Browse Source

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

master
Jon Kristensen 13 years ago
parent
commit
b1393da25a
  1. 17
      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. 12
      source/Network/Xmpp/Session.hs

17
source/Network/Xmpp.hs

@ -26,10 +26,15 @@ module Network.Xmpp
( -- * Session management ( -- * Session management
Session Session
, session , session
-- * JID -- TODO: Close session, etc.
-- ** Authentication handlers
, scramSha1
, plain
, digestMd5
-- * Addressing
-- | A JID (historically: Jabber ID) is XMPPs native format -- | A JID (historically: Jabber ID) is XMPPs native format
-- for addressing entities in the network. It is somewhat similar to an e-mail -- 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(..) , Jid(..)
, isBare , isBare
, isFull , isFull
@ -38,11 +43,11 @@ module Network.Xmpp
-- essentially a fragment of XML that is sent over a stream. @Stanzas@ come in -- essentially a fragment of XML that is sent over a stream. @Stanzas@ come in
-- 3 flavors: -- 3 flavors:
-- --
-- * @'Message'@, for traditional push-style message passing between peers -- * /Message/, for traditional push-style message passing between peers
-- --
-- * @'Presence'@, for communicating status updates -- * /Presence/, for communicating status updates
-- --
-- * IQ (info/query), for request-response semantics communication -- * /Info/\//Query/ (or /IQ/), for request-response semantics communication
-- --
-- All stanza types have the following attributes in common: -- All stanza types have the following attributes in common:
-- --
@ -62,7 +67,7 @@ module Network.Xmpp
-- presence, or IQ stanza. The particular allowable values for the 'type' -- presence, or IQ stanza. The particular allowable values for the 'type'
-- attribute vary depending on whether the stanza is a message, presence, -- attribute vary depending on whether the stanza is a message, presence,
-- or IQ stanza. -- or IQ stanza.
--
-- ** Messages -- ** Messages
-- | The /message/ stanza is a /push/ mechanism whereby one entity -- | The /message/ stanza is a /push/ mechanism whereby one entity
-- pushes information to another entity, similar to the communications that -- 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
xmppSasl :: [SaslHandler] -- ^ Acceptable authentication mechanisms and their xmppSasl :: [SaslHandler] -- ^ Acceptable authentication mechanisms and their
-- corresponding handlers -- corresponding handlers
-> TMVar Connection -> TMVar Connection
-> IO (Either AuthError ()) -> IO (Either AuthFailure ())
xmppSasl handlers = withConnection $ do xmppSasl handlers = withConnection $ do
-- Chooses the first mechanism that is acceptable by both the client and the -- Chooses the first mechanism that is acceptable by both the client and the
-- server. -- server.
@ -56,8 +56,8 @@ xmppSasl handlers = withConnection $ do
(_name, handler):_ -> runErrorT $ do (_name, handler):_ -> runErrorT $ do
cs <- gets sConnectionState cs <- gets sConnectionState
case cs of case cs of
ConnectionClosed -> throwError AuthConnectionError ConnectionClosed -> throwError AuthConnectionFailure
_ -> do _ -> do
r <- handler r <- handler
_ <- ErrorT $ left AuthStreamError <$> restartStream _ <- ErrorT $ left AuthStreamFailure <$> restartStream
return r return r

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

@ -127,11 +127,11 @@ pullChallenge = do
SaslChallenge (Just scb64) SaslChallenge (Just scb64)
| Right sc <- B64.decode . Text.encodeUtf8 $ scb64 | Right sc <- B64.decode . Text.encodeUtf8 $ scb64
-> return $ Just sc -> 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 :: Maybe a -> SaslM a
saslFromJust Nothing = throwError $ AuthChallengeError saslFromJust Nothing = throwError $ AuthChallengeFailure
saslFromJust (Just d) = return d saslFromJust (Just d) = return d
-- | Pull the next element and check that it is success. -- | Pull the next element and check that it is success.
@ -140,7 +140,7 @@ pullSuccess = do
e <- pullSaslElement e <- pullSaslElement
case e of case e of
SaslSuccess x -> return x SaslSuccess x -> return x
_ -> throwError $ AuthXmlError _ -> throwError $ AuthXmlFailure
-- | Pull the next element. When it's success, return it's payload. -- | Pull the next element. When it's success, return it's payload.
-- If it's a challenge, send an empty response and pull success. -- If it's a challenge, send an empty response and pull success.
@ -156,13 +156,13 @@ pullFinalMessage = do
where where
decode Nothing = return Nothing decode Nothing = return Nothing
decode (Just d) = case B64.decode $ Text.encodeUtf8 d of decode (Just d) = case B64.decode $ Text.encodeUtf8 d of
Left _e -> throwError $ AuthChallengeError Left _e -> throwError $ AuthChallengeFailure
Right x -> return $ Just x Right x -> return $ Just x
-- | Extract p=q pairs from a challenge. -- | Extract p=q pairs from a challenge.
toPairs :: BS.ByteString -> SaslM Pairs toPairs :: BS.ByteString -> SaslM Pairs
toPairs ctext = case pairs ctext of toPairs ctext = case pairs ctext of
Left _e -> throwError AuthChallengeError Left _e -> throwError AuthChallengeFailure
Right r -> return r Right r -> return r
-- | Send a SASL response element. The content will be base64-encoded. -- | 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. -- | Run the appropriate stringprep profiles on the credentials.
-- May fail with 'AuthStringPrepError' -- May fail with 'AuthStringPrepFailure'
prepCredentials :: Text.Text -> Maybe Text.Text -> Text.Text prepCredentials :: Text.Text -> Maybe Text.Text -> Text.Text
-> SaslM (Text.Text, Maybe Text.Text, Text.Text) -> SaslM (Text.Text, Maybe Text.Text, Text.Text)
prepCredentials authcid authzid password = case credentials of prepCredentials authcid authzid password = case credentials of
Nothing -> throwError $ AuthStringPrepError Nothing -> throwError $ AuthStringPrepFailure
Just creds -> return creds Just creds -> return creds
where where
credentials = do credentials = do

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

@ -51,7 +51,7 @@ xmppDigestMd5 authcid authzid password = do
case hn of case hn of
Just hn' -> do Just hn' -> do
xmppDigestMd5' hn' ac az pw xmppDigestMd5' hn' ac az pw
Nothing -> throwError AuthConnectionError Nothing -> throwError AuthConnectionFailure
where where
xmppDigestMd5' :: Text -> Text -> Maybe Text -> Text -> SaslM () xmppDigestMd5' :: Text -> Text -> Maybe Text -> Text -> SaslM ()
xmppDigestMd5' hostname authcid authzid password = do xmppDigestMd5' hostname authcid authzid password = do

4
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 let (cfm, v) = cFinalMessageAndVerifier nonce salt ic sFirstMessage cnonce
respond $ Just cfm respond $ Just cfm
finalPairs <- toPairs =<< saslFromJust =<< pullFinalMessage finalPairs <- toPairs =<< saslFromJust =<< pullFinalMessage
unless (lookup "v" finalPairs == Just v) $ throwError AuthServerAuthError unless (lookup "v" finalPairs == Just v) $ throwError AuthServerAuthFailure
return () return ()
where where
-- We need to jump through some hoops to get a polymorphic solution -- 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 , Just ic <- lookup "i" pairs
, [(i,"")] <- reads $ BS8.unpack ic , [(i,"")] <- reads $ BS8.unpack ic
= return (nonce, salt, i) = return (nonce, salt, i)
fromPairs _ _ = throwError $ AuthChallengeError fromPairs _ _ = throwError $ AuthChallengeFailure
cFinalMessageAndVerifier :: BS.ByteString cFinalMessageAndVerifier :: BS.ByteString
-> BS.ByteString -> BS.ByteString

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

@ -7,29 +7,29 @@ import Data.ByteString(ByteString)
import qualified Data.Text as Text import qualified Data.Text as Text
import Network.Xmpp.Types import Network.Xmpp.Types
data AuthError = AuthXmlError data AuthFailure = AuthXmlFailure
| AuthNoAcceptableMechanism [Text.Text] -- ^ Wraps mechanisms | AuthNoAcceptableMechanism [Text.Text] -- ^ Wraps mechanisms
-- offered -- offered
| AuthChallengeError | AuthChallengeFailure
| AuthServerAuthError -- ^ The server failed to authenticate | AuthServerAuthFailure -- ^ The server failed to authenticate
-- itself -- itself
| AuthStreamError StreamFailure -- ^ Stream error on stream restart | AuthStreamFailure StreamFailure -- ^ Stream error on stream restart
-- TODO: Rename AuthConnectionError? -- TODO: Rename AuthConnectionFailure?
| AuthConnectionError -- ^ Connection is closed | AuthConnectionFailure -- ^ Connection is closed
| AuthError -- General instance used for the Error instance | AuthFailure -- General instance used for the Error instance
| AuthSaslFailure SaslFailure -- ^ Defined SASL error condition | AuthSaslFailure SaslFailure -- ^ Defined SASL error condition
| AuthStringPrepError -- ^ StringPrep failed | AuthStringPrepFailure -- ^ StringPrep failed
deriving Show deriving Show
instance Error AuthError where instance Error AuthFailure where
noMsg = AuthError noMsg = AuthFailure
data SaslElement = SaslSuccess (Maybe Text.Text) data SaslElement = SaslSuccess (Maybe Text.Text)
| SaslChallenge (Maybe Text.Text) | SaslChallenge (Maybe Text.Text)
-- | SASL mechanism XmppConnection computation, with the possibility of throwing -- | SASL mechanism XmppConnection computation, with the possibility of throwing
-- an authentication error. -- 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)] type Pairs = [(ByteString, ByteString)]

