+module Network.HTTP.Lucu.MultipartForm
+ ( multipartFormP
+ )
+ where
+
+import Data.ByteString.Base (LazyByteString(..))
+import qualified Data.ByteString.Char8 as C8
+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 String
+
+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, String)]
+multipartFormP boundary
+ = do parts <- many (partP boundary)
+ string "--"
+ string boundary
+ string "--"
+ crlf
+ eof
+ return $ map partToPair 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 String
+bodyP boundary
+ = do body <- many $
+ do notFollowedBy $ do crlf
+ string "--"
+ string boundary
+ anyChar
+ crlf
+ return body
+
+
+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
+ 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)