Skip to content
Snippets Groups Projects
Commit f414b553 authored by Jens Nolte's avatar Jens Nolte
Browse files

Remove old resource manager and async modules

parent 5ad92b3d
No related branches found
No related tags found
No related merge requests found
Pipeline #2708 passed
Stage: build
Expand all Hide whitespace changes
Inline Side-by-side
Showing
with 198 additions and 1336 deletions
quasar.cabal
+ 1
− 6
View file @ f414b553
......@@ -90,7 +90,6 @@ library
Quasar.Async.STMHelper
Quasar.Async.V2
Quasar.Awaitable
Quasar.Disposable
Quasar.Exceptions
Quasar.Exceptions.ExceptionChannel
Quasar.Monad
......@@ -98,11 +97,8 @@ library
Quasar.Observable.Delta
Quasar.Observable.ObservableHashMap
Quasar.Observable.ObservablePriority
Quasar.Old.Async
Quasar.Old.UnmanagedAsync
Quasar.Prelude
Quasar.PreludeExtras
Quasar.ResourceManager
Quasar.Resources
Quasar.Timer
Quasar.Timer.PosixTimer
......@@ -130,10 +126,9 @@ test-suite quasar-test
other-modules:
Quasar.AsyncSpec
Quasar.AwaitableSpec
Quasar.DisposableSpec
Quasar.ObservableSpec
Quasar.Observable.ObservableHashMapSpec
Quasar.Observable.ObservablePrioritySpec
Quasar.ResourceManagerSpec
Quasar.ResourcesSpec
hs-source-dirs:
test
src/Quasar/Disposable.hs deleted 100644 → 0
+ 0
− 272
View file @ 5ad92b3d
module Quasar.Disposable (
-- * Disposable
IsDisposable(..),
Disposable,
dispose,
disposeEventually,
disposeEventually_,
newDisposable,
noDisposable,
-- ** Async Disposable
newAsyncDisposable,
-- ** STM disposable
STMDisposable,
newSTMDisposable,
newSTMDisposable',
disposeSTMDisposable,
-- * Implementation internals
DisposeResult(..),
ResourceManagerResult(..),
DisposableFinalizers,
newDisposableFinalizers,
newDisposableFinalizersSTM,
defaultRegisterFinalizer,
defaultRunFinalizers,
awaitResourceManagerResult,
) where
import Control.Concurrent (forkIO)
import Control.Concurrent.STM
import Control.Monad.Catch
import Control.Monad.Reader
import Data.HashSet (HashSet)
import Data.HashSet qualified as HashSet
import GHC.Conc (unsafeIOToSTM)
import Quasar.Awaitable
import Quasar.Prelude
-- * Disposable
class IsDisposable a where
-- | Convert an `IsDisposable`-Object to a `Disposable`.
--
-- When implementing the `IsDisposable`-class this can be used to defer the dispose behavior to a disposable created
-- by e.g. `newDisposable`.
toDisposable :: a -> Disposable
toDisposable = Disposable
-- | Begin to dispose (/release) resource(s).
--
-- The implementation has to be idempotent, i.e. calling `beginDispose` once or multiple times should have the same
-- effect.
--
-- `beginDispose` must be called in masked state.
--
-- `beginDispose` must not block for an unbounded time.
--
-- TODO document finalizers (finalizers also have to run when an exception is thrown)
beginDispose :: a -> IO DisposeResult
beginDispose = beginDispose . toDisposable
isDisposed :: a -> Awaitable ()
isDisposed = isDisposed . toDisposable
-- | Finalizers MUST NOT throw exceptions.
--
-- The boolean returned by register finalizer indicates if the operation was successful.
registerFinalizer :: a -> STM () -> STM Bool
registerFinalizer = registerFinalizer . toDisposable
{-# MINIMAL toDisposable | (beginDispose, isDisposed, registerFinalizer) #-}
dispose :: MonadIO m => IsDisposable a => a -> m ()
dispose disposable = liftIO do
uninterruptibleMask_ (beginDispose disposable) >>= \case
DisposeResultDisposed -> pure ()
(DisposeResultAwait awaitable) -> await awaitable
(DisposeResultResourceManager result) -> awaitResourceManagerResult result
-- | Begin to dispose a resource.
disposeEventually :: (IsDisposable a, MonadIO m) => a -> m (Awaitable ())
disposeEventually disposable = do
disposeEventually_ disposable
pure $ isDisposed disposable
-- | Begin to dispose a resource.
disposeEventually_ :: (IsDisposable a, MonadIO m) => a -> m ()
disposeEventually_ disposable = liftIO do
uninterruptibleMask_ $ void $ beginDispose disposable
awaitResourceManagerResult :: forall m. MonadAwait m => ResourceManagerResult -> m ()
awaitResourceManagerResult = void . go mempty
where
go :: HashSet Unique -> ResourceManagerResult -> m (HashSet Unique)
go keys (ResourceManagerResult key awaitable)
| HashSet.member key keys = pure keys -- resource manager was encountered before
| otherwise = do
dependencies <- await awaitable
foldM go (HashSet.insert key keys) dependencies
data DisposeResult
= DisposeResultDisposed
| DisposeResultAwait (Awaitable ())
| DisposeResultResourceManager ResourceManagerResult
data ResourceManagerResult = ResourceManagerResult Unique (Awaitable [ResourceManagerResult])
instance IsDisposable a => IsDisposable (Maybe a) where
toDisposable = maybe noDisposable toDisposable
data Disposable = forall a. IsDisposable a => Disposable a
instance IsDisposable Disposable where
beginDispose (Disposable x) = beginDispose x
isDisposed (Disposable x) = isDisposed x
registerFinalizer (Disposable x) = registerFinalizer x
toDisposable = id
instance IsAwaitable () Disposable where
toAwaitable = isDisposed
data IODisposable = IODisposable Unique (TMVar (IO ())) DisposableFinalizers (AsyncVar ())
instance IsDisposable IODisposable where
beginDispose (IODisposable key actionVar finalizers resultVar) = do
-- This is only safe when run in masked state
atomically (tryTakeTMVar actionVar) >>= mapM_ \action -> do
result <- try action
atomically do
putAsyncVarEitherSTM_ resultVar result
defaultRunFinalizers finalizers
-- Await so concurrent `beginDispose` calls don't exit too early
await resultVar
pure DisposeResultDisposed
isDisposed (IODisposable _ _ _ resultVar) = toAwaitable resultVar `catchAll` \_ -> pure ()
registerFinalizer (IODisposable _ _ finalizers _) = defaultRegisterFinalizer finalizers
-- | Create a new disposable from an IO action. Is is guaranteed, that the IO action will only be called once (even when
-- `dispose` is called multiple times).
--
-- The action must not block for an unbound time.
newDisposable :: IO () -> STM Disposable
newDisposable disposeAction = do
key <- newUniqueSTM
fmap toDisposable $ IODisposable key <$> newTMVar disposeAction <*> newDisposableFinalizersSTM <*> newAsyncVarSTM
data AsyncDisposable = AsyncDisposable Unique (TMVar (IO ())) DisposableFinalizers (AsyncVar ())
instance IsDisposable AsyncDisposable where
beginDispose (AsyncDisposable key actionVar finalizers resultVar) = do
-- This is only safe when run in masked state
atomically (tryTakeTMVar actionVar) >>= mapM_ \action -> do
void $ forkIO do
result <- try action
atomically do
putAsyncVarEitherSTM_ resultVar result
defaultRunFinalizers finalizers
pure $ DisposeResultAwait $ await resultVar
isDisposed (AsyncDisposable _ _ _ resultVar) = toAwaitable resultVar `catchAll` \_ -> pure ()
registerFinalizer (AsyncDisposable _ _ finalizers _) = defaultRegisterFinalizer finalizers
-- | Create a new disposable from an IO action. The action will be run asynchrously. Is is guaranteed, that the IO
-- action will only be called once (even when `dispose` is called multiple times).
--
-- The action must not block for an unbound time.
newAsyncDisposable :: IO () -> STM Disposable
newAsyncDisposable disposeAction = do
key <- newUniqueSTM
fmap toDisposable $ AsyncDisposable key <$> newTMVar disposeAction <*> newDisposableFinalizersSTM <*> newAsyncVarSTM
data STMDisposable = STMDisposable Unique (TMVar (STM ())) DisposableFinalizers (AsyncVar ())
instance IsDisposable STMDisposable where
beginDispose (STMDisposable key actionVar finalizers resultVar) = do
-- This is only safe when run in masked state
atomically (tryTakeTMVar actionVar) >>= mapM_ \action -> do
atomically do
result <- try action
putAsyncVarEitherSTM_ resultVar result
defaultRunFinalizers finalizers
-- Await so concurrent `beginDispose` calls don't exit too early
await resultVar
pure DisposeResultDisposed
isDisposed (STMDisposable _ _ _ resultVar) = toAwaitable resultVar `catchAll` \_ -> pure ()
registerFinalizer (STMDisposable _ _ finalizers _) = defaultRegisterFinalizer finalizers
-- | Create a new disposable from an STM action. Is is guaranteed, that the STM action will only be called once (even
-- when `dispose` is called multiple times).
--
-- The action must not block (retry) for an unbound time.
newSTMDisposable :: STM () -> STM Disposable
newSTMDisposable disposeAction = toDisposable <$> newSTMDisposable' disposeAction
-- | Create a new disposable from an STM action. Is is guaranteed, that the STM action will only be called once (even
-- when `dispose` is called multiple times).
--
-- The action must not block (retry) for an unbound time.
--
-- This variant of `newSTMDisposable` returns an unboxed `STMDisposable` which can be disposed from `STM` by using
-- `disposeSTMDisposable`.
newSTMDisposable' :: STM () -> STM STMDisposable
newSTMDisposable' disposeAction = do
key <- unsafeIOToSTM newUnique
STMDisposable key <$> newTMVar disposeAction <*> newDisposableFinalizersSTM <*> newAsyncVarSTM
disposeSTMDisposable :: STMDisposable -> STM ()
disposeSTMDisposable (STMDisposable key actionVar finalizers resultVar) = do
tryTakeTMVar actionVar >>= \case
Just action -> do
result <- try action
putAsyncVarEitherSTM_ resultVar result
defaultRunFinalizers finalizers
Nothing -> readAsyncVarSTM resultVar
data EmptyDisposable = EmptyDisposable
instance IsDisposable EmptyDisposable where
beginDispose EmptyDisposable = pure DisposeResultDisposed
isDisposed _ = pure ()
registerFinalizer _ _ = pure False
-- | A `Disposable` for which `dispose` is a no-op and which reports as already disposed.
noDisposable :: Disposable
noDisposable = toDisposable EmptyDisposable
-- * Implementation internals
newtype DisposableFinalizers = DisposableFinalizers (TMVar [STM ()])
newDisposableFinalizers :: IO DisposableFinalizers
newDisposableFinalizers = DisposableFinalizers <$> newTMVarIO []
newDisposableFinalizersSTM :: STM DisposableFinalizers
newDisposableFinalizersSTM = DisposableFinalizers <$> newTMVar []
defaultRegisterFinalizer :: DisposableFinalizers -> STM () -> STM Bool
defaultRegisterFinalizer (DisposableFinalizers finalizerVar) finalizer =
tryTakeTMVar finalizerVar >>= \case
Just finalizers -> do
putTMVar finalizerVar (finalizer : finalizers)
pure True
Nothing -> pure False
defaultRunFinalizers :: DisposableFinalizers -> STM ()
defaultRunFinalizers (DisposableFinalizers finalizerVar) = do
tryTakeTMVar finalizerVar >>= \case
Just finalizers -> sequence_ finalizers
Nothing -> throwM $ userError "defaultRunFinalizers was called multiple times (it must only be run once)"
src/Quasar/Old/Async.hs deleted 100644 → 0
+ 0
− 95
View file @ 5ad92b3d
module Quasar.Old.Async (
-- * Async
Async,
async,
async_,
asyncWithUnmask,
asyncWithUnmask_,
withAsync,
-- ** Async with explicit error handling
asyncWithHandler,
asyncWithHandler_,
asyncWithHandlerAndUnmask,
asyncWithHandlerAndUnmask_,
-- ** Async exceptions
CancelAsync(..),
AsyncDisposed(..),
AsyncException(..),
isCancelAsync,
isAsyncDisposed,
) where
import Control.Monad.Catch
import Control.Monad.Reader
import Quasar.Disposable
import Quasar.Old.UnmanagedAsync
import Quasar.Prelude
import Quasar.ResourceManager
-- | TODO: Documentation
--
-- The action will be run with asynchronous exceptions unmasked.
async :: (MonadResourceManager m, MonadIO m, MonadMask m) => ResourceManagerIO a -> m (Async a)
async action = asyncWithUnmask \unmask -> unmask action
-- | TODO: Documentation
--
-- The action will be run with asynchronous exceptions masked and will be passed an action that can be used to unmask.
asyncWithUnmask
:: (MonadResourceManager m, MonadIO m, MonadMask m)
=> ((ResourceManagerIO a -> ResourceManagerIO a)
-> ResourceManagerIO r)
-> m (Async r)
asyncWithUnmask action = do
resourceManager <- askResourceManager
asyncWithHandlerAndUnmask (onResourceManager resourceManager . throwToResourceManager . AsyncException) action
async_ :: (MonadResourceManager m, MonadIO m, MonadMask m) => ResourceManagerIO () -> m ()
async_ action = void $ async action
asyncWithUnmask_ :: (MonadResourceManager m, MonadIO m, MonadMask m) => ((ResourceManagerIO a -> ResourceManagerIO a) -> ResourceManagerIO ()) -> m ()
asyncWithUnmask_ action = void $ asyncWithUnmask action
-- | TODO: Documentation
--
-- The action will be run with asynchronous exceptions unmasked. When an exception is thrown that is not caused from
-- the disposable instance (i.e. the task being canceled), the handler is called with that exception.
asyncWithHandlerAndUnmask
:: (MonadResourceManager m, MonadIO m, MonadMask m)
=> (SomeException -> IO ())
-> ((ResourceManagerIO a -> ResourceManagerIO a)
-> ResourceManagerIO r)
-> m (Async r)
asyncWithHandlerAndUnmask handler action = do
resourceManager <- askResourceManager
registerNewResource do
unmanagedAsyncWithHandlerAndUnmask wrappedHandler \unmask ->
onResourceManager resourceManager (action (liftUnmask unmask))
where
wrappedHandler :: SomeException -> IO ()
wrappedHandler (fromException -> Just AsyncDisposed) = pure ()
wrappedHandler ex = handler ex
liftUnmask :: (forall b. IO b -> IO b) -> ResourceManagerIO a -> ResourceManagerIO a
liftUnmask unmask innerAction = do
resourceManager <- askResourceManager
liftIO $ unmask $ onResourceManager resourceManager innerAction
asyncWithHandlerAndUnmask_
:: (MonadResourceManager m, MonadIO m, MonadMask m)
=> (SomeException -> IO ())
-> ((ResourceManagerIO a -> ResourceManagerIO a)
-> ResourceManagerIO r)
-> m ()
asyncWithHandlerAndUnmask_ handler action = void $ asyncWithHandlerAndUnmask handler action
asyncWithHandler :: (MonadResourceManager m, MonadIO m, MonadMask m) => (SomeException -> IO ()) -> ResourceManagerIO r -> m (Async r)
asyncWithHandler handler action = asyncWithHandlerAndUnmask handler \unmask -> unmask action
asyncWithHandler_ :: (MonadResourceManager m, MonadIO m, MonadMask m) => (SomeException -> IO ()) -> ResourceManagerIO r -> m ()
asyncWithHandler_ handler action = void $ asyncWithHandler handler action
withAsync :: (MonadResourceManager m, MonadIO m, MonadMask m) => ResourceManagerIO r -> (Async r -> m a) -> m a
withAsync action = bracket (async action) dispose
src/Quasar/Old/UnmanagedAsync.hs deleted 100644 → 0
+ 0
− 133
View file @ 5ad92b3d
module Quasar.Old.UnmanagedAsync (
-- ** Unmanaged variant
Async,
unmanagedAsync,
unmanagedAsyncWithHandler,
unmanagedAsyncWithUnmask,
unmanagedAsyncWithHandlerAndUnmask,
-- ** Async exceptions
CancelAsync(..),
AsyncDisposed(..),
AsyncException(..),
isCancelAsync,
isAsyncDisposed,
) where
import Control.Concurrent (ThreadId, forkIO, forkIOWithUnmask, throwTo)
import Control.Concurrent.STM
import Control.Monad.Catch
import Quasar.Exceptions
import Quasar.Awaitable
import Quasar.Disposable
import Quasar.Prelude
-- | A async is an asynchronously running computation that can be cancelled.
--
-- The result (or exception) can be aquired by using the `IsAwaitable` class (e.g. by calling `await` or `awaitIO`).
-- It is possible to cancel the async by using `dispose` if the operation has not been completed.
data Async r = Async Unique (TVar AsyncState) DisposableFinalizers (Awaitable r)
data AsyncState = AsyncStateInitializing | AsyncStateRunning ThreadId | AsyncStateThrowing | AsyncStateCompleted
instance IsAwaitable r (Async r) where
toAwaitable (Async _ _ _ resultAwaitable) = resultAwaitable
instance IsDisposable (Async r) where
beginDispose self@(Async key stateVar _ _) = uninterruptibleMask_ do
join $ atomically do
readTVar stateVar >>= \case
AsyncStateInitializing -> unreachableCodePathM
AsyncStateRunning threadId -> do
writeTVar stateVar AsyncStateThrowing
-- Fork to prevent synchronous exceptions when disposing this thread, and to prevent blocking when disposing
-- a thread that is running in uninterruptible masked state.
pure $ void $ forkIO do
throwTo threadId $ CancelAsync key
atomically $ writeTVar stateVar AsyncStateCompleted
AsyncStateThrowing -> pure $ pure @IO ()
AsyncStateCompleted -> pure $ pure @IO ()
-- Wait for async completion or failure. Asyncs must not ignore `CancelAsync` or this will hang.
pure $ DisposeResultAwait $ isDisposed self
isDisposed (Async _ _ _ resultAwaitable) = awaitSuccessOrFailure resultAwaitable
registerFinalizer (Async _ _ finalizers _) = defaultRegisterFinalizer finalizers
instance Functor Async where
fmap fn (Async key actionVar finalizerVar resultAwaitable) = Async key actionVar finalizerVar (fn <$> resultAwaitable)
-- | Base implementation for the `unmanagedAsync`- and `Quasar.Async.async`-class of functions.
unmanagedAsyncWithHandlerAndUnmask :: MonadIO m => (SomeException -> IO ()) -> ((forall b. IO b -> IO b) -> IO a) -> m (Async a)
unmanagedAsyncWithHandlerAndUnmask handler action = do
liftIO $ mask_ do
key <- newUnique
resultVar <- newAsyncVar
stateVar <- newTVarIO AsyncStateInitializing
finalizers <- newDisposableFinalizers
threadId <- forkIOWithUnmask \unmask ->
handleAll
do \ex -> fail $ "coreAsyncImplementation thread failed: " <> displayException ex
do
result <- try $ catchAll
do action unmask
\ex -> do
-- Rewrite exception if its the cancel exception for this async
when (fromException ex == Just (CancelAsync key)) $ throwIO AsyncDisposed
throwIO $ AsyncException ex
-- The `action` has completed its work.
-- "disarm" dispose:
catchIf
do \(CancelAsync exKey) -> key == exKey
do
atomically $ readTVar stateVar >>= \case
AsyncStateInitializing -> retry
AsyncStateRunning _ -> writeTVar stateVar AsyncStateCompleted
AsyncStateThrowing -> retry -- Could not disarm so we have to wait for the exception to arrive
AsyncStateCompleted -> pure ()
do mempty -- ignore exception if it matches; this can only happen once (see AsyncStateThrowing above)
catchAll
case result of
Left (fromException -> Just AsyncDisposed) -> pure ()
Left (fromException -> Just (AsyncException ex)) -> handler ex
-- Impossible code path reached
Left ex -> traceIO $ "Error in unmanagedAsyncWithHandlerAndUnmask: " <> displayException ex
_ -> pure ()
\ex -> traceIO $ "An exception was thrown while handling an async exception: " <> displayException ex
atomically do
putAsyncVarEitherSTM_ resultVar result
defaultRunFinalizers finalizers
atomically $ writeTVar stateVar $ AsyncStateRunning threadId
pure $ Async key stateVar finalizers (toAwaitable resultVar)
unmanagedAsync :: MonadIO m => IO a -> m (Async a)
unmanagedAsync action = unmanagedAsyncWithUnmask \unmask -> unmask action
unmanagedAsyncWithHandler :: MonadIO m => (SomeException -> IO ()) -> IO a -> m (Async a)
unmanagedAsyncWithHandler handler action = unmanagedAsyncWithHandlerAndUnmask handler \unmask -> unmask action
unmanagedAsyncWithUnmask :: MonadIO m => ((forall b. IO b -> IO b) -> IO a) -> m (Async a)
unmanagedAsyncWithUnmask = unmanagedAsyncWithHandlerAndUnmask (traceIO . ("Unhandled exception in unmanaged async: " <>) . displayException)
-- | Run a computation concurrently to another computation. When the current thread leaves `withAsync`, the async
-- computation is cancelled.
--
-- While the async is disposed when `withUnmanagedAsync` exits, an exception would be ignored if the action fails. This
-- behavior is similar to the @withAsync@ function from the @async@ package.
--
-- For an exception-safe version, see `Quasar.Async.withAsync`.
withUnmanagedAsync :: (MonadIO m, MonadMask m) => IO r -> (Async r -> m a) -> m a
withUnmanagedAsync action = bracket (unmanagedAsync action) dispose
src/Quasar/ResourceManager.hs deleted 100644 → 0
+ 0
− 628
View file @ 5ad92b3d
This diff is collapsed.
test/Quasar/AsyncSpec.hs
+ 6
− 6
View file @ f414b553
module Quasar.AsyncSpec (spec) where
import Control.Concurrent
import Control.Monad (void)
import Control.Monad.IO.Class
--import Control.Concurrent
--import Control.Monad (void)
--import Control.Monad.IO.Class
import Prelude
import Test.Hspec
--import Quasar.Async
import Quasar.Awaitable
import Quasar.ResourceManager
import System.Timeout
--import Quasar.Awaitable
--import Quasar.ResourceManager
--import System.Timeout
spec :: Spec
spec = describe "async" $ it "async" $ pendingWith "moving to new implementation..."
......
test/Quasar/DisposableSpec.hs deleted 100644 → 0
+ 0
− 36
View file @ 5ad92b3d
module Quasar.DisposableSpec (spec) where
import Control.Concurrent
import Control.Concurrent.STM
import Quasar.Prelude
import Test.Hspec
import Quasar.Awaitable
import Quasar.Disposable
spec :: Spec
spec = parallel $ do
describe "Disposable" $ do
describe "noDisposable" $ do
it "can be disposed" $ io do
dispose noDisposable
it "can be awaited" $ io do
await (isDisposed noDisposable)
describe "newDisposable" $ do
it "signals it's disposed state" $ io do
disposable <- atomically $ newDisposable $ pure ()
void $ forkIO $ threadDelay 100000 >> dispose disposable
await (isDisposed disposable)
it "can be disposed multiple times" $ io do
disposable <- atomically $ newDisposable $ pure ()
dispose disposable
dispose disposable
await (isDisposed disposable)
it "can be disposed in parallel" $ do
disposable <- atomically $ newDisposable $ threadDelay 100000
void $ forkIO $ dispose disposable
dispose disposable
await (isDisposed disposable)
test/Quasar/Observable/ObservableHashMapSpec.hs
+ 9
− 9
View file @ f414b553
module Quasar.Observable.ObservableHashMapSpec (spec) where
import Control.Monad (void)
import Data.HashMap.Strict qualified as HM
import Data.IORef
import Quasar.Awaitable
import Quasar.Disposable
import Quasar.Observable
import Quasar.Observable.Delta
import Quasar.Observable.ObservableHashMap qualified as OM
--import Control.Monad (void)
--import Data.HashMap.Strict qualified as HM
--import Data.IORef
--import Quasar.Awaitable
--import Quasar.Disposable
--import Quasar.Observable
--import Quasar.Observable.Delta
--import Quasar.Observable.ObservableHashMap qualified as OM
import Quasar.Prelude
import Quasar.ResourceManager
--import Quasar.ResourceManager
import Test.Hspec
shouldReturnM :: (Eq a, Show a, MonadIO m) => m a -> a -> m ()
......
test/Quasar/ObservableSpec.hs
+ 4
− 4
View file @ f414b553
module Quasar.ObservableSpec (spec) where
import Data.IORef
--import Data.IORef
import Quasar.Prelude
import Quasar.Awaitable
import Quasar.Observable
import Quasar.ResourceManager
--import Quasar.Awaitable
--import Quasar.Observable
--import Quasar.ResourceManager
import Test.Hspec
......
test/Quasar/ResourceManagerSpec.hs deleted 100644 → 0
+ 0
− 147
View file @ 5ad92b3d
module Quasar.ResourceManagerSpec (spec) where
import Control.Concurrent
import Control.Concurrent.STM
import Control.Exception
import Control.Monad.Catch
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
withRootResourceManager $ pure ()
it "can be created and disposed" $ io do
withRootResourceManager do
resourceManager <- askResourceManager
disposeEventually_ resourceManager
it "is disposed when exiting withRootResourceManager" $ io do
resourceManager <- withRootResourceManager askResourceManager
peekAwaitable (isDisposed resourceManager) `shouldReturn` Just ()
it "can be created and disposed with a delay" $ io do
withRootResourceManager $ liftIO $ threadDelay 100000
it "can \"dispose\" a noDisposable" $ io do
withRootResourceManager do
registerDisposable noDisposable
it "can attach a dispose action" $ io do
var <- newTVarIO False
withRootResourceManager do
registerDisposeAction $ atomically $ writeTVar var True
atomically (readTVar var) `shouldReturn` True
it "can attach a slow dispose action" $ io do
withRootResourceManager do
registerDisposeAction $ threadDelay 100000
it "re-throws an exception" $ do
shouldThrow
do
withRootResourceManager do
liftIO $ throwIO TestException
\TestException -> True
it "handles an exception while disposing" $ io do
(`shouldThrow` \(_ :: CombinedException) -> True) do
withRootResourceManager do
registerDisposeAction $ throwIO TestException
liftIO $ threadDelay 100000
it "passes an exception to the root resource manager" $ io do
(`shouldThrow` \(_ :: CombinedException) -> True) do
withRootResourceManager 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
withScopedResourceManager do
registerDisposeAction $ throwIO TestException
liftIO $ threadDelay 100000
it "can attach an disposable that is disposed asynchronously" $ io do
withRootResourceManager do
disposable <- captureDisposable_ $ registerDisposeAction $ threadDelay 100000
liftIO $ void $ forkIO $ dispose disposable
it "does not abort disposing when encountering an exception" $ do
var1 <- newTVarIO False
var2 <- newTVarIO False
(`shouldThrow` \(_ :: CombinedException) -> True) do
withRootResourceManager do
registerDisposeAction $ atomically (writeTVar var1 True)
registerDisposeAction $ throwIO TestException
registerDisposeAction $ atomically (writeTVar var2 True)
atomically (readTVar var1) `shouldReturn` True
atomically (readTVar var2) `shouldReturn` True
it "withRootResourceManager will start disposing when receiving an exception" $ io do
(`shouldThrow` \(_ :: CombinedException) -> True) do
withRootResourceManager do
linkExecution do
throwToResourceManager TestException
sleepForever
it "combines exceptions from resources with exceptions on the thread" $ io do
(`shouldThrow` \(combinedExceptions -> exceptions) -> length exceptions == 2) do
withRootResourceManager do
throwToResourceManager TestException
throwM TestException
it "can dispose a resource manager loop" $ io do
withRootResourceManager do
rm1 <- newResourceManager
rm2 <- newResourceManager
liftIO $ atomically do
attachDisposable rm1 rm2
attachDisposable rm2 rm1
it "can dispose a resource manager loop" $ io do
withRootResourceManager do
rm1 <- newResourceManager
rm2 <- newResourceManager
liftIO $ atomically do
attachDisposable rm1 rm2
attachDisposable rm2 rm1
dispose rm1
it "can dispose a resource manager loop with a shared disposable" $ io do
var <- newTVarIO (0 :: Int)
d <- atomically $ newDisposable $ atomically $ modifyTVar var (+ 1)
withRootResourceManager do
rm1 <- newResourceManager
rm2 <- newResourceManager
liftIO $ atomically do
attachDisposable rm1 rm2
attachDisposable rm2 rm1
attachDisposable rm1 d
attachDisposable rm2 d
atomically (readTVar var) `shouldReturn` 1
describe "linkExecution" do
it "does not generate an exception after it is completed" $ io do
(`shouldThrow` \(_ :: CombinedException) -> True) do
withRootResourceManager do
linkExecution do
pure ()
throwToResourceManager TestException
liftIO $ threadDelay 100000
test/Quasar/ResourcesSpec.hs 0 → 100644
+ 178
− 0
View file @ f414b553
module Quasar.ResourcesSpec (spec) where
import Control.Concurrent
import Control.Concurrent.STM
import Control.Exception
import Control.Monad.Catch
import Quasar.Prelude
import Test.Hspec
import Quasar.Awaitable
import Quasar.Resources
import Quasar.Monad
data TestException = TestException
deriving stock (Eq, Show)
instance Exception TestException
spec :: Spec
spec = pure ()
--spec = parallel $ do
-- describe "ResourceManager" $ do
-- it "can be created" $ io do
-- withRootResourceManager $ pure ()
--
-- it "can be created and disposed" $ io do
-- withRootResourceManager do
-- resourceManager <- askResourceManager
-- disposeEventually_ resourceManager
--
-- it "is disposed when exiting withRootResourceManager" $ io do
-- resourceManager <- withRootResourceManager askResourceManager
--
-- peekAwaitable (isDisposed resourceManager) `shouldReturn` Just ()
--
-- it "can be created and disposed with a delay" $ io do
-- withRootResourceManager $ liftIO $ threadDelay 100000
--
-- it "can \"dispose\" a noDisposable" $ io do
-- withRootResourceManager do
-- registerDisposable noDisposable
--
-- it "can attach a dispose action" $ io do
-- var <- newTVarIO False
-- withRootResourceManager do
-- registerDisposeAction $ atomically $ writeTVar var True
--
-- atomically (readTVar var) `shouldReturn` True
--
-- it "can attach a slow dispose action" $ io do
-- withRootResourceManager do
-- registerDisposeAction $ threadDelay 100000
--
-- it "re-throws an exception" $ do
-- shouldThrow
-- do
-- withRootResourceManager do
-- liftIO $ throwIO TestException
-- \TestException -> True
--
-- it "handles an exception while disposing" $ io do
-- (`shouldThrow` \(_ :: CombinedException) -> True) do
-- withRootResourceManager do
-- registerDisposeAction $ throwIO TestException
-- liftIO $ threadDelay 100000
--
-- it "passes an exception to the root resource manager" $ io do
-- (`shouldThrow` \(_ :: CombinedException) -> True) do
-- withRootResourceManager 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
-- withScopedResourceManager do
-- registerDisposeAction $ throwIO TestException
-- liftIO $ threadDelay 100000
--
-- it "can attach an disposable that is disposed asynchronously" $ io do
-- withRootResourceManager do
-- disposable <- captureDisposable_ $ registerDisposeAction $ threadDelay 100000
-- liftIO $ void $ forkIO $ dispose disposable
--
-- it "does not abort disposing when encountering an exception" $ do
-- var1 <- newTVarIO False
-- var2 <- newTVarIO False
-- (`shouldThrow` \(_ :: CombinedException) -> True) do
-- withRootResourceManager do
-- registerDisposeAction $ atomically (writeTVar var1 True)
-- registerDisposeAction $ throwIO TestException
-- registerDisposeAction $ atomically (writeTVar var2 True)
-- atomically (readTVar var1) `shouldReturn` True
-- atomically (readTVar var2) `shouldReturn` True
--
-- it "withRootResourceManager will start disposing when receiving an exception" $ io do
-- (`shouldThrow` \(_ :: CombinedException) -> True) do
-- withRootResourceManager do
-- linkExecution do
-- throwToResourceManager TestException
-- sleepForever
--
-- it "combines exceptions from resources with exceptions on the thread" $ io do
-- (`shouldThrow` \(combinedExceptions -> exceptions) -> length exceptions == 2) do
-- withRootResourceManager do
-- throwToResourceManager TestException
-- throwM TestException
--
-- it "can dispose a resource manager loop" $ io do
-- withRootResourceManager do
-- rm1 <- newResourceManager
-- rm2 <- newResourceManager
-- liftIO $ atomically do
-- attachDisposable rm1 rm2
-- attachDisposable rm2 rm1
--
-- it "can dispose a resource manager loop" $ io do
-- withRootResourceManager do
-- rm1 <- newResourceManager
-- rm2 <- newResourceManager
-- liftIO $ atomically do
-- attachDisposable rm1 rm2
-- attachDisposable rm2 rm1
-- dispose rm1
--
-- it "can dispose a resource manager loop with a shared disposable" $ io do
-- var <- newTVarIO (0 :: Int)
-- d <- atomically $ newDisposable $ atomically $ modifyTVar var (+ 1)
-- withRootResourceManager do
-- rm1 <- newResourceManager
-- rm2 <- newResourceManager
-- liftIO $ atomically do
-- attachDisposable rm1 rm2
-- attachDisposable rm2 rm1
-- attachDisposable rm1 d
-- attachDisposable rm2 d
--
-- atomically (readTVar var) `shouldReturn` 1
--
--
-- describe "linkExecution" do
-- it "does not generate an exception after it is completed" $ io do
-- (`shouldThrow` \(_ :: CombinedException) -> True) do
-- withRootResourceManager do
-- linkExecution do
-- pure ()
-- throwToResourceManager TestException
-- liftIO $ threadDelay 100000
-- From DisposableSpec.hs:
--spec :: Spec
--spec = parallel $ do
-- describe "Disposable" $ do
-- describe "noDisposable" $ do
-- it "can be disposed" $ io do
-- dispose noDisposable
--
-- it "can be awaited" $ io do
-- await (isDisposed noDisposable)
--
-- describe "newDisposable" $ do
-- it "signals it's disposed state" $ io do
-- disposable <- atomically $ newDisposable $ pure ()
-- void $ forkIO $ threadDelay 100000 >> dispose disposable
-- await (isDisposed disposable)
--
-- it "can be disposed multiple times" $ io do
-- disposable <- atomically $ newDisposable $ pure ()
-- dispose disposable
-- dispose disposable
-- await (isDisposed disposable)
--
-- it "can be disposed in parallel" $ do
-- disposable <- atomically $ newDisposable $ threadDelay 100000
-- void $ forkIO $ dispose disposable
-- dispose disposable
-- await (isDisposed disposable)
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment