Jon Kristensen
14 years ago
6 changed files with 273 additions and 176 deletions
@ -0,0 +1,152 @@
@@ -0,0 +1,152 @@
|
||||
{-# LANGUAGE OverloadedStrings #-} |
||||
|
||||
module Network.XMPP.SASL.DIGEST_MD5 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 Network.XMPP.SASL.SASL |
||||
import Network.XMPP.SASL.Types |
||||
|
||||
xmppDIGEST_MD5 :: Maybe Text -- Authorization identity (authzid) |
||||
-> Text -- Authentication identity (authzid) |
||||
-> Text -- Password (authzid) |
||||
-> XMPPConMonad (Either AuthError ()) |
||||
xmppDIGEST_MD5 authzid authcid passwd = runErrorT $ do |
||||
realm <- gets sHostname |
||||
case realm of |
||||
Just realm' -> do |
||||
ErrorT $ xmppDIGEST_MD5' realm' |
||||
-- TODO: Save authzid |
||||
modify (\s -> s{sUsername = Just authcid}) |
||||
Nothing -> throwError AuthConnectionError |
||||
where |
||||
xmppDIGEST_MD5' :: Text -- ^ SASL realm |
||||
-> XMPPConMonad (Either AuthError ()) |
||||
xmppDIGEST_MD5' realm = runErrorT $ do |
||||
-- 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 () |
||||
-- 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 authcid |
||||
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] |
||||
@ -0,0 +1,65 @@
@@ -0,0 +1,65 @@
|
||||
{-# LANGUAGE OverloadedStrings #-} |
||||
|
||||
module Network.XMPP.SASL.SASL where |
||||
|
||||
import Network.XMPP.Types |
||||
|
||||
import Control.Monad.Error |
||||
import Data.Text |
||||
import qualified Data.Attoparsec.ByteString.Char8 as AP |
||||
import Data.XML.Pickle |
||||
import Data.XML.Types |
||||
import qualified Data.ByteString as BS |
||||
|
||||
import Network.XMPP.Pickle |
||||
|
||||
-- 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) |
||||
|
||||
-- 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 |
||||
challengePickle = xpElemNodes "{urn:ietf:params:xml:ns:xmpp-sasl}challenge" |
||||
(xpIsolate $ xpContent xpId) |
||||
@ -0,0 +1,16 @@
@@ -0,0 +1,16 @@
|
||||
module Network.XMPP.SASL.Types where |
||||
|
||||
import Control.Monad.Error |
||||
import Data.Text |
||||
import Network.XMPP.Types |
||||
|
||||
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 |
||||
Loading…
Reference in new issue