{-# LANGUAGE CPP #-}
module Network.HTTP.Auth
( Authority(..)
, Algorithm(..)
, Challenge(..)
, Qop(..)
, headerToChallenge
, withAuthority
) where
import Network.URI
import Network.HTTP.Base
import Network.HTTP.Utils
import Network.HTTP.Headers ( Header(..) )
import qualified Network.HTTP.MD5Aux as MD5 (md5s, Str(Str))
import qualified Network.HTTP.Base64 as Base64 (encode)
import Text.ParserCombinators.Parsec
( Parser, char, many, many1, satisfy, parse, spaces, sepBy1 )
import Data.Char
import Data.Maybe
import Data.Word ( Word8 )
data Authority
= AuthBasic { Authority -> String
auRealm :: String
, Authority -> String
auUsername :: String
, Authority -> String
auPassword :: String
, Authority -> URI
auSite :: URI
}
| AuthDigest{ auRealm :: String
, auUsername :: String
, auPassword :: String
, Authority -> String
auNonce :: String
, Authority -> Maybe Algorithm
auAlgorithm :: Maybe Algorithm
, Authority -> [URI]
auDomain :: [URI]
, Authority -> Maybe String
auOpaque :: Maybe String
, Authority -> [Qop]
auQop :: [Qop]
}
data Challenge
= ChalBasic { Challenge -> String
chRealm :: String }
| ChalDigest { chRealm :: String
, Challenge -> [URI]
chDomain :: [URI]
, Challenge -> String
chNonce :: String
, Challenge -> Maybe String
chOpaque :: Maybe String
, Challenge -> Bool
chStale :: Bool
, Challenge -> Maybe Algorithm
chAlgorithm ::Maybe Algorithm
, Challenge -> [Qop]
chQop :: [Qop]
}
data Algorithm = AlgMD5 | AlgMD5sess
deriving(Algorithm -> Algorithm -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Algorithm -> Algorithm -> Bool
$c/= :: Algorithm -> Algorithm -> Bool
== :: Algorithm -> Algorithm -> Bool
$c== :: Algorithm -> Algorithm -> Bool
Eq)
instance Show Algorithm where
show :: Algorithm -> String
show Algorithm
AlgMD5 = String
"md5"
show Algorithm
AlgMD5sess = String
"md5-sess"
data Qop = QopAuth | QopAuthInt
deriving(Qop -> Qop -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Qop -> Qop -> Bool
$c/= :: Qop -> Qop -> Bool
== :: Qop -> Qop -> Bool
$c== :: Qop -> Qop -> Bool
Eq,Int -> Qop -> ShowS
[Qop] -> ShowS
Qop -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Qop] -> ShowS
$cshowList :: [Qop] -> ShowS
show :: Qop -> String
$cshow :: Qop -> String
showsPrec :: Int -> Qop -> ShowS
$cshowsPrec :: Int -> Qop -> ShowS
Show)
withAuthority :: Authority -> Request ty -> String
withAuthority :: forall ty. Authority -> Request ty -> String
withAuthority Authority
a Request ty
rq = case Authority
a of
AuthBasic{} -> String
"Basic " forall a. [a] -> [a] -> [a]
++ ShowS
base64encode (Authority -> String
auUsername Authority
a forall a. [a] -> [a] -> [a]
++ Char
':' forall a. a -> [a] -> [a]
: Authority -> String
auPassword Authority
a)
AuthDigest{} ->
String
"Digest " forall a. [a] -> [a] -> [a]
++
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ String
"username=" forall a. [a] -> [a] -> [a]
++ ShowS
quo (Authority -> String
auUsername Authority
a)
, String
",realm=" forall a. [a] -> [a] -> [a]
++ ShowS
quo (Authority -> String
auRealm Authority
a)
, String
",nonce=" forall a. [a] -> [a] -> [a]
++ ShowS
quo (Authority -> String
auNonce Authority
a)
, String
",uri=" forall a. [a] -> [a] -> [a]
++ ShowS
quo String
digesturi
, String
",response=" forall a. [a] -> [a] -> [a]
++ ShowS
quo String
rspdigest
, forall a. a -> Maybe a -> a
fromMaybe String
"" (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\ Algorithm
alg -> String
",algorithm=" forall a. [a] -> [a] -> [a]
++ ShowS
quo (forall a. Show a => a -> String
show Algorithm
alg)) (Authority -> Maybe Algorithm
auAlgorithm Authority
a))
, forall a. a -> Maybe a -> a
fromMaybe String
"" (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\ String
o -> String
",opaque=" forall a. [a] -> [a] -> [a]
++ ShowS
quo String
o) (Authority -> Maybe String
auOpaque Authority
a))
, if forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Authority -> [Qop]
auQop Authority
a) then String
"" else String
",qop=auth"
]
where
quo :: ShowS
quo String
s = Char
'"'forall a. a -> [a] -> [a]
:String
s forall a. [a] -> [a] -> [a]
++ String
"\""
rspdigest :: String
rspdigest = forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower (String -> ShowS
kd (ShowS
md5 String
a1) (String
noncevalue forall a. [a] -> [a] -> [a]
++ String
":" forall a. [a] -> [a] -> [a]
++ ShowS
md5 String
a2))
a1, a2 :: String
a1 :: String
a1 = Authority -> String
auUsername Authority
a forall a. [a] -> [a] -> [a]
++ String
":" forall a. [a] -> [a] -> [a]
++ Authority -> String
auRealm Authority
a forall a. [a] -> [a] -> [a]
++ String
":" forall a. [a] -> [a] -> [a]
++ Authority -> String
auPassword Authority
a
a2 :: String
a2 = forall a. Show a => a -> String
show (forall a. Request a -> RequestMethod
rqMethod Request ty
rq) forall a. [a] -> [a] -> [a]
++ String
":" forall a. [a] -> [a] -> [a]
++ String
digesturi
digesturi :: String
digesturi = forall a. Show a => a -> String
show (forall a. Request a -> URI
rqURI Request ty
rq)
noncevalue :: String
noncevalue = Authority -> String
auNonce Authority
a
type Octet = Word8
stringToOctets :: String -> [Octet]
stringToOctets :: String -> [Octet]
stringToOctets = forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Enum a => a -> Int
fromEnum)
base64encode :: String -> String
base64encode :: ShowS
base64encode = [Octet] -> String
Base64.encode forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [Octet]
stringToOctets
md5 :: String -> String
md5 :: ShowS
md5 = forall a. MD5 a => a -> String
MD5.md5s forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Str
MD5.Str
kd :: String -> String -> String
kd :: String -> ShowS
kd String
a String
b = ShowS
md5 (String
a forall a. [a] -> [a] -> [a]
++ String
":" forall a. [a] -> [a] -> [a]
++ String
b)
headerToChallenge :: URI -> Header -> Maybe Challenge
URI
baseURI (Header HeaderName
_ String
str) =
case forall s t a.
Stream s Identity t =>
Parsec s () a -> String -> s -> Either ParseError a
parse Parser (String, [(String, String)])
challenge String
"" String
str of
Left{} -> forall a. Maybe a
Nothing
Right (String
name,[(String, String)]
props) -> case String
name of
String
"basic" -> [(String, String)] -> Maybe Challenge
mkBasic [(String, String)]
props
String
"digest" -> [(String, String)] -> Maybe Challenge
mkDigest [(String, String)]
props
String
_ -> forall a. Maybe a
Nothing
where
challenge :: Parser (String,[(String,String)])
challenge :: Parser (String, [(String, String)])
challenge =
do { String
nme <- Parser String
word
; forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces
; [(String, String)]
pps <- ParsecT String () Identity [(String, String)]
cprops
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
nme,[(String, String)]
pps)
}
cprops :: ParsecT String () Identity [(String, String)]
cprops = forall s (m :: * -> *) t u a sep.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m sep -> ParsecT s u m [a]
sepBy1 ParsecT String () Identity (String, String)
cprop forall {u}. ParsecT String u Identity ()
comma
comma :: ParsecT String u Identity ()
comma = do { forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces ; Char
_ <- forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
',' ; forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces }
cprop :: ParsecT String () Identity (String, String)
cprop =
do { String
nm <- Parser String
word
; Char
_ <- forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'='
; String
val <- Parser String
quotedstring
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
nm,String
val)
}
mkBasic, mkDigest :: [(String,String)] -> Maybe Challenge
mkBasic :: [(String, String)] -> Maybe Challenge
mkBasic [(String, String)]
params = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Challenge
ChalBasic (forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"realm" [(String, String)]
params)
mkDigest :: [(String, String)] -> Maybe Challenge
mkDigest [(String, String)]
params =
do { String
r <- forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"realm" [(String, String)]
params
; String
n <- forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"nonce" [(String, String)]
params
; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
ChalDigest { chRealm :: String
chRealm = String
r
, chDomain :: [URI]
chDomain = ([Maybe URI] -> [URI]
annotateURIs
forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map String -> Maybe URI
parseURI
forall a b. (a -> b) -> a -> b
$ String -> [String]
words
forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe []
forall a b. (a -> b) -> a -> b
$ forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"domain" [(String, String)]
params)
, chNonce :: String
chNonce = String
n
, chOpaque :: Maybe String
chOpaque = forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"opaque" [(String, String)]
params
, chStale :: Bool
chStale = String
"true" forall a. Eq a => a -> a -> Bool
== (forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower
forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe String
"" (forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"stale" [(String, String)]
params))
, chAlgorithm :: Maybe Algorithm
chAlgorithm= String -> Maybe Algorithm
readAlgorithm (forall a. a -> Maybe a -> a
fromMaybe String
"MD5" forall a b. (a -> b) -> a -> b
$ forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"algorithm" [(String, String)]
params)
, chQop :: [Qop]
chQop = String -> [Qop]
readQop (forall a. a -> Maybe a -> a
fromMaybe String
"" forall a b. (a -> b) -> a -> b
$ forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"qop" [(String, String)]
params)
}
}
annotateURIs :: [Maybe URI] -> [URI]
#if MIN_VERSION_network(2,4,0)
annotateURIs :: [Maybe URI] -> [URI]
annotateURIs = forall a b. (a -> b) -> [a] -> [b]
map (URI -> URI -> URI
`relativeTo` URI
baseURI) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [Maybe a] -> [a]
catMaybes
#else
annotateURIs = (map (\u -> fromMaybe u (u `relativeTo` baseURI))) . catMaybes
#endif
readQop :: String -> [Qop]
readQop :: String -> [Qop]
readQop = forall a. [Maybe a] -> [a]
catMaybes forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a b. (a -> b) -> [a] -> [b]
map String -> Maybe Qop
strToQop) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Eq a => a -> [a] -> [[a]]
splitBy Char
',')
strToQop :: String -> Maybe Qop
strToQop String
qs = case forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower (ShowS
trim String
qs) of
String
"auth" -> forall a. a -> Maybe a
Just Qop
QopAuth
String
"auth-int" -> forall a. a -> Maybe a
Just Qop
QopAuthInt
String
_ -> forall a. Maybe a
Nothing
readAlgorithm :: String -> Maybe Algorithm
readAlgorithm String
astr = case forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower (ShowS
trim String
astr) of
String
"md5" -> forall a. a -> Maybe a
Just Algorithm
AlgMD5
String
"md5-sess" -> forall a. a -> Maybe a
Just Algorithm
AlgMD5sess
String
_ -> forall a. Maybe a
Nothing
word, quotedstring :: Parser String
quotedstring :: Parser String
quotedstring =
do { Char
_ <- forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'"'
; String
str <- forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many (forall s (m :: * -> *) u.
Stream s m Char =>
(Char -> Bool) -> ParsecT s u m Char
satisfy forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Eq a => a -> a -> Bool
==Char
'"'))
; Char
_ <- forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'"'
; forall (m :: * -> *) a. Monad m => a -> m a
return String
str
}
word :: Parser String
word = forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 (forall s (m :: * -> *) u.
Stream s m Char =>
(Char -> Bool) -> ParsecT s u m Char
satisfy (\Char
x -> Char -> Bool
isAlphaNum Char
x Bool -> Bool -> Bool
|| Char
xforall a. Eq a => a -> a -> Bool
==Char
'_' Bool -> Bool -> Bool
|| Char
xforall a. Eq a => a -> a -> Bool
==Char
'.' Bool -> Bool -> Bool
|| Char
xforall a. Eq a => a -> a -> Bool
==Char
'-' Bool -> Bool -> Bool
|| Char
xforall a. Eq a => a -> a -> Bool
==Char
':'))