Better name-rewriting engine

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

diff --git a/Network/HTTP/Lucu/Headers.hs b/Network/HTTP/Lucu/Headers.hs
index a5fdb022e7437e5add0071bcf723834b36f85c23..80b9b1339501d95a08c80511645e3603a5b1d9ea 100644 (file)
--- a/Network/HTTP/Lucu/Headers.hs
+++ b/Network/HTTP/Lucu/Headers.hs
@@ -1,31 +1,35 @@
 {-# LANGUAGE
-    BangPatterns
-  , GeneralizedNewtypeDeriving
+    GeneralizedNewtypeDeriving
   , OverloadedStrings
   , UnicodeSyntax
   #-}
+-- |An internal module for HTTP headers.
 module Network.HTTP.Lucu.Headers
     ( Headers
     , HasHeaders(..)
 
+    , singleton
+
     , toHeaders
     , fromHeaders
 
-    , headersP
+    , headers
     , printHeaders
     )
     where
 import Control.Applicative
+import Control.Monad
 import Data.Ascii (Ascii, AsciiBuilder, CIAscii)
 import qualified Data.Ascii as A
 import Data.Attoparsec.Char8 as P
 import qualified Data.ByteString as BS
+import Data.List
 import Data.Map (Map)
 import qualified Data.Map as M
+import qualified Data.Map.Unicode as M
 import Data.Monoid
 import Data.Monoid.Unicode
 import Network.HTTP.Lucu.Parser.Http
-import Network.HTTP.Lucu.Utils
 import Prelude.Unicode
 
 newtype Headers
@@ -37,21 +41,31 @@ 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
 
+    hasHeader ∷ CIAscii → a → Bool
+    {-# INLINE hasHeader #-}
+    hasHeader key a
+        = case getHeaders a of
+            Headers m → key M.∈ 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
@@ -60,6 +74,11 @@ instance HasHeaders Headers where
     getHeaders   = id
     setHeaders _ = id
 
+singleton ∷ CIAscii → Ascii → Headers
+{-# INLINE singleton #-}
+singleton key val
+    = Headers $ M.singleton key val
+
 toHeaders ∷ [(CIAscii, Ascii)] → Headers
 {-# INLINE toHeaders #-}
 toHeaders = flip mkHeaders (∅)
@@ -98,17 +117,17 @@ fromHeaders (Headers m) = M.toList m
   field-value の先頭および末尾にある LWS は全て削除され、それ以外の
   LWS は單一の SP に變換される。
 -}
-headersP ∷ Parser Headers
-{-# INLINEABLE headersP #-}
-headersP = do xs ← P.many header
-              crlf
-              return $ toHeaders xs
+headers ∷ Parser Headers
+{-# INLINEABLE headers #-}
+headers = do xs ← P.many header
+             crlf
+             return $ toHeaders xs
     where
       header ∷ Parser (CIAscii, Ascii)
       header = do name ← A.toCIAscii <$> token
-                  _    ← char ':'
+                  void $ char ':'
                   skipMany lws
-                  values ← sepBy content (try lws)
+                  values ← content `sepBy` try lws
                   skipMany (try lws)
                   crlf
                   return (name, joinValues values)
@@ -117,11 +136,14 @@ headersP = do xs ← P.many header
       {-# INLINE content #-}
       content = A.unsafeFromByteString
                 <$>
-                takeWhile1 (\c → ((¬) (isSPHT c)) ∧ isText c)
+                takeWhile1 (\c → isText c ∧ c ≢ '\x20')
 
       joinValues ∷ [Ascii] → Ascii
       {-# INLINE joinValues #-}
-      joinValues = A.fromAsciiBuilder ∘ joinWith "\x20" ∘ map A.toAsciiBuilder
+      joinValues = A.fromAsciiBuilder
+                   ∘ mconcat
+                   ∘ intersperse (A.toAsciiBuilder "\x20")
+                   ∘ map A.toAsciiBuilder
 
 printHeaders ∷ Headers → AsciiBuilder
 printHeaders (Headers m)