From cc6af12e1f77a769a2b1582f9cd476aa68f18049 Mon Sep 17 00:00:00 2001
From: Jens Nolte <git@queezle.net>
Date: Sun, 3 Oct 2021 22:48:18 +0200
Subject: [PATCH] Add dedicated exceptions for linked resource manager threads
Co-authored-by: Jan Beinke <git@janbeinke.com>
---
quasar.cabal | 1 +
src/Quasar/Disposable.hs | 1 +
src/Quasar/Observable.hs | 1 +
src/Quasar/ResourceManager.hs | 24 ++++++--
test/Quasar/DisposableSpec.hs | 73 ----------------------
test/Quasar/ResourceManagerSpec.hs | 97 ++++++++++++++++++++++++++++++
6 files changed, 119 insertions(+), 78 deletions(-)
create mode 100644 test/Quasar/ResourceManagerSpec.hs
diff --git a/quasar.cabal b/quasar.cabal
index ddd2245..e0c9da8 100644
--- a/quasar.cabal
+++ b/quasar.cabal
@@ -117,6 +117,7 @@ test-suite quasar-test
Quasar.ObservableSpec
Quasar.Observable.ObservableHashMapSpec
Quasar.Observable.ObservablePrioritySpec
+ Quasar.ResourceManagerSpec
Quasar.SubscribableSpec
hs-source-dirs:
test
diff --git a/src/Quasar/Disposable.hs b/src/Quasar/Disposable.hs
index 8a6e3d4..3e0329e 100644
--- a/src/Quasar/Disposable.hs
+++ b/src/Quasar/Disposable.hs
@@ -47,6 +47,7 @@ class IsDisposable a where
{-# MINIMAL toDisposable | (dispose, isDisposed) #-}
+-- TODO remove
disposeAndAwait :: (MonadAwait m, MonadIO m) => IsDisposable a => a -> m ()
disposeAndAwait disposable = await =<< liftIO (dispose disposable)
diff --git a/src/Quasar/Observable.hs b/src/Quasar/Observable.hs
index 16a44af..cac15b3 100644
--- a/src/Quasar/Observable.hs
+++ b/src/Quasar/Observable.hs
@@ -76,6 +76,7 @@ toObservableUpdate (ObservableNotAvailable ex) = throwM ex
class IsRetrievable v a | a -> v where
retrieve :: MonadResourceManager m => a -> m (Awaitable v)
+-- TODO remove
retrieveIO :: IsRetrievable v a => a -> IO v
retrieveIO x = withResourceManagerM $ await =<< retrieve x
diff --git a/src/Quasar/ResourceManager.hs b/src/Quasar/ResourceManager.hs
index 554219f..7ba907b 100644
--- a/src/Quasar/ResourceManager.hs
+++ b/src/Quasar/ResourceManager.hs
@@ -3,6 +3,7 @@ module Quasar.ResourceManager (
MonadResourceManager(..),
registerDisposable,
registerDisposeAction,
+ registerSimpleDisposeAction,
disposeEventually,
withSubResourceManagerM,
onResourceManager,
@@ -21,6 +22,9 @@ module Quasar.ResourceManager (
withRootResourceManager,
withRootResourceManagerM,
+ CancelLinkedThread(..),
+ LinkedThreadDisposed(..),
+
-- ** Resource manager implementations
newUnmanagedRootResourceManager,
--newUnmanagedDefaultResourceManager,
@@ -122,10 +126,11 @@ registerDisposable disposable = do
registerDisposeAction :: MonadResourceManager m => IO (Awaitable ()) -> m ()
registerDisposeAction disposeAction = mask_ $ registerDisposable =<< newDisposable disposeAction
-registerDisposeAction' :: MonadResourceManager m => IO () -> m ()
-registerDisposeAction' disposeAction = registerDisposeAction (pure () <$ disposeAction)
+registerSimpleDisposeAction :: MonadResourceManager m => IO () -> m ()
+registerSimpleDisposeAction disposeAction = registerDisposeAction (pure () <$ disposeAction)
+-- TODO rename to withResourceScope?
withSubResourceManagerM :: MonadResourceManager m => m a -> m a
withSubResourceManagerM action =
bracket newResourceManager (await <=< dispose) \scope -> localResourceManager scope action
@@ -173,7 +178,16 @@ captureTask action = do
type ExceptionHandler = SomeException -> IO ()
loggingExceptionHandler :: ExceptionHandler
-loggingExceptionHandler ex = hPutStrLn stderr $ displayException ex
+loggingExceptionHandler ex = traceIO $ displayException ex
+
+
+data CancelLinkedThread = CancelLinkedThread
+ deriving stock Show
+ deriving anyclass Exception
+
+data LinkedThreadDisposed = LinkedThreadDisposed
+ deriving stock Show
+ deriving anyclass Exception
data CancelHelper = CancelHelper
@@ -194,7 +208,7 @@ withLinkedExceptionHandler parentExceptionHandler action = do
do
unmask do
atomically $ check =<< readTVar shouldCancelVar
- throwTo mainThreadId CancelTask
+ throwTo mainThreadId CancelLinkedThread
`catch`
\CancelHelper -> pure ()
@@ -206,7 +220,7 @@ withLinkedExceptionHandler parentExceptionHandler action = do
do \cancelThreadId -> liftIO $ throwTo cancelThreadId CancelHelper
do \_ -> unmask $ action exceptionHandler
`catch`
- \CancelTask -> throwM TaskDisposed
+ \CancelLinkedThread -> throwM LinkedThreadDisposed
diff --git a/test/Quasar/DisposableSpec.hs b/test/Quasar/DisposableSpec.hs
index 9651659..7ccd885 100644
--- a/test/Quasar/DisposableSpec.hs
+++ b/test/Quasar/DisposableSpec.hs
@@ -8,11 +8,6 @@ import Quasar.Awaitable
import Quasar.Disposable
import Quasar.ResourceManager
-data TestException = TestException
- deriving stock (Eq, Show)
-
-instance Exception TestException
-
spec :: Spec
spec = parallel $ do
describe "Disposable" $ do
@@ -40,71 +35,3 @@ spec = parallel $ do
void $ forkIO $ disposeAndAwait disposable
disposeAndAwait disposable
await (isDisposed disposable)
-
-
- describe "ResourceManager" $ do
- it "can be created" $ io do
- void newUnmanagedResourceManager
-
- it "can be created and disposed" $ io do
- resourceManager <- newUnmanagedResourceManager
- await =<< dispose resourceManager
-
- it "can be created and disposed" $ io do
- withResourceManager \_ -> pure ()
-
- it "can be created and disposed with a delay" $ do
- withResourceManager \_ -> threadDelay 100000
-
- it "can \"dispose\" a noDisposable" $ io do
- withResourceManager \resourceManager -> do
- attachDisposable resourceManager noDisposable
-
- it "can attach an disposable" $ do
- withResourceManager \resourceManager -> do
- avar <- newAsyncVar :: IO (AsyncVar ())
- attachDisposable resourceManager $ alreadyDisposing avar
- putAsyncVar_ avar ()
- pure () :: IO ()
-
- it "can dispose an awaitable that is completed asynchronously" $ do
- avar <- newAsyncVar :: IO (AsyncVar ())
- void $ forkIO $ do
- threadDelay 100000
- putAsyncVar_ avar ()
-
- withResourceManager \resourceManager -> do
- attachDisposable resourceManager (alreadyDisposing avar)
-
- it "can call a trivial dispose action" $ do
- withResourceManager \resourceManager ->
- attachDisposeAction_ resourceManager $ pure $ pure ()
- pure () :: IO ()
-
- it "can call a dispose action" $ do
- withResourceManager \resourceManager -> do
- avar <- newAsyncVar :: IO (AsyncVar ())
- attachDisposeAction_ resourceManager $ toAwaitable avar <$ putAsyncVar_ avar ()
- pure () :: IO ()
-
- it "re-throws an exception" $ do
- shouldThrow
- do
- withResourceManager \_ ->
- 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"
- \TaskDisposed -> True
-
- it "can attach an disposable that is disposed asynchronously" $ do
- withResourceManager \resourceManager -> do
- disposable <- attachDisposeAction resourceManager $ pure () <$ threadDelay 100000
- void $ forkIO $ disposeAndAwait disposable
diff --git a/test/Quasar/ResourceManagerSpec.hs b/test/Quasar/ResourceManagerSpec.hs
new file mode 100644
index 0000000..640fcee
--- /dev/null
+++ b/test/Quasar/ResourceManagerSpec.hs
@@ -0,0 +1,97 @@
+module Quasar.ResourceManagerSpec (spec) where
+
+import Control.Concurrent
+import Control.Concurrent.STM
+import Control.Exception
+import Quasar.Prelude
+import Test.Hspec
+import Quasar.Awaitable
+import Quasar.Disposable
+import Quasar.ResourceManager
+
+data TestException = TestException
+ deriving stock (Eq, Show)
+
+instance Exception TestException
+
+spec :: Spec
+spec = parallel $ do
+ describe "ResourceManager" $ do
+ it "can be created" $ io do
+ void newUnmanagedResourceManager
+
+ it "can be created and disposed" $ io do
+ resourceManager <- newUnmanagedResourceManager
+ await =<< dispose resourceManager
+
+ it "can be created and disposed" $ io do
+ withResourceManager \_ -> pure ()
+
+ it "can be created and disposed with a delay" $ do
+ withResourceManager \_ -> threadDelay 100000
+
+ it "can \"dispose\" a noDisposable" $ io do
+ withResourceManager \resourceManager -> do
+ attachDisposable resourceManager noDisposable
+
+ it "can attach an disposable" $ do
+ withResourceManager \resourceManager -> do
+ avar <- newAsyncVar :: IO (AsyncVar ())
+ attachDisposable resourceManager $ alreadyDisposing avar
+ putAsyncVar_ avar ()
+ pure () :: IO ()
+
+ it "can dispose an awaitable that is completed asynchronously" $ do
+ avar <- newAsyncVar :: IO (AsyncVar ())
+ void $ forkIO $ do
+ threadDelay 100000
+ putAsyncVar_ avar ()
+
+ withResourceManager \resourceManager -> do
+ attachDisposable resourceManager (alreadyDisposing avar)
+
+ it "can call a trivial dispose action" $ do
+ withResourceManager \resourceManager ->
+ attachDisposeAction_ resourceManager $ pure $ pure ()
+ pure () :: IO ()
+
+ it "can call a dispose action" $ do
+ withResourceManager \resourceManager -> do
+ avar <- newAsyncVar :: IO (AsyncVar ())
+ attachDisposeAction_ resourceManager $ toAwaitable avar <$ putAsyncVar_ avar ()
+ pure () :: IO ()
+
+ it "re-throws an exception" $ do
+ shouldThrow
+ do
+ withResourceManager \_ ->
+ 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 "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
+ atomically (readTVar var1) `shouldReturn` True
+ atomically (readTVar var2) `shouldReturn` True
--
GitLab