5 , MultiParamTypeClasses
14 -- |Parse \"multipart/form-data\" based on RFC 2388:
15 -- <http://tools.ietf.org/html/rfc2388>
16 module Network.HTTP.Lucu.MultipartForm
18 , parseMultipartFormData
21 import Control.Applicative hiding (many)
22 import Control.Applicative.Unicode hiding ((∅))
23 import Control.Monad.Error (MonadError, throwError)
24 import Control.Monad.Unicode
25 import Data.Ascii (Ascii, CIAscii, AsciiBuilder)
27 import Data.Attoparsec
28 import qualified Data.Attoparsec.Lazy as LP
29 import qualified Data.ByteString as BS
30 import qualified Data.ByteString.Lazy as LS
31 import Data.ByteString.Lazy.Search
32 import Data.Collections
33 import Data.Convertible.Base
34 import Data.Convertible.Instances.Ascii ()
35 import Data.Convertible.Utils
37 import Data.List (intercalate)
39 import Data.Monoid.Unicode
40 import Data.Sequence (Seq)
41 import Data.Text (Text)
42 import Network.HTTP.Lucu.Headers
43 import Network.HTTP.Lucu.MIMEParams
44 import Network.HTTP.Lucu.MIMEType
45 import Network.HTTP.Lucu.Parser
46 import Network.HTTP.Lucu.Parser.Http
47 import Network.HTTP.Lucu.Utils
48 import Prelude hiding (lookup, mapM)
49 import Prelude.Unicode
51 -- |'FormData' represents a form value and possibly an uploaded file
55 -- | @'Nothing'@ for non-file values.
56 fdFileName ∷ !(Maybe Text)
57 -- | MIME Type of this value, defaulted to \"text/plain\".
58 , fdMIMEType ∷ !MIMEType
60 , fdContent ∷ !(LS.ByteString)
65 ptContDispo ∷ !ContDispo
66 , ptContType ∷ !MIMEType
67 , ptBody ∷ !LS.ByteString
73 , dParams ∷ !MIMEParams
76 instance ConvertSuccess ContDispo Ascii where
77 {-# INLINE convertSuccess #-}
78 convertSuccess = convertSuccessVia ((⊥) ∷ AsciiBuilder)
80 instance ConvertSuccess ContDispo AsciiBuilder where
81 {-# INLINE convertSuccess #-}
82 convertSuccess (ContDispo {..})
83 = cs dType ⊕ cs dParams
85 deriveAttempts [ ([t| ContDispo |], [t| Ascii |])
86 , ([t| ContDispo |], [t| AsciiBuilder |])
89 -- |Parse \"multipart/form-data\" to a list of @(name,
90 -- formData)@. Note that there are currently the following
93 -- * Multiple files embedded as \"multipart/mixed\" within the
94 -- \"multipart/form-data\" won't be decomposed.
96 -- * \"Content-Transfer-Encoding\" is always ignored.
98 -- * RFC 2388 (<http://tools.ietf.org/html/rfc2388#section-3>) says
99 -- that non-ASCII field names are encoded according to the method
100 -- in RFC 2047 (<http://tools.ietf.org/html/rfc2047>), but this
101 -- function currently doesn't decode them.
102 parseMultipartFormData ∷ Ascii -- ^boundary
103 → LS.ByteString -- ^input
104 → Either String [(Ascii, FormData)]
105 parseMultipartFormData boundary = (mapM partToFormPair =≪) ∘ go
107 go ∷ (Functor m, MonadError String m)
110 {-# INLINEABLE go #-}
112 = case LP.parse (prologue boundary) src of
116 → throwError $ "Unparsable multipart/form-data: "
117 ⧺ intercalate ", " eCtx
120 go' ∷ (Functor m, MonadError String m)
124 {-# INLINEABLE go' #-}
126 = case LP.parse epilogue src of
130 → do (src', x) ← parsePart boundary src
133 prologue ∷ Ascii → Parser ()
135 = ( (string "--" <?> "prefix")
137 (string (cs boundary) <?> "boundary")
145 epilogue = finishOff ((string "--" <?> "suffix") *> crlf)
149 parsePart ∷ (Functor m, MonadError String m)
152 → m (LS.ByteString, Part)
153 {-# INLINEABLE parsePart #-}
154 parsePart boundary src
155 = case LP.parse partHeader src of
157 → do dispo ← getContDispo hdrs
158 cType ← fromMaybe defaultCType <$> getContType hdrs
160 ← getBody boundary src'
161 return (src'', Part dispo cType body)
163 → throwError $ "unparsable part: "
164 ⧺ intercalate ", " eCtx
168 defaultCType ∷ MIMEType
169 defaultCType = [mimeType| text/plain |]
171 partHeader ∷ Parser Headers
172 {-# INLINE partHeader #-}
173 partHeader = crlf *> def
175 getContDispo ∷ MonadError String m ⇒ Headers → m ContDispo
176 {-# INLINEABLE getContDispo #-}
178 = case getHeader "Content-Disposition" hdrs of
180 → throwError "Content-Disposition is missing"
182 → case parseOnly (finishOff contentDisposition) $ cs str of
184 Left err → throwError $ "malformed Content-Disposition: "
189 contentDisposition ∷ Parser ContDispo
190 {-# INLINEABLE contentDisposition #-}
192 = (ContDispo <$> (cs <$> token) ⊛ def)
196 getContType ∷ MonadError String m ⇒ Headers → m (Maybe MIMEType)
197 {-# INLINEABLE getContType #-}
199 = case getHeader "Content-Type" hdrs of
203 → case parseOnly (finishOff def) $ cs str of
204 Right d → return $ Just d
205 Left err → throwError $ "malformed Content-Type: "
210 getBody ∷ MonadError String m
213 → m (LS.ByteString, LS.ByteString)
214 {-# INLINEABLE getBody #-}
215 getBody (("\r\n--" ⊕) ∘ cs → boundary) src
216 = case breakOn boundary src of
219 → throwError "missing boundary"
221 → let len = fromIntegral $ BS.length boundary
222 after' = LS.drop len after
224 return (before, after')
226 partToFormPair ∷ MonadError String m ⇒ Part → m (Ascii, FormData)
227 {-# INLINEABLE partToFormPair #-}
228 partToFormPair pt@(Part {..})
229 | dType ptContDispo ≡ "form-data"
230 = do name ← partName pt
232 fdFileName = partFileName pt
233 , fdMIMEType = ptContType
238 = throwError $ "disposition type is not \"form-data\": "
239 ⊕ cs (dType ptContDispo)
241 partName ∷ MonadError String m ⇒ Part → m Ascii
242 {-# INLINEABLE partName #-}
244 = case lookup "name" $ dParams ptContDispo of
248 Failure e → throwError $ show e
250 → throwError $ "form-data without name: "
251 ⊕ convertSuccessVia ((⊥) ∷ Ascii) ptContDispo
253 partFileName ∷ Part → Maybe Text
254 partFileName (ptContDispo → ContDispo {..})
255 = lookup "filename" dParams