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)
26 import qualified Data.Ascii as A
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
36 import Data.List (intercalate)
38 import Data.Monoid.Unicode
39 import Data.Sequence (Seq)
40 import Data.Text (Text)
41 import qualified Data.Text as T
42 import Network.HTTP.Lucu.Headers
43 import Network.HTTP.Lucu.MIMEParams
44 import Network.HTTP.Lucu.MIMEType (MIMEType)
45 import qualified Network.HTTP.Lucu.MIMEType as MT
46 import Network.HTTP.Lucu.MIMEType.TH
47 import Network.HTTP.Lucu.Parser
48 import Network.HTTP.Lucu.Parser.Http
49 import Network.HTTP.Lucu.Utils
50 import Prelude hiding (lookup, mapM)
51 import Prelude.Unicode
53 -- |'FormData' represents a form value and possibly an uploaded file
57 -- | @'Nothing'@ for non-file values.
58 fdFileName ∷ !(Maybe Text)
59 -- | MIME Type of this value, defaulted to \"text/plain\".
60 , fdMIMEType ∷ !MIMEType
62 , fdContent ∷ !(LS.ByteString)
67 ptContDispo ∷ !ContDispo
68 , ptContType ∷ !MIMEType
69 , ptBody ∷ !LS.ByteString
75 , dParams ∷ !MIMEParams
78 instance ConvertSuccess ContDispo Ascii where
79 {-# INLINE convertSuccess #-}
80 convertSuccess = convertSuccessVia ((⊥) ∷ AsciiBuilder)
82 instance ConvertSuccess ContDispo AsciiBuilder where
83 {-# INLINE convertSuccess #-}
84 convertSuccess (ContDispo {..})
85 = cs dType ⊕ cs dParams
87 deriveAttempts [ ([t| ContDispo |], [t| Ascii |])
88 , ([t| ContDispo |], [t| AsciiBuilder |])
91 -- |Parse \"multipart/form-data\" and return either @'Left' err@ or
92 -- @'Right' result@. Note that there are currently the following
95 -- * Multiple files embedded as \"multipart/mixed\" within the
96 -- \"multipart/form-data\" won't be decomposed.
98 -- * \"Content-Transfer-Encoding\" is always ignored.
100 -- * RFC 2388 (<http://tools.ietf.org/html/rfc2388#section-3>) says
101 -- that non-ASCII field names are encoded according to the method in
102 -- RFC 2047 (<http://tools.ietf.org/html/rfc2047>), but they won't
104 parseMultipartFormData ∷ Ascii -- ^boundary
105 → LS.ByteString -- ^input
106 → Either String [(Ascii, FormData)]
107 parseMultipartFormData boundary = (mapM partToFormPair =≪) ∘ go
109 go ∷ (Functor m, MonadError String m)
112 {-# INLINEABLE go #-}
114 = case LP.parse (prologue boundary) src of
118 → throwError $ "Unparsable multipart/form-data: "
119 ⧺ intercalate ", " eCtx
122 go' ∷ (Functor m, MonadError String m)
126 {-# INLINEABLE go' #-}
128 = case LP.parse epilogue src of
132 → do (src', x) ← parsePart boundary src
135 prologue ∷ Ascii → Parser ()
137 = ( (string "--" <?> "prefix")
139 (string (A.toByteString boundary) <?> "boundary")
147 epilogue = finishOff ((string "--" <?> "suffix") *> crlf)
151 parsePart ∷ (Functor m, MonadError String m)
154 → m (LS.ByteString, Part)
155 {-# INLINEABLE parsePart #-}
156 parsePart boundary src
157 = case LP.parse partHeader src of
159 → do dispo ← getContDispo hdrs
160 cType ← fromMaybe defaultCType <$> getContType hdrs
162 ← getBody boundary src'
163 return (src'', Part dispo cType body)
165 → throwError $ "unparsable part: "
166 ⧺ intercalate ", " eCtx
170 defaultCType ∷ MIMEType
171 defaultCType = [mimeType| text/plain |]
173 partHeader ∷ Parser Headers
174 partHeader = crlf *> headers
176 getContDispo ∷ MonadError String m ⇒ Headers → m ContDispo
177 {-# INLINEABLE getContDispo #-}
179 = case getHeader "Content-Disposition" hdrs of
181 → throwError "Content-Disposition is missing"
183 → case parseOnly (finishOff contentDisposition) $ A.toByteString str of
185 Left err → throwError $ "malformed Content-Disposition: "
190 contentDisposition ∷ Parser ContDispo
192 = (ContDispo <$> (A.toCIAscii <$> token) ⊛ mimeParams)
196 getContType ∷ MonadError String m ⇒ Headers → m (Maybe MIMEType)
197 {-# INLINEABLE getContType #-}
199 = case getHeader "Content-Type" hdrs of
203 → case parseOnly (finishOff MT.mimeType) $ A.toByteString 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--" ⊕) ∘ A.toByteString → 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 ⧺ A.toString (A.fromCIAscii $ dType ptContDispo)
241 partName ∷ MonadError String m ⇒ Part → m Ascii
242 {-# INLINEABLE partName #-}
244 = case lookup "name" $ dParams ptContDispo of
246 → case A.fromText name of
248 Nothing → throwError $ "Non-ascii part name: "
251 → throwError $ "form-data without name: "
252 ⊕ convertSuccessVia ((⊥) ∷ Ascii) ptContDispo
254 partFileName ∷ Part → Maybe Text
255 partFileName (ptContDispo → ContDispo {..})
256 = lookup "filename" dParams