upstream: github.com/mirleft/ocaml-tls
feat(ocaml-tls): make fuzz tests fully random
[main]: add Transmit `Drain to the op generator so drain mode is part
of the random action space rather than a hardcoded setup step. The TLS
state when each op executes is now determined entirely by the random
prefix of actions — the handshake may or may not be complete when any
given op runs. Remove quickstart since Path.close always enables drain
at the end, guaranteeing no deadlock even with no Transmit in the
action list.
[main_sm]: replace the hardcoded "drain both sockets from the start"
setup with two random pre-transmit sequences (one per direction). Each
sequence feeds random byte-chunk sizes through the socket before
enabling drain, so the point at which drain mode activates during the
handshake is part of the random input rather than always being t=0.
+47
-62
+47
-62
eio/tests/fuzz/fuzz_tls.ml
+47
-62
eio/tests/fuzz/fuzz_tls.ml
···
2
2
*
3
3
* Two test strategies:
4
4
*
5
-
* 1. [main] — controlled-transmit test. Picks random strings for each
6
-
* direction, interleaves explicit Send/Recv/Transmit/Shutdown/Key_update
7
-
* /Epoch actions, and verifies data integrity end-to-end. Good at catching
8
-
* bugs in the data path.
5
+
* 1. [main] — fully random interleaved actions on both sides. The action
6
+
* space includes [Transmit `Drain], so the fuzz engine can randomly decide
7
+
* when (or whether) to enable permanent drain mode on each direction. The
8
+
* TLS state when each op executes is determined entirely by the random
9
+
* prefix of actions — the handshake may or may not be complete, drain mode
10
+
* may or may not be active. [Path.close] at the end always enables drain,
11
+
* so the handshake always eventually completes and there is no deadlock
12
+
* even when the action list contains no Transmit.
9
13
*
10
-
* 2. [main_sm] — state machine test. Each side gets an independent random
11
-
* operation sequence and both sockets drain immediately. This exercises all
12
-
* TLS state transitions:
13
-
* Active → Write_closed (Sm_shutdown_send)
14
-
* Active → Read_closed (peer sends close_notify, visible via drain)
15
-
* Write_closed → Closed (peer close_notify arrives)
16
-
* Read_closed → Closed (Sm_shutdown_send)
17
-
* and all operations in all states (send, key_update, epoch).
14
+
* 2. [main_sm] — state machine test. Each side gets an independent random op
15
+
* sequence and both sockets drain immediately. The handshake and the first
16
+
* ops run in the SAME fiber (no yield between them), so Sm_shutdown_send
17
+
* can execute before the client's [drain_handshake] returns — placing
18
+
* [ServerFinished + NewSessionTicket + close_notify] in one batch for
19
+
* [handle_tls]. Without the [Read_closed] early-exit in [drain_handshake]
20
+
* this raises End_of_file.
18
21
*
19
-
* Crucially, the server completes its TLS 1.3 handshake one round-trip
20
-
* before the client (the client still needs to process the NewSessionTicket).
21
-
* With drain mode the server can execute Sm_shutdown_send — sending its
22
-
* close_notify — before the client's [drain_handshake] returns. The three
23
-
* records (ServerFinished + NewSessionTicket + close_notify) land in the
24
-
* client's buffer in one batch, so [handle_tls] processes them together:
25
-
* after the NewSessionTicket [handshake_in_progress] becomes false and after
26
-
* the close_notify the state becomes [Read_closed]. Without the
27
-
* [Read_closed] early-exit in [drain_handshake] this raises End_of_file. *)
22
+
* Two random pre-transmit sequences (one per direction) control how bytes
23
+
* flow through the handshake before drain mode kicks in, randomising
24
+
* *when* in the handshake drain becomes active rather than hard-coding it
25
+
* at the very start. *)
28
26
29
27
open Eio.Std
30
28
···
34
32
module W = Eio.Buf_write
35
33
36
34
type transmit_amount = Mock_socket.transmit_amount
37
-
38
-
(* ── controlled-transmit test (main) ──────────────────────────────────────── *)
39
35
40
36
type op =
41
37
| Send of int (* The application sends some bytes to Tls *)
···
52
48
@@ [
53
49
Crowbar.(map [ range 4096 ]) (fun n -> Send n);
54
50
Crowbar.(map [ range ~min:1 4096 ]) (fun n -> Transmit (`Bytes n));
51
+
label "drain" @@ Crowbar.const (Transmit `Drain);
55
52
label "recv" @@ Crowbar.const Recv;
56
53
label "shutdown-send" @@ Crowbar.const Shutdown_send;
57
54
Crowbar.(map [ bool ]) (fun req -> Key_update req);
···
260
257
in
261
258
aux actions
262
259
263
-
let quickstart_actions =
264
-
[
265
-
Some (To_server, Transmit (`Bytes 4096));
266
-
None;
267
-
None;
268
-
Some (To_client, Transmit (`Bytes 4096));
269
-
None;
270
-
None;
271
-
Some (To_server, Transmit (`Bytes 4096));
272
-
None;
273
-
None;
274
-
Some (To_client, Recv);
275
-
Some (To_server, Recv);
276
-
]
277
-
278
-
let main client_message server_message quickstart actions =
279
-
let actions = if quickstart then quickstart_actions @ actions else actions in
260
+
let main client_message server_message actions =
280
261
Eio_mock.Backend.run @@ fun () ->
281
262
Switch.run @@ fun sw ->
282
263
let insecure_test_rng = Crypto_rng.v (module Mock_rng) in
···
309
290
310
291
(* ── state machine test (main_sm) ─────────────────────────────────────────── *)
311
292
312
-
(* Per-side operations for the state machine test. No [Transmit] — drain
313
-
mode makes the network transparent. No [Recv] — reads block until the
314
-
peer sends data or closes; without explicit coordination between the two
315
-
sides that would deadlock. Instead each side drains after its ops. *)
293
+
(* Per-side operations. No [Transmit] — drain handles the network. No [Recv]
294
+
— reads block until the peer sends data or closes; without explicit
295
+
coordination that would deadlock. Instead each side drains after its ops. *)
316
296
type sm_op =
317
-
| Sm_send of int (* write n bytes in current state *)
318
-
| Sm_shutdown_send (* send close_notify → Write_closed / Closed *)
319
-
| Sm_key_update of bool (* TLS 1.3 key rotation *)
320
-
| Sm_epoch (* check epoch doesn't crash in any state *)
297
+
| Sm_send of int
298
+
| Sm_shutdown_send
299
+
| Sm_key_update of bool
300
+
| Sm_epoch
321
301
322
302
let sm_op =
323
303
Crowbar.choose
···
328
308
label "epoch" @@ Crowbar.const Sm_epoch;
329
309
]
330
310
331
-
(* Execute [ops] on [tls] then unconditionally drain (read until EOF) so the
332
-
other side's [Path.run] / [run_sm_ops] can also finish. *)
311
+
(* A list of explicit byte-chunk sizes to feed through the socket before
312
+
enabling permanent drain mode. This randomises when during the handshake
313
+
drain mode activates — from "before the first byte" (empty list) to
314
+
"after N chunks of various sizes". *)
315
+
let pre_transmit =
316
+
Crowbar.(list (map [ range ~min:1 4096 ] (fun n -> `Bytes n)))
317
+
333
318
let run_sm_ops tls message ops =
334
319
let sent = ref 0 in
335
320
let write_closed = ref false in
···
355
340
with Invalid_argument _ -> ())
356
341
| Sm_epoch -> ignore (Tls_eio.epoch tls))
357
342
ops;
358
-
(* Send close_notify if not already done so the peer's read drains. *)
359
343
(if not !write_closed then try Eio.Flow.shutdown tls `Send with _ -> ());
360
-
(* Drain: read until the peer sends its close_notify. *)
361
344
try ignore (Eio.Flow.read_all tls) with _ -> ()
362
345
363
-
let main_sm client_message server_message client_ops server_ops =
346
+
let main_sm client_message server_message client_pre server_pre client_ops
347
+
server_ops =
364
348
Eio_mock.Backend.run @@ fun () ->
365
349
Switch.run @@ fun _sw ->
366
350
let insecure_test_rng = Crypto_rng.v (module Mock_rng) in
367
351
Crypto_rng.set_default_generator insecure_test_rng;
368
352
let client_socket, server_socket = Mock_socket.create_pair () in
369
-
(* Permanent drain: all writes are forwarded immediately; the cooperative
370
-
scheduler can only interleave fibers at blocking points (W.await_batch),
371
-
so records written before a yield land in the peer's buffer in one batch.
372
-
Crucially, the handshake and the first ops run in the SAME fiber with no
373
-
yield between them, so Sm_shutdown_send executes before the client's
374
-
drain_handshake gets a turn — placing [ServerFinished + NewSessionTicket +
375
-
close_notify] in one batch for handle_tls. *)
353
+
(* Feed random byte-sized chunks before enabling drain, so the point at
354
+
which drain mode activates is part of the random input rather than
355
+
always being "before the handshake starts". *)
356
+
List.iter (Mock_socket.transmit client_socket) client_pre;
376
357
Mock_socket.transmit client_socket `Drain;
358
+
List.iter (Mock_socket.transmit server_socket) server_pre;
377
359
Mock_socket.transmit server_socket `Drain;
360
+
(* Handshake and ops in the SAME fiber: Sm_shutdown_send runs before the
361
+
peer's drain_handshake returns, placing [ServerFinished +
362
+
NewSessionTicket + close_notify] in one batch for handle_tls. *)
378
363
Fiber.both
379
364
(fun () ->
380
365
let tls = Tls_eio.client_of_flow Config.client client_socket in
···
387
372
( "tls",
388
373
Crowbar.
389
374
[
390
-
test_case "random ops" [ bytes; bytes; bool; list action ] main;
375
+
test_case "random ops" [ bytes; bytes; list action ] main;
391
376
test_case "state machine"
392
-
[ bytes; bytes; list sm_op; list sm_op ]
377
+
[ bytes; bytes; pre_transmit; pre_transmit; list sm_op; list sm_op ]
393
378
main_sm;
394
379
] )