Lossless: Support for handling exceptions on send.

1 files changed, 15 insertions, 6 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