Code clean-up using convertible-text.

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

diff --git a/Network/HTTP/Lucu/MultipartForm.hs b/Network/HTTP/Lucu/MultipartForm.hs
index edba0d50f1e33e589feeb10b57ec71dbe4ebb3da..2d1b3470f1cf62a797a1336c183e8d54999589b9 100644 (file)
--- a/Network/HTTP/Lucu/MultipartForm.hs
+++ b/Network/HTTP/Lucu/MultipartForm.hs
@@ -1,16 +1,18 @@
 {-# LANGUAGE
     DoAndIfThenElse
 {-# LANGUAGE
     DoAndIfThenElse

+  , FlexibleInstances

   , FlexibleContexts
   , FlexibleContexts

+  , MultiParamTypeClasses

   , OverloadedStrings
   , OverloadedStrings

+  , QuasiQuotes

   , RecordWildCards
   , ScopedTypeVariables
   , RecordWildCards
   , ScopedTypeVariables

+  , TemplateHaskell

   , UnicodeSyntax
   , ViewPatterns
   #-}
 -- |Parse \"multipart/form-data\" based on RFC 2388:
   , UnicodeSyntax
   , ViewPatterns
   #-}
 -- |Parse \"multipart/form-data\" based on RFC 2388:

--- <http://www.faqs.org/rfcs/rfc2388.html>
---
--- You usually don't have to use this module directly.
+-- <http://tools.ietf.org/html/rfc2388>

 module Network.HTTP.Lucu.MultipartForm
     ( FormData(..)
     , parseMultipartFormData
 module Network.HTTP.Lucu.MultipartForm
     ( FormData(..)
     , parseMultipartFormData


@@ -18,37 +20,44 @@ module Network.HTTP.Lucu.MultipartForm
     where
 import Control.Applicative hiding (many)
 import Control.Applicative.Unicode hiding ((∅))
     where
 import Control.Applicative hiding (many)
 import Control.Applicative.Unicode hiding ((∅))

-import Control.Monad.Error
+import Control.Monad.Error (MonadError, throwError)

 import Control.Monad.Unicode
 import Control.Monad.Unicode

-import Data.Ascii (Ascii, CIAscii)
-import qualified Data.Ascii as A
+import Data.Ascii (Ascii, CIAscii, AsciiBuilder)
+import Data.Attempt

 import Data.Attoparsec
 import qualified Data.Attoparsec.Lazy as LP
 import qualified Data.ByteString as BS
 import qualified Data.ByteString.Lazy as LS
 import Data.ByteString.Lazy.Search
 import Data.Attoparsec
 import qualified Data.Attoparsec.Lazy as LP
 import qualified Data.ByteString as BS
 import qualified Data.ByteString.Lazy as LS
 import Data.ByteString.Lazy.Search

-import Data.Foldable
-import Data.List
-import Data.Map (Map)
-import qualified Data.Map as M
+import Data.Collections
+import Data.Convertible.Base
+import Data.Convertible.Instances.Ascii ()
+import Data.Convertible.Utils
+import Data.List (intercalate)

 import Data.Maybe
 import Data.Monoid.Unicode
 import Data.Sequence (Seq)
 import Data.Maybe
 import Data.Monoid.Unicode
 import Data.Sequence (Seq)

-import Data.Sequence.Unicode hiding ((∅))

 import Data.Text (Text)
 import Data.Text (Text)

-import qualified Data.Text as T

 import Network.HTTP.Lucu.Headers
 import Network.HTTP.Lucu.Headers

-import Network.HTTP.Lucu.MIMEType
+import Network.HTTP.Lucu.MIMEParams
+import Network.HTTP.Lucu.MIMEType (MIMEType)
+import qualified Network.HTTP.Lucu.MIMEType as MT
+import Network.HTTP.Lucu.MIMEType.TH
+import Network.HTTP.Lucu.Parser

 import Network.HTTP.Lucu.Parser.Http
 import Network.HTTP.Lucu.Parser.Http

-import Network.HTTP.Lucu.RFC2231
+import Network.HTTP.Lucu.Utils
+import Prelude hiding (lookup, mapM)

 import Prelude.Unicode
 
 -- |'FormData' represents a form value and possibly an uploaded file
 -- name.
 data FormData
     = FormData {
 import Prelude.Unicode
 
 -- |'FormData' represents a form value and possibly an uploaded file
 -- name.
 data FormData
     = FormData {

+        -- | @'Nothing'@ for non-file values.

         fdFileName ∷ !(Maybe Text)
         fdFileName ∷ !(Maybe Text)

+        -- | MIME Type of this value, defaulted to \"text/plain\".

       , fdMIMEType ∷ !MIMEType
       , fdMIMEType ∷ !MIMEType

+        -- | The form value.

       , fdContent  ∷ !(LS.ByteString)
       }
 
       , fdContent  ∷ !(LS.ByteString)
       }
 


@@ -62,29 +71,35 @@ data Part
 data ContDispo
     = ContDispo {
         dType   ∷ !CIAscii
 data ContDispo
     = ContDispo {
         dType   ∷ !CIAscii

-      , dParams ∷ !(Map CIAscii Text)
+      , dParams ∷ !MIMEParams

       }
 
       }
 

-printContDispo ∷ ContDispo → Ascii
-printContDispo d
-    = A.fromAsciiBuilder
-      ( A.toAsciiBuilder (A.fromCIAscii $ dType d)
-        ⊕
-        printMIMEParams (dParams d) )
+instance ConvertSuccess ContDispo Ascii where
+    {-# INLINE convertSuccess #-}
+    convertSuccess = convertSuccessVia ((⊥) ∷ AsciiBuilder)
+
+instance ConvertSuccess ContDispo AsciiBuilder where
+    {-# INLINE convertSuccess #-}
+    convertSuccess (ContDispo {..})
+        = cs dType ⊕ cs dParams
+
+deriveAttempts [ ([t| ContDispo |], [t| Ascii        |])
+               , ([t| ContDispo |], [t| AsciiBuilder |])
+               ]

 
 -- |Parse \"multipart/form-data\" and return either @'Left' err@ or
 -- @'Right' result@. Note that there are currently the following
 -- limitations:
 --
 --   * Multiple files embedded as \"multipart/mixed\" within the
 
 -- |Parse \"multipart/form-data\" and return either @'Left' err@ or
 -- @'Right' result@. Note that there are currently the following
 -- limitations:
 --
 --   * Multiple files embedded as \"multipart/mixed\" within the

---     \"multipart/form-data\" aren't decomposed.
+--     \"multipart/form-data\" won't be decomposed.

 --
 --

---   * \"Content-Transfer-Encoding\"s are always ignored.
+--   * \"Content-Transfer-Encoding\" is always ignored.

 --
 --

---   * RFC 2388 says that non-ASCII field names are encoded according
---     to the method in RFC 2047
---     <http://www.faqs.org/rfcs/rfc2047.html>, but they aren't
---     decoded.
+--   * RFC 2388 (<http://tools.ietf.org/html/rfc2388#section-3>) says
+--   that non-ASCII field names are encoded according to the method in
+--   RFC 2047 (<http://tools.ietf.org/html/rfc2047>), but they won't
+--   be decoded.

 parseMultipartFormData ∷ Ascii -- ^boundary
                        → LS.ByteString -- ^input
                        → Either String [(Ascii, FormData)]
 parseMultipartFormData ∷ Ascii -- ^boundary
                        → LS.ByteString -- ^input
                        → Either String [(Ascii, FormData)]


@@ -120,7 +135,7 @@ prologue ∷ Ascii → Parser ()
 prologue boundary
     = ( (string "--" <?> "prefix")
         *>
 prologue boundary
     = ( (string "--" <?> "prefix")
         *>

-        (string (A.toByteString boundary) <?> "boundary")
+        (string (cs boundary) <?> "boundary")

         *>
         pure ()
       )
         *>
         pure ()
       )


@@ -128,12 +143,7 @@ prologue boundary
       "prologue"
 
 epilogue ∷ Parser ()
       "prologue"
 
 epilogue ∷ Parser ()

-epilogue = ( (string "--" <?> "suffix")
-             *>
-             crlf
-             *>
-             endOfInput
-           )
+epilogue = finishOff ((string "--" <?> "suffix") *> crlf)

            <?>
            "epilogue"
 
            <?>
            "epilogue"
 


@@ -157,7 +167,7 @@ parsePart boundary src
                          ⧺ e
       where
         defaultCType ∷ MIMEType
                          ⧺ e
       where
         defaultCType ∷ MIMEType

-        defaultCType = parseMIMEType "text/plain"
+        defaultCType = [mimeType| text/plain |]

 
 partHeader ∷ Parser Headers
 partHeader = crlf *> headers
 
 partHeader ∷ Parser Headers
 partHeader = crlf *> headers


@@ -169,20 +179,16 @@ getContDispo hdrs
         Nothing
             → throwError "Content-Disposition is missing"
         Just str
         Nothing
             → throwError "Content-Disposition is missing"
         Just str

-            → case parseOnly p $ A.toByteString str of
+            → case parseOnly (finishOff contentDisposition) $ cs str of

                  Right  d → return d
                  Left err → throwError $ "malformed Content-Disposition: "
                  Right  d → return d
                  Left err → throwError $ "malformed Content-Disposition: "

-                                       ⧺ A.toString str
-                                       ⧺ ": "
-                                       ⧺ err
-    where
-      p = do dispo ← contentDisposition
-             endOfInput
-             return dispo
+                                       ⊕ cs str
+                                       ⊕ ": "
+                                       ⊕ err

 
 contentDisposition ∷ Parser ContDispo
 contentDisposition
 
 contentDisposition ∷ Parser ContDispo
 contentDisposition

-    = (ContDispo <$> (A.toCIAscii <$> token) ⊛ mimeParams)
+    = (ContDispo <$> (cs <$> token) ⊛ mimeParams)

       <?>
       "contentDisposition"
 
       <?>
       "contentDisposition"
 


@@ -193,23 +199,19 @@ getContType hdrs
         Nothing
             → return Nothing
         Just str
         Nothing
             → return Nothing
         Just str

-            → case parseOnly p $ A.toByteString str of
+            → case parseOnly (finishOff MT.mimeType) $ cs str of

                  Right  d → return $ Just d
                  Left err → throwError $ "malformed Content-Type: "
                  Right  d → return $ Just d
                  Left err → throwError $ "malformed Content-Type: "

-                                       ⧺ A.toString str
-                                       ⧺ ": "
-                                       ⧺ err
-    where
-      p = do t ← mimeType
-             endOfInput
-             return t
+                                       ⊕ cs str
+                                       ⊕ ": "
+                                       ⊕ err

 
 getBody ∷ MonadError String m
         ⇒ Ascii
         → LS.ByteString
         → m (LS.ByteString, LS.ByteString)
 {-# INLINEABLE getBody #-}
 
 getBody ∷ MonadError String m
         ⇒ Ascii
         → LS.ByteString
         → m (LS.ByteString, LS.ByteString)
 {-# INLINEABLE getBody #-}

-getBody (("\r\n--" ⊕) ∘ A.toByteString → boundary) src
+getBody (("\r\n--" ⊕) ∘ cs → boundary) src

     = case breakOn boundary src of
         (before, after)
             | LS.null after
     = case breakOn boundary src of
         (before, after)
             | LS.null after


@@ -233,21 +235,20 @@ partToFormPair pt@(Part {..})
              return (name, fd)
     | otherwise
         = throwError $ "disposition type is not \"form-data\": "
              return (name, fd)
     | otherwise
         = throwError $ "disposition type is not \"form-data\": "

-                     ⧺ A.toString (A.fromCIAscii $ dType ptContDispo)
+                     â\8a\95 cs (dType ptContDispo)

 
 partName ∷ MonadError String m ⇒ Part → m Ascii
 {-# INLINEABLE partName #-}
 partName (Part {..})
 
 partName ∷ MonadError String m ⇒ Part → m Ascii
 {-# INLINEABLE partName #-}
 partName (Part {..})

-    = case M.lookup "name" $ dParams ptContDispo of
+    = case lookup "name" $ dParams ptContDispo of

         Just name
         Just name

-            → case A.fromText name of
-                 Just a  → return a
-                 Nothing → throwError $ "Non-ascii part name: "
-                                      ⧺ T.unpack name
+            → case ca name of
+                 Success a → return a
+                 Failure e → throwError $ show e

         Nothing
             → throwError $ "form-data without name: "
         Nothing
             → throwError $ "form-data without name: "

-                         ⧺ A.toString (printContDispo ptContDispo)
+                         â\8a\95 convertSuccessVia ((â\8a¥) â\88· Ascii) ptContDispo

 
 partFileName ∷ Part → Maybe Text
 
 partFileName ∷ Part → Maybe Text

-partFileName (Part {..})
-    = M.lookup "filename" $ dParams ptContDispo
+partFileName (ptContDispo → ContDispo {..})
+    = lookup "filename" dParams