threads-supervisor 1.0.4.1 → 1.1.0.0
raw patch · 8 files changed
+128/−113 lines, 8 filesdep ~retry
Dependency ranges changed: retry
Files
- examples/Main.hs +6/−6
- src/Control/Concurrent/Supervisor.hs +2/−2
- src/Control/Concurrent/Supervisor/Bounded.hs +3/−3
- src/Control/Concurrent/Supervisor/Tutorial.hs +9/−9
- src/Control/Concurrent/Supervisor/Types.hs +77/−60
- test/Tests.hs +15/−16
- test/Tests/Bounded.hs +14/−15
- threads-supervisor.cabal +2/−2
examples/Main.hs view
@@ -30,19 +30,19 @@ main :: IO () main = bracketOnError (do- supSpec <- newSupervisorSpec+ supSpec <- newSupervisorSpec OneForOne sup1 <- newSupervisor supSpec sup2 <- newSupervisor supSpec sup1 `monitor` sup2 - _ <- forkSupervised sup2 oneForOne job3+ _ <- forkSupervised sup2 fibonacciRetryPolicy job3 - j1 <- forkSupervised sup1 oneForOne job1- _ <- forkSupervised sup1 oneForOne (job2 j1)- _ <- forkSupervised sup1 oneForOne job4- _ <- forkSupervised sup1 oneForOne job5+ j1 <- forkSupervised sup1 fibonacciRetryPolicy job1+ _ <- forkSupervised sup1 fibonacciRetryPolicy (job2 j1)+ _ <- forkSupervised sup1 fibonacciRetryPolicy job4+ _ <- forkSupervised sup1 fibonacciRetryPolicy job5 _ <- forkIO (go (eventStream sup1)) return sup1) shutdownSupervisor (\_ -> threadDelay 10000000000) where
src/Control/Concurrent/Supervisor.hs view
@@ -33,8 +33,8 @@ -- | Creates a new 'SupervisorSpec'. The reason it doesn't return a -- 'Supervisor' is to force you to call 'supervise' explicitly, in order to start the -- supervisor thread.-newSupervisorSpec :: IO SupervisorSpec-newSupervisorSpec = Types.newSupervisorSpec 0+newSupervisorSpec :: Types.RestartStrategy -> IO SupervisorSpec+newSupervisorSpec strategy = Types.newSupervisorSpec strategy 0 -- $supervise
src/Control/Concurrent/Supervisor/Bounded.hs view
@@ -35,13 +35,13 @@ -- | Creates a new 'SupervisorSpec'. The reason it doesn't return a -- 'Supervisor' is to force you to call 'supervise' explicitly, in order to start the -- supervisor thread.-newSupervisorSpec :: IO SupervisorSpec-newSupervisorSpec = Types.newSupervisorSpec defaultEventQueueSize+newSupervisorSpec :: Types.RestartStrategy -> IO SupervisorSpec+newSupervisorSpec strategy = Types.newSupervisorSpec strategy defaultEventQueueSize -------------------------------------------------------------------------------- -- | Like 'newSupervisorSpec', but give the user control over the size of the -- event queue.-newSupervisorSpecBounded :: Int -> IO SupervisorSpec+newSupervisorSpecBounded :: Types.RestartStrategy -> Int -> IO SupervisorSpec newSupervisorSpecBounded = Types.newSupervisorSpec --------------------------------------------------------------------------------
src/Control/Concurrent/Supervisor/Tutorial.hs view
@@ -118,18 +118,18 @@ -- -- > main :: IO () -- > main = bracketOnError (do--- > supSpec <- newSupervisorSpec+-- > supSpec <- newSupervisorSpec OneForOne -- > -- > sup1 <- newSupervisor supSpec -- > sup2 <- newSupervisor supSpec -- > -- > sup1 `monitor` sup2 -- >--- > _ <- forkSupervised sup2 oneForOne job3+-- > _ <- forkSupervised sup2 fibonacciRetryPolicy job3 -- >--- > j1 <- forkSupervised sup1 oneForOne job1--- > _ <- forkSupervised sup1 oneForOne (job2 j1)--- > _ <- forkSupervised sup1 oneForOne job4+-- > j1 <- forkSupervised sup1 fibonacciRetryPolicy job1+-- > _ <- forkSupervised sup1 fibonacciRetryPolicy (job2 j1)+-- > _ <- forkSupervised sup1 fibonacciRetryPolicy job4 -- > _ <- forkIO (go (eventStream sup1)) -- > return sup1) shutdownSupervisor (\_ -> threadDelay 10000000000) -- > where@@ -147,10 +147,10 @@ -- (from the same spec, but you can create a separate one as well) -- and we ask the first supervisor to monitor the second one. ----- `oneForOne` is a smart constructor for our `RestartStrategy`,which creates--- under the hood a `OneForOne` strategy which is using the `fibonacciBackoff`--- as `RetryPolicy` from the "retry" package. The clear advantage is that--- you are not obliged to use it if you don't like this sensible default;+-- `fibonacciRetryPolicy` is a constructor for the `RetryPolicy`, which creates+-- under the hood a `RetryPolicy` from the "retry" package which is using+-- the `fibonacciBackoff`. The clear advantage is that you are not obliged to use+-- it if you don't like this sensible default; -- `RetryPolicy` is an monoid, so you can compose retry policies as you wish. -- -- The `RetryPolicy` will also be responsible for determining whether a thread can be
src/Control/Concurrent/Supervisor/Types.hs view
@@ -25,8 +25,8 @@ -- * Creating a new supervisor -- $sup , newSupervisor- -- * Restart Strategies- , oneForOne+ -- * Restart Policies+ , fibonacciRetryPolicy -- * Stopping a supervisor -- $shutdown , shutdownSupervisor@@ -59,6 +59,7 @@ -------------------------------------------------------------------------------- data Supervisor_ q a = Supervisor_ { _sp_myTid :: !(Maybe ThreadId)+ , _sp_strategy :: !RestartStrategy , _sp_children :: !(IORef (Map.HashMap ThreadId (Child_ q))) , _sp_mailbox :: TChan DeadLetter , _sp_eventStream :: q SupervisionEvent@@ -88,8 +89,8 @@ data DeadLetter = DeadLetter ThreadId SomeException ---------------------------------------------------------------------------------data Child_ q = Worker !RestartStrategy RestartAction- | Supvsr !RestartStrategy !(Supervisor_ q Initialised)+data Child_ q = Worker !RetryStatus (RetryPolicyM IO) RestartAction+ | Supvsr !RetryStatus (RetryPolicyM IO) !(Supervisor_ q Initialised) -------------------------------------------------------------------------------- type RestartAction = ThreadId -> IO ThreadId@@ -98,25 +99,22 @@ data SupervisionEvent = ChildBorn !ThreadId !UTCTime | ChildDied !ThreadId !SomeException !UTCTime- | ChildRestarted !ThreadId !ThreadId !RestartStrategy !UTCTime- | ChildRestartLimitReached !ThreadId !RestartStrategy !UTCTime+ | ChildRestarted !ThreadId !ThreadId !RetryStatus !UTCTime+ | ChildRestartLimitReached !ThreadId !RetryStatus !UTCTime | ChildFinished !ThreadId !UTCTime deriving Show -------------------------------------------------------------------------------- -- | Erlang inspired strategies. At the moment only the 'OneForOne' is -- implemented.-data RestartStrategy =- OneForOne !Int RetryPolicy--instance Show RestartStrategy where- show (OneForOne r _) = "OneForOne (Restarted " <> show r <> " times)"+data RestartStrategy = OneForOne+ deriving Show -------------------------------------------------------------------------------- -- | Smart constructor which offers a default throttling based on -- fibonacci numbers.-oneForOne :: RestartStrategy-oneForOne = OneForOne 0 $ fibonacciBackoff 100+fibonacciRetryPolicy :: RetryPolicyM IO+fibonacciRetryPolicy = fibonacciBackoff 100 -- $new -- In order to create a new supervisor, you need a `SupervisorSpec`,@@ -127,12 +125,12 @@ -- | Creates a new 'SupervisorSpec'. The reason it doesn't return a -- 'Supervisor' is to force you to call 'supervise' explicitly, in order to start the -- supervisor thread.-newSupervisorSpec :: QueueLike q => Int -> IO (SupervisorSpec0 q)-newSupervisorSpec size = do+newSupervisorSpec :: QueueLike q => RestartStrategy -> Int -> IO (SupervisorSpec0 q)+newSupervisorSpec strategy size = do tkn <- newTChanIO evt <- newQueueIO size ref <- newIORef Map.empty- return $ Supervisor_ Nothing ref tkn evt+ return $ Supervisor_ Nothing strategy ref tkn evt -- $supervise @@ -142,6 +140,7 @@ mbx <- atomically $ dupTChan (_sp_mailbox spec) return Supervisor_ { _sp_myTid = Just tid+ , _sp_strategy = _sp_strategy spec , _sp_mailbox = mbx , _sp_children = _sp_children spec , _sp_eventStream = _sp_eventStream spec@@ -154,12 +153,12 @@ -- to react. It's using a bounded queue to explicitly avoid memory leaks in case -- you do not want to drain the queue to listen to incoming events. eventStream :: QueueLike q => Supervisor0 q -> q SupervisionEvent-eventStream (Supervisor_ _ _ _ e) = e+eventStream (Supervisor_ _ _ _ _ e) = e -------------------------------------------------------------------------------- -- | Returns the number of active threads at a given moment in time. activeChildren :: QueueLike q => Supervisor0 q -> IO Int-activeChildren (Supervisor_ _ chRef _ _) = do+activeChildren (Supervisor_ _ _ chRef _ _) = do readIORef chRef >>= return . length . Map.keys -- $shutdown@@ -169,7 +168,7 @@ -- be killed as well. To do so, we explore the children tree, killing workers as we go, -- and recursively calling `shutdownSupervisor` in case we hit a monitored `Supervisor`. shutdownSupervisor :: QueueLike q => Supervisor0 q -> IO ()-shutdownSupervisor (Supervisor_ sId chRef _ _) = do+shutdownSupervisor (Supervisor_ sId _ chRef _ _) = do case sId of Nothing -> return () Just tid -> do@@ -180,8 +179,8 @@ processChildren [] = return () processChildren (x:xs) = do case x of- (tid, Worker _ _) -> killThread tid- (_, Supvsr _ s) -> shutdownSupervisor s+ (tid, Worker _ _ _) -> killThread tid+ (_, Supvsr _ _ s) -> shutdownSupervisor s processChildren xs -- $fork@@ -191,14 +190,14 @@ forkSupervised :: QueueLike q => Supervisor0 q -- ^ The 'Supervisor'- -> RestartStrategy- -- ^ The 'RestartStrategy' to use+ -> RetryPolicyM IO+ -- ^ The retry policy to use -> IO () -- ^ The computation to run -> IO ThreadId-forkSupervised sup@Supervisor_{..} str act =+forkSupervised sup@Supervisor_{..} policy act = bracket (supervised sup act) return $ \newChild -> do- let ch = Worker str (const (supervised sup act))+ let ch = Worker defaultRetryStatus policy (const (supervised sup act)) atomicModifyIORef' _sp_children $ \chMap -> (Map.insert newChild ch chMap, ()) now <- getCurrentTime atomically $ writeQueue _sp_eventStream (ChildBorn newChild now)@@ -207,16 +206,59 @@ -------------------------------------------------------------------------------- supervised :: QueueLike q => Supervisor0 q -> IO () -> IO ThreadId supervised Supervisor_{..} act = forkFinally act $ \res -> case res of- Left ex -> bracket myThreadId return $ \myId -> atomically $ + Left ex -> bracket myThreadId return $ \myId -> atomically $ writeTChan _sp_mailbox (DeadLetter myId ex) Right _ -> bracket myThreadId return $ \myId -> do now <- getCurrentTime atomicModifyIORef' _sp_children $ \chMap -> (Map.delete myId chMap, ()) atomically $ writeQueue _sp_eventStream (ChildFinished myId now) +restartChild :: QueueLike q => SupervisorSpec0 q -> UTCTime -> ThreadId -> IO Bool+restartChild (Supervisor_ myId myStrategy myChildren myMailbox myStream) now newDeath = do+ chMap <- readIORef myChildren+ case Map.lookup newDeath chMap of+ Nothing -> return False+ Just (Worker rState rPolicy act) ->+ runRetryPolicy rState rPolicy emitEventChildRestartLimitReached $ \newRState -> do+ let ch = Worker newRState rPolicy act+ newThreadId <- act newDeath+ writeIORef myChildren (Map.insert newThreadId ch $! Map.delete newDeath chMap)+ emitEventChildRestarted newThreadId newRState+ Just (Supvsr rState rPolicy s@(Supervisor_ _ str mbx cld es)) ->+ runRetryPolicy rState rPolicy emitEventChildRestartLimitReached $ \newRState -> do+ let node = Supervisor_ myId myStrategy myChildren myMailbox myStream+ let ch = (Supvsr newRState rPolicy s)+ -- TODO: shutdown children?+ newThreadId <- supervised node (handleEvents $ Supervisor_ Nothing str mbx cld es)+ writeIORef myChildren (Map.insert newThreadId ch $! Map.delete newDeath chMap)+ emitEventChildRestarted newThreadId newRState+ where+ emitEventChildRestarted newThreadId newRState = atomically $+ writeQueue myStream (ChildRestarted newDeath newThreadId newRState now)+ emitEventChildRestartLimitReached newRState = atomically $+ writeQueue myStream (ChildRestartLimitReached newDeath newRState now)+ runRetryPolicy :: RetryStatus+ -> RetryPolicyM IO+ -> (RetryStatus -> IO ())+ -> (RetryStatus -> IO ())+ -> IO Bool+ runRetryPolicy rState rPolicy ifAbort ifThrottle = do+ maybeDelay <- getRetryPolicyM rPolicy rState+ case maybeDelay of+ Nothing -> ifAbort rState >> return False+ Just delay ->+ let newRState = rState { rsIterNumber = rsIterNumber rState + 1+ , rsCumulativeDelay = rsCumulativeDelay rState + delay+ , rsPreviousDelay = Just (maybe 0 (const delay) (rsPreviousDelay rState))+ }+ in threadDelay delay >> ifThrottle newRState >> return True++restartOneForOne :: QueueLike q => SupervisorSpec0 q -> UTCTime -> ThreadId -> IO Bool+restartOneForOne sup now newDeath = restartChild sup now newDeath+ -------------------------------------------------------------------------------- handleEvents :: QueueLike q => SupervisorSpec0 q -> IO ()-handleEvents sp@(Supervisor_ myId myChildren myMailbox myStream) = do+handleEvents sup@(Supervisor_ _ myStrategy _ myMailbox myStream) = do (DeadLetter newDeath ex) <- atomically $ readTChan myMailbox now <- getCurrentTime atomically $ writeQueue myStream (ChildDied newDeath ex now)@@ -225,39 +267,14 @@ -- Note to the skeptical: It's perfectly fine do put `undefined` here, -- as `typeOf` does not inspect the content (try in GHCi!) case typeOf ex == (typeOf (undefined :: AsyncException)) of- True -> handleEvents sp+ True -> handleEvents sup False -> do- chMap <- readIORef myChildren- case Map.lookup newDeath chMap of- Nothing -> return ()- Just (Worker str act) ->- applyStrategy str (\newStr -> do- atomically $- writeQueue myStream (ChildRestartLimitReached newDeath newStr now)) $ \newStr -> do- let ch = Worker newStr act- newThreadId <- act newDeath- writeIORef myChildren (Map.insert newThreadId ch $! Map.delete newDeath chMap)- atomically $ writeQueue myStream (ChildRestarted newDeath newThreadId newStr now)- Just (Supvsr str s@(Supervisor_ _ mbx cld es)) ->- applyStrategy str (\newStr -> do- atomically $- writeQueue myStream (ChildRestartLimitReached newDeath newStr now)) $ \newStr -> do- let node = Supervisor_ myId myChildren myMailbox myStream- let ch = (Supvsr newStr s)- newThreadId <- supervised node (handleEvents $ Supervisor_ Nothing mbx cld es)- writeIORef myChildren (Map.insert newThreadId ch $! Map.delete newDeath chMap)- atomically $ writeQueue myStream (ChildRestarted newDeath newThreadId newStr now)- handleEvents sp- where- applyStrategy :: RestartStrategy- -> (RestartStrategy -> IO ())- -> (RestartStrategy -> IO ())- -> IO ()- applyStrategy (OneForOne currentRestarts retryPol) ifAbort ifThrottle = do- let newStr = OneForOne (currentRestarts + 1) retryPol- case getRetryPolicy retryPol (currentRestarts + 1) of- Nothing -> ifAbort newStr- Just delay -> threadDelay delay >> ifThrottle newStr+ successful <- case myStrategy of+ OneForOne -> restartOneForOne sup now newDeath+ unless successful $ do+ -- TODO: shutdown supervisor?+ return ()+ handleEvents sup -- $monitor @@ -271,7 +288,7 @@ -- Thanks to the fact that for the supervisor the restart means we just copy over -- its internal state, it should be perfectly fine to do so. monitor :: QueueLike q => Supervisor0 q -> Supervisor0 q -> IO ()-monitor (Supervisor_ _ _ mbox _) (Supervisor_ mbId _ _ _) = do+monitor (Supervisor_ _ _ _ mbox _) (Supervisor_ mbId _ _ _ _) = do case mbId of Nothing -> return () Just tid -> atomically $
test/Tests.hs view
@@ -11,7 +11,6 @@ import Control.Monad import Control.Retry import Control.Monad.Trans.Class-import Control.Applicative import Control.Concurrent import Control.Concurrent.STM import Control.Exception@@ -84,9 +83,9 @@ Nothing -> return [] ---------------------------------------------------------------------------------assertContainsNMsg :: (SupervisionEvent -> Bool) +assertContainsNMsg :: (SupervisionEvent -> Bool) -> Int- -> [SupervisionEvent] + -> [SupervisionEvent] -> IO () assertContainsNMsg _ 0 _ = HUnit.assertBool "" True assertContainsNMsg _ x [] = do@@ -120,7 +119,7 @@ assertContainsRestartMsg :: [SupervisionEvent] -> ThreadId -> IOProperty () assertContainsRestartMsg [] _ = QM.assert False assertContainsRestartMsg (x:xs) tid = case x of- ((ChildRestarted old _ _ _)) -> + ((ChildRestarted old _ _ _)) -> if old == tid then QM.assert True else assertContainsRestartMsg xs tid _ -> assertContainsRestartMsg xs tid @@ -128,18 +127,18 @@ -- Control.Concurrent.Supervisor tests test1SupThreadNoEx :: IOProperty () test1SupThreadNoEx = forAllM randomLiveTime $ \ttl -> do- supSpec <- lift newSupervisorSpec+ supSpec <- lift $ newSupervisorSpec OneForOne sup <- lift $ newSupervisor supSpec- _ <- lift (forkSupervised sup oneForOne (forever $ threadDelay ttl))+ _ <- lift (forkSupervised sup fibonacciRetryPolicy (forever $ threadDelay ttl)) assertActiveThreads sup (== 1) lift $ shutdownSupervisor sup -------------------------------------------------------------------------------- test1SupThreadPrematureDemise :: IOProperty () test1SupThreadPrematureDemise = forAllM randomLiveTime $ \ttl -> do- supSpec <- lift newSupervisorSpec+ supSpec <- lift $ newSupervisorSpec OneForOne sup <- lift $ newSupervisor supSpec- tid <- lift (forkSupervised sup oneForOne (forever $ threadDelay ttl))+ tid <- lift (forkSupervised sup fibonacciRetryPolicy (forever $ threadDelay ttl)) lift $ do throwTo tid (AssertionFailed "You must die") threadDelay ttl --give time to restart the thread@@ -150,10 +149,10 @@ -------------------------------------------------------------------------------- fromAction :: Supervisor -> ThreadAction -> IO ThreadId-fromAction s Live = forkSupervised s oneForOne (forever $ threadDelay 100000000)-fromAction s (DieAfter (TTL ttl)) = forkSupervised s oneForOne (threadDelay ttl)-fromAction s (ThrowAfter (TTL ttl)) = forkSupervised s oneForOne (do- threadDelay ttl +fromAction s Live = forkSupervised s fibonacciRetryPolicy (forever $ threadDelay 100000000)+fromAction s (DieAfter (TTL ttl)) = forkSupervised s fibonacciRetryPolicy (threadDelay ttl)+fromAction s (ThrowAfter (TTL ttl)) = forkSupervised s fibonacciRetryPolicy (do+ threadDelay ttl throwIO $ AssertionFailed "die") --------------------------------------------------------------------------------@@ -172,7 +171,7 @@ -- the side effects strikes. testKillingSpree :: IOProperty () testKillingSpree = forAllM arbitrary $ \ep@(ExecutionPlan _ acts) -> do- supSpec <- lift newSupervisorSpec+ supSpec <- lift $ newSupervisorSpec OneForOne sup <- lift $ newSupervisor supSpec _ <- forM acts $ lift . fromAction sup lift (threadDelay $ maxWait acts * 2)@@ -187,7 +186,7 @@ testSupCleanup :: IOProperty () testSupCleanup = forAllM (vectorOf 100 arbitrary) $ \ttls -> do let acts = map DieAfter ttls- supSpec <- lift newSupervisorSpec+ supSpec <- lift $ newSupervisorSpec OneForOne sup <- lift $ newSupervisor supSpec _ <- forM acts $ lift . fromAction sup lift (threadDelay $ maxWait acts * 2)@@ -198,9 +197,9 @@ testTooManyRestarts :: Assertion testTooManyRestarts = do- supSpec <- newSupervisorSpec+ supSpec <- newSupervisorSpec OneForOne sup <- newSupervisor supSpec- _ <- forkSupervised sup (OneForOne 0 $ limitRetries 5) $ error "die"+ _ <- forkSupervised sup (limitRetries 5) $ error "die" threadDelay 2000000 q <- qToList (eventStream sup) assertContainsNLimitReached 1 q
test/Tests/Bounded.hs view
@@ -11,7 +11,6 @@ import Control.Monad import Control.Retry import Control.Monad.Trans.Class-import Control.Applicative import Control.Concurrent import Control.Concurrent.STM import Control.Exception@@ -84,9 +83,9 @@ Nothing -> return [] ---------------------------------------------------------------------------------assertContainsNMsg :: (SupervisionEvent -> Bool) +assertContainsNMsg :: (SupervisionEvent -> Bool) -> Int- -> [SupervisionEvent] + -> [SupervisionEvent] -> IO () assertContainsNMsg _ 0 _ = HUnit.assertBool "" True assertContainsNMsg _ x [] = do@@ -120,7 +119,7 @@ assertContainsRestartMsg :: [SupervisionEvent] -> ThreadId -> IOProperty () assertContainsRestartMsg [] _ = QM.assert False assertContainsRestartMsg (x:xs) tid = case x of- ((ChildRestarted old _ _ _)) -> + ((ChildRestarted old _ _ _)) -> if old == tid then QM.assert True else assertContainsRestartMsg xs tid _ -> assertContainsRestartMsg xs tid @@ -128,18 +127,18 @@ -- Control.Concurrent.Supervisor tests test1SupThreadNoEx :: IOProperty () test1SupThreadNoEx = forAllM randomLiveTime $ \ttl -> do- supSpec <- lift newSupervisorSpec+ supSpec <- lift $ newSupervisorSpec OneForOne sup <- lift $ newSupervisor supSpec- _ <- lift (forkSupervised sup oneForOne (forever $ threadDelay ttl))+ _ <- lift (forkSupervised sup fibonacciRetryPolicy (forever $ threadDelay ttl)) assertActiveThreads sup (== 1) lift $ shutdownSupervisor sup -------------------------------------------------------------------------------- test1SupThreadPrematureDemise :: IOProperty () test1SupThreadPrematureDemise = forAllM randomLiveTime $ \ttl -> do- supSpec <- lift newSupervisorSpec+ supSpec <- lift $ newSupervisorSpec OneForOne sup <- lift $ newSupervisor supSpec- tid <- lift (forkSupervised sup oneForOne (forever $ threadDelay ttl))+ tid <- lift (forkSupervised sup fibonacciRetryPolicy (forever $ threadDelay ttl)) lift $ do throwTo tid (AssertionFailed "You must die") threadDelay ttl --give time to restart the thread@@ -150,9 +149,9 @@ -------------------------------------------------------------------------------- fromAction :: Supervisor -> ThreadAction -> IO ThreadId-fromAction s Live = forkSupervised s oneForOne (forever $ threadDelay 100000000)-fromAction s (DieAfter (TTL ttl)) = forkSupervised s oneForOne (threadDelay ttl)-fromAction s (ThrowAfter (TTL ttl)) = forkSupervised s oneForOne (do+fromAction s Live = forkSupervised s fibonacciRetryPolicy (forever $ threadDelay 100000000)+fromAction s (DieAfter (TTL ttl)) = forkSupervised s fibonacciRetryPolicy (threadDelay ttl)+fromAction s (ThrowAfter (TTL ttl)) = forkSupervised s fibonacciRetryPolicy (do threadDelay ttl throwIO $ AssertionFailed "die") @@ -172,7 +171,7 @@ -- the side effects strikes. testKillingSpree :: IOProperty () testKillingSpree = forAllM arbitrary $ \ep@(ExecutionPlan _ acts) -> do- supSpec <- lift newSupervisorSpec+ supSpec <- lift $ newSupervisorSpec OneForOne sup <- lift $ newSupervisor supSpec _ <- forM acts $ lift . fromAction sup lift (threadDelay $ maxWait acts * 2)@@ -187,7 +186,7 @@ testSupCleanup :: IOProperty () testSupCleanup = forAllM (vectorOf 100 arbitrary) $ \ttls -> do let acts = map DieAfter ttls- supSpec <- lift newSupervisorSpec+ supSpec <- lift $ newSupervisorSpec OneForOne sup <- lift $ newSupervisor supSpec _ <- forM acts $ lift . fromAction sup lift (threadDelay $ maxWait acts * 2)@@ -198,9 +197,9 @@ testTooManyRestarts :: Assertion testTooManyRestarts = do- supSpec <- newSupervisorSpec+ supSpec <- newSupervisorSpec OneForOne sup <- newSupervisor supSpec- _ <- forkSupervised sup (OneForOne 0 $ limitRetries 5) $ error "die"+ _ <- forkSupervised sup (limitRetries 5) $ error "die" threadDelay 2000000 q <- qToList (eventStream sup) assertContainsNLimitReached 1 q
threads-supervisor.cabal view
@@ -1,5 +1,5 @@ name: threads-supervisor-version: 1.0.4.1+version: 1.1.0.0 synopsis: Simple, IO-based library for Erlang-style thread supervision description: Simple, IO-based library for Erlang-style thread supervision license: MIT@@ -27,7 +27,7 @@ build-depends: base >= 4.6 && < 6, unordered-containers >= 0.2.0.0 && < 0.5.0.0,- retry >= 0.5 && < 0.10,+ retry >= 0.7 && < 0.10, stm >= 2.4, time >= 1.2 hs-source-dirs: src