-- Copyright 2002 Warrick Gray
-- Copyright 2001,2002 Peter Thiemann
-- Copyright 2003-2006 Bjorn Bringert
-- Copyright 2009 Henning Thielemann
module Network.MoHWS.HTTP.Header (
    Group, group, ungroup,
    setGroup,
    getGroup,
    list,
    modifyMany,
    T, Hdrs.Header(..), make,
    getName, getValue, name, value,
    Name, Hdrs.HeaderName(..),
    HasHeaders,
    -- * Header parsing
    pGroup, makeName,
    -- * Header manipulation
    insert,
    insertIfMissing,
    replace, insertMany,
    lookupMany, lookup,
    -- * Constructing headers
    makeContentLength,
    makeContentType,
    makeLocation,
    makeLastModified,
    TransferCoding(..),
    makeTransferCoding,
    -- * Getting values of specific headers
    getContentType,
    getContentLength,
--    getHost,
   ) where

import qualified Network.HTTP.Headers as Hdrs
import Network.HTTP.Headers (HasHeaders, )

import Network.MoHWS.ParserUtility
import Network.MoHWS.Utility

-- import Network.Socket (HostName, )
import Network.URI (URI, )

import Control.Monad (liftM, )
import Data.Char (toLower, )
import Data.Map (Map, )
import qualified Data.Map as Map hiding (Map)
import System.Time (ClockTime, toUTCTime, )
import Text.ParserCombinators.Parsec
          (Parser, char, skipMany, many, )

import qualified Data.Accessor.Basic as Accessor

import Prelude hiding (lookup, )


-- * Header

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


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

getName :: T -> Name
getName :: T -> Name
getName (Hdrs.Header Name
n String
_v) = Name
n

getValue :: T -> String
getValue :: T -> String
getValue (Hdrs.Header Name
_n String
v) = String
v

name :: Accessor.T T Name
name :: T T Name
name =
   (Name -> T -> T) -> (T -> Name) -> T T Name
forall a r. (a -> r -> r) -> (r -> a) -> T r a
Accessor.fromSetGet
      (\Name
n (Hdrs.Header Name
_ String
v) -> Name -> String -> T
Hdrs.Header Name
n String
v)
      T -> Name
getName

value :: Accessor.T T String
value :: T T String
value =
   (String -> T -> T) -> (T -> String) -> T T String
forall a r. (a -> r -> r) -> (r -> a) -> T r a
Accessor.fromSetGet
      (\String
v (Hdrs.Header Name
n String
_) -> Name -> String -> T
Hdrs.Header Name
n String
v)
      T -> String
getValue


-- Translation between header names and values,
nameList :: [ (String, Name) ]
nameList :: [(String, Name)]
nameList =
   (String
"Cache-Control"        , Name
Hdrs.HdrCacheControl      ) (String, Name) -> [(String, Name)] -> [(String, Name)]
forall a. a -> [a] -> [a]
:
   (String
"Connection"           , Name
Hdrs.HdrConnection        ) (String, Name) -> [(String, Name)] -> [(String, Name)]
forall a. a -> [a] -> [a]
:
   (String
"Date"                 , Name
Hdrs.HdrDate              ) (String, Name) -> [(String, Name)] -> [(String, Name)]
forall a. a -> [a] -> [a]
:
   (String
"Pragma"               , Name
Hdrs.HdrPragma            ) (String, Name) -> [(String, Name)] -> [(String, Name)]
forall a. a -> [a] -> [a]
:
--   ("Trailer"              , Hdrs.HdrTrailer           ) :

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

