Done.

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

diff --git a/Network/HTTP/Lucu/MIMEParams.hs b/Network/HTTP/Lucu/MIMEParams.hs
index 88dbb6fdd71a47bdc832cca03dc4b36797f3230b..37410330bd25fee7c589f5a1c3b7a234cbce0e18 100644 (file)
--- a/Network/HTTP/Lucu/MIMEParams.hs
+++ b/Network/HTTP/Lucu/MIMEParams.hs
@@ -16,7 +16,6 @@
 -- (<http://tools.ietf.org/html/rfc2231>).
 module Network.HTTP.Lucu.MIMEParams
     ( MIMEParams
-    , mimeParams
     )
     where
 import Control.Applicative hiding (empty)
@@ -25,7 +24,9 @@ import Control.Monad.Unicode
 import Data.Ascii (Ascii, CIAscii, AsciiBuilder)
 import qualified Data.Ascii as A
 import Data.Attoparsec.Char8
+import Data.Attoparsec.Parsable
 import Data.Bits
+import Data.ByteString (ByteString)
 import qualified Data.ByteString.Char8 as BS
 import Data.Char
 import Data.Collections
@@ -145,34 +146,33 @@ section ∷ ExtendedParam → Integer
 section (InitialEncodedParam {..}) = 0
 section ep                         = epSection ep
 
--- |'Parser' for MIME parameter values.
-mimeParams ∷ Parser MIMEParams
-{-# INLINEABLE mimeParams #-}
-mimeParams = decodeParams =≪ many (try paramP)
+instance Parsable ByteString MIMEParams where
+    {-# INLINEABLE parser #-}
+    parser = decodeParams =≪ many (try parser)
 
-paramP ∷ Parser ExtendedParam
-paramP = do skipMany lws
-            void $ char ';'
-            skipMany lws
-            epm ← nameP
-            void $ char '='
-            case epm of
-              (name, 0, True)
-                  → do (charset, payload) ← initialEncodedValue
-                       return $ InitialEncodedParam name charset payload
-              (name, sect, True)
-                  → do payload ← encodedPayload
-                       return $ ContinuedEncodedParam name sect payload
-              (name, sect, False)
-                  → do payload ← token <|> quotedStr
-                       return $ AsciiParam name sect payload
+instance Parsable ByteString ExtendedParam where
+    parser = do skipMany lws
+                void $ char ';'
+                skipMany lws
+                epm ← name
+                void $ char '='
+                case epm of
+                  (nm, 0, True)
+                      → do (charset, payload) ← initialEncodedValue
+                           return $ InitialEncodedParam nm charset payload
+                  (nm, sect, True)
+                      → do payload ← encodedPayload
+                           return $ ContinuedEncodedParam nm sect payload
+                  (nm, sect, False)
+                      → do payload ← token <|> quotedStr
+                           return $ AsciiParam nm sect payload
 
-nameP ∷ Parser (CIAscii, Integer, Bool)
-nameP = do name      ← (A.toCIAscii ∘ A.unsafeFromByteString) <$>
-                       takeWhile1 (\c → isToken c ∧ c ≢ '*')
-           sect      ← option 0     $ try (char '*' *> decimal  )
-           isEncoded ← option False $ try (char '*' *> pure True)
-           return (name, sect, isEncoded)
+name ∷ Parser (CIAscii, Integer, Bool)
+name = do nm        ← (cs ∘ A.unsafeFromByteString) <$>
+                      takeWhile1 (\c → isToken c ∧ c ≢ '*')
+          sect      ← option 0     $ try (char '*' *> decimal  )
+          isEncoded ← option False $ try (char '*' *> pure True)
+          return (nm, sect, isEncoded)
 
 initialEncodedValue ∷ Parser (CIAscii, BS.ByteString)
 initialEncodedValue
@@ -190,7 +190,7 @@ initialEncodedValue
              return (charset, payload)
     where
       metadata ∷ Parser CIAscii
-      metadata = (A.toCIAscii ∘ A.unsafeFromByteString) <$>
+      metadata = (cs ∘ A.unsafeFromByteString) <$>
                  takeWhile (\c → c ≢ '\'' ∧ isToken c)
 
 encodedPayload ∷ Parser BS.ByteString
@@ -257,7 +257,7 @@ sortBySection = flip go (∅)
                            → fail (concat [ "Duplicate section "
                                           , show $ section x
                                           , " for parameter '"
-                                          , A.toString $ A.fromCIAscii $ epName x
+                                          , cs $ epName x
                                           , "'"
                                           ])
 
@@ -280,7 +280,7 @@ decodeSections = (decodeSeq =≪) ∘ flip (flip toSeq 0) (∅)
                         → fail (concat [ "Missing section "
                                        , show $ section p
                                        , " for parameter '"
-                                       , A.toString $ A.fromCIAscii $ epName p
+                                       , cs $ epName p
                                        , "'"
                                        ])
 
@@ -296,9 +296,7 @@ decodeSections = (decodeSeq =≪) ∘ flip (flip toSeq 0) (∅)
               Just (ContinuedEncodedParam {..}, _)
                   → fail "decodeSeq: internal error: CEP at section 0"
               Just (AsciiParam {..}, xs)
-                  → let t = A.toText apPayload
-                    in
-                      decodeSeq' Nothing xs $ singleton t
+                  → decodeSeq' Nothing xs $ singleton $ cs apPayload
 
       decodeSeq' ∷ Monad m
                  ⇒ Maybe Decoder
@@ -320,13 +318,11 @@ decodeSections = (decodeSeq =≪) ∘ flip (flip toSeq 0) (∅)
                            → fail (concat [ "Section "
                                           , show epSection
                                           , " for parameter '"
-                                          , A.toString $ A.fromCIAscii epName
+                                          , cs epName
                                           , "' is encoded but its first section is not"
                                           ])
               Just (AsciiParam {..}, xs)
-                  → let t = A.toText apPayload
-                    in
-                      decodeSeq' decoder xs $ chunks ⊳ t
+                  → decodeSeq' decoder xs $ chunks ⊳ cs apPayload
 
 type Decoder = BS.ByteString → Either UnicodeException Text
 
@@ -340,5 +336,4 @@ getDecoder ∷ Monad m ⇒ CIAscii → m Decoder
 getDecoder charset
     | charset ≡ "UTF-8"    = return decodeUtf8'
     | charset ≡ "US-ASCII" = return decodeUtf8'
-    | otherwise            = fail $ "No decoders found for charset: "
-                                  ⧺ A.toString (A.fromCIAscii charset)
+    | otherwise            = fail $ "No decoders found for charset: " ⊕ cs charset