diff --git a/ChangeLog b/ChangeLog --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,7 @@ +2024-10-30 Laurent P. René de Cotret 0.2.3 + +* Removed dependency on `rematch` (#459) + 2024-09-03 Laurent P. René de Cotret 0.2.2 * Bumped dependency bounds to support GHC 8.10.7 - GHC 9.10.1 diff --git a/distributed-process-supervisor.cabal b/distributed-process-supervisor.cabal --- a/distributed-process-supervisor.cabal +++ b/distributed-process-supervisor.cabal @@ -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 diff --git a/tests/TestSupervisor.hs b/tests/TestSupervisor.hs --- a/tests/TestSupervisor.hs +++ b/tests/TestSupervisor.hs @@ -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 diff --git a/tests/TestUtils.hs b/tests/TestUtils.hs --- a/tests/TestUtils.hs +++ b/tests/TestUtils.hs @@ -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)