tcp: this seems to work.

1 files changed, 25 insertions, 13 deletions

diff --git a/src/Network/Tox/TCP.hs b/src/Network/Tox/TCP.hs
index 71050fe8..36200586 100644
--- a/src/Network/Tox/TCP.hs
+++ b/src/Network/Tox/TCP.hs
@@ -11,6 +11,7 @@ import Debug.Trace
 import Control.Arrow
 import Control.Concurrent
 import Control.Concurrent.STM
+import Control.Exception
 import Control.Monad
 import Crypto.Random
 import Data.Aeson (ToJSON(..),FromJSON(..))
@@ -92,7 +93,7 @@ tcpStream crypto = StreamHandshake
             nil = SessionProtocol
                 { streamGoodbye = return ()
                 , streamDecode = return Nothing
-                , streamEncode = \y -> return ()
+                , streamEncode = \y -> dput XTCP $ "TCP nil <-- " ++ show y
                 }
         either (\_ -> return nil) id $ mwelcome <&> \welcome -> do
         dput XTCP $ "TCP:" ++ show addr ++ " --> " ++ show welcome
@@ -100,12 +101,13 @@ tcpStream crypto = StreamHandshake
         nsend <- newMVar (sessionBaseNonce $ runIdentity $ helloData hello)
         nread <- newMVar (sessionBaseNonce $ runIdentity $ welcomeData welcome)
         let them = sessionPublicKey $ runIdentity $ welcomeData welcome
+        hvar <- newMVar h
         return SessionProtocol
             { streamGoodbye = do
                 dput XTCP $ "Closing " ++ show addr
                 return () -- No goodbye packet?  Seems rude.
             , streamDecode =
-                let go = decode <$> hGet h 2 >>= \case
+                let go h = decode <$> hGet h 2 >>= \case
                         Left e    -> do
                             dput XTCP $ "TCP: Failed to get length: " ++ e
                             return Nothing
@@ -115,25 +117,27 @@ tcpStream crypto = StreamHandshake
                                     dput XTCP $ "TCP: Failed to decode packet."
                                     return Nothing
                                 Right x -> do
-                                    m24 <- timeout 100000 (takeMVar nread)
+                                    m24 <- timeout 1000000 (takeMVar nread)
                                     fmap join $ forM m24 $ \n24 -> do
                                         let r = decrypt (noncef' n24) x >>= decodePlain
                                         putMVar nread (incrementNonce24 n24)
-                                        either (dput XTCP)
+                                        either (dput XTCP . ("TCP decryption: " ++))
                                                (\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
+                 in bracket (takeMVar hvar) (putMVar hvar)
+                     $ \h -> go h `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)
-                    `catchIOError` \e -> dput XTCP $ "TCP write exception: " ++ show e
+                ($ h) -- bracket (takeMVar hvar) (putMVar hvar)
+                    $ \h -> hPut h (encode (fromIntegral $ Data.ByteString.length bs :: Word16) <> bs)
+                                `catchIOError` \e -> dput XTCP $ "TCP write exception: " ++ show e
                 putMVar nsend (incrementNonce24 n24)
             }
     , streamAddr = nodeAddr
@@ -154,7 +158,7 @@ nodeSearch tcp = Search
     }
 -}
 
-data TCPClient err meth tid = TCPClient
+data TCPClient err tid = TCPClient
     { tcpCrypto     :: TransportCrypto
     , tcpClient     :: Client err PacketNumber tid NodeInfo (Bool,RelayPacket)
     , tcpGetGateway :: UDP.NodeInfo -> STM (Maybe NodeInfo)
@@ -181,10 +185,10 @@ getTCPNodes tcp seeking dst = do
         return $ Just ts
 -}
 
-getUDPNodes :: TCPClient err () Nonce8 -> NodeId -> UDP.NodeInfo -> IO (Maybe ([UDP.NodeInfo], [UDP.NodeInfo], Maybe ()))
+getUDPNodes :: TCPClient err Nonce8 -> NodeId -> UDP.NodeInfo -> IO (Maybe ([UDP.NodeInfo], [UDP.NodeInfo], Maybe ()))
 getUDPNodes tcp seeking dst = fmap fst <$> getUDPNodes' tcp seeking dst
 
-getUDPNodes' :: TCPClient err () Nonce8 -> NodeId -> UDP.NodeInfo -> IO (Maybe (([UDP.NodeInfo], [UDP.NodeInfo], Maybe ()), NodeInfo))
+getUDPNodes' :: TCPClient err Nonce8 -> NodeId -> UDP.NodeInfo -> IO (Maybe (([UDP.NodeInfo], [UDP.NodeInfo], Maybe ()), NodeInfo))
 getUDPNodes' tcp seeking dst0 = do
     mgateway <- atomically $ tcpGetGateway tcp dst0
     fmap join $ forM mgateway $ \gateway -> do
@@ -201,7 +205,14 @@ getUDPNodes' tcp seeking dst0 = do
         wrap2 <- lookupNonceFunction (tcpCrypto tcp) b (UDP.id2key $ UDP.nodeId dst)
         wrap1 <- lookupNonceFunction (tcpCrypto tcp) c (UDP.id2key $ nodeId gateway)
         wrap0 <- lookupNonceFunction (tcpCrypto tcp) (transportSecret $ tcpCrypto tcp) (UDP.id2key $ UDP.nodeId dst)
-        let meth = MethodSerializer -- MethodSerializer Nonce8 NodeInfo RelayPacket meth AnnounceRequest (Either String AnnounceResponse)
+        let meth :: MethodSerializer
+                        Nonce8
+                        a -- NodeInfo
+                        (Bool, RelayPacket)
+                        PacketNumber
+                        AnnounceRequest
+                        (Either String AnnounceResponse)
+            meth = MethodSerializer
                     { methodTimeout = \tid addr -> return (addr,12000000) -- 12 second timeout
                     , method = OnionPacketID -- meth
                     , wrapQuery = \n8 src gateway x -> (,) True $
@@ -271,6 +282,7 @@ newClient crypto store load = do
                 OnionPacketResponse (OnionAnnounceResponse n8 n24 ciphered) -> IsResponse n8
                 OnionPacketResponse o@(OnionToRouteResponse _) -> IsUnsolicited $ handle2route o
                 OOBRecv k bs          -> IsUnsolicited $ handleOOB k bs
+                wut                   -> IsUnknown (show wut)
             , lookupHandler   = \case
                 PingPacket -> Just MethodHandler
                     { methodParse     = \(_,RelayPing n8) -> Right ()