time-manager 0.4.0 → 0.5.0

raw patch · 4 files changed

+468/−76 lines, 4 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• ChangeLog.md +23/−0
• System/ThreadManager.hs +292/−73
• test/Spec.hs +148/−1
• time-manager.cabal +5/−2

@@ -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:

@@ -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

@@ -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

@@ -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