{-# 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'.
-- 
-----------------------------------------------------------------------------
module Network.HTTP.Auth
       ( Authority(..)
       , Algorithm(..)
       , Challenge(..)
       , Qop(..)

       , headerToChallenge -- :: URI -> Header -> Maybe Challenge
       , withAuthority     -- :: Authority -> Request ty -> String
       ) 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 )

-- | @Authority@ specifies the HTTP Authentication method to use for
-- a given domain/realm; @Basic@ or @Digest@.
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]
              }

-- | @Algorithm@ controls the digest algorithm to, @MD5@ or @MD5Session@.
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
/= :: 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
(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 String
withAuthority :: Authority -> Request ty -> String
withAuthority :: 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
                       -- plus optional stuff:
                    , String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" ((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
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 (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) 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
        
        {-
        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

type Octet = Word8

-- FIXME: these probably only work right for latin-1 strings
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 base www_auth@ tries to convert the @WWW-Authenticate@ header 
-- @www_auth@  into a 'Challenge' value.
headerToChallenge :: URI -> Header -> Maybe Challenge
headerToChallenge :: URI -> Header -> Maybe Challenge
headerToChallenge 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 { 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]
map Char -> Char
toLower String
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]
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
_ <- Char -> ParsecT String u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
',' ; 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
char Char
'='
               ; 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]
map Char -> Char
toLower String
nm,String
val)
               }

        mkBasic, mkDigest :: [(String,String)] -> Maybe Challenge

        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
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 =
            -- with Maybe monad
            do { String
r <- String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"realm" [(String, String)]
params
               ; String
n <- String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"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]
map String -> 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
lookup String
"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
lookup String
"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]
map Char -> Char
toLower
                                           ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" (String -> [(String, String)] -> Maybe 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 (String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"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
lookup String
"algorithm" [(String, String)]
params)
                               , chQop :: [Qop]
chQop    = String -> [Qop]
readQop (String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" (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
lookup String
"qop" [(String, String)]
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

        -- 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]
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
_ <- Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'"'  -- "
       ; 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
char Char
'"'
       ; String -> Parser String
forall (m :: * -> *) a. Monad m => a -> m a
return String
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
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
':'))