From e02b3a26895565c492e96b75c7348f3d625b2ba8 Mon Sep 17 00:00:00 2001
From: Joe Crayne <joe@jerkface.net>
Date: Fri, 18 Oct 2019 02:52:25 -0400
Subject: Debugging recvFrom termination.

---
 dht/examples/dhtd.hs             | 15 +++++++++++++--
 dht/src/Network/QueryResponse.hs | 15 +++++++++------
 2 files changed, 22 insertions(+), 8 deletions(-)

(limited to 'dht')

diff --git a/dht/examples/dhtd.hs b/dht/examples/dhtd.hs
index 6bbb3388..287301d4 100644
--- a/dht/examples/dhtd.hs
+++ b/dht/examples/dhtd.hs
@@ -1773,8 +1773,10 @@ main = do
     (waitForSignal, checkQuit) <- do
         signalQuit <- atomically $ newTVar False
         let quitCommand = atomically $ writeTVar signalQuit True
-        installHandler sigTERM (CatchOnce (atomically $ writeTVar signalQuit True)) Nothing
-        installHandler sigINT (CatchOnce (atomically $ writeTVar signalQuit True)) Nothing
+        installHandler sigTERM (CatchOnce (do dput XMisc "sigTERM!"
+                                              atomically $ writeTVar signalQuit True)) Nothing
+        installHandler sigINT (CatchOnce (do dput XMisc "sigINT!"
+                                             atomically $ writeTVar signalQuit True)) Nothing
         let defaultToxData = do
                 rster <- Tox.newContactInfo
                 crypto <- newCrypto
@@ -1848,6 +1850,13 @@ 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
@@ -1855,5 +1864,7 @@ 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 27134470..8f3c078d 100644
--- a/dht/src/Network/QueryResponse.hs
+++ b/dht/src/Network/QueryResponse.hs
@@ -200,11 +200,11 @@ forkListener :: String -> Transport err addr x -> IO (IO ())
 forkListener name client = do
     thread_id <- forkIO $ do
         myThreadId >>= flip labelThread ("listener."++name)
-        fix $ awaitMessage client . const
+        fix $ \loop -> awaitMessage client $ maybe (return ()) (const loop)
         dput XMisc $ "Listener died: " ++ name
     return $ do
         closeTransport client
-        killThread thread_id
+        -- killThread thread_id
 
 asyncQuery_ :: Client err meth tid addr x
               -> MethodSerializer tid addr x meth a b
@@ -560,6 +560,7 @@ ignoreEOF sock isClosed def e = do
     done <- tryReadMVar isClosed
     case done of
         Just () -> do close sock
+                      dput XMisc "Closing UDP socket."
                       pure Nothing
         _ -> if isEOFError e then pure $ Just def
                              else throwIO e
@@ -584,11 +585,11 @@ saferSendTo sock bs saddr = void (B.sendTo sock bs saddr)
 -- argument is the listen-address for incoming packets.  This is a useful
 -- low-level 'Transport' that can be transformed for higher-level protocols
 -- using 'layerTransport'.
-udpTransport :: SockAddr -> IO (Transport err SockAddr ByteString)
+udpTransport :: Show err => SockAddr -> IO (Transport err SockAddr ByteString)
 udpTransport bind_address = fst <$> udpTransport' bind_address
 
 -- | Like 'udpTransport' except also returns the raw socket (for broadcast use).
-udpTransport' :: SockAddr -> IO (Transport err SockAddr ByteString, Socket)
+udpTransport' :: Show err => SockAddr -> IO (Transport err SockAddr ByteString, Socket)
 udpTransport' bind_address = do
   let family = sockAddrFamily bind_address
   sock <- socket family Datagram defaultProtocol
@@ -601,6 +602,7 @@ 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
@@ -618,8 +620,8 @@ udpTransport' bind_address = do
             addr4 -> \bs -> saferSendTo sock bs addr4
         _ -> \addr bs -> saferSendTo sock bs addr
     , closeTransport = do
-        -- close sock
-        tryTakeMVar isClosed >> putMVar isClosed ()
+        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)
@@ -627,6 +629,7 @@ udpTransport' bind_address = do
 #else
         setNonBlockIfNeeded (fdSocket sock) -- setSocketOption sock ??? 0
 #endif
+        -- shutdown sock ShutdownBoth `catchIOError` \_ -> return ()
     }
   return (tr, sock)
 
-- 
cgit v1.2.3