X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FHeaders.hs;h=b36927d9bc13978ce9a7116883b69f0901b369bd;hb=2bb7a0baa35dadb5d36d3f9fa98bd242baabc6d1;hp=2378ebcc529295f9495f1f1e5daf5daef46ce907;hpb=9bb89434103e9a22f100d6ecb7e65a5d461e0454;p=Lucu.git

diff --git a/Network/HTTP/Lucu/Headers.hs b/Network/HTTP/Lucu/Headers.hs
index 2378ebc..b36927d 100644
--- a/Network/HTTP/Lucu/Headers.hs
+++ b/Network/HTTP/Lucu/Headers.hs
@@ -1,6 +1,5 @@
 {-# LANGUAGE
-    BangPatterns
-  , GeneralizedNewtypeDeriving
+    GeneralizedNewtypeDeriving
   , OverloadedStrings
   , UnicodeSyntax
   #-}
@@ -12,11 +11,11 @@ module Network.HTTP.Lucu.Headers
     , fromHeaders
 
     , headersP
-    , hPutHeaders
+    , printHeaders
     )
     where
 import Control.Applicative
-import Data.Ascii (Ascii, CIAscii)
+import Data.Ascii (Ascii, AsciiBuilder, CIAscii)
 import qualified Data.Ascii as A
 import Data.Attoparsec.Char8 as P
 import qualified Data.ByteString as BS
@@ -24,7 +23,6 @@ import Data.Map (Map)
 import qualified Data.Map as M
 import Data.Monoid
 import Data.Monoid.Unicode
-import Network.HTTP.Lucu.HandleLike
 import Network.HTTP.Lucu.Parser.Http
 import Network.HTTP.Lucu.Utils
 import Prelude.Unicode
@@ -38,25 +36,33 @@ class HasHeaders a where
     setHeaders ∷ a → Headers → a
 
     getHeader ∷ CIAscii → a → Maybe Ascii
-    {-# INLINE getHeader #-}
-    getHeader !key !a
+    getHeader key a
         = case getHeaders a of
             Headers m → M.lookup key m
 
+    getCIHeader ∷ CIAscii → a → Maybe CIAscii
+    {-# INLINE getCIHeader #-}
+    getCIHeader key a
+        = A.toCIAscii <$> getHeader key a
+
     deleteHeader ∷ CIAscii → a → a
     {-# INLINE deleteHeader #-}
-    deleteHeader !key !a
+    deleteHeader key a
         = case getHeaders a of
             Headers m
               → setHeaders a $ Headers $ M.delete key m
 
     setHeader ∷ CIAscii → Ascii → a → a
     {-# INLINE setHeader #-}
-    setHeader !key !val !a
+    setHeader key val a
         = case getHeaders a of
             Headers m
               → setHeaders a $ Headers $ M.insert key val m
 
+instance HasHeaders Headers where
+    getHeaders   = id
+    setHeaders _ = id
+
 toHeaders ∷ [(CIAscii, Ascii)] → Headers
 {-# INLINE toHeaders #-}
 toHeaders = flip mkHeaders (∅)
@@ -102,12 +108,11 @@ headersP = do xs ← P.many header
               return $ toHeaders xs
     where
       header ∷ Parser (CIAscii, Ascii)
-      header = try $
-               do name ← A.toCIAscii <$> token
+      header = do name ← A.toCIAscii <$> token
                   _    ← char ':'
                   skipMany lws
-                  values ← sepBy content lws
-                  skipMany lws
+                  values ← sepBy content (try lws)
+                  skipMany (try lws)
                   crlf
                   return (name, joinValues values)
 
@@ -119,15 +124,16 @@ headersP = do xs ← P.many header
 
       joinValues ∷ [Ascii] → Ascii
       {-# INLINE joinValues #-}
-      joinValues = A.fromAsciiBuilder ∘ joinWith "\x20"
+      joinValues = A.fromAsciiBuilder ∘ joinWith "\x20" ∘ map A.toAsciiBuilder
 
-hPutHeaders ∷ HandleLike h => h → Headers → IO ()
-hPutHeaders !h !(Headers m)
-    = mapM_ putH (M.toList m) >> hPutBS h "\r\n"
+printHeaders ∷ Headers → AsciiBuilder
+printHeaders (Headers m)
+    = mconcat (map printHeader (M.toList m)) ⊕
+      A.toAsciiBuilder "\x0D\x0A"
     where
-      putH ∷ (CIAscii, Ascii) → IO ()
-      putH (!name, !value)
-          = do hPutBS h (A.ciToByteString name)
-               hPutBS h ": "
-               hPutBS h (A.toByteString value)
-               hPutBS h "\r\n"
+      printHeader ∷ (CIAscii, Ascii) → AsciiBuilder
+      printHeader (name, value)
+          = A.toAsciiBuilder (A.fromCIAscii name) ⊕
+            A.toAsciiBuilder ": "                 ⊕
+            A.toAsciiBuilder value                ⊕
+            A.toAsciiBuilder "\x0D\x0A"