5 module Network.HTTP.Lucu.MultipartForm
10 import qualified Data.ByteString.Char8 as C8
11 import qualified Data.ByteString.Lazy.Char8 as L8
14 import Network.HTTP.Lucu.Abortion
15 import Network.HTTP.Lucu.Headers
16 import Network.HTTP.Lucu.Parser.Http
17 import Network.HTTP.Lucu.Response
18 import Network.HTTP.Lucu.Utils
20 data Part = Part Headers L8.ByteString
22 -- |This data type represents a form value and possibly an uploaded
26 fdFileName :: Maybe String
27 , fdContent :: L8.ByteString
30 instance HasHeaders Part where
31 getHeaders (Part hs _) = hs
32 setHeaders (Part _ b) hs = Part hs b
35 data ContDispo = ContDispo String [(String, String)]
37 instance Show ContDispo where
38 show (ContDispo dType dParams)
43 "; " ++ joinWith "; " (map showPair dParams)
45 showPair :: (String, String) -> String
46 showPair (name, value)
47 = name ++ "=" ++ if any (not . isToken) value then
53 multipartFormP :: String -> Parser [(String, FormData)]
54 multipartFormP boundary
55 = do parts <- many (partP boundary)
61 return $ map partToFormPair parts
64 partP :: String -> Parser Part
68 _ <- crlf -- バウンダリの末尾に -- が付いてゐたらここで fail する。
70 body <- bodyP boundary
74 bodyP :: String -> Parser L8.ByteString
76 = do body <- manyChar $
77 do notFollowedBy $ ( crlf >>
85 partToFormPair :: Part -> (String, FormData)
86 partToFormPair part@(Part _ body)
87 = let name = partName part
88 fname = partFileName part
95 partName :: Part -> String
96 partName = getName' . getContDispoFormData
98 getName' :: ContDispo -> String
99 getName' dispo@(ContDispo _ dParams)
100 = case find ((== "name") . map toLower . fst) dParams of
101 Just (_, name) -> name
103 -> abortPurely BadRequest []
104 (Just $ "form-data without name: " ++ show dispo)
107 partFileName :: Part -> Maybe String
108 partFileName = getFileName' . getContDispoFormData
110 getFileName' :: ContDispo -> Maybe String
111 getFileName' (ContDispo _ dParams)
112 = do (_, fileName) <- find ((== "filename") . map toLower . fst) dParams
115 getContDispoFormData :: Part -> ContDispo
116 getContDispoFormData part
117 = let dispo@(ContDispo dType _) = getContDispo part
119 if map toLower dType == "form-data" then
122 abortPurely BadRequest []
123 (Just $ "Content-Disposition type is not form-data: " ++ dType)
126 getContDispo :: Part -> ContDispo
128 = case getHeader (C8.pack "Content-Disposition") part of
130 -> abortPurely BadRequest []
131 (Just "There is a part without Content-Disposition in the multipart/form-data.")
133 -> case parse contDispoP (L8.fromChunks [dispoStr]) of
134 (# Success dispo, _ #)
137 -> abortPurely BadRequest []
138 (Just $ "Unparsable Content-Disposition: " ++ C8.unpack dispoStr)
141 contDispoP :: Parser ContDispo
142 contDispoP = do dispoType <- token
143 params <- allowEOF $ many paramP
144 return $ ContDispo dispoType params
146 paramP :: Parser (String, String)
147 paramP = do _ <- many lws
152 value <- token <|> quotedStr