summaryrefslogtreecommitdiff
path: root/src/Network
diff options
context:
space:
mode:
Diffstat (limited to 'src/Network')
-rw-r--r--src/Network/QueryResponse.hs46
-rw-r--r--src/Network/Tox.hs56
-rw-r--r--src/Network/Tox/Onion/Transport.hs1069
-rw-r--r--src/Network/Tox/TCP.hs57
-rw-r--r--src/Network/Tox/Transport.hs22
5 files changed, 160 insertions, 1090 deletions
diff --git a/src/Network/QueryResponse.hs b/src/Network/QueryResponse.hs
index 4e110ec3..0fbbc929 100644
--- a/src/Network/QueryResponse.hs
+++ b/src/Network/QueryResponse.hs
@@ -134,6 +134,35 @@ partitionTransportM parse encodex tr = do
134 } 134 }
135 return (xtr, ytr) 135 return (xtr, ytr)
136 136
137partitionAndForkTransport ::
138 (dst -> msg -> IO ())
139 -> ((b,a) -> IO (Either (x,xaddr) (b,a)))
140 -> ((x,xaddr) -> IO (Maybe (Either (msg,dst) (b,a))))
141 -> Transport err a b
142 -> IO (Transport err xaddr x, Transport err a b)
143partitionAndForkTransport forkedSend parse encodex tr = do
144 mvar <- newEmptyMVar
145 let xtr = tr { awaitMessage = \kont -> fix $ \again -> do
146 awaitMessage tr $ \m -> case m of
147 Just (Right msg) -> parse msg >>=
148 either (kont . Just . Right)
149 (\y -> putMVar mvar y >> again)
150 Just (Left e) -> kont $ Just (Left e)
151 Nothing -> kont Nothing
152 , sendMessage = \addr' msg' -> do
153 msg_addr <- encodex (msg',addr')
154 case msg_addr of
155 Just (Right (b,a)) -> sendMessage tr a b
156 Just (Left (msg,dst)) -> forkedSend dst msg
157 Nothing -> return ()
158 }
159 ytr = Transport
160 { awaitMessage = \kont -> takeMVar mvar >>= kont . Just . Right
161 , sendMessage = sendMessage tr
162 , closeTransport = return ()
163 }
164 return (xtr, ytr)
165
137-- | 166-- |
138-- * f add x --> Nothing, consume x 167-- * f add x --> Nothing, consume x
139-- --> Just id, leave x to a different handler 168-- --> Just id, leave x to a different handler
@@ -376,16 +405,27 @@ transactionMethods ::
376 TableMethods t tid -- ^ Table methods to lookup values by /tid/. 405 TableMethods t tid -- ^ Table methods to lookup values by /tid/.
377 -> (g -> (tid,g)) -- ^ Generate a new unique /tid/ value and update the generator state /g/. 406 -> (g -> (tid,g)) -- ^ Generate a new unique /tid/ value and update the generator state /g/.
378 -> TransactionMethods (g,t (MVar x)) tid addr x 407 -> TransactionMethods (g,t (MVar x)) tid addr x
379transactionMethods (TableMethods insert delete lookup) generate = TransactionMethods 408transactionMethods methods generate = transactionMethods' id tryPutMVar methods generate
409
410-- | Like 'transactionMethods' but allows extra information to be stored in the
411-- table of pending transactions. This also enables multiple 'Client's to
412-- share a single transaction table.
413transactionMethods' ::
414 (MVar x -> a) -- ^ store MVar into table entry
415 -> (a -> x -> IO void) -- ^ load MVar from table entry
416 -> TableMethods t tid -- ^ Table methods to lookup values by /tid/.
417 -> (g -> (tid,g)) -- ^ Generate a new unique /tid/ value and update the generator state /g/.
418 -> TransactionMethods (g,t a) tid addr x
419transactionMethods' store load (TableMethods insert delete lookup) generate = TransactionMethods
380 { dispatchCancel = \tid (g,t) -> return (g, delete tid t) 420 { dispatchCancel = \tid (g,t) -> return (g, delete tid t)
381 , dispatchRegister = \v _ (g,t) -> 421 , dispatchRegister = \v _ (g,t) ->
382 let (tid,g') = generate g 422 let (tid,g') = generate g
383 t' = insert tid v t 423 t' = insert tid (store v) t
384 in return ( tid, (g',t') ) 424 in return ( tid, (g',t') )
385 , dispatchResponse = \tid x (g,t) -> 425 , dispatchResponse = \tid x (g,t) ->
386 case lookup tid t of 426 case lookup tid t of
387 Just v -> let t' = delete tid t 427 Just v -> let t' = delete tid t
388 in return ((g,t'),void $ tryPutMVar v x) 428 in return ((g,t'),void $ load v x)
389 Nothing -> return ((g,t), return ()) 429 Nothing -> return ((g,t), return ())
390 } 430 }
391 431
diff --git a/src/Network/Tox.hs b/src/Network/Tox.hs
index ef74b9c6..6e2a42c5 100644
--- a/src/Network/Tox.hs
+++ b/src/Network/Tox.hs
@@ -1,4 +1,5 @@
1{-# LANGUAGE CPP #-} 1{-# LANGUAGE CPP #-}
2{-# LANGUAGE FlexibleContexts #-}
2{-# LANGUAGE DeriveDataTypeable #-} 3{-# LANGUAGE DeriveDataTypeable #-}
3{-# LANGUAGE DeriveFoldable #-} 4{-# LANGUAGE DeriveFoldable #-}
4{-# LANGUAGE DeriveFunctor #-} 5{-# LANGUAGE DeriveFunctor #-}
@@ -32,6 +33,7 @@ import qualified Data.ByteString as B
32 ;import Data.ByteString (ByteString) 33 ;import Data.ByteString (ByteString)
33import qualified Data.ByteString.Char8 as C8 34import qualified Data.ByteString.Char8 as C8
34import Data.Data 35import Data.Data
36import Data.Functor.Identity
35import Data.Functor.Contravariant 37import Data.Functor.Contravariant
36import Data.Maybe 38import Data.Maybe
37import qualified Data.MinMaxPSQ as MinMaxPSQ 39import qualified Data.MinMaxPSQ as MinMaxPSQ
@@ -42,6 +44,7 @@ import Network.Socket
42import System.Endian 44import System.Endian
43import System.IO.Error 45import System.IO.Error
44 46
47import qualified Data.Word64Map
45import Network.BitTorrent.DHT.Token as Token 48import Network.BitTorrent.DHT.Token as Token
46import qualified Data.Wrapper.PSQ as PSQ 49import qualified Data.Wrapper.PSQ as PSQ
47import System.Global6 50import System.Global6
@@ -68,6 +71,7 @@ import DebugTag
68import TCPProber 71import TCPProber
69import Network.Tox.Avahi 72import Network.Tox.Avahi
70import Network.Tox.Session 73import Network.Tox.Session
74import qualified Data.Tox.Relay as TCP
71import Network.Tox.Relay 75import Network.Tox.Relay
72import Network.SessionTransports 76import Network.SessionTransports
73import Network.Kademlia.Search 77import Network.Kademlia.Search
@@ -238,6 +242,37 @@ getOnionAlias crypto dhtself remoteNode = atomically $ do
238 _ -> ni { nodeId = key2id (onionAliasPublic crypto) } 242 _ -> ni { nodeId = key2id (onionAliasPublic crypto) }
239 return $ Onion.OnionDestination Onion.SearchingAlias alias Nothing 243 return $ Onion.OnionDestination Onion.SearchingAlias alias Nothing
240 244
245newOnionClient :: DRG g =>
246 TransportCrypto
247 -> Transport String (Onion.OnionDestination RouteId) Onion.Message
248 -> DHT.Routing
249 -> TVar SessionTokens
250 -> TVar Onion.AnnouncedKeys
251 -> OnionRouter
252 -> TVar (g, Data.Word64Map.Word64Map a)
253 -> (MVar Onion.Message -> a)
254 -> (a -> Onion.Message -> IO void)
255 -> Client String
256 DHT.PacketKind
257 DHT.TransactionId
258 (Onion.OnionDestination RouteId)
259 Onion.Message
260newOnionClient crypto net r toks keydb orouter map_var store load = Client
261 { clientNet = net
262 , clientDispatcher = DispatchMethods
263 { classifyInbound = Onion.classify
264 , lookupHandler = Onion.handlers net r toks keydb
265 , tableMethods = hookQueries orouter DHT.transactionKey
266 $ transactionMethods' store load (contramap w64Key w64MapMethods) gen
267 }
268 , clientErrorReporter = logErrors { reportTimeout = reportTimeout ignoreErrors }
269 , clientPending = map_var
270 , clientAddress = getOnionAlias crypto $ R.thisNode <$> readTVar (DHT.routing4 r)
271 , clientResponseId = genNonce24 map_var
272 , clientEnterQuery = \_ -> return ()
273 , clientLeaveQuery = \_ _ -> return ()
274 }
275
241newTox :: TVar Onion.AnnouncedKeys -- ^ Store of announced keys we are a rendezvous for. 276newTox :: TVar Onion.AnnouncedKeys -- ^ Store of announced keys we are a rendezvous for.
242 -> [String] -- ^ Bind-address to listen on. Must provide at least one. 277 -> [String] -- ^ Bind-address to listen on. Must provide at least one.
243 -> ( ContactInfo extra -> SockAddr -> Session -> IO () ) 278 -> ( ContactInfo extra -> SockAddr -> Session -> IO () )
@@ -287,8 +322,11 @@ newToxOverTransport keydb addr onNewSession suppliedDHTKey udp tcp = do
287 let lookupClose _ = return Nothing 322 let lookupClose _ = return Nothing
288 323
289 mkrouting <- DHT.newRouting addr crypto updateIP updateIP 324 mkrouting <- DHT.newRouting addr crypto updateIP updateIP
290 orouter <- newOnionRouter crypto $ dput XRoutes 325 (orouter,otbl) <- newOnionRouter crypto (dput XRoutes)
291 (cryptonet,dhtcrypt,onioncrypt,dtacrypt,handshakes) <- toxTransport crypto orouter lookupClose udp tcp 326 (cryptonet,dhtcrypt,onioncrypt,dtacrypt,handshakes)
327 <- toxTransport crypto orouter lookupClose udp
328 (sendMessage (clientNet $ tcpClient $ tcpKademliaClient orouter))
329 tcp
292 sessions <- initSessions (sendMessage cryptonet) 330 sessions <- initSessions (sendMessage cryptonet)
293 331
294 let dhtnet0 = layerTransportM (DHT.decrypt crypto) (DHT.encrypt crypto) dhtcrypt 332 let dhtnet0 = layerTransportM (DHT.decrypt crypto) (DHT.encrypt crypto) dhtcrypt
@@ -296,7 +334,7 @@ newToxOverTransport keydb addr onNewSession suppliedDHTKey udp tcp = do
296 tbl6 = DHT.routing6 $ mkrouting (error "missing client") 334 tbl6 = DHT.routing6 $ mkrouting (error "missing client")
297 updateOnion bkts tr = hookBucketList DHT.toxSpace bkts orouter (trampolinesUDP orouter) tr 335 updateOnion bkts tr = hookBucketList DHT.toxSpace bkts orouter (trampolinesUDP orouter) tr
298 dhtclient <- newClient drg dhtnet0 DHT.classify (myAddr tbl4 tbl6) (DHT.handlers crypto . mkrouting) id 336 dhtclient <- newClient drg dhtnet0 DHT.classify (myAddr tbl4 tbl6) (DHT.handlers crypto . mkrouting) id
299 $ \client net -> onInbound (DHT.updateRouting client (mkrouting client) updateOnion) net 337 (\client net -> onInbound (DHT.updateRouting client (mkrouting client) updateOnion) net)
300 338
301 hscache <- newHandshakeCache crypto (sendMessage handshakes) 339 hscache <- newHandshakeCache crypto (sendMessage handshakes)
302 let sparams = SessionParams 340 let sparams = SessionParams
@@ -315,13 +353,13 @@ newToxOverTransport keydb addr onNewSession suppliedDHTKey udp tcp = do
315 toks <- do 353 toks <- do
316 nil <- nullSessionTokens 354 nil <- nullSessionTokens
317 atomically $ newTVar nil { maxInterval = 20 } -- 20 second timeout on announce ping-ids. 355 atomically $ newTVar nil { maxInterval = 20 } -- 20 second timeout on announce ping-ids.
318 oniondrg <- drgNew
319 let onionnet = layerTransportM (Onion.decrypt crypto) (Onion.encrypt crypto) onioncrypt 356 let onionnet = layerTransportM (Onion.decrypt crypto) (Onion.encrypt crypto) onioncrypt
320 onionclient <- newClient oniondrg onionnet (const Onion.classify) 357 let onionclient = newOnionClient crypto onionnet (mkrouting dhtclient) toks keydb orouter' otbl
321 (getOnionAlias crypto $ R.thisNode <$> readTVar (DHT.routing4 $ mkrouting dhtclient)) 358 Right $ \case
322 (const $ Onion.handlers onionnet (mkrouting dhtclient) toks keydb) 359 Right v -> tryPutMVar v
323 (hookQueries orouter' DHT.transactionKey) 360 Left v -> \_ -> do
324 (const id) 361 dput XUnexpected "TCP-sent onion query got response over UDP?"
362 return False
325 363
326 return Tox 364 return Tox
327 { toxDHT = dhtclient 365 { toxDHT = dhtclient
diff --git a/src/Network/Tox/Onion/Transport.hs b/src/Network/Tox/Onion/Transport.hs
index 8918f913..e746c414 100644
--- a/src/Network/Tox/Onion/Transport.hs
+++ b/src/Network/Tox/Onion/Transport.hs
@@ -1,21 +1,3 @@
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE DataKinds #-}
3{-# LANGUAGE DeriveDataTypeable #-}
4{-# LANGUAGE FlexibleContexts #-}
5{-# LANGUAGE FlexibleInstances #-}
6{-# LANGUAGE GADTs #-}
7{-# LANGUAGE GeneralizedNewtypeDeriving #-}
8{-# LANGUAGE KindSignatures #-}
9{-# LANGUAGE LambdaCase #-}
10{-# LANGUAGE MultiParamTypeClasses #-}
11{-# LANGUAGE PartialTypeSignatures #-}
12{-# LANGUAGE RankNTypes #-}
13{-# LANGUAGE ScopedTypeVariables #-}
14{-# LANGUAGE StandaloneDeriving #-}
15{-# LANGUAGE TupleSections #-}
16{-# LANGUAGE TypeFamilies #-}
17{-# LANGUAGE TypeOperators #-}
18{-# LANGUAGE UndecidableInstances #-}
19module Network.Tox.Onion.Transport 1module Network.Tox.Onion.Transport
20 ( parseOnionAddr 2 ( parseOnionAddr
21 , encodeOnionAddr 3 , encodeOnionAddr
@@ -58,856 +40,51 @@ module Network.Tox.Onion.Transport
58 , wrapOnionPure 40 , wrapOnionPure
59 ) where 41 ) where
60 42
61import Network.Address (fromSockAddr,toSockAddr,setPort,either4or6,sockAddrPort) 43import Data.ByteString (ByteString)
62import Network.QueryResponse 44import Data.Serialize
63import Crypto.Tox hiding (encrypt,decrypt)
64import Network.Tox.NodeId
65import qualified Crypto.Tox as ToxCrypto
66import Network.Tox.DHT.Transport (NodeInfo(..),NodeId(..),SendNodes(..),nodeInfo,DHTPublicKey(..),FriendRequest,asymNodeInfo)
67
68import Control.Applicative
69import Control.Arrow
70import Control.Concurrent.STM
71import Control.Monad
72import qualified Data.ByteString as B
73 ;import Data.ByteString (ByteString)
74import Data.Data
75import Data.Function
76import Data.Functor.Contravariant
77import Data.Functor.Identity
78#if MIN_VERSION_iproute(1,7,4)
79import Data.IP hiding (fromSockAddr)
80#else
81import Data.IP
82#endif
83import Data.Maybe
84import Data.Monoid
85import Data.Serialize as S
86import Data.Type.Equality
87import Data.Typeable
88import Data.Word
89import GHC.Generics ()
90import GHC.TypeLits
91import Network.Socket 45import Network.Socket
92import qualified Text.ParserCombinators.ReadP as RP
93import Data.Hashable
94import DPut
95import DebugTag
96import Data.Word64Map (fitsInInt)
97import Data.Bits (shiftR,shiftL)
98import qualified Rank2
99
100type HandleLo a = Maybe (Either String (ByteString, SockAddr)) -> IO a
101
102type UDPTransport = Transport String SockAddr ByteString
103
104
105getOnionAsymm :: Get (Asymm (Encrypted DataToRoute))
106getOnionAsymm = getAliasedAsymm
107
108putOnionAsymm :: Serialize a => Word8 -> Put -> Asymm a -> Put
109putOnionAsymm typ p a = put typ >> p >> putAliasedAsymm a
110
111data OnionMessage (f :: * -> *)
112 = OnionAnnounce (Asymm (f (AnnounceRequest,Nonce8)))
113 | OnionAnnounceResponse Nonce8 Nonce24 (f AnnounceResponse) -- XXX: Why is Nonce8 transmitted in the clear?
114 | OnionToRoute PublicKey (Asymm (Encrypted DataToRoute)) -- destination key, aliased Asymm
115 | OnionToRouteResponse (Asymm (Encrypted DataToRoute))
116
117deriving instance ( Eq (f (AnnounceRequest, Nonce8))
118 , Eq (f AnnounceResponse)
119 , Eq (f DataToRoute)
120 ) => Eq (OnionMessage f)
121
122deriving instance ( Ord (f (AnnounceRequest, Nonce8))
123 , Ord (f AnnounceResponse)
124 , Ord (f DataToRoute)
125 ) => Ord (OnionMessage f)
126
127deriving instance ( Show (f (AnnounceRequest, Nonce8))
128 , Show (f AnnounceResponse)
129 , Show (f DataToRoute)
130 ) => Show (OnionMessage f)
131
132instance Data (OnionMessage Encrypted) where
133 gfoldl f z txt = z (either error id . S.decode) `f` S.encode txt
134 toConstr _ = error "OnionMessage.toConstr"
135 gunfold _ _ = error "OnionMessage.gunfold"
136#if MIN_VERSION_base(4,2,0)
137 dataTypeOf _ = mkNoRepType "Network.Tox.Onion.Transport.OnionMessage"
138#else
139 dataTypeOf _ = mkNorepType "Network.Tox.Onion.Transport.OnionMessage"
140#endif
141
142instance Rank2.Functor OnionMessage where
143 f <$> m = mapPayload (Proxy :: Proxy Serialize) f m
144
145instance Payload Serialize OnionMessage where
146 mapPayload _ f (OnionAnnounce a) = OnionAnnounce (fmap f a)
147 mapPayload _ f (OnionAnnounceResponse n8 n24 a) = OnionAnnounceResponse n8 n24 (f a)
148 mapPayload _ f (OnionToRoute k a) = OnionToRoute k a
149 mapPayload _ f (OnionToRouteResponse a) = OnionToRouteResponse a
150
151
152msgNonce :: OnionMessage f -> Nonce24
153msgNonce (OnionAnnounce a) = asymmNonce a
154msgNonce (OnionAnnounceResponse _ n24 _) = n24
155msgNonce (OnionToRoute _ a) = asymmNonce a
156msgNonce (OnionToRouteResponse a) = asymmNonce a
157
158data AliasSelector = SearchingAlias | AnnouncingAlias SecretKey PublicKey
159 deriving (Eq,Show)
160
161data OnionDestination r
162 = OnionToOwner
163 { onionNodeInfo :: NodeInfo
164 , onionReturnPath :: ReturnPath N3 -- ^ Somebody else's path to us.
165 }
166 | OnionDestination
167 { onionAliasSelector' :: AliasSelector
168 , onionNodeInfo :: NodeInfo
169 , onionRouteSpec :: Maybe r -- ^ Our own onion-path.
170 }
171 deriving Show
172
173onionAliasSelector :: OnionDestination r -> AliasSelector
174onionAliasSelector (OnionToOwner {} ) = SearchingAlias
175onionAliasSelector (OnionDestination{onionAliasSelector' = sel}) = sel
176
177onionKey :: OnionDestination r -> PublicKey
178onionKey od = id2key . nodeId $ onionNodeInfo od
179
180instance Sized (OnionMessage Encrypted) where
181 size = VarSize $ \case
182 OnionAnnounce a -> case size of ConstSize n -> n + 1
183 VarSize f -> f a + 1
184 OnionAnnounceResponse n8 n24 x -> case size of ConstSize n -> n + 33
185 VarSize f -> f x + 33
186 OnionToRoute pubkey a -> case size of ConstSize n -> n + 33
187 VarSize f -> f a + 33
188 OnionToRouteResponse a -> case size of ConstSize n -> n + 1
189 VarSize f -> f a + 1
190
191instance Serialize (OnionMessage Encrypted) where
192 get = do
193 typ <- get
194 case typ :: Word8 of
195 0x83 -> OnionAnnounce <$> getAliasedAsymm
196 0x85 -> OnionToRoute <$> getPublicKey <*> getAliasedAsymm
197 t -> fail ("Unknown onion payload: " ++ show t)
198 `fromMaybe` getOnionReply t
199 put (OnionAnnounce a) = putWord8 0x83 >> putAliasedAsymm a
200 put (OnionToRoute k a) = putWord8 0x85 >> putPublicKey k >> putAliasedAsymm a
201 put (OnionAnnounceResponse n8 n24 x) = putWord8 0x84 >> put n8 >> put n24 >> put x
202 put (OnionToRouteResponse a) = putWord8 0x86 >> putAliasedAsymm a
203
204onionToOwner :: Asymm a -> ReturnPath N3 -> SockAddr -> Either String (OnionDestination r)
205onionToOwner asymm ret3 saddr = do
206 ni <- nodeInfo (key2id $ senderKey asymm) saddr
207 return $ OnionToOwner ni ret3
208-- data CookieAddress = WithoutCookie NodeInfo | CookieAddress Cookie SockAddr
209
210
211onion :: Sized msg =>
212 ByteString
213 -> SockAddr
214 -> Get (Asymm (Encrypted msg) -> t)
215 -> Either String (t, OnionDestination r)
216onion bs saddr getf = do (f,(asymm,ret3)) <- runGet ((,) <$> getf <*> getOnionRequest) bs
217 oaddr <- onionToOwner asymm ret3 saddr
218 return (f asymm, oaddr)
219
220parseOnionAddr :: (SockAddr -> Nonce8 -> IO (Maybe (OnionDestination r)))
221 -> (ByteString, SockAddr)
222 -> IO (Either (OnionMessage Encrypted,OnionDestination r)
223 (ByteString,SockAddr))
224parseOnionAddr lookupSender (msg,saddr)
225 | Just (typ,bs) <- B.uncons msg
226 , let right = Right (msg,saddr)
227 query = return . either (const right) Left
228 = case typ of
229 0x83 -> query $ onion bs saddr (pure OnionAnnounce) -- Announce Request
230 0x85 -> query $ onion bs saddr (OnionToRoute <$> getPublicKey) -- Onion Data Request
231 _ -> case flip runGet bs <$> getOnionReply typ of
232 Just (Right msg@(OnionAnnounceResponse n8 _ _)) -> do
233 maddr <- lookupSender saddr n8
234 maybe (return right) -- Response unsolicited or too late.
235 (return . Left . \od -> (msg,od))
236 maddr
237 Just (Right msg@(OnionToRouteResponse asym)) -> do
238 let ni = asymNodeInfo saddr asym
239 return $ Left (msg, OnionDestination SearchingAlias ni Nothing)
240 _ -> return right
241
242getOnionReply :: Word8 -> Maybe (Get (OnionMessage Encrypted))
243getOnionReply 0x84 = Just $ OnionAnnounceResponse <$> get <*> get <*> get
244getOnionReply 0x86 = Just $ OnionToRouteResponse <$> getOnionAsymm
245getOnionReply _ = Nothing
246
247putOnionMsg :: OnionMessage Encrypted -> Put
248putOnionMsg (OnionAnnounce a) = putOnionAsymm 0x83 (return ()) a
249putOnionMsg (OnionToRoute pubkey a) = putOnionAsymm 0x85 (putPublicKey pubkey) a
250putOnionMsg (OnionAnnounceResponse n8 n24 x) = put (0x84 :: Word8) >> put n8 >> put n24 >> put x
251putOnionMsg (OnionToRouteResponse a) = putOnionAsymm 0x86 (return ()) a
252
253newtype RouteId = RouteId Int
254 deriving Show
255
256
257-- We used to derive the RouteId from the Nonce8 associated with the query.
258-- This is problematic because a nonce generated by toxcore will not validate
259-- if it is received via a different route than it was issued. This is
260-- described by the Tox spec:
261--
262-- Toxcore generates `ping_id`s by taking a 32 byte sha hash of the current
263-- time, some secret bytes generated when the instance is created, the
264-- current time divided by a 20 second timeout, the public key of the
265-- requester and the source ip/port that the packet was received from. Since
266-- the ip/port that the packet was received from is in the `ping_id`, the
267-- announce packets being sent with a ping id must be sent using the same
268-- path as the packet that we received the `ping_id` from or announcing will
269-- fail.
270--
271-- The original idea was:
272--
273-- > routeId :: Nonce8 -> RouteId
274-- > routeId (Nonce8 w8) = RouteId $ mod (fromIntegral w8) 12
275--
276-- Instead, we'll just hash the destination node id.
277routeId :: NodeId -> RouteId
278routeId nid = RouteId $ mod (hash nid) 12
279 46
47import Crypto.Tox hiding (encrypt,decrypt)
48import qualified Data.Tox.Relay as TCP
49import Data.Tox.Onion
50import Network.Tox.NodeId
280 51
52{-
281encodeOnionAddr :: TransportCrypto 53encodeOnionAddr :: TransportCrypto
282 -> (NodeInfo -> RouteId -> IO (Maybe OnionRoute)) 54 -> (NodeInfo -> RouteId -> IO (Maybe OnionRoute))
283 -> (OnionMessage Encrypted,OnionDestination RouteId) 55 -> (OnionMessage Encrypted,OnionDestination RouteId)
284 -> IO (Maybe (ByteString, SockAddr)) 56 -> IO (Maybe (ByteString, SockAddr))
57-}
58encodeOnionAddr :: TransportCrypto
59 -> (NodeInfo -> RouteId -> IO (Maybe OnionRoute))
60 -> (OnionMessage Encrypted, OnionDestination RouteId)
61 -> IO (Maybe
62 (Either (TCP.RelayPacket, TCP.NodeInfo) (ByteString, SockAddr)))
285encodeOnionAddr crypto _ (msg,OnionToOwner ni p) = 63encodeOnionAddr crypto _ (msg,OnionToOwner ni p) =
286 return $ Just ( runPut $ putResponse (OnionResponse p msg) 64 return $ Just $ Right ( runPut $ putResponse (OnionResponse p msg)
287 , nodeAddr ni ) 65 , nodeAddr ni )
288encodeOnionAddr crypto getRoute (msg,OnionDestination x ni Nothing) = do 66encodeOnionAddr crypto getRoute (msg,OnionDestination x ni Nothing) = do
289 encodeOnionAddr crypto getRoute (msg,OnionDestination x ni (Just $ routeId $ nodeId ni) ) 67 encodeOnionAddr crypto getRoute (msg,OnionDestination x ni (Just $ routeId $ nodeId ni) )
290 -- dput XMisc $ "ONION encode missing routeid" 68 -- dput XMisc $ "ONION encode missing routeid"
291 -- return Nothing 69 -- return Nothing
292encodeOnionAddr crypto getRoute (msg,OnionDestination _ ni (Just rid)) = do 70encodeOnionAddr crypto getRoute (msg,OnionDestination _ ni (Just rid)) = do
293 let go route = do 71 let go route = do
294 req <- wrapForRoute crypto msg ni route 72 mreq <- wrapForRoute crypto msg ni route
295 return ( runPut $ putRequest req 73 case mreq of
296 , nodeAddr $ routeNodeA route) 74 Right req -> return $ Right ( runPut $ putRequest req , nodeAddr $ routeNodeA route)
75 Left o | Just port <- routeRelayPort route
76 -> return $ Left ( o, TCP.NodeInfo (routeNodeA route) port)
297 m <- {-# SCC "encodeOnionAddr.getRoute" #-} getRoute ni rid 77 m <- {-# SCC "encodeOnionAddr.getRoute" #-} getRoute ni rid
298 x <- {-# SCC "encodeOnionAddr.wrapForRoute" #-} mapM go m 78 x <- {-# SCC "encodeOnionAddr.wrapForRoute" #-} mapM go m
299 return x 79 return x
300 80
301 81-- wrapForRoute :: TransportCrypto -> OnionMessage Encrypted -> NodeInfo -> OnionRoute -> IO (OnionRequest N0)
302forwardOnions :: TransportCrypto -> UDPTransport -> (Int -> OnionMessage Encrypted -> IO ()) {- ^ TCP relay send -} -> UDPTransport 82wrapForRoute :: TransportCrypto
303forwardOnions crypto udp sendTCP = udp { awaitMessage = forwardAwait crypto udp sendTCP } 83 -> OnionMessage Encrypted
304 84 -> NodeInfo
305forwardAwait :: TransportCrypto -> UDPTransport -> (Int -> OnionMessage Encrypted -> IO ()) {- ^ TCP relay send -} -> HandleLo a -> IO a 85 -> OnionRoute
306forwardAwait crypto udp sendTCP kont = do 86 -> IO (Either TCP.RelayPacket (OnionRequest N0))
307 fix $ \another -> do 87wrapForRoute crypto msg ni r@OnionRoute{routeRelayPort=Nothing} = do
308 awaitMessage udp $ \case
309 m@(Just (Right (bs,saddr))) -> case B.head bs of
310 0x80 -> forward kont bs $ handleOnionRequest (Proxy :: Proxy N0) crypto (Addressed saddr) udp another
311 0x81 -> forward kont bs $ handleOnionRequest (Proxy :: Proxy N1) crypto (Addressed saddr) udp another
312 0x82 -> forward kont bs $ handleOnionRequest (Proxy :: Proxy N2) crypto (Addressed saddr) udp another
313 0x8c -> forward kont bs $ handleOnionResponse (Proxy :: Proxy N3) crypto saddr udp sendTCP another
314 0x8d -> forward kont bs $ handleOnionResponse (Proxy :: Proxy N2) crypto saddr udp sendTCP another
315 0x8e -> forward kont bs $ handleOnionResponse (Proxy :: Proxy N1) crypto saddr udp sendTCP another
316 _ -> kont m
317 m -> kont m
318
319forward :: forall c b b1. (Serialize b, Show b) =>
320 (Maybe (Either String b1) -> c) -> ByteString -> (b -> c) -> c
321forward kont bs f = either (kont . Just . Left) f $ decode $ B.tail bs
322
323class SumToThree a b
324
325instance SumToThree N0 N3
326instance SumToThree (S a) b => SumToThree a (S b)
327
328class ( Serialize (ReturnPath n)
329 , Serialize (ReturnPath (S n))
330 , Serialize (Forwarding (ThreeMinus (S n)) (OnionMessage Encrypted))
331 , ThreeMinus n ~ S (ThreeMinus (S n))
332 ) => LessThanThree n
333
334instance LessThanThree N0
335instance LessThanThree N1
336instance LessThanThree N2
337
338type family ThreeMinus n where
339 ThreeMinus N3 = N0
340 ThreeMinus N2 = N1
341 ThreeMinus N1 = N2
342 ThreeMinus N0 = N3
343
344-- n = 0, 1, 2
345data OnionRequest n = OnionRequest
346 { onionNonce :: Nonce24
347 , onionForward :: Forwarding (ThreeMinus n) (OnionMessage Encrypted)
348 , pathFromOwner :: ReturnPath n
349 }
350 deriving (Eq,Ord)
351
352
353{-
354instance (Typeable n, Sized (ReturnPath n), Serialize (ReturnPath n)
355 , Serialize (Forwarding (ThreeMinus n) (OnionMessage Encrypted))
356 ) => Data (OnionRequest n) where
357 gfoldl f z txt = z (either error id . S.decode) `f` S.encode txt
358 toConstr _ = error "OnionRequest.toConstr"
359 gunfold _ _ = error "OnionRequest.gunfold"
360#if MIN_VERSION_base(4,2,0)
361 dataTypeOf _ = mkNoRepType "Network.Tox.Onion.Transport.OnionRequest"
362#else
363 dataTypeOf _ = mkNorepType "Network.Tox.Onion.Transport.OnionRequest"
364#endif
365-}
366
367
368instance (Typeable n, Serialize (ReturnPath n)) => Data (OnionResponse n) where
369 gfoldl f z txt = z (either error id . S.decode) `f` S.encode txt
370 toConstr _ = error "OnionResponse.toConstr"
371 gunfold _ _ = error "OnionResponse.gunfold"
372#if MIN_VERSION_base(4,2,0)
373 dataTypeOf _ = mkNoRepType "Network.Tox.Onion.Transport.OnionResponse"
374#else
375 dataTypeOf _ = mkNorepType "Network.Tox.Onion.Transport.OnionResponse"
376#endif
377
378deriving instance ( Show (Forwarding (ThreeMinus n) (OnionMessage Encrypted))
379 , KnownNat (PeanoNat n)
380 ) => Show (OnionRequest n)
381
382instance Sized (OnionRequest N0) where -- N1 and N2 are the same, N3 does not encode the nonce.
383 size = contramap onionNonce size
384 <> contramap onionForward size
385 <> contramap pathFromOwner size
386
387instance ( Serialize (Forwarding (ThreeMinus n) (OnionMessage Encrypted))
388 , Sized (ReturnPath n)
389 , Serialize (ReturnPath n)
390 , Typeable n
391 ) => Serialize (OnionRequest n) where
392 get = do
393 -- TODO share code with 'getOnionRequest'
394 n24 <- case eqT :: Maybe (n :~: N3) of
395 Just Refl -> return $ Nonce24 zeros24
396 Nothing -> get
397 cnt <- remaining
398 let fwdsize = case size :: Size (ReturnPath n) of ConstSize n -> cnt - n
399 fwd <- isolate fwdsize get
400 rpath <- get
401 return $ OnionRequest n24 fwd rpath
402 put (OnionRequest n f p) = maybe (put n) (\Refl -> return ()) (eqT :: Maybe (n :~: N3)) >> put f >> put p
403
404-- getRequest :: _
405-- getRequest = OnionRequest <$> get <*> get <*> get
406
407-- n = 1, 2, 3
408-- Attributed (Encrypted (
409
410data OnionResponse n = OnionResponse
411 { pathToOwner :: ReturnPath n
412 , msgToOwner :: OnionMessage Encrypted
413 }
414 deriving (Eq,Ord)
415
416deriving instance KnownNat (PeanoNat n) => Show (OnionResponse n)
417
418instance ( Serialize (ReturnPath n) ) => Serialize (OnionResponse n) where
419 get = OnionResponse <$> get <*> (get >>= fromMaybe (fail "illegal onion forwarding")
420 . getOnionReply)
421 put (OnionResponse p m) = put p >> putOnionMsg m
422
423instance (Sized (ReturnPath n)) => Sized (OnionResponse (S n)) where
424 size = contramap pathToOwner size <> contramap msgToOwner size
425
426data Addressed a = Addressed { sockAddr :: SockAddr, unaddressed :: a }
427 | TCPIndex { tcpIndex :: Int, unaddressed :: a }
428 deriving (Eq,Ord,Show)
429
430instance (Typeable a, Serialize a) => Data (Addressed a) where
431 gfoldl f z a = z (either error id . S.decode) `f` S.encode a
432 toConstr _ = error "Addressed.toConstr"
433 gunfold _ _ = error "Addressed.gunfold"
434#if MIN_VERSION_base(4,2,0)
435 dataTypeOf _ = mkNoRepType "Network.Tox.Onion.Transport.Addressed"
436#else
437 dataTypeOf _ = mkNorepType "Network.Tox.Onion.Transport.Addressed"
438#endif
439
440instance Sized a => Sized (Addressed a) where
441 size = case size :: Size a of
442 ConstSize n -> ConstSize $ 1{-family-} + 16{-ip-} + 2{-port-} + n
443 VarSize f -> VarSize $ \x -> 1{-family-} + 16{-ip-} + 2{-port-} + f (unaddressed x)
444
445getForwardAddr :: S.Get SockAddr
446getForwardAddr = do
447 addrfam <- S.get :: S.Get Word8
448 ip <- getIP addrfam
449 case ip of IPv4 _ -> S.skip 12 -- compliant peers would zero-fill this.
450 IPv6 _ -> return ()
451 port <- S.get :: S.Get PortNumber
452 return $ setPort port $ toSockAddr ip
453
454
455putForwardAddr :: SockAddr -> S.Put
456putForwardAddr saddr = fromMaybe (return $ error "unsupported SockAddr family") $ do
457 port <- sockAddrPort saddr
458 ip <- fromSockAddr $ either id id $ either4or6 saddr
459 return $ do
460 case ip of
461 IPv4 ip4 -> S.put (0x02 :: Word8) >> S.put ip4 >> S.putByteString (B.replicate 12 0)
462 IPv6 ip6 -> S.put (0x0a :: Word8) >> S.put ip6
463 S.put port
464
465addrToIndex :: SockAddr -> Int
466addrToIndex (SockAddrInet6 _ _ (lo, hi, _, _) _) =
467 if fitsInInt (Proxy :: Proxy Word64)
468 then fromIntegral lo + (fromIntegral hi `shiftL` 32)
469 else fromIntegral lo
470addrToIndex _ = 0
471
472indexToAddr :: Int -> SockAddr
473indexToAddr x = SockAddrInet6 0 0 (fromIntegral x, fromIntegral (x `shiftR` 32),0,0) 0
474
475-- Note, toxcore would check an address family byte here to detect a TCP-bound
476-- packet, but we instead use the IPv6 id and rely on the port number being
477-- zero. Since it will be symmetrically encrypted for our eyes only, it's not
478-- important to conform on this point.
479instance Serialize a => Serialize (Addressed a) where
480 get = do saddr <- getForwardAddr
481 a <- get
482 case sockAddrPort saddr of
483 Just 0 -> return $ TCPIndex (addrToIndex saddr) a
484 _ -> return $ Addressed saddr a
485 put (Addressed addr x) = putForwardAddr addr >> put x
486 put (TCPIndex idx x) = putForwardAddr (indexToAddr idx) >> put x
487
488data N0
489data S n
490type N1 = S N0
491type N2 = S N1
492type N3 = S N2
493
494deriving instance Data N0
495deriving instance Data n => Data (S n)
496
497class KnownPeanoNat n where
498 peanoVal :: p n -> Int
499
500instance KnownPeanoNat N0 where
501 peanoVal _ = 0
502instance KnownPeanoNat n => KnownPeanoNat (S n) where
503 peanoVal _ = 1 + peanoVal (Proxy :: Proxy n)
504
505type family PeanoNat p where
506 PeanoNat N0 = 0
507 PeanoNat (S n) = 1 + PeanoNat n
508
509data ReturnPath n where
510 NoReturnPath :: ReturnPath N0
511 ReturnPath :: Nonce24 -> Encrypted (Addressed (ReturnPath n)) -> ReturnPath (S n)
512
513deriving instance Eq (ReturnPath n)
514deriving instance Ord (ReturnPath n)
515
516-- Size: 59 = 1(family) + 16(ip) + 2(port) +16(mac) + 24(nonce)
517instance Sized (ReturnPath N0) where size = ConstSize 0
518instance Sized (ReturnPath n) => Sized (ReturnPath (S n)) where
519 size = ConstSize 59 <> contramap (\x -> let _ = x :: ReturnPath (S n)
520 in error "non-constant ReturnPath size")
521 (size :: Size (ReturnPath n))
522
523{-
524instance KnownNat (PeanoNat n) => Sized (ReturnPath n) where
525 size = ConstSize $ 59 * fromIntegral (natVal (Proxy :: Proxy (PeanoNat n)))
526-}
527
528instance Serialize (ReturnPath N0) where get = pure NoReturnPath
529 put NoReturnPath = pure ()
530
531instance Serialize (ReturnPath N1) where
532 get = ReturnPath <$> get <*> get
533 put (ReturnPath n24 p) = put n24 >> put p
534
535instance (Sized (ReturnPath n), Serialize (ReturnPath n)) => Serialize (ReturnPath (S (S n))) where
536 get = ReturnPath <$> get <*> get
537 put (ReturnPath n24 p) = put n24 >> put p
538
539
540{-
541-- This doesn't work because it tried to infer it for (0 - 1)
542instance (Serialize (Encrypted (Addressed (ReturnPath (n - 1))))) => Serialize (ReturnPath n) where
543 get = ReturnPath <$> get <*> get
544 put (ReturnPath n24 p) = put n24 >> put p
545-}
546
547instance KnownNat (PeanoNat n) => Show (ReturnPath n) where
548 show rpath = "ReturnPath" ++ show (natVal (Proxy :: Proxy (PeanoNat n)))
549
550
551-- instance KnownNat n => Serialize (ReturnPath n) where
552-- -- Size: 59 = 1(family) + 16(ip) + 2(port) +16(mac) + 24(nonce)
553-- get = ReturnPath <$> getBytes ( 59 * (fromIntegral $ natVal $ Proxy @n) )
554-- put (ReturnPath bs) = putByteString bs
555
556
557data Forwarding n msg where
558 NotForwarded :: msg -> Forwarding N0 msg
559 Forwarding :: PublicKey -> Encrypted (Addressed (Forwarding n msg)) -> Forwarding (S n) msg
560
561deriving instance Eq msg => Eq (Forwarding n msg)
562deriving instance Ord msg => Ord (Forwarding n msg)
563
564instance Show msg => Show (Forwarding N0 msg) where
565 show (NotForwarded x) = "NotForwarded "++show x
566
567instance ( KnownNat (PeanoNat (S n))
568 , Show (Encrypted (Addressed (Forwarding n msg)))
569 ) => Show (Forwarding (S n) msg) where
570 show (Forwarding k a) = unwords [ "Forwarding"
571 , "("++show (natVal (Proxy :: Proxy (PeanoNat (S n))))++")"
572 , show (key2id k)
573 , show a
574 ]
575
576instance Sized msg => Sized (Forwarding N0 msg)
577 where size = case size :: Size msg of
578 ConstSize n -> ConstSize n
579 VarSize f -> VarSize $ \(NotForwarded x) -> f x
580
581instance Sized (Forwarding n msg) => Sized (Forwarding (S n) msg)
582 where size = ConstSize 32
583 <> contramap (\(Forwarding _ e) -> e)
584 (size :: Size (Encrypted (Addressed (Forwarding n msg))))
585
586instance Serialize msg => Serialize (Forwarding N0 msg) where
587 get = NotForwarded <$> get
588 put (NotForwarded msg) = put msg
589
590instance (Serialize (Encrypted (Addressed (Forwarding n msg)))) => Serialize (Forwarding (S n) msg) where
591 get = Forwarding <$> getPublicKey <*> get
592 put (Forwarding k x) = putPublicKey k >> put x
593
594{-
595rewrap :: (ThreeMinus n ~ S (ThreeMinus (S n)),
596 Serialize (ReturnPath n),
597 Serialize
598 (Forwarding (ThreeMinus (S n)) (OnionMessage Encrypted))) =>
599 TransportCrypto
600 -> (forall x. x -> Addressed x)
601 -> OnionRequest n
602 -> IO (Either String (OnionRequest (S n), SockAddr))
603rewrap crypto saddr (OnionRequest nonce msg rpath) = do
604 (sym, snonce) <- atomically ( (,) <$> transportSymmetric crypto
605 <*> transportNewNonce crypto )
606 peeled <- peelOnion crypto nonce msg
607 return $ peeled >>= \case
608 Addressed dst msg'
609 -> Right (OnionRequest nonce msg' $ wrapSymmetric sym snonce saddr rpath, dst)
610 _ -> Left "Onion forward to TCP client?"
611-}
612
613handleOnionRequest :: forall a proxy n.
614 ( LessThanThree n
615 , KnownPeanoNat n
616 , Sized (ReturnPath n)
617 , Typeable n
618 ) => proxy n -> TransportCrypto -> (forall x. x -> Addressed x) -> UDPTransport -> IO a -> OnionRequest n -> IO a
619handleOnionRequest proxy crypto saddr udp kont (OnionRequest nonce msg rpath) = do
620 let n = peanoVal rpath
621 dput XOnion $ "handleOnionRequest " ++ show n
622 (sym, snonce) <- atomically ( (,) <$> transportSymmetric crypto
623 <*> transportNewNonce crypto )
624 peeled <- peelOnion crypto nonce msg
625 let showDestination = case saddr () of
626 Addressed a _ -> either show show $ either4or6 a
627 TCPIndex i _ -> "TCP" ++ show [i]
628
629 case peeled of
630 Left e -> do
631 dput XOnion $ unwords [ "peelOnion:", show n, showDestination, e]
632 kont
633 Right (Addressed dst msg') -> do
634 dput XOnion $ unwords [ "peelOnion:", show n, showDestination, "-->", either show show (either4or6 dst), "SUCCESS"]
635 sendMessage udp dst (runPut $ putRequest $ OnionRequest nonce msg' $ wrapSymmetric sym snonce saddr rpath)
636 kont
637 Right (TCPIndex {}) -> do
638 dput XUnexpected "handleOnionRequest: Onion forward to TCP client?"
639 kont
640
641wrapSymmetric :: Serialize (ReturnPath n) =>
642 SymmetricKey -> Nonce24 -> (forall x. x -> Addressed x) -> ReturnPath n -> ReturnPath (S n)
643wrapSymmetric sym n saddr rpath = ReturnPath n $ encryptSymmetric sym n (encodePlain $ saddr rpath)
644
645peelSymmetric :: Serialize (Addressed (ReturnPath n))
646 => SymmetricKey -> ReturnPath (S n) -> Either String (Addressed (ReturnPath n))
647peelSymmetric sym (ReturnPath nonce e) = decryptSymmetric sym nonce e >>= decodePlain
648
649
650peelOnion :: Serialize (Addressed (Forwarding n t))
651 => TransportCrypto
652 -> Nonce24
653 -> Forwarding (S n) t
654 -> IO (Either String (Addressed (Forwarding n t)))
655peelOnion crypto nonce (Forwarding k fwd) = do
656 fmap runIdentity . uncomposed <$> decryptMessage crypto (dhtKey crypto) nonce (Right $ Asymm k nonce fwd)
657
658handleOnionResponse :: (KnownPeanoNat n, Sized (ReturnPath n), Serialize (ReturnPath n), Typeable n) =>
659 proxy (S n)
660 -> TransportCrypto
661 -> SockAddr
662 -> UDPTransport
663 -> (Int -> OnionMessage Encrypted -> IO ()) -- ^ TCP-relay onion send.
664 -> IO a
665 -> OnionResponse (S n)
666 -> IO a
667handleOnionResponse proxy crypto saddr udp sendTCP kont (OnionResponse path msg) = do
668 sym <- atomically $ transportSymmetric crypto
669 case peelSymmetric sym path of
670 Left e -> do
671 -- todo report encryption error
672 let n = peanoVal path
673 dput XMisc $ unwords [ "peelSymmetric:", show n, either show show (either4or6 saddr), e]
674 kont
675 Right (Addressed dst path') -> do
676 sendMessage udp dst (runPut $ putResponse $ OnionResponse path' msg)
677 kont
678 Right (TCPIndex dst path') -> do
679 case peanoVal path' of
680 0 -> sendTCP dst msg
681 n -> dput XUnexpected $ "handleOnionResponse: TCP-bound OnionResponse" ++ show n ++ " not supported."
682 kont
683
684
685data AnnounceRequest = AnnounceRequest
686 { announcePingId :: Nonce32 -- Ping ID
687 , announceSeeking :: NodeId -- Public key we are searching for
688 , announceKey :: NodeId -- Public key that we want those sending back data packets to use
689 }
690 deriving Show
691
692instance Sized AnnounceRequest where size = ConstSize (32*3)
693
694instance S.Serialize AnnounceRequest where
695 get = AnnounceRequest <$> S.get <*> S.get <*> S.get
696 put (AnnounceRequest p s k) = S.put (p,s,k)
697
698getOnionRequest :: Sized msg => Get (Asymm (Encrypted msg), ReturnPath N3)
699getOnionRequest = do
700 -- Assumes return path is constant size so that we can isolate
701 -- the variable-sized prefix.
702 cnt <- remaining
703 a <- isolate (case size :: Size (ReturnPath N3) of ConstSize n -> cnt - n)
704 getAliasedAsymm
705 path <- get
706 return (a,path)
707
708putRequest :: ( KnownPeanoNat n
709 , Serialize (OnionRequest n)
710 , Typeable n
711 ) => OnionRequest n -> Put
712putRequest req = do
713 let tag = 0x80 + fromIntegral (peanoVal req)
714 when (tag <= 0x82) (putWord8 tag)
715 put req
716
717putResponse :: (KnownPeanoNat n, Serialize (OnionResponse n)) => OnionResponse n -> Put
718putResponse resp = do
719 let tag = 0x8f - fromIntegral (peanoVal resp)
720 -- OnionResponse N0 is an alias for the OnionMessage Encrypted type which includes a tag
721 -- in it's Serialize instance.
722 when (tag /= 0x8f) (putWord8 tag)
723 put resp
724
725
726data KeyRecord = NotStored Nonce32
727 | SendBackKey PublicKey
728 | Acknowledged Nonce32
729 deriving Show
730
731instance Sized KeyRecord where size = ConstSize 33
732
733instance S.Serialize KeyRecord where
734 get = do
735 is_stored <- S.get :: S.Get Word8
736 case is_stored of
737 1 -> SendBackKey <$> getPublicKey
738 2 -> Acknowledged <$> S.get
739 _ -> NotStored <$> S.get
740 put (NotStored n32) = S.put (0 :: Word8) >> S.put n32
741 put (SendBackKey key) = S.put (1 :: Word8) >> putPublicKey key
742 put (Acknowledged n32) = S.put (2 :: Word8) >> S.put n32
743
744data AnnounceResponse = AnnounceResponse
745 { is_stored :: KeyRecord
746 , announceNodes :: SendNodes
747 }
748 deriving Show
749
750instance Sized AnnounceResponse where
751 size = contramap is_stored size <> contramap announceNodes size
752
753getNodeList :: S.Get [NodeInfo]
754getNodeList = do
755 n <- S.get
756 (:) n <$> (getNodeList <|> pure [])
757
758instance S.Serialize AnnounceResponse where
759 get = AnnounceResponse <$> S.get <*> (SendNodes <$> getNodeList)
760 put (AnnounceResponse st (SendNodes ns)) = S.put st >> mapM_ S.put ns
761
762data DataToRoute = DataToRoute
763 { dataFromKey :: PublicKey -- Real public key of sender
764 , dataToRoute :: Encrypted OnionData -- (Word8,ByteString) -- DHTPK 0x9c
765 }
766
767instance Sized DataToRoute where
768 size = ConstSize 32 <> contramap dataToRoute size
769
770instance Serialize DataToRoute where
771 get = DataToRoute <$> getPublicKey <*> get
772 put (DataToRoute k dta) = putPublicKey k >> put dta
773
774data OnionData
775 = -- | type 0x9c
776 --
777 -- We send this packet every 30 seconds if there is more than one peer (in
778 -- the 8) that says they our friend is announced on them. This packet can
779 -- also be sent through the DHT module as a DHT request packet (see DHT) if
780 -- we know the DHT public key of the friend and are looking for them in the
781 -- DHT but have not connected to them yet. 30 second is a reasonable
782 -- timeout to not flood the network with too many packets while making sure
783 -- the other will eventually receive the packet. Since packets are sent
784 -- through every peer that knows the friend, resending it right away
785 -- without waiting has a high likelihood of failure as the chances of
786 -- packet loss happening to all (up to to 8) packets sent is low.
787 --
788 -- If a friend is online and connected to us, the onion will stop all of
789 -- its actions for that friend. If the peer goes offline it will restart
790 -- searching for the friend as if toxcore was just started.
791 OnionDHTPublicKey DHTPublicKey
792 | -- | type 0x20
793 --
794 --
795 OnionFriendRequest FriendRequest -- 0x20
796 deriving (Eq,Show)
797
798instance Sized OnionData where
799 size = VarSize $ \case
800 OnionDHTPublicKey dhtpk -> case size of
801 ConstSize n -> n -- Override because OnionData probably
802 -- should be treated as variable sized.
803 VarSize f -> f dhtpk
804 -- FIXME: inconsitantly, we have to add in the tag byte for this case.
805 OnionFriendRequest req -> 1 + case size of
806 ConstSize n -> n
807 VarSize f -> f req
808
809instance Serialize OnionData where
810 get = do
811 tag <- get
812 case tag :: Word8 of
813 0x9c -> OnionDHTPublicKey <$> get
814 0x20 -> OnionFriendRequest <$> get
815 _ -> fail $ "Unknown onion data: "++show tag
816 put (OnionDHTPublicKey dpk) = put (0x9c :: Word8) >> put dpk
817 put (OnionFriendRequest fr) = put (0x20 :: Word8) >> put fr
818
819selectKey :: TransportCrypto -> OnionMessage f -> OnionDestination r -> IO (SecretKey, PublicKey)
820selectKey crypto _ rpath@(OnionDestination (AnnouncingAlias skey pkey) _ _)
821 = return (skey, pkey)
822selectKey crypto msg rpath = return $ aliasKey crypto rpath
823
824encrypt :: TransportCrypto
825 -> OnionMessage Identity
826 -> OnionDestination r
827 -> IO (OnionMessage Encrypted, OnionDestination r)
828encrypt crypto msg rpath = do
829 (skey,pkey) <- selectKey crypto msg rpath -- source key
830 let okey = onionKey rpath -- destination key
831 encipher1 :: Serialize a => SecretKey -> PublicKey -> Nonce24 -> a -> (IO ∘ Encrypted) a
832 encipher1 sk pk n a = Composed $ do
833 secret <- lookupSharedSecret crypto sk pk n
834 return $ ToxCrypto.encrypt secret $ encodePlain a
835 encipher :: Serialize a => Nonce24 -> Either (Identity a) (Asymm (Identity a)) -> (IO ∘ Encrypted) a
836 encipher n d = encipher1 skey okey n $ either runIdentity (runIdentity . asymmData) d
837 m <- sequenceMessage $ transcode encipher msg
838 return (m, rpath)
839
840decrypt :: TransportCrypto -> OnionMessage Encrypted -> OnionDestination r -> IO (Either String (OnionMessage Identity, OnionDestination r))
841decrypt crypto msg addr = do
842 (skey,pkey) <- selectKey crypto msg addr
843 let decipher1 :: Serialize a =>
844 TransportCrypto -> SecretKey -> Nonce24
845 -> Either (PublicKey,Encrypted a) (Asymm (Encrypted a))
846 -> (IO ∘ Either String ∘ Identity) a
847 decipher1 crypto k n arg = Composed $ do
848 let (sender,e) = either id (senderKey &&& asymmData) arg
849 secret <- lookupSharedSecret crypto k sender n
850 return $ Composed $ do
851 plain <- ToxCrypto.decrypt secret e
852 Identity <$> decodePlain plain
853 decipher :: Serialize a
854 => Nonce24 -> Either (Encrypted a) (Asymm (Encrypted a))
855 -> (IO ∘ Either String ∘ Identity) a
856 decipher = (\n -> decipher1 crypto skey n . left (senderkey addr))
857 foo <- sequenceMessage $ transcode decipher msg
858 return $ do
859 msg <- sequenceMessage foo
860 Right (msg, addr)
861
862senderkey :: OnionDestination r -> t -> (PublicKey, t)
863senderkey addr e = (onionKey addr, e)
864
865aliasKey :: TransportCrypto -> OnionDestination r -> (SecretKey,PublicKey)
866aliasKey crypto (OnionToOwner {}) = (transportSecret &&& transportPublic) crypto
867aliasKey crypto (OnionDestination {}) = (onionAliasSecret &&& onionAliasPublic) crypto
868
869dhtKey :: TransportCrypto -> (SecretKey,PublicKey)
870dhtKey crypto = (transportSecret &&& transportPublic) crypto
871
872decryptMessage :: Serialize x =>
873 TransportCrypto
874 -> (SecretKey,PublicKey)
875 -> Nonce24
876 -> Either (PublicKey, Encrypted x)
877 (Asymm (Encrypted x))
878 -> IO ((Either String ∘ Identity) x)
879decryptMessage crypto (sk,pk) n arg = do
880 let (sender,e) = either id (senderKey &&& asymmData) arg
881 plain = Composed . fmap Identity . (>>= decodePlain)
882 secret <- lookupSharedSecret crypto sk sender n
883 return $ plain $ ToxCrypto.decrypt secret e
884
885sequenceMessage :: Applicative m => OnionMessage (m ∘ f) -> m (OnionMessage f)
886sequenceMessage (OnionAnnounce a) = fmap OnionAnnounce $ sequenceA $ fmap uncomposed a
887sequenceMessage (OnionAnnounceResponse n8 n24 dta) = OnionAnnounceResponse n8 n24 <$> uncomposed dta
888sequenceMessage (OnionToRoute pub a) = pure $ OnionToRoute pub a
889sequenceMessage (OnionToRouteResponse a) = pure $ OnionToRouteResponse a
890-- sequenceMessage (OnionToRouteResponse a) = fmap OnionToRouteResponse $ sequenceA $ fmap uncomposed a
891
892transcode :: forall f g. (forall a. Serialize a => Nonce24 -> Either (f a) (Asymm (f a)) -> g a) -> OnionMessage f -> OnionMessage g
893transcode f (OnionAnnounce a) = OnionAnnounce $ a { asymmData = f (asymmNonce a) (Right a) }
894transcode f (OnionAnnounceResponse n8 n24 dta) = OnionAnnounceResponse n8 n24 $ f n24 $ Left dta
895transcode f (OnionToRoute pub a) = OnionToRoute pub a
896transcode f (OnionToRouteResponse a) = OnionToRouteResponse a
897-- transcode f (OnionToRouteResponse a) = OnionToRouteResponse $ a { asymmData = f (asymmNonce a) (Right a) }
898
899
900data OnionRoute = OnionRoute
901 { routeAliasA :: SecretKey
902 , routeAliasB :: SecretKey
903 , routeAliasC :: SecretKey
904 , routeNodeA :: NodeInfo
905 , routeNodeB :: NodeInfo
906 , routeNodeC :: NodeInfo
907 }
908
909wrapForRoute :: TransportCrypto -> OnionMessage Encrypted -> NodeInfo -> OnionRoute -> IO (OnionRequest N0)
910wrapForRoute crypto msg ni r = do
911 -- We needn't use the same nonce value here, but I think it is safe to do so. 88 -- We needn't use the same nonce value here, but I think it is safe to do so.
912 let nonce = msgNonce msg 89 let nonce = msgNonce msg
913 fwd <- wrapOnion crypto (routeAliasA r) 90 fwd <- wrapOnion crypto (routeAliasA r)
@@ -923,186 +100,20 @@ wrapForRoute crypto msg ni r = do
923 (id2key . nodeId $ routeNodeC r) 100 (id2key . nodeId $ routeNodeC r)
924 (nodeAddr ni) 101 (nodeAddr ni)
925 (NotForwarded msg) 102 (NotForwarded msg)
926 return OnionRequest 103 return $ Right OnionRequest
927 { onionNonce = nonce 104 { onionNonce = nonce
928 , onionForward = fwd 105 , onionForward = fwd
929 , pathFromOwner = NoReturnPath 106 , pathFromOwner = NoReturnPath
930 } 107 }
931 108wrapForRoute crypto msg ni r@OnionRoute{routeRelayPort = Just tcpport} = do
932wrapOnion :: Serialize (Forwarding n msg) => 109 let nonce = msgNonce msg
933 TransportCrypto 110 fwd <- wrapOnion crypto (routeAliasB r)
934 -> SecretKey 111 nonce
935 -> Nonce24 112 (id2key . nodeId $ routeNodeB r)
936 -> PublicKey 113 (nodeAddr $ routeNodeC r)
937 -> SockAddr 114 =<< wrapOnion crypto (routeAliasC r)
938 -> Forwarding n msg 115 nonce
939 -> IO (Forwarding (S n) msg) 116 (id2key . nodeId $ routeNodeC r)
940wrapOnion crypto skey nonce destkey saddr fwd = do 117 (nodeAddr ni)
941 let plain = encodePlain $ Addressed saddr fwd 118 (NotForwarded msg)
942 secret <- lookupSharedSecret crypto skey destkey nonce 119 return $ Left $ TCP.OnionPacket nonce $ Addressed (nodeAddr $ routeNodeB r) fwd
943 return $ Forwarding (toPublic skey) $ ToxCrypto.encrypt secret plain
944
945wrapOnionPure :: Serialize (Forwarding n msg) =>
946 SecretKey
947 -> ToxCrypto.State
948 -> SockAddr
949 -> Forwarding n msg
950 -> Forwarding (S n) msg
951wrapOnionPure skey st saddr fwd = Forwarding (toPublic skey) (ToxCrypto.encrypt st plain)
952 where
953 plain = encodePlain $ Addressed saddr fwd
954
955
956
957-- TODO
958-- Two types of packets may be sent to Rendezvous via OnionToRoute requests.
959--
960-- (1) DHT public key packet (0x9c)
961--
962-- (2) Friend request
963data Rendezvous = Rendezvous
964 { rendezvousKey :: PublicKey
965 , rendezvousNode :: NodeInfo
966 }
967 deriving Eq
968
969instance Show Rendezvous where
970 showsPrec d (Rendezvous k ni)
971 = showsPrec d (key2id k)
972 . (':' :)
973 . showsPrec d ni
974
975instance Read Rendezvous where
976 readsPrec d = RP.readP_to_S $ do
977 rkstr <- RP.munch (/=':')
978 RP.char ':'
979 nistr <- RP.munch (const True)
980 return Rendezvous
981 { rendezvousKey = id2key $ read rkstr
982 , rendezvousNode = read nistr
983 }
984
985
986data AnnouncedRendezvous = AnnouncedRendezvous
987 { remoteUserKey :: PublicKey
988 , rendezvous :: Rendezvous
989 }
990 deriving Eq
991
992instance Show AnnouncedRendezvous where
993 showsPrec d (AnnouncedRendezvous remote rendez)
994 = showsPrec d (key2id remote)
995 . (':' :)
996 . showsPrec d rendez
997
998instance Read AnnouncedRendezvous where
999 readsPrec d = RP.readP_to_S $ do
1000 ukstr <- RP.munch (/=':')
1001 RP.char ':'
1002 rkstr <- RP.munch (/=':')
1003 RP.char ':'
1004 nistr <- RP.munch (const True)
1005 return AnnouncedRendezvous
1006 { remoteUserKey = id2key $ read ukstr
1007 , rendezvous = Rendezvous
1008 { rendezvousKey = id2key $ read rkstr
1009 , rendezvousNode = read nistr
1010 }
1011 }
1012
1013
1014selectAlias :: TransportCrypto -> NodeId -> STM AliasSelector
1015selectAlias crypto pkey = do
1016 ks <- filter (\(sk,pk) -> pk == id2key pkey)
1017 <$> userKeys crypto
1018 maybe (return SearchingAlias)
1019 (return . uncurry AnnouncingAlias)
1020 (listToMaybe ks)
1021
1022
1023parseDataToRoute
1024 :: TransportCrypto
1025 -> (OnionMessage Encrypted,OnionDestination r)
1026 -> IO (Either ((PublicKey,OnionData),AnnouncedRendezvous) (OnionMessage Encrypted, OnionDestination r))
1027parseDataToRoute crypto (OnionToRouteResponse dta, od) = do
1028 ks <- atomically $ userKeys crypto
1029
1030 omsg0 <- decryptMessage crypto (rendezvousSecret crypto,rendezvousPublic crypto)
1031 (asymmNonce dta)
1032 (Right dta) -- using Asymm{senderKey} as remote key
1033 let eOuter = fmap runIdentity $ uncomposed omsg0
1034
1035 anyRight [] f = return $ Left "parseDataToRoute: no user key"
1036 anyRight (x:xs) f = f x >>= either (const $ anyRight xs f) (return . Right)
1037
1038 -- TODO: We don't currently have a way to look up which user key we
1039 -- announced using along this onion route. Therefore, for now, we will
1040 -- try all our user keys to see if any can decrypt the packet.
1041 eInner <- case eOuter of
1042 Left e -> return $ Left e
1043 Right dtr -> anyRight ks $ \(sk,pk) -> do
1044 omsg0 <- decryptMessage crypto
1045 (sk,pk)
1046 (asymmNonce dta)
1047 (Left (dataFromKey dtr, dataToRoute dtr))
1048 return $ do
1049 omsg <- fmap runIdentity . uncomposed $ omsg0
1050 Right (pk,dtr,omsg)
1051
1052 let e = do
1053 (pk,dtr,omsg) <- eInner
1054 return ( (pk, omsg)
1055 , AnnouncedRendezvous
1056 (dataFromKey dtr)
1057 $ Rendezvous (rendezvousPublic crypto) $ onionNodeInfo od )
1058 r = either (const $ Right (OnionToRouteResponse dta,od)) Left e
1059 -- parseDataToRoute OnionToRouteResponse decipherAndAuth: auth fail
1060 case e of
1061 Left _ -> dput XMisc $ "Failed keys: " ++ show (map (key2id . snd) ks)
1062 Right _ -> return ()
1063 dput XMisc $ unlines
1064 [ "parseDataToRoute " ++ either id (const "Right") e
1065 , " crypto inner.me = " ++ either id (\(pk,_,_) -> show $ key2id pk) eInner
1066 , " inner.them = " ++ either id (show . key2id . dataFromKey) eOuter
1067 , " outer.me = " ++ show (key2id $ rendezvousPublic crypto)
1068 , " outer.them = " ++ show (key2id $ senderKey dta)
1069 ]
1070 return r
1071parseDataToRoute _ msg = return $ Right msg
1072
1073encodeDataToRoute :: TransportCrypto
1074 -> ((PublicKey,OnionData),AnnouncedRendezvous)
1075 -> IO (Maybe (OnionMessage Encrypted,OnionDestination r))
1076encodeDataToRoute crypto ((me,omsg), AnnouncedRendezvous toxid (Rendezvous pub ni)) = do
1077 nonce <- atomically $ transportNewNonce crypto
1078 asel <- atomically $ selectAlias crypto (key2id me)
1079 let (sk,pk) = case asel of
1080 AnnouncingAlias sk pk -> (sk,pk)
1081 _ -> (onionAliasSecret crypto, onionAliasPublic crypto)
1082 innerSecret <- lookupSharedSecret crypto sk toxid nonce
1083 let plain = encodePlain $ DataToRoute { dataFromKey = pk
1084 , dataToRoute = ToxCrypto.encrypt innerSecret $ encodePlain omsg
1085 }
1086 outerSecret <- lookupSharedSecret crypto (onionAliasSecret crypto) pub nonce
1087 let dta = ToxCrypto.encrypt outerSecret plain
1088 dput XOnion $ unlines
1089 [ "encodeDataToRoute me=" ++ show (key2id me)
1090 , " dhtpk=" ++ case omsg of
1091 OnionDHTPublicKey dmsg -> show (key2id $ dhtpk dmsg)
1092 OnionFriendRequest fr -> "friend request"
1093 , " ns=" ++ case omsg of
1094 OnionDHTPublicKey dmsg -> show (dhtpkNodes dmsg)
1095 OnionFriendRequest fr -> "friend request"
1096 , " crypto inner.me =" ++ show (key2id pk)
1097 , " inner.you=" ++ show (key2id toxid)
1098 , " outer.me =" ++ show (key2id $ onionAliasPublic crypto)
1099 , " outer.you=" ++ show (key2id pub)
1100 , " " ++ show (AnnouncedRendezvous toxid (Rendezvous pub ni))
1101 , " " ++ show dta
1102 ]
1103 return $ Just ( OnionToRoute toxid -- Public key of destination node
1104 Asymm { senderKey = onionAliasPublic crypto
1105 , asymmNonce = nonce
1106 , asymmData = dta
1107 }
1108 , OnionDestination SearchingAlias ni Nothing )
diff --git a/src/Network/Tox/TCP.hs b/src/Network/Tox/TCP.hs
index e3f5012b..1111d3b8 100644
--- a/src/Network/Tox/TCP.hs
+++ b/src/Network/Tox/TCP.hs
@@ -2,7 +2,10 @@
2{-# LANGUAGE PartialTypeSignatures #-} 2{-# LANGUAGE PartialTypeSignatures #-}
3{-# LANGUAGE LambdaCase #-} 3{-# LANGUAGE LambdaCase #-}
4{-# LANGUAGE FlexibleContexts #-} 4{-# LANGUAGE FlexibleContexts #-}
5module Network.Tox.TCP where 5module Network.Tox.TCP
6 ( module Network.Tox.TCP
7 , NodeInfo(..)
8 ) where
6 9
7import Control.Arrow 10import Control.Arrow
8import Control.Concurrent 11import Control.Concurrent
@@ -46,11 +49,6 @@ import qualified Network.Tox.NodeId as UDP
46withSize :: Sized x => (Size x -> m (p x)) -> m (p x) 49withSize :: Sized x => (Size x -> m (p x)) -> m (p x)
47withSize f = case size of len -> f len 50withSize f = case size of len -> f len
48 51
49data NodeInfo = NodeInfo
50 { udpNodeInfo :: UDP.NodeInfo
51 , tcpPort :: PortNumber
52 }
53 deriving (Eq,Ord)
54 52
55type NodeId = UDP.NodeId 53type NodeId = UDP.NodeId
56 54
@@ -59,36 +57,6 @@ type NodeId = UDP.NodeId
59instance Show NodeInfo where 57instance Show NodeInfo where
60 show (NodeInfo udp port) = show udp ++ "{tcp:"++show port++"}" 58 show (NodeInfo udp port) = show udp ++ "{tcp:"++show port++"}"
61 59
62instance Read NodeInfo where
63 readsPrec _ = RP.readP_to_S $ do
64 udp <- RP.readS_to_P reads
65 port <- RP.between (RP.char '{') (RP.char '}') $ do
66 mapM_ RP.char ("tcp:" :: String)
67 w16 <- RP.readS_to_P reads
68 return $ fromIntegral (w16 :: Word16)
69 return $ NodeInfo udp port
70
71instance ToJSON NodeInfo where
72 toJSON (NodeInfo udp port) = case (toJSON udp) of
73 JSON.Object tbl -> JSON.Object $ HashMap.insert "tcp_ports"
74 (JSON.Array $ Vector.fromList
75 [JSON.Number (fromIntegral port)])
76 tbl
77 x -> x -- Shouldn't happen.
78
79instance FromJSON NodeInfo where
80 parseJSON json = do
81 udp <- parseJSON json
82 port <- case json of
83 JSON.Object v -> do
84 portnum:_ <- v JSON..: "tcp_ports"
85 return (fromIntegral (portnum :: Word16))
86 _ -> fail "TCP.NodeInfo: Expected JSON object."
87 return $ NodeInfo udp port
88
89instance Hashable NodeInfo where
90 hashWithSalt s n = hashWithSalt s (udpNodeInfo n)
91
92nodeId :: NodeInfo -> NodeId 60nodeId :: NodeInfo -> NodeId
93nodeId ni = UDP.nodeId $ udpNodeInfo ni 61nodeId ni = UDP.nodeId $ udpNodeInfo ni
94 62
@@ -275,12 +243,21 @@ tcpPing client dst = sendQuery client meth () dst
275 243
276type RelayClient = Client String () Nonce8 NodeInfo RelayPacket 244type RelayClient = Client String () Nonce8 NodeInfo RelayPacket
277 245
278newClient :: TransportCrypto -> IO RelayClient 246-- | Create a new TCP relay client. Because polymorphic existential record
279newClient crypto = do 247-- updates are currently hard with GHC, this function accepts parameters for
248-- generalizing the table-entry type for pending transactions. Safe trivial
249-- defaults are 'id' and 'tryPutMVar'. The resulting customized table state
250-- will be returned to the caller along with the new client.
251newClient :: TransportCrypto
252 -> (MVar RelayPacket -> a) -- ^ store mvar for query
253 -> (a -> RelayPacket -> IO void) -- ^ load mvar for query
254 -> IO ( TVar (ChaChaDRG, Data.Word64Map.Word64Map a)
255 , Client String () Nonce8 NodeInfo RelayPacket)
256newClient crypto store load = do
280 net <- toxTCP crypto 257 net <- toxTCP crypto
281 drg <- drgNew 258 drg <- drgNew
282 map_var <- atomically $ newTVar (drg, Data.Word64Map.empty) 259 map_var <- atomically $ newTVar (drg, Data.Word64Map.empty)
283 return Client 260 return $ (,) map_var Client
284 { clientNet = net 261 { clientNet = net
285 , clientDispatcher = DispatchMethods 262 , clientDispatcher = DispatchMethods
286 { classifyInbound = \case 263 { classifyInbound = \case
@@ -294,7 +271,7 @@ newClient crypto = do
294 , methodSerialize = \n8 src dst () -> RelayPong n8 271 , methodSerialize = \n8 src dst () -> RelayPong n8
295 , methodAction = \src () -> return () 272 , methodAction = \src () -> return ()
296 } 273 }
297 , tableMethods = transactionMethods (contramap (\(Nonce8 w64) -> w64) w64MapMethods) 274 , tableMethods = transactionMethods' store load (contramap (\(Nonce8 w64) -> w64) w64MapMethods)
298 $ first (either error Nonce8 . decode) . randomBytesGenerate 8 275 $ first (either error Nonce8 . decode) . randomBytesGenerate 8
299 } 276 }
300 , clientErrorReporter = logErrors 277 , clientErrorReporter = logErrors
diff --git a/src/Network/Tox/Transport.hs b/src/Network/Tox/Transport.hs
index e79e4d8b..217d5b1d 100644
--- a/src/Network/Tox/Transport.hs
+++ b/src/Network/Tox/Transport.hs
@@ -10,7 +10,8 @@ module Network.Tox.Transport (toxTransport, RouteId) where
10 10
11import Network.QueryResponse 11import Network.QueryResponse
12import Crypto.Tox 12import Crypto.Tox
13import Network.Tox.DHT.Transport 13import Data.Tox.Relay as TCP
14import Network.Tox.DHT.Transport as UDP
14import Network.Tox.Onion.Transport 15import Network.Tox.Onion.Transport
15import Network.Tox.Crypto.Transport 16import Network.Tox.Crypto.Transport
16import OnionRouter 17import OnionRouter
@@ -20,20 +21,23 @@ import Network.Socket
20toxTransport :: 21toxTransport ::
21 TransportCrypto 22 TransportCrypto
22 -> OnionRouter 23 -> OnionRouter
23 -> (PublicKey -> IO (Maybe NodeInfo)) 24 -> (PublicKey -> IO (Maybe UDP.NodeInfo))
24 -> UDPTransport 25 -> UDPTransport
25 -> (Int -> OnionMessage Encrypted -> IO ()) -- ^ TCP-bound callback. 26 -> (TCP.NodeInfo -> RelayPacket -> IO ()) -- ^ TCP server-bound callback.
27 -> (Int -> OnionMessage Encrypted -> IO ()) -- ^ TCP client-bound callback.
26 -> IO ( Transport String SockAddr (CryptoPacket Encrypted) 28 -> IO ( Transport String SockAddr (CryptoPacket Encrypted)
27 , Transport String NodeInfo (DHTMessage Encrypted8) 29 , Transport String UDP.NodeInfo (DHTMessage Encrypted8)
28 , Transport String (OnionDestination RouteId) (OnionMessage Encrypted) 30 , Transport String (OnionDestination RouteId) (OnionMessage Encrypted)
29 , Transport String AnnouncedRendezvous (PublicKey,OnionData) 31 , Transport String AnnouncedRendezvous (PublicKey,OnionData)
30 , Transport String SockAddr (Handshake Encrypted)) 32 , Transport String SockAddr (Handshake Encrypted))
31toxTransport crypto orouter closeLookup udp tcp = do 33toxTransport crypto orouter closeLookup udp tcp2server tcp2client = do
32 (netcrypto, udp0) <- partitionTransport parseCrypto encodeCrypto udp 34 (netcrypto, udp0) <- partitionTransport parseCrypto encodeCrypto udp
33 (dht,udp1) <- partitionTransportM (parseDHTAddr crypto) (fmap Just . encodeDHTAddr) $ forwardOnions crypto udp0 tcp 35 (dht,udp1) <- partitionTransportM (parseDHTAddr crypto) (fmap Just . encodeDHTAddr)
34 (onion1,udp2) <- partitionTransportM (parseOnionAddr $ lookupSender orouter) 36 $ forwardOnions crypto udp0 tcp2client
35 (encodeOnionAddr crypto $ lookupRoute orouter) 37 (onion1,udp2) <- partitionAndForkTransport tcp2server
36 udp1 38 (parseOnionAddr $ lookupSender orouter)
39 (encodeOnionAddr crypto $ lookupRoute orouter)
40 udp1
37 (dta,onion) <- partitionTransportM (parseDataToRoute crypto) (encodeDataToRoute crypto) onion1 41 (dta,onion) <- partitionTransportM (parseDataToRoute crypto) (encodeDataToRoute crypto) onion1
38 let handshakes = layerTransport parseHandshakes encodeHandshakes udp2 42 let handshakes = layerTransport parseHandshakes encodeHandshakes udp2
39 return ( netcrypto 43 return ( netcrypto
generated by cgit v1.2.3 (git 2.39.1) at 2024-09-22 05:31:16 +0000