diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,4 +1,4 @@ -# Scotty [![Hackage](http://img.shields.io/hackage/v/scotty.svg)](https://hackage.haskell.org/package/scotty) [![CI](https://github.com/scotty-web/scotty/actions/workflows/haskell-ci.yml/badge.svg)](https://github.com/scotty-web/scotty/actions/workflows/haskell-ci.yml) +# Scotty [![Hackage](http://img.shields.io/hackage/v/scotty.svg)](https://hackage.haskell.org/package/scotty) [![Stackage Lts](http://stackage.org/package/scotty/badge/lts)](http://stackage.org/lts/package/scotty) [![Stackage Nightly](http://stackage.org/package/scotty/badge/nightly)](http://stackage.org/nightly/package/scotty) [![CI](https://github.com/scotty-web/scotty/actions/workflows/haskell-ci.yml/badge.svg)](https://github.com/scotty-web/scotty/actions/workflows/haskell-ci.yml) A Haskell web framework inspired by Ruby's Sinatra, using WAI and Warp. diff --git a/Web/Scotty.hs b/Web/Scotty.hs --- a/Web/Scotty.hs +++ b/Web/Scotty.hs @@ -25,12 +25,14 @@ , 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.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) @@ -118,7 +121,7 @@ -- | Turn a scotty application into a WAI 'Application', which can be -- run with any WAI handler. scottyApp :: ScottyM () -> IO Application -scottyApp = Trans.scottyAppT id +scottyApp = Trans.scottyAppT defaultOptions id -- | Global handler for user-defined exceptions. defaultHandler :: ErrorHandler IO -> ScottyM () @@ -141,8 +144,8 @@ nested = Trans.nested -- | Set global size limit for the request body. Requests with body size exceeding the limit will not be --- processed and an HTTP response 413 will be returned to the client. Size limit needs to be greater than 0, --- otherwise the application will terminate on start. +-- processed and an HTTP response 413 will be returned to the client. Size limit needs to be greater than 0, +-- otherwise the application will terminate on start. setMaxRequestBodySize :: Kilobytes -> ScottyM () setMaxRequestBodySize = Trans.setMaxRequestBodySize @@ -231,9 +234,19 @@ 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 = 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 = 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 --- a/Web/Scotty/Action.hs +++ b/Web/Scotty/Action.hs @@ -1,6 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE LambdaCase #-} @@ -12,6 +13,8 @@ , file , rawResponse , files + , filesOpts + , W.ParseRequestBodyOptions, W.defaultParseRequestBodyOptions , finish , header , headers @@ -66,6 +69,7 @@ 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,12 +78,16 @@ 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 import Data.Text.Encoding as STE import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Encoding as TLE +import Data.Time (UTCTime) +import Data.Time.Format (parseTimeM, defaultTimeLocale) +import Data.Typeable (typeOf) import Data.Word import Network.HTTP.Types @@ -88,30 +96,35 @@ 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 import Web.Scotty.Internal.Types import Web.Scotty.Util (mkResponse, addIfNotPresent, add, replace, lazyTextToStrictByteString, decodeUtf8Lenient) import UnliftIO.Exception (Handler(..), catch, catches, throwIO) +import System.IO (hPutStrLn, stderr) 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' -- -- 'Nothing' indicates route failed (due to Next) and pattern matching should try the next available route. -- 'Just' indicates a successful response. runAction :: MonadUnliftIO m => - Maybe (ErrorHandler m) -- ^ this handler (if present) is in charge of user-defined exceptions + Options + -> Maybe (ErrorHandler m) -- ^ this handler (if present) is in charge of user-defined exceptions -> ActionEnv -> ActionT m () -- ^ Route action to be evaluated -> m (Maybe Response) -runAction mh env action = do +runAction options mh env action = do ok <- flip runReaderT env $ runAM $ tryNext $ action `catches` concat [ [actionErrorHandler] , maybeToList mh - , [statusErrorHandler, scottyExceptionHandler, someExceptionHandler] + , [statusErrorHandler, scottyExceptionHandler, someExceptionHandler options] ] res <- getResponse env return $ bool Nothing (Just $ mkResponse res) ok @@ -167,12 +180,30 @@ 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 +someExceptionHandler :: MonadIO m => Options -> ErrorHandler m +someExceptionHandler Options{verbose} = + Handler $ \(E.SomeException e) -> do + when (verbose > 0) $ + liftIO $ + hPutStrLn stderr $ + "Unhandled exception of " <> show (typeOf e) <> ": " <> show e + status status500 + -- | Throw a "500 Server Error" 'StatusError', which can be caught with 'catch'. -- -- Uncaught exceptions turn into HTTP 500 responses. @@ -252,9 +283,30 @@ 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) header k = do @@ -270,6 +322,8 @@ | (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) @@ -288,6 +342,8 @@ -- 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 @@ -309,7 +365,7 @@ 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. "#-} @@ -340,8 +396,14 @@ -- * 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. -- @@ -376,9 +438,15 @@ -- 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. -- -- NB : Doesn't throw exceptions, so developers must 'raiseStatus' or 'throw' to signal something went wrong. @@ -413,7 +481,7 @@ -- -- NB : Doesn't throw exceptions. -- --- /Since: FIXME/ +-- /Since: 0.21/ paramWithMaybe :: (Monad m, Parsable b) => (ActionEnv -> [Param]) -> T.Text -- ^ parameter name @@ -438,8 +506,10 @@ 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 @@ -448,8 +518,9 @@ 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 @@ -524,6 +595,18 @@ instance Parsable Word32 where parseParam = readEither instance Parsable Word64 where parseParam = readEither instance Parsable Natural where parseParam = readEither + +-- | parse a UTCTime timestamp formatted as a ISO 8601 timestamp: +-- +-- @yyyy-mm-ddThh:mm:ssZ@ , where the seconds can have a decimal part with up to 12 digits and no trailing zeros. +instance Parsable UTCTime where + parseParam t = + let + fmt = "%FT%T%QZ" + in + case parseTimeM True defaultTimeLocale fmt (TL.unpack t) of + Just d -> Right d + _ -> Left $ "parseParam UTCTime: no parse of \"" <> t <> "\"" -- | Useful for creating 'Parsable' instances for things that already implement 'Read'. Ex: -- diff --git a/Web/Scotty/Body.hs b/Web/Scotty/Body.hs --- 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,21 +9,28 @@ , 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 newBodyInfo req = liftIO $ do @@ -36,26 +45,62 @@ 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) - 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 ([], []) +-- | 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 + + -- | 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 @@ | 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 --- a/Web/Scotty/Internal/Types.hs +++ b/Web/Scotty/Internal/Types.hs @@ -25,27 +25,31 @@ 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 @@ 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 @@ , routeOptions :: RouteOptions } -instance Default (ScottyState m) where - def = defaultScottyState +-- instance Default (ScottyState m) where +-- def = defaultScottyState defaultScottyState :: ScottyState m defaultScottyState = ScottyState [] [] Nothing defaultRouteOptions @@ -116,7 +120,8 @@ let ro' = ro { maxRequestBodySize = maxRequestBodySize } in s { routeOptions = ro' } -newtype ScottyT m a = ScottyT { runS :: State (ScottyState m) a } +newtype ScottyT m a = + ScottyT { runS :: ReaderT Options (State (ScottyState m)) a } deriving ( Functor, Applicative, Monad ) @@ -127,7 +132,7 @@ -- 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 +145,7 @@ _ -> 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 +155,46 @@ -- | 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 +242,10 @@ 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 +256,7 @@ 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 +297,11 @@ 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 --- a/Web/Scotty/Route.hs +++ b/Web/Scotty/Route.hs @@ -9,7 +9,9 @@ import Control.Concurrent.STM (newTVarIO) import Control.Monad.IO.Class (MonadIO(..)) import UnliftIO (MonadUnliftIO(..)) +import qualified Control.Monad.Reader as MR 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 +22,13 @@ 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 (Options, RoutePattern(..), RouteOptions, ActionEnv(..), ActionT, ScottyState(..), ScottyT(..), ErrorHandler, Middleware, BodyInfo, File, handler, addRoute, defaultScottyResponse) + import Web.Scotty.Util (decodeUtf8Lenient) import Web.Scotty.Body (cloneBodyInfo, getBodyAction, getBodyChunkAction, getFormParamsAndFilesAction) + {- $setup >>> :{ import Control.Monad.IO.Class (MonadIO(..)) @@ -78,7 +83,13 @@ -- | Add a route that matches regardless of the HTTP verb. matchAny :: (MonadUnliftIO m) => RoutePattern -> ActionT m () -> ScottyT m () -matchAny pat action = ScottyT $ MS.modify $ \s -> addRoute (route (routeOptions s) (handler s) Nothing pat action) s +matchAny pat action = + ScottyT $ do + serverOptions <- MR.ask + MS.modify $ \s -> + addRoute + (route serverOptions (routeOptions s) (handler s) Nothing pat action) + s -- | Specify an action to take if nothing else is found. Note: this _always_ matches, -- so should generally be the last route specified. @@ -101,12 +112,20 @@ "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 $ do + serverOptions <- MR.ask + MS.modify $ \s -> + addRoute + (route serverOptions (routeOptions s) (handler s) (Just method) pat action) + s + route :: (MonadUnliftIO m) => - RouteOptions + Options + -> RouteOptions -> Maybe (ErrorHandler m) -> Maybe StdMethod -> RoutePattern -> ActionT m () -> BodyInfo -> Middleware m -route opts h method pat action bodyInfo app req = +route serverOpts opts h method pat action bodyInfo app req = let tryNext = app req -- We match all methods in the case where 'method' is 'Nothing'. -- See https://github.com/scotty-web/scotty/issues/196 and 'matchAny' @@ -122,10 +141,11 @@ -- 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 - res <- runAction h env action + env <- mkEnv cbi req captures opts + res <- runAction serverOpts h env action + maybe tryNext return res Nothing -> tryNext else tryNext @@ -140,10 +160,10 @@ | otherwise = Nothing -- request string is longer than pattern go p [] prs | T.null (mconcat p) = Just prs -- in case pattern has trailing slashes | otherwise = Nothing -- request string is not long enough - go (p:ps) (r:rs) prs | p == r = go ps rs prs -- equal literals, keeping checking - | T.null p = Nothing -- p is null, but r is not, fail - | T.head p == ':' = go ps rs $ (T.tail p, r) : prs -- p is a capture, add to params - | otherwise = Nothing -- both literals, but unequal, fail + go (p:ps) (r:rs) prs = case T.uncons p of + Just (':', name) -> go ps rs $ (name, r) : prs -- p is a capture, add to params + _ | p == r -> go ps rs prs -- equal literals, keeping checking + | otherwise -> Nothing -- both literals, but unequal, fail compress ("":rest@("":_)) = compress rest compress (x:xs) = x : compress xs compress [] = [] @@ -153,14 +173,20 @@ 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 --- a/Web/Scotty/Trans.hs +++ b/Web/Scotty/Trans.hs @@ -30,12 +30,15 @@ , 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 @@ -64,6 +67,7 @@ import Control.Exception (assert) import Control.Monad (when) +import Control.Monad.Reader (runReaderT) import Control.Monad.State.Strict (execState, modify) import Control.Monad.IO.Class @@ -101,7 +105,7 @@ scottyOptsT opts runActionToIO s = do when (verbose opts > 0) $ liftIO $ putStrLn $ "Setting phasers to stun... (port " ++ show (getPort (settings opts)) ++ ") (ctrl-c to quit)" - liftIO . runSettings (settings opts) =<< scottyAppT runActionToIO s + liftIO . runSettings (settings opts) =<< scottyAppT opts runActionToIO s -- | Run a scotty application using the warp server, passing extra options, and -- listening on the provided socket. @@ -116,17 +120,18 @@ when (verbose opts > 0) $ do d <- liftIO $ socketDescription sock liftIO $ putStrLn $ "Setting phasers to stun... (" ++ d ++ ") (ctrl-c to quit)" - liftIO . runSettingsSocket (settings opts) sock =<< scottyAppT runActionToIO s + liftIO . runSettingsSocket (settings opts) sock =<< scottyAppT opts runActionToIO s -- | Turn a scotty application into a WAI 'Application', which can be -- run with any WAI handler. -- NB: scottyApp === scottyAppT id scottyAppT :: (Monad m, Monad n) - => (m W.Response -> IO W.Response) -- ^ Run monad 'm' into 'IO', called at each action. + => Options + -> (m W.Response -> IO W.Response) -- ^ Run monad 'm' into 'IO', called at each action. -> ScottyT m () -> n W.Application -scottyAppT runActionToIO defs = do - let s = execState (runS defs) defaultScottyState +scottyAppT options runActionToIO defs = do + let s = execState (runReaderT (runS defs) options) defaultScottyState let rapp req callback = do bodyInfo <- newBodyInfo req resp <- runActionToIO (applyAll notFoundApp ([midd bodyInfo | midd <- routes s]) req) @@ -134,7 +139,7 @@ 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!" @@ -160,7 +165,7 @@ middleware = ScottyT . modify . addMiddleware -- | Set global size limit for the request body. Requests with body size exceeding the limit will not be --- processed and an HTTP response 413 will be returned to the client. Size limit needs to be greater than 0, +-- processed and an HTTP response 413 will be returned to the client. Size limit needs to be greater than 0, -- otherwise the application will terminate on start. setMaxRequestBodySize :: Kilobytes -- ^ Request size limit -> ScottyT m () diff --git a/Web/Scotty/Util.hs b/Web/Scotty/Util.hs --- a/Web/Scotty/Util.hs +++ b/Web/Scotty/Util.hs @@ -71,7 +71,7 @@ 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 @@ -96,6 +96,5 @@ if B.null b then throwIO RequestTooLarge else readUntilEmpty - diff --git a/bench/Main.hs b/bench/Main.hs --- a/bench/Main.hs +++ b/bench/Main.hs @@ -11,6 +11,7 @@ import Lucid.Html5 import Web.Scotty import Web.Scotty.Internal.Types +import qualified Control.Monad.Reader as R import qualified Control.Monad.State.Lazy as SL import qualified Control.Monad.State.Strict as SS import qualified Data.ByteString.Lazy as BL @@ -23,11 +24,14 @@ setColumns [Case,Allocated,GCs,Live,Check,Max,MaxOS] setFormat Markdown io "ScottyM Strict" BL.putStr - (SS.evalState (runS $ renderBST htmlScotty) defaultScottyState) + (SS.evalState + (R.runReaderT (runS $ renderBST htmlScotty) defaultOptions) + 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 --- a/changelog.md +++ b/changelog.md @@ -1,6 +1,25 @@ ## next [????.??.??] +## 0.22 [2024.03.09] + +### 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 customize upload limits, a mechanism to back uploads with temporary files based on resourcet, as well as a continuation-based syntax to process such temporary files. + +### Fixes +* `files` does not accept unbounded uploads anymore (see #183, #203), but like `filesOpts` it is backed by temporary files which are read back in memory and removed right away. The limits for `files` are prescribed by `defaultParseBodyOptions` in wai-extra (#369). +* 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) +* Remove dependency upper bounds on `text` and `bytestring` (#371) +* When in 'verbose' mode any unhandled exceptions are printed to stderr as well (#374) + +### 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. E.g. `files` has now a MonadUnliftIO constraint on its base monad. (#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 * add `getResponseHeaders`, `getResponseStatus`, `getResponseContent` (#214) @@ -16,10 +35,14 @@ * 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] diff --git a/examples/basic.hs b/examples/basic.hs --- a/examples/basic.hs +++ b/examples/basic.hs @@ -9,7 +9,7 @@ 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 --- a/examples/bodyecho.hs +++ b/examples/bodyecho.hs @@ -3,7 +3,7 @@ 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 --- 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.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 --- a/examples/urlshortener.hs +++ b/examples/urlshortener.hs @@ -8,7 +8,6 @@ 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 --- a/scotty.cabal +++ b/scotty.cabal @@ -1,5 +1,5 @@ Name: scotty -Version: 0.21 +Version: 0.22 Synopsis: Haskell web framework inspired by Ruby's Sinatra, using WAI and Warp Homepage: https://github.com/scotty-web/scotty Bug-reports: https://github.com/scotty-web/scotty/issues @@ -46,8 +46,8 @@ , GHC == 9.0.2 , GHC == 9.2.8 , GHC == 9.4.6 - , GHC == 9.6.2 - , GHC == 9.6.3 + , GHC == 9.6.4 + , GHC == 9.8.2 Extra-source-files: README.md changelog.md @@ -73,7 +73,7 @@ build-depends: aeson >= 0.6.2.1 && < 2.3, base >= 4.14 && < 5, blaze-builder >= 0.3.3.0 && < 0.5, - bytestring >= 0.10.0.2 && < 0.13, + bytestring >= 0.10.0.2 , case-insensitive >= 1.0.0.1 && < 1.3, cookie >= 0.4, data-default-class >= 0.1, @@ -83,15 +83,15 @@ 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.1, + text >= 0.11.3.1 , time >= 1.8, transformers >= 0.3.0.0 && < 0.7, transformers-base >= 0.4.1 && < 0.5, - 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 +105,7 @@ 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 @@ -119,7 +120,9 @@ network, scotty, text, - wai + time, + wai, + wai-extra build-tool-depends: hspec-discover:hspec-discover == 2.* GHC-options: -Wall -threaded -fno-warn-orphans @@ -148,6 +151,7 @@ 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 --- /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 --- 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 @@ -10,8 +11,13 @@ import Data.String import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Encoding as TLE +import Data.Time (UTCTime(..)) +import Data.Time.Calendar (fromGregorian) +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 @@ -57,9 +63,11 @@ makeRequest "//scotty" `shouldRespondWith` 200 withApp (route "/:paramName" $ captureParam "paramName" >>= text) $ do + it ("captures route parameters for " ++ method ++ " requests when parameter matches its name") $ 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 @@ -109,7 +117,7 @@ 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") @@ -127,17 +135,29 @@ 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 @@ -150,7 +170,6 @@ it "returns query parameter with given name" $ do get "/search" `shouldRespondWith` "haskell" - describe "ActionM" $ do context "MonadBaseControl instance" $ do withApp (Scotty.get "/" $ (undefined `EL.catch` ((\_ -> html "") :: E.SomeException -> ActionM ()))) $ do @@ -158,7 +177,7 @@ 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) $ @@ -188,22 +207,30 @@ it "Responds with a 302 Redirect" $ do get "/a" `shouldRespondWith` 302 { matchHeaders = ["Location" <:> "/b"] } + describe "Parsable" $ do + it "parses a UTCTime string" $ do + parseParam "2023-12-18T00:38:00Z" `shouldBe` Right (UTCTime (fromGregorian 2023 12 18) (secondsToDiffTime (60 * 38)) ) + describe "captureParam" $ do withApp ( do - Scotty.matchAny "/search/:q" $ do + Scotty.get "/search/:q" $ do _ :: Int <- captureParam "q" text "int" - Scotty.matchAny "/search/:q" $ do + Scotty.get "/search/:q" $ do _ :: String <- captureParam "q" text "string" + Scotty.get "/search-time/:q" $ do + t :: UTCTime <- captureParam "q" + text $ TL.pack (show t) ) $ do it "responds with 200 OK iff at least one route matches at the right type" $ do get "/search/42" `shouldRespondWith` 200 { matchBody = "int" } get "/search/potato" `shouldRespondWith` 200 { matchBody = "string" } + get "/search-time/2023-12-18T00:38:00Z" `shouldRespondWith` 200 {matchBody = "2023-12-18 00:38:00 UTC"} withApp ( do - Scotty.matchAny "/search/:q" $ do + Scotty.get "/search/:q" $ do v <- captureParam "q" json (v :: Int) ) $ do @@ -225,7 +252,7 @@ get "/search/xxx" `shouldRespondWith` 200 { matchBody = "z"} describe "queryParam" $ do - withApp (Scotty.matchAny "/search" $ queryParam "query" >>= text) $ do + withApp (Scotty.get "/search" $ queryParam "query" >>= text) $ do it "returns query parameter with given name" $ do get "/search?query=haskell" `shouldRespondWith` "haskell" withApp (Scotty.matchAny "/search" (do @@ -293,6 +320,57 @@ get "/a/42" `shouldRespondWith` 200 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