Make use of mimeType quasi-quoter.

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

diff --git a/Network/HTTP/Lucu/MultipartForm.hs b/Network/HTTP/Lucu/MultipartForm.hs
index 53174fa94d0a2f0ac448e4a53182800e5da64c43..a28a80461ede0d502d4de626121731c232c940cc 100644 (file)
--- a/Network/HTTP/Lucu/MultipartForm.hs
+++ b/Network/HTTP/Lucu/MultipartForm.hs
@@ -2,12 +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>
+-- <http://tools.ietf.org/html/rfc2388>
 --
 -- You usually don't have to use this module directly.
 module Network.HTTP.Lucu.MultipartForm
@@ -23,11 +25,11 @@ import Data.Ascii (Ascii, CIAscii)
 import qualified Data.Ascii as A
 import Data.Attoparsec
 import qualified Data.Attoparsec.Lazy as LP
-import qualified Data.ByteString.Lazy.Char8 as LS
+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.Maybe
 import Data.Monoid.Unicode
@@ -36,17 +38,23 @@ 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 Prelude.Unicode
 
 -- |'FormData' represents a form value and possibly an uploaded file
 -- name.
 data FormData
     = FormData {
+        -- | @'Nothing'@ for non-file values.
         fdFileName ∷ !(Maybe Text)
+        -- | MIME Type of this value, defaulted to \"text/plain\".
       , fdMIMEType ∷ !MIMEType
+        -- | The form value.
       , fdContent  ∷ !(LS.ByteString)
       }
 
@@ -60,7 +68,7 @@ data Part
 data ContDispo
     = ContDispo {
         dType   ∷ !CIAscii
-      , dParams ∷ !(Map CIAscii Text)
+      , dParams ∷ !MIMEParams
       }
 
 printContDispo ∷ ContDispo → Ascii
@@ -75,14 +83,14 @@ printContDispo d
 -- 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)]
@@ -126,12 +134,7 @@ prologue boundary
       "prologue"
 
 epilogue ∷ Parser ()
-epilogue = ( (string "--" <?> "suffix")
-             *>
-             crlf
-             *>
-             endOfInput
-           )
+epilogue = finishOff ((string "--" <?> "suffix") *> crlf)
            <?>
            "epilogue"
 
@@ -155,7 +158,7 @@ parsePart boundary src
                          ⧺ e
       where
         defaultCType ∷ MIMEType
-        defaultCType = parseMIMEType "text/plain"
+        defaultCType = [mimeType| text/plain |]
 
 partHeader ∷ Parser Headers
 partHeader = crlf *> headers
@@ -167,16 +170,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
@@ -191,27 +190,28 @@ 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
         → LS.ByteString
         → m (LS.ByteString, LS.ByteString)
 {-# INLINEABLE getBody #-}
-getBody boundary src
-    = case breakFindAfter (A.toByteString boundary) src of
-        ((before, after), True)
-            → return (before, after)
-        _   → throwError "missing boundary"
+getBody (("\r\n--" ⊕) ∘ A.toByteString → boundary) src
+    = case breakOn boundary src of
+        (before, after)
+            | LS.null after
+                → throwError "missing boundary"
+            | otherwise
+                → let len    = fromIntegral $ BS.length boundary
+                      after' = LS.drop len after
+                  in
+                    return (before, after')
 
 partToFormPair ∷ MonadError String m ⇒ Part → m (Ascii, FormData)
 {-# INLINEABLE partToFormPair #-}
@@ -231,7 +231,7 @@ partToFormPair pt@(Part {..})
 partName ∷ MonadError String m ⇒ Part → m Ascii
 {-# INLINEABLE partName #-}
 partName (Part {..})
-    = case M.lookup "name" $ dParams ptContDispo of
+    = case M.lookup "name" params of
         Just name
             → case A.fromText name of
                  Just a  → return a
@@ -240,7 +240,10 @@ partName (Part {..})
         Nothing
             → throwError $ "form-data without name: "
                          ⧺ A.toString (printContDispo ptContDispo)
+    where
+      params = case dParams ptContDispo of
+                 MIMEParams m → m
 
 partFileName ∷ Part → Maybe Text
-partFileName (Part {..})
-    = M.lookup "filename" $ dParams ptContDispo
+partFileName (dParams ∘ ptContDispo → MIMEParams m)
+    = M.lookup "filename" m