diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,28 @@ # ChangeLog for time-manager +## 0.5.0 + +* BREAKING CHANGE: a `ThreadManager` no longer carries a `T.Manager`. + `newThreadManager` takes no argument, `forkManagedTimeout` and + `forkManagedTimeoutFinally` take the caller's, and `withHandle` and the + re-exports from `System.TimeManager` are gone. + [#1131](https://github.com/yesodweb/wai/pull/1131) +* Count a thread in `System.ThreadManager` from when it is forked rather + than from when it starts, with `forkManagedBy`, `reserveManaged`, + `takeReservation` and `countManaged`. + [#1128](https://github.com/yesodweb/wai/pull/1128) +* Keep counting the threads `stopAfter` stopped until they end. + [#1128](https://github.com/yesodweb/wai/pull/1128) +* `countManaged` throws `AssertionFailed` when a reservation has been taken + by a manager other than its own. + [#1128](https://github.com/yesodweb/wai/pull/1128) +* `forkManagedFinally` and `forkManagedTimeoutFinally` no longer swallow an + exception from the action; it ends the thread, after the cleanup has run. + [#1128](https://github.com/yesodweb/wai/pull/1128) +* Add `forkManagedUnmaskFinally`, so that every fork has a variant with a + cleanup. + [#1128](https://github.com/yesodweb/wai/pull/1128) + ## 0.4.0 * CHANGES IN BEHAVIOUR: diff --git a/System/ThreadManager.hs b/System/ThreadManager.hs --- a/System/ThreadManager.hs +++ b/System/ThreadManager.hs @@ -1,8 +1,9 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} --- | A thread manager including a time manager. +-- | A thread manager. -- The manager has responsibility to kill managed threads. -- -- Because this is based on the accompanying "System.TimeManager" module, @@ -23,30 +24,33 @@ KilledByThreadManager (..), -- * Fork + Reservation, + reserveManaged, + takeReservation, forkManaged, forkManagedFinally, forkManagedUnmask, + forkManagedUnmaskFinally, + forkManagedBy, + forkManagedByFinally, forkManagedTimeout, forkManagedTimeoutFinally, -- * Synchronization waitUntilAllGone, isAllGone, - - -- * Re-exports - T.Manager, - withHandle, - T.Handle, - T.tickle, - T.pause, - T.resume, + countManaged, ) where import Control.Concurrent import Control.Concurrent.STM -import Control.Exception (Exception (..), SomeException (..)) +import Control.Exception ( + AssertionFailed (..), + Exception (..), + SomeException (..), + ) import qualified Control.Exception as E -import Control.Monad (unless, void) +import Control.Monad (unless, void, when) import Data.Foldable (forM_) import Data.IORef (IORef, atomicModifyIORef', newIORef) import Data.Map.Strict (Map) @@ -61,16 +65,25 @@ ---------------------------------------------------------------- --- | Manager to manage the thread and the timer. -data ThreadManager = ThreadManager T.Manager (TVar ManagedThreads) +-- | Manager to own threads. +data ThreadManager = ThreadManager + { managedThreads :: TVar ManagedThreads + , reservedPlaces :: TVar Int + -- ^ Places kept by 'reserveManaged' for threads not started yet. + , managerStopped :: TVar Bool + -- ^ Stopped by 'stopAfter'. A thread which registers after that + -- is killed on arrival: it was forked before the stop and would + -- otherwise run on with nobody owning it. + } type Key = Word64 type ManagedThreads = Map Key ManagedThread ---------------------------------------------------------------- --- 'IORef' prevents race between WAI TimeManager (TimeoutThread) --- and stopAfter (KilledByThreadManager). +-- The 'IORef' prevents a race between the timeout of +-- 'forkManagedTimeout' and 'forkManagedTimeoutFinally', which the time +-- manager runs, and 'stopAfter'. Both throw 'KilledByThreadManager'. -- It is initialized with 'False' and turned into 'True' when locked. -- The winner can throw an asynchronous exception. data ManagedThread = ManagedThread (Weak ThreadId) (IORef Bool) @@ -79,13 +92,60 @@ -- | Create a thread manager. -- --- To create a 'ThreadManager', you will first have to create a --- 'T.Manager' from the "System.TimeManager" module. +-- A manager owns threads; it does not time them out. A caller which wants +-- both passes its own 'T.Manager' to 'forkManagedTimeout'. +newThreadManager :: IO ThreadManager +newThreadManager = do + managedThreads <- newTVarIO Map.empty + reservedPlaces <- newTVarIO 0 + managerStopped <- newTVarIO False + return ThreadManager{..} + +---------------------------------------------------------------- + +-- | A place kept for a thread that is not running yet. -- --- You can use either 'System.TimeManager.initialize' or 'System.TimeManager.withManager'. -newThreadManager :: T.Manager -> IO ThreadManager -newThreadManager timmgr = ThreadManager timmgr <$> newTVarIO Map.empty +-- Registering a thread needs its 'ThreadId', and it is the thread +-- itself which provides it, by asking for its own. A caller which +-- forks through a function that hands no identity back cannot do it on +-- the thread's behalf, so until the thread arrives and registers +-- itself, what is counted is the place kept for it. +newtype Reservation = Reservation (IORef Bool) +-- | Keeping a place for a thread about to be forked. It counts towards +-- 'countManaged' from here, so that a manager stopped in between does +-- not see a connection that has been accepted as one that is gone. +-- A place that is never taken is never given back, so a caller which +-- reserves and then fails to fork leaves the manager counting it. +reserveManaged :: ThreadManager -> IO Reservation +reserveManaged ThreadManager{..} = do + atomically $ modifyTVar' reservedPlaces (+ 1) + Reservation <$> newIORef False + +-- | Running the action of a thread which was reserved for, taking the +-- place kept for it: the thread records itself, so that 'stopAfter' can +-- reach it, and gives the reservation back. +-- +-- The reservation is given back only once the thread is recorded, so +-- that it is counted throughout. +-- A thread which gets here after 'stopAfter' has stopped the manager is +-- killed rather than registered. +-- +-- The reservation must be one kept by this manager. Taking one kept by +-- another lowers this manager's count instead of that one's: the other +-- manager never reaches zero, and once this count goes negative, +-- 'countManaged', 'isAllGone' and 'waitUntilAllGone' throw 'AssertionFailed'. +takeReservation :: ThreadManager -> Reservation -> IO () -> IO () +takeReservation mgr rsv io = taking mgr rsv (return ()) $ \_ -> io + +-- | Giving a place back, at most once however often this is called: the +-- thread which takes it gives it back, and so does a caller whose fork +-- throws, and only one of them can have it. +release :: ThreadManager -> Reservation -> IO () +release ThreadManager{..} (Reservation ref) = do + taken <- atomicModifyIORef' ref (\b -> (True, b)) + unless taken $ atomically $ modifyTVar' reservedPlaces (subtract 1) + ---------------------------------------------------------------- -- | An exception used internally to kill a managed thread. @@ -106,6 +166,20 @@ -- exceptions (including asynchronous ones); this allows the cleanup handler -- to cleanup in all circumstances. If an exception is caught, it is rethrown -- after the cleanup is complete. +-- +-- This tells the managed threads to stop; it does not wait for them to be +-- gone, and neither does the cleanup handler. They are the manager\'s +-- until they end, so 'countManaged' goes on counting them -- which is what +-- a caller waits on with 'waitUntilAllGone' before it frees what those +-- threads were using. +-- +-- A thread whose place is still being kept by 'reserveManaged' is not told +-- but refused when it arrives, and never runs. +-- +-- A thread which swallows the exception and never ends is therefore +-- counted for ever, and 'waitUntilAllGone' on such a manager never +-- returns. Nothing here can make it end; a caller which cannot rule that +-- out should put its own timeout around the wait. stopAfter :: ThreadManager -> IO a -> (Maybe SomeException -> IO ()) -> IO a stopAfter mgr action cleanup = stopAfterWithResult mgr action $ \mResult -> @@ -125,13 +199,19 @@ -- @since 0.3.2 stopAfterWithResult :: ThreadManager -> IO a -> (Either SomeException a -> IO b) -> IO b -stopAfterWithResult (ThreadManager _timmgr var) action cleanup = do +stopAfterWithResult ThreadManager{..} action cleanup = do E.mask $ \unmask -> do ma <- E.try $ unmask action + -- The threads are left in the map rather than taken out of it: + -- 'throwTo' waits for the exception to be taken, not for the + -- thread to be gone, and a manager which reports that it owns + -- nothing while its threads are still unwinding is no use to a + -- caller which frees what they were using. They should take + -- themselves out as they end, and 'managerStopped' is what keeps + -- new ones from arriving. m <- atomically $ do - m0 <- readTVar var - writeTVar var Map.empty - return m0 + writeTVar managerStopped True + readTVar managedThreads let ths = Map.elems m er = either Just (const Nothing) ma ex = KilledByThreadManager er @@ -142,9 +222,12 @@ -- | Fork a managed thread. -- --- This guarantees that the thread ID is added to the manager's queue before --- the thread starts, and is removed again when the thread terminates --- (normally or abnormally). +-- A place is kept for the thread before it is forked, so that it counts +-- towards 'countManaged' from this call rather than from the moment the +-- run-time system gives the thread its first step. The thread adds +-- itself to the manager's queue as the first thing it does, takes the +-- place over, and is removed again when it terminates (normally or +-- abnormally). forkManaged :: ThreadManager -> String @@ -152,10 +235,25 @@ -> IO () -- ^ Action -> IO () -forkManaged mgr label io = - forkManagedUnmask mgr label $ \unmask -> unmask io +forkManaged mgr label io = forkManagedFinally mgr label io $ return () --- | Like 'forkManaged', but run action with exceptions masked +-- | Like 'forkManaged', but with a cleanup function, run regardless of how +-- the action ends. An exception from the action is not caught: it ends +-- the thread as it would under 'forkManaged'. +forkManagedFinally + :: ThreadManager + -> String + -- ^ Thread name + -> IO () + -- ^ Action + -> IO () + -- ^ Cleanup function + -> IO () +forkManagedFinally mgr label io final = + forkManagedUnmaskFinally mgr label (\restore -> restore io) final + +-- | Like 'forkManaged', but run the action with exceptions masked +-- until the provided `unmask` is used. (i.e. @(forall x. IO x -> IO x)@) forkManagedUnmask :: ThreadManager -> String @@ -163,64 +261,163 @@ -> ((forall x. IO x -> IO x) -> IO ()) -- ^ Action with unmask argument -> IO () -forkManagedUnmask (ThreadManager _timmgr var) label io = - void $ E.mask_ $ forkIOWithUnmask $ \unmask -> E.handle ignore $ do - labelMe label - E.bracket (setup var) (clear var) $ \_ -> io unmask +forkManagedUnmask mgr label io = forkManagedUnmaskFinally mgr label io $ return () +-- | Like 'forkManagedUnmask', but with a cleanup function, run regardless of +-- how the action ends. An exception from the action is not caught: it +-- ends the thread as it would under 'forkManagedUnmask'. +forkManagedUnmaskFinally + :: ThreadManager + -> String + -- ^ Thread name + -> ((forall x. IO x -> IO x) -> IO ()) + -- ^ Action with unmask argument + -> IO () + -- ^ Cleanup: will always run, regardless of how the thread ends + -> IO () +forkManagedUnmaskFinally mgr label io final = + E.mask_ $ + forkManagedByFinally mgr (\body -> void $ forkIOWithUnmask body) label io final + +-- | Fork a managed thread with a fork of the caller's own, for a caller +-- which does not fork with 'forkIO'. (The @warp@ library, for example, +-- forks the thread serving a connection through a function of its +-- settings, so that the user can replace it.) +-- +-- A place is kept for the thread before the fork, so that it counts +-- towards 'countManaged' from here rather than from the moment the +-- thread starts, and the place is given back whether the fork makes the +-- thread or throws. A caller which forks by itself can do the same +-- with 'reserveManaged' and 'takeReservation', which this is made of. +forkManagedBy + :: ThreadManager + -> (((forall x. IO x -> IO x) -> IO ()) -> IO a) + -- ^ The fork to make the thread with + -> String + -- ^ Thread name + -> ((forall x. IO x -> IO x) -> IO ()) + -- ^ Action with unmask argument + -> IO a +forkManagedBy mgr fork label io = forkManagedByFinally mgr fork label io $ return () + +-- | Like 'forkManagedBy', but with a cleanup function. +forkManagedByFinally + :: ThreadManager + -> (((forall x. IO x -> IO x) -> IO ()) -> IO a) + -- ^ The fork to make the thread with + -> String + -- ^ Thread name + -> ((forall x. IO x -> IO x) -> IO ()) + -- ^ Action with unmask argument + -> IO () + -- ^ Cleanup: will always run, regardless of how the thread ends + -> IO a +forkManagedByFinally mgr fork label io final = + E.bracketOnError (reserveManaged mgr) (release mgr) $ \rsv -> + fork $ \unmask -> managed mgr rsv label final $ \_ -> io unmask + -- | Fork a managed thread with a handle created by a timeout manager. +-- +-- The time manager is the caller's, since this manager has none: owning a +-- thread and timing it out are separate things, and only this pair of +-- functions needs both. What needs them together is the lock that keeps +-- the timeout and 'stopAfter' from both throwing at the thread. forkManagedTimeout :: ThreadManager + -> T.Manager + -- ^ Time manager -> String -- ^ Thread name -> (T.Handle -> IO ()) -- ^ Action with timeout handle -> IO () -forkManagedTimeout (ThreadManager timmgr var) label io = - void $ forkIO $ do - labelMe label - E.bracket (setup var) (clear var) $ \(_n, wtid, ref) -> - E.handle ignore $ T.withHandle timmgr (lockAndKill wtid ref ex) io +forkManagedTimeout mgr timmgr label io = + forkManagedTimeoutFinally mgr timmgr label io $ return () + +-- | Like 'forkManagedTimeout', but with a cleanup function, run regardless of +-- how the action ends. An exception from the action is not caught: it +-- ends the thread as it would under 'forkManagedTimeout'. +forkManagedTimeoutFinally + :: ThreadManager + -> T.Manager + -- ^ Time manager + -> String + -- ^ Thread name + -> (T.Handle -> IO ()) + -- ^ Action with timeout handle + -> IO () + -- ^ Cleanup: will always run, regardless of how the thread ends + -> IO () +forkManagedTimeoutFinally mgr timmgr label io final = + E.bracketOnError (reserveManaged mgr) (release mgr) $ \rsv -> + void $ forkIO $ + managed mgr rsv label final $ \(_n, ManagedThread wtid ref) -> + T.withHandle timmgr (lockAndKill wtid ref ex) io where ex = KilledByThreadManager Nothing --- | Fork a managed thread with a cleanup function. -forkManagedFinally +-- | The body of a managed thread, under its own label, taking the place +-- kept for it. +managed :: ThreadManager + -> Reservation -> String - -- ^ Thread name -> IO () - -- ^ Action + -> ((Key, ManagedThread) -> IO ()) -> IO () - -- ^ Cleanup function +managed mgr rsv label final body = do + labelMe label + taking mgr rsv final body + +-- | Running the body of a thread which had a place kept for it. The +-- place is given back only once the thread is recorded, so that it is +-- counted throughout. +taking + :: ThreadManager + -> Reservation -> IO () -forkManagedFinally mgr label io final = - forkManagedUnmask mgr label $ \restore -> - E.try (restore io) >>= \(_ :: Either E.SomeException ()) -> final + -> ((Key, ManagedThread) -> IO ()) + -> IO () +taking mgr rsv final body = + recorded mgr (give >> final) $ \key -> give >> body key + where + give = release mgr rsv --- | Fork a managed thread with a handle created by a timeout manager --- and with a cleanup function. -forkManagedTimeoutFinally +-- | Running the body of a managed thread with the thread recorded. +-- +-- The cleanup runs regardless of how the body ends, and while the thread is still +-- recorded, so that a manager which has none left has none whose cleanup +-- is still running either. +-- +-- A thread forked before the manager was stopped and scheduled after it +-- is not recorded and does not run its body: there is nobody left to +-- kill it, and running it is what the stop was for. +recorded :: ThreadManager - -> String - -- ^ Thread name - -> (T.Handle -> IO ()) - -- ^ Action with timeout handle -> IO () - -- ^ Cleanup function + -> ((Key, ManagedThread) -> IO ()) -> IO () -forkManagedTimeoutFinally mgr label io final = E.mask $ \restore -> - forkManagedTimeout mgr label $ \th -> - E.try (restore $ io th) >>= \(_ :: Either E.SomeException ()) -> final +recorded mgr final body = + E.handle ignore $ + E.bracket (setup mgr) (mapM_ $ clear mgr) $ \mkey -> + mapM_ body mkey `E.finally` final -setup :: TVar (Map Key ManagedThread) -> IO (Key, Weak ThreadId, IORef Bool) -setup var = do +-- | Recording this thread, or 'Nothing' once the manager has stopped. +setup + :: ThreadManager + -> IO (Maybe (Key, ManagedThread)) +setup ThreadManager{..} = do (wtid, n) <- myWeakThreadId ref <- newIORef False let ent = ManagedThread wtid ref -- asking to throw KilledByThreadManager to me - atomically $ modifyTVar' var $ Map.insert n ent - return (n, wtid, ref) + atomically $ do + stopped <- readTVar managerStopped + if stopped + then return Nothing + else do + modifyTVar' managedThreads $ Map.insert n ent + return $ Just (n, ent) lockAndKill :: Exception e => Weak ThreadId -> IORef Bool -> e -> IO () lockAndKill wtid ref e = do @@ -232,15 +429,24 @@ Just tid -> E.throwTo tid e clear - :: TVar (Map Key ManagedThread) - -> (Key, Weak ThreadId, IORef Bool) + :: ThreadManager + -> (Key, ManagedThread) -> IO () -clear var (n, _, _) = atomically $ modifyTVar' var $ Map.delete n +clear ThreadManager{..} (n, _) = + atomically $ modifyTVar' managedThreads $ Map.delete n ignore :: KilledByThreadManager -> IO () ignore (KilledByThreadManager _) = return () -- | Wait until all managed threads are finished. +-- +-- After 'stopAfter' this waits for the threads it stopped to end, not +-- merely for them to have been told. See there for the thread that +-- never ends. +-- +-- A place kept by 'reserveManaged' and never taken is never given back, +-- so this never returns for a caller which reserves and then fails to +-- fork. waitUntilAllGone :: ThreadManager -> IO () waitUntilAllGone tm = atomically $ @@ -248,9 +454,28 @@ -- | STM action that checks if all managed threads are finished. isAllGone :: ThreadManager -> STM Bool -isAllGone (ThreadManager _timmgr var) = - Map.null <$> readTVar var +isAllGone tm = (== 0) <$> countManaged tm +-- | STM action for how many threads are managed, counting the places +-- kept by 'reserveManaged' for threads which have not started, and the +-- threads 'stopAfter' has stopped which have not ended yet. +-- +-- Throws 'AssertionFailed' if the count of places has gone negative, +-- which happens when a reservation is taken by a manager other than the +-- one that kept it. A mistake of that kind which does not drive the +-- count negative goes unnoticed. +countManaged :: ThreadManager -> STM Int +countManaged ThreadManager{..} = do + places <- readTVar reservedPlaces + when (places < 0) $ + throwSTM $ + AssertionFailed $ + "System.ThreadManager: " + ++ show places + ++ " reserved places; a reservation was taken by a" + ++ " manager other than its own" + (+ places) . Map.size <$> readTVar managedThreads + ---------------------------------------------------------------- myWeakThreadId :: IO (Weak ThreadId, Key) @@ -264,12 +489,6 @@ labelMe l = do tid <- myThreadId labelThread tid l - --- | Registering a 'T.TimeoutAction' and unregister its 'T.Handle' --- when the body action is finished. -withHandle - :: ThreadManager -> T.TimeoutAction -> (T.Handle -> IO a) -> IO a -withHandle (ThreadManager timmgr _) = T.withHandle timmgr #if __GLASGOW_HASKELL__ < 908 fromThreadId :: ThreadId -> Word64 diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -22,7 +22,17 @@ it "tests don't work on windows" $ pendingWith "requires more testing on a Windows machine" #else -import Control.Concurrent (threadDelay) +import Control.Concurrent ( + MVar, + forkIO, + newEmptyMVar, + putMVar, + takeMVar, + threadDelay, + tryPutMVar, + ) +import Control.Concurrent.STM (atomically) +import Control.Exception (AssertionFailed (..), finally, throwIO) import Control.Monad (forM_, void) import Data.IORef as I ( IORef, @@ -31,12 +41,107 @@ readIORef, writeIORef, ) +import GHC.Conc.Sync ( + getUncaughtExceptionHandler, + setUncaughtExceptionHandler, + ) +import System.ThreadManager ( + ThreadManager, + countManaged, + forkManaged, + forkManagedFinally, + forkManagedTimeout, + forkManagedTimeoutFinally, + forkManagedUnmaskFinally, + newThreadManager, + reserveManaged, + stopAfter, + takeReservation, + waitUntilAllGone, + ) import System.TimeManager import System.TimeManager.Internal import Test.HUnit (assertBool) main :: IO () main = hspec $ do + describe "ThreadManager, once stopped" $ do + -- 'setup' refuses to record a thread forked before the stop and + -- scheduled after it, by throwing. That must not escape the fork, + -- and must not take the cleanup with it. + it "does not let forkManagedTimeout's refusal escape the fork" $ do + tm <- newThreadManager + stopAfter tm (return ()) $ \_ -> return () + ran <- freshRef + escaped <- freshRef + before <- getUncaughtExceptionHandler + setUncaughtExceptionHandler $ \_ -> I.writeIORef escaped True + forkManagedTimeout tm defaultManager "probe" $ \_ -> I.writeIORef ran True + threadDelay 200_000 + setUncaughtExceptionHandler before + ran `refShouldBe` False + escaped `refShouldBe` False + + itRunsTheCleanupOf "forkManagedFinally" $ + \tm label -> forkManagedFinally tm label (return ()) + + itRunsTheCleanupOf "forkManagedTimeoutFinally" $ + \tm label -> forkManagedTimeoutFinally tm defaultManager label (\_ -> return ()) + + itRunsTheCleanupOf "forkManagedUnmaskFinally" $ + \tm label -> forkManagedUnmaskFinally tm label (\_ -> return ()) + + describe "ThreadManager, the action of a fork with a cleanup" $ do + itLetsTheExceptionOutOf "forkManagedFinally" forkManagedFinally + + itLetsTheExceptionOutOf "forkManagedTimeoutFinally" $ + \tm label io -> forkManagedTimeoutFinally tm defaultManager label (\_ -> io) + + itLetsTheExceptionOutOf "forkManagedUnmaskFinally" $ + \tm label io -> forkManagedUnmaskFinally tm label (\unmask -> unmask io) + + describe "ThreadManager" $ do + it "fails loudly when a reservation is taken by another manager" $ do + a <- newThreadManager + b <- newThreadManager + rsv <- reserveManaged a + takeReservation b rsv (return ()) + atomically (countManaged b) + `shouldThrow` (\(AssertionFailed _) -> True) + + it "has none left only once their cleanups are done" $ do + tm <- newThreadManager + ref <- freshRef + forkManagedFinally + tm + "probe" + (threadDelay 100_000) + (threadDelay 300_000 >> I.writeIORef ref True) + -- The action is over and the cleanup is still running. + threadDelay 200_000 + waitUntilAllGone tm + ref `refShouldBe` True + + it "still owns a thread it killed until that thread is gone" $ do + tm <- newThreadManager + ref <- freshRef + started <- newEmptyMVar + -- The cleanup here is the thread's own, not one the manager + -- runs for it, so what is tested is an ordinary managed + -- thread unwinding. + forkManaged tm "probe" $ + (putMVar started () >> threadDelay 10_000_000) + `finally` (threadDelay 300_000 >> I.writeIORef ref True) + takeMVar started + threadDelay 50_000 + -- 'throwTo' waits for the exception to be taken, not for the + -- thread to be gone. + stopAfter tm (return ()) $ \_ -> return () + threadDelay 50_000 + atomically (countManaged tm) `shouldReturn` 1 + waitUntilAllGone tm + ref `refShouldBe` True + describe "TimeManager" $ do it "defaultManager == no manager" $ defaultManager `shouldSatisfy` isNoManager @@ -202,6 +307,48 @@ mgr1 :: Manager mgr1 = Manager 1 + +-- | The cleanup of a fork that takes one runs even when the manager has +-- been stopped and the thread is refused. +itRunsTheCleanupOf + :: String + -> (ThreadManager -> String -> IO () -> IO ()) + -- ^ The fork, with its action already given and its cleanup to come + -> Spec +itRunsTheCleanupOf name fork = + it ("runs the cleanup of " ++ name) $ do + tm <- newThreadManager + stopAfter tm (return ()) $ \_ -> return () + done <- newEmptyMVar + fork tm "probe" $ putMVar done () + ranWithin 500_000 done `shouldReturn` True + +-- | An exception from the action of a fork that takes a cleanup leaves the +-- thread, after the cleanup has run. +itLetsTheExceptionOutOf + :: String + -> (ThreadManager -> String -> IO () -> IO () -> IO ()) + -> Spec +itLetsTheExceptionOutOf name fork = + it ("lets an exception from the action of " ++ name ++ " out") $ do + tm <- newThreadManager + escaped <- newEmptyMVar + cleaned <- freshRef + before <- getUncaughtExceptionHandler + setUncaughtExceptionHandler $ \_ -> void $ tryPutMVar escaped () + fork tm "probe" (throwIO $ userError "probe") (I.writeIORef cleaned True) + out <- ranWithin 500_000 escaped + setUncaughtExceptionHandler before + out `shouldBe` True + cleaned `refShouldBe` True + +-- | Whether the 'MVar' was filled within the time. +ranWithin :: Int -> MVar () -> IO Bool +ranWithin us var = do + r <- newEmptyMVar + void $ forkIO $ takeMVar var >> putMVar r True + void $ forkIO $ threadDelay us >> putMVar r False + takeMVar r freshRef :: IO (IORef Bool) freshRef = I.newIORef False diff --git a/time-manager.cabal b/time-manager.cabal --- a/time-manager.cabal +++ b/time-manager.cabal @@ -1,6 +1,6 @@ cabal-version: >=1.10 name: time-manager -version: 0.4.0 +version: 0.5.0 license: MIT license-file: LICENSE maintainer: kazu@iij.ad.jp @@ -37,6 +37,7 @@ type: exitcode-stdio-1.0 main-is: test/Spec.hs other-modules: + System.ThreadManager, System.TimeManager, System.TimeManager.Internal build-depends: base @@ -44,5 +45,7 @@ ghc-options: -Wall -threaded build-depends: base >=4.12 && <5, + containers, hspec, - HUnit + HUnit, + stm