+{-# LANGUAGE
+ UnboxedTuples
+ , UnicodeSyntax
+ #-}
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
import Network.HTTP.Lucu.Headers
-import Network.HTTP.Lucu.Parser
import Network.HTTP.Lucu.Parser.Http
import Network.HTTP.Lucu.Response
import Network.HTTP.Lucu.Utils
+data Part = Part Headers L8.ByteString
-data Part = Part Headers String
+-- |This data type represents a form value and possibly an uploaded
+-- file name.
+data FormData
+ = FormData {
+ fdFileName :: Maybe String
+ , fdContent :: L8.ByteString
+ }
instance HasHeaders Part where
getHeaders (Part hs _) = hs
value
-multipartFormP :: String -> Parser [(String, String)]
+multipartFormP :: String -> Parser [(String, FormData)]
multipartFormP boundary
= do parts <- many (partP boundary)
- string "--"
- string boundary
- string "--"
- crlf
+ _ <- string "--"
+ _ <- string boundary
+ _ <- string "--"
+ _ <- crlf
eof
- return $ map partToPair parts
+ return $ map partToFormPair parts
partP :: String -> Parser Part
partP boundary
- = do string "--"
- string boundary
- crlf -- バウンダリの末尾に -- が付いてゐたらここで fail する。
+ = do _ <- string "--"
+ _ <- string boundary
+ _ <- crlf -- バウンダリの末尾に -- が付いてゐたらここで fail する。
hs <- headersP
body <- bodyP boundary
return $ Part hs body
-bodyP :: String -> Parser String
+bodyP :: String -> Parser L8.ByteString
bodyP boundary
- = do body <- many $
- do notFollowedBy $ do crlf
- string "--"
- string boundary
+ = do body <- manyChar $
+ do notFollowedBy $ ( crlf >>
+ string "--" >>
+ string boundary )
anyChar
- crlf
+ _ <- crlf
return body
-partToPair :: Part -> (String, String)
-partToPair part@(Part _ 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 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
return $ ContDispo dispoType params
where
paramP :: Parser (String, String)
- paramP = do many lws
- char ';'
- many lws
- name <- token
- char '='
+ paramP = do _ <- many lws
+ _ <- char ';'
+ _ <- many lws
+ name <- token
+ _ <- char '='
value <- token <|> quotedStr
return (name, value)