Release 0.3.3

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

diff --git a/Network/HTTP/Lucu/MultipartForm.hs b/Network/HTTP/Lucu/MultipartForm.hs
index 8903d7f88d3c4736faccf4aaacf6c3d8361c98cd..4a34ba549764e722ea613de97ff5ff80bd116d79 100644 (file)
--- a/Network/HTTP/Lucu/MultipartForm.hs
+++ b/Network/HTTP/Lucu/MultipartForm.hs
@@ -1,5 +1,6 @@
 module Network.HTTP.Lucu.MultipartForm
-    ( multipartFormP
+    ( FormData(..)
+    , multipartFormP
     )
     where
 
@@ -17,6 +18,15 @@ import           Network.HTTP.Lucu.Utils
 
 data Part = Part Headers String
 
+-- |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  :: String
+      }
+
 instance HasHeaders Part where
     getHeaders (Part hs _)    = hs
     setHeaders (Part _  b) hs = Part hs b
@@ -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
@@ -72,8 +82,51 @@ 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 []
@@ -81,22 +134,10 @@ partToPair part@(Part _ body)
         Just dispoStr
             -> case parse contDispoP (L8.fromChunks [dispoStr]) of
                  (# Success dispo, _ #)
-                     -> (getName dispo, body)
+                     -> dispo
                  (# _, _ #)
                      -> abortPurely BadRequest []
                         (Just $ "Unparsable Content-Disposition: " ++ C8.unpack dispoStr)
-      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)
 
 
 contDispoP :: Parser ContDispo