diff --git a/distributed-process-tests.cabal b/distributed-process-tests.cabal --- a/distributed-process-tests.cabal +++ b/distributed-process-tests.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: distributed-process-tests -version: 0.5.2 +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 @@ -99,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 @@ -168,4 +192,19 @@ 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 diff --git a/src/Control/Distributed/Process/Tests/CH.hs b/src/Control/Distributed/Process/Tests/CH.hs --- a/src/Control/Distributed/Process/Tests/CH.hs +++ b/src/Control/Distributed/Process/Tests/CH.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NumericUnderscores #-} module Control.Distributed.Process.Tests.CH (tests) where @@ -42,8 +43,9 @@ import Control.Distributed.Process.Tests.Internal.Utils (pause) import Control.Distributed.Process.Serializable (Serializable) import Data.Maybe (isNothing, isJust) +import System.Timeout (timeout) import Test.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit (Assertion, assertBool, assertEqual, testCase) +import Test.Tasty.HUnit (Assertion, assertBool, assertEqual, testCase, assertFailure) newtype Ping = Ping ProcessId deriving (Typeable, Binary, Show) @@ -70,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 @@ -175,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" $ @@ -220,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 @@ -348,6 +355,7 @@ putMVar processAddr addr readMVar monitorSetup NT.closeEndPoint (localEndPoint localNode) + threadDelay 100_000 putMVar processAddr2 addr2 forkIO $ do @@ -430,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 @@ -447,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 @@ -459,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 @@ -582,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 @@ -621,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 @@ -638,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 diff --git a/src/Control/Distributed/Process/Tests/Mx.hs b/src/Control/Distributed/Process/Tests/Mx.hs --- a/src/Control/Distributed/Process/Tests/Mx.hs +++ b/src/Control/Distributed/Process/Tests/Mx.hs @@ -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,16 +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.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (assertBool, assertEqual, testCase) data Publish = Publish - deriving (Typeable, Generic, Eq) + deriving (Generic, Eq) instance Binary Publish where @@ -147,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 @@ -262,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 @@ -301,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 diff --git a/tests/TestDeathKeys.hs b/tests/TestDeathKeys.hs new file mode 100644 --- /dev/null +++ b/tests/TestDeathKeys.hs @@ -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 + ] diff --git a/tests/credentials/cert.crt b/tests/credentials/cert.crt new file mode 100644 --- /dev/null +++ b/tests/credentials/cert.crt @@ -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----- diff --git a/tests/credentials/cert.key b/tests/credentials/cert.key new file mode 100644 --- /dev/null +++ b/tests/credentials/cert.key @@ -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----- diff --git a/tests/runQUIC.hs b/tests/runQUIC.hs new file mode 100644 --- /dev/null +++ b/tests/runQUIC.hs @@ -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 = [] + } + )