Lossless: Support for handling exceptions on send.

2 files changed, 25 insertions, 7 deletions

diff --git a/src/Network/Lossless.hs b/src/Network/Lossless.hs
index ff0b8cc1..4d5521fd 100644
--- a/src/Network/Lossless.hs
+++ b/src/Network/Lossless.hs
@@ -14,6 +14,7 @@ import Control.Monad
 import Control.Monad.STM
 import Data.Function
 import Data.Word
+import System.IO.Error
 
 import Data.PacketBuffer as PB
 import DPut
@@ -32,12 +33,19 @@ data SequenceInfo = SequenceInfo
     }
  deriving (Eq,Ord,Show)
 
+data OutgoingInfo y = OutgoingInfo
+    { oIsLossy         :: Bool                     -- ^ True if the packet is treated as lossy.
+    , oEncoded         :: y                        -- ^ The packet.
+    , oHandleException :: Maybe (IOError -> IO ()) -- ^ Optionally handle send failure.
+    }
+
 -- | Obtain a reliable transport form an unreliable one.
 lossless :: Show addr =>
-    (x -> addr -> IO (PacketInboundEvent (x',addr'))) -- ^ Used to classify newly arrived packets.
-    -> (SequenceInfo -> x' -> addr' -> IO (Bool,y))   -- ^ Used to encode and classify outbound packets.
-    -> addr                                           -- ^ The remote address for this session.
-    -> TransportA String addr x y                     -- ^ An unreliable lossy transport.
+    (x -> addr -> IO (PacketInboundEvent (x',addr')))       -- ^ Used to classify newly arrived packets.
+    -> (SequenceInfo -> x' -> addr' -> IO (OutgoingInfo y)) -- ^ Used to encode and classify outbound packets.
+    -> addr                                                 -- ^ The remote address for this session.
+    -> TransportA String addr x y                           -- ^ An unreliable lossy transport.
+
     -> IO ( Transport String addr' x' -- ^ A reliable lossless transport.
           , [Word32] -> IO ()         -- ^ Use this to request lost packets be re-sent.
           , IO ([Word32],Word32)      -- ^ Use this to discover missing packets to request.
@@ -86,7 +94,7 @@ lossless isLossless encode saddr udp = do
                     seqno <- PB.nextToSendSequenceNumber pb
                     ack   <- PB.expectingSequenceNumber pb
                     return $ SequenceInfo seqno ack
-                (islossy,x) <- encode seqno x' a'
+                OutgoingInfo islossy x oops <- encode seqno x' a'
                 (isfull,nn) <-
                     if islossy
                         then do
@@ -100,7 +108,8 @@ lossless isLossless encode saddr udp = do
                     atomically $ do
                         (isfull,_) <- PB.grokOutboundPacket pb (PacketSent (sequenceNumber seqno) x)
                         when isfull retry
-                sendMessage udp saddr x
+                let sendit = sendMessage udp saddr x
+                maybe sendit (catchIOError sendit) oops
             , closeTransport = do
                 atomically $ writeTChan oob Nothing -- quit rloop thread
                 closeTransport udp
diff --git a/src/Network/Tox/Session.hs b/src/Network/Tox/Session.hs
index 525338b2..c672087f 100644
--- a/src/Network/Tox/Session.hs
+++ b/src/Network/Tox/Session.hs
@@ -11,6 +11,7 @@ module Network.Tox.Session
 
 import Control.Concurrent.STM
 import Control.Monad
+import Control.Exception
 import Data.Functor.Identity
 import Data.Word
 import Network.Socket         (SockAddr)
@@ -132,7 +133,15 @@ plainHandshakeH sp saddr skey handshake = do
             <- lossless (\cp a -> return $ fmap (,a) $ checkLossless $ runIdentity $ pktData cp)
                         (\seqno p _ -> do
                             y <- encryptPacket sk $ bookKeeping seqno p
-                            return (lossyness (msgID p) == Lossy, y))
+                            return OutgoingInfo
+                                { oIsLossy         = lossyness (msgID p) == Lossy
+                                , oEncoded         = y
+                                , oHandleException = Just $ \e -> do
+                                        dput XUnexpected $ unlines
+                                            [ "<-- " ++ show e
+                                            , "<--   while sending " ++ show (seqno,p) ]
+                                        throwIO e
+                                })
                         ()
                         t
         let _ = t :: TransportA String () (CryptoPacket Identity) (CryptoPacket Encrypted)