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 value and possibly an uploaded
25 fdFileName :: Maybe String
26 , fdContent :: L8.ByteString
29 instance HasHeaders Part where
30 getHeaders (Part hs _) = hs
31 setHeaders (Part _ b) hs = Part hs b
34 data ContDispo = ContDispo String [(String, String)]
36 instance Show ContDispo where
37 show (ContDispo dType dParams)
42 "; " ++ joinWith "; " (map showPair dParams)
44 showPair :: (String, String) -> String
45 showPair (name, value)
46 = name ++ "=" ++ if any (not . isToken) value then
52 multipartFormP :: String -> Parser [(String, FormData)]
53 multipartFormP boundary
54 = do parts <- many (partP boundary)
60 return $ map partToFormPair parts
63 partP :: String -> Parser Part
67 _ <- crlf -- バウンダリの末尾に -- が付いてゐたらここで fail する。
69 body <- bodyP boundary
73 bodyP :: String -> Parser L8.ByteString
75 = do body <- manyChar $
76 do notFollowedBy $ ( crlf >>
84 partToFormPair :: Part -> (String, FormData)
85 partToFormPair part@(Part _ body)
86 = let name = partName part
87 fname = partFileName part
94 partName :: Part -> String
95 partName = getName' . getContDispoFormData
97 getName' :: ContDispo -> String
98 getName' dispo@(ContDispo _ dParams)
99 = case find ((== "name") . map toLower . fst) dParams of
100 Just (_, name) -> name
102 -> abortPurely BadRequest []
103 (Just $ "form-data without name: " ++ show dispo)
106 partFileName :: Part -> Maybe String
107 partFileName = getFileName' . getContDispoFormData
109 getFileName' :: ContDispo -> Maybe String
110 getFileName' (ContDispo _ dParams)
111 = do (_, fileName) <- find ((== "filename") . map toLower . fst) dParams
114 getContDispoFormData :: Part -> ContDispo
115 getContDispoFormData part
116 = let dispo@(ContDispo dType _) = getContDispo part
118 if map toLower dType == "form-data" then
121 abortPurely BadRequest []
122 (Just $ "Content-Disposition type is not form-data: " ++ dType)
125 getContDispo :: Part -> ContDispo
127 = case getHeader (C8.pack "Content-Disposition") part of
129 -> abortPurely BadRequest []
130 (Just "There is a part without Content-Disposition in the multipart/form-data.")
132 -> case parse contDispoP (L8.fromChunks [dispoStr]) of
133 (# Success dispo, _ #)
136 -> abortPurely BadRequest []
137 (Just $ "Unparsable Content-Disposition: " ++ C8.unpack dispoStr)
140 contDispoP :: Parser ContDispo
141 contDispoP = do dispoType <- token
142 params <- allowEOF $ many paramP
143 return $ ContDispo dispoType params
145 paramP :: Parser (String, String)
146 paramP = do _ <- many lws
151 value <- token <|> quotedStr