distributed-process-supervisor 0.2.2 → 0.2.3
raw patch · 4 files changed
+56/−117 lines, 4 filesdep −ansi-terminaldep −fingertreedep −ghc-primdep ~bytestringdep ~containersdep ~data-accessorPVP ok
version bump matches the API change (PVP)
Dependencies removed: ansi-terminal, fingertree, ghc-prim, mtl, network, rematch, transformers, unordered-containers
Dependency ranges changed: bytestring, containers, data-accessor, hashable, stm, time
API changes (from Hackage documentation)
Files
- ChangeLog +4/−0
- distributed-process-supervisor.cabal +4/−34
- tests/TestSupervisor.hs +46/−52
- tests/TestUtils.hs +2/−31
ChangeLog view
@@ -1,3 +1,7 @@+2024-10-30 Laurent P. René de Cotret <laurent.decotret@outlook.com> 0.2.3++* Removed dependency on `rematch` (#459)+ 2024-09-03 Laurent P. René de Cotret <laurent.decotret@outlook.com> 0.2.2 * Bumped dependency bounds to support GHC 8.10.7 - GHC 9.10.1
distributed-process-supervisor.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.0 name: distributed-process-supervisor-version: 0.2.2+version: 0.2.3 build-type: Simple license: BSD-3-Clause license-file: LICENSE@@ -42,22 +42,16 @@ import: warnings build-depends: base >= 4.14 && < 5,- bytestring >= 0.10, data-accessor >= 0.2.2.3, distributed-static >= 0.3.4.0 && < 0.4, distributed-process >= 0.7.3 && < 0.8, distributed-process-extras >= 0.3.1 && < 0.4, distributed-process-client-server >= 0.2.0 && < 0.4, binary >= 0.8 && < 0.9,- deepseq >= 1.4 && < 1.6,- mtl,+ deepseq >= 1.4 && < 1.7, containers >= 0.6 && < 0.8, hashable >= 1.2.0.5 && < 1.6,- unordered-containers >= 0.2.3.0 && < 0.3,- fingertree < 0.2,- stm >= 2.4 && < 2.6, time > 1.4 && < 1.15,- transformers, exceptions >= 0.10 && < 0.11 hs-source-dirs: src exposed-modules:@@ -72,10 +66,6 @@ type: exitcode-stdio-1.0 build-depends: base >= 4.14 && < 5,- ansi-terminal >= 0.5 && < 0.9,- containers,- unordered-containers,- hashable, distributed-static >= 0.3.5.0 && < 0.4, distributed-process >= 0.7.3 && < 0.8, distributed-process-supervisor,@@ -84,25 +74,17 @@ distributed-static, bytestring, random,- data-accessor,- fingertree < 0.2, network-transport >= 0.4 && < 0.6,- mtl, network-transport-tcp >= 0.4 && < 0.9, binary >= 0.8 && < 0.9, deepseq,- network >= 2.3 && < 3.3, HUnit >= 1.2 && < 2, stm,- time, test-framework >= 0.6 && < 0.9, test-framework-hunit,- transformers,- rematch >= 0.2.0.0,- ghc-prim, exceptions >= 0.10 && < 0.11 hs-source-dirs: tests- ghc-options: -threaded -rtsopts -with-rtsopts=-N -fno-warn-name-shadowing -fno-warn-unused-do-bind -eventlog+ ghc-options: -threaded -rtsopts -with-rtsopts=-N -fno-warn-name-shadowing -fno-warn-unused-do-bind main-is: TestSupervisor.hs other-modules: TestUtils default-language: Haskell2010@@ -112,34 +94,22 @@ type: exitcode-stdio-1.0 build-depends: base >= 4.14 && < 5,- ansi-terminal >= 0.5 && < 0.9,- containers,- unordered-containers,- hashable,+ bytestring, distributed-static >= 0.3.5.0 && < 0.4, distributed-process >= 0.7.3 && < 0.8, distributed-process-supervisor, distributed-process-extras, distributed-process-client-server, distributed-static,- bytestring, random,- data-accessor,- fingertree < 0.2, network-transport,- mtl, network-transport-tcp >= 0.4 && < 0.9, binary >= 0.8 && < 0.9, deepseq,- network >= 2.3 && < 3.3, HUnit >= 1.2 && < 2, stm,- time, test-framework >= 0.6 && < 0.9, test-framework-hunit,- transformers,- rematch >= 0.2.0.0,- ghc-prim, exceptions >= 0.10 && < 0.11 hs-source-dirs: tests ghc-options: -rtsopts -fno-warn-unused-do-bind -fno-warn-name-shadowing
tests/TestSupervisor.hs view
@@ -1,9 +1,9 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE Rank2Types #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -- NOTICE: Some of these tests are /unsafe/, and will fail intermittently, since -- they rely on ordering constraints which the Cloud Haskell runtime does not@@ -47,18 +47,11 @@ 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)+import Data.Maybe (catMaybes, isNothing, isJust) -import Test.HUnit (Assertion, assertFailure)+import Test.HUnit (Assertion, assertFailure, assertEqual, assertBool) import Test.Framework (Test, testGroup) import Test.Framework.Providers.HUnit (testCase) import TestUtils hiding (waitForExit)@@ -119,7 +112,7 @@ ensureProcessIsAlive :: ProcessId -> Process () ensureProcessIsAlive pid = do result <- isProcessAlive pid- expectThat result $ is True+ liftIO $ assertBool mempty result runInTestContext :: LocalNode -> MVar ()@@ -178,7 +171,7 @@ -- TODO: handle (ChildRestarting _) too! case cSpec of Just (ref, _) -> do Just pid' <- resolve ref- expectThat pid' $ isNot $ equalTo pid+ liftIO $ assertBool mempty ( pid' /= pid) _ -> do liftIO $ assertFailure $ "unexpected child ref: " ++ (show (key, cSpec)) @@ -195,7 +188,7 @@ void $ waitForExit pid sleepFor 500 Millis cSpec <- lookupChild sup "temp-worker"- expectThat cSpec isNothing+ liftIO $ assertBool mempty (isNothing cSpec) waitForExit :: ProcessId -> Process DiedReason waitForExit pid = do@@ -232,11 +225,11 @@ mx <- receiveChanTimeout t sniffer case mx of Just rs@SupervisedChildRestarting{} -> do- (childSpecKey rs) `shouldBe` equalTo key+ liftIO $ assertEqual mempty (childSpecKey rs) key mx' <- receiveChanTimeout t sniffer case mx' of Just cs@SupervisedChildStarted{} -> do- (childSpecKey cs) `shouldBe` equalTo key+ liftIO $ assertEqual mempty (childSpecKey cs) key debug logChannel $ "restart ok for " ++ (show cs) _ -> liftIO $ assertFailure $ " Unexpected Waiting Child Started " ++ (show mx') _ -> liftIO $ assertFailure $ "Unexpected Waiting Child Restarted " ++ (show mx)@@ -257,14 +250,14 @@ case mx of Just SupervisedChildRestarting{..} -> do debug logChannel $ "for restart " ++ (show childSpecKey) ++ " we're expecting " ++ (childKey cs)- childSpecKey `shouldBe` equalTo (childKey cs)+ liftIO $ assertEqual mempty childSpecKey (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+ liftIO $ assertEqual mempty childRef oCr mx' <- receiveChanTimeout t sniffer case mx' of- Just SupervisedChildStarted{..} -> childRef `shouldBe` equalTo cr+ Just SupervisedChildStarted{..} -> liftIO $ assertEqual mempty childRef cr _ -> do liftIO $ assertFailure $ "After Stopping " ++ (show cs) ++ " received unexpected " ++ (show mx)@@ -287,7 +280,7 @@ case mx of Just SupervisedChildRestarting{..} -> do debug logChannel $ "for restart " ++ (show childSpecKey) ++ " we're expecting " ++ (childKey cs)- childSpecKey `shouldBe` equalTo (childKey cs)+ liftIO $ assertEqual mempty childSpecKey (childKey cs) if childSpecKey /= toStop then do Just SupervisedChildStopped{..} <- receiveChanTimeout t sniffer debug logChannel $ "for " ++ (show childRef) ++ " we're expecting " ++ (show oCr)@@ -304,7 +297,7 @@ debug logChannel $ "checking (reverse) start order for " ++ (show cr) mx <- receiveTimeout t [ matchChan sniffer return ] case mx of- Just SupervisedChildStarted{..} -> childRef `shouldBe` equalTo cr+ Just SupervisedChildStarted{..} -> liftIO $ assertEqual mempty childRef cr _ -> liftIO $ assertFailure $ "Bad Child Start: " ++ (show mx) checkStartupOrder :: Context -> [Child] -> Process ()@@ -314,7 +307,7 @@ debug logChannel $ "checking " ++ (show cr) mx <- receiveTimeout (asTimeout waitTimeout) [ matchChan sniffer return ] case mx of- Just SupervisedChildStarted{..} -> childRef `shouldBe` equalTo cr+ Just SupervisedChildStarted{..} -> liftIO $ assertEqual mempty childRef cr _ -> liftIO $ assertFailure $ "Bad Child Start: " ++ (show mx) exitIgnore :: Process ()@@ -469,7 +462,7 @@ addChildWithoutRestart cs sup = let spec = transientWorker cs in do response <- addChild sup spec- response `shouldBe` equalTo (ChildAdded ChildStopped)+ liftIO $ assertEqual mempty response (ChildAdded ChildStopped) addChildThenStart :: ChildStart -> ProcessId -> Process () addChildThenStart cs sup =@@ -479,7 +472,7 @@ case response of ChildStartOk (ChildRunning pid) -> do alive <- isProcessAlive pid- alive `shouldBe` equalTo True+ liftIO $ assertBool mempty alive _ -> do liftIO $ putStrLn (show response) die "Ooops"@@ -487,13 +480,13 @@ startUnknownChild :: ChildStart -> ProcessId -> Process () startUnknownChild cs sup = do response <- startChild sup (childKey (transientWorker cs))- response `shouldBe` equalTo ChildStartUnknownId+ liftIO $ assertEqual mempty response ChildStartUnknownId setupChild :: ChildStart -> ProcessId -> Process (ChildRef, ChildSpec) setupChild cs sup = do let spec = transientWorker cs response <- addChild sup spec- response `shouldBe` equalTo (ChildAdded ChildStopped)+ liftIO $ assertEqual mempty response (ChildAdded ChildStopped) Just child <- lookupChild sup "transient-worker" return child @@ -501,19 +494,19 @@ addDuplicateChild cs sup = do (ref, spec) <- setupChild cs sup dup <- addChild sup spec- dup `shouldBe` equalTo (ChildFailedToStart $ StartFailureDuplicateChild ref)+ liftIO $ assertEqual mempty dup (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)+ liftIO $ assertEqual mempty dup (ChildFailedToStart $ StartFailureDuplicateChild ref) startBadClosure :: ChildStart -> ProcessId -> Process () startBadClosure cs sup = do let spec = tempWorker cs child <- startNewChild sup spec- child `shouldBe` equalTo+ liftIO $ assertEqual mempty child (ChildFailedToStart $ StartFailureBadClosure "user error (Could not resolve closure: Invalid static label 'non-existing')") @@ -532,7 +525,7 @@ let spec = transientWorker cs (ChildAdded ref) <- startNewChild sup spec result <- deleteChild sup "transient-worker"- result `shouldBe` equalTo (ChildNotStopped ref)+ liftIO $ assertEqual mempty result (ChildNotStopped ref) deleteStoppedTempChild :: ChildStart -> ProcessId -> Process () deleteStoppedTempChild cs sup = do@@ -543,7 +536,7 @@ -- child needs to be stopped waitForExit pid result <- deleteChild sup (childKey spec)- result `shouldBe` equalTo ChildNotFound+ liftIO $ assertEqual mempty result ChildNotFound deleteStoppedChild :: ChildStart -> ProcessId -> Process () deleteStoppedChild cs sup = do@@ -554,7 +547,7 @@ -- child needs to be stopped waitForExit pid result <- deleteChild sup (childKey spec)- result `shouldBe` equalTo ChildDeleted+ liftIO $ assertEqual mempty result ChildDeleted permanentChildrenAlwaysRestart :: ChildStart -> ProcessId -> Process () permanentChildrenAlwaysRestart cs sup = do@@ -601,7 +594,7 @@ waitForDown mRef mx <- receiveChanTimeout 1000 sniffer :: Process (Maybe MxSupervisor)- expectThat mx isNothing+ liftIO $ assertBool mempty (isNothing mx) verifyChildWasNotRestarted (childKey spec) pid sup intrinsicChildrenAbnormalExit :: ChildStart -> ProcessId -> Process ()@@ -619,19 +612,19 @@ Just pid <- resolve ref testProcessStop pid reason <- waitForExit sup- expectThat reason $ equalTo DiedNormal+ liftIO $ assertEqual mempty reason 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)+ liftIO $ assertEqual mempty result (ChildRestartFailed (StartFailureAlreadyRunning ref)) explicitRestartUnknownChild :: ProcessId -> Process () explicitRestartUnknownChild sup = do result <- restartChild sup "unknown-id"- expectThat result $ equalTo ChildRestartUnknownId+ liftIO $ assertEqual mempty result ChildRestartUnknownId explicitRestartRestartingChild :: ChildStart -> ProcessId -> Process () explicitRestartRestartingChild cs sup = do@@ -660,7 +653,7 @@ restarted <- restartChild sup key sleepFor 500 Millis Just (ref', _) <- lookupChild sup key- expectThat ref $ isNot $ equalTo ref'+ liftIO $ assertBool mempty (ref /= ref') case restarted of ChildRestartOk (ChildRunning _) -> return () _ -> liftIO $ assertFailure $ "unexpected exit: " ++ (show restarted)@@ -673,7 +666,7 @@ mRef <- monitor ref void $ stopChild sup (childKey spec) reason <- waitForDown mRef- expectThat reason $ equalTo $ DiedException (expectedExitReason sup)+ liftIO $ assertEqual mempty reason (DiedException (expectedExitReason sup)) stoppingChildExceedsDelay :: ProcessId -> Process () stoppingChildExceedsDelay sup = do@@ -684,7 +677,7 @@ mRef <- monitor ref void $ stopChild sup (childKey spec) reason <- waitForDown mRef- expectThat reason $ equalTo $ DiedException (expectedExitReason sup)+ liftIO $ assertEqual mempty reason (DiedException (expectedExitReason sup)) stoppingChildObeysDelay :: ProcessId -> Process () stoppingChildObeysDelay sup = do@@ -732,7 +725,7 @@ case ref of ChildRestarting _ -> do SupervisedChildStarted{..} <- receiveChan sniffer- childSpecKey `shouldBe` equalTo (childKey spec)+ liftIO $ assertEqual mempty childSpecKey (childKey spec) _ -> liftIO $ assertFailure $ "Unexpected ChildRef: " ++ (show ref) mapM_ (const $ verifySingleRestart ctx (childKey spec)) [1..3 :: Int]@@ -757,7 +750,7 @@ void $ ((startNewChild sup spec >> return ()) `catchExit` (\_ (_ :: ExitReason) -> return ())) reason <- waitForDown ref- expectThat reason $ equalTo $+ liftIO $ assertEqual mempty reason $ DiedException $ "exit-from=" ++ (show sup) ++ ",reason=ReachedMaxRestartIntensity" @@ -841,7 +834,7 @@ True -> liftIO $ assertFailure $ "unexpected exit from " ++ show pid' False -> return ()) ]- expectThat r isNothing+ liftIO $ assertBool mempty (isNothing r) restartRightWithLeftToRightSeqRestarts :: ChildStart@@ -873,7 +866,7 @@ True -> liftIO $ assertFailure $ "unexpected exit from " ++ show pid' False -> return ()) ]- expectThat r isNothing+ liftIO $ assertBool mempty (isNothing r) restartAllWithLeftToRightRestarts :: ProcessId -> Process () restartAllWithLeftToRightRestarts sup = do@@ -907,7 +900,7 @@ 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+ forM_ (zip c1 c2) $ \(p1, p2) -> liftIO $ assertBool mempty (p1 /= p2) where drainAllChildren children = do -- Receive all pids then verify they arrived in the correct order.@@ -977,7 +970,7 @@ [ matchIf (\(ProcessMonitorNotification r _ _) -> (Just r) == (snd $ head refs)) (\sig@(ProcessMonitorNotification _ _ _) -> return sig) ]- expectThat initRes $ isJust+ liftIO $ assertBool mempty (isJust initRes) forM_ (reverse (filter ((/= ref) .fst ) refs)) $ \(_, Just mRef) -> do (ProcessMonitorNotification ref' _ _) <- expect@@ -1022,7 +1015,7 @@ verifyChildWasRestarted (childKey spec) pid sup Just (ref3, _) <- lookupChild sup "child2" Just pid2' <- resolve ref3- pid2 `shouldBe` equalTo pid2'+ liftIO $ assertEqual mempty pid2 pid2' restartWithoutTempChildren :: ChildStart -> ProcessId -> Process () restartWithoutTempChildren cs sup = do@@ -1044,8 +1037,9 @@ (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+ liftIO $ do+ assertEqual mempty (fst ch1) ref2+ assertEqual mempty (fst ch2) ref Just pid <- resolve ref Just pid2 <- resolve ref2 -- ref (and therefore pid) is 'rightmost' now@@ -1053,7 +1047,7 @@ verifyChildWasRestarted "child1" pid sup Just (ref3, _) <- lookupChild sup "child2" Just pid2' <- resolve ref3- pid2 `shouldBe` equalTo pid2'+ liftIO $ assertEqual mempty pid2 pid2' restartLeftWithLeftToRightRestarts :: Bool -> Context -> Process () restartLeftWithLeftToRightRestarts rev ctx@Context{..} = do@@ -1084,7 +1078,7 @@ 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+ forM_ (zip c1 c2) $ \(p1, p2) -> liftIO $ assertEqual mempty p1 p2 restartRightWithLeftToRightRestarts :: Bool -> Context -> Process () restartRightWithLeftToRightRestarts rev ctx@Context{..} = do@@ -1116,7 +1110,7 @@ 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+ forM_ (zip c1 c2) $ \(p1, p2) -> liftIO $ assertEqual mempty p1 p2 restartRightWithRightToLeftRestarts :: Bool -> Context -> Process () restartRightWithRightToLeftRestarts rev ctx@Context{..} = do@@ -1148,7 +1142,7 @@ 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+ forM_ (zip c1 c2) $ \(p1, p2) -> liftIO $ assertEqual mempty p1 p2 restartLeftWithRightToLeftRestarts :: Bool -> Context -> Process () restartLeftWithRightToLeftRestarts rev ctx@Context{..} = do@@ -1182,7 +1176,7 @@ 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+ forM_ (zip c1 c2) $ \(p1, p2) -> liftIO $ assertEqual mempty p1 p2 -- remote table definition and main
tests/TestUtils.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TemplateHaskell #-}@@ -9,12 +8,7 @@ -- ping ! , Ping(Ping) , ping- , shouldBe- , shouldMatch- , shouldContain- , shouldNotContain , shouldExitWith- , expectThat -- test process utilities , TestProcessControl , startTestProcess@@ -66,9 +60,7 @@ import Control.Monad (forever) import Control.Monad.Catch (catch) import Control.Monad.STM (atomically)-import Control.Rematch hiding (match)-import Control.Rematch.Run-import Test.HUnit (Assertion, assertFailure)+import Test.HUnit (Assertion, assertEqual) import Test.HUnit.Base (assertBool) import Test.Framework (Test, defaultMain) import Control.DeepSeq@@ -80,32 +72,11 @@ import Data.Typeable import GHC.Generics ---expect :: a -> Matcher a -> Process ()---expect a m = liftIO $ Rematch.expect a m--expectThat :: a -> Matcher a -> Process ()-expectThat a matcher = case res of- MatchSuccess -> return ()- (MatchFailure msg) -> liftIO $ assertFailure msg- where res = runMatch matcher a--shouldBe :: a -> Matcher a -> Process ()-shouldBe = expectThat--shouldContain :: (Show a, Eq a) => [a] -> a -> Process ()-shouldContain xs x = expectThat xs $ hasItem (equalTo x)--shouldNotContain :: (Show a, Eq a) => [a] -> a -> Process ()-shouldNotContain xs x = expectThat xs $ isNot (hasItem (equalTo x))--shouldMatch :: a -> Matcher a -> Process ()-shouldMatch = expectThat- shouldExitWith :: (Resolvable a) => a -> DiedReason -> Process () shouldExitWith a r = do _ <- resolve a d <- receiveWait [ match (\(ProcessMonitorNotification _ _ r') -> return r') ]- d `shouldBe` equalTo r+ liftIO $ assertEqual mempty d r waitForExit :: MVar ExitReason -> Process (Maybe ExitReason)