1 module Network.HTTP.Lucu.MultipartForm
7 import qualified Data.ByteString.Char8 as C8
8 import qualified Data.ByteString.Lazy.Char8 as L8
11 import Network.HTTP.Lucu.Abortion
12 import Network.HTTP.Lucu.Headers
13 import Network.HTTP.Lucu.Parser
14 import Network.HTTP.Lucu.Parser.Http
15 import Network.HTTP.Lucu.Response
16 import Network.HTTP.Lucu.Utils
19 data Part = Part Headers L8.ByteString
21 -- |This data type represents a form entry name, form value and
22 -- possibly an uploaded file name.
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 [FormData]
54 multipartFormP boundary
55 = do parts <- many (partP boundary)
61 return $ map partToFormData 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 $ do crlf
85 partToFormData :: Part -> FormData
86 partToFormData part@(Part _ body)
87 = let name = partName part
88 fName = partFileName part
97 partName :: Part -> String
98 partName = getName' . getContDispoFormData
100 getName' :: ContDispo -> String
101 getName' dispo@(ContDispo _ dParams)
102 = case find ((== "name") . map toLower . fst) dParams of
103 Just (_, name) -> name
105 -> abortPurely BadRequest []
106 (Just $ "form-data without name: " ++ show dispo)
109 partFileName :: Part -> Maybe String
110 partFileName = getFileName' . getContDispoFormData
112 getFileName' :: ContDispo -> Maybe String
113 getFileName' (ContDispo _ dParams)
114 = do (_, fileName) <- find ((== "filename") . map toLower . fst) dParams
117 getContDispoFormData :: Part -> ContDispo
118 getContDispoFormData part
119 = let dispo@(ContDispo dType _) = getContDispo part
121 if map toLower dType == "form-data" then
124 abortPurely BadRequest []
125 (Just $ "Content-Disposition type is not form-data: " ++ dType)
128 getContDispo :: Part -> ContDispo
130 = case getHeader (C8.pack "Content-Disposition") part of
132 -> abortPurely BadRequest []
133 (Just "There is a part without Content-Disposition in the multipart/form-data.")
135 -> case parse contDispoP (L8.fromChunks [dispoStr]) of
136 (# Success dispo, _ #)
139 -> abortPurely BadRequest []
140 (Just $ "Unparsable Content-Disposition: " ++ C8.unpack dispoStr)
143 contDispoP :: Parser ContDispo
144 contDispoP = do dispoType <- token
145 params <- allowEOF $ many paramP
146 return $ ContDispo dispoType params
148 paramP :: Parser (String, String)
154 value <- token <|> quotedStr