diff --git a/src/Quasar/Async.hs b/src/Quasar/Async.hs index fdfd3189e9fcdc074cea87e6c34df94c1bbf34b2..68d0aaf314e013f9e85feec8d2049cd56d956ad3 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 dd98b0a57f6e037c36bbff3492122f345da967fb..c2aee3d3ce0575787b23c49b2fd65a075939b384 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 d35f01f023bd8ff5fd0f6462e2489b05775907b1..7378ee5b2ac3c1abe34a1360b7269860d7ca4e15 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 e09b0753fea8c3ab1c47a16298d43f376753dbb0..d7776f8c0b5c6cf1faeb51614eddfdd13e7d789a 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 3bb1d135da20fbd8b0ee59be965ecb5165906ecd..b7c4bdea17effd62fc256b90f382ca927b9a1c5f 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