Many bugfixes

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

diff --git a/Network/HTTP/Lucu/MultipartForm.hs b/Network/HTTP/Lucu/MultipartForm.hs
index 7d0866cd4225fe0ec54f8c77f84a01fc24e5dbe6..72eef21c1ec9e99be27857e48169cd0b068d6c3e 100644 (file)
--- a/Network/HTTP/Lucu/MultipartForm.hs
+++ b/Network/HTTP/Lucu/MultipartForm.hs
@@ -11,9 +11,10 @@ module Network.HTTP.Lucu.MultipartForm
     )
     where
 import Control.Applicative hiding (many)
+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.Map (Map)
@@ -22,6 +23,7 @@ import Data.Maybe
 import Data.Monoid.Unicode
 import Data.Text (Text)
 import Network.HTTP.Lucu.Headers
+import Network.HTTP.Lucu.Parser
 import Network.HTTP.Lucu.Parser.Http
 import Network.HTTP.Lucu.RFC2231
 import Prelude.Unicode
@@ -60,33 +62,34 @@ printContDispo d
 
 multipartFormP ∷ Ascii → Parser [(Text, FormData)]
 multipartFormP boundary
-    = do parts ← many $ try $ 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
-    = 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
-    = 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 #-}
@@ -138,6 +141,10 @@ getContDispo hdr
                                           ])
 
 contDispoP ∷ Parser ContDispo
-contDispoP = do dispoType ← A.toCIAscii <$> token
-                params    ← paramsP
-                return $ ContDispo dispoType params
+{-# INLINEABLE contDispoP #-}
+contDispoP
+    = do dispoType ← A.toCIAscii <$> token
+         params    ← paramsP
+         return $ ContDispo dispoType params
+      <?>
+      "contDispoP"