diff --git a/README.md b/README.md index 46f3fb51..ebe05357 100644 --- a/README.md +++ b/README.md @@ -6,8 +6,6 @@ A Haskell web framework inspired by Ruby's Sinatra, using WAI and Warp. {-# LANGUAGE OverloadedStrings #-} import Web.Scotty -import Data.Monoid (mconcat) - main = scotty 3000 $ get "/:word" $ do beam <- captureParam "word" @@ -41,7 +39,7 @@ Feel free to ask questions or report bugs on the [Github issue tracker](https:// Github issues are now (September 2023) labeled, so newcomers to the Haskell language can start with `easy fix` ones and gradually progress to `new feature`s, `bug`s and `R&D` :) -## Package version numbers +## Package versions Scotty adheres to the [Package Versioning Policy](https://pvp.haskell.org/). @@ -71,4 +69,4 @@ Scotty adheres to the [Package Versioning Policy](https://pvp.haskell.org/). # Copyright -(c) 2012-Present Andrew Farmer and Scotty contributors +(c) 2012-Present, Andrew Farmer and Scotty contributors diff --git a/Web/Scotty.hs b/Web/Scotty.hs index 0b000892..09da4a26 100644 --- a/Web/Scotty.hs +++ b/Web/Scotty.hs @@ -7,7 +7,7 @@ -- the comments on each of these functions for more information. module Web.Scotty ( -- * scotty-to-WAI - scotty, scottyApp, scottyOpts, scottySocket, Options(..) + scotty, scottyApp, scottyOpts, scottySocket, Options(..), defaultOptions -- * Defining Middleware and Routes -- -- | 'Middleware' and routes are run in the order in which they @@ -30,16 +30,18 @@ module Web.Scotty -- definition, as they completely replace the current 'Response' body. , text, html, file, json, stream, raw -- ** Exceptions - , raise, raiseStatus, rescue, next, finish, defaultHandler, liftAndCatchIO + , raise, raiseStatus, throw, rescue, next, finish, defaultHandler, liftAndCatchIO + , StatusError(..) -- * Parsing Parameters , Param, Trans.Parsable(..), Trans.readEither -- * Types - , ScottyM, ActionM, RoutePattern, File, Kilobytes + , ScottyM, ActionM, RoutePattern, File, Kilobytes, Handler(..) + , ScottyState, defaultScottyState ) where --- With the exception of this, everything else better just import types. import qualified Web.Scotty.Trans as Trans +import qualified Control.Exception as E import Data.Aeson (FromJSON, ToJSON) import qualified Data.ByteString as BS import Data.ByteString.Lazy.Char8 (ByteString) @@ -50,10 +52,11 @@ import Network.Socket (Socket) import Network.Wai (Application, Middleware, Request, StreamingBody) import Network.Wai.Handler.Warp (Port) -import Web.Scotty.Internal.Types (ScottyT, ActionT, Param, RoutePattern, Options, File, Kilobytes) +import Web.Scotty.Internal.Types (ScottyT, ActionT, ErrorHandler, Param, RoutePattern, Options, defaultOptions, File, Kilobytes, ScottyState, defaultScottyState, StatusError(..)) +import Web.Scotty.Exceptions (Handler(..)) -type ScottyM = ScottyT Text IO -type ActionM = ActionT Text IO +type ScottyM = ScottyT IO +type ActionM = ActionT IO -- | Run a scotty application using the warp server. scotty :: Port -> ScottyM () -> IO () @@ -75,16 +78,8 @@ scottySocket opts sock = Trans.scottySocketT opts sock id scottyApp :: ScottyM () -> IO Application scottyApp = Trans.scottyAppT id --- | Global handler for uncaught exceptions. --- --- Uncaught exceptions normally become 500 responses. --- You can use this to selectively override that behavior. --- --- Note: IO exceptions are lifted into Scotty exceptions by default. --- This has security implications, so you probably want to provide your --- own defaultHandler in production which does not send out the error --- strings as 500 responses. -defaultHandler :: (Text -> ActionM ()) -> ScottyM () +-- | Global handler for user-defined exceptions. +defaultHandler :: ErrorHandler IO -> ScottyM () defaultHandler = Trans.defaultHandler -- | Use given middleware. Middleware is nested such that the first declared @@ -100,8 +95,6 @@ middleware = Trans.middleware -- this could require stripping the current prefix, or adding the prefix to your -- application's handlers if it depends on them. One potential use-case for this -- is hosting a web-socket handler under a specific route. --- nested :: Application -> ActionM () --- nested :: (Monad m, MonadIO m) => Application -> ActionT Text m () nested :: Application -> ActionM () nested = Trans.nested @@ -111,28 +104,42 @@ nested = Trans.nested setMaxRequestBodySize :: Kilobytes -> ScottyM () setMaxRequestBodySize = Trans.setMaxRequestBodySize --- | Throw an exception, which can be caught with 'rescue'. Uncaught exceptions --- turn into HTTP 500 responses. +-- | Throw a "500 Server Error" 'StatusError', which can be caught with 'rescue'. +-- +-- Uncaught exceptions turn into HTTP 500 responses. raise :: Text -> ActionM a raise = Trans.raise --- | Throw an exception, which can be caught with 'rescue'. Uncaught exceptions turn into HTTP responses corresponding to the given status. +-- | Throw a 'StatusError' exception that has an associated HTTP error code and can be caught with 'rescue'. +-- +-- Uncaught exceptions turn into HTTP responses corresponding to the given status. raiseStatus :: Status -> Text -> ActionM a raiseStatus = Trans.raiseStatus +-- | Throw an exception which can be caught within the scope of the current Action with 'rescue' or 'catch'. +-- +-- If the exception is not caught locally, another option is to implement a global 'Handler' (with 'defaultHandler') that defines its interpretation and a translation to HTTP error codes. +-- +-- Uncaught exceptions turn into HTTP 500 responses. +throw :: (E.Exception e) => e -> ActionM a +throw = Trans.throw + -- | Abort execution of this action and continue pattern matching routes. -- Like an exception, any code after 'next' is not executed. -- +-- NB : Internally, this is implemented with an exception that can only be +-- caught by the library, but not by the user. +-- -- As an example, these two routes overlap. The only way the second one will -- ever run is if the first one calls 'next'. -- -- > get "/foo/:bar" $ do --- > w :: Text <- param "bar" +-- > w :: Text <- captureParam "bar" -- > unless (w == "special") next -- > text "You made a request to /foo/special" -- > -- > get "/foo/:baz" $ do --- > w <- param "baz" +-- > w <- captureParam "baz" -- > text $ "You made a request to: " <> w next :: ActionM () next = Trans.next @@ -144,7 +151,7 @@ next = Trans.next -- content the text message. -- -- > get "/foo/:bar" $ do --- > w :: Text <- param "bar" +-- > w :: Text <- captureParam "bar" -- > unless (w == "special") finish -- > text "You made a request to /foo/special" -- @@ -152,10 +159,10 @@ next = Trans.next finish :: ActionM a finish = Trans.finish --- | Catch an exception thrown by 'raise'. +-- | Catch an exception e.g. a 'StatusError' or a user-defined exception. -- --- > raise "just kidding" `rescue` (\msg -> text msg) -rescue :: ActionM a -> (Text -> ActionM a) -> ActionM a +-- > raise JustKidding `rescue` (\msg -> text msg) +rescue :: E.Exception e => ActionM a -> (e -> ActionM a) -> ActionM a rescue = Trans.rescue -- | Like 'liftIO', but catch any IO exceptions and turn them into Scotty exceptions. @@ -207,7 +214,7 @@ jsonData = Trans.jsonData -- -- * Raises an exception which can be caught by 'rescue' if parameter is not found. -- --- * If parameter is found, but 'read' fails to parse to the correct type, 'next' is called. +-- * If parameter is found, but 'parseParam' fails to parse to the correct type, 'next' is called. -- This means captures are somewhat typed, in that a route won't match if a correctly typed -- capture cannot be parsed. param :: Trans.Parsable a => Text -> ActionM a diff --git a/Web/Scotty/Action.hs b/Web/Scotty/Action.hs index b70156a0..726240f5 100644 --- a/Web/Scotty/Action.hs +++ b/Web/Scotty/Action.hs @@ -1,7 +1,11 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE LambdaCase #-} +{-# language ScopedTypeVariables #-} module Web.Scotty.Action ( addHeader , body @@ -27,6 +31,7 @@ module Web.Scotty.Action , queryParams , raise , raiseStatus + , throw , raw , nested , readEither @@ -46,19 +51,18 @@ module Web.Scotty.Action import Blaze.ByteString.Builder (fromLazyByteString) import qualified Control.Exception as E -import Control.Monad (liftM, when) -import Control.Monad.Error.Class (throwError, catchError) +import Control.Monad (when) import Control.Monad.IO.Class (MonadIO(..)) +import UnliftIO (MonadUnliftIO(..)) import Control.Monad.Reader (MonadReader(..), ReaderT(..)) -import qualified Control.Monad.State.Strict as MS -import Control.Monad.Trans.Except + import Control.Concurrent.MVar import qualified Data.Aeson as A +import Data.Bool (bool) import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as BL import qualified Data.CaseInsensitive as CI -import Data.Default.Class (def) import Data.Int import qualified Data.Text as ST import qualified Data.Text.Encoding as STE @@ -71,83 +75,118 @@ import Network.HTTP.Types #if !MIN_VERSION_http_types(0,11,0) import Network.HTTP.Types.Status #endif -import Network.Wai +import Network.Wai (Request, Response, StreamingBody, Application, requestHeaders) import Numeric.Natural import Prelude () -import Prelude.Compat +import "base-compat-batteries" Prelude.Compat import Web.Scotty.Internal.Types -import Web.Scotty.Util +import Web.Scotty.Util (mkResponse, addIfNotPresent, add, replace, lazyTextToStrictByteString, strictByteStringToLazyText) +import Web.Scotty.Exceptions (Handler(..), catch, catchesOptionally, tryAny) import Network.Wai.Internal (ResponseReceived(..)) --- Nothing indicates route failed (due to Next) and pattern matching should continue. --- Just indicates a successful response. -runAction :: (ScottyError e, Monad m) => ErrorHandler e m -> ActionEnv -> ActionT e m () -> m (Maybe Response) -runAction h env action = do - (e,r) <- flip MS.runStateT def - $ flip runReaderT env - $ runExceptT - $ runAM - $ action `catchError` (defH h) - return $ either (const Nothing) (const $ Just $ mkResponse r) e - --- | Default error handler for all actions. -defH :: (ScottyError e, Monad m) => ErrorHandler e m -> ActionError e -> ActionT e m () -defH _ (Redirect url) = do - status status302 - setHeader "Location" url -defH Nothing (ActionError s e) = do +-- | 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 + -> ActionEnv + -> ActionT m () -- ^ Route action to be evaluated + -> m (Maybe Response) +runAction mh env action = do + let + handlers = [ + statusErrorHandler, -- StatusError + actionErrorHandler, -- ActionError i.e. Next, Finish, Redirect + someExceptionHandler -- all remaining exceptions + ] + ok <- flip runReaderT env $ runAM $ tryNext (catchesOptionally action mh handlers ) + res <- getResponse env + return $ bool Nothing (Just $ mkResponse res) ok + +-- | Catches 'StatusError' and produces an appropriate HTTP response. +statusErrorHandler :: MonadIO m => ErrorHandler m +statusErrorHandler = Handler $ \case + StatusError s e -> do status s let code = T.pack $ show $ statusCode s let msg = T.fromStrict $ STE.decodeUtf8 $ statusMessage s - html $ mconcat ["

