module Network.Sasl.DigestMd5.Client (sasl) where
import "monads-tf" Control.Monad.State
import "monads-tf" Control.Monad.Error
import Data.Pipe
import Network.Sasl
import Network.Sasl.DigestMd5.DigestMd5
import Network.Sasl.DigestMd5.Papillon
import qualified Data.ByteString as BS
sasl :: (
MonadState m, SaslState (StateType m),
MonadError m, Error (ErrorType m) ) => (
BS.ByteString,
(Bool, Pipe (Either Success BS.ByteString) BS.ByteString m ()) )
sasl = ("DIGEST-MD5", client digestMd5Cl)
digestMd5Cl :: (
MonadState m, SaslState (StateType m),
MonadError m, Error (ErrorType m) ) => Client m
digestMd5Cl = Client Nothing (zip svs cls) (Just . const $ return ())
cls :: (MonadState m, SaslState (StateType m)) => [Send m]
cls = [mkResponse]
svs :: (MonadState m, SaslState (StateType m)) => [Receive m]
svs = [putReceive]
mkResponse :: (MonadState m, SaslState (StateType m)) => Send m
mkResponse = do
st <- gets getSaslState
let Just ps = lookup "password" st
Just rlm = lookup "realm" st
Just n = lookup "nonce" st
Just q = lookup "qop" st
Just c = lookup "charset" st
Just un = lookup "username" st
Just uri = lookup "uri" st
Just cn = lookup "cnonce" st
Just nc = lookup "nc" st
modify . putSaslState $ [
("username", un),
("digest-uri", uri),
("nc", nc),
("cnonce", cn) ] ++ st
return . fromDigestResponse $ DR {
drUserName = un,
drRealm = rlm,
drPassword = ps,
drCnonce = cn,
drNonce = n,
drNc = nc,
drQop = q,
drDigestUri = uri,
drCharset = c }
putReceive :: (MonadState m, SaslState (StateType m)) => Receive m
putReceive bs = do
let Just ch = parseAtts bs
st <- gets getSaslState
let Just rlm = lookup "realm" ch
Just n = lookup "nonce" ch
Just q = lookup "qop" ch
Just c = lookup "charset" ch
Just a = lookup "algorithm" ch
modify . putSaslState $ [
("realm", rlm),
("nonce", n),
("qop", q),
("charset", c),
("algorithm", a) ] ++ st