------------------------------------------------------------------------------- |-- 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.-- -----------------------------------------------------------------------------moduleNetwork.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 )whereimportData.Char(toLower)importNetwork.Stream (Result ,failParse )importNetwork.HTTP.Utils (trim ,split ,crlf )-- | The @Header@ data type pairs header names & values.dataHeader =Header HeaderName StringhdrName::Header ->HeaderName hdrName (Header h _)=h hdrValue::Header ->StringhdrValue (Header _v )=v -- | Header constructor as a function, hiding above rep.mkHeader::HeaderName ->String->Header mkHeader =Header instanceShowHeader whereshow (Header key value )=showskey (':':' ':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.-- dataHeaderName -- 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.deriving(Eq)-- | @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 ]wherep a b =(a ,b )instanceShowHeaderName whereshow (HdrCustom s )=s showx =casefilter((==x ).snd)headerMap of[]->error"headerMap incomplete"(h :_)->fsth -- | @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.classHasHeaders x wheregetHeaders ::x ->[Header ]setHeaders ::x ->[Header ]->x -- Header manipulation functionstypeHeaderSetter 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 wherenewHeaders =(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 )wherenewHeaders 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 wherenewHeaders =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 =filtermatchname (getHeaders x )wherematchname (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 ->MaybeStringfindHeader n x =lookupHeader n (getHeaders x )-- | @lookupHeader hdr hdrs@ locates the first header matching @hdr@ in the-- list @hdrs@.lookupHeader::HeaderName ->[Header ]->MaybeStringlookupHeader _[]=NothinglookupHeaderv (Header n s :t )|v ==n =Justs |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 =casesplit ':'str ofNothing->failParse ("Unable to parse header: "++str )Just(k ,v )->return$Header (fn k )(trim $drop1v )wherefn k =casemapsnd$filter(match k .fst)headerMap of[]->(HdrCustom k )(h :_)->h match::String->String->Boolmatch s1 s2 =maptoLowers1 ==maptoLowers2 -- | @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 ]joinExtendedold (h :t )|isLineExtension h =joinExtended (old ++' ':tailh )t |otherwise=old :joinExtended h t isLineExtension (x :_)=x ==' '||x =='\t'isLineExtension_=Falseclean []=[]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 )=caseh ofLeft_->catRslts list t Rightv ->catRslts (v :list )t catRsltslist []=Right$reverselist