", code, " ", msg, "

", showError e] -defH h@(Just f) (ActionError _ e) = f e `catchError` (defH h) -- so handlers can throw exceptions themselves -defH _ Next = next -defH _ Finish = return () + html $ mconcat ["

", code, " ", msg, "

", e] --- | Throw an exception, which can be caught with 'rescue'. Uncaught exceptions --- turn into HTTP 500 responses. -raise :: (ScottyError e, Monad m) => e -> ActionT e m a -raise = raiseStatus status500 +-- | Exception handler in charge of 'ActionError'. Rethrowing 'Next' here is caught by 'tryNext'. +-- All other cases of 'ActionError' are converted to HTTP responses. +actionErrorHandler :: MonadIO m => ErrorHandler m +actionErrorHandler = Handler $ \case + AERedirect url -> do + status status302 + setHeader "Location" url + AENext -> next + AEFinish -> return () --- | Throw an exception, which can be caught with 'rescue'. Uncaught exceptions turn into HTTP responses corresponding to the given status. -raiseStatus :: (ScottyError e, Monad m) => Status -> e -> ActionT e m a -raiseStatus s = throwError . ActionError s +-- | Uncaught exceptions turn into HTTP 500 Server Error codes +someExceptionHandler :: MonadIO m => ErrorHandler m +someExceptionHandler = Handler $ \case + (_ :: E.SomeException) -> status status500 +-- | Throw a "500 Server Error" 'StatusError', which can be caught with 'rescue'. +-- +-- Uncaught exceptions turn into HTTP 500 responses. +raise :: (MonadIO m) => + T.Text -- ^ Error text + -> ActionT m a +raise = raiseStatus status500 + +-- | Throw a 'StatusError' exception that has an associated HTTP error code and can be caught with 'rescue'. +-- +-- Uncaught exceptions turn into HTTP responses corresponding to the given status. +raiseStatus :: Monad m => Status -> T.Text -> ActionT m a +raiseStatus s = E.throw . StatusError s + +-- | Throw an exception which can be caught within the scope of the current Action with 'rescue' or 'catch'. +-- +-- If the exception is not caught locally, another option is to implement a global 'Handler' (with 'defaultHandler') that defines its interpretation and a translation to HTTP error codes. +-- +-- Uncaught exceptions turn into HTTP 500 responses. +throw :: (MonadIO m, E.Exception e) => e -> ActionT m a +throw = E.throw -- | Abort execution of this action and continue pattern matching routes. -- Like an exception, any code after 'next' is not executed. -- +-- NB : Internally, this is implemented with an exception that can only be +-- caught by the library, but not by the user. +-- -- As an example, these two routes overlap. The only way the second one will -- ever run is if the first one calls 'next'. -- -- > get "/foo/:bar" $ do --- > w :: Text <- param "bar" +-- > w :: Text <- captureParam "bar" -- > unless (w == "special") next -- > text "You made a request to /foo/special" -- > -- > get "/foo/:baz" $ do --- > w <- param "baz" +-- > w <- captureParam "baz" -- > text $ "You made a request to: " <> w -next :: (ScottyError e, Monad m) => ActionT e m a -next = throwError Next +next :: Monad m => ActionT m a +next = E.throw AENext --- | Catch an exception thrown by 'raise'. +-- | Catch an exception e.g. a 'StatusError' or a user-defined exception. -- --- > raise "just kidding" `rescue` (\msg -> text msg) -rescue :: (ScottyError e, Monad m) => ActionT e m a -> (e -> ActionT e m a) -> ActionT e m a -rescue action h = catchError action $ \e -> case e of - ActionError _ err -> h err -- handle errors - other -> throwError other -- rethrow internal error types - --- | Like 'liftIO', but catch any IO exceptions and turn them into 'ScottyError's. -liftAndCatchIO :: (ScottyError e, MonadIO m) => IO a -> ActionT e m a -liftAndCatchIO io = ActionT $ do - r <- liftIO $ liftM Right io `E.catch` (\ e -> return $ Left $ stringError $ show (e :: E.SomeException)) - either throwError return r +-- > raise JustKidding `rescue` (\msg -> text msg) +rescue :: (MonadUnliftIO m, E.Exception e) => ActionT m a -> (e -> ActionT m a) -> ActionT m a +rescue = catch + +-- | Catch any synchronous IO exceptions +liftAndCatchIO :: MonadIO m => IO a -> ActionT m a +liftAndCatchIO io = liftIO $ do + r <- tryAny io + either E.throwIO pure r + -- | Redirect to given URL. Like throwing an uncatchable exception. Any code after the call to redirect -- will not be run. @@ -157,47 +196,47 @@ liftAndCatchIO io = ActionT $ do -- OR -- -- > redirect "/foo/bar" -redirect :: (ScottyError e, Monad m) => T.Text -> ActionT e m a -redirect = throwError . Redirect +redirect :: (Monad m) => T.Text -> ActionT m a +redirect = E.throw . AERedirect -- | Finish the execution of the current action. Like throwing an uncatchable -- exception. Any code after the call to finish will not be run. -- -- /Since: 0.10.3/ -finish :: (ScottyError e, Monad m) => ActionT e m a -finish = throwError Finish +finish :: (Monad m) => ActionT m a +finish = E.throw AEFinish -- | Get the 'Request' object. -request :: Monad m => ActionT e m Request -request = ActionT $ liftM getReq ask +request :: Monad m => ActionT m Request +request = ActionT $ envReq <$> ask -- | Get list of uploaded files. -files :: Monad m => ActionT e m [File] -files = ActionT $ liftM getFiles ask +files :: Monad m => ActionT m [File] +files = ActionT $ envFiles <$> ask -- | Get a request header. Header name is case-insensitive. -header :: (ScottyError e, Monad m) => T.Text -> ActionT e m (Maybe T.Text) +header :: (Monad m) => T.Text -> ActionT m (Maybe T.Text) header k = do - hs <- liftM requestHeaders request + hs <- requestHeaders <$> request return $ fmap strictByteStringToLazyText $ lookup (CI.mk (lazyTextToStrictByteString k)) hs -- | Get all the request headers. Header names are case-insensitive. -headers :: (ScottyError e, Monad m) => ActionT e m [(T.Text, T.Text)] +headers :: (Monad m) => ActionT m [(T.Text, T.Text)] headers = do - hs <- liftM requestHeaders request + hs <- requestHeaders <$> request return [ ( strictByteStringToLazyText (CI.original k) , strictByteStringToLazyText v) | (k,v) <- hs ] -- | Get the request body. -body :: (ScottyError e, MonadIO m) => ActionT e m BL.ByteString -body = ActionT ask >>= (liftIO . getBody) +body :: (MonadIO m) => ActionT m BL.ByteString +body = ActionT ask >>= (liftIO . envBody) -- | Get an IO action that reads body chunks -- -- * This is incompatible with 'body' since 'body' consumes all chunks. -bodyReader :: Monad m => ActionT e m (IO B.ByteString) -bodyReader = ActionT $ getBodyChunk `liftM` ask +bodyReader :: Monad m => ActionT m (IO B.ByteString) +bodyReader = ActionT $ envBodyChunk <$> ask -- | Parse the request body as a JSON object and return it. -- @@ -208,24 +247,24 @@ bodyReader = ActionT $ getBodyChunk `liftM` ask -- 422 Unprocessable Entity. -- -- These status codes are as per https://www.restapitutorial.com/httpstatuscodes.html. -jsonData :: (A.FromJSON a, ScottyError e, MonadIO m) => ActionT e m a +jsonData :: (A.FromJSON a, MonadIO m) => ActionT m a jsonData = do b <- body when (b == "") $ do let htmlError = "jsonData - No data was provided." - raiseStatus status400 $ stringError htmlError + raiseStatus status400 $ T.pack htmlError case A.eitherDecode b of Left err -> do let htmlError = "jsonData - malformed." `mappend` " Data was: " `mappend` BL.unpack b `mappend` " Error was: " `mappend` err - raiseStatus status400 $ stringError htmlError + raiseStatus status400 $ T.pack htmlError Right value -> case A.fromJSON value of A.Error err -> do let htmlError = "jsonData - failed parse." `mappend` " Data was: " `mappend` BL.unpack b `mappend` "." `mappend` " Error was: " `mappend` err - raiseStatus status422 $ stringError htmlError + raiseStatus status422 $ T.pack htmlError A.Success a -> do return a @@ -236,11 +275,11 @@ jsonData = do -- * If parameter is found, but 'parseParam' fails to parse to the correct type, 'next' is called. -- This means captures are somewhat typed, in that a route won't match if a correctly typed -- capture cannot be parsed. -param :: (Parsable a, ScottyError e, Monad m) => T.Text -> ActionT e m a +param :: (Parsable a, MonadIO m) => T.Text -> ActionT m a param k = do - val <- ActionT $ liftM (lookup k . getParams) ask + val <- ActionT $ (lookup k . getParams) <$> ask case val of - Nothing -> raise $ stringError $ "Param: " ++ T.unpack k ++ " not found!" + Nothing -> raiseStatus status500 $ "Param: " <> k <> " not found!" -- FIXME Just v -> either (const next) return $ parseParam v {-# DEPRECATED param "(#204) Not a good idea to treat all parameters identically. Use captureParam, formParam and queryParam instead. "#-} @@ -249,24 +288,24 @@ param k = do -- * Raises an exception which can be caught by 'rescue' if parameter is not found. If the exception is not caught, scotty will return a HTTP error code 500 ("Internal Server Error") to the client. -- -- * If the parameter is found, but 'parseParam' fails to parse to the correct type, 'next' is called. -captureParam :: (Parsable a, ScottyError e, Monad m) => T.Text -> ActionT e m a -captureParam = paramWith CaptureParam getCaptureParams status500 +captureParam :: (Parsable a, Monad m) => T.Text -> ActionT m a +captureParam = paramWith CaptureParam envCaptureParams status500 -- | Get a form parameter. -- -- * Raises an exception which can be caught by 'rescue' if parameter is not found. If the exception is not caught, scotty will return a HTTP error code 400 ("Bad Request") to the client. -- -- * This function raises a code 400 also if the parameter is found, but 'parseParam' fails to parse to the correct type. -formParam :: (Parsable a, ScottyError e, Monad m) => T.Text -> ActionT e m a -formParam = paramWith FormParam getFormParams status400 +formParam :: (Parsable a, Monad m) => T.Text -> ActionT m a +formParam = paramWith FormParam envFormParams status400 -- | Get a query parameter. -- -- * Raises an exception which can be caught by 'rescue' if parameter is not found. If the exception is not caught, scotty will return a HTTP error code 400 ("Bad Request") to the client. -- -- * This function raises a code 400 also if the parameter is found, but 'parseParam' fails to parse to the correct type. -queryParam :: (Parsable a, ScottyError e, Monad m) => T.Text -> ActionT e m a -queryParam = paramWith QueryParam getQueryParams status400 +queryParam :: (Parsable a, Monad m) => T.Text -> ActionT m a +queryParam = paramWith QueryParam envQueryParams status400 data ParamType = CaptureParam | FormParam @@ -277,43 +316,43 @@ instance Show ParamType where FormParam -> "form" QueryParam -> "query" -paramWith :: (ScottyError e, Monad m, Parsable b) => +paramWith :: (Monad m, Parsable b) => ParamType -> (ActionEnv -> [Param]) -> Status -- ^ HTTP status to return if parameter is not found -> T.Text -- ^ parameter name - -> ActionT e m b + -> ActionT m b paramWith ty f err k = do - val <- ActionT $ liftM (lookup k . f) ask + val <- ActionT $ (lookup k . f) <$> ask case val of - Nothing -> raiseStatus err $ stringError (unwords [show ty, "parameter:", T.unpack k, "not found!"]) + Nothing -> raiseStatus err (T.unwords [T.pack (show ty), "parameter:", k, "not found!"]) Just v -> let handleParseError = \case CaptureParam -> next - _ -> raiseStatus err $ stringError (unwords ["Cannot parse", T.unpack v, "as a", show ty, "parameter"]) + _ -> raiseStatus err (T.unwords ["Cannot parse", v, "as a", T.pack (show ty), "parameter"]) in either (const $ handleParseError ty) return $ parseParam v -- | Get all parameters from capture, form and query (in that order). -params :: Monad m => ActionT e m [Param] +params :: Monad m => ActionT m [Param] params = paramsWith getParams {-# DEPRECATED params "(#204) Not a good idea to treat all parameters identically. Use captureParams, formParams and queryParams instead. "#-} -- | Get capture parameters -captureParams :: Monad m => ActionT e m [Param] -captureParams = paramsWith getCaptureParams +captureParams :: Monad m => ActionT m [Param] +captureParams = paramsWith envCaptureParams -- | Get form parameters -formParams :: Monad m => ActionT e m [Param] -formParams = paramsWith getFormParams +formParams :: Monad m => ActionT m [Param] +formParams = paramsWith envFormParams -- | Get query parameters -queryParams :: Monad m => ActionT e m [Param] -queryParams = paramsWith getQueryParams +queryParams :: Monad m => ActionT m [Param] +queryParams = paramsWith envQueryParams -paramsWith :: Monad m => (ActionEnv -> a) -> ActionT e m a +paramsWith :: Monad m => (ActionEnv -> a) -> ActionT m a paramsWith f = ActionT (f <$> ask) {-# DEPRECATED getParams "(#204) Not a good idea to treat all parameters identically" #-} getParams :: ActionEnv -> [Param] -getParams e = getCaptureParams e <> getFormParams e <> getQueryParams e +getParams e = envCaptureParams e <> envFormParams e <> envQueryParams e -- | Minimum implemention: 'parseParam' class Parsable a where @@ -378,39 +417,36 @@ readEither t = case [ x | (x,"") <- reads (T.unpack t) ] of [] -> Left "readEither: no parse" _ -> Left "readEither: ambiguous parse" --- | Set the HTTP response status. Default is 200. -status :: Monad m => Status -> ActionT e m () -status = ActionT . MS.modify . setStatus +-- | Set the HTTP response status. +status :: MonadIO m => Status -> ActionT m () +status = modifyResponse . setStatus -- Not exported, but useful in the functions below. -changeHeader :: Monad m +changeHeader :: MonadIO m => (CI.CI B.ByteString -> B.ByteString -> [(HeaderName, B.ByteString)] -> [(HeaderName, B.ByteString)]) - -> T.Text -> T.Text -> ActionT e m () -changeHeader f k = ActionT - . MS.modify - . setHeaderWith - . f (CI.mk $ lazyTextToStrictByteString k) - . lazyTextToStrictByteString + -> T.Text -> T.Text -> ActionT m () +changeHeader f k = + modifyResponse . setHeaderWith . f (CI.mk $ lazyTextToStrictByteString k) . lazyTextToStrictByteString -- | Add to the response headers. Header names are case-insensitive. -addHeader :: Monad m => T.Text -> T.Text -> ActionT e m () +addHeader :: MonadIO m => T.Text -> T.Text -> ActionT m () addHeader = changeHeader add -- | Set one of the response headers. Will override any previously set value for that header. -- Header names are case-insensitive. -setHeader :: Monad m => T.Text -> T.Text -> ActionT e m () +setHeader :: MonadIO m => T.Text -> T.Text -> ActionT m () setHeader = changeHeader replace -- | Set the body of the response to the given 'T.Text' value. Also sets \"Content-Type\" -- header to \"text/plain; charset=utf-8\" if it has not already been set. -text :: (ScottyError e, Monad m) => T.Text -> ActionT e m () +text :: (MonadIO m) => T.Text -> ActionT m () text t = do changeHeader addIfNotPresent "Content-Type" "text/plain; charset=utf-8" raw $ encodeUtf8 t -- | Set the body of the response to the given 'T.Text' value. Also sets \"Content-Type\" -- header to \"text/html; charset=utf-8\" if it has not already been set. -html :: (ScottyError e, Monad m) => T.Text -> ActionT e m () +html :: (MonadIO m) => T.Text -> ActionT m () html t = do changeHeader addIfNotPresent "Content-Type" "text/html; charset=utf-8" raw $ encodeUtf8 t @@ -418,15 +454,15 @@ html t = do -- | Send a file as the response. Doesn't set the \"Content-Type\" header, so you probably -- want to do that on your own with 'setHeader'. Setting a status code will have no effect -- because Warp will overwrite that to 200 (see 'Network.Wai.Handler.Warp.Internal.sendResponse'). -file :: Monad m => FilePath -> ActionT e m () -file = ActionT . MS.modify . setContent . ContentFile +file :: MonadIO m => FilePath -> ActionT m () +file = modifyResponse . setContent . ContentFile -rawResponse :: Monad m => Response -> ActionT e m () -rawResponse = ActionT . MS.modify . setContent . ContentResponse +rawResponse :: MonadIO m => Response -> ActionT m () +rawResponse = modifyResponse . setContent . ContentResponse -- | Set the body of the response to the JSON encoding of the given value. Also sets \"Content-Type\" -- header to \"application/json; charset=utf-8\" if it has not already been set. -json :: (A.ToJSON a, ScottyError e, Monad m) => a -> ActionT e m () +json :: (A.ToJSON a, MonadIO m) => a -> ActionT m () json v = do changeHeader addIfNotPresent "Content-Type" "application/json; charset=utf-8" raw $ A.encode v @@ -434,18 +470,18 @@ json v = do -- | Set the body of the response to a Source. Doesn't set the -- \"Content-Type\" header, so you probably want to do that on your -- own with 'setHeader'. -stream :: Monad m => StreamingBody -> ActionT e m () -stream = ActionT . MS.modify . setContent . ContentStream +stream :: MonadIO m => StreamingBody -> ActionT m () +stream = modifyResponse . setContent . ContentStream -- | Set the body of the response to the given 'BL.ByteString' value. Doesn't set the -- \"Content-Type\" header, so you probably want to do that on your -- own with 'setHeader'. -raw :: Monad m => BL.ByteString -> ActionT e m () -raw = ActionT . MS.modify . setContent . ContentBuilder . fromLazyByteString +raw :: MonadIO m => BL.ByteString -> ActionT m () +raw = modifyResponse . setContent . ContentBuilder . fromLazyByteString -- | Nest a whole WAI application inside a Scotty handler. -- See Web.Scotty for further documentation -nested :: (ScottyError e, MonadIO m) => Network.Wai.Application -> ActionT e m () +nested :: (MonadIO m) => Network.Wai.Application -> ActionT m () nested app = do -- Is MVar really the best choice here? Not sure. r <- request diff --git a/Web/Scotty/Body.hs b/Web/Scotty/Body.hs index a2839d85..6d739d07 100644 --- a/Web/Scotty/Body.hs +++ b/Web/Scotty/Body.hs @@ -15,12 +15,12 @@ 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 GHC.Exception +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 +import Web.Scotty.Action (Param) import Web.Scotty.Internal.Types (BodyInfo(..), BodyChunkBuffer(..), BodyPartiallyStreamed(..), RouteOptions(..)) -import Web.Scotty.Util +import Web.Scotty.Util (readRequestBody, strictByteStringToLazyText) -- | Make a new BodyInfo with readProgress at 0 and an empty BodyChunkBuffer. newBodyInfo :: (MonadIO m) => Request -> m BodyInfo @@ -60,7 +60,7 @@ getBodyAction :: BodyInfo -> RouteOptions -> IO (BL.ByteString) getBodyAction (BodyInfo readProgress chunkBufferVar getChunk) opts = modifyMVar readProgress $ \index -> modifyMVar chunkBufferVar $ \bcb@(BodyChunkBuffer hasFinished chunks) -> do - if | index > 0 -> throw BodyPartiallyStreamed + if | index > 0 -> E.throw BodyPartiallyStreamed | hasFinished -> return (bcb, (index, BL.fromChunks chunks)) | otherwise -> do newChunks <- readRequestBody getChunk return (maxRequestBodySize opts) diff --git a/Web/Scotty/Cookie.hs b/Web/Scotty/Cookie.hs index 629e2bcc..aaea7553 100644 --- a/Web/Scotty/Cookie.hs +++ b/Web/Scotty/Cookie.hs @@ -71,13 +71,15 @@ module Web.Scotty.Cookie ( , sameSiteStrict ) where +import Control.Monad.IO.Class (MonadIO(..)) + -- bytestring import Data.ByteString.Builder (toLazyByteString) import qualified Data.ByteString.Lazy as BSL (toStrict) -- cookie import Web.Cookie (SetCookie, setCookieName , setCookieValue, setCookiePath, setCookieExpires, setCookieMaxAge, setCookieDomain, setCookieHttpOnly, setCookieSecure, setCookieSameSite, renderSetCookie, defaultSetCookie, CookiesText, parseCookiesText, SameSiteOption, sameSiteStrict, sameSiteNone, sameSiteLax) -- scotty -import Web.Scotty.Trans (ActionT, ScottyError(..), addHeader, header) +import Web.Scotty.Trans (ActionT, addHeader, header) -- time import Data.Time.Clock.POSIX ( posixSecondsToUTCTime ) -- text @@ -88,36 +90,36 @@ import qualified Data.Text.Lazy.Encoding as TL (encodeUtf8, decodeUtf8) -- | Set a cookie, with full access to its options (see 'SetCookie') -setCookie :: (Monad m, ScottyError e) +setCookie :: (MonadIO m) => SetCookie - -> ActionT e m () + -> ActionT m () setCookie c = addHeader "Set-Cookie" (TL.decodeUtf8 . toLazyByteString $ renderSetCookie c) -- | 'makeSimpleCookie' and 'setCookie' combined. -setSimpleCookie :: (Monad m, ScottyError e) +setSimpleCookie :: (MonadIO m) => Text -- ^ name -> Text -- ^ value - -> ActionT e m () + -> ActionT m () setSimpleCookie n v = setCookie $ makeSimpleCookie n v -- | Lookup one cookie name -getCookie :: (Monad m, ScottyError e) +getCookie :: (Monad m) => Text -- ^ name - -> ActionT e m (Maybe Text) + -> ActionT m (Maybe Text) getCookie c = lookup c <$> getCookies -- | Returns all cookies -getCookies :: (Monad m, ScottyError e) - => ActionT e m CookiesText +getCookies :: (Monad m) + => ActionT m CookiesText getCookies = (maybe [] parse) <$> header "Cookie" where parse = parseCookiesText . BSL.toStrict . TL.encodeUtf8 -- | Browsers don't directly delete a cookie, but setting its expiry to a past date (e.g. the UNIX epoch) ensures that the cookie will be invalidated (whether and when it will be actually deleted by the browser seems to be browser-dependent). -deleteCookie :: (Monad m, ScottyError e) +deleteCookie :: (MonadIO m) => Text -- ^ name - -> ActionT e m () + -> ActionT m () deleteCookie c = setCookie $ (makeSimpleCookie c "") { setCookieExpires = Just $ posixSecondsToUTCTime 0 } diff --git a/Web/Scotty/Exceptions.hs b/Web/Scotty/Exceptions.hs new file mode 100644 index 00000000..53f7d36f --- /dev/null +++ b/Web/Scotty/Exceptions.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE ExistentialQuantification #-} +module Web.Scotty.Exceptions ( + Handler(..) + -- * catching + , catch + , catchAny + , catches + , catchesOptionally + -- * trying + , try + , tryAny + ) where + +import Data.Maybe (maybeToList) + +import UnliftIO (MonadUnliftIO(..), catch, catchAny, catches, try, tryAny, Handler(..)) + + +-- | Handlers are tried sequentially +catchesOptionally :: MonadUnliftIO m => + m a + -> Maybe (Handler m a) -- ^ if present, this 'Handler' is tried first + -> [Handler m a] -- ^ these are tried in order + -> m a +catchesOptionally io mh handlers = io `catches` (maybeToList mh <> handlers) diff --git a/Web/Scotty/Internal/Types.hs b/Web/Scotty/Internal/Types.hs index 76a7723b..efad224d 100644 --- a/Web/Scotty/Internal/Types.hs +++ b/Web/Scotty/Internal/Types.hs @@ -1,32 +1,32 @@ +{-# LANGUAGE PackageImports #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DerivingStrategies #-} +{-# language DerivingVia #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# language ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE RecordWildCards #-} - module Web.Scotty.Internal.Types where import Blaze.ByteString.Builder (Builder) import Control.Applicative import Control.Concurrent.MVar -import Control.Exception (Exception) +import Control.Concurrent.STM (TVar, atomically, readTVarIO, modifyTVar') import qualified Control.Exception as E -import qualified Control.Monad as Monad import Control.Monad (MonadPlus(..)) -import Control.Monad.Base (MonadBase, liftBase, liftBaseDefault) -import Control.Monad.Catch (MonadCatch, catch, MonadThrow, throwM) -import Control.Monad.Error.Class -import qualified Control.Monad.Fail as Fail -import Control.Monad.IO.Class (MonadIO) -import Control.Monad.Reader (MonadReader(..), ReaderT, mapReaderT) -import Control.Monad.State.Strict (MonadState(..), State, StateT, mapStateT) +import Control.Monad.Base (MonadBase) +import Control.Monad.Catch (MonadCatch, MonadThrow) +import Control.Monad.IO.Class (MonadIO(..)) +import UnliftIO (MonadUnliftIO(..)) +import Control.Monad.Reader (MonadReader(..), ReaderT, asks) +import Control.Monad.State.Strict (State, StateT(..)) import Control.Monad.Trans.Class (MonadTrans(..)) -import Control.Monad.Trans.Control (MonadBaseControl, StM, liftBaseWith, restoreM, ComposeSt, defaultLiftBaseWith, defaultRestoreM, MonadTransControl, StT, liftWith, restoreT) -import Control.Monad.Trans.Except +import Control.Monad.Trans.Control (MonadBaseControl, MonadTransControl) import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy.Char8 as LBS8 (ByteString) @@ -42,8 +42,10 @@ import qualified Network.Wai as Wai import Network.Wai.Handler.Warp (Settings, defaultSettings) import Network.Wai.Parse (FileInfo) +import Web.Scotty.Exceptions (Handler(..), catch, catches) + import Prelude () -import Prelude.Compat +import "base-compat-batteries" Prelude.Compat --------------------- Options ----------------------- data Options = Options { verbose :: Int -- ^ 0 = silent, 1(def) = startup banner @@ -57,13 +59,19 @@ data Options = Options { verbose :: Int -- ^ 0 = silent, 1(def) = startup banner } instance Default Options where - def = Options 1 defaultSettings + def = defaultOptions + +defaultOptions :: Options +defaultOptions = Options 1 defaultSettings newtype RouteOptions = RouteOptions { maxRequestBodySize :: Maybe Kilobytes -- max allowed request size in KB } instance Default RouteOptions where - def = RouteOptions Nothing + def = defaultRouteOptions + +defaultRouteOptions :: RouteOptions +defaultRouteOptions = RouteOptions Nothing type Kilobytes = Int ----- Transformer Aware Applications/Middleware ----- @@ -85,78 +93,90 @@ data BodyInfo = BodyInfo { bodyInfoReadProgress :: MVar Int -- ^ index into the --------------- Scotty Applications ----------------- -data ScottyState e m = +data ScottyState m = ScottyState { middlewares :: [Wai.Middleware] , routes :: [BodyInfo -> Middleware m] - , handler :: ErrorHandler e m + , handler :: Maybe (ErrorHandler m) , routeOptions :: RouteOptions } -instance Default (ScottyState e m) where - def = ScottyState [] [] Nothing def +instance Default (ScottyState m) where + def = defaultScottyState -addMiddleware :: Wai.Middleware -> ScottyState e m -> ScottyState e m +defaultScottyState :: ScottyState m +defaultScottyState = ScottyState [] [] Nothing defaultRouteOptions + +addMiddleware :: Wai.Middleware -> ScottyState m -> ScottyState m addMiddleware m s@(ScottyState {middlewares = ms}) = s { middlewares = m:ms } -addRoute :: (BodyInfo -> Middleware m) -> ScottyState e m -> ScottyState e m +addRoute :: (BodyInfo -> Middleware m) -> ScottyState m -> ScottyState m addRoute r s@(ScottyState {routes = rs}) = s { routes = r:rs } -addHandler :: ErrorHandler e m -> ScottyState e m -> ScottyState e m -addHandler h s = s { handler = h } +setHandler :: Maybe (ErrorHandler m) -> ScottyState m -> ScottyState m +setHandler h s = s { handler = h } -updateMaxRequestBodySize :: RouteOptions -> ScottyState e m -> ScottyState e m +updateMaxRequestBodySize :: RouteOptions -> ScottyState m -> ScottyState m updateMaxRequestBodySize RouteOptions { .. } s@ScottyState { routeOptions = ro } = let ro' = ro { maxRequestBodySize = maxRequestBodySize } in s { routeOptions = ro' } -newtype ScottyT e m a = ScottyT { runS :: State (ScottyState e m) a } +newtype ScottyT m a = ScottyT { runS :: State (ScottyState m) a } deriving ( Functor, Applicative, Monad ) ------------------ Scotty Errors -------------------- -data ActionError e - = Redirect Text - | Next - | Finish - | ActionError Status e - --- | In order to use a custom exception type (aside from 'Text'), you must --- define an instance of 'ScottyError' for that type. -class ScottyError e where - stringError :: String -> e - showError :: e -> Text - -instance ScottyError Text where - stringError = pack - showError = id - -instance ScottyError e => ScottyError (ActionError e) where - stringError = ActionError status500 . stringError - showError (Redirect url) = url - showError Next = pack "Next" - showError Finish = pack "Finish" - showError (ActionError _ e) = showError e - -type ErrorHandler e m = Maybe (e -> ActionT e m ()) +-- | Internal exception mechanism used to modify the request processing flow. +-- +-- 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 + | AENext -- ^ Stop processing this route and skip to the next one + | AEFinish -- ^ Stop processing the request + deriving (Show, Typeable) +instance E.Exception ActionError + +tryNext :: MonadUnliftIO m => m a -> m Bool +tryNext io = catch (io >> pure True) $ \e -> + case e of + AENext -> pure False + _ -> 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) +instance E.Exception StatusError + +-- | Specializes a 'Handler' to the 'ActionT' monad +type ErrorHandler m = Handler (ActionT m) () + +-- | Thrown e.g. when a request is too large data ScottyException = RequestException BS.ByteString Status deriving (Show, Typeable) - -instance Exception ScottyException +instance E.Exception ScottyException ------------------ Scotty Actions ------------------- type Param = (Text, Text) type File = (Text, FileInfo LBS8.ByteString) -data ActionEnv = Env { getReq :: Request - , getCaptureParams :: [Param] - , getFormParams :: [Param] - , getQueryParams :: [Param] - , getBody :: IO LBS8.ByteString - , getBodyChunk :: IO BS.ByteString - , getFiles :: [File] +data ActionEnv = Env { envReq :: Request + , envCaptureParams :: [Param] + , envFormParams :: [Param] + , envQueryParams :: [Param] + , envBody :: IO LBS8.ByteString + , envBodyChunk :: IO BS.ByteString + , envFiles :: [File] + , envResponse :: TVar ScottyResponse } +getResponse :: MonadIO m => ActionEnv -> m ScottyResponse +getResponse ae = liftIO $ readTVarIO (envResponse ae) + +modifyResponse :: (MonadIO m) => (ScottyResponse -> ScottyResponse) -> ActionT m () +modifyResponse f = do + tv <- asks envResponse + liftIO $ atomically $ modifyTVar' tv f + data BodyPartiallyStreamed = BodyPartiallyStreamed deriving (Show, Typeable) instance E.Exception BodyPartiallyStreamed @@ -171,83 +191,42 @@ data ScottyResponse = SR { srStatus :: Status , srContent :: Content } -instance Default ScottyResponse where - def = SR status200 [] (ContentBuilder mempty) - -newtype ActionT e m a = ActionT { runAM :: ExceptT (ActionError e) (ReaderT ActionEnv (StateT ScottyResponse m)) a } - deriving ( Functor, Applicative, MonadIO ) - -instance (Monad m, ScottyError e) => Monad.Monad (ActionT e m) where - ActionT m >>= k = ActionT (m >>= runAM . k) -#if !(MIN_VERSION_base(4,13,0)) - fail = Fail.fail -#endif - -instance (Monad m, ScottyError e) => Fail.MonadFail (ActionT e m) where - fail = ActionT . throwError . stringError - -instance ( Monad m, ScottyError e -#if !(MIN_VERSION_base(4,8,0)) - , Functor m -#endif - ) => Alternative (ActionT e m) where - empty = mzero - (<|>) = mplus - -instance (Monad m, ScottyError e) => MonadPlus (ActionT e m) where - mzero = ActionT . ExceptT . return $ Left Next - ActionT m `mplus` ActionT n = ActionT . ExceptT $ do - a <- runExceptT m - case a of - Left _ -> runExceptT n - Right r -> return $ Right r - -instance ScottyError e => MonadTrans (ActionT e) where - lift = ActionT . lift . lift . lift - -instance (ScottyError e, Monad m) => MonadError (ActionError e) (ActionT e m) where - throwError = ActionT . throwError - - catchError (ActionT m) f = ActionT (catchError m (runAM . f)) - - -instance (MonadBase b m, ScottyError e) => MonadBase b (ActionT e m) where - liftBase = liftBaseDefault +setContent :: Content -> ScottyResponse -> ScottyResponse +setContent c sr = sr { srContent = c } +setHeaderWith :: ([(HeaderName, BS.ByteString)] -> [(HeaderName, BS.ByteString)]) -> ScottyResponse -> ScottyResponse +setHeaderWith f sr = sr { srHeaders = f (srHeaders sr) } -instance (MonadThrow m, ScottyError e) => MonadThrow (ActionT e m) where - throwM = ActionT . throwM +setStatus :: Status -> ScottyResponse -> ScottyResponse +setStatus s sr = sr { srStatus = s } -instance (MonadCatch m, ScottyError e) => MonadCatch (ActionT e m) where - catch (ActionT m) f = ActionT (m `catch` (runAM . f)) - -instance ScottyError e => MonadTransControl (ActionT e) where - type StT (ActionT e) a = StT (StateT ScottyResponse) (StT (ReaderT ActionEnv) (StT (ExceptT (ActionError e)) a)) - liftWith = \f -> - ActionT $ liftWith $ \run -> - liftWith $ \run' -> - liftWith $ \run'' -> - f $ run'' . run' . run . runAM - restoreT = ActionT . restoreT . restoreT . restoreT - -instance (ScottyError e, MonadBaseControl b m) => MonadBaseControl b (ActionT e m) where - type StM (ActionT e m) a = ComposeSt (ActionT e) m a - liftBaseWith = defaultLiftBaseWith - restoreM = defaultRestoreM - -instance (MonadReader r m, ScottyError e) => MonadReader r (ActionT e m) where - {-# INLINE ask #-} - ask = lift ask - {-# INLINE local #-} - local f = ActionT . mapExceptT (mapReaderT (mapStateT $ local f)) . runAM - -instance (MonadState s m, ScottyError e) => MonadState s (ActionT e m) where - {-# INLINE get #-} - get = lift get - {-# INLINE put #-} - put = lift . put - -instance (Semigroup a) => Semigroup (ScottyT e m a) where +instance Default ScottyResponse where + def = defaultScottyResponse + +-- | The default response has code 200 OK and empty body +defaultScottyResponse :: ScottyResponse +defaultScottyResponse = SR status200 [] (ContentBuilder mempty) + + +newtype ActionT m a = ActionT { runAM :: ReaderT ActionEnv m a } + deriving newtype (Functor, Applicative, Monad, MonadIO, MonadReader ActionEnv, MonadTrans, MonadThrow, MonadCatch, MonadBase b, MonadBaseControl b, MonadTransControl, MonadUnliftIO) +instance (MonadUnliftIO m) => Alternative (ActionT m) where + empty = E.throw AENext + a <|> b = do + ok <- tryAnyStatus a + if ok then a else b +instance (MonadUnliftIO m) => MonadPlus (ActionT m) where + mzero = empty + mplus = (<|>) + +-- | catches either ActionError (thrown by 'next') or 'StatusError' (thrown if e.g. a query parameter is not found) +tryAnyStatus :: MonadUnliftIO m => m a -> m Bool +tryAnyStatus io = (io >> pure True) `catches` [h1, h2] + where + h1 = Handler $ \(_ :: ActionError) -> pure False + h2 = Handler $ \(_ :: StatusError) -> pure False + +instance (Semigroup a) => Semigroup (ScottyT m a) where x <> y = (<>) <$> x <*> y instance @@ -258,7 +237,7 @@ instance #if !(MIN_VERSION_base(4,8,0)) , Functor m #endif - ) => Monoid (ScottyT e m a) where + ) => Monoid (ScottyT m a) where mempty = return mempty #if !(MIN_VERSION_base(4,11,0)) mappend = (<>) @@ -270,18 +249,18 @@ instance , Functor m #endif , Semigroup a - ) => Semigroup (ActionT e m a) where + ) => Semigroup (ActionT m a) where x <> y = (<>) <$> x <*> y instance - ( Monad m, ScottyError e, Monoid a + ( Monad m, Monoid a #if !(MIN_VERSION_base(4,11,0)) , Semigroup a #endif #if !(MIN_VERSION_base(4,8,0)) , Functor m #endif - ) => Monoid (ActionT e m a) where + ) => Monoid (ActionT m a) where mempty = return mempty #if !(MIN_VERSION_base(4,11,0)) mappend = (<>) @@ -296,4 +275,3 @@ instance IsString RoutePattern where fromString = Capture . pack - diff --git a/Web/Scotty/Route.hs b/Web/Scotty/Route.hs index 434dee88..c8f80be2 100644 --- a/Web/Scotty/Route.hs +++ b/Web/Scotty/Route.hs @@ -1,12 +1,15 @@ {-# LANGUAGE FlexibleContexts, FlexibleInstances, OverloadedStrings, RankNTypes, ScopedTypeVariables #-} +{-# language PackageImports #-} module Web.Scotty.Route ( get, post, put, delete, patch, options, addroute, matchAny, notFound, capture, regex, function, literal ) where import Control.Arrow ((***)) -import Control.Monad.IO.Class +import Control.Concurrent.STM (newTVarIO) +import Control.Monad.IO.Class (MonadIO(..)) +import UnliftIO (MonadUnliftIO(..)) import qualified Control.Monad.State as MS import qualified Data.ByteString.Char8 as B @@ -20,46 +23,46 @@ import Network.HTTP.Types import Network.Wai (Request(..)) import Prelude () -import Prelude.Compat +import "base-compat-batteries" Prelude.Compat import qualified Text.Regex as Regex import Web.Scotty.Action -import Web.Scotty.Internal.Types (RoutePattern(..), RouteOptions, ActionEnv(..), ActionT, ScottyState(..), ScottyT(..), Middleware, BodyInfo, ScottyError(..), ErrorHandler, handler, addRoute) +import Web.Scotty.Internal.Types (RoutePattern(..), RouteOptions, ActionEnv(..), ActionT, ScottyState(..), ScottyT(..), ErrorHandler, Middleware, BodyInfo, handler, addRoute, defaultScottyResponse) import Web.Scotty.Util (strictByteStringToLazyText) import Web.Scotty.Body (cloneBodyInfo, getBodyAction, getBodyChunkAction, getFormParamsAndFilesAction) -- | get = 'addroute' 'GET' -get :: (ScottyError e, MonadIO m) => RoutePattern -> ActionT e m () -> ScottyT e m () +get :: (MonadUnliftIO m) => RoutePattern -> ActionT m () -> ScottyT m () get = addroute GET -- | post = 'addroute' 'POST' -post :: (ScottyError e, MonadIO m) => RoutePattern -> ActionT e m () -> ScottyT e m () +post :: (MonadUnliftIO m) => RoutePattern -> ActionT m () -> ScottyT m () post = addroute POST -- | put = 'addroute' 'PUT' -put :: (ScottyError e, MonadIO m) => RoutePattern -> ActionT e m () -> ScottyT e m () +put :: (MonadUnliftIO m) => RoutePattern -> ActionT m () -> ScottyT m () put = addroute PUT -- | delete = 'addroute' 'DELETE' -delete :: (ScottyError e, MonadIO m) => RoutePattern -> ActionT e m () -> ScottyT e m () +delete :: (MonadUnliftIO m) => RoutePattern -> ActionT m () -> ScottyT m () delete = addroute DELETE -- | patch = 'addroute' 'PATCH' -patch :: (ScottyError e, MonadIO m) => RoutePattern -> ActionT e m () -> ScottyT e m () +patch :: (MonadUnliftIO m) => RoutePattern -> ActionT m () -> ScottyT m () patch = addroute PATCH -- | options = 'addroute' 'OPTIONS' -options :: (ScottyError e, MonadIO m) => RoutePattern -> ActionT e m () -> ScottyT e m () +options :: (MonadUnliftIO m) => RoutePattern -> ActionT m () -> ScottyT m () options = addroute OPTIONS -- | Add a route that matches regardless of the HTTP verb. -matchAny :: (ScottyError e, MonadIO m) => RoutePattern -> ActionT e m () -> ScottyT e m () -matchAny pattern action = ScottyT $ MS.modify $ \s -> addRoute (route (routeOptions s) (handler s) Nothing pattern action) s +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 -- | Specify an action to take if nothing else is found. Note: this _always_ matches, -- so should generally be the last route specified. -notFound :: (ScottyError e, MonadIO m) => ActionT e m () -> ScottyT e m () +notFound :: (MonadUnliftIO m) => ActionT m () -> ScottyT m () notFound action = matchAny (Function (\req -> Just [("path", path req)])) (status status404 >> action) -- | Define a route with a 'StdMethod', 'T.Text' value representing the path spec, @@ -68,24 +71,28 @@ notFound action = matchAny (Function (\req -> Just [("path", path req)])) (statu -- > addroute GET "/" $ text "beam me up!" -- -- The path spec can include values starting with a colon, which are interpreted --- as /captures/. These are named wildcards that can be looked up with 'param'. +-- as /captures/. These are named wildcards that can be looked up with 'captureParam'. -- -- > addroute GET "/foo/:bar" $ do --- > v <- param "bar" +-- > v <- captureParam "bar" -- > text v -- -- >>> curl http://localhost:3000/foo/something -- something -addroute :: (ScottyError e, MonadIO m) => StdMethod -> RoutePattern -> ActionT e m () -> ScottyT e m () +-- +-- NB: the 'RouteOptions' and the exception handler of the newly-created route will be +-- copied from the previously-created routes. +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 -route :: (ScottyError e, MonadIO m) => - RouteOptions -> ErrorHandler e m -> Maybe StdMethod -> RoutePattern -> ActionT e m () -> BodyInfo -> Middleware m +route :: (MonadUnliftIO m) => + RouteOptions + -> Maybe (ErrorHandler m) -> Maybe StdMethod -> RoutePattern -> ActionT m () -> BodyInfo -> Middleware m route 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 + See https://github.com/scotty-web/scotty/issues/196 and 'matchAny' -} methodMatches :: Bool methodMatches = maybe True (\x -> (Right x == parseMethod (requestMethod req))) method @@ -129,14 +136,15 @@ matchRoute (Capture pat) req = go (T.split (=='/') pat) (compress $ T.split (== path :: Request -> T.Text path = T.fromStrict . TS.cons '/' . TS.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 let queryps = parseEncodedParams $ rawQueryString req bodyFiles' = [ (strictByteStringToLazyText k, fi) | (k,fi) <- bodyFiles ] - return $ Env req captureps formps queryps (getBodyAction bodyInfo opts) (getBodyChunkAction bodyInfo) bodyFiles' + responseInit <- liftIO $ newTVarIO defaultScottyResponse + return $ Env req captureps formps queryps (getBodyAction bodyInfo opts) (getBodyChunkAction bodyInfo) bodyFiles' responseInit parseEncodedParams :: B.ByteString -> [Param] diff --git a/Web/Scotty/Trans.hs b/Web/Scotty/Trans.hs index 14657db6..19446fa8 100644 --- a/Web/Scotty/Trans.hs +++ b/Web/Scotty/Trans.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings, RankNTypes #-} +{-# language LambdaCase #-} -- | It should be noted that most of the code snippets below depend on the -- OverloadedStrings language pragma. -- @@ -11,7 +12,7 @@ -- the comments on each of these functions for more information. module Web.Scotty.Trans ( -- * scotty-to-WAI - scottyT, scottyAppT, scottyOptsT, scottySocketT, Options(..) + scottyT, scottyAppT, scottyOptsT, scottySocketT, Options(..), defaultOptions -- * Defining Middleware and Routes -- -- | 'Middleware' and routes are run in the order in which they @@ -34,13 +35,15 @@ module Web.Scotty.Trans -- definition, as they completely replace the current 'Response' body. , text, html, file, json, stream, raw, nested -- ** Exceptions - , raise, raiseStatus, rescue, next, finish, defaultHandler, ScottyError(..), liftAndCatchIO + , raise, raiseStatus, throw, rescue, next, finish, defaultHandler, liftAndCatchIO + , StatusError(..) -- * Parsing Parameters , Param, Parsable(..), readEither -- * Types - , RoutePattern, File, Kilobytes + , RoutePattern, File, Kilobytes, ErrorHandler, Handler(..) -- * Monad Transformers , ScottyT, ActionT + , ScottyState, defaultScottyState ) where import Blaze.ByteString.Builder (fromByteString) @@ -50,35 +53,33 @@ import Control.Monad (when) import Control.Monad.State.Strict (execState, modify) import Control.Monad.IO.Class -import Data.Default.Class (def) - -import Network.HTTP.Types (status404, status500) +import Network.HTTP.Types (status404) import Network.Socket (Socket) -import Network.Wai +import qualified Network.Wai as W (Application, Middleware, Response, responseBuilder) import Network.Wai.Handler.Warp (Port, runSettings, runSettingsSocket, setPort, getPort) import Web.Scotty.Action import Web.Scotty.Route -import Web.Scotty.Internal.Types hiding (Application, Middleware) +import Web.Scotty.Internal.Types (ActionT(..), ScottyT(..), defaultScottyState, Application, RoutePattern, Options(..), defaultOptions, RouteOptions(..), defaultRouteOptions, ErrorHandler, Kilobytes, File, addMiddleware, setHandler, updateMaxRequestBodySize, routes, middlewares, ScottyException(..), ScottyState, defaultScottyState, StatusError(..)) import Web.Scotty.Util (socketDescription) -import qualified Web.Scotty.Internal.Types as Scotty import Web.Scotty.Body (newBodyInfo) +import Web.Scotty.Exceptions (Handler(..), catches) -- | Run a scotty application using the warp server. -- NB: scotty p === scottyT p id scottyT :: (Monad m, MonadIO n) => Port - -> (m Response -> IO Response) -- ^ Run monad 'm' into 'IO', called at each action. - -> ScottyT e m () + -> (m W.Response -> IO W.Response) -- ^ Run monad 'm' into 'IO', called at each action. + -> ScottyT m () -> n () -scottyT p = scottyOptsT $ def { settings = setPort p (settings def) } +scottyT p = scottyOptsT $ defaultOptions { settings = setPort p (settings defaultOptions) } -- | Run a scotty application using the warp server, passing extra options. -- NB: scottyOpts opts === scottyOptsT opts id scottyOptsT :: (Monad m, MonadIO n) => Options - -> (m Response -> IO Response) -- ^ Run monad 'm' into 'IO', called at each action. - -> ScottyT e m () + -> (m W.Response -> IO W.Response) -- ^ Run monad 'm' into 'IO', called at each action. + -> ScottyT m () -> n () scottyOptsT opts runActionToIO s = do when (verbose opts > 0) $ @@ -91,8 +92,8 @@ scottyOptsT opts runActionToIO s = do scottySocketT :: (Monad m, MonadIO n) => Options -> Socket - -> (m Response -> IO Response) - -> ScottyT e m () + -> (m W.Response -> IO W.Response) + -> ScottyT m () -> n () scottySocketT opts sock runActionToIO s = do when (verbose opts > 0) $ do @@ -104,40 +105,44 @@ scottySocketT opts sock runActionToIO s = do -- run with any WAI handler. -- NB: scottyApp === scottyAppT id scottyAppT :: (Monad m, Monad n) - => (m Response -> IO Response) -- ^ Run monad 'm' into 'IO', called at each action. - -> ScottyT e m () - -> n Application + => (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) def + let s = execState (runS defs) defaultScottyState let rapp req callback = do bodyInfo <- newBodyInfo req - runActionToIO (foldl (flip ($)) notFoundApp ([midd bodyInfo | midd <- routes s]) req) >>= callback - return $ foldl (flip ($)) rapp (middlewares s) + resp <- runActionToIO (applyAll notFoundApp ([midd bodyInfo | midd <- routes s]) req) `catches` [scottyExceptionHandler] + callback resp + return $ applyAll rapp (middlewares s) + +applyAll :: Foldable t => a -> t (a -> a) -> a +applyAll = foldl (flip ($)) -notFoundApp :: Monad m => Scotty.Application m -notFoundApp _ = return $ responseBuilder status404 [("Content-Type","text/html")] +notFoundApp :: Monad m => Application m +notFoundApp _ = return $ W.responseBuilder status404 [("Content-Type","text/html")] $ fromByteString "

404: File Not Found!

" --- | Global handler for uncaught exceptions. --- --- Uncaught exceptions normally become 500 responses. --- You can use this to selectively override that behavior. --- --- Note: IO exceptions are lifted into 'ScottyError's by 'stringError'. --- This has security implications, so you probably want to provide your --- own defaultHandler in production which does not send out the error --- strings as 500 responses. -defaultHandler :: (ScottyError e, Monad m) => (e -> ActionT e m ()) -> ScottyT e m () -defaultHandler f = ScottyT $ modify $ addHandler $ Just (\e -> status status500 >> f e) +-- | Global handler for user-defined exceptions. +defaultHandler :: (Monad m) => ErrorHandler m -> ScottyT m () +defaultHandler f = ScottyT $ modify $ setHandler $ Just f + +-- | Exception handler in charge of 'ScottyException' +scottyExceptionHandler :: MonadIO m => Handler m W.Response +scottyExceptionHandler = Handler $ \case + RequestException ebody s -> do + return $ W.responseBuilder s [("Content-Type", "text/plain")] (fromByteString ebody) + -- | Use given middleware. Middleware is nested such that the first declared -- is the outermost middleware (it has first dibs on the request and last action -- on the response). Every middleware is run on each request. -middleware :: Middleware -> ScottyT e m () +middleware :: W.Middleware -> ScottyT m () 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, --- otherwise the application will terminate on start. -setMaxRequestBodySize :: Kilobytes -> ScottyT e m () -setMaxRequestBodySize i = assert (i > 0) $ ScottyT . modify . updateMaxRequestBodySize $ def { maxRequestBodySize = Just i } +-- otherwise the application will terminate on start. +setMaxRequestBodySize :: Kilobytes -- ^ Request size limit + -> ScottyT m () +setMaxRequestBodySize i = assert (i > 0) $ ScottyT . modify . updateMaxRequestBodySize $ defaultRouteOptions { maxRequestBodySize = Just i } diff --git a/Web/Scotty/Util.hs b/Web/Scotty/Util.hs index 71823d21..af7af8df 100644 --- a/Web/Scotty/Util.hs +++ b/Web/Scotty/Util.hs @@ -2,9 +2,6 @@ module Web.Scotty.Util ( lazyTextToStrictByteString , strictByteStringToLazyText - , setContent - , setHeaderWith - , setStatus , mkResponse , replace , add @@ -17,7 +14,8 @@ import Network.Socket (SockAddr(..), Socket, getSocketName, socketPort) import Network.Wai import Control.Monad (when) -import Control.Exception (throw) +import qualified Control.Exception as EUnsafe (throw) + import Network.HTTP.Types @@ -35,14 +33,7 @@ lazyTextToStrictByteString = ES.encodeUtf8 . TL.toStrict strictByteStringToLazyText :: B.ByteString -> TL.Text strictByteStringToLazyText = TL.fromStrict . ES.decodeUtf8With ES.lenientDecode -setContent :: Content -> ScottyResponse -> ScottyResponse -setContent c sr = sr { srContent = c } - -setHeaderWith :: ([(HeaderName, B.ByteString)] -> [(HeaderName, B.ByteString)]) -> ScottyResponse -> ScottyResponse -setHeaderWith f sr = sr { srHeaders = f (srHeaders sr) } -setStatus :: Status -> ScottyResponse -> ScottyResponse -setStatus s sr = sr { srStatus = s } -- Note: we currently don't support responseRaw, which may be useful -- for websockets. However, we always read the request body, which @@ -101,5 +92,8 @@ readRequestBody rbody prefix maxSize = do readUntilEmpty = do b <- rbody if B.null b - then throw (RequestException (ES.encodeUtf8 . TP.pack $ "Request is too big Jim!") status413) + then EUnsafe.throw (RequestException (ES.encodeUtf8 . TP.pack $ "Request is too big Jim!") status413) else readUntilEmpty + + + diff --git a/bench/Main.hs b/bench/Main.hs index 6285defc..19a0fc49 100644 --- a/bench/Main.hs +++ b/bench/Main.hs @@ -6,9 +6,7 @@ module Main (main) where import Control.Monad -import Data.Default.Class (def) import Data.Functor.Identity -import Data.Text (Text) import Lucid.Base import Lucid.Html5 import Web.Scotty @@ -25,9 +23,9 @@ main = do setColumns [Case,Allocated,GCs,Live,Check,Max,MaxOS] setFormat Markdown io "ScottyM Strict" BL.putStr - (SS.evalState (runS $ renderBST htmlScotty) def) + (SS.evalState (runS $ renderBST htmlScotty) defaultScottyState) io "ScottyM Lazy" BL.putStr - (SL.evalState (runScottyLazy $ renderBST htmlScottyLazy) def) + (SL.evalState (runScottyLazy $ renderBST htmlScottyLazy) defaultScottyState) io "Identity" BL.putStr (runIdentity $ renderBST htmlIdentity) @@ -49,6 +47,6 @@ htmlScottyLazy = htmlTest {-# noinline htmlScottyLazy #-} newtype ScottyLazy a = ScottyLazy - { runScottyLazy:: SL.State (ScottyState Text IO) a } + { runScottyLazy:: SL.State (ScottyState IO) a } deriving (Functor,Applicative,Monad) diff --git a/changelog.md b/changelog.md index 0f6ffa0a..f6f22077 100644 --- a/changelog.md +++ b/changelog.md @@ -1,9 +1,19 @@ ## next [????.??.??] -* Adds a new `nested` handler that allows you to place an entire WAI Application under a Scotty route -* Disambiguate request parameters (#204). Adjust the `Env` type to have three [Param] fields instead of one, add `captureParam`, `formParam`, `queryParam` and the associated `captureParams`, `formParams`, `queryParams`. Add deprecation notices to `param` and `params`. -* Add `Scotty.Cookie` module. -* Change body parsing behaviour such that calls to 'next' don't result in POST request bodies disappearing (#147). -* (Internal) Remove unused type RequestBodyState (#313) + +## 0.20 [2023.10.02] +* Drop support for GHC < 8.10 and modernise the CI pipeline (#300). +* Adds a new `nested` handler that allows you to place an entire WAI Application under a Scotty route (#233). +* Disambiguate request parameters (#204). Adjust the `Env` type to have three `[Param]` fields instead of one, add `captureParam`, `formParam`, `queryParam` and the associated `captureParams`, `formParams`, `queryParams`. Add deprecation notices to `param` and `params`. +* Add `Scotty.Cookie` module (#293). +* Change body parsing behaviour such that calls to `next` don't result in POST request bodies disappearing (#147). +* (Internal) Remove unused type `RequestBodyState` (#313) +* Rewrite `ActionT` using the "ReaderT pattern" (#310) https://www.fpcomplete.com/blog/readert-design-pattern/ + +Breaking: + +* (#310) Introduce `unliftio` as a dependency, and base exception handling on `catch`. +** Clarify the exception handling mechanism of ActionT, ScottyT. `rescue` changes signature to use proper `Exception` types rather than strings. +** All ActionT methods (`text`, `html` etc.) have now a MonadIO constraint on the base monad rather than Monad because the response is constructed in a TVar inside ActionEnv. `rescue` has a MonadUnliftIO constraint. The Alternative instance of ActionT also is based on MonadUnliftIO because `<|>` is implemented in terms of `catch`. `ScottyT` and `ActionT` do not have an exception type parameter anymore. ## 0.12.1 [2022.11.17] * Fix CPP bug that prevented tests from building on Windows. diff --git a/examples/basic.hs b/examples/basic.hs index c1aa0b6f..ef9ca7e2 100644 --- a/examples/basic.hs +++ b/examples/basic.hs @@ -1,21 +1,29 @@ {-# LANGUAGE OverloadedStrings #-} +{-# language DeriveAnyClass #-} +{-# language ScopedTypeVariables #-} module Main (main) where import Web.Scotty import Network.Wai.Middleware.RequestLogger -- install wai-extra if you don't have this +import Control.Exception (Exception(..)) import Control.Monad import Control.Monad.Trans import System.Random (newStdGen, randomRs) import Network.HTTP.Types (status302) +import Data.Text.Lazy (pack) import Data.Text.Lazy.Encoding (decodeUtf8) import Data.String (fromString) +import Data.Typeable (Typeable) import Prelude () import Prelude.Compat +data Err = Boom | UserAgentNotFound | NeverReached deriving (Show, Typeable, Exception) + + main :: IO () main = scotty 3000 $ do -- Add any WAI middleware, they are run top-down. @@ -29,14 +37,14 @@ main = scotty 3000 $ do get "/" $ text "foobar" get "/" $ text "barfoo" - -- Using a parameter in the query string. If it has + -- Using a parameter in the query string. Since it has -- not been given, a 500 page is generated. get "/foo" $ do v <- captureParam "fooparam" html $ mconcat ["

", v, "

"] -- An uncaught error becomes a 500 page. - get "/raise" $ raise "some error here" + get "/raise" $ throw Boom -- You can set status and headers directly. get "/redirect-custom" $ do @@ -47,12 +55,12 @@ main = scotty 3000 $ do -- redirects preempt execution get "/redirect" $ do void $ redirect "http://www.google.com" - raise "this error is never reached" + throw NeverReached -- Of course you can catch your own errors. get "/rescue" $ do - (do void $ raise "a rescued error"; redirect "http://www.we-never-go-here.com") - `rescue` (\m -> text $ "we recovered from " `mappend` m) + (do void $ throw Boom; redirect "http://www.we-never-go-here.com") + `rescue` (\(e :: Err) -> text $ "we recovered from " `mappend` pack (show e)) -- Parts of the URL that start with a colon match -- any string, and capture that value as a parameter. @@ -64,7 +72,7 @@ main = scotty 3000 $ do -- Files are streamed directly to the client. get "/404" $ file "404.html" - -- You can stop execution of this action and keep pattern matching routes. + -- 'next' stops execution of the current action and keeps pattern matching routes. get "/random" $ do void next redirect "http://www.we-never-go-here.com" @@ -85,17 +93,21 @@ main = scotty 3000 $ do ,"" ] + -- Read and decode the request body as UTF-8 post "/readbody" $ do b <- body text $ decodeUtf8 b + -- Look up a request header get "/header" $ do agent <- header "User-Agent" - maybe (raise "User-Agent header not found!") text agent + maybe (throw UserAgentNotFound) text agent -- Make a request to this URI, then type a line in the terminal, which -- will be the response. Using ctrl-c will cause getLine to fail. -- This demonstrates that IO exceptions are lifted into ActionM exceptions. + -- + -- (#310) we don't catch async exceptions, so ctrl-c just exits the program get "/iofail" $ do msg <- liftIO $ liftM fromString getLine text msg diff --git a/examples/exceptions.hs b/examples/exceptions.hs index bddb1a41..3e4f3c7e 100644 --- a/examples/exceptions.hs +++ b/examples/exceptions.hs @@ -1,9 +1,13 @@ {-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving, ScopedTypeVariables #-} +{-# language DeriveAnyClass #-} +{-# language LambdaCase #-} module Main (main) where +import Control.Exception (Exception(..)) import Control.Monad.IO.Class import Data.String (fromString) +import Data.Typeable import Network.HTTP.Types import Network.Wai.Middleware.RequestLogger @@ -15,25 +19,20 @@ import System.Random import Web.Scotty.Trans --- Define a custom exception type. +-- | A custom exception type. data Except = Forbidden | NotFound Int | StringEx String - deriving (Show, Eq) + deriving (Show, Eq, Typeable, Exception) --- The type must be an instance of 'ScottyError'. --- 'ScottyError' is essentially a combination of 'Error' and 'Show'. -instance ScottyError Except where - stringError = StringEx - showError = fromString . show - --- Handler for uncaught exceptions. -handleEx :: Monad m => Except -> ActionT Except m () -handleEx Forbidden = do +-- | User-defined exceptions should have an associated Handler: +handleEx :: MonadIO m => ErrorHandler m +handleEx = Handler $ \case + Forbidden -> do status status403 html "

Scotty Says No

" -handleEx (NotFound i) = do + NotFound i -> do status status404 html $ fromString $ "

Can't find " ++ show i ++ ".

" -handleEx (StringEx s) = do + StringEx s -> do status status500 html $ fromString $ "

" ++ s ++ "

" @@ -54,12 +53,12 @@ main = scottyT 3000 id $ do -- note, we aren't using any additional transformer get "/switch/:val" $ do v <- captureParam "val" - _ <- if even v then raise Forbidden else raise (NotFound v) + _ <- if even v then throw Forbidden else throw (NotFound v) text "this will never be reached" get "/random" $ do rBool <- liftIO randomIO i <- liftIO randomIO let catchOne Forbidden = html "

Forbidden was randomly thrown, but we caught it." - catchOne other = raise other - raise (if rBool then Forbidden else NotFound i) `rescue` catchOne + catchOne other = throw other + throw (if rBool then Forbidden else NotFound i) `rescue` catchOne diff --git a/examples/globalstate.hs b/examples/globalstate.hs index d0ff6fc9..7a433e0b 100644 --- a/examples/globalstate.hs +++ b/examples/globalstate.hs @@ -10,11 +10,10 @@ module Main (main) where import Control.Concurrent.STM +import Control.Monad.IO.Unlift (MonadUnliftIO(..)) import Control.Monad.Reader -import Data.Default.Class import Data.String -import Data.Text.Lazy (Text) import Network.Wai.Middleware.RequestLogger @@ -25,8 +24,8 @@ import Web.Scotty.Trans newtype AppState = AppState { tickCount :: Int } -instance Default AppState where - def = AppState 0 +defaultAppState :: AppState +defaultAppState = AppState 0 -- Why 'ReaderT (TVar AppState)' rather than 'StateT AppState'? -- With a state transformer, 'runActionToIO' (below) would have @@ -39,7 +38,7 @@ instance Default AppState where -- Also note: your monad must be an instance of 'MonadIO' for -- Scotty to use it. newtype WebM a = WebM { runWebM :: ReaderT (TVar AppState) IO a } - deriving (Applicative, Functor, Monad, MonadIO, MonadReader (TVar AppState)) + deriving (Applicative, Functor, Monad, MonadIO, MonadReader (TVar AppState), MonadUnliftIO) -- Scotty's monads are layered on top of our custom monad. -- We define this synonym for lift in order to be explicit @@ -56,7 +55,7 @@ modify f = ask >>= liftIO . atomically . flip modifyTVar' f main :: IO () main = do - sync <- newTVarIO def + sync <- newTVarIO defaultAppState -- 'runActionToIO' is called once per action. let runActionToIO m = runReaderT (runWebM m) sync @@ -66,7 +65,7 @@ main = do -- type is ambiguous. We can fix it by putting a type -- annotation just about anywhere. In this case, we'll -- just do it on the entire app. -app :: ScottyT Text WebM () +app :: ScottyT WebM () app = do middleware logStdoutDev get "/" $ do diff --git a/examples/options.hs b/examples/options.hs index ad4de68e..f29b1116 100644 --- a/examples/options.hs +++ b/examples/options.hs @@ -5,14 +5,13 @@ import Web.Scotty import Network.Wai.Middleware.RequestLogger -- install wai-extra if you don't have this -import Data.Default.Class (def) import Network.Wai.Handler.Warp (setPort) -- Set some Scotty settings opts :: Options -opts = def { verbose = 0 - , settings = setPort 4000 $ settings def - } +opts = defaultOptions { verbose = 0 + , settings = setPort 4000 $ settings defaultOptions + } -- This won't display anything at startup, and will listen on localhost:4000 main :: IO () diff --git a/examples/reader.hs b/examples/reader.hs index bda30e2e..b1f67258 100644 --- a/examples/reader.hs +++ b/examples/reader.hs @@ -8,11 +8,11 @@ module Main where import Control.Monad.Reader (MonadIO, MonadReader, ReaderT, asks, lift, runReaderT) -import Data.Default.Class (def) -import Data.Text.Lazy (Text, pack) +import Control.Monad.IO.Unlift (MonadUnliftIO(..)) +import Data.Text.Lazy (pack) import Prelude () import Prelude.Compat -import Web.Scotty.Trans (ScottyT, get, scottyOptsT, text) +import Web.Scotty.Trans (ScottyT, defaultOptions, get, scottyOptsT, text) data Config = Config { environment :: String @@ -20,16 +20,16 @@ data Config = Config newtype ConfigM a = ConfigM { runConfigM :: ReaderT Config IO a - } deriving (Applicative, Functor, Monad, MonadIO, MonadReader Config) + } deriving (Applicative, Functor, Monad, MonadIO, MonadReader Config, MonadUnliftIO) -application :: ScottyT Text ConfigM () +application :: ScottyT ConfigM () application = do get "/" $ do e <- lift $ asks environment text $ pack $ show e main :: IO () -main = scottyOptsT def runIO application where +main = scottyOptsT defaultOptions runIO application where runIO :: ConfigM a -> IO a runIO m = runReaderT (runConfigM m) config diff --git a/examples/scotty-examples.cabal b/examples/scotty-examples.cabal index 0e98cab3..de36659e 100644 --- a/examples/scotty-examples.cabal +++ b/examples/scotty-examples.cabal @@ -82,12 +82,12 @@ executable scotty-globalstate hs-source-dirs: . build-depends: base >= 4.6 && < 5, base-compat >= 0.11 && < 0.13, - data-default-class, mtl, scotty, stm, text, transformers, + unliftio-core >= 0.2, wai-extra GHC-options: -Wall -threaded @@ -105,7 +105,6 @@ executable scotty-options default-language: Haskell2010 hs-source-dirs: . build-depends: base >= 4.6 && < 5, - data-default-class, scotty, wai-extra, warp @@ -117,10 +116,10 @@ executable scotty-reader hs-source-dirs: . build-depends: base >= 4.6 && < 5, base-compat >= 0.11 && < 0.13, - data-default-class, mtl, scotty, - text + text, + unliftio-core >= 0.2 GHC-options: -Wall -threaded executable scotty-upload diff --git a/examples/urlshortener.hs b/examples/urlshortener.hs index c6e85e31..854e8108 100644 --- a/examples/urlshortener.hs +++ b/examples/urlshortener.hs @@ -1,12 +1,17 @@ {-# LANGUAGE OverloadedStrings #-} +{-# language DeriveAnyClass #-} +{-# language LambdaCase #-} +-- {-# language ScopedTypeVariables #-} module Main (main) where import Web.Scotty import Control.Concurrent.MVar +import Control.Exception (Exception(..)) import Control.Monad.IO.Class import qualified Data.Map as M import qualified Data.Text.Lazy as T +import Data.Typeable (Typeable) import Network.Wai.Middleware.RequestLogger import Network.Wai.Middleware.Static @@ -23,12 +28,17 @@ import Text.Blaze.Html5.Attributes import Text.Blaze.Html.Renderer.Text (renderHtml) -- TODO: --- Implement some kind of session and/or cookies +-- Implement some kind of session (#317) and/or cookies -- Add links +data SessionError = UrlHashNotFound Int deriving (Typeable, Exception) +instance Show SessionError where + show = \case + UrlHashNotFound hash -> unwords ["URL hash #", show hash, " not found in database!"] + main :: IO () main = do - m <- newMVar (0::Int,M.empty :: M.Map Int T.Text) + m <- newMVar (0::Int, M.empty :: M.Map Int T.Text) scotty 3000 $ do middleware logStdoutDev middleware static @@ -55,7 +65,7 @@ main = do hash <- captureParam "hash" (_,db) <- liftIO $ readMVar m case M.lookup hash db of - Nothing -> raise $ mconcat ["URL hash #", T.pack $ show $ hash, " not found in database!"] + Nothing -> throw $ UrlHashNotFound hash Just url -> redirect url -- We put /list down here to show that it will not match the '/:hash' route above. diff --git a/scotty.cabal b/scotty.cabal index a64eeb87..6a4de172 100644 --- a/scotty.cabal +++ b/scotty.cabal @@ -1,13 +1,13 @@ Name: scotty -Version: 0.12.1 +Version: 0.20 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 License: BSD3 License-file: LICENSE Author: Andrew Farmer -Maintainer: Andrew Farmer and the Scotty maintainers -Copyright: (c) 2012-Present Andrew Farmer +Maintainer: The Scotty maintainers +Copyright: (c) 2012-Present, Andrew Farmer and the Scotty contributors Category: Web Stability: experimental Build-type: Simple @@ -20,8 +20,6 @@ Description: . import Web.Scotty . - import Data.Monoid (mconcat) - . main = scotty 3000 $ get "/:word" $ do beam <- captureParam "word" @@ -66,6 +64,7 @@ Library Web.Scotty.Cookie other-modules: Web.Scotty.Action Web.Scotty.Body + Web.Scotty.Exceptions Web.Scotty.Route Web.Scotty.Util default-language: Haskell2010 @@ -76,18 +75,20 @@ Library bytestring >= 0.10.0.2 && < 0.12, case-insensitive >= 1.0.0.1 && < 1.3, cookie >= 0.4, - data-default-class >= 0.0.1 && < 0.2, + data-default-class >= 0.1, exceptions >= 0.7 && < 0.11, http-types >= 0.9.1 && < 0.13, monad-control >= 1.0.0.3 && < 1.1, mtl >= 2.1.2 && < 2.4, network >= 2.6.0.2 && < 3.2, regex-compat >= 0.95.1 && < 0.96, + stm, text >= 0.11.3.1 && < 2.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, warp >= 3.0.13 && < 3.4 @@ -109,7 +110,6 @@ test-suite spec build-depends: async, base, bytestring, - data-default-class, directory, hspec == 2.*, hspec-wai >= 0.6.3, @@ -134,7 +134,6 @@ benchmark weigh mtl, text, transformers, - data-default-class, weigh >= 0.0.16 && <0.1 GHC-options: -Wall -O2 -threaded diff --git a/test/Web/ScottySpec.hs b/test/Web/ScottySpec.hs index 943bc410..e2aa3646 100644 --- a/test/Web/ScottySpec.hs +++ b/test/Web/ScottySpec.hs @@ -24,7 +24,6 @@ import Control.Concurrent.Async (withAsync) import Control.Exception (bracketOnError) import qualified Data.ByteString as BS import Data.ByteString (ByteString) -import Data.Default.Class (def) import Network.Socket (Family(..), SockAddr(..), Socket, SocketOption(..), SocketType(..), bind, close, connect, listen, maxListenQueue, setSocketOption, socket) import Network.Socket.ByteString (send, recv) import System.Directory (removeFile) @@ -84,29 +83,29 @@ spec = do get "/" `shouldRespondWith` "

404: File Not Found!

" {matchStatus = 404} describe "defaultHandler" $ do - withApp (defaultHandler text >> Scotty.get "/" (liftAndCatchIO $ E.throwIO E.DivideByZero)) $ do + withApp (do + let h = Handler (\(e :: E.ArithException) -> status status500 >> text (TL.pack $ show e)) + defaultHandler h + Scotty.get "/" (throw E.DivideByZero)) $ do it "sets custom exception handler" $ do get "/" `shouldRespondWith` "divide by zero" {matchStatus = 500} - - withApp (defaultHandler (\_ -> status status503) >> Scotty.get "/" (liftAndCatchIO $ E.throwIO E.DivideByZero)) $ do + withApp (do + let h = Handler (\(_ :: E.ArithException) -> status status503) + defaultHandler h + Scotty.get "/" (liftAndCatchIO $ E.throwIO E.DivideByZero)) $ do it "allows to customize the HTTP status code" $ do get "/" `shouldRespondWith` "" {matchStatus = 503} context "when not specified" $ do - withApp (Scotty.get "/" $ liftAndCatchIO $ E.throwIO E.DivideByZero) $ do + withApp (Scotty.get "/" $ throw E.DivideByZero) $ do it "returns 500 on exceptions" $ do - get "/" `shouldRespondWith` "

500 Internal Server Error

divide by zero" {matchStatus = 500} + get "/" `shouldRespondWith` "" {matchStatus = 500} describe "setMaxRequestBodySize" $ do let large = TLE.encodeUtf8 . TL.pack . concat $ [show c | c <- ([1..4500]::[Integer])] smol = TLE.encodeUtf8 . TL.pack . concat $ [show c | c <- ([1..50]::[Integer])] - 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")] - large `shouldRespondWith` 200 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")] @@ -114,6 +113,12 @@ spec = do 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")] + large `shouldRespondWith` 200 + describe "ActionM" $ do context "MonadBaseControl instance" $ do @@ -122,13 +127,27 @@ spec = do get "/" `shouldRespondWith` 200 withApp (Scotty.get "/" $ EL.throwIO E.DivideByZero) $ do it "returns 500 on uncaught exceptions" $ do - get "/" `shouldRespondWith` "

