From e89c411ee5c922b120f99abc4a0df24ba4df385e Mon Sep 17 00:00:00 2001 From: Marco Zocca Date: Sun, 24 Sep 2023 23:19:59 +0200 Subject: [PATCH 1/3] WIP limit parsing of multipart uploads --- Web/Scotty.hs | 4 ++-- Web/Scotty/Action.hs | 4 ++-- Web/Scotty/Internal/Types.hs | 8 ++++++-- Web/Scotty/Route.hs | 34 ++++++++++++++++++++++------------ scotty.cabal | 1 + 5 files changed, 33 insertions(+), 18 deletions(-) diff --git a/Web/Scotty.hs b/Web/Scotty.hs index 649f9bbc..07079db8 100644 --- a/Web/Scotty.hs +++ b/Web/Scotty.hs @@ -46,7 +46,7 @@ import Network.Socket (Socket) import Network.Wai (Application, Middleware, Request, StreamingBody) import Network.Wai.Handler.Warp (Port) -import Web.Scotty.Internal.Types (ScottyT, ActionT, Param, RoutePattern, Options, File, Kilobytes) +import Web.Scotty.Internal.Types (ScottyT, ActionT, Param, RoutePattern, Options, File, FileMem, Kilobytes) type ScottyM = ScottyT Text IO type ActionM = ActionT Text IO @@ -174,7 +174,7 @@ request :: ActionM Request request = Trans.request -- | Get list of uploaded files. -files :: ActionM [File] +files :: ActionM [FileMem] files = Trans.files -- | Get a request header. Header name is case-insensitive. diff --git a/Web/Scotty/Action.hs b/Web/Scotty/Action.hs index 331a0c9d..434b61ea 100644 --- a/Web/Scotty/Action.hs +++ b/Web/Scotty/Action.hs @@ -165,8 +165,8 @@ request :: Monad m => ActionT e m Request request = ActionT $ liftM getReq ask -- | Get list of uploaded files. -files :: Monad m => ActionT e m [File] -files = ActionT $ liftM getFiles ask +files :: Monad m => ActionT e m [FileMem] +files = ActionT $ liftM getFilesMem ask -- | Get a request header. Header name is case-insensitive. header :: (ScottyError e, Monad m) => T.Text -> ActionT e m (Maybe T.Text) diff --git a/Web/Scotty/Internal/Types.hs b/Web/Scotty/Internal/Types.hs index 885675d6..5950d9e2 100644 --- a/Web/Scotty/Internal/Types.hs +++ b/Web/Scotty/Internal/Types.hs @@ -131,13 +131,17 @@ instance Exception ScottyException ------------------ Scotty Actions ------------------- type Param = (Text, Text) -type File = (Text, FileInfo ByteString) +-- type File = (Text, FileInfo (Either ByteString FilePath)) +type File i = (Text, FileInfo i) +type FileMem = File ByteString +type FileDisk = File FilePath data ActionEnv = Env { getReq :: Request , getParams :: [Param] , getBody :: IO ByteString , getBodyChunk :: IO BS.ByteString - , getFiles :: [File] + , getFilesMem :: [FileMem] + , getFilesDisk :: [FileDisk] } data RequestBodyState = BodyUntouched diff --git a/Web/Scotty/Route.hs b/Web/Scotty/Route.hs index f688b908..745826e3 100644 --- a/Web/Scotty/Route.hs +++ b/Web/Scotty/Route.hs @@ -11,11 +11,12 @@ import Control.Concurrent.MVar import Control.Exception (throw, catch) import Control.Monad.IO.Class import qualified Control.Monad.State as MS +import Control.Monad.Trans.Resource (runResourceT, withInternalState) import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as BL -import Data.Maybe (fromMaybe, isJust) +import Data.Maybe (fromMaybe) import Data.String (fromString) import qualified Data.Text.Lazy as T import qualified Data.Text as TS @@ -138,11 +139,12 @@ path = T.fromStrict . TS.cons '/' . TS.intercalate "/" . pathInfo -- Once read, they can't be read again. We read them into a lazy Bytestring, so Scotty -- user can get the raw body, even if they also want to call wai-extra's parsing routines. parseRequestBody :: MonadIO m - => [B.ByteString] + => Parse.ParseRequestBodyOptions + -> [B.ByteString] -> Parse.BackEnd y -> Request -> m ([Parse.Param], [Parse.File y]) -parseRequestBody bl s r = +parseRequestBody opts bl s r = case Parse.getRequestBodyType r of Nothing -> return ([], []) Just rbt -> do @@ -151,9 +153,9 @@ parseRequestBody bl s r = let provider = modifyMVar mvar $ \bsold -> case bsold of [] -> return ([], B.empty) (b:bs) -> return (bs, b) - liftIO $ Parse.sinkRequestBody s rbt provider + liftIO $ Parse.sinkRequestBodyEx opts s rbt provider -mkEnv :: forall m. MonadIO m => Request -> [Param] -> RouteOptions ->m ActionEnv +mkEnv :: forall m. MonadIO m => Request -> [Param] -> RouteOptions -> m ActionEnv mkEnv req captures opts = do bodyState <- liftIO $ newMVar BodyUntouched @@ -187,19 +189,27 @@ mkEnv req captures opts = do putMVar bodyState $ BodyCached b chunks return b - shouldParseBody = isJust $ Parse.getRequestBodyType req - - (formparams, fs) <- if shouldParseBody - then liftIO $ do wholeBody <- BL.toChunks `fmap` bs - parseRequestBody wholeBody Parse.lbsBackEnd req - else return ([], []) + (formparams, fsm, fsd) <- + case Parse.getRequestBodyType req of + Just Parse.UrlEncoded -> liftIO $ do + wholeBody <- BL.toChunks `fmap` bs + (fp, fsm) <- parseRequestBody Parse.noLimitParseRequestBodyOptions wholeBody Parse.lbsBackEnd req + pure (fp, fsm, []) + Just (Parse.Multipart _) -> liftIO $ do + wholeBody <- BL.toChunks `fmap` bs -- XXX very much unsure we should be traversing the body here + (fp, fsd) <- runResourceT (withInternalState $ \ istate -> + parseRequestBody Parse.defaultParseRequestBodyOptions wholeBody (Parse.tempFileBackEnd istate) req) + pure (fp, [], fsd) + Nothing -> pure ([], [], []) let convert (k, v) = (strictByteStringToLazyText k, strictByteStringToLazyText v) + toLazies fs = [ (strictByteStringToLazyText k, fi) | (k, fi) <- fs ] parameters = captures ++ map convert formparams ++ queryparams queryparams = parseEncodedParams $ rawQueryString req - return $ Env req parameters bs safeBodyReader [ (strictByteStringToLazyText k, fi) | (k,fi) <- fs ] + return $ Env req parameters bs safeBodyReader (toLazies fsm) (toLazies fsd) + parseEncodedParams :: B.ByteString -> [Param] parseEncodedParams bs = [ (T.fromStrict k, T.fromStrict $ fromMaybe "" v) | (k,v) <- parseQueryText bs ] diff --git a/scotty.cabal b/scotty.cabal index 96e90091..83323439 100644 --- a/scotty.cabal +++ b/scotty.cabal @@ -87,6 +87,7 @@ Library mtl >= 2.1.2 && < 2.4, network >= 2.6.0.2 && < 3.2, regex-compat >= 0.95.1 && < 0.96, + resourcet >= 0.4.6, text >= 0.11.3.1 && < 2.1, time >= 1.8, transformers >= 0.3.0.0 && < 0.7, From 0ae301ed0552b5eacc8cb0b75b04d6522639eee5 Mon Sep 17 00:00:00 2001 From: Marco Zocca Date: Sun, 24 Sep 2023 23:20:23 +0200 Subject: [PATCH 2/3] cleanup --- Web/Scotty/Internal/Types.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/Web/Scotty/Internal/Types.hs b/Web/Scotty/Internal/Types.hs index 5950d9e2..2051ef78 100644 --- a/Web/Scotty/Internal/Types.hs +++ b/Web/Scotty/Internal/Types.hs @@ -131,7 +131,6 @@ instance Exception ScottyException ------------------ Scotty Actions ------------------- type Param = (Text, Text) --- type File = (Text, FileInfo (Either ByteString FilePath)) type File i = (Text, FileInfo i) type FileMem = File ByteString type FileDisk = File FilePath From 74252f09ab7ceb55eb7aca160d03de68dd47f7cf Mon Sep 17 00:00:00 2001 From: Marco Zocca Date: Mon, 25 Sep 2023 12:40:11 +0200 Subject: [PATCH 3/3] add comments --- Web/Scotty/Internal/Types.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/Web/Scotty/Internal/Types.hs b/Web/Scotty/Internal/Types.hs index 2051ef78..d0753647 100644 --- a/Web/Scotty/Internal/Types.hs +++ b/Web/Scotty/Internal/Types.hs @@ -139,8 +139,8 @@ data ActionEnv = Env { getReq :: Request , getParams :: [Param] , getBody :: IO ByteString , getBodyChunk :: IO BS.ByteString - , getFilesMem :: [FileMem] - , getFilesDisk :: [FileDisk] + , getFilesMem :: [FileMem] -- ^ files that are completely in memory + , getFilesDisk :: [FileDisk] -- ^ files that have been saved to disk } data RequestBodyState = BodyUntouched