scotty 0.21 → 0.22
raw patch · 17 files changed
+531/−163 lines, 17 filesdep +resourcetdep −transformers-compatdep ~bytestringdep ~networkdep ~text
Dependencies added: resourcet
Dependencies removed: transformers-compat
Dependency ranges changed: bytestring, network, text, time, wai-extra
Files
- README.md +1/−1
- Web/Scotty.hs +22/−5
- Web/Scotty/Action.hs +100/−17
- Web/Scotty/Body.hs +68/−43
- Web/Scotty/Internal/Types.hs +48/−23
- Web/Scotty/Route.hs +43/−17
- Web/Scotty/Trans.hs +13/−8
- Web/Scotty/Util.hs +1/−2
- bench/Main.hs +5/−1
- changelog.md +23/−0
- examples/basic.hs +1/−1
- examples/bodyecho.hs +1/−1
- examples/upload.hs +30/−15
- examples/urlshortener.hs +0/−1
- scotty.cabal +12/−8
- test/Test/Hspec/Wai/Extra.hs +65/−0
- test/Web/ScottySpec.hs +98/−20
README.md view
@@ -1,4 +1,4 @@-# Scotty [](https://hackage.haskell.org/package/scotty) [](https://github.com/scotty-web/scotty/actions/workflows/haskell-ci.yml)+# Scotty [](https://hackage.haskell.org/package/scotty) [](http://stackage.org/lts/package/scotty) [](http://stackage.org/nightly/package/scotty) [](https://github.com/scotty-web/scotty/actions/workflows/haskell-ci.yml) A Haskell web framework inspired by Ruby's Sinatra, using WAI and Warp.
Web/Scotty.hs view
@@ -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
Web/Scotty/Action.hs view
@@ -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: --
Web/Scotty/Body.hs view
@@ -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
Web/Scotty/Internal/Types.hs view
@@ -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
Web/Scotty/Route.hs view
@@ -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]
Web/Scotty/Trans.hs view
@@ -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 ()
Web/Scotty/Util.hs view
@@ -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-
bench/Main.hs view
@@ -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
changelog.md view
@@ -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]
examples/basic.hs view
@@ -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)
examples/bodyecho.hs view
@@ -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
examples/upload.hs view
@@ -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' ]
examples/urlshortener.hs view
@@ -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)
scotty.cabal view
@@ -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
+ test/Test/Hspec/Wai/Extra.hs view
@@ -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=<bd>@ 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
test/Web/ScottySpec.hs view
@@ -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