{- |
Module:        Network.Monad.HTTP.Header
Copyright:     (c) 2009 Henning Thielemann
License:       BSD

Stability:     experimental
Portability:   non-portable (not tested)

Provide the functionality of "Network.HTTP.Headers"
with qualified identifier style.
-}
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


{-
class IsHeader h where
   toHeader   :: h -> Hdrs.Header
   fromHeader :: Hdrs.Header -> h

instance IsHeader Hdrs.Header where
   toHeader   = id
   fromHeader = id

instance IsHeader h => HasHeaders [h] where
   setHeaders _ = map fromHeader
   getHeaders   = map toHeader
-}


cons :: Name -> String -> T
cons :: Name -> String -> T
cons = Name -> String -> T
Hdrs.Header

-- an Accessor would be even nicer
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


-- Header manipulation functions
insert, replace, insertIfMissing :: HasHeaders a =>
   Name -> String -> a -> a


-- | Inserts a header with the given name and value.
-- Allows duplicate header names.
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]
:)

-- | Adds the new header only if no previous header shares
-- the same name.
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

-- | Removes old headers with duplicate name.
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)

-- | Inserts multiple headers.
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)

-- | Gets a list of headers with a particular 'Name'.
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


-- | Lookup presence of specific Name in a list of Headers
-- Returns the value from the first matching header.
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 =
   {- mapM (strict on errors) vs. catMaybes (tolerant of errors)?
      Should parse errors here be reported or ignored?
      Currently ignored. -}
   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

-- | Joins consecutive lines where the second line
-- begins with ' ' or '\t'.
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))
      []