-----------------------------------------------------------------------------
-- |
-- Module      :  Network.HTTP.Headers
-- Copyright   :  See LICENSE file
-- License     :  BSD
-- 
-- Maintainer  :  Ganesh Sittampalam <ganesh@earth.li>
-- Stability   :  experimental
-- Portability :  non-portable (not tested)
--
-- This module provides the data types for representing HTTP headers, and
-- operations for looking up header values and working with sequences of
-- header values in 'Request's and 'Response's. To avoid having to provide
-- separate set of operations for doing so, we introduce a type class 'HasHeaders'
-- to facilitate writing such processing using overloading instead.
-- 
-----------------------------------------------------------------------------
module Network.HTTP.Headers
   ( HasHeaders(..)     -- type class

   , Header(..)
   , mkHeader           -- :: HeaderName -> String -> Header
   , hdrName            -- :: Header     -> HeaderName
   , hdrValue           -- :: Header     -> String

   , HeaderName(..)

   , insertHeader          -- :: HasHeaders a => HeaderName -> String -> a -> a
   , insertHeaderIfMissing -- :: HasHeaders a => HeaderName -> String -> a -> a
   , insertHeaders         -- :: HasHeaders a => [Header] -> a -> a
   , retrieveHeaders       -- :: HasHeaders a => HeaderName -> a -> [Header]
   , replaceHeader         -- :: HasHeaders a => HeaderName -> String -> a -> a
   , findHeader            -- :: HasHeaders a => HeaderName -> a -> Maybe String
   , lookupHeader          -- :: HeaderName -> [Header] -> Maybe String

   , parseHeader           -- :: parseHeader :: String -> Result Header
   , parseHeaders          -- :: [String] -> Result [Header]
   
   , headerMap             -- :: [(String, HeaderName)]
   
   , HeaderSetter
   ) where

import Data.Char (toLower)
import Network.Stream (Result, failParse)
import Network.HTTP.Utils ( trim, split, crlf )

-- | The @Header@ data type pairs header names & values.
data Header = Header HeaderName String

hdrName :: Header -> HeaderName
hdrName :: Header -> HeaderName
hdrName (Header HeaderName
h String
_) = HeaderName
h

hdrValue :: Header -> String
hdrValue :: Header -> String
hdrValue (Header HeaderName
_ String
v) = String
v

-- | Header constructor as a function, hiding above rep.
mkHeader :: HeaderName -> String -> Header
mkHeader :: HeaderName -> String -> Header
mkHeader = HeaderName -> String -> Header
Header

instance Show Header where
    show :: Header -> String
show (Header HeaderName
key String
value) = HeaderName -> ShowS
forall a. Show a => a -> ShowS
shows HeaderName
key (Char
':'Char -> ShowS
forall a. a -> [a] -> [a]
:Char
' 'Char -> ShowS
forall a. a -> [a] -> [a]
:String
value String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
crlf)

-- | HTTP @HeaderName@ type, a Haskell data constructor for each
-- specification-defined header, prefixed with @Hdr@ and CamelCased,
-- (i.e., eliding the @-@ in the process.) Should you require using
-- a custom header, there's the @HdrCustom@ constructor which takes
-- a @String@ argument.
--
-- Encoding HTTP header names differently, as Strings perhaps, is an
-- equally fine choice..no decidedly clear winner, but let's stick
-- with data constructors here.
-- 
data HeaderName 
    -- Generic Headers --
 = HdrCacheControl
 | HdrConnection
 | HdrDate
 | HdrPragma
 | HdrTransferEncoding        
 | HdrUpgrade                
 | HdrVia
    -- Request Headers --
 | HdrAccept
 | HdrAcceptCharset
 | HdrAcceptEncoding
 | HdrAcceptLanguage
 | HdrAuthorization
 | HdrCookie
 | HdrExpect
 | HdrFrom
 | HdrHost
 | HdrIfModifiedSince
 | HdrIfMatch
 | HdrIfNoneMatch
 | HdrIfRange
 | HdrIfUnmodifiedSince
 | HdrMaxForwards
 | HdrProxyAuthorization
 | HdrRange
 | HdrReferer
 | HdrUserAgent
    -- Response Headers
 | HdrAge
 | HdrLocation
 | HdrProxyAuthenticate
 | HdrPublic
 | HdrRetryAfter
 | HdrServer
 | HdrSetCookie
 | HdrTE
 | HdrTrailer
 | HdrVary
 | HdrWarning
 | HdrWWWAuthenticate
    -- Entity Headers
 | HdrAllow
 | HdrContentBase
 | HdrContentEncoding
 | HdrContentLanguage
 | HdrContentLength
 | HdrContentLocation
 | HdrContentMD5
 | HdrContentRange
 | HdrContentType
 | HdrETag
 | HdrExpires
 | HdrLastModified
    -- | MIME entity headers (for sub-parts)
 | HdrContentTransferEncoding
    -- | Allows for unrecognised or experimental headers.
 | HdrCustom String -- not in header map below.

