From 048be2a604fe49f64e0ba5272e3f9380eb8d8cce Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Er=C3=A8be?= <romain.gerard@erebe.eu>
Date: Sat, 26 Nov 2016 16:59:21 +0100
Subject: [PATCH] Fix udp server

Former-commit-id: dc6b384be35d0da3d96502aee7a34f03f64069f9
Former-commit-id: 886ee2d95c42ce476a9233c66d266f76edd7c352 [formerly 5938a7b6b407cdc64f0972b4fe0d5cc44af815a6] [formerly 71fe7cf675464eee1ee6c467e6835ea0ae60f30a [formerly 3ed2dbb76a6fe601478b01b60a4b845703eee2d2 [formerly 3ed2dbb76a6fe601478b01b60a4b845703eee2d2 [formerly 3ed2dbb76a6fe601478b01b60a4b845703eee2d2 [formerly c58f0795fa3796cb7873988ebf64361b0860c4b5]]]]]
Former-commit-id: 7bc8c5f4bfa8854ace4360d9d645795964923fdf [formerly ae69d9d2df4790d121871a578a48ac1e3414498f]
Former-commit-id: ce2df65ede7f77d7e0a59ee65e502f88a5c85c6b
Former-commit-id: a69b9bfb8c42a9a9523535e2c225fec06228c4eb
Former-commit-id: efc5bbd6fbe9cd3f550f5767313559a1df65bb77
Former-commit-id: f32be564261055e3499491aff9bc88ca0e897adf [formerly 794c396edb9719688b3040a2f484afa3591059f9]
Former-commit-id: ab8cbe512c3737a53733083fb8f499e6bf589fb1
---
 src/Protocols.hs | 10 +++++++---
 1 file changed, 7 insertions(+), 3 deletions(-)

diff --git a/src/Protocols.hs b/src/Protocols.hs
index d9f1dbe..c22c5ac 100644
--- a/src/Protocols.hs
+++ b/src/Protocols.hs
@@ -45,7 +45,7 @@ runUDPClient endPoint@(host, port) app = do
     app UdpAppData { appAddr  = N.addrAddress addrInfo
                    , appSem   = sem
                    , appRead  = fst <$> N.recvFrom socket 4096
-                   , appWrite = \payload -> void $ N.sendTo socket payload (N.addrAddress addrInfo)
+                   , appWrite = \payload -> void $ N.sendAllTo socket payload (N.addrAddress addrInfo)
                    }
 
   info $ "CLOSE udp connection to " <> toStr endPoint
@@ -65,7 +65,7 @@ runUDPServer endPoint@(host, port) app = do
       let appData = UdpAppData { appAddr  = addr
                                , appSem   = sem
                                , appRead  = takeMVar sem
-                               , appWrite = \payload' -> void $ N.sendTo socket payload' addr
+                               , appWrite = \payload' -> void $ N.sendAllTo socket payload' addr
                                }
       void $ atomicModifyIORef' clientsCtx (\clients -> (H.insert addr appData clients, ()))
       return appData
@@ -76,7 +76,11 @@ runUDPServer endPoint@(host, port) app = do
       debug "TIMEOUT connection"
 
     pushDataToClient :: UdpAppData -> ByteString -> IO ()
-    pushDataToClient clientCtx = putMVar (appSem clientCtx)
+    pushDataToClient clientCtx payload = putMVar (appSem clientCtx) payload
+      `catch` (\(_ :: SomeException) -> debug $ "DROP udp packet, client thread dead")
+     -- If we are unlucky the client's thread died before we had the time to push the data on a already full mutex
+     -- and will leave us waiting forever for the mutex to empty. So catch the exeception and drop the message.
+     -- Udp is not a reliable protocol so transmission failure should be handled by the application layer
 
     runEventLoop :: IORef (H.HashMap N.SockAddr UdpAppData) -> N.Socket -> IO ()
     runEventLoop clientsCtx socket = forever $ do