Switched to throw-to instead of hClose to quit reader thread

2 files changed, 5 insertions, 6 deletions

diff --git a/Presence/Server.hs b/Presence/Server.hs
index 1d586900..e5ceaf2d 100644
--- a/Presence/Server.hs
+++ b/Presence/Server.hs
@@ -482,8 +482,8 @@ connectionThreads h pinglogic = do
         let finished e  = do
                           hClose h
                           -- warn $ "finished read: " <> bshow (fmap ioeGetErrorType e)
-                          let _ = fmap ioeGetErrorType e -- type hint
-                          -- let _ = fmap what e where what (SomeException _) = undefined
+                          -- let _ = fmap ioeGetErrorType e -- type hint
+                          let _ = fmap what e where what (SomeException _) = undefined
                           atomically $ do tryTakeTMVar outs
                                           putTMVar outs Nothing -- quit writer
                                           putTMVar doner ()
@@ -498,8 +498,8 @@ connectionThreads h pinglogic = do
 
     writerThread <- forkIO . fix $ \loop -> do
         let finished = do -- warn $ "finished write"
-                          hClose h -- quit reader
-                          -- throwTo readerThread (ErrorCall "EOF")
+                          -- hClose h -- quit reader
+                          throwTo readerThread (ErrorCall "EOF")
                           atomically $ putTMVar donew ()
         mb <- atomically $ readTMVar outs
         case mb of Just bs -> handle (\(SomeException e)->finished)
diff --git a/xmppServer.hs b/xmppServer.hs
index 48745e51..e8864706 100644
--- a/xmppServer.hs
+++ b/xmppServer.hs
@@ -160,10 +160,9 @@ forkConnection k pingflag src snk stanzas = do
                                   Just xml -> do
                                     atomically $ Slotted.push slots Nothing xml
                                     inner
-                                  Nothing -> return ())
+                                  Nothing -> loop)
                             (readTMVar rdone >> return (return ()))
                         what
-                    loop
                 ,do pingflag >>= check
                     return $ do
                     wlog $ "TODO: send ping"