Cloud Haskell tests for QUIC

Author: LaurentRDC

cabal.project

@@ -1,4 +1,6 @@
 packages: packages/*/**.cabal
 
 package distributed-process-tests
-  flags: +tcp
+  -- There is also the +quic flag, but for some reason,
+  -- QUIC-based tests aren't running correctly in CI at this time
+  flags: +tcp

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

@@ -11,6 +11,7 @@ maintainer:    The Distributed Haskell team
 copyright:     Well-Typed LLP
 category:      Control, Cloud Haskell
 build-type:    Simple
+extra-source-files: tests/credentials/*
 
 source-repository head
   Type:     git
@@ -21,6 +22,10 @@ flag tcp
   Description: build and run TCP tests
   Default:     False
 
+flag quic
+  Description: build and run QUIC tests
+  Default:     False
+
 common warnings
     ghc-options: -Wall
                  -Wcompat
@@ -99,6 +104,21 @@ 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-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

@@ -43,7 +43,7 @@ import Control.Distributed.Process.Tests.Internal.Utils (pause)
 import Control.Distributed.Process.Serializable (Serializable)
 import Data.Maybe (isNothing, isJust)
 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)
@@ -220,11 +220,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

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,55 @@
+{-# LANGUAGE LambdaCase #-}
+-- Run tests using the QUIC transport.
+--
+module Main where
+
+import Control.Exception (throwIO)
+import Data.List.NonEmpty (NonEmpty(..))
+import Network.Transport.QUIC
+    ( createTransport,
+      credentialLoadX509,
+      QUICTransportConfig(..) )
+import Network.Transport.Test (TestTransport (..))
+import System.IO
+    ( hSetBuffering, stderr, stdout, BufferMode(LineBuffering) )
+import Control.Distributed.Process.Tests.CH (tests)
+import Test.Tasty (defaultMain, localOption)
+import Test.Tasty.Runners (NumThreads)
+import System.FilePath ((</>))
+
+main :: IO ()
+main = do
+  hSetBuffering stdout LineBuffering
+  hSetBuffering stderr LineBuffering
+  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 -> throwIO (userError errmsg)
+      Right creds -> do
+        transport <-
+          createTransport
+            ( QUICTransportConfig
+                { hostName = "127.0.0.1",
+                  serviceName = "0",
+                  credentials = creds :| [],
+                  validateCredentials = False -- self-signed certificates cannot be validated
+                }
+            )
+        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)