500 Internal Server Error

divide by zero" {matchStatus = 500} - - withApp (Scotty.get "/dictionary" $ empty <|> queryParam "word1" <|> empty <|> queryParam "word2" >>= text) $ - it "has an Alternative instance" $ do - get "/dictionary?word1=haskell" `shouldRespondWith` "haskell" - get "/dictionary?word2=scotty" `shouldRespondWith` "scotty" - get "/dictionary?word1=a&word2=b" `shouldRespondWith` "a" + get "/" `shouldRespondWith` "" {matchStatus = 500} + + context "Alternative instance" $ do + withApp (Scotty.get "/" $ empty >>= text) $ + it "empty without any route following returns a 404" $ + get "/" `shouldRespondWith` 404 + withApp (Scotty.get "/dictionary" $ empty <|> queryParam "word1" >>= text) $ + it "empty throws Next" $ do + get "/dictionary?word1=x" `shouldRespondWith` "x" + withApp (Scotty.get "/dictionary" $ queryParam "word1" <|> empty <|> queryParam "word2" >>= text) $ + it "<|> skips the left route if that fails" $ do + get "/dictionary?word2=y" `shouldRespondWith` "y" + get "/dictionary?word1=a&word2=b" `shouldRespondWith` "a" + + describe "redirect" $ do + withApp ( + do + Scotty.get "/a" $ redirect "/b" + ) $ do + it "Responds with a 302 Redirect" $ do + get "/a" `shouldRespondWith` 302 { matchHeaders = ["Location" <:> "/b"] } describe "captureParam" $ do withApp ( @@ -159,6 +178,12 @@ spec = do ) $ do it "responds with 500 Server Error if the parameter cannot be found in the capture" $ do get "/search/potato" `shouldRespondWith` 500 + context "recover from missing parameter exception" $ do + withApp (Scotty.get "/search/:q" $ + (captureParam "z" >>= text) `rescue` (\(_::StatusError) -> text "z") + ) $ do + it "catches a StatusError" $ do + get "/search/xxx" `shouldRespondWith` 200 { matchBody = "z"} describe "queryParam" $ do withApp (Scotty.matchAny "/search" $ queryParam "query" >>= text) $ do @@ -171,20 +196,29 @@ spec = do get "/search?query=42" `shouldRespondWith` 200 it "responds with 400 Bad Request if the query parameter cannot be parsed at the right type" $ do get "/search?query=potato" `shouldRespondWith` 400 + context "recover from type mismatch parameter exception" $ do + withApp (Scotty.get "/search" $ + (queryParam "z" >>= (\v -> json (v :: Int))) `rescue` (\(_::StatusError) -> text "z") + ) $ do + it "catches a StatusError" $ do + get "/search?query=potato" `shouldRespondWith` 200 { matchBody = "z"} describe "formParam" $ do - withApp (Scotty.matchAny "/search" $ formParam "query" >>= text) $ do + let + postForm p bdy = request "POST" p [("Content-Type","application/x-www-form-urlencoded")] bdy + withApp (Scotty.post "/search" $ formParam "query" >>= text) $ do it "returns form parameter with given name" $ do - request "POST" "/search" [("Content-Type","application/x-www-form-urlencoded")] "query=haskell" `shouldRespondWith` "haskell" + postForm "/search" "query=haskell" `shouldRespondWith` "haskell" + it "replaces non UTF-8 bytes with Unicode replacement character" $ do - request "POST" "/search" [("Content-Type","application/x-www-form-urlencoded")] "query=\xe9" `shouldRespondWith` "\xfffd" - withApp (Scotty.matchAny "/search" (do + postForm "/search" "query=\xe9" `shouldRespondWith` "\xfffd" + withApp (Scotty.post "/search" (do v <- formParam "query" json (v :: Int))) $ do it "responds with 200 OK if the form parameter can be parsed at the right type" $ do - request "POST" "/search" [("Content-Type","application/x-www-form-urlencoded")] "query=42" `shouldRespondWith` 200 + postForm "/search" "query=42" `shouldRespondWith` 200 it "responds with 400 Bad Request if the form parameter cannot be parsed at the right type" $ do - request "POST" "/search" [("Content-Type","application/x-www-form-urlencoded")] "query=potato" `shouldRespondWith` 400 + postForm "/search" "query=potato" `shouldRespondWith` 400 withApp (do Scotty.post "/" $ next @@ -193,7 +227,13 @@ spec = do json p ) $ do it "preserves the body of a POST request even after 'next' (#147)" $ do - request "POST" "/" [("Content-Type","application/x-www-form-urlencoded")] "p=42" `shouldRespondWith` "42" + postForm "/" "p=42" `shouldRespondWith` "42" + context "recover from type mismatch parameter exception" $ do + withApp (Scotty.post "/search" $ + (formParam "z" >>= (\v -> json (v :: Int))) `rescue` (\(_::StatusError) -> text "z") + ) $ do + it "catches a StatusError" $ do + postForm "/search" "z=potato" `shouldRespondWith` 200 { matchBody = "z"} describe "text" $ do @@ -296,7 +336,7 @@ withServer :: ScottyM () -> IO a -> IO a withServer actions inner = E.bracket (listenOn socketPath) (\sock -> close sock >> removeFile socketPath) - (\sock -> withAsync (Scotty.scottySocket def sock actions) $ const inner) + (\sock -> withAsync (Scotty.scottySocket defaultOptions sock actions) $ const inner) -- See https://github.com/haskell/network/issues/318 listenOn :: String -> IO Socket