10 -- |Parse \"multipart/form-data\" based on RFC 2388:
11 -- <http://tools.ietf.org/html/rfc2388>
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
32 import qualified Data.Map as M
34 import Data.Monoid.Unicode
35 import Data.Sequence (Seq)
36 import Data.Sequence.Unicode hiding ((∅))
37 import Data.Text (Text)
38 import qualified Data.Text as T
39 import Network.HTTP.Lucu.Headers
40 import Network.HTTP.Lucu.MIMEParams
41 import Network.HTTP.Lucu.MIMEType
42 import Network.HTTP.Lucu.Parser
43 import Network.HTTP.Lucu.Parser.Http
44 import Prelude.Unicode
46 -- |'FormData' represents a form value and possibly an uploaded file
50 -- | @'Nothing'@ for non-file values.
51 fdFileName ∷ !(Maybe Text)
52 -- | MIME Type of this value, defaulted to \"text/plain\".
53 , fdMIMEType ∷ !MIMEType
55 , fdContent ∷ !(LS.ByteString)
60 ptContDispo ∷ !ContDispo
61 , ptContType ∷ !MIMEType
62 , ptBody ∷ !LS.ByteString
68 , dParams ∷ !MIMEParams
71 printContDispo ∷ ContDispo → Ascii
74 ( A.toAsciiBuilder (A.fromCIAscii $ dType d)
76 printMIMEParams (dParams d) )
78 -- |Parse \"multipart/form-data\" and return either @'Left' err@ or
79 -- @'Right' result@. Note that there are currently the following
82 -- * Multiple files embedded as \"multipart/mixed\" within the
83 -- \"multipart/form-data\" won't be decomposed.
85 -- * \"Content-Transfer-Encoding\" is always ignored.
87 -- * RFC 2388 (<http://tools.ietf.org/html/rfc2388#section-3>) says
88 -- that non-ASCII field names are encoded according to the method in
89 -- RFC 2047 (<http://tools.ietf.org/html/rfc2047>), but they won't
91 parseMultipartFormData ∷ Ascii -- ^boundary
92 → LS.ByteString -- ^input
93 → Either String [(Ascii, FormData)]
94 parseMultipartFormData boundary = (mapM partToFormPair =≪) ∘ go
96 go ∷ (Functor m, MonadError String m)
101 = case LP.parse (prologue boundary) src of
105 → throwError $ "Unparsable multipart/form-data: "
106 ⧺ intercalate ", " eCtx
109 go' ∷ (Functor m, MonadError String m)
113 {-# INLINEABLE go' #-}
115 = case LP.parse epilogue src of
119 → do (src', x) ← parsePart boundary src
122 prologue ∷ Ascii → Parser ()
124 = ( (string "--" <?> "prefix")
126 (string (A.toByteString boundary) <?> "boundary")
134 epilogue = finishOff ((string "--" <?> "suffix") *> crlf)
138 parsePart ∷ (Functor m, MonadError String m)
141 → m (LS.ByteString, Part)
142 {-# INLINEABLE parsePart #-}
143 parsePart boundary src
144 = case LP.parse partHeader src of
146 → do dispo ← getContDispo hdrs
147 cType ← fromMaybe defaultCType <$> getContType hdrs
149 ← getBody boundary src'
150 return (src'', Part dispo cType body)
152 → throwError $ "unparsable part: "
153 ⧺ intercalate ", " eCtx
157 defaultCType ∷ MIMEType
158 defaultCType = parseMIMEType "text/plain"
160 partHeader ∷ Parser Headers
161 partHeader = crlf *> headers
163 getContDispo ∷ MonadError String m ⇒ Headers → m ContDispo
164 {-# INLINEABLE getContDispo #-}
166 = case getHeader "Content-Disposition" hdrs of
168 → throwError "Content-Disposition is missing"
170 → case parseOnly (finishOff contentDisposition) $ A.toByteString str of
172 Left err → throwError $ "malformed Content-Disposition: "
177 contentDisposition ∷ Parser ContDispo
179 = (ContDispo <$> (A.toCIAscii <$> token) ⊛ mimeParams)
183 getContType ∷ MonadError String m ⇒ Headers → m (Maybe MIMEType)
184 {-# INLINEABLE getContType #-}
186 = case getHeader "Content-Type" hdrs of
190 → case parseOnly (finishOff mimeType) $ A.toByteString str of
191 Right d → return $ Just d
192 Left err → throwError $ "malformed Content-Type: "
197 getBody ∷ MonadError String m
200 → m (LS.ByteString, LS.ByteString)
201 {-# INLINEABLE getBody #-}
202 getBody (("\r\n--" ⊕) ∘ A.toByteString → boundary) src
203 = case breakOn boundary src of
206 → throwError "missing boundary"
208 → let len = fromIntegral $ BS.length boundary
209 after' = LS.drop len after
211 return (before, after')
213 partToFormPair ∷ MonadError String m ⇒ Part → m (Ascii, FormData)
214 {-# INLINEABLE partToFormPair #-}
215 partToFormPair pt@(Part {..})
216 | dType ptContDispo ≡ "form-data"
217 = do name ← partName pt
219 fdFileName = partFileName pt
220 , fdMIMEType = ptContType
225 = throwError $ "disposition type is not \"form-data\": "
226 ⧺ A.toString (A.fromCIAscii $ dType ptContDispo)
228 partName ∷ MonadError String m ⇒ Part → m Ascii
229 {-# INLINEABLE partName #-}
231 = case M.lookup "name" params of
233 → case A.fromText name of
235 Nothing → throwError $ "Non-ascii part name: "
238 → throwError $ "form-data without name: "
239 ⧺ A.toString (printContDispo ptContDispo)
241 params = case dParams ptContDispo of
244 partFileName ∷ Part → Maybe Text
245 partFileName (dParams ∘ ptContDispo → MIMEParams m)
246 = M.lookup "filename" m