{- |
Module:        Network.Monad.HTTP.Header
Copyright:     (c) 2009 Henning Thielemann
License:       BSD

Stability:     experimental
Portability:   non-portable (not tested)

Provide the functionality of "Network.HTTP.Headers"
with qualified identifier style.
-}
module Network.Monad.HTTP.Header (
         Hdrs.HasHeaders(..),
   T,    Hdrs.Header(..),     cons,
   Name, Hdrs.HeaderName(..), consName,
   getName, getValue,
   setMany, getMany, modifyMany,
   insert, insertMany,
   insertIfMissing,
   retrieveMany,
   replace,
   find, findMany, lookup,
   parse,
   parseManyWarn,
   parseManyStraight,
   dictionary,
   matchName,
   ) where

import qualified Network.HTTP.Headers as Hdrs
import Network.HTTP.Headers (HasHeaders(..), )
import Data.String.HT (trim, )

import qualified Control.Monad.Exception.Synchronous as Sync

import qualified Data.Map as Map

import Data.Char (toLower, )
import Data.Tuple.HT (mapFst, )
import Data.Maybe.HT (toMaybe, )
import Data.Maybe (mapMaybe, listToMaybe, )

import Prelude hiding (lookup, )


type T    = Hdrs.Header
type Name = Hdrs.HeaderName


{-
class IsHeader h where
   toHeader   :: h -> Hdrs.Header
   fromHeader :: Hdrs.Header -> h

instance IsHeader Hdrs.Header where
   toHeader   = id
   fromHeader = id

instance IsHeader h => HasHeaders [h] where
   setHeaders _ = map fromHeader
   getHeaders   = map toHeader
-}


cons :: Name -> String -> T
cons = Hdrs.Header

-- an Accessor would be even nicer
getName :: T -> Name
getName (Hdrs.Header name _value) = name

getValue :: T -> String
getValue (Hdrs.Header _name value) = value


dictionary :: Map.Map String Name
dictionary =
   Map.fromList $
   map (mapFst (map toLower)) $
   ("Cache-Control"        , Hdrs.HdrCacheControl      ) :
   ("Connection"           , Hdrs.HdrConnection        ) :
   ("Date"                 , Hdrs.HdrDate              ) :
   ("Pragma"               , Hdrs.HdrPragma            ) :
   ("Transfer-Encoding"    , Hdrs.HdrTransferEncoding  ) :
   ("Upgrade"              , Hdrs.HdrUpgrade           ) :
   ("Via"                  , Hdrs.HdrVia               ) :
   ("Accept"               , Hdrs.HdrAccept            ) :
   ("Accept-Charset"       , Hdrs.HdrAcceptCharset     ) :
   ("Accept-Encoding"      , Hdrs.HdrAcceptEncoding    ) :
   ("Accept-Language"      , Hdrs.HdrAcceptLanguage    ) :
   ("Authorization"        , Hdrs.HdrAuthorization     ) :
   ("From"                 , Hdrs.HdrFrom              ) :
   ("Host"                 , Hdrs.HdrHost              ) :
   ("If-Modified-Since"    , Hdrs.HdrIfModifiedSince   ) :
   ("If-Match"             , Hdrs.HdrIfMatch           ) :
   ("If-None-Match"        , Hdrs.HdrIfNoneMatch       ) :
   ("If-Range"             , Hdrs.HdrIfRange           ) :
   ("If-Unmodified-Since"  , Hdrs.HdrIfUnmodifiedSince ) :
   ("Max-Forwards"         , Hdrs.HdrMaxForwards       ) :
   ("Proxy-Authorization"  , Hdrs.HdrProxyAuthorization) :
   ("Range"                , Hdrs.HdrRange             ) :
   ("Referer"              , Hdrs.HdrReferer           ) :
   ("User-Agent"           , Hdrs.HdrUserAgent         ) :
   ("Age"                  , Hdrs.HdrAge               ) :
   ("Location"             , Hdrs.HdrLocation          ) :
   ("Proxy-Authenticate"   , Hdrs.HdrProxyAuthenticate ) :
   ("Public"               , Hdrs.HdrPublic            ) :
   ("Retry-After"          , Hdrs.HdrRetryAfter        ) :
   ("Server"               , Hdrs.HdrServer            ) :
   ("Vary"                 , Hdrs.HdrVary              ) :
   ("Warning"              , Hdrs.HdrWarning           ) :
   ("WWW-Authenticate"     , Hdrs.HdrWWWAuthenticate   ) :
   ("Allow"                , Hdrs.HdrAllow             ) :
   ("Content-Base"         , Hdrs.HdrContentBase       ) :
   ("Content-Encoding"     , Hdrs.HdrContentEncoding   ) :
   ("Content-Language"     , Hdrs.HdrContentLanguage   ) :
   ("Content-Length"       , Hdrs.HdrContentLength     ) :
   ("Content-Location"     , Hdrs.HdrContentLocation   ) :
   ("Content-MD5"          , Hdrs.HdrContentMD5        ) :
   ("Content-Range"        , Hdrs.HdrContentRange      ) :
   ("Content-Type"         , Hdrs.HdrContentType       ) :
   ("ETag"                 , Hdrs.HdrETag              ) :
   ("Expires"              , Hdrs.HdrExpires           ) :
   ("Last-Modified"        , Hdrs.HdrLastModified      ) :
   ("Set-Cookie"           , Hdrs.HdrSetCookie         ) :
   ("Cookie"               , Hdrs.HdrCookie            ) :
   ("Expect"               , Hdrs.HdrExpect            ) :
   []



