upstream: github.com/mirleft/ocaml-tls
fix(ocaml-tls): remove main_corrupt fuzz test and mock_socket inject
The cooperative mock scheduler cannot model partial-read stalls, so
corruption injected mid-handshake causes Deadlock_detected rather than
exercising real recovery paths. Wire-level corruption is better tested
via the AFL campaign against raw byte streams.
+7
-70
+7
-60
eio/tests/fuzz/fuzz_tls.ml
+7
-60
eio/tests/fuzz/fuzz_tls.ml
···
1
1
(* Fuzz testing for tls-eio.
2
2
*
3
-
* Four test strategies:
3
+
* Three 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
···
28
28
* calls [Tls_eio.reneg], which runs [drain_handshake] a second time.
29
29
* Renegotiation is a TLS 1.2-only feature; TLS 1.3 uses key updates.
30
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. *)
31
+
* Note: wire-level corruption testing (fuzzing the TLS parser against
32
+
* arbitrary byte streams) is better suited to the AFL campaign
33
+
* (dune build --profile=afl @fuzz), which feeds raw bytes to the executable
34
+
* via stdin/file. The mock-socket cooperative scheduler cannot model a
35
+
* partial-read stall, so corruption injected mid-handshake causes
36
+
* Deadlock_detected rather than exercising the real recovery paths. *)
37
37
38
38
open Eio.Std
39
39
40
40
let src = Logs.Src.create "fuzz" ~doc:"Fuzz tests"
41
41
42
42
module Log = (val Logs.src_log src : Logs.LOG)
43
-
module W = Eio.Buf_write
44
43
45
44
type transmit_amount = Mock_socket.transmit_amount
46
45
···
415
414
Eio.Flow.shutdown tls `Send;
416
415
try ignore (Eio.Flow.read_all tls) with _ -> ())
417
416
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
-
467
417
let suite =
468
418
( "tls",
469
419
Crowbar.
···
473
423
[ bytes; bytes; pre_transmit; pre_transmit; list sm_op; list sm_op ]
474
424
main_sm;
475
425
test_case "tls12 reneg" [ bytes; bytes ] main_reneg;
476
-
test_case "post-handshake corrupt"
477
-
[ bytes; bytes; bytes; bytes ]
478
-
main_corrupt;
479
426
] )
-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
-
84
79
let create ~from_peer ~to_peer label =
85
80
let t = Impl.create ~from_peer ~to_peer label in
86
81
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. *)