{-# OPTIONS_HADDOCK hide #-}
{-# LANGUAGE NoMonomorphismRestriction, OverloadedStrings #-}
--
-- Submodule for functionality related to SASL negotation:
-- authentication functions, SASL functionality, bind functionality,
-- and the legacy `{urn:ietf:params:xml:ns:xmpp-session}session'
-- functionality.

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)

-- | Uses the first supported mechanism to authenticate, if any. Updates the
-- state with non-password credentials and restarts the stream upon
-- success. Returns `Nothing' on success, an `AuthFailure' if
-- authentication fails, or an `XmppFailure' if anything else fails.
xmppSasl :: [SaslHandler] -- ^ Acceptable authentication mechanisms and their
                       -- corresponding handlers
         -> 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
        -- Chooses the first mechanism that is acceptable by both the client and the
        -- server.
        [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
                           -- TODO: Log details about handler? SaslHandler "show" instance?
                           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

-- | Authenticate to the server using the first matching method and bind a
-- resource.
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 [ -- Check that the stream feature is set and not optional
              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
            ]


-- Produces a `bind' element, optionally wrapping a resource.
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
$
               -- Pickler to produce a
               -- "<bind xmlns='urn:ietf:params:xml:ns:xmpp-bind'/>"
               -- element, with a possible "<resource>[JID]</resource>"
               -- child.
               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)

-- Sends a (synchronous) IQ set request for a (`Just') given or server-generated
-- resource and extract the JID from the non-error response.
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
    -- Extracts the character data in the `jid' element.
    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"

-- A `bind' element pickler.
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")
    ()

-- Sends the session IQ set element and waits for an answer. Throws an error if
-- if an IQ error stanza is returned from the server.
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