instance Eq HeaderName where
    HdrCustom String
a                == :: HeaderName -> HeaderName -> Bool
== HdrCustom String
b                = ((Char -> Char) -> ShowS
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Char -> Char
toLower String
a) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== ((Char -> Char) -> ShowS
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Char -> Char
toLower String
b)
    HeaderName
HdrCacheControl            == HeaderName
HdrCacheControl            = Bool
True
    HeaderName
HdrCacheControl            == HeaderName
_                          = Bool
False
    HeaderName
_                          == HeaderName
HdrCacheControl            = Bool
False
    HeaderName
HdrConnection              == HeaderName
HdrConnection              = Bool
True
    HeaderName
HdrConnection              == HeaderName
_                          = Bool
False
    HeaderName
_                          == HeaderName
HdrConnection              = Bool
False
    HeaderName
HdrDate                    == HeaderName
HdrDate                    = Bool
True
    HeaderName
HdrDate                    == HeaderName
_                          = Bool
False
    HeaderName
_                          == HeaderName
HdrDate                    = Bool
False
    HeaderName
HdrPragma                  == HeaderName
HdrPragma                  = Bool
True
    HeaderName
HdrPragma                  == HeaderName
_                          = Bool
False
    HeaderName
_                          == HeaderName
HdrPragma                  = Bool
False
    HeaderName
HdrTransferEncoding        == HeaderName
HdrTransferEncoding        = Bool
True
    HeaderName
HdrTransferEncoding        == HeaderName
_                          = Bool
False
    HeaderName
_                          == HeaderName
HdrTransferEncoding        = Bool
False
    HeaderName
HdrUpgrade                 == HeaderName
HdrUpgrade                 = Bool
True
    HeaderName
HdrUpgrade                 == HeaderName
_                          = Bool
False
    HeaderName
_                          == HeaderName
HdrUpgrade                 = Bool
False
    HeaderName
HdrVia                     == HeaderName
HdrVia                     = Bool
True
    HeaderName
HdrVia                     == HeaderName
_                          = Bool
False
    HeaderName
_                          == HeaderName
HdrVia                     = Bool
False
    HeaderName
HdrAccept                  == HeaderName
HdrAccept                  = Bool
True
    HeaderName
HdrAccept                  == HeaderName
_                          = Bool
False
    HeaderName
_                          == HeaderName
HdrAccept                  = Bool
False
    HeaderName
HdrAcceptCharset           == HeaderName
HdrAcceptCharset           = Bool
True
    HeaderName
HdrAcceptCharset           == HeaderName
_                          = Bool
False
    HeaderName
_                          == HeaderName
HdrAcceptCharset           = Bool
False
    HeaderName
HdrAcceptEncoding          == HeaderName
HdrAcceptEncoding          = Bool
True
    HeaderName
HdrAcceptEncoding          == HeaderName
_                          = Bool
False
    HeaderName
_                          == HeaderName
HdrAcceptEncoding          = Bool
False
    HeaderName
HdrAcceptLanguage          == HeaderName
HdrAcceptLanguage          = Bool
True
    HeaderName
HdrAcceptLanguage          == HeaderName
_                          = Bool
False
    HeaderName
_                          == HeaderName
HdrAcceptLanguage          = Bool
False
    HeaderName
HdrAuthorization           == HeaderName
HdrAuthorization           = Bool
True
    HeaderName
HdrAuthorization           == HeaderName
_                          = Bool
False
    HeaderName
_                          == HeaderName
HdrAuthorization           = Bool
False
    HeaderName
HdrCookie                  == HeaderName
HdrCookie                  = Bool
True
    HeaderName
HdrCookie                  == HeaderName
_                          = Bool
False
    HeaderName
_                          == HeaderName
HdrCookie                  = Bool
False
    HeaderName
HdrExpect                  == HeaderName
HdrExpect                  = Bool
True
    HeaderName
HdrExpect                  == HeaderName
_                          = Bool
False
    HeaderName
_                          == HeaderName
HdrExpect                  = Bool
False
    HeaderName
HdrFrom                    == HeaderName
HdrFrom                    = Bool
True
    HeaderName
HdrFrom                    == HeaderName
_                          = Bool
False
    HeaderName
_                          == HeaderName
HdrFrom                    = Bool
False
    HeaderName
HdrHost                    == HeaderName
HdrHost                    = Bool
True
    HeaderName
HdrHost                    == HeaderName
_                          = Bool
False
    HeaderName
_                          == HeaderName
HdrHost                    = Bool
False
    HeaderName
HdrIfModifiedSince         == HeaderName
HdrIfModifiedSince         = Bool
True
    HeaderName
