diff options
Diffstat (limited to 'dht/src/Network')
-rw-r--r-- | dht/src/Network/Tox/Relay.hs | 56 |
1 files changed, 31 insertions, 25 deletions
diff --git a/dht/src/Network/Tox/Relay.hs b/dht/src/Network/Tox/Relay.hs index 22a692a9..dd150917 100644 --- a/dht/src/Network/Tox/Relay.hs +++ b/dht/src/Network/Tox/Relay.hs | |||
@@ -85,7 +85,7 @@ relaySession crypto clients cons sendOnion _ conid h = do | |||
85 | 85 | ||
86 | -- mhello <- fmap (>>= \h -> decryptPayload (computeSharedSecret me (helloFrom h) (helloNonce h)) h) $ hGetSized h | 86 | -- mhello <- fmap (>>= \h -> decryptPayload (computeSharedSecret me (helloFrom h) (helloNonce h)) h) $ hGetSized h |
87 | 87 | ||
88 | dput XOnion $ "Relay client session conid=" ++ show conid | 88 | dput XRelay $ "Relay client session conid=" ++ show conid |
89 | (hGetSized h >>=) $ mapM_ $ \helloE -> do | 89 | (hGetSized h >>=) $ mapM_ $ \helloE -> do |
90 | 90 | ||
91 | let me = transportSecret crypto | 91 | let me = transportSecret crypto |
@@ -93,23 +93,23 @@ relaySession crypto clients cons sendOnion _ conid h = do | |||
93 | 93 | ||
94 | noncef <- lookupNonceFunction crypto me them | 94 | noncef <- lookupNonceFunction crypto me them |
95 | let mhello = decryptPayload (noncef $ helloNonce helloE) helloE | 95 | let mhello = decryptPayload (noncef $ helloNonce helloE) helloE |
96 | dput XOnion $ "Relay client (conid=" ++ show conid ++ ") decrypted hello = " ++ show mhello | ||
97 | forM_ mhello $ \hello -> do | 96 | forM_ mhello $ \hello -> do |
98 | let _ = hello :: Hello Identity | 97 | let _ = hello :: Hello Identity |
99 | 98 | ||
100 | dput XOnion $ "Relay client sent hello. conid=" ++ show conid | 99 | -- dput XRelay $ "Relay client sent hello. conid=" ++ show conid |
101 | (me',welcome) <- atomically $ do | 100 | (me',welcome) <- atomically $ do |
102 | skey <- transportNewKey crypto | 101 | skey <- transportNewKey crypto |
103 | dta <- HelloData (toPublic skey) <$> transportNewNonce crypto | 102 | dta <- HelloData (toPublic skey) <$> transportNewNonce crypto |
104 | w24 <- transportNewNonce crypto | 103 | w24 <- transportNewNonce crypto |
105 | return (skey, Welcome w24 $ pure dta) | 104 | return (skey, Welcome w24 $ pure dta) |
106 | 105 | ||
107 | dput XOnion $ unlines [ "Relay client to receive welcome. conid=" ++ show conid | 106 | {- |
107 | dput XRelay $ unlines [ "Relay to send welcome to client. conid=" ++ show conid | ||
108 | , show welcome | 108 | , show welcome |
109 | ] | 109 | ] |
110 | -} | ||
110 | B.hPut h $ encode $ encryptPayload (noncef $ welcomeNonce welcome) welcome | 111 | B.hPut h $ encode $ encryptPayload (noncef $ welcomeNonce welcome) welcome |
111 | 112 | dput XRelay $ "Relay welcomes (conid=" ++ show conid ++ ") " ++ showKey256 them | |
112 | dput XOnion $ "Relay client welcome sent. conid=" ++ show conid | ||
113 | 113 | ||
114 | noncef' <- let them' = sessionPublicKey (runIdentity $ helloData hello) | 114 | noncef' <- let them' = sessionPublicKey (runIdentity $ helloData hello) |
115 | in lookupNonceFunction crypto me' them' | 115 | in lookupNonceFunction crypto me' them' |
@@ -158,18 +158,18 @@ relaySession crypto clients cons sendOnion _ conid h = do | |||
158 | `finally` do | 158 | `finally` do |
159 | atomically $ modifyTVar' clients $ IntMap.delete conid | 159 | atomically $ modifyTVar' clients $ IntMap.delete conid |
160 | disconnect cons (helloFrom hello) | 160 | disconnect cons (helloFrom hello) |
161 | dput XOnion $ "Relay client session closed. conid=" ++ show conid | 161 | dput XRelay $ "Relay client session closed. conid=" ++ show conid |
162 | 162 | ||
163 | handlePacket :: TVar (Map PublicKey (RelayPacket -> IO (), TVar RelaySession)) | 163 | handlePacket :: TVar (Map PublicKey (RelayPacket -> IO (), TVar RelaySession)) -- ^ All sessions. |
164 | -> Int | 164 | -> Int -- ^ TCP client number. |
165 | -> PublicKey | 165 | -> PublicKey -- ^ Public key of client. |
166 | -> TransportCrypto | 166 | -> TransportCrypto |
167 | -> (SockAddr -> OnionRequest N1 -> IO ()) | 167 | -> (SockAddr -> OnionRequest N1 -> IO ()) -- ^ Forward onion packet. |
168 | -> (RelayPacket -> IO ()) | 168 | -> (RelayPacket -> IO ()) -- ^ Send to this client. |
169 | -> TVar RelaySession | 169 | -> TVar RelaySession -- ^ Session for this client. |
170 | -> RelayPacket | 170 | -> RelayPacket |
171 | -> IO () | 171 | -> IO () |
172 | handlePacket cons thistcp me crypto sendOnion sendToMe session = \case | 172 | handlePacket cons thistcp thisKey crypto sendOnion sendToClient session = \case |
173 | RoutingRequest them -> join $ atomically $ do | 173 | RoutingRequest them -> join $ atomically $ do |
174 | mySession <- readTVar session | 174 | mySession <- readTVar session |
175 | mi <- case Map.lookup them (solicited mySession) of | 175 | mi <- case Map.lookup them (solicited mySession) of |
@@ -187,28 +187,33 @@ handlePacket cons thistcp me crypto sendOnion sendToMe session = \case | |||
187 | mp <- Map.lookup them <$> readTVar cons | 187 | mp <- Map.lookup them <$> readTVar cons |
188 | forM mp $ \(sendToThem,peer) -> do | 188 | forM mp $ \(sendToThem,peer) -> do |
189 | theirSession <- readTVar peer | 189 | theirSession <- readTVar peer |
190 | forM (Map.lookup me $ solicited theirSession) $ \reserved_id -> do | 190 | forM (Map.lookup thisKey $ solicited theirSession) $ \reserved_id -> do |
191 | let sendToThem' f = sendToThem $ f $ key2c reserved_id | 191 | let sendToThem' f = sendToThem $ f $ key2c reserved_id |
192 | sendToMe' f = sendToMe $ f $ key2c i | 192 | sendToClient' f = sendToClient $ f $ key2c i |
193 | writeTVar peer theirSession | 193 | writeTVar peer theirSession |
194 | { solicited = Map.delete me (solicited theirSession) | 194 | { solicited = Map.delete thisKey (solicited theirSession) |
195 | , associated = IntMap.insert reserved_id sendToMe' (associated theirSession) | 195 | , associated = IntMap.insert reserved_id sendToClient' (associated theirSession) |
196 | } | 196 | } |
197 | writeTVar session mySession | 197 | writeTVar session mySession |
198 | { solicited = Map.delete them (solicited mySession) | 198 | { solicited = Map.delete them (solicited mySession) |
199 | , associated = IntMap.insert i sendToThem' (associated mySession) | 199 | , associated = IntMap.insert i sendToThem' (associated mySession) |
200 | } | 200 | } |
201 | return $ do sendToThem' ConnectNotification | 201 | return $ do |
202 | sendToMe' ConnectNotification | 202 | let showSession n k = "("++ show (key2c n) ++ ")" ++ showKey256 k |
203 | return $ do sendToMe $ RoutingResponse (maybe badcon key2c mi) them | 203 | dput XRelay $ |
204 | "Relay session " ++ showSession reserved_id thisKey | ||
205 | ++ " <--> " ++ showSession i them | ||
206 | sendToThem' ConnectNotification | ||
207 | sendToClient' ConnectNotification | ||
208 | return $ do sendToClient $ RoutingResponse (maybe badcon key2c mi) them | ||
204 | sequence_ notifyConnect | 209 | sequence_ notifyConnect |
205 | 210 | ||
206 | RelayPing x -> sendToMe $ RelayPong x -- TODO x==0 is invalid. Do we care? | 211 | RelayPing x -> sendToClient $ RelayPong x -- TODO x==0 is invalid. Do we care? |
207 | 212 | ||
208 | OOBSend them bs -> do | 213 | OOBSend them bs -> do |
209 | dput XRelay $ "OOB send to " ++ showKey256 them | 214 | dput XRelay $ "OOB send to " ++ showKey256 them |
210 | m <- atomically $ Map.lookup them <$> readTVar cons | 215 | m <- atomically $ Map.lookup them <$> readTVar cons |
211 | forM_ m $ \(sendToThem,_) -> sendToThem $ OOBRecv me bs | 216 | forM_ m $ \(sendToThem,_) -> sendToThem $ OOBRecv thisKey bs |
212 | 217 | ||
213 | RelayData bs con -> do | 218 | RelayData bs con -> do |
214 | mySession <- atomically $ readTVar session | 219 | mySession <- atomically $ readTVar session |
@@ -220,7 +225,8 @@ handlePacket cons thistcp me crypto sendOnion sendToMe session = \case | |||
220 | i <- c2key con | 225 | i <- c2key con |
221 | sendToThem' <- IntMap.lookup i $ associated mySession | 226 | sendToThem' <- IntMap.lookup i $ associated mySession |
222 | return $ sendToThem' $ RelayData bs | 227 | return $ sendToThem' $ RelayData bs |
223 | dput XRelay $ "RelayData to con " ++ show con ++ maybe "to no key" (\io -> "to an associatied key") mbSendIt | 228 | dput XRelay $ "RelayData from " ++ showKey256 thisKey ++ " to conid=" |
229 | ++ show con ++ maybe " (no key)" (\io -> " (associated key)") mbSendIt | ||
224 | sequence_ mbSendIt | 230 | sequence_ mbSendIt |
225 | 231 | ||
226 | OnionPacket n24 (Addressed addr req) -> do | 232 | OnionPacket n24 (Addressed addr req) -> do |