Skip to content

Commit 66391e3

Browse files
LaurentRDCLaurentRDC
committed
Cloud Haskell tests for QUIC
1 parent 6808dd4 commit 66391e3

File tree

8 files changed

+263
-113
lines changed

8 files changed

+263
-113
lines changed

‎.github/workflows/cabal.yml‎

Lines changed: 8 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -48,14 +48,14 @@ jobs:
4848
id: setup-haskell
4949
with:
5050
ghc-version: ${{ matrix.ghc-version }}
51-
cabal-version: '3.12.1.0'
52-
51+
cabal-version: '3.16.0.0'
52+
5353
- name: Generate freeze file
5454
run: |
5555
cabal configure --enable-tests --test-show-details=direct
5656
cabal freeze ${{matrix.cabal-flags}} --minimize-conflict-set
5757
cat cabal.project.freeze
58-
58+
5959
- name: Cache cabal work
6060
uses: actions/cache@v4
6161
with:
@@ -68,12 +68,14 @@ jobs:
6868

6969
- name: Build dependencies only
7070
run: cabal build all --only-dependencies ${{matrix.cabal-flags}}
71-
71+
7272
- name: Build all packages
7373
run: cabal build all ${{matrix.cabal-flags}}
74-
74+
7575
- name: Run all tests
7676
# We have seen in the past some tests hang for hours, wasting resources.
7777
# The timeout below should be plenty
7878
timeout-minutes: 10
79-
run: cabal test all ${{matrix.cabal-flags}}
79+
# We run each test suite one-by-one to better observe problems.
80+
run: cabal test all -j1 ${{matrix.cabal-flags}}
81+

