From 9273a01aac621f09b0c00292b55153d558b4a4e0 Mon Sep 17 00:00:00 2001
From: Joe Crayne <joe@jerkface.net>
Date: Fri, 18 Oct 2019 04:22:15 -0400
Subject: Use GHC's closeFdWith to un-block recvFrom.

---
 dht/src/Network/QueryResponse.hs | 17 ++++++++---------
 1 file changed, 8 insertions(+), 9 deletions(-)

(limited to 'dht/src')

diff --git a/dht/src/Network/QueryResponse.hs b/dht/src/Network/QueryResponse.hs
index 8f3c078d..4f956936 100644
--- a/dht/src/Network/QueryResponse.hs
+++ b/dht/src/Network/QueryResponse.hs
@@ -32,6 +32,7 @@ import qualified Data.Word64Map     as W64Map
          ;import Data.Word64Map     (Word64Map)
 import Data.Word
 import Data.Maybe
+import GHC.Conc (closeFdWith)
 import GHC.Event
 import Network.Socket
 import Network.Socket.ByteString    as B
@@ -602,7 +603,6 @@ udpTransport' bind_address = do
       awaitMessage = \kont -> do
         r <- handle (ignoreEOF sock isClosed $ Right (B.empty, SockAddrInet 0 0)) $ do
                 Just . Right <$!> B.recvFrom sock udpBufferSize
-        dput XMisc $ "udp.awaitMessage.recvFrom: " ++ show r
         kont $! r
     , sendMessage = case family of
         AF_INET6 -> \case
@@ -621,15 +621,14 @@ udpTransport' bind_address = do
         _ -> \addr bs -> saferSendTo sock bs addr
     , closeTransport = do
         dput XMisc $ "closeTransport for udpTransport' called. " ++ show bind_address
-        tryPutMVar isClosed ()
-        -- set O_NONBLOCK using fcntl
-        -- NOTE: setNonBlockIfNeeded is a no-op on windows
-#if MIN_VERSION_network (3,1,0)
-        withFdSocket sock $ \fd -> setNonBlockIfNeeded fd
-#else
-        setNonBlockIfNeeded (fdSocket sock) -- setSocketOption sock ??? 0
+        tryPutMVar isClosed () -- signal awaitMessage that the transport is closed.
+#if !MIN_VERSION_network (3,1,0)
+        let withFdSocket sock f = f (fdSocket sock)
 #endif
-        -- shutdown sock ShutdownBoth `catchIOError` \_ -> return ()
+        withFdSocket sock $ \fd -> do
+            let sorryGHCButIAmNotFuckingClosingTheSocketYet fd = return ()
+            -- This call is necessary to interrupt the blocking recvFrom call in awaitMessage.
+            closeFdWith sorryGHCButIAmNotFuckingClosingTheSocketYet (fromIntegral fd)
     }
   return (tr, sock)
 
-- 
cgit v1.2.3