summaryrefslogtreecommitdiff
path: root/dht
diff options
context:
space:
mode:
Diffstat (limited to 'dht')
-rw-r--r--dht/examples/dhtd.hs8
-rw-r--r--dht/examples/testTox.hs3
-rw-r--r--dht/examples/toxrelay.hs12
-rw-r--r--dht/src/Network/Tox.hs32
-rw-r--r--dht/src/Network/Tox/Relay.hs39
-rw-r--r--dht/src/Network/Tox/TCP.hs25
6 files changed, 84 insertions, 35 deletions
diff --git a/dht/examples/dhtd.hs b/dht/examples/dhtd.hs
index 68c847c5..5f0eead8 100644
--- a/dht/examples/dhtd.hs
+++ b/dht/examples/dhtd.hs
@@ -698,7 +698,7 @@ clientSession s@Session{..} sock cnum h = do
698 tcnt <- readTVar $ setCount t 698 tcnt <- readTVar $ setCount t
699 icnt <- HashMap.size <$> readTVar (setIDs t) 699 icnt <- HashMap.size <$> readTVar (setIDs t)
700 return (ts,tcnt,icnt) 700 return (ts,tcnt,icnt)
701 (ts,tcnt,icnt) <- trampstate (trampolinesUDP onionRouter) 701 (uts,tcnt,icnt) <- trampstate (trampolinesUDP onionRouter)
702 (tts,ttcnt,ticnt) <- trampstate (trampolinesTCP onionRouter) 702 (tts,ttcnt,ticnt) <- trampstate (trampolinesTCP onionRouter)
703 rs <- getAssocs (pendingRoutes onionRouter) 703 rs <- getAssocs (pendingRoutes onionRouter)
704 pqs <- readTVar (pendingQueries onionRouter) 704 pqs <- readTVar (pendingQueries onionRouter)
@@ -718,9 +718,10 @@ clientSession s@Session{..} sock cnum h = do
718 then show routeVersion 718 then show routeVersion
719 else show routeVersion ++ "(pending)" ] 719 else show routeVersion ++ "(pending)" ]
720 | otherwise = [show n, "error!","","",""] 720 | otherwise = [show n, "error!","","",""]
721 -- otherwise = [show n, "error!",show (IntMap.lookup n rm),show (IntMap.null rm),""]
721 r = map (uncurry showRecord) rs 722 r = map (uncurry showRecord) rs
722 return $ do 723 return $ do
723 hPutClientChunk h $ unlines [ "trampolines(UDP): " ++ show (IntMap.size ts,tcnt,icnt) 724 hPutClientChunk h $ unlines [ "trampolines(UDP): " ++ show (IntMap.size uts,tcnt,icnt)
724 ++ if tcpmode then "" else " *" 725 ++ if tcpmode then "" else " *"
725 , "trampolines(TCP): " ++ show (IntMap.size tts,ttcnt,ticnt) 726 , "trampolines(TCP): " ++ show (IntMap.size tts,ttcnt,ticnt)
726 ++ if tcpmode then " *" else "" 727 ++ if tcpmode then " *" else ""
@@ -1377,12 +1378,13 @@ initTox opts ssvar keysdb mbxmpp invc = case porttox opts of
1377 [""] -> return (Nothing,return (), Map.empty, return [],[]) 1378 [""] -> return (Nothing,return (), Map.empty, return [],[])
1378 toxport -> do 1379 toxport -> do
1379 dput XMisc $ "Supplied key: " ++ show (fmap (Tox.key2id . toPublic) (dhtkey opts)) 1380 dput XMisc $ "Supplied key: " ++ show (fmap (Tox.key2id . toPublic) (dhtkey opts))
1381 crypto <- Tox.newToxCrypto (dhtkey opts)
1380 tox <- Tox.newTox keysdb 1382 tox <- Tox.newTox keysdb
1381 toxport 1383 toxport
1382 (case mbxmpp of 1384 (case mbxmpp of
1383 Nothing -> \_ _ _ -> return () 1385 Nothing -> \_ _ _ -> return ()
1384 Just xmpp -> onNewToxSession xmpp ssvar invc) 1386 Just xmpp -> onNewToxSession xmpp ssvar invc)
1385 (dhtkey opts) 1387 crypto
1386 (\_ _ -> return ()) -- TODO: TCP relay send 1388 (\_ _ -> return ()) -- TODO: TCP relay send
1387 -- addrTox <- getBindAddress toxport (ip6tox opts) 1389 -- addrTox <- getBindAddress toxport (ip6tox opts)
1388 (quitTox, toxStrap4, toxStrap6) <- Tox.forkTox tox (advertiseOnAvahi opts) 1390 (quitTox, toxStrap4, toxStrap6) <- Tox.forkTox tox (advertiseOnAvahi opts)
diff --git a/dht/examples/testTox.hs b/dht/examples/testTox.hs
index 67c4daef..57601422 100644
--- a/dht/examples/testTox.hs
+++ b/dht/examples/testTox.hs
@@ -42,10 +42,11 @@ makeToxNode :: UDPTransport -> Maybe SecretKey
42 -> IO (Tox extra) 42 -> IO (Tox extra)
43makeToxNode udp sec onSessionF = do 43makeToxNode udp sec onSessionF = do
44 keysdb <- newKeysDatabase 44 keysdb <- newKeysDatabase
45 crypto <- newToxCrypto sec
45 newToxOverTransport keysdb 46 newToxOverTransport keysdb
46 (SockAddrInet 0 0) 47 (SockAddrInet 0 0)
47 onSessionF 48 onSessionF
48 sec 49 crypto
49 udp 50 udp
50 (\_ _ -> return ()) 51 (\_ _ -> return ())
51 52
diff --git a/dht/examples/toxrelay.hs b/dht/examples/toxrelay.hs
index af08e8d7..d6b0da17 100644
--- a/dht/examples/toxrelay.hs
+++ b/dht/examples/toxrelay.hs
@@ -1,15 +1,23 @@
1import Network.Address (getBindAddress) 1import Network.Address (getBindAddress,sockAddrPort)
2import Network.SocketLike 2import Network.SocketLike
3import Network.StreamServer 3import Network.StreamServer
4import Network.Tox.Onion.Transport hiding (encrypt,decrypt) 4import Network.Tox.Onion.Transport hiding (encrypt,decrypt)
5import Network.Tox.Relay 5import Network.Tox.Relay
6import Crypto.Tox
7
8import DPut
9import DebugTag
10
11socketPort s = sockAddrPort <$> getSocketName s
6 12
7main :: IO () 13main :: IO ()
8main = do 14main = do
9 udp_addr <- getBindAddress "33445" True 15 udp_addr <- getBindAddress "33445" True
10 let sendOnion :: SockAddr -> OnionRequest N1 -> IO () 16 let sendOnion :: SockAddr -> OnionRequest N1 -> IO ()
11 sendOnion _ _ = return () 17 sendOnion _ _ = return ()
12 (h,sendTCP) <- tcpRelay udp_addr sendOnion 18 setVerbose XNetCrypto
19 crypto <- newCrypto
20 (h,sendTCP) <- tcpRelay crypto udp_addr sendOnion
13 boundPort <- socketPort $ listenSocket h 21 boundPort <- socketPort $ listenSocket h
14 putStrLn $ "Listening on port: " ++ show boundPort 22 putStrLn $ "Listening on port: " ++ show boundPort
15 23
diff --git a/dht/src/Network/Tox.hs b/dht/src/Network/Tox.hs
index 97b97bad..69c56e24 100644
--- a/dht/src/Network/Tox.hs
+++ b/dht/src/Network/Tox.hs
@@ -278,10 +278,10 @@ newOnionClient crypto net r toks keydb orouter map_var store load = c
278newTox :: TVar Onion.AnnouncedKeys -- ^ Store of announced keys we are a rendezvous for. 278newTox :: TVar Onion.AnnouncedKeys -- ^ Store of announced keys we are a rendezvous for.
279 -> [String] -- ^ Bind-address to listen on. Must provide at least one. 279 -> [String] -- ^ Bind-address to listen on. Must provide at least one.
280 -> ( ContactInfo extra -> SockAddr -> Session -> IO () ) 280 -> ( ContactInfo extra -> SockAddr -> Session -> IO () )
281 -> Maybe SecretKey -- ^ Optional DHT secret key to use. 281 -> (TransportCrypto, ContactInfo extra)
282 -> ( Int -> Onion.OnionMessage Encrypted -> IO () ) -- ^ TCP-bound onion responses. 282 -> ( Int -> Onion.OnionMessage Encrypted -> IO () ) -- ^ TCP-bound onion responses.
283 -> IO (Tox extra) 283 -> IO (Tox extra)
284newTox keydb bindspecs onsess suppliedDHTKey tcp = do 284newTox keydb bindspecs onsess crypto tcp = do
285 addrs <- mapM (`getBindAddress` True) bindspecs 285 addrs <- mapM (`getBindAddress` True) bindspecs
286 let tryBind addr next _ = udpTransport' addr `catchIOError` (next . Just) 286 let tryBind addr next _ = udpTransport' addr `catchIOError` (next . Just)
287 failedBind mbe = do 287 failedBind mbe = do
@@ -291,21 +291,14 @@ newTox keydb bindspecs onsess suppliedDHTKey tcp = do
291 throwIO $ userError "Tox UDP listen port?" 291 throwIO $ userError "Tox UDP listen port?"
292 (udp,sock) <- foldr tryBind failedBind addrs Nothing 292 (udp,sock) <- foldr tryBind failedBind addrs Nothing
293 addr <- getSocketName sock 293 addr <- getSocketName sock
294 (relay,sendTCP) <- tcpRelay addr (\a x -> sendMessage udp a $ S.runPut $ Onion.putRequest x) 294 (relay,sendTCP) <- tcpRelay (fst crypto) addr (\a x -> sendMessage udp a $ S.runPut $ Onion.putRequest x)
295 tox <- newToxOverTransport keydb addr onsess suppliedDHTKey udp sendTCP 295 tox <- newToxOverTransport keydb addr onsess crypto udp sendTCP
296 return tox { toxAnnounceToLan = announceToLan sock (key2id $ transportPublic $ toxCryptoKeys tox) 296 return tox { toxAnnounceToLan = announceToLan sock (key2id $ transportPublic $ toxCryptoKeys tox)
297 , toxRelayServer = Just relay 297 , toxRelayServer = Just relay
298 } 298 }
299 299
300-- | This version of 'newTox' is useful for automated tests using 'testPairTransport'. 300newToxCrypto :: Maybe SecretKey -> IO (TransportCrypto, ContactInfo extra)
301newToxOverTransport :: TVar Onion.AnnouncedKeys 301newToxCrypto suppliedDHTKey = do
302 -> SockAddr
303 -> ( ContactInfo extra -> SockAddr -> Session -> IO () )
304 -> Maybe SecretKey
305 -> Onion.UDPTransport
306 -> ( Int -> Onion.OnionMessage Encrypted -> IO () ) -- ^ TCP-bound onion responses.
307 -> IO (Tox extra)
308newToxOverTransport keydb addr onNewSession suppliedDHTKey udp tcp = do
309 roster <- newContactInfo 302 roster <- newContactInfo
310 crypto0 <- newCrypto 303 crypto0 <- newCrypto
311 let -- patch in supplied DHT key 304 let -- patch in supplied DHT key
@@ -316,12 +309,21 @@ newToxOverTransport keydb addr onNewSession suppliedDHTKey udp tcp = do
316 , transportPublic = toPublic k 309 , transportPublic = toPublic k
317 } 310 }
318 -- patch in newly allocated roster state. 311 -- patch in newly allocated roster state.
319 crypto = crypto1 { userKeys = myKeyPairs roster }
320 forM_ suppliedDHTKey $ \k -> do 312 forM_ suppliedDHTKey $ \k -> do
321 maybe (dput XMisc "failed to encode suppliedDHTKey") 313 maybe (dput XMisc "failed to encode suppliedDHTKey")
322 (dputB XMisc . C8.append "Using suppliedDHTKey: ") 314 (dputB XMisc . C8.append "Using suppliedDHTKey: ")
323 $ encodeSecret k 315 $ encodeSecret k
316 return (crypto1 { userKeys = myKeyPairs roster }, roster )
324 317
318-- | This version of 'newTox' is useful for automated tests using 'testPairTransport'.
319newToxOverTransport :: TVar Onion.AnnouncedKeys
320 -> SockAddr
321 -> ( ContactInfo extra -> SockAddr -> Session -> IO () )
322 -> (TransportCrypto, ContactInfo extra)
323 -> Onion.UDPTransport
324 -> ( Int -> Onion.OnionMessage Encrypted -> IO () ) -- ^ TCP-bound onion responses.
325 -> IO (Tox extra)
326newToxOverTransport keydb addr onNewSession (crypto,roster) udp tcp = do
325 drg <- drgNew 327 drg <- drgNew
326 let lookupClose _ = return Nothing 328 let lookupClose _ = return Nothing
327 329
diff --git a/dht/src/Network/Tox/Relay.hs b/dht/src/Network/Tox/Relay.hs
index 2842fcc2..2ecd7ddf 100644
--- a/dht/src/Network/Tox/Relay.hs
+++ b/dht/src/Network/Tox/Relay.hs
@@ -30,6 +30,8 @@ import Network.SocketLike
30import Network.StreamServer 30import Network.StreamServer
31import Network.Tox.Onion.Transport hiding (encrypt,decrypt) 31import Network.Tox.Onion.Transport hiding (encrypt,decrypt)
32 32
33import DPut
34import DebugTag
33 35
34 36
35hGetPrefixed :: Serialize a => Handle -> IO (Either String a) 37hGetPrefixed :: Serialize a => Handle -> IO (Either String a)
@@ -43,6 +45,7 @@ hGetSized h = runGet get <$> B.hGet h len -- We treat parse-fail the same as EOF
43 where 45 where
44 ConstSize len = size :: Size x 46 ConstSize len = size :: Size x
45 47
48-- This type manages ConId assignments.
46data RelaySession = RelaySession 49data RelaySession = RelaySession
47 { indexPool :: IntSet -- ^ Ints that are either solicited or associated. 50 { indexPool :: IntSet -- ^ Ints that are either solicited or associated.
48 , solicited :: Map PublicKey Int -- ^ Reserved ids, not yet in associated. 51 , solicited :: Map PublicKey Int -- ^ Reserved ids, not yet in associated.
@@ -70,17 +73,19 @@ disconnect cons who = join $ atomically $ do
70 in IntMap.foldrWithKey notifyPeer (return ()) cs 73 in IntMap.foldrWithKey notifyPeer (return ()) cs
71 74
72relaySession :: TransportCrypto 75relaySession :: TransportCrypto
76 -> TVar (IntMap (RelayPacket -> IO ()))
73 -> TVar (Map PublicKey (RelayPacket -> IO (),TVar RelaySession)) 77 -> TVar (Map PublicKey (RelayPacket -> IO (),TVar RelaySession))
74 -> (SockAddr -> OnionRequest N1 -> IO ()) 78 -> (SockAddr -> OnionRequest N1 -> IO ())
75 -> sock 79 -> sock
76 -> Int 80 -> Int
77 -> Handle 81 -> Handle
78 -> IO () 82 -> IO ()
79relaySession crypto cons sendOnion _ conid h = do 83relaySession crypto clients cons sendOnion _ conid h = do
80 -- atomically $ modifyTVar' cons $ IntMap.insert conid h 84 -- atomically $ modifyTVar' cons $ IntMap.insert conid h
81 85
82 -- 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
83 87
88 dput XOnion $ "Relay client session conid=" ++ show conid
84 (hGetSized h >>=) $ mapM_ $ \helloE -> do 89 (hGetSized h >>=) $ mapM_ $ \helloE -> do
85 90
86 let me = transportSecret crypto 91 let me = transportSecret crypto
@@ -88,17 +93,24 @@ relaySession crypto cons sendOnion _ conid h = do
88 93
89 noncef <- lookupNonceFunction crypto me them 94 noncef <- lookupNonceFunction crypto me them
90 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
91 forM_ mhello $ \hello -> do 97 forM_ mhello $ \hello -> do
92 let _ = hello :: Hello Identity 98 let _ = hello :: Hello Identity
93 99
100 dput XOnion $ "Relay client sent hello. conid=" ++ show conid
94 (me',welcome) <- atomically $ do 101 (me',welcome) <- atomically $ do
95 skey <- transportNewKey crypto 102 skey <- transportNewKey crypto
96 dta <- HelloData (toPublic skey) <$> transportNewNonce crypto 103 dta <- HelloData (toPublic skey) <$> transportNewNonce crypto
97 w24 <- transportNewNonce crypto 104 w24 <- transportNewNonce crypto
98 return (skey, Welcome w24 $ pure dta) 105 return (skey, Welcome w24 $ pure dta)
99 106
107 dput XOnion $ unlines [ "Relay client to receive welcome. conid=" ++ show conid
108 , show welcome
109 ]
100 B.hPut h $ encode $ encryptPayload (noncef $ welcomeNonce welcome) welcome 110 B.hPut h $ encode $ encryptPayload (noncef $ welcomeNonce welcome) welcome
101 111
112 dput XOnion $ "Relay client welcome sent. conid=" ++ show conid
113
102 noncef' <- let them' = sessionPublicKey (runIdentity $ helloData hello) 114 noncef' <- let them' = sessionPublicKey (runIdentity $ helloData hello)
103 in lookupNonceFunction crypto me' them' 115 in lookupNonceFunction crypto me' them'
104 116
@@ -133,13 +145,20 @@ relaySession crypto cons sendOnion _ conid h = do
133 145
134 handlePacket cons conid (helloFrom hello) crypto sendOnion sendPacket session pkt0 146 handlePacket cons conid (helloFrom hello) crypto sendOnion sendPacket session pkt0
135 147
148 atomically $ modifyTVar' clients $ IntMap.insert conid $
149 \p -> do
150 dput XOnion $ "Sending onion reply to TCP client conid="++show conid
151 sendPacket p
152
136 flip fix (incrementNonce24 base) $ \loop n24 -> do 153 flip fix (incrementNonce24 base) $ \loop n24 -> do
137 m <- readPacket n24 154 m <- readPacket n24
138 forM_ m $ \p -> do 155 forM_ m $ \p -> do
139 handlePacket cons conid (helloFrom hello) crypto sendOnion sendPacket session p 156 handlePacket cons conid (helloFrom hello) crypto sendOnion sendPacket session p
140 loop (incrementNonce24 n24) 157 loop (incrementNonce24 n24)
141 `finally` 158 `finally` do
159 atomically $ modifyTVar' clients $ IntMap.delete conid
142 disconnect cons (helloFrom hello) 160 disconnect cons (helloFrom hello)
161 dput XOnion $ "Relay client session closed. conid=" ++ show conid
143 162
144handlePacket :: TVar (Map PublicKey (RelayPacket -> IO (), TVar RelaySession)) 163handlePacket :: TVar (Map PublicKey (RelayPacket -> IO (), TVar RelaySession))
145 -> Int 164 -> Int
@@ -202,6 +221,7 @@ handlePacket cons thistcp me crypto sendOnion sendToMe session = \case
202 return $ sendToThem' $ RelayData bs 221 return $ sendToThem' $ RelayData bs
203 222
204 OnionPacket n24 (Addressed addr req) -> do 223 OnionPacket n24 (Addressed addr req) -> do
224 dput XOnion $ "Received onion request via TCP client conid="++show thistcp
205 rpath <- atomically $ do 225 rpath <- atomically $ do
206 sym <- transportSymmetric crypto 226 sym <- transportSymmetric crypto
207 n <- transportNewNonce crypto 227 n <- transportNewNonce crypto
@@ -217,19 +237,24 @@ sendTCP_ st addr x = join $ atomically
217 Nothing -> return $ return () 237 Nothing -> return $ return ()
218 Just send -> return $ send $ OnionPacketResponse x 238 Just send -> return $ send $ OnionPacketResponse x
219 239
220tcpRelay :: SockAddr -> (SockAddr -> OnionRequest N1 -> IO ()) -> IO (ServerHandle, Int -> OnionMessage Encrypted -> IO ()) 240tcpRelay :: TransportCrypto
221tcpRelay udp_addr sendOnion = do 241 -> SockAddr -- ^ UDP bind address (this port may be tried for TCP if hardcoded defaults dont work).
222 crypto <- newCrypto 242 -> (SockAddr -> OnionRequest N1 -> IO ()) -- ^ This callback will be used to forward onion messages over udp.
243 -> IO ( ServerHandle -- Handle to the Tox Tcp-Relay server.
244 , Int -> OnionMessage Encrypted -> IO () -- forward onion response to tcp client.
245 )
246tcpRelay crypto udp_addr sendOnion = do
223 cons <- newTVarIO Map.empty 247 cons <- newTVarIO Map.empty
224 clients <- newTVarIO IntMap.empty 248 clients <- newTVarIO IntMap.empty
225 b443 <- getBindAddress "443" True 249 b443 <- getBindAddress "443" True
226 b80 <- getBindAddress "80" True 250 b80 <- getBindAddress "80" True
251 b3389 <- getBindAddress "3389" True
227 b33445 <- getBindAddress "33445" True 252 b33445 <- getBindAddress "33445" True
228 bany <- getBindAddress "" True 253 bany <- getBindAddress "" True
229 h <- streamServer ServerConfig 254 h <- streamServer ServerConfig
230 { serverWarn = hPutStrLn stderr 255 { serverWarn = hPutStrLn stderr
231 , serverSession = relaySession crypto cons sendOnion 256 , serverSession = relaySession crypto clients cons sendOnion
232 } 257 }
233 [b443,b80,udp_addr,b33445,bany] 258 [b443,b80,b3389,udp_addr,b33445,bany]
234 return (h,sendTCP_ clients) 259 return (h,sendTCP_ clients)
235 260
diff --git a/dht/src/Network/Tox/TCP.hs b/dht/src/Network/Tox/TCP.hs
index 13da804f..ca4ca817 100644
--- a/dht/src/Network/Tox/TCP.hs
+++ b/dht/src/Network/Tox/TCP.hs
@@ -48,7 +48,8 @@ import Network.Tox.DHT.Handlers (toxSpace)
48import Network.Tox.Onion.Transport hiding (encrypt,decrypt) 48import Network.Tox.Onion.Transport hiding (encrypt,decrypt)
49import Network.Tox.Onion.Handlers (unwrapAnnounceResponse) 49import Network.Tox.Onion.Handlers (unwrapAnnounceResponse)
50import qualified Network.Tox.NodeId as UDP 50import qualified Network.Tox.NodeId as UDP
51 51import Text.XXD
52import Data.Proxy
52 53
53withSize :: Sized x => (Size x -> m (p x)) -> m (p x) 54withSize :: Sized x => (Size x -> m (p x)) -> m (p x)
54withSize f = case size of len -> f len 55withSize f = case size of len -> f len
@@ -89,14 +90,23 @@ tcpStream crypto = StreamHandshake
89 noncef <- lookupNonceFunction crypto (transportSecret crypto) (UDP.id2key $ nodeId addr) 90 noncef <- lookupNonceFunction crypto (transportSecret crypto) (UDP.id2key $ nodeId addr)
90 dput XTCP $ "TCP:" ++ show addr ++ " <-- " ++ show hello 91 dput XTCP $ "TCP:" ++ show addr ++ " <-- " ++ show hello
91 hPut h $ encode $ encryptPayload (noncef $ helloNonce hello) hello 92 hPut h $ encode $ encryptPayload (noncef $ helloNonce hello) hello
92 welcomeE <- withSize $ fmap decode . hGet h . constSize 93 (welcomeE, wbs) <- do
94 let sz0 = size
95 sz = constSize sz0
96 bs <- hGet h sz
97 return ( fmap (`asProxyTypeOf` sz0) $ decode bs, bs )
93 let mwelcome = welcomeE >>= \w -> decryptPayload (noncef $ welcomeNonce w) w 98 let mwelcome = welcomeE >>= \w -> decryptPayload (noncef $ welcomeNonce w) w
94 nil = SessionProtocol 99 nil = SessionProtocol
95 { streamGoodbye = return () 100 { streamGoodbye = return ()
96 , streamDecode = return Nothing 101 , streamDecode = return Nothing
97 , streamEncode = \y -> dput XTCP $ "TCP nil <-- " ++ show y 102 , streamEncode = \y -> dput XTCP $ "TCP nil <-- " ++ show y
98 } 103 }
99 either (\_ -> return nil) id $ mwelcome <&> \welcome -> do 104 either (\e -> do
105 dput XTCP $ "welcome: " ++ show (Data.ByteString.length wbs) ++ " bytes."
106 forM_ (xxd2 0 wbs) $ dput XTCP
107 dput XTCP $ "TCP(fail welcome): " ++ e
108 return nil
109 ) id $ mwelcome <&> \welcome -> do
100 dput XTCP $ "TCP:" ++ show addr ++ " --> " ++ show welcome 110 dput XTCP $ "TCP:" ++ show addr ++ " --> " ++ show welcome
101 noncef' <- lookupNonceFunction crypto skey (sessionPublicKey $ runIdentity $ welcomeData welcome) 111 noncef' <- lookupNonceFunction crypto skey (sessionPublicKey $ runIdentity $ welcomeData welcome)
102 nsend <- newMVar (sessionBaseNonce $ runIdentity $ helloData hello) 112 nsend <- newMVar (sessionBaseNonce $ runIdentity $ helloData hello)
@@ -118,6 +128,7 @@ tcpStream crypto = StreamHandshake
118 dput XTCP $ "TCP: Failed to decode packet." 128 dput XTCP $ "TCP: Failed to decode packet."
119 return Nothing 129 return Nothing
120 Right x -> do 130 Right x -> do
131 dput XTCP $ "TCP:"++ show addr ++ " --> packet!"
121 m24 <- timeout 1000000 (takeMVar nread) 132 m24 <- timeout 1000000 (takeMVar nread)
122 fmap join $ forM m24 $ \n24 -> do 133 fmap join $ forM m24 $ \n24 -> do
123 let r = decrypt (noncef' n24) x >>= decodePlain 134 let r = decrypt (noncef' n24) x >>= decodePlain
@@ -133,16 +144,16 @@ tcpStream crypto = StreamHandshake
133 dput XTCP $ "TCP exception: " ++ show e 144 dput XTCP $ "TCP exception: " ++ show e
134 return Nothing 145 return Nothing
135 , streamEncode = \y -> do 146 , streamEncode = \y -> do
136 dput XTCP $ "TCP(acquire nonce):" ++ show addr ++ " <-- " ++ show y 147 -- dput XTCP $ "TCP(acquire nonce):" ++ show addr ++ " <-- " ++ show y
137 n24 <- takeMVar nsend 148 n24 <- takeMVar nsend
138 dput XTCP $ "TCP(got nonce):" ++ show addr ++ " <-- " ++ show y 149 -- dput XTCP $ "TCP(got nonce):" ++ show addr ++ " <-- " ++ show y
139 let bs = encode $ encrypt (noncef' n24) $ encodePlain y 150 let bs = encode $ encrypt (noncef' n24) $ encodePlain y
140 ($ h) -- bracket (takeMVar hvar) (putMVar hvar) 151 ($ h) -- bracket (takeMVar hvar) (putMVar hvar)
141 $ \h -> hPut h (encode (fromIntegral $ Data.ByteString.length bs :: Word16) <> bs) 152 $ \h -> hPut h (encode (fromIntegral $ Data.ByteString.length bs :: Word16) <> bs)
142 `catchIOError` \e -> dput XTCP $ "TCP write exception: " ++ show e 153 `catchIOError` \e -> dput XTCP $ "TCP write exception: " ++ show e
143 dput XTCP $ "TCP(incrementing nonce): " ++ show addr ++ " <-- " ++ show y 154 -- dput XTCP $ "TCP(incrementing nonce): " ++ show addr ++ " <-- " ++ show y
144 putMVar nsend (incrementNonce24 n24) 155 putMVar nsend (incrementNonce24 n24)
145 dput XTCP $ "TCP(finished): " ++ show addr ++ " <-- " ++ show y 156 dput XTCP $ "TCP: " ++ show addr ++ " <-- " ++ show y
146 } 157 }
147 , streamAddr = nodeAddr 158 , streamAddr = nodeAddr
148 } 159 }