X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Lucu.git;a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FMultipartForm.hs;h=98699e43ca37d2e2a2978236130f50b6a705c04a;hp=155003024b9c2e82989bc017bdcb0f58ed8541f6;hb=90fca0675b1694e69b8e431c989343855cbd125d;hpb=cc074d0ce3f7df2544bc2baddca4e7730ecdf0a0

diff --git a/Network/HTTP/Lucu/MultipartForm.hs b/Network/HTTP/Lucu/MultipartForm.hs
index 1550030..98699e4 100644
--- a/Network/HTTP/Lucu/MultipartForm.hs
+++ b/Network/HTTP/Lucu/MultipartForm.hs
@@ -1,10 +1,13 @@
 {-# LANGUAGE
     DoAndIfThenElse
+  , FlexibleInstances
   , FlexibleContexts
+  , MultiParamTypeClasses
   , OverloadedStrings
   , QuasiQuotes
   , RecordWildCards
   , ScopedTypeVariables
+  , TemplateHaskell
   , UnicodeSyntax
   , ViewPatterns
   #-}
@@ -17,31 +20,32 @@ module Network.HTTP.Lucu.MultipartForm
     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 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.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.Sequence.Unicode hiding ((∅))
 import Data.Text (Text)
-import qualified Data.Text as T
 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.Utils
+import Prelude hiding (lookup, mapM)
 import Prelude.Unicode
 
 -- |'FormData' represents a form value and possibly an uploaded file
@@ -69,15 +73,21 @@ data ContDispo
       , 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
@@ -86,9 +96,9 @@ printContDispo d
 --   * \"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)]
@@ -124,7 +134,7 @@ prologue ∷ Ascii → Parser ()
 prologue boundary
     = ( (string "--" <?> "prefix")
         *>
-        (string (A.toByteString boundary) <?> "boundary")
+        (string (cs boundary) <?> "boundary")
         *>
         pure ()
       )
@@ -159,7 +169,8 @@ parsePart boundary src
         defaultCType = [mimeType| text/plain |]
 
 partHeader ∷ Parser Headers
-partHeader = crlf *> headers
+{-# INLINE partHeader #-}
+partHeader = crlf *> def
 
 getContDispo ∷ MonadError String m ⇒ Headers → m ContDispo
 {-# INLINEABLE getContDispo #-}
@@ -168,16 +179,17 @@ getContDispo hdrs
         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: "
-                                       ⧺ A.toString str
-                                       ⧺ ": "
-                                       ⧺ err
+                                       ⊕ cs str
+                                       ⊕ ": "
+                                       ⊕ err
 
 contentDisposition ∷ Parser ContDispo
+{-# INLINEABLE contentDisposition #-}
 contentDisposition
-    = (ContDispo <$> (A.toCIAscii <$> token) ⊛ mimeParams)
+    = (ContDispo <$> (cs <$> token) ⊛ def)
       <?>
       "contentDisposition"
 
@@ -188,19 +200,19 @@ getContType hdrs
         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: "
-                                       ⧺ A.toString str
-                                       ⧺ ": "
-                                       ⧺ err
+                                       ⊕ cs str
+                                       ⊕ ": "
+                                       ⊕ err
 
 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
@@ -224,24 +236,20 @@ partToFormPair pt@(Part {..})
              return (name, fd)
     | otherwise
         = throwError $ "disposition type is not \"form-data\": "
-                     ⧺ A.toString (A.fromCIAscii $ dType ptContDispo)
+                     ⊕ cs (dType ptContDispo)
 
 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
-            → 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: "
-                         ⧺ A.toString (printContDispo ptContDispo)
-    where
-      params = case dParams ptContDispo of
-                 MIMEParams m → m
+                         ⊕ convertSuccessVia ((⊥) ∷ Ascii) ptContDispo
 
 partFileName ∷ Part → Maybe Text
-partFileName (dParams ∘ ptContDispo → MIMEParams m)
-    = M.lookup "filename" m
+partFileName (ptContDispo → ContDispo {..})
+    = lookup "filename" dParams