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
36 import Data.List (intercalate)
38 import Data.Monoid.Unicode
39 import Data.Sequence (Seq)
40 import Data.Text (Text)
41 import Network.HTTP.Lucu.Headers
42 import Network.HTTP.Lucu.MIMEParams
43 import Network.HTTP.Lucu.MIMEType (MIMEType)
44 import qualified Network.HTTP.Lucu.MIMEType as MT
45 import Network.HTTP.Lucu.MIMEType.TH
46 import Network.HTTP.Lucu.Parser
47 import Network.HTTP.Lucu.Parser.Http
48 import Network.HTTP.Lucu.Utils
49 import Prelude hiding (lookup, mapM)
50 import Prelude.Unicode
52 -- |'FormData' represents a form value and possibly an uploaded file
56 -- | @'Nothing'@ for non-file values.
57 fdFileName ∷ !(Maybe Text)
58 -- | MIME Type of this value, defaulted to \"text/plain\".
59 , fdMIMEType ∷ !MIMEType
61 , fdContent ∷ !(LS.ByteString)
66 ptContDispo ∷ !ContDispo
67 , ptContType ∷ !MIMEType
68 , ptBody ∷ !LS.ByteString
74 , dParams ∷ !MIMEParams
77 instance ConvertSuccess ContDispo Ascii where
78 {-# INLINE convertSuccess #-}
79 convertSuccess = convertSuccessVia ((⊥) ∷ AsciiBuilder)
81 instance ConvertSuccess ContDispo AsciiBuilder where
82 {-# INLINE convertSuccess #-}
83 convertSuccess (ContDispo {..})
84 = cs dType ⊕ cs dParams
86 deriveAttempts [ ([t| ContDispo |], [t| Ascii |])
87 , ([t| ContDispo |], [t| AsciiBuilder |])
90 -- |Parse \"multipart/form-data\" and return either @'Left' err@ or
91 -- @'Right' result@. Note that there are currently the following
94 -- * Multiple files embedded as \"multipart/mixed\" within the
95 -- \"multipart/form-data\" won't be decomposed.
97 -- * \"Content-Transfer-Encoding\" is always ignored.
99 -- * RFC 2388 (<http://tools.ietf.org/html/rfc2388#section-3>) says
100 -- that non-ASCII field names are encoded according to the method in
101 -- RFC 2047 (<http://tools.ietf.org/html/rfc2047>), but they won't
103 parseMultipartFormData ∷ Ascii -- ^boundary
104 → LS.ByteString -- ^input
105 → Either String [(Ascii, FormData)]
106 parseMultipartFormData boundary = (mapM partToFormPair =≪) ∘ go
108 go ∷ (Functor m, MonadError String m)
111 {-# INLINEABLE go #-}
113 = case LP.parse (prologue boundary) src of
117 → throwError $ "Unparsable multipart/form-data: "
118 ⧺ intercalate ", " eCtx
121 go' ∷ (Functor m, MonadError String m)
125 {-# INLINEABLE go' #-}
127 = case LP.parse epilogue src of
131 → do (src', x) ← parsePart boundary src
134 prologue ∷ Ascii → Parser ()
136 = ( (string "--" <?> "prefix")
138 (string (cs boundary) <?> "boundary")
146 epilogue = finishOff ((string "--" <?> "suffix") *> crlf)
150 parsePart ∷ (Functor m, MonadError String m)
153 → m (LS.ByteString, Part)
154 {-# INLINEABLE parsePart #-}
155 parsePart boundary src
156 = case LP.parse partHeader src of
158 → do dispo ← getContDispo hdrs
159 cType ← fromMaybe defaultCType <$> getContType hdrs
161 ← getBody boundary src'
162 return (src'', Part dispo cType body)
164 → throwError $ "unparsable part: "
165 ⧺ intercalate ", " eCtx
169 defaultCType ∷ MIMEType
170 defaultCType = [mimeType| text/plain |]
172 partHeader ∷ Parser Headers
173 partHeader = crlf *> headers
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
191 = (ContDispo <$> (cs <$> token) ⊛ mimeParams)
195 getContType ∷ MonadError String m ⇒ Headers → m (Maybe MIMEType)
196 {-# INLINEABLE getContType #-}
198 = case getHeader "Content-Type" hdrs of
202 → case parseOnly (finishOff MT.mimeType) $ cs str of
203 Right d → return $ Just d
204 Left err → throwError $ "malformed Content-Type: "
209 getBody ∷ MonadError String m
212 → m (LS.ByteString, LS.ByteString)
213 {-# INLINEABLE getBody #-}
214 getBody (("\r\n--" ⊕) ∘ cs → boundary) src
215 = case breakOn boundary src of
218 → throwError "missing boundary"
220 → let len = fromIntegral $ BS.length boundary
221 after' = LS.drop len after
223 return (before, after')
225 partToFormPair ∷ MonadError String m ⇒ Part → m (Ascii, FormData)
226 {-# INLINEABLE partToFormPair #-}
227 partToFormPair pt@(Part {..})
228 | dType ptContDispo ≡ "form-data"
229 = do name ← partName pt
231 fdFileName = partFileName pt
232 , fdMIMEType = ptContType
237 = throwError $ "disposition type is not \"form-data\": "
238 ⊕ cs (dType ptContDispo)
240 partName ∷ MonadError String m ⇒ Part → m Ascii
241 {-# INLINEABLE partName #-}
243 = case lookup "name" $ dParams ptContDispo of
247 Failure e → throwError $ show e
249 → throwError $ "form-data without name: "
250 ⊕ convertSuccessVia ((⊥) ∷ Ascii) ptContDispo
252 partFileName ∷ Part → Maybe Text
253 partFileName (ptContDispo → ContDispo {..})
254 = lookup "filename" dParams