]> gitweb @ CieloNegro.org - Lucu.git/blobdiff - Network/HTTP/Lucu/MultipartForm.hs
Fix for insane memory usage
[Lucu.git] / Network / HTTP / Lucu / MultipartForm.hs
index 21fca67b8519f2a13d29c5c11cfbda6a116c5c18..e73b74d19b814f3830106828170b883d617bee23 100644 (file)
@@ -1,10 +1,11 @@
 module Network.HTTP.Lucu.MultipartForm
-    ( multipartFormP
+    ( FormData(..)
+    , multipartFormP
     )
     where
 
-import           Data.ByteString.Base (LazyByteString(..))
 import qualified Data.ByteString.Char8 as C8
+import qualified Data.ByteString.Lazy.Char8 as L8
 import           Data.Char
 import           Data.List
 import           Network.HTTP.Lucu.Abortion
@@ -15,7 +16,16 @@ import           Network.HTTP.Lucu.Response
 import           Network.HTTP.Lucu.Utils
 
 
-data Part = Part Headers String
+data Part = Part Headers L8.ByteString
+
+-- |This data type represents a form entry name, form value and
+-- possibly an uploaded file name.
+data FormData
+    = FormData {
+        fdName     :: String
+      , fdFileName :: Maybe String
+      , fdContent  :: L8.ByteString
+      }
 
 instance HasHeaders Part where
     getHeaders (Part hs _)    = hs
@@ -40,7 +50,7 @@ instance Show ContDispo where
                                    value
 
 
-multipartFormP :: String -> Parser [(String, String)]
+multipartFormP :: String -> Parser [FormData]
 multipartFormP boundary
     = do parts <- many (partP boundary)
          string "--"
@@ -48,7 +58,7 @@ multipartFormP boundary
          string "--"
          crlf
          eof
-         return $ map partToPair parts
+         return $ map partToFormData parts
 
 
 partP :: String -> Parser Part
@@ -61,9 +71,9 @@ partP boundary
          return $ Part hs body
 
 
-bodyP :: String -> Parser String
+bodyP :: String -> Parser L8.ByteString
 bodyP boundary
-    = do body <- many $
+    = do body <- manyChar $
                  do notFollowedBy $ do crlf
                                        string "--"
                                        string boundary
@@ -72,31 +82,62 @@ bodyP boundary
          return body
 
 
-partToPair :: Part -> (String, String)
-partToPair part@(Part _ body)
+partToFormData :: Part -> FormData
+partToFormData part@(Part _ body)
+    = let name  = partName part
+          fName = partFileName part
+      in
+        FormData {
+          fdName     = name
+        , fdFileName = fName
+        , fdContent  = body
+        }
+
+
+partName :: Part -> String
+partName = getName' . getContDispoFormData
+    where
+      getName' :: ContDispo -> String
+      getName' dispo@(ContDispo _ dParams)
+          = case find ((== "name") . map toLower . fst) dParams of
+              Just (_, name) -> name
+              Nothing   
+                  -> abortPurely BadRequest []
+                     (Just $ "form-data without name: " ++ show dispo)
+
+
+partFileName :: Part -> Maybe String
+partFileName = getFileName' . getContDispoFormData
+    where
+      getFileName' :: ContDispo -> Maybe String
+      getFileName' (ContDispo _ dParams)
+          = do (_, fileName) <- find ((== "filename") . map toLower . fst) dParams
+               return fileName
+
+getContDispoFormData :: Part -> ContDispo
+getContDispoFormData part
+    = let dispo@(ContDispo dType _) = getContDispo part
+      in
+        if map toLower dType == "form-data" then
+            dispo
+        else
+            abortPurely BadRequest []
+            (Just $ "Content-Disposition type is not form-data: " ++ dType)
+
+
+getContDispo :: Part -> ContDispo
+getContDispo part
     = case getHeader (C8.pack "Content-Disposition") part of
         Nothing  
             -> abortPurely BadRequest []
                (Just "There is a part without Content-Disposition in the multipart/form-data.")
-        Just dispo
-            -> case parse contDispoP (LPS [dispo]) of
+        Just dispoStr
+            -> case parse contDispoP (L8.fromChunks [dispoStr]) of
                  (# Success dispo, _ #)
-                     -> (getName dispo, body)
+                     -> dispo
                  (# _, _ #)
                      -> abortPurely BadRequest []
-                        (Just $ "Unparsable Content-Disposition: " ++ C8.unpack dispo)
-      where
-        getName :: ContDispo -> String
-        getName dispo@(ContDispo dType dParams)
-            | map toLower dType == "form-data"
-                = case find ((== "name") . map toLower . fst) dParams of
-                    Just (_, name) -> name
-                    Nothing   
-                        -> abortPurely BadRequest []
-                           (Just $ "form-data without name: " ++ show dispo)
-            | otherwise
-                = abortPurely BadRequest []
-                  (Just $ "Content-Disposition type is not form-data: " ++ dType)
+                        (Just $ "Unparsable Content-Disposition: " ++ C8.unpack dispoStr)
 
 
 contDispoP :: Parser ContDispo