1 module Network.HTTP.Lucu.MultipartForm
6 import Data.ByteString.Base (LazyByteString(..))
7 import qualified Data.ByteString.Char8 as C8
10 import Network.HTTP.Lucu.Abortion
11 import Network.HTTP.Lucu.Headers
12 import Network.HTTP.Lucu.Parser
13 import Network.HTTP.Lucu.Parser.Http
14 import Network.HTTP.Lucu.Response
15 import Network.HTTP.Lucu.Utils
18 data Part = Part Headers String
20 instance HasHeaders Part where
21 getHeaders (Part hs _) = hs
22 setHeaders (Part _ b) hs = Part hs b
25 data ContDispo = ContDispo String [(String, String)]
27 instance Show ContDispo where
28 show (ContDispo dType dParams)
33 "; " ++ joinWith "; " (map showPair dParams)
35 showPair :: (String, String) -> String
36 showPair (name, value)
37 = name ++ "=" ++ if any (not . isToken) value then
43 multipartFormP :: String -> Parser [(String, String)]
44 multipartFormP boundary
45 = do parts <- many (partP boundary)
51 return $ map partToPair parts
54 partP :: String -> Parser Part
58 crlf -- バウンダリの末尾に -- が付いてゐたらここで fail する。
60 body <- bodyP boundary
64 bodyP :: String -> Parser String
67 do notFollowedBy $ do crlf
75 partToPair :: Part -> (String, String)
76 partToPair part@(Part _ body)
77 = case getHeader (C8.pack "Content-Disposition") part of
79 -> abortPurely BadRequest []
80 (Just "There is a part without Content-Disposition in the multipart/form-data.")
82 -> case parse contDispoP (LPS [dispo]) of
83 (# Success dispo, _ #)
84 -> (getName dispo, body)
86 -> abortPurely BadRequest []
87 (Just $ "Unparsable Content-Disposition: " ++ C8.unpack dispo)
89 getName :: ContDispo -> String
90 getName dispo@(ContDispo dType dParams)
91 | map toLower dType == "form-data"
92 = case find ((== "name") . map toLower . fst) dParams of
93 Just (_, name) -> name
95 -> abortPurely BadRequest []
96 (Just $ "form-data without name: " ++ show dispo)
98 = abortPurely BadRequest []
99 (Just $ "Content-Disposition type is not form-data: " ++ dType)
102 contDispoP :: Parser ContDispo
103 contDispoP = do dispoType <- token
104 params <- allowEOF $ many paramP
105 return $ ContDispo dispoType params
107 paramP :: Parser (String, String)
113 value <- token <|> quotedStr