From d376f435f72bc4360596484cee71fa3c14b9263f Mon Sep 17 00:00:00 2001 From: Marco Z Date: Sat, 9 Mar 2024 17:44:36 +0100 Subject: [PATCH] Files limit v2 #203 (#369) * add WaiParseSafe * traverse multipart req bodies only on demand * update upload.hs * defer form parsing * use latest wai-extra * get rid of inlined wai-extra code * add hspec-wai extras * fix files testing, add exception handling cases * add tests for 'files' and 'filesOpts' --------- Co-authored-by: Marco Zocca --- Web/Scotty.hs | 21 ++++++- Web/Scotty/Action.hs | 83 ++++++++++++++++++++++---- Web/Scotty/Body.hs | 111 +++++++++++++++++++++-------------- Web/Scotty/Internal/Types.hs | 68 ++++++++++++++------- Web/Scotty/Route.hs | 27 ++++++--- Web/Scotty/Trans.hs | 7 ++- Web/Scotty/Util.hs | 3 +- bench/Main.hs | 19 +++--- changelog.md | 12 ++++ examples/basic.hs | 2 +- examples/bodyecho.hs | 2 +- examples/upload.hs | 45 +++++++++----- examples/urlshortener.hs | 1 - scotty.cabal | 8 ++- test/Test/Hspec/Wai/Extra.hs | 65 ++++++++++++++++++++ test/Web/ScottySpec.hs | 95 +++++++++++++++++++++++++----- 16 files changed, 434 insertions(+), 135 deletions(-) create mode 100644 test/Test/Hspec/Wai/Extra.hs diff --git a/Web/Scotty.hs b/Web/Scotty.hs index fae5180f..68d4a6dd 100644 --- a/Web/Scotty.hs +++ b/Web/Scotty.hs @@ -25,12 +25,14 @@ module Web.Scotty , capture, regex, function, literal -- ** Accessing the Request and its fields , request, header, headers, body, bodyReader - , jsonData, files + , jsonData -- ** Accessing Path, Form and Query Parameters , param, params , pathParam, captureParam, formParam, queryParam , pathParamMaybe, captureParamMaybe, formParamMaybe, queryParamMaybe , pathParams, captureParams, formParams, queryParams + -- *** Files + , files, filesOpts, Trans.ParseRequestBodyOptions -- ** Modifying the Response and Redirecting , status, addHeader, setHeader, redirect -- ** Setting Response Body @@ -65,6 +67,7 @@ import Network.HTTP.Types (Status, StdMethod, ResponseHeaders) import Network.Socket (Socket) import Network.Wai (Application, Middleware, Request, StreamingBody) import Network.Wai.Handler.Warp (Port) +import qualified Network.Wai.Parse as W (defaultParseRequestBodyOptions) import Web.Scotty.Internal.Types (ScottyT, ActionT, ErrorHandler, Param, RoutePattern, Options, defaultOptions, File, Kilobytes, ScottyState, defaultScottyState, ScottyException, StatusError(..), Content(..)) import UnliftIO.Exception (Handler(..), catch) @@ -231,9 +234,19 @@ request :: ActionM Request request = Trans.request -- | Get list of uploaded files. -files :: ActionM [File] +-- +-- NB: Loads all file contents in memory with options 'W.defaultParseRequestBodyOptions' +files :: ActionM [File ByteString] files = Trans.files +-- | Get list of temp files and form parameters decoded from multipart payloads. +-- +-- NB the temp files are deleted when the continuation exits +filesOpts :: Trans.ParseRequestBodyOptions + -> ([Param] -> [File FilePath] -> ActionM a) -- ^ temp files validation, storage etc + -> ActionM a +filesOpts = Trans.filesOpts + -- | Get a request header. Header name is case-insensitive. header :: Text -> ActionM (Maybe Text) header = Trans.header @@ -243,6 +256,8 @@ headers :: ActionM [(Text, Text)] headers = Trans.headers -- | Get the request body. +-- +-- NB: loads the entire request body in memory body :: ActionM ByteString body = Trans.body @@ -253,6 +268,8 @@ bodyReader :: ActionM (IO BS.ByteString) bodyReader = Trans.bodyReader -- | Parse the request body as a JSON object and return it. Raises an exception if parse is unsuccessful. +-- +-- NB: uses 'body' internally jsonData :: FromJSON a => ActionM a jsonData = Trans.jsonData diff --git a/Web/Scotty/Action.hs b/Web/Scotty/Action.hs index f625d6cf..fa541edb 100644 --- a/Web/Scotty/Action.hs +++ b/Web/Scotty/Action.hs @@ -12,6 +12,8 @@ module Web.Scotty.Action , file , rawResponse , files + , filesOpts + , W.ParseRequestBodyOptions, W.defaultParseRequestBodyOptions , finish , header , headers @@ -66,6 +68,7 @@ import Control.Monad (when) import Control.Monad.IO.Class (MonadIO(..)) import UnliftIO (MonadUnliftIO(..)) import Control.Monad.Reader (MonadReader(..), ReaderT(..)) +import Control.Monad.Trans.Resource (withInternalState, runResourceT) import Control.Concurrent.MVar @@ -74,6 +77,7 @@ import Data.Bool (bool) import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as BL import qualified Data.CaseInsensitive as CI +import Data.Traversable (for) import Data.Int import Data.Maybe (maybeToList) import qualified Data.Text as T @@ -90,6 +94,8 @@ import Network.HTTP.Types import Network.HTTP.Types.Status #endif import Network.Wai (Request, Response, StreamingBody, Application, requestHeaders) +import Network.Wai.Handler.Warp (InvalidRequest(..)) +import qualified Network.Wai.Parse as W (FileInfo(..), ParseRequestBodyOptions, defaultParseRequestBodyOptions) import Numeric.Natural @@ -99,6 +105,7 @@ import UnliftIO.Exception (Handler(..), catch, catches, throwIO) import Network.Wai.Internal (ResponseReceived(..)) + -- | Evaluate a route, catch all exceptions (user-defined ones, internal and all remaining, in this order) -- and construct the 'Response' -- @@ -169,11 +176,25 @@ scottyExceptionHandler = Handler $ \case FailedToParseParameter k v e -> do status status400 text $ T.unwords [ "Failed to parse parameter", k, v, ":", e] + WarpRequestException we -> case we of + RequestHeaderFieldsTooLarge -> do + status status413 + weo -> do -- FIXME fall-through case on InvalidRequest, it would be nice to return more specific error messages and codes here + status status400 + text $ T.unwords ["Request Exception:", T.pack (show weo)] + WaiRequestParseException we -> do + status status413 -- 413 Content Too Large https://developer.mozilla.org/en-US/docs/Web/HTTP/Status/413 + text $ T.unwords ["wai-extra Exception:", T.pack (show we)] + ResourceTException rte -> do + status status500 + text $ T.unwords ["resourcet Exception:", T.pack (show rte)] -- | Uncaught exceptions turn into HTTP 500 Server Error codes someExceptionHandler :: MonadIO m => ErrorHandler m someExceptionHandler = Handler $ \case - (_ :: E.SomeException) -> status status500 + (e :: E.SomeException) -> do + status status500 + text $ T.unwords ["Uncaught server exception:", T.pack (show e)] -- | Throw a "500 Server Error" 'StatusError', which can be caught with 'catch'. -- @@ -254,8 +275,29 @@ request :: Monad m => ActionT m Request request = ActionT $ envReq <$> ask -- | Get list of uploaded files. -files :: Monad m => ActionT m [File] -files = ActionT $ envFiles <$> ask +-- +-- NB: Loads all file contents in memory with options 'W.defaultParseRequestBodyOptions' +files :: MonadUnliftIO m => ActionT m [File BL.ByteString] +files = runResourceT $ withInternalState $ \istate -> do + (_, fs) <- formParamsAndFilesWith istate W.defaultParseRequestBodyOptions + for fs (\(fname, f) -> do + bs <- liftIO $ BL.readFile (W.fileContent f) + pure (fname, f{ W.fileContent = bs}) + ) + + +-- | Get list of uploaded temp files and form parameters decoded from multipart payloads. +-- +-- NB the temp files are deleted when the continuation exits. +filesOpts :: MonadUnliftIO m => + W.ParseRequestBodyOptions + -> ([Param] -> [File FilePath] -> ActionT m a) -- ^ temp files validation, storage etc + -> ActionT m a +filesOpts prbo io = runResourceT $ withInternalState $ \istate -> do + (ps, fs) <- formParamsAndFilesWith istate prbo + io ps fs + + -- | Get a request header. Header name is case-insensitive. header :: (Monad m) => T.Text -> ActionT m (Maybe T.Text) @@ -272,6 +314,8 @@ headers = do | (k,v) <- hs ] -- | Get the request body. +-- +-- NB This loads the whole request body in memory at once. body :: (MonadIO m) => ActionT m BL.ByteString body = ActionT ask >>= (liftIO . envBody) @@ -290,6 +334,8 @@ bodyReader = ActionT $ envBodyChunk <$> ask -- 422 Unprocessable Entity. -- -- These status codes are as per https://www.restapitutorial.com/httpstatuscodes.html. +-- +-- NB : Internally this uses 'body'. jsonData :: (A.FromJSON a, MonadIO m) => ActionT m a jsonData = do b <- body @@ -311,7 +357,7 @@ param :: (Parsable a, MonadIO m) => T.Text -> ActionT m a param k = do val <- ActionT $ (lookup k . getParams) <$> ask case val of - Nothing -> raiseStatus status500 $ "Param: " <> k <> " not found!" -- FIXME + Nothing -> raiseStatus status500 $ "Param: " <> k <> " not found!" Just v -> either (const next) return $ parseParam (TL.fromStrict v) {-# DEPRECATED param "(#204) Not a good idea to treat all parameters identically. Use captureParam, formParam and queryParam instead. "#-} @@ -342,8 +388,14 @@ pathParam k = do -- * This function raises a code 400 also if the parameter is found, but 'parseParam' fails to parse to the correct type. -- -- /Since: 0.20/ -formParam :: (Parsable a, MonadIO m) => T.Text -> ActionT m a -formParam = paramWith FormFieldNotFound envFormParams +formParam :: (MonadUnliftIO m, Parsable b) => T.Text -> ActionT m b +formParam k = runResourceT $ withInternalState $ \istate -> do + (ps, _) <- formParamsAndFilesWith istate W.defaultParseRequestBodyOptions + case lookup k ps of + Nothing -> throwIO $ FormFieldNotFound k + Just v -> case parseParam $ TL.fromStrict v of + Left e -> throwIO $ FailedToParseParameter k v (TL.toStrict e) + Right a -> pure a -- | Look up a query parameter. -- @@ -378,8 +430,14 @@ captureParamMaybe = paramWithMaybe envPathParams -- NB : Doesn't throw exceptions, so developers must 'raiseStatus' or 'throw' to signal something went wrong. -- -- /Since: 0.21/ -formParamMaybe :: (Parsable a, Monad m) => T.Text -> ActionT m (Maybe a) -formParamMaybe = paramWithMaybe envFormParams +formParamMaybe :: (MonadUnliftIO m, Parsable a) => + T.Text -> ActionT m (Maybe a) +formParamMaybe k = runResourceT $ withInternalState $ \istate -> do + (ps, _) <- formParamsAndFilesWith istate W.defaultParseRequestBodyOptions + case lookup k ps of + Nothing -> pure Nothing + Just v -> either (const $ pure Nothing) (pure . Just) $ parseParam $ TL.fromStrict v + -- | Look up a query parameter. Returns 'Nothing' if the parameter is not found or cannot be parsed at the right type. -- @@ -440,8 +498,10 @@ captureParams :: Monad m => ActionT m [Param] captureParams = paramsWith envPathParams -- | Get form parameters -formParams :: Monad m => ActionT m [Param] -formParams = paramsWith envFormParams +formParams :: MonadUnliftIO m => ActionT m [Param] +formParams = runResourceT $ withInternalState $ \istate -> do + fst <$> formParamsAndFilesWith istate W.defaultParseRequestBodyOptions + -- | Get query parameters queryParams :: Monad m => ActionT m [Param] queryParams = paramsWith envQueryParams @@ -450,8 +510,9 @@ paramsWith :: Monad m => (ActionEnv -> a) -> ActionT m a paramsWith f = ActionT (f <$> ask) {-# DEPRECATED getParams "(#204) Not a good idea to treat all parameters identically" #-} +-- | Returns path and query parameters as a single list getParams :: ActionEnv -> [Param] -getParams e = envPathParams e <> envFormParams e <> envQueryParams e +getParams e = envPathParams e <> [] <> envQueryParams e -- === access the fields of the Response being constructed diff --git a/Web/Scotty/Body.hs b/Web/Scotty/Body.hs index d3a9046f..97614eab 100644 --- a/Web/Scotty/Body.hs +++ b/Web/Scotty/Body.hs @@ -1,5 +1,7 @@ -{-# LANGUAGE FlexibleContexts, FlexibleInstances, RecordWildCards, - OverloadedStrings, MultiWayIf #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# language OverloadedStrings #-} +{-# language ScopedTypeVariables #-} module Web.Scotty.Body ( newBodyInfo, cloneBodyInfo @@ -7,20 +9,27 @@ module Web.Scotty.Body ( , getFormParamsAndFilesAction , getBodyAction , getBodyChunkAction + -- wai-extra + , W.RequestParseException(..) ) where import Control.Concurrent.MVar import Control.Monad.IO.Class +import Control.Monad.Trans.Resource (InternalState) +import Data.Bifunctor (first, bimap) import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as BL -import Data.Maybe import qualified GHC.Exception as E (throw) import Network.Wai (Request(..), getRequestBodyChunk) -import qualified Network.Wai.Parse as W (File, Param, getRequestBodyType, BackEnd, lbsBackEnd, sinkRequestBody) -import Web.Scotty.Action (Param) -import Web.Scotty.Internal.Types (BodyInfo(..), BodyChunkBuffer(..), BodyPartiallyStreamed(..), RouteOptions(..)) -import Web.Scotty.Util (readRequestBody, strictByteStringToLazyText, decodeUtf8Lenient) +import qualified Network.Wai.Handler.Warp as Warp (InvalidRequest(..)) +import qualified Network.Wai.Parse as W (File, Param, getRequestBodyType, tempFileBackEnd, RequestBodyType(..), sinkRequestBodyEx, RequestParseException(..), ParseRequestBodyOptions) +-- import UnliftIO (MonadUnliftIO(..)) +import UnliftIO.Exception (Handler(..), catches, throwIO) + +import Web.Scotty.Internal.Types (BodyInfo(..), BodyChunkBuffer(..), BodyPartiallyStreamed(..), RouteOptions(..), File, ScottyException(..), Param) +import Web.Scotty.Util (readRequestBody, decodeUtf8Lenient) + -- | Make a new BodyInfo with readProgress at 0 and an empty BodyChunkBuffer. newBodyInfo :: (MonadIO m) => Request -> m BodyInfo @@ -36,26 +45,62 @@ cloneBodyInfo (BodyInfo _ chunkBufferVar getChunk) = liftIO $ do cleanReadProgressVar <- newMVar 0 return $ BodyInfo cleanReadProgressVar chunkBufferVar getChunk --- | Get the form params and files from the request. Requires reading the whole body. -getFormParamsAndFilesAction :: Request -> BodyInfo -> RouteOptions -> IO ([Param], [W.File BL.ByteString]) -getFormParamsAndFilesAction req bodyInfo opts = do - let shouldParseBody = isJust $ W.getRequestBodyType req +-- | Get the form params and files from the request. +-- +-- NB : catches exceptions from 'warp' and 'wai-extra' and wraps them into 'ScottyException' +getFormParamsAndFilesAction :: + InternalState + -> W.ParseRequestBodyOptions + -> Request -- ^ only used for its body type + -> BodyInfo -- ^ the request body contents are read from here + -> RouteOptions + -> IO ([Param], [File FilePath]) +getFormParamsAndFilesAction istate prbo req bodyInfo opts = do + let + bs2t = decodeUtf8Lenient + convertBoth = bimap bs2t bs2t + convertKey = first bs2t + bs <- getBodyAction bodyInfo opts + let + wholeBody = BL.toChunks bs + (formparams, fs) <- parseRequestBodyExBS istate prbo wholeBody (W.getRequestBodyType req) `catches` handleWaiParseSafeExceptions + return (convertBoth <$> formparams, convertKey <$> fs) + +-- | Wrap exceptions from upstream libraries into 'ScottyException' +handleWaiParseSafeExceptions :: MonadIO m => [Handler m a] +handleWaiParseSafeExceptions = [h1, h2] + where + h1 = Handler (\ (e :: W.RequestParseException ) -> throwIO $ WaiRequestParseException e) + h2 = Handler (\(e :: Warp.InvalidRequest) -> throwIO $ WarpRequestException e) + +-- | Adapted from wai-extra's Network.Wai.Parse, modified to accept body as list of Bytestrings. +-- Reason: WAI's requestBody is an IO action that returns the body as chunks. 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. +parseRequestBodyExBS :: MonadIO m => + InternalState + -> W.ParseRequestBodyOptions + -> [B.ByteString] + -> Maybe W.RequestBodyType + -> m ([W.Param], [W.File FilePath]) +parseRequestBodyExBS istate o bl rty = + case rty of + Nothing -> return ([], []) + Just rbt -> do + mvar <- liftIO $ newMVar bl -- MVar is a bit of a hack so we don't have to inline + -- large portions of Network.Wai.Parse + let provider = modifyMVar mvar $ \bsold -> case bsold of + [] -> return ([], B.empty) + (b:bs) -> return (bs, b) + liftIO $ W.sinkRequestBodyEx o (W.tempFileBackEnd istate) rbt provider - if shouldParseBody - then - do - bs <- getBodyAction bodyInfo opts - let wholeBody = BL.toChunks bs - (formparams, fs) <- parseRequestBody wholeBody W.lbsBackEnd req -- NB this loads the whole body into memory - let convert (k, v) = (decodeUtf8Lenient k, decodeUtf8Lenient v) - return (convert <$> formparams, fs) - else - return ([], []) -- | Retrieve the entire body, using the cached chunks in the BodyInfo and reading any other -- chunks if they still exist. --- Mimic the previous behavior by throwing BodyPartiallyStreamed if the user has already +-- Mimic the previous behavior by throwing 'BodyPartiallyStreamed' if the user has already -- started reading the body by chunks. +-- +-- throw 'ScottyException' if request body too big getBodyAction :: BodyInfo -> RouteOptions -> IO (BL.ByteString) getBodyAction (BodyInfo readProgress chunkBufferVar getChunk) opts = modifyMVar readProgress $ \index -> @@ -77,25 +122,5 @@ getBodyChunkAction (BodyInfo readProgress chunkBufferVar getChunk) = | hasFinished -> return (bcb, (index, mempty)) | otherwise -> do newChunk <- getChunk - return (BodyChunkBuffer (newChunk == mempty) (chunks ++ [newChunk]), (index + 1, newChunk)) - + return (BodyChunkBuffer (B.null newChunk) (chunks ++ [newChunk]), (index + 1, newChunk)) --- Stolen from wai-extra's Network.Wai.Parse, modified to accept body as list of Bytestrings. --- Reason: WAI's requestBody is an IO action that returns the body as chunks. 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] - -> W.BackEnd y - -> Request - -> m ([W.Param], [W.File y]) -parseRequestBody bl s r = - case W.getRequestBodyType r of - Nothing -> return ([], []) - Just rbt -> do - mvar <- liftIO $ newMVar bl -- MVar is a bit of a hack so we don't have to inline - -- large portions of Network.Wai.Parse - let provider = modifyMVar mvar $ \bsold -> case bsold of - [] -> return ([], B.empty) - (b:bs) -> return (bs, b) - liftIO $ W.sinkRequestBody s rbt provider diff --git a/Web/Scotty/Internal/Types.hs b/Web/Scotty/Internal/Types.hs index 4de097c4..efc40d28 100644 --- a/Web/Scotty/Internal/Types.hs +++ b/Web/Scotty/Internal/Types.hs @@ -25,27 +25,31 @@ import Control.Monad.Reader (MonadReader(..), ReaderT, asks, mapReader import Control.Monad.State.Strict (State, StateT(..)) import Control.Monad.Trans.Class (MonadTrans(..)) import Control.Monad.Trans.Control (MonadBaseControl, MonadTransControl) +import qualified Control.Monad.Trans.Resource as RT (InternalState, InvalidAccess) import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy.Char8 as LBS8 (ByteString) import Data.Default.Class (Default, def) import Data.String (IsString(..)) -import Data.Text (Text, pack) +import qualified Data.Text as T (Text, pack) import Data.Typeable (Typeable) import Network.HTTP.Types import Network.Wai hiding (Middleware, Application) import qualified Network.Wai as Wai -import Network.Wai.Handler.Warp (Settings, defaultSettings) +import qualified Network.Wai.Handler.Warp as W (Settings, defaultSettings, InvalidRequest(..)) import Network.Wai.Parse (FileInfo) +import qualified Network.Wai.Parse as WPS (ParseRequestBodyOptions, RequestParseException(..)) import UnliftIO.Exception (Handler(..), catch, catches) + + --------------------- Options ----------------------- data Options = Options { verbose :: Int -- ^ 0 = silent, 1(def) = startup banner - , settings :: Settings -- ^ Warp 'Settings' + , settings :: W.Settings -- ^ Warp 'Settings' -- Note: to work around an issue in warp, -- the default FD cache duration is set to 0 -- so changes to static files are always picked @@ -58,7 +62,7 @@ instance Default Options where def = defaultOptions defaultOptions :: Options -defaultOptions = Options 1 defaultSettings +defaultOptions = Options 1 W.defaultSettings newtype RouteOptions = RouteOptions { maxRequestBodySize :: Maybe Kilobytes -- max allowed request size in KB } @@ -96,8 +100,8 @@ data ScottyState m = , routeOptions :: RouteOptions } -instance Default (ScottyState m) where - def = defaultScottyState +-- instance Default (ScottyState m) where +-- def = defaultScottyState defaultScottyState :: ScottyState m defaultScottyState = ScottyState [] [] Nothing defaultRouteOptions @@ -127,7 +131,7 @@ newtype ScottyT m a = ScottyT { runS :: State (ScottyState m) a } -- The exception constructor is not exposed to the user and all exceptions of this type are caught -- and processed within the 'runAction' function. data ActionError - = AERedirect Text -- ^ Redirect + = AERedirect T.Text -- ^ Redirect | AENext -- ^ Stop processing this route and skip to the next one | AEFinish -- ^ Stop processing the request deriving (Show, Typeable) @@ -140,7 +144,7 @@ tryNext io = catch (io >> pure True) $ \e -> _ -> pure True -- | E.g. when a parameter is not found in a query string (400 Bad Request) or when parsing a JSON body fails (422 Unprocessable Entity) -data StatusError = StatusError Status Text deriving (Show, Typeable) +data StatusError = StatusError Status T.Text deriving (Show, Typeable) instance E.Exception StatusError {-# DEPRECATED StatusError "If it is supposed to be caught, a proper exception type should be defined" #-} @@ -150,30 +154,46 @@ type ErrorHandler m = Handler (ActionT m) () -- | Thrown e.g. when a request is too large data ScottyException = RequestTooLarge - | MalformedJSON LBS8.ByteString Text - | FailedToParseJSON LBS8.ByteString Text - | PathParameterNotFound Text - | QueryParameterNotFound Text - | FormFieldNotFound Text - | FailedToParseParameter Text Text Text + | MalformedJSON LBS8.ByteString T.Text + | FailedToParseJSON LBS8.ByteString T.Text + | PathParameterNotFound T.Text + | QueryParameterNotFound T.Text + | FormFieldNotFound T.Text + | FailedToParseParameter T.Text T.Text T.Text + | WarpRequestException W.InvalidRequest + | WaiRequestParseException WPS.RequestParseException -- request parsing + | ResourceTException RT.InvalidAccess -- use after free deriving (Show, Typeable) instance E.Exception ScottyException ------------------ Scotty Actions ------------------- -type Param = (Text, Text) +type Param = (T.Text, T.Text) -type File = (Text, FileInfo LBS8.ByteString) +-- | Type parameter @t@ is the file content. Could be @()@ when not needed or a @FilePath@ for temp files instead. +type File t = (T.Text, FileInfo t) data ActionEnv = Env { envReq :: Request , envPathParams :: [Param] - , envFormParams :: [Param] , envQueryParams :: [Param] + , envFormDataAction :: RT.InternalState -> WPS.ParseRequestBodyOptions -> IO ([Param], [File FilePath]) , envBody :: IO LBS8.ByteString , envBodyChunk :: IO BS.ByteString - , envFiles :: [File] , envResponse :: TVar ScottyResponse } + + + +formParamsAndFilesWith :: MonadUnliftIO m => + RT.InternalState + -> WPS.ParseRequestBodyOptions + -> ActionT m ([Param], [File FilePath]) +formParamsAndFilesWith istate prbo = action `catch` (\(e :: RT.InvalidAccess) -> E.throw $ ResourceTException e) + where + action = do + act <- ActionT $ asks envFormDataAction + liftIO $ act istate prbo + getResponse :: MonadIO m => ActionEnv -> m ScottyResponse getResponse ae = liftIO $ readTVarIO (envResponse ae) @@ -221,6 +241,10 @@ defaultScottyResponse = SR status200 [] (ContentBuilder mempty) newtype ActionT m a = ActionT { runAM :: ReaderT ActionEnv m a } deriving newtype (Functor, Applicative, Monad, MonadIO, MonadTrans, MonadThrow, MonadCatch, MonadBase b, MonadBaseControl b, MonadTransControl, MonadUnliftIO) +withActionEnv :: Monad m => + (ActionEnv -> ActionEnv) -> ActionT m a -> ActionT m a +withActionEnv f (ActionT r) = ActionT $ local f r + instance MonadReader r m => MonadReader r (ActionT m) where ask = ActionT $ lift ask local f = ActionT . mapReaderT (local f) . runAM @@ -231,7 +255,7 @@ instance (MonadUnliftIO m) => MonadError StatusError (ActionT m) where catchError = catch -- | Modeled after the behaviour in scotty < 0.20, 'fail' throws a 'StatusError' with code 500 ("Server Error"), which can be caught with 'E.catch'. instance (MonadIO m) => MonadFail (ActionT m) where - fail = E.throw . StatusError status500 . pack + fail = E.throw . StatusError status500 . T.pack -- | 'empty' throws 'ActionError' 'AENext', whereas '(<|>)' catches any 'ActionError's or 'StatusError's in the first action and proceeds to the second one. instance (MonadUnliftIO m) => Alternative (ActionT m) where empty = E.throw AENext @@ -272,11 +296,11 @@ instance mempty = return mempty ------------------ Scotty Routes -------------------- -data RoutePattern = Capture Text - | Literal Text +data RoutePattern = Capture T.Text + | Literal T.Text | Function (Request -> Maybe [Param]) instance IsString RoutePattern where - fromString = Capture . pack + fromString = Capture . T.pack diff --git a/Web/Scotty/Route.hs b/Web/Scotty/Route.hs index 9c4bd951..1baa3081 100644 --- a/Web/Scotty/Route.hs +++ b/Web/Scotty/Route.hs @@ -10,6 +10,7 @@ import Control.Concurrent.STM (newTVarIO) import Control.Monad.IO.Class (MonadIO(..)) import UnliftIO (MonadUnliftIO(..)) import qualified Control.Monad.State as MS +import Control.Monad.Trans.Resource (InternalState) import Data.String (fromString) import qualified Data.Text as T @@ -20,10 +21,11 @@ import Network.Wai (Request(..)) import qualified Text.Regex as Regex import Web.Scotty.Action -import Web.Scotty.Internal.Types (RoutePattern(..), RouteOptions, ActionEnv(..), ActionT, ScottyState(..), ScottyT(..), ErrorHandler, Middleware, BodyInfo, handler, addRoute, defaultScottyResponse) +import Web.Scotty.Internal.Types (RoutePattern(..), RouteOptions, ActionEnv(..), ScottyState(..), ScottyT(..), File, ErrorHandler, Middleware, BodyInfo, handler, addRoute, defaultScottyResponse) import Web.Scotty.Util (decodeUtf8Lenient) import Web.Scotty.Body (cloneBodyInfo, getBodyAction, getBodyChunkAction, getFormParamsAndFilesAction) + {- $setup >>> :{ import Control.Monad.IO.Class (MonadIO(..)) @@ -101,7 +103,8 @@ let server = S.get "/foo/:bar" (S.pathParam "bar" >>= S.text) "something" -} addroute :: (MonadUnliftIO m) => StdMethod -> RoutePattern -> ActionT m () -> ScottyT m () -addroute method pat action = ScottyT $ MS.modify $ \s -> addRoute (route (routeOptions s) (handler s) (Just method) pat action) s +addroute method pat action = ScottyT $ MS.modify $ \s -> + addRoute (route (routeOptions s) (handler s) (Just method) pat action) s route :: (MonadUnliftIO m) => RouteOptions @@ -122,9 +125,9 @@ route opts h method pat action bodyInfo app req = -- if `next` is called and we try to match further routes. -- Instead, make a "cloned" copy of the BodyInfo that allows the IO actions to be called -- without messing up the state of the original BodyInfo. - clonedBodyInfo <- cloneBodyInfo bodyInfo + cbi <- cloneBodyInfo bodyInfo - env <- mkEnv clonedBodyInfo req captures opts + env <- mkEnv cbi req captures opts res <- runAction h env action maybe tryNext return res Nothing -> tryNext @@ -153,14 +156,20 @@ path :: Request -> T.Text path = T.cons '/' . T.intercalate "/" . pathInfo -- | Parse the request and construct the initial 'ActionEnv' with a default 200 OK response -mkEnv :: MonadIO m => BodyInfo -> Request -> [Param] -> RouteOptions -> m ActionEnv -mkEnv bodyInfo req captureps opts = do - (formps, bodyFiles) <- liftIO $ getFormParamsAndFilesAction req bodyInfo opts +mkEnv :: MonadIO m => + BodyInfo + -> Request + -> [Param] + -> RouteOptions + -> m ActionEnv +mkEnv bodyInfo req pathps opts = do let + getFormData :: InternalState -> ParseRequestBodyOptions -> IO ([Param], [File FilePath]) + getFormData istate prbo = getFormParamsAndFilesAction istate prbo req bodyInfo opts queryps = parseEncodedParams $ queryString req - bodyFiles' = [ (decodeUtf8Lenient k, fi) | (k,fi) <- bodyFiles ] responseInit <- liftIO $ newTVarIO defaultScottyResponse - return $ Env req captureps formps queryps (getBodyAction bodyInfo opts) (getBodyChunkAction bodyInfo) bodyFiles' responseInit + return $ Env req pathps queryps getFormData (getBodyAction bodyInfo opts) (getBodyChunkAction bodyInfo) responseInit + parseEncodedParams :: Query -> [Param] diff --git a/Web/Scotty/Trans.hs b/Web/Scotty/Trans.hs index 4bdc5c29..96161082 100644 --- a/Web/Scotty/Trans.hs +++ b/Web/Scotty/Trans.hs @@ -30,12 +30,15 @@ module Web.Scotty.Trans , capture, regex, function, literal -- ** Accessing the Request and its fields , request, Lazy.header, Lazy.headers, body, bodyReader - , jsonData, files + , jsonData + -- ** Accessing Path, Form and Query Parameters , param, params , pathParam, captureParam, formParam, queryParam , pathParamMaybe, captureParamMaybe, formParamMaybe, queryParamMaybe , pathParams, captureParams, formParams, queryParams + -- *** Files + , files, filesOpts, ParseRequestBodyOptions -- ** Modifying the Response and Redirecting , status, Lazy.addHeader, Lazy.setHeader, Lazy.redirect -- ** Setting Response Body @@ -134,7 +137,7 @@ scottyAppT runActionToIO defs = do callback resp return $ applyAll rapp (middlewares s) ---- | Exception handler in charge of 'ScottyException' that's not caught by 'scottyExceptionHandler' +-- | Exception handler in charge of 'ScottyException' that's not caught by 'scottyExceptionHandler' unhandledExceptionHandler :: MonadIO m => ScottyException -> m W.Response unhandledExceptionHandler = \case RequestTooLarge -> return $ W.responseBuilder status413 ct "Request is too big Jim!" diff --git a/Web/Scotty/Util.hs b/Web/Scotty/Util.hs index cd278f92..338a368e 100644 --- a/Web/Scotty/Util.hs +++ b/Web/Scotty/Util.hs @@ -71,7 +71,7 @@ socketDescription sock = do SockAddrUnix u -> return $ "unix socket " ++ u _ -> fmap (\port -> "port " ++ show port) $ socketPort sock --- | return request body or throw a 'RequestException' if request body too big +-- | return request body or throw a 'ScottyException' if request body too big readRequestBody :: IO B.ByteString -- ^ body chunk reader -> ([B.ByteString] -> IO [B.ByteString]) -> Maybe Kilobytes -- ^ max body size @@ -98,4 +98,3 @@ readRequestBody rbody prefix maxSize = do else readUntilEmpty - diff --git a/bench/Main.hs b/bench/Main.hs index 19a0fc49..6658888f 100644 --- a/bench/Main.hs +++ b/bench/Main.hs @@ -19,15 +19,16 @@ import Weigh main :: IO () main = do - mainWith $ do - setColumns [Case,Allocated,GCs,Live,Check,Max,MaxOS] - setFormat Markdown - io "ScottyM Strict" BL.putStr - (SS.evalState (runS $ renderBST htmlScotty) defaultScottyState) - io "ScottyM Lazy" BL.putStr - (SL.evalState (runScottyLazy $ renderBST htmlScottyLazy) defaultScottyState) - io "Identity" BL.putStr - (runIdentity $ renderBST htmlIdentity) + mainWith $ do + setColumns [Case,Allocated,GCs,Live,Check,Max,MaxOS] + setFormat Markdown + io "ScottyM Strict" BL.putStr + (SS.evalState (runS $ renderBST htmlScotty) defaultScottyState) + io "ScottyM Lazy" BL.putStr + (SL.evalState (runScottyLazy $ renderBST htmlScottyLazy) defaultScottyState) + io "Identity" BL.putStr + (runIdentity $ renderBST htmlIdentity) + htmlTest :: Monad m => HtmlT m () htmlTest = replicateM_ 2 $ div_ $ do diff --git a/changelog.md b/changelog.md index 0c35eedd..340c44f7 100644 --- a/changelog.md +++ b/changelog.md @@ -1,12 +1,20 @@ ## next [????.??.??] + + ### New * add `instance Parsable UTCTime` (#250) +* add `filesOpts` (#369). Form parameters and files are only parsed from the request body if needed; `filesOpts` introduces options to limit uploads, a mechanism to back uploads with temporary files based on resourcet, as well as a continuation-based syntax to process such temporary files. This function is now the central mechanism for handling form parameters and files (`files` is written in terms of it). ### Fixes * Path parameters with value matching the parameter name prefixed by colon will properly populate `pathParams` with their literal value : `/:param` will match `/:param` and add a `Param` with value `("param", ":param")` (#301) * Accept text-2.1 (#364) +### Breaking changes +* some ActionT API functions have now a MonadIO or MonadUnliftIO constraint rather than Monad reflecting that there is where request reading takes place. (#369) +* the File type has now a type parameter to reflect whether it carries file contents or just a filepath pointing to the temp file (#369). + + ## 0.21 [2023.12.17] ### New @@ -23,12 +31,16 @@ * Reverted the `MonadReader` instance of `ActionT` so that it inherits the base monad (#342) * Scotty's API such as `queryParam` now throws `ScottyException` rather than `StatusException`. Uncaught exceptions are handled by `scottyExceptionHandler`, resembling the existing behaviour + +### Breaking changes +* `File` type: the first component of the tuple is strict text now (used to be lazy prior to 0.21) (#370) ### Documentation * Add doctest, refactor some inline examples into doctests (#353) * document "`defaultHandler` only applies to endpoints defined after it" (#237) + ## 0.20.1 [2023.10.03] * remove dependencies on 'base-compat' and 'base-compat-batteries' (#318) * re-add MonadFail (ActionT m) instance (#325) diff --git a/examples/basic.hs b/examples/basic.hs index 3c2c33ce..3b838f14 100644 --- a/examples/basic.hs +++ b/examples/basic.hs @@ -9,7 +9,7 @@ import Network.Wai.Middleware.RequestLogger -- install wai-extra if you don't ha import Control.Exception (Exception(..)) import Control.Monad -import Control.Monad.Trans +-- import Control.Monad.Trans import System.Random (newStdGen, randomRs) import Network.HTTP.Types (status302) diff --git a/examples/bodyecho.hs b/examples/bodyecho.hs index 963b9d8d..83473b8a 100644 --- a/examples/bodyecho.hs +++ b/examples/bodyecho.hs @@ -3,7 +3,7 @@ module Main (main) where import Web.Scotty -import Control.Monad.IO.Class (liftIO) +-- import Control.Monad.IO.Class (liftIO) import qualified Blaze.ByteString.Builder as B import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BSL diff --git a/examples/upload.hs b/examples/upload.hs index 06f184a1..b3d9c206 100644 --- a/examples/upload.hs +++ b/examples/upload.hs @@ -1,14 +1,16 @@ {-# LANGUAGE OverloadedStrings #-} +{-# language ScopedTypeVariables #-} module Main (main) where import Web.Scotty -import Control.Monad.IO.Class +import Control.Exception (SomeException) +import Data.Foldable (for_) import qualified Data.Text.Lazy as TL import Network.Wai.Middleware.RequestLogger import Network.Wai.Middleware.Static -import Network.Wai.Parse +import Network.Wai.Parse (fileName, fileContent, defaultParseRequestBodyOptions) import qualified Text.Blaze.Html5 as H import Text.Blaze.Html5.Attributes @@ -18,30 +20,43 @@ import qualified Data.ByteString.Lazy as B import qualified Data.ByteString.Char8 as BS import System.FilePath (()) +{-| NB : the file paths where files are saved and looked up are relative, so make sure +to run this program from the root directory of the 'scotty' repo, or adjust the paths +accordingly. +-} + main :: IO () main = scotty 3000 $ do middleware logStdoutDev - middleware $ staticPolicy (noDots >-> addBase "uploads") + middleware $ staticPolicy (noDots >-> addBase "examples/uploads") get "/" $ do html $ renderHtml $ H.html $ do H.body $ do H.form H.! method "post" H.! enctype "multipart/form-data" H.! action "/upload" $ do - H.input H.! type_ "file" H.! name "foofile" + H.input H.! type_ "file" H.! name "file_1" H.br - H.input H.! type_ "file" H.! name "barfile" + H.input H.! type_ "file" H.! name "file_2" H.br H.input H.! type_ "submit" post "/upload" $ do - fs <- files - let fs' = [ (fieldName, BS.unpack (fileName fi), fileContent fi) | (fieldName,fi) <- fs ] - -- write the files to disk, so they will be served by the static middleware - liftIO $ sequence_ [ B.writeFile ("uploads" fn) fc | (_,fn,fc) <- fs' ] - -- generate list of links to the files just uploaded - html $ mconcat [ mconcat [ TL.fromStrict fName - , ": " - , renderHtml $ H.a (H.toHtml fn) H.! (href $ H.toValue fn) >> H.br - ] - | (fName,fn,_) <- fs' ] + filesOpts defaultParseRequestBodyOptions $ \_ fs -> do + let + fs' = [(fieldName, BS.unpack (fileName fi), fileContent fi) | (fieldName, fi) <- fs] + -- write the files to disk, so they can be served by the static middleware + for_ fs' $ \(_, fnam, fpath) -> do + -- copy temp file to local dir + liftIO (do + fc <- B.readFile fpath + B.writeFile ("examples" "uploads" fnam) fc + ) `catch` (\(e :: SomeException) -> do + liftIO $ putStrLn $ unwords ["upload: something went wrong while saving temp files :", show e] + ) + -- generate list of links to the files just uploaded + html $ mconcat [ mconcat [ TL.fromStrict fName + , ": " + , renderHtml $ H.a (H.toHtml fn) H.! (href $ H.toValue fn) >> H.br + ] + | (fName,fn,_) <- fs' ] diff --git a/examples/urlshortener.hs b/examples/urlshortener.hs index d27c3b42..d7b18b7b 100644 --- a/examples/urlshortener.hs +++ b/examples/urlshortener.hs @@ -8,7 +8,6 @@ import Web.Scotty import Control.Concurrent.MVar import Control.Exception (Exception(..)) -import Control.Monad.IO.Class import qualified Data.Map as M import qualified Data.Text.Lazy as T import Data.Typeable (Typeable) diff --git a/scotty.cabal b/scotty.cabal index c3b0b145..ebbb0a0f 100644 --- a/scotty.cabal +++ b/scotty.cabal @@ -83,6 +83,7 @@ Library mtl >= 2.1.2 && < 2.4, network >= 2.6.0.2 && < 3.2, regex-compat >= 0.95.1 && < 0.96, + resourcet, stm, text >= 0.11.3.1 && < 2.2, time >= 1.8, @@ -91,7 +92,7 @@ Library transformers-compat >= 0.4 && < 0.8, unliftio >= 0.2, wai >= 3.0.0 && < 3.3, - wai-extra >= 3.0.0 && < 3.2, + wai-extra >= 3.1.14, warp >= 3.0.13 && < 3.4 if impl(ghc < 8.0) @@ -105,6 +106,7 @@ Library test-suite spec main-is: Spec.hs other-modules: Web.ScottySpec + Test.Hspec.Wai.Extra type: exitcode-stdio-1.0 default-language: Haskell2010 hs-source-dirs: test @@ -120,7 +122,8 @@ test-suite spec scotty, text, time, - wai + wai, + wai-extra build-tool-depends: hspec-discover:hspec-discover == 2.* GHC-options: -Wall -threaded -fno-warn-orphans @@ -149,6 +152,7 @@ benchmark weigh lucid, bytestring, mtl, + resourcet, text, transformers, weigh >= 0.0.16 && <0.1 diff --git a/test/Test/Hspec/Wai/Extra.hs b/test/Test/Hspec/Wai/Extra.hs new file mode 100644 index 00000000..9f97ef1e --- /dev/null +++ b/test/Test/Hspec/Wai/Extra.hs @@ -0,0 +1,65 @@ +-- | This should be in 'hspec-wai', PR pending as of Feb 2024 : https://github.com/hspec/hspec-wai/pull/77 +-- +-- NB the code below has been changed wrt PR 77 and works in the scotty test suite as well. + +{-# language OverloadedStrings #-} +module Test.Hspec.Wai.Extra (postMultipartForm, FileMeta(..)) where + +import qualified Data.Char as Char +import Data.List (intersperse) + +import Data.ByteString (ByteString) +import qualified Data.ByteString.Builder as Builder +import qualified Data.ByteString.Lazy as LB + +import Data.Word (Word8) + +import Network.HTTP.Types (methodPost, hContentType) +import Network.Wai.Test (SResponse) + +import Test.Hspec.Wai (request) +import Test.Hspec.Wai.Internal (WaiSession) + +-- | @POST@ a @multipart/form-data@ form which might include files. +-- +-- The @Content-Type@ is set to @multipart/form-data; boundary=@ where @bd@ is the part separator without the @--@ prefix. +postMultipartForm :: ByteString -- ^ path + -> ByteString -- ^ part separator without any dashes + -> [(FileMeta, ByteString, ByteString, ByteString)] -- ^ (file metadata, field MIME type, field name, field contents) + -> WaiSession st SResponse +postMultipartForm path sbs = + request methodPost path [(hContentType, "multipart/form-data; boundary=" <> sbs)] . formMultipartQuery sbs + +-- | Encode the body of a multipart form post +-- +-- schema from : https://swagger.io/docs/specification/describing-request-body/multipart-requests/ +formMultipartQuery :: ByteString -- ^ part separator without any dashes + -> [(FileMeta, ByteString, ByteString, ByteString)] -- ^ (file metadata, field MIME type, field name, field contents) + -> LB.ByteString +formMultipartQuery sbs = Builder.toLazyByteString . mconcat . intersperse newline . encodeAll + where + encodeAll fs = map encodeFile fs <> [sepEnd] + encodeFile (fieldMeta, ty, n, payload) = mconcat $ [ + sep + , newline + , kv "Content-Disposition" ("form-data;" <> " name=" <> quoted n <> encodeMPField fieldMeta) + , newline + , kv "Content-Type" (Builder.byteString ty) + , newline, newline + , Builder.byteString payload + ] + sep = Builder.byteString ("--" <> sbs) + sepEnd = Builder.byteString ("--" <> sbs <> "--") + encodeMPField FMFormField = mempty + encodeMPField (FMFile fname) = "; filename=" <> quoted fname + quoted x = Builder.byteString ("\"" <> x <> "\"") + kv k v = k <> ": " <> v + newline = Builder.word8 (ord '\n') + + +data FileMeta = FMFormField -- ^ any form field except a file + | FMFile ByteString -- ^ file name + + +ord :: Char -> Word8 +ord = fromIntegral . Char.ord diff --git a/test/Web/ScottySpec.hs b/test/Web/ScottySpec.hs index fcbe8605..80217af9 100644 --- a/test/Web/ScottySpec.hs +++ b/test/Web/ScottySpec.hs @@ -2,7 +2,8 @@ module Web.ScottySpec (main, spec) where import Test.Hspec -import Test.Hspec.Wai +import Test.Hspec.Wai (with, request, get, post, put, patch, delete, options, (<:>), shouldRespondWith, postHtmlForm, matchHeaders, matchBody, matchStatus) +import Test.Hspec.Wai.Extra (postMultipartForm, FileMeta(..)) import Control.Applicative import Control.Monad @@ -16,6 +17,7 @@ import Data.Time.Clock (secondsToDiffTime) import Network.HTTP.Types import Network.Wai (Application, Request(queryString), responseLBS) +import Network.Wai.Parse (defaultParseRequestBodyOptions) import qualified Control.Exception.Lifted as EL import qualified Control.Exception as E @@ -65,7 +67,7 @@ spec = do makeRequest "/:paramName" `shouldRespondWith` ":paramName" it ("captures route parameters for " ++ method ++ " requests with url encoded '/' in path") $ do makeRequest "/a%2Fb" `shouldRespondWith` "a/b" - + describe "addroute" $ do forM_ availableMethods $ \method -> do withApp (addroute method "/scotty" $ html "") $ do @@ -115,7 +117,7 @@ spec = do context "when not specified" $ do withApp (Scotty.get "/" $ throw E.DivideByZero) $ do it "returns 500 on exceptions" $ do - get "/" `shouldRespondWith` "" {matchStatus = 500} + get "/" `shouldRespondWith` 500 context "only applies to endpoints defined after it (#237)" $ do withApp (do let h = Handler (\(_ :: E.SomeException) -> status status503 >> text "ok") @@ -133,17 +135,29 @@ spec = do let large = TLE.encodeUtf8 . TL.pack . concat $ [show c | c <- ([1..4500]::[Integer])] smol = TLE.encodeUtf8 . TL.pack . concat $ [show c | c <- ([1..50]::[Integer])] - withApp (Scotty.setMaxRequestBodySize 1 >> Scotty.matchAny "/upload" (do status status200)) $ do - it "should return 200 OK if the request body size is below 1 KB" $ do - request "POST" "/upload" [("Content-Type","multipart/form-data; boundary=--33")] - smol `shouldRespondWith` 200 - it "should return 413 (Content Too Large) if the request body size is above 1 KB" $ do - request "POST" "/upload" [("Content-Type","multipart/form-data; boundary=--33")] - large `shouldRespondWith` 413 - context "(counterexample)" $ - withApp (Scotty.post "/" $ status status200) $ do - it "doesn't throw an uncaught exception if the body is large" $ do - request "POST" "/" [("Content-Type","multipart/form-data; boundary=--33")] + withApp (do + Scotty.setMaxRequestBodySize 1 + Scotty.post "/upload" $ do + _ <- files + status status200 + ) $ do + context "application/x-www-form-urlencoded" $ do + it "should return 200 OK if the request body size is below 1 KB" $ do + request "POST" "/upload" [("Content-Type","application/x-www-form-urlencoded")] + smol `shouldRespondWith` 200 + it "should return 413 (Content Too Large) if the request body size is above 1 KB" $ do + request "POST" "/upload" [("Content-Type","application/x-www-form-urlencoded")] + large `shouldRespondWith` 413 + + withApp (Scotty.post "/" $ status status200) $ do + context "(counterexample)" $ do + it "doesn't throw an uncaught exception if the body is large" $ do + request "POST" "/" [("Content-Type","application/x-www-form-urlencoded")] + large `shouldRespondWith` 200 + withApp (Scotty.setMaxRequestBodySize 1 >> Scotty.post "/upload" (do status status200)) $ do + context "multipart/form-data; boundary=--33" $ do + it "should return 200 OK if the request body size is above 1 KB (since multipart form bodies are only traversed or parsed on demand)" $ do + request "POST" "/upload" [("Content-Type","multipart/form-data; boundary=--33")] large `shouldRespondWith` 200 describe "middleware" $ do @@ -163,7 +177,7 @@ spec = do get "/" `shouldRespondWith` 200 withApp (Scotty.get "/" $ EL.throwIO E.DivideByZero) $ do it "returns 500 on uncaught exceptions" $ do - get "/" `shouldRespondWith` "" {matchStatus = 500} + get "/" `shouldRespondWith` 500 context "Alternative instance" $ do withApp (Scotty.get "/" $ empty >>= text) $ @@ -307,6 +321,57 @@ spec = do it "responds with 200 OK if the parameter is not found" $ do get "/b/potato" `shouldRespondWith` 200 + describe "files" $ do + withApp (Scotty.post "/files" $ do + fs <- files + text $ TL.pack $ show $ length fs) $ do + context "small number of files" $ do + it "loads uploaded files in memory" $ do + postMultipartForm "/files" "ABC123" [ + (FMFile "file1.txt", "text/plain;charset=UTF-8", "first_file", "xxx") + ] `shouldRespondWith` 200 { matchBody = "1"} + context "file name too long (> 32 bytes)" $ do + it "responds with 413 - Request Too Large" $ do + postMultipartForm "/files" "ABC123" [ + (FMFile "file.txt", "text/plain;charset=UTF-8", "abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzx", "xxx") + ] `shouldRespondWith` 413 + context "large number of files (> 10)" $ do + it "responds with 413 - Request Too Large" $ do + postMultipartForm "/files" "ABC123" [ + (FMFile "file1.txt", "text/plain;charset=UTF-8", "file", "xxx"), + (FMFile "file1.txt", "text/plain;charset=UTF-8", "file", "xxx"), + (FMFile "file1.txt", "text/plain;charset=UTF-8", "file", "xxx"), + (FMFile "file1.txt", "text/plain;charset=UTF-8", "file", "xxx"), + (FMFile "file1.txt", "text/plain;charset=UTF-8", "file", "xxx"), + (FMFile "file1.txt", "text/plain;charset=UTF-8", "file", "xxx"), + (FMFile "file1.txt", "text/plain;charset=UTF-8", "file", "xxx"), + (FMFile "file1.txt", "text/plain;charset=UTF-8", "file", "xxx"), + (FMFile "file1.txt", "text/plain;charset=UTF-8", "file", "xxx"), + (FMFile "file1.txt", "text/plain;charset=UTF-8", "file", "xxx"), + (FMFile "file1.txt", "text/plain;charset=UTF-8", "file", "xxx") + ] `shouldRespondWith` 413 + + + describe "filesOpts" $ do + let + postForm = postMultipartForm "/files" "ABC123" [ + (FMFile "file1.txt", "text/plain;charset=UTF-8", "first_file", "xxx"), + (FMFile "file2.txt", "text/plain;charset=UTF-8", "second_file", "yyy") + ] + processForm = do + filesOpts defaultParseRequestBodyOptions $ \_ fs -> do + text $ TL.pack $ show $ length fs + withApp (Scotty.post "/files" processForm + ) $ do + it "loads uploaded files in memory" $ do + postForm `shouldRespondWith` 200 { matchBody = "2"} + context "preserves the body of a POST request even after 'next' (#147)" $ do + withApp (do + Scotty.post "/files" next + Scotty.post "/files" processForm) $ do + it "loads uploaded files in memory" $ do + postForm `shouldRespondWith` 200 { matchBody = "2"} + describe "text" $ do let modernGreekText :: IsString a => a