allow read Worker to close streams on read failure and prevent it from stopping itself in this case

source/Network/Xmpp/Concurrent/Threads.hs

@@ -23,37 +23,50 @@ import           System.Log.Logger
 readWorker :: (Stanza -> IO ())
            -> (XmppFailure -> IO ())
            -> TMVar Stream
-           -> IO ()
+           -> IO a
-readWorker onStanza onConnectionClosed stateRef = Ex.mask_ go
+readWorker onStanza onConnectionClosed stateRef = forever . Ex.mask_ $ do
-  where
+
-    go = do
+    s' <- Ex.catches ( do
-        res <- Ex.catches ( do
+                   -- we don't know whether pull will
-                       -- we don't know whether pull will
+                   -- necessarily be interruptible
-                       -- necessarily be interruptible
+                        atomically $ do
-                       s <- atomically $ do
                             s@(Stream con) <- readTMVar stateRef
                             scs <- streamConnectionState <$> readTMVar con
-                            when (scs == Closed)
+                            when (stateIsClosed scs)
                                  retry
-                            return s
+                            return $ Just s
-                       allowInterrupt
+                   )
-                       Just <$> pullStanza s
+               [ Ex.Handler $ \(Interrupt t) -> do
-                       )
+                     void $ handleInterrupts [t]
-                   [ Ex.Handler $ \(Interrupt t) -> do
+                     return Nothing
-                         void $ handleInterrupts [t]
+
-                         return Nothing
+               ]
-                   , Ex.Handler $ \(e :: XmppFailure) -> do
+    case s' of
-                         onConnectionClosed e
+        Nothing -> return ()
-                         errorM "Pontarius.Xmpp" $  "Read error: " ++ show e
+        Just s -> do
-                         return Nothing
+            res <- Ex.catches (do
-                   ]
+                             allowInterrupt
-        case res of
+                             Just <$> pullStanza s
-              Nothing -> go -- Caught an exception, nothing to do. TODO: Can this happen?
+                              )
-              Just (Left e) -> do
+                       [ Ex.Handler $ \(Interrupt t) -> do
-                  infoM "Pontarius.Xmpp.Reader" $
+                              void $ handleInterrupts [t]
-                          "Connection died: " ++ show e
+                              return Nothing
-                  onConnectionClosed e
+                       , Ex.Handler $ \(e :: XmppFailure) -> do
-              Just (Right sta) -> onStanza sta >> go
+                              errorM "Pontarius.Xmpp" $ "Read error: "
+                                                         ++ show e
+                              closeStreams s
+                              onConnectionClosed e
+                              return Nothing
+                       ]
+            case res of
+                Nothing -> return () -- Caught an exception, nothing to
+                                     -- do. TODO: Can this happen?
+                Just (Left e) -> do
+                    errorM "Pontarius.Xmpp" $ "Stanza error:" ++ show e
+                    closeStreams s
+                    onConnectionClosed e
+                Just (Right sta) -> void $ onStanza sta
+  where
     -- Defining an Control.Exception.allowInterrupt equivalent for GHC 7
     -- compatibility.
     allowInterrupt :: IO ()
@@ -67,6 +80,10 @@ readWorker onStanza onConnectionClosed stateRef = Ex.mask_ go
     handleInterrupts ts =
         Ex.catch (atomically $ forM ts takeTMVar)
             (\(Interrupt t) -> handleInterrupts (t:ts))
+    stateIsClosed Closed   = True
+    stateIsClosed Finished = True
+    stateIsClosed _        = False
+
 
 -- Two streams: input and output. Threads read from input stream and write to
 -- output stream.