Update TCP kademlia table.

3 files changed, 47 insertions, 13 deletions

diff --git a/src/Network/Kademlia/Bootstrap.hs b/src/Network/Kademlia/Bootstrap.hs
index 0f5d4e4d..1324ae77 100644
--- a/src/Network/Kademlia/Bootstrap.hs
+++ b/src/Network/Kademlia/Bootstrap.hs
@@ -424,3 +424,14 @@ touchBucket r@BucketRefresher{ refreshSearch
             modifyTVar' refreshQueue $ Int.insert num (now + interval)
             writeTVar refreshLastTouch now
             return action
+
+refreshKademlia :: SensibleNodeId nid ni => BucketRefresher nid ni -> Kademlia nid ni
+refreshKademlia r@BucketRefresher { refreshSearch  = sch
+                                  , refreshPing    = ping
+                                  , refreshBuckets = bkts
+                                  }
+                = Kademlia quietInsertions (searchSpace sch) (vanillaIO bkts ping)
+                    { tblTransition = \tr -> do
+                        io <- touchBucket r tr
+                        return io
+                    }
diff --git a/src/Network/Tox.hs b/src/Network/Tox.hs
index 1e82c0c4..ea9bbe56 100644
--- a/src/Network/Tox.hs
+++ b/src/Network/Tox.hs
@@ -59,6 +59,7 @@ import Network.Tox.NodeId
 import qualified Network.Tox.Onion.Handlers  as Onion
 import qualified Network.Tox.Onion.Transport as Onion
 import Network.Tox.Transport
+import Network.Tox.TCP (tcpClient)
 import OnionRouter
 import Network.Tox.ContactInfo
 import Text.XXD
@@ -372,6 +373,8 @@ forkTox tox with_avahi = do
     quitOnion   <- forkListener "toxOnion" (clientNet $ toxOnion tox)
     quitDHT     <- forkListener "toxDHT" (clientNet $ toxDHT tox)
     quitNC      <- forkListener "toxCrypto" (toxCrypto tox)
+    quitTCP     <- forkListener "relay-client" (clientNet $ tcpClient $ tcpKademliaClient $ toxOnionRoutes tox)
+    tcpKademlia <- forkPollForRefresh (tcpBucketRefresher $ toxOnionRoutes tox)
     quitAvahi <- if with_avahi then do
                     forkPollForRefresh (DHT.refresher4 $ toxRouting tox)
                     forkPollForRefresh (DHT.refresher6 $ toxRouting tox)
@@ -387,6 +390,8 @@ forkTox tox with_avahi = do
                 quitNC
                 quitDHT
                 quitOnion
+                quitTCP
+                killThread tcpKademlia
                 quitToRoute
                 quitHs
            , bootstrap (DHT.refresher4 $ toxRouting tox)
diff --git a/src/Network/Tox/TCP.hs b/src/Network/Tox/TCP.hs
index 5c6456f6..353b5ea3 100644
--- a/src/Network/Tox/TCP.hs
+++ b/src/Network/Tox/TCP.hs
@@ -22,6 +22,7 @@ import Data.Word
 import qualified Data.Vector as Vector
 import Network.Socket (SockAddr(..))
 import qualified Text.ParserCombinators.ReadP as RP
+import System.IO.Error
 
 import Crypto.Tox
 import Data.ByteString (hPut,hGet,ByteString,length)
@@ -95,7 +96,7 @@ nodeAddr ni = setPort (tcpPort ni) $ UDP.nodeAddr $ udpNodeInfo ni
 nodeIP :: NodeInfo -> IP
 nodeIP ni = UDP.nodeIP $ udpNodeInfo ni
 
-tcpStream :: (Serialize y, Sized y, Serialize x, Sized x) =>
+tcpStream :: (Show y, Show x, Serialize y, Sized y, Serialize x, Sized x) =>
                    TransportCrypto -> StreamHandshake NodeInfo x y
 tcpStream crypto = StreamHandshake
     { streamHello = \addr h -> do
@@ -112,28 +113,45 @@ tcpStream crypto = StreamHandshake
                                 }
                 }
         noncef <- lookupNonceFunction crypto (transportSecret crypto) (UDP.id2key $ nodeId addr)
+        dput XTCP $ "TCP:" ++ show addr ++ " <-- " ++ show hello
         hPut h $ encode $ encryptPayload (noncef $ helloNonce hello) hello
         welcomeE <- withSize $ fmap decode . hGet h . constSize
         let Right welcome = welcomeE >>= \w -> decryptPayload (noncef $ welcomeNonce w) w
+        dput XTCP $ "TCP:" ++ show addr ++ " --> " ++ show welcome
         noncef' <- lookupNonceFunction crypto skey (sessionPublicKey $ runIdentity $ welcomeData welcome)
         nsend <- newMVar (sessionBaseNonce $ runIdentity $ helloData hello)
         nread <- newMVar (sessionBaseNonce $ runIdentity $ welcomeData welcome)
         let them = sessionPublicKey $ runIdentity $ welcomeData welcome
         return SessionProtocol
-            { streamGoodbye = return () -- No goodbye packet?  Seems rude.
-            , streamDecode = do
-                decode <$> hGet h 2 >>= \case
-                    Left _    -> return Nothing
-                    Right len -> do
-                        decode <$> hGet h (fromIntegral (len :: Word16)) >>= \case
-                            Left _  -> return Nothing
-                            Right x -> do
-                                n24 <- takeMVar nread
-                                let r = decrypt (noncef' n24) x >>= decodePlain
-                                putMVar nread (incrementNonce24 n24)
-                                return $ either (const Nothing) Just r
+            { streamGoodbye = do
+                dput XTCP $ "Closing " ++ show addr
+                return () -- No goodbye packet?  Seems rude.
+            , streamDecode =
+                let go = decode <$> hGet h 2 >>= \case
+                        Left e    -> do
+                            dput XTCP $ "TCP: Failed to get length: " ++ e
+                            return Nothing
+                        Right len -> do
+                            decode <$> hGet h (fromIntegral (len :: Word16)) >>= \case
+                                Left e  -> do
+                                    dput XTCP $ "TCP: Failed to decode packet."
+                                    return Nothing
+                                Right x -> do
+                                    n24 <- takeMVar nread
+                                    let r = decrypt (noncef' n24) x >>= decodePlain
+                                    putMVar nread (incrementNonce24 n24)
+                                    either (dput XTCP)
+                                           (\x' -> do
+                                                dput XTCP $ "TCP:" ++ show addr ++ " --> " ++ show x'
+                                                return ())
+                                           r
+                                    return $ either (const Nothing) Just r
+                 in go `catchIOError` \e -> do
+                            dput XTCP $ "TCP exception: " ++ show e
+                            return Nothing
             , streamEncode = \y -> do
                 n24 <- takeMVar nsend
+                dput XTCP $ "TCP:" ++ show addr ++ " <-- " ++ show y
                 let bs = encode $ encrypt (noncef' n24) $ encodePlain y
                 hPut h $ encode (fromIntegral $ Data.ByteString.length bs :: Word16)
                             <> bs