fix exception on unexpected stream end (#88)

examples/echoclient/Main.hs

@@ -12,17 +12,24 @@ module Main where
 
 import Control.Monad
 import Data.Default
+import Lens.Family2
 import Network.Xmpp
+import Network.Xmpp.Internal (TlsBehaviour(..))
 import System.Log.Logger
 
+
 main :: IO ()
 main = do
     updateGlobalLogger "Pontarius.Xmpp" $ setLevel DEBUG
     result <- session
-                 "example.com"
+                 "test.pontarius.org"
-                  (Just (\_ -> ( [scramSha1 "username" Nothing "password"])
+                  (Just (\_ -> ( [scramSha1 "testuser1" Nothing "pwd1"])
                                , Nothing))
-                  def
+                  $ def & streamConfigurationL . tlsBehaviourL .~ PreferPlain
+                        & streamConfigurationL . connectionDetailsL .~
+                            UseHost "localhost" 5222
+                        & onConnectionClosedL .~ reconnectSession
+
     sess <- case result of
                 Right s -> return s
                 Left e -> error $ "XmppFailure: " ++ (show e)
@@ -32,3 +39,5 @@ main = do
         case answerMessage msg (messagePayload msg) of
             Just answer -> sendMessage answer sess >> return ()
             Nothing -> putStrLn "Received message with no sender."
+  where
+    reconnectSession sess failure = reconnect' sess >> return ()

examples/echoclient/echoclient.cabal

@@ -13,5 +13,12 @@ Maintainer:     info@jonkri.com
 Synopsis:       Echo client test program for Pontarius XMPP
 
 Executable echoclient
-  Build-Depends:  base, data-default, hslogger, mtl, pontarius-xmpp, text, tls
+  Build-Depends:  base
+                , data-default
+                , hslogger
+                , lens-family
+                , mtl
+                , pontarius-xmpp
+                , text
+                , tls
   Main-Is:        Main.hs

source/Network/Xmpp/Concurrent.hs

@@ -318,7 +318,6 @@ reconnectNow sess@Session{conf = config, reconnectWait = rw} = do
             when (enableRoster config) $ initRoster sess
             return Nothing
 
-
 -- | Reconnect with the stored settings.
 --
 -- Waits a random amount of seconds (between 0 and 60 inclusive) before the

source/Network/Xmpp/Concurrent/Monad.hs

@@ -29,7 +29,7 @@ withConnection a session =  do
         -- We acquire the write and stateRef locks, to make sure that this is
         -- the only thread that can write to the stream and to perform a
         -- withConnection calculation. Afterwards, we release the lock and
-        -- fetches an updated state.
+        -- fetch an updated state.
         s <- Ex.catch
             (atomically $ do
                  _ <- takeTMVar (writeSemaphore session)

source/Network/Xmpp/Concurrent/Threads.hs

@@ -24,7 +24,6 @@ readWorker :: (Stanza -> IO ())
            -> TMVar Stream
            -> IO a
 readWorker onStanza onCClosed stateRef = forever . Ex.mask_ $ do
-
     s' <- Ex.catches ( do
                         atomically $ do
                             s@(Stream con) <- readTMVar stateRef
@@ -38,9 +37,9 @@ readWorker onStanza onCClosed stateRef = forever . Ex.mask_ $ do
                      return Nothing
 
                ]
-    case s' of
+    case s' of -- Maybe Stream
         Nothing -> return ()
-        Just s -> do
+        Just s -> do -- Stream
             res <- Ex.catches (do
                    -- we don't know whether pull will
                    -- necessarily be interruptible
@@ -95,16 +94,22 @@ startThreadsWith writeSem stanzaHandler eh con keepAlive = do
     -- writeSem <- newTMVarIO read'
     conS <- newTMVarIO con
     cp <- forkIO $ connPersist keepAlive writeSem
-    rdw <- forkIO $ readWorker stanzaHandler (noCon eh) conS
+    let onConClosed failure = do
+            stopWrites
+            noCon eh failure
+    rdw <- forkIO $ readWorker stanzaHandler onConClosed conS
     return $ Right ( killConnection [rdw, cp]
                    , conS
                    , rdw
                    )
   where
-    killConnection threads = liftIO $ do
+    stopWrites = atomically $ do
-        _ <- atomically $ do
         _ <- takeTMVar writeSem
         putTMVar writeSem $ \_ -> return $ Left XmppNoStream
+    killConnection threads = liftIO $ do
+        debugM "Pontarius.Xmpp" "killing connection"
+        stopWrites
+        debugM "Pontarius.Xmpp" "killing threads"
         _ <- forM threads killThread
         return ()
     -- Call the connection closed handlers.
@@ -115,7 +120,7 @@ startThreadsWith writeSem stanzaHandler eh con keepAlive = do
         return ()
 
 -- Acquires the write lock, pushes a space, and releases the lock.
--- | Sends a blank space every 30 seconds to keep the connection alive.
+-- | Sends a blank space every <delay> seconds to keep the connection alive.
 connPersist :: Maybe Int -> TMVar (BS.ByteString -> IO a) -> IO ()
 connPersist (Just delay) sem = forever $ do
     pushBS <- atomically $ takeTMVar sem

source/Network/Xmpp/Stream.hs

@@ -373,13 +373,20 @@ debugOut outData = liftIO $ debugM "Pontarius.Xmpp"
              ("Out: " ++ (Text.unpack . Text.decodeUtf8 $ outData))
 
 wrapIOException :: MonadIO m =>
-                   IO a -> m (Either XmppFailure a)
+                   String
-wrapIOException action = do
+                -> IO a
+                -> m (Either XmppFailure a)
+wrapIOException tag action = do
     r <- liftIO $ tryIOError action
     case r of
         Right b -> return $ Right b
         Left e -> do
-            liftIO $ warningM "Pontarius.Xmpp" $ "wrapIOException: Exception wrapped: " ++ (show e)
+            liftIO $ warningM "Pontarius.Xmpp" $ concat
+                [ "wrapIOException ("
+                , tag
+                , ") : Exception wrapped: "
+                , show e
+                ]
             return $ Left $ XmppIOException e
 
 pushElement :: Element -> StateT StreamState IO (Either XmppFailure ())
@@ -513,9 +520,11 @@ zeroSource = do
 
 handleToStreamHandle :: Handle -> StreamHandle
 handleToStreamHandle h = StreamHandle { streamSend = \d ->
-                                         wrapIOException $ BS.hPut h d
+                                         wrapIOException "streamSend"
+                                           $ BS.hPut h d
                                       , streamReceive = \n ->
-                                         wrapIOException $ BS.hGetSome h n
+                                         wrapIOException "streamReceive"
+                                           $ BS.hGetSome h n
                                       , streamFlush = hFlush h
                                       , streamClose = hClose h
                                       }
@@ -762,7 +771,7 @@ srvLookup realm resolvSeed = ErrorT $ do
 killStream :: Stream -> IO (Either XmppFailure ())
 killStream = withStream $ do
     cc <- gets (streamClose . streamHandle)
-    err <- wrapIOException cc
+    err <- wrapIOException "killStream" cc
     -- (ExL.try cc :: IO (Either ExL.SomeException ()))
     put xmppNoStream{ streamConnectionState = Finished }
     return err
@@ -813,7 +822,10 @@ elements = do
                                                  elements
             -- This might be an XML error if the end element tag is not
             -- "</stream>". TODO: We might want to check this at a later time
-            Just (EventEndElement _) -> throwError StreamEndFailure
+            Just EventEndElement{} -> throwError StreamEndFailure
+            -- This happens when the connection to the server is closed without
+            -- the stream being properly terminated
+            Just EventEndDocument -> throwError StreamEndFailure
             Just (EventContent (ContentText ct)) | Text.all isSpace ct ->
                 elements
             Nothing -> return ()