From 021a0487c37622097f20e9bbc68149efe017e5ac Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Mon, 19 Mar 2012 00:54:55 +0100 Subject: [PATCH] sasl working --- src/Network/XMPP/Monad.hs | 23 ++++++- src/Network/XMPP/SASL.hs | 121 +++++++++++++++++++++++++++++++++++++ src/Network/XMPPConduit.hs | 62 ++++++------------- 3 files changed, 161 insertions(+), 45 deletions(-) create mode 100644 src/Network/XMPP/SASL.hs diff --git a/src/Network/XMPP/Monad.hs b/src/Network/XMPP/Monad.hs index ae2dfaf..204a4d5 100644 --- a/src/Network/XMPP/Monad.hs +++ b/src/Network/XMPP/Monad.hs @@ -4,6 +4,8 @@ import Control.Monad.Trans import Control.Monad.Trans.State import Data.Conduit +import Data.Conduit.Text as CT +import Data.Conduit.Binary as CB import Data.Conduit.List as CL import Data.XML.Types @@ -13,6 +15,8 @@ import Data.Text import System.IO import Text.XML.Stream.Elements +import Text.XML.Stream.Render as XR +import Text.XML.Stream.Parse type XMPPMonad a = StateT XMPPState (ResourceT IO) a @@ -22,8 +26,9 @@ data XMPPState = XMPPState , conHandle :: Maybe Handle , sFeatures :: ServerFeatures , haveTLS :: Bool - , sHostname :: Text - , jid :: Text + , sHostname :: Text + , username :: Text + , resource :: Text } data ServerFeatures = SF @@ -61,3 +66,17 @@ pull :: XMPPMonad Element pull = do source <- gets conSrc pulls elementFromEvents + +xmppFromHandle handle hostname username resource f = runResourceT $ do + liftIO $ hSetBuffering handle NoBuffering + src <- bufferSource $ CB.sourceHandle handle $= CT.decode CT.utf8 $= parseText def + let st = XMPPState + src + (XR.renderBytes def =$ CB.sinkHandle handle) + (Just handle) + def + False + hostname + username + resource + runStateT f st diff --git a/src/Network/XMPP/SASL.hs b/src/Network/XMPP/SASL.hs new file mode 100644 index 0000000..396a6e1 --- /dev/null +++ b/src/Network/XMPP/SASL.hs @@ -0,0 +1,121 @@ +{-# LANGUAGE NoMonomorphismRestriction, OverloadedStrings #-} +module Network.XMPP.SASL where + +import Control.Applicative +import Control.Monad +import Control.Monad.Trans +import Control.Monad.Trans.State + +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.Char8 as BS8 +import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Lazy.Char8 as BL8 +import qualified Data.ByteString.Base64 as B64 +import qualified Data.List as L +import qualified Data.Digest.Pure.MD5 as MD5 +import Data.List +import Data.XML.Types + +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text + +import Network.XMPP.Monad + +import Numeric -- + +import qualified System.Random as Random + +import Text.XML.Stream.Elements + +saslInitE mechanism = + Element "{urn:ietf:params:xml:ns:xmpp-sasl}auth" + [("mechanism", [ContentText mechanism]) + ] + [] + +saslResponseE resp = + Element "{urn:ietf:params:xml:ns:xmpp-sasl}response" [] + [NodeContent $ ContentText resp] + +saslResponse2E = + Element "{urn:ietf:params:xml:ns:xmpp-sasl}response" [] [] + +xmppSASL passwd = do + mechanisms <- gets $ saslMechanisms . sFeatures + unless ("DIGEST-MD5" `elem` mechanisms) $ error "No usable auth mechanism" + push $ saslInitE "DIGEST-MD5" + Element "{urn:ietf:params:xml:ns:xmpp-sasl}challenge" [] + [NodeContent (ContentText content)] <- pull + let (Right challenge) = B64.decode . Text.encodeUtf8 $ content + let Right pairs = toPairs challenge + liftIO $ BS.putStrLn challenge + push . saslResponseE =<< createResponse passwd pairs + Element name attrs content <- pull + when (name == "{urn:ietf:params:xml:ns:xmpp-sasl}failure") $ + (error $ show content) + push saslResponse2E + Element "{urn:ietf:params:xml:ns:xmpp-sasl}sucess" <- pull + return () + +createResponse passwd' pairs = do + let Just qop = L.lookup "qop" pairs + let Just nonce = L.lookup "nonce" pairs + uname <- Text.encodeUtf8 <$> gets username + let passwd = Text.encodeUtf8 passwd' + realm <- Text.encodeUtf8 <$> gets sHostname + g <- liftIO $ Random.newStdGen + let cnonce = BS.tail . BS.init . + B64.encode . BS.pack . take 8 $ Random.randoms g + let nc = "00000001" + let digestURI = ("xmpp/" `BS.append` realm) + let digest = md5Digest + uname + realm + passwd + digestURI + nc + qop + nonce + cnonce + let response = BS.intercalate"," . map (BS.intercalate "=") $ + [["username" , quote uname ] + ,["realm" , quote realm ] + ,["nonce" , quote nonce ] + ,["cnonce" , quote cnonce ] + ,["nc" , nc ] + ,["qop" , qop ] + ,["digest-uri", quote digestURI ] + ,["response" , digest ] + ,["charset" , "utf-8" ] + ] + liftIO $ BS.putStrLn response + return . Text.decodeUtf8 $ B64.encode response + where quote x = BS.concat ["\"",x,"\""] + +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.pack . show + . (CC.hash' :: BS.ByteString -> MD5.MD5Digest) . BS.intercalate (":") + +hashRaw = toStrict . Binary.encode + . (CC.hash' :: BS.ByteString -> MD5.MD5Digest) . BS.intercalate (":") + +toStrict = BS.concat . BL.toChunks +-- TODO: this only handles MD5-sess +md5Digest uname realm password digestURI nc qop nonce cnonce= + let ha1 = hash [hashRaw [uname,realm,password], nonce, cnonce] + ha2 = hash ["AUTHENTICATE", digestURI] + in hash [ha1,nonce, nc, cnonce,qop,ha2] + diff --git a/src/Network/XMPPConduit.hs b/src/Network/XMPPConduit.hs index 3a0cd7a..eef010c 100644 --- a/src/Network/XMPPConduit.hs +++ b/src/Network/XMPPConduit.hs @@ -1,61 +1,37 @@ {-# LANGUAGE NoMonomorphismRestriction, OverloadedStrings #-} module Network.XMPPConduit where -import Control.Exception import Control.Monad -import Control.Monad.ST (runST) import Control.Monad.Trans -import Control.Monad.Trans.Class -import Control.Monad.Trans.State -import Control.Applicative - -import Data.Conduit as C -import Data.Conduit.Binary as CB -import Data.Conduit.Text as CT -import Data.Default -import Data.List as L -import Data.Text as T -import Data.XML.Types - -import GHC.IO.Handle +import qualified Data.ByteString as BS +import Data.Text as Text import Network -import qualified Network.TLSConduit as TLS +import Network.XMPP.Monad +import Network.XMPP.TLS +import Network.XMPP.Stream +import Network.XMPP.SASL + import System.IO -import System.Random - -import Text.XML.Stream.Elements -import Text.XML.Stream.Render as XR -import Text.XML.Stream.Parse - -import qualified Data.Conduit.List as CL - - -xmppSASL = do - return () - -xmppFromHandle handle hostname jid = do - liftIO $ hSetBuffering handle NoBuffering - src <- bufferSource $ CB.sourceHandle handle $= CT.decode CT.utf8 $= parseText def - let st = XMPPState - src - (XR.renderBytes def =$ CB.sinkHandle handle) - (Just handle) - def - False - hostname - jid - flip runStateT st $ do + +fromHandle :: Handle -> Text -> Text -> Text -> IO ((), XMPPState) +fromHandle handle hostname username password = + xmppFromHandle handle hostname username "" $ do xmppStartStream - xmppStartTLS - xmppSASL + -- this will check whether the server supports tls + -- on it's own + xmppStartTLS exampleParams + xmppSASL password + forever $ pull >>= liftIO . print + return () main = do con <- connectTo "localhost" (PortNumber 5222) hSetBuffering con NoBuffering - fs <- runResourceT $ xmppFromHandle con "species_64739.dyndns.org" "uart14" + (fs,st) <- fromHandle con "species64739.dyndns.org" "bot" "pwd" + print $ haveTLS st putStrLn "" hGetContents con >>= putStrLn