X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FHeaders.hs;h=e6641154adc1d390b1c7cd35bb4d5d5a4c71342d;hb=db4a546d0d462cb94639b1f273bf0b78bccc960c;hp=242d19194d0a30f7f0d68bc375bc1914f0942505;hpb=545053db37e71ed18ca59c12467a8ecb10bf5f83;p=Lucu.git

diff --git a/Network/HTTP/Lucu/Headers.hs b/Network/HTTP/Lucu/Headers.hs
index 242d191..e664115 100644
--- a/Network/HTTP/Lucu/Headers.hs
+++ b/Network/HTTP/Lucu/Headers.hs
@@ -12,9 +12,6 @@
 module Network.HTTP.Lucu.Headers
     ( Headers
     , HasHeaders(..)
-
-    , headers
-    , printHeaders
     )
     where
 import Control.Applicative hiding (empty)
@@ -22,8 +19,13 @@ import Control.Applicative.Unicode hiding ((∅))
 import Control.Monad
 import Data.Ascii (Ascii, AsciiBuilder, CIAscii)
 import qualified Data.Ascii as A
-import Data.Attoparsec.Char8 as P
+import Data.Attoparsec.Char8
+import Data.Attoparsec.Parsable
+import Data.ByteString (ByteString)
 import qualified Data.Collections.Newtype.TH as C
+import Data.Convertible.Base
+import Data.Convertible.Instances.Ascii ()
+import Data.Convertible.Utils
 import Data.List (intersperse)
 import qualified Data.Map as M (Map)
 import Data.Collections
@@ -56,7 +58,7 @@ class HasHeaders a where
 
     getCIHeader ∷ CIAscii → a → Maybe CIAscii
     {-# INLINE getCIHeader #-}
-    getCIHeader = ((A.toCIAscii <$>) ∘) ∘ getHeader
+    getCIHeader = ((cs <$>) ∘) ∘ getHeader
 
     deleteHeader ∷ CIAscii → a → a
     {-# INLINE deleteHeader #-}
@@ -105,6 +107,27 @@ merge a b
       {-# INLINE nullA #-}
       nullA = null ∘ A.toByteString
 
+instance ConvertSuccess Headers Ascii where
+    {-# INLINE convertSuccess #-}
+    convertSuccess = convertSuccessVia ((⊥) ∷ AsciiBuilder)
+
+instance ConvertSuccess Headers AsciiBuilder where
+    {-# INLINEABLE convertSuccess #-}
+    convertSuccess (Headers m)
+        = mconcat (header <$> fromFoldable m) ⊕ cs ("\x0D\x0A" ∷ Ascii)
+        where
+          header ∷ (CIAscii, Ascii) → AsciiBuilder
+          {-# INLINE header #-}
+          header (name, value)
+              = cs name                 ⊕
+                cs (": " ∷ Ascii)       ⊕
+                cs value                ⊕
+                cs ("\x0D\x0A" ∷ Ascii)
+
+deriveAttempts [ ([t| Headers |], [t| Ascii        |])
+               , ([t| Headers |], [t| AsciiBuilder |])
+               ]
+
 {-
   message-header = field-name ":" [ field-value ]
   field-name     = token
@@ -116,42 +139,31 @@ merge a b
   field-value の先頭および末尾にある LWS は全て削除され、それ以外の
   LWS は單一の SP に變換される。
 -}
-headers ∷ Parser Headers
-{-# INLINEABLE headers #-}
-headers = do xs ← P.many header
-             crlf
-             return $ fromFoldable xs
-    where
-      header ∷ Parser (CIAscii, Ascii)
-      header = do name ← A.toCIAscii <$> token
-                  void $ char ':'
-                  skipMany lws
-                  values ← content `sepBy` try lws
-                  skipMany (try lws)
-                  crlf
-                  return (name, joinValues values)
-
-      content ∷ Parser Ascii
-      {-# INLINE content #-}
-      content = A.unsafeFromByteString
-                <$>
-                takeWhile1 (\c → isText c ∧ c ≢ '\x20')
-
-      joinValues ∷ [Ascii] → Ascii
-      {-# INLINE joinValues #-}
-      joinValues = A.fromAsciiBuilder
-                   ∘ mconcat
-                   ∘ intersperse (A.toAsciiBuilder "\x20")
-                   ∘ (A.toAsciiBuilder <$>)
-
-printHeaders ∷ Headers → AsciiBuilder
-printHeaders (Headers m)
-    = mconcat (printHeader <$> fromFoldable m) ⊕
-      A.toAsciiBuilder "\x0D\x0A"
-    where
-      printHeader ∷ (CIAscii, Ascii) → AsciiBuilder
-      printHeader (name, value)
-          = A.toAsciiBuilder (A.fromCIAscii name) ⊕
-            A.toAsciiBuilder ": "                 ⊕
-            A.toAsciiBuilder value                ⊕
-            A.toAsciiBuilder "\x0D\x0A"
+instance Parsable ByteString Headers where
+    {-# INLINEABLE parser #-}
+    parser = do xs ← many header
+                crlf
+                return $ fromFoldable xs
+        where
+          header ∷ Parser (CIAscii, Ascii)
+          {-# INLINEABLE header #-}
+          header = do name ← cs <$> token
+                      void $ char ':'
+                      skipMany lws
+                      values ← content `sepBy` try lws
+                      skipMany (try lws)
+                      crlf
+                      return (name, joinValues values)
+
+          content ∷ Parser Ascii
+          {-# INLINEABLE content #-}
+          content = A.unsafeFromByteString
+                    <$>
+                    takeWhile1 (\c → isText c ∧ c ≢ '\x20')
+
+          joinValues ∷ [Ascii] → Ascii
+          {-# INLINEABLE joinValues #-}
+          joinValues = cs
+                       ∘ mconcat
+                       ∘ intersperse (cs ("\x20" ∷ Ascii) ∷ AsciiBuilder)
+                       ∘ (cs <$>)