{-# 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
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 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 :: 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
                       -- plus optional stuff:
                    , 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

        {-
        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 = 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

-- FIXME: these probably only work right for latin-1 strings
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 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 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 =
            -- with Maybe monad
            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

        -- Change These:
        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
':'))