HdrIfModifiedSince         == HeaderName
_                          = Bool
False
    HeaderName
_                          == HeaderName
HdrIfModifiedSince         = Bool
False
    HeaderName
HdrIfMatch                 == HeaderName
HdrIfMatch                 = Bool
True
    HeaderName
HdrIfMatch                 == HeaderName
_                          = Bool
False
    HeaderName
_                          == HeaderName
HdrIfMatch                 = Bool
False
    HeaderName
HdrIfNoneMatch             == HeaderName
HdrIfNoneMatch             = Bool
True
    HeaderName
HdrIfNoneMatch             == HeaderName
_                          = Bool
False
    HeaderName
_                          == HeaderName
HdrIfNoneMatch             = Bool
False
    HeaderName
HdrIfRange                 == HeaderName
HdrIfRange                 = Bool
True
    HeaderName
HdrIfRange                 == HeaderName
_                          = Bool
False
    HeaderName
_                          == HeaderName
HdrIfRange                 = Bool
False
    HeaderName
HdrIfUnmodifiedSince       == HeaderName
HdrIfUnmodifiedSince       = Bool
True
    HeaderName
HdrIfUnmodifiedSince       == HeaderName
_                          = Bool
False
    HeaderName
_                          == HeaderName
HdrIfUnmodifiedSince       = Bool
False
    HeaderName
HdrMaxForwards             == HeaderName
HdrMaxForwards             = Bool
True
    HeaderName
HdrMaxForwards             == HeaderName
_                          = Bool
False
    HeaderName
_                          == HeaderName
HdrMaxForwards             = Bool
False
    HeaderName
HdrProxyAuthorization      == HeaderName
HdrProxyAuthorization      = Bool
True
    HeaderName
HdrProxyAuthorization      == HeaderName
_                          = Bool
False
    HeaderName
_                          == HeaderName
HdrProxyAuthorization      = Bool
False
    HeaderName
HdrRange                   == HeaderName
HdrRange                   = Bool
True
    HeaderName
HdrRange                   == HeaderName
_                          = Bool
False
    HeaderName
_                          == HeaderName
HdrRange                   = Bool
False
    HeaderName
HdrReferer                 == HeaderName
HdrReferer                 = Bool
True
    HeaderName
HdrReferer                 == HeaderName
_                          = Bool
False
    HeaderName
_                          == HeaderName
HdrReferer                 = Bool
False
    HeaderName
HdrUserAgent               == HeaderName
HdrUserAgent               = Bool
True
    HeaderName
HdrUserAgent               == HeaderName
_                          = Bool
False
    HeaderName
_                          == HeaderName
HdrUserAgent               = Bool
False
    HeaderName
HdrAge                     == HeaderName
HdrAge                     = Bool
True
    HeaderName
HdrAge                     == HeaderName
_                          = Bool
False
    HeaderName
_                          == HeaderName
HdrAge                     = Bool
False
    HeaderName
HdrLocation                == HeaderName
HdrLocation                = Bool
True
    HeaderName
HdrLocation                == HeaderName
_                          = Bool
False
    HeaderName
_                          == HeaderName
HdrLocation                = Bool
False
    HeaderName
HdrProxyAuthenticate       == HeaderName
HdrProxyAuthenticate       = Bool
True
    HeaderName
HdrProxyAuthenticate       == HeaderName
_                          = Bool
False
    HeaderName
_                          == HeaderName
HdrProxyAuthenticate       = Bool
False
    HeaderName
HdrPublic                  == HeaderName
HdrPublic                  = Bool
True
    HeaderName
HdrPublic                  == HeaderName
_                          = Bool
False
    HeaderName
_                          == HeaderName
HdrPublic                  = Bool
False
    HeaderName
HdrRetryAfter              == HeaderName
HdrRetryAfter              = Bool
True
    HeaderName
HdrRetryAfter              == HeaderName
_                          = Bool
False
    HeaderName
_                          == HeaderName
HdrRetryAfter              = Bool
False
    HeaderName
HdrServer                  == HeaderName
HdrServer                  = Bool
True
    HeaderName
HdrServer                  == HeaderName
_                          = Bool
False
    HeaderName
_                          == HeaderName
HdrServer                  = Bool
False
    HeaderName
HdrSetCookie               == HeaderName
HdrSetCookie               = Bool
True
    HeaderName
HdrSetCookie               == HeaderName
_                          = Bool
False
    HeaderName
_                          == HeaderName
HdrSetCookie               = Bool
False
    HeaderName
HdrTE                      == HeaderName
HdrTE                      = Bool
True
    HeaderName
HdrTE                      == HeaderName
_                          = Bool
False
    HeaderName
_                          == HeaderName
HdrTE                      = Bool
False
    HeaderName
HdrTrailer                 == HeaderName
HdrTrailer                 = Bool
True
    HeaderName
