----------------------------------------------------------------------------- -- | -- Module : Network.HTTP.Headers -- Copyright : See LICENSE file -- License : BSD -- -- Maintainer : Ganesh Sittampalam -- 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 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 | 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 a == HdrCustom b = (fmap toLower a) == (fmap toLower b) HdrCacheControl == HdrCacheControl = True HdrCacheControl == _ = False _ == HdrCacheControl = False HdrConnection == HdrConnection = True HdrConnection == _ = False _ == HdrConnection = False HdrDate == HdrDate = True HdrDate == _ = False _ == HdrDate = False HdrPragma == HdrPragma = True HdrPragma == _ = False _ == HdrPragma = False HdrTransferEncoding == HdrTransferEncoding = True HdrTransferEncoding == _ = False _ == HdrTransferEncoding = False HdrUpgrade == HdrUpgrade = True HdrUpgrade == _ = False _ == HdrUpgrade = False HdrVia == HdrVia = True HdrVia == _ = False _ == HdrVia = False HdrAccept == HdrAccept = True HdrAccept == _ = False _ == HdrAccept = False HdrAcceptCharset == HdrAcceptCharset = True HdrAcceptCharset == _ = False _ == HdrAcceptCharset = False HdrAcceptEncoding == HdrAcceptEncoding = True HdrAcceptEncoding == _ = False _ == HdrAcceptEncoding = False HdrAcceptLanguage == HdrAcceptLanguage = True HdrAcceptLanguage == _ = False _ == HdrAcceptLanguage = False HdrAuthorization == HdrAuthorization = True HdrAuthorization == _ = False _ == HdrAuthorization = False HdrCookie == HdrCookie = True HdrCookie == _ = False _ == HdrCookie = False HdrExpect == HdrExpect = True HdrExpect == _ = False _ == HdrExpect = False HdrFrom == HdrFrom = True HdrFrom == _ = False _ == HdrFrom = False HdrHost == HdrHost = True HdrHost == _ = False _ == HdrHost = False HdrIfModifiedSince == HdrIfModifiedSince = True HdrIfModifiedSince == _ = False _ == HdrIfModifiedSince = False HdrIfMatch == HdrIfMatch = True HdrIfMatch == _ = False _ == HdrIfMatch = False HdrIfNoneMatch == HdrIfNoneMatch = True HdrIfNoneMatch == _ = False _ == HdrIfNoneMatch = False HdrIfRange == HdrIfRange = True HdrIfRange == _ = False _ == HdrIfRange = False HdrIfUnmodifiedSince == HdrIfUnmodifiedSince = True HdrIfUnmodifiedSince == _ = False _ == HdrIfUnmodifiedSince = False HdrMaxForwards == HdrMaxForwards = True HdrMaxForwards == _ = False _ == HdrMaxForwards = False HdrProxyAuthorization == HdrProxyAuthorization = True HdrProxyAuthorization == _ = False _ == HdrProxyAuthorization = False HdrRange == HdrRange = True HdrRange == _ = False _ == HdrRange = False HdrReferer == HdrReferer = True HdrReferer == _ = False _ == HdrReferer = False HdrUserAgent == HdrUserAgent = True HdrUserAgent == _ = False _ == HdrUserAgent = False HdrAge == HdrAge = True HdrAge == _ = False _ == HdrAge = False HdrLocation == HdrLocation = True HdrLocation == _ = False _ == HdrLocation = False HdrProxyAuthenticate == HdrProxyAuthenticate = True HdrProxyAuthenticate == _ = False _ == HdrProxyAuthenticate = False HdrPublic == HdrPublic = True HdrPublic == _ = False _ == HdrPublic = False HdrRetryAfter == HdrRetryAfter = True HdrRetryAfter == _ = False _ == HdrRetryAfter = False HdrServer == HdrServer = True HdrServer == _ = False _ == HdrServer = False HdrSetCookie == HdrSetCookie = True HdrSetCookie == _ = False _ == HdrSetCookie = False HdrTE == HdrTE = True HdrTE == _ = False _ == HdrTE = False HdrTrailer == HdrTrailer = True HdrTrailer == _ = False _ == HdrTrailer = False HdrVary == HdrVary = True HdrVary == _ = False _ == HdrVary = False HdrWarning == HdrWarning = True HdrWarning == _ = False _ == HdrWarning = False HdrWWWAuthenticate == HdrWWWAuthenticate = True HdrWWWAuthenticate == _ = False _ == HdrWWWAuthenticate = False HdrAllow == HdrAllow = True HdrAllow == _ = False _ == HdrAllow = False HdrContentBase == HdrContentBase = True HdrContentBase == _ = False _ == HdrContentBase = False HdrContentEncoding == HdrContentEncoding = True HdrContentEncoding == _ = False _ == HdrContentEncoding = False HdrContentLanguage == HdrContentLanguage = True HdrContentLanguage == _ = False _ == HdrContentLanguage = False HdrContentLength == HdrContentLength = True HdrContentLength == _ = False _ == HdrContentLength = False HdrContentLocation == HdrContentLocation = True HdrContentLocation == _ = False _ == HdrContentLocation = False HdrContentMD5 == HdrContentMD5 = True HdrContentMD5 == _ = False _ == HdrContentMD5 = False HdrContentRange == HdrContentRange = True HdrContentRange == _ = False _ == HdrContentRange = False HdrContentType == HdrContentType = True HdrContentType == _ = False _ == HdrContentType = False HdrETag == HdrETag = True HdrETag == _ = False _ == HdrETag = False HdrExpires == HdrExpires = True HdrExpires == _ = False _ == HdrExpires = False HdrLastModified == HdrLastModified = True HdrLastModified == _ = False _ == HdrLastModified = False HdrContentTransferEncoding == HdrContentTransferEncoding = True HdrContentTransferEncoding == _ = False _ == HdrContentTransferEncoding = False -- | @headerMap@ is a straight assoc list for translating between header names -- and values. headerMap :: [ (String,HeaderName) ] headerMap = [ p "Cache-Control" HdrCacheControl , p "Connection" HdrConnection , p "Date" HdrDate , p "Pragma" HdrPragma , p "Transfer-Encoding" HdrTransferEncoding , p "Upgrade" HdrUpgrade , p "Via" HdrVia , p "Accept" HdrAccept , p "Accept-Charset" HdrAcceptCharset , p "Accept-Encoding" HdrAcceptEncoding , p "Accept-Language" HdrAcceptLanguage , p "Authorization" HdrAuthorization , p "Cookie" HdrCookie , p "Expect" HdrExpect , p "From" HdrFrom , p "Host" HdrHost , p "If-Modified-Since" HdrIfModifiedSince , p "If-Match" HdrIfMatch , p "If-None-Match" HdrIfNoneMatch , p "If-Range" HdrIfRange , p "If-Unmodified-Since" HdrIfUnmodifiedSince , p "Max-Forwards" HdrMaxForwards , p "Proxy-Authorization" HdrProxyAuthorization , p "Range" HdrRange , p "Referer" HdrReferer , p "User-Agent" HdrUserAgent , p "Age" HdrAge , p "Location" HdrLocation , p "Proxy-Authenticate" HdrProxyAuthenticate , p "Public" HdrPublic , p "Retry-After" HdrRetryAfter , p "Server" HdrServer , p "Set-Cookie" HdrSetCookie , p "TE" HdrTE , p "Trailer" HdrTrailer , p "Vary" HdrVary , p "Warning" HdrWarning , p "WWW-Authenticate" HdrWWWAuthenticate , p "Allow" HdrAllow , p "Content-Base" HdrContentBase , p "Content-Encoding" HdrContentEncoding , p "Content-Language" HdrContentLanguage , p "Content-Length" HdrContentLength , p "Content-Location" HdrContentLocation , p "Content-MD5" HdrContentMD5 , p "Content-Range" HdrContentRange , p "Content-Type" HdrContentType , p "ETag" HdrETag , p "Expires" HdrExpires , p "Last-Modified" HdrLastModified , p "Content-Transfer-Encoding" HdrContentTransferEncoding ] where p a b = (a,b) instance Show HeaderName where show (HdrCustom s) = s show x = case filter ((==x).snd) headerMap of [] -> error "headerMap incomplete" (h:_) -> fst 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 name value x = setHeaders x newHeaders where newHeaders = (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 => HeaderSetter a insertHeaderIfMissing name value x = setHeaders x (newHeaders $ getHeaders x) where newHeaders list@(h@(Header n _): rest) | n == name = list | otherwise = h : newHeaders rest newHeaders [] = [Header name value] -- | @replaceHeader hdr val o@ replaces the header @hdr@ with the -- value @val@, dropping any existing replaceHeader :: HasHeaders a => HeaderSetter a replaceHeader name value h = setHeaders h newHeaders where newHeaders = Header name value : [ x | x@(Header n _) <- getHeaders h, name /= n ] -- | @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) -- | @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 -> Result Header parseHeader str = case split ':' str of Nothing -> failParse ("Unable to parse header: " ++ str) Just (k,v) -> return $ Header (fn k) (trim $ drop 1 v) where fn k = case map snd $ filter (match k . fst) headerMap of [] -> (HdrCustom k) (h:_) -> h match :: String -> String -> Bool match s1 s2 = map toLower s1 == map toLower 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 = catRslts [] . map (parseHeader . clean) . joinExtended "" where -- Joins consecutive lines where the second line -- begins with ' ' or '\t'. joinExtended old [] = [old] joinExtended old (h : t) | isLineExtension h = joinExtended (old ++ ' ' : tail 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 -- tolerant of errors? should parse -- errors here be reported or ignored? -- currently ignored. catRslts :: [a] -> [Result a] -> Result [a] catRslts list (h:t) = case h of Left _ -> catRslts list t Right v -> catRslts (v:list) t catRslts list [] = Right $ reverse list