- = do parts <- many (partP boundary)
- _ <- string "--"
- _ <- string boundary
- _ <- string "--"
- _ <- crlf
- eof
- return $ map partToFormPair parts
-
-
-partP :: String -> Parser Part
-partP boundary
- = do _ <- string "--"
- _ <- string boundary
- _ <- crlf -- バウンダリの末尾に -- が付いてゐたらここで fail する。
- hs <- headersP
- body <- bodyP boundary
- return $ Part hs body
-
-
-bodyP :: String -> Parser L8.ByteString
-bodyP boundary
- = do body <- manyChar $
- do notFollowedBy $ ( crlf >>
- string "--" >>
- string boundary )
- anyChar
- _ <- crlf
- return body
-
-
-partToFormPair :: Part -> (String, FormData)
-partToFormPair part@(Part _ body)
- = let name = partName part
- fname = partFileName part
- fd = FormData {
- fdFileName = fname
- , fdContent = body
- }
- in (name, fd)
-
-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 dispoStr
- -> case parse contDispoP (L8.fromChunks [dispoStr]) of
- (# Success dispo, _ #)
- -> dispo
- (# _, _ #)
- -> abortPurely BadRequest []
- (Just $ "Unparsable Content-Disposition: " ++ C8.unpack dispoStr)
-
-
-contDispoP :: Parser ContDispo
-contDispoP = do dispoType <- token
- params <- allowEOF $ many paramP
- return $ ContDispo dispoType params