HdrTrailer                 == HeaderName
_                          = Bool
False
    HeaderName
_                          == HeaderName
HdrTrailer                 = Bool
False
    HeaderName
HdrVary                    == HeaderName
HdrVary                    = Bool
True
    HeaderName
HdrVary                    == HeaderName
_                          = Bool
False
    HeaderName
_                          == HeaderName
HdrVary                    = Bool
False
    HeaderName
HdrWarning                 == HeaderName
HdrWarning                 = Bool
True
    HeaderName
HdrWarning                 == HeaderName
_                          = Bool
False
    HeaderName
_                          == HeaderName
HdrWarning                 = Bool
False
    HeaderName
HdrWWWAuthenticate         == HeaderName
HdrWWWAuthenticate         = Bool
True
    HeaderName
HdrWWWAuthenticate         == HeaderName
_                          = Bool
False
    HeaderName
_                          == HeaderName
HdrWWWAuthenticate         = Bool
False
    HeaderName
HdrAllow                   == HeaderName
HdrAllow                   = Bool
True
    HeaderName
HdrAllow                   == HeaderName
_                          = Bool
False
    HeaderName
_                          == HeaderName
HdrAllow                   = Bool
False
    HeaderName
HdrContentBase             == HeaderName
HdrContentBase             = Bool
True
    HeaderName
HdrContentBase             == HeaderName
_                          = Bool
False
    HeaderName
_                          == HeaderName
HdrContentBase             = Bool
False
    HeaderName
HdrContentEncoding         == HeaderName
HdrContentEncoding         = Bool
True
    HeaderName
HdrContentEncoding         == HeaderName
_                          = Bool
False
    HeaderName
_                          == HeaderName
HdrContentEncoding         = Bool
False
    HeaderName
HdrContentLanguage         == HeaderName
HdrContentLanguage         = Bool
True
    HeaderName
HdrContentLanguage         == HeaderName
_                          = Bool
False
    HeaderName
_                          == HeaderName
HdrContentLanguage         = Bool
False
    HeaderName
HdrContentLength           == HeaderName
HdrContentLength           = Bool
True
    HeaderName
HdrContentLength           == HeaderName
_                          = Bool
False
    HeaderName
_                          == HeaderName
HdrContentLength           = Bool
False
    HeaderName
HdrContentLocation         == HeaderName
HdrContentLocation         = Bool
True
    HeaderName
HdrContentLocation         == HeaderName
_                          = Bool
False
    HeaderName
_                          == HeaderName
HdrContentLocation         = Bool
False
    HeaderName
HdrContentMD5              == HeaderName
HdrContentMD5              = Bool
True
    HeaderName
HdrContentMD5              == HeaderName
_                          = Bool
False
    HeaderName
_                          == HeaderName
HdrContentMD5              = Bool
False
    HeaderName
HdrContentRange            == HeaderName
HdrContentRange            = Bool
True
    HeaderName
HdrContentRange            == HeaderName
_                          = Bool
False
    HeaderName
_                          == HeaderName
HdrContentRange            = Bool
False
    HeaderName
HdrContentType             == HeaderName
HdrContentType             = Bool
True
    HeaderName
HdrContentType             == HeaderName
_                          = Bool
False
    HeaderName
_                          == HeaderName
HdrContentType             = Bool
False
    HeaderName
HdrETag                    == HeaderName
HdrETag                    = Bool
True
    HeaderName
HdrETag                    == HeaderName
_                          = Bool
False
    HeaderName
_                          == HeaderName
HdrETag                    = Bool
False
    HeaderName
HdrExpires                 == HeaderName
HdrExpires                 = Bool
True
    HeaderName
HdrExpires                 == HeaderName
_                          = Bool
False
    HeaderName
_                          == HeaderName
HdrExpires                 = Bool
False
    HeaderName
HdrLastModified            == HeaderName
HdrLastModified            = Bool
True
    HeaderName
HdrLastModified            == HeaderName
_                          = Bool
False
    HeaderName
_                          == HeaderName
HdrLastModified            = Bool
False
    HeaderName
HdrContentTransferEncoding == HeaderName
HdrContentTransferEncoding = Bool
True
    HeaderName
HdrContentTransferEncoding == HeaderName
_                          = Bool
False
    HeaderName
_                          == HeaderName
HdrContentTransferEncoding = Bool
False