setMany :: (HasHeaders x) => x -> [T] -> x
setMany = Hdrs.setHeaders

getMany :: (HasHeaders x) => x -> [T]
getMany = Hdrs.getHeaders

modifyMany :: (HasHeaders x) => ([T] -> [T]) -> x -> x
modifyMany f x =
   setMany x $ f $ getMany x


consName :: String -> Name
consName k =
   Map.findWithDefault (Hdrs.HdrCustom k) (map toLower k) dictionary


-- Header manipulation functions
insert, replace, insertIfMissing :: HasHeaders a =>
   Name -> String -> a -> a


-- | Inserts a header with the given name and value.
-- Allows duplicate header names.
insert name value = modifyMany (cons name value :)

-- | Adds the new header only if no previous header shares
-- the same name.
insertIfMissing name value =
   let newHeaders list@(h : rest) =
          if matchName name h
            then list
            else h : newHeaders rest
       newHeaders [] = [cons name value]
   in  modifyMany newHeaders

-- | Removes old headers with duplicate name.
replace name value =
    modifyMany $
        (cons name value :) .
        filter (not . matchName name)

-- | Inserts multiple headers.
insertMany :: HasHeaders a => [T] -> a -> a
insertMany hdrs = modifyMany (++ hdrs)

-- | Gets a list of headers with a particular 'Name'.
retrieveMany :: HasHeaders a => Name -> a -> [T]
retrieveMany name = filter (matchName name) . getMany

matchName :: Name -> T -> Bool
matchName name h  =  name == getName h


-- | Lookup presence of specific Name in a list of Headers
-- Returns the value from the first matching header.
find :: HasHeaders a => Name -> a -> Maybe String
find n = listToMaybe . findMany n

findMany :: HasHeaders a => Name -> a -> [String]
findMany n =
   mapMaybe (\h -> toMaybe (matchName n h) (getValue h)) .
   getMany

{-# DEPRECATED lookup "Call 'find' using the [Header] instance of HasHeaders" #-}
lookup :: Name -> [T] -> Maybe String
lookup n =
   listToMaybe .
   mapMaybe (\h -> toMaybe (matchName n h) (getValue h))


parse :: String -> Sync.Exceptional String T
parse str =
   case break (':'==) str of
      (k,':':v) -> Sync.Success $ cons (consName k) (trim v)
      _ -> Sync.Exception $ "Unable to parse header: " ++ str


parseManyWarn :: [String] -> [Sync.Exceptional String T]
parseManyWarn =
   let clean = map (\h -> if h `elem` "\t\r\n" then ' ' else h)
   in  map (parse . clean) . joinExtended

parseManyStraight :: [String] -> [T]
parseManyStraight =
   {- mapM (strict on errors) vs. catMaybes (tolerant of errors)?
      Should parse errors here be reported or ignored?
      Currently ignored. -}
   mapMaybe (either (const Nothing) Just . Sync.toEither) .
   parseManyWarn

-- | Joins consecutive lines where the second line
-- begins with ' ' or '\t'.
joinExtended :: [String] -> [String]
joinExtended =
   foldr
      (\h0 next ->
         uncurry (:) $
         mapFst (h0++) $
         let join line rest = (' ' : line, rest)
         in  case next of
                ((' ' :line):rest) -> join line rest
                (('\t':line):rest) -> join line rest
                _ -> ("", next))
      []