From 900afc0332ab8cb2e410abe52d955069c72c0abf Mon Sep 17 00:00:00 2001
From: Jens Nolte <git@queezle.net>
Date: Wed, 3 Nov 2021 01:04:01 +0100
Subject: [PATCH] Improve some resource manager utility functions
Co-authored-by: Jan Beinke <git@janbeinke.com>
---
src/Quasar/Observable.hs | 6 +--
src/Quasar/ResourceManager.hs | 63 ++++++++++++++++++------------
test/Quasar/ResourceManagerSpec.hs | 4 +-
test/Quasar/SubscribableSpec.hs | 2 +-
4 files changed, 44 insertions(+), 31 deletions(-)
diff --git a/src/Quasar/Observable.hs b/src/Quasar/Observable.hs
index 9081e03..2ca45e6 100644
--- a/src/Quasar/Observable.hs
+++ b/src/Quasar/Observable.hs
@@ -105,8 +105,8 @@ class IsRetrievable v o => IsObservable v o | o -> v where
-- after it completes; when the value changes multiple times it will only be executed once (with the latest value).
observeBlocking :: (IsObservable v o, MonadResourceManager m) => o -> (ObservableMessage v -> m ()) -> m a
observeBlocking observable handler = do
- -- `withSubResourceManagerM` removes the `observe` callback when the `handler` fails.
- withSubResourceManagerM do
+ -- `withScopedResourceManager` removes the `observe` callback when the `handler` fails.
+ genericWithScopedResourceManager do
var <- liftIO newEmptyTMVarIO
observe observable \msg -> liftIO $ atomically do
void $ tryTakeTMVar var
@@ -292,7 +292,7 @@ instance IsObservable v (ObservableVar v) where
key <- liftIO newUnique
registerNewResource_ do
- let wrappedCallback = handleByResourceManager resourceManager . callback
+ let wrappedCallback = enterResourceManager resourceManager . callback
liftIO $ modifyMVar_ mvar $ \(state, subscribers) -> do
-- Call listener with initial value
diff --git a/src/Quasar/ResourceManager.hs b/src/Quasar/ResourceManager.hs
index 2a101f2..1a9a1ea 100644
--- a/src/Quasar/ResourceManager.hs
+++ b/src/Quasar/ResourceManager.hs
@@ -9,14 +9,14 @@ module Quasar.ResourceManager (
registerDisposable,
registerDisposeAction,
withScopedResourceManager,
- withScopedResourceManagerIO,
- withSubResourceManagerM,
+ genericWithScopedResourceManager,
onResourceManager,
captureDisposable,
captureDisposable_,
disposeOnError,
liftResourceManagerIO,
- handleByResourceManager,
+ enterResourceManager,
+ lockResourceManager,
-- ** Top level initialization
withRootResourceManager,
@@ -93,21 +93,21 @@ class IsDisposable a => IsResourceManager a where
attachDisposable :: (IsDisposable b, MonadIO m) => a -> b -> m ()
attachDisposable self = attachDisposable (toResourceManager self)
- lockResourceManager :: (IsDisposable b, MonadIO m, MonadMask m) => a -> m b -> m b
- lockResourceManager self = lockResourceManager (toResourceManager self)
+ lockResourceManagerImpl :: (MonadIO m, MonadMask m) => a -> m b -> m b
+ lockResourceManagerImpl self = lockResourceManagerImpl (toResourceManager self)
-- | Forward an exception that happened asynchronously.
throwToResourceManager :: Exception e => a -> e -> IO ()
throwToResourceManager = throwToResourceManager . toResourceManager
- {-# MINIMAL toResourceManager | (attachDisposable, lockResourceManager, throwToResourceManager) #-}
+ {-# MINIMAL toResourceManager | (attachDisposable, lockResourceManagerImpl, throwToResourceManager) #-}
data ResourceManager = forall a. IsResourceManager a => ResourceManager a
instance IsResourceManager ResourceManager where
toResourceManager = id
attachDisposable (ResourceManager x) = attachDisposable x
- lockResourceManager (ResourceManager x) = lockResourceManager x
+ lockResourceManagerImpl (ResourceManager x) = lockResourceManagerImpl x
throwToResourceManager (ResourceManager x) = throwToResourceManager x
instance IsDisposable ResourceManager where
toDisposable (ResourceManager x) = toDisposable x
@@ -120,6 +120,16 @@ class (MonadAwait m, MonadMask m, MonadIO m, MonadFix m) => MonadResourceManager
localResourceManager :: IsResourceManager a => a -> m r -> m r
+
+-- | Locks the resource manager. As long as the resource manager is locked, it's possible to register new resources
+-- on the resource manager.
+--
+-- This prevents the resource manager from disposing, so the computation must not block for an unbound amount of time.
+lockResourceManager :: MonadResourceManager m => m a -> m a
+lockResourceManager action = do
+ resourceManager <- askResourceManager
+ lockResourceManagerImpl resourceManager action
+
-- | Register a `Disposable` to the resource manager.
--
-- May throw an `FailedToRegisterResource` if the resource manager is disposing/disposed.
@@ -132,28 +142,27 @@ registerDisposable disposable = do
registerDisposeAction :: MonadResourceManager m => IO () -> m ()
registerDisposeAction disposeAction = mask_ $ registerDisposable =<< newDisposable disposeAction
+-- | Locks the resource manager (which may fail), runs the computation and registeres the resulting disposable.
+--
+-- The computation will be run in masked state.
+--
+-- The computation must not block for an unbound amount of time.
registerNewResource :: (IsDisposable a, MonadResourceManager m) => m a -> m a
-registerNewResource action = mask_ do
- resourceManager <- askResourceManager
- lockResourceManager resourceManager do
+registerNewResource action = mask_ $ lockResourceManager do
resource <- action
- attachDisposable resourceManager resource
+ registerDisposable resource
pure resource
registerNewResource_ :: (IsDisposable a, MonadResourceManager m) => m a -> m ()
registerNewResource_ action = void $ registerNewResource action
-withScopedResourceManager :: MonadResourceManager m => m a -> m a
+withScopedResourceManager :: MonadResourceManager m => ResourceManagerIO a -> m a
withScopedResourceManager action =
- bracket newResourceManager dispose \scope -> localResourceManager scope action
-
-withScopedResourceManagerIO :: MonadResourceManager m => ResourceManagerIO a -> m a
-withScopedResourceManagerIO action =
bracket newResourceManager dispose \scope -> onResourceManager scope action
-withSubResourceManagerM :: MonadResourceManager m => m a -> m a
-withSubResourceManagerM = withScopedResourceManager
-{-# DEPRECATED withSubResourceManagerM "Use `withScopedResourceManager` instead." #-}
+genericWithScopedResourceManager :: MonadResourceManager m => m a -> m a
+genericWithScopedResourceManager action =
+ bracket newResourceManager dispose \scope -> localResourceManager scope action
type ResourceManagerT = ReaderT ResourceManager
@@ -202,12 +211,16 @@ disposeOnError action = do
dispose
\resourceManager -> localResourceManager resourceManager action
--- | Run a computation and throw any exception that occurs to the resource manager.
+-- | Run a computation on a resource manager and throw any exception that occurs to the resource manager.
--
-- This can be used to run e.g. callbacks that belong to a different resource context.
-handleByResourceManager :: ResourceManager -> ResourceManagerIO () -> IO ()
-handleByResourceManager resourceManager action =
- onResourceManager resourceManager do
+--
+-- Locks the resource manager, so the computation must not block for an unbounded time.
+--
+-- May throw an exception when the resource manager is disposing.
+enterResourceManager :: MonadIO m => ResourceManager -> ResourceManagerIO () -> m ()
+enterResourceManager resourceManager action = liftIO do
+ onResourceManager resourceManager $ lockResourceManager do
action `catchAll` \ex -> liftIO $ throwToResourceManager resourceManager ex
@@ -220,7 +233,7 @@ data RootResourceManager
instance IsResourceManager RootResourceManager where
attachDisposable (RootResourceManager internal _ _ _) = attachDisposable internal
- lockResourceManager (RootResourceManager internal _ _ _) = lockResourceManager internal
+ lockResourceManagerImpl (RootResourceManager internal _ _ _) = lockResourceManagerImpl internal
throwToResourceManager (RootResourceManager _ _ exceptionsVar _) ex = do
-- TODO only log exceptions after a timeout
traceIO $ "Exception thrown to root resource manager: " <> displayException ex
@@ -329,7 +342,7 @@ instance IsResourceManager DefaultResourceManager where
putTMVar disposablesVar $ HM.delete key disposables
Nothing -> pure ()
- lockResourceManager DefaultResourceManager{stateVar, lockVar} =
+ lockResourceManagerImpl DefaultResourceManager{stateVar, lockVar} =
bracket_ (liftIO aquire) (liftIO release)
where
aquire :: IO ()
diff --git a/test/Quasar/ResourceManagerSpec.hs b/test/Quasar/ResourceManagerSpec.hs
index 9c7464a..0d31b58 100644
--- a/test/Quasar/ResourceManagerSpec.hs
+++ b/test/Quasar/ResourceManagerSpec.hs
@@ -65,14 +65,14 @@ spec = parallel $ do
it "passes an exception to the root resource manager" $ io do
(`shouldThrow` \(_ :: CombinedException) -> True) do
withRootResourceManager do
- withSubResourceManagerM do
+ withScopedResourceManager do
registerDisposeAction $ throwIO TestException
liftIO $ threadDelay 100000
it "passes an exception to the root resource manager when closing the inner resource manager first" $ io do
(`shouldThrow` \(_ :: CombinedException) -> True) do
withRootResourceManager do
- withSubResourceManagerM do
+ withScopedResourceManager do
registerDisposeAction $ throwIO TestException
liftIO $ threadDelay 100000
diff --git a/test/Quasar/SubscribableSpec.hs b/test/Quasar/SubscribableSpec.hs
index ca15528..deefbd4 100644
--- a/test/Quasar/SubscribableSpec.hs
+++ b/test/Quasar/SubscribableSpec.hs
@@ -25,7 +25,7 @@ spec = do
it "stops calling the callback after the subscription is disposed" $ io $ withRootResourceManager do
event <- newSubscribableEvent
resultVar <- liftIO $ newEmptyTMVarIO
- withSubResourceManagerM do
+ withScopedResourceManager do
subscribe event $ liftIO . \case
SubscribableUpdate r -> atomically (putTMVar resultVar r) >> mempty
SubscribableNotAvailable ex -> throwIO ex
--
GitLab