-- | @headerMap@ is a straight assoc list for translating between header names 
-- and values.
headerMap :: [ (String,HeaderName) ]
headerMap :: [(String, HeaderName)]
headerMap =
   [ String -> HeaderName -> (String, HeaderName)
forall a b. a -> b -> (a, b)
p String
"Cache-Control"        HeaderName
HdrCacheControl
   , String -> HeaderName -> (String, HeaderName)
forall a b. a -> b -> (a, b)
p String
"Connection"           HeaderName
HdrConnection
   , String -> HeaderName -> (String, HeaderName)
forall a b. a -> b -> (a, b)
p String
"Date"                 HeaderName
HdrDate
   , String -> HeaderName -> (String, HeaderName)
forall a b. a -> b -> (a, b)
p String
"Pragma"               HeaderName
HdrPragma
   , String -> HeaderName -> (String, HeaderName)
forall a b. a -> b -> (a, b)
p String
"Transfer-Encoding"    HeaderName
HdrTransferEncoding
   , String -> HeaderName -> (String, HeaderName)
forall a b. a -> b -> (a, b)
p String
"Upgrade"              HeaderName
HdrUpgrade
   , String -> HeaderName -> (String, HeaderName)
forall a b. a -> b -> (a, b)
p String
"Via"                  HeaderName
HdrVia
   , String -> HeaderName -> (String, HeaderName)
forall a b. a -> b -> (a, b)
p String
"Accept"               HeaderName
HdrAccept
   , String -> HeaderName -> (String, HeaderName)
forall a b. a -> b -> (a, b)
p String
"Accept-Charset"       HeaderName
HdrAcceptCharset
   , String -> HeaderName -> (String, HeaderName)
forall a b. a -> b -> (a, b)
p String
"Accept-Encoding"      HeaderName
HdrAcceptEncoding
   , String -> HeaderName -> (String, HeaderName)
forall a b. a -> b -> (a, b)
p String
"Accept-Language"      HeaderName
HdrAcceptLanguage
   , String -> HeaderName -> (String, HeaderName)
forall a b. a -> b -> (a, b)
p String
"Authorization"        HeaderName
HdrAuthorization
   , String -> HeaderName -> (String, HeaderName)
forall a b. a -> b -> (a, b)
p String
"Cookie"               HeaderName
HdrCookie
   , String -> HeaderName -> (String, HeaderName)
forall a b. a -> b -> (a, b)
p String
"Expect"               HeaderName
HdrExpect
   , String -> HeaderName -> (String, HeaderName)
forall a b. a -> b -> (a, b)
p String
"From"                 HeaderName
HdrFrom
   , String -> HeaderName -> (String, HeaderName)
forall a b. a -> b -> (a, b)
p String
"Host"                 HeaderName
HdrHost
   , String -> HeaderName -> (String, HeaderName)
forall a b. a -> b -> (a, b)
p String
"If-Modified-Since"    HeaderName
HdrIfModifiedSince
   , String -> HeaderName -> (String, HeaderName)
forall a b. a -> b -> (a, b)
p String
"If-Match"             HeaderName
HdrIfMatch
   , String -> HeaderName -> (String, HeaderName)
forall a b. a -> b -> (a, b)
p String
"If-None-Match"        HeaderName
HdrIfNoneMatch
   , String -> HeaderName -> (String, HeaderName)
forall a b. a -> b -> (a, b)
p String
"If-Range"             HeaderName
HdrIfRange
   , String -> HeaderName -> (String, HeaderName)
forall a b. a -> b -> (a, b)
p String
"If-Unmodified-Since"  HeaderName
HdrIfUnmodifiedSince
   , String -> HeaderName -> (String, HeaderName)
forall a b. a -> b -> (a, b)
p String
"Max-Forwards"         HeaderName
HdrMaxForwards
   , String -> HeaderName -> (String, HeaderName)
forall a b. a -> b -> (a, b)
p String
"Proxy-Authorization"  HeaderName
HdrProxyAuthorization
   , String -> HeaderName -> (String, HeaderName)
forall a b. a -> b -> (a, b)
p String
"Range"                HeaderName
HdrRange
   , String -> HeaderName -> (String, HeaderName)
forall a b. a -> b -> (a, b)
p String
"Referer"              HeaderName
HdrReferer
   , String -> HeaderName -> (String, HeaderName)
forall a b. a -> b -> (a, b)
p String
"User-Agent"           HeaderName
HdrUserAgent
   , String -> HeaderName -> (String, HeaderName)
forall a b. a -> b -> (a, b)
p String
"Age"                  HeaderName
HdrAge
   , String -> HeaderName -> (String, HeaderName)
forall a b. a -> b -> (a, b)
p String
"Location"             HeaderName
HdrLocation
   , String -> HeaderName -> (String, HeaderName)
forall a b. a -> b -> (a, b)
p String
"Proxy-Authenticate"   HeaderName
HdrProxyAuthenticate
   , String -> HeaderName -> (String, HeaderName)
forall a b. a -> b -> (a, b)
p String
"Public"               HeaderName
HdrPublic
   , String -> HeaderName -> (String, HeaderName)
forall a b. a -> b -> (a, b)
p String
"Retry-After"          HeaderName
HdrRetryAfter
   , String -> HeaderName -> (String, HeaderName)
forall a b. a -> b -> (a, b)
p String
"Server"               HeaderName
HdrServer
   , String -> HeaderName -> (String, HeaderName)
forall a b. a -> b -> (a, b)
p String
"Set-Cookie"           HeaderName
HdrSetCookie
   , String -> HeaderName -> (String, HeaderName)
forall a b. a -> b -> (a, b)
p String
"TE"                   HeaderName
HdrTE
   , String -> HeaderName -> (String, HeaderName)
forall a b. a -> b -> (a, b)
p String
"Trailer"              HeaderName
HdrTrailer
   , String -> HeaderName -> (String, HeaderName)
forall a b. a -> b -> (a, b)
p String
"Vary"                 HeaderName
HdrVary
   , String -> HeaderName -> (String, HeaderName)
forall a b. a -> b -> (a, b)
p String
"Warning"              HeaderName
HdrWarning
   , String -> HeaderName -> (String, HeaderName)
forall a b. a -> b -> (a, b)
p String
"WWW-Authenticate"     HeaderName
HdrWWWAuthenticate
   , String -> HeaderName -> (String, HeaderName)
forall a b. a -> b -> (a, b)
p String
"Allow"                HeaderName
HdrAllow
   , String -> HeaderName -> (String, HeaderName)
forall a b. a -> b -> (a, b)
p String
"Content-Base"         HeaderName
HdrContentBase
   , String -> HeaderName -> (String, HeaderName)
forall a b. a -> b -> (a, b)
p String
"Content-Encoding"     HeaderName
HdrContentEncoding
   , String -> HeaderName -> (String, HeaderName)
forall a b. a -> b -> (a, b)
p String
"Content-Language"     HeaderName
HdrContentLanguage
   , String -> HeaderName -> (String, HeaderName)
forall a b. a -> b -> (a, b)
p String
"Content-Length"       HeaderName
HdrContentLength
   , String -> HeaderName -> (String, HeaderName)
forall a b. a -> b -> (a, b)
p String
"Content-Location"     HeaderName
HdrContentLocation
   , String -> HeaderName -> (String, HeaderName)
forall a b. a -> b -> (a, b)
p String
"Content-MD5"          HeaderName
HdrContentMD5
   , String -> HeaderName -> (String, HeaderName)
forall a b. a -> b -> (a, b)
p String
"Content-Range"        HeaderName
HdrContentRange
   , String -> HeaderName -> (String, HeaderName)
forall a b. a -> b -> (a, b)
p String
"Content-Type"         HeaderName
HdrContentType
   , String -> HeaderName -> (String, HeaderName)
forall a b. a -> b -> (a, b)
p String
"ETag"                 HeaderName
HdrETag
   , String -> HeaderName -> (String, HeaderName)
forall a b. a -> b -> (a, b)
p String
"Expires"              HeaderName
HdrExpires
   , String -> HeaderName -> (String, HeaderName)
forall a b. a -> b -> (a, b)
p String
"Last-Modified"        HeaderName
HdrLastModified
   , String -> HeaderName -> (String, HeaderName)
forall a b. a -> b -> (a, b)
p String
"Content-Transfer-Encoding" HeaderName
HdrContentTransferEncoding
   ]
 where
  p :: a -> b -> (a, b)
