{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes       #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Network.XMPP.Sasl
-- Copyright   :  (c) Dmitry Astapov, 2006 ; pierre, 2007
-- License     :  BSD-style (see the file LICENSE)
-- Copyright   :  (c) riskbook, 2020
-- SPDX-License-Identifier:  BSD3
-- 
-- Maintainer  :  Dmitry Astapov <dastapov@gmail.com>, pierre <k.pierre.k@gmail.com>
-- Stability   :  experimental
-- Portability :  portable
--
-- SASL Authentication for XMPP
--
-----------------------------------------------------------------------------

module Network.XMPP.Sasl
  ( saslAuth
  ) where

import           Control.Monad                     (unless, join)
import           Control.Monad.IO.Class
import           Control.Monad.Except              (throwError, runExceptT,
                                                    lift, ExceptT(..))
import           Data.Char                         (chr, ord)
import           Data.List                         (intercalate)
import qualified Data.Text                         as T
import           Numeric                           (showHex)
import           System.Random                     (newStdGen, randoms)
import           Text.XML.HaXml.Combinators hiding (when)
import           Text.Hamlet.XML

import qualified Network.XMPP.Base64 as B64
import qualified Network.XMPP.MD5    as MD5
import           Network.XMPP.Stream
import           Network.XMPP.Types

-- | Perform authentication over already-open channel
saslAuth :: MonadIO m
         => [T.Text] -- ^ List of auth mechanism available from server, currently only "DIGEST-MD5" is supported
         -> T.Text   -- ^ Server we are connectint to (hostname)
         -> T.Text   -- ^ Username to connect as
         -> T.Text   -- ^ Password
         -> XmppMonad m (Either XmppError ())
saslAuth :: [Text] -> Text -> Text -> Text -> XmppMonad m (Either XmppError ())
saslAuth [Text]
mechanisms Text
server Text
username Text
password
  | Text
"DIGEST-MD5" Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
mechanisms
  = Text -> Text -> Text -> XmppMonad m (Either XmppError ())
forall (m :: * -> *).
MonadIO m =>
Text -> Text -> Text -> XmppMonad m (Either XmppError ())
saslDigest Text
server Text
username Text
password
  | Bool
otherwise
  = let mechs :: [Text]
mechs = String -> Text
T.pack (String -> Text) -> (Text -> String) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
forall a. Show a => a -> String
show (Text -> Text) -> [Text] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text]
mechanisms
    in  Either XmppError () -> XmppMonad m (Either XmppError ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either XmppError () -> XmppMonad m (Either XmppError ()))
-> Either XmppError () -> XmppMonad m (Either XmppError ())
forall a b. (a -> b) -> a -> b
$ XmppError -> Either XmppError ()
forall a b. a -> Either a b
Left (XmppError -> Either XmppError ())
-> XmppError -> Either XmppError ()
forall a b. (a -> b) -> a -> b
$ [Text] -> Text -> XmppError
NonSupportedAuthMechanisms [Text]
mechs Text
"DIGEST-MD5"


saslDigest :: MonadIO m => T.Text -> T.Text -> T.Text -> XmppMonad m (Either XmppError ())
saslDigest :: Text -> Text -> Text -> XmppMonad m (Either XmppError ())
saslDigest Text
server Text
username Text
password = ExceptT XmppError (XmppMonad m) ()
-> XmppMonad m (Either XmppError ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT XmppError (XmppMonad m) ()
 -> XmppMonad m (Either XmppError ()))
-> ExceptT XmppError (XmppMonad m) ()
-> XmppMonad m (Either XmppError ())
forall a b. (a -> b) -> a -> b
$ do
  XmppMonad m () -> ExceptT XmppError (XmppMonad m) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (XmppMonad m () -> ExceptT XmppError (XmppMonad m) ())
-> XmppMonad m () -> ExceptT XmppError (XmppMonad m) ()
forall a b. (a -> b) -> a -> b
$ Node -> XmppMonad m ()
forall (t :: * -> *) a. (XmppSendable t a, Monad t) => a -> t ()
xmppSend (Node -> XmppMonad m ()) -> Node -> XmppMonad m ()
forall a b. (a -> b) -> a -> b
$ [Node] -> Node
forall a. [a] -> a
head [Node]
auth
  Text
