module Network.HTTP.Lucu.MultipartForm
- ( multipartFormP
+ ( FormData(..)
+ , multipartFormP
)
where
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
value
-multipartFormP :: String -> Parser [(String, String)]
+multipartFormP :: String -> Parser [FormData]
multipartFormP boundary
= do parts <- many (partP boundary)
string "--"
string "--"
crlf
eof
- return $ map partToPair parts
+ return $ map partToFormData parts
partP :: String -> Parser Part
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
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 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