{-# OPTIONS_HADDOCK hide #-}
-- Implementation of the PLAIN Simple Authentication and Security Layer (SASL)
-- Mechanism, http://tools.ietf.org/html/rfc4616.

{-# LANGUAGE OverloadedStrings #-}

module Network.Xmpp.Sasl.Mechanisms.Plain
    ( plain
    ) where

import           Control.Monad.Except
import           Control.Monad.State.Strict
import qualified Data.ByteString as BS
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import           Network.Xmpp.Sasl.Common
import           Network.Xmpp.Sasl.Types
import           Network.Xmpp.Types

-- TODO: stringprep
xmppPlain :: Text.Text -- ^ Password
          -> Maybe Text.Text -- ^ Authorization identity (authzid)
          -> Text.Text -- ^ Authentication identity (authcid)
          -> ExceptT AuthFailure (StateT StreamState IO) ()
xmppPlain :: Text
-> Maybe Text
-> Text
-> ExceptT AuthFailure (StateT StreamState IO) ()
xmppPlain Text
authcid' Maybe Text
authzid' Text
password  = do
    (Text
ac, Maybe Text
az, Text
pw) <- Text
-> Maybe Text
-> Text
-> ExceptT
     AuthFailure (StateT StreamState IO) (Text, Maybe Text, Text)
prepCredentials Text
authcid' Maybe Text
authzid' Text
password
    ()
_ <- Text
-> Maybe ByteString
-> ExceptT AuthFailure (StateT StreamState IO) ()
saslInit Text
"PLAIN" ( forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text -> Text -> ByteString
plainMessage Text
ac Maybe Text
az Text
pw)
    Maybe Text
_ <- ExceptT AuthFailure (StateT StreamState IO) (Maybe Text)
pullSuccess
    forall (m :: * -> *) a. Monad m => a -> m a
return ()
  where
    -- Converts an optional authorization identity, an authentication identity,
    -- and a password to a \NUL-separated PLAIN message.
    plainMessage :: Text.Text -- Authorization identity (authzid)
                 -> Maybe Text.Text -- Authentication identity (authcid)
                 -> Text.Text -- Password
                 -> BS.ByteString -- The PLAIN message
    plainMessage :: Text -> Maybe Text -> Text -> ByteString
plainMessage Text
authcid Maybe Text
_authzid Text
passwd = [ByteString] -> ByteString
BS.concat forall a b. (a -> b) -> a -> b
$
                                             [ ByteString
authzid''
                                             , ByteString
"\NUL"
                                             , Text -> ByteString
Text.encodeUtf8 forall a b. (a -> b) -> a -> b
$ Text
authcid
                                             , ByteString
"\NUL"
                                             , Text -> ByteString
Text.encodeUtf8 forall a b. (a -> b) -> a -> b
$ Text
passwd
                                             ]
      where
        authzid'' :: ByteString
authzid'' = forall b a. b -> (a -> b) -> Maybe a -> b
maybe ByteString
"" Text -> ByteString
Text.encodeUtf8 Maybe Text
authzid'

plain :: Username -- ^ authentication ID (username)
      -> Maybe AuthZID -- ^ authorization ID
      -> Password -- ^ password
      -> SaslHandler
plain :: Text -> Maybe Text -> Text -> SaslHandler
plain Text
authcid Maybe Text
authzid Text
passwd =
    ( Text
"PLAIN"
    , do
          Either AuthFailure ()
r <- forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ Text
-> Maybe Text
-> Text
-> ExceptT AuthFailure (StateT StreamState IO) ()
xmppPlain Text
authcid Maybe Text
authzid Text
passwd
          case Either AuthFailure ()
r of
              Left (AuthStreamFailure XmppFailure
e) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left XmppFailure
e
              Left AuthFailure
e -> 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 AuthFailure
e
              Right () -> 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
    )