Update TCP kademlia table.

1 files changed, 31 insertions, 13 deletions

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