p a
a b
b = (a
a,b
b)

instance Show HeaderName where
    show :: HeaderName -> String
show (HdrCustom String
s) = String
s
    show HeaderName
x = case ((String, HeaderName) -> Bool)
-> [(String, HeaderName)] -> [(String, HeaderName)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
==HeaderName
x)(HeaderName -> Bool)
-> ((String, HeaderName) -> HeaderName)
-> (String, HeaderName)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(String, HeaderName) -> HeaderName
forall a b. (a, b) -> b
snd) [(String, HeaderName)]
headerMap of
                [] -> ShowS
forall a. HasCallStack => String -> a
error String
"headerMap incomplete"
                ((String, HeaderName)
h:[(String, HeaderName)]
_) -> (String, HeaderName) -> String
forall a b. (a, b) -> a
fst (String, HeaderName)
h

-- | @HasHeaders@ is a type class for types containing HTTP headers, allowing
-- you to write overloaded header manipulation functions
-- for both 'Request' and 'Response' data types, for instance.
class HasHeaders x where
    getHeaders :: x -> [Header]
    setHeaders :: x -> [Header] -> x

-- Header manipulation functions

type HeaderSetter a = HeaderName -> String -> a -> a

-- | @insertHeader hdr val x@ inserts a header with the given header name
-- and value. Does not check for existing headers with same name, allowing
-- duplicates to be introduce (use 'replaceHeader' if you want to avoid this.)
insertHeader :: HasHeaders a => HeaderSetter a
insertHeader :: HeaderSetter a
insertHeader HeaderName
name String
value a
x = a -> [Header] -> a
forall x. HasHeaders x => x -> [Header] -> x
setHeaders a
x [Header]
newHeaders
    where
        newHeaders :: [Header]
