{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE Rank2Types #-}
-- NOTICE: Some of these tests are /unsafe/, and will fail intermittently, since
-- they rely on ordering constraints which the Cloud Haskell runtime does not
-- guarantee.
module Main where
import Control.Concurrent.MVar
( MVar
, newMVar
, putMVar
, takeMVar
)
import qualified Control.Exception as Ex
import Control.Exception (throwIO)
import Control.Distributed.Process hiding (call, monitor, finally)
import Control.Distributed.Process.Closure
import Control.Distributed.Process.Node
import Control.Distributed.Process.Extras.Internal.Types
import Control.Distributed.Process.Extras.Internal.Primitives
import Control.Distributed.Process.Extras.SystemLog
( LogLevel(Debug)
, systemLogFile
, addFormatter
, debug
, logChannel
)
import Control.Distributed.Process.Extras.Time
import Control.Distributed.Process.Extras.Timer
import Control.Distributed.Process.Supervisor hiding (start, shutdown)
import qualified Control.Distributed.Process.Supervisor as Supervisor
import Control.Distributed.Process.Supervisor.Management
( MxSupervisor(..)
, monitorSupervisor
, unmonitorSupervisor
, supervisionMonitor
)
import Control.Distributed.Process.ManagedProcess.Client (shutdown)
import Control.Distributed.Process.Serializable()
import Control.Distributed.Static (staticLabel)
import Control.Monad (void, unless, forM_, forM)
import Control.Monad.Catch (finally)
import Control.Rematch
( equalTo
, is
, isNot
, isNothing
, isJust
)
import Data.ByteString.Lazy (empty)
import Data.Maybe (catMaybes)
#if !MIN_VERSION_base(4,6,0)
import Prelude hiding (catch)
#endif
import Test.HUnit (Assertion, assertFailure)
import Test.Framework (Test, testGroup)
import Test.Framework.Providers.HUnit (testCase)
import TestUtils hiding (waitForExit)
import qualified Network.Transport as NT
import System.Random (mkStdGen, randomR)
-- test utilities
expectedExitReason :: ProcessId -> String
expectedExitReason sup = "killed-by=" ++ (show sup) ++
",reason=StoppedBySupervisor"
defaultWorker :: ChildStart -> ChildSpec
defaultWorker clj =
ChildSpec
{
childKey = ""
, childType = Worker
, childRestart = Temporary
, childRestartDelay = Nothing
, childStop = StopImmediately
, childStart = clj
, childRegName = Nothing
}
tempWorker :: ChildStart -> ChildSpec
tempWorker clj =
(defaultWorker clj)
{
childKey = "temp-worker"
, childRestart = Temporary
}
transientWorker :: ChildStart -> ChildSpec
transientWorker clj =
(defaultWorker clj)
{
childKey = "transient-worker"
, childRestart = Transient
}
intrinsicWorker :: ChildStart -> ChildSpec
intrinsicWorker clj =
(defaultWorker clj)
{
childKey = "intrinsic-worker"
, childRestart = Intrinsic
}
permChild :: ChildStart -> ChildSpec
permChild clj =
(defaultWorker clj)
{
childKey = "perm-child"
, childRestart = Permanent
}
ensureProcessIsAlive :: ProcessId -> Process ()
ensureProcessIsAlive pid = do
result <- isProcessAlive pid
expectThat result $ is True
runInTestContext :: LocalNode
-> MVar ()
-> ShutdownMode
-> RestartStrategy
-> [ChildSpec]
-> (ProcessId -> Process ())
-> Assertion
runInTestContext node lock sm rs cs proc = do
Ex.bracket (takeMVar lock) (putMVar lock) $ \() -> runProcess node $ do
sup <- Supervisor.start rs sm cs
(proc sup) `finally` (exit sup ExitShutdown)
data Context = Context { sup :: SupervisorPid
, sniffer :: Sniffer
, waitTimeout :: TimeInterval
, listSize :: Int
, split :: forall a . ([a] -> ([a], [a]))
}
type Sniffer = ReceivePort MxSupervisor
mkRandom :: Int -> Int -> (Int, Int)
mkRandom minListSz maxListSz
| minListSz > maxListSz = error "nope"
| minListSz < 20 = mkRandom 20 maxListSz
| otherwise =
let gen = mkStdGen 273846
(lSz :: Int, gen') = randomR (minListSz, maxListSz) gen
(sPt :: Int, _) = randomR (max 3 (round((fromIntegral lSz) / 3.15 :: Double) :: Int), lSz - 3) gen'
in (lSz, sPt)
randomIshSizes :: (Int, Int)
randomIshSizes = mkRandom 20 1200
runInTestContext' :: LocalNode
-> ShutdownMode
-> RestartStrategy
-> [ChildSpec]
-> (Context -> Process ())
-> Assertion
runInTestContext' node sm rs cs proc = do
liftIO $ do
-- we don't care about real randomness, just about selecting a vaguely
-- different sizes for each run...
let (lSz, sPt) = randomIshSizes
runProcess node $ do
sup <- Supervisor.start rs sm cs
sf <- monitorSupervisor sup
finally (proc $ Context sup sf (seconds 30) lSz (splitAt sPt))
(exit sup ExitShutdown >> unmonitorSupervisor sup)
verifyChildWasRestarted :: ChildKey -> ProcessId -> ProcessId -> Process ()
verifyChildWasRestarted key pid sup = do
void $ waitForExit pid
cSpec <- lookupChild sup key
-- TODO: handle (ChildRestarting _) too!
case cSpec of
Just (ref, _) -> do Just pid' <- resolve ref
expectThat pid' $ isNot $ equalTo pid
_ -> do
liftIO $ assertFailure $ "unexpected child ref: " ++ (show (key, cSpec))
verifyChildWasNotRestarted :: ChildKey -> ProcessId -> ProcessId -> Process ()
verifyChildWasNotRestarted key pid sup = do
void $ waitForExit pid
cSpec <- lookupChild sup key
case cSpec of
Just (ChildStopped, _) -> return ()
_ -> liftIO $ assertFailure $ "unexpected child ref: " ++ (show (key, cSpec))
verifyTempChildWasRemoved :: ProcessId -> ProcessId -> Process ()
verifyTempChildWasRemoved pid sup = do
void $ waitForExit pid
sleepFor 500 Millis
cSpec <- lookupChild sup "temp-worker"
expectThat cSpec isNothing
waitForExit :: ProcessId -> Process DiedReason
waitForExit pid = do
monitor pid >>= waitForDown
waitForDown :: Maybe MonitorRef -> Process DiedReason
waitForDown Nothing = error "invalid mref"
waitForDown (Just ref) =
receiveWait [ matchIf (\(ProcessMonitorNotification ref' _ _) -> ref == ref')
(\(ProcessMonitorNotification _ _ dr) -> return dr) ]
waitForBranchRestartComplete :: Sniffer
-> ChildKey
-> Process ()
waitForBranchRestartComplete sniff key = do
debug logChannel $ "waiting for branch restart..."
aux 10000 sniff Nothing -- `finally` unmonitorSupervisor sup
where
aux :: Int -> Sniffer -> Maybe MxSupervisor -> Process ()
aux n s m
| n < 1 = liftIO $ assertFailure $ "Never Saw Branch Restarted for " ++ (show key)
| Just mx <- m
, SupervisorBranchRestarted{..} <- mx
, childSpecKey == key = return ()
| Nothing <- m = receiveTimeout 100 [ matchChan s return ] >>= aux (n-1) s
| otherwise = aux (n-1) s Nothing
verifySingleRestart :: Context
-> ChildKey
-> Process ()
verifySingleRestart Context{..} key = do
sleep $ seconds 1
let t = asTimeout waitTimeout
mx <- receiveChanTimeout t sniffer
case mx of
Just rs@SupervisedChildRestarting{} -> do
(childSpecKey rs) `shouldBe` equalTo key
mx' <- receiveChanTimeout t sniffer
case mx' of
Just cs@SupervisedChildStarted{} -> do
(childSpecKey cs) `shouldBe` equalTo key
debug logChannel $ "restart ok for " ++ (show cs)
_ -> liftIO $ assertFailure $ " Unexpected Waiting Child Started " ++ (show mx')
_ -> liftIO $ assertFailure $ "Unexpected Waiting Child Restarted " ++ (show mx)
verifySeqStartOrder :: Context
-> [(ChildRef, Child)]
-> ChildKey
-> Process ()
verifySeqStartOrder Context{..} xs toStop = do
-- xs == [(oldRef, (ref, spec))] in specified/insertion order
-- if shutdown is LeftToRight then that's correct, otherwise we
-- should expect the shutdowns in reverse order
sleep $ seconds 1
let t = asTimeout waitTimeout
forM_ xs $ \(oCr, c@(cr, cs)) -> do
debug logChannel $ "checking restart " ++ (show c)
mx <- receiveTimeout t [ matchChan sniffer return ]
case mx of
Just SupervisedChildRestarting{..} -> do
debug logChannel $ "for restart " ++ (show childSpecKey) ++ " we're expecting " ++ (childKey cs)
childSpecKey `shouldBe` equalTo (childKey cs)
unless (childSpecKey == toStop) $ do
Just SupervisedChildStopped{..} <- receiveChanTimeout t sniffer
debug logChannel $ "for " ++ (show childRef) ++ " we're expecting " ++ (show oCr)
childRef `shouldBe` equalTo oCr
mx' <- receiveChanTimeout t sniffer
case mx' of
Just SupervisedChildStarted{..} -> childRef `shouldBe` equalTo cr
_ -> do
liftIO $ assertFailure $ "After Stopping " ++ (show cs) ++
" received unexpected " ++ (show mx)
_ -> liftIO $ assertFailure $ "Bad Restart: " ++ (show mx)
verifyStopStartOrder :: Context
-> [(ChildRef, Child)]
-> [Child]
-> ChildKey
-> Process ()
verifyStopStartOrder Context{..} xs restarted toStop = do
-- xs == [(oldRef, (ref, spec))] in specified/insertion order
-- if shutdown is LeftToRight then that's correct, otherwise we
-- should expect the shutdowns in reverse order
sleep $ seconds 1
let t = asTimeout waitTimeout
forM_ xs $ \(oCr, c@(_, cs)) -> do
debug logChannel $ "checking restart " ++ (show c)
mx <- receiveTimeout t [ matchChan sniffer return ]
case mx of
Just SupervisedChildRestarting{..} -> do
debug logChannel $ "for restart " ++ (show childSpecKey) ++ " we're expecting " ++ (childKey cs)
childSpecKey `shouldBe` equalTo (childKey cs)
if childSpecKey /= toStop
then do Just SupervisedChildStopped{..} <- receiveChanTimeout t sniffer
debug logChannel $ "for " ++ (show childRef) ++ " we're expecting " ++ (show oCr)
-- childRef `shouldBe` equalTo oCr
if childRef /= oCr
then debug logChannel $ "childRef " ++ (show childRef) ++ " /= " ++ (show oCr)
else return ()
else return ()
_ -> liftIO $ assertFailure $ "Bad Restart: " ++ (show mx)
debug logChannel "checking start order..."
sleep $ seconds 1
forM_ restarted $ \(cr, _) -> do
debug logChannel $ "checking (reverse) start order for " ++ (show cr)
mx <- receiveTimeout t [ matchChan sniffer return ]
case mx of
Just SupervisedChildStarted{..} -> childRef `shouldBe` equalTo cr
_ -> liftIO $ assertFailure $ "Bad Child Start: " ++ (show mx)
checkStartupOrder :: Context -> [Child] -> Process ()
checkStartupOrder Context{..} children = do
-- assert that we saw the startup sequence working...
forM_ children $ \(cr, _) -> do
debug logChannel $ "checking " ++ (show cr)
mx <- receiveTimeout (asTimeout waitTimeout) [ matchChan sniffer return ]
case mx of
Just SupervisedChildStarted{..} -> childRef `shouldBe` equalTo cr
_ -> liftIO $ assertFailure $ "Bad Child Start: " ++ (show mx)
exitIgnore :: Process ()
exitIgnore = liftIO $ throwIO ChildInitIgnore
noOp :: Process ()
noOp = return ()
blockIndefinitely :: Process ()
blockIndefinitely = runTestProcess noOp
notifyMe :: ProcessId -> Process ()
notifyMe me = getSelfPid >>= send me >> obedient
sleepy :: Process ()
sleepy = (sleepFor 5 Minutes)
`catchExit` (\_ (_ :: ExitReason) -> return ()) >> sleepy
obedient :: Process ()
obedient = (sleepFor 5 Minutes)
{- supervisor inserts handlers that act like we wrote:
`catchExit` (\_ (r :: ExitReason) -> do
case r of
ExitShutdown -> return ()
_ -> die r)
-}
runCore :: SendPort () -> Process ()
runCore sp = (expect >>= say) `catchExit` (\_ ExitShutdown -> sendChan sp ())
runApp :: SendPort () -> Process ()
runApp sg = do
Just pid <- whereis "core"
link pid -- if the real "core" exits first, we go too
sendChan sg ()
expect >>= say
formatMxSupervisor :: Message -> Process (Maybe String)
formatMxSupervisor msg = do
m <- unwrapMessage msg :: Process (Maybe MxSupervisor)
case m of
Nothing -> return Nothing
Just m' -> return $ Just (show m')
$(remotable [ 'exitIgnore
, 'noOp
, 'blockIndefinitely
, 'sleepy
, 'obedient
, 'notifyMe
, 'runCore
, 'runApp
, 'formatMxSupervisor ])
-- test cases start here...
normalStartStop :: ProcessId -> Process ()
normalStartStop sup = do
ensureProcessIsAlive sup
void $ monitor sup
shutdown sup
sup `shouldExitWith` DiedNormal
sequentialShutdown :: TestResult (Maybe ()) -> Process ()
sequentialShutdown result = do
(sp, rp) <- newChan
(sg, rg) <- newChan
core' <- toChildStart $ $(mkClosure 'runCore) sp
app' <- toChildStart $ $(mkClosure 'runApp) sg
let core = (permChild core') { childRegName = Just (LocalName "core")
, childStop = StopTimeout (Delay $ within 2 Seconds)
, childKey = "child-1"
}
let app = (permChild app') { childRegName = Just (LocalName "app")
, childStop = StopTimeout (Delay $ within 2 Seconds)
, childKey = "child-2"
}
sup <- Supervisor.start restartRight
(SequentialShutdown RightToLeft)
[core, app]
() <- receiveChan rg
exit sup ExitShutdown
res <- receiveChanTimeout (asTimeout $ seconds 5) rp
stash result res
configuredTemporaryChildExitsWithIgnore ::
ChildStart
-> (RestartStrategy -> [ChildSpec] -> (ProcessId -> Process ()) -> Assertion)
-> Assertion
configuredTemporaryChildExitsWithIgnore cs withSupervisor =
let spec = tempWorker cs in do
withSupervisor restartOne [spec] verifyExit
where
verifyExit :: ProcessId -> Process ()
verifyExit sup = do
child <- lookupChild sup "temp-worker"
case child of
Nothing -> return () -- the child exited and was removed ok
Just (ref, _) -> do
Just pid <- resolve ref
verifyTempChildWasRemoved pid sup
configuredNonTemporaryChildExitsWithIgnore ::
ChildStart
-> (RestartStrategy -> [ChildSpec] -> (ProcessId -> Process ()) -> Assertion)
-> Assertion
configuredNonTemporaryChildExitsWithIgnore cs withSupervisor =
let spec = transientWorker cs in do
withSupervisor restartOne [spec] $ verifyExit spec
where
verifyExit :: ChildSpec -> ProcessId -> Process ()
verifyExit spec sup = do
sleep $ milliSeconds 100 -- make sure our super has seen the EXIT signal
child <- lookupChild sup (childKey spec)
case child of
Nothing -> liftIO $ assertFailure $ "lost non-temp spec!"
Just (ref, spec') -> do
rRef <- resolve ref
maybe (return DiedNormal) waitForExit rRef
cSpec <- lookupChild sup (childKey spec')
case cSpec of
Just (ChildStartIgnored, _) -> return ()
_ -> do
liftIO $ assertFailure $ "unexpected lookup: " ++ (show cSpec)
startTemporaryChildExitsWithIgnore :: ChildStart -> ProcessId -> Process ()
startTemporaryChildExitsWithIgnore cs sup =
-- if a temporary child exits with "ignore" then we must
-- have deleted its specification from the supervisor
let spec = tempWorker cs in do
ChildAdded ref <- startNewChild sup spec
Just pid <- resolve ref
verifyTempChildWasRemoved pid sup
startNonTemporaryChildExitsWithIgnore :: ChildStart -> ProcessId -> Process ()
startNonTemporaryChildExitsWithIgnore cs sup =
let spec = transientWorker cs in do
ChildAdded ref <- startNewChild sup spec
Just pid <- resolve ref
void $ waitForExit pid
sleep $ milliSeconds 250
cSpec <- lookupChild sup (childKey spec)
case cSpec of
Just (ChildStartIgnored, _) -> return ()
_ -> do
liftIO $ assertFailure $ "unexpected lookup: " ++ (show cSpec)
addChildWithoutRestart :: ChildStart -> ProcessId -> Process ()
addChildWithoutRestart cs sup =
let spec = transientWorker cs in do
response <- addChild sup spec
response `shouldBe` equalTo (ChildAdded ChildStopped)
addChildThenStart :: ChildStart -> ProcessId -> Process ()
addChildThenStart cs sup =
let spec = transientWorker cs in do
(ChildAdded _) <- addChild sup spec
response <- startChild sup (childKey spec)
case response of
ChildStartOk (ChildRunning pid) -> do
alive <- isProcessAlive pid
alive `shouldBe` equalTo True
_ -> do
liftIO $ putStrLn (show response)
die "Ooops"
startUnknownChild :: ChildStart -> ProcessId -> Process ()
startUnknownChild cs sup = do
response <- startChild sup (childKey (transientWorker cs))
response `shouldBe` equalTo ChildStartUnknownId
setupChild :: ChildStart -> ProcessId -> Process (ChildRef, ChildSpec)
setupChild cs sup = do
let spec = transientWorker cs
response <- addChild sup spec
response `shouldBe` equalTo (ChildAdded ChildStopped)
Just child <- lookupChild sup "transient-worker"
return child
addDuplicateChild :: ChildStart -> ProcessId -> Process ()
addDuplicateChild cs sup = do
(ref, spec) <- setupChild cs sup
dup <- addChild sup spec
dup `shouldBe` equalTo (ChildFailedToStart $ StartFailureDuplicateChild ref)
startDuplicateChild :: ChildStart -> ProcessId -> Process ()
startDuplicateChild cs sup = do
(ref, spec) <- setupChild cs sup
dup <- startNewChild sup spec
dup `shouldBe` equalTo (ChildFailedToStart $ StartFailureDuplicateChild ref)
startBadClosure :: ChildStart -> ProcessId -> Process ()
startBadClosure cs sup = do
let spec = tempWorker cs
child <- startNewChild sup spec
child `shouldBe` equalTo
(ChildFailedToStart $ StartFailureBadClosure
"user error (Could not resolve closure: Invalid static label 'non-existing')")
-- configuredBadClosure withSupervisor = do
-- let spec = permChild (closure (staticLabel "non-existing") empty)
-- -- we make sure we don't hit the supervisor's limits
-- let strategy = RestartOne $ limit (maxRestarts 500000000) (milliSeconds 1)
-- withSupervisor strategy [spec] $ \sup -> do
-- -- ref <- monitor sup
-- children <- (listChildren sup)
-- let specs = map fst children
-- expectThat specs $ equalTo []
deleteExistingChild :: ChildStart -> ProcessId -> Process ()
deleteExistingChild cs sup = do
let spec = transientWorker cs
(ChildAdded ref) <- startNewChild sup spec
result <- deleteChild sup "transient-worker"
result `shouldBe` equalTo (ChildNotStopped ref)
deleteStoppedTempChild :: ChildStart -> ProcessId -> Process ()
deleteStoppedTempChild cs sup = do
let spec = tempWorker cs
ChildAdded ref <- startNewChild sup spec
Just pid <- resolve ref
testProcessStop pid
-- child needs to be stopped
waitForExit pid
result <- deleteChild sup (childKey spec)
result `shouldBe` equalTo ChildNotFound
deleteStoppedChild :: ChildStart -> ProcessId -> Process ()
deleteStoppedChild cs sup = do
let spec = transientWorker cs
ChildAdded ref <- startNewChild sup spec
Just pid <- resolve ref
testProcessStop pid
-- child needs to be stopped
waitForExit pid
result <- deleteChild sup (childKey spec)
result `shouldBe` equalTo ChildDeleted
permanentChildrenAlwaysRestart :: ChildStart -> ProcessId -> Process ()
permanentChildrenAlwaysRestart cs sup = do
let spec = permChild cs
(ChildAdded ref) <- startNewChild sup spec
Just pid <- resolve ref
testProcessStop pid -- a normal stop should *still* trigger a restart
verifyChildWasRestarted (childKey spec) pid sup
temporaryChildrenNeverRestart :: ChildStart -> ProcessId -> Process ()
temporaryChildrenNeverRestart cs sup = do
let spec = tempWorker cs
(ChildAdded ref) <- startNewChild sup spec
Just pid <- resolve ref
kill pid "bye bye"
verifyTempChildWasRemoved pid sup
transientChildrenNormalExit :: ChildStart -> ProcessId -> Process ()
transientChildrenNormalExit cs sup = do
let spec = transientWorker cs
(ChildAdded ref) <- startNewChild sup spec
Just pid <- resolve ref
testProcessStop pid
verifyChildWasNotRestarted (childKey spec) pid sup
transientChildrenAbnormalExit :: ChildStart -> ProcessId -> Process ()
transientChildrenAbnormalExit cs sup = do
let spec = transientWorker cs
(ChildAdded ref) <- startNewChild sup spec
Just pid <- resolve ref
kill pid "bye bye"
verifyChildWasRestarted (childKey spec) pid sup
transientChildrenExitShutdown :: ChildStart -> Context -> Process ()
transientChildrenExitShutdown cs Context{..} = do
let spec = transientWorker cs
(ChildAdded ref) <- startNewChild sup spec
Just _ <- receiveChanTimeout (asTimeout waitTimeout) sniffer :: Process (Maybe MxSupervisor)
Just pid <- resolve ref
mRef <- monitor pid
exit pid ExitShutdown
waitForDown mRef
mx <- receiveChanTimeout 1000 sniffer :: Process (Maybe MxSupervisor)
expectThat mx isNothing
verifyChildWasNotRestarted (childKey spec) pid sup
intrinsicChildrenAbnormalExit :: ChildStart -> ProcessId -> Process ()
intrinsicChildrenAbnormalExit cs sup = do
let spec = intrinsicWorker cs
ChildAdded ref <- startNewChild sup spec
Just pid <- resolve ref
kill pid "bye bye"
verifyChildWasRestarted (childKey spec) pid sup
intrinsicChildrenNormalExit :: ChildStart -> ProcessId -> Process ()
intrinsicChildrenNormalExit cs sup = do
let spec = intrinsicWorker cs
ChildAdded ref <- startNewChild sup spec
Just pid <- resolve ref
testProcessStop pid
reason <- waitForExit sup
expectThat reason $ equalTo DiedNormal
explicitRestartRunningChild :: ChildStart -> ProcessId -> Process ()
explicitRestartRunningChild cs sup = do
let spec = tempWorker cs
ChildAdded ref <- startNewChild sup spec
result <- restartChild sup (childKey spec)
expectThat result $ equalTo $ ChildRestartFailed (StartFailureAlreadyRunning ref)
explicitRestartUnknownChild :: ProcessId -> Process ()
explicitRestartUnknownChild sup = do
result <- restartChild sup "unknown-id"
expectThat result $ equalTo ChildRestartUnknownId
explicitRestartRestartingChild :: ChildStart -> ProcessId -> Process ()
explicitRestartRestartingChild cs sup = do
let spec = permChild cs
ChildAdded _ <- startNewChild sup spec
-- TODO: we've seen a few explosions here (presumably of the supervisor?)
-- expecially when running with +RTS -N1 - it's possible that there's a bug
-- tucked away that we haven't cracked just yet
restarted <- (restartChild sup (childKey spec))
`catchExit` (\_ (r :: ExitReason) -> (liftIO $ putStrLn (show r)) >>
die r)
-- this is highly timing dependent, so we have to allow for both
-- possible outcomes - on a dual core machine, the first clause
-- will match approx. 1 / 200 times when running with +RTS -N
case restarted of
ChildRestartFailed (StartFailureAlreadyRunning (ChildRestarting _)) -> return ()
ChildRestartFailed (StartFailureAlreadyRunning (ChildRunning _)) -> return ()
other -> liftIO $ assertFailure $ "unexpected result: " ++ (show other)
explicitRestartStoppedChild :: ChildStart -> ProcessId -> Process ()
explicitRestartStoppedChild cs sup = do
let spec = transientWorker cs
let key = childKey spec
ChildAdded ref <- startNewChild sup spec
void $ stopChild sup key
restarted <- restartChild sup key
sleepFor 500 Millis
Just (ref', _) <- lookupChild sup key
expectThat ref $ isNot $ equalTo ref'
case restarted of
ChildRestartOk (ChildRunning _) -> return ()
_ -> liftIO $ assertFailure $ "unexpected exit: " ++ (show restarted)
stopChildImmediately :: ChildStart -> ProcessId -> Process ()
stopChildImmediately cs sup = do
let spec = tempWorker cs
ChildAdded ref <- startNewChild sup spec
-- Just pid <- resolve ref
mRef <- monitor ref
void $ stopChild sup (childKey spec)
reason <- waitForDown mRef
expectThat reason $ equalTo $ DiedException (expectedExitReason sup)
stoppingChildExceedsDelay :: ProcessId -> Process ()
stoppingChildExceedsDelay sup = do
let spec = (tempWorker (RunClosure $(mkStaticClosure 'sleepy)))
{ childStop = StopTimeout (Delay $ within 500 Millis) }
ChildAdded ref <- startNewChild sup spec
-- Just pid <- resolve ref
mRef <- monitor ref
void $ stopChild sup (childKey spec)
reason <- waitForDown mRef
expectThat reason $ equalTo $ DiedException (expectedExitReason sup)
stoppingChildObeysDelay :: ProcessId -> Process ()
stoppingChildObeysDelay sup = do
let spec = (tempWorker (RunClosure $(mkStaticClosure 'obedient)))
{ childStop = StopTimeout (Delay $ within 1 Seconds) }
ChildAdded child <- startNewChild sup spec
Just pid <- resolve child
void $ monitor pid
void $ stopChild sup (childKey spec)
child `shouldExitWith` DiedNormal
restartAfterThreeAttempts ::
ChildStart
-> (RestartStrategy -> [ChildSpec] -> (ProcessId -> Process ()) -> Assertion)
-> Assertion
restartAfterThreeAttempts cs withSupervisor = do
let spec = permChild cs
let strategy = RestartOne $ limit (maxRestarts 500) (seconds 2)
withSupervisor strategy [spec] $ \sup -> do
mapM_ (\_ -> do
[(childRef, _)] <- listChildren sup
Just pid <- resolve childRef
ref <- monitor pid
testProcessStop pid
void $ waitForDown ref) [1..3 :: Int]
[(_, _)] <- listChildren sup
return ()
delayedRestartAfterThreeAttempts ::
(RestartStrategy -> [ChildSpec] -> (Context -> Process ()) -> Assertion)
-> Assertion
delayedRestartAfterThreeAttempts withSupervisor = do
let spec = (permChild $ RunClosure $ $(mkStaticClosure 'blockIndefinitely))
{ childRestartDelay = Just (seconds 3) }
let strategy = RestartOne $ limit (maxRestarts 2) (seconds 2)
withSupervisor strategy [spec] $ \ctx@Context{..} -> do
mapM_ (\_ -> do
[(childRef, _)] <- listChildren sup
Just pid <- resolve childRef
ref <- monitor pid
testProcessStop pid
void $ waitForDown ref) [1..3 :: Int]
Just (ref, _) <- lookupChild sup $ childKey spec
case ref of
ChildRestarting _ -> do
SupervisedChildStarted{..} <- receiveChan sniffer
childSpecKey `shouldBe` equalTo (childKey spec)
_ -> liftIO $ assertFailure $ "Unexpected ChildRef: " ++ (show ref)
mapM_ (const $ verifySingleRestart ctx (childKey spec)) [1..3 :: Int]
[(ref', _)] <- listChildren sup
Just pid <- resolve ref'
mRef <- monitor pid
testProcessStop pid
void $ waitForDown mRef
permanentChildExceedsRestartsIntensity ::
ChildStart
-> (RestartStrategy -> [ChildSpec] -> (ProcessId -> Process ()) -> Assertion)
-> Assertion
permanentChildExceedsRestartsIntensity cs withSupervisor = do
let spec = permChild cs -- child that exits immediately
let strategy = RestartOne $ limit (maxRestarts 50) (seconds 2)
withSupervisor strategy [spec] $ \sup -> do
ref <- monitor sup
-- if the supervisor dies whilst the call is in-flight,
-- *this* process will exit, therefore we handle that exit reason
void $ ((startNewChild sup spec >> return ())
`catchExit` (\_ (_ :: ExitReason) -> return ()))
reason <- waitForDown ref
expectThat reason $ equalTo $
DiedException $ "exit-from=" ++ (show sup) ++
",reason=ReachedMaxRestartIntensity"
stopChildIgnoresSiblings ::
ChildStart
-> (RestartStrategy -> [ChildSpec] -> (ProcessId -> Process ()) -> Assertion)
-> Assertion
stopChildIgnoresSiblings cs withSupervisor = do
let templ = permChild cs
let specs = [templ { childKey = (show i) } | i <- [1..3 :: Int]]
withSupervisor restartAll specs $ \sup -> do
let toStop = childKey $ head specs
Just (ref, _) <- lookupChild sup toStop
mRef <- monitor ref
stopChild sup toStop
waitForDown mRef
children <- listChildren sup
forM_ (tail $ map fst children) $ \cRef -> do
maybe (error "invalid ref") ensureProcessIsAlive =<< resolve cRef
restartAllWithLeftToRightSeqRestarts ::
ChildStart
-> (RestartStrategy -> [ChildSpec] -> (Context -> Process ()) -> Assertion)
-> Assertion
restartAllWithLeftToRightSeqRestarts cs withSupervisor = do
let (sz, _) = randomIshSizes
let templ = permChild cs
let specs = [templ { childKey = (show i) } | i <- [1..sz :: Int]]
withSupervisor restartAll specs $ \Context{..} -> do
let toStop = childKey $ head specs
Just (ref, _) <- lookupChild sup toStop
children <- listChildren sup
Just pid <- resolve ref
kill pid "goodbye"
forM_ (map fst children) $ \cRef -> monitor cRef >>= waitForDown
forM_ (map snd children) $ \cSpec -> do
Just (ref', _) <- lookupChild sup (childKey cSpec)
maybe (error "invalid ref") ensureProcessIsAlive =<< resolve ref'
restartLeftWithLeftToRightSeqRestarts ::
ChildStart
-> (RestartStrategy -> [ChildSpec] -> (Context -> Process ()) -> Assertion)
-> Assertion
restartLeftWithLeftToRightSeqRestarts cs withSupervisor = do
let (lSz, sptSz) = randomIshSizes
let templ = permChild cs
let specs = [templ { childKey = (show i) } | i <- [1..lSz :: Int]]
withSupervisor restartLeft specs $ \ctx@Context{..} -> do
children <- listChildren sup
checkStartupOrder ctx children
sniff <- monitorSupervisor sup
let (toRestart, _notToRestart) = splitAt sptSz specs
let (restarts, survivors) = splitAt sptSz children
let toStop = childKey $ last toRestart
Just (ref, _) <- lookupChild sup toStop
Just pid <- resolve ref
kill pid "goodbye"
forM_ (map fst restarts) $ \cRef -> monitor cRef >>= waitForDown
-- NB: this uses a separate channel to consume the Mx events...
waitForBranchRestartComplete sniff toStop
children' <- listChildren sup
let (restarted', _) = splitAt sptSz children'
let xs = zip [fst o | o <- restarts] restarted'
verifySeqStartOrder ctx xs toStop
forM_ (map snd children') $ \cSpec -> do
Just (ref', _) <- lookupChild sup (childKey cSpec)
maybe (error "invalid ref") ensureProcessIsAlive =<< resolve ref'
resolved <- forM (map fst survivors) resolve
let possibleBadRestarts = catMaybes resolved
r <- receiveTimeout (after 5 Seconds) [
match (\(ProcessMonitorNotification _ pid' _) -> do
case (elem pid' possibleBadRestarts) of
True -> liftIO $ assertFailure $ "unexpected exit from " ++ show pid'
False -> return ())
]
expectThat r isNothing
restartRightWithLeftToRightSeqRestarts ::
ChildStart
-> (RestartStrategy -> [ChildSpec] -> (ProcessId -> Process ()) -> Assertion)
-> Assertion
restartRightWithLeftToRightSeqRestarts cs withSupervisor = do
let (lSz, sptSz) = mkRandom 150 688
let templ = permChild cs
let specs = [templ { childKey = (show i) } | i <- [1..lSz :: Int]]
withSupervisor restartRight specs $ \sup -> do
let (_notToRestart, toRestart) = splitAt sptSz specs
let toStop = childKey $ head toRestart
Just (ref, _) <- lookupChild sup toStop
Just pid <- resolve ref
children <- listChildren sup
let (survivors, children') = splitAt sptSz children
kill pid "goodbye"
forM_ (map fst children') $ \cRef -> do
mRef <- monitor cRef
waitForDown mRef
forM_ (map snd children') $ \cSpec -> do
Just (ref', _) <- lookupChild sup (childKey cSpec)
maybe (error "invalid ref") ensureProcessIsAlive =<< resolve ref'
resolved <- forM (map fst survivors) resolve
let possibleBadRestarts = catMaybes resolved
r <- receiveTimeout (after 1 Seconds) [
match (\(ProcessMonitorNotification _ pid' _) -> do
case (elem pid' possibleBadRestarts) of
True -> liftIO $ assertFailure $ "unexpected exit from " ++ show pid'
False -> return ())
]
expectThat r isNothing
restartAllWithLeftToRightRestarts :: ProcessId -> Process ()
restartAllWithLeftToRightRestarts sup = do
let (lSz, _) = randomIshSizes
self <- getSelfPid
let templ = permChild $ RunClosure ($(mkClosure 'notifyMe) self)
let specs = [templ { childKey = (show i) } | i <- [1..lSz :: Int]]
-- add the specs one by one
forM_ specs $ \s -> void $ startNewChild sup s
-- assert that we saw the startup sequence working...
children <- listChildren sup
drainAllChildren children
let toStop = childKey $ head specs
Just (ref, _) <- lookupChild sup toStop
Just pid <- resolve ref
kill pid "goodbye"
-- wait for all the exit signals, so we know the children are restarting
forM_ (map fst children) $ \cRef -> do
Just mRef <- monitor cRef
receiveWait [
matchIf (\(ProcessMonitorNotification ref' _ _) -> ref' == mRef)
(\_ -> return ())
-- we should NOT see *any* process signalling that it has started
-- whilst waiting for all the children to be terminated
, match (\(pid' :: ProcessId) -> do
liftIO $ assertFailure $ "unexpected signal from " ++ (show pid'))
]
-- Now assert that all the children were restarted in the same order.
-- THIS is the bit that is technically unsafe, though it's also unlikely
-- to change, since the architecture of the node controller is pivotal to CH
children' <- listChildren sup
drainAllChildren children'
let [c1, c2] = [map fst cs | cs <- [children, children']]
forM_ (zip c1 c2) $ \(p1, p2) -> expectThat p1 $ isNot $ equalTo p2
where
drainAllChildren children = do
-- Receive all pids then verify they arrived in the correct order.
-- Any out-of-order messages (such as ProcessMonitorNotification) will
-- violate the invariant asserted below, and fail the test case
pids <- forM children $ \_ -> expect :: Process ProcessId
forM_ pids ensureProcessIsAlive
restartAllWithRightToLeftSeqRestarts :: Context -> Process ()
restartAllWithRightToLeftSeqRestarts ctx@Context{..} = do
self <- getSelfPid
let templ = permChild $ RunClosure $(mkStaticClosure 'obedient)
let specs = [templ { childKey = (show i) } | i <- [1..listSize :: Int]]
-- add the specs one by one
forM_ specs $ \s -> do
ChildAdded ref <- startNewChild sup s
maybe (error "invalid ref") ensureProcessIsAlive =<< resolve ref
-- assert that we saw the startup sequence working...
children <- listChildren sup
checkStartupOrder ctx children
-- we need this before the restarts occur
sniff <- monitorSupervisor sup
let toStop = childKey $ head specs
Just (ref, _) <- lookupChild sup toStop
Just pid <- resolve ref
kill pid "fooboo"
-- wait for all the exit signals, so we know the children are restarting
forM_ (map fst children) $ \cRef -> monitor cRef >>= waitForDown
-- NB: this uses a separate channel to consume the Mx events...
waitForBranchRestartComplete sniff toStop
children' <- listChildren sup
let xs = zip [fst o | o <- children] children'
verifySeqStartOrder ctx (reverse xs) toStop
forM_ (map snd children') $ \cSpec -> do
Just (ref', _) <- lookupChild sup (childKey cSpec)
maybe (error "invalid ref") ensureProcessIsAlive =<< resolve ref'
expectLeftToRightRestarts :: Context -> Process ()
expectLeftToRightRestarts ctx@Context{..} = do
let templ = permChild $ RunClosure $(mkStaticClosure 'obedient)
let specs = [templ { childKey = (show i) } | i <- [1..listSize :: Int]]
-- add the specs one by one
forM_ specs $ \s -> void $ startNewChild sup s
-- assert that we saw the startup sequence working...
children <- listChildren sup
checkStartupOrder ctx children
let toStop = childKey $ head specs
Just (ref, _) <- lookupChild sup toStop
Just pid <- resolve ref
-- wait for all the exit signals and ensure they arrive in RightToLeft order
refs <- forM children $ \(ch, _) -> monitor ch >>= \r -> return (ch, r)
kill pid "fooboo"
initRes <- receiveTimeout
(asTimeout $ seconds 1)
[ matchIf
(\(ProcessMonitorNotification r _ _) -> (Just r) == (snd $ head refs))
(\sig@(ProcessMonitorNotification _ _ _) -> return sig) ]
expectThat initRes $ isJust
forM_ (reverse (filter ((/= ref) .fst ) refs)) $ \(_, Just mRef) -> do
(ProcessMonitorNotification ref' _ _) <- expect
if ref' == mRef then (return ()) else (die "unexpected monitor signal")
expectRightToLeftRestarts :: Bool -> Context -> Process ()
expectRightToLeftRestarts rev ctx@Context{..} = do
self <- getSelfPid
let templ = permChild $ RunClosure ($(mkClosure 'notifyMe) self)
let specs = [templ { childKey = (show i) } | i <- [1..listSize :: Int]]
-- add the specs one by one
forM_ specs $ \s -> do
ChildAdded ref <- startNewChild sup s
maybe (error "invalid ref") ensureProcessIsAlive =<< resolve ref
children <- listChildren sup
checkStartupOrder ctx children
-- assert that we saw the startup sequence working...
let toStop = childKey $ head specs
Just (ref, _) <- lookupChild sup toStop
Just pid <- resolve ref
kill pid "fooboobarbazbub"
-- wait for all the exit signals, so we know the children are restarting
forM_ (map fst children) $ \cRef -> monitor cRef >>= waitForDown
restarted' <- listChildren sup
let xs = zip [fst o | o <- children] restarted'
let xs' = if rev then xs else reverse xs
-- say $ "xs = " ++ (show [(o, (cr, childKey cs)) | (o, (cr, cs)) <- xs])
verifyStopStartOrder ctx xs' (reverse restarted') toStop
restartLeftWhenLeftmostChildDies :: ChildStart -> ProcessId -> Process ()
restartLeftWhenLeftmostChildDies cs sup = do
let spec = permChild cs
(ChildAdded ref) <- startNewChild sup spec
(ChildAdded ref2) <- startNewChild sup $ spec { childKey = "child2" }
Just pid <- resolve ref
Just pid2 <- resolve ref2
testProcessStop pid -- a normal stop should *still* trigger a restart
verifyChildWasRestarted (childKey spec) pid sup
Just (ref3, _) <- lookupChild sup "child2"
Just pid2' <- resolve ref3
pid2 `shouldBe` equalTo pid2'
restartWithoutTempChildren :: ChildStart -> ProcessId -> Process ()
restartWithoutTempChildren cs sup = do
(ChildAdded refTrans) <- startNewChild sup $ transientWorker cs
(ChildAdded _) <- startNewChild sup $ tempWorker cs
(ChildAdded refPerm) <- startNewChild sup $ permChild cs
Just pid2 <- resolve refTrans
Just pid3 <- resolve refPerm
kill pid2 "foobar"
void $ waitForExit pid2 -- this wait reduces the likelihood of a race in the test
Nothing <- lookupChild sup "temp-worker"
verifyChildWasRestarted "transient-worker" pid2 sup
verifyChildWasRestarted "perm-child" pid3 sup
restartRightWhenRightmostChildDies :: ChildStart -> ProcessId -> Process ()
restartRightWhenRightmostChildDies cs sup = do
let spec = permChild cs
(ChildAdded ref2) <- startNewChild sup $ spec { childKey = "child2" }
(ChildAdded ref) <- startNewChild sup $ spec { childKey = "child1" }
[ch1, ch2] <- listChildren sup
(fst ch1) `shouldBe` equalTo ref2
(fst ch2) `shouldBe` equalTo ref
Just pid <- resolve ref
Just pid2 <- resolve ref2
-- ref (and therefore pid) is 'rightmost' now
testProcessStop pid -- a normal stop should *still* trigger a restart
verifyChildWasRestarted "child1" pid sup
Just (ref3, _) <- lookupChild sup "child2"
Just pid2' <- resolve ref3
pid2 `shouldBe` equalTo pid2'
restartLeftWithLeftToRightRestarts :: Bool -> Context -> Process ()
restartLeftWithLeftToRightRestarts rev ctx@Context{..} = do
self <- getSelfPid
let templ = permChild $ RunClosure ($(mkClosure 'notifyMe) self)
let specs = [templ { childKey = (show i) } | i <- [1..listSize :: Int]]
forM_ specs $ \s -> void $ startNewChild sup s
-- assert that we saw the startup sequence working...
children <- listChildren sup
checkStartupOrder ctx children
let (toRestart, _) = split specs
let (restarts, _) = split children
let toStop = childKey $ last toRestart
Just (ref', _) <- lookupChild sup toStop
Just stopPid <- resolve ref'
kill stopPid "goodbye"
-- wait for all the exit signals, so we know the children are restarting
forM_ (map fst (fst $ split children)) $ \cRef -> monitor cRef >>= waitForDown
children' <- listChildren sup
let (restarted, notRestarted) = split children'
let restarted' = if rev then reverse restarted else restarted
let restarts' = if rev then reverse restarts else restarts
let xs = zip [fst o | o <- restarts'] restarted'
verifyStopStartOrder ctx xs restarted toStop
let [c1, c2] = [map fst cs | cs <- [(snd $ split children), notRestarted]]
forM_ (zip c1 c2) $ \(p1, p2) -> p1 `shouldBe` equalTo p2
restartRightWithLeftToRightRestarts :: Bool -> Context -> Process ()
restartRightWithLeftToRightRestarts rev ctx@Context{..} = do
let templ = permChild $ RunClosure $(mkStaticClosure 'obedient)
let specs = [templ { childKey = (show i) } | i <- [1..listSize :: Int]]
forM_ specs $ \s -> void $ startNewChild sup s
children <- listChildren sup
-- assert that we saw the startup sequence working...
checkStartupOrder ctx children
let (_, toRestart) = split specs
let (_, restarts) = split children
let toStop = childKey $ head toRestart
Just (ref', _) <- lookupChild sup toStop
Just stopPid <- resolve ref'
kill stopPid "goodbye"
-- wait for all the exit signals, so we know the children are restarting
forM_ (map fst (snd $ split children)) $ \cRef -> monitor cRef >>= waitForDown
children' <- listChildren sup
let (notRestarted, restarted) = split children'
let restarted' = if rev then reverse restarted else restarted
let restarts' = if rev then reverse restarts else restarts
let xs = zip [fst o | o <- restarts'] restarted'
verifyStopStartOrder ctx xs restarted toStop
let [c1, c2] = [map fst cs | cs <- [(fst $ splitAt 3 children), notRestarted]]
forM_ (zip c1 c2) $ \(p1, p2) -> p1 `shouldBe` equalTo p2
restartRightWithRightToLeftRestarts :: Bool -> Context -> Process ()
restartRightWithRightToLeftRestarts rev ctx@Context{..} = do
let templ = permChild $ RunClosure $(mkStaticClosure 'obedient)
let specs = [templ { childKey = (show i) } | i <- [1..listSize :: Int]]
forM_ specs $ \s -> void $ startNewChild sup s
children <- listChildren sup
-- assert that we saw the startup sequence working...
checkStartupOrder ctx children
let (_, toRestart) = split specs
let (_, restarts) = split children
let toStop = childKey $ head toRestart
Just (ref', _) <- lookupChild sup toStop
Just stopPid <- resolve ref'
kill stopPid "goodbye"
-- wait for all the exit signals, so we know the children are restarting
forM_ (map fst (snd $ split children)) $ \cRef -> monitor cRef >>= waitForDown
children' <- listChildren sup
let (notRestarted, restarted) = split children'
let (restarts', restarted') = if rev then (reverse restarts, reverse restarted)
else (restarts, restarted)
let xs = zip [fst o | o <- restarts'] restarted'
verifyStopStartOrder ctx xs (reverse restarted) toStop
let [c1, c2] = [map fst cs | cs <- [(fst $ split children), notRestarted]]
forM_ (zip c1 c2) $ \(p1, p2) -> p1 `shouldBe` equalTo p2
restartLeftWithRightToLeftRestarts :: Bool -> Context -> Process ()
restartLeftWithRightToLeftRestarts rev ctx@Context{..} = do
let templ = permChild $ RunClosure $(mkStaticClosure 'obedient)
let specs = [templ { childKey = (show i) } | i <- [1..listSize :: Int]]
forM_ specs $ \s -> void $ startNewChild sup s
children <- listChildren sup
-- assert that we saw the startup sequence working...
checkStartupOrder ctx children
-- split off 6 children to be restarted
let (toRestart, _) = split specs
let (restarts, toSurvive) = split children
let toStop = childKey $ last toRestart
Just (ref', _) <- lookupChild sup toStop
Just stopPid <- resolve ref'
kill stopPid "test process waves goodbye...."
-- wait for all the exit signals, so we know the children are restarting
forM_ (map fst restarts) $ \cRef -> monitor cRef >>= waitForDown
children' <- listChildren sup
let (restarted, notRestarted) = split children'
--let xs = zip [fst o | o <- restarts] restarted
let (restarts', restarted') = if rev then (reverse restarts, reverse restarted)
else (restarts, restarted)
let xs = zip [fst o | o <- restarts'] restarted'
verifyStopStartOrder ctx xs (reverse restarted) toStop
let [c1, c2] = [map fst cs | cs <- [toSurvive, notRestarted]]
forM_ (zip c1 c2) $ \(p1, p2) -> p1 `shouldBe` equalTo p2
-- remote table definition and main
myRemoteTable :: RemoteTable
myRemoteTable = Main.__remoteTable initRemoteTable
withClosure :: (ChildStart -> ProcessId -> Process ())
-> (Closure (Process ()))
-> ProcessId -> Process ()
withClosure fn clj supervisor = do
cs <- toChildStart clj
fn cs supervisor
withClosure' :: (ChildStart -> Context -> Process ())
-> (Closure (Process ()))
-> Context
-> Process ()
withClosure' fn clj ctx = do
cs <- toChildStart clj
fn cs ctx
tests :: NT.Transport -> IO [Test]
tests transport = do
putStrLn $ concat [ "NOTICE: Branch Tests (Relying on Non-Guaranteed Message Order) "
, "Can Fail Intermittently" ]
localNode <- newLocalNode transport myRemoteTable
singleTestLock <- newMVar ()
runProcess localNode $ do
void $ supervisionMonitor
{-
slog <- systemLogFile "supervisor.test.log" Debug return
addFormatter slog $(mkStaticClosure 'formatMxSupervisor)
-}
let withSup sm = runInTestContext localNode singleTestLock sm
let withSup' sm = runInTestContext' localNode sm
let withSupervisor = runInTestContext localNode singleTestLock ParallelShutdown
let withSupervisor' = runInTestContext' localNode ParallelShutdown
return
[ testGroup "Supervisor Processes"
[
testGroup "Starting And Adding Children"
[
testCase "Normal (Managed Process) Supervisor Start Stop"
(withSupervisor restartOne [] normalStartStop)
, testCase "Add Child Without Starting"
(withSupervisor restartOne []
(withClosure addChildWithoutRestart
$(mkStaticClosure 'blockIndefinitely)))
, testCase "Start Previously Added Child"
(withSupervisor restartOne []
(withClosure addChildThenStart
$(mkStaticClosure 'blockIndefinitely)))
, testCase "Start Unknown Child"
(withSupervisor restartOne []
(withClosure startUnknownChild
$(mkStaticClosure 'blockIndefinitely)))
, testCase "Add Duplicate Child"
(withSupervisor restartOne []
(withClosure addDuplicateChild
$(mkStaticClosure 'blockIndefinitely)))
, testCase "Start Duplicate Child"
(withSupervisor restartOne []
(withClosure startDuplicateChild
$(mkStaticClosure 'blockIndefinitely)))
, testCase "Started Temporary Child Exits With Ignore"
(withSupervisor restartOne []
(withClosure startTemporaryChildExitsWithIgnore
$(mkStaticClosure 'exitIgnore)))
, testCase "Configured Temporary Child Exits With Ignore"
(configuredTemporaryChildExitsWithIgnore
(RunClosure $(mkStaticClosure 'exitIgnore)) withSupervisor)
, testCase "Start Bad Closure"
(withSupervisor restartOne []
(withClosure startBadClosure
(closure (staticLabel "non-existing") empty)))
, testCase "Configured Bad Closure"
(configuredTemporaryChildExitsWithIgnore
(RunClosure $(mkStaticClosure 'exitIgnore)) withSupervisor)
, testCase "Started Non-Temporary Child Exits With Ignore"
(withSupervisor restartOne [] $
(withClosure startNonTemporaryChildExitsWithIgnore
$(mkStaticClosure 'exitIgnore)))
, testCase "Configured Non-Temporary Child Exits With Ignore"
(configuredNonTemporaryChildExitsWithIgnore
(RunClosure $(mkStaticClosure 'exitIgnore)) withSupervisor)
]
, testGroup "Stopping And Deleting Children"
[
testCase "Delete Existing Child Fails"
(withSupervisor restartOne []
(withClosure deleteExistingChild
$(mkStaticClosure 'blockIndefinitely)))
, testCase "Delete Stopped Temporary Child (Doesn't Exist)"
(withSupervisor restartOne []
(withClosure deleteStoppedTempChild
$(mkStaticClosure 'blockIndefinitely)))
, testCase "Delete Stopped Child Succeeds"
(withSupervisor restartOne []
(withClosure deleteStoppedChild
$(mkStaticClosure 'blockIndefinitely)))
, testCase "Restart Minus Dropped (Temp) Child"
(withSupervisor restartAll []
(withClosure restartWithoutTempChildren
$(mkStaticClosure 'blockIndefinitely)))
, testCase "Sequential Shutdown Ordering"
(delayedAssertion
"expected the shutdown order to hold"
localNode (Just ()) sequentialShutdown)
]
, testGroup "Stopping and Restarting Children"
[
testCase "Permanent Children Always Restart (Closure)"
(withSupervisor restartOne []
(withClosure permanentChildrenAlwaysRestart
$(mkStaticClosure 'blockIndefinitely)))
, testCase "Temporary Children Never Restart (Closure)"
(withSupervisor restartOne []
(withClosure temporaryChildrenNeverRestart
$(mkStaticClosure 'blockIndefinitely)))
, testCase "Transient Children Do Not Restart When Exiting Normally (Closure)"
(withSupervisor restartOne []
(withClosure transientChildrenNormalExit
$(mkStaticClosure 'blockIndefinitely)))
, testCase "Transient Children Do Restart When Exiting Abnormally (Closure)"
(withSupervisor restartOne []
(withClosure transientChildrenAbnormalExit
$(mkStaticClosure 'blockIndefinitely)))
, testCase "ExitShutdown Is Considered Normal"
(withSupervisor' restartOne []
(withClosure' transientChildrenExitShutdown
$(mkStaticClosure 'blockIndefinitely)))
, testCase "Intrinsic Children Do Restart When Exiting Abnormally (Closure)"
(withSupervisor restartOne []
(withClosure intrinsicChildrenAbnormalExit
$(mkStaticClosure 'blockIndefinitely)))
, testCase (concat [ "Intrinsic Children Cause Supervisor Exits "
, "When Exiting Normally (Closure)"])
(withSupervisor restartOne []
(withClosure intrinsicChildrenNormalExit
$(mkStaticClosure 'blockIndefinitely)))
, testCase "Explicit Restart Of Running Child Fails (Closure)"
(withSupervisor restartOne []
(withClosure explicitRestartRunningChild
$(mkStaticClosure 'blockIndefinitely)))
, testCase "Explicit Restart Of Unknown Child Fails"
(withSupervisor restartOne [] explicitRestartUnknownChild)
, testCase "Explicit Restart Whilst Child Restarting Fails (Closure)"
(withSupervisor
(RestartOne (limit (maxRestarts 500000000) (milliSeconds 1))) []
(withClosure explicitRestartRestartingChild $(mkStaticClosure 'noOp)))
, testCase "Explicit Restart Stopped Child (Closure)"
(withSupervisor restartOne []
(withClosure explicitRestartStoppedChild
$(mkStaticClosure 'blockIndefinitely)))
, testCase "Immediate Child Stop (Brutal Kill) (Closure)"
(withSupervisor restartOne []
(withClosure stopChildImmediately
$(mkStaticClosure 'blockIndefinitely)))
, testCase "Child Stop Exceeds Timeout/Delay (Becomes Brutal Kill)"
(withSupervisor restartOne [] stoppingChildExceedsDelay)
, testCase "Child Stop Within Timeout/Delay"
(withSupervisor restartOne [] stoppingChildObeysDelay)
]
-- TODO: test for init failures (expecting $ ChildInitFailed r)
, testGroup "Branch Restarts"
[
testGroup "Restart All"
[
testCase "Stop Child Ignores Siblings"
(stopChildIgnoresSiblings
(RunClosure $(mkStaticClosure 'blockIndefinitely))
withSupervisor)
, testCase "Restart All, Left To Right (Sequential) Restarts"
(restartAllWithLeftToRightSeqRestarts
(RunClosure $(mkStaticClosure 'blockIndefinitely))
withSupervisor')
, testCase "Restart All, Right To Left (Sequential) Restarts"
(withSupervisor'
(RestartAll defaultLimits (RestartEach RightToLeft)) []
restartAllWithRightToLeftSeqRestarts)
, testCase "Restart All, Left To Right Stop, Left To Right Start"
(withSup
(SequentialShutdown LeftToRight)
(RestartAll defaultLimits (RestartInOrder LeftToRight)) []
restartAllWithLeftToRightRestarts)
, testCase "Restart All, Right To Left Stop, Right To Left Start"
(withSup'
(SequentialShutdown RightToLeft)
(RestartAll defaultLimits (RestartInOrder RightToLeft)
) []
(expectRightToLeftRestarts False))
, testCase "Restart All, Left To Right Stop, Reverse Start"
(withSup'
(SequentialShutdown LeftToRight)
(RestartAll defaultLimits (RestartRevOrder LeftToRight)
) []
(expectRightToLeftRestarts True))
, testCase "Restart All, Right To Left Stop, Reverse Start"
(withSup'
(SequentialShutdown RightToLeft)
(RestartAll defaultLimits (RestartRevOrder RightToLeft)
) []
expectLeftToRightRestarts)
],
testGroup "Restart Left"
[
testCase "Restart Left, Left To Right (Sequential) Restarts"
(restartLeftWithLeftToRightSeqRestarts
(RunClosure $(mkStaticClosure 'blockIndefinitely))
withSupervisor')
, testCase "Restart Left, Leftmost Child Dies"
(withSupervisor restartLeft [] $
restartLeftWhenLeftmostChildDies
(RunClosure $(mkStaticClosure 'blockIndefinitely)))
, testCase "Restart Left, Left To Right Stop, Left To Right Start"
(withSupervisor'
(RestartLeft defaultLimits (RestartInOrder LeftToRight)) []
(restartLeftWithLeftToRightRestarts False))
, testCase "Restart Left, Right To Left Stop, Right To Left Start"
(withSupervisor'
(RestartLeft defaultLimits (RestartInOrder RightToLeft)) []
(restartLeftWithRightToLeftRestarts True))
, testCase "Restart Left, Left To Right Stop, Reverse Start"
(withSupervisor'
(RestartLeft defaultLimits (RestartRevOrder LeftToRight)) []
(restartLeftWithRightToLeftRestarts False))
, testCase "Restart Left, Right To Left Stop, Reverse Start"
(withSupervisor'
(RestartLeft defaultLimits (RestartRevOrder RightToLeft)) []
(restartLeftWithLeftToRightRestarts True))
],
testGroup "Restart Right"
[
testCase "Restart Right, Left To Right (Sequential) Restarts"
(restartRightWithLeftToRightSeqRestarts
(RunClosure $(mkStaticClosure 'blockIndefinitely))
withSupervisor)
, testCase "Restart Right, Rightmost Child Dies"
(withSupervisor restartRight [] $
restartRightWhenRightmostChildDies
(RunClosure $(mkStaticClosure 'blockIndefinitely)))
, testCase "Restart Right, Left To Right Stop, Left To Right Start"
(withSupervisor'
(RestartRight defaultLimits (RestartInOrder LeftToRight)) []
(restartRightWithLeftToRightRestarts False))
, testCase "Restart Right, Right To Left Stop, Right To Left Start"
(withSupervisor'
(RestartRight defaultLimits (RestartInOrder RightToLeft)) []
(restartRightWithRightToLeftRestarts True))
, testCase "Restart Right, Left To Right Stop, Reverse Start"
(withSupervisor'
(RestartRight defaultLimits (RestartRevOrder LeftToRight)) []
(restartRightWithRightToLeftRestarts False))
, testCase "Restart Right, Right To Left Stop, Reverse Start"
(withSupervisor'
(RestartRight defaultLimits (RestartRevOrder RightToLeft)) []
(restartRightWithLeftToRightRestarts True))
]
]
, testGroup "Restart Intensity"
[
testCase "Three Attempts Before Successful Restart"
(restartAfterThreeAttempts
(RunClosure $(mkStaticClosure 'blockIndefinitely)) withSupervisor)
, testCase "Permanent Child Exceeds Restart Limits"
(permanentChildExceedsRestartsIntensity
(RunClosure $(mkStaticClosure 'noOp)) withSupervisor)
, testCase "Permanent Child Delayed Restart"
(delayedRestartAfterThreeAttempts withSupervisor')
]
]
{- , testGroup "CI"
[ testCase "Flush [NonTest]"
(withSupervisor'
(RestartRight defaultLimits (RestartInOrder LeftToRight)) []
(\_ -> sleep $ seconds 20))
]
-}
]
main :: IO ()
main = testMain $ tests