diff --git a/source/Network/Xmpp.hs b/source/Network/Xmpp.hs index 3deaaf8..b4d0b5d 100644 --- a/source/Network/Xmpp.hs +++ b/source/Network/Xmpp.hs @@ -26,10 +26,15 @@ module Network.Xmpp ( -- * Session management Session , session - -- * JID + -- TODO: Close session, etc. + -- ** Authentication handlers + , scramSha1 + , plain + , digestMd5 + -- * Addressing -- | A JID (historically: Jabber ID) is XMPPs native format -- for addressing entities in the network. It is somewhat similar to an e-mail - -- address but contains three parts instead of two: + -- address, but contains three parts instead of two. , Jid(..) , isBare , isFull @@ -37,32 +42,32 @@ module Network.Xmpp -- | The basic protocol data unit in XMPP is the XML stanza. The stanza is -- essentially a fragment of XML that is sent over a stream. @Stanzas@ come in -- 3 flavors: - -- - -- * @'Message'@, for traditional push-style message passing between peers - -- - -- * @'Presence'@, for communicating status updates - -- - -- * IQ (info/query), for request-response semantics communication - -- + -- + -- * /Message/, for traditional push-style message passing between peers + -- + -- * /Presence/, for communicating status updates + -- + -- * /Info/\//Query/ (or /IQ/), for request-response semantics communication + -- -- All stanza types have the following attributes in common: - -- + -- -- * The /id/ attribute is used by the originating entity to track any -- response or error stanza that it might receive in relation to the -- generated stanza from another entity (such as an intermediate server or -- the intended recipient). It is up to the originating entity whether the -- value of the 'id' attribute is unique only within its current stream or -- unique globally. - -- + -- -- * The /from/ attribute specifies the JID of the sender. - -- + -- -- * The /to/ attribute specifies the JID of the intended recipient for the -- stanza. - -- + -- -- * The /type/ attribute specifies the purpose or context of the message, -- presence, or IQ stanza. The particular allowable values for the 'type' -- attribute vary depending on whether the stanza is a message, presence, -- or IQ stanza. - -- + -- ** Messages -- | The /message/ stanza is a /push/ mechanism whereby one entity -- pushes information to another entity, similar to the communications that diff --git a/source/Network/Xmpp/Sasl.hs b/source/Network/Xmpp/Sasl.hs index 9b3df03..c5e2e62 100644 --- a/source/Network/Xmpp/Sasl.hs +++ b/source/Network/Xmpp/Sasl.hs @@ -46,7 +46,7 @@ import Control.Concurrent.STM.TMVar xmppSasl :: [SaslHandler] -- ^ Acceptable authentication mechanisms and their -- corresponding handlers -> TMVar Connection - -> IO (Either AuthError ()) + -> IO (Either AuthFailure ()) xmppSasl handlers = withConnection $ do -- Chooses the first mechanism that is acceptable by both the client and the -- server. @@ -56,8 +56,8 @@ xmppSasl handlers = withConnection $ do (_name, handler):_ -> runErrorT $ do cs <- gets sConnectionState case cs of - ConnectionClosed -> throwError AuthConnectionError + ConnectionClosed -> throwError AuthConnectionFailure _ -> do r <- handler - _ <- ErrorT $ left AuthStreamError <$> restartStream + _ <- ErrorT $ left AuthStreamFailure <$> restartStream return r diff --git a/source/Network/Xmpp/Sasl/Common.hs b/source/Network/Xmpp/Sasl/Common.hs index 5d4164f..468cf01 100644 --- a/source/Network/Xmpp/Sasl/Common.hs +++ b/source/Network/Xmpp/Sasl/Common.hs @@ -127,11 +127,11 @@ pullChallenge = do SaslChallenge (Just scb64) | Right sc <- B64.decode . Text.encodeUtf8 $ scb64 -> return $ Just sc - _ -> throwError AuthChallengeError + _ -> throwError AuthChallengeFailure --- | Extract value from Just, failing with AuthChallengeError on Nothing. +-- | Extract value from Just, failing with AuthChallengeFailure on Nothing. saslFromJust :: Maybe a -> SaslM a -saslFromJust Nothing = throwError $ AuthChallengeError +saslFromJust Nothing = throwError $ AuthChallengeFailure saslFromJust (Just d) = return d -- | Pull the next element and check that it is success. @@ -140,7 +140,7 @@ pullSuccess = do e <- pullSaslElement case e of SaslSuccess x -> return x - _ -> throwError $ AuthXmlError + _ -> throwError $ AuthXmlFailure -- | Pull the next element. When it's success, return it's payload. -- If it's a challenge, send an empty response and pull success. @@ -156,13 +156,13 @@ pullFinalMessage = do where decode Nothing = return Nothing decode (Just d) = case B64.decode $ Text.encodeUtf8 d of - Left _e -> throwError $ AuthChallengeError + Left _e -> throwError $ AuthChallengeFailure Right x -> return $ Just x -- | Extract p=q pairs from a challenge. toPairs :: BS.ByteString -> SaslM Pairs toPairs ctext = case pairs ctext of - Left _e -> throwError AuthChallengeError + Left _e -> throwError AuthChallengeFailure Right r -> return r -- | Send a SASL response element. The content will be base64-encoded. @@ -172,11 +172,11 @@ respond = lift . pushElement . saslResponseE . -- | Run the appropriate stringprep profiles on the credentials. --- May fail with 'AuthStringPrepError' +-- May fail with 'AuthStringPrepFailure' prepCredentials :: Text.Text -> Maybe Text.Text -> Text.Text -> SaslM (Text.Text, Maybe Text.Text, Text.Text) prepCredentials authcid authzid password = case credentials of - Nothing -> throwError $ AuthStringPrepError + Nothing -> throwError $ AuthStringPrepFailure Just creds -> return creds where credentials = do diff --git a/source/Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs b/source/Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs index 55bce2c..75ddac5 100644 --- a/source/Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs +++ b/source/Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs @@ -51,7 +51,7 @@ xmppDigestMd5 authcid authzid password = do case hn of Just hn' -> do xmppDigestMd5' hn' ac az pw - Nothing -> throwError AuthConnectionError + Nothing -> throwError AuthConnectionFailure where xmppDigestMd5' :: Text -> Text -> Maybe Text -> Text -> SaslM () xmppDigestMd5' hostname authcid authzid password = do diff --git a/source/Network/Xmpp/Sasl/Mechanisms/Scram.hs b/source/Network/Xmpp/Sasl/Mechanisms/Scram.hs index 6cf809d..e9cebc7 100644 --- a/source/Network/Xmpp/Sasl/Mechanisms/Scram.hs +++ b/source/Network/Xmpp/Sasl/Mechanisms/Scram.hs @@ -59,7 +59,7 @@ scram hashToken authcid authzid password = do let (cfm, v) = cFinalMessageAndVerifier nonce salt ic sFirstMessage cnonce respond $ Just cfm finalPairs <- toPairs =<< saslFromJust =<< pullFinalMessage - unless (lookup "v" finalPairs == Just v) $ throwError AuthServerAuthError + unless (lookup "v" finalPairs == Just v) $ throwError AuthServerAuthFailure return () where -- We need to jump through some hoops to get a polymorphic solution @@ -102,7 +102,7 @@ scram hashToken authcid authzid password = do , Just ic <- lookup "i" pairs , [(i,"")] <- reads $ BS8.unpack ic = return (nonce, salt, i) - fromPairs _ _ = throwError $ AuthChallengeError + fromPairs _ _ = throwError $ AuthChallengeFailure cFinalMessageAndVerifier :: BS.ByteString -> BS.ByteString diff --git a/source/Network/Xmpp/Sasl/Types.hs b/source/Network/Xmpp/Sasl/Types.hs index 5f09f51..cd14c1d 100644 --- a/source/Network/Xmpp/Sasl/Types.hs +++ b/source/Network/Xmpp/Sasl/Types.hs @@ -7,29 +7,29 @@ import Data.ByteString(ByteString) import qualified Data.Text as Text import Network.Xmpp.Types -data AuthError = AuthXmlError +data AuthFailure = AuthXmlFailure | AuthNoAcceptableMechanism [Text.Text] -- ^ Wraps mechanisms -- offered - | AuthChallengeError - | AuthServerAuthError -- ^ The server failed to authenticate + | AuthChallengeFailure + | AuthServerAuthFailure -- ^ The server failed to authenticate -- itself - | AuthStreamError StreamFailure -- ^ Stream error on stream restart - -- TODO: Rename AuthConnectionError? - | AuthConnectionError -- ^ Connection is closed - | AuthError -- General instance used for the Error instance + | AuthStreamFailure StreamFailure -- ^ Stream error on stream restart + -- TODO: Rename AuthConnectionFailure? + | AuthConnectionFailure -- ^ Connection is closed + | AuthFailure -- General instance used for the Error instance | AuthSaslFailure SaslFailure -- ^ Defined SASL error condition - | AuthStringPrepError -- ^ StringPrep failed + | AuthStringPrepFailure -- ^ StringPrep failed deriving Show -instance Error AuthError where - noMsg = AuthError +instance Error AuthFailure where + noMsg = AuthFailure data SaslElement = SaslSuccess (Maybe Text.Text) | SaslChallenge (Maybe Text.Text) -- | SASL mechanism XmppConnection computation, with the possibility of throwing -- an authentication error. -type SaslM a = ErrorT AuthError (StateT Connection IO) a +type SaslM a = ErrorT AuthFailure (StateT Connection IO) a type Pairs = [(ByteString, ByteString)] diff --git a/source/Network/Xmpp/Session.hs b/source/Network/Xmpp/Session.hs index 304feef..554dbea 100644 --- a/source/Network/Xmpp/Session.hs +++ b/source/Network/Xmpp/Session.hs @@ -26,8 +26,10 @@ import Data.Maybe -- | Creates a 'Session' object by setting up a connection with an XMPP server. -- --- Will connect to the specified host, optionally secure the connection with --- TLS, as well as optionally authenticate and acquire an XMPP resource. +-- Will connect to the specified host. If the fourth parameters is a 'Just' +-- value, @session@ will attempt to secure the connection with TLS. If the fifth +-- parameters is a 'Just' value, @session@ will attempt to authenticate and +-- acquire an XMPP resource. session :: HostName -- ^ Host to connect to -> Text -- ^ The realm host name (to -- distinguish the XMPP service) @@ -45,7 +47,7 @@ session hostname realm port tls sasl = do 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 AuthError + saslResponse <- if isJust sasl then auth (fst $ fromJust sasl) (snd $ fromJust sasl) con >> return () else return () -- TODO: Eats AuthFailure newSession con -- | Connect to host with given address. @@ -104,7 +106,7 @@ startSession con = do auth :: [SaslHandler] -> Maybe Text -> TMVar Connection - -> IO (Either AuthError Jid) + -> IO (Either AuthFailure Jid) auth mechanisms resource con = runErrorT $ do ErrorT $ xmppSasl mechanisms con jid <- lift $ xmppBind resource con @@ -120,9 +122,9 @@ simpleAuth :: Text.Text -- ^ The username -> Maybe Text -- ^ The desired resource or 'Nothing' to let the -- server assign one -> TMVar Connection - -> IO (Either AuthError Jid) + -> IO (Either AuthFailure Jid) simpleAuth username passwd resource = flip auth resource $ [ -- TODO: scramSha1Plus scramSha1 username Nothing passwd , digestMd5 username Nothing passwd - ] + ] \ No newline at end of file