{-# 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
String -> String -> IO ()
debugM String
"Pontarius.Xmpp" String
"xmppSasl: Attempts to authenticate..."
(StateT StreamState IO (Either XmppFailure (Maybe AuthFailure))
-> Stream -> IO (Either XmppFailure (Maybe AuthFailure)))
-> Stream
-> StateT StreamState IO (Either XmppFailure (Maybe AuthFailure))
-> IO (Either XmppFailure (Maybe AuthFailure))
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT StreamState IO (Either XmppFailure (Maybe AuthFailure))
-> Stream -> IO (Either XmppFailure (Maybe AuthFailure))
forall a. StateT StreamState IO a -> Stream -> IO a
withStream Stream
stream (StateT StreamState IO (Either XmppFailure (Maybe AuthFailure))
-> IO (Either XmppFailure (Maybe AuthFailure)))
-> StateT StreamState IO (Either XmppFailure (Maybe AuthFailure))
-> IO (Either XmppFailure (Maybe AuthFailure))
forall a b. (a -> b) -> a -> b
$ do
[Text]
mechanisms <- (StreamState -> [Text]) -> StateT StreamState IO [Text]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ((StreamState -> [Text]) -> StateT StreamState IO [Text])
-> (StreamState -> [Text]) -> StateT StreamState IO [Text]
forall a b. (a -> b) -> a -> b
$ StreamFeatures -> [Text]
streamFeaturesMechanisms (StreamFeatures -> [Text])
-> (StreamState -> StreamFeatures) -> StreamState -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StreamState -> StreamFeatures
streamFeatures
case ((SaslHandler -> Bool) -> [SaslHandler] -> [SaslHandler]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(Text
name, StateT StreamState IO (Either XmppFailure (Maybe AuthFailure))
_) -> Text
name Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
mechanisms)) [SaslHandler]
handlers of
[] -> Either XmppFailure (Maybe AuthFailure)
-> StateT StreamState IO (Either XmppFailure (Maybe AuthFailure))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either XmppFailure (Maybe AuthFailure)
-> StateT StreamState IO (Either XmppFailure (Maybe AuthFailure)))
-> Either XmppFailure (Maybe AuthFailure)
-> StateT StreamState IO (Either XmppFailure (Maybe AuthFailure))
forall a b. (a -> b) -> a -> b
$ Maybe AuthFailure -> Either XmppFailure (Maybe AuthFailure)
forall a b. b -> Either a b
Right (Maybe AuthFailure -> Either XmppFailure (Maybe AuthFailure))
-> Maybe AuthFailure -> Either XmppFailure (Maybe AuthFailure)
forall a b. (a -> b) -> a -> b
$ AuthFailure -> Maybe AuthFailure
forall a. a -> Maybe a
Just (AuthFailure -> Maybe AuthFailure)
-> AuthFailure -> Maybe AuthFailure
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 <- (StreamState -> ConnectionState)
-> StateT StreamState IO ConnectionState
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets StreamState -> ConnectionState
streamConnectionState
case ConnectionState
cs of
ConnectionState
Closed -> do
IO () -> StateT StreamState IO ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> StateT StreamState IO ())
-> IO () -> StateT StreamState IO ()
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
errorM String
"Pontarius.Xmpp" String
"xmppSasl: Stream state closed."
Either XmppFailure (Maybe AuthFailure)
-> StateT StreamState IO (Either XmppFailure (Maybe AuthFailure))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either XmppFailure (Maybe AuthFailure)
-> StateT StreamState IO (Either XmppFailure (Maybe AuthFailure)))
-> (XmppFailure -> Either XmppFailure (Maybe AuthFailure))
-> XmppFailure
-> StateT StreamState IO (Either XmppFailure (Maybe AuthFailure))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XmppFailure -> Either XmppFailure (Maybe AuthFailure)
forall a b. a -> Either a b
Left (XmppFailure
-> StateT StreamState IO (Either XmppFailure (Maybe AuthFailure)))
-> XmppFailure
-> StateT StreamState IO (Either XmppFailure (Maybe AuthFailure))
forall a b. (a -> b) -> a -> b
$ XmppFailure
XmppNoStream
ConnectionState
_ -> ExceptT XmppFailure (StateT StreamState IO) (Maybe AuthFailure)
-> StateT StreamState IO (Either XmppFailure (Maybe AuthFailure))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT XmppFailure (StateT StreamState IO) (Maybe AuthFailure)
-> StateT StreamState IO (Either XmppFailure (Maybe AuthFailure)))
-> ExceptT XmppFailure (StateT StreamState IO) (Maybe AuthFailure)
-> StateT StreamState IO (Either XmppFailure (Maybe AuthFailure))
forall a b. (a -> b) -> a -> b
$ do
StateT StreamState IO ()
-> ExceptT XmppFailure (StateT StreamState IO) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT StreamState IO ()
-> ExceptT XmppFailure (StateT StreamState IO) ())
-> StateT StreamState IO ()
-> ExceptT XmppFailure (StateT StreamState IO) ()
forall a b. (a -> b) -> a -> b
$ IO () -> StateT StreamState IO ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> StateT StreamState IO ())
-> IO () -> StateT StreamState IO ()
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
debugM String
"Pontarius.Xmpp" String
"xmppSasl: Performing handler..."
Maybe AuthFailure
r <- StateT StreamState IO (Either XmppFailure (Maybe AuthFailure))
-> ExceptT XmppFailure (StateT StreamState IO) (Maybe AuthFailure)
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
StateT StreamState IO ()
-> ExceptT XmppFailure (StateT StreamState IO) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT StreamState IO ()
-> ExceptT XmppFailure (StateT StreamState IO) ())
-> StateT StreamState IO ()
-> ExceptT XmppFailure (StateT StreamState IO) ()
forall a b. (a -> b) -> a -> b
$ IO () -> StateT StreamState IO ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> StateT StreamState IO ())
-> IO () -> StateT StreamState IO ()
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
errorM String
"Pontarius.Xmpp" (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
String
"xmppSasl: AuthFailure encountered: " String -> String -> String
forall a. [a] -> [a] -> [a]
++
AuthFailure -> String
forall a. Show a => a -> String
show AuthFailure
ae
Maybe AuthFailure
-> ExceptT XmppFailure (StateT StreamState IO) (Maybe AuthFailure)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe AuthFailure
-> ExceptT XmppFailure (StateT StreamState IO) (Maybe AuthFailure))
-> Maybe AuthFailure
-> ExceptT XmppFailure (StateT StreamState IO) (Maybe AuthFailure)
forall a b. (a -> b) -> a -> b
$ AuthFailure -> Maybe AuthFailure
forall a. a -> Maybe a
Just AuthFailure
ae
Maybe AuthFailure
Nothing -> do
StateT StreamState IO ()
-> ExceptT XmppFailure (StateT StreamState IO) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT StreamState IO ()
-> ExceptT XmppFailure (StateT StreamState IO) ())
-> StateT StreamState IO ()
-> ExceptT XmppFailure (StateT StreamState IO) ()
forall a b. (a -> b) -> a -> b
$ IO () -> StateT StreamState IO ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> StateT StreamState IO ())
-> IO () -> StateT StreamState IO ()
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
debugM String
"Pontarius.Xmpp" String
"xmppSasl: Authentication successful, restarting stream."
()
_ <- StateT StreamState IO (Either XmppFailure ())
-> ExceptT XmppFailure (StateT StreamState IO) ()
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT StateT StreamState IO (Either XmppFailure ())
restartStream
StateT StreamState IO ()
-> ExceptT XmppFailure (StateT StreamState IO) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT StreamState IO ()
-> ExceptT XmppFailure (StateT StreamState IO) ())
-> StateT StreamState IO ()
-> ExceptT XmppFailure (StateT StreamState IO) ()
forall a b. (a -> b) -> a -> b
$ IO () -> StateT StreamState IO ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> StateT StreamState IO ())
-> IO () -> StateT StreamState IO ()
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
debugM String
"Pontarius.Xmpp" String
"xmppSasl: Stream restarted."
Maybe AuthFailure
-> ExceptT XmppFailure (StateT StreamState IO) (Maybe AuthFailure)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe AuthFailure
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 = ExceptT XmppFailure IO (Maybe AuthFailure)
-> IO (Either XmppFailure (Maybe AuthFailure))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT XmppFailure IO (Maybe AuthFailure)
-> IO (Either XmppFailure (Maybe AuthFailure)))
-> ExceptT XmppFailure IO (Maybe AuthFailure)
-> IO (Either XmppFailure (Maybe AuthFailure))
forall a b. (a -> b) -> a -> b
$ do
Maybe AuthFailure
mbAuthFail <- IO (Either XmppFailure (Maybe AuthFailure))
-> ExceptT XmppFailure IO (Maybe AuthFailure)
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either XmppFailure (Maybe AuthFailure))
-> ExceptT XmppFailure IO (Maybe AuthFailure))
-> IO (Either XmppFailure (Maybe AuthFailure))
-> ExceptT XmppFailure IO (Maybe AuthFailure)
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 <- IO (Either XmppFailure Jid) -> ExceptT XmppFailure IO Jid
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either XmppFailure Jid) -> ExceptT XmppFailure IO Jid)
-> IO (Either XmppFailure Jid) -> ExceptT XmppFailure IO Jid
forall a b. (a -> b) -> a -> b
$ Maybe Text -> Stream -> IO (Either XmppFailure Jid)
xmppBind Maybe Text
resource Stream
con
IO (Either XmppFailure (Maybe AuthFailure))
-> ExceptT XmppFailure IO (Maybe AuthFailure)
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either XmppFailure (Maybe AuthFailure))
-> ExceptT XmppFailure IO (Maybe AuthFailure))
-> IO (Either XmppFailure (Maybe AuthFailure))
-> ExceptT XmppFailure IO (Maybe AuthFailure)
forall a b. (a -> b) -> a -> b
$ (StateT StreamState IO (Either XmppFailure (Maybe AuthFailure))
-> Stream -> IO (Either XmppFailure (Maybe AuthFailure)))
-> Stream
-> StateT StreamState IO (Either XmppFailure (Maybe AuthFailure))
-> IO (Either XmppFailure (Maybe AuthFailure))
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT StreamState IO (Either XmppFailure (Maybe AuthFailure))
-> Stream -> IO (Either XmppFailure (Maybe AuthFailure))
forall a. StateT StreamState IO a -> Stream -> IO a
withStream' Stream
con (StateT StreamState IO (Either XmppFailure (Maybe AuthFailure))
-> IO (Either XmppFailure (Maybe AuthFailure)))
-> StateT StreamState IO (Either XmppFailure (Maybe AuthFailure))
-> IO (Either XmppFailure (Maybe AuthFailure))
forall a b. (a -> b) -> a -> b
$ do
StreamState
s <- StateT StreamState IO StreamState
forall s (m :: * -> *). MonadState s m => m s
get
case StreamState -> Bool
sendStreamElement StreamState
s of
Bool
False -> Either XmppFailure (Maybe AuthFailure)
-> StateT StreamState IO (Either XmppFailure (Maybe AuthFailure))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either XmppFailure (Maybe AuthFailure)
-> StateT StreamState IO (Either XmppFailure (Maybe AuthFailure)))
-> Either XmppFailure (Maybe AuthFailure)
-> StateT StreamState IO (Either XmppFailure (Maybe AuthFailure))
forall a b. (a -> b) -> a -> b
$ Maybe AuthFailure -> Either XmppFailure (Maybe AuthFailure)
forall a b. b -> Either a b
Right Maybe AuthFailure
forall a. Maybe a
Nothing
Bool
True -> do
Bool
_ <- IO Bool -> StateT StreamState IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> StateT StreamState IO Bool)
-> IO Bool -> StateT StreamState IO Bool
forall a b. (a -> b) -> a -> b
$ Stream -> IO Bool
startSession Stream
con
Either XmppFailure (Maybe AuthFailure)
-> StateT StreamState IO (Either XmppFailure (Maybe AuthFailure))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either XmppFailure (Maybe AuthFailure)
-> StateT StreamState IO (Either XmppFailure (Maybe AuthFailure)))
-> Either XmppFailure (Maybe AuthFailure)
-> StateT StreamState IO (Either XmppFailure (Maybe AuthFailure))
forall a b. (a -> b) -> a -> b
$ Maybe AuthFailure -> Either XmppFailure (Maybe AuthFailure)
forall a b. b -> Either a b
Right Maybe AuthFailure
forall a. Maybe a
Nothing
Maybe AuthFailure
f -> Maybe AuthFailure -> ExceptT XmppFailure IO (Maybe AuthFailure)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe AuthFailure
f
where
sendStreamElement :: StreamState -> Bool
sendStreamElement StreamState
s =
[Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [
StreamFeatures -> Maybe Bool
streamFeaturesSession (StreamState -> StreamFeatures
streamFeatures StreamState
s) Maybe Bool -> Maybe Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False
]
bindBody :: Maybe Text -> Element
bindBody :: Maybe Text -> Element
bindBody = PU [Node] (Maybe Text) -> Maybe Text -> Element
forall a. PU [Node] a -> a -> Element
pickleElem (PU [Node] (Maybe Text) -> Maybe Text -> Element)
-> PU [Node] (Maybe Text) -> Maybe Text -> Element
forall a b. (a -> b) -> a -> b
$
PU [Node] (Maybe Text) -> PU [Node] (Maybe Text)
forall b. PU [Node] b -> PU [Node] b
xpBind (PU [Node] (Maybe Text) -> PU [Node] (Maybe Text))
-> (PU [Node] Text -> PU [Node] (Maybe Text))
-> PU [Node] Text
-> PU [Node] (Maybe Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PU [Node] Text -> PU [Node] (Maybe Text)
forall t a. PU [t] a -> PU [t] (Maybe a)
xpOption (PU [Node] Text -> PU [Node] (Maybe Text))
-> PU [Node] Text -> PU [Node] (Maybe Text)
forall a b. (a -> b) -> a -> b
$ Name -> PU [Node] Text -> PU [Node] Text
forall b. Name -> PU [Node] b -> PU [Node] b
xpElemNodes Name
"{urn:ietf:params:xml:ns:xmpp-bind}resource" (PU Text Text -> PU [Node] Text
forall a. PU Text a -> PU [Node] a
xpContent PU Text Text
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 = ExceptT XmppFailure IO Jid -> IO (Either XmppFailure Jid)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT XmppFailure IO Jid -> IO (Either XmppFailure Jid))
-> ExceptT XmppFailure IO Jid -> IO (Either XmppFailure Jid)
forall a b. (a -> b) -> a -> b
$ do
IO () -> ExceptT XmppFailure IO ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> ExceptT XmppFailure IO ())
-> IO () -> ExceptT XmppFailure IO ()
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
debugM String
"Pontarius.Xmpp" String
"Attempts to bind..."
Either IQError IQResult
answer <- IO (Either XmppFailure (Either IQError IQResult))
-> ExceptT XmppFailure IO (Either IQError IQResult)
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either XmppFailure (Either IQError IQResult))
-> ExceptT XmppFailure IO (Either IQError IQResult))
-> IO (Either XmppFailure (Either IQError IQResult))
-> ExceptT XmppFailure IO (Either IQError IQResult)
forall a b. (a -> b) -> a -> b
$ Text
-> Maybe Jid
-> IQRequestType
-> Maybe LangTag
-> Element
-> Stream
-> IO (Either XmppFailure (Either IQError IQResult))
pushIQ Text
"bind" Maybe Jid
forall a. Maybe a
Nothing IQRequestType
Set Maybe LangTag
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
IO () -> ExceptT XmppFailure IO ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> ExceptT XmppFailure IO ())
-> IO () -> ExceptT XmppFailure IO ()
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
debugM String
"Pontarius.Xmpp" String
"xmppBind: IQ result received; unpickling JID..."
let j :: Either UnpickleError Jid
j = PU [Node] Jid -> Element -> Either UnpickleError Jid
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
IO () -> ExceptT XmppFailure IO ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> ExceptT XmppFailure IO ())
-> IO () -> ExceptT XmppFailure IO ()
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
infoM String
"Pontarius.Xmpp" (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Bound JID: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Jid -> String
forall a. Show a => a -> String
show Jid
jid'
()
_ <- IO () -> ExceptT XmppFailure IO ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> ExceptT XmppFailure IO ())
-> IO () -> ExceptT XmppFailure IO ()
forall a b. (a -> b) -> a -> b
$ StateT StreamState IO () -> Stream -> IO ()
forall a. StateT StreamState IO a -> Stream -> IO a
withStream ( do (StreamState -> StreamState) -> StateT StreamState IO ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((StreamState -> StreamState) -> StateT StreamState IO ())
-> (StreamState -> StreamState) -> StateT StreamState IO ()
forall a b. (a -> b) -> a -> b
$ \StreamState
s ->
StreamState
s{streamJid :: Maybe Jid
streamJid = Jid -> Maybe Jid
forall a. a -> Maybe a
Just Jid
jid'})
Stream
c
Jid -> ExceptT XmppFailure IO Jid
forall (m :: * -> *) a. Monad m => a -> m a
return Jid
jid'
Either UnpickleError Jid
_ -> do
IO () -> ExceptT XmppFailure IO ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> ExceptT XmppFailure IO ())
-> IO () -> ExceptT XmppFailure IO ()
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
errorM String
"Pontarius.Xmpp"
(String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"xmppBind: JID could not be unpickled from: "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ Element -> String
forall a. Show a => a -> String
show Element
b
XmppFailure -> ExceptT XmppFailure IO Jid
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (XmppFailure -> ExceptT XmppFailure IO Jid)
-> XmppFailure -> ExceptT XmppFailure IO Jid
forall a b. (a -> b) -> a -> b
$ XmppFailure
XmppOtherFailure
Either IQError IQResult
_ -> do
IO () -> ExceptT XmppFailure IO ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> ExceptT XmppFailure IO ())
-> IO () -> ExceptT XmppFailure IO ()
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
errorM String
"Pontarius.XMPP" String
"xmppBind: IQ error received."
XmppFailure -> ExceptT XmppFailure IO Jid
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError XmppFailure
XmppOtherFailure
where
xpJid' :: PU [Node] Jid
xpJid' :: PU [Node] Jid
xpJid' = PU [Node] Jid -> PU [Node] Jid
forall b. PU [Node] b -> PU [Node] b
xpBind (PU [Node] Jid -> PU [Node] Jid) -> PU [Node] Jid -> PU [Node] Jid
forall a b. (a -> b) -> a -> b
$ Name -> PU [Node] Jid -> PU [Node] Jid
forall b. Name -> PU [Node] b -> PU [Node] b
xpElemNodes Name
forall p. IsString p => p
jidName (PU Text Jid -> PU [Node] Jid
forall a. PU Text a -> PU [Node] a
xpContent PU Text Jid
xpJid)
jidName :: p
jidName = p
"{urn:ietf:params:xml:ns:xmpp-bind}jid"
xpBind :: PU [Node] b -> PU [Node] b
xpBind :: PU [Node] b -> PU [Node] b
xpBind PU [Node] b
c = Name -> PU [Node] b -> PU [Node] b
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 = PU [Node] () -> () -> Element
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
String -> String -> IO ()
debugM String
"Pontarius.XMPP" String
"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" Maybe Jid
forall a. Maybe a
Nothing IQRequestType
Set Maybe LangTag
forall a. Maybe a
Nothing Element
sessionXml Stream
con
case Either XmppFailure (Either IQError IQResult)
answer of
Left XmppFailure
e -> do
String -> String -> IO ()
errorM String
"Pontarius.XMPP" (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"startSession: Error stanza received (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (XmppFailure -> String
forall a. Show a => a -> String
show XmppFailure
e) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
Right Either IQError IQResult
_ -> do
String -> String -> IO ()
debugM String
"Pontarius.XMPP" String
"startSession: Result stanza received."
Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True