Moved hidden modules from Exposed-Modules to Other-Modules.

[Lucu.git] / Network / HTTP / Lucu / Headers.hs

diff --git a/Network/HTTP/Lucu/Headers.hs b/Network/HTTP/Lucu/Headers.hs
index 7936f0435fe575c64e0faf2ba5980cf6b70913d4..65a4940026d5b626d4a11bbec50449d101745256 100644 (file)
--- a/Network/HTTP/Lucu/Headers.hs
+++ b/Network/HTTP/Lucu/Headers.hs
@@ -1,9 +1,9 @@
 module Network.HTTP.Lucu.Headers
     ( Headers
     , HasHeaders(..)
-    , emptyHeaders -- Headers
-    , headersP     -- Parser Headers
-    , hPutHeaders  -- Handle -> Headers -> IO ()
+    , emptyHeaders
+    , headersP
+    , hPutHeaders
     )
     where
 
@@ -22,20 +22,24 @@ class HasHeaders a where
 
     getHeader :: String -> a -> Maybe String
     getHeader key a
-        = fmap snd $ find (noCaseEq key . fst) (getHeaders a)
+        = key `seq` a `seq`
+          fmap snd $ find (noCaseEq' key . fst) (getHeaders a)
 
     deleteHeader :: String -> a -> a
     deleteHeader key a
-        = setHeaders a $ filter (not . noCaseEq key . fst) (getHeaders a)
+        = key `seq` a `seq`
+          setHeaders a $ filter (not . noCaseEq' key . fst) (getHeaders a)
 
     addHeader :: String -> String -> a -> a
     addHeader key val a
-        = setHeaders a $ (getHeaders a) ++ [(key, val)]
+        = key `seq` val `seq` a `seq`
+          setHeaders a $ (getHeaders a) ++ [(key, val)]
 
     setHeader :: String -> String -> a -> a
     setHeader key val a
-        = let list    = getHeaders a
-              deleted = filter (not . noCaseEq key . fst) list
+        = 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 +81,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"