module Network.HTTP.Lucu.Headers
( Headers
, HasHeaders(..)
- , emptyHeaders -- Headers
- , headersP -- Parser Headers
- , hPutHeaders -- Handle -> Headers -> IO ()
+ , emptyHeaders
+ , headersP
+ , hPutHeaders
)
where
getHeaders :: a -> Headers
setHeaders :: a -> Headers -> a
- getHeader :: a -> String -> Maybe String
- getHeader a key
- = fmap snd $ find (noCaseEq key . fst) (getHeaders a)
+ getHeader :: String -> a -> Maybe String
+ getHeader key a
+ = key `seq` a `seq`
+ fmap snd $ find (noCaseEq' key . fst) (getHeaders a)
- deleteHeader :: a -> String -> a
- deleteHeader a key
- = setHeaders a $ filter (not . noCaseEq key . fst) (getHeaders a)
+ deleteHeader :: String -> a -> a
+ deleteHeader key a
+ = key `seq` a `seq`
+ setHeaders a $ filter (not . noCaseEq' key . fst) (getHeaders a)
- addHeader :: a -> String -> String -> a
- addHeader a key val
- = setHeaders a $ (getHeaders a) ++ [(key, val)]
+ addHeader :: String -> String -> a -> a
+ addHeader key val a
+ = key `seq` val `seq` a `seq`
+ setHeaders a $ (getHeaders a) ++ [(key, val)]
- setHeader :: a -> String -> String -> a
- setHeader a key val
- = let list = getHeaders a
- deleted = filter (not . noCaseEq key . fst) list
+ setHeader :: String -> String -> a -> a
+ setHeader key val a
+ = key `seq` val `seq` a `seq`
+ let list = getHeaders a
+ deleted = filter (not . noCaseEq' key . fst) list
added = deleted ++ [(key, val)]
in
setHeaders a added
normalize :: String -> String
normalize = trimBody . trim isWhiteSpace
- trimBody = nubBy (\ a b -> a == ' ' && b == ' ')
+ trimBody = foldr (++) []
+ . map (\ s -> if head s == ' ' then
+ " "
+ else
+ s)
+ . group
. map (\ c -> if isWhiteSpace c
then ' '
else c)
hPutHeaders :: Handle -> Headers -> IO ()
-hPutHeaders h hds = mapM_ putH hds >> hPutStr h "\r\n"
+hPutHeaders h hds
+ = h `seq` hds `seq`
+ mapM_ putH hds >> hPutStr h "\r\n"
where
- putH (name, value) = do hPutStr h name
- hPutStr h ": "
- hPutStr h value
- hPutStr h "\r\n"
+ putH :: (String, String) -> IO ()
+ putH (name, value)
+ = name `seq` value `seq`
+ do hPutStr h name
+ hPutStr h ": "
+ hPutStr h value
+ hPutStr h "\r\n"