X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FHeaders.hs;h=a5808838990efb9ea501b95b1770a19890273e20;hb=858129cb755aa09da2b7bd758efb8519f2c89103;hp=655252cc4b656c39abcb92252a276ffc1d94e638;hpb=3c7a58ab749a55a30466a033b170536bcdf18b98;p=Lucu.git

diff --git a/Network/HTTP/Lucu/Headers.hs b/Network/HTTP/Lucu/Headers.hs
index 655252c..a580883 100644
--- a/Network/HTTP/Lucu/Headers.hs
+++ b/Network/HTTP/Lucu/Headers.hs
@@ -1,9 +1,10 @@
+-- #hide
 module Network.HTTP.Lucu.Headers
     ( Headers
     , HasHeaders(..)
-    , emptyHeaders -- Headers
-    , headersP     -- Parser Headers
-    , hPutHeaders  -- Handle -> Headers -> IO ()
+    , emptyHeaders
+    , headersP
+    , hPutHeaders
     )
     where
 
@@ -20,22 +21,26 @@ class HasHeaders a 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
@@ -77,16 +82,26 @@ headersP = do xs <- many header
       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"