Cloud Haskell tests for QUIC

Author: LaurentRDC

.github/workflows/cabal.yml

@@ -49,13 +49,15 @@ jobs:
       with:
         ghc-version: ${{ matrix.ghc-version }}
         cabal-version: '3.12.1.0'
-    
+
     - name: Generate freeze file
       run: |
-        cabal configure --enable-tests --test-show-details=direct
+        # Cloud Haskell tests using the QUIC backend are quite flaky, but in CI only.
+        # Therefore, the 'quic' flag is normally enabled locally, but disabled in CI. 
+        cabal configure --enable-tests --test-show-details=direct --flags "-quic"
         cabal freeze ${{matrix.cabal-flags}} --minimize-conflict-set
         cat cabal.project.freeze
-    
+
     - name: Cache cabal work
       uses: actions/cache@v4
       with:
@@ -68,12 +70,14 @@ jobs:
 
     - name: Build dependencies only
       run: cabal build all --only-dependencies ${{matrix.cabal-flags}}
-    
+
     - name: Build all packages
       run: cabal build all ${{matrix.cabal-flags}}
-        
+
     - name: Run all tests
       # We have seen in the past some tests hang for hours, wasting resources.
       # The timeout below should be plenty
       timeout-minutes: 10
-      run: cabal test all ${{matrix.cabal-flags}}
+      # We run each test suite one-by-one to better observe problems.
+      run: cabal test all -j1 ${{matrix.cabal-flags}}
+

cabal.project

@@ -1,4 +1,4 @@
 packages: packages/*/**.cabal
 
 package distributed-process-tests
-  flags: +tcp
+  flags: +tcp

packages/distributed-process-tests/distributed-process-tests.cabal

@@ -12,6 +12,7 @@ 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
+extra-source-files: tests/credentials/*
 
 source-repository head
   Type:     git
@@ -22,6 +23,10 @@ flag tcp
   Description: build and run TCP tests
   Default:     False
 
+flag quic
+  Description: build and run QUIC tests
+  Default:     True
+
 common warnings
     ghc-options: -Wall
                  -Wcompat
@@ -100,6 +105,22 @@ Test-Suite TestCHInTCP
   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

packages/distributed-process-tests/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.Node
 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 = do
   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 @@ monitorTestProcess theirAddr mOrL un reason monitorSetup done =
                 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 @@ testPing TestTransport{..} = do
         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 @@ testMonitorDisconnect TestTransport{..} mOrL un = do
     putMVar processAddr addr
     readMVar monitorSetup
     NT.closeEndPoint (localEndPoint localNode)
+    threadDelay 100_000
     putMVar processAddr2 addr2
 
   forkIO $ do
@@ -430,7 +438,7 @@ testTimeout TestTransport{..} = do
   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 @@ testTimeout0 TestTransport{..} = do
       -- 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 @@ testTimeout0 TestTransport{..} = do
       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 @@ testMergeChannels TestTransport{..} = do
     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 @@ testMonitorLiveNode TestTransport{..} = do
   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 -> Assertion
 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
 

packages/distributed-process-tests/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-----

packages/distributed-process-tests/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-----

packages/distributed-process-tests/tests/runQUIC.hs

@@ -0,0 +1,75 @@
+{-# LANGUAGE CPP #-}
+{-# 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
+                }
+            )