10 -- |Parse \"multipart/form-data\" based on RFC 2388:
11 -- <http://www.faqs.org/rfcs/rfc2388.html>
13 -- You usually don't have to use this module directly.
14 module Network.HTTP.Lucu.MultipartForm
16 , parseMultipartFormData
19 import Control.Applicative hiding (many)
20 import Control.Applicative.Unicode hiding ((∅))
21 import Control.Monad.Error
22 import Control.Monad.Unicode
23 import Data.Ascii (Ascii, CIAscii)
24 import qualified Data.Ascii as A
25 import Data.Attoparsec
26 import qualified Data.Attoparsec.Lazy as LP
27 import qualified Data.ByteString as BS
28 import qualified Data.ByteString.Lazy as LS
29 import Data.ByteString.Lazy.Search
33 import qualified Data.Map as M
35 import Data.Monoid.Unicode
36 import Data.Sequence (Seq)
37 import Data.Sequence.Unicode hiding ((∅))
38 import Data.Text (Text)
39 import qualified Data.Text as T
40 import Network.HTTP.Lucu.Headers
41 import Network.HTTP.Lucu.MIMEType
42 import Network.HTTP.Lucu.Parser.Http
43 import Network.HTTP.Lucu.RFC2231
44 import Prelude.Unicode
46 -- |'FormData' represents a form value and possibly an uploaded file
50 fdFileName ∷ !(Maybe Text)
51 , fdMIMEType ∷ !MIMEType
52 , fdContent ∷ !(LS.ByteString)
57 ptContDispo ∷ !ContDispo
58 , ptContType ∷ !MIMEType
59 , ptBody ∷ !LS.ByteString
65 , dParams ∷ !(Map CIAscii Text)
68 printContDispo ∷ ContDispo → Ascii
71 ( A.toAsciiBuilder (A.fromCIAscii $ dType d)
73 printMIMEParams (dParams d) )
75 -- |Parse \"multipart/form-data\" and return either @'Left' err@ or
76 -- @'Right' result@. Note that there are currently the following
79 -- * Multiple files embedded as \"multipart/mixed\" within the
80 -- \"multipart/form-data\" aren't decomposed.
82 -- * \"Content-Transfer-Encoding\"s are always ignored.
84 -- * RFC 2388 says that non-ASCII field names are encoded according
85 -- to the method in RFC 2047
86 -- <http://www.faqs.org/rfcs/rfc2047.html>, but they aren't
88 parseMultipartFormData ∷ Ascii -- ^boundary
89 → LS.ByteString -- ^input
90 → Either String [(Ascii, FormData)]
91 parseMultipartFormData boundary = (mapM partToFormPair =≪) ∘ go
93 go ∷ (Functor m, MonadError String m)
98 = case LP.parse (prologue boundary) src of
102 → throwError $ "Unparsable multipart/form-data: "
103 ⧺ intercalate ", " eCtx
106 go' ∷ (Functor m, MonadError String m)
110 {-# INLINEABLE go' #-}
112 = case LP.parse epilogue src of
116 → do (src', x) ← parsePart boundary src
119 prologue ∷ Ascii → Parser ()
121 = ( (string "--" <?> "prefix")
123 (string (A.toByteString boundary) <?> "boundary")
131 epilogue = ( (string "--" <?> "suffix")
140 parsePart ∷ (Functor m, MonadError String m)
143 → m (LS.ByteString, Part)
144 {-# INLINEABLE parsePart #-}
145 parsePart boundary src
146 = case LP.parse partHeader src of
148 → do dispo ← getContDispo hdrs
149 cType ← fromMaybe defaultCType <$> getContType hdrs
151 ← getBody boundary src'
152 return (src'', Part dispo cType body)
154 → throwError $ "unparsable part: "
155 ⧺ intercalate ", " eCtx
159 defaultCType ∷ MIMEType
160 defaultCType = parseMIMEType "text/plain"
162 partHeader ∷ Parser Headers
163 partHeader = crlf *> headers
165 getContDispo ∷ MonadError String m ⇒ Headers → m ContDispo
166 {-# INLINEABLE getContDispo #-}
168 = case getHeader "Content-Disposition" hdrs of
170 → throwError "Content-Disposition is missing"
172 → case parseOnly p $ A.toByteString str of
174 Left err → throwError $ "malformed Content-Disposition: "
179 p = do dispo ← contentDisposition
183 contentDisposition ∷ Parser ContDispo
185 = (ContDispo <$> (A.toCIAscii <$> token) ⊛ mimeParams)
189 getContType ∷ MonadError String m ⇒ Headers → m (Maybe MIMEType)
190 {-# INLINEABLE getContType #-}
192 = case getHeader "Content-Type" hdrs of
196 → case parseOnly p $ A.toByteString str of
197 Right d → return $ Just d
198 Left err → throwError $ "malformed Content-Type: "
207 getBody ∷ MonadError String m
210 → m (LS.ByteString, LS.ByteString)
211 {-# INLINEABLE getBody #-}
212 getBody (("\r\n--" ⊕) ∘ A.toByteString → boundary) src
213 = case breakOn boundary src of
216 → throwError "missing boundary"
218 → let len = fromIntegral $ BS.length boundary
219 after' = LS.drop len after
221 return (before, after')
223 partToFormPair ∷ MonadError String m ⇒ Part → m (Ascii, FormData)
224 {-# INLINEABLE partToFormPair #-}
225 partToFormPair pt@(Part {..})
226 | dType ptContDispo ≡ "form-data"
227 = do name ← partName pt
229 fdFileName = partFileName pt
230 , fdMIMEType = ptContType
235 = throwError $ "disposition type is not \"form-data\": "
236 ⧺ A.toString (A.fromCIAscii $ dType ptContDispo)
238 partName ∷ MonadError String m ⇒ Part → m Ascii
239 {-# INLINEABLE partName #-}
241 = case M.lookup "name" $ dParams ptContDispo of
243 → case A.fromText name of
245 Nothing → throwError $ "Non-ascii part name: "
248 → throwError $ "form-data without name: "
249 ⧺ A.toString (printContDispo ptContDispo)
251 partFileName ∷ Part → Maybe Text
252 partFileName (Part {..})
253 = M.lookup "filename" $ dParams ptContDispo