From 06713295ae18dec2cfdb1fee325bc5437a50394f Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Mon, 23 Nov 2015 14:23:32 +0100 Subject: [PATCH] fix exception on unexpected stream end (#88) --- examples/echoclient/Main.hs | 15 ++++++++++--- examples/echoclient/echoclient.cabal | 9 +++++++- source/Network/Xmpp/Concurrent.hs | 1 - source/Network/Xmpp/Concurrent/Monad.hs | 2 +- source/Network/Xmpp/Concurrent/Threads.hs | 21 +++++++++++------- source/Network/Xmpp/Stream.hs | 26 +++++++++++++++++------ 6 files changed, 53 insertions(+), 21 deletions(-) diff --git a/examples/echoclient/Main.hs b/examples/echoclient/Main.hs index 9f2730b..8bab19c 100644 --- a/examples/echoclient/Main.hs +++ b/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" - (Just (\_ -> ( [scramSha1 "username" Nothing "password"]) + "test.pontarius.org" + (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 () diff --git a/examples/echoclient/echoclient.cabal b/examples/echoclient/echoclient.cabal index e9f3297..080dfda 100755 --- a/examples/echoclient/echoclient.cabal +++ b/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 \ No newline at end of file diff --git a/source/Network/Xmpp/Concurrent.hs b/source/Network/Xmpp/Concurrent.hs index 7ac691c..96ea431 100644 --- a/source/Network/Xmpp/Concurrent.hs +++ b/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 diff --git a/source/Network/Xmpp/Concurrent/Monad.hs b/source/Network/Xmpp/Concurrent/Monad.hs index 7b8f360..46d2946 100644 --- a/source/Network/Xmpp/Concurrent/Monad.hs +++ b/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) diff --git a/source/Network/Xmpp/Concurrent/Threads.hs b/source/Network/Xmpp/Concurrent/Threads.hs index 3137764..d5b57ac 100644 --- a/source/Network/Xmpp/Concurrent/Threads.hs +++ b/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 + stopWrites = atomically $ do + _ <- takeTMVar writeSem + putTMVar writeSem $ \_ -> return $ Left XmppNoStream killConnection threads = liftIO $ do - _ <- atomically $ do - _ <- takeTMVar writeSem - putTMVar writeSem $ \_ -> return $ Left XmppNoStream + 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 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 diff --git a/source/Network/Xmpp/Stream.hs b/source/Network/Xmpp/Stream.hs index db461c9..5e99b83 100644 --- a/source/Network/Xmpp/Stream.hs +++ b/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) -wrapIOException action = do + String + -> 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 -- "". 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 ()