module Network.Monad.HTTP.Header (
Hdrs.HasHeaders(..),
T, Hdrs.Header(..), cons,
Name, Hdrs.HeaderName(..), consName,
getName, getValue,
setMany, getMany, modifyMany,
insert, insertMany,
insertIfMissing,
retrieveMany,
replace,
find, findMany, lookup,
parse,
parseManyWarn,
parseManyStraight,
dictionary,
matchName,
) where
import qualified Network.HTTP.Headers as Hdrs
import Network.HTTP.Headers (HasHeaders(..), )
import Data.String.HT (trim, )
import qualified Control.Monad.Exception.Synchronous as Sync
import qualified Data.Map as Map
import Data.Char (toLower, )
import Data.Tuple.HT (mapFst, )
import Data.Maybe.HT (toMaybe, )
import Data.Maybe (mapMaybe, listToMaybe, )
import Prelude hiding (lookup, )
type T = Hdrs.Header
type Name = Hdrs.HeaderName
cons :: Name -> String -> T
cons :: Name -> String -> T
cons = Name -> String -> T
Hdrs.Header
getName :: T -> Name
getName :: T -> Name
getName (Hdrs.Header Name
name String
_value) = Name
name
getValue :: T -> String
getValue :: T -> String
getValue (Hdrs.Header Name
_name String
value) = String
value
dictionary :: Map.Map String Name
dictionary :: Map String Name
dictionary =
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$
forall a b. (a -> b) -> [a] -> [b]
map (forall a c b. (a -> c) -> (a, b) -> (c, b)
mapFst (forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower)) forall a b. (a -> b) -> a -> b
$
(String
"Cache-Control" , Name
Hdrs.HdrCacheControl ) forall a. a -> [a] -> [a]
:
(String
"Connection" , Name
Hdrs.HdrConnection ) forall a. a -> [a] -> [a]
:
(String
"Date" , Name
Hdrs.HdrDate ) forall a. a -> [a] -> [a]
:
(String
"Pragma" , Name
Hdrs.HdrPragma ) forall a. a -> [a] -> [a]
:
(String
"Transfer-Encoding" , Name
Hdrs.HdrTransferEncoding ) forall a. a -> [a] -> [a]
:
(String
"Upgrade" , Name
Hdrs.HdrUpgrade ) forall a. a -> [a] -> [a]
:
(String
"Via" , Name
Hdrs.HdrVia ) forall a. a -> [a] -> [a]
:
(String
"Accept" , Name
Hdrs.HdrAccept ) forall a. a -> [a] -> [a]
:
(String
"Accept-Charset" , Name
Hdrs.HdrAcceptCharset ) forall a. a -> [a] -> [a]
:
(String
"Accept-Encoding" , Name
Hdrs.HdrAcceptEncoding ) forall a. a -> [a] -> [a]
:
(String
"Accept-Language" , Name
Hdrs.HdrAcceptLanguage ) forall a. a -> [a] -> [a]
:
(String
"Authorization" , Name
Hdrs.HdrAuthorization ) forall a. a -> [a] -> [a]
:
(String
"From" , Name
Hdrs.HdrFrom ) forall a. a -> [a] -> [a]
:
(String
"Host" , Name
Hdrs.HdrHost ) forall a. a -> [a] -> [a]
:
(String
"If-Modified-Since" , Name
Hdrs.HdrIfModifiedSince ) forall a. a -> [a] -> [a]
:
(String
"If-Match" , Name
Hdrs.HdrIfMatch ) forall a. a -> [a] -> [a]
:
(String
"If-None-Match" , Name
Hdrs.HdrIfNoneMatch ) forall a. a -> [a] -> [a]
:
(String
"If-Range" , Name
Hdrs.HdrIfRange ) forall a. a -> [a] -> [a]
:
(String
"If-Unmodified-Since" , Name
Hdrs.HdrIfUnmodifiedSince ) forall a. a -> [a] -> [a]
:
(String
"Max-Forwards" , Name
Hdrs.HdrMaxForwards ) forall a. a -> [a] -> [a]
:
(String
"Proxy-Authorization" , Name
Hdrs.HdrProxyAuthorization) forall a. a -> [a] -> [a]
:
(String
"Range" , Name
Hdrs.HdrRange ) forall a. a -> [a] -> [a]
:
(String
"Referer" , Name
Hdrs.HdrReferer ) forall a. a -> [a] -> [a]
:
(String
"User-Agent" , Name
Hdrs.HdrUserAgent ) forall a. a -> [a] -> [a]
:
(String
"Age" , Name
Hdrs.HdrAge ) forall a. a -> [a] -> [a]
:
(String
"Location" , Name
Hdrs.HdrLocation ) forall a. a -> [a] -> [a]
:
(String
"Proxy-Authenticate" , Name
Hdrs.HdrProxyAuthenticate ) forall a. a -> [a] -> [a]
:
(String
"Public" , Name
Hdrs.HdrPublic ) forall a. a -> [a] -> [a]
:
(String
"Retry-After" , Name
Hdrs.HdrRetryAfter ) forall a. a -> [a] -> [a]
:
(String
"Server" , Name
Hdrs.HdrServer ) forall a. a -> [a] -> [a]
:
(String
"Vary" , Name
Hdrs.HdrVary ) forall a. a -> [a] -> [a]
:
(String
"Warning" , Name
Hdrs.HdrWarning ) forall a. a -> [a] -> [a]
:
(String
"WWW-Authenticate" , Name
Hdrs.HdrWWWAuthenticate ) forall a. a -> [a] -> [a]
:
(String
"Allow" , Name
Hdrs.HdrAllow ) forall a. a -> [a] -> [a]
:
(String
"Content-Base" , Name
Hdrs.HdrContentBase ) forall a. a -> [a] -> [a]
:
(String
"Content-Encoding" , Name
Hdrs.HdrContentEncoding ) forall a. a -> [a] -> [a]
:
(String
"Content-Language" , Name
Hdrs.HdrContentLanguage ) forall a. a -> [a] -> [a]
:
(String
"Content-Length" , Name
Hdrs.HdrContentLength ) forall a. a -> [a] -> [a]
:
(String
"Content-Location" , Name
Hdrs.HdrContentLocation ) forall a. a -> [a] -> [a]
:
(String
"Content-MD5" , Name
Hdrs.HdrContentMD5 ) forall a. a -> [a] -> [a]
:
(String
"Content-Range" , Name
Hdrs.HdrContentRange ) forall a. a -> [a] -> [a]
:
(String
"Content-Type" , Name
Hdrs.HdrContentType ) forall a. a -> [a] -> [a]
:
(String
"ETag" , Name
Hdrs.HdrETag ) forall a. a -> [a] -> [a]
:
(String
"Expires" , Name
Hdrs.HdrExpires ) forall a. a -> [a] -> [a]
:
(String
"Last-Modified" , Name
Hdrs.HdrLastModified ) forall a. a -> [a] -> [a]
:
(String
"Set-Cookie" , Name
Hdrs.HdrSetCookie ) forall a. a -> [a] -> [a]
:
(String
"Cookie" , Name
Hdrs.HdrCookie ) forall a. a -> [a] -> [a]
:
(String
"Expect" , Name
Hdrs.HdrExpect ) forall a. a -> [a] -> [a]
:
[]
setMany :: (HasHeaders x) => x -> [T] -> x
setMany :: forall x. HasHeaders x => x -> [T] -> x
setMany = forall x. HasHeaders x => x -> [T] -> x
Hdrs.setHeaders
getMany :: (HasHeaders x) => x -> [T]
getMany :: forall x. HasHeaders x => x -> [T]
getMany = forall x. HasHeaders x => x -> [T]
Hdrs.getHeaders
modifyMany :: (HasHeaders x) => ([T] -> [T]) -> x -> x
modifyMany :: forall x. HasHeaders x => ([T] -> [T]) -> x -> x
modifyMany [T] -> [T]
f x
x =
forall x. HasHeaders x => x -> [T] -> x
setMany x
x forall a b. (a -> b) -> a -> b
$ [T] -> [T]
f forall a b. (a -> b) -> a -> b
$ forall x. HasHeaders x => x -> [T]
getMany x
x
consName :: String -> Name
consName :: String -> Name
consName String
k =
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault (String -> Name
Hdrs.HdrCustom String
k) (forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
k) Map String Name
dictionary
insert, replace, insertIfMissing :: HasHeaders a =>
Name -> String -> a -> a
insert :: forall a. HasHeaders a => Name -> String -> a -> a
insert Name
name String
value = forall x. HasHeaders x => ([T] -> [T]) -> x -> x
modifyMany (Name -> String -> T
cons Name
name String
value forall a. a -> [a] -> [a]
:)
insertIfMissing :: forall a. HasHeaders a => Name -> String -> a -> a
insertIfMissing Name
name String
value =
let newHeaders :: [T] -> [T]
newHeaders list :: [T]
list@(T
h : [T]
rest) =
if Name -> T -> Bool
matchName Name
name T
h
then [T]
list
else T
h forall a. a -> [a] -> [a]
: [T] -> [T]
newHeaders [T]
rest
newHeaders [] = [Name -> String -> T
cons Name
name String
value]
in forall x. HasHeaders x => ([T] -> [T]) -> x -> x
modifyMany [T] -> [T]
newHeaders
replace :: forall a. HasHeaders a => Name -> String -> a -> a
replace Name
name String
value =
forall x. HasHeaders x => ([T] -> [T]) -> x -> x
modifyMany forall a b. (a -> b) -> a -> b
$
(Name -> String -> T
cons Name
name String
value forall a. a -> [a] -> [a]
:) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> T -> Bool
matchName Name
name)
insertMany :: HasHeaders a => [T] -> a -> a
insertMany :: forall a. HasHeaders a => [T] -> a -> a
insertMany [T]
hdrs = forall x. HasHeaders x => ([T] -> [T]) -> x -> x
modifyMany (forall a. [a] -> [a] -> [a]
++ [T]
hdrs)
retrieveMany :: HasHeaders a => Name -> a -> [T]
retrieveMany :: forall a. HasHeaders a => Name -> a -> [T]
retrieveMany Name
name = forall a. (a -> Bool) -> [a] -> [a]
filter (Name -> T -> Bool
matchName Name
name) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall x. HasHeaders x => x -> [T]
getMany
matchName :: Name -> T -> Bool
matchName :: Name -> T -> Bool
matchName Name
name T
h = Name
name forall a. Eq a => a -> a -> Bool
== T -> Name
getName T
h
find :: HasHeaders a => Name -> a -> Maybe String
find :: forall a. HasHeaders a => Name -> a -> Maybe String
find Name
n = forall a. [a] -> Maybe a
listToMaybe forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HasHeaders a => Name -> a -> [String]
findMany Name
n
findMany :: HasHeaders a => Name -> a -> [String]
findMany :: forall a. HasHeaders a => Name -> a -> [String]
findMany Name
n =
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\T
h -> forall a. Bool -> a -> Maybe a
toMaybe (Name -> T -> Bool
matchName Name
n T
h) (T -> String
getValue T
h)) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall x. HasHeaders x => x -> [T]
getMany
{-# DEPRECATED lookup "Call 'find' using the [Header] instance of HasHeaders" #-}
lookup :: Name -> [T] -> Maybe String
lookup :: Name -> [T] -> Maybe String
lookup Name
n =
forall a. [a] -> Maybe a
listToMaybe forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\T
h -> forall a. Bool -> a -> Maybe a
toMaybe (Name -> T -> Bool
matchName Name
n T
h) (T -> String
getValue T
h))
parse :: String -> Sync.Exceptional String T
parse :: String -> Exceptional String T
parse String
str =
case forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char
':'forall a. Eq a => a -> a -> Bool
==) String
str of
(String
k,Char
':':String
v) -> forall e a. a -> Exceptional e a
Sync.Success forall a b. (a -> b) -> a -> b
$ Name -> String -> T
cons (String -> Name
consName String
k) (String -> String
trim String
v)
(String, String)
_ -> forall e a. e -> Exceptional e a
Sync.Exception forall a b. (a -> b) -> a -> b
$ String
"Unable to parse header: " forall a. [a] -> [a] -> [a]
++ String
str
parseManyWarn :: [String] -> [Sync.Exceptional String T]
parseManyWarn :: [String] -> [Exceptional String T]
parseManyWarn =
let clean :: String -> String
clean = forall a b. (a -> b) -> [a] -> [b]
map (\Char
h -> if Char
h forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
"\t\r\n" then Char
' ' else Char
h)
in forall a b. (a -> b) -> [a] -> [b]
map (String -> Exceptional String T
parse forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
clean) forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [String]
joinExtended
parseManyStraight :: [String] -> [T]
parseManyStraight :: [String] -> [T]
parseManyStraight =
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a. Exceptional e a -> Either e a
Sync.toEither) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
[String] -> [Exceptional String T]
parseManyWarn
joinExtended :: [String] -> [String]
joinExtended :: [String] -> [String]
joinExtended =
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
(\String
h0 [String]
next ->
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (:) forall a b. (a -> b) -> a -> b
$
forall a c b. (a -> c) -> (a, b) -> (c, b)
mapFst (String
h0forall a. [a] -> [a] -> [a]
++) forall a b. (a -> b) -> a -> b
$
let join :: String -> b -> (String, b)
join String
line b
rest = (Char
' ' forall a. a -> [a] -> [a]
: String
line, b
rest)
in case [String]
next of
((Char
' ' :String
line):[String]
rest) -> forall {b}. String -> b -> (String, b)
join String
line [String]
rest
((Char
'\t':String
line):[String]
rest) -> forall {b}. String -> b -> (String, b)
join String
line [String]
rest
[String]
_ -> (String
"", [String]
next))
[]