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/examples/dhtd.hs             |  9 ---------
 dht/src/Network/QueryResponse.hs | 17 ++++++++---------
 2 files changed, 8 insertions(+), 18 deletions(-)

(limited to 'dht')

diff --git a/dht/examples/dhtd.hs b/dht/examples/dhtd.hs
index 287301d4..eb41c598 100644
--- a/dht/examples/dhtd.hs
+++ b/dht/examples/dhtd.hs
@@ -1850,13 +1850,6 @@ main = do
     quitBt
     quitTox
 
-    -- dput XMisc "Raising sigINT"
-    -- raiseSignal sigINT
-    -- dput XMisc "Raising sigTERM"
-    -- raiseSignal sigTERM -- This shouldn't cause a termination because the signal handler is still installed.
-    --                     -- However, it will interrupt any dangling calls to recvFrom so that those threads
-    --                     -- can clean up.
-
     swarmsdb <- atomically $ readTVar (Mainline.contactInfo swarms)
     forM_ (Map.toList dhts) $ \(netname,dht) -> do
         saveNodes netname dht
@@ -1864,7 +1857,5 @@ main = do
     L.writeFile "bt-peers.dat" $ S.encodeLazy swarmsdb
     dput XMisc $ "Saved bt-peers.dat"
 
-    -- threadDelay 1000000
-
     s <- threadReport False
     putStrLn s
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