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

@@ -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
 

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

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)

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

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

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.

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) "<?xml version=\"1.0\" encoding=\"UTF-8\" ?>"
+    wrapIOException $ (cSend con) "<?xml version=\"1.0\" encoding=\"UTF-8\" ?>"
 
-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 "</stream:stream>" 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 </stream:stream> 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 "</stream:stream>"
     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

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
+pickleElem p = pickle $ xpNodeElem p

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

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.

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

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

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

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
 
 

source/Network/Xmpp/Tls.hs

@@ -76,7 +76,7 @@ exampleParams = TLS.defaultParamsClient
 
 -- Pushes "<starttls/>, waits for "<proceed/>", 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

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

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