{-# OPTIONS_HADDOCK hide #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
module Network.Xmpp.Sasl.Common where
import Control.Applicative ((<$>))
import Control.Monad
import Control.Monad.Except
import qualified Data.Attoparsec.ByteString.Char8 as AP
import Data.Bits
import qualified Data.ByteString as BS
import qualified Data.ByteString.Base64 as B64
import Data.Maybe (maybeToList)
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import Data.Word (Word8)
import Data.XML.Pickle
import Data.XML.Types
import Network.Xmpp.Marshal
import Network.Xmpp.Sasl.StringPrep
import Network.Xmpp.Sasl.Types
import Network.Xmpp.Stream
import Network.Xmpp.Types
import qualified System.Random as Random
import Control.Monad.State.Strict
makeNonce :: IO BS.ByteString
makeNonce :: IO ByteString
makeNonce = do
StdGen
g <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall (m :: * -> *). MonadIO m => m StdGen
Random.newStdGen
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
B64.encode forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Word8] -> ByteString
BS.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Int -> Word8
toWord8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> [a] -> [a]
take Int
15 forall a b. (a -> b) -> a -> b
$ forall a g. (Random a, RandomGen g) => g -> [a]
Random.randoms StdGen
g
where
toWord8 :: Int -> Word8
toWord8 :: Int -> Word8
toWord8 Int
x = forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
x :: Word8
saslInitE :: Text.Text -> Maybe Text.Text -> Element
saslInitE :: Text -> Maybe Text -> Element
saslInitE Text
mechanism Maybe Text
rt =
Name -> [(Name, [Content])] -> [Node] -> Element
Element Name
"{urn:ietf:params:xml:ns:xmpp-sasl}auth"
[(Name
"mechanism", [Text -> Content
ContentText Text
mechanism])]
(forall a. Maybe a -> [a]
maybeToList forall a b. (a -> b) -> a -> b
$ Content -> Node
NodeContent forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Content
ContentText forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
rt)
saslResponseE :: Maybe Text.Text -> Element
saslResponseE :: Maybe Text -> Element
saslResponseE Maybe Text
resp =
Name -> [(Name, [Content])] -> [Node] -> Element
Element Name
"{urn:ietf:params:xml:ns:xmpp-sasl}response"
[]
(forall a. Maybe a -> [a]
maybeToList forall a b. (a -> b) -> a -> b
$ Content -> Node
NodeContent forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Content
ContentText forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
resp)
xpSuccess :: PU [Node] (Maybe Text.Text)
xpSuccess :: PU [Node] (Maybe Text)
xpSuccess = forall b. Name -> PU [Node] b -> PU [Node] b
xpElemNodes Name
"{urn:ietf:params:xml:ns:xmpp-sasl}success"
(forall t a. PU [t] a -> PU [t] (Maybe a)
xpOption forall a b. (a -> b) -> a -> b
$ forall a. PU Text a -> PU [Node] a
xpContent forall a. PU a a
xpId)
pairs :: BS.ByteString -> Either String Pairs
pairs :: ByteString -> Either String Pairs
pairs = forall a. Parser a -> ByteString -> Either String a
AP.parseOnly forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (f :: * -> *) a s. Alternative f => f a -> f s -> f [a]
AP.sepBy1 (forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ Char -> Parser Char
AP.char Char
',') forall a b. (a -> b) -> a -> b
$ do
Parser ByteString ()
AP.skipSpace
ByteString
name <- (Char -> Bool) -> Parser ByteString
AP.takeWhile1 (forall a. Eq a => a -> a -> Bool
/= Char
'=')
Char
_ <- Char -> Parser Char
AP.char Char
'='
Bool
qt <- ((Char -> Parser Char
AP.char Char
'"' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True) forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False)
ByteString
content <- (Char -> Bool) -> Parser ByteString
AP.takeWhile1 (String -> Char -> Bool
AP.notInClass [Char
',', Char
'"'])
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
qt forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ Char -> Parser Char
AP.char Char
'"'
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString
name, ByteString
content)
xpFailure :: PU [Node] SaslFailure
xpFailure :: PU [Node] SaslFailure
xpFailure = forall a b t. (a -> b) -> (b -> a) -> PU t a -> PU t b
xpWrap
(\(Maybe (Maybe LangTag, Text)
txt, (SaslError
failure, ()
_, ()
_)) -> SaslError -> Maybe (Maybe LangTag, Text) -> SaslFailure
SaslFailure SaslError
failure Maybe (Maybe LangTag, Text)
txt)
(\(SaslFailure SaslError
failure Maybe (Maybe LangTag, Text)
txt) -> (Maybe (Maybe LangTag, Text)
txt,(SaslError
failure,(),())))
(forall b. Name -> PU [Node] b -> PU [Node] b
xpElemNodes
Name
"{urn:ietf:params:xml:ns:xmpp-sasl}failure"
(forall a b1 b2. PU [a] b1 -> PU [a] b2 -> PU [a] (b1, b2)
xp2Tuple
(forall t a. PU [t] a -> PU [t] (Maybe a)
xpOption forall a b. (a -> b) -> a -> b
$ forall a n.
Name -> PU [(Name, [Content])] a -> PU [Node] n -> PU [Node] (a, n)
xpElem
Name
"{urn:ietf:params:xml:ns:xmpp-sasl}text"
PU [(Name, [Content])] (Maybe LangTag)
xpLangTag
(forall a. PU Text a -> PU [Node] a
xpContent forall a. PU a a
xpId))
(forall name a n.
Text
-> PU Text name
-> PU [(Name, [Content])] a
-> PU [Node] n
-> PU [Node] (name, a, n)
xpElemByNamespace
Text
"urn:ietf:params:xml:ns:xmpp-sasl"
PU Text SaslError
xpSaslError
(forall a. PU [a] ()
xpUnit)
(forall a. PU [a] ()
xpUnit))))
xpSaslError :: PU Text.Text SaslError
xpSaslError :: PU Text SaslError
xpSaslError = (Text
"xpSaslError", Text
"") forall t a. (Text, Text) -> PU t a -> PU t a
<?>
forall a b. (a -> b) -> (b -> a) -> PU a b
xpIso forall {a}. (Eq a, IsString a) => a -> SaslError
saslErrorFromText forall {a}. IsString a => SaslError -> a
saslErrorToText
where
saslErrorToText :: SaslError -> a
saslErrorToText SaslError
SaslAborted = a
"aborted"
saslErrorToText SaslError
SaslAccountDisabled = a
"account-disabled"
saslErrorToText SaslError
SaslCredentialsExpired = a
"credentials-expired"
saslErrorToText SaslError
SaslEncryptionRequired = a
"encryption-required"
saslErrorToText SaslError
SaslIncorrectEncoding = a
"incorrect-encoding"
saslErrorToText SaslError
SaslInvalidAuthzid = a
"invalid-authzid"
saslErrorToText SaslError
SaslInvalidMechanism = a
"invalid-mechanism"
saslErrorToText SaslError
SaslMalformedRequest = a
"malformed-request"
saslErrorToText SaslError
SaslMechanismTooWeak = a
"mechanism-too-weak"
saslErrorToText SaslError
SaslNotAuthorized = a
"not-authorized"
saslErrorToText SaslError
SaslTemporaryAuthFailure = a
"temporary-auth-failure"
saslErrorFromText :: a -> SaslError
saslErrorFromText a
"aborted" = SaslError
SaslAborted
saslErrorFromText a
"account-disabled" = SaslError
SaslAccountDisabled
saslErrorFromText a
"credentials-expired" = SaslError
SaslCredentialsExpired
saslErrorFromText a
"encryption-required" = SaslError
SaslEncryptionRequired
saslErrorFromText a
"incorrect-encoding" = SaslError
SaslIncorrectEncoding
saslErrorFromText a
"invalid-authzid" = SaslError
SaslInvalidAuthzid
saslErrorFromText a
"invalid-mechanism" = SaslError
SaslInvalidMechanism
saslErrorFromText a
"malformed-request" = SaslError
SaslMalformedRequest
saslErrorFromText a
"mechanism-too-weak" = SaslError
SaslMechanismTooWeak
saslErrorFromText a
"not-authorized" = SaslError
SaslNotAuthorized
saslErrorFromText a
"temporary-auth-failure" = SaslError
SaslTemporaryAuthFailure
saslErrorFromText a
_ = SaslError
SaslNotAuthorized
xpChallenge :: PU [Node] (Maybe Text.Text)
xpChallenge :: PU [Node] (Maybe Text)
xpChallenge = forall b. Name -> PU [Node] b -> PU [Node] b
xpElemNodes Name
"{urn:ietf:params:xml:ns:xmpp-sasl}challenge"
(forall t a. PU [t] a -> PU [t] (Maybe a)
xpOption forall a b. (a -> b) -> a -> b
$ forall a. PU Text a -> PU [Node] a
xpContent forall a. PU a a
xpId)
xpSaslElement :: PU [Node] SaslElement
xpSaslElement :: PU [Node] SaslElement
xpSaslElement = forall a t. (a -> Int) -> [PU t a] -> PU t a
xpAlt forall {a}. Num a => SaslElement -> a
saslSel
[ forall a b t. (a -> b) -> (b -> a) -> PU t a -> PU t b
xpWrap Maybe Text -> SaslElement
SaslSuccess (\(SaslSuccess Maybe Text
x) -> Maybe Text
x) PU [Node] (Maybe Text)
xpSuccess
, forall a b t. (a -> b) -> (b -> a) -> PU t a -> PU t b
xpWrap Maybe Text -> SaslElement
SaslChallenge (\(SaslChallenge Maybe Text
c) -> Maybe Text
c) PU [Node] (Maybe Text)
xpChallenge
]
where
saslSel :: SaslElement -> a
saslSel (SaslSuccess Maybe Text
_) = a
0
saslSel (SaslChallenge Maybe Text
_) = a
1
quote :: BS.ByteString -> BS.ByteString
quote :: ByteString -> ByteString
quote ByteString
x = [ByteString] -> ByteString
BS.concat [ByteString
"\"",ByteString
x,ByteString
"\""]
saslInit :: Text.Text -> Maybe BS.ByteString -> ExceptT AuthFailure (StateT StreamState IO) ()
saslInit :: Text
-> Maybe ByteString
-> ExceptT AuthFailure (StateT StreamState IO) ()
saslInit Text
mechanism Maybe ByteString
payload = do
Either XmppFailure ()
r <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> StateT StreamState IO (Either XmppFailure ())
pushElement forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Maybe Text -> Element
saslInitE Text
mechanism forall a b. (a -> b) -> a -> b
$
ByteString -> Text
Text.decodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. (Eq a, IsString a) => a -> a
encodeEmpty forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
B64.encode forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ByteString
payload
case Either XmppFailure ()
r of
Right () -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Left XmppFailure
e -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ XmppFailure -> AuthFailure
AuthStreamFailure XmppFailure
e
where
encodeEmpty :: a -> a
encodeEmpty a
"" = a
"="
encodeEmpty a
x = a
x
pullSaslElement :: ExceptT AuthFailure (StateT StreamState IO) SaslElement
pullSaslElement :: ExceptT AuthFailure (StateT StreamState IO) SaslElement
pullSaslElement = do
Either XmppFailure (Either SaslFailure SaslElement)
mbse <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a.
PU [Node] a -> StateT StreamState IO (Either XmppFailure a)
pullUnpickle (forall n t1 t2. PU n t1 -> PU n t2 -> PU n (Either t1 t2)
xpEither PU [Node] SaslFailure
xpFailure PU [Node] SaslElement
xpSaslElement)
case Either XmppFailure (Either SaslFailure SaslElement)
mbse of
Left XmppFailure
e -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ XmppFailure -> AuthFailure
AuthStreamFailure XmppFailure
e
Right (Left SaslFailure
e) -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ SaslFailure -> AuthFailure
AuthSaslFailure SaslFailure
e
Right (Right SaslElement
r) -> forall (m :: * -> *) a. Monad m => a -> m a
return SaslElement
r
pullChallenge :: ExceptT AuthFailure (StateT StreamState IO) (Maybe BS.ByteString)
pullChallenge :: ExceptT AuthFailure (StateT StreamState IO) (Maybe ByteString)
pullChallenge = do
SaslElement
e <- ExceptT AuthFailure (StateT StreamState IO) SaslElement
pullSaslElement
case SaslElement
e of
SaslChallenge Maybe Text
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
SaslChallenge (Just Text
scb64)
| Right ByteString
sc <- ByteString -> Either String ByteString
B64.decode forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
Text.encodeUtf8 forall a b. (a -> b) -> a -> b
$ Text
scb64
-> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just ByteString
sc
SaslElement
_ -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError AuthFailure
AuthOtherFailure
saslFromJust :: Maybe a -> ExceptT AuthFailure (StateT StreamState IO) a
saslFromJust :: forall a. Maybe a -> ExceptT AuthFailure (StateT StreamState IO) a
saslFromJust Maybe a
Nothing = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ AuthFailure
AuthOtherFailure
saslFromJust (Just a
d) = forall (m :: * -> *) a. Monad m => a -> m a
return a
d
pullSuccess :: ExceptT AuthFailure (StateT StreamState IO) (Maybe Text.Text)
pullSuccess :: ExceptT AuthFailure (StateT StreamState IO) (Maybe Text)
pullSuccess = do
SaslElement
e <- ExceptT AuthFailure (StateT StreamState IO) SaslElement
pullSaslElement
case SaslElement
e of
SaslSuccess Maybe Text
x -> forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Text
x
SaslElement
_ -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ AuthFailure
AuthOtherFailure
pullFinalMessage :: ExceptT AuthFailure (StateT StreamState IO) (Maybe BS.ByteString)
pullFinalMessage :: ExceptT AuthFailure (StateT StreamState IO) (Maybe ByteString)
pullFinalMessage = do
SaslElement
challenge2 <- ExceptT AuthFailure (StateT StreamState IO) SaslElement
pullSaslElement
case SaslElement
challenge2 of
SaslSuccess Maybe Text
x -> forall {m :: * -> *}.
MonadError AuthFailure m =>
Maybe Text -> m (Maybe ByteString)
decode Maybe Text
x
SaslChallenge Maybe Text
x -> do
()
_b <- Maybe ByteString -> ExceptT AuthFailure (StateT StreamState IO) ()
respond forall a. Maybe a
Nothing
Maybe Text
_s <- ExceptT AuthFailure (StateT StreamState IO) (Maybe Text)
pullSuccess
forall {m :: * -> *}.
MonadError AuthFailure m =>
Maybe Text -> m (Maybe ByteString)
decode Maybe Text
x
where
decode :: Maybe Text -> m (Maybe ByteString)
decode Maybe Text
Nothing = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
decode (Just Text
d) = case ByteString -> Either String ByteString
B64.decode forall a b. (a -> b) -> a -> b
$ Text -> ByteString
Text.encodeUtf8 Text
d of
Left String
_e -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ AuthFailure
AuthOtherFailure
Right ByteString
x -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just ByteString
x
toPairs :: BS.ByteString -> ExceptT AuthFailure (StateT StreamState IO) Pairs
toPairs :: ByteString -> ExceptT AuthFailure (StateT StreamState IO) Pairs
toPairs ByteString
ctext = case ByteString -> Either String Pairs
pairs ByteString
ctext of
Left String
_e -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError AuthFailure
AuthOtherFailure
Right Pairs
r -> forall (m :: * -> *) a. Monad m => a -> m a
return Pairs
r
respond :: Maybe BS.ByteString -> ExceptT AuthFailure (StateT StreamState IO) ()
respond :: Maybe ByteString -> ExceptT AuthFailure (StateT StreamState IO) ()
respond Maybe ByteString
m = do
Either XmppFailure ()
r <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> StateT StreamState IO (Either XmppFailure ())
pushElement forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Text -> Element
saslResponseE forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ByteString -> Text
Text.decodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
B64.encode) forall a b. (a -> b) -> a -> b
$ Maybe ByteString
m
case Either XmppFailure ()
r of
Left XmppFailure
e -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ XmppFailure -> AuthFailure
AuthStreamFailure XmppFailure
e
Right () -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
prepCredentials :: Text.Text -> Maybe Text.Text -> Text.Text
-> ExceptT AuthFailure (StateT StreamState IO) (Text.Text, Maybe Text.Text, Text.Text)
prepCredentials :: Text
-> Maybe Text
-> Text
-> ExceptT
AuthFailure (StateT StreamState IO) (Text, Maybe Text, Text)
prepCredentials Text
authcid Maybe Text
authzid Text
password = case Maybe (Text, Maybe Text, Text)
credentials of
Maybe (Text, Maybe Text, Text)
Nothing -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ AuthFailure
AuthIllegalCredentials
Just (Text, Maybe Text, Text)
creds -> forall (m :: * -> *) a. Monad m => a -> m a
return (Text, Maybe Text, Text)
creds
where
credentials :: Maybe (Text, Maybe Text, Text)
credentials = do
Text
ac <- Text -> Maybe Text
normalizeUsername Text
authcid
Maybe Text
az <- case Maybe Text
authzid of
Maybe Text
Nothing -> forall a. a -> Maybe a
Just forall a. Maybe a
Nothing
Just Text
az' -> forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Maybe Text
normalizeUsername Text
az'
Text
pw <- Text -> Maybe Text
normalizePassword Text
password
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
ac, Maybe Text
az, Text
pw)
xorBS :: BS.ByteString -> BS.ByteString -> BS.ByteString
xorBS :: ByteString -> ByteString -> ByteString
xorBS ByteString
x ByteString
y = [Word8] -> ByteString
BS.pack forall a b. (a -> b) -> a -> b
$ forall a. (Word8 -> Word8 -> a) -> ByteString -> ByteString -> [a]
BS.zipWith forall a. Bits a => a -> a -> a
xor ByteString
x ByteString
y
merge :: [BS.ByteString] -> BS.ByteString
merge :: [ByteString] -> ByteString
merge = ByteString -> [ByteString] -> ByteString
BS.intercalate ByteString
","
(+++) :: BS.ByteString -> BS.ByteString -> BS.ByteString
+++ :: ByteString -> ByteString -> ByteString
(+++) = ByteString -> ByteString -> ByteString
BS.append