http-slim-1.0: Network/HTTP/Headers.hs
-----------------------------------------------------------------------------
-- |
-- Module : Network.HTTP.Headers
-- Copyright : See LICENSE file
-- License : BSD
--
-- Maintainer : Krasimir Angelov <kr.angelov@gmail.com>
-- 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
, replaceHeaders
, findHeader -- :: HasHeaders a => HeaderName -> a -> Maybe String
, lookupHeader -- :: HeaderName -> [Header] -> Maybe String
, parseHeader -- :: parseHeader :: String -> Result Header
, parseHeaders -- :: [String] -> Result [Header]
, variableToHeaderName
, Cookie(..), processCookie, processSetCookies
, getEncoding
) where
import Data.Char (toLower,toUpper)
import Network.HTTP.Cookie
import Network.HTTP.Utils (trim, split, crlf, HttpError(..))
import System.IO
-- | The @Header@ data type pairs header names & values.
data Header = Header HeaderName String
hdrName :: Header -> HeaderName
hdrName (Header h _) = h
hdrValue :: Header -> String
hdrValue (Header _ v) = v
-- | Header constructor as a function, hiding above rep.
mkHeader :: HeaderName -> String -> Header
mkHeader = Header
instance Show Header where
show (Header key value) = shows key (':':' ':value ++ 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
| HdrAcceptRanges
| HdrAge
| HdrLocation
| HdrProxyAuthenticate
| HdrPublic
| HdrRetryAfter
| HdrServer
| HdrSetCookie
| HdrTE
| HdrTrailer
| HdrVary
| HdrWarning
| HdrWWWAuthenticate
| HdrAccessControlAllowOrigin
-- Entity Headers
| HdrAllow
| HdrContentBase
| HdrContentEncoding
| HdrContentLanguage
| HdrContentLength
| HdrContentLocation
| HdrContentMD5
| HdrContentRange
| HdrContentType
| HdrETag
| HdrExpires
| HdrLastModified
| HdrContentDisposition
-- | MIME entity headers (for sub-parts)
| HdrContentTransferEncoding
-- | Allows for unrecognised or experimental headers.
| HdrCustom String -- not in header map below.
| HdrExtensionHeader
instance Eq HeaderName where
HdrCustom a == HdrCustom b = map toLower a == map toLower b
HdrCacheControl == HdrCacheControl = True
HdrConnection == HdrConnection = True
HdrDate == HdrDate = True
HdrPragma == HdrPragma = True
HdrTransferEncoding == HdrTransferEncoding = True
HdrUpgrade == HdrUpgrade = True
HdrVia == HdrVia = True
HdrAccept == HdrAccept = True
HdrAcceptCharset == HdrAcceptCharset = True
HdrAcceptEncoding == HdrAcceptEncoding = True
HdrAcceptLanguage == HdrAcceptLanguage = True
HdrAuthorization == HdrAuthorization = True
HdrCookie == HdrCookie = True
HdrExpect == HdrExpect = True
HdrFrom == HdrFrom = True
HdrHost == HdrHost = True
HdrIfModifiedSince == HdrIfModifiedSince = True
HdrIfMatch == HdrIfMatch = True
HdrIfNoneMatch == HdrIfNoneMatch = True
HdrIfRange == HdrIfRange = True
HdrIfUnmodifiedSince == HdrIfUnmodifiedSince = True
HdrMaxForwards == HdrMaxForwards = True
HdrProxyAuthorization == HdrProxyAuthorization = True
HdrRange == HdrRange = True
HdrReferer == HdrReferer = True
HdrUserAgent == HdrUserAgent = True
HdrAcceptRanges == HdrAcceptRanges = True
HdrAge == HdrAge = True
HdrLocation == HdrLocation = True
HdrProxyAuthenticate == HdrProxyAuthenticate = True
HdrPublic == HdrPublic = True
HdrRetryAfter == HdrRetryAfter = True
HdrServer == HdrServer = True
HdrSetCookie == HdrSetCookie = True
HdrTE == HdrTE = True
HdrTrailer == HdrTrailer = True
HdrVary == HdrVary = True
HdrWarning == HdrWarning = True
HdrWWWAuthenticate == HdrWWWAuthenticate = True
HdrAccessControlAllowOrigin== HdrAccessControlAllowOrigin= True
HdrAllow == HdrAllow = True
HdrContentBase == HdrContentBase = True
HdrContentEncoding == HdrContentEncoding = True
HdrContentLanguage == HdrContentLanguage = True
HdrContentLength == HdrContentLength = True
HdrContentLocation == HdrContentLocation = True
HdrContentMD5 == HdrContentMD5 = True
HdrContentRange == HdrContentRange = True
HdrContentType == HdrContentType = True
HdrETag == HdrETag = True
HdrExpires == HdrExpires = True
HdrLastModified == HdrLastModified = True
HdrContentTransferEncoding == HdrContentTransferEncoding = True
HdrContentDisposition == HdrContentDisposition = True
_ == _ = False
-- | @headerMap@ is a straight assoc list for translating between
-- header names, variable names and Haskell values.
headerMap :: [(String,String,HeaderName)]
headerMap =
[ p "Cache-Control" "HTTP_CACHE_CONTROL" HdrCacheControl
, p "Connection" "HTTP_CONNECTION" HdrConnection
, p "Date" "HTTP_DATE" HdrDate
, p "Pragma" "HTTP_PRAGMA" HdrPragma
, p "Transfer-Encoding" "HTTP_TRANSFER_ENCODING" HdrTransferEncoding
, p "Upgrade" "HTTP_UPGRADE" HdrUpgrade
, p "Via" "HTTP_VIA" HdrVia
, p "Accept" "HTTP_ACCEPT" HdrAccept
, p "Accept-Charset" "HTTP_ACCEPT_CHARSET" HdrAcceptCharset
, p "Accept-Encoding" "HTTP_ACCEPT_ENCODING" HdrAcceptEncoding
, p "Accept-Language" "HTTP_ACCEPT_LANGUAGE" HdrAcceptLanguage
, p "Authorization" "HTTP_AUTHORIZATION" HdrAuthorization
, p "Cookie" "HTTP_COOKIE" HdrCookie
, p "Expect" "HTTP_EXPECT" HdrExpect
, p "From" "HTTP_FROM" HdrFrom
, p "Host" "HTTP_HOST" HdrHost
, p "If-Modified-Since" "HTTP_IF_MODIFIED_SINCE" HdrIfModifiedSince
, p "If-Match" "HTTP_IF_MATCH" HdrIfMatch
, p "If-None-Match" "HTTP_IF_NONE_MATCH" HdrIfNoneMatch
, p "If-Range" "HTTP_IF_RANGE" HdrIfRange
, p "If-Unmodified-Since" "HTTP_IF_UNMODIFIED_SINCE" HdrIfUnmodifiedSince
, p "Max-Forwards" "HTTP_MAX_FORWARDS" HdrMaxForwards
, p "Proxy-Authorization" "HTTP_PROXY_AUTHORIZATION" HdrProxyAuthorization
, p "Range" "HTTP_RANGE" HdrRange
, p "Referer" "HTTP_REFERER" HdrReferer
, p "TE" "HTTP_TE" HdrTE
, p "User-Agent" "HTTP_USER_AGENT" HdrUserAgent
, p "Accept-Ranges" "HTTP_ACCEPT_RANGES" HdrAcceptRanges
, p "Age" "HTTP_AGE" HdrAge
, p "ETag" "HTTP_ETAG" HdrETag
, p "Location" "HTTP_LOCATION" HdrLocation
, p "Proxy-Authenticate" "HTTP_PROXY_AUTHENTICATE" HdrProxyAuthenticate
, p "Public" "HTTP_PUBLIC" HdrPublic
, p "Retry-After" "HTTP_RETRY_AFTER" HdrRetryAfter
, p "Server" "HTTP_SERVER" HdrServer
, p "Set-Cookie" "HTTP_SET_COOKIE" HdrSetCookie
, p "Trailer" "HTTP_TRAILER" HdrTrailer
, p "Vary" "HTTP_VARY" HdrVary
, p "Warning" "HTTP_WARNING" HdrWarning
, p "WWW-Authenticate" "HTTP_WWW_AUTHENTICATE" HdrWWWAuthenticate
, p "Access-Control-Allow-Origin" "HTTP_ACCESS_CONTROL_ALLOW_ORIGIN" HdrAccessControlAllowOrigin
, p "Allow" "HTTP_ALLOW" HdrAllow
, p "Content-Base" "HTTP_CONTENT_BASE" HdrContentBase
, p "Content-Encoding" "HTTP_CONTENT_ENCODING" HdrContentEncoding
, p "Content-Language" "HTTP_CONTENT_LANGUAGE" HdrContentLanguage
, p "Content-Length" "CONTENT_LENGTH" HdrContentLength
, p "Content-Location" "HTTP_CONTENT_LOCATION" HdrContentLocation
, p "Content-MD5" "HTTP_CONTENT_MD5" HdrContentMD5
, p "Content-Range" "HTTP_CONTENT_RANGE" HdrContentRange
, p "Content-Type" "CONTENT_TYPE" HdrContentType
, p "Expires" "HTTP_EXPIRES" HdrExpires
, p "Last-Modified" "HTTP_LAST_MODIFIED" HdrLastModified
, p "Content-Transfer-Encoding" "HTTP_CONTENT_TRANSFER_ENCODING" HdrContentTransferEncoding
, p "Content-Disposition" "HTTP_CONTENT_DISPOSITION" HdrContentDisposition
]
where
p a b c = (a,b,c)
instance Show HeaderName where
show (HdrCustom s) = s
show x = case filter (\(_,_,y)->x==y) headerMap of
[] -> error "headerMap incomplete"
((h,_,_):_) -> 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
getCookies :: x -> [Cookie]
setCookies :: x -> [Cookie] -> x
-- | @insertHeader hdr x@ inserts a header. Does not check for
-- existing headers with same name, allowing duplicates to be
-- introduced (use 'replaceHeader' if you want to avoid this.)
insertHeader :: HasHeaders a => HeaderName -> String -> a -> a
insertHeader name value x = setHeaders x (Header name value : getHeaders x)
-- | @insertHeaderIfMissing hdr val x@ adds the new header only if no previous
-- header with name @hdr@ exists in @x@.
insertHeaderIfMissing :: HasHeaders a => HeaderName -> String -> a -> a
insertHeaderIfMissing name value x = setHeaders x (update (getHeaders x))
where
update [] = [Header name value]
update list@(h@(Header n _) : rest)
| n == name = list
| otherwise = h : update rest
-- | @replaceHeader hdr val o@ replaces the header @hdr@ with the
-- value @val@, dropping any existing
replaceHeader :: HasHeaders a => HeaderName -> String -> a -> a
replaceHeader name value x = setHeaders x (update (getHeaders x))
where
update [] = [Header name value]
update (h@(Header n _) : rest)
| n == name = update rest
| otherwise = h : update rest
-- | @insertHeaders hdrs x@ appends multiple headers to @x@'s existing
-- set.
insertHeaders :: HasHeaders a => [Header] -> a -> a
insertHeaders hdrs x = setHeaders x (getHeaders x ++ hdrs)
-- | @replaceHeader hdr val o@ replaces the header @hdr@ with the
-- value @val@, dropping any existing
replaceHeaders :: HasHeaders a => HeaderName -> [String] -> a -> a
replaceHeaders name values x = setHeaders x (update (getHeaders x))
where
update [] = [Header name value | value <- values]
update (h@(Header n _) : rest)
| n == name = update rest
| otherwise = h : update rest
-- | @retrieveHeaders hdrNm x@ gets a list of headers with 'HeaderName' @hdrNm@.
retrieveHeaders :: HasHeaders a => HeaderName -> a -> [Header]
retrieveHeaders name x = filter matchname (getHeaders x)
where
matchname (Header n _) = n == 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 n x = lookupHeader n (getHeaders x)
-- | @lookupHeader hdr hdrs@ locates the first header matching @hdr@ in the
-- list @hdrs@.
lookupHeader :: HeaderName -> [Header] -> Maybe String
lookupHeader _ [] = Nothing
lookupHeader v (Header n s:t)
| v == n = Just s
| otherwise = lookupHeader v t
-- | @parseHeader headerNameAndValueString@ tries to unscramble a
-- @header: value@ pairing and returning it as a 'Header'.
parseHeader :: String -> Maybe Header
parseHeader str =
case split ':' str of
Nothing -> Nothing
Just (k,v) -> Just $ Header (fn k) (trim $ drop 1 v)
where
fn x = case filter (\(y,_,_) -> match x y) headerMap of
[] -> HdrCustom x
((_,_,h):_) -> h
match :: String -> String -> Bool
match s1 s2 = map toLower s1 == map toLower s2
variableToHeaderName :: String -> Maybe HeaderName
variableToHeaderName x =
case filter (\(_,y,_) -> x==y) headerMap of
[] -> variableToHeader x
((_,_,h):_) -> Just h
where
variableToHeader ('H':'T':'T':'P':'_':cs)
| null cs = Nothing
| otherwise = Just (HdrCustom (translate cs))
variableToHeader _ = Nothing
translate [] = []
translate cs = case break (=='_') cs of
(first, '_':rest) -> titleCase first++'-':translate rest
_ -> cs
titleCase [] = []
titleCase (c:cs) = toUpper c : map toLower cs
-- | @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] -> Either HttpError [Header]
parseHeaders = parseLines [] . joinExtended ""
where
-- Joins consecutive lines where the second line
-- begins with ' ' or '\t'.
joinExtended old [] = [old | not (null old)]
joinExtended old (h : t)
| isLineExtension h = joinExtended (old ++ ' ' : tail h) t
| null old = joinExtended h t
| otherwise = old : joinExtended h t
isLineExtension (x:_) = x == ' ' || x == '\t'
isLineExtension _ = False
clean [] = []
clean (h:t) | h `elem` "\t\r\n" = ' ' : clean t
| otherwise = h : clean t
parseLines :: [Header] -> [String] -> Either HttpError [Header]
parseLines hdrs [] = Right (reverse hdrs)
parseLines hdrs (l:ls) =
case (parseHeader . clean) l of
Just hdr -> parseLines (hdr:hdrs) ls
Nothing -> Left (ErrorParse ("Unable to parse header: " ++ l))
-- | process SetCookie headers and extract the cookies and the errors
processSetCookies :: [Header] -> ([String], [Cookie])
processSetCookies hdrs =
foldr (\(Header hdr val) st ->
if hdr == HdrSetCookie
then parseSetCookie val st
else st)
([],[])
hdrs
-- | @processCookieHeaders dom hdrs@
processCookie :: String -> [Header] -> Maybe [Cookie]
processCookie dom hdrs =
lookupHeader HdrCookie hdrs >>= parseCookie dom
getEncoding :: [Header] -> IO TextEncoding
getEncoding hdrs =
case lookupHeader HdrContentType hdrs of
Just val -> case dropWhile (/=';') val of
(';':cs) -> case break (=='=') cs of
(xs,'=':ys) | trim (map toLower xs) == "charset" ->
do enc <- mkTextEncoding (trim ys++"//IGNORE")
return enc
_ -> return latin1
_ -> return latin1
Nothing -> return latin1