{-# LANGUAGE CPP #-}------------------------------------------------------------------------------- |-- Module : Network.HTTP.Auth-- Copyright : See LICENSE file-- License : BSD---- Maintainer : Ganesh Sittampalam <ganesh@earth.li>-- Stability : experimental-- Portability : non-portable (not tested)---- Representing HTTP Auth values in Haskell.-- Right now, it contains mostly functionality needed by 'Network.Browser'.-------------------------------------------------------------------------------moduleNetwork.HTTP.Auth(Authority (..),Algorithm (..),Challenge (..),Qop (..),headerToChallenge -- :: URI -> Header -> Maybe Challenge,withAuthority -- :: Authority -> Request ty -> String)whereimportNetwork.URIimportNetwork.HTTP.Base importNetwork.HTTP.Utils importNetwork.HTTP.Headers (Header (..))importqualifiedNetwork.HTTP.MD5Aux asMD5(md5s ,Str (Str ))importqualifiedNetwork.HTTP.Base64 asBase64(encode )importText.ParserCombinators.Parsec(Parser,char,many,many1,satisfy,parse,spaces,sepBy1)importData.CharimportData.MaybeimportData.Word(Word8)-- | @Authority@ specifies the HTTP Authentication method to use for-- a given domain/realm; @Basic@ or @Digest@.dataAuthority =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 ::MaybeAlgorithm ,Authority -> [URI]
auDomain ::[URI],Authority -> Maybe String
auOpaque ::MaybeString,Authority -> [Qop]
auQop ::[Qop ]}dataChallenge =ChalBasic {Challenge -> String
chRealm ::String}|ChalDigest {chRealm ::String,Challenge -> [URI]
chDomain ::[URI],Challenge -> String
chNonce ::String,Challenge -> Maybe String
chOpaque ::MaybeString,Challenge -> Bool
chStale ::Bool,Challenge -> Maybe Algorithm
chAlgorithm ::MaybeAlgorithm ,Challenge -> [Qop]
chQop ::[Qop ]}-- | @Algorithm@ controls the digest algorithm to, @MD5@ or @MD5Session@.dataAlgorithm =AlgMD5 |AlgMD5sess deriving(Algorithm -> Algorithm -> Bool
(Algorithm -> Algorithm -> Bool)
-> (Algorithm -> Algorithm -> Bool) -> Eq Algorithm
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)instanceShowAlgorithm whereshow :: Algorithm -> String
showAlgorithm
AlgMD5 =String
"md5"showAlgorithm
AlgMD5sess =String
"md5-sess"-- |dataQop =QopAuth |QopAuthInt deriving(Qop -> Qop -> Bool
(Qop -> Qop -> Bool) -> (Qop -> Qop -> Bool) -> Eq Qop
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
(Int -> Qop -> ShowS)
-> (Qop -> String) -> ([Qop] -> ShowS) -> Show Qop
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 auth req@ generates a credentials value from the @auth@ 'Authority',-- in the context of the given request.---- If a client nonce was to be used then this function might need to be of type ... -> BrowserAction StringwithAuthority ::Authority ->Request ty ->StringwithAuthority :: Authority -> Request ty -> String
withAuthority Authority
a Request ty
rq =caseAuthority
a ofAuthBasic {}->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 -- plus optional stuff:,String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybeString
""((Algorithm -> String) -> Maybe Algorithm -> Maybe String
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
showAlgorithm
alg ))(Authority -> Maybe Algorithm
auAlgorithm Authority
a )),String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybeString
""(ShowS -> Maybe String -> Maybe String
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 (t :: * -> *) a. Foldable t => t a -> Bool
null(Authority -> [Qop]
auQop Authority
a )thenString
""elseString
",qop=auth"]wherequo :: 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]
mapChar -> 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 ::Stringa1 :: 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 {-
 If the "qop" directive's value is "auth" or is unspecified, then A2
 is:
 A2 = Method ":" digest-uri-value
 If the "qop" value is "auth-int", then A2 is:
 A2 = Method ":" digest-uri-value ":" H(entity-body)
 -}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 typeOctet =Word8-- FIXME: these probably only work right for latin-1 stringsstringToOctets ::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->Stringbase64encode :: 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->Stringmd5 :: 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->Stringkd :: 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 base www_auth@ tries to convert the @WWW-Authenticate@ header-- @www_auth@ into a 'Challenge' value.headerToChallenge ::URI->Header ->MaybeChallenge headerToChallenge :: URI -> Header -> Maybe Challenge
