You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
211 lines
8.5 KiB
211 lines
8.5 KiB
{-# LANGUAGE NoMonomorphismRestriction, OverloadedStrings #-} |
|
|
|
module Network.XMPP.SASL where |
|
|
|
import Control.Applicative |
|
import Control.Arrow (left) |
|
import Control.Monad |
|
import Control.Monad.Error |
|
import Control.Monad.State.Strict |
|
|
|
import qualified Crypto.Classes as CC |
|
|
|
import qualified Data.Attoparsec.ByteString.Char8 as AP |
|
import qualified Data.Binary as Binary |
|
import qualified Data.ByteString as BS |
|
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 Data.XML.Pickle |
|
import Data.XML.Types |
|
|
|
import qualified Data.Text as Text |
|
import Data.Text (Text) |
|
import qualified Data.Text.Encoding as Text |
|
|
|
import Network.XMPP.Monad |
|
import Network.XMPP.Stream |
|
import Network.XMPP.Types |
|
import Network.XMPP.Pickle |
|
|
|
import qualified System.Random as Random |
|
|
|
data AuthError = AuthXmlError |
|
| AuthMechanismError [Text] -- ^ Wraps mechanisms offered |
|
| AuthChallengeError |
|
| AuthStreamError StreamError -- ^ Stream error on stream restart |
|
| AuthConnectionError -- ^ No host name set in state |
|
| AuthError -- General instance used for the Error instance |
|
deriving Show |
|
|
|
instance Error AuthError where |
|
noMsg = AuthError |
|
|
|
-- Uses the DIGEST-MD5 method (if available) to authenticate. Updates the |
|
-- sUsername XMPPConMonad field with a `Just' value 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 -- ^ User name |
|
-> Text -- ^ Password |
|
-> XMPPConMonad (Either AuthError ()) |
|
xmppSASL uname passwd = runErrorT $ do |
|
realm <- gets sHostname |
|
case realm of |
|
Just realm' -> do |
|
ErrorT $ xmppStartSASL realm' |
|
modify (\s -> s{sUsername = Just uname}) |
|
Nothing -> throwError AuthConnectionError |
|
where |
|
xmppStartSASL :: Text -- ^ SASL realm |
|
-> XMPPConMonad (Either AuthError ()) |
|
xmppStartSASL realm = runErrorT $ do |
|
mechanisms <- gets $ saslMechanisms . sFeatures |
|
unless ("DIGEST-MD5" `elem` mechanisms) . |
|
throwError $ AuthMechanismError mechanisms |
|
-- Push element and receive the challenge (in XMPPConMonad). |
|
_ <- lift . pushElement $ saslInitE "DIGEST-MD5" -- TODO: Check boolean? |
|
challenge' <- lift $ B64.decode . Text.encodeUtf8 <$> |
|
pullPickle challengePickle |
|
challenge <- case challenge' of |
|
Left _e -> throwError AuthChallengeError |
|
Right r -> return r |
|
pairs <- case toPairs challenge of |
|
Left _ -> throwError AuthChallengeError |
|
Right p -> return p |
|
g <- liftIO Random.newStdGen |
|
_ <- lift . pushElement . -- TODO: Check boolean? |
|
saslResponseE $ createResponse g realm pairs |
|
challenge2 <- lift $ pullPickle (xpEither failurePickle challengePickle) |
|
case challenge2 of |
|
Left _x -> throwError AuthXmlError |
|
Right _ -> return () |
|
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 () |
|
-- The <auth xmlns='urn:ietf:params:xml:ns:xmpp-sasl'/> element. |
|
saslInitE :: Text -> Element |
|
saslInitE mechanism = |
|
Element "{urn:ietf:params:xml:ns:xmpp-sasl}auth" |
|
[("mechanism", [ContentText mechanism])] |
|
[] |
|
-- SASL response with text payload. |
|
saslResponseE :: Text -> Element |
|
saslResponseE resp = |
|
Element "{urn:ietf:params:xml:ns:xmpp-sasl}response" |
|
[] |
|
[NodeContent $ ContentText resp] |
|
-- SASL response without payload. |
|
saslResponse2E :: Element |
|
saslResponse2E = |
|
Element "{urn:ietf:params:xml:ns:xmpp-sasl}response" |
|
[] |
|
[] |
|
-- Parses the incoming SASL data to a mapped list of pairs. |
|
toPairs :: BS.ByteString -> Either String [(BS.ByteString, BS.ByteString)] |
|
toPairs = AP.parseOnly . flip AP.sepBy1 (void $ AP.char ',') $ do |
|
AP.skipSpace |
|
name <- AP.takeWhile1 (/= '=') |
|
_ <- AP.char '=' |
|
quote <- ((AP.char '"' >> return True) `mplus` return False) |
|
content <- AP.takeWhile1 (AP.notInClass [',', '"']) |
|
when quote . void $ AP.char '"' |
|
return (name, content) |
|
-- Produce the response to the challenge. |
|
createResponse :: Random.RandomGen g |
|
=> g |
|
-> Text |
|
-> [(BS8.ByteString, BS8.ByteString)] -- Pairs |
|
-> Text |
|
createResponse g hostname pairs = let |
|
Just qop = L.lookup "qop" pairs |
|
Just nonce = L.lookup "nonce" pairs |
|
uname_ = Text.encodeUtf8 uname |
|
passwd_ = Text.encodeUtf8 passwd |
|
-- Using Int instead of Word8 for random 1.0.0.0 (GHC 7) compatibility. |
|
cnonce = BS.tail . BS.init . |
|
B64.encode . BS.pack . map toWord8 . |
|
take 8 $ Random.randoms g |
|
nc = "00000001" |
|
digestURI = "xmpp/" `BS.append` Text.encodeUtf8 hostname |
|
digest = md5Digest |
|
uname_ |
|
(lookup "realm" pairs) |
|
passwd_ |
|
digestURI |
|
nc |
|
qop |
|
nonce |
|
cnonce |
|
response = BS.intercalate "," . map (BS.intercalate "=") $ |
|
[["username", quote uname_]] ++ |
|
case L.lookup "realm" pairs of |
|
Just realm -> [["realm" , quote realm ]] |
|
Nothing -> [] ++ |
|
[ ["nonce" , quote nonce ] |
|
, ["cnonce" , quote cnonce ] |
|
, ["nc" , nc ] |
|
, ["qop" , qop ] |
|
, ["digest-uri", quote digestURI] |
|
, ["response" , digest ] |
|
, ["charset" , "utf-8" ] |
|
] |
|
in Text.decodeUtf8 $ B64.encode response |
|
quote :: BS8.ByteString -> BS8.ByteString |
|
quote x = BS.concat ["\"",x,"\""] |
|
toWord8 :: Int -> Word8 |
|
toWord8 x = fromIntegral x :: Word8 |
|
hash :: [BS8.ByteString] -> BS8.ByteString |
|
hash = BS8.pack . show |
|
. (CC.hash' :: BS.ByteString -> MD5.MD5Digest) . BS.intercalate (":") |
|
hashRaw :: [BS8.ByteString] -> BS8.ByteString |
|
hashRaw = toStrict . Binary.encode . |
|
(CC.hash' :: BS.ByteString -> MD5.MD5Digest) . BS.intercalate (":") |
|
toStrict :: BL.ByteString -> BS8.ByteString |
|
toStrict = BS.concat . BL.toChunks |
|
-- TODO: this only handles MD5-sess |
|
md5Digest :: BS8.ByteString |
|
-> Maybe BS8.ByteString |
|
-> BS8.ByteString |
|
-> BS8.ByteString |
|
-> BS8.ByteString |
|
-> BS8.ByteString |
|
-> BS8.ByteString |
|
-> BS8.ByteString |
|
-> BS8.ByteString |
|
md5Digest uname realm password digestURI nc qop nonce cnonce = |
|
let ha1 = hash [ hashRaw [uname, maybe "" id realm, password] |
|
, nonce |
|
, cnonce |
|
] |
|
ha2 = hash ["AUTHENTICATE", digestURI] |
|
in hash [ha1, nonce, nc, cnonce, qop, ha2] |
|
-- Failure element pickler. |
|
failurePickle :: PU [Node] SaslFailure |
|
failurePickle = xpWrap |
|
(\(txt, (failure, _, _)) -> SaslFailure failure txt) |
|
(\(SaslFailure failure txt) -> (txt,(failure,(),()))) |
|
(xpElemNodes |
|
"{urn:ietf:params:xml:ns:xmpp-sasl}failure" |
|
(xp2Tuple |
|
(xpOption $ xpElem |
|
"{urn:ietf:params:xml:ns:xmpp-sasl}text" |
|
xpLangTag |
|
(xpContent xpId)) |
|
(xpElemByNamespace |
|
"urn:ietf:params:xml:ns:xmpp-sasl" |
|
xpPrim |
|
(xpUnit) |
|
(xpUnit)))) |
|
-- Challenge element pickler. |
|
challengePickle :: PU [Node] Text.Text |
|
challengePickle = xpElemNodes "{urn:ietf:params:xml:ns:xmpp-sasl}challenge" |
|
(xpIsolate $ xpContent xpId) |