From 72a2a2f66b87147c7f0583ea5980cf78788189c9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9ophile=20Choutri?= Date: Mon, 23 Jun 2025 15:21:12 +0200 Subject: [PATCH 1/2] Add MonadCatch and MonadMask instances to RouteResultT and DelayedIO Fix #1829 --- .../src/Servant/Server/Internal/DelayedIO.hs | 5 ++- .../Servant/Server/Internal/RouteResult.hs | 42 ++++++++++++++++++- 2 files changed, 45 insertions(+), 2 deletions(-) diff --git a/servant-server/src/Servant/Server/Internal/DelayedIO.hs b/servant-server/src/Servant/Server/Internal/DelayedIO.hs index c22e7e9d4..6d0ca2ecf 100644 --- a/servant-server/src/Servant/Server/Internal/DelayedIO.hs +++ b/servant-server/src/Servant/Server/Internal/DelayedIO.hs @@ -5,7 +5,7 @@ module Servant.Server.Internal.DelayedIO where import Control.Monad.Base (MonadBase (..)) -import Control.Monad.Catch (MonadThrow (..)) +import Control.Monad.Catch (MonadThrow (..), MonadCatch(..), MonadMask) import Control.Monad.Reader (MonadReader (..), ReaderT (..), runReaderT) import Control.Monad.Trans (MonadIO (..), MonadTrans (..)) import Control.Monad.Trans.Control (MonadBaseControl (..)) @@ -34,6 +34,8 @@ newtype DelayedIO a = DelayedIO {runDelayedIO' :: ReaderT Request (ResourceT (Ro , MonadReader Request , MonadResource , MonadThrow + , MonadCatch + , MonadMask ) instance MonadBase IO DelayedIO where @@ -53,6 +55,7 @@ instance MonadBaseControl IO DelayedIO where runInBase (runInternalState (runReaderT (runDelayedIO' x) req) s) restoreM = DelayedIO . lift . withInternalState . const . restoreM + runDelayedIO :: DelayedIO a -> Request -> ResourceT IO (RouteResult a) runDelayedIO m req = transResourceT runRouteResultT $ runReaderT (runDelayedIO' m) req diff --git a/servant-server/src/Servant/Server/Internal/RouteResult.hs b/servant-server/src/Servant/Server/Internal/RouteResult.hs index 86f5594c5..defa1862f 100644 --- a/servant-server/src/Servant/Server/Internal/RouteResult.hs +++ b/servant-server/src/Servant/Server/Internal/RouteResult.hs @@ -8,7 +8,7 @@ module Servant.Server.Internal.RouteResult where import Control.Monad (ap) import Control.Monad.Base (MonadBase (..)) -import Control.Monad.Catch (MonadThrow (..)) +import Control.Monad.Catch (ExitCase (..), MonadCatch (..), MonadMask (..), MonadThrow (..)) import Control.Monad.Trans (MonadIO (..), MonadTrans (..)) import Control.Monad.Trans.Control ( ComposeSt @@ -75,3 +75,43 @@ instance MonadTransControl RouteResultT where instance MonadThrow m => MonadThrow (RouteResultT m) where throwM = lift . throwM + +instance MonadCatch m => MonadCatch (RouteResultT m) where + catch (RouteResultT m) f = RouteResultT $ catch m (runRouteResultT . f) + +instance MonadMask m => MonadMask (RouteResultT m) where + mask f = RouteResultT $ mask $ \u -> runRouteResultT $ f (q u) + where + q + :: (m (RouteResult a) -> m (RouteResult a)) + -> RouteResultT m a + -> RouteResultT m a + q u (RouteResultT b) = RouteResultT (u b) + uninterruptibleMask f = RouteResultT $ uninterruptibleMask $ \u -> runRouteResultT $ f (q u) + where + q + :: (m (RouteResult a) -> m (RouteResult a)) + -> RouteResultT m a + -> RouteResultT m a + q u (RouteResultT b) = RouteResultT (u b) + + generalBracket acquire release use = RouteResultT $ do + (eb, ec) <- + generalBracket + (runRouteResultT acquire) + ( \resourceRoute exitCase -> case resourceRoute of + Fail e -> pure $ Fail e -- nothing to release, acquire didn't succeed + FailFatal e -> pure $ FailFatal e + Route resource -> case exitCase of + ExitCaseSuccess (Route b) -> runRouteResultT (release resource (ExitCaseSuccess b)) + ExitCaseException e -> runRouteResultT (release resource (ExitCaseException e)) + _ -> runRouteResultT (release resource ExitCaseAbort) + ) + ( \case + Fail e -> pure $ Fail e -- nothing to release, acquire didn't succeed + FailFatal e -> pure $ FailFatal e + Route resource -> runRouteResultT (use resource) + ) + -- The order in which we perform those two effects doesn't matter, + -- since the error message is the same regardless. + pure ((,) <$> eb <*> ec) From f18ff26b1a625f417134c527c4ad3251af66a6c1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9ophile=20Choutri?= Date: Mon, 23 Jun 2025 15:24:37 +0200 Subject: [PATCH 2/2] Add changelog entry --- changelog.d/issue-1829 | 4 ++++ servant-server/src/Servant/Server/Internal/DelayedIO.hs | 7 +++---- 2 files changed, 7 insertions(+), 4 deletions(-) create mode 100644 changelog.d/issue-1829 diff --git a/changelog.d/issue-1829 b/changelog.d/issue-1829 new file mode 100644 index 000000000..28d0f80cf --- /dev/null +++ b/changelog.d/issue-1829 @@ -0,0 +1,4 @@ +synopsis: Add MonadCatch and MonadMask instances to RouteResultT and DelayedIO +packages: servant-server +prs: #1830 +issues: #1829 diff --git a/servant-server/src/Servant/Server/Internal/DelayedIO.hs b/servant-server/src/Servant/Server/Internal/DelayedIO.hs index 6d0ca2ecf..cce86f423 100644 --- a/servant-server/src/Servant/Server/Internal/DelayedIO.hs +++ b/servant-server/src/Servant/Server/Internal/DelayedIO.hs @@ -5,7 +5,7 @@ module Servant.Server.Internal.DelayedIO where import Control.Monad.Base (MonadBase (..)) -import Control.Monad.Catch (MonadThrow (..), MonadCatch(..), MonadMask) +import Control.Monad.Catch (MonadCatch (..), MonadMask, MonadThrow (..)) import Control.Monad.Reader (MonadReader (..), ReaderT (..), runReaderT) import Control.Monad.Trans (MonadIO (..), MonadTrans (..)) import Control.Monad.Trans.Control (MonadBaseControl (..)) @@ -30,12 +30,12 @@ newtype DelayedIO a = DelayedIO {runDelayedIO' :: ReaderT Request (ResourceT (Ro ( Applicative , Functor , Monad + , MonadCatch , MonadIO + , MonadMask , MonadReader Request , MonadResource , MonadThrow - , MonadCatch - , MonadMask ) instance MonadBase IO DelayedIO where @@ -55,7 +55,6 @@ instance MonadBaseControl IO DelayedIO where runInBase (runInternalState (runReaderT (runDelayedIO' x) req) s) restoreM = DelayedIO . lift . withInternalState . const . restoreM - runDelayedIO :: DelayedIO a -> Request -> ResourceT IO (RouteResult a) runDelayedIO m req = transResourceT runRouteResultT $ runReaderT (runDelayedIO' m) req