X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FMultipartForm.hs;h=a5280c043f6bf252bf0095ba2792c3959ab26247;hb=bb121f1189d01b5089aa5c29f0d390fad36ade48;hp=a04b4a059f9a28c7e10b3ffc6b7f144b30df0252;hpb=3eb69879d3b336c7c3e613c0ce4bfb3c67989ff3;p=Lucu.git

diff --git a/Network/HTTP/Lucu/MultipartForm.hs b/Network/HTTP/Lucu/MultipartForm.hs
index a04b4a0..a5280c0 100644
--- a/Network/HTTP/Lucu/MultipartForm.hs
+++ b/Network/HTTP/Lucu/MultipartForm.hs
@@ -2,15 +2,14 @@
     DoAndIfThenElse
   , FlexibleContexts
   , OverloadedStrings
+  , QuasiQuotes
   , RecordWildCards
   , ScopedTypeVariables
   , 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
@@ -18,7 +17,7 @@ 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
@@ -27,20 +26,22 @@ 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.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.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.RFC2231
+import Network.HTTP.Lucu.Utils
+import Prelude hiding (lookup, mapM)
 import Prelude.Unicode
 
 -- |'FormData' represents a form value and possibly an uploaded file
@@ -65,7 +66,7 @@ data Part
 data ContDispo
     = ContDispo {
         dType   ∷ !CIAscii
-      , dParams ∷ !(Map CIAscii Text)
+      , dParams ∷ !MIMEParams
       }
 
 printContDispo ∷ ContDispo → Ascii
@@ -84,10 +85,10 @@ printContDispo d
 --
 --   * \"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 won't be
---     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)]
@@ -131,12 +132,7 @@ prologue boundary
       "prologue"
 
 epilogue ∷ Parser ()
-epilogue = ( (string "--" <?> "suffix")
-             *>
-             crlf
-             *>
-             endOfInput
-           )
+epilogue = finishOff ((string "--" <?> "suffix") *> crlf)
            <?>
            "epilogue"
 
@@ -160,7 +156,7 @@ parsePart boundary src
                          ⧺ e
       where
         defaultCType ∷ MIMEType
-        defaultCType = parseMIMEType "text/plain"
+        defaultCType = [mimeType| text/plain |]
 
 partHeader ∷ Parser Headers
 partHeader = crlf *> headers
@@ -172,16 +168,12 @@ getContDispo hdrs
         Nothing
             → throwError "Content-Disposition is missing"
         Just str
-            → case parseOnly p $ A.toByteString str of
+            → case parseOnly (finishOff contentDisposition) $ A.toByteString str of
                  Right  d → return d
                  Left err → throwError $ "malformed Content-Disposition: "
                                        ⧺ A.toString str
                                        ⧺ ": "
                                        ⧺ err
-    where
-      p = do dispo ← contentDisposition
-             endOfInput
-             return dispo
 
 contentDisposition ∷ Parser ContDispo
 contentDisposition
@@ -196,16 +188,12 @@ getContType hdrs
         Nothing
             → return Nothing
         Just str
-            → case parseOnly p $ A.toByteString str of
+            → case parseOnly (finishOff MT.mimeType) $ A.toByteString str of
                  Right  d → return $ Just d
                  Left err → throwError $ "malformed Content-Type: "
                                        ⧺ A.toString str
                                        ⧺ ": "
                                        ⧺ err
-    where
-      p = do t ← mimeType
-             endOfInput
-             return t
 
 getBody ∷ MonadError String m
         ⇒ Ascii
@@ -241,7 +229,7 @@ partToFormPair pt@(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
             → case A.fromText name of
                  Just a  → return a
@@ -252,5 +240,5 @@ partName (Part {..})
                          ⧺ A.toString (printContDispo ptContDispo)
 
 partFileName ∷ Part → Maybe Text
-partFileName (Part {..})
-    = M.lookup "filename" $ dParams ptContDispo
+partFileName (ptContDispo → ContDispo {..})
+    = lookup "filename" dParams