Many bugfixes

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

diff --git a/Network/HTTP/Lucu/MultipartForm.hs b/Network/HTTP/Lucu/MultipartForm.hs
index 4dcf076c93c13be34f7fd3bc0986f24652601616..72eef21c1ec9e99be27857e48169cd0b068d6c3e 100644 (file)
--- a/Network/HTTP/Lucu/MultipartForm.hs
+++ b/Network/HTTP/Lucu/MultipartForm.hs
@@ -1,8 +1,8 @@
 {-# LANGUAGE
     DoAndIfThenElse
   , OverloadedStrings
+  , RecordWildCards
   , ScopedTypeVariables
-  , UnboxedTuples
   , UnicodeSyntax
   #-}
 module Network.HTTP.Lucu.MultipartForm
@@ -11,20 +11,21 @@ module Network.HTTP.Lucu.MultipartForm
     )
     where
 import Control.Applicative hiding (many)
-import Data.Ascii (Ascii, CIAscii, AsciiBuilder)
+import Control.Monad
+import Data.Ascii (Ascii, CIAscii)
 import qualified Data.Ascii as A
-import Data.Attoparsec.Char8
+import Data.Attoparsec
 import qualified Data.ByteString.Char8 as BS
 import qualified Data.ByteString.Lazy.Char8 as LS
-import           Data.Char
-import           Data.List
+import Data.Map (Map)
+import qualified Data.Map as M
 import Data.Maybe
 import Data.Monoid.Unicode
 import Data.Text (Text)
-import           Network.HTTP.Lucu.Headers
-import           Network.HTTP.Lucu.Parser.Http
-import           Network.HTTP.Lucu.Response
-import           Network.HTTP.Lucu.Utils
+import Network.HTTP.Lucu.Headers
+import Network.HTTP.Lucu.Parser
+import Network.HTTP.Lucu.Parser.Http
+import Network.HTTP.Lucu.RFC2231
 import Prelude.Unicode
 
 -- |This data type represents a form value and possibly an uploaded
@@ -49,67 +50,52 @@ instance HasHeaders Part where
 data ContDispo
     = ContDispo {
         dType   ∷ !CIAscii
-      , dParams ∷ ![(CIAscii, Ascii)]
+      , dParams ∷ !(Map CIAscii Text)
       }
 
 printContDispo ∷ ContDispo → Ascii
 printContDispo d
-    = A.fromAsciiBuilder $
+    = A.fromAsciiBuilder
       ( A.toAsciiBuilder (A.fromCIAscii $ dType d)
         ⊕
-        ( if null $ dParams d then
-              (∅)
-          else
-              A.toAsciiBuilder "; " ⊕
-              joinWith "; " (map printPair $ dParams d) ) )
-    where
-      printPair ∷ (CIAscii, Ascii) → AsciiBuilder
-      printPair (name, value)
-          = A.toAsciiBuilder (A.fromCIAscii name) ⊕
-            A.toAsciiBuilder "=" ⊕
-            ( if BS.any ((¬) ∘ isToken) $ A.toByteString value then
-                  quoteStr value
-              else
-                  A.toAsciiBuilder value )
+        printParams (dParams d) )
 
 multipartFormP ∷ Ascii → Parser [(Text, FormData)]
 multipartFormP boundary
-    = try $
-      do parts ← many (partP boundary)
-         _     ← string "--"
-         _     ← string $ A.toByteString boundary
-         _     ← string "--"
+    = do void boundaryP
+         parts ← many $ partP boundaryP
+         void (string "--" <?> "suffix")
          crlf
          catMaybes <$> mapM partToFormPair parts
+      <?>
+      "multipartFormP"
+    where
+      boundaryP ∷ Parser BS.ByteString
+      boundaryP = string ("--" ⊕ A.toByteString boundary)
+                  <?>
+                  "boundaryP"
 
-partP ∷ Ascii → Parser Part
-partP boundary
-    = try $
-      do _    ← string "--"
-         _    ← string $ A.toByteString boundary
-         crlf
+partP ∷ Parser α → Parser Part
+partP boundaryP
+    = do crlf
          hs   ← headersP
          d    ← getContDispo hs
-         body ← bodyP boundary
+         body ← bodyP boundaryP
          return $ Part hs d body
+      <?>
+      "partP"
 
-bodyP ∷ Ascii → Parser LS.ByteString
-bodyP boundary
-    = try $
-      do body ← manyCharsTill anyChar $
-                    try $
-                    do crlf
-                       _ ← string "--"
-                       _ ← string $ A.toByteString boundary
-                       return ()
-         crlf
-         return body
+bodyP ∷ Parser α → Parser LS.ByteString
+bodyP boundaryP
+    = manyOctetsTill anyWord8 (try $ crlf *> boundaryP)
+      <?>
+      "bodyP"
 
 partToFormPair ∷ Monad m ⇒ Part → m (Maybe (Text, FormData))
 {-# INLINEABLE partToFormPair #-}
 partToFormPair pt
     | dType (ptContDispo pt) ≡ "form-data"
-        = do name  ← partName pt
+        = do name ← partName pt
              let fname = partFileName pt
              let fd    = FormData {
                            fdFileName = fname
@@ -121,25 +107,25 @@ partToFormPair pt
 
 partName ∷ Monad m ⇒ Part → m Text
 {-# INLINEABLE partName #-}
-partName pt
-    = case find ((≡ "name") ∘ fst) $ dParams $ ptContDispo pt of
-        Just (_, name)
+partName (Part {..})
+    = case M.lookup "name" $ dParams ptContDispo of
+        Just name
             → return name
         Nothing
             → fail ("form-data without name: " ⧺
-                    A.toString (printContDispo $ ptContDispo pt))
+                    A.toString (printContDispo ptContDispo))
 
 partFileName ∷ Part → Maybe Text
 {-# INLINEABLE partFileName #-}
-partFileName pt
-    = snd <$> (find ((== "filename") ∘ fst) $ dParams $ ptContDispo pt)
+partFileName (Part {..})
+    = M.lookup "filename" $ dParams ptContDispo
 
 getContDispo ∷ Monad m ⇒ Headers → m ContDispo
 {-# INLINEABLE getContDispo #-}
 getContDispo hdr
     = case getHeader "Content-Disposition" hdr of
         Nothing
-            → fail ("There is a part without Content-Disposition in the multipart/form-data.")
+            → fail "There is a part without Content-Disposition in the multipart/form-data."
         Just str
             → let p  = do d ← contDispoP
                           endOfInput
@@ -155,16 +141,10 @@ getContDispo hdr
                                           ])
 
 contDispoP ∷ Parser ContDispo
-contDispoP = try $
-             do dispoType ← A.toCIAscii <$> token
-                params    ← many paramP
-                return $ ContDispo dispoType params
-    where
-      paramP ∷ Parser (CIAscii, Ascii)
-      paramP = do skipMany lws
-                  _     ← char ';'
-                  skipMany lws
-                  name  ← A.toCIAscii <$> token
-                  _     ← char '='
-                  value ← token <|> quotedStr
-                  return (name, value)
+{-# INLINEABLE contDispoP #-}
+contDispoP
+    = do dispoType ← A.toCIAscii <$> token
+         params    ← paramsP
+         return $ ContDispo dispoType params
+      <?>
+      "contDispoP"