From bb311b6279ab0f0f8cf381ed6565bc338c63bcfe Mon Sep 17 00:00:00 2001 From: Jon Kristensen Date: Mon, 4 Feb 2013 23:53:19 +0100 Subject: [PATCH] Tweak failure approach I'm assuming and defining the following: 1. XMPP failures (which can occur at the TCP, TLS, and XML/XMPP layers (as a stream error or forbidden input)) are fatal; they will distrupt the XMPP session. 2. All fatal failures should be thrown (or similar) by `session', or any other function that might produce them. 3. Authentication failures that are not "XMPP failures" are not fatal. They do not necessarily terminate the stream. For example, the developer should be able to make another authentication attempt. The `Session' object returned by `session' might be useful even if the authentication fails. 4. We can (and should) use one single data type for fatal failures. (Previously, both StreamFailure and TlsFailure was used.) 5. We can catch and rethrow/wrap IO exceptions in the context of the Pontarius XMPP error system that we decide to use, making the error system more intuitive, Haskell-like, and more straight-forward to implement. Calling `error' may only be done in the case of a program error (a bug). 6. A logging system will remove the need for many of the error types. Only exceptions that seem likely to affect the flow of client applications should be defined. 7. The authentication functions are prone to fatal XMPP failures in addition to non-fatal authentication conditions. (Previously, `AuthStreamFailure' was used to wrap these errors.) I'm hereby suggesting (and implementing) the following: `StreamFailure' and `TlsFailure' should be joined into `XmppFailure'. `pullStanza' and the other Connection functions used to throw `IOException', `StreamFailure' and `TlsFailure' exceptions. With this patch, they have been converted to `StateT Connection IO (Either XmppFailure a)' computations. They also catch (some) IOException errors and wrap them in the new `XmppIOException' constructor. `newSession' is now `IO (Either XmppFailure Session)' as well (being capable of throwing IO exceptions). Whether or not to continue to a) wrap `XmppFailure' failures in an `AuthStreamFailure' equivalent, or, b) treat the authentication functions just like the other functions that may result in failure (Either XmppFailure a), depends on how Network.Xmpp.Connection.auth will be used. Since the latter will make `auth' more consistent, as well as remove the need for a wrapped (and special-case) "AuthFailure" type, I have decided to give the "b" approach a try. (The drawback being, of course, that authentication errors can not be accessed through the use of ErrorT. Whether or not this might be a problem, I don't really know at this point.) As the SASL code (and SaslM) depended on `AuthStreamFailure', it remains for internal use, at least for the time-being. `session' is now an ErrorT computation as well. Some functions have been updated as hacks, but this will be changed if we decide to move forward with this approach. --- source/Network/Xmpp.hs | 11 +- source/Network/Xmpp/Bind.hs | 28 +++-- source/Network/Xmpp/Concurrent.hs | 20 ++-- source/Network/Xmpp/Concurrent/Monad.hs | 2 +- source/Network/Xmpp/Concurrent/Threads.hs | 43 ++++--- source/Network/Xmpp/Concurrent/Types.hs | 2 +- source/Network/Xmpp/Connection_.hs | 113 ++++++++++-------- source/Network/Xmpp/Pickle.hs | 2 +- source/Network/Xmpp/Sasl.hs | 20 ++-- source/Network/Xmpp/Sasl/Common.hs | 24 ++-- .../Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs | 5 +- source/Network/Xmpp/Sasl/Types.hs | 4 +- source/Network/Xmpp/Session.hs | 40 ++++--- source/Network/Xmpp/Stream.hs | 29 ++--- source/Network/Xmpp/Tls.hs | 13 +- source/Network/Xmpp/Types.hs | 53 ++++---- source/Network/Xmpp/Xep/ServiceDiscovery.hs | 20 ++-- 17 files changed, 240 insertions(+), 189 deletions(-) diff --git a/source/Network/Xmpp.hs b/source/Network/Xmpp.hs index 93c78bb..3744248 100644 --- a/source/Network/Xmpp.hs +++ b/source/Network/Xmpp.hs @@ -139,11 +139,16 @@ module Network.Xmpp , LangTag(..) , exampleParams , PortID(..) - , StreamFailure(..) + , XmppFailure(..) , StreamErrorInfo(..) , StreamErrorCondition(..) - , TlsFailure(..) - , AuthFailure(..) + , AuthFailure( AuthXmlFailure -- Does not export AuthStreamFailure + , AuthNoAcceptableMechanism + , AuthChallengeFailure + , AuthNoConnection + , AuthFailure + , AuthSaslFailure + , AuthStringPrepFailure ) ) where diff --git a/source/Network/Xmpp/Bind.hs b/source/Network/Xmpp/Bind.hs index 4d180ce..a3676e6 100644 --- a/source/Network/Xmpp/Bind.hs +++ b/source/Network/Xmpp/Bind.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE PatternGuards #-} {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_HADDOCK hide #-} @@ -19,6 +18,8 @@ import Control.Monad.State(modify) import Control.Concurrent.STM.TMVar +import Control.Monad.Error + -- Produces a `bind' element, optionally wrapping a resource. bindBody :: Maybe Text -> Element bindBody = pickleElem $ @@ -30,16 +31,21 @@ bindBody = pickleElem $ -- Sends a (synchronous) IQ set request for a (`Just') given or server-generated -- resource and extract the JID from the non-error response. -xmppBind :: Maybe Text -> TMVar Connection -> IO Jid -xmppBind rsrc c = do - answer <- pushIQ' "bind" Nothing Set Nothing (bindBody rsrc) c - jid <- case () of () | Right IQResult{iqResultPayload = Just b} <- answer - , Right jid <- unpickleElem xpJid b - -> return jid - | otherwise -> throw StreamOtherFailure - -- TODO: Log: ("Bind couldn't unpickle JID from " ++ show answer) - withConnection (modify $ \s -> s{cJid = Just jid}) c - return jid +xmppBind :: Maybe Text -> TMVar Connection -> IO (Either XmppFailure Jid) +xmppBind rsrc c = runErrorT $ do + answer <- ErrorT $ pushIQ' "bind" Nothing Set Nothing (bindBody rsrc) c + case answer of + Right IQResult{iqResultPayload = Just b} -> do + let jid = unpickleElem xpJid b + case jid of + Right jid' -> do + ErrorT $ withConnection (do + modify $ \s -> s{cJid = Just jid'} + return $ Right jid') c -- not pretty + return jid' + otherwise -> throwError XmppOtherFailure + -- TODO: Log: ("Bind couldn't unpickle JID from " ++ show answer) + otherwise -> throwError XmppOtherFailure where -- Extracts the character data in the `jid' element. xpJid :: PU [Node] Jid diff --git a/source/Network/Xmpp/Concurrent.hs b/source/Network/Xmpp/Concurrent.hs index 9156b33..fa94910 100644 --- a/source/Network/Xmpp/Concurrent.hs +++ b/source/Network/Xmpp/Concurrent.hs @@ -35,6 +35,8 @@ import Network.Xmpp.Pickle import Network.Xmpp.Types import Text.Xml.Stream.Elements +import Control.Monad.Error + toChans :: TChan Stanza -> TVar IQHandlers -> Stanza @@ -72,16 +74,16 @@ toChans stanzaC iqHands sta = atomically $ do -- | Creates and initializes a new Xmpp context. -newSession :: TMVar Connection -> IO Session -newSession con = do - outC <- newTChanIO - stanzaChan <- newTChanIO - iqHandlers <- newTVarIO (Map.empty, Map.empty) - eh <- newTVarIO $ EventHandlers { connectionClosedHandler = \_ -> return () } +newSession :: TMVar Connection -> IO (Either XmppFailure Session) +newSession con = runErrorT $ do + outC <- lift newTChanIO + stanzaChan <- lift newTChanIO + iqHandlers <- lift $ newTVarIO (Map.empty, Map.empty) + eh <- lift $ newTVarIO $ EventHandlers { connectionClosedHandler = \_ -> return () } let stanzaHandler = toChans stanzaChan iqHandlers - (kill, wLock, conState, readerThread) <- startThreadsWith stanzaHandler eh con - writer <- forkIO $ writeWorker outC wLock - idRef <- newTVarIO 1 + (kill, wLock, conState, readerThread) <- ErrorT $ startThreadsWith stanzaHandler eh con + writer <- lift $ forkIO $ writeWorker outC wLock + idRef <- lift $ newTVarIO 1 let getId = atomically $ do curId <- readTVar idRef writeTVar idRef (curId + 1 :: Integer) diff --git a/source/Network/Xmpp/Concurrent/Monad.hs b/source/Network/Xmpp/Concurrent/Monad.hs index 863c985..ff0f07a 100644 --- a/source/Network/Xmpp/Concurrent/Monad.hs +++ b/source/Network/Xmpp/Concurrent/Monad.hs @@ -71,7 +71,7 @@ modifyHandlers f session = atomically $ modifyTVar (eventHandlers session) f writeTVar var (f x) -- | Sets the handler to be executed when the server connection is closed. -setConnectionClosedHandler_ :: (StreamFailure -> Session -> IO ()) -> Session -> IO () +setConnectionClosedHandler_ :: (XmppFailure -> Session -> IO ()) -> Session -> IO () setConnectionClosedHandler_ eh session = do modifyHandlers (\s -> s{connectionClosedHandler = \e -> eh e session}) session diff --git a/source/Network/Xmpp/Concurrent/Threads.hs b/source/Network/Xmpp/Concurrent/Threads.hs index 1ff2ff3..c55fc16 100644 --- a/source/Network/Xmpp/Concurrent/Threads.hs +++ b/source/Network/Xmpp/Concurrent/Threads.hs @@ -22,10 +22,12 @@ import Control.Concurrent.STM.TMVar import GHC.IO (unsafeUnmask) +import Control.Monad.Error + -- Worker to read stanzas from the stream and concurrently distribute them to -- all listener threads. readWorker :: (Stanza -> IO ()) - -> (StreamFailure -> IO ()) + -> (XmppFailure -> IO ()) -> TMVar (TMVar Connection) -> IO a readWorker onStanza onConnectionClosed stateRef = @@ -45,13 +47,14 @@ readWorker onStanza onConnectionClosed stateRef = [ Ex.Handler $ \(Interrupt t) -> do void $ handleInterrupts [t] return Nothing - , Ex.Handler $ \(e :: StreamFailure) -> do + , Ex.Handler $ \(e :: XmppFailure) -> do onConnectionClosed e return Nothing ] case res of - Nothing -> return () -- Caught an exception, nothing to do - Just sta -> onStanza sta + Nothing -> return () -- Caught an exception, nothing to do. TODO: Can this happen? + Just (Left e) -> return () + Just (Right sta) -> onStanza sta where -- Defining an Control.Exception.allowInterrupt equivalent for GHC 7 -- compatibility. @@ -75,30 +78,32 @@ readWorker onStanza onConnectionClosed stateRef = startThreadsWith :: (Stanza -> IO ()) -> TVar EventHandlers -> TMVar Connection - -> IO - (IO (), + -> IO (Either XmppFailure (IO (), TMVar (BS.ByteString -> IO Bool), TMVar (TMVar Connection), - ThreadId) + ThreadId)) startThreadsWith stanzaHandler eh con = do - read <- withConnection' (gets $ cSend. cHandle) con - writeLock <- newTMVarIO read - conS <- newTMVarIO con --- lw <- forkIO $ writeWorker outC writeLock - cp <- forkIO $ connPersist writeLock - rd <- forkIO $ readWorker stanzaHandler (noCon eh) conS - return ( killConnection writeLock [rd, cp] - , writeLock - , conS - , rd - ) + read <- withConnection' (gets $ cSend . cHandle >>= \d -> return $ Right d) con + case read of + Left e -> return $ Left e + Right read' -> do + writeLock <- newTMVarIO read' + conS <- newTMVarIO con + -- lw <- forkIO $ writeWorker outC writeLock + cp <- forkIO $ connPersist writeLock + rd <- forkIO $ readWorker stanzaHandler (noCon eh) conS + return $ Right ( killConnection writeLock [rd, cp] + , writeLock + , conS + , rd + ) where killConnection writeLock threads = liftIO $ do _ <- atomically $ takeTMVar writeLock -- Should we put it back? _ <- forM threads killThread return () -- Call the connection closed handlers. - noCon :: TVar EventHandlers -> StreamFailure -> IO () + noCon :: TVar EventHandlers -> XmppFailure -> IO () noCon h e = do hands <- atomically $ readTVar h _ <- forkIO $ connectionClosedHandler hands e diff --git a/source/Network/Xmpp/Concurrent/Types.hs b/source/Network/Xmpp/Concurrent/Types.hs index 212ea1e..decce8a 100644 --- a/source/Network/Xmpp/Concurrent/Types.hs +++ b/source/Network/Xmpp/Concurrent/Types.hs @@ -21,7 +21,7 @@ import Network.Xmpp.Types -- | Handlers to be run when the Xmpp session ends and when the Xmpp connection is -- closed. data EventHandlers = EventHandlers - { connectionClosedHandler :: StreamFailure -> IO () + { connectionClosedHandler :: XmppFailure -> IO () } -- | Interrupt is used to signal to the reader thread that it should stop. Th contained semphore signals the reader to resume it's work. diff --git a/source/Network/Xmpp/Connection_.hs b/source/Network/Xmpp/Connection_.hs index 8317ef1..38a7532 100644 --- a/source/Network/Xmpp/Connection_.hs +++ b/source/Network/Xmpp/Connection_.hs @@ -6,6 +6,7 @@ module Network.Xmpp.Connection_ where import Control.Applicative((<$>)) import Control.Concurrent (forkIO, threadDelay) +import System.IO.Error (tryIOError) import Control.Monad import Control.Monad.IO.Class import Control.Monad.Trans.Class @@ -41,7 +42,7 @@ import System.Log.Logger import Data.ByteString.Base64 import Control.Concurrent.STM.TMVar - +import Control.Monad.Error -- Enable/disable debug output -- This will dump all incoming and outgoing network taffic to the console, @@ -49,69 +50,83 @@ import Control.Concurrent.STM.TMVar debug :: Bool debug = False -pushElement :: Element -> StateT Connection IO Bool +-- TODO: Can the TLS send/recv functions throw something other than an IO error? + +wrapIOException :: IO a -> StateT Connection IO (Either XmppFailure a) +wrapIOException action = do + r <- liftIO $ tryIOError action + case r of + Right b -> return $ Right b + Left e -> return $ Left $ XmppIOException e + +pushElement :: Element -> StateT Connection IO (Either XmppFailure Bool) pushElement x = do send <- gets (cSend . cHandle) - liftIO . send $ renderElement x + wrapIOException $ send $ renderElement x -- | Encode and send stanza -pushStanza :: Stanza -> TMVar Connection -> IO Bool +pushStanza :: Stanza -> TMVar Connection -> IO (Either XmppFailure Bool) pushStanza s = withConnection' . pushElement $ pickleElem xpStanza s -- XML documents and XMPP streams SHOULD be preceeded by an XML declaration. -- UTF-8 is the only supported XMPP encoding. The standalone document -- declaration (matching "SDDecl" in the XML standard) MUST NOT be included in -- XMPP streams. RFC 6120 defines XMPP only in terms of XML 1.0. -pushXmlDecl :: StateT Connection IO Bool +pushXmlDecl :: StateT Connection IO (Either XmppFailure Bool) pushXmlDecl = do con <- gets cHandle - liftIO $ (cSend con) "" + wrapIOException $ (cSend con) "" -pushOpenElement :: Element -> StateT Connection IO Bool +pushOpenElement :: Element -> StateT Connection IO (Either XmppFailure Bool) pushOpenElement e = do sink <- gets (cSend . cHandle) - liftIO . sink $ renderOpenElement e + wrapIOException $ sink $ renderOpenElement e -- `Connect-and-resumes' the given sink to the connection source, and pulls a -- `b' value. -runEventsSink :: Sink Event IO b -> StateT Connection IO b -runEventsSink snk = do +runEventsSink :: Sink Event IO b -> StateT Connection IO (Either XmppFailure b) +runEventsSink snk = do -- TODO: Wrap exceptions? source <- gets cEventSource (src', r) <- lift $ source $$++ snk modify (\s -> s{cEventSource = src'}) - return r + return $ Right r -pullElement :: StateT Connection IO Element +pullElement :: StateT Connection IO (Either XmppFailure Element) pullElement = do Ex.catches (do e <- runEventsSink (elements =$ await) case e of - Nothing -> liftIO $ Ex.throwIO StreamOtherFailure - Just r -> return r + Left f -> return $ Left f + Right Nothing -> return $ Left XmppOtherFailure -- TODO + Right (Just r) -> return $ Right r ) - [ Ex.Handler (\StreamEnd -> Ex.throwIO StreamEndFailure) + [ Ex.Handler (\StreamEnd -> return $ Left StreamEndFailure) , Ex.Handler (\(InvalidXmppXml s) -- Invalid XML `Event' encountered, or missing element close tag - -> liftIO . Ex.throwIO $ StreamOtherFailure) -- TODO: Log: s + -> return $ Left XmppOtherFailure) -- TODO: Log: s , Ex.Handler $ \(e :: InvalidEventStream) -- xml-conduit exception - -> liftIO . Ex.throwIO $ StreamOtherFailure -- TODO: Log: (show e) + -> return $ Left XmppOtherFailure -- TODO: Log: (show e) ] -- Pulls an element and unpickles it. -pullUnpickle :: PU [Node] a -> StateT Connection IO a +pullUnpickle :: PU [Node] a -> StateT Connection IO (Either XmppFailure a) pullUnpickle p = do - res <- unpickleElem p <$> pullElement - case res of - Left e -> liftIO $ Ex.throwIO e - Right r -> return r + elem <- pullElement + case elem of + Left e -> return $ Left e + Right elem' -> do + let res = unpickleElem p elem' + case res of + Left e -> return $ Left XmppOtherFailure -- TODO: Log + Right r -> return $ Right r --- | Pulls a stanza (or stream error) from the stream. Throws an error on a stream --- error. -pullStanza :: TMVar Connection -> IO Stanza +-- | Pulls a stanza (or stream error) from the stream. +pullStanza :: TMVar Connection -> IO (Either XmppFailure Stanza) pullStanza = withConnection' $ do res <- pullUnpickle xpStreamStanza case res of - Left e -> liftIO . Ex.throwIO $ StreamErrorFailure e - Right r -> return r + Left e -> return $ Left e + Right (Left e) -> return $ Left $ StreamErrorFailure e + Right (Right r) -> return $ Right r -- Performs the given IO operation, catches any errors and re-throws everything -- except 'ResourceVanished' and IllegalOperation, in which case it will return False instead @@ -129,7 +144,7 @@ xmppNoConnection :: Connection xmppNoConnection = Connection { cHandle = ConnectionHandle { cSend = \_ -> return False , cRecv = \_ -> Ex.throwIO - StreamOtherFailure + XmppOtherFailure , cFlush = return () , cClose = return () } @@ -147,9 +162,9 @@ xmppNoConnection = Connection } where zeroSource :: Source IO output - zeroSource = liftIO . Ex.throwIO $ StreamOtherFailure + zeroSource = liftIO . Ex.throwIO $ XmppOtherFailure -connectTcp :: HostName -> PortID -> Text -> IO (TMVar Connection) +connectTcp :: HostName -> PortID -> Text -> IO (Either XmppFailure (TMVar Connection)) connectTcp host port hostname = do let PortNumber portNumber = port debugM "Pontarius.Xmpp" $ "Connecting to " ++ host ++ " on port " ++ @@ -190,7 +205,8 @@ connectTcp host port hostname = do , cJidWhenPlain = False -- TODO: Allow user to set , cFrom = Nothing } - mkConnection con + con' <- mkConnection con + return $ Right con' where logConduit :: Conduit ByteString IO ByteString logConduit = CL.mapM $ \d -> do @@ -201,10 +217,12 @@ connectTcp host port hostname = do -- Closes the connection and updates the XmppConMonad Connection state. -killConnection :: TMVar Connection -> IO (Either Ex.SomeException ()) +-- killConnection :: TMVar Connection -> IO (Either Ex.SomeException ()) +killConnection :: TMVar Connection -> IO (Either XmppFailure ()) killConnection = withConnection $ do cc <- gets (cClose . cHandle) - err <- liftIO $ (Ex.try cc :: IO (Either Ex.SomeException ())) + err <- wrapIOException cc + -- (Ex.try cc :: IO (Either Ex.SomeException ())) put xmppNoConnection return err @@ -216,44 +234,45 @@ pushIQ' :: StanzaId -> Maybe LangTag -> Element -> TMVar Connection - -> IO (Either IQError IQResult) + -> IO (Either XmppFailure (Either IQError IQResult)) pushIQ' iqID to tp lang body con = do pushStanza (IQRequestS $ IQRequest iqID Nothing to lang tp body) con res <- pullStanza con case res of - IQErrorS e -> return $ Left e - IQResultS r -> do + Left e -> return $ Left e + Right (IQErrorS e) -> return $ Right $ Left e + Right (IQResultS r) -> do unless (iqID == iqResultID r) . liftIO . Ex.throwIO $ - StreamOtherFailure + XmppOtherFailure -- TODO: Log: ("In sendIQ' IDs don't match: " ++ show iqID ++ -- " /= " ++ show (iqResultID r) ++ " .") - return $ Right r - _ -> liftIO $ Ex.throwIO StreamOtherFailure + return $ Right $ Right r + _ -> return $ Left XmppOtherFailure -- TODO: Log: "sendIQ': unexpected stanza type " -- | Send "" and wait for the server to finish processing and to --- close the connection. Any remaining elements from the server and whether or --- not we received a element from the server is returned. -closeStreams :: TMVar Connection -> IO ([Element], Bool) +-- close the connection. Any remaining elements from the server are returned. +-- Surpresses StreamEndFailure exceptions, but may throw a StreamCloseError. +closeStreams :: TMVar Connection -> IO (Either XmppFailure [Element]) closeStreams = withConnection $ do send <- gets (cSend . cHandle) cc <- gets (cClose . cHandle) liftIO $ send "" void $ liftIO $ forkIO $ do - threadDelay 3000000 + threadDelay 3000000 -- TODO: Configurable value (Ex.try cc) :: IO (Either Ex.SomeException ()) return () collectElems [] where -- Pulls elements from the stream until the stream ends, or an error is -- raised. - collectElems :: [Element] -> StateT Connection IO ([Element], Bool) + collectElems :: [Element] -> StateT Connection IO (Either XmppFailure [Element]) collectElems es = do - result <- Ex.try pullElement + result <- pullElement case result of - Left StreamEndFailure -> return (es, True) - Left _ -> return (es, False) + Left StreamEndFailure -> return $ Right es + Left e -> return $ Left $ StreamCloseError (es, e) Right e -> collectElems (e:es) debugConduit :: Pipe l ByteString ByteString u IO b diff --git a/source/Network/Xmpp/Pickle.hs b/source/Network/Xmpp/Pickle.hs index e16cb2e..10b72a9 100644 --- a/source/Network/Xmpp/Pickle.hs +++ b/source/Network/Xmpp/Pickle.hs @@ -75,4 +75,4 @@ unpickleElem p x = unpickle (xpNodeElem p) x -- Given a pickler and an object, produces an Element. pickleElem :: PU [Node] a -> a -> Element -pickleElem p = pickle $ xpNodeElem p \ No newline at end of file +pickleElem p = pickle $ xpNodeElem p diff --git a/source/Network/Xmpp/Sasl.hs b/source/Network/Xmpp/Sasl.hs index cbcc825..2a61ae2 100644 --- a/source/Network/Xmpp/Sasl.hs +++ b/source/Network/Xmpp/Sasl.hs @@ -42,22 +42,26 @@ import Control.Concurrent.STM.TMVar -- | Uses the first supported mechanism to authenticate, if any. Updates the -- state with non-password credentials and restarts the stream upon --- success. +-- success. Returns `Nothing' on success, an `AuthFailure' if +-- authentication fails, or an `XmppFailure' if anything else fails. xmppSasl :: [SaslHandler] -- ^ Acceptable authentication mechanisms and their -- corresponding handlers -> TMVar Connection - -> IO (Either AuthFailure ()) + -> IO (Either XmppFailure (Maybe AuthFailure)) xmppSasl handlers = withConnection $ do -- Chooses the first mechanism that is acceptable by both the client and the -- server. mechanisms <- gets $ saslMechanisms . cFeatures case (filter (\(name, _) -> name `elem` mechanisms)) handlers of - [] -> return . Left $ AuthNoAcceptableMechanism mechanisms - (_name, handler):_ -> runErrorT $ do + [] -> return $ Right $ Just $ AuthNoAcceptableMechanism mechanisms + (_name, handler):_ -> do cs <- gets cState case cs of - ConnectionClosed -> throwError AuthConnectionFailure + ConnectionClosed -> return . Right $ Just AuthNoConnection _ -> do - r <- handler - _ <- ErrorT $ left AuthStreamFailure <$> restartStream - return r + r <- runErrorT handler + case r of + Left ae -> return $ Right $ Just ae + Right a -> do + _ <- runErrorT $ ErrorT restartStream + return $ Right $ Nothing diff --git a/source/Network/Xmpp/Sasl/Common.hs b/source/Network/Xmpp/Sasl/Common.hs index a83add5..e3dcc5c 100644 --- a/source/Network/Xmpp/Sasl/Common.hs +++ b/source/Network/Xmpp/Sasl/Common.hs @@ -107,16 +107,21 @@ quote :: BS.ByteString -> BS.ByteString quote x = BS.concat ["\"",x,"\""] saslInit :: Text.Text -> Maybe BS.ByteString -> SaslM Bool -saslInit mechanism payload = lift . pushElement . saslInitE mechanism $ - Text.decodeUtf8 . B64.encode <$> payload +saslInit mechanism payload = do + r <- lift . pushElement . saslInitE mechanism $ + Text.decodeUtf8 . B64.encode <$> payload + case r of + Left e -> throwError $ AuthStreamFailure e + Right b -> return b -- | Pull the next element. pullSaslElement :: SaslM SaslElement pullSaslElement = do - el <- lift $ pullUnpickle (xpEither xpFailure xpSaslElement) - case el of - Left e ->throwError $ AuthSaslFailure e - Right r -> return r + r <- lift $ pullUnpickle (xpEither xpFailure xpSaslElement) + case r of + Left e -> throwError $ AuthStreamFailure e + Right (Left e) -> throwError $ AuthSaslFailure e + Right (Right r) -> return r -- | Pull the next element, checking that it is a challenge. pullChallenge :: SaslM (Maybe BS.ByteString) @@ -167,8 +172,11 @@ toPairs ctext = case pairs ctext of -- | Send a SASL response element. The content will be base64-encoded. respond :: Maybe BS.ByteString -> SaslM Bool -respond = lift . pushElement . saslResponseE . - fmap (Text.decodeUtf8 . B64.encode) +respond m = do + r <- lift . pushElement . saslResponseE . fmap (Text.decodeUtf8 . B64.encode) $ m + case r of + Left e -> throwError $ AuthStreamFailure e + Right b -> return b -- | Run the appropriate stringprep profiles on the credentials. diff --git a/source/Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs b/source/Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs index 9048842..f8fc03c 100644 --- a/source/Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs +++ b/source/Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs @@ -48,10 +48,7 @@ xmppDigestMd5 :: Text -- ^ Authentication identity (authzid or username) xmppDigestMd5 authcid authzid password = do (ac, az, pw) <- prepCredentials authcid authzid password hn <- gets cHostName - case hn of - Just hn' -> do - xmppDigestMd5' hn' ac az pw - Nothing -> throwError AuthConnectionFailure + xmppDigestMd5' (fromJust hn) ac az pw where xmppDigestMd5' :: Text -> Text -> Maybe Text -> Text -> SaslM () xmppDigestMd5' hostname authcid authzid password = do diff --git a/source/Network/Xmpp/Sasl/Types.hs b/source/Network/Xmpp/Sasl/Types.hs index cd14c1d..90f20da 100644 --- a/source/Network/Xmpp/Sasl/Types.hs +++ b/source/Network/Xmpp/Sasl/Types.hs @@ -13,9 +13,9 @@ data AuthFailure = AuthXmlFailure | AuthChallengeFailure | AuthServerAuthFailure -- ^ The server failed to authenticate -- itself - | AuthStreamFailure StreamFailure -- ^ Stream error on stream restart + | AuthStreamFailure XmppFailure -- ^ Stream error on stream restart -- TODO: Rename AuthConnectionFailure? - | AuthConnectionFailure -- ^ Connection is closed + | AuthNoConnection | AuthFailure -- General instance used for the Error instance | AuthSaslFailure SaslFailure -- ^ Defined SASL error condition | AuthStringPrepFailure -- ^ StringPrep failed diff --git a/source/Network/Xmpp/Session.hs b/source/Network/Xmpp/Session.hs index 7318067..67cf882 100644 --- a/source/Network/Xmpp/Session.hs +++ b/source/Network/Xmpp/Session.hs @@ -40,25 +40,29 @@ session :: HostName -- ^ Host to connect to -> Maybe ([SaslHandler], Maybe Text) -- ^ SASL handlers and the desired -- JID resource (or Nothing to let -- the server decide) - -> IO Session -- TODO: ErrorT -session hostname realm port tls sasl = do - con' <- connect hostname port realm - con <- case con' of - Left e -> Ex.throwIO e - Right c -> return c - if isJust tls then startTls (fromJust tls) con >> return () else return () -- TODO: Eats TlsFailure - saslResponse <- if isJust sasl then auth (fst $ fromJust sasl) (snd $ fromJust sasl) con >> return () else return () -- TODO: Eats AuthFailure - newSession con - + -> IO (Either XmppFailure (Session, Maybe AuthFailure)) +session hostname realm port tls sasl = runErrorT $ do + con <- ErrorT $ connect hostname port realm + if isJust tls + then ErrorT $ startTls (fromJust tls) con + else return () + aut <- if isJust sasl + then ErrorT $ auth (fst $ fromJust sasl) (snd $ fromJust sasl) con + else return Nothing + ses <- ErrorT $ newSession con + return (ses, aut) + -- | Connects to the XMPP server and opens the XMPP stream against the given -- host name, port, and realm. -connect :: HostName -> PortID -> Text -> IO (Either StreamFailure (TMVar Connection)) +connect :: HostName -> PortID -> Text -> IO (Either XmppFailure (TMVar Connection)) connect address port hostname = do con <- connectTcp address port hostname - result <- withConnection startStream con - case result of - Left e -> return $ Left e -- TODO - Right () -> return $ Right con + case con of + Right con' -> do + result <- withConnection startStream con' + return $ Right con' + Left e -> do + return $ Left e sessionXml :: Element sessionXml = pickleElem @@ -88,12 +92,12 @@ startSession con = do auth :: [SaslHandler] -> Maybe Text -> TMVar Connection - -> IO (Either AuthFailure Jid) + -> IO (Either XmppFailure (Maybe AuthFailure)) auth mechanisms resource con = runErrorT $ do ErrorT $ xmppSasl mechanisms con jid <- lift $ xmppBind resource con lift $ startSession con - return jid + return Nothing -- | Authenticate to the server with the given username and password -- and bind a resource. @@ -104,7 +108,7 @@ simpleAuth :: Text.Text -- ^ The username -> Maybe Text -- ^ The desired resource or 'Nothing' to let the -- server assign one -> TMVar Connection - -> IO (Either AuthFailure Jid) + -> IO (Either XmppFailure (Maybe AuthFailure)) simpleAuth username passwd resource = flip auth resource $ [ -- TODO: scramSha1Plus scramSha1 username Nothing passwd diff --git a/source/Network/Xmpp/Stream.hs b/source/Network/Xmpp/Stream.hs index 972017a..a4ce39e 100644 --- a/source/Network/Xmpp/Stream.hs +++ b/source/Network/Xmpp/Stream.hs @@ -36,12 +36,12 @@ streamUnpickleElem :: PU [Node] a -> StreamSink a streamUnpickleElem p x = do case unpickleElem p x of - Left l -> throwError $ StreamOtherFailure -- TODO: Log: StreamXmlError (show l) + Left l -> throwError $ XmppOtherFailure -- TODO: Log: StreamXmlError (show l) Right r -> return r -- This is the conduit sink that handles the stream XML events. We extend it -- with ErrorT capabilities. -type StreamSink a = ErrorT StreamFailure (Pipe Event Event Void () IO) a +type StreamSink a = ErrorT XmppFailure (Pipe Event Event Void () IO) a -- Discards all events before the first EventBeginElement. throwOutJunk :: Monad m => Sink Event m () @@ -59,13 +59,13 @@ openElementFromEvents = do hd <- lift CL.head case hd of Just (EventBeginElement name attrs) -> return $ Element name attrs [] - _ -> throwError $ StreamOtherFailure + _ -> throwError $ XmppOtherFailure -- Sends the initial stream:stream element and pulls the server features. If the -- server responds in a way that is invalid, an appropriate stream error will be --- generated, the connection to the server will be closed, and a StreamFilure +-- generated, the connection to the server will be closed, and a XmppFailure -- will be produced. -startStream :: StateT Connection IO (Either StreamFailure ()) +startStream :: StateT Connection IO (Either XmppFailure ()) startStream = runErrorT $ do state <- lift $ get con <- liftIO $ mkConnection state @@ -76,7 +76,7 @@ startStream = runErrorT $ do then cJid state else Nothing ConnectionSecured -> cJid state case cHostName state of - Nothing -> throwError StreamOtherFailure -- TODO: When does this happen? + Nothing -> throwError XmppOtherFailure -- TODO: When does this happen? Just hostname -> lift $ do pushXmlDecl pushOpenElement $ @@ -88,8 +88,9 @@ startStream = runErrorT $ do ) response <- ErrorT $ runEventsSink $ runErrorT $ streamS expectedTo case response of + Left e -> throwError e -- Successful unpickling of stream element. - Right (ver, from, to, id, lt, features) + Right (Right (ver, from, to, id, lt, features)) | (unpack ver) /= "1.0" -> closeStreamWithError con StreamUnsupportedVersion Nothing | lt == Nothing -> @@ -107,7 +108,7 @@ startStream = runErrorT $ do } ) return () -- Unpickling failed - we investigate the element. - Left (Element name attrs children) + Right (Left (Element name attrs children)) | (nameLocalName name /= "stream") -> closeStreamWithError con StreamInvalidXml Nothing | (nameNamespace name /= Just "http://etherx.jabber.org/streams") -> @@ -117,13 +118,13 @@ startStream = runErrorT $ do | otherwise -> ErrorT $ checkchildren con (flattenAttrs attrs) where -- closeStreamWithError :: MonadIO m => TMVar Connection -> StreamErrorCondition -> - -- Maybe Element -> ErrorT StreamFailure m () + -- Maybe Element -> ErrorT XmppFailure m () closeStreamWithError con sec el = do liftIO $ do withConnection (pushElement . pickleElem xpStreamError $ StreamErrorInfo sec Nothing el) con closeStreams con - throwError StreamOtherFailure + throwError XmppOtherFailure checkchildren con children = let to' = lookup "to" children ver' = lookup "version" children @@ -156,7 +157,7 @@ flattenAttrs attrs = Prelude.map (\(name, content) -> -- Sets a new Event source using the raw source (of bytes) -- and calls xmppStartStream. -restartStream :: StateT Connection IO (Either StreamFailure ()) +restartStream :: StateT Connection IO (Either XmppFailure ()) restartStream = do raw <- gets (cRecv . cHandle) let newSource = DCI.ResumableSource (loopRead raw $= XP.parseBytes def) @@ -172,7 +173,7 @@ restartStream = do -- Reads the (partial) stream:stream and the server features from the stream. -- Returns the (unvalidated) stream attributes, the unparsed element, or --- throwError throws a `StreamOtherFailure' (if something other than an element +-- throwError throws a `XmppOtherFailure' (if something other than an element -- was encountered at first, or if something other than stream features was -- encountered second). -- TODO: from. @@ -195,7 +196,7 @@ streamS expectedTo = do lift throwOutJunk -- Get the stream:stream element (or whatever it is) from the server, -- and validate what we get. - el <- openElementFromEvents -- May throw `StreamOtherFailure' if an + el <- openElementFromEvents -- May throw `XmppOtherFailure' if an -- element is not received case unpickleElem xpStream el of Left _ -> return $ Left el @@ -204,7 +205,7 @@ streamS expectedTo = do xmppStreamFeatures = do e <- lift $ elements =$ CL.head case e of - Nothing -> throwError StreamOtherFailure + Nothing -> throwError XmppOtherFailure Just r -> streamUnpickleElem xpStreamFeatures r diff --git a/source/Network/Xmpp/Tls.hs b/source/Network/Xmpp/Tls.hs index 75c73bf..957cdc4 100644 --- a/source/Network/Xmpp/Tls.hs +++ b/source/Network/Xmpp/Tls.hs @@ -76,7 +76,7 @@ exampleParams = TLS.defaultParamsClient -- Pushes ", waits for "", performs the TLS handshake, and -- restarts the stream. -startTls :: TLS.TLSParams -> TMVar Connection -> IO (Either TlsFailure ()) +startTls :: TLS.TLSParams -> TMVar Connection -> IO (Either XmppFailure ()) startTls params con = Ex.handle (return . Left . TlsError) . flip withConnection con . runErrorT $ do @@ -84,19 +84,16 @@ startTls params con = Ex.handle (return . Left . TlsError) state <- gets cState case state of ConnectionPlain -> return () - ConnectionClosed -> throwError TlsNoConnection + ConnectionClosed -> throwError XmppNoConnection ConnectionSecured -> throwError TlsConnectionSecured con <- lift $ gets cHandle when (stls features == Nothing) $ throwError TlsNoServerSupport lift $ pushElement starttlsE answer <- lift $ pullElement case answer of - Element "{urn:ietf:params:xml:ns:xmpp-tls}proceed" [] [] -> return () - Element "{urn:ietf:params:xml:ns:xmpp-tls}failure" _ _ -> - lift $ Ex.throwIO StreamOtherFailure - -- TODO: find something more suitable - e -> lift $ Ex.throwIO StreamOtherFailure - -- TODO: Log: "Unexpected element: " ++ ppElement e + Left e -> return $ Left e + Right (Element "{urn:ietf:params:xml:ns:xmpp-tls}proceed" [] []) -> return $ Right () + Right (Element "{urn:ietf:params:xml:ns:xmpp-tls}failure" _ _) -> return $ Left XmppOtherFailure (raw, _snk, psh, read, ctx) <- lift $ TLS.tlsinit debug params (mkBackend con) let newHand = ConnectionHandle { cSend = catchPush . psh , cRecv = read diff --git a/source/Network/Xmpp/Types.hs b/source/Network/Xmpp/Types.hs index 1a71d94..86dd602 100644 --- a/source/Network/Xmpp/Types.hs +++ b/source/Network/Xmpp/Types.hs @@ -28,7 +28,7 @@ module Network.Xmpp.Types , StanzaErrorCondition(..) , StanzaErrorType(..) , StanzaId(..) - , StreamFailure(..) + , XmppFailure(..) , StreamErrorCondition(..) , Version(..) , ConnectionHandle(..) @@ -39,7 +39,6 @@ module Network.Xmpp.Types , ConnectionState(..) , StreamErrorInfo(..) , langTag - , TlsFailure(..) , module Network.Xmpp.Jid ) where @@ -629,17 +628,32 @@ data StreamErrorInfo = StreamErrorInfo -- | Signals an XMPP stream error or another unpredicted stream-related -- situation. -data StreamFailure = StreamErrorFailure StreamErrorInfo -- ^ An error XML stream +data XmppFailure = StreamErrorFailure StreamErrorInfo -- ^ An error XML stream -- element has been -- encountered. - | StreamEndFailure -- ^ The server has closed the stream. - | StreamOtherFailure -- ^ Undefined condition. More - -- information should be available in - -- the log. - deriving (Show, Eq, Typeable) - -instance Exception StreamFailure -instance Error StreamFailure where noMsg = StreamOtherFailure + | StreamEndFailure -- ^ The stream has been closed. + -- This exception is caught by the + -- concurrent implementation, and + -- will thus not be visible + -- through use of 'Session'. + | StreamCloseError ([Element], XmppFailure) -- ^ When an XmppFailure + -- is encountered in + -- closeStreams, this + -- constructor wraps the + -- elements collected so + -- far. + | TlsError TLS.TLSError + | TlsNoServerSupport + | XmppNoConnection + | TlsConnectionSecured -- ^ Connection already secured + | XmppOtherFailure -- ^ Undefined condition. More + -- information should be available + -- in the log. + | XmppIOException IOException + deriving (Show, Eq, Typeable) + +instance Exception XmppFailure +instance Error XmppFailure where noMsg = XmppOtherFailure -- ============================================================================= -- XML TYPES @@ -781,7 +795,7 @@ data Connection = Connection -- element's `from' attribute. } -withConnection :: StateT Connection IO c -> TMVar Connection -> IO c +withConnection :: StateT Connection IO (Either XmppFailure c) -> TMVar Connection -> IO (Either XmppFailure c) withConnection action con = bracketOnError (atomically $ takeTMVar con) (atomically . putTMVar con ) @@ -792,7 +806,7 @@ withConnection action con = bracketOnError ) -- nonblocking version. Changes to the connection are ignored! -withConnection' :: StateT Connection IO b -> TMVar Connection -> IO b +withConnection' :: StateT Connection IO (Either XmppFailure b) -> TMVar Connection -> IO (Either XmppFailure b) withConnection' action con = do con_ <- atomically $ readTMVar con (r, _) <- runStateT action con_ @@ -801,16 +815,3 @@ withConnection' action con = do mkConnection :: Connection -> IO (TMVar Connection) mkConnection con = {- Connection `fmap` -} (atomically $ newTMVar con) - - --- | Failure conditions that may arise during TLS negotiation. -data TlsFailure = TlsError TLS.TLSError - | TlsNoServerSupport - | TlsNoConnection - | TlsConnectionSecured -- ^ Connection already secured - | TlsStreamError StreamFailure - | TlsFailureError -- General instance used for the Error instance (TODO) - deriving (Show, Eq, Typeable) - -instance Error TlsFailure where - noMsg = TlsFailureError diff --git a/source/Network/Xmpp/Xep/ServiceDiscovery.hs b/source/Network/Xmpp/Xep/ServiceDiscovery.hs index c025677..d5325e0 100644 --- a/source/Network/Xmpp/Xep/ServiceDiscovery.hs +++ b/source/Network/Xmpp/Xep/ServiceDiscovery.hs @@ -33,7 +33,7 @@ import Network.Xmpp.Types import Control.Concurrent.STM.TMVar data DiscoError = DiscoNoQueryElement - | DiscoIQError IQError + | DiscoIQError (Maybe IQError) | DiscoTimeout | DiscoXmlError Element UnpickleError @@ -92,7 +92,7 @@ queryInfo :: Jid -- ^ Entity to query queryInfo to node context = do res <- sendIQ' (Just to) Get Nothing queryBody context return $ case res of - IQResponseError e -> Left $ DiscoIQError e + IQResponseError e -> Left $ DiscoIQError (Just e) IQResponseTimeout -> Left $ DiscoTimeout IQResponseResult r -> case iqResultPayload r of Nothing -> Left DiscoNoQueryElement @@ -110,12 +110,14 @@ xmppQueryInfo :: Maybe Jid xmppQueryInfo to node con = do res <- pushIQ' "info" to Get Nothing queryBody con return $ case res of - Left e -> Left $ DiscoIQError e - Right r -> case iqResultPayload r of - Nothing -> Left DiscoNoQueryElement - Just p -> case unpickleElem xpQueryInfo p of - Left e -> Left $ DiscoXmlError p e - Right r -> Right r + Left e -> Left $ DiscoIQError Nothing + Right res' -> case res' of + Left e -> Left $ DiscoIQError (Just e) + Right r -> case iqResultPayload r of + Nothing -> Left DiscoNoQueryElement + Just p -> case unpickleElem xpQueryInfo p of + Left e -> Left $ DiscoXmlError p e + Right r -> Right r where queryBody = pickleElem xpQueryInfo (QIR node [] []) @@ -156,7 +158,7 @@ queryItems :: Jid -- ^ Entity to query queryItems to node session = do res <- sendIQ' (Just to) Get Nothing queryBody session return $ case res of - IQResponseError e -> Left $ DiscoIQError e + IQResponseError e -> Left $ DiscoIQError (Just e) IQResponseTimeout -> Left $ DiscoTimeout IQResponseResult r -> case iqResultPayload r of Nothing -> Left DiscoNoQueryElement