newHeaders = (HeaderName -> String -> Header
Header HeaderName
name String
value) Header -> [Header] -> [Header]
forall a. a -> [a] -> [a]
: a -> [Header]
forall x. HasHeaders x => x -> [Header]
getHeaders a
x

-- | @insertHeaderIfMissing hdr val x@ adds the new header only if no previous
-- header with name @hdr@ exists in @x@.
insertHeaderIfMissing :: HasHeaders a => HeaderSetter a
insertHeaderIfMissing :: HeaderSetter a
insertHeaderIfMissing HeaderName
name String
value a
x = a -> [Header] -> a
forall x. HasHeaders x => x -> [Header] -> x
setHeaders a
x ([Header] -> [Header]
newHeaders ([Header] -> [Header]) -> [Header] -> [Header]
forall a b. (a -> b) -> a -> b
$ a -> [Header]
forall x. HasHeaders x => x -> [Header]
getHeaders a
x)
    where
        newHeaders :: [Header] -> [Header]
newHeaders list :: [Header]
list@(h :: Header
h@(Header HeaderName
n String
_): [Header]
rest)
            | HeaderName
n HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderName
name  = [Header]
list
            | Bool
otherwise  = Header
h Header -> [Header] -> [Header]
forall a. a -> [a] -> [a]
: [Header] -> [Header]
newHeaders [Header]
rest
        newHeaders [] = [HeaderName -> String -> Header
Header HeaderName
name String
value]

-- | @replaceHeader hdr val o@ replaces the header @hdr@ with the
-- value @val@, dropping any existing 
replaceHeader :: HasHeaders a => HeaderSetter a
replaceHeader :: HeaderSetter a
replaceHeader HeaderName
name String
value a
h = a -> [Header] -> a
forall x. HasHeaders x => x -> [Header] -> x
setHeaders a
h [Header]
newHeaders
    where
        newHeaders :: [Header]
newHeaders = HeaderName -> String -> Header
Header HeaderName
name String
value Header -> [Header] -> [Header]
forall a. a -> [a] -> [a]
: [ Header
x | x :: Header
x@(Header HeaderName
n String
_) <- a -> [Header]
forall x. HasHeaders x => x -> [Header]
getHeaders a
h, HeaderName
name HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
/= HeaderName
n ]
          
-- | @insertHeaders hdrs x@ appends multiple headers to @x@'s existing
-- set.
insertHeaders :: HasHeaders a => [Header] -> a -> a
insertHeaders :: [Header] -> a -> a
insertHeaders [Header]
hdrs a
x = a -> [Header] -> a
forall x. HasHeaders x => x -> [Header] -> x
setHeaders a
x (a -> [Header]
forall x. HasHeaders x => x -> [Header]
getHeaders a
x [Header] -> [Header] -> [Header]
forall a. [a] -> [a] -> [a]
++ [Header]
hdrs)

-- | @retrieveHeaders hdrNm x@ gets a list of headers with 'HeaderName' @hdrNm@.
retrieveHeaders :: HasHeaders a => HeaderName -> a -> [Header]
retrieveHeaders :: HeaderName -> a -> [Header]
retrieveHeaders HeaderName
name a
x = (Header -> Bool) -> [Header] -> [Header]
forall a. (a -> Bool) -> [a] -> [a]
filter Header -> Bool
matchname (a -> [Header]
forall x. HasHeaders x => x -> [Header]
getHeaders a
x)
    where
        matchname :: Header -> Bool
matchname (Header HeaderName
n String
_) = HeaderName
n HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderName
name 

-- | @findHeader hdrNm x@ looks up @hdrNm@ in @x@, returning the first
-- header that matches, if any.
findHeader :: HasHeaders a => HeaderName -> a -> Maybe String
findHeader :: HeaderName -> a -> Maybe String
findHeader HeaderName
n a
x = HeaderName -> [Header] -> Maybe String
lookupHeader HeaderName
n (a -> [Header]
forall x. HasHeaders x => x -> [Header]
getHeaders a
x)

-- | @lookupHeader hdr hdrs@ locates the first header matching @hdr@ in the
-- list @hdrs@.
lookupHeader :: HeaderName -> [Header] -> Maybe String
lookupHeader :: HeaderName -> [Header] -> Maybe String
lookupHeader HeaderName
_ [] = Maybe String
forall a. Maybe a
Nothing
lookupHeader HeaderName
v (Header HeaderName
n String
s:[Header]
t)  
  |  HeaderName
v HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderName
n   =  String -> Maybe String
forall a. a -> Maybe a
Just String
s
  | Bool
otherwise =  HeaderName -> [Header] -> Maybe String
lookupHeader HeaderName
v [Header]
t

