summaryrefslogtreecommitdiff
path: root/dht
diff options
context:
space:
mode:
Diffstat (limited to 'dht')
-rw-r--r--dht/Announcer.hs2
-rw-r--r--dht/ToxManager.hs83
-rw-r--r--dht/src/Data/Tox/Relay.hs5
-rw-r--r--dht/src/Network/Tox/TCP.hs28
4 files changed, 57 insertions, 61 deletions
diff --git a/dht/Announcer.hs b/dht/Announcer.hs
index 98fcdf94..e7c0bcd2 100644
--- a/dht/Announcer.hs
+++ b/dht/Announcer.hs
@@ -63,7 +63,7 @@ decodeAnnounceKey _ k = AnnounceKey k
63-- themselves, they are typically bootstrapped using 'scheduleImmediately' with 63-- themselves, they are typically bootstrapped using 'scheduleImmediately' with
64-- 'NewAnnouncement' which triggers the ordinary recurring scheduling of 64-- 'NewAnnouncement' which triggers the ordinary recurring scheduling of
65-- 'Announce'. 65-- 'Announce'.
66data ScheduledItem = ScheduledItem (Announcer -> AnnounceKey -> POSIXTime -> STM (IO ())) 66newtype ScheduledItem = ScheduledItem (Announcer -> AnnounceKey -> POSIXTime -> STM (IO ()))
67 deriving Generics.Generic 67 deriving Generics.Generic
68 68
69 69
diff --git a/dht/ToxManager.hs b/dht/ToxManager.hs
index 39377733..96bd9bc3 100644
--- a/dht/ToxManager.hs
+++ b/dht/ToxManager.hs
@@ -262,29 +262,10 @@ default_nospam :: Word32
262default_nospam = 0x6a7a27fc -- big-endian base64: anon/A== 262default_nospam = 0x6a7a27fc -- big-endian base64: anon/A==
263 263
264nodeinfoStaleTime :: POSIXTime 264nodeinfoStaleTime :: POSIXTime
265nodeinfoStaleTime = 600 265nodeinfoStaleTime = 600 -- consider DHT node address stale after 10 minutes
266 266
267nodeinfoSearchInterval :: POSIXTime 267nodeinfoSearchInterval :: POSIXTime
268nodeinfoSearchInterval = 15 268nodeinfoSearchInterval = 15 -- when no address, search DHT node every 15 seconds
269
270data Awaiting v = Since POSIXTime
271data Acquired v = At POSIXTime v
272data Moot v = Moot
273
274data NNS a b c = NNS { -- NetcryptoNegotiationState
275 sessionDesired :: Bool,
276 theirPublicKey :: a Tox.DHTPublicKey,
277 theirAddress :: b NodeInfo,
278 theirCookie :: c (Tox.Cookie Encrypted),
279 sessionIsActive :: Bool
280}
281
282data NS
283 = Stage1 (NNS Moot Moot Moot)
284 | Stage2 (NNS Awaiting Moot Moot)
285 | Stage3 (NNS Acquired Awaiting Moot)
286 | Stage4 (NNS Acquired Acquired Awaiting)
287 | Stage5 (NNS Acquired Acquired Acquired)
288 269
289gotDhtPubkey :: Tox.DHTPublicKey -> ToxToXMPP -> PublicKey -> IO () 270gotDhtPubkey :: Tox.DHTPublicKey -> ToxToXMPP -> PublicKey -> IO ()
290gotDhtPubkey theirDhtKey tx theirKey = do 271gotDhtPubkey theirDhtKey tx theirKey = do
@@ -303,6 +284,7 @@ gotDhtPubkey theirDhtKey tx theirKey = do
303 me = key2id myPublicKey 284 me = key2id myPublicKey
304 285
305 doSearch = do 286 doSearch = do
287 -- TODO: attempt to connect via TCP relays.
306 let akey = akeyConnect (txAnnouncer tx) me theirKey 288 let akey = akeyConnect (txAnnouncer tx) me theirKey
307 atomically $ registerNodeCallback (toxRouting tox) (nic akey) 289 atomically $ registerNodeCallback (toxRouting tox) (nic akey)
308 scheduleSearch (txAnnouncer tx) akey meth theirDhtKey 290 scheduleSearch (txAnnouncer tx) akey meth theirDhtKey
@@ -357,21 +339,13 @@ gotAddr' ni@(nodeAddr -> addr) tx theirKey theirDhtKey = atomically blee
357 339
358 blee = do 340 blee = do
359 scheduleImmediately (txAnnouncer tx) akey $ 341 scheduleImmediately (txAnnouncer tx) akey $
360 ScheduledItem $ getCookie ni (activeSesh addr) (getContact theirKey (txAccount tx)) 342 ScheduledItem $ getCookie tx theirKey theirDhtKey ni (activeSesh addr) (getContact theirKey (txAccount tx))
361 343
362 tox :: Tox JabberClients 344 tox :: Tox JabberClients
363 tox = txTox tx 345 tox = txTox tx
364 346
365 crypto = toxCryptoKeys tox 347 crypto = toxCryptoKeys tox
366 348
367 {-
368 byAddr :: TVar (Map.Map SockAddr Tox.NetCryptoSession)
369 byAddr = Tox.netCryptoSessions (toxCryptoSessions tox)
370
371 readNcVar :: (Tox.NetCryptoSession -> TVar b) -> SockAddr -> STM (Maybe b)
372 readNcVar v addr = traverse readTVar =<< fmap v . Map.lookup addr <$> readTVar byAddr
373 -}
374
375 activeSesh :: SockAddr -> STM Bool 349 activeSesh :: SockAddr -> STM Bool
376 activeSesh a = do 350 activeSesh a = do
377 ss <- readTVar (txSessions tx) 351 ss <- readTVar (txSessions tx)
@@ -390,27 +364,26 @@ gotAddr' ni@(nodeAddr -> addr) tx theirKey theirDhtKey = atomically blee
390 Just False -> return False 364 Just False -> return False
391 _ -> (== Established) <$> aggregateStatus c 365 _ -> (== Established) <$> aggregateStatus c
392 366
393 {-
394 readCookie :: SockAddr -> STM (Maybe (UponCookie (Tox.Cookie Encrypted)))
395 readCookie = readNcVar Tox.ncCookie
396 readCookie' :: SockAddr -> STM (Maybe (Tox.Cookie Encrypted))
397 readCookie' = fmap join . (fmap.fmap) Tox.toMaybe . readCookie
398 -}
399
400 client :: Network.Tox.DHT.Handlers.Client 367 client :: Network.Tox.DHT.Handlers.Client
401 client = toxDHT tox 368 client = toxDHT tox
402 369
403 getCookie 370getCookie
404 :: NodeInfo 371 :: ToxToXMPP
372 -> PublicKey
373 -> Tox.DHTPublicKey
374 -> NodeInfo
405 -> STM Bool 375 -> STM Bool
406 -> STM (Maybe Contact) 376 -> STM (Maybe Contact)
407 -> Announcer 377 -> Announcer
408 -> AnnounceKey 378 -> AnnounceKey
409 -> POSIXTime 379 -> POSIXTime
410 -> STM (IO ()) 380 -> STM (IO ())
411 getCookie ni isActive getC ann akey now = getCookieAgain 381getCookie tx theirKey theirDhtKey ni isActive getC ann akey now = getCookieAgain
412 where 382 where
413 getCookieAgain = do 383 myPublicKey = toPublic $ userSecret (txAccount tx)
384 addr = nodeAddr ni
385 hscache = toxHandshakeCache $ txTox tx
386 getCookieAgain = do
414 tput XNodeinfoSearch $ show ("getCookieAgain", unpackAnnounceKey ann akey) 387 tput XNodeinfoSearch $ show ("getCookieAgain", unpackAnnounceKey ann akey)
415 mbContact <- getC 388 mbContact <- getC
416 case mbContact of 389 case mbContact of
@@ -419,23 +392,23 @@ gotAddr' ni@(nodeAddr -> addr) tx theirKey theirDhtKey = atomically blee
419 active <- isActive 392 active <- isActive
420 return $ when (not active) getCookieIO 393 return $ when (not active) getCookieIO
421 394
422 callRealShakeHands cookie = do 395 callRealShakeHands cookie = do
423 forM_ (nodeInfo (key2id $ dhtpk theirDhtKey) (nodeAddr ni)) $ \ni' -> do 396 forM_ (nodeInfo (key2id $ dhtpk theirDhtKey) (nodeAddr ni)) $ \ni' -> do
424 hs <- cacheHandshake (toxHandshakeCache tox) (userSecret (txAccount tx)) theirKey ni' cookie 397 hs <- cacheHandshake hscache (userSecret (txAccount tx)) theirKey ni' cookie
425 dput XNetCrypto $ show addr ++ "<-- handshake " ++ show (key2id theirKey) 398 dput XNetCrypto $ show addr ++ "<-- handshake " ++ show (key2id theirKey)
426 sendMessage (toxHandshakes tox) (nodeAddr ni) hs 399 sendMessage (toxHandshakes $ txTox tx) (nodeAddr ni) hs
427 400
428 reschedule n f = scheduleRel ann akey f n 401 reschedule n f = scheduleRel ann akey f n
429 reschedule' n f = reschedule n (ScheduledItem $ \_ _ now -> f now) 402 reschedule' n f = reschedule n (ScheduledItem $ \_ _ now -> f now)
430 403
431 cookieMaxAge = 60 * 5 404 cookieMaxAge = 60 * 5
432 405
433 getCookieIO :: IO () 406 getCookieIO :: IO ()
434 getCookieIO = do 407 getCookieIO = do
435 dput XNetCrypto $ show addr ++ " <-- request cookie" 408 dput XNetCrypto $ show addr ++ " <-- request cookie"
436 let pending flag = setPendingCookie (toxHandshakeCache tox) myPublicKey theirKey flag 409 let pending flag = setPendingCookie hscache myPublicKey theirKey flag
437 atomically $ pending True 410 atomically $ pending True
438 cookieRequest crypto client myPublicKey ni >>= \case 411 cookieRequest (toxCryptoKeys $ txTox tx) (toxDHT $ txTox tx) myPublicKey ni >>= \case
439 Nothing -> atomically $ do 412 Nothing -> atomically $ do
440 pending False 413 pending False
441 reschedule' 5 (const getCookieAgain) 414 reschedule' 5 (const getCookieAgain)
@@ -485,10 +458,10 @@ realShakeHands myseckey theirpubkey theirDhtKey allsessions saddr cookie = do
485 458
486 459
487dispatch :: ToxToXMPP -> ContactEvent -> IO () 460dispatch :: ToxToXMPP -> ContactEvent -> IO ()
488dispatch tx (SessionEstablished theirKey) = do stopConnecting tx theirKey "established" 461dispatch tx (SessionEstablished theirKey ) = do stopConnecting tx theirKey "established"
489 updateRoster tx theirKey 462 updateRoster tx theirKey
490dispatch tx (SessionTerminated theirKey) = startConnecting tx theirKey "terminated" 463dispatch tx (SessionTerminated theirKey ) = startConnecting tx theirKey "terminated"
491dispatch tx (AddrChange theirKey saddr) = gotAddr saddr tx theirKey 464dispatch tx (AddrChange theirKey saddr ) = gotAddr saddr tx theirKey
492dispatch tx (PolicyChange theirkey TryingToConnect ) = startConnecting tx theirkey "policy" 465dispatch tx (PolicyChange theirkey TryingToConnect ) = startConnecting tx theirkey "policy"
493dispatch tx (PolicyChange theirkey policy ) = stopConnecting tx theirkey "policy" 466dispatch tx (PolicyChange theirkey policy ) = stopConnecting tx theirkey "policy"
494dispatch tx (OnionRouted theirKey (OnionDHTPublicKey pkey)) = gotDhtPubkey pkey tx theirKey 467dispatch tx (OnionRouted theirKey (OnionDHTPublicKey pkey)) = gotDhtPubkey pkey tx theirKey
diff --git a/dht/src/Data/Tox/Relay.hs b/dht/src/Data/Tox/Relay.hs
index 64c90806..1bce76db 100644
--- a/dht/src/Data/Tox/Relay.hs
+++ b/dht/src/Data/Tox/Relay.hs
@@ -72,8 +72,9 @@ data RelayPacket
72newtype PacketNumber = PacketNumber { packetNumberToWord8 :: Word8 } 72newtype PacketNumber = PacketNumber { packetNumberToWord8 :: Word8 }
73 deriving (Eq,Ord,Show) 73 deriving (Eq,Ord,Show)
74 74
75pattern PingPacket = PacketNumber 4 75pattern RoutingRequestPacket = PacketNumber 0
76pattern OnionPacketID = PacketNumber 8 76pattern PingPacket = PacketNumber 4
77pattern OnionPacketID = PacketNumber 8
77 78
78packetNumber :: RelayPacket -> PacketNumber 79packetNumber :: RelayPacket -> PacketNumber
79packetNumber (RelayData _ (ConId conid)) = PacketNumber $ conid -- 0 to 15 not allowed. 80packetNumber (RelayData _ (ConId conid)) = PacketNumber $ conid -- 0 to 15 not allowed.
diff --git a/dht/src/Network/Tox/TCP.hs b/dht/src/Network/Tox/TCP.hs
index 1531dfb4..4b3a4594 100644
--- a/dht/src/Network/Tox/TCP.hs
+++ b/dht/src/Network/Tox/TCP.hs
@@ -16,6 +16,7 @@ import Control.Monad
16import Crypto.Random 16import Crypto.Random
17import Data.Aeson (ToJSON(..),FromJSON(..)) 17import Data.Aeson (ToJSON(..),FromJSON(..))
18import qualified Data.Aeson as JSON 18import qualified Data.Aeson as JSON
19import Data.ByteArray (withByteArray)
19import Data.Functor.Contravariant 20import Data.Functor.Contravariant
20import Data.Functor.Identity 21import Data.Functor.Identity
21import Data.Hashable 22import Data.Hashable
@@ -26,9 +27,11 @@ import Data.Monoid
26import Data.Serialize 27import Data.Serialize
27import Data.Word 28import Data.Word
28import qualified Data.Vector as Vector 29import qualified Data.Vector as Vector
30import Foreign.Storable (peek)
29import Network.Socket (SockAddr(..)) 31import Network.Socket (SockAddr(..))
30import qualified Text.ParserCombinators.ReadP as RP 32import qualified Text.ParserCombinators.ReadP as RP
31import System.IO.Error 33import System.IO.Error
34import System.IO.Unsafe (unsafeDupablePerformIO)
32import System.Timeout 35import System.Timeout
33 36
34import ControlMaybe 37import ControlMaybe
@@ -270,8 +273,25 @@ tcpPing client dst = do
270 , method = PingPacket 273 , method = PingPacket
271 } 274 }
272 275
276tcpConnectionRequest :: Client err PacketNumber tid addr (Bool, RelayPacket)
277 -> PublicKey -> addr -> IO (Maybe ConId)
278tcpConnectionRequest client pubkey ni = do
279 sendQuery client meth pubkey ni
280 where
281 meth = MethodSerializer
282 { wrapQuery = \n8 src dst pubkey -> (True,RoutingRequest pubkey)
283 , unwrapResponse = \(_,RoutingResponse cid pubkey) -> cid
284 , methodTimeout = \dst -> return (dst,5000000)
285 , method = RoutingRequestPacket
286 }
287
273type RelayClient = Client String PacketNumber Nonce8 NodeInfo (Bool,RelayPacket) 288type RelayClient = Client String PacketNumber Nonce8 NodeInfo (Bool,RelayPacket)
274 289
290keyToNonce :: PublicKey -> Nonce8
291keyToNonce k = unsafeDupablePerformIO $ withByteArray k $ \ptr -> do
292 w8 <- peek ptr
293 return $ Nonce8 w8
294
275-- | Create a new TCP relay client. Because polymorphic existential record 295-- | Create a new TCP relay client. Because polymorphic existential record
276-- updates are currently hard with GHC, this function accepts parameters for 296-- updates are currently hard with GHC, this function accepts parameters for
277-- generalizing the table-entry type for pending transactions. Safe trivial 297-- generalizing the table-entry type for pending transactions. Safe trivial
@@ -291,11 +311,13 @@ newClient crypto store load = do
291 { clientNet = {- XXX: Client type forces this pointless layering. -} layerTransport ((Right .) . (,) . (,) False) (,) net 311 { clientNet = {- XXX: Client type forces this pointless layering. -} layerTransport ((Right .) . (,) . (,) False) (,) net
292 , clientDispatcher = DispatchMethods 312 , clientDispatcher = DispatchMethods
293 { classifyInbound = (. snd) $ \case 313 { classifyInbound = (. snd) $ \case
294 RelayPing n -> IsQuery PingPacket n 314 RelayPing n -> IsQuery PingPacket n
295 RelayPong n -> IsResponse n 315 RelayPong n -> IsResponse n
316 RoutingRequest k -> IsQuery RoutingRequestPacket (keyToNonce k)
317 RoutingResponse conId k -> IsResponse (keyToNonce k)
296 OnionPacketResponse (OnionAnnounceResponse n8 n24 ciphered) -> IsResponse n8 318 OnionPacketResponse (OnionAnnounceResponse n8 n24 ciphered) -> IsResponse n8
297 OnionPacketResponse o@(OnionToRouteResponse _) -> IsUnsolicited $ handle2route o 319 OnionPacketResponse o@(OnionToRouteResponse _) -> IsUnsolicited $ handle2route o
298 OOBRecv k bs -> IsUnsolicited $ handleOOB k bs 320 OOBRecv k bs -> IsUnsolicited $ handleOOB k bs
299 wut -> IsUnknown (show wut) 321 wut -> IsUnknown (show wut)
300 , lookupHandler = \case 322 , lookupHandler = \case
301 PingPacket -> trace ("tcp-received-ping") $ Just MethodHandler 323 PingPacket -> trace ("tcp-received-ping") $ Just MethodHandler