module Network.HTTP.Headers
( HasHeaders(..)
, Header(..)
, HeaderName(..)
, insertHeader
, insertHeaderIfMissing
, insertHeaders
, retrieveHeaders
, replaceHeader
, findHeader
, lookupHeader
, parseHeaders
, parseHeader
, headerMap
) where
import Data.Char (isSpace, toLower)
import Data.List (elemIndex)
import Network.Stream (Result, ConnError(ErrorParse))
trim :: String -> String
trim = let dropspace = dropWhile isSpace in
reverse . dropspace . reverse . dropspace
split :: Eq a => a -> [a] -> Maybe ([a],[a])
split delim list = case delim `elemIndex` list of
Nothing -> Nothing
Just x -> Just $ splitAt x list
crlf :: String
crlf = "\r\n"
data Header = Header HeaderName String
instance Show Header where
show (Header key value) = show key ++ ": " ++ value ++ crlf
data HeaderName =
HdrCacheControl
| HdrConnection
| HdrDate
| HdrPragma
| HdrTransferEncoding
| HdrUpgrade
| HdrVia
| HdrAccept
| HdrAcceptCharset
| HdrAcceptEncoding
| HdrAcceptLanguage
| HdrAuthorization
| HdrCookie
| HdrExpect
| HdrFrom
| HdrHost
| HdrIfModifiedSince
| HdrIfMatch
| HdrIfNoneMatch
| HdrIfRange
| HdrIfUnmodifiedSince
| HdrMaxForwards
| HdrProxyAuthorization
| HdrRange
| HdrReferer
| HdrUserAgent
| HdrAge
| HdrLocation
| HdrProxyAuthenticate
| HdrPublic
| HdrRetryAfter
| HdrServer
| HdrSetCookie
| HdrVary
| HdrWarning
| HdrWWWAuthenticate
| HdrAllow
| HdrContentBase
| HdrContentEncoding
| HdrContentLanguage
| HdrContentLength
| HdrContentLocation
| HdrContentMD5
| HdrContentRange
| HdrContentType
| HdrETag
| HdrExpires
| HdrLastModified
| HdrContentTransferEncoding
| HdrCustom String
deriving(Eq)
headerMap :: [ (String,HeaderName) ]
headerMap
= [ ("Cache-Control" ,HdrCacheControl )
, ("Connection" ,HdrConnection )
, ("Date" ,HdrDate )
, ("Pragma" ,HdrPragma )
, ("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 )
, ("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 ) ]
instance Show HeaderName where
show (HdrCustom s) = s
show x = case filter ((==x).snd) headerMap of
[] -> error "headerMap incomplete"
(h:_) -> fst h
class HasHeaders x where
getHeaders :: x -> [Header]
setHeaders :: x -> [Header] -> x
insertHeader, replaceHeader, insertHeaderIfMissing
:: HasHeaders a => HeaderName -> String -> a -> a
insertHeader name value x = setHeaders x newHeaders
where
newHeaders = (Header name value) : getHeaders x
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 name value x = setHeaders x newHeaders
where
newHeaders = Header name value : [ x | x@(Header n v) <- getHeaders x, name /= n ]
insertHeaders :: HasHeaders a => [Header] -> a -> a
insertHeaders hdrs x = setHeaders x (getHeaders x ++ hdrs)
retrieveHeaders :: HasHeaders a => HeaderName -> a -> [Header]
retrieveHeaders name x = filter matchname (getHeaders x)
where
matchname (Header n _) | n == name = True
matchname _ = False
findHeader :: HasHeaders a => HeaderName -> a -> Maybe String
findHeader n x = lookupHeader n (getHeaders x)
lookupHeader :: HeaderName -> [Header] -> Maybe String
lookupHeader v (Header n s:t) | v == n = Just s
| otherwise = lookupHeader v t
lookupHeader _ _ = Nothing
parseHeader :: String -> Result Header
parseHeader str =
case split ':' str of
Nothing -> Left (ErrorParse $ "Unable to parse header: " ++ str)
Just (k,v) -> Right $ 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 :: [String] -> Result [Header]
parseHeaders =
catRslts [] . map (parseHeader . clean) . joinExtended ""
where
joinExtended old (h : t)
| not (null h) && (head h == ' ' || head h == '\t')
= joinExtended (old ++ ' ' : tail h) t
| otherwise = old : joinExtended h t
joinExtended old [] = [old]
clean [] = []
clean (h:t) | h `elem` "\t\r\n" = ' ' : clean t
| otherwise = h : clean t
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