{-# 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
(Algorithm -> Algorithm -> Bool)
-> (Algorithm -> Algorithm -> Bool) -> Eq Algorithm
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Algorithm -> Algorithm -> Bool
== :: Algorithm -> Algorithm -> Bool
$c/= :: Algorithm -> Algorithm -> Bool
/= :: 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
(Qop -> Qop -> Bool) -> (Qop -> Qop -> Bool) -> Eq Qop
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Qop -> Qop -> Bool
== :: Qop -> Qop -> Bool
$c/= :: Qop -> Qop -> Bool
/= :: Qop -> Qop -> Bool
Eq,Int -> Qop -> ShowS
[Qop] -> ShowS
Qop -> String
(Int -> Qop -> ShowS)
-> (Qop -> String) -> ([Qop] -> ShowS) -> Show Qop
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Qop -> ShowS
showsPrec :: Int -> Qop -> ShowS
$cshow :: Qop -> String
show :: Qop -> String
$cshowList :: [Qop] -> ShowS
showList :: [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 " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
base64encode (Authority -> String
auUsername Authority
a String -> ShowS
forall a. [a] -> [a] -> [a]
++ Char
':' Char -> ShowS
forall a. a -> [a] -> [a]
: Authority -> String
auPassword Authority
a)
AuthDigest{} ->
String
"Digest " String -> ShowS
forall a. [a] -> [a] -> [a]
++
[String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ String
"username=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
quo (Authority -> String
auUsername Authority
a)
, String
",realm=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
quo (Authority -> String
auRealm Authority
a)
, String
",nonce=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
quo (Authority -> String
auNonce Authority
a)
, String
",uri=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
quo String
digesturi
, String
",response=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
quo String
rspdigest
, String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" ((Algorithm -> String) -> Maybe Algorithm -> Maybe String
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\ Algorithm
alg -> String
",algorithm=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
quo (Algorithm -> String
forall a. Show a => a -> String
show Algorithm
alg)) (Authority -> Maybe Algorithm
auAlgorithm Authority
a))
, String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" (ShowS -> Maybe String -> Maybe String
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\ String
o -> String
",opaque=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
quo String
o) (Authority -> Maybe String
auOpaque Authority
a))
, if [Qop] -> Bool
forall a. [a] -> Bool
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
'"'Char -> ShowS
forall a. a -> [a] -> [a]
:String
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\""
rspdigest :: String
rspdigest = (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower (String -> ShowS
kd (ShowS
md5 String
a1) (String
noncevalue String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
":" String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
md5 String
a2))
a1, a2 :: String
a1 :: String
a1 = Authority -> String
auUsername Authority
a String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
":" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Authority -> String
auRealm Authority
a String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
":" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Authority -> String
auPassword Authority
a
a2 :: String
a2 = RequestMethod -> String
forall a. Show a => a -> String
show (Request ty -> RequestMethod
forall a. Request a -> RequestMethod
rqMethod Request ty
rq) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
":" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
digesturi
digesturi :: String
digesturi = URI -> String
forall a. Show a => a -> String
show (Request ty -> URI
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 = (Char -> Octet) -> String -> [Octet]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Octet
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Octet) -> (Char -> Int) -> Char -> Octet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
forall a. Enum a => a -> Int
fromEnum)
base64encode :: String -> String
base64encode :: ShowS
base64encode = [Octet] -> String
Base64.encode ([Octet] -> String) -> (String -> [Octet]) -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [Octet]
stringToOctets
md5 :: String -> String
md5 :: ShowS
md5 = Str -> String
forall a. MD5 a => a -> String
MD5.md5s (Str -> String) -> (String -> Str) -> ShowS
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 String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
":" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
b)
headerToChallenge :: URI -> Header -> Maybe Challenge
URI
baseURI (Header HeaderName
_ String
str) =
case Parsec String () (String, [(String, String)])
-> String
-> String
-> Either ParseError (String, [(String, String)])
forall s t a.
Stream s Identity t =>
Parsec s () a -> String -> s -> Either ParseError a
parse Parsec String () (String, [(String, String)])
challenge String
"" String
str of
Left{} -> Maybe Challenge
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
_ -> Maybe Challenge
forall a. Maybe a
Nothing
where
challenge :: Parser (String,[(String,String)])
challenge :: Parsec String () (String, [(String, String)])
challenge =
do { nme <- Parser String
word
; spaces
; pps <- cprops
; return (map toLower nme,pps)
}
cprops :: ParsecT String () Identity [(String, String)]
cprops = ParsecT String () Identity (String, String)
-> ParsecT String () Identity ()
-> ParsecT String () Identity [(String, String)]
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 ParsecT String () Identity ()
forall {u}. ParsecT String u Identity ()
comma
comma :: ParsecT String u Identity ()
comma = do { ParsecT String u Identity ()
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces ; _ <- Char -> ParsecT String u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
',' ; spaces }
cprop :: ParsecT String () Identity (String, String)
cprop =
do { nm <- Parser String
word
; _ <- char '='
; val <- quotedstring
; return (map toLower nm,val)
}
mkBasic, mkDigest :: [(String,String)] -> Maybe Challenge
mkBasic :: [(String, String)] -> Maybe Challenge
mkBasic [(String, String)]
params = (String -> Challenge) -> Maybe String -> Maybe Challenge
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Challenge
ChalBasic (String -> [(String, String)] -> Maybe String
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 { r <- String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"realm" [(String, String)]
params
; n <- lookup "nonce" params
; return $
ChalDigest { chRealm = r
, chDomain = (annotateURIs
$ map parseURI
$ words
$ fromMaybe []
$ lookup "domain" params)
, chNonce = n
, chOpaque = lookup "opaque" params
, chStale = "true" == (map toLower
$ fromMaybe "" (lookup "stale" params))
, chAlgorithm= readAlgorithm (fromMaybe "MD5" $ lookup "algorithm" params)
, chQop = readQop (fromMaybe "" $ lookup "qop" params)
}
}
annotateURIs :: [Maybe URI] -> [URI]
#if MIN_VERSION_network(2,4,0)
annotateURIs :: [Maybe URI] -> [URI]
annotateURIs = (URI -> URI) -> [URI] -> [URI]
forall a b. (a -> b) -> [a] -> [b]
map (URI -> URI -> URI
`relativeTo` URI
baseURI) ([URI] -> [URI]) -> ([Maybe URI] -> [URI]) -> [Maybe URI] -> [URI]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe URI] -> [URI]
forall a. [Maybe a] -> [a]
catMaybes
#else
annotateURIs = (map (\u -> fromMaybe u (u `relativeTo` baseURI))) . catMaybes
#endif
readQop :: String -> [Qop]
readQop :: String -> [Qop]
readQop = [Maybe Qop] -> [Qop]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe Qop] -> [Qop])
-> (String -> [Maybe Qop]) -> String -> [Qop]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String -> Maybe Qop) -> [String] -> [Maybe Qop]
forall a b. (a -> b) -> [a] -> [b]
map String -> Maybe Qop
strToQop) ([String] -> [Maybe Qop])
-> (String -> [String]) -> String -> [Maybe Qop]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> String -> [String]
forall a. Eq a => a -> [a] -> [[a]]
splitBy Char
',')
strToQop :: String -> Maybe Qop
strToQop String
qs = case (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower (ShowS
trim String
qs) of
String
"auth" -> Qop -> Maybe Qop
forall a. a -> Maybe a
Just Qop
QopAuth
String
"auth-int" -> Qop -> Maybe Qop
forall a. a -> Maybe a
Just Qop
QopAuthInt
String
_ -> Maybe Qop
forall a. Maybe a
Nothing
readAlgorithm :: String -> Maybe Algorithm
readAlgorithm String
astr = case (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower (ShowS
trim String
astr) of
String
"md5" -> Algorithm -> Maybe Algorithm
forall a. a -> Maybe a
Just Algorithm
AlgMD5
String
"md5-sess" -> Algorithm -> Maybe Algorithm
forall a. a -> Maybe a
Just Algorithm
AlgMD5sess
String
_ -> Maybe Algorithm
forall a. Maybe a
Nothing
word, quotedstring :: Parser String
quotedstring :: Parser String
quotedstring =
do { _ <- Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'"'
; str <- many (satisfy $ not . (=='"'))
; _ <- char '"'
; return str
}
word :: Parser String
word = ParsecT String () Identity Char -> Parser String
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many1 ((Char -> Bool) -> ParsecT String () Identity Char
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
xChar -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'_' Bool -> Bool -> Bool
|| Char
xChar -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'.' Bool -> Bool -> Bool
|| Char
xChar -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'-' Bool -> Bool -> Bool
|| Char
xChar -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
':'))