{-# LANGUAGE
DoAndIfThenElse
+ , FlexibleInstances
, FlexibleContexts
+ , MultiParamTypeClasses
, OverloadedStrings
+ , QuasiQuotes
, RecordWildCards
, ScopedTypeVariables
+ , TemplateHaskell
, UnicodeSyntax
, ViewPatterns
#-}
-- |Parse \"multipart/form-data\" based on RFC 2388:
--- <http://www.faqs.org/rfcs/rfc2388.html>
---
--- You usually don't have to use this module directly.
+-- <http://tools.ietf.org/html/rfc2388>
module Network.HTTP.Lucu.MultipartForm
( FormData(..)
, parseMultipartFormData
where
import Control.Applicative hiding (many)
import Control.Applicative.Unicode hiding ((∅))
-import Control.Monad.Error
+import Control.Monad.Error (MonadError, throwError)
import Control.Monad.Unicode
-import Data.Ascii (Ascii, CIAscii)
-import qualified Data.Ascii as A
+import Data.Ascii (Ascii, CIAscii, AsciiBuilder)
+import Data.Attempt
import Data.Attoparsec
import qualified Data.Attoparsec.Lazy as LP
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LS
import Data.ByteString.Lazy.Search
-import Data.Foldable
-import Data.List
-import Data.Map (Map)
-import qualified Data.Map as M
+import Data.Collections
+import Data.Convertible.Base
+import Data.Convertible.Instances.Ascii ()
+import Data.Convertible.Utils
+import Data.Default
+import Data.List (intercalate)
import Data.Maybe
import Data.Monoid.Unicode
import Data.Sequence (Seq)
-import Data.Sequence.Unicode hiding ((∅))
import Data.Text (Text)
-import qualified Data.Text as T
import Network.HTTP.Lucu.Headers
+import Network.HTTP.Lucu.MIMEParams
import Network.HTTP.Lucu.MIMEType
+import Network.HTTP.Lucu.Parser
import Network.HTTP.Lucu.Parser.Http
-import Network.HTTP.Lucu.RFC2231
+import Network.HTTP.Lucu.Utils
+import Prelude hiding (lookup, mapM)
import Prelude.Unicode
-- |'FormData' represents a form value and possibly an uploaded file
-- name.
data FormData
= FormData {
+ -- | @'Nothing'@ for non-file values.
fdFileName ∷ !(Maybe Text)
+ -- | MIME Type of this value, defaulted to \"text/plain\".
, fdMIMEType ∷ !MIMEType
+ -- | The form value.
, fdContent ∷ !(LS.ByteString)
}
data ContDispo
= ContDispo {
dType ∷ !CIAscii
- , dParams ∷ !(Map CIAscii Text)
+ , dParams ∷ !MIMEParams
}
-printContDispo ∷ ContDispo → Ascii
-printContDispo d
- = A.fromAsciiBuilder
- ( A.toAsciiBuilder (A.fromCIAscii $ dType d)
- ⊕
- printMIMEParams (dParams d) )
+instance ConvertSuccess ContDispo Ascii where
+ {-# INLINE convertSuccess #-}
+ convertSuccess = convertSuccessVia ((⊥) ∷ AsciiBuilder)
+
+instance ConvertSuccess ContDispo AsciiBuilder where
+ {-# INLINE convertSuccess #-}
+ convertSuccess (ContDispo {..})
+ = cs dType ⊕ cs dParams
+
+deriveAttempts [ ([t| ContDispo |], [t| Ascii |])
+ , ([t| ContDispo |], [t| AsciiBuilder |])
+ ]
--- |Parse \"multipart/form-data\" and return either @'Left' err@ or
--- @'Right' result@. Note that there are currently the following
+-- |Parse \"multipart/form-data\" to a list of @(name,
+-- formData)@. Note that there are currently the following
-- limitations:
--
-- * Multiple files embedded as \"multipart/mixed\" within the
--- \"multipart/form-data\" aren't decomposed.
+-- \"multipart/form-data\" won't be decomposed.
--
--- * \"Content-Transfer-Encoding\"s are always ignored.
+-- * \"Content-Transfer-Encoding\" is always ignored.
--
--- * RFC 2388 says that non-ASCII field names are encoded according
--- to the method in RFC 2047
--- <http://www.faqs.org/rfcs/rfc2047.html>, but they aren't
--- decoded.
+-- * RFC 2388 (<http://tools.ietf.org/html/rfc2388#section-3>) says
+-- that non-ASCII field names are encoded according to the method
+-- in RFC 2047 (<http://tools.ietf.org/html/rfc2047>), but this
+-- function currently doesn't decode them.
parseMultipartFormData ∷ Ascii -- ^boundary
→ LS.ByteString -- ^input
→ Either String [(Ascii, FormData)]
prologue boundary
= ( (string "--" <?> "prefix")
*>
- (string (A.toByteString boundary) <?> "boundary")
+ (string (cs boundary) <?> "boundary")
*>
pure ()
)
"prologue"
epilogue ∷ Parser ()
-epilogue = ( (string "--" <?> "suffix")
- *>
- crlf
- *>
- endOfInput
- )
+epilogue = finishOff ((string "--" <?> "suffix") *> crlf)
<?>
"epilogue"
⧺ e
where
defaultCType ∷ MIMEType
- defaultCType = parseMIMEType "text/plain"
+ defaultCType = [mimeType| text/plain |]
partHeader ∷ Parser Headers
-partHeader = crlf *> headers
+{-# INLINE partHeader #-}
+partHeader = crlf *> def
getContDispo ∷ MonadError String m ⇒ Headers → m ContDispo
{-# INLINEABLE getContDispo #-}
Nothing
→ throwError "Content-Disposition is missing"
Just str
- → case parseOnly p $ A.toByteString str of
+ → case parseOnly (finishOff contentDisposition) $ cs str of
Right d → return d
Left err → throwError $ "malformed Content-Disposition: "
- ⧺ A.toString str
- ⧺ ": "
- ⧺ err
- where
- p = do dispo ← contentDisposition
- endOfInput
- return dispo
+ ⊕ cs str
+ ⊕ ": "
+ ⊕ err
contentDisposition ∷ Parser ContDispo
+{-# INLINEABLE contentDisposition #-}
contentDisposition
- = (ContDispo <$> (A.toCIAscii <$> token) ⊛ mimeParams)
+ = (ContDispo <$> (cs <$> token) ⊛ def)
<?>
"contentDisposition"
Nothing
→ return Nothing
Just str
- → case parseOnly p $ A.toByteString str of
+ → case parseOnly (finishOff def) $ cs str of
Right d → return $ Just d
Left err → throwError $ "malformed Content-Type: "
- ⧺ A.toString str
- ⧺ ": "
- ⧺ err
- where
- p = do t ← mimeType
- endOfInput
- return t
+ ⊕ cs str
+ ⊕ ": "
+ ⊕ err
getBody ∷ MonadError String m
⇒ Ascii
→ LS.ByteString
→ m (LS.ByteString, LS.ByteString)
{-# INLINEABLE getBody #-}
-getBody (("\r\n--" ⊕) ∘ A.toByteString → boundary) src
+getBody (("\r\n--" ⊕) ∘ cs → boundary) src
= case breakOn boundary src of
(before, after)
| LS.null after
return (name, fd)
| otherwise
= throwError $ "disposition type is not \"form-data\": "
- ⧺ A.toString (A.fromCIAscii $ dType ptContDispo)
+ â\8a\95 cs (dType ptContDispo)
partName ∷ MonadError String m ⇒ Part → m Ascii
{-# INLINEABLE partName #-}
partName (Part {..})
- = case M.lookup "name" $ dParams ptContDispo of
+ = case lookup "name" $ dParams ptContDispo of
Just name
- → case A.fromText name of
- Just a → return a
- Nothing → throwError $ "Non-ascii part name: "
- ⧺ T.unpack name
+ → case ca name of
+ Success a → return a
+ Failure e → throwError $ show e
Nothing
→ throwError $ "form-data without name: "
- ⧺ A.toString (printContDispo ptContDispo)
+ â\8a\95 convertSuccessVia ((â\8a¥) â\88· Ascii) ptContDispo
partFileName ∷ Part → Maybe Text
-partFileName (Part {..})
- = M.lookup "filename" $ dParams ptContDispo
+partFileName (ptContDispo → ContDispo {..})
+ = lookup "filename" dParams
projects / Lucu.git / blobdiff