ch_text <- (Either XmppError (Either XmppError Text) -> Either XmppError Text
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Either XmppError (Either XmppError Text) -> Either XmppError Text)
-> ExceptT
     XmppError (XmppMonad m) (Either XmppError (Either XmppError Text))
-> ExceptT XmppError (XmppMonad m) (Either XmppError Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> XmppMonad m (Either XmppError (Either XmppError Text))
-> ExceptT
     XmppError (XmppMonad m) (Either XmppError (Either XmppError Text))
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ((Content Posn -> Either XmppError Text)
-> XmppMonad m (Either XmppError (Either XmppError Text))
forall (m :: * -> *) b.
MonadIO m =>
(Content Posn -> b) -> XmppMonad m (Either XmppError b)
withNextM Content Posn -> Either XmppError Text
forall i. Content i -> Either XmppError Text
getChallenge)) ExceptT XmppError (XmppMonad m) (Either XmppError Text)
-> (Either XmppError Text -> ExceptT XmppError (XmppMonad m) Text)
-> ExceptT XmppError (XmppMonad m) Text
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (XmppError -> ExceptT XmppError (XmppMonad m) Text)
-> (Text -> ExceptT XmppError (XmppMonad m) Text)
-> Either XmppError Text
-> ExceptT XmppError (XmppMonad m) Text
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either XmppError -> ExceptT XmppError (XmppMonad m) Text
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError Text -> ExceptT XmppError (XmppMonad m) Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  String
resp    <- IO String -> ExceptT XmppError (XmppMonad m) String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> ExceptT XmppError (XmppMonad m) String)
-> IO String -> ExceptT XmppError (XmppMonad m) String
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Text -> Text -> IO String
saslDigestResponse Text
ch_text Text
username Text
server Text
password
  XmppMonad m () -> ExceptT XmppError (XmppMonad m) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (XmppMonad m () -> ExceptT XmppError (XmppMonad m) ())
-> XmppMonad m () -> ExceptT XmppError (XmppMonad m) ()
forall a b. (a -> b) -> a -> b
$ Node -> XmppMonad m ()
forall (t :: * -> *) a. (XmppSendable t a, Monad t) => a -> t ()
xmppSend (Node -> XmppMonad m ()) -> Node -> XmppMonad m ()
forall a b. (a -> b) -> a -> b
$ [Node] -> Node
forall a. [a] -> a
head ([Node] -> Node) -> [Node] -> Node
forall a b. (a -> b) -> a -> b
$ Text -> [Node]
response (Text -> [Node]) -> Text -> [Node]
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
resp
  Content Posn
m <- XmppMonad m (Either XmppError (Content Posn))
-> ExceptT
     XmppError (XmppMonad m) (Either XmppError (Content Posn))
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift XmppMonad m (Either XmppError (Content Posn))
forall (m :: * -> *).
MonadIO m =>
XmppMonad m (Either XmppError (Content Posn))
nextM ExceptT XmppError (XmppMonad m) (Either XmppError (Content Posn))
-> (Either XmppError (Content Posn)
    -> ExceptT XmppError (XmppMonad m) (Content Posn))
-> ExceptT XmppError (XmppMonad m) (Content Posn)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (XmppError -> ExceptT XmppError (XmppMonad m) (Content Posn))
-> (Content Posn -> ExceptT XmppError (XmppMonad m) (Content Posn))
-> Either XmppError (Content Posn)
-> ExceptT XmppError (XmppMonad m) (Content Posn)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either XmppError -> ExceptT XmppError (XmppMonad m) (Content Posn)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError Content Posn -> ExceptT XmppError (XmppMonad m) (Content Posn)
forall (f :: * -> *) a. Applicative f => a -> f a
pure

  Bool
-> ExceptT XmppError (XmppMonad m) ()
-> ExceptT XmppError (XmppMonad m) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Content Posn] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Content Posn] -> Bool) -> [Content Posn] -> Bool
forall a b. (a -> b) -> a -> b
$ String -> CFilter Posn
forall i. String -> CFilter i
tag String
"failure" Content Posn
m) (ExceptT XmppError (XmppMonad m) ()
 -> ExceptT XmppError (XmppMonad m) ())
-> ExceptT XmppError (XmppMonad m) ()
-> ExceptT XmppError (XmppMonad m) ()
forall a b. (a -> b) -> a -> b
$ XmppError -> ExceptT XmppError (XmppMonad m) ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (XmppError -> ExceptT XmppError (XmppMonad m) ())
-> XmppError -> ExceptT XmppError (XmppMonad m) ()
forall a b. (a -> b) -> a -> b
$ Text -> XmppError
AuthError (Text -> XmppError) -> Text -> XmppError
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Content Posn -> String
forall a. Show a => a -> String
show Content Posn
m

  Text
