{-# OPTIONS_HADDOCK hide #-}
{-# LANGUAGE NoMonomorphismRestriction, OverloadedStrings #-}
module Network.Xmpp.Sasl
( xmppSasl
, digestMd5
, scramSha1
, plain
, auth
) where
import Control.Monad.Except
import Control.Monad.State.Strict
import Data.Text (Text)
import Data.XML.Pickle
import Data.XML.Types
import Network.Xmpp.Marshal
import Network.Xmpp.Sasl.Mechanisms
import Network.Xmpp.Sasl.Types
import Network.Xmpp.Stream
import Network.Xmpp.Types
import System.Log.Logger (debugM, errorM, infoM)
xmppSasl :: [SaslHandler]
-> Stream
-> IO (Either XmppFailure (Maybe AuthFailure))
xmppSasl :: [SaslHandler]
-> Stream -> IO (Either XmppFailure (Maybe AuthFailure))
xmppSasl [SaslHandler]
handlers Stream
stream = do
[Char] -> [Char] -> IO ()
debugM [Char]
"Pontarius.Xmpp" [Char]
"xmppSasl: Attempts to authenticate..."
forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. StateT StreamState IO a -> Stream -> IO a
withStream Stream
stream forall a b. (a -> b) -> a -> b
$ do
[Text]
mechanisms <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall a b. (a -> b) -> a -> b
$ StreamFeatures -> [Text]
streamFeaturesMechanisms forall b c a. (b -> c) -> (a -> b) -> a -> c
. StreamState -> StreamFeatures
streamFeatures
case (forall a. (a -> Bool) -> [a] -> [a]
filter (\(Text
name, StateT StreamState IO (Either XmppFailure (Maybe AuthFailure))
_) -> Text
name forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
mechanisms)) [SaslHandler]
handlers of
[] -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [Text] -> AuthFailure
AuthNoAcceptableMechanism [Text]
mechanisms
(Text
_name, StateT StreamState IO (Either XmppFailure (Maybe AuthFailure))
handler):[SaslHandler]
_ -> do
ConnectionState
cs <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets StreamState -> ConnectionState
streamConnectionState
case ConnectionState
cs of
ConnectionState
Closed -> do
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> IO ()
errorM [Char]
"Pontarius.Xmpp" [Char]
"xmppSasl: Stream state closed."
forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ XmppFailure
XmppNoStream
ConnectionState
_ -> forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ do
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> IO ()
debugM [Char]
"Pontarius.Xmpp" [Char]
"xmppSasl: Performing handler..."
Maybe AuthFailure
r <- forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT StateT StreamState IO (Either XmppFailure (Maybe AuthFailure))
handler
case Maybe AuthFailure
r of
Just AuthFailure
ae -> do
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> IO ()
errorM [Char]
"Pontarius.Xmpp" forall a b. (a -> b) -> a -> b
$
[Char]
"xmppSasl: AuthFailure encountered: " forall a. [a] -> [a] -> [a]
++
forall a. Show a => a -> [Char]
show AuthFailure
ae
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just AuthFailure
ae
Maybe AuthFailure
Nothing -> do
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> IO ()
debugM [Char]
"Pontarius.Xmpp" [Char]
"xmppSasl: Authentication successful, restarting stream."
()
_ <- forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT StateT StreamState IO (Either XmppFailure ())
restartStream
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> IO ()
debugM [Char]
"Pontarius.Xmpp" [Char]
"xmppSasl: Stream restarted."
forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
auth :: [SaslHandler]
-> Maybe Text
-> Stream
-> IO (Either XmppFailure (Maybe AuthFailure))
auth :: [SaslHandler]
-> Maybe Text
-> Stream
-> IO (Either XmppFailure (Maybe AuthFailure))
auth [SaslHandler]
mechanisms Maybe Text
resource Stream
con = forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ do
Maybe AuthFailure
mbAuthFail <- forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT forall a b. (a -> b) -> a -> b
$ [SaslHandler]
-> Stream -> IO (Either XmppFailure (Maybe AuthFailure))
xmppSasl [SaslHandler]
mechanisms Stream
con
case Maybe AuthFailure
mbAuthFail of
Maybe AuthFailure
Nothing -> do
Jid
_jid <- forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT forall a b. (a -> b) -> a -> b
$ Maybe Text -> Stream -> IO (Either XmppFailure Jid)
xmppBind Maybe Text
resource Stream
con
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. StateT StreamState IO a -> Stream -> IO a
withStream' Stream
con forall a b. (a -> b) -> a -> b
$ do
StreamState
s <- forall s (m :: * -> *). MonadState s m => m s
get
case StreamState -> Bool
sendStreamElement StreamState
s of
Bool
False -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a. Maybe a
Nothing
Bool
True -> do
Bool
_ <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Stream -> IO Bool
startSession Stream
con
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a. Maybe a
Nothing
Maybe AuthFailure
f -> forall (m :: * -> *) a. Monad m => a -> m a
return Maybe AuthFailure
f
where
sendStreamElement :: StreamState -> Bool
sendStreamElement StreamState
s =
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [
StreamFeatures -> Maybe Bool
streamFeaturesSession (StreamState -> StreamFeatures
streamFeatures StreamState
s) forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just Bool
False
]
bindBody :: Maybe Text -> Element
bindBody :: Maybe Text -> Element
bindBody = forall a. PU [Node] a -> a -> Element
pickleElem forall a b. (a -> b) -> a -> b
$
forall b. PU [Node] b -> PU [Node] b
xpBind forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t a. PU [t] a -> PU [t] (Maybe a)
xpOption forall a b. (a -> b) -> a -> b
$ forall b. Name -> PU [Node] b -> PU [Node] b
xpElemNodes Name
"{urn:ietf:params:xml:ns:xmpp-bind}resource" (forall a. PU Text a -> PU [Node] a
xpContent forall a. PU a a
xpId)
xmppBind :: Maybe Text -> Stream -> IO (Either XmppFailure Jid)
xmppBind :: Maybe Text -> Stream -> IO (Either XmppFailure Jid)
xmppBind Maybe Text
rsrc Stream
c = forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ do
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> IO ()
debugM [Char]
"Pontarius.Xmpp" [Char]
"Attempts to bind..."
Either IQError IQResult
answer <- forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT forall a b. (a -> b) -> a -> b
$ Text
-> Maybe Jid
-> IQRequestType
-> Maybe LangTag
-> Element
-> Stream
-> IO (Either XmppFailure (Either IQError IQResult))
pushIQ Text
"bind" forall a. Maybe a
Nothing IQRequestType
Set forall a. Maybe a
Nothing (Maybe Text -> Element
bindBody Maybe Text
rsrc) Stream
c
case Either IQError IQResult
answer of
Right IQResult{iqResultPayload :: IQResult -> Maybe Element
iqResultPayload = Just Element
b} -> do
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> IO ()
debugM [Char]
"Pontarius.Xmpp" [Char]
"xmppBind: IQ result received; unpickling JID..."
let j :: Either UnpickleError Jid
j = forall a. PU [Node] a -> Element -> Either UnpickleError a
unpickleElem PU [Node] Jid
xpJid' Element
b
case Either UnpickleError Jid
j of
Right Jid
jid' -> do
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> IO ()
infoM [Char]
"Pontarius.Xmpp" forall a b. (a -> b) -> a -> b
$ [Char]
"Bound JID: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Jid
jid'
()
_ <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. StateT StreamState IO a -> Stream -> IO a
withStream ( do forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \StreamState
s ->
StreamState
s{streamJid :: Maybe Jid
streamJid = forall a. a -> Maybe a
Just Jid
jid'})
Stream
c
forall (m :: * -> *) a. Monad m => a -> m a
return Jid
jid'
Either UnpickleError Jid
_ -> do
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> IO ()
errorM [Char]
"Pontarius.Xmpp"
forall a b. (a -> b) -> a -> b
$ [Char]
"xmppBind: JID could not be unpickled from: "
forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Element
b
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ XmppFailure
XmppOtherFailure
Either IQError IQResult
_ -> do
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> IO ()
errorM [Char]
"Pontarius.XMPP" [Char]
"xmppBind: IQ error received."
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError XmppFailure
XmppOtherFailure
where
xpJid' :: PU [Node] Jid
xpJid' :: PU [Node] Jid
xpJid' = forall b. PU [Node] b -> PU [Node] b
xpBind forall a b. (a -> b) -> a -> b
$ forall b. Name -> PU [Node] b -> PU [Node] b
xpElemNodes forall {a}. IsString a => a
jidName (forall a. PU Text a -> PU [Node] a
xpContent PU Text Jid
xpJid)
jidName :: a
jidName = a
"{urn:ietf:params:xml:ns:xmpp-bind}jid"
xpBind :: PU [Node] b -> PU [Node] b
xpBind :: forall b. PU [Node] b -> PU [Node] b
xpBind PU [Node] b
c = forall b. Name -> PU [Node] b -> PU [Node] b
xpElemNodes Name
"{urn:ietf:params:xml:ns:xmpp-bind}bind" PU [Node] b
c
sessionXml :: Element
sessionXml :: Element
sessionXml = forall a. PU [Node] a -> a -> Element
pickleElem
(Name -> PU [Node] ()
xpElemBlank Name
"{urn:ietf:params:xml:ns:xmpp-session}session")
()
startSession :: Stream -> IO Bool
startSession :: Stream -> IO Bool
startSession Stream
con = do
[Char] -> [Char] -> IO ()
debugM [Char]
"Pontarius.XMPP" [Char]
"startSession: Pushing `session' IQ set stanza..."
Either XmppFailure (Either IQError IQResult)
answer <- Text
-> Maybe Jid
-> IQRequestType
-> Maybe LangTag
-> Element
-> Stream
-> IO (Either XmppFailure (Either IQError IQResult))
pushIQ Text
"session" forall a. Maybe a
Nothing IQRequestType
Set forall a. Maybe a
Nothing Element
sessionXml Stream
con
case Either XmppFailure (Either IQError IQResult)
answer of
Left XmppFailure
e -> do
[Char] -> [Char] -> IO ()
errorM [Char]
"Pontarius.XMPP" forall a b. (a -> b) -> a -> b
$ [Char]
"startSession: Error stanza received (" forall a. [a] -> [a] -> [a]
++ (forall a. Show a => a -> [Char]
show XmppFailure
e) forall a. [a] -> [a] -> [a]
++ [Char]
")"
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
Right Either IQError IQResult
_ -> do
[Char] -> [Char] -> IO ()
debugM [Char]
"Pontarius.XMPP" [Char]
"startSession: Result stanza received."
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True