Browse Source

de-monadified createResponse

master
Philipp Balzarek 14 years ago
parent
commit
6de96f2679
  1. 37
      src/Network/XMPP/SASL.hs

37
src/Network/XMPP/SASL.hs

@ -68,7 +68,8 @@ xmppStartSASL realm username passwd = do
pushN $ saslInitE "DIGEST-MD5" pushN $ saslInitE "DIGEST-MD5"
Right challenge <- B64.decode . Text.encodeUtf8<$> pullPickle challengePickle Right challenge <- B64.decode . Text.encodeUtf8<$> pullPickle challengePickle
let Right pairs = toPairs challenge let Right pairs = toPairs challenge
pushN . saslResponseE =<< createResponse realm username passwd pairs g <- liftIO $ Random.newStdGen
pushN . saslResponseE $ createResponse g realm username passwd pairs
challenge2 <- pullPickle (xpEither failurePickle challengePickle) challenge2 <- pullPickle (xpEither failurePickle challengePickle)
case challenge2 of case challenge2 of
Left x -> error $ show x Left x -> error $ show x
@ -78,23 +79,24 @@ xmppStartSASL realm username passwd = do
xmppRestartStream xmppRestartStream
return () return ()
createResponse :: Text createResponse :: Random.RandomGen g
=> g
-> Text
-> Text -> Text
-> Text -> Text
-> [(BS8.ByteString, BS8.ByteString)] -> [(BS8.ByteString, BS8.ByteString)]
-> XMPPConMonad Text -> Text
createResponse hostname username passwd' pairs = do createResponse g hostname username passwd' pairs = let
let Just qop = L.lookup "qop" pairs Just qop = L.lookup "qop" pairs
let Just nonce = L.lookup "nonce" pairs Just nonce = L.lookup "nonce" pairs
let uname = Text.encodeUtf8 username uname = Text.encodeUtf8 username
let passwd = Text.encodeUtf8 passwd' passwd = Text.encodeUtf8 passwd'
let realm = Text.encodeUtf8 hostname realm = Text.encodeUtf8 hostname
g <- liftIO $ Random.newStdGen cnonce = BS.tail . BS.init .
let cnonce = BS.tail . BS.init .
B64.encode . BS.pack . take 8 $ Random.randoms g B64.encode . BS.pack . take 8 $ Random.randoms g
let nc = "00000001" nc = "00000001"
let digestURI = ("xmpp/" `BS.append` realm) digestURI = ("xmpp/" `BS.append` realm)
let digest = md5Digest digest = md5Digest
uname uname
realm realm
passwd passwd
@ -103,7 +105,7 @@ createResponse hostname username passwd' pairs = do
qop qop
nonce nonce
cnonce cnonce
let response = BS.intercalate"," . map (BS.intercalate "=") $ response = BS.intercalate"," . map (BS.intercalate "=") $
[["username" , quote uname ] [["username" , quote uname ]
,["realm" , quote realm ] ,["realm" , quote realm ]
,["nonce" , quote nonce ] ,["nonce" , quote nonce ]
@ -114,8 +116,9 @@ createResponse hostname username passwd' pairs = do
,["response" , digest ] ,["response" , digest ]
,["charset" , "utf-8" ] ,["charset" , "utf-8" ]
] ]
return . Text.decodeUtf8 $ B64.encode response in Text.decodeUtf8 $ B64.encode response
where quote x = BS.concat ["\"",x,"\""] where
quote x = BS.concat ["\"",x,"\""]
toPairs :: BS.ByteString -> Either String [(BS.ByteString, BS.ByteString)] toPairs :: BS.ByteString -> Either String [(BS.ByteString, BS.ByteString)]
toPairs = AP.parseOnly . flip AP.sepBy1 (void $ AP.char ',') $ do toPairs = AP.parseOnly . flip AP.sepBy1 (void $ AP.char ',') $ do

Loading…
Cancel
Save