Browse Source

Rename `AuthError' to `AuthFailure'; apply minor documentation changes

master
Jon Kristensen 13 years ago
parent
commit
b1393da25a
  1. 33
      source/Network/Xmpp.hs
  2. 6
      source/Network/Xmpp/Sasl.hs
  3. 16
      source/Network/Xmpp/Sasl/Common.hs
  4. 2
      source/Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs
  5. 4
      source/Network/Xmpp/Sasl/Mechanisms/Scram.hs
  6. 22
      source/Network/Xmpp/Sasl/Types.hs
  7. 14
      source/Network/Xmpp/Session.hs

33
source/Network/Xmpp.hs

@ -26,10 +26,15 @@ module Network.Xmpp @@ -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 @@ -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

6
source/Network/Xmpp/Sasl.hs

@ -46,7 +46,7 @@ import Control.Concurrent.STM.TMVar @@ -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 @@ -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

16
source/Network/Xmpp/Sasl/Common.hs

@ -127,11 +127,11 @@ pullChallenge = do @@ -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 @@ -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 @@ -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 . @@ -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

2
source/Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs

@ -51,7 +51,7 @@ xmppDigestMd5 authcid authzid password = do @@ -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

4
source/Network/Xmpp/Sasl/Mechanisms/Scram.hs

@ -59,7 +59,7 @@ scram hashToken authcid authzid password = do @@ -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 @@ -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

22
source/Network/Xmpp/Sasl/Types.hs

@ -7,29 +7,29 @@ import Data.ByteString(ByteString) @@ -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)]

14
source/Network/Xmpp/Session.hs

@ -26,8 +26,10 @@ import Data.Maybe @@ -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 @@ -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 @@ -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 @@ -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
]
]
Loading…
Cancel
Save