{-# 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
    [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
        -- Chooses the first mechanism that is acceptable by both the client and the
        -- server.
        [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
                           -- TODO: Log details about handler? SaslHandler "show" instance?
                           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

-- | 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 = 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 [ -- Check that the stream feature is set and not optional
              StreamFeatures -> Maybe Bool
streamFeaturesSession (StreamState -> StreamFeatures
streamFeatures StreamState
s) forall a. Eq a => a -> a -> 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 = forall a. PU [Node] a -> a -> Element
pickleElem 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.
               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)

-- 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 = 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
    -- Extracts the character data in the `jid' element.
    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"

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

-- 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
    [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