upstream: github.com/mirleft/ocaml-tls
feat(ocaml-tls): add full TLS state machine fuzz test
Add [main_sm] — a state machine fuzz test where both sides operate in
permanent drain mode with independent random op sequences
(Sm_send/Sm_shutdown_send/Sm_key_update/Sm_epoch).
Both sides' handshake and first ops run in the same Fiber.both fiber
with no yield between them. This means when the server executes
Sm_shutdown_send immediately after server_of_flow, its close_notify
lands in the same buffer batch as ServerFinished + NewSessionTicket,
triggering the Read_closed path inside drain_handshake that the
controlled-transmit [main] test misses.
This test caught the drain_handshake bug (End_of_file raised when state
is Read_closed with handshake already complete) before the fix was
applied, and passes cleanly with the fix in place.
Also add Epoch op to both [main] and [main_sm] to verify epoch is
accessible in all states.
+128
-67
+128
-67
eio/tests/fuzz/fuzz_tls.ml
+128
-67
eio/tests/fuzz/fuzz_tls.ml
···
1
1
(* Fuzz testing for tls-eio.
2
-
3
-
This code picks two random strings, one for the client to send and one for
4
-
the server. It then starts a send and receive fiber for each end.
5
-
6
-
A dispatcher fiber then sends commands to these worker fibers
7
-
(see [action] for the possible actions).
8
-
9
-
This is intended to check for bugs in the Eio wrapper (rather than in Tls itself).
10
-
At the moment, it's just checking that tls-eio works when used correctly.
11
-
Each endpoint overlaps reads with writes (but not reads with other reads or
12
-
writes with other writes).
13
-
14
-
Some possible future improvements:
15
-
16
-
- It currently only checks the basic read/write/close operations.
17
-
It should be extended to check [reneg], etc too.
18
-
19
-
- Currently, cancelling a read operation marks the Tls flow as broken.
20
-
We should allow resuming after a cancelled read, and test that here.
21
-
22
-
- We should try injecting faults and make sure they're handled sensibly.
23
-
24
-
- It would be good to get coverage reports for these tests.
25
-
However, this requires changes to crowbar:
26
-
https://github.com/stedolan/crowbar/issues/4#issuecomment-1310277551
27
-
(a patched version reported 54% coverage of Tls_eio.ml) *)
2
+
*
3
+
* Two test strategies:
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.
9
+
*
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).
18
+
*
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. *)
28
28
29
29
open Eio.Std
30
30
···
35
35
36
36
type transmit_amount = Mock_socket.transmit_amount
37
37
38
+
(* ── controlled-transmit test (main) ──────────────────────────────────────── *)
39
+
38
40
type op =
39
41
| Send of int (* The application sends some bytes to Tls *)
40
-
| Transmit of transmit_amount (* The network sends some types to the peer *)
42
+
| Transmit of transmit_amount (* The network sends some bytes to the peer *)
41
43
| Recv (* The application tries to read some data *)
42
44
| Shutdown_send (* The application shuts down the sending side *)
43
-
| Key_update of
44
-
bool (* TLS 1.3: update session keys; bool = request peer update *)
45
+
| Key_update of bool (* TLS 1.3: update keys; bool = request peer update *)
46
+
| Epoch (* Check epoch is accessible in current state *)
45
47
46
48
let label name gen = Crowbar.with_printer Fmt.(const string name) gen
47
49
···
53
55
label "recv" @@ Crowbar.const Recv;
54
56
label "shutdown-send" @@ Crowbar.const Shutdown_send;
55
57
Crowbar.(map [ bool ]) (fun req -> Key_update req);
58
+
label "epoch" @@ Crowbar.const Epoch;
56
59
]
57
60
58
61
type dir = To_client | To_server
···
68
71
label "client-to-server" @@ Crowbar.const To_server;
69
72
]
70
73
71
-
(* A test case is a random sequence of [action]s, followed by party shutting
72
-
down the sending side of the connection (if it hasn't already done so) and
73
-
the network draining any queued traffic.
74
-
75
-
Once all fibers have finished, we check that what was sent matches the data
76
-
that has been received. *)
77
-
78
74
let action = Crowbar.option (Crowbar.pair dir op) (* None means yield *)
79
75
80
-
(* A [Path] is one direction (either server-to-client or client-to-server).
81
-
The two paths can be tested mostly independently (except for shutdown at the moment). *)
76
+
(* A [Path] is one direction (either server-to-client or client-to-server). *)
82
77
module Path : sig
83
78
type t
84
79
···
89
84
dir ->
90
85
string ->
91
86
t
92
-
(** Create a test driver for one direction, from [sender] to [receiver].
93
-
[transmit n] causes [n] bytes to be transferred over the mock network. *)
94
87
95
88
val close : t -> unit
96
-
(** [close t] causes the sender to close the socket for sending. Futher send
97
-
operations will be ignored. *)
98
-
99
89
val run : t -> unit
100
-
(** Run the send and receive fibers. Returns once the receiver has read EOF.
101
-
*)
102
-
103
90
val enqueue : t -> op -> unit
104
-
(** Send a command to the send or receive fiber (depending on [op]). *)
105
91
end = struct
106
92
type t = {
107
93
dir : dir;
108
94
message : string;
109
-
(* The complete message to be transmitted over this path. *)
110
-
(* We need to construct [t] before the handshake is done, so these are promises: *)
111
95
sender : Tls_eio.t Promise.or_exn;
112
96
receiver : Tls_eio.t Promise.or_exn;
113
-
mutable sent : int; (* Bytes of [message] sent so far *)
114
-
mutable recv : int; (* Bytes of [message] received so far *)
115
-
send_commands : [ `Send of int | `Key_update of bool | `Exit ] Eio.Stream.t;
116
-
(* Commands for the sending fiber *)
97
+
mutable sent : int;
98
+
mutable recv : int;
99
+
send_commands :
100
+
[ `Send of int | `Key_update of bool | `Epoch | `Exit ] Eio.Stream.t;
117
101
recv_commands : [ `Recv | `Drain ] Eio.Stream.t;
118
-
(* Commands for the receiving fiber *)
119
102
transmit : transmit_amount -> unit;
120
103
}
121
104
···
140
123
141
124
let close t =
142
125
shutdown t;
143
-
(* Sender stops sending *)
144
126
t.transmit `Drain;
145
-
(* Network transmits everything *)
146
-
Eio.Stream.add t.recv_commands `Drain (* Receiver reads everything *)
127
+
Eio.Stream.add t.recv_commands `Drain
147
128
148
129
let run_send_thread t =
149
130
let sender = Promise.await_exn t.sender in
···
158
139
(try Tls_eio.key_update ~request:req sender
159
140
with Invalid_argument _ -> ());
160
141
aux ()
142
+
| `Epoch ->
143
+
Log.info (fun f -> f "%a: epoch" pp_dir t);
144
+
ignore (Tls_eio.epoch sender);
145
+
aux ()
161
146
| `Send len ->
162
147
let available = String.length t.message - t.sent in
163
148
let len = min len available in
···
223
208
| Key_update req ->
224
209
Log.info (fun f -> f "%a: enqueue key_update request=%b" pp_dir t req);
225
210
Eio.Stream.add t.send_commands @@ `Key_update req
211
+
| Epoch ->
212
+
Log.info (fun f -> f "%a: enqueue epoch" pp_dir t);
213
+
Eio.Stream.add t.send_commands `Epoch
226
214
end
227
215
228
216
module Config : sig
···
272
260
in
273
261
aux actions
274
262
275
-
(* In some runs we automatically perform these actions first, which allows the handshake to complete.
276
-
This lets the fuzz tester get to the interesting cases more quickly. *)
277
263
let quickstart_actions =
278
264
[
279
265
Some (To_server, Transmit (`Bytes 4096));
280
266
None;
281
-
(* Client sends handshake *)
282
267
None;
283
-
(* Server reads handshake *)
284
268
Some (To_client, Transmit (`Bytes 4096));
285
269
None;
286
-
(* Server replies to handshake *)
287
270
None;
288
-
(* Client reads reply *)
289
271
Some (To_server, Transmit (`Bytes 4096));
290
272
None;
291
-
(* Client sends final part *)
292
273
None;
293
-
(* Server receives it *)
294
274
Some (To_client, Recv);
295
275
Some (To_server, Recv);
296
276
]
···
327
307
(fun () -> Path.run to_client);
328
308
]
329
309
310
+
(* ── state machine test (main_sm) ─────────────────────────────────────────── *)
311
+
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. *)
316
+
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 *)
321
+
322
+
let sm_op =
323
+
Crowbar.choose
324
+
[
325
+
Crowbar.(map [ range 4096 ]) (fun n -> Sm_send n);
326
+
label "shutdown_send" @@ Crowbar.const Sm_shutdown_send;
327
+
Crowbar.(map [ bool ]) (fun req -> Sm_key_update req);
328
+
label "epoch" @@ Crowbar.const Sm_epoch;
329
+
]
330
+
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. *)
333
+
let run_sm_ops tls message ops =
334
+
let sent = ref 0 in
335
+
let write_closed = ref false in
336
+
List.iter
337
+
(fun op ->
338
+
match op with
339
+
| Sm_send n when not !write_closed -> (
340
+
let n = min n (String.length message - !sent) in
341
+
if n > 0 then
342
+
try
343
+
Eio.Flow.write tls [ Cstruct.of_string ~off:!sent ~len:n message ];
344
+
sent := !sent + n
345
+
with
346
+
| Eio.Exn.Io _ -> ()
347
+
| Invalid_argument _ -> ())
348
+
| Sm_send _ -> ()
349
+
| Sm_shutdown_send when not !write_closed ->
350
+
(try Eio.Flow.shutdown tls `Send with _ -> ());
351
+
write_closed := true
352
+
| Sm_shutdown_send -> ()
353
+
| Sm_key_update req -> (
354
+
try Tls_eio.key_update ~request:req tls
355
+
with Invalid_argument _ -> ())
356
+
| Sm_epoch -> ignore (Tls_eio.epoch tls))
357
+
ops;
358
+
(* Send close_notify if not already done so the peer's read drains. *)
359
+
(if not !write_closed then try Eio.Flow.shutdown tls `Send with _ -> ());
360
+
(* Drain: read until the peer sends its close_notify. *)
361
+
try ignore (Eio.Flow.read_all tls) with _ -> ()
362
+
363
+
let main_sm client_message server_message client_ops server_ops =
364
+
Eio_mock.Backend.run @@ fun () ->
365
+
Switch.run @@ fun _sw ->
366
+
let insecure_test_rng = Crypto_rng.v (module Mock_rng) in
367
+
Crypto_rng.set_default_generator insecure_test_rng;
368
+
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. *)
376
+
Mock_socket.transmit client_socket `Drain;
377
+
Mock_socket.transmit server_socket `Drain;
378
+
Fiber.both
379
+
(fun () ->
380
+
let tls = Tls_eio.client_of_flow Config.client client_socket in
381
+
run_sm_ops tls client_message client_ops)
382
+
(fun () ->
383
+
let tls = Tls_eio.server_of_flow Config.server server_socket in
384
+
run_sm_ops tls server_message server_ops)
385
+
330
386
let suite =
331
387
( "tls",
332
-
Crowbar.[ test_case "random ops" [ bytes; bytes; bool; list action ] main ]
333
-
)
388
+
Crowbar.
389
+
[
390
+
test_case "random ops" [ bytes; bytes; bool; list action ] main;
391
+
test_case "state machine"
392
+
[ bytes; bytes; list sm_op; list sm_op ]
393
+
main_sm;
394
+
] )