add sensible timeout to sendLossless

(also call this function from dispatchMessage)

2 files changed, 11 insertions, 24 deletions

diff --git a/src/Network/Tox/AggregateSession.hs b/src/Network/Tox/AggregateSession.hs
index 26e7153a..27258a6f 100644
--- a/src/Network/Tox/AggregateSession.hs
+++ b/src/Network/Tox/AggregateSession.hs
@@ -242,26 +242,7 @@ dispatchMessage c msid msg = join $ atomically $ do
     imap <- readTVar (contactSession c)
     let go = case msid of Nothing  -> forM_ imap
                           Just sid -> forM_ (IntMap.lookup sid imap)
-    return $ go $ \con -> do
-        outq <- atomically $ do
-            mbOutq <- readTVar (ncOutgoingQueue $ singleSession con)
-            case mbOutq of
-                HaveHandshake outq -> return outq
-                NeedHandshake -> retry
-        extra <- nqToWireIO outq
-        r <- atomically $ do
-                    rTry <- tryAppendQueueOutgoing extra outq msg
-                    case rTry of
-                        OGFull -> retry
-                        OGSuccess x -> return (OGSuccess x)
-                        OGEncodeFail -> return OGEncodeFail
-        case r of
-            OGSuccess x  -> case ncSockAddr (singleSession con) of
-                HaveDHTKey saddr -> sendSessionPacket (ncAllSessions $ singleSession con) saddr x
-                _                    -> return ()
-            OGEncodeFail -> dput XMisc ("FAILURE to Encode Outgoing: " ++ show msg)
-            _                -> return ()
-
+    return $ go $ \con -> sendLossless (transportCrypto (ncAllSessions (singleSession con))) (singleSession con) msg
 
 -- | Retry until:
 --
diff --git a/src/Network/Tox/Crypto/Handlers.hs b/src/Network/Tox/Crypto/Handlers.hs
index 50224178..8975e4dc 100644
--- a/src/Network/Tox/Crypto/Handlers.hs
+++ b/src/Network/Tox/Crypto/Handlers.hs
@@ -39,6 +39,7 @@ import SensibleDir
 import System.FilePath
 import System.Environment
 import System.Directory
+import System.Timeout
 #ifdef THREAD_DEBUG
 import Control.Concurrent.Lifted.Instrument
 #else
@@ -766,8 +767,9 @@ tryAppendQueueOutgoing getExtra outq msg = do
     mbWire <- nqToWire outq getExtra nextno be pktno msg
     case mbWire of
         Just (payload,seqno) -> do
-            PB.grokOutboundPacket (nqPacketBuffer outq) (PacketSent seqno payload)
-            return $ OGSuccess payload
+            (isFull,_) <- PB.grokOutboundPacket (nqPacketBuffer outq) (PacketSent seqno payload)
+            if isFull then return OGFull
+                      else return $ OGSuccess payload
         Nothing -> return OGEncodeFail
 
 
@@ -1253,12 +1255,16 @@ sendCrypto crypto session updateLocal cm = do
     dput XNetCrypto "sendCrypto: enter "
     getOutGoingParam <- nqToWireIO outq
     dput XNetCrypto "sendCrypto: got the io extra stuff"
-    r <- atomically $ do
+    ncTime <- atomically $ readTVar (ncTimeOut session)
+    r0 <- timeout (ncTime*1000) . atomically $ do
         result <- tryAppendQueueOutgoing getOutGoingParam outq cm
         case result of
             OGSuccess x  -> updateLocal >> return (Right x)
-            OGFull       -> return (Left "Outgoing packet buffer is full")
+            OGFull       -> retry -- return (Left "Outgoing packet buffer is full")
             OGEncodeFail -> return (Left "Failed to encode outgoing packet")
+    let r = case r0 of
+                Nothing -> Left "Outgoing packet buffer is full"
+                Just x  -> x
     case ncSockAddr session of
         HaveDHTKey saddr -> mapM_ (sendSessionPacket (ncAllSessions session) saddr) r
         _                -> return ()