    {-# 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
    $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 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 " 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 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

            {-
            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 { 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 =
                -- with Maybe monad
                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

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