module Network.HTTP.Lucu.MultipartForm
( FormData(..)
, multipartFormP
)
where
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 FormData
= FormData {
fdFileName :: Maybe String
, fdContent :: L8.ByteString
}
instance HasHeaders Part where
getHeaders (Part hs _) = hs
setHeaders (Part _ b) hs = Part hs b
data ContDispo = ContDispo String [(String, String)]
instance Show ContDispo where
show (ContDispo dType dParams)
= dType ++
if null dParams then
""
else
"; " ++ joinWith "; " (map showPair dParams)
where
showPair :: (String, String) -> String
showPair (name, value)
= name ++ "=" ++ if any (not . isToken) value then
quoteStr value
else
value
multipartFormP :: String -> Parser [(String, FormData)]
multipartFormP boundary
= 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
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
where
paramP :: Parser (String, String)
paramP = do _ <- many lws
_ <- char ';'
_ <- many lws
name <- token
_ <- char '='
value <- token <|> quotedStr
return (name, value)