mohws-0.1: src/Headers.hs
-- Copyright 2002 Warrick Gray
-- Copyright 2001,2002 Peter Thiemann
-- Copyright 2003-2006 Bjorn Bringert
module Headers (Headers(..),
mkHeaders,
Header(..),
HeaderName(..),
HasHeaders(..),
-- * Header parsing
pHeaders, mkHeaderName,
-- * Header manipulation
insertHeader,
insertHeaderIfMissing,
replaceHeader, insertHeaders,
lookupHeaders, lookupHeader,
-- * Constructing headers
contentLengthHeader,
contentTypeHeader,
lastModifiedHeader,
TransferCoding,
transferCodingHeader,
-- * Getting values of specific headers
getContentType, getContentLength
) where
import Parse
import Util
import Control.Monad (liftM)
import Data.Char (toLower)
import Data.Map (Map)
import qualified Data.Map as Map hiding (Map)
import Data.Maybe (listToMaybe)
import System.Time (ClockTime, toUTCTime)
import Text.ParserCombinators.Parsec
newtype Headers = Headers { unHeaders :: [Header] }
mkHeaders :: [Header] -> Headers
mkHeaders = Headers
instance Show Headers where
showsPrec _
= foldr (.) id . map (\x -> shows x . showString crLf) . unHeaders
instance HasHeaders Headers where
getHeaders = id
setHeaders _ = id
-- | This class allows us to write generic header manipulation functions
-- for both 'Request' and 'Response' data types.
class HasHeaders x where
getHeaders :: x -> Headers
setHeaders :: x -> Headers -> x
listHeaders :: x -> [Header]
listHeaders = unHeaders . getHeaders
modifyHeaders :: ([Header] -> [Header]) -> x -> x
modifyHeaders f x = setHeaders x $ mkHeaders $ f $ listHeaders x
-- | The Header data type pairs header names & values.
data Header = Header HeaderName String
instance Show Header where
showsPrec _ (Header key value)
= shows key . showString ": " . showString value
-- | HTTP Header Name type:
-- Why include this at all? I have some reasons
-- 1) prevent spelling errors of header names,
-- 2) remind everyone of what headers are available,
-- 3) might speed up searches for specific headers.
--
-- Arguments against:
-- 1) makes customising header names laborious
-- 2) increases code volume.
--
data HeaderName =
-- Generic Headers --
HdrCacheControl
| HdrConnection
| HdrDate
| HdrPragma
| HdrTrailer
| HdrTransferEncoding
| HdrUpgrade
| HdrVia
-- Request Headers --
| HdrAccept
| HdrAcceptCharset
| HdrAcceptEncoding
| HdrAcceptLanguage
| HdrAuthorization
| HdrCookie
| HdrExpect
| HdrFrom
| HdrHost
| HdrIfModifiedSince
| HdrIfMatch
| HdrIfNoneMatch
| HdrIfRange
| HdrIfUnmodifiedSince
| HdrMaxForwards
| HdrProxyAuthorization
| HdrRange
| HdrReferer
| HdrTE
| HdrUserAgent
-- Response Headers
| HdrAge
| HdrLocation
| HdrProxyAuthenticate
| HdrPublic
| HdrRetryAfter
| HdrServer
| HdrSetCookie
| 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.
deriving (Eq,Ord)
-- Translation between header names and values,
headerNames :: [ (String,HeaderName) ]
headerNames
= [ ("Cache-Control" ,HdrCacheControl )
, ("Connection" ,HdrConnection )
, ("Date" ,HdrDate )
, ("Pragma" ,HdrPragma )
, ("Trailer" ,HdrTrailer )
, ("Transfer-Encoding" ,HdrTransferEncoding )
, ("Upgrade" ,HdrUpgrade )
, ("Via" ,HdrVia )
, ("Accept" ,HdrAccept )
, ("Accept-Charset" ,HdrAcceptCharset )
, ("Accept-Encoding" ,HdrAcceptEncoding )
, ("Accept-Language" ,HdrAcceptLanguage )
, ("Authorization" ,HdrAuthorization )
, ("From" ,HdrFrom )
, ("Host" ,HdrHost )
, ("If-Modified-Since" ,HdrIfModifiedSince )
, ("If-Match" ,HdrIfMatch )
, ("If-None-Match" ,HdrIfNoneMatch )
, ("If-Range" ,HdrIfRange )
, ("If-Unmodified-Since" ,HdrIfUnmodifiedSince )
, ("Max-Forwards" ,HdrMaxForwards )
, ("Proxy-Authorization" ,HdrProxyAuthorization)
, ("Range" ,HdrRange )
, ("Referer" ,HdrReferer )
, ("TE" ,HdrTE )
, ("User-Agent" ,HdrUserAgent )
, ("Age" ,HdrAge )
, ("Location" ,HdrLocation )
, ("Proxy-Authenticate" ,HdrProxyAuthenticate )
, ("Public" ,HdrPublic )
, ("Retry-After" ,HdrRetryAfter )
, ("Server" ,HdrServer )
, ("Vary" ,HdrVary )
, ("Warning" ,HdrWarning )
, ("WWW-Authenticate" ,HdrWWWAuthenticate )
, ("Allow" ,HdrAllow )
, ("Content-Base" ,HdrContentBase )
, ("Content-Encoding" ,HdrContentEncoding )
, ("Content-Language" ,HdrContentLanguage )
, ("Content-Length" ,HdrContentLength )
, ("Content-Location" ,HdrContentLocation )
, ("Content-MD5" ,HdrContentMD5 )
, ("Content-Range" ,HdrContentRange )
, ("Content-Type" ,HdrContentType )
, ("ETag" ,HdrETag )
, ("Expires" ,HdrExpires )
, ("Last-Modified" ,HdrLastModified )
, ("Set-Cookie" ,HdrSetCookie )
, ("Cookie" ,HdrCookie )
, ("Expect" ,HdrExpect ) ]
toHeaderNameMap :: Map String HeaderName
toHeaderNameMap = Map.fromList [(map toLower x, y) | (x,y) <- headerNames]
fromHeaderNameMap :: Map HeaderName String
fromHeaderNameMap = Map.fromList [(y,x) | (x,y) <- headerNames]
instance Show HeaderName where
show (HdrCustom s) = s
show x = case Map.lookup x fromHeaderNameMap of
Nothing -> error "headerNames incomplete"
Just h -> h
mkHeaderName :: String -> HeaderName
mkHeaderName s =
case Map.lookup (map toLower s) toHeaderNameMap of
Just n -> n
Nothing -> HdrCustom s
-- * Header manipulation functions
-- | Inserts a header with the given name and value.
-- Allows duplicate header names.
insertHeader :: HasHeaders a => HeaderName -> String -> a -> a
insertHeader name value = modifyHeaders (Header name value:)
-- | Adds the new header only if no previous header shares
-- the same name.
insertHeaderIfMissing :: HasHeaders a => HeaderName -> String -> a -> a
insertHeaderIfMissing name value x = setHeaders x $ mkHeaders hs'
where hs' = case lookupHeader name x of
Nothing -> Header name value : hs
Just _ -> hs
hs = listHeaders (getHeaders x)
-- | Removes old headers with the same name.
replaceHeader :: HasHeaders a => HeaderName -> String -> a -> a
replaceHeader name value = modifyHeaders f
where f hs = Header name value : [ x | x@(Header n _) <- hs, name /= n ]
-- | Inserts multiple headers.
insertHeaders :: HasHeaders a => [Header] -> a -> a
insertHeaders hdrs = modifyHeaders (hdrs++)
lookupHeaders :: HasHeaders a => HeaderName -> a -> [String]
lookupHeaders name x = [ v | Header n v <- listHeaders x, name == n ]
lookupHeader :: HasHeaders a => HeaderName -> a -> Maybe String
lookupHeader n x = listToMaybe $ lookupHeaders n x
-- * Constructing specific headers
contentLengthHeader :: Integer -> Header
contentLengthHeader i = Header HdrContentLength (show i)
contentTypeHeader :: String -> Header
contentTypeHeader t = Header HdrContentType t
lastModifiedHeader :: ClockTime -> Header
lastModifiedHeader t = Header HdrLastModified (formatTimeSensibly (toUTCTime t))
transferCodingHeader :: TransferCoding -> Header
transferCodingHeader te = Header HdrTransferEncoding (transferCodingStr te)
data TransferCoding
= ChunkedTransferCoding
| GzipTransferCoding
| CompressTransferCoding
| DeflateTransferCoding
deriving Eq
transferCodingStr :: TransferCoding -> String
transferCodingStr ChunkedTransferCoding = "chunked"
transferCodingStr GzipTransferCoding = "gzip"
transferCodingStr CompressTransferCoding = "compress"
transferCodingStr DeflateTransferCoding = "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 x = lookupHeader HdrContentType x
getContentLength :: HasHeaders a => a -> Maybe Integer
getContentLength x = lookupHeader HdrContentLength x >>= readM
-- * Parsing
pHeaders :: Parser Headers
pHeaders = liftM Headers $ many pHeader
pHeader :: Parser Header
pHeader =
do name <- pToken
char ':'
many pWS1
line <- lineString
pCRLF
extraLines <- many extraFieldLine
return $ Header (mkHeaderName name) (concat (line:extraLines))
extraFieldLine :: Parser String
extraFieldLine =
do sp <- pWS1
line <- lineString
pCRLF
return (sp:line)