fixme ScottyException handling still not working

Web/Scotty.hs

@@ -51,7 +51,8 @@ import Network.Socket (Socket)
 import Network.Wai (Application, Middleware, Request, StreamingBody)
 import Network.Wai.Handler.Warp (Port)
 
-import Web.Scotty.Internal.Types (ScottyT, ActionT, Handler(..), ErrorHandler, Param, RoutePattern, Options, defaultOptions, File, Kilobytes)
+import Web.Scotty.Internal.Types (ScottyT, ActionT, ErrorHandler, Param, RoutePattern, Options, defaultOptions, File, Kilobytes)
+import Web.Scotty.Exceptions (Handler(..))
 
 type ScottyM = ScottyT IO
 type ActionM = ActionT IO

Web/Scotty/Action.hs

@@ -88,21 +88,25 @@ import           Prelude ()
 import "base-compat-batteries" Prelude.Compat
 
 import           Web.Scotty.Internal.Types
-import           Web.Scotty.Util (mkResponse, addIfNotPresent, add, replace, lazyTextToStrictByteString, strictByteStringToLazyText, catch, catches, catchesOptionally, catchAny, try, tryAny)
+import           Web.Scotty.Util (mkResponse, addIfNotPresent, add, replace, lazyTextToStrictByteString, strictByteStringToLazyText)
+import Web.Scotty.Exceptions (Handler(..), catch, catches, catchesOptionally, catchAny, try, 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 :: MonadUnliftIO m =>
              Maybe (ErrorHandler m) -- ^ if present, this handler is in charge of user-defined exceptions
           -> ActionEnv -> ActionT m () -> m (Maybe Response)
 runAction mh env action = do
-  ok <- flip runReaderT env $ runAM $ tryNext (catchesOptionally action mh actionErrorHandler )
+  let
+    handlers = [
+      scottyExceptionHandler
+      , actionErrorHandler
+               ]
+  ok <- flip runReaderT env $ runAM $ tryNext (catchesOptionally action mh handlers )
   res <- getResponse env
   return $ bool Nothing (Just $ mkResponse res) ok
-  -- return $ either (const Nothing) (const $ Just $ mkResponse res) ei
 
 
 {-|
@@ -116,8 +120,8 @@ tryNext io = catch (io >> pure True) $ \e ->
     Next -> pure False
     _ -> pure True
 
--- | Error handler in charge of 'ActionError'. Rethrowing 'Next' here is caught by 'tryNext'
-actionErrorHandler :: MonadIO m => ErrorHandler m -- ActionError -> ActionT m ()
+-- | Exception handler in charge of 'ActionError'. Rethrowing 'Next' here is caught by 'tryNext'
+actionErrorHandler :: MonadIO m => ErrorHandler m
 actionErrorHandler = Handler $ \case
   Redirect url -> do
     status status302
@@ -130,6 +134,12 @@ 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

Web/Scotty/Exceptions.hs

@@ -0,0 +1,75 @@
+{-# LANGUAGE ExistentialQuantification #-}
+module Web.Scotty.Exceptions (
+  Handler(..)
+  -- * catching
+  , catch
+  , catchAny
+  , catches
+  , catchesOptionally
+  -- * trying
+  , try
+  , tryAny
+                             ) where
+
+import Control.Exception (Exception (..), SomeException (..), SomeAsyncException (..))
+import qualified Control.Exception as EUnsafe (fromException, throwIO, catch)
+import           Control.Monad.IO.Class (MonadIO(..))
+import Data.Maybe (maybeToList)
+
+import Control.Monad.IO.Unlift (MonadUnliftIO(..))
+
+-- | Handler for a specific type of exception, see 'handleActionError'
+data Handler m a = forall e . Exception e => Handler (e -> m a)
+instance Monad m => Functor (Handler m) where
+  fmap f (Handler h) = Handler (\e -> f <$> h e)
+
+
+-- exceptions
+
+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)
+
+catches :: MonadUnliftIO m => m a -> [Handler m a] -> m a
+catches io handlers = io `catch` catchesHandler handlers
+
+catchesHandler :: MonadIO m => [Handler m a] -> SomeException -> m a
+catchesHandler handlers e = foldr tryHandler (liftIO (EUnsafe.throwIO e)) handlers
+    where tryHandler (Handler h) res
+              = case EUnsafe.fromException e of
+                Just e' -> h e'
+                Nothing -> res
+
+-- | (from 'unliftio') Catch a synchronous (but not asynchronous) exception and recover from it.
+catch
+  :: (MonadUnliftIO m, Exception e)
+  => m a -- ^ action
+  -> (e -> m a) -- ^ handler
+  -> m a
+catch f g = withRunInIO $ \run -> run f `EUnsafe.catch` \e ->
+  if isSyncException e
+    then run (g e)
+    -- intentionally rethrowing an async exception synchronously,
+    -- since we want to preserve async behavior
+    else EUnsafe.throwIO e
+
+-- | 'catch' specialized to catch all synchronous exceptions.
+catchAny :: MonadUnliftIO m => m a -> (SomeException -> m a) -> m a
+catchAny = catch
+
+-- | (from 'safe-exceptions') Check if the given exception is synchronous
+isSyncException :: Exception e => e -> Bool
+isSyncException e =
+    case EUnsafe.fromException (toException e) of
+        Just (SomeAsyncException _) -> False
+        Nothing -> True
+
+try :: (MonadUnliftIO m, Exception e) => m a -> m (Either e a)
+try f = catch (Right <$> f) (pure . Left)
+
+-- | 'try' specialized to catch all synchronous exceptions.
+tryAny :: MonadUnliftIO m => m a -> m (Either SomeException a)
+tryAny = try

Web/Scotty/Internal/Types.hs

@@ -2,7 +2,8 @@
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE DerivingStrategies #-}
-{-# LANGUAGE ExistentialQuantification #-}
+{-# language DerivingVia #-}
+
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
@@ -48,6 +49,8 @@ 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           Prelude ()
 import "base-compat-batteries" Prelude.Compat
 
@@ -126,34 +129,10 @@ data ActionError
   | Next
   | Finish
   | StatusError Status Text -- e.g. 422 Unprocessable Entity when JSON body parsing fails
-  -- | SomeActionError Status AErr
   deriving (Show, Typeable)
 instance E.Exception ActionError
 
--- actionErrorHandler = Handler (\(e1 :: ActionError e))
-
--- | Handler for a specific type of exception, see 'handleActionError'
---
--- TODO export the constructor to the user since they will need to implement their
--- own handler
-data Handler m a = forall e . E.Exception e => Handler (e -> m a)
-instance Monad m => Functor (Handler m) where
-  fmap f (Handler h) = Handler (\e -> f <$> h e)
-
-
-
--- -- | FIXME placeholder for a more informative concrete error type
--- newtype AErr = AErr { aErrText :: Text } deriving (Show, Typeable)
--- instance E.Exception AErr
--- instance IsString AErr where
---   fromString = AErr . pack
-
 
--- -- | 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
 
 type ErrorHandler m = Handler (ActionT m) ()
 -- type ErrorHandler e m = Maybe (e -> ActionT e m ())
@@ -212,7 +191,14 @@ defaultScottyResponse = SR status200 [] (ContentBuilder mempty)
 
 
 newtype ActionT m a = ActionT { runAM :: ReaderT ActionEnv m a }
-  deriving newtype (Functor, Applicative, Alternative, Monad, MonadIO, MonadReader ActionEnv, MonadTrans, MonadThrow, MonadCatch, MonadBase b, MonadBaseControl b, MonadTransControl, MonadUnliftIO)
+  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 Next
+  a <|> b = do
+    e <- tryAny a
+    case e of
+      Left _ -> b
+      Right ra -> pure ra
 
 instance (Semigroup a) => Semigroup (ScottyT m a) where
   x <> y = (<>) <$> x <*> y

Web/Scotty/Util.hs

@@ -8,13 +8,6 @@ module Web.Scotty.Util
     , addIfNotPresent
     , socketDescription
     , readRequestBody
-    -- * exceptions
-    , catch
-    , catches
-    , catchesOptionally
-    , catchAny
-    , try
-    , tryAny
     ) where
 
 import Network.Socket (SockAddr(..), Socket, getSocketName, socketPort)
@@ -25,7 +18,7 @@ import           Control.Monad.IO.Class (MonadIO(..))
 import Control.Monad.IO.Unlift (MonadUnliftIO(..))
 import Control.Exception (Exception (..), SomeException (..), IOException, SomeAsyncException (..))
 import qualified Control.Exception as EUnsafe (fromException, throw, throwIO, catch)
-import Data.Maybe (maybeToList)
+
 
 import Network.HTTP.Types
 
@@ -106,51 +99,4 @@ readRequestBody rbody prefix maxSize = do
               else readUntilEmpty
 
 
--- exceptions
-
-catchesOptionally :: MonadUnliftIO m =>
-                     m a
-                  -> Maybe (Handler m a) -- ^ if present, this 'Handler' is tried first
-                  -> Handler m a -> m a
-catchesOptionally io mh h = io `catches` (maybeToList mh <> [h])
-
-catches :: MonadUnliftIO m => m a -> [Handler m a] -> m a
-catches io handlers = io `catch` catchesHandler handlers
-
-catchesHandler :: MonadIO m => [Handler m a] -> SomeException -> m a
-catchesHandler handlers e = foldr tryHandler (liftIO (EUnsafe.throwIO e)) handlers
-    where tryHandler (Handler h) res
-              = case EUnsafe.fromException e of
-                Just e' -> h e'
-                Nothing -> res
-
--- | (from 'unliftio') Catch a synchronous (but not asynchronous) exception and recover from it.
-catch
-  :: (MonadUnliftIO m, Exception e)
-  => m a -- ^ action
-  -> (e -> m a) -- ^ handler
-  -> m a
-catch f g = withRunInIO $ \run -> run f `EUnsafe.catch` \e ->
-  if isSyncException e
-    then run (g e)
-    -- intentionally rethrowing an async exception synchronously,
-    -- since we want to preserve async behavior
-    else EUnsafe.throwIO e
-
--- | 'catch' specialized to catch all synchronous exceptions.
-catchAny :: MonadUnliftIO m => m a -> (SomeException -> m a) -> m a
-catchAny = catch
-
--- | (from 'safe-exceptions') Check if the given exception is synchronous
-isSyncException :: Exception e => e -> Bool
-isSyncException e =
-    case EUnsafe.fromException (toException e) of
-        Just (SomeAsyncException _) -> False
-        Nothing -> True
-
-try :: (MonadUnliftIO m, Exception e) => m a -> m (Either e a)
-try f = catch (Right <$> f) (pure . Left)
-
--- | 'try' specialized to catch all synchronous exceptions.
-tryAny :: MonadUnliftIO m => m a -> m (Either SomeException a)
-tryAny = try
+

scotty.cabal

@@ -66,6 +66,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

test/Web/ScottySpec.hs

@@ -83,12 +83,13 @@ spec = do
           it "returns 404 when no route matches" $ do
             get "/" `shouldRespondWith` "<h1>404: File Not Found!</h1>" {matchStatus = 404}
 
-    -- describe "defaultHandler" $ do
-    --   withApp (defaultHandler text >> Scotty.get "/" (liftAndCatchIO $ E.throwIO E.DivideByZero)) $ do
-    --     it "sets custom exception handler" $ do
-    --       get "/" `shouldRespondWith` "divide by zero" {matchStatus = 500}
-
     describe "defaultHandler" $ do
+      withApp (do
+                  let h = Handler (\(e :: E.ArithException) -> text (TL.pack $ show e))
+                  defaultHandler h
+                  Scotty.get "/" (liftAndCatchIO $ E.throwIO E.DivideByZero)) $ do
+        it "sets custom exception handler" $ do
+          get "/" `shouldRespondWith` "divide by zero" {matchStatus = 500}
       withApp (do
                   let h = Handler (\(e :: E.ArithException) -> status status503)
                   defaultHandler h