module Network.HTTP.Headers
( HasHeaders(..)
, Header(..)
, mkHeader
, hdrName
, hdrValue
, HeaderName(..)
, insertHeader
, insertHeaderIfMissing
, insertHeaders
, retrieveHeaders
, replaceHeader
, findHeader
, lookupHeader
, parseHeader
, parseHeaders
, headerMap
, HeaderSetter
) where
import Data.Char (toLower)
import Network.Stream (Result, failParse)
import Network.HTTP.Utils ( trim, split, crlf )
data = HeaderName String
hdrName :: Header -> HeaderName
hdrName :: Header -> HeaderName
hdrName (Header HeaderName
h String
_) = HeaderName
h
hdrValue :: Header -> String
hdrValue :: Header -> String
hdrValue (Header HeaderName
_ String
v) = String
v
mkHeader :: HeaderName -> String -> Header
= HeaderName -> String -> Header
Header
instance Show Header where
show :: Header -> String
show (Header HeaderName
key String
value) = HeaderName -> ShowS
forall a. Show a => a -> ShowS
shows HeaderName
key (Char
':'Char -> ShowS
forall a. a -> [a] -> [a]
:Char
' 'Char -> ShowS
forall a. a -> [a] -> [a]
:String
value String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
crlf)
data
= 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
| HdrTE
| HdrTrailer
| HdrVary
| HdrWarning
| HdrWWWAuthenticate
| HdrAllow
| HdrContentBase
| HdrContentEncoding
| HdrContentLanguage
| HdrContentLength
| HdrContentLocation
| HdrContentMD5
| HdrContentRange
| HdrContentType
| HdrETag
| HdrExpires
| HdrLastModified
| HdrContentTransferEncoding
| HdrCustom String
deriving(HeaderName -> HeaderName -> Bool
(HeaderName -> HeaderName -> Bool)
-> (HeaderName -> HeaderName -> Bool) -> Eq HeaderName
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: HeaderName -> HeaderName -> Bool
$c/= :: HeaderName -> HeaderName -> Bool
== :: HeaderName -> HeaderName -> Bool
$c== :: HeaderName -> HeaderName -> Bool
Eq)
headerMap :: [ (String,HeaderName) ]
=
[ String -> HeaderName -> (String, HeaderName)
forall a b. a -> b -> (a, b)
p String
"Cache-Control" HeaderName
HdrCacheControl
, String -> HeaderName -> (String, HeaderName)
forall a b. a -> b -> (a, b)
p String
"Connection" HeaderName
HdrConnection
, String -> HeaderName -> (String, HeaderName)
forall a b. a -> b -> (a, b)
p String
"Date" HeaderName
HdrDate
, String -> HeaderName -> (String, HeaderName)
forall a b. a -> b -> (a, b)
p String
"Pragma" HeaderName
HdrPragma
, String -> HeaderName -> (String, HeaderName)
forall a b. a -> b -> (a, b)
p String
"Transfer-Encoding" HeaderName
HdrTransferEncoding
, String -> HeaderName -> (String, HeaderName)
forall a b. a -> b -> (a, b)
p String
"Upgrade" HeaderName
HdrUpgrade
, String -> HeaderName -> (String, HeaderName)
forall a b. a -> b -> (a, b)
p String
"Via" HeaderName
HdrVia
, String -> HeaderName -> (String, HeaderName)
forall a b. a -> b -> (a, b)
p String
"Accept" HeaderName
HdrAccept
, String -> HeaderName -> (String, HeaderName)
forall a b. a -> b -> (a, b)
p String
"Accept-Charset" HeaderName
HdrAcceptCharset
, String -> HeaderName -> (String, HeaderName)
forall a b. a -> b -> (a, b)
p String
"Accept-Encoding" HeaderName
HdrAcceptEncoding
, String -> HeaderName -> (String, HeaderName)
forall a b. a -> b -> (a, b)
p String
"Accept-Language" HeaderName
HdrAcceptLanguage
, String -> HeaderName -> (String, HeaderName)
forall a b. a -> b -> (a, b)
p String
"Authorization" HeaderName
HdrAuthorization
, String -> HeaderName -> (String, HeaderName)
forall a b. a -> b -> (a, b)
p String
"Cookie" HeaderName
HdrCookie
, String -> HeaderName -> (String, HeaderName)
forall a b. a -> b -> (a, b)
p String
"Expect" HeaderName
HdrExpect
, String -> HeaderName -> (String, HeaderName)
forall a b. a -> b -> (a, b)
p String
"From" HeaderName
HdrFrom
, String -> HeaderName -> (String, HeaderName)
forall a b. a -> b -> (a, b)
p String
"Host" HeaderName
HdrHost
, String -> HeaderName -> (String, HeaderName)
forall a b. a -> b -> (a, b)
p String
"If-Modified-Since" HeaderName
HdrIfModifiedSince
, String -> HeaderName -> (String, HeaderName)
forall a b. a -> b -> (a, b)
p String
"If-Match" HeaderName
HdrIfMatch
, String -> HeaderName -> (String, HeaderName)
forall a b. a -> b -> (a, b)
p String
"If-None-Match" HeaderName
HdrIfNoneMatch
, String -> HeaderName -> (String, HeaderName)
forall a b. a -> b -> (a, b)
p String
"If-Range" HeaderName
HdrIfRange
, String -> HeaderName -> (String, HeaderName)
forall a b. a -> b -> (a, b)
p String
"If-Unmodified-Since" HeaderName
HdrIfUnmodifiedSince
, String -> HeaderName -> (String, HeaderName)
forall a b. a -> b -> (a, b)
p String
"Max-Forwards" HeaderName
HdrMaxForwards
, String -> HeaderName -> (String, HeaderName)
forall a b. a -> b -> (a, b)
p String
"Proxy-Authorization" HeaderName
HdrProxyAuthorization
, String -> HeaderName -> (String, HeaderName)
forall a b. a -> b -> (a, b)
p String
"Range" HeaderName
HdrRange
, String -> HeaderName -> (String, HeaderName)
forall a b. a -> b -> (a, b)
p String
"Referer" HeaderName
HdrReferer
, String -> HeaderName -> (String, HeaderName)
forall a b. a -> b -> (a, b)
p String
"User-Agent" HeaderName
HdrUserAgent
, String -> HeaderName -> (String, HeaderName)
forall a b. a -> b -> (a, b)
p String
"Age" HeaderName
HdrAge
, String -> HeaderName -> (String, HeaderName)
forall a b. a -> b -> (a, b)
p String
"Location" HeaderName
HdrLocation
, String -> HeaderName -> (String, HeaderName)
forall a b. a -> b -> (a, b)
p String
"Proxy-Authenticate" HeaderName
HdrProxyAuthenticate
, String -> HeaderName -> (String, HeaderName)
forall a b. a -> b -> (a, b)
p String
"Public" HeaderName
HdrPublic
, String -> HeaderName -> (String, HeaderName)
forall a b. a -> b -> (a, b)
p String
"Retry-After" HeaderName
HdrRetryAfter
, String -> HeaderName -> (String, HeaderName)
forall a b. a -> b -> (a, b)
p String
"Server" HeaderName
HdrServer
, String -> HeaderName -> (String, HeaderName)
forall a b. a -> b -> (a, b)
p String
"Set-Cookie" HeaderName
HdrSetCookie
, String -> HeaderName -> (String, HeaderName)
forall a b. a -> b -> (a, b)
p String
"TE" HeaderName
HdrTE
, String -> HeaderName -> (String, HeaderName)
forall a b. a -> b -> (a, b)
p String
"Trailer" HeaderName
HdrTrailer
, String -> HeaderName -> (String, HeaderName)
forall a b. a -> b -> (a, b)
p String
"Vary" HeaderName
HdrVary
, String -> HeaderName -> (String, HeaderName)
forall a b. a -> b -> (a, b)
p String
"Warning" HeaderName
HdrWarning
, String -> HeaderName -> (String, HeaderName)
forall a b. a -> b -> (a, b)
p String
"WWW-Authenticate" HeaderName
HdrWWWAuthenticate
, String -> HeaderName -> (String, HeaderName)
forall a b. a -> b -> (a, b)
p String
"Allow" HeaderName
HdrAllow
, String -> HeaderName -> (String, HeaderName)
forall a b. a -> b -> (a, b)
p String
"Content-Base" HeaderName
HdrContentBase
, String -> HeaderName -> (String, HeaderName)
forall a b. a -> b -> (a, b)
p String
"Content-Encoding" HeaderName
HdrContentEncoding
, String -> HeaderName -> (String, HeaderName)
forall a b. a -> b -> (a, b)
p String
"Content-Language" HeaderName
HdrContentLanguage
, String -> HeaderName -> (String, HeaderName)
forall a b. a -> b -> (a, b)
p String
"Content-Length" HeaderName
HdrContentLength
, String -> HeaderName -> (String, HeaderName)
forall a b. a -> b -> (a, b)
p String
"Content-Location" HeaderName
HdrContentLocation
, String -> HeaderName -> (String, HeaderName)
forall a b. a -> b -> (a, b)
p String
"Content-MD5" HeaderName
HdrContentMD5
, String -> HeaderName -> (String, HeaderName)
forall a b. a -> b -> (a, b)
p String
"Content-Range" HeaderName
HdrContentRange
, String -> HeaderName -> (String, HeaderName)
forall a b. a -> b -> (a, b)
p String
"Content-Type" HeaderName
HdrContentType
, String -> HeaderName -> (String, HeaderName)
forall a b. a -> b -> (a, b)
p String
"ETag" HeaderName
HdrETag
, String -> HeaderName -> (String, HeaderName)
forall a b. a -> b -> (a, b)
p String
"Expires" HeaderName
HdrExpires
, String -> HeaderName -> (String, HeaderName)
forall a b. a -> b -> (a, b)
p String
"Last-Modified" HeaderName
HdrLastModified
, String -> HeaderName -> (String, HeaderName)
forall a b. a -> b -> (a, b)
p String
"Content-Transfer-Encoding" HeaderName
HdrContentTransferEncoding
]
where
p :: a -> b -> (a, b)
p a
a b
b = (a
a,b
b)
instance Show HeaderName where
show :: HeaderName -> String
show (HdrCustom String
s) = String
s
show HeaderName
x = case ((String, HeaderName) -> Bool)
-> [(String, HeaderName)] -> [(String, HeaderName)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
==HeaderName
x)(HeaderName -> Bool)
-> ((String, HeaderName) -> HeaderName)
-> (String, HeaderName)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(String, HeaderName) -> HeaderName
forall a b. (a, b) -> b
snd) [(String, HeaderName)]
headerMap of
[] -> ShowS
forall a. HasCallStack => String -> a
error String
"headerMap incomplete"
((String, HeaderName)
h:[(String, HeaderName)]
_) -> (String, HeaderName) -> String
forall a b. (a, b) -> a
fst (String, HeaderName)
h
class x where
:: x -> [Header]
:: x -> [Header] -> x
type a = HeaderName -> String -> a -> a
insertHeader :: HasHeaders a => HeaderSetter a
HeaderName
name String
value a
x = a -> [Header] -> a
forall x. HasHeaders x => x -> [Header] -> x
setHeaders a
x [Header]
newHeaders
where
newHeaders :: [Header]
newHeaders = (HeaderName -> String -> Header
Header HeaderName
name String
value) Header -> [Header] -> [Header]
forall a. a -> [a] -> [a]
: a -> [Header]
forall x. HasHeaders x => x -> [Header]
getHeaders a
x
insertHeaderIfMissing :: HasHeaders a => HeaderSetter a
HeaderName
name String
value a
x = a -> [Header] -> a
forall x. HasHeaders x => x -> [Header] -> x
setHeaders a
x ([Header] -> [Header]
newHeaders ([Header] -> [Header]) -> [Header] -> [Header]
forall a b. (a -> b) -> a -> b
$ a -> [Header]
forall x. HasHeaders x => x -> [Header]
getHeaders a
x)
where
newHeaders :: [Header] -> [Header]
newHeaders list :: [Header]
list@(h :: Header
h@(Header HeaderName
n String
_): [Header]
rest)
| HeaderName
n HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderName
name = [Header]
list
| Bool
otherwise = Header
h Header -> [Header] -> [Header]
forall a. a -> [a] -> [a]
: [Header] -> [Header]
newHeaders [Header]
rest
newHeaders [] = [HeaderName -> String -> Header
Header HeaderName
name String
value]
replaceHeader :: HasHeaders a => HeaderSetter a
HeaderName
name String
value a
h = a -> [Header] -> a
forall x. HasHeaders x => x -> [Header] -> x
setHeaders a
h [Header]
newHeaders
where
newHeaders :: [Header]
newHeaders = HeaderName -> String -> Header
Header HeaderName
name String
value Header -> [Header] -> [Header]
forall a. a -> [a] -> [a]
: [ Header
x | x :: Header
x@(Header HeaderName
n String
_) <- a -> [Header]
forall x. HasHeaders x => x -> [Header]
getHeaders a
h, HeaderName
name HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
/= HeaderName
n ]
insertHeaders :: HasHeaders a => [Header] -> a -> a
[Header]
hdrs a
x = a -> [Header] -> a
forall x. HasHeaders x => x -> [Header] -> x
setHeaders a
x (a -> [Header]
forall x. HasHeaders x => x -> [Header]
getHeaders a
x [Header] -> [Header] -> [Header]
forall a. [a] -> [a] -> [a]
++ [Header]
hdrs)
retrieveHeaders :: HasHeaders a => HeaderName -> a -> [Header]
HeaderName
name a
x = (Header -> Bool) -> [Header] -> [Header]
forall a. (a -> Bool) -> [a] -> [a]
filter Header -> Bool
matchname (a -> [Header]
forall x. HasHeaders x => x -> [Header]
getHeaders a
x)
where
matchname :: Header -> Bool
matchname (Header HeaderName
n String
_) = HeaderName
n HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderName
name
findHeader :: HasHeaders a => HeaderName -> a -> Maybe String
HeaderName
n a
x = HeaderName -> [Header] -> Maybe String
lookupHeader HeaderName
n (a -> [Header]
forall x. HasHeaders x => x -> [Header]
getHeaders a
x)
lookupHeader :: HeaderName -> [Header] -> Maybe String
HeaderName
_ [] = Maybe String
forall a. Maybe a
Nothing
lookupHeader HeaderName
v (Header HeaderName
n String
s:[Header]
t)
| HeaderName
v HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderName
n = String -> Maybe String
forall a. a -> Maybe a
Just String
s
| Bool
otherwise = HeaderName -> [Header] -> Maybe String
lookupHeader HeaderName
v [Header]
t
parseHeader :: String -> Result Header
String
str =
case Char -> String -> Maybe (String, String)
forall a. Eq a => a -> [a] -> Maybe ([a], [a])
split Char
':' String
str of
Maybe (String, String)
Nothing -> String -> Result Header
forall a. String -> Result a
failParse (String
"Unable to parse header: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
str)
Just (String
k,String
v) -> Header -> Result Header
forall (m :: * -> *) a. Monad m => a -> m a
return (Header -> Result Header) -> Header -> Result Header
forall a b. (a -> b) -> a -> b
$ HeaderName -> String -> Header
Header (String -> HeaderName
fn String
k) (ShowS
trim ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Int -> ShowS
forall a. Int -> [a] -> [a]
drop Int
1 String
v)
where
fn :: String -> HeaderName
fn String
k = case ((String, HeaderName) -> HeaderName)
-> [(String, HeaderName)] -> [HeaderName]
forall a b. (a -> b) -> [a] -> [b]
map (String, HeaderName) -> HeaderName
forall a b. (a, b) -> b
snd ([(String, HeaderName)] -> [HeaderName])
-> [(String, HeaderName)] -> [HeaderName]
forall a b. (a -> b) -> a -> b
$ ((String, HeaderName) -> Bool)
-> [(String, HeaderName)] -> [(String, HeaderName)]
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> String -> Bool
match String
k (String -> Bool)
-> ((String, HeaderName) -> String) -> (String, HeaderName) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, HeaderName) -> String
forall a b. (a, b) -> a
fst) [(String, HeaderName)]
headerMap of
[] -> (String -> HeaderName
HdrCustom String
k)
(HeaderName
h:[HeaderName]
_) -> HeaderName
h
match :: String -> String -> Bool
match :: String -> String -> Bool
match String
s1 String
s2 = (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
s1 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
s2
parseHeaders :: [String] -> Result [Header]
= [Header] -> [Result Header] -> Result [Header]
forall a. [a] -> [Result a] -> Result [a]
catRslts [] ([Result Header] -> Result [Header])
-> ([String] -> [Result Header]) -> [String] -> Result [Header]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
(String -> Result Header) -> [String] -> [Result Header]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Result Header
parseHeader (String -> Result Header) -> ShowS -> String -> Result Header
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
clean) ([String] -> [Result Header])
-> ([String] -> [String]) -> [String] -> [Result Header]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
String -> [String] -> [String]
joinExtended String
""
where
joinExtended :: String -> [String] -> [String]
joinExtended String
old [] = [String
old]
joinExtended String
old (String
h : [String]
t)
| String -> Bool
isLineExtension String
h = String -> [String] -> [String]
joinExtended (String
old String -> ShowS
forall a. [a] -> [a] -> [a]
++ Char
' ' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
forall a. [a] -> [a]
tail String
h) [String]
t
| Bool
otherwise = String
old String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String -> [String] -> [String]
joinExtended String
h [String]
t
isLineExtension :: String -> Bool
isLineExtension (Char
x:String
_) = Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ' Bool -> Bool -> Bool
|| Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\t'
isLineExtension String
_ = Bool
False
clean :: ShowS
clean [] = []
clean (Char
h:String
t) | Char
h Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
"\t\r\n" = Char
' ' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
clean String
t
| Bool
otherwise = Char
h Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
clean String
t
catRslts :: [a] -> [Result a] -> Result [a]
catRslts :: [a] -> [Result a] -> Result [a]
catRslts [a]
list (Result a
h:[Result a]
t) =
case Result a
h of
Left ConnError
_ -> [a] -> [Result a] -> Result [a]
forall a. [a] -> [Result a] -> Result [a]
catRslts [a]
list [Result a]
t
Right a
v -> [a] -> [Result a] -> Result [a]
forall a. [a] -> [Result a] -> Result [a]
catRslts (a
va -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
list) [Result a]
t
catRslts [a]
list [] = [a] -> Result [a]
forall a b. b -> Either a b
Right ([a] -> Result [a]) -> [a] -> Result [a]
forall a b. (a -> b) -> a -> b
$ [a] -> [a]
forall a. [a] -> [a]
reverse [a]
list