{-# 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 AlgMD5 = "md5"
    show AlgMD5sess = "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 a :: Authority
a rq :: Request ty
rq = case Authority
a of
        AuthBasic{}  -> "Basic " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
base64encode (Authority -> String
auUsername Authority
a String -> ShowS
forall a. [a] -> [a] -> [a]
++ ':' Char -> ShowS
forall a. a -> [a] -> [a]
: Authority -> String
auPassword Authority
a)
        AuthDigest{} ->
            "Digest " String -> ShowS
forall a. [a] -> [a] -> [a]
++
             [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ "username="  String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
quo (Authority -> String
auUsername Authority
a)
                    , ",realm="    String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
quo (Authority -> String
auRealm Authority
a)
                    , ",nonce="    String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
quo (Authority -> String
auNonce Authority
a)
                    , ",uri="      String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
quo String
digesturi
                    , ",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 "" ((Algorithm -> String) -> Maybe Algorithm -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\ alg :: Algorithm
alg -> ",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 "" (ShowS -> Maybe String -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\ o :: String
o   -> ",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 "" else ",qop=auth"
                    ]
    where
        quo :: ShowS
quo s :: String
s = '"'Char -> ShowS
forall a. a -> [a] -> [a]
:String
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ "\""

        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 -> 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 -> ShowS
forall a. [a] -> [a] -> [a]
++ Authority -> String
auRealm Authority
a String -> ShowS
forall a. [a] -> [a] -> [a]
++ ":" 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 -> 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 a :: String
a b :: String
b = ShowS
md5 (String
a String -> ShowS
forall a. [a] -> [a] -> [a]
++ ":" 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 baseURI :: URI
baseURI (Header _ str :: 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
str of
        Left{} -> Maybe Challenge
forall a. Maybe a
Nothing
        Right (name :: String
name,props :: [(String, String)]
props) -> case String
name of
            "basic"  -> [(String, String)] -> Maybe Challenge
mkBasic [(String, String)]
props
            "digest" -> [(String, String)] -> Maybe Challenge
mkDigest [(String, String)]
props
            _        -> 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 ',' ; 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 '='
               ; 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 params :: [(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 "realm" [(String, String)]
params)

        mkDigest :: [(String, String)] -> Maybe Challenge
mkDigest params :: [(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 "realm" [(String, String)]
params
               ; String
n <- String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup "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 "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 "opaque" [(String, String)]
params
                               , chStale :: Bool
chStale  = "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)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup "stale" [(String, String)]
params))
                               , chAlgorithm :: Maybe Algorithm
chAlgorithm= String -> Maybe Algorithm
readAlgorithm (String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe "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 "algorithm" [(String, String)]
params)
                               , chQop :: [Qop]
chQop    = String -> [Qop]
readQop (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 "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 ',')

        strToQop :: String -> Maybe Qop
strToQop qs :: String
qs = case (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower (ShowS
trim String
qs) of
            "auth"     -> Qop -> Maybe Qop
forall a. a -> Maybe a
Just Qop
QopAuth
            "auth-int" -> Qop -> Maybe Qop
forall a. a -> Maybe a
Just Qop
QopAuthInt
            _          -> Maybe Qop
forall a. Maybe a
Nothing

        readAlgorithm :: String -> Maybe Algorithm
readAlgorithm astr :: String
astr = case (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower (ShowS
trim String
astr) of
            "md5"      -> Algorithm -> Maybe Algorithm
forall a. a -> Maybe a
Just Algorithm
AlgMD5
            "md5-sess" -> Algorithm -> Maybe Algorithm
forall a. a -> Maybe a
Just Algorithm
AlgMD5sess
            _          -> 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 '"'  -- "
       ; 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 -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m 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 (\x :: Char
x -> Char -> Bool
isAlphaNum Char
x Bool -> Bool -> Bool
|| Char
xChar -> Char -> Bool
forall a. Eq a => a -> a -> Bool
=='_' Bool -> Bool -> Bool
|| Char
xChar -> Char -> Bool
forall a. Eq a => a -> a -> Bool
=='.' Bool -> Bool -> Bool
|| Char
xChar -> Char -> Bool
forall a. Eq a => a -> a -> Bool
=='-' Bool -> Bool -> Bool
|| Char
xChar -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==':'))