    {-# LANGUAGE CPP #-}
    -----------------------------------------------------------------------------
    -- |
    -- Module      :  Network.HTTP.Auth
    -- Copyright   :  See LICENSE file
    -- License     :  BSD
    --
    -- Maintainer  :  Ganesh Sittampalam <http@projects.haskell.org>
    -- 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 { auRealm    :: String
                 , auUsername :: String
                 , auPassword :: String
                 , auSite     :: URI
                 }
     | AuthDigest{ auRealm     :: String
                 , auUsername  :: String
                 , auPassword  :: String
                 , auNonce     :: String
                 , auAlgorithm :: Maybe Algorithm
                 , auDomain    :: [URI]
                 , auOpaque    :: Maybe String
                 , auQop       :: [Qop]
                 }

    data Challenge
     = ChalBasic  { chRealm   :: String }
     | ChalDigest { chRealm   :: String
                  , chDomain  :: [URI]
                  , chNonce   :: String
                  , chOpaque  :: Maybe String
                  , chStale   :: Bool
                  , chAlgorithm ::Maybe Algorithm
                  , chQop     :: [Qop]
                  }

    -- | @Algorithm@ controls the digest algorithm to, @MD5@ or @MD5Session@.
    data Algorithm = AlgMD5 | AlgMD5sess
        deriving(Eq)

    instance Show Algorithm where
        show AlgMD5 = "md5"
        show AlgMD5sess = "md5-sess"

    -- |
    data Qop = QopAuth | QopAuthInt
        deriving(Eq,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 a rq = case a of
            AuthBasic{}  -> "Basic " ++ base64encode (auUsername a ++ ':' : auPassword a)
            AuthDigest{} ->
                "Digest " ++
    	     concat [ "username="  ++ quo (auUsername a)
    	            , ",realm="    ++ quo (auRealm a)
    		    , ",nonce="    ++ quo (auNonce a)
    		    , ",uri="      ++ quo digesturi
    		    , ",response=" ++ quo rspdigest
                           -- plus optional stuff:
    		    , fromMaybe "" (fmap (\ alg -> ",algorithm=" ++ quo (show alg)) (auAlgorithm a))
    		    , fromMaybe "" (fmap (\ o   -> ",opaque=" ++ quo o) (auOpaque a))
    		    , if null (auQop a) then "" else ",qop=auth"
    		    ]
        where
            quo s = '"':s ++ "\""

            rspdigest = map toLower (kd (md5 a1) (noncevalue ++ ":" ++ md5 a2))

            a1, a2 :: String
            a1 = auUsername a ++ ":" ++ auRealm a ++ ":" ++ auPassword 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 = show (rqMethod rq) ++ ":" ++ digesturi

            digesturi = show (rqURI rq)
            noncevalue = auNonce a

    type Octet = Word8

    -- FIXME: these probably only work right for latin-1 strings
    stringToOctets :: String -> [Octet]
    stringToOctets = map (fromIntegral . fromEnum)

    base64encode :: String -> String
    base64encode = Base64.encode . stringToOctets

    md5 :: String -> String
    md5 = MD5.md5s . MD5.Str

    kd :: String -> String -> String
    kd a b = md5 (a ++ ":" ++ b)

    -- | @headerToChallenge base www_auth@ tries to convert the @WWW-Authenticate@ header
    -- @www_auth@  into a 'Challenge' value.
    headerToChallenge :: URI -> Header -> Maybe Challenge
    headerToChallenge baseURI (Header _ str) =
        case parse challenge "" str of
            Left{} -> Nothing
            Right (name,props) -> case name of
                "basic"  -> mkBasic props
                "digest" -> mkDigest props
                _        -> Nothing
        where
            challenge :: Parser (String,[(String,String)])
            challenge =
                do { nme <- word
                   ; spaces
                   ; pps <- cprops
                   ; return (map toLower nme,pps)
                   }

            cprops = sepBy1 cprop comma

            comma = do { spaces ; _ <- char ',' ; spaces }

            cprop =
                do { nm <- word
                   ; _ <- char '='
                   ; val <- quotedstring
                   ; return (map toLower nm,val)
                   }

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

            mkBasic params = fmap ChalBasic (lookup "realm" params)

            mkDigest params =
                -- with Maybe monad
                do { r <- lookup "realm" 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 = map (`relativeTo` baseURI) . catMaybes
    #else
            annotateURIs = (map (\u -> fromMaybe u (u `relativeTo` baseURI))) . catMaybes
    #endif

            -- Change These:
            readQop :: String -> [Qop]
            readQop = catMaybes . (map strToQop) . (splitBy ',')

            strToQop qs = case map toLower (trim qs) of
                "auth"     -> Just QopAuth
                "auth-int" -> Just QopAuthInt
                _          -> Nothing

            readAlgorithm astr = case map toLower (trim astr) of
                "md5"      -> Just AlgMD5
                "md5-sess" -> Just AlgMD5sess
                _          -> Nothing

    word, quotedstring :: Parser String
    quotedstring =
        do { _ <- char '"'  -- "
           ; str <- many (satisfy $ not . (=='"'))
           ; _ <- char '"'
           ; return str
           }

    word = many1 (satisfy (\x -> isAlphaNum x || x=='_' || x=='.' || x=='-' || x==':'))