From e6596b26c57fdebc95f058b04e68e892da9f12e5 Mon Sep 17 00:00:00 2001
From: Jens Nolte <git@queezle.net>
Date: Mon, 4 Oct 2021 20:08:57 +0200
Subject: [PATCH] Update withRootResourceManager and related functions (WIP)
Co-authored-by: Jan Beinke <git@janbeinke.com>
---
src/Quasar/Observable.hs | 8 +--
src/Quasar/ResourceManager.hs | 89 +++++++-----------------------
test/Quasar/AsyncSpec.hs | 6 +-
test/Quasar/ObservableSpec.hs | 2 +-
test/Quasar/ResourceManagerSpec.hs | 87 +++++++++++++----------------
test/Quasar/SubscribableSpec.hs | 8 +--
6 files changed, 70 insertions(+), 130 deletions(-)
diff --git a/src/Quasar/Observable.hs b/src/Quasar/Observable.hs
index cac15b3..c53b622 100644
--- a/src/Quasar/Observable.hs
+++ b/src/Quasar/Observable.hs
@@ -78,7 +78,7 @@ class IsRetrievable v a | a -> v where
-- TODO remove
retrieveIO :: IsRetrievable v a => a -> IO v
-retrieveIO x = withResourceManagerM $ await =<< retrieve x
+retrieveIO x = withRootResourceManager $ await =<< retrieve x
class IsRetrievable v o => IsObservable v o | o -> v where
-- | Register a callback to observe changes. The callback is called when the value changes, but depending on the
@@ -103,7 +103,7 @@ class IsRetrievable v o => IsObservable v o | o -> v where
-- | Old signature of `observe`, will be removed from the class once it's no longer used for implementations.
oldObserve :: o -> (ObservableMessage v -> IO ()) -> IO Disposable
oldObserve observable callback = do
- resourceManager <- newUnmanagedResourceManager
+ resourceManager <- newUnmanagedRootResourceManager
onResourceManager resourceManager do
observe observable $ \msg -> liftIO (callback msg)
pure $ toDisposable resourceManager
@@ -232,7 +232,7 @@ instance IsObservable r (BindObservable r) where
oldObserve :: BindObservable r -> (ObservableMessage r -> IO ()) -> IO Disposable
oldObserve (BindObservable fx fn) callback = do
-- Create a resource manager to ensure all subscriptions are cleaned up when disposing.
- resourceManager <- newUnmanagedResourceManager
+ resourceManager <- newUnmanagedRootResourceManager
isDisposingVar <- newTVarIO False
disposableVar <- newTMVarIO noDisposable
@@ -300,7 +300,7 @@ instance IsObservable r (CatchObservable e r) where
oldObserve :: CatchObservable e r -> (ObservableMessage r -> IO ()) -> IO Disposable
oldObserve (CatchObservable fx fn) callback = do
-- Create a resource manager to ensure all subscriptions are cleaned up when disposing.
- resourceManager <- newUnmanagedResourceManager
+ resourceManager <- newUnmanagedRootResourceManager
isDisposingVar <- newTVarIO False
disposableVar <- newTMVarIO noDisposable
diff --git a/src/Quasar/ResourceManager.hs b/src/Quasar/ResourceManager.hs
index 38f4858..8717737 100644
--- a/src/Quasar/ResourceManager.hs
+++ b/src/Quasar/ResourceManager.hs
@@ -22,19 +22,12 @@ module Quasar.ResourceManager (
-- ** Initialization
withRootResourceManager,
- withRootResourceManagerM,
- CancelLinkedThread(..),
- LinkedThreadDisposed(..),
+ CancelLinkedThread,
-- ** Resource manager implementations
newUnmanagedRootResourceManager,
--newUnmanagedDefaultResourceManager,
-
- -- ** Deprecated
- withResourceManager,
- withResourceManagerM,
- newUnmanagedResourceManager,
) where
@@ -58,7 +51,7 @@ data FailedToRegisterResource = FailedToRegisterResource
instance Exception FailedToRegisterResource where
displayException FailedToRegisterResource =
- "Failed to register a resource to a resource manager. This might result in leaked resources if left unhandled."
+ "FailedToRegisterResource: Failed to register a resource to a resource manager. This might result in leaked resources if left unhandled."
-- | Internal entry of `ResourceManager`. The `TMVar` will be set to `Nothing` when the disposable has completed disposing.
newtype ResourceManagerEntry = ResourceManagerEntry (TMVar (Awaitable (), Disposable))
@@ -195,56 +188,23 @@ loggingExceptionHandler :: ExceptionHandler
loggingExceptionHandler ex = traceIO $ displayException ex
-data CancelLinkedThread = CancelLinkedThread
- deriving stock Show
- deriving anyclass Exception
-
-data LinkedThreadDisposed = LinkedThreadDisposed
- deriving stock Show
+-- | A computation bound to a resource manager with 'linkThread' should be canceled.
+data CancelLinkedThread = CancelLinkedThread Unique
deriving anyclass Exception
+instance Show CancelLinkedThread where
+ show _ = "CancelLinkedThread"
-data CancelHelper = CancelHelper
- deriving stock Show
- deriving anyclass Exception
-
-
-withLinkedExceptionHandler :: (MonadAwait m, MonadMask m, MonadIO m) => ExceptionHandler -> (ExceptionHandler -> m a) -> m a
-withLinkedExceptionHandler parentExceptionHandler action = do
- shouldCancelVar <- liftIO $ newTVarIO False
- let
- exceptionHandler :: ExceptionHandler
- exceptionHandler ex = do
- parentExceptionHandler ex
- atomically $ writeTVar shouldCancelVar True
- cancelThread :: ThreadId -> (IO () -> IO ()) -> IO ()
- cancelThread mainThreadId unmask =
- do
- unmask do
- atomically $ check =<< readTVar shouldCancelVar
- throwTo mainThreadId CancelLinkedThread
- `catch`
- \CancelHelper -> pure ()
-
- mainThreadId <- liftIO myThreadId
- mask \unmask ->
- do
- bracket
- do liftIO $ forkIOWithUnmask \unmask -> cancelThread mainThreadId unmask
- do \cancelThreadId -> liftIO $ throwTo cancelThreadId CancelHelper
- do \_ -> unmask $ action exceptionHandler
- `catch`
- \CancelLinkedThread -> throwM LinkedThreadDisposed
-
-
-withRootExceptionHandler :: (MonadAwait m, MonadMask m, MonadIO m) => (ExceptionHandler -> m a) -> m a
-withRootExceptionHandler = withLinkedExceptionHandler loggingExceptionHandler
+data LinkState = LinkStateLinked ThreadId | LinkStateThrowing | LinkStateCompleted
+ deriving Eq
-- * Resource manager implementations
+newtype CombinedException = CombinedException [SomeException]
+
data RootResourceManager = RootResourceManager ResourceManager ExceptionHandler
instance IsResourceManager RootResourceManager where
@@ -257,18 +217,19 @@ instance IsDisposable RootResourceManager where
dispose (RootResourceManager child _) = dispose child
isDisposed (RootResourceManager child _) = isDisposed child
-withRootResourceManager :: (MonadAwait m, MonadMask m, MonadIO m) => (ResourceManager -> m a) -> m a
-withRootResourceManager action = withRootExceptionHandler \exceptionHandler ->
- bracket (newUnmanagedRootResourceManager exceptionHandler) (await <=< liftIO . dispose) action
+withRootResourceManager :: (MonadAwait m, MonadMask m, MonadIO m) => ReaderT ResourceManager IO a -> m a
+withRootResourceManager action =
+ bracket
+ newUnmanagedRootResourceManager
+ (await <=< liftIO . dispose)
+ (`onResourceManager` action)
-withRootResourceManagerM :: (MonadAwait m, MonadMask m, MonadIO m) => ReaderT ResourceManager IO a -> m a
-withRootResourceManagerM action = withRootResourceManager (`onResourceManager` action)
-newUnmanagedRootResourceManager :: MonadIO m => ExceptionHandler -> m ResourceManager
-newUnmanagedRootResourceManager exceptionHandler = liftIO $ fixIO \self -> do
+newUnmanagedRootResourceManager :: MonadIO m => m ResourceManager
+newUnmanagedRootResourceManager = liftIO $ fixIO \self -> do
var <- liftIO newEmptyTMVarIO
childResourceManager <- newUnmanagedDefaultResourceManager self
- pure $ toResourceManager (RootResourceManager childResourceManager exceptionHandler)
+ pure $ toResourceManager (RootResourceManager childResourceManager loggingExceptionHandler)
data DefaultResourceManager = DefaultResourceManager {
@@ -325,18 +286,6 @@ instance IsDisposable DefaultResourceManager where
disposed <- readTVar (disposedVar resourceManager)
unless disposed retry
-{-# DEPRECATED withResourceManager "Use withRootResourceManager insted" #-}
-withResourceManager :: (MonadAwait m, MonadMask m, MonadIO m) => (ResourceManager -> m a) -> m a
-withResourceManager = withRootResourceManager
-
-{-# DEPRECATED withResourceManagerM "Use withRootResourceManagerM insted" #-}
-withResourceManagerM :: (MonadAwait m, MonadMask m, MonadIO m) => ReaderT ResourceManager IO a -> m a
-withResourceManagerM = withRootResourceManagerM
-
-{-# DEPRECATED newUnmanagedResourceManager "Use newUnmanagedRootResourceManager insted" #-}
-newUnmanagedResourceManager :: MonadIO m => m ResourceManager
-newUnmanagedResourceManager = newUnmanagedRootResourceManager loggingExceptionHandler
-
newResourceManager :: MonadResourceManager m => m ResourceManager
newResourceManager = mask_ do
parent <- askResourceManager
diff --git a/test/Quasar/AsyncSpec.hs b/test/Quasar/AsyncSpec.hs
index fe2c7f4..2a7bf76 100644
--- a/test/Quasar/AsyncSpec.hs
+++ b/test/Quasar/AsyncSpec.hs
@@ -15,10 +15,10 @@ spec :: Spec
spec = parallel $ do
describe "async" $ do
it "can pass a value through async and await" $ do
- withResourceManagerM (runUnlimitedAsync (await =<< async (pure 42))) `shouldReturn` (42 :: Int)
+ withRootResourceManager (runUnlimitedAsync (await =<< async (pure 42))) `shouldReturn` (42 :: Int)
it "can pass a value through async and await" $ do
- withResourceManagerM (runUnlimitedAsync (await =<< async (liftIO (threadDelay 100000) >> pure 42))) `shouldReturn` (42 :: Int)
+ withRootResourceManager (runUnlimitedAsync (await =<< async (liftIO (threadDelay 100000) >> pure 42))) `shouldReturn` (42 :: Int)
describe "await" $ do
it "can await the result of an async that is completed later" $ do
@@ -34,6 +34,6 @@ spec = parallel $ do
it "can terminate when encountering an asynchronous exception" $ do
never <- newAsyncVar :: IO (AsyncVar ())
- result <- timeout 100000 $ withResourceManagerM $
+ result <- timeout 100000 $ withRootResourceManager $
await never
result `shouldBe` Nothing
diff --git a/test/Quasar/ObservableSpec.hs b/test/Quasar/ObservableSpec.hs
index 53d9e07..0532dba 100644
--- a/test/Quasar/ObservableSpec.hs
+++ b/test/Quasar/ObservableSpec.hs
@@ -19,7 +19,7 @@ observableSpec = parallel do
it "works" $ io do
shouldReturn
do
- withResourceManagerM do
+ withRootResourceManager do
observeWhile (pure () :: Observable ()) toObservableUpdate
()
diff --git a/test/Quasar/ResourceManagerSpec.hs b/test/Quasar/ResourceManagerSpec.hs
index 640fcee..3d4f084 100644
--- a/test/Quasar/ResourceManagerSpec.hs
+++ b/test/Quasar/ResourceManagerSpec.hs
@@ -18,80 +18,71 @@ spec :: Spec
spec = parallel $ do
describe "ResourceManager" $ do
it "can be created" $ io do
- void newUnmanagedResourceManager
+ void newUnmanagedRootResourceManager
it "can be created and disposed" $ io do
- resourceManager <- newUnmanagedResourceManager
+ resourceManager <- newUnmanagedRootResourceManager
await =<< dispose resourceManager
it "can be created and disposed" $ io do
- withResourceManager \_ -> pure ()
+ withRootResourceManager $ pure ()
- it "can be created and disposed with a delay" $ do
- withResourceManager \_ -> threadDelay 100000
+ it "can be created and disposed with a delay" $ io do
+ withRootResourceManager $ liftIO $ threadDelay 100000
it "can \"dispose\" a noDisposable" $ io do
- withResourceManager \resourceManager -> do
- attachDisposable resourceManager noDisposable
+ withRootResourceManager do
+ registerDisposable noDisposable
- it "can attach an disposable" $ do
- withResourceManager \resourceManager -> do
- avar <- newAsyncVar :: IO (AsyncVar ())
- attachDisposable resourceManager $ alreadyDisposing avar
+ it "can attach an disposable" $ io do
+ withRootResourceManager do
+ avar <- newAsyncVar
+ registerDisposable $ alreadyDisposing avar
putAsyncVar_ avar ()
- pure () :: IO ()
- it "can dispose an awaitable that is completed asynchronously" $ do
- avar <- newAsyncVar :: IO (AsyncVar ())
+ it "can dispose an awaitable that is completed asynchronously" $ io do
+ avar <- newAsyncVar
void $ forkIO $ do
threadDelay 100000
putAsyncVar_ avar ()
- withResourceManager \resourceManager -> do
- attachDisposable resourceManager (alreadyDisposing avar)
+ withRootResourceManager do
+ registerDisposable (alreadyDisposing avar)
- it "can call a trivial dispose action" $ do
- withResourceManager \resourceManager ->
- attachDisposeAction_ resourceManager $ pure $ pure ()
- pure () :: IO ()
+ it "can call a trivial dispose action" $ io do
+ withRootResourceManager do
+ registerDisposeAction $ pure $ pure ()
- it "can call a dispose action" $ do
- withResourceManager \resourceManager -> do
- avar <- newAsyncVar :: IO (AsyncVar ())
- attachDisposeAction_ resourceManager $ toAwaitable avar <$ putAsyncVar_ avar ()
- pure () :: IO ()
+ it "can call a dispose action" $ io do
+ withRootResourceManager do
+ avar <- newAsyncVar
+ registerDisposeAction $ toAwaitable avar <$ putAsyncVar_ avar ()
it "re-throws an exception" $ do
shouldThrow
do
- withResourceManager \_ ->
- throwIO TestException
+ withRootResourceManager do
+ liftIO $ throwIO TestException
\TestException -> True
- it "cancels the main thread when a dispose action fails" $ do
- shouldThrow
- do
- withRootResourceManagerM do
- withSubResourceManagerM do
- registerDisposeAction $ throwIO TestException
- liftIO $ threadDelay 100000
- fail "Did not stop main thread on failing dispose action"
- \LinkedThreadDisposed -> True
-
- it "can attach an disposable that is disposed asynchronously" $ do
- withResourceManager \resourceManager -> do
- disposable <- attachDisposeAction resourceManager $ pure () <$ threadDelay 100000
- void $ forkIO $ disposeAndAwait disposable
+ it "cancels the main thread when a dispose action fails" $ io @() do
+ withRootResourceManager do
+ withSubResourceManagerM do
+ registerDisposeAction $ throwIO TestException
+ liftIO $ threadDelay 100000
+ fail "Did not stop main thread on failing dispose action"
+
+ it "can attach an disposable that is disposed asynchronously" $ io do
+ withRootResourceManager do
+ disposable <- captureDisposable_ $ registerDisposeAction $ pure () <$ threadDelay 100000
+ liftIO $ void $ forkIO $ await =<< dispose disposable
it "does not abort when encountering an exception" $ do
var1 <- newTVarIO False
var2 <- newTVarIO False
- shouldThrow
- do
- withRootResourceManagerM do
- registerDisposeAction $ pure () <$ (atomically (writeTVar var1 True))
- registerDisposeAction $ pure () <$ throwIO TestException
- registerDisposeAction $ pure () <$ (atomically (writeTVar var2 True))
- \LinkedThreadDisposed -> True
+ withRootResourceManager do
+ registerDisposeAction $ pure () <$ (atomically (writeTVar var1 True))
+ registerDisposeAction $ pure () <$ throwIO TestException
+ registerDisposeAction $ pure () <$ (atomically (writeTVar var2 True))
atomically (readTVar var1) `shouldReturn` True
atomically (readTVar var2) `shouldReturn` True
diff --git a/test/Quasar/SubscribableSpec.hs b/test/Quasar/SubscribableSpec.hs
index c9ca1bc..ca15528 100644
--- a/test/Quasar/SubscribableSpec.hs
+++ b/test/Quasar/SubscribableSpec.hs
@@ -13,7 +13,7 @@ spec :: Spec
spec = do
describe "SubscribableEvent" $ parallel do
- it "can be subscribed" $ io $ withResourceManagerM do
+ it "can be subscribed" $ io $ withRootResourceManager do
event <- newSubscribableEvent
resultVar <- liftIO newEmptyTMVarIO
subscribe event $ liftIO . \case
@@ -22,7 +22,7 @@ spec = do
raiseSubscribableEvent event (42 :: Int)
liftIO $ atomically (tryTakeTMVar resultVar) `shouldReturn` Just 42
- it "stops calling the callback after the subscription is disposed" $ io $ withResourceManagerM do
+ it "stops calling the callback after the subscription is disposed" $ io $ withRootResourceManager do
event <- newSubscribableEvent
resultVar <- liftIO $ newEmptyTMVarIO
withSubResourceManagerM do
@@ -34,7 +34,7 @@ spec = do
raiseSubscribableEvent event (21 :: Int)
liftIO $ atomically (tryTakeTMVar resultVar) `shouldReturn` Nothing
- it "can be fmap'ed" $ io $ withResourceManagerM do
+ it "can be fmap'ed" $ io $ withRootResourceManager do
event <- newSubscribableEvent
let subscribable = (* 2) <$> toSubscribable event
resultVar <- liftIO $ newEmptyTMVarIO
@@ -44,7 +44,7 @@ spec = do
raiseSubscribableEvent event (21 :: Int)
liftIO $ atomically (tryTakeTMVar resultVar) `shouldReturn` Just 42
- it "can be combined with other events" $ io $ withResourceManagerM do
+ it "can be combined with other events" $ io $ withRootResourceManager do
event1 <- newSubscribableEvent
event2 <- newSubscribableEvent
let subscribable = toSubscribable event1 <> toSubscribable event2
--
GitLab