diff --git a/src/Network/XMPP/SASL.hs b/src/Network/XMPP/SASL.hs index b5897bf..a820f1d 100644 --- a/src/Network/XMPP/SASL.hs +++ b/src/Network/XMPP/SASL.hs @@ -1,4 +1,5 @@ {-# LANGUAGE NoMonomorphismRestriction, OverloadedStrings #-} + module Network.XMPP.SASL where import Control.Applicative @@ -32,181 +33,179 @@ import Network.XMPP.Pickle import qualified System.Random as Random - -saslInitE :: Text -> Element -saslInitE mechanism = - Element "{urn:ietf:params:xml:ns:xmpp-sasl}auth" - [ ("mechanism", [ContentText mechanism]) ] - [] - -saslResponseE :: Text -> Element -saslResponseE resp = - Element "{urn:ietf:params:xml:ns:xmpp-sasl}response" - [] - [NodeContent $ ContentText resp] - -saslResponse2E :: Element -saslResponse2E = - Element "{urn:ietf:params:xml:ns:xmpp-sasl}response" - [] - [] - data AuthError = AuthXmlError - | AuthMechanismError [Text] + | AuthMechanismError [Text] -- ^ Wraps mechanisms offered | AuthChallengeError - | AuthStreamError StreamError - | AuthConnectionError + | 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 = AuthXmlError - -xmppSASL:: Text -> Text -> XMPPConMonad (Either AuthError Text) + 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' uname passwd - modify (\s -> s{sUsername = Just uname}) - return uname - Nothing -> throwError AuthConnectionError - -xmppStartSASL :: Text - -> Text - -> Text - -> XMPPConMonad (Either AuthError ()) -xmppStartSASL realm username passwd = runErrorT $ do - mechanisms <- gets $ saslMechanisms . sFeatures - unless ("DIGEST-MD5" `elem` mechanisms) - . throwError $ AuthMechanismError mechanisms - lift . pushN $ saslInitE "DIGEST-MD5" - 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 . pushN . saslResponseE $ createResponse g realm username passwd pairs - challenge2 <- lift $ pullPickle (xpEither failurePickle challengePickle) - case challenge2 of - Left _x -> throwError $ AuthXmlError - Right _ -> return () - lift $ pushN saslResponse2E - e <- lift pullElement - case e of - Element "{urn:ietf:params:xml:ns:xmpp-sasl}success" [] [] -> return () - _ -> throwError AuthXmlError -- TODO: investigate - _ <- ErrorT $ left AuthStreamError <$> xmppRestartStream - return () - -createResponse :: Random.RandomGen g - => g - -> Text - -> Text - -> Text - -> [(BS8.ByteString, BS8.ByteString)] - -> Text -createResponse g hostname username passwd' pairs = let - Just qop = L.lookup "qop" pairs - Just nonce = L.lookup "nonce" pairs - uname = Text.encodeUtf8 username - 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 + 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 . pushN $ 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 . pushN . -- TODO: Check boolean? + saslResponseE $ createResponse g realm pairs + challenge2 <- lift $ pullPickle (xpEither failurePickle challengePickle) + case challenge2 of + Left _x -> throwError AuthXmlError + Right _ -> return () + lift $ pushN 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 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 x = fromIntegral (x :: Int) :: Word8 - -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) - -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] - --- Pickling -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)))) - - -challengePickle :: PU [Node] Text.Text -challengePickle = xpElemNodes "{urn:ietf:params:xml:ns:xmpp-sasl}challenge" - (xpIsolate $ xpContent xpId) - + 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) \ No newline at end of file