headerToChallenge URI
baseURI (Header HeaderName
_String
str )=caseParsec 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
parseParsec String () (String, [(String, String)])
challenge String
""String
str ofLeft{}->Maybe Challenge
forall a. Maybe a
NothingRight(String
name ,[(String, String)]
props )->caseString
name ofString
"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
Nothingwherechallenge ::Parser(String,[(String,String)])challenge :: Parsec String () (String, [(String, String)])
challenge =do{String
nme <-Parser String
word ;ParsecT String () Identity ()
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces;[(String, String)]
pps <-ParsecT String () Identity [(String, String)]
cprops ;(String, [(String, String)])
-> Parsec String () (String, [(String, String)])
forall (m :: * -> *) a. Monad m => a -> m a
return((Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
mapChar -> Char
toLowerString
nme ,[(String, String)]
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]
sepBy1ParsecT 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
_<-Char -> ParsecT String u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
charChar
',';ParsecT String u Identity ()
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
_<-Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
charChar
'=';String
val <-Parser String
quotedstring ;(String, String) -> ParsecT String () Identity (String, String)
forall (m :: * -> *) a. Monad m => a -> m a
return((Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
mapChar -> Char
toLowerString
nm ,String
val )}mkBasic ,mkDigest ::[(String,String)]->MaybeChallenge mkBasic :: [(String, String)] -> Maybe Challenge
mkBasic [(String, String)]
params =(String -> Challenge) -> Maybe String -> Maybe Challenge
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmapString -> Challenge
ChalBasic (String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookupString
"realm"[(String, String)]
params )mkDigest :: [(String, String)] -> Maybe Challenge
mkDigest [(String, String)]
params =-- with Maybe monaddo{String
r <-String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookupString
"realm"[(String, String)]
params ;String
n <-String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookupString
"nonce"[(String, String)]
params ;Challenge -> Maybe Challenge
forall (m :: * -> *) a. Monad m => a -> m a
return(Challenge -> Maybe Challenge) -> Challenge -> Maybe Challenge
forall a b. (a -> b) -> a -> b
$ChalDigest :: String
-> [URI]
-> String
-> Maybe String
-> Bool
-> Maybe Algorithm
-> [Qop]
-> Challenge
ChalDigest {chRealm :: String
chRealm =String
r ,chDomain :: [URI]
chDomain =([Maybe URI] -> [URI]
annotateURIs ([Maybe URI] -> [URI]) -> [Maybe URI] -> [URI]
forall a b. (a -> b) -> a -> b
$(String -> Maybe URI) -> [String] -> [Maybe URI]
forall a b. (a -> b) -> [a] -> [b]
mapString -> Maybe URI
parseURI([String] -> [Maybe URI]) -> [String] -> [Maybe URI]
forall a b. (a -> b) -> a -> b
$String -> [String]
words(String -> [String]) -> String -> [String]
forall a b. (a -> b) -> a -> b
$String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe[](Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookupString
"domain"[(String, String)]
params ),chNonce :: String
chNonce =String
n ,chOpaque :: Maybe String
chOpaque =String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookupString
"opaque"[(String, String)]
params ,chStale :: Bool
chStale =String
"true"String -> String -> Bool
forall a. Eq a => a -> a -> Bool
==((Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
mapChar -> Char
toLowerShowS -> ShowS
forall a b. (a -> b) -> a -> b
$String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybeString
""(String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookupString
"stale"[(String, String)]
params )),chAlgorithm :: Maybe Algorithm
chAlgorithm =String -> Maybe Algorithm
readAlgorithm (String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybeString
"MD5"(Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookupString
"algorithm"[(String, String)]
params ),chQop :: [Qop]
chQop =String -> [Qop]
readQop (String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybeString
""(Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookupString
"qop"[(String, String)]
params )}}annotateURIs ::[MaybeURI]->[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->fromMaybeu(u`relativeTo`baseURI))).catMaybes
#endif
-- Change These: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]
mapString -> 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]
mapChar -> Char
toLower(ShowS
trim String
qs )ofString
"auth"->Qop -> Maybe Qop
forall a. a -> Maybe a
JustQop
QopAuth String
"auth-int"->Qop -> Maybe Qop
forall a. a -> Maybe a
JustQop
QopAuthInt String
_->Maybe Qop
forall a. Maybe a
NothingreadAlgorithm :: String -> Maybe Algorithm
readAlgorithm String
astr =case(Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
mapChar -> Char
toLower(ShowS
trim String
astr )ofString
"md5"->Algorithm -> Maybe Algorithm
forall a. a -> Maybe a
JustAlgorithm
AlgMD5 String
"md5-sess"->Algorithm -> Maybe Algorithm
forall a. a -> Maybe a
JustAlgorithm
AlgMD5sess String
_->Maybe Algorithm
forall a. Maybe a
Nothingword ,quotedstring ::ParserStringquotedstring :: Parser String
quotedstring =do{Char
_<-Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
charChar
'"'-- ";String
str <-ParsecT String () Identity Char -> Parser String
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many((Char -> Bool) -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
(Char -> Bool) -> ParsecT s u m Char
satisfy((Char -> Bool) -> ParsecT String () Identity Char)
-> (Char -> Bool) -> ParsecT String () Identity Char
forall a b. (a -> b) -> a -> b
$Bool -> Bool
not(Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'"'));Char
_<-Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
charChar
'"';String -> Parser String
forall (m :: * -> *) a. Monad m => a -> m a
returnString
str }word :: Parser String
word =ParsecT String () Identity Char -> Parser String
forall s (m :: * -> *) t u a.
Stream s m t =>
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
isAlphaNumChar
x Bool -> Bool -> Bool
||Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'_'Bool -> Bool -> Bool
||Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'.'Bool -> Bool -> Bool
||Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'-'Bool -> Bool -> Bool
||Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
':'))