chl_text <- XmppMonad m (Either XmppError Text)
-> ExceptT XmppError (XmppMonad m) Text
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (XmppMonad m (Either XmppError Text)
 -> ExceptT XmppError (XmppMonad m) Text)
-> (Either XmppError Text -> XmppMonad m (Either XmppError Text))
-> Either XmppError Text
-> ExceptT XmppError (XmppMonad m) Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either XmppError Text -> XmppMonad m (Either XmppError Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either XmppError Text -> ExceptT XmppError (XmppMonad m) Text)
-> Either XmppError Text -> ExceptT XmppError (XmppMonad m) Text
forall a b. (a -> b) -> a -> b
$ Content Posn -> Either XmppError Text
forall i. Content i -> Either XmppError Text
getChallenge Content Posn
m
  XmppMonad m (Either XmppError ())
-> ExceptT XmppError (XmppMonad m) (Either XmppError ())
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Text -> XmppMonad m (Either XmppError ())
forall (m :: * -> *).
MonadIO m =>
Text -> XmppMonad m (Either XmppError ())
saslDigestRspAuth Text
chl_text) ExceptT XmppError (XmppMonad m) (Either XmppError ())
-> (Either XmppError () -> ExceptT XmppError (XmppMonad m) ())
-> ExceptT XmppError (XmppMonad m) ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (XmppError -> ExceptT XmppError (XmppMonad m) ())
-> (() -> ExceptT XmppError (XmppMonad m) ())
-> Either XmppError ()
-> ExceptT XmppError (XmppMonad m) ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either XmppError -> ExceptT XmppError (XmppMonad m) ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError () -> ExceptT XmppError (XmppMonad m) ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  XmppMonad m () -> ExceptT XmppError (XmppMonad m) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (XmppMonad m () -> ExceptT XmppError (XmppMonad m) ())
-> XmppMonad m () -> ExceptT XmppError (XmppMonad m) ()
forall a b. (a -> b) -> a -> b
$ Node -> XmppMonad m ()
forall (t :: * -> *) a. (XmppSendable t a, Monad t) => a -> t ()
xmppSend (Node -> XmppMonad m ()) -> Node -> XmppMonad m ()
forall a b. (a -> b) -> a -> b
$ [Node] -> Node
forall a. [a] -> a
head [Node]
sndResponse
  Content Posn
m <- XmppMonad m (Either XmppError (Content Posn))
-> ExceptT
     XmppError (XmppMonad m) (Either XmppError (Content Posn))
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift XmppMonad m (Either XmppError (Content Posn))
forall (m :: * -> *).
MonadIO m =>
XmppMonad m (Either XmppError (Content Posn))
nextM ExceptT XmppError (XmppMonad m) (Either XmppError (Content Posn))
-> (Either XmppError (Content Posn)
    -> ExceptT XmppError (XmppMonad m) (Content Posn))
-> ExceptT XmppError (XmppMonad m) (Content Posn)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (XmppError -> ExceptT XmppError (XmppMonad m) (Content Posn))
-> (Content Posn -> ExceptT XmppError (XmppMonad m) (Content Posn))
-> Either XmppError (Content Posn)
-> ExceptT XmppError (XmppMonad m) (Content Posn)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either XmppError -> ExceptT XmppError (XmppMonad m) (Content Posn)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError Content Posn -> ExceptT XmppError (XmppMonad m) (Content Posn)
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  Bool
-> ExceptT XmppError (XmppMonad m) ()
-> ExceptT XmppError (XmppMonad m) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [Content Posn] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Content Posn] -> Bool) -> [Content Posn] -> Bool
forall a b. (a -> b) -> a -> b
$ String -> CFilter Posn
forall i. String -> CFilter i
tag String
"success" Content Posn
m) (ExceptT XmppError (XmppMonad m) ()
 -> ExceptT XmppError (XmppMonad m) ())
