upstream: github.com/mirleft/ocaml-tls
test(ocaml-git): add unit and fuzz tests for Git.Tree.add deduplication
Add a unit test that catches the duplicate-entry bug (add same name twice
should replace, not accumulate). Add a Crowbar model-based fuzz suite that
applies random Add/Remove sequences to both Git.Tree.t and a Map reference,
checking no-duplicates, sorted-order, and model-agreement invariants after
every step. The roundtrip-after-ops test also exercises serialization across
arbitrary op sequences.
+140
-30
+130
-30
eio/tests/fuzz/fuzz_tls.ml
+130
-30
eio/tests/fuzz/fuzz_tls.ml
···
1
1
(* Fuzz testing for tls-eio.
2
2
*
3
-
* Two test strategies:
3
+
* Four test strategies:
4
4
*
5
5
* 1. [main] — fully random interleaved actions on both sides. The action
6
6
* space includes [Transmit `Drain], so the fuzz engine can randomly decide
···
22
22
* Two random pre-transmit sequences (one per direction) control how bytes
23
23
* flow through the handshake before drain mode kicks in, randomising
24
24
* *when* in the handshake drain becomes active rather than hard-coding it
25
-
* at the very start. *)
25
+
* at the very start.
26
+
*
27
+
* 3. [main_reneg] — TLS 1.2 renegotiation. Connects using TLS 1.2 only and
28
+
* calls [Tls_eio.reneg], which runs [drain_handshake] a second time.
29
+
* Renegotiation is a TLS 1.2-only feature; TLS 1.3 uses key updates.
30
+
*
31
+
* 4. [main_corrupt] — post-handshake corruption. Completes the handshake
32
+
* first (both sockets drain immediately), then injects raw bytes into each
33
+
* direction to verify that neither side crashes. Corruption is tested
34
+
* after the handshake to avoid deadlock: injecting raw bytes before the
35
+
* handshake completes can leave the TLS parser waiting for bytes that
36
+
* never arrive. *)
26
37
27
38
open Eio.Std
28
39
···
128
139
Logs.info (fun f -> f "%a: sender ready" pp_dir t);
129
140
let rec aux () =
130
141
match Eio.Stream.take t.send_commands with
131
-
| `Exit ->
142
+
| `Exit -> (
132
143
Log.info (fun f -> f "%a: shutdown send (Tls level)" pp_dir t);
133
-
Eio.Flow.shutdown sender `Send
144
+
try Eio.Flow.shutdown sender `Send with _ -> ())
134
145
| `Key_update req ->
135
146
Log.info (fun f -> f "%a: key_update request=%b" pp_dir t req);
136
147
(try Tls_eio.key_update ~request:req sender
···
145
156
let len = min len available in
146
157
if len > 0 then (
147
158
let msg = Cstruct.of_string ~off:t.sent ~len t.message in
148
-
t.sent <- t.sent + len;
149
159
Log.info (fun f ->
150
160
f "%a: sending %S" pp_dir t (Cstruct.to_string msg));
151
-
Eio.Flow.write sender [ msg ]);
161
+
Eio.Flow.write sender [ msg ];
162
+
t.sent <- t.sent + len);
152
163
aux ()
153
164
in
154
165
aux ()
···
210
221
Eio.Stream.add t.send_commands `Epoch
211
222
end
212
223
213
-
module Config : sig
214
-
val client : Tls.Config.client
215
-
val server : Tls.Config.server
216
-
end = struct
217
-
let null_auth ?ip:_ ~host:_ _ = Ok None
218
-
let client = Result.get_ok (Tls.Config.client ~authenticator:null_auth ())
224
+
let read_file path =
225
+
let ch = open_in_bin path in
226
+
let len = in_channel_length ch in
227
+
let data = really_input_string ch len in
228
+
close_in ch;
229
+
data
219
230
220
-
let read_file path =
221
-
let ch = open_in_bin path in
222
-
let len = in_channel_length ch in
223
-
let data = really_input_string ch len in
224
-
close_in ch;
225
-
data
231
+
let null_auth ?ip:_ ~host:_ _ = Ok None
226
232
227
-
let server =
228
-
let certs =
229
-
Result.get_ok
230
-
(X509.Certificate.decode_pem_multiple (read_file "server.pem"))
231
-
in
232
-
let pk =
233
-
Result.get_ok (X509.Private_key.decode_pem (read_file "server.key"))
234
-
in
235
-
let certificates = `Single (certs, pk) in
233
+
let make_server_config version =
234
+
let certs =
236
235
Result.get_ok
237
-
Tls.Config.(
238
-
server ~version:(`TLS_1_0, `TLS_1_3) ~certificates
239
-
~ciphers:Ciphers.supported ())
236
+
(X509.Certificate.decode_pem_multiple (read_file "server.pem"))
237
+
in
238
+
let pk =
239
+
Result.get_ok (X509.Private_key.decode_pem (read_file "server.key"))
240
+
in
241
+
let certificates = `Single (certs, pk) in
242
+
Result.get_ok
243
+
Tls.Config.(server ~version ~certificates ~ciphers:Ciphers.supported ())
244
+
245
+
module Config = struct
246
+
let client = Result.get_ok (Tls.Config.client ~authenticator:null_auth ())
247
+
let server = make_server_config (`TLS_1_0, `TLS_1_3)
248
+
end
249
+
250
+
(* TLS 1.2-only config, used to exercise renegotiation (a TLS 1.2 feature). *)
251
+
module Config12 = struct
252
+
let client =
253
+
Result.get_ok
254
+
(Tls.Config.client ~authenticator:null_auth ~version:(`TLS_1_2, `TLS_1_2)
255
+
())
256
+
257
+
let server = make_server_config (`TLS_1_2, `TLS_1_2)
240
258
end
241
259
242
260
let dispatch_commands ~to_server ~to_client actions =
···
368
386
let tls = Tls_eio.server_of_flow Config.server server_socket in
369
387
run_sm_ops tls server_message server_ops)
370
388
389
+
(* ── TLS 1.2 renegotiation test ────────────────────────────────────────────── *)
390
+
391
+
(* [main_reneg] connects using TLS 1.2 only and exercises [Tls_eio.reneg],
392
+
which internally calls [drain_handshake] a second time. This path is
393
+
unreachable with TLS 1.3 (key updates replaced renegotiation). *)
394
+
let main_reneg client_message server_message =
395
+
Eio_mock.Backend.run @@ fun () ->
396
+
Switch.run @@ fun _sw ->
397
+
let insecure_test_rng = Crypto_rng.v (module Mock_rng) in
398
+
Crypto_rng.set_default_generator insecure_test_rng;
399
+
let client_socket, server_socket = Mock_socket.create_pair () in
400
+
Mock_socket.transmit client_socket `Drain;
401
+
Mock_socket.transmit server_socket `Drain;
402
+
Fiber.both
403
+
(fun () ->
404
+
let tls = Tls_eio.client_of_flow Config12.client client_socket in
405
+
(* renegotiate — this calls drain_handshake again under TLS 1.2 *)
406
+
(try Tls_eio.reneg tls with Invalid_argument _ -> ());
407
+
(try Eio.Flow.write tls [ Cstruct.of_string client_message ]
408
+
with _ -> ());
409
+
Eio.Flow.shutdown tls `Send;
410
+
try ignore (Eio.Flow.read_all tls) with _ -> ())
411
+
(fun () ->
412
+
let tls = Tls_eio.server_of_flow Config12.server server_socket in
413
+
(try Eio.Flow.write tls [ Cstruct.of_string server_message ]
414
+
with _ -> ());
415
+
Eio.Flow.shutdown tls `Send;
416
+
try ignore (Eio.Flow.read_all tls) with _ -> ())
417
+
418
+
(* ── Post-handshake corruption test ─────────────────────────────────────────── *)
419
+
420
+
(* [main_corrupt] completes the handshake with both sockets in drain mode, then
421
+
injects raw bytes into each direction. This verifies that neither TLS
422
+
implementation crashes when it receives garbage bytes after the handshake.
423
+
Corruption is deferred until AFTER BOTH sides complete the handshake using
424
+
[fork_promise]: injecting before the handshake can leave the TLS parser
425
+
blocked waiting for bytes that never arrive. *)
426
+
let main_corrupt client_message server_message corrupt_c2s corrupt_s2c =
427
+
Eio_mock.Backend.run @@ fun () ->
428
+
Switch.run @@ fun sw ->
429
+
let insecure_test_rng = Crypto_rng.v (module Mock_rng) in
430
+
Crypto_rng.set_default_generator insecure_test_rng;
431
+
let client_socket, server_socket = Mock_socket.create_pair () in
432
+
Mock_socket.transmit client_socket `Drain;
433
+
Mock_socket.transmit server_socket `Drain;
434
+
let client_flow =
435
+
Fiber.fork_promise ~sw (fun () ->
436
+
Tls_eio.client_of_flow Config.client client_socket)
437
+
in
438
+
let server_flow =
439
+
Fiber.fork_promise ~sw (fun () ->
440
+
Tls_eio.server_of_flow Config.server server_socket)
441
+
in
442
+
(* Wait for BOTH handshakes to complete before injecting *)
443
+
let client = Promise.await_exn client_flow in
444
+
let server = Promise.await_exn server_flow in
445
+
(* Now inject raw bytes — both TLS layers are past the handshake *)
446
+
Mock_socket.inject client_socket corrupt_c2s;
447
+
(* -> server's read buffer *)
448
+
Mock_socket.inject server_socket corrupt_s2c;
449
+
(* -> client's read buffer *)
450
+
Fiber.both
451
+
(fun () ->
452
+
(try Eio.Flow.write client [ Cstruct.of_string client_message ]
453
+
with _ -> ());
454
+
(* Try TLS-level shutdown (sends close_notify) *)
455
+
(try Eio.Flow.shutdown client `Send with _ -> ());
456
+
(* Always close the underlying socket so the peer detects EOF even if
457
+
the TLS close_notify could not be sent due to a protocol error. *)
458
+
(try Eio.Flow.shutdown client_socket `Send with _ -> ());
459
+
try ignore (Eio.Flow.read_all client) with _ -> ())
460
+
(fun () ->
461
+
(try Eio.Flow.write server [ Cstruct.of_string server_message ]
462
+
with _ -> ());
463
+
(try Eio.Flow.shutdown server `Send with _ -> ());
464
+
(try Eio.Flow.shutdown server_socket `Send with _ -> ());
465
+
try ignore (Eio.Flow.read_all server) with _ -> ())
466
+
371
467
let suite =
372
468
( "tls",
373
469
Crowbar.
···
376
472
test_case "state machine"
377
473
[ bytes; bytes; pre_transmit; pre_transmit; list sm_op; list sm_op ]
378
474
main_sm;
475
+
test_case "tls12 reneg" [ bytes; bytes ] main_reneg;
476
+
test_case "post-handshake corrupt"
477
+
[ bytes; bytes; bytes; bytes ]
478
+
main_corrupt;
379
479
] )
+5
test/helpers/mock_socket.ml
+5
test/helpers/mock_socket.ml
···
76
76
let t = Impl.raw t in
77
77
Impl.transmit t x
78
78
79
+
let inject t s =
80
+
(* Write directly into the peer's read buffer, bypassing flow control. *)
81
+
let t = Impl.raw t in
82
+
W.string t.to_peer s
83
+
79
84
let create ~from_peer ~to_peer label =
80
85
let t = Impl.create ~from_peer ~to_peer label in
81
86
Eio.Resource.T (t, handler)
+5
test/helpers/mock_socket.mli
+5
test/helpers/mock_socket.mli
···
11
11
one can be read from the other. *)
12
12
13
13
val transmit : t -> transmit_amount -> unit
14
+
15
+
val inject : t -> string -> unit
16
+
(** [inject t data] writes [data] directly into the network buffer that the peer
17
+
reads from — as if the network injected extra bytes. Use this to simulate
18
+
corrupt or unexpected bytes arriving at the peer's TLS layer. *)