toNameMap :: Map String Name
toNameMap :: Map String Name
toNameMap =
   [(String, Name)] -> Map String Name
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [((Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
x, Name
y) | (String
x,Name
y) <- [(String, Name)]
nameList]

{-
fromHeaderNameMap :: Map Name String
fromHeaderNameMap = Map.fromList [(y,x) | (x,y) <- headerNames]
-}

makeName :: String -> Name
makeName :: String -> Name
makeName String
s =
   Name -> String -> Map String Name -> Name
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault (String -> Name
Hdrs.HdrCustom String
s) ((Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
s) Map String Name
toNameMap


-- * Header group

newtype Group = Group { Group -> [T]
ungroup :: [T] }

group :: [T] -> Group
group :: [T] -> Group
group = [T] -> Group
Group

instance Show Group where
   showsPrec :: Int -> Group -> String -> String
showsPrec Int
_ =
      ((String -> String) -> (String -> String) -> String -> String)
-> (String -> String) -> [String -> String] -> String -> String
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) String -> String
forall a. a -> a
id ([String -> String] -> String -> String)
-> (Group -> [String -> String]) -> Group -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (T -> String -> String) -> [T] -> [String -> String]
forall a b. (a -> b) -> [a] -> [b]
map T -> String -> String
forall a. Show a => a -> String -> String
shows ([T] -> [String -> String])
-> (Group -> [T]) -> Group -> [String -> String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Group -> [T]
ungroup
--      foldr (.) id . map (\x -> shows x . showString crLf) . unGroup

instance HasHeaders Group where
   getHeaders :: Group -> [T]
getHeaders = Group -> [T]
ungroup
   setHeaders :: Group -> [T] -> Group
setHeaders Group
_ = [T] -> Group
group


getGroup :: HasHeaders x => x -> Group
getGroup :: x -> Group
getGroup = [T] -> Group
group ([T] -> Group) -> (x -> [T]) -> x -> Group
forall b c a. (b -> c) -> (a -> b) -> a -> c
. x -> [T]
forall x. HasHeaders x => x -> [T]
Hdrs.getHeaders

setGroup :: HasHeaders x => x -> Group -> x
setGroup :: x -> Group -> x
setGroup x
x = x -> [T] -> x
forall x. HasHeaders x => x -> [T] -> x
Hdrs.setHeaders x
x ([T] -> x) -> (Group -> [T]) -> Group -> x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Group -> [T]
ungroup

list :: HasHeaders x => x -> [T]
list :: x -> [T]
list = x -> [T]
forall x. HasHeaders x => x -> [T]
Hdrs.getHeaders

modifyMany :: HasHeaders x => ([T] -> [T]) -> x -> x
modifyMany :: ([T] -> [T]) -> x -> x
modifyMany [T] -> [T]
f x
x = x -> [T] -> x
forall x. HasHeaders x => x -> [T] -> x
Hdrs.setHeaders x
x ([T] -> x) -> [T] -> x
forall a b. (a -> b) -> a -> b
$ [T] -> [T]
f ([T] -> [T]) -> [T] -> [T]
forall a b. (a -> b) -> a -> b
$ x -> [T]
forall x. HasHeaders x => x -> [T]
Hdrs.getHeaders x
x


-- * Header manipulation functions

-- Header manipulation functions
insert, replace, insertIfMissing :: HasHeaders a =>
   Name -> String -> a -> a
insert :: Name -> String -> a -> a
insert = Name -> String -> a -> a
forall a. HasHeaders a => HeaderSetter a
Hdrs.insertHeader
insertIfMissing :: Name -> String -> a -> a
insertIfMissing = Name -> String -> a -> a
forall a. HasHeaders a => HeaderSetter a
Hdrs.insertHeaderIfMissing
replace :: Name -> String -> a -> a
replace = Name -> String -> a -> a
forall a. HasHeaders a => HeaderSetter a
Hdrs.replaceHeader

insertMany :: HasHeaders a => [T] -> a -> a
insertMany :: [T] -> a -> a
insertMany = [T] -> a -> a
forall a. HasHeaders a => [T] -> a -> a
Hdrs.insertHeaders


lookupMany :: HasHeaders a => Name -> a -> [String]
lookupMany :: Name -> a -> [String]
lookupMany Name
searchName a
x =
   [ String
v | Hdrs.Header Name
n String
v <- a -> [T]
forall x. HasHeaders x => x -> [T]
list a
x, Name
searchName Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
n ]

lookup :: HasHeaders a => Name -> a -> Maybe String
lookup :: Name -> a -> Maybe String
lookup Name
n = Name -> [T] -> Maybe String
Hdrs.lookupHeader Name
n ([T] -> Maybe String) -> (a -> [T]) -> a -> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> [T]
forall x. HasHeaders x => x -> [T]
list
-- lookup n x = listToMaybe $ lookupMany n x


-- * Constructing specific headers

makeContentLength :: Integer -> T
makeContentLength :: Integer -> T
makeContentLength Integer
i = Name -> String -> T
Hdrs.Header Name
Hdrs.HdrContentLength (Integer -> String
forall a. Show a => a -> String
show Integer
i)

makeContentType :: String -> T
makeContentType :: String -> T
makeContentType String
t = Name -> String -> T
Hdrs.Header Name
Hdrs.HdrContentType String
t

makeLocation :: URI -> T
makeLocation :: URI -> T
makeLocation URI
t = Name -> String -> T
Hdrs.Header Name
Hdrs.HdrLocation (String -> T) -> String -> T
forall a b. (a -> b) -> a -> b
$ URI -> String
forall a. Show a => a -> String
show URI
t

makeLastModified :: ClockTime -> T
makeLastModified :: ClockTime -> T
makeLastModified ClockTime
t =
   Name -> String -> T
Hdrs.Header Name
Hdrs.HdrLastModified (CalendarTime -> String
formatTimeSensibly (ClockTime -> CalendarTime
toUTCTime ClockTime
t))

makeTransferCoding :: TransferCoding -> T
makeTransferCoding :: TransferCoding -> T
makeTransferCoding TransferCoding
te = Name -> String -> T
Hdrs.Header Name
Hdrs.HdrTransferEncoding (TransferCoding -> String
transferCodingStr TransferCoding
te)

data TransferCoding
  = ChunkedTransferCoding
  | GzipTransferCoding
  | CompressTransferCoding
  | DeflateTransferCoding
  deriving TransferCoding -> TransferCoding -> Bool
(TransferCoding -> TransferCoding -> Bool)
-> (TransferCoding -> TransferCoding -> Bool) -> Eq TransferCoding
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TransferCoding -> TransferCoding -> Bool
$c/= :: TransferCoding -> TransferCoding -> Bool
== :: TransferCoding -> TransferCoding -> Bool
$c== :: TransferCoding -> TransferCoding -> Bool
Eq

transferCodingStr :: TransferCoding -> String
transferCodingStr :: TransferCoding -> String
transferCodingStr TransferCoding
ChunkedTransferCoding  = String
"chunked"
transferCodingStr TransferCoding
GzipTransferCoding     = String
"gzip"
transferCodingStr TransferCoding
CompressTransferCoding = String
"compress"
transferCodingStr TransferCoding
DeflateTransferCoding  = String
"deflate"

-- validTransferCoding :: [TransferCoding] -> Bool
-- validTransferCoding codings
--   | null codings
--     || last codings == ChunkedTransferCoding
--        && ChunkedTransferCoding `notElem` init codings = True
--   | otherwise = False
;

-- * Values of specific headers

getContentType :: HasHeaders a => a -> Maybe String
getContentType :: a -> Maybe String
getContentType a
x = Name -> a -> Maybe String
forall a. HasHeaders a => Name -> a -> Maybe String
lookup Name
Hdrs.HdrContentType a
x

getContentLength :: HasHeaders a => a -> Maybe Integer
getContentLength :: a -> Maybe Integer
getContentLength a
x = Name -> a -> Maybe String
forall a. HasHeaders a => Name -> a -> Maybe String
lookup Name
Hdrs.HdrContentLength a
x Maybe String -> (String -> Maybe Integer) -> Maybe Integer
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> Maybe Integer
forall a (m :: * -> *). (Read a, MonadFail m) => String -> m a
readM

{-
getHost :: HasHeaders a => a -> Maybe (HostName, Maybe Int)
getHost x = lookup Hdrs.HdrHost x >>= parseHost
-}


-- * Parsing

pGroup :: Parser Group
pGroup :: Parser Group
pGroup = ([T] -> Group) -> ParsecT String () Identity [T] -> Parser Group
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [T] -> Group
group (ParsecT String () Identity [T] -> Parser Group)
-> ParsecT String () Identity [T] -> Parser Group
forall a b. (a -> b) -> a -> b
$ ParsecT String () Identity T -> ParsecT String () Identity [T]
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many ParsecT String () Identity T
pHeader

pHeader :: Parser T
pHeader :: ParsecT String () Identity T
pHeader =
    do String
n <- Parser String
pToken
       Char
_ <- Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
':'
       ParsecT String () Identity Char -> ParsecT String () Identity ()
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m ()
skipMany ParsecT String () Identity Char
pWS1
       String
line <- Parser String
lineString
       String
_ <- Parser String
pCRLF
       [String]
extraLines <- Parser String -> ParsecT String () Identity [String]
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many Parser String
extraFieldLine
       T -> ParsecT String () Identity T
forall (m :: * -> *) a. Monad m => a -> m a
return (T -> ParsecT String () Identity T)
-> T -> ParsecT String () Identity T
forall a b. (a -> b) -> a -> b
$ Name -> String -> T
Hdrs.Header (String -> Name
makeName String
n) ([String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (String
lineString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
extraLines))

extraFieldLine :: Parser String
extraFieldLine :: Parser String
extraFieldLine =
    do Char
sp <- ParsecT String () Identity Char
pWS1
       String
line <- Parser String
lineString
       String
_ <- Parser String
pCRLF
       String -> Parser String
forall (m :: * -> *) a. Monad m => a -> m a
return (Char
spChar -> String -> String
forall a. a -> [a] -> [a]
:String
line)

{-
parseHost :: String -> Maybe (HostName, Maybe Int)
parseHost s =
    let (host,prt) = break (==':') s
    in  case prt of
           ""       -> Just (host, Nothing)
           ':':port -> readM port >>= \p -> Just (host, Just p)
           _        -> Nothing
-}