‎cabal.project‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,4 +1,4 @@
11
packages: packages/*/**.cabal
22

33
package distributed-process-tests
4-
flags: +tcp
4+
flags: +tcp +quic

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

Lines changed: 21 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -12,6 +12,7 @@ copyright: Well-Typed LLP
1212
category: Control, Cloud Haskell
1313
build-type: Simple
1414
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
15+
extra-source-files: tests/credentials/*
1516

1617
source-repository head
1718
Type: git
@@ -22,6 +23,10 @@ flag tcp
2223
Description: build and run TCP tests
2324
Default: False
2425

26+
flag quic
27+
Description: build and run QUIC tests
28+
Default: False
29+
2530
common warnings
2631
ghc-options: -Wall
2732
-Wcompat
@@ -100,6 +105,22 @@ Test-Suite TestCHInTCP
100105
ghc-options: -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind
101106
HS-Source-Dirs: tests
102107

108+
Test-Suite TestCHInQUIC
109+
import: warnings
110+
Type: exitcode-stdio-1.0
111+
Main-Is: runQUIC.hs
112+
if flag(quic)
113+
Build-Depends: base >= 4.14 && < 5,
114+
distributed-process-tests,
115+
filepath,
116+
network-transport,
117+
network-transport-quic,
118+
tasty >= 1.5 && <1.6,
119+
else
120+
Buildable: False
121+
default-language: Haskell2010
122+
ghc-options: -threaded -rtsopts -with-rtsopts=-N
123+
HS-Source-Dirs: tests
103124

104125
Test-Suite TestClosure
105126
import: warnings

‎packages/distributed-process-tests/src/Control/Distributed/Process/Tests/CH.hs‎

Lines changed: 19 additions & 13 deletions
Original file line numberDiff line numberDiff line change
@@ -1,3 +1,4 @@
1+
{-# LANGUAGE NumericUnderscores #-}
12
module Control.Distributed.Process.Tests.CH (tests) where
23

34

@@ -43,7 +44,7 @@ import Control.Distributed.Process.Tests.Internal.Utils (pause)
4344
import Control.Distributed.Process.Serializable (Serializable)
4445
import Data.Maybe (isNothing, isJust)
4546
import Test.Tasty (TestTree, testGroup)
46-
import Test.Tasty.HUnit (Assertion, assertBool, assertEqual, testCase)
47+
import Test.Tasty.HUnit (Assertion, assertBool, assertEqual, testCase, assertFailure)
4748

4849
newtype Ping = Ping ProcessId
4950
deriving (Typeable, Binary, Show)
@@ -175,14 +176,14 @@ monitorTestProcess theirAddr mOrL un reason monitorSetup done =
175176
unmonitor ref
176177
liftIO $ putMVar done ()
177178
(False, ref) -> do
178-
receiveWait [
179+
receiveTimeout 1_000_000 [
179180
match (\(ProcessMonitorNotification ref' pid reason') -> do
180181
liftIO $ do
181182
assertBool "Bad Monitor Signal"
182183
(Just ref' == ref && pid == theirAddr &&
183184
mOrL && reason == reason')
184185
putMVar done ())
185-
]
186+
] >>= maybe (liftIO $ assertFailure "No ProcessMonitorNotification received within timeout window") pure
186187
)
187188
(\(ProcessLinkException pid reason') -> do
188189
(liftIO $ assertBool "link exception unmatched" $
@@ -220,11 +221,11 @@ testPing TestTransport{..} = do
220221
p <- expectTimeout 3000000
221222
case p of
222223
Just (Ping _) -> return ()
223-
Nothing -> die "Failed to receive Ping"
224+
Nothing -> let msg = "Failed to receive Ping" in liftIO (putMVar clientDone (Left msg)) >> die msg
224225

225-
putMVar clientDone ()
226+
putMVar clientDone (Right ())
226227

227-
takeMVar clientDone
228+
takeMVar clientDone >>= either assertFailure pure
228229

229230
-- | Monitor a process on an unreachable node
230231
testMonitorUnreachable :: TestTransport -> Bool -> Bool -> Assertion
@@ -348,6 +349,7 @@ testMonitorDisconnect TestTransport{..} mOrL un = do
348349
putMVar processAddr addr
349350
readMVar monitorSetup
350351
NT.closeEndPoint (localEndPoint localNode)
352+
threadDelay 100_000
351353
putMVar processAddr2 addr2
352354

353355
forkIO $ do
@@ -430,7 +432,7 @@ testTimeout TestTransport{..} = do
430432
done <- newEmptyMVar
431433

432434
runProcess localNode $ do
433-
res <- receiveTimeout 1000000 [match (\Add{} -> return ())]
435+
res <- receiveTimeout 1_000_000 [match (\Add{} -> return ())]
434436
liftIO $ putMVar done $ res == Nothing
435437

436438
verifyClient "Expected receiveTimeout to timeout..." done
@@ -447,7 +449,7 @@ testTimeout0 TestTransport{..} = do
447449
-- Variation on the venerable ping server which uses a zero timeout
448450
partner <- fix $ \loop ->
449451
receiveTimeout 0 [match (\(Pong partner) -> return partner)]
450-
>>= maybe (liftIO (threadDelay 100000) >> loop) return
452+
>>= maybe (liftIO (threadDelay 100_000) >> loop) return
451453
self <- getSelfPid
452454
send partner (Ping self)
453455
putMVar serverAddr addr
@@ -459,7 +461,7 @@ testTimeout0 TestTransport{..} = do
459461
pid <- getSelfPid
460462
-- Send a bunch of messages. A large number of messages that the server
461463
-- is not interested in, and then a single message that it wants
462-
replicateM_ 10000 $ send server "Irrelevant message"
464+
replicateM_ 10_000 $ send server "Irrelevant message"
463465
send server (Pong pid)
464466
expectPing clientDone
465467

@@ -582,7 +584,7 @@ testMergeChannels TestTransport{..} = do
582584
charChannel c = do
583585
(sport, rport) <- newChan
584586
replicateM_ 3 $ sendChan sport c
585-
liftIO $ threadDelay 10000 -- Make sure messages have been sent
587+
liftIO $ threadDelay 10_000 -- Make sure messages have been sent
586588
return rport
587589

588590
testTerminate :: TestTransport -> Assertion
@@ -621,6 +623,7 @@ testMonitorLiveNode TestTransport{..} = do
621623
forkProcess node2 $ do
622624
ref <- monitorNode (localNodeId node1)
623625
liftIO $ putMVar ready ()
626+
-- node1 gets closed
624627
liftIO $ takeMVar readyr
625628
send p ()
626629
receiveWait [
@@ -630,6 +633,7 @@ testMonitorLiveNode TestTransport{..} = do
630633

631634
takeMVar ready
632635
closeLocalNode node1
636+
threadDelay 1_000_000
633637
putMVar readyr ()
634638

635639
verifyClient "Expected NodeMonitorNotification for LIVE node" done
@@ -642,18 +646,20 @@ testMonitorChannel TestTransport{..} = do
642646
pid <- forkProcess node1 $ do
643647
sport <- expect :: Process (SendPort ())
644648
ref <- monitorPort sport
645-
receiveWait [
649+
receiveTimeout 1_000_000 [
646650
-- reason might be DiedUnknownId if the receive port is GCed before the
647651
-- monitor is established (TODO: not sure that this is reasonable)
648652
match (\(PortMonitorNotification ref' port' reason) ->
649653
return $ ref' == ref && port' == sendPortId sport &&
650654
(reason == DiedNormal || reason == DiedUnknownId))
651-
] >>= liftIO . putMVar gotNotification
655+
] >>= maybe
656+
(liftIO $ assertFailure "Did not receive PortMonitorNotification message within timeout window")
657+
(liftIO . putMVar gotNotification)
652658

653659
runProcess node2 $ do
654660
(sport, _) <- newChan :: Process (SendPort (), ReceivePort ())
655661
send pid sport
656-
liftIO $ threadDelay 100000
662+
liftIO $ threadDelay 1_000_000
657663

658664
verifyClient "Expected PortMonitorNotification" gotNotification
659665

‎packages/distributed-process-tests/tests/credentials/cert.crt‎

Lines changed: 22 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,22 @@
1+
-----BEGIN CERTIFICATE-----
2+
MIIDoTCCAomgAwIBAgIUVp3lTRQWZSOwolWHNaghO6gR68owDQYJKoZIhvcNAQEL
3+
BQAwRTESMBAGA1UEAwwJMTI3LjAuMC4xMQswCQYDVQQGEwJDQTEPMA0GA1UECAwG
4+
UXVlYmVjMREwDwYDVQQHDAhNb250cmVhbDAgFw0yNTA4MTgwMDU1MDRaGA8yMTI1
5+
MDcyNTAwNTUwNFowRTESMBAGA1UEAwwJMTI3LjAuMC4xMQswCQYDVQQGEwJDQTEP
6+
MA0GA1UECAwGUXVlYmVjMREwDwYDVQQHDAhNb250cmVhbDCCASIwDQYJKoZIhvcN
7+
AQEBBQADggEPADCCAQoCggEBAORALZlg9Qmu+A2HT4MUjF1iGUdWF6tlRgF6+zLZ
8+
uvuSM+eR0yH+EJZB2xqanzkXHVAkAnHPWRZ2HWqTS7TLOMyRdPEkiCg+WmW2f0t0
9+
hNCjZVMviahQgOwHkbTZbfsUHTv65cEk4XCgvQXFteMC+Q3lCeXWGoeMOt7AZ3ld
10+
vf7jgmPTQXOQFhqa9q5Qcxn+b1+2NBgQXqEQTVARBLPbCB4M0SKLZ4fWK4VHZsbe
11+
k8fUJBGgz/gTDNNClUiVBhBiv/9uvunZRpU1QBN5tZYXAPc0hX608L33R+LFsoDM
12+
cO5+j+XIjvxWNk94cmM/cb4PLlZBeNBlXxWxY1lKAxjja58CAwEAAaOBhjCBgzAd
13+
BgNVHQ4EFgQUGj/6Vt/0fjbTGBHPZNRIxJywRnkwHwYDVR0jBBgwFoAUGj/6Vt/0
14+
fjbTGBHPZNRIxJywRnkwDgYDVR0PAQH/BAQDAgWgMCAGA1UdJQEB/wQWMBQGCCsG
15+
AQUFBwMBBggrBgEFBQcDAjAPBgNVHRMBAf8EBTADAQH/MA0GCSqGSIb3DQEBCwUA
16+
A4IBAQA+AuoFBODpWaWrVSjdGZPHP4DtlhB9jDy0WmUBJ8BxeB8SooJoyTsBXVhq
17+
7ACKp11rxJPk9Tv9JOsRrWi+YLzgs+QsKpUKb6RK5nszz17K1md8BavGzE4n/e0F
18+
tzYvWAeyIazHW551GMB1MkpSVcsJNqe91z35qmykmwIo8h+BgqTFzUFiln6bLnqP
19+
KxrWKdlVh2BGEVbH5APClQii0bX1qEn0A8CkAMbldC1GNFbfhyxk1v+8CVK1M6Nx
20+
BrTe15/CVTw/ceCfFZra4DinsflyCP+CcitGOUhWKgrUSiyN8xtr+Wopq4+ntm/Z
21+
ku6j3frrSJnT9A+nZyyGvZlSPrxf
22+
-----END CERTIFICATE-----

‎packages/distributed-process-tests/tests/credentials/cert.key‎

Lines changed: 28 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,28 @@
1+
-----BEGIN PRIVATE KEY-----
2+
MIIEvQIBADANBgkqhkiG9w0BAQEFAASCBKcwggSjAgEAAoIBAQDkQC2ZYPUJrvgN
3+
h0+DFIxdYhlHVherZUYBevsy2br7kjPnkdMh/hCWQdsamp85Fx1QJAJxz1kWdh1q
4+
k0u0yzjMkXTxJIgoPlpltn9LdITQo2VTL4moUIDsB5G02W37FB07+uXBJOFwoL0F
5+
xbXjAvkN5Qnl1hqHjDrewGd5Xb3+44Jj00FzkBYamvauUHMZ/m9ftjQYEF6hEE1Q
6+
EQSz2wgeDNEii2eH1iuFR2bG3pPH1CQRoM/4EwzTQpVIlQYQYr//br7p2UaVNUAT
7+
ebWWFwD3NIV+tPC990fixbKAzHDufo/lyI78VjZPeHJjP3G+Dy5WQXjQZV8VsWNZ
8+
SgMY42ufAgMBAAECggEAGfwodM6x9tFBkiC2b6DWPgdeA14Mwcl8x8xdbrOU8vD5
9+
EcLrO3J2JvUGYaf6uoAkKSyATr6hUMpPnQN52fJM3BUvMAjNq2810WCOa2OvfyUq
10+
8uZ1kIDhvH08HE+okq3+igaNQ4jUVYMnIdIZW+fJvMg3cUAHsyjGxvc2kH2YlLzQ
11+
3zxEFacnTb2K/Sxa/rFC7O3r2M6casTVsqfLyeShnSLEwLLk8tzCZZc6Sap9rVgh
12+
CIcUhZFGxLYWMBJwRs68rmgT7rvQvh8NxzDMGM9Z/AQzeeHAvjAkb4gZBu+W69vD
13+
CYjMi3cchdG/2ouYqijdv9DcqRDfz6BDwf8fT96dyQKBgQD0rGreqY7E8Wnt3EjF
14+
TYwi6Hj7r6gMw3kdIIJ49st2lTvOmeZpvJX7DOh43NNidx9q2Ai1XCCEDQlpPS7i
15+
UnqOLwX0gGYZjYkI8QSdNbJ9T4wepfSeox7dte/xnglEkfipHV3tLqhurgw+wvGW
16+
52hBB6DVSumzjcG/hrvkDth31QKBgQDu0SMH5mg4L4KaT9+qZm3IW+Xey3vwPFES
17+
w4bGsmAddzxXRIw6+ut2+AX/WSccUnZmgtiKKzS1yrBXGa98dqzjGRcDnbchkm+6
18+
Ka1s3ZSx7cjgya43jLIZ9ycwva8+OPPfzrOB6zLgIauwi5B7JsB1Qt81AXeo5/jb
19+
S64FRXkjowKBgChebj+QoEK0RjL9nnAXTGDSFGwKXmLEua3pmD1XEtjc5IJA+DhH
20+
6kMCrTSL0sCzQNbDECTEL4U6FWxssNicnSXqckQWD0J2DL8R7R33JxzvzAGehg7K
21+
gSQ5iX5HAeZzYyCb/MxOX3Hre4+7YFrykUvxc0Ld2lNKt0XfeA63uFWFAoGAOMfk
22+
ylYP5Xv2U3Y2Oa+M3pxq9SPwXdgZdpqiis+SZq8Y267ioItUPL8PvfyWffdlS05E
23+
6eUH7Uk50Bu9S5xz0rL+c8+l4QeOJPcP0tiEKCHfJwMMtwxutBm9aatP5T1pToc4
24+
yuT+/adDyQAF5CH8lGTH6TRmHPS6iHlf8MTp3n0CgYEAwUWjiimBoPQV3X2mHYp5
25+
yXBKGrsEItOmZUKYpl9UGVdGHHuZqzKi5ckOUK+vfd2uH9toUBMFK5aBM3VmFWPb
26+
3IpTrYe/Zu545dZszESjpl9JeiiSOVvPllCh0BrOAK1TwRapWUTsS8ut5pt5zLuo
27+
VbKNvUzMHtq6vp511AD0zCY=
28+
-----END PRIVATE KEY-----

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

Lines changed: 72 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,72 @@
1+
{-# LANGUAGE LambdaCase #-}
2+
3+
-- Run tests using the QUIC transport.
4+
--
5+
module Main where
6+
7+
import Control.Distributed.Process.Tests.CH (tests)
8+
import Control.Exception (bracket, throwIO)
9+
import Data.List.NonEmpty (NonEmpty (..))
10+
import Network.Transport (Transport, closeTransport)
11+
import Network.Transport.QUIC
12+
( QUICTransportConfig (..),
13+
createTransport,
14+
credentialLoadX509,
15+
)
16+
import Network.Transport.Test (TestTransport (..))
17+
import System.FilePath ((</>))
18+
import System.IO
19+
( BufferMode (LineBuffering),
20+
hSetBuffering,
21+
stderr,
22+
stdout,
23+
)
24+
import Test.Tasty (defaultMain, localOption)
25+
import Test.Tasty.Runners (NumThreads)
26+
27+
main :: IO ()
28+
main = do
29+
hSetBuffering stdout LineBuffering
30+
hSetBuffering stderr LineBuffering
31+
withQUICTransport $ \transport -> do
32+
tests
33+
TestTransport
34+
{ testTransport = transport,
35+
testBreakConnection = \_ _ -> pure () -- I'm not sure how to break the connection at this time
36+
}
37+
-- Tests are time sensitive. Running the tests concurrently can slow them
38+
-- down enough that threads using threadDelay would wake up later than
39+
-- expected, thus changing the order in which messages were expected.
40+
-- Therefore we run the tests sequentially
41+
--
42+
-- The problem was first detected with
43+
-- 'Control.Distributed.Process.Tests.CH.testMergeChannels'
44+
-- in particular.
45+
>>= defaultMain . localOption (1 :: NumThreads)
46+
47+
withQUICTransport :: (Transport -> IO a) -> IO a
48+
withQUICTransport =
49+
bracket
50+
(mkQUICTransport >>= either (throwIO . userError) pure)
51+
closeTransport
52+
53+
mkQUICTransport :: IO (Either String Transport)
54+
mkQUICTransport = do
55+
credentialLoadX509
56+
-- Generate a self-signed x509v3 certificate using this nifty tool:
57+
-- https://certificatetools.com/
58+
("tests" </> "credentials" </> "cert.crt")
59+
("tests" </> "credentials" </> "cert.key")
60+
>>= \case
61+
Left errmsg -> pure $ Left errmsg
62+
Right creds ->
63+
Right
64+
<$> createTransport
65+
( QUICTransportConfig
66+
{ hostName = "127.0.0.1",
67+
serviceName = "0",
68+
credentials = creds :| [],
69+
-- credentials are self-signed
70+
validateCredentials = False
71+
}
72+
)

0 commit comments

Comments
 (0)