-> ExceptT XmppError (XmppMonad m) ()
-> ExceptT XmppError (XmppMonad m) ()
forall a b. (a -> b) -> a -> b
$ XmppError -> ExceptT XmppError (XmppMonad m) ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (XmppError -> ExceptT XmppError (XmppMonad m) ())
-> XmppError -> ExceptT XmppError (XmppMonad m) ()
forall a b. (a -> b) -> a -> b
$ Text -> XmppError
AuthError (Text -> XmppError) -> Text -> XmppError
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Content Posn -> String
forall a. Show a => a -> String
show Content Posn
m

  where
      auth :: [Node]
auth = [xml|<auth xmlns="urn:ietf:params:xml:ns:xmpp-sasl" mechanism="DIGEST-MD5">|]
      response :: Text -> [Node]
response Text
resp = [xml|
        <response xmlns="urn:ietf:params:xml:ns:xmpp-sasl">
          #{resp}
        |]
      sndResponse :: [Node]
sndResponse = [xml|<response xmlns="urn:ietf:params:xml:ns:xmpp-sasl">|]
      getChallenge :: Content i -> Either XmppError Text
getChallenge Content i
c =
          case (String -> CFilter i
forall i. String -> CFilter i
tag String
"challenge" CFilter i -> CFilter i -> CFilter i
forall i. CFilter i -> CFilter i -> CFilter i
/> CFilter i
forall i. CFilter i
txt) Content i
c of
              [] -> XmppError -> Either XmppError Text
forall a b. a -> Either a b
Left (XmppError -> Either XmppError Text)
-> XmppError -> Either XmppError Text
forall a b. (a -> b) -> a -> b
$ Text -> XmppError
AuthError Text
"Where is challenge?"
              [Content i]
x  -> Text -> Either XmppError Text
forall a b. b -> Either a b
Right (Text -> Either XmppError Text) -> Text -> Either XmppError Text
forall a b. (a -> b) -> a -> b
$ [Content i] -> Text
forall i. [Content i] -> Text
getText_ [Content i]
x

saslDigestResponse :: T.Text -> T.Text -> T.Text -> T.Text -> IO String
saslDigestResponse :: Text -> Text -> Text -> Text -> IO String
saslDigestResponse Text
chl Text
username Text
server Text
password =
  let pairs :: [(String, String)]
pairs = String -> [(String, String)]
getPairs (String -> [(String, String)]) -> String -> [(String, String)]
forall a b. (a -> b) -> a -> b
$ String -> String
B64.decode (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
chl
      Just String
qop = String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"qop" [(String, String)]
pairs
      Just String
nonce = String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"nonce" [(String, String)]
pairs
      nc :: String
nc = String
"00000001"
      digest_uri :: String
digest_uri = String
"xmpp/" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack Text
server
      realm :: Text
realm = Text
server 
      in do String
cnonce <- IO String
make_cnonce
            let a1 :: String
a1 = [String] -> String
semi_sep [ Str -> String
md5raw (String -> Str
MD5.Str ([String] -> String
semi_sep ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (Text -> String) -> [Text] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Text -> String
T.unpack [Text
username, Text
realm, Text
password])), String
nonce, String
cnonce]
                a2 :: String
a2 = String
"AUTHENTICATE:" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
digest_uri
                t :: String
t  = [String] -> String
semi_sep [ Str -> String
forall a. MD5 a => a -> String
MD5.md5s (String -> Str
MD5.Str String
a1), String
nonce, String
nc, String
cnonce, String
qop, Str -> String
forall a. MD5 a => a -> String
MD5.md5s (String -> Str
MD5.Str String
a2) ]
                response :: String
response = Str -> String
forall a. MD5 a => a -> String
MD5.md5s (String -> Str
MD5.Str String
t)
                resp :: String
resp = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ String
"username=", Text -> String
forall a. Show a => a -> String
show Text
username
                              , String
",realm=", Text -> String
forall a. Show a => a -> String
show Text
realm
                              , String
",nonce=", String -> String
forall a. Show a => a -> String
show String
nonce
                              , String
",cnonce=", String -> String
forall a. Show a => a -> String
show String
cnonce
                              , String
",nc=", String
nc
                              , String
",qop=", String
qop
                              , String
",digest-uri=", String -> String
forall a. Show a => a -> String
show String
digest_uri
                              , String
",response=", String
response
                              ]
            String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ String -> String
B64.encode String
resp
  where
  md5raw :: Str -> String
