Destroy Data.Attoparsec.Parsable; use Data.Default instead

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

diff --git a/Network/HTTP/Lucu/MultipartForm.hs b/Network/HTTP/Lucu/MultipartForm.hs
index 155003024b9c2e82989bc017bdcb0f58ed8541f6..98699e43ca37d2e2a2978236130f50b6a705c04a 100644 (file)
--- a/Network/HTTP/Lucu/MultipartForm.hs
+++ b/Network/HTTP/Lucu/MultipartForm.hs
@@ -1,10 +1,13 @@
 {-# LANGUAGE
     DoAndIfThenElse
 {-# LANGUAGE
     DoAndIfThenElse

+  , FlexibleInstances

   , FlexibleContexts
   , FlexibleContexts

+  , MultiParamTypeClasses

   , OverloadedStrings
   , QuasiQuotes
   , RecordWildCards
   , ScopedTypeVariables
   , OverloadedStrings
   , QuasiQuotes
   , RecordWildCards
   , ScopedTypeVariables

+  , TemplateHaskell

   , UnicodeSyntax
   , ViewPatterns
   #-}
   , UnicodeSyntax
   , ViewPatterns
   #-}


@@ -17,31 +20,32 @@ 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 qualified Data.Map as M
+import Data.Collections
+import Data.Convertible.Base
+import Data.Convertible.Instances.Ascii ()
+import Data.Convertible.Utils
+import Data.Default
+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.MIMEParams
 import Network.HTTP.Lucu.Headers
 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.MIMEType

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

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

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


@@ -69,15 +73,21 @@ data ContDispo
       , dParams ∷ !MIMEParams
       }
 
       , 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)

 
 

--- |Parse \"multipart/form-data\" and return either @'Left' err@ or
--- @'Right' result@. Note that there are currently the following
+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\" to a list of @(name,
+-- formData)@. Note that there are currently the following

 -- limitations:
 --
 --   * Multiple files embedded as \"multipart/mixed\" within the
 -- limitations:
 --
 --   * Multiple files embedded as \"multipart/mixed\" within the


@@ -86,9 +96,9 @@ printContDispo d
 --   * \"Content-Transfer-Encoding\" is always ignored.
 --
 --   * RFC 2388 (<http://tools.ietf.org/html/rfc2388#section-3>) says
 --   * \"Content-Transfer-Encoding\" is always ignored.
 --
 --   * 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.
+--     that non-ASCII field names are encoded according to the method
+--     in RFC 2047 (<http://tools.ietf.org/html/rfc2047>), but this
+--     function currently doesn't decode them.

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


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

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

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


@@ -159,7 +169,8 @@ parsePart boundary src
         defaultCType = [mimeType| text/plain |]
 
 partHeader ∷ Parser Headers
         defaultCType = [mimeType| text/plain |]
 
 partHeader ∷ Parser Headers

-partHeader = crlf *> headers
+{-# INLINE partHeader #-}
+partHeader = crlf *> def

 
 getContDispo ∷ MonadError String m ⇒ Headers → m ContDispo
 {-# INLINEABLE getContDispo #-}
 
 getContDispo ∷ MonadError String m ⇒ Headers → m ContDispo
 {-# INLINEABLE getContDispo #-}


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

-            → case parseOnly (finishOff contentDisposition) $ 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
+                                       â\8a\95 cs str
+                                       â\8a\95 ": "
+                                       â\8a\95 err

 
 contentDisposition ∷ Parser ContDispo
 
 contentDisposition ∷ Parser ContDispo

+{-# INLINEABLE contentDisposition #-}

 contentDisposition
 contentDisposition

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

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


@@ -188,19 +200,19 @@ getContType hdrs
         Nothing
             → return Nothing
         Just str
         Nothing
             → return Nothing
         Just str

-            → case parseOnly (finishOff MT.mimeType) $ A.toByteString str of
+            → case parseOnly (finishOff def) $ 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
+                                       â\8a\95 cs str
+                                       â\8a\95 ": "
+                                       â\8a\95 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


@@ -224,24 +236,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" params 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)
-    where
-      params = case dParams ptContDispo of
-                 MIMEParams m → m
+                         ⊕ convertSuccessVia ((⊥) ∷ Ascii) ptContDispo

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

-partFileName (dParams ∘ ptContDispo → MIMEParams m)
-    = M.lookup "filename" m
+partFileName (ptContDispo → ContDispo {..})
+    = lookup "filename" dParams