module Network.XMPP.SASL (replyToChallenge1) where
import Data.ByteString.Internal (c2w)
import Data.Char (isLatin1)
import Data.Digest.Pure.MD5
import qualified Data.Binary as DBi (Binary, encode)
import qualified Data.ByteString.Lazy as DBL (ByteString, append, pack,
fromChunks, toChunks, null)
import qualified Data.ByteString.Lazy.Char8 as DBLC (append, pack, unpack)
import qualified Data.List as DL
data Challenge1Error = C1MultipleCriticalAttributes |
C1NotAllParametersPresent |
C1SomeParamtersPresentMoreThanOnce |
C1WrongRealm |
C1UnsupportedAlgorithm |
C1UnsupportedCharset |
C1UnsupportedQOP
deriving Show
stringToList :: String -> [(String, String)]
stringToList "" = []
stringToList s' = let (next, rest) = break' s' ','
in break' next '=' : stringToList rest
where
break' :: String -> Char -> (String, String)
break' s' c = let (first, second) = break ((==) c) s'
in (first, removeCharIfPresent second c)
removeCharIfPresent :: String -> Char -> String
removeCharIfPresent [] _ = []
removeCharIfPresent (c:t) c' | c == c' = t
removeCharIfPresent s' c = s'
countDirectives :: String -> [(String, String)] -> Int
countDirectives v l = DL.length $ filter (isEntry v) l
where
isEntry :: String -> (String, String) -> Bool
isEntry name (name', _) | name == name' = True
| otherwise = False
lookupDirective :: String -> [(String, String)] -> Maybe String
lookupDirective d [] = Nothing
lookupDirective d ((d', v):t) | d == d' = Just v
| otherwise = lookupDirective d t
lookupDirectiveWithDefault :: String -> [(String, String)] -> String -> String
lookupDirectiveWithDefault di l de
| lookup == Nothing = de
| otherwise = let Just r = lookup in r
where
lookup = lookupDirective di l
replyToChallenge1 :: String -> String -> String -> String -> String ->
Either String Challenge1Error
replyToChallenge1 s h u p c =
let list = stringToList $ filter (/= '\n') s
in
case countDirectives "nonce" list <= 1 &&
countDirectives "algorithm" list <= 1 of
True ->
let
nonce = lookupDirective "nonce" list
qop = lookupDirectiveWithDefault "qop" list "auth"
charset = lookupDirectiveWithDefault "charset" list "utf-8"
algorithm = lookupDirective "algorithm" list
in case (nonce, qop, charset, algorithm) of
(Just nonce', qop', charset', Just algorithm') ->
let
nonce'' = stripQuotations nonce'
qop'' = stripQuotations qop'
in
case qop'' == "auth" of
True ->
case charset' == "utf-8" of
True ->
case algorithm' == "md5-sess" of
True ->
Left (reply nonce'' qop'')
False -> Right C1UnsupportedAlgorithm
False -> Right C1UnsupportedCharset
False -> Right C1UnsupportedQOP
_ -> Right C1NotAllParametersPresent
where
reply n q =
let
username = case all isLatin1 u of
True -> DBL.pack $ map c2w u
False -> DBLC.pack $ u
password = case all isLatin1 p of
True -> DBL.pack $ map c2w p
False -> DBLC.pack p
nc = "00000001"
digestUri = "xmpp/" ++ h
a1a = DBi.encode $ md5 $ DBLC.append
(DBLC.append username (DBLC.pack (":" ++ h ++ ":")))
password
a1aDebug = "DBi.encode $ md5 $ " ++ (DBLC.unpack $ DBLC.append
(DBLC.append username (DBLC.pack (":" ++ h ++ ":")))
password)
a1b = DBLC.pack (":" ++ n ++ ":" ++ c)
a1 = DBLC.append a1a a1b
a2 = DBLC.pack ("AUTHENTICATE:" ++ digestUri)
k = DBLC.pack (show $ md5 a1)
colon = DBLC.pack ":"
s0 = DBLC.pack (n ++ ":" ++ nc ++ ":" ++ c ++ ":" ++
q ++ ":")
s1 = DBLC.pack $ show $ md5 a2
s_ = DBLC.append s0 s1
kd = md5 (DBLC.append k (DBLC.append colon s_))
lol0 = DBLC.unpack s_
lol1 = show kd
response = show kd
in "username=\"" ++ u ++ "\",realm=\"" ++ h ++ "\",nonce=\"" ++ n ++
"\",cnonce=\"" ++ c ++ "\",nc=" ++ nc ++ ",digest-uri=\"" ++
digestUri ++ "\",qop=auth,response=" ++ response ++ ",charset=utf-8"
stripQuotations :: String -> String
stripQuotations "" = ""
stripQuotations s | (head s == '"') && (last s == '"') = tail $ init s
| otherwise = s