12
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. -- | Creates a 'Session' object by setting up a connection with an XMPP server.
-- --
-- Will connect to the specified host, optionally secure the connection with -- Will connect to the specified host. If the fourth parameters is a 'Just'
-- TLS, as well as optionally authenticate and acquire an XMPP resource. -- 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 session :: HostName -- ^ Host to connect to
-> Text -- ^ The realm host name (to -> Text -- ^ The realm host name (to
-- distinguish the XMPP service) -- distinguish the XMPP service)
@ -45,7 +47,7 @@ session hostname realm port tls sasl = do
Left e -> Ex.throwIO e Left e -> Ex.throwIO e
Right c -> return c Right c -> return c
if isJust tls then startTls (fromJust tls) con >> return () else return () -- TODO: Eats TlsFailure 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 newSession con
-- | Connect to host with given address. -- | Connect to host with given address.
@ -104,7 +106,7 @@ startSession con = do
auth :: [SaslHandler] auth :: [SaslHandler]
-> Maybe Text -> Maybe Text
-> TMVar Connection -> TMVar Connection
-> IO (Either AuthError Jid) -> IO (Either AuthFailure Jid)
auth mechanisms resource con = runErrorT $ do auth mechanisms resource con = runErrorT $ do
ErrorT $ xmppSasl mechanisms con ErrorT $ xmppSasl mechanisms con
jid <- lift $ xmppBind resource con jid <- lift $ xmppBind resource con
@ -120,7 +122,7 @@ simpleAuth :: Text.Text -- ^ The username
-> Maybe Text -- ^ The desired resource or 'Nothing' to let the -> Maybe Text -- ^ The desired resource or 'Nothing' to let the
-- server assign one -- server assign one
-> TMVar Connection -> TMVar Connection
-> IO (Either AuthError Jid) -> IO (Either AuthFailure Jid)
simpleAuth username passwd resource = flip auth resource $ simpleAuth username passwd resource = flip auth resource $
[ -- TODO: scramSha1Plus [ -- TODO: scramSha1Plus
scramSha1 username Nothing passwd scramSha1 username Nothing passwd

Loading…
Cancel
Save