From b37c12628272c147aa12a9bd199e1b8b0e1033fb Mon Sep 17 00:00:00 2001 From: Jon Kristensen Date: Mon, 11 Jun 2012 20:30:18 +0200 Subject: [PATCH] miscellaneous sasl changes stopped wrapping passwd in a SaslM computation for the time-being SaslHandler now takes password and does not take hostname minor formatting and documentation changes runSasl where-local SaslElement moved to Sasl/Types.hs --- source/Network/Xmpp.hs | 4 +-- source/Network/Xmpp/Sasl.hs | 42 ++++++++++++++---------------- source/Network/Xmpp/Sasl/Common.hs | 27 +++++++++---------- source/Network/Xmpp/Sasl/Plain.hs | 35 +++++++++++-------------- source/Network/Xmpp/Sasl/Scram.hs | 8 ++---- source/Network/Xmpp/Sasl/Types.hs | 20 +++++++++----- 6 files changed, 64 insertions(+), 72 deletions(-) diff --git a/source/Network/Xmpp.hs b/source/Network/Xmpp.hs index 985f99c..ed595b7 100644 --- a/source/Network/Xmpp.hs +++ b/source/Network/Xmpp.hs @@ -179,7 +179,7 @@ auth :: Text.Text -- ^ The username -- assign one -> XmppConMonad (Either AuthError Text.Text) auth username passwd resource = runErrorT $ do - ErrorT $ xmppSasl username Nothing [scramSha1 $ return passwd] + ErrorT $ xmppSasl username Nothing passwd [scramSha1] res <- lift $ xmppBind resource - lift $ xmppStartSession + lift xmppStartSession return res diff --git a/source/Network/Xmpp/Sasl.hs b/source/Network/Xmpp/Sasl.hs index b32b689..a75efdf 100644 --- a/source/Network/Xmpp/Sasl.hs +++ b/source/Network/Xmpp/Sasl.hs @@ -34,38 +34,34 @@ import Network.Xmpp.Sasl.DigestMD5 import Network.Xmpp.Sasl.Plain import Network.Xmpp.Sasl.Types - -runSasl :: (Text.Text -> Text.Text -> Maybe Text.Text -> SaslM a) - -> Text.Text - -> Maybe Text.Text - -> XmppConMonad (Either AuthError a) -runSasl authAction authcid authzid = runErrorT $ do - hn <- gets sHostname - case hn of - Just hn' -> do - r <- authAction hn' authcid authzid - modify (\s -> s{ sUsername = Just authcid - , sAuthzid = authzid - }) - _ <- ErrorT $ left AuthStreamError <$> xmppRestartStream - return r - Nothing -> throwError AuthConnectionError - -- Uses the first supported mechanism to authenticate, if any. Updates the -- XmppConMonad state with non-password credentials and restarts the stream upon -- success. This computation wraps an ErrorT computation, which means that -- catchError can be used to catch any errors. -xmppSasl :: Text.Text - -> Maybe Text.Text +xmppSasl :: Text.Text -- ^ Authentication identity (user name) + -> Maybe Text.Text -- ^ Authorization identity + -> Text.Text -- ^ Password -> [SaslHandler] -- ^ Acceptable authentication -- mechanisms and their corresponding -- handlers -> XmppConMonad (Either AuthError ()) -xmppSasl authcid authzid handlers = do +xmppSasl authcid authzid passwd handlers = do -- Chooses the first mechanism that is acceptable by both the client and the -- server. mechanisms <- gets $ saslMechanisms . sFeatures - case (filter (\(name,_) -> name `elem` mechanisms)) handlers of + case (filter (\(name, _) -> name `elem` mechanisms)) handlers of [] -> return . Left $ AuthNoAcceptableMechanism mechanisms - (_name, handler):_ -> runSasl handler authcid authzid - + (_name, handler):_ -> runSasl handler authcid authzid passwd + where + runSasl :: (Text.Text -> Maybe Text.Text -> Text.Text -> SaslM a) + -> Text.Text + -> Maybe Text.Text + -> Text.Text + -> XmppConMonad (Either AuthError a) + runSasl authAction authcid authzid passwd = runErrorT $ do + r <- authAction authcid authzid passwd + modify (\s -> s{ sUsername = Just authcid + , sAuthzid = authzid + }) + _ <- ErrorT $ left AuthStreamError <$> xmppRestartStream + return r \ No newline at end of file diff --git a/source/Network/Xmpp/Sasl/Common.hs b/source/Network/Xmpp/Sasl/Common.hs index c65328d..03cb432 100644 --- a/source/Network/Xmpp/Sasl/Common.hs +++ b/source/Network/Xmpp/Sasl/Common.hs @@ -26,9 +26,6 @@ import Network.Xmpp.Sasl.Types import qualified System.Random as Random -data SaslElement = SaslSuccess (Maybe Text.Text) - | SaslChallenge (Maybe Text.Text) - --makeNonce :: SaslM BS.ByteString makeNonce :: IO BS.ByteString makeNonce = do @@ -53,9 +50,10 @@ saslResponseE resp = [] (maybeToList $ NodeContent . ContentText <$> resp) +-- The element. xpSuccess :: PU [Node] (Maybe Text.Text) xpSuccess = xpElemNodes "{urn:ietf:params:xml:ns:xmpp-sasl}success" - (xpOption $ xpContent xpId) + (xpOption $ xpContent xpId) -- Parses the incoming SASL data to a mapped list of pairs. pairs :: BS.ByteString -> Either String Pairs @@ -91,7 +89,7 @@ xpChallenge :: PU [Node] (Maybe Text.Text) xpChallenge = xpElemNodes "{urn:ietf:params:xml:ns:xmpp-sasl}challenge" (xpOption $ xpContent xpId) --- | pickler for SaslElement +-- | Pickler for SaslElement. xpSaslElement :: PU [Node] SaslElement xpSaslElement = xpAlt saslSel [ xpWrap SaslSuccess (\(SaslSuccess x) -> x) xpSuccess @@ -101,7 +99,7 @@ xpSaslElement = xpAlt saslSel saslSel (SaslSuccess _) = 0 saslSel (SaslChallenge _) = 1 --- | Add quotationmarks around a byte string +-- | Add quotationmarks around a byte string. quote :: BS.ByteString -> BS.ByteString quote x = BS.concat ["\"",x,"\""] @@ -109,7 +107,7 @@ saslInit :: Text.Text -> Maybe BS.ByteString -> SaslM Bool saslInit mechanism payload = lift . pushElement . saslInitE mechanism $ Text.decodeUtf8 . B64.encode <$> payload --- | Pull the next element +-- | Pull the next element. pullSaslElement :: SaslM SaslElement pullSaslElement = do el <- lift $ pullPickle (xpEither xpFailure xpSaslElement) @@ -117,7 +115,7 @@ pullSaslElement = do Left e ->throwError $ AuthSaslFailure e Right r -> return r --- | Pull the next element, checking that it is a challenge +-- | Pull the next element, checking that it is a challenge. pullChallenge :: SaslM (Maybe BS.ByteString) pullChallenge = do e <- pullSaslElement @@ -128,12 +126,12 @@ pullChallenge = do -> return $ Just sc _ -> throwError AuthChallengeError --- | Extract value from Just, failing with AuthChallengeError on Nothing +-- | Extract value from Just, failing with AuthChallengeError on Nothing. saslFromJust :: Maybe a -> SaslM a saslFromJust Nothing = throwError $ AuthChallengeError 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. pullSuccess :: SaslM (Maybe Text.Text) pullSuccess = do e <- pullSaslElement @@ -142,7 +140,7 @@ pullSuccess = do _ -> throwError $ AuthXmlError -- | 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. pullFinalMessage :: SaslM (Maybe BS.ByteString) pullFinalMessage = do challenge2 <- pullSaslElement @@ -158,14 +156,13 @@ pullFinalMessage = do Left _e -> throwError $ AuthChallengeError 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 ctext = case pairs ctext of Left _e -> throwError AuthChallengeError Right r -> return r --- | Send a SASL response element. The content will be base64-encoded for you +-- | 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) - + fmap (Text.decodeUtf8 . B64.encode) \ No newline at end of file diff --git a/source/Network/Xmpp/Sasl/Plain.hs b/source/Network/Xmpp/Sasl/Plain.hs index 32e8633..bedca29 100644 --- a/source/Network/Xmpp/Sasl/Plain.hs +++ b/source/Network/Xmpp/Sasl/Plain.hs @@ -46,32 +46,27 @@ import Network.Xmpp.Sasl.Common import Network.Xmpp.Sasl.Types -- TODO: stringprep -xmppPlain :: SaslM Text.Text - -> a - -> Text.Text - -> Maybe Text.Text +xmppPlain :: Text.Text -- ^ Password + -> Maybe Text.Text -- ^ Authorization identity (authzid) + -> Text.Text -- ^ Authentication identity (authcid) -> SaslM () -xmppPlain pw _hostname authcid authzid = do - passwd <- pw - _ <- saslInit "PLAIN" ( Just $ plainMessage authzid authcid passwd) +xmppPlain passwd authzid authcid = do + _ <- saslInit "PLAIN" (Just $ plainMessage passwd) _ <- pullSuccess return () where -- Converts an optional authorization identity, an authentication identity, -- and a password to a \NUL-separated PLAIN message. - plainMessage :: Maybe Text.Text -- Authorization identity (authzid) - -> Text.Text -- Authentication identity (authcid) - -> Text.Text -- Password - -> BS.ByteString -- The PLAIN message - plainMessage authzid authcid passwd = BS.concat $ - [ authzid' - , "\NUL" - , Text.encodeUtf8 $ authcid - , "\NUL" - , Text.encodeUtf8 $ passwd - ] + plainMessage :: Text.Text -> BS.ByteString + plainMessage passwd = BS.concat + [ authzid' + , "\NUL" + , Text.encodeUtf8 authcid + , "\NUL" + , Text.encodeUtf8 passwd + ] where authzid' = maybe "" Text.encodeUtf8 authzid -plain :: SaslM Text.Text -> SaslHandler -plain passwd = ("PLAIN", xmppPlain passwd) \ No newline at end of file +plain :: SaslHandler +plain = ("PLAIN", xmppPlain) \ No newline at end of file diff --git a/source/Network/Xmpp/Sasl/Scram.hs b/source/Network/Xmpp/Sasl/Scram.hs index 26c289f..9d74c36 100644 --- a/source/Network/Xmpp/Sasl/Scram.hs +++ b/source/Network/Xmpp/Sasl/Scram.hs @@ -170,9 +170,5 @@ hashToken :: (Crypto.Hash ctx hash) => hash hashToken = undefined -- | 'scram' spezialised to the SHA-1 hash function, packaged as a SaslHandler. -scramSha1 :: SaslM Text.Text -> SaslHandler -scramSha1 passwd = ("SCRAM-SHA-1" - , \_hostname authcid authzid -> do - pw <- passwd - scram (hashToken :: Crypto.SHA1) authcid authzid pw - ) \ No newline at end of file +scramSha1 :: SaslHandler +scramSha1 = ("SCRAM-SHA-1", scram (hashToken :: Crypto.SHA1)) \ No newline at end of file diff --git a/source/Network/Xmpp/Sasl/Types.hs b/source/Network/Xmpp/Sasl/Types.hs index 00ea74b..223714c 100644 --- a/source/Network/Xmpp/Sasl/Types.hs +++ b/source/Network/Xmpp/Sasl/Types.hs @@ -11,21 +11,29 @@ data AuthError = AuthXmlError -- offered | AuthChallengeError | AuthServerAuthError -- ^ The server failed to authenticate - -- himself + -- itself | AuthStreamError StreamError -- ^ Stream error on stream restart + -- TODO: Rename AuthConnectionError? | AuthConnectionError -- ^ No host name set in state | AuthError -- General instance used for the Error instance - | AuthSaslFailure SaslFailure -- ^ defined SASL error condition + | AuthSaslFailure SaslFailure -- ^ Defined SASL error condition deriving Show instance Error AuthError where noMsg = AuthError +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 XmppConnection IO) a type Pairs = [(ByteString, ByteString)] -type SaslHandler = (Text.Text, Text.Text - -> Text.Text - -> Maybe Text.Text - -> SaslM ()) \ No newline at end of file +-- | Tuple defining the SASL Handler's name, and a SASL mechanism computation +-- taking an authentication identity, an optional authorization identity, and a +-- password. +type SaslHandler = ( Text.Text, + Text.Text -> Maybe Text.Text -> Text.Text -> SaslM () + ) \ No newline at end of file