distributed-process-tests 0.4.13 → 0.5.3
raw patch · 14 files changed
Files
- distributed-process-tests.cabal +52/−28
- src/Control/Distributed/Process/Tests/CH.hs +36/−20
- src/Control/Distributed/Process/Tests/Closure.hs +4/−5
- src/Control/Distributed/Process/Tests/Internal/Utils.hs +1/−2
- src/Control/Distributed/Process/Tests/Mx.hs +118/−76
- src/Control/Distributed/Process/Tests/Receive.hs +4/−5
- src/Control/Distributed/Process/Tests/Stats.hs +4/−8
- src/Control/Distributed/Process/Tests/Tracing.hs +4/−7
- tests/TestDeathKeys.hs +117/−0
- tests/credentials/cert.crt +22/−0
- tests/credentials/cert.key +28/−0
- tests/runInMemory.hs +4/−7
- tests/runQUIC.hs +75/−0
- tests/runTCP.hs +4/−6
distributed-process-tests.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.0 name: distributed-process-tests-version: 0.4.13+version: 0.5.3 synopsis: Tests and test support tools for distributed-process. homepage: http://github.com/haskell-distributed/distributed-process/tree/master/distributed-process-tests description: Tests and test suite for Cloud Haskell libraries, specifically the core distributed-process library.@@ -11,6 +11,10 @@ copyright: Well-Typed LLP category: Control, Cloud Haskell build-type: Simple+tested-with: GHC==8.10.7 GHC==9.0.2 GHC==9.2.8 GHC==9.4.8 GHC==9.6.7 GHC==9.8.4 GHC==9.10.3 GHC==9.12.2 GHC==9.14.1+extra-source-files:+ tests/credentials/cert.crt+ tests/credentials/cert.key source-repository head Type: git@@ -21,6 +25,10 @@ Description: build and run TCP tests Default: False +flag quic+ Description: build and run QUIC tests+ Default: True+ common warnings ghc-options: -Wall -Wcompat@@ -30,6 +38,7 @@ -Wredundant-constraints -fhide-source-paths -Wpartial-fields+ -Wunused-packages library import: warnings@@ -42,19 +51,16 @@ Control.Distributed.Process.Tests.Tracing Control.Distributed.Process.Tests.Internal.Utils Build-Depends: base >= 4.14 && < 5,- ansi-terminal >= 0.5, binary >= 0.8 && < 0.9, bytestring >= 0.10 && < 0.13, distributed-process >= 0.6.0 && < 0.8, distributed-static, exceptions >= 0.10,- HUnit >= 1.2 && < 1.7, network-transport >= 0.4.1.0 && < 0.6,- network >= 2.5 && < 3.3,- random >= 1.0 && < 1.3,+ random >= 1.0 && < 1.4, setenv >= 0.1.1.3,- test-framework >= 0.6 && < 0.9,- test-framework-hunit >= 0.2.0 && < 0.4,+ tasty >= 1.5 && <1.6,+ tasty-hunit >=0.10 && <0.11, stm hs-source-dirs: src default-language: Haskell98@@ -76,10 +82,8 @@ CPP-Options: -DTEST_SUITE_MODULE=Control.Distributed.Process.Tests.CH Build-Depends: base >= 4.14 && < 5, distributed-process-tests,- network >= 2.3 && < 3.3,- network-transport >= 0.4.1.0 && < 0.6, network-transport-inmemory >= 0.5,- test-framework >= 0.6 && < 0.9+ tasty >= 1.5 && <1.6, default-extensions: CPP default-language: Haskell98 ghc-options: -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind@@ -93,10 +97,9 @@ if flag(tcp) Build-Depends: base >= 4.14 && < 5, distributed-process-tests,- network >= 2.5 && < 3.2,- network-transport >= 0.4.1.0 && < 0.6,+ network >= 2.3 && < 3.3, network-transport-tcp >= 0.5 && < 0.9,- test-framework >= 0.6 && < 0.9+ tasty >= 1.5 && <1.6, else Buildable: False default-extensions: CPP@@ -104,6 +107,22 @@ ghc-options: -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind HS-Source-Dirs: tests +Test-Suite TestCHInQUIC+ import: warnings+ Type: exitcode-stdio-1.0+ Main-Is: runQUIC.hs+ if flag(quic)+ Build-Depends: base >= 4.14 && < 5,+ distributed-process-tests,+ filepath,+ network-transport,+ network-transport-quic,+ tasty >= 1.5 && <1.6,+ else+ Buildable: False+ default-language: Haskell2010+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ HS-Source-Dirs: tests Test-Suite TestClosure import: warnings@@ -112,10 +131,8 @@ CPP-Options: -DTEST_SUITE_MODULE=Control.Distributed.Process.Tests.Closure Build-Depends: base >= 4.14 && < 5, distributed-process-tests,- network >= 2.3 && < 3.3,- network-transport >= 0.4.1.0 && < 0.6, network-transport-inmemory >= 0.5,- test-framework >= 0.6 && < 0.9+ tasty >= 1.5 && <1.6, default-extensions: CPP default-language: Haskell98 ghc-options: -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind@@ -128,10 +145,8 @@ CPP-Options: -DTEST_SUITE_MODULE=Control.Distributed.Process.Tests.Stats Build-Depends: base >= 4.14 && < 5, distributed-process-tests,- network >= 2.3 && < 3.3,- network-transport >= 0.4.1.0 && < 0.6, network-transport-inmemory >= 0.5,- test-framework >= 0.6 && < 0.9+ tasty >= 1.5 && <1.6, default-extensions: CPP default-language: Haskell98 ghc-options: -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind@@ -144,10 +159,8 @@ CPP-Options: -DTEST_SUITE_MODULE=Control.Distributed.Process.Tests.Mx Build-Depends: base >= 4.14 && < 5, distributed-process-tests,- network >= 2.3 && < 3.3,- network-transport >= 0.4.1.0 && < 0.6, network-transport-inmemory >= 0.5,- test-framework >= 0.6 && < 0.9+ tasty >= 1.5 && <1.6, default-extensions: CPP default-language: Haskell98 ghc-options: -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind@@ -160,10 +173,8 @@ CPP-Options: -DTEST_SUITE_MODULE=Control.Distributed.Process.Tests.Tracing Build-Depends: base >= 4.14 && < 5, distributed-process-tests,- network >= 2.3 && < 3.3,- network-transport >= 0.4.1.0 && < 0.6, network-transport-inmemory >= 0.5,- test-framework >= 0.6 && < 0.9+ tasty >= 1.5 && <1.6, default-extensions: CPP default-language: Haskell98 ghc-options: -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind@@ -176,11 +187,24 @@ CPP-Options: -DTEST_SUITE_MODULE=Control.Distributed.Process.Tests.Mx Build-Depends: base >= 4.14 && < 5, distributed-process-tests,- network >= 2.3 && < 3.3,- network-transport >= 0.4.1.0 && < 0.6, network-transport-inmemory >= 0.5,- test-framework >= 0.6 && < 0.9+ tasty >= 1.5 && <1.6, default-extensions: CPP default-language: Haskell98 ghc-options: -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind+ HS-Source-Dirs: tests++Test-Suite TestDeathKeys+ import: warnings+ Type: exitcode-stdio-1.0+ Main-Is: TestDeathKeys.hs+ Build-Depends: base >= 4.14 && < 5,+ bytestring >= 0.10 && < 0.13,+ containers >= 0.6 && < 0.9,+ distributed-process >= 0.7.10 && < 0.8,+ network-transport >= 0.4.1.0 && < 0.6,+ tasty >= 1.5 && <1.6,+ tasty-hunit >=0.10 && <0.11,+ tasty-quickcheck >=0.11 && <0.12+ default-language: Haskell2010 HS-Source-Dirs: tests
src/Control/Distributed/Process/Tests/CH.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE NumericUnderscores #-} module Control.Distributed.Process.Tests.CH (tests) where @@ -42,9 +43,9 @@ import Control.Distributed.Process.Tests.Internal.Utils (pause) import Control.Distributed.Process.Serializable (Serializable) import Data.Maybe (isNothing, isJust)-import Test.HUnit (Assertion, assertBool, assertEqual, assertFailure)-import Test.Framework (Test, testGroup)-import Test.Framework.Providers.HUnit (testCase)+import System.Timeout (timeout)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (Assertion, assertBool, assertEqual, testCase, assertFailure) newtype Ping = Ping ProcessId deriving (Typeable, Binary, Show)@@ -71,7 +72,12 @@ ping verifyClient :: String -> MVar Bool -> IO ()-verifyClient s b = takeMVar b >>= assertBool s+verifyClient s b =+ -- The timeout below must be generous enough to support+ -- running tests in the Github Actions CI environment, which is quite slow.+ timeout 60_000_000+ (takeMVar b >>= assertBool s)+ >>= maybe (assertFailure $ "verifyClient timeout: " <> s) (\_ -> pure ()) expectPing :: MVar Bool -> Process () expectPing mv = expect >>= liftIO . putMVar mv . checkPing@@ -176,14 +182,14 @@ unmonitor ref liftIO $ putMVar done () (False, ref) -> do- receiveWait [+ receiveTimeout 1_000_000 [ match (\(ProcessMonitorNotification ref' pid reason') -> do liftIO $ do assertBool "Bad Monitor Signal" (Just ref' == ref && pid == theirAddr && mOrL && reason == reason') putMVar done ())- ]+ ] >>= maybe (liftIO $ assertFailure "No ProcessMonitorNotification received within timeout window") pure ) (\(ProcessLinkException pid reason') -> do (liftIO $ assertBool "link exception unmatched" $@@ -221,11 +227,11 @@ p <- expectTimeout 3000000 case p of Just (Ping _) -> return ()- Nothing -> die "Failed to receive Ping"+ Nothing -> let msg = "Failed to receive Ping" in liftIO (putMVar clientDone (Left msg)) >> die msg - putMVar clientDone ()+ putMVar clientDone (Right ()) - takeMVar clientDone+ takeMVar clientDone >>= either assertFailure pure -- | Monitor a process on an unreachable node testMonitorUnreachable :: TestTransport -> Bool -> Bool -> Assertion@@ -349,6 +355,7 @@ putMVar processAddr addr readMVar monitorSetup NT.closeEndPoint (localEndPoint localNode)+ threadDelay 100_000 putMVar processAddr2 addr2 forkIO $ do@@ -431,7 +438,7 @@ done <- newEmptyMVar runProcess localNode $ do- res <- receiveTimeout 1000000 [match (\Add{} -> return ())]+ res <- receiveTimeout 1_000_000 [match (\Add{} -> return ())] liftIO $ putMVar done $ res == Nothing verifyClient "Expected receiveTimeout to timeout..." done@@ -448,7 +455,7 @@ -- Variation on the venerable ping server which uses a zero timeout partner <- fix $ \loop -> receiveTimeout 0 [match (\(Pong partner) -> return partner)]- >>= maybe (liftIO (threadDelay 100000) >> loop) return+ >>= maybe (liftIO (threadDelay 100_000) >> loop) return self <- getSelfPid send partner (Ping self) putMVar serverAddr addr@@ -460,7 +467,7 @@ pid <- getSelfPid -- Send a bunch of messages. A large number of messages that the server -- is not interested in, and then a single message that it wants- replicateM_ 10000 $ send server "Irrelevant message"+ replicateM_ 10_000 $ send server "Irrelevant message" send server (Pong pid) expectPing clientDone @@ -583,7 +590,7 @@ charChannel c = do (sport, rport) <- newChan replicateM_ 3 $ sendChan sport c- liftIO $ threadDelay 10000 -- Make sure messages have been sent+ liftIO $ threadDelay 10_000 -- Make sure messages have been sent return rport testTerminate :: TestTransport -> Assertion@@ -622,15 +629,19 @@ forkProcess node2 $ do ref <- monitorNode (localNodeId node1) liftIO $ putMVar ready ()+ -- node1 gets closed liftIO $ takeMVar readyr send p ()- receiveWait [+ receiveTimeout 10_000_000 [ match (\(NodeMonitorNotification ref' nid _) -> (return $ ref == ref' && nid == localNodeId node1))- ] >>= liftIO . putMVar done+ ] >>= maybe+ (liftIO $ assertFailure "Did not receive NodeMonitorNotification message within timeout window")+ (liftIO . putMVar done) takeMVar ready closeLocalNode node1+ threadDelay 1_000_000 putMVar readyr () verifyClient "Expected NodeMonitorNotification for LIVE node" done@@ -639,22 +650,27 @@ testMonitorChannel TestTransport{..} = do [node1, node2] <- replicateM 2 $ newLocalNode testTransport initRemoteTable gotNotification <- newEmptyMVar+ ready <- newEmptyMVar pid <- forkProcess node1 $ do+ liftIO $ putMVar ready () sport <- expect :: Process (SendPort ()) ref <- monitorPort sport- receiveWait [+ receiveTimeout 10_000_000 [ -- reason might be DiedUnknownId if the receive port is GCed before the -- monitor is established (TODO: not sure that this is reasonable) match (\(PortMonitorNotification ref' port' reason) -> return $ ref' == ref && port' == sendPortId sport && (reason == DiedNormal || reason == DiedUnknownId))- ] >>= liftIO . putMVar gotNotification+ ] >>= maybe+ (liftIO $ assertFailure "Did not receive PortMonitorNotification message within timeout window")+ (liftIO . putMVar gotNotification) runProcess node2 $ do (sport, _) <- newChan :: Process (SendPort (), ReceivePort ())+ liftIO $ takeMVar ready send pid sport- liftIO $ threadDelay 100000+ liftIO $ threadDelay 100_000 verifyClient "Expected PortMonitorNotification" gotNotification @@ -1770,8 +1786,8 @@ takeMVar result4 >>= assertBool "Expected 'True'" -- XXX: Testing that when mask_ $ callLocal p runs p in masked state. -tests :: TestTransport -> IO [Test]-tests testtrans = return [+tests :: TestTransport -> IO TestTree+tests testtrans = return $ testGroup "CH" [ testGroup "Basic features" [ testCase "Ping" (testPing testtrans) , testCase "Math" (testMath testtrans)
src/Control/Distributed/Process/Tests/Closure.hs view
@@ -31,9 +31,8 @@ import Control.Distributed.Static (staticLabel, staticClosure) import qualified Network.Transport as NT -import Test.HUnit (Assertion)-import Test.Framework (Test)-import Test.Framework.Providers.HUnit (testCase)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (Assertion, testCase) -------------------------------------------------------------------------------- -- Supporting definitions --@@ -563,10 +562,10 @@ takeMVar masterDone -tests :: TestTransport -> IO [Test]+tests :: TestTransport -> IO TestTree tests testtrans = do let rtable = __remoteTable . __remoteTableDecl $ initRemoteTable- return+ return $ testGroup "Closure" [ testCase "Unclosure" (testUnclosure testtrans rtable) , testCase "Bind" (testBind testtrans rtable) , testCase "SendPureClosure" (testSendPureClosure testtrans rtable)
src/Control/Distributed/Process/Tests/Internal/Utils.hs view
@@ -79,8 +79,7 @@ import Data.Binary import Data.Typeable (Typeable) -import Test.HUnit (Assertion, assertFailure)-import Test.HUnit.Base (assertBool)+import Test.Tasty.HUnit (Assertion, assertBool) import GHC.Generics import System.Timeout (timeout)
src/Control/Distributed/Process/Tests/Mx.hs view
@@ -1,8 +1,11 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE ParallelListComp #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NumericUnderscores #-} module Control.Distributed.Process.Tests.Mx (tests) where +import Control.Concurrent.MVar (newEmptyMVar, putMVar, tryTakeMVar)+import Control.Concurrent (threadDelay) import Control.Distributed.Process.Tests.Internal.Utils import Network.Transport.Test (TestTransport(..)) import Control.Distributed.Process hiding (bracket, finally, try)@@ -36,20 +39,15 @@ import Control.Monad (void, unless) import Control.Monad.Catch(finally, bracket, try) import Data.Binary-import Data.List (find, sort, intercalate)-import Data.Maybe (isJust, fromJust, isNothing, fromMaybe, catMaybes)-import Data.Typeable+import Data.List (sort, intercalate)+import Data.Maybe (isJust, fromJust, fromMaybe) import GHC.Generics hiding (from) -import Test.Framework- ( Test- , testGroup- )-import Test.Framework.Providers.HUnit (testCase)-import Test.HUnit (assertBool, assertEqual)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, assertEqual, testCase) data Publish = Publish- deriving (Typeable, Generic, Eq)+ deriving (Generic, Eq) instance Binary Publish where @@ -151,82 +149,126 @@ stash result =<< receiveChanTimeout 1000000 rp kill agent "finished" + testAgentEventHandling :: TestResult Bool -> Process () testAgentEventHandling result = do- us <- getSelfPid- -- because this test is a bit racy, let's ensure it can't run indefinitely- timer <- spawnLocal $ do- pause (1000000 * 60 * 5)- -- okay we've waited 5 mins, let's kill the test off if it's stuck...- stash result False- kill us "Test Timed Out"+ let timeout = 1_000_000 + (ackSP, ackRP) <- newChan :: Process (SendPort MxEvent, ReceivePort MxEvent)+ let initState = [] :: [MxEvent]- (rc, rs) <- newChan- agentPid <- mxAgent (MxAgentId "lifecycle-listener-agent") initState [- (mxSink $ \ev -> do- st <- mxGetLocal- let act =- case ev of- (MxSpawned _) -> mxSetLocal (ev:st)- (MxProcessDied _ _) -> mxSetLocal (ev:st)- _ -> return ()- act >> (liftMX $ sendChan rc ()) >> mxReady),- (mxSink $ \(ev, sp :: SendPort Bool) -> do- st <- mxGetLocal- let found =- case ev of- MxSpawned p ->- isJust $ find (\ev' ->- case ev' of- (MxSpawned p') -> p' == p- _ -> False) st- MxProcessDied p r ->- isJust $ find (\ev' ->- case ev' of- (MxProcessDied p' r') -> p' == p && r == r'- _ -> False) st- _ -> False- liftMX $ sendChan sp found- mxReady)- ] - -- TODO: yes, this is racy, but we're at the mercy of the scheduler here...- faff 2000000 rs+ agentPid <- mxAgent (MxAgentId "lifecycle-listener-agent") initState [+ mxSink $ \ev -> do+ case ev of+ MxSpawned _ -> do+ st <- mxGetLocal+ mxSetLocal (ev : st)+ liftMX $ sendChan ackSP ev - (sp, rp) <- newChan :: Process (SendPort (), ReceivePort ())+ MxProcessDied _ _ -> do+ st <- mxGetLocal+ mxSetLocal (ev : st)+ liftMX $ sendChan ackSP ev - pid <- spawnLocal $ expect >>= sendChan sp+ _ -> pure () - -- By waiting for a monitor notification, we have a- -- higher probably that the agent has seen the spawn and died events- monitor pid+ mxReady + , mxSink $ \(ev, sp :: SendPort Bool) -> do+ st <- mxGetLocal++ let found =+ case ev of+ MxSpawned p ->+ any (\case+ MxSpawned p' -> p' == p+ _ -> False) st++ MxProcessDied p r ->+ any (\case+ MxProcessDied p' r' ->+ p' == p && r' == r+ _ -> False) st++ _ -> False++ liftMX $ sendChan sp found+ mxReady+ ]++ (sp, rp) <- newChan :: Process (SendPort (), ReceivePort ())++ pid <- spawnLocal $ (expect :: Process ()) >> sendChan sp ()++ ref <- monitor pid send pid ()- rct <- receiveChanTimeout 10000000 rp- unless (isJust rct) $ die "No response on channel" - pmn <- receiveTimeout 2000000 [ match (\ProcessMonitorNotification{} -> return ()) ]- unless (isJust pmn) $ die "No monitor notification arrived"+ completed <- receiveChanTimeout timeout rp+ terminated <- receiveTimeout timeout+ [ matchIf+ (\(ProcessMonitorNotification r _ _) -> r == ref)+ (\_ -> pure ())+ ] - -- TODO: yes, this is racy, but we're at the mercy of the scheduler here...- faff 2000000 rs+ takingTooLong <- liftIO newEmptyMVar - (replyTo, reply) <- newChan :: Process (SendPort Bool, ReceivePort Bool)- mxNotify (MxSpawned pid, replyTo)- mxNotify (MxProcessDied pid DiedNormal, replyTo)+ spawnLocal . liftIO $ do+ threadDelay timeout+ putMVar takingTooLong () - seenAlive <- receiveChanTimeout 10000000 reply- seenDead <- receiveChanTimeout 10000000 reply+ -- race conditions are eliminated by awaiting exactly the events+ let awaitEvents seenSpawn seenDeath+ | seenSpawn && seenDeath = pure True+ | otherwise =+ liftIO (tryTakeMVar takingTooLong) >>= \case+ -- Awaiting is taking too long+ Just () -> pure False+ Nothing -> do+ next <- receiveChanTimeout timeout ackRP+ case next of+ Nothing -> pure False - stash result $ foldr (&&) True $ catMaybes [seenAlive, seenDead]- kill timer "test-complete"+ Just ev ->+ case ev of+ MxSpawned p+ | p == pid -> awaitEvents True seenDeath++ MxProcessDied p DiedNormal+ | p == pid -> awaitEvents seenSpawn True++ _ -> awaitEvents seenSpawn seenDeath++++ observed <- awaitEvents False False++ (seenAlive, seenDead) <-+ if observed+ then do+ (replyTo, reply) <- newChan :: Process (SendPort Bool, ReceivePort Bool)++ mxNotify (MxSpawned pid, replyTo)+ mxNotify (MxProcessDied pid DiedNormal, replyTo)++ alive <- receiveChanTimeout timeout reply+ dead <- receiveChanTimeout timeout reply++ return (alive, dead)++ else return (Nothing, Nothing)++ stash result $+ and [ completed == Just ()+ , isJust terminated+ , observed+ , seenAlive == Just True+ , seenDead == Just True+ ]+ kill agentPid "test-complete"- where- faff delay port = do- res <- receiveChanTimeout delay port- unless (isNothing res) $ pause delay + testMxRegEvents :: TestResult () -> Process () testMxRegEvents result = do {- This test only deals with the local case, to ensure that we are being@@ -266,7 +308,7 @@ reregister label p1 unreg2 <- receiveChanTimeout delay unRegSink- liftIO $ assertEqual mempty (Just (label, p2)) unreg2 + liftIO $ assertEqual mempty (Just (label, p2)) unreg2 reg3 <- receiveChanTimeout delay regSink liftIO $ assertEqual mempty (Just (label, p1)) reg3@@ -305,7 +347,7 @@ register label1 p1 reg1 <- receiveChanTimeout delay regSink- liftIO $ assertEqual mempty (Just (label1, p1)) reg1 + liftIO $ assertEqual mempty (Just (label1, p1)) reg1 register label2 p1 reg2 <- receiveChanTimeout delay regSink@@ -461,11 +503,11 @@ send p' s return r -tests :: TestTransport -> IO [Test]+tests :: TestTransport -> IO TestTree tests TestTransport{..} = do node1 <- newLocalNode testTransport initRemoteTable node2 <- newLocalNode testTransport initRemoteTable- return [+ return $ testGroup "Mx" [ testGroup "MxAgents" [ testCase "EventHandling" (delayedAssertion@@ -527,7 +569,7 @@ build :: LocalNode -> LocalNode -> [(String, [(String, (Maybe LocalNode -> Process ()))])]- -> [Test]+ -> [TestTree] build n ln specs = [ testGroup (intercalate "-" [groupName, caseSuffix]) [ testCase (intercalate "-" [caseName, caseSuffix])
src/Control/Distributed/Process/Tests/Receive.hs view
@@ -14,9 +14,8 @@ import Control.Monad -import Test.HUnit (Assertion, (@?=))-import Test.Framework (Test)-import Test.Framework.Providers.HUnit (testCase)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (Assertion, (@?=), testCase) -- Tests: @@ -147,8 +146,8 @@ node <- newLocalNode transport rtable runProcess node $ master -tests :: TestTransport -> IO [Test]+tests :: TestTransport -> IO TestTree tests TestTransport{..} = do let rtable = initRemoteTable- return+ return $ testGroup "Receive" [ testCase "testReceive" (testReceive testTransport rtable) ]
src/Control/Distributed/Process/Tests/Stats.hs view
@@ -16,12 +16,8 @@ import Data.Binary () import Data.Typeable () -import Test.Framework- ( Test- , testGroup- )-import Test.HUnit (Assertion)-import Test.Framework.Providers.HUnit (testCase)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (Assertion, testCase) testLocalDeadProcessInfo :: TestResult (Maybe ProcessInfo) -> Process () testLocalDeadProcessInfo result = do@@ -107,10 +103,10 @@ a <- delayedAssertion "getProcessInfo remotePid failed" n True return a -tests :: TestTransport -> IO [Test]+tests :: TestTransport -> IO TestTree tests testtrans@TestTransport{..} = do node1 <- newLocalNode testTransport initRemoteTable- return [+ return $ testGroup "Stats" [ testGroup "Process Info" [ testCase "testLocalDeadProcessInfo" (delayedAssertion
src/Control/Distributed/Process/Tests/Tracing.hs view
@@ -25,11 +25,8 @@ import Prelude hiding ((<*)) -import Test.Framework- ( Test- , testGroup- )-import Test.Framework.Providers.HUnit (testCase)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit ( testCase) import System.Environment (getEnvironment) -- These are available in System.Environment only since base 4.7 import System.SetEnv (setEnv, unsetEnv)@@ -375,14 +372,14 @@ (getSelfPid >>= register "a" >> unregister "a" >> getSelfPid) (\self -> isPrefixOf $ "MxUnRegistered " ++ show self ++ " " ++ show "a") -tests :: TestTransport -> IO [Test]+tests :: TestTransport -> IO TestTree tests testtrans@TestTransport{..} = do node1 <- newLocalNode testTransport initRemoteTable -- if we execute the test cases in parallel, the -- various tracers will race with one another and -- we'll get garbage results (or worse, deadlocks) lock <- liftIO $ newMVar ()- return [+ return $ testGroup "Tracing" [ testGroup "Tracing" [ testCase "Spawn Tracing" (synchronisedAssertion
+ tests/TestDeathKeys.hs view
@@ -0,0 +1,117 @@+module Main where++import Control.Distributed.Process.Internal.BiMultiMap (BiMultiMap)+import qualified Control.Distributed.Process.Internal.BiMultiMap as BiMultiMap+import Control.Distributed.Process.Internal.Messaging+ ( deathKey+ , deathKeys+ , impliesDeathOf+ )+import Control.Distributed.Process.Internal.Types+ ( Identifier(..)+ , LocalProcessId(..)+ , NodeId(..)+ , ProcessId(..)+ , SendPortId(..)+ )+import qualified Data.ByteString.Char8 as BSC+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Set (Set)+import Network.Transport (EndPointAddress(..))+import Test.Tasty (TestTree, defaultMain, testGroup)+import Test.Tasty.HUnit (assertEqual, testCase)+import Test.Tasty.QuickCheck+ ( Arbitrary(..)+ , Positive(..)+ , elements+ , testProperty+ )++-- All identifiers with 2 nodes, 4 processes per node and 2 ports per process.+universe :: [Identifier]+universe = map NodeIdentifier nodes+ ++ map ProcessIdentifier processes+ ++ [ SendPortIdentifier (SendPortId pid c) | pid <- processes, c <- [0, 1] ]+ where+ nodes = [ NodeId (EndPointAddress (BSC.pack a)) | a <- ["a", "b"] ]+ processes = [ ProcessId nid (LocalProcessId u c)+ | nid <- nodes, u <- [0, 1], c <- [0, 1] ]++newtype Ident = Ident Identifier++instance Show Ident where+ show (Ident i) = show i++instance Arbitrary Ident where+ arbitrary = Ident <$> elements universe++testDeathKeyImpliesDeathOf :: TestTree+testDeathKeyImpliesDeathOf =+ testCase "deathKey agrees with impliesDeathOf" $+ assertEqual "counterexamples" []+ [ (a, b) | a <- universe, b <- universe+ , (a `impliesDeathOf` b) /= (deathKey a b `elem` deathKeys a) ]++testDeathKeyMonotone :: TestTree+testDeathKeyMonotone =+ testCase "deathKey is monotone" $+ assertEqual "counterexamples" []+ [ (a, b1, b2) | a <- universe, b1 <- universe, b2 <- universe+ , b1 <= b2, deathKey a b1 > deathKey a b2 ]++-- Projections on Int: @(`div` d)@ is monotone.+prop_partitionOn :: Positive Int -> [Int] -> Map Int Char -> Bool+prop_partitionOn (Positive d) ps m =+ BiMultiMap.partitionOn (`div` d) ps m+ == Map.partitionWithKey (\k _ -> (k `div` d) `elem` ps) m++prop_partitionOnDeathKey :: Ident -> [(Ident, Char)] -> Bool+prop_partitionOnDeathKey (Ident a) kvs =+ BiMultiMap.partitionOn (deathKey a) (deathKeys a) m+ == Map.partitionWithKey (\k _ -> a `impliesDeathOf` k) m+ where+ m = Map.fromList [ (k, v) | (Ident k, v) <- kvs ]++prop_partitionOnBy1st :: Positive Int -> [Int] -> [(Int, Int, Char)] -> Bool+prop_partitionOnBy1st (Positive d) ps ts =+ sameResult (BiMultiMap.partitionOnBy1st (`div` d) ps bm)+ (BiMultiMap.partitionWithKeyBy1st (\k _ -> (k `div` d) `elem` ps) bm)+ where+ bm = fromTriplets ts++prop_partitionOnBy2nd :: Positive Int -> [Int] -> [(Int, Int, Char)] -> Bool+prop_partitionOnBy2nd (Positive d) ps ts =+ sameResult (BiMultiMap.partitionOnBy2nd (`div` d) ps bm)+ (BiMultiMap.partitionWithKeyBy2nd (\k _ -> (k `div` d) `elem` ps) bm)+ where+ bm = fromTriplets ts++sameResult :: (Eq k, Eq s)+ => (Map k s, BiMultiMap Int Int Char)+ -> (Map k s, BiMultiMap Int Int Char)+ -> Bool+sameResult (m, bm) (m', bm') = m == m' && sides bm == sides bm'++fromTriplets :: [(Int, Int, Char)] -> BiMultiMap Int Int Char+fromTriplets = foldr (\(a, b, v) -> BiMultiMap.insert a b v) BiMultiMap.empty++-- Both sides of a multimap: by the first and by the second component.+sides :: BiMultiMap Int Int Char+ -> (Map Int (Set (Int, Char)), Map Int (Set (Int, Char)))+sides bm = ( fst (BiMultiMap.partitionWithKeyBy1st (\_ _ -> True) bm)+ , fst (BiMultiMap.partitionWithKeyBy2nd (\_ _ -> True) bm)+ )++main :: IO ()+main = defaultMain tests++tests :: TestTree+tests = testGroup "Death keys"+ [ testDeathKeyImpliesDeathOf+ , testDeathKeyMonotone+ , testProperty "partitionOn" prop_partitionOn+ , testProperty "partitionOn with deathKey" prop_partitionOnDeathKey+ , testProperty "partitionOnBy1st" prop_partitionOnBy1st+ , testProperty "partitionOnBy2nd" prop_partitionOnBy2nd+ ]
+ tests/credentials/cert.crt view
@@ -0,0 +1,22 @@+-----BEGIN CERTIFICATE----- +MIIDoTCCAomgAwIBAgIUVp3lTRQWZSOwolWHNaghO6gR68owDQYJKoZIhvcNAQEL +BQAwRTESMBAGA1UEAwwJMTI3LjAuMC4xMQswCQYDVQQGEwJDQTEPMA0GA1UECAwG +UXVlYmVjMREwDwYDVQQHDAhNb250cmVhbDAgFw0yNTA4MTgwMDU1MDRaGA8yMTI1 +MDcyNTAwNTUwNFowRTESMBAGA1UEAwwJMTI3LjAuMC4xMQswCQYDVQQGEwJDQTEP +MA0GA1UECAwGUXVlYmVjMREwDwYDVQQHDAhNb250cmVhbDCCASIwDQYJKoZIhvcN +AQEBBQADggEPADCCAQoCggEBAORALZlg9Qmu+A2HT4MUjF1iGUdWF6tlRgF6+zLZ +uvuSM+eR0yH+EJZB2xqanzkXHVAkAnHPWRZ2HWqTS7TLOMyRdPEkiCg+WmW2f0t0 +hNCjZVMviahQgOwHkbTZbfsUHTv65cEk4XCgvQXFteMC+Q3lCeXWGoeMOt7AZ3ld +vf7jgmPTQXOQFhqa9q5Qcxn+b1+2NBgQXqEQTVARBLPbCB4M0SKLZ4fWK4VHZsbe +k8fUJBGgz/gTDNNClUiVBhBiv/9uvunZRpU1QBN5tZYXAPc0hX608L33R+LFsoDM +cO5+j+XIjvxWNk94cmM/cb4PLlZBeNBlXxWxY1lKAxjja58CAwEAAaOBhjCBgzAd +BgNVHQ4EFgQUGj/6Vt/0fjbTGBHPZNRIxJywRnkwHwYDVR0jBBgwFoAUGj/6Vt/0 +fjbTGBHPZNRIxJywRnkwDgYDVR0PAQH/BAQDAgWgMCAGA1UdJQEB/wQWMBQGCCsG +AQUFBwMBBggrBgEFBQcDAjAPBgNVHRMBAf8EBTADAQH/MA0GCSqGSIb3DQEBCwUA +A4IBAQA+AuoFBODpWaWrVSjdGZPHP4DtlhB9jDy0WmUBJ8BxeB8SooJoyTsBXVhq +7ACKp11rxJPk9Tv9JOsRrWi+YLzgs+QsKpUKb6RK5nszz17K1md8BavGzE4n/e0F +tzYvWAeyIazHW551GMB1MkpSVcsJNqe91z35qmykmwIo8h+BgqTFzUFiln6bLnqP +KxrWKdlVh2BGEVbH5APClQii0bX1qEn0A8CkAMbldC1GNFbfhyxk1v+8CVK1M6Nx +BrTe15/CVTw/ceCfFZra4DinsflyCP+CcitGOUhWKgrUSiyN8xtr+Wopq4+ntm/Z +ku6j3frrSJnT9A+nZyyGvZlSPrxf +-----END CERTIFICATE-----
+ tests/credentials/cert.key view
@@ -0,0 +1,28 @@+-----BEGIN PRIVATE KEY----- +MIIEvQIBADANBgkqhkiG9w0BAQEFAASCBKcwggSjAgEAAoIBAQDkQC2ZYPUJrvgN +h0+DFIxdYhlHVherZUYBevsy2br7kjPnkdMh/hCWQdsamp85Fx1QJAJxz1kWdh1q +k0u0yzjMkXTxJIgoPlpltn9LdITQo2VTL4moUIDsB5G02W37FB07+uXBJOFwoL0F +xbXjAvkN5Qnl1hqHjDrewGd5Xb3+44Jj00FzkBYamvauUHMZ/m9ftjQYEF6hEE1Q +EQSz2wgeDNEii2eH1iuFR2bG3pPH1CQRoM/4EwzTQpVIlQYQYr//br7p2UaVNUAT +ebWWFwD3NIV+tPC990fixbKAzHDufo/lyI78VjZPeHJjP3G+Dy5WQXjQZV8VsWNZ +SgMY42ufAgMBAAECggEAGfwodM6x9tFBkiC2b6DWPgdeA14Mwcl8x8xdbrOU8vD5 +EcLrO3J2JvUGYaf6uoAkKSyATr6hUMpPnQN52fJM3BUvMAjNq2810WCOa2OvfyUq +8uZ1kIDhvH08HE+okq3+igaNQ4jUVYMnIdIZW+fJvMg3cUAHsyjGxvc2kH2YlLzQ +3zxEFacnTb2K/Sxa/rFC7O3r2M6casTVsqfLyeShnSLEwLLk8tzCZZc6Sap9rVgh +CIcUhZFGxLYWMBJwRs68rmgT7rvQvh8NxzDMGM9Z/AQzeeHAvjAkb4gZBu+W69vD +CYjMi3cchdG/2ouYqijdv9DcqRDfz6BDwf8fT96dyQKBgQD0rGreqY7E8Wnt3EjF +TYwi6Hj7r6gMw3kdIIJ49st2lTvOmeZpvJX7DOh43NNidx9q2Ai1XCCEDQlpPS7i +UnqOLwX0gGYZjYkI8QSdNbJ9T4wepfSeox7dte/xnglEkfipHV3tLqhurgw+wvGW +52hBB6DVSumzjcG/hrvkDth31QKBgQDu0SMH5mg4L4KaT9+qZm3IW+Xey3vwPFES +w4bGsmAddzxXRIw6+ut2+AX/WSccUnZmgtiKKzS1yrBXGa98dqzjGRcDnbchkm+6 +Ka1s3ZSx7cjgya43jLIZ9ycwva8+OPPfzrOB6zLgIauwi5B7JsB1Qt81AXeo5/jb +S64FRXkjowKBgChebj+QoEK0RjL9nnAXTGDSFGwKXmLEua3pmD1XEtjc5IJA+DhH +6kMCrTSL0sCzQNbDECTEL4U6FWxssNicnSXqckQWD0J2DL8R7R33JxzvzAGehg7K +gSQ5iX5HAeZzYyCb/MxOX3Hre4+7YFrykUvxc0Ld2lNKt0XfeA63uFWFAoGAOMfk +ylYP5Xv2U3Y2Oa+M3pxq9SPwXdgZdpqiis+SZq8Y267ioItUPL8PvfyWffdlS05E +6eUH7Uk50Bu9S5xz0rL+c8+l4QeOJPcP0tiEKCHfJwMMtwxutBm9aatP5T1pToc4 +yuT+/adDyQAF5CH8lGTH6TRmHPS6iHlf8MTp3n0CgYEAwUWjiimBoPQV3X2mHYp5 +yXBKGrsEItOmZUKYpl9UGVdGHHuZqzKi5ckOUK+vfd2uH9toUBMFK5aBM3VmFWPb +3IpTrYe/Zu545dZszESjpl9JeiiSOVvPllCh0BrOAK1TwRapWUTsS8ut5pt5zLuo +VbKNvUzMHtq6vp511AD0zCY= +-----END PRIVATE KEY-----
tests/runInMemory.hs view
@@ -6,9 +6,8 @@ import Network.Transport.Test (TestTransport(..)) import Network.Transport.InMemory-import Test.Framework (defaultMainWithArgs)--import System.Environment (getArgs)+import Test.Tasty (defaultMain, localOption)+import Test.Tasty.Runners (NumThreads) main :: IO () main = do@@ -17,14 +16,12 @@ { testTransport = transport , testBreakConnection = \addr1 addr2 -> breakConnection internals addr1 addr2 "user error" }- args <- getArgs -- Tests are time sensitive. Running the tests concurrently can slow them -- down enough that threads using threadDelay would wake up later than -- expected, thus changing the order in which messages were expected.- -- Therefore we run the tests sequentially by passing "-j 1" to- -- test-framework. This does not solve the issue but makes it less likely.+ -- Therefore we run the tests sequentially -- -- The problem was first detected with -- 'Control.Distributed.Process.Tests.CH.testMergeChannels' -- in particular.- defaultMainWithArgs ts ("-j" : "1" : args)+ defaultMain (localOption (1::NumThreads) ts)
+ tests/runQUIC.hs view
@@ -0,0 +1,75 @@+{-# LANGUAGE LambdaCase #-}++-- Run tests using the QUIC transport.+--+module Main where++import Control.Distributed.Process.Tests.CH (tests)+import Control.Exception (bracket, throwIO)+import Data.List.NonEmpty (NonEmpty (..))+import Network.Transport (Transport, closeTransport)+import Network.Transport.QUIC+ ( QUICTransportConfig (..),+ createTransport,+ credentialLoadX509,+ )+import Network.Transport.Test (TestTransport (..))+import System.FilePath ((</>))+import System.IO+ ( BufferMode (LineBuffering),+ hSetBuffering,+ stderr,+ stdout,+ )+import Test.Tasty (defaultMain, localOption)+import Test.Tasty.Runners (NumThreads)++main :: IO ()+main = do+ hSetBuffering stdout LineBuffering+ hSetBuffering stderr LineBuffering+ withQUICTransport $ \transport -> do+ ts <-+ tests+ TestTransport+ { testTransport = transport,+ testBreakConnection = \_ _ -> pure () -- I'm not sure how to break the connection at this time+ }++ -- Tests are time sensitive. Running the tests concurrently can slow them+ -- down enough that threads using threadDelay would wake up later than+ -- expected, thus changing the order in which messages were expected.+ -- Therefore we run the tests sequentially+ --+ -- The problem was first detected with+ -- 'Control.Distributed.Process.Tests.CH.testMergeChannels'+ -- in particular.+ defaultMain (localOption (1 :: NumThreads) ts)++withQUICTransport :: (Transport -> IO a) -> IO a+withQUICTransport =+ bracket+ (mkQUICTransport >>= either (throwIO . userError) pure)+ closeTransport++mkQUICTransport :: IO (Either String Transport)+mkQUICTransport = do+ credentialLoadX509+ -- Generate a self-signed x509v3 certificate using this nifty tool:+ -- https://certificatetools.com/+ ("tests" </> "credentials" </> "cert.crt")+ ("tests" </> "credentials" </> "cert.key")+ >>= \case+ Left errmsg -> pure $ Left errmsg+ Right creds ->+ Right+ <$> createTransport+ ( QUICTransportConfig+ { hostName = "127.0.0.1",+ serviceName = "0",+ credentials = creds :| [],+ -- credentials are self-signed, and therefore cannot be validated+ validateCredentials = False,+ socketOptions = []+ }+ )
tests/runTCP.hs view
@@ -13,11 +13,11 @@ , defaultTCPAddr , TCPParameters(..) )-import Test.Framework (defaultMainWithArgs)+import Test.Tasty (defaultMain, localOption)+import Test.Tasty.Runners (NumThreads) import Control.Concurrent (threadDelay) import Control.Exception (IOException, try)-import System.Environment (getArgs) import System.IO main :: IO ()@@ -34,14 +34,12 @@ either (\e -> const (return ()) (e :: IOException)) close esock threadDelay 10000 }- args <- getArgs -- Tests are time sensitive. Running the tests concurrently can slow them -- down enough that threads using threadDelay would wake up later than -- expected, thus changing the order in which messages were expected.- -- Therefore we run the tests sequentially by passing "-j 1" to- -- test-framework. This does not solve the issue but makes it less likely.+ -- Therefore we run the tests sequentially -- -- The problem was first detected with -- 'Control.Distributed.Process.Tests.CH.testMergeChannels' -- in particular.- defaultMainWithArgs ts ("-j" : "1" : args)+ defaultMain (localOption (1::NumThreads) ts)