From f23514ff16d5a32d27ce106c84bd45d95dd8ff13 Mon Sep 17 00:00:00 2001
From: Jens Nolte <git@queezle.net>
Date: Thu, 26 Aug 2021 02:13:04 +0200
Subject: [PATCH] Add function to create nested ResourceManagers
---
src/Quasar/Async.hs | 16 ++++++++++++----
src/Quasar/Awaitable.hs | 3 ++-
src/Quasar/Disposable.hs | 13 ++++++++++---
src/Quasar/Observable.hs | 4 ++--
test/Quasar/DisposableSpec.hs | 5 ++---
5 files changed, 28 insertions(+), 13 deletions(-)
diff --git a/src/Quasar/Async.hs b/src/Quasar/Async.hs
index fdfd318..68d0aaf 100644
--- a/src/Quasar/Async.hs
+++ b/src/Quasar/Async.hs
@@ -111,6 +111,7 @@ instance MonadIO m => MonadAsync (ReaderT AsyncManager m) where
awaitResult :: IsAwaitable r a => AsyncIO a -> AsyncIO r
awaitResult = (await =<<)
+-- TODO rename to AsyncContext
data AsyncManager = AsyncManager {
resourceManager :: ResourceManager,
configuration :: AsyncManagerConfiguraiton,
@@ -190,9 +191,10 @@ unlimitedAsyncManagerConfiguration = AsyncManagerConfiguraiton {
}
withAsyncManager :: AsyncManagerConfiguraiton -> AsyncIO r -> IO r
-withAsyncManager configuration = bracket (newAsyncManager configuration) (awaitIO <=< dispose) . flip runOnAsyncManager
+withAsyncManager configuration = bracket (unsafeNewAsyncManager configuration) (awaitIO <=< dispose) . flip runOnAsyncManager
runOnAsyncManager :: AsyncManager -> AsyncIO r -> IO r
+-- TODO resource limits
runOnAsyncManager asyncManager (AsyncIO action) = runReaderT action asyncManager
withDefaultAsyncManager :: AsyncIO a -> IO a
@@ -201,9 +203,15 @@ withDefaultAsyncManager = withAsyncManager defaultAsyncManagerConfiguration
withUnlimitedAsyncManager :: AsyncIO a -> IO a
withUnlimitedAsyncManager = withAsyncManager unlimitedAsyncManagerConfiguration
-newAsyncManager :: AsyncManagerConfiguraiton -> IO AsyncManager
-newAsyncManager configuration = do
- resourceManager <- newResourceManager
+newAsyncManager :: ResourceManager -> AsyncManagerConfiguraiton -> IO AsyncManager
+newAsyncManager parent configuraton = mask_ do
+ asyncManager <- unsafeNewAsyncManager configuraton
+ attachDisposable parent asyncManager
+ pure asyncManager
+
+unsafeNewAsyncManager :: AsyncManagerConfiguraiton -> IO AsyncManager
+unsafeNewAsyncManager configuration = do
+ resourceManager <- unsafeNewResourceManager
threads <- newTVarIO mempty
pure AsyncManager {
resourceManager,
diff --git a/src/Quasar/Awaitable.hs b/src/Quasar/Awaitable.hs
index dd98b0a..c2aee3d 100644
--- a/src/Quasar/Awaitable.hs
+++ b/src/Quasar/Awaitable.hs
@@ -138,7 +138,8 @@ successfulAwaitable = completedAwaitable . Right
failedAwaitable :: SomeException -> Awaitable r
failedAwaitable = completedAwaitable . Left
--- | Create an awaitable from an `STM` transaction. The STM transaction should not have visible side effects.
+-- | Create an awaitable from an `STM` transaction. The STM transaction must always return the same result and should
+-- not have visible side effects.
--
-- Use `retry` to signal that the awaitable is not yet completed and `throwM`/`throwSTM` to set the awaitable to failed.
simpleAwaitable :: STM a -> Awaitable a
diff --git a/src/Quasar/Disposable.hs b/src/Quasar/Disposable.hs
index d35f01f..7378ee5 100644
--- a/src/Quasar/Disposable.hs
+++ b/src/Quasar/Disposable.hs
@@ -13,6 +13,7 @@ module Quasar.Disposable (
HasResourceManager(..),
withResourceManager,
newResourceManager,
+ unsafeNewResourceManager,
attachDisposable,
attachDisposeAction,
attachDisposeAction_,
@@ -227,10 +228,16 @@ instance IsDisposable ResourceManager where
((\disposed -> unless disposed retry) =<< readTVar (disposedVar resourceManager))
withResourceManager :: (ResourceManager -> IO a) -> IO a
-withResourceManager = bracket newResourceManager (awaitIO <=< dispose)
+withResourceManager = bracket unsafeNewResourceManager (awaitIO <=< dispose)
-newResourceManager :: IO ResourceManager
-newResourceManager = do
+newResourceManager :: ResourceManager -> IO ResourceManager
+newResourceManager parent = mask_ do
+ resourceManager <- unsafeNewResourceManager
+ attachDisposable parent resourceManager
+ pure resourceManager
+
+unsafeNewResourceManager :: IO ResourceManager
+unsafeNewResourceManager = do
disposingVar <- newTVarIO False
disposedVar <- newTVarIO False
exceptionVar <- newEmptyTMVarIO
diff --git a/src/Quasar/Observable.hs b/src/Quasar/Observable.hs
index e09b075..d7776f8 100644
--- a/src/Quasar/Observable.hs
+++ b/src/Quasar/Observable.hs
@@ -171,7 +171,7 @@ instance IsObservable r (BindObservable r) where
observe :: BindObservable r -> (ObservableMessage r -> IO ()) -> IO Disposable
observe (BindObservable fx fn) callback = do
-- Create a resource manager to ensure all subscriptions are cleaned up when disposing.
- resourceManager <- newResourceManager
+ resourceManager <- unsafeNewResourceManager
isDisposingVar <- newTVarIO False
disposableVar <- newTMVarIO noDisposable
@@ -239,7 +239,7 @@ instance IsObservable r (CatchObservable e r) where
observe :: CatchObservable e r -> (ObservableMessage r -> IO ()) -> IO Disposable
observe (CatchObservable fx fn) callback = do
-- Create a resource manager to ensure all subscriptions are cleaned up when disposing.
- resourceManager <- newResourceManager
+ resourceManager <- unsafeNewResourceManager
isDisposingVar <- newTVarIO False
disposableVar <- newTMVarIO noDisposable
diff --git a/test/Quasar/DisposableSpec.hs b/test/Quasar/DisposableSpec.hs
index 3bb1d13..b7c4bde 100644
--- a/test/Quasar/DisposableSpec.hs
+++ b/test/Quasar/DisposableSpec.hs
@@ -24,7 +24,6 @@ spec = parallel $ do
awaitIO (isDisposed noDisposable)
pure () :: IO ()
-
describe "newDisposable" $ do
it "signals it's disposed state" $ do
disposable <- newDisposable $ pure $ pure ()
@@ -47,10 +46,10 @@ spec = parallel $ do
describe "ResourceManager" $ do
it "can be created" $ do
- void newResourceManager
+ void unsafeNewResourceManager
it "can be created and disposed" $ do
- resourceManager <- newResourceManager
+ resourceManager <- unsafeNewResourceManager
awaitIO =<< dispose resourceManager
it "can be created and disposed" $ do
--
GitLab