11 -- |Parse \"multipart/form-data\" based on RFC 2388:
12 -- <http://tools.ietf.org/html/rfc2388>
14 -- You usually don't have to use this module directly.
15 module Network.HTTP.Lucu.MultipartForm
17 , parseMultipartFormData
20 import Control.Applicative hiding (many)
21 import Control.Applicative.Unicode hiding ((∅))
22 import Control.Monad.Error
23 import Control.Monad.Unicode
24 import Data.Ascii (Ascii, CIAscii)
25 import qualified Data.Ascii as A
26 import Data.Attoparsec
27 import qualified Data.Attoparsec.Lazy as LP
28 import qualified Data.ByteString as BS
29 import qualified Data.ByteString.Lazy as LS
30 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.MIMEParams
42 import Network.HTTP.Lucu.MIMEType (MIMEType)
43 import qualified Network.HTTP.Lucu.MIMEType as MT
44 import Network.HTTP.Lucu.MIMEType.TH
45 import Network.HTTP.Lucu.Parser
46 import Network.HTTP.Lucu.Parser.Http
47 import Prelude.Unicode
49 -- |'FormData' represents a form value and possibly an uploaded file
53 -- | @'Nothing'@ for non-file values.
54 fdFileName ∷ !(Maybe Text)
55 -- | MIME Type of this value, defaulted to \"text/plain\".
56 , fdMIMEType ∷ !MIMEType
58 , fdContent ∷ !(LS.ByteString)
63 ptContDispo ∷ !ContDispo
64 , ptContType ∷ !MIMEType
65 , ptBody ∷ !LS.ByteString
71 , dParams ∷ !MIMEParams
74 printContDispo ∷ ContDispo → Ascii
77 ( A.toAsciiBuilder (A.fromCIAscii $ dType d)
79 printMIMEParams (dParams d) )
81 -- |Parse \"multipart/form-data\" and return either @'Left' err@ or
82 -- @'Right' result@. Note that there are currently the following
85 -- * Multiple files embedded as \"multipart/mixed\" within the
86 -- \"multipart/form-data\" won't be decomposed.
88 -- * \"Content-Transfer-Encoding\" is always ignored.
90 -- * RFC 2388 (<http://tools.ietf.org/html/rfc2388#section-3>) says
91 -- that non-ASCII field names are encoded according to the method in
92 -- RFC 2047 (<http://tools.ietf.org/html/rfc2047>), but they won't
94 parseMultipartFormData ∷ Ascii -- ^boundary
95 → LS.ByteString -- ^input
96 → Either String [(Ascii, FormData)]
97 parseMultipartFormData boundary = (mapM partToFormPair =≪) ∘ go
99 go ∷ (Functor m, MonadError String m)
102 {-# INLINEABLE go #-}
104 = case LP.parse (prologue boundary) src of
108 → throwError $ "Unparsable multipart/form-data: "
109 ⧺ intercalate ", " eCtx
112 go' ∷ (Functor m, MonadError String m)
116 {-# INLINEABLE go' #-}
118 = case LP.parse epilogue src of
122 → do (src', x) ← parsePart boundary src
125 prologue ∷ Ascii → Parser ()
127 = ( (string "--" <?> "prefix")
129 (string (A.toByteString boundary) <?> "boundary")
137 epilogue = finishOff ((string "--" <?> "suffix") *> crlf)
141 parsePart ∷ (Functor m, MonadError String m)
144 → m (LS.ByteString, Part)
145 {-# INLINEABLE parsePart #-}
146 parsePart boundary src
147 = case LP.parse partHeader src of
149 → do dispo ← getContDispo hdrs
150 cType ← fromMaybe defaultCType <$> getContType hdrs
152 ← getBody boundary src'
153 return (src'', Part dispo cType body)
155 → throwError $ "unparsable part: "
156 ⧺ intercalate ", " eCtx
160 defaultCType ∷ MIMEType
161 defaultCType = [mimeType| text/plain |]
163 partHeader ∷ Parser Headers
164 partHeader = crlf *> headers
166 getContDispo ∷ MonadError String m ⇒ Headers → m ContDispo
167 {-# INLINEABLE getContDispo #-}
169 = case getHeader "Content-Disposition" hdrs of
171 → throwError "Content-Disposition is missing"
173 → case parseOnly (finishOff contentDisposition) $ A.toByteString str of
175 Left err → throwError $ "malformed Content-Disposition: "
180 contentDisposition ∷ Parser ContDispo
182 = (ContDispo <$> (A.toCIAscii <$> token) ⊛ mimeParams)
186 getContType ∷ MonadError String m ⇒ Headers → m (Maybe MIMEType)
187 {-# INLINEABLE getContType #-}
189 = case getHeader "Content-Type" hdrs of
193 → case parseOnly (finishOff MT.mimeType) $ A.toByteString str of
194 Right d → return $ Just d
195 Left err → throwError $ "malformed Content-Type: "
200 getBody ∷ MonadError String m
203 → m (LS.ByteString, LS.ByteString)
204 {-# INLINEABLE getBody #-}
205 getBody (("\r\n--" ⊕) ∘ A.toByteString → boundary) src
206 = case breakOn boundary src of
209 → throwError "missing boundary"
211 → let len = fromIntegral $ BS.length boundary
212 after' = LS.drop len after
214 return (before, after')
216 partToFormPair ∷ MonadError String m ⇒ Part → m (Ascii, FormData)
217 {-# INLINEABLE partToFormPair #-}
218 partToFormPair pt@(Part {..})
219 | dType ptContDispo ≡ "form-data"
220 = do name ← partName pt
222 fdFileName = partFileName pt
223 , fdMIMEType = ptContType
228 = throwError $ "disposition type is not \"form-data\": "
229 ⧺ A.toString (A.fromCIAscii $ dType ptContDispo)
231 partName ∷ MonadError String m ⇒ Part → m Ascii
232 {-# INLINEABLE partName #-}
234 = case M.lookup "name" params of
236 → case A.fromText name of
238 Nothing → throwError $ "Non-ascii part name: "
241 → throwError $ "form-data without name: "
242 ⧺ A.toString (printContDispo ptContDispo)
244 params = case dParams ptContDispo of
247 partFileName ∷ Part → Maybe Text
248 partFileName (dParams ∘ ptContDispo → MIMEParams m)
249 = M.lookup "filename" m