-
-partToPair :: Part -> (String, String)
-partToPair part@(Part _ body)
- = 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
- (# Success dispo, _ #)
- -> (getName dispo, body)
- (# _, _ #)
- -> 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)
-
-
-contDispoP :: Parser ContDispo
-contDispoP = do dispoType <- token
- params <- allowEOF $ many paramP
+partToFormPair ∷ Monad m ⇒ Part → m (Maybe (Text, FormData))
+{-# INLINEABLE partToFormPair #-}
+partToFormPair pt
+ | dType (ptContDispo pt) ≡ "form-data"
+ = do name ← partName pt
+ let fname = partFileName pt
+ let fd = FormData {
+ fdFileName = fname
+ , fdContent = ptBody pt
+ }
+ return $ Just (name, fd)
+ | otherwise
+ = return Nothing
+
+partName ∷ Monad m ⇒ Part → m Text
+{-# INLINEABLE partName #-}
+partName (Part {..})
+ = case M.lookup "name" $ dParams ptContDispo of
+ Just name
+ → return name
+ Nothing
+ → fail ("form-data without name: " ⧺
+ A.toString (printContDispo ptContDispo))
+
+partFileName ∷ Part → Maybe Text
+{-# INLINEABLE partFileName #-}
+partFileName (Part {..})
+ = M.lookup "filename" $ dParams ptContDispo
+
+getContDispo ∷ Monad m ⇒ Headers → m ContDispo
+{-# INLINEABLE getContDispo #-}
+getContDispo hdr
+ = case getHeader "Content-Disposition" hdr of
+ Nothing
+ → fail "There is a part without Content-Disposition in the multipart/form-data."
+ Just str
+ → let p = do d ← contDispoP
+ endOfInput
+ return d
+ bs = A.toByteString str
+ in
+ case parseOnly p bs of
+ Right d → return d
+ Left err → fail (concat [ "Unparsable Content-Disposition: "
+ , BS.unpack bs
+ , ": "
+ , err
+ ])
+
+contDispoP ∷ Parser ContDispo
+contDispoP = do dispoType ← A.toCIAscii <$> token
+ params ← paramsP