+{-# LANGUAGE
+ DoAndIfThenElse
+ , FlexibleContexts
+ , OverloadedStrings
+ , QuasiQuotes
+ , RecordWildCards
+ , ScopedTypeVariables
+ , UnicodeSyntax
+ , ViewPatterns
+ #-}
+-- |Parse \"multipart/form-data\" based on RFC 2388:
+-- <http://tools.ietf.org/html/rfc2388>
+--
+-- You usually don't have to use this module directly.
module Network.HTTP.Lucu.MultipartForm
( FormData(..)
- , multipartFormP
+ , parseMultipartFormData
)
where
-
-import qualified Data.ByteString.Char8 as C8
-import qualified Data.ByteString.Lazy.Char8 as L8
-import Data.Char
-import Data.List
-import Network.HTTP.Lucu.Abortion
-import Network.HTTP.Lucu.Headers
-import Network.HTTP.Lucu.Parser
-import Network.HTTP.Lucu.Parser.Http
-import Network.HTTP.Lucu.Response
-import Network.HTTP.Lucu.Utils
-
-
-data Part = Part Headers L8.ByteString
-
--- |This data type represents a form value and possibly an uploaded
--- file name.
+import Control.Applicative hiding (many)
+import Control.Applicative.Unicode hiding ((∅))
+import Control.Monad.Error
+import Control.Monad.Unicode
+import Data.Ascii (Ascii, CIAscii)
+import qualified Data.Ascii as A
+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 qualified Data.Map as M
+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 (MIMEType)
+import qualified Network.HTTP.Lucu.MIMEType as MT
+import Network.HTTP.Lucu.MIMEType.TH
+import Network.HTTP.Lucu.Parser
+import Network.HTTP.Lucu.Parser.Http
+import Prelude.Unicode
+
+-- |'FormData' represents a form value and possibly an uploaded file
+-- name.
data FormData
= FormData {
- fdFileName :: Maybe String
- , fdContent :: L8.ByteString
+ -- | @'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)
}
-instance HasHeaders Part where
- getHeaders (Part hs _) = hs
- setHeaders (Part _ b) hs = Part hs b
-
-
-data ContDispo = ContDispo String [(String, String)]
-
-instance Show ContDispo where
- show (ContDispo dType dParams)
- = dType ++
- if null dParams then
- ""
- else
- "; " ++ joinWith "; " (map showPair dParams)
- where
- showPair :: (String, String) -> String
- showPair (name, value)
- = name ++ "=" ++ if any (not . isToken) value then
- quoteStr value
- else
- value
-
-
-multipartFormP :: String -> Parser [(String, FormData)]
-multipartFormP boundary
- = do parts <- many (partP boundary)
- _ <- string "--"
- _ <- string boundary
- _ <- string "--"
- _ <- crlf
- eof
- return $ map partToFormPair parts
-
-
-partP :: String -> Parser Part
-partP boundary
- = do _ <- string "--"
- _ <- string boundary
- _ <- crlf -- バウンダリの末尾に -- が付いてゐたらここで fail する。
- hs <- headersP
- body <- bodyP boundary
- return $ Part hs body
-
-
-bodyP :: String -> Parser L8.ByteString
-bodyP boundary
- = do body <- manyChar $
- do notFollowedBy $ ( crlf >>
- string "--" >>
- string boundary )
- anyChar
- _ <- crlf
- return body
-
-
-partToFormPair :: Part -> (String, FormData)
-partToFormPair part@(Part _ body)
- = let name = partName part
- fname = partFileName part
- fd = FormData {
- fdFileName = fname
- , fdContent = body
- }
- in (name, fd)
-
-partName :: Part -> String
-partName = getName' . getContDispoFormData
- where
- getName' :: ContDispo -> String
- getName' dispo@(ContDispo _ dParams)
- = case find ((== "name") . map toLower . fst) dParams of
- Just (_, name) -> name
- Nothing
- -> abortPurely BadRequest []
- (Just $ "form-data without name: " ++ show dispo)
+data Part
+ = Part {
+ ptContDispo ∷ !ContDispo
+ , ptContType ∷ !MIMEType
+ , ptBody ∷ !LS.ByteString
+ }
+data ContDispo
+ = ContDispo {
+ dType ∷ !CIAscii
+ , dParams ∷ !MIMEParams
+ }
-partFileName :: Part -> Maybe String
-partFileName = getFileName' . getContDispoFormData
+printContDispo ∷ ContDispo → Ascii
+printContDispo d
+ = A.fromAsciiBuilder
+ ( A.toAsciiBuilder (A.fromCIAscii $ dType d)
+ ⊕
+ printMIMEParams (dParams d) )
+
+-- |Parse \"multipart/form-data\" and return either @'Left' err@ or
+-- @'Right' result@. Note that there are currently the following
+-- limitations:
+--
+-- * Multiple files embedded as \"multipart/mixed\" within the
+-- \"multipart/form-data\" won't be decomposed.
+--
+-- * \"Content-Transfer-Encoding\" is always ignored.
+--
+-- * 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 they won't
+-- be decoded.
+parseMultipartFormData ∷ Ascii -- ^boundary
+ → LS.ByteString -- ^input
+ → Either String [(Ascii, FormData)]
+parseMultipartFormData boundary = (mapM partToFormPair =≪) ∘ go
where
- getFileName' :: ContDispo -> Maybe String
- getFileName' (ContDispo _ dParams)
- = do (_, fileName) <- find ((== "filename") . map toLower . fst) dParams
- return fileName
-
-getContDispoFormData :: Part -> ContDispo
-getContDispoFormData part
- = let dispo@(ContDispo dType _) = getContDispo part
- in
- if map toLower dType == "form-data" then
- dispo
- else
- abortPurely BadRequest []
- (Just $ "Content-Disposition type is not form-data: " ++ dType)
-
-
-getContDispo :: Part -> ContDispo
-getContDispo part
- = case getHeader (C8.pack "Content-Disposition") part of
- Nothing
- -> abortPurely BadRequest []
- (Just "There is a part without Content-Disposition in the multipart/form-data.")
- Just dispoStr
- -> case parse contDispoP (L8.fromChunks [dispoStr]) of
- (# Success dispo, _ #)
- -> dispo
- (# _, _ #)
- -> abortPurely BadRequest []
- (Just $ "Unparsable Content-Disposition: " ++ C8.unpack dispoStr)
-
-
-contDispoP :: Parser ContDispo
-contDispoP = do dispoType <- token
- params <- allowEOF $ many paramP
- return $ ContDispo dispoType params
+ go ∷ (Functor m, MonadError String m)
+ ⇒ LS.ByteString
+ → m [Part]
+ {-# INLINEABLE go #-}
+ go src
+ = case LP.parse (prologue boundary) src of
+ LP.Done src' _
+ → go' src' (∅)
+ LP.Fail _ eCtx e
+ → throwError $ "Unparsable multipart/form-data: "
+ ⧺ intercalate ", " eCtx
+ ⧺ ": "
+ ⧺ e
+ go' ∷ (Functor m, MonadError String m)
+ ⇒ LS.ByteString
+ → Seq Part
+ → m [Part]
+ {-# INLINEABLE go' #-}
+ go' src xs
+ = case LP.parse epilogue src of
+ LP.Done _ _
+ → return $ toList xs
+ LP.Fail _ _ _
+ → do (src', x) ← parsePart boundary src
+ go' src' $ xs ⊳ x
+
+prologue ∷ Ascii → Parser ()
+prologue boundary
+ = ( (string "--" <?> "prefix")
+ *>
+ (string (A.toByteString boundary) <?> "boundary")
+ *>
+ pure ()
+ )
+ <?>
+ "prologue"
+
+epilogue ∷ Parser ()
+epilogue = finishOff ((string "--" <?> "suffix") *> crlf)
+ <?>
+ "epilogue"
+
+parsePart ∷ (Functor m, MonadError String m)
+ ⇒ Ascii
+ → LS.ByteString
+ → m (LS.ByteString, Part)
+{-# INLINEABLE parsePart #-}
+parsePart boundary src
+ = case LP.parse partHeader src of
+ LP.Done src' hdrs
+ → do dispo ← getContDispo hdrs
+ cType ← fromMaybe defaultCType <$> getContType hdrs
+ (body, src'')
+ ← getBody boundary src'
+ return (src'', Part dispo cType body)
+ LP.Fail _ eCtx e
+ → throwError $ "unparsable part: "
+ ⧺ intercalate ", " eCtx
+ ⧺ ": "
+ ⧺ e
+ where
+ defaultCType ∷ MIMEType
+ defaultCType = [mimeType| text/plain |]
+
+partHeader ∷ Parser Headers
+partHeader = crlf *> headers
+
+getContDispo ∷ MonadError String m ⇒ Headers → m ContDispo
+{-# INLINEABLE getContDispo #-}
+getContDispo hdrs
+ = case getHeader "Content-Disposition" hdrs of
+ Nothing
+ → throwError "Content-Disposition is missing"
+ Just str
+ → case parseOnly (finishOff contentDisposition) $ A.toByteString str of
+ Right d → return d
+ Left err → throwError $ "malformed Content-Disposition: "
+ ⧺ A.toString str
+ ⧺ ": "
+ ⧺ err
+
+contentDisposition ∷ Parser ContDispo
+contentDisposition
+ = (ContDispo <$> (A.toCIAscii <$> token) ⊛ mimeParams)
+ <?>
+ "contentDisposition"
+
+getContType ∷ MonadError String m ⇒ Headers → m (Maybe MIMEType)
+{-# INLINEABLE getContType #-}
+getContType hdrs
+ = case getHeader "Content-Type" hdrs of
+ Nothing
+ → return Nothing
+ Just str
+ → case parseOnly (finishOff MT.mimeType) $ A.toByteString str of
+ Right d → return $ Just d
+ Left err → throwError $ "malformed Content-Type: "
+ ⧺ A.toString str
+ ⧺ ": "
+ ⧺ err
+
+getBody ∷ MonadError String m
+ ⇒ Ascii
+ → LS.ByteString
+ → m (LS.ByteString, LS.ByteString)
+{-# INLINEABLE getBody #-}
+getBody (("\r\n--" ⊕) ∘ A.toByteString → boundary) src
+ = case breakOn boundary src of
+ (before, after)
+ | LS.null after
+ → throwError "missing boundary"
+ | otherwise
+ → let len = fromIntegral $ BS.length boundary
+ after' = LS.drop len after
+ in
+ return (before, after')
+
+partToFormPair ∷ MonadError String m ⇒ Part → m (Ascii, FormData)
+{-# INLINEABLE partToFormPair #-}
+partToFormPair pt@(Part {..})
+ | dType ptContDispo ≡ "form-data"
+ = do name ← partName pt
+ let fd = FormData {
+ fdFileName = partFileName pt
+ , fdMIMEType = ptContType
+ , fdContent = ptBody
+ }
+ return (name, fd)
+ | otherwise
+ = throwError $ "disposition type is not \"form-data\": "
+ ⧺ A.toString (A.fromCIAscii $ dType ptContDispo)
+
+partName ∷ MonadError String m ⇒ Part → m Ascii
+{-# INLINEABLE partName #-}
+partName (Part {..})
+ = case M.lookup "name" params of
+ Just name
+ → case A.fromText name of
+ Just a → return a
+ Nothing → throwError $ "Non-ascii part name: "
+ ⧺ T.unpack name
+ Nothing
+ → throwError $ "form-data without name: "
+ ⧺ A.toString (printContDispo ptContDispo)
where
- paramP :: Parser (String, String)
- paramP = do _ <- many lws
- _ <- char ';'
- _ <- many lws
- name <- token
- _ <- char '='
- value <- token <|> quotedStr
- return (name, value)
+ params = case dParams ptContDispo of
+ MIMEParams m → m
+
+partFileName ∷ Part → Maybe Text
+partFileName (dParams ∘ ptContDispo → MIMEParams m)
+ = M.lookup "filename" m
projects / Lucu.git / blobdiff