diff --git a/source/Network/XMPP/SASL.hs b/source/Network/XMPP/SASL.hs index 105f591..3ce2d1f 100644 --- a/source/Network/XMPP/SASL.hs +++ b/source/Network/XMPP/SASL.hs @@ -32,9 +32,9 @@ import qualified System.Random as Random import Network.XMPP.SASL.SASL import Network.XMPP.SASL.DIGEST_MD5 +import Network.XMPP.SASL.PLAIN import Network.XMPP.SASL.Types - -- 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 @@ -53,6 +53,10 @@ xmppSASL creds = runErrorT $ do authzid authcid passwd + PLAINCredentials authzid authcid passwd -> ErrorT $ xmppPLAIN + authzid + authcid + passwd _ -> error "xmppSASL: Mechanism not caught" where -- Converts the credentials to the appropriate mechanism name, corresponding to diff --git a/source/Network/XMPP/SASL/DIGEST_MD5.hs b/source/Network/XMPP/SASL/DIGEST_MD5.hs index b113569..4eb3638 100644 --- a/source/Network/XMPP/SASL/DIGEST_MD5.hs +++ b/source/Network/XMPP/SASL/DIGEST_MD5.hs @@ -56,7 +56,7 @@ xmppDIGEST_MD5 authzid authcid passwd = runErrorT $ do -> XMPPConMonad (Either AuthError ()) xmppDIGEST_MD5' realm = runErrorT $ do -- Push element and receive the challenge (in XMPPConMonad). - _ <- lift . pushElement $ saslInitE "DIGEST-MD5" -- TODO: Check boolean? + _ <- lift . pushElement $ saslInitE "DIGEST-MD5" Nothing -- TODO: Check boolean? challenge' <- lift $ B64.decode . Text.encodeUtf8 <$> pullPickle challengePickle challenge <- case challenge' of diff --git a/source/Network/XMPP/SASL/PLAIN.hs b/source/Network/XMPP/SASL/PLAIN.hs new file mode 100644 index 0000000..6c1ca3e --- /dev/null +++ b/source/Network/XMPP/SASL/PLAIN.hs @@ -0,0 +1,73 @@ +-- Implementation of the PLAIN Simple Authentication and Security Layer (SASL) +-- Mechanism, http://tools.ietf.org/html/rfc4616. + +{-# LANGUAGE OverloadedStrings #-} + +module Network.XMPP.SASL.PLAIN where + +import Control.Applicative +import Control.Arrow (left) +import Control.Monad +import Control.Monad.Error +import Control.Monad.State.Strict +import Data.Maybe (fromJust, isJust) + +import qualified Crypto.Classes as CC + +import qualified Data.Binary as Binary +import qualified Data.ByteString.Base64 as B64 +import qualified Data.ByteString.Char8 as BS8 +import qualified Data.ByteString.Lazy as BL +import qualified Data.Digest.Pure.MD5 as MD5 +import qualified Data.List as L +import Data.Word (Word8) + +import qualified Data.Text as Text +import Data.Text (Text) +import qualified Data.Text.Encoding as Text + +import Data.XML.Pickle + +import qualified Data.ByteString as BS + +import Data.XML.Types + +import Network.XMPP.Monad +import Network.XMPP.Stream +import Network.XMPP.Types +import Network.XMPP.Pickle + +import qualified System.Random as Random + +import Data.Maybe (fromMaybe) +import qualified Data.Text as T + +import Network.XMPP.SASL.SASL +import Network.XMPP.SASL.Types + +xmppPLAIN :: Maybe T.Text + -> T.Text + -> T.Text + -> XMPPConMonad (Either AuthError ()) +xmppPLAIN authzid authcid passwd = runErrorT $ do + _ <- lift . pushElement $ saslInitE "PLAIN" $ -- TODO: Check boolean? + Just $ plainMessage authzid authcid passwd + lift $ pushElement saslResponse2E + e <- lift pullElement + case e of + Element "{urn:ietf:params:xml:ns:xmpp-sasl}success" [] [] -> + return () + _ -> throwError AuthXmlError -- TODO: investigate + -- The SASL authentication has succeeded; the stream is restarted. + _ <- ErrorT $ left AuthStreamError <$> xmppRestartStream + return () + where + -- Converts an optional authorization identity, an authentication identity, + -- and a password to a \NUL-separated PLAIN message. + plainMessage :: Maybe T.Text -- Authorization identity (authzid) + -> T.Text -- Authentication identity (authcid) + -> T.Text -- Password + -> T.Text -- The PLAIN message + plainMessage authzid authcid passwd = + let authzid' = fromMaybe "" authzid in + T.concat [authzid', "\NUL", authcid, "\NUL", passwd] \ No newline at end of file diff --git a/source/Network/XMPP/SASL/SASL.hs b/source/Network/XMPP/SASL/SASL.hs index 8259664..9cba0ef 100644 --- a/source/Network/XMPP/SASL/SASL.hs +++ b/source/Network/XMPP/SASL/SASL.hs @@ -10,15 +10,18 @@ import qualified Data.Attoparsec.ByteString.Char8 as AP import Data.XML.Pickle import Data.XML.Types import qualified Data.ByteString as BS +import Data.Maybe (fromMaybe) import Network.XMPP.Pickle --- The element. -saslInitE :: Text -> Element -saslInitE mechanism = +-- The element, with an +-- optional round-trip value. +saslInitE :: Text -> Maybe Text -> Element +saslInitE mechanism rt = Element "{urn:ietf:params:xml:ns:xmpp-sasl}auth" [("mechanism", [ContentText mechanism])] - [] + [NodeContent $ ContentText $ fromMaybe "" rt] + -- SASL response with text payload. saslResponseE :: Text -> Element saslResponseE resp = diff --git a/source/Network/XMPP/Types.hs b/source/Network/XMPP/Types.hs index f3130c5..5eddfc6 100644 --- a/source/Network/XMPP/Types.hs +++ b/source/Network/XMPP/Types.hs @@ -403,11 +403,15 @@ instance Read StanzaErrorCondition where -- ============================================================================= data SASLCredentials = DIGEST_MD5Credentials (Maybe Text) Text Text + | PLAINCredentials (Maybe Text) Text Text instance Show SASLCredentials where show (DIGEST_MD5Credentials authzid authcid _) = "DIGEST_MD5Credentials " ++ (Text.unpack $ fromMaybe "" authzid) ++ " " ++ (Text.unpack authcid) ++ " (password hidden)" + show (PLAINCredentials authzid authcid _) = "PLAINCredentials " ++ + (Text.unpack $ fromMaybe "" authzid) ++ " " ++ (Text.unpack authcid) ++ + " (password hidden)" data SASLMechanism = DIGEST_MD5 deriving Show