-- | @parseHeader headerNameAndValueString@ tries to unscramble a
-- @header: value@ pairing and returning it as a 'Header'.
parseHeader :: String -> Result Header
parseHeader :: String -> Result Header
parseHeader String
str =
    case Char -> String -> Maybe (String, String)
forall a. Eq a => a -> [a] -> Maybe ([a], [a])
split Char
':' String
str of
        Maybe (String, String)
Nothing -> String -> Result Header
forall a. String -> Result a
failParse (String
"Unable to parse header: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
str)
        Just (String
k,String
v) -> Header -> Result Header
forall (m :: * -> *) a. Monad m => a -> m a
return (Header -> Result Header) -> Header -> Result Header
forall a b. (a -> b) -> a -> b
$ HeaderName -> String -> Header
Header (String -> HeaderName
fn String
k) (ShowS
trim ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Int -> ShowS
forall a. Int -> [a] -> [a]
drop Int
1 String
v)
    where
        fn :: String -> HeaderName
fn String
k = case ((String, HeaderName) -> HeaderName)
-> [(String, HeaderName)] -> [HeaderName]
forall a b. (a -> b) -> [a] -> [b]
map (String, HeaderName) -> HeaderName
forall a b. (a, b) -> b
snd ([(String, HeaderName)] -> [HeaderName])
-> [(String, HeaderName)] -> [HeaderName]
forall a b. (a -> b) -> a -> b
$ ((String, HeaderName) -> Bool)
-> [(String, HeaderName)] -> [(String, HeaderName)]
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> String -> Bool
match String
k (String -> Bool)
-> ((String, HeaderName) -> String) -> (String, HeaderName) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, HeaderName) -> String
forall a b. (a, b) -> a
fst) [(String, HeaderName)]
headerMap of
                 [] -> (String -> HeaderName
HdrCustom String
k)
                 (HeaderName
h:[HeaderName]
_) -> HeaderName
h

        match :: String -> String -> Bool
        match :: String -> String -> Bool
match String
s1 String
s2 = (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
s1 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
s2
    
-- | @parseHeaders hdrs@ takes a sequence of strings holding header
-- information and parses them into a set of headers (preserving their
-- order in the input argument.) Handles header values split up over
-- multiple lines.
parseHeaders :: [String] -> Result [Header]
parseHeaders :: [String] -> Result [Header]
parseHeaders = [Header] -> [Result Header] -> Result [Header]
forall a. [a] -> [Result a] -> Result [a]
catRslts [] ([Result Header] -> Result [Header])
-> ([String] -> [Result Header]) -> [String] -> Result [Header]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. 
                 (String -> Result Header) -> [String] -> [Result Header]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Result Header
parseHeader (String -> Result Header) -> ShowS -> String -> Result Header
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
clean) ([String] -> [Result Header])
-> ([String] -> [String]) -> [String] -> [Result Header]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. 
                     String -> [String] -> [String]
joinExtended String
""
   where
        -- Joins consecutive lines where the second line
        -- begins with ' ' or '\t'.
        joinExtended :: String -> [String] -> [String]
joinExtended String
old      [] = [String
old]
        joinExtended String
old (String
h : [String]
t)
          | String -> Bool
isLineExtension String
h    = String -> [String] -> [String]
joinExtended (String
old String -> ShowS
forall a. [a] -> [a] -> [a]
++ Char
' ' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
forall a. [a] -> [a]
tail String
h) [String]
t
          | Bool
otherwise            = String
old String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String -> [String] -> [String]
joinExtended String
h [String]
t

        isLineExtension :: String -> Bool
isLineExtension (Char
x:String
_) = Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ' Bool -> Bool -> Bool
|| Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\t'
        isLineExtension String
_ = Bool
False

        clean :: ShowS
clean [] = []
        clean (Char
h:String
t) | Char
h Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
"\t\r\n" = Char
' ' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
clean String
t
                    | Bool
otherwise = Char
h Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
clean String
t

        -- tolerant of errors?  should parse
        -- errors here be reported or ignored?
        -- currently ignored.
        catRslts :: [a] -> [Result a] -> Result [a]
        catRslts :: [a] -> [Result a] -> Result [a]
catRslts [a]
list (Result a
h:[Result a]
t) = 
            case Result a
h of
                Left ConnError
_ -> [a] -> [Result a] -> Result [a]
forall a. [a] -> [Result a] -> Result [a]
catRslts [a]
list [Result a]
t
                Right a
v -> [a] -> [Result a] -> Result [a]
forall a. [a] -> [Result a] -> Result [a]
catRslts (a
va -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
list) [Result a]
t
        catRslts [a]
list [] = [a] -> Result [a]
forall a b. b -> Either a b
Right ([a] -> Result [a]) -> [a] -> Result [a]
forall a b. (a -> b) -> a -> b
$ [a] -> [a]
forall a. [a] -> [a]
reverse [a]
list