md5raw   = (String -> Char) -> [String] -> String
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Char
chr (Int -> Char) -> (String -> Int) -> String -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Int
forall a. Read a => String -> a
read (String -> Int) -> (String -> String) -> String -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"0x"String -> String -> String
forall a. [a] -> [a] -> [a]
++ ) (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String -> String
forall a. Int -> [a] -> [a]
take Int
2) ([String] -> String) -> (Str -> [String]) -> Str -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Bool -> Bool
not(Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) ([String] -> [String]) -> (Str -> [String]) -> Str -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String) -> String -> [String]
forall a. (a -> a) -> a -> [a]
iterate (Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
2) (String -> [String]) -> (Str -> String) -> Str -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Str -> String
forall a. MD5 a => a -> String
MD5.md5s
  hexa :: String -> String
hexa     = (Char -> String -> String) -> String -> String -> String
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Int -> String -> String
forall a. (Integral a, Show a) => a -> String -> String
showHex (Int -> String -> String)
-> (Char -> Int) -> Char -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
ord) String
""
  semi_sep :: [String] -> String
semi_sep = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
":"
  make_cnonce :: IO String
make_cnonce = do StdGen
g <- IO StdGen
newStdGen
                   String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ String -> String
hexa (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ (Int -> Char) -> [Int] -> String
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Char
chr(Int -> Char) -> (Int -> Int) -> Int -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
256)) ([Int] -> String) -> [Int] -> String
forall a b. (a -> b) -> a -> b
$ Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
take Int
8 ([Int] -> [Int]) -> [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ StdGen -> [Int]
forall a g. (Random a, RandomGen g) => g -> [a]
randoms StdGen
g

-- | Split aaa=bbb,foo="bar" into [("aaa","bbb"),("foo","bar")]
getPairs :: String -> [(String, String)]
getPairs :: String -> [(String, String)]
getPairs String
str = 
  let chunks :: [String]
chunks = (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
',')) ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Bool -> Bool
not(Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ (String -> String) -> String -> [String]
forall a. (a -> a) -> a -> [a]
iterate (Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
1 (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
',')) String
str
      ([String]
keys, [String]
values) = [(String, String)] -> ([String], [String])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(String, String)] -> ([String], [String]))
-> [(String, String)] -> ([String], [String])
forall a b. (a -> b) -> a -> b
$ (String -> (String, String)) -> [String] -> [(String, String)]
forall a b. (a -> b) -> [a] -> [b]
map ((Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'=')) [String]
chunks
      in [String] -> [String] -> [(String, String)]
forall a b. [a] -> [b] -> [(a, b)]
zip [String]
keys ([String] -> [(String, String)]) -> [String] -> [(String, String)]
forall a b. (a -> b) -> a -> b
$ (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String
trim [String]
values
  where
  -- | Trim leading '=' and surrounding quotes (if any) from value
  trim :: String -> String
trim String
str = case (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'=') String
str of
                  x :: String
x@(Char
'\"':String
_) -> String -> String
forall a. Read a => String -> a
read String
x
                  String
x          -> String
x

saslDigestRspAuth :: MonadIO m => T.Text -> XmppMonad m (Either XmppError ())
saslDigestRspAuth :: Text -> XmppMonad m (Either XmppError ())
saslDigestRspAuth Text
chl =
  let pairs :: [(String, String)]
pairs = String -> [(String, String)]
getPairs (String -> [(String, String)]) -> String -> [(String, String)]
forall a b. (a -> b) -> a -> b
$ String -> String
B64.decode (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
chl
  in  case String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"rspauth" [(String, String)]
pairs of
        Just String
_  -> Either XmppError () -> XmppMonad m (Either XmppError ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either XmppError () -> XmppMonad m (Either XmppError ()))
-> Either XmppError () -> XmppMonad m (Either XmppError ())
forall a b. (a -> b) -> a -> b
$ () -> Either XmppError ()
forall a b. b -> Either a b
Right ()
        Maybe String
Nothing -> Either XmppError () -> XmppMonad m (Either XmppError ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either XmppError () -> XmppMonad m (Either XmppError ()))
-> Either XmppError () -> XmppMonad m (Either XmppError ())
forall a b. (a -> b) -> a -> b
$ XmppError -> Either XmppError ()
forall a b. a -> Either a b
Left (XmppError -> Either XmppError ())
-> XmppError -> Either XmppError ()
forall a b. (a -> b) -> a -> b
$ Text -> XmppError
AuthError Text
"No rspauth in SASL digest rspauth!"