summaryrefslogtreecommitdiff
path: root/dht/src
diff options
context:
space:
mode:
Diffstat (limited to 'dht/src')
-rw-r--r--dht/src/Data/Tox/DHT/Multi.hs126
-rw-r--r--dht/src/Data/Tox/Msg.hs26
-rw-r--r--dht/src/Data/Tox/Relay.hs3
-rw-r--r--dht/src/Network/QueryResponse.hs6
-rw-r--r--dht/src/Network/SessionTransports.hs19
-rw-r--r--dht/src/Network/Tox.hs47
-rw-r--r--dht/src/Network/Tox/DHT/Handlers.hs189
-rw-r--r--dht/src/Network/Tox/DHT/Transport.hs10
-rw-r--r--dht/src/Network/Tox/Handshake.hs2
-rw-r--r--dht/src/Network/Tox/Onion/Handlers.hs11
-rw-r--r--dht/src/Network/Tox/Onion/Routes.hs7
-rw-r--r--dht/src/Network/Tox/Onion/Transport.hs11
-rw-r--r--dht/src/Network/Tox/Session.hs11
-rw-r--r--dht/src/Network/Tox/TCP.hs80
-rw-r--r--dht/src/Network/Tox/Transport.hs46
15 files changed, 434 insertions, 160 deletions
diff --git a/dht/src/Data/Tox/DHT/Multi.hs b/dht/src/Data/Tox/DHT/Multi.hs
new file mode 100644
index 00000000..3f91387c
--- /dev/null
+++ b/dht/src/Data/Tox/DHT/Multi.hs
@@ -0,0 +1,126 @@
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE FlexibleInstances #-}
3{-# LANGUAGE GADTs #-}
4{-# LANGUAGE MultiParamTypeClasses #-}
5{-# LANGUAGE StandaloneDeriving #-}
6{-# LANGUAGE TemplateHaskell #-}
7{-# LANGUAGE TypeFamilies #-}
8module Data.Tox.DHT.Multi where
9
10import qualified Network.Tox.NodeId as UDP
11 ;import Network.Tox.NodeId (NodeId)
12import qualified Network.Tox.TCP.NodeId as TCP
13import Data.Tox.Relay
14import Network.Address (either4or6)
15import Network.Tox.TCP as TCP (ViaRelay(..))
16import Network.QueryResponse (Tagged(..))
17
18import Data.Dependent.Sum
19import Data.GADT.Compare
20import Data.GADT.Show
21import Data.Functor.Identity
22import Data.Typeable
23import Network.Socket
24
25#if MIN_VERSION_dependent_sum(0,6,0)
26import Data.Constraint.Compose
27import Data.Constraint.Extras
28import Data.Constraint.Extras.TH
29#endif
30
31
32data T ni where
33 UDP :: T UDP.NodeInfo
34 TCP :: T TCP.ViaRelay
35
36instance GEq T where
37 geq UDP UDP = Just Refl
38 geq TCP TCP = Just Refl
39 geq _ _ = Nothing
40instance GCompare T where
41 gcompare UDP UDP = GEQ
42 gcompare UDP TCP = GLT
43 gcompare TCP TCP = GEQ
44 gcompare TCP UDP = GGT
45instance GShow T where
46 gshowsPrec _ UDP = showString "UDP"
47 gshowsPrec _ TCP = showString "TCP"
48
49data S addr where
50 SessionUDP :: S SockAddr
51 SessionTCP :: S TCP.ViaRelay
52
53instance GEq S where
54 geq SessionUDP SessionUDP = Just Refl
55 geq SessionTCP SessionTCP = Just Refl
56 geq _ _ = Nothing
57instance GCompare S where
58 gcompare SessionUDP SessionUDP = GEQ
59 gcompare SessionUDP SessionTCP = GLT
60 gcompare SessionTCP SessionTCP = GEQ
61 gcompare SessionTCP SessionUDP = GGT
62instance GShow S where
63 gshowsPrec _ SessionUDP = showString "UDP"
64 gshowsPrec _ SessionTCP = showString "TCP"
65
66-- Canonical in case of 6-mapped-4 addresses.
67canonize :: DSum S Identity -> DSum S Identity
68canonize (SessionUDP :=> Identity saddr) = SessionUDP ==> either id id (either4or6 saddr)
69canonize taddr = taddr
70
71data A addr where
72 AddrUDP :: SockAddr -> A UDP.NodeInfo
73 AddrTCP :: Maybe ConId -> TCP.NodeInfo -> A TCP.ViaRelay
74
75deriving instance Eq (A addr)
76
77type NodeInfo = DSum T Identity
78type SessionAddress = DSum S Identity
79
80type Address = DSum T A
81
82#if MIN_VERSION_dependent_sum(0,6,0)
83deriveArgDict ''T
84deriveArgDict ''S
85#else
86instance ShowTag T Identity where
87 showTaggedPrec UDP = showsPrec
88 showTaggedPrec TCP = showsPrec
89instance ShowTag S Identity where
90 showTaggedPrec SessionUDP = showsPrec
91 showTaggedPrec SessionTCP = showsPrec
92instance EqTag S Identity where
93 eqTagged SessionUDP SessionUDP = (==)
94 eqTagged SessionTCP SessionTCP = (==)
95instance OrdTag S Identity where
96 compareTagged SessionUDP SessionUDP = compare
97 compareTagged SessionTCP SessionTCP = compare
98#endif
99
100
101{-
102nodeInfo :: NodeId -> DSum T A -> Either String (DSum T Identity )
103nodeInfo nid (UDP :=> AddrUDP saddr ) = fmap (UDP ==>) $ UDP.nodeInfo nid saddr
104nodeInfo nid (TCP :=> AddrTCP conid relay) = Right $ TCP ==> ViaRelay conid nid relay
105
106nodeAddr :: DSum T Identity -> DSum T A
107nodeAddr (UDP :=> Identity ni ) = UDP :=> AddrUDP (UDP.nodeAddr ni)
108nodeAddr (TCP :=> Identity (ViaRelay conid _ relay)) = TCP :=> AddrTCP conid relay
109-}
110
111nodeInfo :: NodeId -> DSum S Identity -> Either String (DSum T Identity)
112nodeInfo nid (SessionUDP :=> Identity saddr) = fmap (UDP ==>) $ UDP.nodeInfo nid saddr
113nodeInfo nid (SessionTCP :=> Identity taddr@(ViaRelay _ nid2 _)) =
114 if nid2 == nid then Right $ TCP ==> taddr
115 else Left $ "Cached dht-key doesn't match."
116
117nodeId :: DSum T Identity -> NodeId
118nodeId (UDP :=> Identity ni ) = UDP.nodeId ni
119nodeId (TCP :=> Identity (ViaRelay _ nid _)) = nid
120
121relayNodeId :: TCP.ViaRelay -> UDP.NodeId
122relayNodeId (ViaRelay _ nid _) = nid
123
124udpNode :: DSum T Identity -> Maybe UDP.NodeInfo
125udpNode (UDP :=> Identity ni) = Just ni
126udpNode _ = Nothing
diff --git a/dht/src/Data/Tox/Msg.hs b/dht/src/Data/Tox/Msg.hs
index 8819faa7..4398586f 100644
--- a/dht/src/Data/Tox/Msg.hs
+++ b/dht/src/Data/Tox/Msg.hs
@@ -1,3 +1,4 @@
1{-# LANGUAGE CPP #-}
1{-# LANGUAGE DataKinds #-} 2{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE DefaultSignatures #-} 3{-# LANGUAGE DefaultSignatures #-}
3{-# LANGUAGE FlexibleInstances #-} 4{-# LANGUAGE FlexibleInstances #-}
@@ -7,6 +8,7 @@
7{-# LANGUAGE MultiParamTypeClasses #-} 8{-# LANGUAGE MultiParamTypeClasses #-}
8{-# LANGUAGE PolyKinds #-} 9{-# LANGUAGE PolyKinds #-}
9{-# LANGUAGE StandaloneDeriving #-} 10{-# LANGUAGE StandaloneDeriving #-}
11{-# LANGUAGE TemplateHaskell #-}
10{-# LANGUAGE TypeFamilies #-} 12{-# LANGUAGE TypeFamilies #-}
11module Data.Tox.Msg where 13module Data.Tox.Msg where
12 14
@@ -14,6 +16,7 @@ import Crypto.Error
14import qualified Crypto.PubKey.Ed25519 as Ed25519 16import qualified Crypto.PubKey.Ed25519 as Ed25519
15import Data.ByteArray as BA 17import Data.ByteArray as BA
16import Data.ByteString as B 18import Data.ByteString as B
19import Data.Constraint
17import Data.Dependent.Sum 20import Data.Dependent.Sum
18import Data.Functor.Contravariant 21import Data.Functor.Contravariant
19import Data.Functor.Identity 22import Data.Functor.Identity
@@ -31,6 +34,12 @@ import Crypto.Tox
31import Data.PacketBuffer (compressSequenceNumbers, decompressSequenceNumbers) 34import Data.PacketBuffer (compressSequenceNumbers, decompressSequenceNumbers)
32import Network.Tox.NodeId 35import Network.Tox.NodeId
33 36
37#if MIN_VERSION_dependent_sum(0,6,0)
38import Data.Constraint.Compose
39import Data.Constraint.Extras
40import Data.Constraint.Extras.TH
41#endif
42
34newtype Unknown = Unknown B.ByteString deriving (Eq,Show) 43newtype Unknown = Unknown B.ByteString deriving (Eq,Show)
35newtype Padded = Padded B.ByteString deriving (Eq,Show) 44newtype Padded = Padded B.ByteString deriving (Eq,Show)
36 45
@@ -102,11 +111,7 @@ msgID (Pkt mid :=> Identity _) = M mid
102 111
103-- TODO 112-- TODO
104instance GShow Pkt where gshowsPrec = showsPrec 113instance GShow Pkt where gshowsPrec = showsPrec
105instance ShowTag Pkt Identity where
106 showTaggedPrec (Pkt _) = showsPrec
107
108instance GEq Pkt where geq (Pkt _) (Pkt _) = eqT 114instance GEq Pkt where geq (Pkt _) (Pkt _) = eqT
109instance EqTag Pkt Identity where eqTagged (Pkt _) (Pkt _) = (==)
110 115
111someMsgVal :: KnownMsg n => Msg n a -> SomeMsg 116someMsgVal :: KnownMsg n => Msg n a -> SomeMsg
112someMsgVal m = msgid (proxy m) 117someMsgVal m = msgid (proxy m)
@@ -311,3 +316,16 @@ instance Serialize Invite where
311 ConfirmedInvite ns -> return () -- TODO: encode nodes. 316 ConfirmedInvite ns -> return () -- TODO: encode nodes.
312 317
313instance Packet Invite where 318instance Packet Invite where
319
320#if MIN_VERSION_dependent_sum(0,6,0)
321-- deriveArgDict ''Pkt
322instance ArgDict (ComposeC Show Identity) Pkt where
323 type ConstraintsFor Pkt (ComposeC Show Identity) = ()
324 argDict (Pkt _) = Dict
325instance ArgDict (ComposeC Eq Identity) Pkt where
326 type ConstraintsFor Pkt (ComposeC Eq Identity) = ()
327 argDict (Pkt _) = Dict
328#else
329instance EqTag Pkt Identity where eqTagged (Pkt _) (Pkt _) = (==)
330instance ShowTag Pkt Identity where showTaggedPrec (Pkt _) = showsPrec
331#endif
diff --git a/dht/src/Data/Tox/Relay.hs b/dht/src/Data/Tox/Relay.hs
index 1bce76db..31752433 100644
--- a/dht/src/Data/Tox/Relay.hs
+++ b/dht/src/Data/Tox/Relay.hs
@@ -8,7 +8,7 @@
8{-# LANGUAGE StandaloneDeriving #-} 8{-# LANGUAGE StandaloneDeriving #-}
9{-# LANGUAGE UndecidableInstances #-} 9{-# LANGUAGE UndecidableInstances #-}
10module Data.Tox.Relay 10module Data.Tox.Relay
11 ( module Network.Tox.TCP.NodeId 11 ( module TCP
12 , module Data.Tox.Relay 12 , module Data.Tox.Relay
13 ) where 13 ) where
14 14
@@ -30,7 +30,6 @@ import qualified Rank2
30import qualified Text.ParserCombinators.ReadP as RP 30import qualified Text.ParserCombinators.ReadP as RP
31 31
32import Crypto.Tox 32import Crypto.Tox
33import Network.Tox.TCP.NodeId
34import Data.Tox.Onion 33import Data.Tox.Onion
35import qualified Network.Tox.NodeId as UDP 34import qualified Network.Tox.NodeId as UDP
36import Network.Tox.TCP.NodeId as TCP 35import Network.Tox.TCP.NodeId as TCP
diff --git a/dht/src/Network/QueryResponse.hs b/dht/src/Network/QueryResponse.hs
index d8dc8bfa..8e32899f 100644
--- a/dht/src/Network/QueryResponse.hs
+++ b/dht/src/Network/QueryResponse.hs
@@ -122,9 +122,9 @@ layerTransport parse encode tr =
122-- is used to share the same underlying socket, so be sure to fork a thread for 122-- is used to share the same underlying socket, so be sure to fork a thread for
123-- both returned 'Transport's to avoid hanging. 123-- both returned 'Transport's to avoid hanging.
124partitionTransportM :: ((b,a) -> IO (Either (x,xaddr) (b,a))) 124partitionTransportM :: ((b,a) -> IO (Either (x,xaddr) (b,a)))
125 -> ((x,xaddr) -> IO (Maybe (b,a))) 125 -> ((x,xaddr) -> IO (Maybe (c,a)))
126 -> Transport err a b 126 -> TransportA err a b c
127 -> IO (Transport err xaddr x, Transport err a b) 127 -> IO (Transport err xaddr x, TransportA err a b c)
128partitionTransportM parse encodex tr = do 128partitionTransportM parse encodex tr = do
129 tchan <- atomically newTChan 129 tchan <- atomically newTChan
130 let ytr = tr { awaitMessage = \kont -> fix $ \again -> do 130 let ytr = tr { awaitMessage = \kont -> fix $ \again -> do
diff --git a/dht/src/Network/SessionTransports.hs b/dht/src/Network/SessionTransports.hs
index b36fbcfd..b6d02f36 100644
--- a/dht/src/Network/SessionTransports.hs
+++ b/dht/src/Network/SessionTransports.hs
@@ -16,19 +16,20 @@ import qualified Data.IntMap.Strict as IntMap
16import qualified Data.Map.Strict as Map 16import qualified Data.Map.Strict as Map
17 ;import Data.Map.Strict (Map) 17 ;import Data.Map.Strict (Map)
18 18
19import qualified Data.Tox.DHT.Multi as Multi
19import Network.Address (SockAddr,either4or6) 20import Network.Address (SockAddr,either4or6)
20import Network.QueryResponse 21import Network.QueryResponse
21import qualified Data.IntervalSet as S 22import qualified Data.IntervalSet as S
22 ;import Data.IntervalSet (IntSet) 23 ;import Data.IntervalSet (IntSet)
23 24
24data Sessions x = Sessions 25data Sessions x = Sessions
25 { sessionsByAddr :: TVar (Map SockAddr (IntMap (x -> IO Bool))) 26 { sessionsByAddr :: TVar (Map Multi.SessionAddress (IntMap (x -> IO Bool)))
26 , sessionsById :: TVar (IntMap SockAddr) 27 , sessionsById :: TVar (IntMap Multi.SessionAddress)
27 , sessionIds :: TVar IntSet 28 , sessionIds :: TVar IntSet
28 , sessionsSendRaw :: SockAddr -> x -> IO () 29 , sessionsSendRaw :: Multi.SessionAddress -> x -> IO ()
29 } 30 }
30 31
31initSessions :: (SockAddr -> x -> IO ()) -> IO (Sessions x) 32initSessions :: (Multi.SessionAddress -> x -> IO ()) -> IO (Sessions x)
32initSessions send = atomically $ do 33initSessions send = atomically $ do
33 byaddr <- newTVar Map.empty 34 byaddr <- newTVar Map.empty
34 byid <- newTVar IntMap.empty 35 byid <- newTVar IntMap.empty
@@ -49,13 +50,13 @@ rmSession sid (Just m) = case IntMap.delete sid m of
49 50
50newSession :: Sessions raw 51newSession :: Sessions raw
51 -> (addr -> y -> IO raw) 52 -> (addr -> y -> IO raw)
52 -> (SockAddr -> raw -> IO (Maybe (x, addr))) 53 -> (Multi.SessionAddress -> raw -> IO (Maybe (x, addr)))
53 -> SockAddr 54 -> Multi.SessionAddress
54 -> IO (Maybe (Int,TransportA err addr x y)) 55 -> IO (Maybe (Int,TransportA err addr x y))
55newSession Sessions{sessionsByAddr,sessionsById,sessionIds,sessionsSendRaw} unwrap wrap addr0 = do 56newSession Sessions{sessionsByAddr,sessionsById,sessionIds,sessionsSendRaw} unwrap wrap addr0 = do
56 mvar <- atomically newEmptyTMVar 57 mvar <- atomically newEmptyTMVar
57 let saddr = -- Canonical in case of 6-mapped-4 addresses. 58 let saddr = -- Canonical in case of 6-mapped-4 addresses.
58 either id id $ either4or6 addr0 59 Multi.canonize addr0
59 handlePacket x = do 60 handlePacket x = do
60 m <- wrap saddr x 61 m <- wrap saddr x
61 case m of 62 case m of
@@ -91,10 +92,10 @@ newSession Sessions{sessionsByAddr,sessionsById,sessionIds,sessionsSendRaw} unwr
91 } 92 }
92 return (sid,tr) 93 return (sid,tr)
93 94
94sessionHandler :: Sessions x -> (SockAddr -> x -> IO (Maybe (x -> x))) 95sessionHandler :: Sessions x -> (Multi.SessionAddress -> x -> IO (Maybe (x -> x)))
95sessionHandler Sessions{sessionsByAddr} = \addr0 x -> do 96sessionHandler Sessions{sessionsByAddr} = \addr0 x -> do
96 let addr = -- Canonical in case of 6-mapped-4 addresses. 97 let addr = -- Canonical in case of 6-mapped-4 addresses.
97 either id id $ either4or6 addr0 98 Multi.canonize addr0
98 dispatch [] = return () 99 dispatch [] = return ()
99 dispatch (f:fs) = do b <- f x 100 dispatch (f:fs) = do b <- f x
100 when (not b) $ dispatch fs 101 when (not b) $ dispatch fs
diff --git a/dht/src/Network/Tox.hs b/dht/src/Network/Tox.hs
index 5d27f34f..4898513a 100644
--- a/dht/src/Network/Tox.hs
+++ b/dht/src/Network/Tox.hs
@@ -34,6 +34,7 @@ import qualified Data.ByteString as B
34 ;import Data.ByteString (ByteString) 34 ;import Data.ByteString (ByteString)
35import qualified Data.ByteString.Char8 as C8 35import qualified Data.ByteString.Char8 as C8
36import Data.Data 36import Data.Data
37import Data.Dependent.Sum
37import Data.Functor.Identity 38import Data.Functor.Identity
38import Data.Functor.Contravariant 39import Data.Functor.Contravariant
39import Data.Maybe 40import Data.Maybe
@@ -45,27 +46,28 @@ import Network.Socket
45import System.Endian 46import System.Endian
46import System.IO.Error 47import System.IO.Error
47 48
49import Crypto.Tox
48import Data.TableMethods 50import Data.TableMethods
51import qualified Data.Tox.DHT.Multi as Multi
49import Data.Tox.Onion (substituteLoopback) 52import Data.Tox.Onion (substituteLoopback)
50import Network.Tox.RelayPinger
51import qualified Data.Word64Map 53import qualified Data.Word64Map
52import Network.BitTorrent.DHT.Token as Token
53import qualified Data.Wrapper.PSQ as PSQ
54import System.Global6
55import Network.Address (WantIP (..),IP,getBindAddress)
56import qualified Network.Kademlia.Routing as R
57import Network.QueryResponse
58import Network.StreamServer (ServerHandle,quitListening)
59import Crypto.Tox
60import Data.Word64Map (fitsInInt)
61import qualified Data.Word64Map (empty) 54import qualified Data.Word64Map (empty)
62import Network.Kademlia.Bootstrap (forkPollForRefresh, bootstrap) 55 ;import Data.Word64Map (fitsInInt)
63import Network.Tox.Crypto.Transport (Handshake(..),CryptoPacket) 56import qualified Data.Wrapper.PSQ as PSQ
57import Network.Address (IP, WantIP (..), getBindAddress)
58import Network.BitTorrent.DHT.Token as Token
59import Network.Kademlia.Bootstrap (bootstrap, forkPollForRefresh)
60import qualified Network.Kademlia.Routing as R
61import Network.QueryResponse
62import Network.StreamServer (ServerHandle, quitListening)
63import Network.Tox.Crypto.Transport (CryptoPacket, Handshake (..))
64import qualified Network.Tox.DHT.Handlers as DHT 64import qualified Network.Tox.DHT.Handlers as DHT
65import qualified Network.Tox.DHT.Transport as DHT 65import qualified Network.Tox.DHT.Transport as DHT
66import Network.Tox.NodeId 66import Network.Tox.NodeId
67import qualified Network.Tox.Onion.Handlers as Onion 67import qualified Network.Tox.Onion.Handlers as Onion
68import qualified Network.Tox.Onion.Transport as Onion 68import qualified Network.Tox.Onion.Transport as Onion
69import Network.Tox.RelayPinger
70import System.Global6
69import Network.Tox.Transport 71import Network.Tox.Transport
70import Network.Tox.TCP (tcpClient) 72import Network.Tox.TCP (tcpClient)
71import Network.Tox.Onion.Routes 73import Network.Tox.Onion.Routes
@@ -117,14 +119,14 @@ nonceKey (DHT.TransactionId n _) = n
117-- | Return my own address. 119-- | Return my own address.
118myAddr :: TVar (R.BucketList NodeInfo) -- ^ IPv4 buckets 120myAddr :: TVar (R.BucketList NodeInfo) -- ^ IPv4 buckets
119 -> TVar (R.BucketList NodeInfo) -- ^ IPv6 buckets 121 -> TVar (R.BucketList NodeInfo) -- ^ IPv6 buckets
120 -> Maybe NodeInfo -- ^ Interested remote address 122 -> Maybe Multi.NodeInfo -- ^ Interested remote address
121 -> IO NodeInfo 123 -> IO Multi.NodeInfo
122myAddr routing4 routing6 maddr = atomically $ do 124myAddr routing4 routing6 maddr = atomically $ do
123 let var = case flip DHT.prefer4or6 Nothing <$> maddr of 125 let var = case flip DHT.prefer4or6 Nothing <$> maddr of
124 Just Want_IP6 -> routing4 126 Just Want_IP6 -> routing4
125 _ -> routing6 127 _ -> routing6
126 a <- readTVar var 128 a <- readTVar var
127 return $ R.thisNode a 129 return $ Multi.UDP ==> R.thisNode a
128 130
129newClient :: (DRG g, Show addr, Show meth) => 131newClient :: (DRG g, Show addr, Show meth) =>
130 g -> Transport String addr x 132 g -> Transport String addr x
@@ -177,8 +179,8 @@ data Tox extra = Tox
177 { toxDHT :: DHT.Client 179 { toxDHT :: DHT.Client
178 , toxOnion :: Onion.Client RouteId 180 , toxOnion :: Onion.Client RouteId
179 , toxToRoute :: Transport String Onion.AnnouncedRendezvous (PublicKey,Onion.OnionData) 181 , toxToRoute :: Transport String Onion.AnnouncedRendezvous (PublicKey,Onion.OnionData)
180 , toxCrypto :: Transport String SockAddr (CryptoPacket Encrypted) 182 , toxCrypto :: Transport String Multi.SessionAddress (CryptoPacket Encrypted)
181 , toxHandshakes :: Transport String SockAddr (Handshake Encrypted) 183 , toxHandshakes :: Transport String Multi.SessionAddress (Handshake Encrypted)
182 , toxHandshakeCache :: HandshakeCache 184 , toxHandshakeCache :: HandshakeCache
183 , toxCryptoKeys :: TransportCrypto 185 , toxCryptoKeys :: TransportCrypto
184 , toxRouting :: DHT.Routing 186 , toxRouting :: DHT.Routing
@@ -344,17 +346,18 @@ newToxOverTransport keydb addr onNewSession (crypto,roster) udp tcp = do
344 let lookupClose _ = return Nothing 346 let lookupClose _ = return Nothing
345 347
346 mkrouting <- DHT.newRouting addr crypto updateIP updateIP 348 mkrouting <- DHT.newRouting addr crypto updateIP updateIP
347 (orouter,otbl) <- newOnionRouter crypto (dput XRoutes) (maybe False (const True) tcp) 349 (orouter,relaynet,otbl) <- newOnionRouter crypto (dput XRoutes) (maybe False (const True) tcp)
348 (cryptonet,dhtcrypt,onioncrypt,dtacrypt,handshakes) 350 (cryptonet,dhtcrypt,onioncrypt,dtacrypt,handshakes)
349 <- toxTransport crypto orouter lookupClose addr udp 351 <- toxTransport crypto orouter lookupClose addr udp relaynet
350 (\dst x -> sendMessage (clientNet $ tcpClient $ tcpKademliaClient orouter) dst (True,x)) 352 (\dst x -> sendMessage (clientNet $ tcpClient $ tcpKademliaClient orouter) dst (True,x))
351 (fromMaybe (\_ _ -> return ()) tcp) 353 (fromMaybe (\_ _ -> return ()) tcp)
352 sessions <- initSessions (sendMessage cryptonet) 354 sessions <- initSessions (sendMessage cryptonet)
353 355
354 let dhtnet0 = layerTransportM (DHT.decrypt crypto nodeId) (DHT.encrypt crypto nodeId) dhtcrypt 356 let dhtnet0 = layerTransportM (DHT.decrypt crypto Multi.nodeId) (DHT.encrypt crypto Multi.nodeId) dhtcrypt
355 tbl4 = DHT.routing4 $ mkrouting (error "missing client") 357 tbl4 = DHT.routing4 $ mkrouting (error "missing client")
356 tbl6 = DHT.routing6 $ mkrouting (error "missing client") 358 tbl6 = DHT.routing6 $ mkrouting (error "missing client")
357 updateOnion bkts tr = hookBucketList DHT.toxSpace bkts orouter (trampolinesUDP orouter) tr 359 updateOnion bkts tr = hookBucketList DHT.toxSpace bkts orouter (trampolinesUDP orouter) tr
360
358 dhtclient <- newClient drg dhtnet0 DHT.classify (myAddr tbl4 tbl6) (DHT.handlers crypto . mkrouting) id 361 dhtclient <- newClient drg dhtnet0 DHT.classify (myAddr tbl4 tbl6) (DHT.handlers crypto . mkrouting) id
359 (\client net -> onInbound (DHT.updateRouting client (mkrouting client) updateOnion) net) 362 (\client net -> onInbound (DHT.updateRouting client (mkrouting client) updateOnion) net)
360 363
@@ -370,7 +373,7 @@ newToxOverTransport keydb addr onNewSession (crypto,roster) udp tcp = do
370 -- This function should only initialize state. 373 -- This function should only initialize state.
371 orouter' <- forkRouteBuilder orouter 374 orouter' <- forkRouteBuilder orouter
372 $ \nid ni -> fmap (\(_,ns,_)->ns) 375 $ \nid ni -> fmap (\(_,ns,_)->ns)
373 <$> DHT.getNodes dhtclient (DHT.nodesOfInterest $ mkrouting dhtclient) nid ni 376 <$> DHT.getNodes dhtclient (DHT.nodesOfInterest $ mkrouting dhtclient) nid (Multi.UDP ==> ni)
374 377
375 toks <- do 378 toks <- do
376 nil <- nullSessionTokens 379 nil <- nullSessionTokens
@@ -420,7 +423,7 @@ dnssdDiscover tox ni toxid = do
420 forM acts $ \act -> 423 forM acts $ \act ->
421 atomically $ setContactAddr now (id2key tid) ni act 424 atomically $ setContactAddr now (id2key tid) ni act
422 425
423 void $ DHT.ping (toxDHT tox) ni 426 void $ DHT.pingUDP (toxDHT tox) ni
424 427
425-- | Returns: 428-- | Returns:
426-- 429--
diff --git a/dht/src/Network/Tox/DHT/Handlers.hs b/dht/src/Network/Tox/DHT/Handlers.hs
index 323d5f5e..5156ec44 100644
--- a/dht/src/Network/Tox/DHT/Handlers.hs
+++ b/dht/src/Network/Tox/DHT/Handlers.hs
@@ -5,22 +5,24 @@
5{-# LANGUAGE TupleSections #-} 5{-# LANGUAGE TupleSections #-}
6module Network.Tox.DHT.Handlers where 6module Network.Tox.DHT.Handlers where
7 7
8import Debug.Trace 8import Control.TriadCommittee
9import Network.Tox.DHT.Transport as DHTTransport
10import Network.Tox.TCP.NodeId as TCP (fromUDPNode, udpNodeInfo)
11import Network.QueryResponse as QR hiding (Client)
12import qualified Network.QueryResponse as QR (Client)
13import Crypto.Tox 9import Crypto.Tox
14import Network.Kademlia.Search 10import qualified Data.Tox.DHT.Multi as Multi
15import qualified Data.Wrapper.PSQInt as Int 11import qualified Data.Wrapper.PSQInt as Int
12import Debug.Trace
13import DebugTag
14import DPut
15import Network.Address (WantIP (..), fromSockAddr, ipFamily,
16 sockAddrPort)
16import Network.Kademlia 17import Network.Kademlia
17import Network.Kademlia.Bootstrap 18import Network.Kademlia.Bootstrap
18import Network.Address (WantIP (..), ipFamily, fromSockAddr, sockAddrPort)
19import qualified Network.Kademlia.Routing as R 19import qualified Network.Kademlia.Routing as R
20import Control.TriadCommittee 20import Network.Kademlia.Search
21import qualified Network.QueryResponse as QR (Client)
22 ;import Network.QueryResponse as QR hiding (Client)
23import Network.Tox.DHT.Transport as DHTTransport
24import Network.Tox.TCP.NodeId as TCP (fromUDPNode, udpNodeInfo)
21import System.Global6 25import System.Global6
22import DPut
23import DebugTag
24 26
25import qualified Data.ByteArray as BA 27import qualified Data.ByteArray as BA
26import qualified Data.ByteString.Char8 as C8 28import qualified Data.ByteString.Char8 as C8
@@ -29,6 +31,7 @@ import Control.Arrow
29import Control.Monad 31import Control.Monad
30import Control.Concurrent.Lifted.Instrument 32import Control.Concurrent.Lifted.Instrument
31import Control.Concurrent.STM 33import Control.Concurrent.STM
34import Data.Dependent.Sum ((==>))
32import Data.Hashable 35import Data.Hashable
33import Data.Ord 36import Data.Ord
34import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime) 37import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime)
@@ -80,21 +83,21 @@ pattern SendNodesType = PacketKind 4 -- 0x04 Nodes Response
80 83
81 84
82instance Show PacketKind where 85instance Show PacketKind where
83 showsPrec d PingType = mappend "PingType" 86 showsPrec d PingType = mappend "PingType"
84 showsPrec d PongType = mappend "PongType" 87 showsPrec d PongType = mappend "PongType"
85 showsPrec d GetNodesType = mappend "GetNodesType" 88 showsPrec d GetNodesType = mappend "GetNodesType"
86 showsPrec d SendNodesType = mappend "SendNodesType" 89 showsPrec d SendNodesType = mappend "SendNodesType"
87 showsPrec d DHTRequestType = mappend "DHTRequestType" 90 showsPrec d DHTRequestType = mappend "DHTRequestType"
88 showsPrec d OnionRequest0Type = mappend "OnionRequest0Type" 91 showsPrec d OnionRequest0Type = mappend "OnionRequest0Type"
89 showsPrec d OnionResponse1Type = mappend "OnionResponse1Type" 92 showsPrec d OnionResponse1Type = mappend "OnionResponse1Type"
90 showsPrec d OnionResponse3Type = mappend "OnionResponse3Type" 93 showsPrec d OnionResponse3Type = mappend "OnionResponse3Type"
91 showsPrec d AnnounceType = mappend "AnnounceType" 94 showsPrec d AnnounceType = mappend "AnnounceType"
92 showsPrec d AnnounceResponseType = mappend "AnnounceResponseType" 95 showsPrec d AnnounceResponseType = mappend "AnnounceResponseType"
93 showsPrec d DataRequestType = mappend "DataRequestType" 96 showsPrec d DataRequestType = mappend "DataRequestType"
94 showsPrec d DataResponseType = mappend "DataResponseType" 97 showsPrec d DataResponseType = mappend "DataResponseType"
95 showsPrec d CookieRequestType = mappend "CookieRequestType" 98 showsPrec d CookieRequestType = mappend "CookieRequestType"
96 showsPrec d CookieResponseType = mappend "CookieResponseType" 99 showsPrec d CookieResponseType = mappend "CookieResponseType"
97 showsPrec d (PacketKind x) = mappend "PacketKind " . showsPrec (d+1) x 100 showsPrec d (PacketKind x) = mappend "PacketKind " . showsPrec (d+1) x
98 101
99msgType :: ( Serialize (f DHTRequest) 102msgType :: ( Serialize (f DHTRequest)
100 , Serialize (f (Cookie Encrypted)), Serialize (f CookieRequest) 103 , Serialize (f (Cookie Encrypted)), Serialize (f CookieRequest)
@@ -103,7 +106,7 @@ msgType :: ( Serialize (f DHTRequest)
103 ) => DHTMessage f -> PacketKind 106 ) => DHTMessage f -> PacketKind
104msgType msg = PacketKind $ fst $ dhtMessageType msg 107msgType msg = PacketKind $ fst $ dhtMessageType msg
105 108
106classify :: Client -> Message -> MessageClass String PacketKind TransactionId NodeInfo Message 109classify :: Client -> Message -> MessageClass String PacketKind TransactionId Multi.NodeInfo Message
107classify client (DHTLanDiscovery {}) = IsUnsolicited (lanDiscoveryH client) 110classify client (DHTLanDiscovery {}) = IsUnsolicited (lanDiscoveryH client)
108classify client msg = fromMaybe (IsUnknown "unknown") 111classify client msg = fromMaybe (IsUnknown "unknown")
109 $ mapMessage (\nonce24 (nonce8,_) -> go msg (TransactionId nonce8 nonce24)) msg 112 $ mapMessage (\nonce24 (nonce8,_) -> go msg (TransactionId nonce8 nonce24)) msg
@@ -121,7 +124,7 @@ data NodeInfoCallback = NodeInfoCallback
121 , listenerId :: Int 124 , listenerId :: Int
122 , observedAddress :: POSIXTime -> NodeInfo -- Address and port for interestingNodeId 125 , observedAddress :: POSIXTime -> NodeInfo -- Address and port for interestingNodeId
123 -> STM () 126 -> STM ()
124 , rumoredAddress :: POSIXTime -> SockAddr -- source of information 127 , rumoredAddress :: POSIXTime -> Multi.NodeInfo -- source of information
125 -> NodeInfo -- Address and port for interestingNodeId 128 -> NodeInfo -- Address and port for interestingNodeId
126 -> STM () 129 -> STM ()
127 } 130 }
@@ -208,7 +211,7 @@ newRouting addr crypto update4 update6 = do
208 cbvar <- newTVar HashMap.empty 211 cbvar <- newTVar HashMap.empty
209 return $ \client -> 212 return $ \client ->
210 -- Now we have a client, so tell the BucketRefresher how to search and ping. 213 -- Now we have a client, so tell the BucketRefresher how to search and ping.
211 let updIO r = updateRefresherIO (nodeSearch client cbvar) (ping client) r 214 let updIO r = updateRefresherIO (nodeSearch client cbvar) (pingUDP client) r
212 in Routing { tentativeId = tentative_info 215 in Routing { tentativeId = tentative_info
213 , committee4 = committee4 216 , committee4 = committee4
214 , committee6 = committee6 217 , committee6 = committee6
@@ -226,32 +229,28 @@ isLocal (IPv4 ip4) = (ip4 == toEnum 0)
226isGlobal :: IP -> Bool 229isGlobal :: IP -> Bool
227isGlobal = not . isLocal 230isGlobal = not . isLocal
228 231
229prefer4or6 :: NodeInfo -> Maybe WantIP -> WantIP 232prefer4or6 :: Multi.NodeInfo -> Maybe WantIP -> WantIP
230prefer4or6 addr iptyp = fromMaybe (ipFamily $ nodeIP addr) iptyp 233prefer4or6 addr iptyp = fromMaybe fallback iptyp
231 234 where
232toxSpace :: R.KademliaSpace NodeId NodeInfo 235 fallback = case Multi.udpNode addr of
233toxSpace = R.KademliaSpace 236 Just ni -> ipFamily $ nodeIP ni
234 { R.kademliaLocation = nodeId 237 Nothing -> Want_Both
235 , R.kademliaTestBit = testNodeIdBit
236 , R.kademliaXor = xorNodeId
237 , R.kademliaSample = sampleNodeId
238 }
239 238
240 239
241pingH :: NodeInfo -> Ping -> IO Pong 240pingH :: ni -> Ping -> IO Pong
242pingH _ Ping = return Pong 241pingH _ Ping = return Pong
243 242
244getNodesH :: Routing -> NodeInfo -> GetNodes -> IO SendNodes 243getNodesH :: Routing -> Multi.NodeInfo -> GetNodes -> IO SendNodes
245getNodesH routing addr (GetNodes nid) = do 244getNodesH routing addr (GetNodes nid) = do
246 let preferred = prefer4or6 addr Nothing 245 let preferred = prefer4or6 addr Nothing
247 246
248 (append4,append6) <- atomically $ do 247 (append4,append6) <- atomically $ do
249 ni4 <- R.thisNode <$> readTVar (routing4 routing) 248 ni4 <- R.thisNode <$> readTVar (routing4 routing)
250 ni6 <- R.thisNode <$> readTVar (routing6 routing) 249 ni6 <- R.thisNode <$> readTVar (routing6 routing)
251 return $ case ipFamily (nodeIP addr) of 250 return $ case ipFamily . nodeIP <$> Multi.udpNode addr of
252 Want_IP4 | isGlobal (nodeIP ni6) -> (id, (++ [ni6])) 251 Just Want_IP4 | isGlobal (nodeIP ni6) -> (id, (++ [ni6]))
253 Want_IP6 | isGlobal (nodeIP ni4) -> ((++ [ni4]), id) 252 Just Want_IP6 | isGlobal (nodeIP ni4) -> ((++ [ni4]), id)
254 _ -> (id, id) 253 _ -> (id, id)
255 ks <- go append4 $ routing4 routing 254 ks <- go append4 $ routing4 routing
256 ks6 <- go append6 $ routing6 routing 255 ks6 <- go append6 $ routing6 routing
257 let (ns1,ns2) = case preferred of Want_IP6 -> (ks6,ks) 256 let (ns1,ns2) = case preferred of Want_IP6 -> (ks6,ks)
@@ -266,7 +265,7 @@ getNodesH routing addr (GetNodes nid) = do
266 265
267 k = 4 266 k = 4
268 267
269createCookie :: TransportCrypto -> NodeInfo -> PublicKey -> IO (Cookie Encrypted) 268createCookie :: TransportCrypto -> Multi.NodeInfo -> PublicKey -> IO (Cookie Encrypted)
270createCookie crypto ni remoteUserKey = do 269createCookie crypto ni remoteUserKey = do
271 (n24,sym) <- atomically $ do 270 (n24,sym) <- atomically $ do
272 n24 <- transportNewNonce crypto 271 n24 <- transportNewNonce crypto
@@ -276,12 +275,12 @@ createCookie crypto ni remoteUserKey = do
276 let dta = encodePlain $ CookieData 275 let dta = encodePlain $ CookieData
277 { cookieTime = timestamp 276 { cookieTime = timestamp
278 , longTermKey = remoteUserKey 277 , longTermKey = remoteUserKey
279 , dhtKey = id2key $ nodeId ni -- transportPublic crypto 278 , dhtKey = id2key $ Multi.nodeId ni -- transportPublic crypto
280 } 279 }
281 edta = encryptSymmetric sym n24 dta 280 edta = encryptSymmetric sym n24 dta
282 return $ Cookie n24 edta 281 return $ Cookie n24 edta
283 282
284createCookieSTM :: POSIXTime -> TransportCrypto -> NodeInfo -> PublicKey -> STM (Cookie Encrypted) 283createCookieSTM :: POSIXTime -> TransportCrypto -> Multi.NodeInfo -> PublicKey -> STM (Cookie Encrypted)
285createCookieSTM now crypto ni remoteUserKey = do 284createCookieSTM now crypto ni remoteUserKey = do
286 let dmsg msg = trace msg (return ()) 285 let dmsg msg = trace msg (return ())
287 (n24,sym) <- do 286 (n24,sym) <- do
@@ -292,37 +291,38 @@ createCookieSTM now crypto ni remoteUserKey = do
292 let dta = encodePlain $ CookieData 291 let dta = encodePlain $ CookieData
293 { cookieTime = timestamp 292 { cookieTime = timestamp
294 , longTermKey = remoteUserKey 293 , longTermKey = remoteUserKey
295 , dhtKey = id2key $ nodeId ni -- transportPublic crypto 294 , dhtKey = id2key $ Multi.nodeId ni -- transportPublic crypto
296 } 295 }
297 edta = encryptSymmetric sym n24 dta 296 edta = encryptSymmetric sym n24 dta
298 return $ Cookie n24 edta 297 return $ Cookie n24 edta
299 298
300cookieRequestH :: TransportCrypto -> NodeInfo -> CookieRequest -> IO (Cookie Encrypted) 299cookieRequestH :: TransportCrypto -> Multi.NodeInfo -> CookieRequest -> IO (Cookie Encrypted)
301cookieRequestH crypto ni (CookieRequest remoteUserKey) = do 300cookieRequestH crypto ni (CookieRequest remoteUserKey) = do
302 dput XNetCrypto $ unlines 301 dput XNetCrypto $ unlines
303 [ show (nodeAddr ni) ++ " --> request cookie: remoteUserKey=" ++ show (key2id remoteUserKey) 302 [ show ni ++ " --> request cookie: remoteUserKey=" ++ show (key2id remoteUserKey)
304 , show (nodeAddr ni) ++ " --> sender=" ++ show (nodeId ni) ] 303 , show ni ++ " --> sender=" ++ show (Multi.nodeId ni) ]
305 x <- createCookie crypto ni remoteUserKey 304 x <- createCookie crypto ni remoteUserKey
306 dput XNetCrypto $ show (nodeAddr ni) ++ " <-- cookie " ++ show (key2id remoteUserKey) 305 dput XNetCrypto $ show ni ++ " <-- cookie " ++ show (key2id remoteUserKey)
307 return x 306 return x
308 307
309lanDiscoveryH :: Client -> NodeInfo -> NodeInfo -> IO (Maybe (Message -> Message)) 308lanDiscoveryH :: Client -> Multi.NodeInfo -> Multi.NodeInfo -> IO (Maybe (Message -> Message))
310lanDiscoveryH client _ ni = do 309lanDiscoveryH client _ ni = do
311 dput XLan $ show (nodeAddr ni) ++ " --> LanAnnounce " ++ show (nodeId ni) 310 forM_ (Multi.udpNode ni) $ \uni -> do
312 forkIO $ do 311 dput XLan $ show (nodeAddr uni) ++ " --> LanAnnounce " ++ show (nodeId uni)
313 myThreadId >>= flip labelThread "lan-discover-ping" 312 forkIO $ do
314 ping client ni 313 myThreadId >>= flip labelThread "lan-discover-ping"
315 return () 314 pingUDP client uni
315 return ()
316 return Nothing 316 return Nothing
317 317
318type Message = DHTMessage ((,) Nonce8) 318type Message = DHTMessage ((,) Nonce8)
319 319
320type Client = QR.Client String PacketKind TransactionId NodeInfo Message 320type Client = QR.Client String PacketKind TransactionId Multi.NodeInfo Message
321 321
322 322
323wrapAsymm :: TransactionId -> NodeInfo -> NodeInfo -> (Nonce8 -> dta) -> Asymm dta 323wrapAsymm :: TransactionId -> Multi.NodeInfo -> Multi.NodeInfo -> (Nonce8 -> dta) -> Asymm dta
324wrapAsymm (TransactionId n8 n24) src dst dta = Asymm 324wrapAsymm (TransactionId n8 n24) src dst dta = Asymm
325 { senderKey = id2key $ nodeId src 325 { senderKey = id2key $ Multi.nodeId src
326 , asymmNonce = n24 326 , asymmNonce = n24
327 , asymmData = dta n8 327 , asymmData = dta n8
328 } 328 }
@@ -330,7 +330,7 @@ wrapAsymm (TransactionId n8 n24) src dst dta = Asymm
330serializer :: PacketKind 330serializer :: PacketKind
331 -> (Asymm (Nonce8,ping) -> Message) 331 -> (Asymm (Nonce8,ping) -> Message)
332 -> (Message -> Maybe (Asymm (Nonce8,pong))) 332 -> (Message -> Maybe (Asymm (Nonce8,pong)))
333 -> MethodSerializer TransactionId NodeInfo Message PacketKind ping (Maybe pong) 333 -> MethodSerializer TransactionId Multi.NodeInfo Message PacketKind ping (Maybe pong)
334serializer pktkind mkping mkpong = MethodSerializer 334serializer pktkind mkping mkpong = MethodSerializer
335 { methodTimeout = \addr -> return (addr, 5000000) 335 { methodTimeout = \addr -> return (addr, 5000000)
336 , method = pktkind 336 , method = pktkind
@@ -345,7 +345,10 @@ unpong :: Message -> Maybe (Asymm (Nonce8,Pong))
345unpong (DHTPong asymm) = Just asymm 345unpong (DHTPong asymm) = Just asymm
346unpong _ = Nothing 346unpong _ = Nothing
347 347
348ping :: Client -> NodeInfo -> IO Bool 348pingUDP :: Client -> NodeInfo -> IO Bool
349pingUDP client ni = ping client (Multi.UDP ==> ni)
350
351ping :: Client -> Multi.NodeInfo -> IO Bool
349ping client addr = do 352ping client addr = do
350 dput XPing $ show addr ++ " <-- ping" 353 dput XPing $ show addr ++ " <-- ping"
351 reply <- QR.sendQuery client (serializer PingType DHTPing unpong) Ping addr 354 reply <- QR.sendQuery client (serializer PingType DHTPing unpong) Ping addr
@@ -372,10 +375,14 @@ loseCookieKey var saddr pk = do
372 _ -> return () -- unreachable? 375 _ -> return () -- unreachable?
373 376
374 377
375cookieRequest :: TransportCrypto -> Client -> PublicKey -> NodeInfo -> IO (Maybe (Cookie Encrypted)) 378cookieRequest :: TransportCrypto -> Client -> PublicKey -> Multi.NodeInfo -> IO (Maybe (Cookie Encrypted))
376cookieRequest crypto client localUserKey addr = do 379cookieRequest crypto client localUserKey addr = do
377 let sockAddr = nodeAddr addr 380 let (runfirst,runlast) = case Multi.udpNode addr of
378 nid = id2key $ nodeId addr 381 Just ni -> let sockAddr = nodeAddr ni
382 nid = id2key $ nodeId ni
383 in ( atomically $ saveCookieKey (pendingCookies crypto) sockAddr nid
384 , atomically $ loseCookieKey (pendingCookies crypto) sockAddr nid )
385 Nothing -> (return (), return ())
379 cookieSerializer 386 cookieSerializer
380 = MethodSerializer 387 = MethodSerializer
381 { methodTimeout = \addr -> return (addr, 5000000) 388 { methodTimeout = \addr -> return (addr, 5000000)
@@ -384,10 +391,10 @@ cookieRequest crypto client localUserKey addr = do
384 , unwrapResponse = fmap snd . unCookie 391 , unwrapResponse = fmap snd . unCookie
385 } 392 }
386 cookieRequest = CookieRequest localUserKey 393 cookieRequest = CookieRequest localUserKey
387 atomically $ saveCookieKey (pendingCookies crypto) sockAddr nid 394 runfirst
388 dput XNetCrypto $ show addr ++ " <-- cookieRequest" 395 dput XNetCrypto $ show addr ++ " <-- cookieRequest"
389 reply <- QR.sendQuery client cookieSerializer cookieRequest addr 396 reply <- QR.sendQuery client cookieSerializer cookieRequest addr
390 atomically $ loseCookieKey (pendingCookies crypto) sockAddr nid 397 runlast
391 dput XNetCrypto $ show addr ++ " -cookieResponse-> " ++ show reply 398 dput XNetCrypto $ show addr ++ " -cookieResponse-> " ++ show reply
392 return $ join reply 399 return $ join reply
393 400
@@ -403,39 +410,42 @@ unsendNodes _ = Nothing
403unwrapNodes :: SendNodes -> ( [NodeInfo], [NodeInfo], Maybe () ) 410unwrapNodes :: SendNodes -> ( [NodeInfo], [NodeInfo], Maybe () )
404unwrapNodes (SendNodes ns) = (map udpNodeInfo ns,map udpNodeInfo ns,Just ()) 411unwrapNodes (SendNodes ns) = (map udpNodeInfo ns,map udpNodeInfo ns,Just ())
405 412
406getNodes :: Client -> TVar (HashMap NodeId [NodeInfoCallback]) -> NodeId -> NodeInfo -> IO (Maybe ([NodeInfo],[NodeInfo],Maybe ())) 413getNodes :: Client -> TVar (HashMap NodeId [NodeInfoCallback]) -> NodeId -> Multi.NodeInfo -> IO (Maybe ([NodeInfo],[NodeInfo],Maybe ()))
407getNodes client cbvar nid addr = do 414getNodes client cbvar nid addr = do
408 -- dput XMisc $ show addr ++ " <-- getnodes " ++ show nid 415 -- dput XMisc $ show addr ++ " <-- getnodes " ++ show nid
409 reply <- QR.sendQuery client (serializer GetNodesType DHTGetNodes unsendNodes) (GetNodes nid) addr 416 reply <- QR.sendQuery client (serializer GetNodesType DHTGetNodes unsendNodes) (GetNodes nid) addr
410 -- dput XMisc $ show addr ++ " -sendnodes-> " ++ show reply 417 -- dput XMisc $ show addr ++ " -sendnodes-> " ++ show reply
411 forM_ (join reply) $ \(SendNodes ns) -> 418 forM_ (join reply) $ \(SendNodes ns) ->
412 forM_ ns $ \n -> do 419 forM_ ns $ \n -> do
413 now <- getPOSIXTime 420 now <- getPOSIXTime
414 atomically $ do 421 atomically $ do
415 mcbs <- HashMap.lookup (nodeId . udpNodeInfo $ n) <$> readTVar cbvar 422 mcbs <- HashMap.lookup (nodeId . udpNodeInfo $ n) <$> readTVar cbvar
416 forM_ mcbs $ \cbs -> do 423 forM_ mcbs $ \cbs -> do
417 forM_ cbs $ \cb -> do 424 forM_ cbs $ \cb -> do
418 rumoredAddress cb now (nodeAddr addr) (udpNodeInfo n) 425 rumoredAddress cb now addr (udpNodeInfo n)
419 return $ fmap unwrapNodes $ join reply 426 return $ fmap unwrapNodes $ join reply
420 427
428getNodesUDP :: Client -> TVar (HashMap NodeId [NodeInfoCallback]) -> NodeId -> NodeInfo -> IO (Maybe ([NodeInfo],[NodeInfo],Maybe ()))
429getNodesUDP client cbvar nid addr = getNodes client cbvar nid (Multi.UDP ==> addr)
430
421updateRouting :: Client -> Routing 431updateRouting :: Client -> Routing
422 -> (TVar (R.BucketList NodeInfo) -> RoutingTransition NodeInfo -> STM ()) 432 -> (TVar (R.BucketList NodeInfo) -> RoutingTransition NodeInfo -> STM ())
423 -> NodeInfo 433 -> Multi.NodeInfo
424 -> Message 434 -> Message
425 -> IO () 435 -> IO ()
426updateRouting client routing orouter naddr msg 436updateRouting client routing orouter naddr0 msg
427 | PacketKind 0x21 <- msgType msg = -- dput XLan "(tox)updateRouting: ignoring lan discovery" -- ignore lan discovery 437 | PacketKind 0x21 <- msgType msg = -- dput XLan "(tox)updateRouting: ignoring lan discovery" -- ignore lan discovery
428 -- Ignore lan announcements until they reply to our ping. 438 -- Ignore lan announcements until they reply to our ping.
429 -- We do this because the lan announce is not authenticated. 439 -- We do this because the lan announce is not authenticated.
430 return () 440 return ()
431 | otherwise = do 441 | otherwise = forM_ (Multi.udpNode naddr0) $ \naddr -> do
432 now <- getPOSIXTime 442 now <- getPOSIXTime
433 atomically $ do 443 atomically $ do
434 m <- HashMap.lookup (nodeId naddr) <$> readTVar (nodesOfInterest routing) 444 m <- HashMap.lookup (nodeId naddr) <$> readTVar (nodesOfInterest routing)
435 forM_ m $ mapM_ $ \NodeInfoCallback{interestingNodeId,observedAddress} -> do 445 forM_ m $ mapM_ $ \NodeInfoCallback{interestingNodeId,observedAddress} -> do
436 when (interestingNodeId == nodeId naddr) 446 when (interestingNodeId == nodeId naddr)
437 $ observedAddress now naddr 447 $ observedAddress now naddr
438 case prefer4or6 naddr Nothing of 448 case prefer4or6 (Multi.UDP ==> naddr) Nothing of
439 Want_IP4 -> updateTable client naddr orouter (committee4 routing) (refresher4 routing) 449 Want_IP4 -> updateTable client naddr orouter (committee4 routing) (refresher4 routing)
440 Want_IP6 -> updateTable client naddr orouter (committee6 routing) (refresher6 routing) 450 Want_IP6 -> updateTable client naddr orouter (committee6 routing) (refresher6 routing)
441 Want_Both -> do dput XMisc "BUG:unreachable" 451 Want_Both -> do dput XMisc "BUG:unreachable"
@@ -461,7 +471,7 @@ toxKademlia :: Client
461toxKademlia client committee orouter refresher 471toxKademlia client committee orouter refresher
462 = Kademlia quietInsertions 472 = Kademlia quietInsertions
463 toxSpace 473 toxSpace
464 (vanillaIO (refreshBuckets refresher) $ ping client) 474 (vanillaIO (refreshBuckets refresher) $ pingUDP client)
465 { tblTransition = \tr -> do 475 { tblTransition = \tr -> do
466 io1 <- transitionCommittee committee tr 476 io1 <- transitionCommittee committee tr
467 io2 <- touchBucket refresher tr -- toxSpace (15*60) var sched tr 477 io2 <- touchBucket refresher tr -- toxSpace (15*60) var sched tr
@@ -486,34 +496,34 @@ transitionCommittee committee (RoutingTransition ni Stranger) = do
486 return () 496 return ()
487transitionCommittee committee _ = return $ return () 497transitionCommittee committee _ = return $ return ()
488 498
489type Handler = MethodHandler String TransactionId NodeInfo Message 499type Handler = MethodHandler String TransactionId Multi.NodeInfo Message
490 500
491isPing :: (f Ping -> Ping) -> DHTMessage f -> Either String Ping 501isPing :: (f Ping -> Ping) -> DHTMessage f -> Either String Ping
492isPing unpack (DHTPing a) = Right $ unpack $ asymmData a 502isPing unpack (DHTPing a) = Right $ unpack $ asymmData a
493isPing _ _ = Left "Bad ping" 503isPing _ _ = Left "Bad ping"
494 504
495mkPong :: TransactionId -> NodeInfo -> NodeInfo -> Pong -> DHTMessage ((,) Nonce8) 505mkPong :: TransactionId -> Multi.NodeInfo -> Multi.NodeInfo -> Pong -> DHTMessage ((,) Nonce8)
496mkPong tid src dst pong = DHTPong $ wrapAsymm tid src dst (, pong) 506mkPong tid src dst pong = DHTPong $ wrapAsymm tid src dst (, pong)
497 507
498isGetNodes :: (f GetNodes -> GetNodes) -> DHTMessage f -> Either String GetNodes 508isGetNodes :: (f GetNodes -> GetNodes) -> DHTMessage f -> Either String GetNodes
499isGetNodes unpack (DHTGetNodes a) = Right $ unpack $ asymmData a 509isGetNodes unpack (DHTGetNodes a) = Right $ unpack $ asymmData a
500isGetNodes _ _ = Left "Bad GetNodes" 510isGetNodes _ _ = Left "Bad GetNodes"
501 511
502mkSendNodes :: TransactionId -> NodeInfo -> NodeInfo -> SendNodes -> DHTMessage ((,) Nonce8) 512mkSendNodes :: TransactionId -> Multi.NodeInfo -> Multi.NodeInfo -> SendNodes -> DHTMessage ((,) Nonce8)
503mkSendNodes tid src dst sendnodes = DHTSendNodes $ wrapAsymm tid src dst (, sendnodes) 513mkSendNodes tid src dst sendnodes = DHTSendNodes $ wrapAsymm tid src dst (, sendnodes)
504 514
505isCookieRequest :: (f CookieRequest -> CookieRequest) -> DHTMessage f -> Either String CookieRequest 515isCookieRequest :: (f CookieRequest -> CookieRequest) -> DHTMessage f -> Either String CookieRequest
506isCookieRequest unpack (DHTCookieRequest a) = Right $ unpack $ asymmData a 516isCookieRequest unpack (DHTCookieRequest a) = Right $ unpack $ asymmData a
507isCookieRequest _ _ = Left "Bad cookie request" 517isCookieRequest _ _ = Left "Bad cookie request"
508 518
509mkCookie :: TransactionId -> NodeInfo -> NodeInfo -> Cookie Encrypted -> DHTMessage ((,) Nonce8) 519mkCookie :: TransactionId -> ni -> ni -> Cookie Encrypted -> DHTMessage ((,) Nonce8)
510mkCookie (TransactionId n8 n24) src dst cookie = DHTCookie n24 (n8,cookie) 520mkCookie (TransactionId n8 n24) src dst cookie = DHTCookie n24 (n8,cookie)
511 521
512isDHTRequest :: (f DHTRequest -> DHTRequest) -> DHTMessage f -> Either String DHTRequest 522isDHTRequest :: (f DHTRequest -> DHTRequest) -> DHTMessage f -> Either String DHTRequest
513isDHTRequest unpack (DHTDHTRequest pubkey a) = Right $ unpack $ asymmData a 523isDHTRequest unpack (DHTDHTRequest pubkey a) = Right $ unpack $ asymmData a
514isDHTRequest _ _ = Left "Bad dht relay request" 524isDHTRequest _ _ = Left "Bad dht relay request"
515 525
516dhtRequestH :: NodeInfo -> DHTRequest -> IO () 526dhtRequestH :: Multi.NodeInfo -> DHTRequest -> IO ()
517dhtRequestH ni req = do 527dhtRequestH ni req = do
518 dput XMisc $ "Unhandled DHT Request: " ++ show req 528 dput XMisc $ "Unhandled DHT Request: " ++ show req
519 529
@@ -528,8 +538,23 @@ nodeSearch :: Client -> TVar (HashMap NodeId [NodeInfoCallback]) -> Search NodeI
528nodeSearch client cbvar = Search 538nodeSearch client cbvar = Search
529 { searchSpace = toxSpace 539 { searchSpace = toxSpace
530 , searchNodeAddress = nodeIP &&& nodePort 540 , searchNodeAddress = nodeIP &&& nodePort
531 , searchQuery = Left $ getNodes client cbvar 541 -- searchQuery :: Either (nid -> ni -> IO (Maybe ([ni], [r], Maybe tok)))
542 -- (nid -> ni -> (Maybe ([ni],[r],Maybe tok) -> IO ()) -> IO ())
543 , searchQuery = Left $ getNodesUDP client cbvar
532 , searchAlpha = 8 544 , searchAlpha = 8
533 , searchK = 16 545 , searchK = 16
546 }
534 547
548{-
549nodeSearchMulti :: Client -> TVar (HashMap NodeId [NodeInfoCallback]) -> Search NodeId (IP,PortNumber) () Multi.NodeInfo Multi.NodeInfo
550nodeSearchMulti client cbvar = Search
551 { searchSpace = toxSpace
552 , searchNodeAddress = nodeIP &&& nodePort
553 -- searchQuery :: Either (nid -> ni -> IO (Maybe ([ni], [r], Maybe tok)))
554 -- (nid -> ni -> (Maybe ([ni],[r],Maybe tok) -> IO ()) -> IO ())
555 , searchQuery = Left $ \nid ni -> fmap fixupUDP <$> getNodes client cbvar nid ni
556 , searchAlpha = 8
557 , searchK = 16
535 } 558 }
559 where fixupUDP (xs,ys,m) = (map (Multi.UDP ==>) xs, map (Multi.UDP ==>) ys, m)
560-}
diff --git a/dht/src/Network/Tox/DHT/Transport.hs b/dht/src/Network/Tox/DHT/Transport.hs
index 0583c9a3..ff743f29 100644
--- a/dht/src/Network/Tox/DHT/Transport.hs
+++ b/dht/src/Network/Tox/DHT/Transport.hs
@@ -33,8 +33,10 @@ module Network.Tox.DHT.Transport
33 , dhtMessageType 33 , dhtMessageType
34 , asymNodeInfo 34 , asymNodeInfo
35 , putMessage -- Convenient for serializing DHTLanDiscovery 35 , putMessage -- Convenient for serializing DHTLanDiscovery
36 , toxSpace
36 ) where 37 ) where
37 38
39import qualified Network.Kademlia.Routing as R
38import Network.Tox.NodeId 40import Network.Tox.NodeId
39import qualified Network.Tox.TCP.NodeId as TCP 41import qualified Network.Tox.TCP.NodeId as TCP
40import Crypto.Tox hiding (encrypt,decrypt) 42import Crypto.Tox hiding (encrypt,decrypt)
@@ -464,3 +466,11 @@ transcode f (DHTCookieRequest asym) = DHTCookieRequest $ asym { asymmDat
464transcode f (DHTCookie n dta) = DHTCookie n $ f n $ Left dta 466transcode f (DHTCookie n dta) = DHTCookie n $ f n $ Left dta
465transcode f (DHTDHTRequest pubkey asym) = DHTDHTRequest pubkey $ asym { asymmData = f (asymmNonce asym) (Right asym) } 467transcode f (DHTDHTRequest pubkey asym) = DHTDHTRequest pubkey $ asym { asymmData = f (asymmNonce asym) (Right asym) }
466transcode f (DHTLanDiscovery nid) = DHTLanDiscovery nid 468transcode f (DHTLanDiscovery nid) = DHTLanDiscovery nid
469
470toxSpace :: R.KademliaSpace NodeId NodeInfo
471toxSpace = R.KademliaSpace
472 { R.kademliaLocation = nodeId
473 , R.kademliaTestBit = testNodeIdBit
474 , R.kademliaXor = xorNodeId
475 , R.kademliaSample = sampleNodeId
476 }
diff --git a/dht/src/Network/Tox/Handshake.hs b/dht/src/Network/Tox/Handshake.hs
index c48b7415..40bbbaf3 100644
--- a/dht/src/Network/Tox/Handshake.hs
+++ b/dht/src/Network/Tox/Handshake.hs
@@ -80,6 +80,7 @@ data HandshakeParams
80 , hpCookieRemoteDhtkey :: PublicKey 80 , hpCookieRemoteDhtkey :: PublicKey
81 } 81 }
82 82
83{-
83newHandShakeData :: POSIXTime -> TransportCrypto -> Nonce24 -> HandshakeParams -> NodeInfo -> PublicKey -> STM HandshakeData 84newHandShakeData :: POSIXTime -> TransportCrypto -> Nonce24 -> HandshakeParams -> NodeInfo -> PublicKey -> STM HandshakeData
84newHandShakeData timestamp crypto basenonce hp nodeinfo mySessionPublic = do 85newHandShakeData timestamp crypto basenonce hp nodeinfo mySessionPublic = do
85 let HParam {hpOtherCookie,hpMySecretKey,hpCookieRemotePubkey,hpCookieRemoteDhtkey} = hp 86 let HParam {hpOtherCookie,hpMySecretKey,hpCookieRemotePubkey,hpCookieRemoteDhtkey} = hp
@@ -95,6 +96,7 @@ newHandShakeData timestamp crypto basenonce hp nodeinfo mySessionPublic = do
95 , cookieHash = digest 96 , cookieHash = digest
96 , otherCookie = freshCookie 97 , otherCookie = freshCookie
97 } 98 }
99-}
98 100
99toHandshakeParams :: (SecretKey, Handshake Identity) -> HandshakeParams 101toHandshakeParams :: (SecretKey, Handshake Identity) -> HandshakeParams
100toHandshakeParams (key,hs) 102toHandshakeParams (key,hs)
diff --git a/dht/src/Network/Tox/Onion/Handlers.hs b/dht/src/Network/Tox/Onion/Handlers.hs
index 52dcf536..7951e707 100644
--- a/dht/src/Network/Tox/Onion/Handlers.hs
+++ b/dht/src/Network/Tox/Onion/Handlers.hs
@@ -3,6 +3,7 @@
3{-# LANGUAGE PatternSynonyms #-} 3{-# LANGUAGE PatternSynonyms #-}
4module Network.Tox.Onion.Handlers where 4module Network.Tox.Onion.Handlers where
5 5
6import qualified Data.Tox.DHT.Multi as Multi
6import Network.Kademlia.Search 7import Network.Kademlia.Search
7import Network.Tox.TCP.NodeId (udpNodeInfo) 8import Network.Tox.TCP.NodeId (udpNodeInfo)
8import Network.Tox.DHT.Transport 9import Network.Tox.DHT.Transport
@@ -29,6 +30,7 @@ import Control.Concurrent
29import GHC.Conc (labelThread) 30import GHC.Conc (labelThread)
30#endif 31#endif
31import Control.Concurrent.STM 32import Control.Concurrent.STM
33import Data.Dependent.Sum ( (==>) )
32import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime) 34import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime)
33import Network.Socket 35import Network.Socket
34#if MIN_VERSION_iproute(1,7,4) 36#if MIN_VERSION_iproute(1,7,4)
@@ -78,7 +80,7 @@ announceH routing toks keydb oaddr req = do
78 where 80 where
79 go withTok = do 81 go withTok = do
80 let naddr = onionNodeInfo oaddr 82 let naddr = onionNodeInfo oaddr
81 ns <- getNodesH routing naddr (GetNodes (announceSeeking req)) 83 ns <- getNodesH routing (Multi.UDP ==> naddr) (GetNodes (announceSeeking req))
82 tm <- getPOSIXTime 84 tm <- getPOSIXTime
83 85
84 let storing = case oaddr of 86 let storing = case oaddr of
@@ -251,13 +253,6 @@ announceSerializer getTimeout = MethodSerializer
251 _ -> Nothing 253 _ -> Nothing
252 } 254 }
253 255
254unwrapAnnounceResponse :: Maybe NodeId -> NodeInfo -> AnnounceResponse -> ([NodeInfo], [Rendezvous], Maybe Nonce32)
255unwrapAnnounceResponse alias ni (AnnounceResponse is_stored (SendNodes ns0)) | let ns = map udpNodeInfo ns0
256 = case is_stored of
257 NotStored n32 -> ( ns , [] , Just n32)
258 SendBackKey k -> ( ns , [Rendezvous k ni] , Nothing )
259 Acknowledged n32 -> ( ns , maybeToList $ fmap (\k -> Rendezvous (id2key k) ni) alias , Just n32)
260
261-- TODO Announce key to announce peers. 256-- TODO Announce key to announce peers.
262-- 257--
263-- Announce Peers are only put in the 8 closest peers array if they respond 258-- Announce Peers are only put in the 8 closest peers array if they respond
diff --git a/dht/src/Network/Tox/Onion/Routes.hs b/dht/src/Network/Tox/Onion/Routes.hs
index d61c721e..baca693b 100644
--- a/dht/src/Network/Tox/Onion/Routes.hs
+++ b/dht/src/Network/Tox/Onion/Routes.hs
@@ -84,7 +84,7 @@ data OnionRouter = OnionRouter
84 , tcpKademliaClient :: TCP.TCPClient String Nonce8 84 , tcpKademliaClient :: TCP.TCPClient String Nonce8
85 -- | This thread maintains the TCP relay table. 85 -- | This thread maintains the TCP relay table.
86 , tcpKademliaThread :: ThreadId 86 , tcpKademliaThread :: ThreadId
87 , tcpProberState :: TCPCache (SessionProtocol TCP.RelayPacket TCP.RelayPacket) 87 , tcpProberState :: TCP.RelayCache
88 , tcpProber :: TCP.TCPProber 88 , tcpProber :: TCP.TCPProber
89 , tcpProberThread :: ThreadId 89 , tcpProberThread :: ThreadId
90 -- | Kademlia table of TCP relays. 90 -- | Kademlia table of TCP relays.
@@ -158,6 +158,7 @@ newOnionRouter :: TransportCrypto
158 -> (String -> IO ()) 158 -> (String -> IO ())
159 -> Bool -- is tcp enabled? 159 -> Bool -- is tcp enabled?
160 -> IO ( OnionRouter 160 -> IO ( OnionRouter
161 , Transport String TCP.ViaRelay B.ByteString
161 , TVar ( ChaChaDRG 162 , TVar ( ChaChaDRG
162 , Word64Map (Either (Maybe (Bool,TCP.RelayPacket) -> IO ()) 163 , Word64Map (Either (Maybe (Bool,TCP.RelayPacket) -> IO ())
163 (Maybe (OnionMessage Identity) -> IO ())))) 164 (Maybe (OnionMessage Identity) -> IO ()))))
@@ -168,7 +169,7 @@ newOnionRouter crypto perror tcp_enabled = do
168 pq <- newTVar W64.empty 169 pq <- newTVar W64.empty
169 rm <- newArray (0,11) Nothing 170 rm <- newArray (0,11) Nothing
170 return (rlog,pq,rm) 171 return (rlog,pq,rm)
171 ((tbl,(tcptbl,tcpcons)),tcp) <- do 172 ((tbl,(tcptbl,tcpcons,relaynet)),tcp) <- do
172 (tcptbl, client) <- TCP.newClient crypto Left $ \case 173 (tcptbl, client) <- TCP.newClient crypto Left $ \case
173 Left v -> void . v . Just . (,) False 174 Left v -> void . v . Just . (,) False
174 Right v -> \case 175 Right v -> \case
@@ -268,7 +269,7 @@ newOnionRouter crypto perror tcp_enabled = do
268 $ clientNet c } 269 $ clientNet c }
269 } 270 }
270 } 271 }
271 return (or,tcptbl) 272 return (or,relaynet,tcptbl)
272 273
273updateTCP :: OnionRouter -> TCP.NodeInfo -> p -> IO () 274updateTCP :: OnionRouter -> TCP.NodeInfo -> p -> IO ()
274updateTCP or addr x = do 275updateTCP or addr x = do
diff --git a/dht/src/Network/Tox/Onion/Transport.hs b/dht/src/Network/Tox/Onion/Transport.hs
index e746c414..407cd387 100644
--- a/dht/src/Network/Tox/Onion/Transport.hs
+++ b/dht/src/Network/Tox/Onion/Transport.hs
@@ -38,15 +38,19 @@ module Network.Tox.Onion.Transport
38 , wrapSymmetric 38 , wrapSymmetric
39 , wrapOnion 39 , wrapOnion
40 , wrapOnionPure 40 , wrapOnionPure
41 , unwrapAnnounceResponse
41 ) where 42 ) where
42 43
43import Data.ByteString (ByteString) 44import Data.ByteString (ByteString)
45import Data.Maybe
44import Data.Serialize 46import Data.Serialize
45import Network.Socket 47import Network.Socket
46 48
47import Crypto.Tox hiding (encrypt,decrypt) 49import Crypto.Tox hiding (encrypt,decrypt)
50import Network.Tox.TCP.NodeId (udpNodeInfo)
48import qualified Data.Tox.Relay as TCP 51import qualified Data.Tox.Relay as TCP
49import Data.Tox.Onion 52import Data.Tox.Onion
53import Network.Tox.DHT.Transport (SendNodes(..))
50import Network.Tox.NodeId 54import Network.Tox.NodeId
51 55
52{- 56{-
@@ -117,3 +121,10 @@ wrapForRoute crypto msg ni r@OnionRoute{routeRelayPort = Just tcpport} = do
117 (nodeAddr ni) 121 (nodeAddr ni)
118 (NotForwarded msg) 122 (NotForwarded msg)
119 return $ Left $ TCP.OnionPacket nonce $ Addressed (nodeAddr $ routeNodeB r) fwd 123 return $ Left $ TCP.OnionPacket nonce $ Addressed (nodeAddr $ routeNodeB r) fwd
124
125unwrapAnnounceResponse :: Maybe NodeId -> NodeInfo -> AnnounceResponse -> ([NodeInfo], [Rendezvous], Maybe Nonce32)
126unwrapAnnounceResponse alias ni (AnnounceResponse is_stored (SendNodes ns0)) | let ns = map udpNodeInfo ns0
127 = case is_stored of
128 NotStored n32 -> ( ns , [] , Just n32)
129 SendBackKey k -> ( ns , [Rendezvous k ni] , Nothing )
130 Acknowledged n32 -> ( ns , maybeToList $ fmap (\k -> Rendezvous (id2key k) ni) alias , Just n32)
diff --git a/dht/src/Network/Tox/Session.hs b/dht/src/Network/Tox/Session.hs
index 189967fa..0d89afc4 100644
--- a/dht/src/Network/Tox/Session.hs
+++ b/dht/src/Network/Tox/Session.hs
@@ -19,6 +19,7 @@ import Network.Socket (SockAddr)
19 19
20import Crypto.Tox 20import Crypto.Tox
21import Data.PacketBuffer (PacketInboundEvent (..)) 21import Data.PacketBuffer (PacketInboundEvent (..))
22import qualified Data.Tox.DHT.Multi as Multi
22import Data.Tox.Msg 23import Data.Tox.Msg
23import DPut 24import DPut
24import DebugTag 25import DebugTag
@@ -45,7 +46,7 @@ data SessionParams = SessionParams
45 -- cookie pair for the remote address. If no handshake was sent, this 46 -- cookie pair for the remote address. If no handshake was sent, this
46 -- should send one immediately. It should return 'Nothing' if anything 47 -- should send one immediately. It should return 'Nothing' if anything
47 -- goes wrong. 48 -- goes wrong.
48 , spGetSentHandshake :: SecretKey -> SockAddr 49 , spGetSentHandshake :: SecretKey -> Multi.SessionAddress
49 -> Cookie Identity 50 -> Cookie Identity
50 -> Cookie Encrypted 51 -> Cookie Encrypted
51 -> IO (Maybe (SessionKey, HandshakeData)) 52 -> IO (Maybe (SessionKey, HandshakeData))
@@ -61,7 +62,7 @@ data Session = Session
61 -- local-end of this session. 62 -- local-end of this session.
62 sOurKey :: SecretKey 63 sOurKey :: SecretKey
63 -- | The remote address for this session. (Not unique, see 'sSessionID'). 64 -- | The remote address for this session. (Not unique, see 'sSessionID').
64 , sTheirAddr :: SockAddr 65 , sTheirAddr :: Multi.SessionAddress
65 -- | The information we sent in the handshake for this session. 66 -- | The information we sent in the handshake for this session.
66 , sSentHandshake :: HandshakeData 67 , sSentHandshake :: HandshakeData
67 -- | The information we received in a handshake for this session. 68 -- | The information we received in a handshake for this session.
@@ -100,7 +101,7 @@ sClose s = closeTransport (sTransport s)
100-- negotiated. It always returns Nothing which makes it convenient to use with 101-- negotiated. It always returns Nothing which makes it convenient to use with
101-- 'Network.QueryResponse.addHandler'. 102-- 'Network.QueryResponse.addHandler'.
102handshakeH :: SessionParams 103handshakeH :: SessionParams
103 -> SockAddr 104 -> Multi.SessionAddress
104 -> Handshake Encrypted 105 -> Handshake Encrypted
105 -> IO (Maybe a) 106 -> IO (Maybe a)
106handshakeH sp saddr handshake = do 107handshakeH sp saddr handshake = do
@@ -111,7 +112,7 @@ handshakeH sp saddr handshake = do
111 112
112 113
113plainHandshakeH :: SessionParams 114plainHandshakeH :: SessionParams
114 -> SockAddr 115 -> Multi.SessionAddress
115 -> SecretKey 116 -> SecretKey
116 -> Handshake Identity 117 -> Handshake Identity
117 -> IO () 118 -> IO ()
@@ -177,7 +178,7 @@ data SessionKeys = SessionKeys
177 } 178 }
178 179
179-- | Decrypt an inbound session packet and update the nonce for the next one. 180-- | Decrypt an inbound session packet and update the nonce for the next one.
180decryptPacket :: SessionKeys -> SockAddr -> CryptoPacket Encrypted -> IO (Maybe (CryptoPacket Identity, ())) 181decryptPacket :: SessionKeys -> addr -> CryptoPacket Encrypted -> IO (Maybe (CryptoPacket Identity, ()))
181decryptPacket sk saddr (CryptoPacket n16 ciphered) = do 182decryptPacket sk saddr (CryptoPacket n16 ciphered) = do
182 (n24,δ) <- atomically $ do 183 (n24,δ) <- atomically $ do
183 n <- readTVar (skNonceIncoming sk) 184 n <- readTVar (skNonceIncoming sk)
diff --git a/dht/src/Network/Tox/TCP.hs b/dht/src/Network/Tox/TCP.hs
index 4b3a4594..dc4c9967 100644
--- a/dht/src/Network/Tox/TCP.hs
+++ b/dht/src/Network/Tox/TCP.hs
@@ -21,6 +21,7 @@ import Data.Functor.Contravariant
21import Data.Functor.Identity 21import Data.Functor.Identity
22import Data.Hashable 22import Data.Hashable
23import qualified Data.HashMap.Strict as HashMap 23import qualified Data.HashMap.Strict as HashMap
24import qualified Data.IntMap.Strict as IntMap
24import Data.IP 25import Data.IP
25import Data.Maybe 26import Data.Maybe
26import Data.Monoid 27import Data.Monoid
@@ -48,9 +49,9 @@ import Network.Kademlia.Search hiding (sendQuery)
48import Network.QueryResponse 49import Network.QueryResponse
49import Network.QueryResponse.TCP 50import Network.QueryResponse.TCP
50import Network.Tox.TCP.NodeId () 51import Network.Tox.TCP.NodeId ()
51import Network.Tox.DHT.Handlers (toxSpace) 52import Network.Tox.DHT.Transport (toxSpace)
52import Network.Tox.Onion.Transport hiding (encrypt,decrypt) 53import Network.Tox.Onion.Transport hiding (encrypt,decrypt)
53import Network.Tox.Onion.Handlers (unwrapAnnounceResponse) 54import Network.Tox.Onion.Transport (unwrapAnnounceResponse)
54import qualified Network.Tox.NodeId as UDP 55import qualified Network.Tox.NodeId as UDP
55import Text.XXD 56import Text.XXD
56import Data.Proxy 57import Data.Proxy
@@ -72,8 +73,8 @@ nodeIP :: NodeInfo -> IP
72nodeIP ni = UDP.nodeIP $ udpNodeInfo ni 73nodeIP ni = UDP.nodeIP $ udpNodeInfo ni
73 74
74tcpStream :: (Show y, Show x, Serialize y, Sized y, Serialize x, Sized x) => 75tcpStream :: (Show y, Show x, Serialize y, Sized y, Serialize x, Sized x) =>
75 TransportCrypto -> StreamHandshake NodeInfo x y 76 TransportCrypto -> (NodeInfo -> IO st) -> StreamHandshake NodeInfo (st,x) y
76tcpStream crypto = StreamHandshake 77tcpStream crypto mkst = StreamHandshake
77 { streamHello = \addr h -> do 78 { streamHello = \addr h -> do
78 (skey, hello) <- atomically $ do 79 (skey, hello) <- atomically $ do
79 n24 <- transportNewNonce crypto 80 n24 <- transportNewNonce crypto
@@ -113,6 +114,7 @@ tcpStream crypto = StreamHandshake
113 nread <- newMVar (sessionBaseNonce $ runIdentity $ welcomeData welcome) 114 nread <- newMVar (sessionBaseNonce $ runIdentity $ welcomeData welcome)
114 let them = sessionPublicKey $ runIdentity $ welcomeData welcome 115 let them = sessionPublicKey $ runIdentity $ welcomeData welcome
115 hvar <- newMVar h 116 hvar <- newMVar h
117 st <- mkst addr
116 return SessionProtocol 118 return SessionProtocol
117 { streamGoodbye = do 119 { streamGoodbye = do
118 dput XTCP $ "Closing " ++ show addr 120 dput XTCP $ "Closing " ++ show addr
@@ -138,7 +140,7 @@ tcpStream crypto = StreamHandshake
138 dput XTCP $ "TCP:" ++ show addr ++ " --> " ++ show x' 140 dput XTCP $ "TCP:" ++ show addr ++ " --> " ++ show x'
139 return ()) 141 return ())
140 r 142 r
141 return $ either (const Nothing) Just r 143 return $ either (const Nothing) (Just . (,) st) r
142 in bracket (takeMVar hvar) (putMVar hvar) 144 in bracket (takeMVar hvar) (putMVar hvar)
143 $ \h -> go h `catchIOError` \e -> do 145 $ \h -> go h `catchIOError` \e -> do
144 dput XTCP $ "TCP exception: " ++ show e 146 dput XTCP $ "TCP exception: " ++ show e
@@ -158,9 +160,26 @@ tcpStream crypto = StreamHandshake
158 , streamAddr = nodeAddr 160 , streamAddr = nodeAddr
159 } 161 }
160 162
161toxTCP :: TransportCrypto -> IO ( TCPCache (SessionProtocol RelayPacket RelayPacket) 163newtype SessionData = SessionData (MVar (IntMap.IntMap NodeId))
162 , TransportA err NodeInfo RelayPacket (Bool,RelayPacket) ) 164
163toxTCP crypto = tcpTransport 30 (tcpStream crypto) 165newSessionData :: NodeInfo -> IO SessionData
166newSessionData _ = SessionData <$> newMVar IntMap.empty
167
168getRelayedRemote :: SessionData -> ConId -> IO NodeId
169getRelayedRemote (SessionData keymapVar) (ConId i) = do
170 keymap <- takeMVar keymapVar
171 let k = fromMaybe UDP.zeroID $ IntMap.lookup (fromIntegral i) keymap
172 putMVar keymapVar keymap
173 return k
174
175setRelayedRemote :: SessionData -> ConId -> NodeId -> IO ()
176setRelayedRemote (SessionData keymapVar) (ConId conid) nid = do
177 keymap <- takeMVar keymapVar
178 putMVar keymapVar $ IntMap.insert (fromIntegral conid) nid keymap
179
180toxTCP :: TransportCrypto -> IO ( TCPCache (SessionProtocol (SessionData,RelayPacket) RelayPacket)
181 , TransportA err NodeInfo (SessionData,RelayPacket) (Bool,RelayPacket) )
182toxTCP crypto = tcpTransport 30 (tcpStream crypto newSessionData)
164 183
165tcpSpace :: KademliaSpace NodeId NodeInfo 184tcpSpace :: KademliaSpace NodeId NodeInfo
166tcpSpace = contramap udpNodeInfo toxSpace 185tcpSpace = contramap udpNodeInfo toxSpace
@@ -292,6 +311,8 @@ keyToNonce k = unsafeDupablePerformIO $ withByteArray k $ \ptr -> do
292 w8 <- peek ptr 311 w8 <- peek ptr
293 return $ Nonce8 w8 312 return $ Nonce8 w8
294 313
314type RelayCache = TCPCache (SessionProtocol (SessionData,RelayPacket) RelayPacket)
315
295-- | Create a new TCP relay client. Because polymorphic existential record 316-- | Create a new TCP relay client. Because polymorphic existential record
296-- updates are currently hard with GHC, this function accepts parameters for 317-- updates are currently hard with GHC, this function accepts parameters for
297-- generalizing the table-entry type for pending transactions. Safe trivial 318-- generalizing the table-entry type for pending transactions. Safe trivial
@@ -301,14 +322,18 @@ newClient :: TransportCrypto
301 -> ((Maybe (Bool,RelayPacket) -> IO ()) -> a) -- ^ store mvar for query 322 -> ((Maybe (Bool,RelayPacket) -> IO ()) -> a) -- ^ store mvar for query
302 -> (a -> RelayPacket -> IO void) -- ^ load mvar for query 323 -> (a -> RelayPacket -> IO void) -- ^ load mvar for query
303 -> IO ( ( TVar (ChaChaDRG, Data.Word64Map.Word64Map a) 324 -> IO ( ( TVar (ChaChaDRG, Data.Word64Map.Word64Map a)
304 , TCPCache (SessionProtocol RelayPacket RelayPacket) ) 325 , RelayCache
326 , Transport String ViaRelay ByteString )
305 , Client String PacketNumber Nonce8 NodeInfo (Bool,RelayPacket)) 327 , Client String PacketNumber Nonce8 NodeInfo (Bool,RelayPacket))
306newClient crypto store load = do 328newClient crypto store load = do
307 (tcpcache,net) <- toxTCP crypto 329 (tcpcache,net0) <- toxTCP crypto
330 (relaynet,net1) <- partitionRelay net0
331 let net2 = {- XXX: Client type forces this pointless layering. -}
332 layerTransport ((Right .) . (,) . (,) False . snd) (,) net1
308 drg <- drgNew 333 drg <- drgNew
309 map_var <- atomically $ newTVar (drg, Data.Word64Map.empty) 334 map_var <- atomically $ newTVar (drg, Data.Word64Map.empty)
310 return $ (,) (map_var,tcpcache) Client 335 return $ (,) (map_var,tcpcache,relaynet) Client
311 { clientNet = {- XXX: Client type forces this pointless layering. -} layerTransport ((Right .) . (,) . (,) False) (,) net 336 { clientNet = net2
312 , clientDispatcher = DispatchMethods 337 , clientDispatcher = DispatchMethods
313 { classifyInbound = (. snd) $ \case 338 { classifyInbound = (. snd) $ \case
314 RelayPing n -> IsQuery PingPacket n 339 RelayPing n -> IsQuery PingPacket n
@@ -318,7 +343,7 @@ newClient crypto store load = do
318 OnionPacketResponse (OnionAnnounceResponse n8 n24 ciphered) -> IsResponse n8 343 OnionPacketResponse (OnionAnnounceResponse n8 n24 ciphered) -> IsResponse n8
319 OnionPacketResponse o@(OnionToRouteResponse _) -> IsUnsolicited $ handle2route o 344 OnionPacketResponse o@(OnionToRouteResponse _) -> IsUnsolicited $ handle2route o
320 OOBRecv k bs -> IsUnsolicited $ handleOOB k bs 345 OOBRecv k bs -> IsUnsolicited $ handleOOB k bs
321 wut -> IsUnknown (show wut) 346 wut -> IsUnknown (show wut)
322 , lookupHandler = \case 347 , lookupHandler = \case
323 PingPacket -> trace ("tcp-received-ping") $ Just MethodHandler 348 PingPacket -> trace ("tcp-received-ping") $ Just MethodHandler
324 { methodParse = \case (_,RelayPing n8) -> Right () 349 { methodParse = \case (_,RelayPing n8) -> Right ()
@@ -330,7 +355,10 @@ newClient crypto store load = do
330 { methodParse = \x -> Left "tcp-lookuphandler?" -- :: x -> Either err a 355 { methodParse = \x -> Left "tcp-lookuphandler?" -- :: x -> Either err a
331 , noreplyAction = \addr a -> dput XTCP $ "tcp-lookupHandler: "++show w 356 , noreplyAction = \addr a -> dput XTCP $ "tcp-lookupHandler: "++show w
332 } 357 }
333 , tableMethods = transactionMethods' store (\x -> mapM_ (load x . snd)) (contramap (\(Nonce8 w64) -> w64) w64MapMethods) 358 , tableMethods = transactionMethods'
359 store
360 (\x -> mapM_ (load x . snd))
361 (contramap (\(Nonce8 w64) -> w64) w64MapMethods)
334 $ first (either error Nonce8 . decode) . randomBytesGenerate 8 362 $ first (either error Nonce8 . decode) . randomBytesGenerate 8
335 } 363 }
336 , clientErrorReporter = logErrors 364 , clientErrorReporter = logErrors
@@ -341,3 +369,27 @@ newClient crypto store load = do
341 } 369 }
342 , clientResponseId = return 370 , clientResponseId = return
343 } 371 }
372
373data ViaRelay = ViaRelay (Maybe ConId) UDP.NodeId NodeInfo
374 deriving (Eq,Ord,Show)
375
376partitionRelay :: TransportA err NodeInfo (SessionData,RelayPacket) (Bool,RelayPacket)
377 -> IO ( Transport err ViaRelay ByteString
378 , TransportA err NodeInfo (SessionData,RelayPacket) (Bool,RelayPacket))
379partitionRelay tr = partitionTransportM parse encode tr
380 where
381 parse :: ((SessionData,RelayPacket), NodeInfo) -> IO (Either (ByteString, ViaRelay) ((SessionData,RelayPacket),NodeInfo))
382 parse ((st,RelayData bs conid), ni) = do
383 nid <- getRelayedRemote st conid
384 return $ Left (bs, ViaRelay (Just conid) nid ni)
385 parse ((_,OOBRecv key bs), ni) =
386 return $ Left (bs, ViaRelay Nothing (UDP.key2id key) ni)
387 parse passthrough@((st,RoutingResponse conid k),ni) = do
388 setRelayedRemote st conid (UDP.key2id k)
389 return $ Right passthrough
390 parse passthrough =
391 return $ Right passthrough
392
393 encode :: (ByteString, ViaRelay) -> IO (Maybe ((Bool,RelayPacket), NodeInfo))
394 encode (bs, ViaRelay (Just conid) _ ni) = return $ Just ((False,RelayData bs conid), ni)
395 encode (bs, ViaRelay Nothing nid ni) = return $ Just ((False,OOBSend (UDP.id2key nid) bs), ni)
diff --git a/dht/src/Network/Tox/Transport.hs b/dht/src/Network/Tox/Transport.hs
index 7728ba7a..0ca9b758 100644
--- a/dht/src/Network/Tox/Transport.hs
+++ b/dht/src/Network/Tox/Transport.hs
@@ -11,43 +11,73 @@ module Network.Tox.Transport (toxTransport, RouteId) where
11import Network.QueryResponse 11import Network.QueryResponse
12import Crypto.Tox 12import Crypto.Tox
13import Data.Tox.Relay as TCP 13import Data.Tox.Relay as TCP
14import qualified Data.Tox.DHT.Multi as Multi
14import Network.Tox.DHT.Transport as UDP 15import Network.Tox.DHT.Transport as UDP
16import Network.Tox.TCP (ViaRelay)
15import Network.Tox.Onion.Transport 17import Network.Tox.Onion.Transport
16import Network.Tox.Crypto.Transport 18import Network.Tox.Crypto.Transport
17import Network.Tox.Onion.Routes 19import Network.Tox.Onion.Routes
18 20
19import Control.Concurrent.STM 21import Control.Concurrent.STM
22import qualified Data.ByteString as B
23import qualified Data.Dependent.Map as DMap
24import Data.Dependent.Sum
25import Data.Functor.Identity
20import Network.Socket 26import Network.Socket
21 27
28pendingCookiesUDP :: TransportCrypto -> STM [(SockAddr, (Int, PublicKey))]
29pendingCookiesUDP crypto = readTVar $ pendingCookies crypto
30
31pendingCookiesTCP :: TransportCrypto -> STM [(ViaRelay, (Int, PublicKey))]
32pendingCookiesTCP crypto = return [] -- TODO
33
22toxTransport :: 34toxTransport ::
23 TransportCrypto 35 TransportCrypto
24 -> OnionRouter 36 -> OnionRouter
25 -> (PublicKey -> IO (Maybe UDP.NodeInfo)) 37 -> (PublicKey -> IO (Maybe UDP.NodeInfo))
26 -> SockAddr -- ^ UDP bind-address 38 -> SockAddr -- ^ UDP bind-address
27 -> UDPTransport 39 -> UDPTransport
40 -> Transport String ViaRelay B.ByteString
28 -> (TCP.NodeInfo -> RelayPacket -> IO ()) -- ^ TCP server-bound callback. 41 -> (TCP.NodeInfo -> RelayPacket -> IO ()) -- ^ TCP server-bound callback.
29 -> (Int -> OnionMessage Encrypted -> IO ()) -- ^ TCP client-bound callback. 42 -> (Int -> OnionMessage Encrypted -> IO ()) -- ^ TCP client-bound callback.
30 -> IO ( Transport String SockAddr (CryptoPacket Encrypted) 43 -> IO ( Transport String Multi.SessionAddress (CryptoPacket Encrypted)
31 , Transport String UDP.NodeInfo (DHTMessage Encrypted8) 44 , Transport String Multi.NodeInfo (DHTMessage Encrypted8)
32 , Transport String (OnionDestination RouteId) (OnionMessage Encrypted) 45 , Transport String (OnionDestination RouteId) (OnionMessage Encrypted)
33 , Transport String AnnouncedRendezvous (PublicKey,OnionData) 46 , Transport String AnnouncedRendezvous (PublicKey,OnionData)
34 , Transport String SockAddr (Handshake Encrypted)) 47 , Transport String Multi.SessionAddress (Handshake Encrypted))
35toxTransport crypto orouter closeLookup addr udp tcp2server tcp2client = do 48toxTransport crypto orouter closeLookup addr udp relaynet tcp2server tcp2client = do
36 (netcrypto, udp0) <- partitionTransport parseCrypto encodeCrypto udp 49 (netcrypto, udp0) <- partitionTransport parseCrypto encodeCrypto udp
37 (dht,udp1) <- partitionTransportM (parseDHTAddr (readTVar $ pendingCookies crypto) nodeInfo) 50 (dhtUDP,udp1) <- partitionTransportM (parseDHTAddr (pendingCookiesUDP crypto) nodeInfo)
38 (fmap Just . encodeDHTAddr nodeAddr) 51 (fmap Just . encodeDHTAddr nodeAddr)
39 $ forwardOnions crypto addr udp0 tcp2client 52 $ forwardOnions crypto addr udp0 tcp2client
53 -- rlynet0 = layerTransportM (DHT.decrypt crypto Multi.relayNodeId) (DHT.encrypt crypto Multi.relayNodeId) relaynet
54 (dhtTCP,relaynet0) <- partitionTransportM
55 (parseDHTAddr (pendingCookiesTCP crypto) (\nid viarelay -> Right viarelay))
56 (fmap Just . encodeDHTAddr id)
57 relaynet
58 let _ = dhtTCP :: Transport String ViaRelay (DHTMessage Encrypted8)
59 dht <- mergeTransports $ DMap.fromList
60 [ Multi.UDP :=> ByAddress dhtUDP
61 , Multi.TCP :=> ByAddress dhtTCP
62 ]
40 (onion1,udp2) <- partitionAndForkTransport tcp2server 63 (onion1,udp2) <- partitionAndForkTransport tcp2server
41 (parseOnionAddr $ lookupSender orouter) 64 (parseOnionAddr $ lookupSender orouter)
42 (encodeOnionAddr crypto $ lookupRoute orouter) 65 (encodeOnionAddr crypto $ lookupRoute orouter)
43 udp1 66 udp1
44 (dta,onion) <- partitionTransportM (parseDataToRoute crypto) (encodeDataToRoute crypto) onion1 67 (dta,onion) <- partitionTransportM (parseDataToRoute crypto) (encodeDataToRoute crypto) onion1
45 let handshakes = layerTransport parseHandshakes encodeHandshakes udp2 68 let handshakes = layerTransport parseHandshakes encodeHandshakes udp2
46 return ( netcrypto 69 promoteUDP :: TransportA err SockAddr x y -> TransportA err Multi.SessionAddress x y
47 , forwardDHTRequests crypto closeLookup dht 70 promoteUDP net = layerTransport (\msg saddr -> Right (msg,Multi.SessionUDP ==> saddr))
71 (\msg (Multi.SessionUDP :=> Identity saddr) -> (msg,saddr))
72 net
73 -- TODO: Enable sessions over TCP
74 multi_netcrypto = promoteUDP netcrypto
75 multi_handshakes = promoteUDP handshakes
76 return ( multi_netcrypto
77 , forwardDHTRequests crypto (fmap (fmap (Multi.UDP ==>)) . closeLookup) dht
48 , onion 78 , onion
49 , dta 79 , dta
50 , handshakes 80 , multi_handshakes
51 ) 81 )
52 82
53 83
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-14 09:33:26 +0000