module Network.Xmpp.Sasl
( xmppSasl
, digestMd5
, scramSha1
, plain
, auth
) 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 Network.Xmpp.Stream
import Network.Xmpp.Types
import System.Log.Logger (debugM, errorM)
import qualified System.Random as Random
import Network.Xmpp.Sasl.Types
import Network.Xmpp.Sasl.Mechanisms
import Control.Concurrent.STM.TMVar
import Control.Exception
import Data.XML.Pickle
import Data.XML.Types
import Network.Xmpp.Types
import Network.Xmpp.Marshal
import Control.Monad.State(modify)
import Control.Concurrent.STM.TMVar
import Control.Monad.Error
xmppSasl :: [SaslHandler]
-> Stream
-> IO (Either XmppFailure (Maybe AuthFailure))
xmppSasl handlers stream = do
debugM "Pontarius.Xmpp" "xmppSasl: Attempts to authenticate..."
flip withStream stream $ do
mechanisms <- gets $ streamSaslMechanisms . streamFeatures
case (filter (\(name, _) -> name `elem` mechanisms)) handlers of
[] -> return $ Right $ Just $ AuthNoAcceptableMechanism mechanisms
(_name, handler):_ -> do
cs <- gets streamConnectionState
case cs of
Closed -> do
lift $ errorM "Pontarius.Xmpp" "xmppSasl: Stream state closed."
return . Left $ XmppNoStream
_ -> runErrorT $ do
lift $ lift $ debugM "Pontarius.Xmpp" "xmppSasl: Performing handler..."
r <- ErrorT handler
case r of
Just ae -> do
lift $ lift $ errorM "Pontarius.Xmpp" $
"xmppSasl: AuthFailure encountered: " ++
show ae
return $ Just ae
Nothing -> do
lift $ lift $ debugM "Pontarius.Xmpp" "xmppSasl: Authentication successful, restarting stream."
_ <- ErrorT restartStream
lift $ lift $ debugM "Pontarius.Xmpp" "xmppSasl: Stream restarted."
return Nothing
auth :: [SaslHandler]
-> Maybe Text
-> Stream
-> IO (Either XmppFailure (Maybe AuthFailure))
auth mechanisms resource con = runErrorT $ do
ErrorT $ xmppSasl mechanisms con
jid <- ErrorT $ xmppBind resource con
ErrorT $ flip withStream con $ do
s <- get
case establishSession $ streamConfiguration s of
False -> return $ Right Nothing
True -> do
_ <- lift $ startSession con
return $ Right Nothing
return Nothing
bindBody :: Maybe Text -> Element
bindBody = pickleElem $
xpBind . xpOption $ xpElemNodes "resource" (xpContent xpId)
xmppBind :: Maybe Text -> Stream -> IO (Either XmppFailure Jid)
xmppBind rsrc c = runErrorT $ do
lift $ debugM "Pontarius.Xmpp" "Attempts to bind..."
answer <- ErrorT $ pushIQ "bind" Nothing Set Nothing (bindBody rsrc) c
case answer of
Right IQResult{iqResultPayload = Just b} -> do
lift $ debugM "Pontarius.XMPP" "xmppBind: IQ result received; unpickling JID..."
let jid = unpickleElem xpJid b
case jid of
Right jid' -> do
lift $ debugM "Pontarius.XMPP" $ "xmppBind: JID unpickled: " ++ show jid'
ErrorT $ withStream (do
modify $ \s -> s{streamJid = Just jid'}
return $ Right jid') c
return jid'
otherwise -> do
lift $ errorM "Pontarius.XMPP" $ "xmppBind: JID could not be unpickled from: "
++ show b
throwError $ XmppOtherFailure
otherwise -> do
lift $ errorM "Pontarius.XMPP" "xmppBind: IQ error received."
throwError XmppOtherFailure
where
xpJid :: PU [Node] Jid
xpJid = xpBind $ xpElemNodes jidName (xpContent xpPrim)
jidName = "{urn:ietf:params:xml:ns:xmpp-bind}jid"
xpBind :: PU [Node] b -> PU [Node] b
xpBind c = xpElemNodes "{urn:ietf:params:xml:ns:xmpp-bind}bind" c
sessionXml :: Element
sessionXml = pickleElem
(xpElemBlank "{urn:ietf:params:xml:ns:xmpp-session}session")
()
sessionIQ :: Stanza
sessionIQ = IQRequestS $ IQRequest { iqRequestID = "sess"
, iqRequestFrom = Nothing
, iqRequestTo = Nothing
, iqRequestLangTag = Nothing
, iqRequestType = Set
, iqRequestPayload = sessionXml
}
startSession :: Stream -> IO Bool
startSession con = do
debugM "Pontarius.XMPP" "startSession: Pushing `session' IQ set stanza..."
answer <- pushIQ "session" Nothing Set Nothing sessionXml con
case answer of
Left e -> do
errorM "Pontarius.XMPP" $ "startSession: Error stanza received (" ++ (show e) ++ ")"
return False
Right _ -> do
debugM "Pontarius.XMPP" "startSession: Result stanza received."
return True