tests green

Web/Scotty/Action.hs

@@ -5,6 +5,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RankNTypes        #-}
 {-# LANGUAGE LambdaCase #-}
+{-# language ScopedTypeVariables #-}
 {-# options_ghc -Wno-unused-imports #-}
 module Web.Scotty.Action
     ( addHeader
@@ -92,33 +93,26 @@ import Web.Scotty.Exceptions (Handler(..), catch, catches, catchesOptionally, ca
 
 import Network.Wai.Internal (ResponseReceived(..))
 
--- | Nothing indicates route failed (due to Next) and pattern matching should continue.
--- Just indicates a successful response.
+-- | 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) -- ^ if present, this handler is in charge of user-defined exceptions
-          -> ActionEnv -> ActionT m () -> m (Maybe Response)
+             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 = [
-      scottyExceptionHandler
-      , actionErrorHandler
+      actionErrorHandler -- ActionError e.g. Next, 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
 
-
-{-|
-* ActionError should only be caught by runAction
-* handlers should not throw ActionError (= do not export ActionError constructors)
--}
-
-tryNext :: MonadUnliftIO m => m a -> m Bool
-tryNext io = catch (io >> pure True) $ \e ->
-  case e of
-    Next -> pure False
-    _ -> pure True
-
 -- | Exception handler in charge of 'ActionError'. Rethrowing 'Next' here is caught by 'tryNext'
 actionErrorHandler :: MonadIO m => ErrorHandler m
 actionErrorHandler = Handler $ \case
@@ -133,31 +127,16 @@ actionErrorHandler = Handler $ \case
   Next -> next
   Finish -> return ()
 
--- | Exception handler in charge of 'ScottyException'
-scottyExceptionHandler :: MonadIO m => ErrorHandler m
-scottyExceptionHandler = Handler $ \case
-  RequestException ebody s -> do
-    raiseStatus s (strictByteStringToLazyText ebody)
-
--- -- defH :: (Monad m) => ErrorHandler e m -> ActionError -> ActionT e m ()
--- defH :: MonadUnliftIO m => Maybe (AErr -> ActionT m ()) -> ActionError -> ActionT m ()
--- defH _          (Redirect url)    = do
---     status status302
---     setHeader "Location" url
--- defH Nothing    (ActionError s e)   = do
---     status s
---     let code = T.pack $ show $ statusCode s
---     let msg = T.fromStrict $ STE.decodeUtf8 $ statusMessage s
---     html $ mconcat ["<h1>", code, " ", msg, "</h1>", T.pack (show e)]
--- defH h@(Just f) (ActionError _ e)   = f e `catch` (defH h) -- so handlers can throw exceptions themselves -- TODO
--- defH _          Next              = next      -- rethrow 'Next'
--- defH _          Finish            = return () -- stop
+-- | Uncaught exceptions turn into HTTP 500 Server Error codes
+someExceptionHandler :: MonadIO m => ErrorHandler m
+someExceptionHandler = Handler $ \case
+  (_ :: E.SomeException) -> status status500
+
 
 -- | Throw an exception, which can be caught with 'rescue'. Uncaught exceptions
 -- turn into HTTP 500 responses.
--- raise :: (Monad m) => AErr -> ActionT m a
 raise :: (MonadIO m, E.Exception e) => e -> ActionT m a
-raise = E.throw -- raiseStatus status500
+raise = E.throw
 
 -- | Throw an exception, which 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

Web/Scotty/Body.hs

@@ -20,7 +20,7 @@ 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.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

Web/Scotty/Internal/Types.hs

@@ -29,7 +29,7 @@ import qualified Control.Monad.Fail as Fail
 import           Control.Monad.IO.Class (MonadIO(..))
 import Control.Monad.IO.Unlift (MonadUnliftIO(..))
 import           Control.Monad.Reader (MonadReader(..), ReaderT, mapReaderT, asks)
-import           Control.Monad.State.Strict (MonadState(..), State, StateT, mapStateT)
+import           Control.Monad.State.Strict (MonadState(..), State, StateT(..), mapStateT, execState)
 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
@@ -49,7 +49,7 @@ import qualified Network.Wai as Wai
 import           Network.Wai.Handler.Warp (Settings, defaultSettings)
 import           Network.Wai.Parse (FileInfo)
 
-import Web.Scotty.Exceptions (Handler, tryAny)
+import Web.Scotty.Exceptions (Handler, catch)
 
 import           Prelude ()
 import "base-compat-batteries" Prelude.Compat
@@ -136,6 +136,14 @@ data ActionError
   deriving (Show, Typeable)
 instance E.Exception ActionError
 
+tryNext :: MonadUnliftIO m => m a -> m Bool
+tryNext io = catch (io >> pure True) $ \e ->
+  case e of
+    Next -> pure False
+    _ -> pure True
+
+
+
 -- | Specializes a 'Handler' to the 'ActionT' monad
 type ErrorHandler m = Handler (ActionT m) ()
 
@@ -199,10 +207,15 @@ newtype ActionT m a = ActionT { runAM :: ReaderT ActionEnv m a }
 instance (MonadUnliftIO m) => Alternative (ActionT m) where
   empty = E.throw Next
   a <|> b = do
-    e <- tryAny a
-    case e of
-      Left _ -> b
-      Right ra -> pure ra
+    ok <- tryActionError a
+    if ok then a else b
+instance (MonadUnliftIO m) => MonadPlus (ActionT m) where
+  mzero = empty
+  mplus = (<|>)
+
+-- | an ActionError is thrown if e.g. a query parameter is not found, or 'next' is called
+tryActionError :: MonadUnliftIO m => m a -> m Bool
+tryActionError io = catch (io >> pure True) (\(_ :: ActionError) -> pure False)
 
 instance (Semigroup a) => Semigroup (ScottyT m a) where
   x <> y = (<>) <$> x <*> y

Web/Scotty/Route.hs

@@ -7,7 +7,7 @@ module Web.Scotty.Route
     ) where
 
 import           Control.Arrow ((***))
-import Control.Concurrent.STM (STM, TVar, atomically, newTVarIO)
+import Control.Concurrent.STM (newTVarIO)
 import           Control.Monad.IO.Class (MonadIO(..))
 import Control.Monad.IO.Unlift (MonadUnliftIO(..))
 import qualified Control.Monad.State as MS

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(..), Scotty.defaultOptions
+      scottyT, scottyAppT, scottyOptsT, scottySocketT, Options(..), defaultOptions
       -- * Defining Middleware and Routes
       --
       -- | 'Middleware' and routes are run in the order in which they
@@ -50,26 +51,23 @@ 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(..))
 import Web.Scotty.Util (socketDescription)
-import qualified Web.Scotty.Internal.Types as Scotty
 import Web.Scotty.Body (newBodyInfo)
-import Web.Scotty.Exceptions (Handler(..))
+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.
+        -> (m W.Response -> IO W.Response) -- ^ Run monad 'm' into 'IO', called at each action.
         -> ScottyT m ()
         -> n ()
 scottyT p = scottyOptsT $ defaultOptions { settings = setPort p (settings defaultOptions) }
@@ -78,7 +76,7 @@ scottyT p = scottyOptsT $ defaultOptions { settings = setPort p (settings defaul
 -- 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.
+            -> (m W.Response -> IO W.Response) -- ^ Run monad 'm' into 'IO', called at each action.
             -> ScottyT m ()
             -> n ()
 scottyOptsT opts runActionToIO s = do
@@ -92,7 +90,7 @@ scottyOptsT opts runActionToIO s = do
 scottySocketT :: (Monad m, MonadIO n)
               => Options
               -> Socket
-              -> (m Response -> IO Response)
+              -> (m W.Response -> IO W.Response)
               -> ScottyT m ()
               -> n ()
 scottySocketT opts sock runActionToIO s = do
@@ -105,35 +103,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.
+           => (m W.Response -> IO W.Response) -- ^ Run monad 'm' into 'IO', called at each action.
            -> ScottyT m ()
-           -> n Application
+           -> n W.Application
 scottyAppT runActionToIO defs = do
     let s = execState (runS defs) defaultScottyState
     let rapp req callback = do
           bodyInfo <- newBodyInfo req
-          runActionToIO (applyAll notFoundApp ([midd bodyInfo | midd <- routes s]) req) >>= callback
+          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 "<h1>404: File Not Found!</h1>"
 
 -- | Global handler for user-defined exceptions.
-defaultHandler :: (Monad m) => (ErrorHandler m) -> ScottyT m ()
+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 [] (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 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 m ()
-setMaxRequestBodySize i = assert (i > 0) $ ScottyT . modify . updateMaxRequestBodySize $ defaultRouteOptions { 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 }

changelog.md

@@ -6,11 +6,11 @@
 * Change body parsing behaviour such that calls to `next` don't result in POST request bodies disappearing (#147).
 * (Internal) Remove unused type `RequestBodyState` (#313)
 
-### Breaking:
+Breaking:
 * Get rid of data-default-class (#316) https://markkarpov.com/post/data-default.html
-* (#314) Rewrite `ActionT` as a `ReaderT`-over-`IO` (using the "ReaderT pattern" : https://www.fpcomplete.com/blog/readert-design-pattern/ )
-* (#314) Introduce `unliftio-core` as a dependency, and base exception handling on methods copied from `unliftio` e.g. `catch`.
-* (#314) All ActionT methods (`text`, `html` etc.) have now a MonadIO constraint on the base monad rather than Monad. `rescue` has a MonadUnliftIO constraint. The Alternative instance of ActionT also is based on MonadIO because `next` is implemented in terms of `throw`.
+* (#310) Rewrite `ActionT` as a `ReaderT`-over-`IO` (using the "ReaderT pattern" : https://www.fpcomplete.com/blog/readert-design-pattern/ )
+* (#310) Introduce `unliftio-core` as a dependency, and base exception handling on methods copied from `unliftio` e.g. `catch`.
+* (#310) All ActionT methods (`text`, `html` etc.) have now a MonadIO constraint on the base monad rather than Monad. `rescue` has a MonadUnliftIO constraint. The Alternative instance of ActionT also is based on MonadIO because `next` is implemented in terms of `throw`.
 
 ## 0.12.1 [2022.11.17]
 * Fix CPP bug that prevented tests from building on Windows.

examples/basic.hs

@@ -37,7 +37,7 @@ 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"
@@ -72,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"
@@ -106,6 +106,8 @@ main = scotty 3000 $ do
     -- 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

examples/globalstate.hs

@@ -13,9 +13,7 @@ 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
 
@@ -26,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
@@ -57,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
 

examples/reader.hs

@@ -9,7 +9,7 @@ module Main where
 
 import Control.Monad.Reader (MonadIO, MonadReader, ReaderT, asks, lift, runReaderT)
 import Control.Monad.IO.Unlift (MonadUnliftIO(..))
-import Data.Text.Lazy (Text, pack)
+import Data.Text.Lazy (pack)
 import Prelude ()
 import Prelude.Compat
 import Web.Scotty.Trans (ScottyT, defaultOptions, get, scottyOptsT, text)

examples/scotty-examples.cabal

@@ -82,7 +82,6 @@ executable scotty-globalstate
   hs-source-dirs:      .
   build-depends:       base >= 4.6 && < 5,
                        base-compat >= 0.11 && < 0.13,
-                       data-default-class,
                        mtl,
                        scotty,
                        stm,
@@ -106,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

examples/urlshortener.hs

@@ -28,7 +28,7 @@ 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)