11 -- |Parse \"multipart/form-data\" based on RFC 2388:
12 -- <http://tools.ietf.org/html/rfc2388>
13 module Network.HTTP.Lucu.MultipartForm
15 , parseMultipartFormData
18 import Control.Applicative hiding (many)
19 import Control.Applicative.Unicode hiding ((∅))
20 import Control.Monad.Error (MonadError, throwError)
21 import Control.Monad.Unicode
22 import Data.Ascii (Ascii, CIAscii)
23 import qualified Data.Ascii as A
24 import Data.Attoparsec
25 import qualified Data.Attoparsec.Lazy as LP
26 import qualified Data.ByteString as BS
27 import qualified Data.ByteString.Lazy as LS
28 import Data.ByteString.Lazy.Search
29 import Data.Collections
30 import Data.Convertible.Base
31 import Data.Convertible.Instances.Ascii ()
32 import Data.Convertible.Utils
33 import Data.List (intercalate)
35 import Data.Monoid.Unicode
36 import Data.Sequence (Seq)
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 (MIMEType)
42 import qualified Network.HTTP.Lucu.MIMEType as MT
43 import Network.HTTP.Lucu.MIMEType.TH
44 import Network.HTTP.Lucu.Parser
45 import Network.HTTP.Lucu.Parser.Http
46 import Network.HTTP.Lucu.Utils
47 import Prelude hiding (lookup, mapM)
48 import Prelude.Unicode
50 -- |'FormData' represents a form value and possibly an uploaded file
54 -- | @'Nothing'@ for non-file values.
55 fdFileName ∷ !(Maybe Text)
56 -- | MIME Type of this value, defaulted to \"text/plain\".
57 , fdMIMEType ∷ !MIMEType
59 , fdContent ∷ !(LS.ByteString)
64 ptContDispo ∷ !ContDispo
65 , ptContType ∷ !MIMEType
66 , ptBody ∷ !LS.ByteString
72 , dParams ∷ !MIMEParams
76 printContDispo ∷ ContDispo → Ascii
79 ( A.toAsciiBuilder (A.fromCIAscii $ dType d)
83 -- |Parse \"multipart/form-data\" and return either @'Left' err@ or
84 -- @'Right' result@. Note that there are currently the following
87 -- * Multiple files embedded as \"multipart/mixed\" within the
88 -- \"multipart/form-data\" won't be decomposed.
90 -- * \"Content-Transfer-Encoding\" is always ignored.
92 -- * RFC 2388 (<http://tools.ietf.org/html/rfc2388#section-3>) says
93 -- that non-ASCII field names are encoded according to the method in
94 -- RFC 2047 (<http://tools.ietf.org/html/rfc2047>), but they won't
96 parseMultipartFormData ∷ Ascii -- ^boundary
97 → LS.ByteString -- ^input
98 → Either String [(Ascii, FormData)]
99 parseMultipartFormData boundary = (mapM partToFormPair =≪) ∘ go
101 go ∷ (Functor m, MonadError String m)
104 {-# INLINEABLE go #-}
106 = case LP.parse (prologue boundary) src of
110 → throwError $ "Unparsable multipart/form-data: "
111 ⧺ intercalate ", " eCtx
114 go' ∷ (Functor m, MonadError String m)
118 {-# INLINEABLE go' #-}
120 = case LP.parse epilogue src of
124 → do (src', x) ← parsePart boundary src
127 prologue ∷ Ascii → Parser ()
129 = ( (string "--" <?> "prefix")
131 (string (A.toByteString boundary) <?> "boundary")
139 epilogue = finishOff ((string "--" <?> "suffix") *> crlf)
143 parsePart ∷ (Functor m, MonadError String m)
146 → m (LS.ByteString, Part)
147 {-# INLINEABLE parsePart #-}
148 parsePart boundary src
149 = case LP.parse partHeader src of
151 → do dispo ← getContDispo hdrs
152 cType ← fromMaybe defaultCType <$> getContType hdrs
154 ← getBody boundary src'
155 return (src'', Part dispo cType body)
157 → throwError $ "unparsable part: "
158 ⧺ intercalate ", " eCtx
162 defaultCType ∷ MIMEType
163 defaultCType = [mimeType| text/plain |]
165 partHeader ∷ Parser Headers
166 partHeader = crlf *> headers
168 getContDispo ∷ MonadError String m ⇒ Headers → m ContDispo
169 {-# INLINEABLE getContDispo #-}
171 = case getHeader "Content-Disposition" hdrs of
173 → throwError "Content-Disposition is missing"
175 → case parseOnly (finishOff contentDisposition) $ A.toByteString str of
177 Left err → throwError $ "malformed Content-Disposition: "
182 contentDisposition ∷ Parser ContDispo
184 = (ContDispo <$> (A.toCIAscii <$> token) ⊛ mimeParams)
188 getContType ∷ MonadError String m ⇒ Headers → m (Maybe MIMEType)
189 {-# INLINEABLE getContType #-}
191 = case getHeader "Content-Type" hdrs of
195 → case parseOnly (finishOff MT.mimeType) $ A.toByteString str of
196 Right d → return $ Just d
197 Left err → throwError $ "malformed Content-Type: "
202 getBody ∷ MonadError String m
205 → m (LS.ByteString, LS.ByteString)
206 {-# INLINEABLE getBody #-}
207 getBody (("\r\n--" ⊕) ∘ A.toByteString → boundary) src
208 = case breakOn boundary src of
211 → throwError "missing boundary"
213 → let len = fromIntegral $ BS.length boundary
214 after' = LS.drop len after
216 return (before, after')
218 partToFormPair ∷ MonadError String m ⇒ Part → m (Ascii, FormData)
219 {-# INLINEABLE partToFormPair #-}
220 partToFormPair pt@(Part {..})
221 | dType ptContDispo ≡ "form-data"
222 = do name ← partName pt
224 fdFileName = partFileName pt
225 , fdMIMEType = ptContType
230 = throwError $ "disposition type is not \"form-data\": "
231 ⧺ A.toString (A.fromCIAscii $ dType ptContDispo)
233 partName ∷ MonadError String m ⇒ Part → m Ascii
234 {-# INLINEABLE partName #-}
236 = case lookup "name" $ dParams ptContDispo of
238 → case A.fromText name of
240 Nothing → throwError $ "Non-ascii part name: "
243 → throwError $ "form-data without name: "
244 ⧺ A.toString (printContDispo ptContDispo)
246 partFileName ∷ Part → Maybe Text
247 partFileName (ptContDispo → ContDispo {..})
248 = lookup "filename" dParams