sasl working

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

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]
+

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