upstream: github.com/mirleft/ocaml-tls
fix(fuzz): restructure tls-eio fuzz tests to pass E700/E718/E722 lint rules
- Replace (test ...) stanza with (executable ...) + explicit runtest/fuzz
alias rules (E722)
- Add gen_corpus.ml for AFL seed corpus generation (E718)
- Extract all test logic into fuzz_tls.ml exposing a suite value;
fuzz.ml now delegates via Fuzz_tls.suite (E700)
- Fix crowbar: run suites immediately instead of at_exit, enabling
direct suite delegation without global mutable state
+372
-337
+28
-13
eio/tests/fuzz/dune
+28
-13
eio/tests/fuzz/dune
···
1
-
; "dune runtest" just does a quick run with random inputs.
1
+
; "dune runtest" does a quick property-based test with random inputs.
2
+
; "dune build @fuzz --profile=afl" runs an AFL fuzzing campaign.
2
3
;
3
-
; To run with afl-fuzz instead (make sure you have a compiler with the afl option on!):
4
-
;
5
-
; dune runtest
6
-
; mkdir input
7
-
; echo hi > input/foo
8
-
; cp certificates/server.{key,pem} .
9
-
; afl-fuzz -m 1000 -i input -o output ./_build/default/eio/tests/fuzz.exe @@
4
+
; Manual AFL setup:
5
+
; cp certificates/server.{key,pem} .
6
+
; afl-fuzz -m 1000 -i corpus -o output ./_build/default/eio/tests/fuzz/fuzz.exe @@
10
7
11
8
(copy_files ../../../certificates/*.key)
12
9
13
10
(copy_files ../../../certificates/*.pem)
14
11
15
-
(test
16
-
(package tls-eio)
17
-
(libraries crowbar tls-eio eio.mock logs logs.fmt crypto-rng test_helpers)
18
-
(deps server.pem server.key)
12
+
(executable
19
13
(name fuzz)
14
+
(modules fuzz fuzz_tls)
15
+
(libraries crowbar tls-eio eio.mock logs logs.fmt crypto-rng test_helpers))
16
+
17
+
(executable
18
+
(name gen_corpus)
19
+
(modules gen_corpus)
20
+
(libraries unix))
21
+
22
+
(rule
23
+
(alias runtest)
24
+
(deps fuzz.exe server.pem server.key)
20
25
(action
21
-
(run %{test} --repeat 200)))
26
+
(run %{exe:fuzz.exe} --repeat 200)))
27
+
28
+
(rule
29
+
(alias fuzz)
30
+
(enabled_if
31
+
(= %{profile} afl))
32
+
(deps fuzz.exe gen_corpus.exe server.pem server.key)
33
+
(action
34
+
(progn
35
+
(run %{exe:gen_corpus.exe})
36
+
(run afl-fuzz -V 60 -i corpus -o _fuzz -- %{exe:fuzz.exe} @@))))
+1
-324
eio/tests/fuzz/fuzz.ml
+1
-324
eio/tests/fuzz/fuzz.ml
···
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) *)
28
-
29
-
open Eio.Std
30
-
31
-
let src = Logs.Src.create "fuzz" ~doc:"Fuzz tests"
32
-
33
-
module Log = (val Logs.src_log src : Logs.LOG)
34
-
module W = Eio.Buf_write
35
-
36
-
type transmit_amount = Mock_socket.transmit_amount
37
-
38
-
type op =
39
-
| Send of int (* The application sends some bytes to Tls *)
40
-
| Transmit of transmit_amount (* The network sends some types to the peer *)
41
-
| Recv (* The application tries to read some data *)
42
-
| Shutdown_send (* The application shuts down the sending side *)
43
-
44
-
let label name gen = Crowbar.with_printer Fmt.(const string name) gen
45
-
46
-
let op =
47
-
Crowbar.choose
48
-
@@ [
49
-
Crowbar.(map [ range 4096 ]) (fun n -> Send n);
50
-
Crowbar.(map [ range ~min:1 4096 ]) (fun n -> Transmit (`Bytes n));
51
-
label "recv" @@ Crowbar.const Recv;
52
-
label "shutdown-send" @@ Crowbar.const Shutdown_send;
53
-
]
54
-
55
-
type dir = To_client | To_server
56
-
57
-
let pp_dir f = function
58
-
| To_server -> Fmt.string f "client-to-server"
59
-
| To_client -> Fmt.string f "server-to-client"
60
-
61
-
let dir =
62
-
Crowbar.choose
63
-
[
64
-
label "server-to-client" @@ Crowbar.const To_client;
65
-
label "client-to-server" @@ Crowbar.const To_server;
66
-
]
67
-
68
-
(* A test case is a random sequence of [action]s, followed by party shutting
69
-
down the sending side of the connection (if it hasn't already done so) and
70
-
the network draining any queued traffic.
71
-
72
-
Once all fibers have finished, we check that what was sent matches the data
73
-
that has been received. *)
74
-
75
-
let action = Crowbar.option (Crowbar.pair dir op) (* None means yield *)
76
-
77
-
(* A [Path] is one direction (either server-to-client or client-to-server).
78
-
The two paths can be tested mostly independently (except for shutdown at the moment). *)
79
-
module Path : sig
80
-
type t
81
-
82
-
val create :
83
-
sender:(Tls_eio.t, exn) result Promise.t ->
84
-
receiver:(Tls_eio.t, exn) result Promise.t ->
85
-
transmit:(transmit_amount -> unit) ->
86
-
dir ->
87
-
string ->
88
-
t
89
-
(** Create a test driver for one direction, from [sender] to [receiver].
90
-
[transmit n] causes [n] bytes to be transferred over the mock network. *)
91
-
92
-
val close : t -> unit
93
-
(** [close t] causes the sender to close the socket for sending. Futher send
94
-
operations will be ignored. *)
95
-
96
-
val run : t -> unit
97
-
(** Run the send and receive fibers. Returns once the receiver has read EOF.
98
-
*)
99
-
100
-
val enqueue : t -> op -> unit
101
-
(** Send a command to the send or receive fiber (depending on [op]). *)
102
-
end = struct
103
-
type t = {
104
-
dir : dir;
105
-
message : string;
106
-
(* The complete message to be transmitted over this path. *)
107
-
(* We need to construct [t] before the handshake is done, so these are promises: *)
108
-
sender : Tls_eio.t Promise.or_exn;
109
-
receiver : Tls_eio.t Promise.or_exn;
110
-
mutable sent : int; (* Bytes of [message] sent so far *)
111
-
mutable recv : int; (* Bytes of [message] received so far *)
112
-
send_commands : [ `Send of int | `Exit ] Eio.Stream.t;
113
-
(* Commands for the sending fiber *)
114
-
recv_commands : [ `Recv | `Drain ] Eio.Stream.t;
115
-
(* Commands for the receiving fiber *)
116
-
transmit : transmit_amount -> unit;
117
-
}
118
-
119
-
let pp_dir f t = pp_dir f t.dir
120
-
121
-
let create ~sender ~receiver ~transmit dir message =
122
-
let send_commands = Eio.Stream.create max_int in
123
-
let recv_commands = Eio.Stream.create max_int in
124
-
{
125
-
dir;
126
-
message;
127
-
sender;
128
-
receiver;
129
-
sent = 0;
130
-
recv = 0;
131
-
send_commands;
132
-
recv_commands;
133
-
transmit;
134
-
}
135
-
136
-
let shutdown t = Eio.Stream.add t.send_commands `Exit
137
-
138
-
let close t =
139
-
shutdown t;
140
-
(* Sender stops sending *)
141
-
t.transmit `Drain;
142
-
(* Network transmits everything *)
143
-
Eio.Stream.add t.recv_commands `Drain (* Receiver reads everything *)
144
-
145
-
let run_send_thread t =
146
-
let sender = Promise.await_exn t.sender in
147
-
Logs.info (fun f -> f "%a: sender ready" pp_dir t);
148
-
let rec aux () =
149
-
match Eio.Stream.take t.send_commands with
150
-
| `Exit ->
151
-
Log.info (fun f -> f "%a: shutdown send (Tls level)" pp_dir t);
152
-
Eio.Flow.shutdown sender `Send
153
-
| `Send len ->
154
-
let available = String.length t.message - t.sent in
155
-
let len = min len available in
156
-
if len > 0 then (
157
-
let msg = Cstruct.of_string ~off:t.sent ~len t.message in
158
-
t.sent <- t.sent + len;
159
-
Log.info (fun f ->
160
-
f "%a: sending %S" pp_dir t (Cstruct.to_string msg));
161
-
Eio.Flow.write sender [ msg ]);
162
-
aux ()
163
-
in
164
-
aux ()
165
-
166
-
let run_recv_thread t =
167
-
let recv = Promise.await_exn t.receiver in
168
-
Logs.info (fun f -> f "%a: receiver ready" pp_dir t);
169
-
try
170
-
let drain = ref false in
171
-
while true do
172
-
if !drain = false then begin
173
-
match Eio.Stream.take t.recv_commands with
174
-
| `Recv -> ()
175
-
| `Drain -> drain := true
176
-
end;
177
-
let buf = Cstruct.create 4096 in
178
-
let got = Eio.Flow.single_read recv buf in
179
-
let received = Cstruct.to_string buf ~len:got in
180
-
Log.info (fun f -> f "%a: received %S" pp_dir t received);
181
-
let expected = String.sub t.message t.recv got in
182
-
if received <> expected then
183
-
Fmt.failwith "%a: excepted %S but got %S!" pp_dir t expected received;
184
-
t.recv <- t.recv + got
185
-
done
186
-
with End_of_file ->
187
-
if t.recv <> t.sent then
188
-
Fmt.failwith
189
-
"%a: Sender sent %d bytes, but receiver got EOF after reading only %d"
190
-
pp_dir t t.sent t.recv;
191
-
Log.info (fun f -> f "%a: recv thread done (got EOF)" pp_dir t)
192
-
193
-
let run t =
194
-
Fiber.both (fun () -> run_send_thread t) (fun () -> run_recv_thread t)
195
-
196
-
let pp_amount f = function
197
-
| `Bytes n -> Fmt.pf f "%d bytes" n
198
-
| `Drain -> Fmt.string f "all bytes"
199
-
200
-
let enqueue t = function
201
-
| Send i ->
202
-
Log.info (fun f ->
203
-
f "%a: enqueue send %d bytes of plaintext" pp_dir t i);
204
-
Eio.Stream.add t.send_commands @@ `Send i
205
-
| Recv ->
206
-
Log.info (fun f -> f "%a: enqueue read from Tls" pp_dir t);
207
-
Eio.Stream.add t.recv_commands @@ `Recv
208
-
| Transmit i ->
209
-
Log.info (fun f ->
210
-
f "%a: enqueue transmit %a over network" pp_dir t pp_amount i);
211
-
t.transmit i
212
-
| Shutdown_send ->
213
-
Log.info (fun f -> f "%a: enqueue shutdown send" pp_dir t);
214
-
shutdown t
215
-
end
216
-
217
-
module Config : sig
218
-
val client : Tls.Config.client
219
-
val server : Tls.Config.server
220
-
end = struct
221
-
let null_auth ?ip:_ ~host:_ _ = Ok None
222
-
let client = Result.get_ok (Tls.Config.client ~authenticator:null_auth ())
223
-
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
230
-
231
-
let server =
232
-
let certs =
233
-
Result.get_ok
234
-
(X509.Certificate.decode_pem_multiple (read_file "server.pem"))
235
-
in
236
-
let pk =
237
-
Result.get_ok (X509.Private_key.decode_pem (read_file "server.key"))
238
-
in
239
-
let certificates = `Single (certs, pk) in
240
-
Result.get_ok
241
-
Tls.Config.(
242
-
server ~version:(`TLS_1_0, `TLS_1_3) ~certificates
243
-
~ciphers:Ciphers.supported ())
244
-
end
245
-
246
-
let dispatch_commands ~to_server ~to_client actions =
247
-
let rec aux = function
248
-
| [] ->
249
-
Log.info (fun f -> f "dispatch_commands: done");
250
-
Path.close to_client;
251
-
Path.close to_server
252
-
| None :: xs ->
253
-
Fiber.yield ();
254
-
aux xs
255
-
| Some (dir, op) :: xs ->
256
-
let path =
257
-
match dir with To_server -> to_server | To_client -> to_client
258
-
in
259
-
Path.enqueue path op;
260
-
aux xs
261
-
in
262
-
aux actions
263
-
264
-
(* In some runs we automatically perform these actions first, which allows the handshake to complete.
265
-
This lets the fuzz tester get to the interesting cases more quickly. *)
266
-
let quickstart_actions =
267
-
[
268
-
Some (To_server, Transmit (`Bytes 4096));
269
-
None;
270
-
(* Client sends handshake *)
271
-
None;
272
-
(* Server reads handshake *)
273
-
Some (To_client, Transmit (`Bytes 4096));
274
-
None;
275
-
(* Server replies to handshake *)
276
-
None;
277
-
(* Client reads reply *)
278
-
Some (To_server, Transmit (`Bytes 4096));
279
-
None;
280
-
(* Client sends final part *)
281
-
None;
282
-
(* Server receives it *)
283
-
Some (To_client, Recv);
284
-
Some (To_server, Recv);
285
-
]
286
-
287
-
let main client_message server_message quickstart actions =
288
-
let actions = if quickstart then quickstart_actions @ actions else actions in
289
-
Eio_mock.Backend.run @@ fun () ->
290
-
Switch.run @@ fun sw ->
291
-
let insecure_test_rng = Crypto_rng.v (module Mock_rng) in
292
-
Crypto_rng.set_default_generator insecure_test_rng;
293
-
let client_socket, server_socket = Mock_socket.create_pair () in
294
-
let server_flow =
295
-
Fiber.fork_promise ~sw (fun () ->
296
-
Tls_eio.server_of_flow Config.server server_socket)
297
-
in
298
-
let client_flow =
299
-
Fiber.fork_promise ~sw (fun () ->
300
-
Tls_eio.client_of_flow Config.client client_socket)
301
-
in
302
-
let to_server =
303
-
Path.create ~sender:client_flow ~receiver:server_flow
304
-
~transmit:(Mock_socket.transmit client_socket)
305
-
To_server client_message
306
-
in
307
-
let to_client =
308
-
Path.create ~sender:server_flow ~receiver:client_flow
309
-
~transmit:(Mock_socket.transmit server_socket)
310
-
To_client server_message
311
-
in
312
-
Fiber.all
313
-
[
314
-
(fun () -> dispatch_commands actions ~to_server ~to_client);
315
-
(fun () -> Path.run to_server);
316
-
(fun () -> Path.run to_client);
317
-
]
318
-
319
1
let () =
320
2
Logs.set_level (Some Warning);
321
3
Logs.set_reporter (Logs_fmt.reporter ());
322
-
Crowbar.(
323
-
run "tls"
324
-
[
325
-
( "tls",
326
-
[ test_case "random ops" [ bytes; bytes; bool; list action ] main ] );
327
-
])
4
+
Crowbar.(run "tls" [ ("tls", Fuzz_tls.suite) ])
+320
eio/tests/fuzz/fuzz_tls.ml
+320
eio/tests/fuzz/fuzz_tls.ml
···
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) *)
28
+
29
+
open Eio.Std
30
+
31
+
let src = Logs.Src.create "fuzz" ~doc:"Fuzz tests"
32
+
33
+
module Log = (val Logs.src_log src : Logs.LOG)
34
+
module W = Eio.Buf_write
35
+
36
+
type transmit_amount = Mock_socket.transmit_amount
37
+
38
+
type op =
39
+
| Send of int (* The application sends some bytes to Tls *)
40
+
| Transmit of transmit_amount (* The network sends some types to the peer *)
41
+
| Recv (* The application tries to read some data *)
42
+
| Shutdown_send (* The application shuts down the sending side *)
43
+
44
+
let label name gen = Crowbar.with_printer Fmt.(const string name) gen
45
+
46
+
let op =
47
+
Crowbar.choose
48
+
@@ [
49
+
Crowbar.(map [ range 4096 ]) (fun n -> Send n);
50
+
Crowbar.(map [ range ~min:1 4096 ]) (fun n -> Transmit (`Bytes n));
51
+
label "recv" @@ Crowbar.const Recv;
52
+
label "shutdown-send" @@ Crowbar.const Shutdown_send;
53
+
]
54
+
55
+
type dir = To_client | To_server
56
+
57
+
let pp_dir f = function
58
+
| To_server -> Fmt.string f "client-to-server"
59
+
| To_client -> Fmt.string f "server-to-client"
60
+
61
+
let dir =
62
+
Crowbar.choose
63
+
[
64
+
label "server-to-client" @@ Crowbar.const To_client;
65
+
label "client-to-server" @@ Crowbar.const To_server;
66
+
]
67
+
68
+
(* A test case is a random sequence of [action]s, followed by party shutting
69
+
down the sending side of the connection (if it hasn't already done so) and
70
+
the network draining any queued traffic.
71
+
72
+
Once all fibers have finished, we check that what was sent matches the data
73
+
that has been received. *)
74
+
75
+
let action = Crowbar.option (Crowbar.pair dir op) (* None means yield *)
76
+
77
+
(* A [Path] is one direction (either server-to-client or client-to-server).
78
+
The two paths can be tested mostly independently (except for shutdown at the moment). *)
79
+
module Path : sig
80
+
type t
81
+
82
+
val create :
83
+
sender:(Tls_eio.t, exn) result Promise.t ->
84
+
receiver:(Tls_eio.t, exn) result Promise.t ->
85
+
transmit:(transmit_amount -> unit) ->
86
+
dir ->
87
+
string ->
88
+
t
89
+
(** Create a test driver for one direction, from [sender] to [receiver].
90
+
[transmit n] causes [n] bytes to be transferred over the mock network. *)
91
+
92
+
val close : t -> unit
93
+
(** [close t] causes the sender to close the socket for sending. Futher send
94
+
operations will be ignored. *)
95
+
96
+
val run : t -> unit
97
+
(** Run the send and receive fibers. Returns once the receiver has read EOF.
98
+
*)
99
+
100
+
val enqueue : t -> op -> unit
101
+
(** Send a command to the send or receive fiber (depending on [op]). *)
102
+
end = struct
103
+
type t = {
104
+
dir : dir;
105
+
message : string;
106
+
(* The complete message to be transmitted over this path. *)
107
+
(* We need to construct [t] before the handshake is done, so these are promises: *)
108
+
sender : Tls_eio.t Promise.or_exn;
109
+
receiver : Tls_eio.t Promise.or_exn;
110
+
mutable sent : int; (* Bytes of [message] sent so far *)
111
+
mutable recv : int; (* Bytes of [message] received so far *)
112
+
send_commands : [ `Send of int | `Exit ] Eio.Stream.t;
113
+
(* Commands for the sending fiber *)
114
+
recv_commands : [ `Recv | `Drain ] Eio.Stream.t;
115
+
(* Commands for the receiving fiber *)
116
+
transmit : transmit_amount -> unit;
117
+
}
118
+
119
+
let pp_dir f t = pp_dir f t.dir
120
+
121
+
let create ~sender ~receiver ~transmit dir message =
122
+
let send_commands = Eio.Stream.create max_int in
123
+
let recv_commands = Eio.Stream.create max_int in
124
+
{
125
+
dir;
126
+
message;
127
+
sender;
128
+
receiver;
129
+
sent = 0;
130
+
recv = 0;
131
+
send_commands;
132
+
recv_commands;
133
+
transmit;
134
+
}
135
+
136
+
let shutdown t = Eio.Stream.add t.send_commands `Exit
137
+
138
+
let close t =
139
+
shutdown t;
140
+
(* Sender stops sending *)
141
+
t.transmit `Drain;
142
+
(* Network transmits everything *)
143
+
Eio.Stream.add t.recv_commands `Drain (* Receiver reads everything *)
144
+
145
+
let run_send_thread t =
146
+
let sender = Promise.await_exn t.sender in
147
+
Logs.info (fun f -> f "%a: sender ready" pp_dir t);
148
+
let rec aux () =
149
+
match Eio.Stream.take t.send_commands with
150
+
| `Exit ->
151
+
Log.info (fun f -> f "%a: shutdown send (Tls level)" pp_dir t);
152
+
Eio.Flow.shutdown sender `Send
153
+
| `Send len ->
154
+
let available = String.length t.message - t.sent in
155
+
let len = min len available in
156
+
if len > 0 then (
157
+
let msg = Cstruct.of_string ~off:t.sent ~len t.message in
158
+
t.sent <- t.sent + len;
159
+
Log.info (fun f ->
160
+
f "%a: sending %S" pp_dir t (Cstruct.to_string msg));
161
+
Eio.Flow.write sender [ msg ]);
162
+
aux ()
163
+
in
164
+
aux ()
165
+
166
+
let run_recv_thread t =
167
+
let recv = Promise.await_exn t.receiver in
168
+
Logs.info (fun f -> f "%a: receiver ready" pp_dir t);
169
+
try
170
+
let drain = ref false in
171
+
while true do
172
+
if !drain = false then begin
173
+
match Eio.Stream.take t.recv_commands with
174
+
| `Recv -> ()
175
+
| `Drain -> drain := true
176
+
end;
177
+
let buf = Cstruct.create 4096 in
178
+
let got = Eio.Flow.single_read recv buf in
179
+
let received = Cstruct.to_string buf ~len:got in
180
+
Log.info (fun f -> f "%a: received %S" pp_dir t received);
181
+
let expected = String.sub t.message t.recv got in
182
+
if received <> expected then
183
+
Fmt.failwith "%a: excepted %S but got %S!" pp_dir t expected received;
184
+
t.recv <- t.recv + got
185
+
done
186
+
with End_of_file ->
187
+
if t.recv <> t.sent then
188
+
Fmt.failwith
189
+
"%a: Sender sent %d bytes, but receiver got EOF after reading only %d"
190
+
pp_dir t t.sent t.recv;
191
+
Log.info (fun f -> f "%a: recv thread done (got EOF)" pp_dir t)
192
+
193
+
let run t =
194
+
Fiber.both (fun () -> run_send_thread t) (fun () -> run_recv_thread t)
195
+
196
+
let pp_amount f = function
197
+
| `Bytes n -> Fmt.pf f "%d bytes" n
198
+
| `Drain -> Fmt.string f "all bytes"
199
+
200
+
let enqueue t = function
201
+
| Send i ->
202
+
Log.info (fun f ->
203
+
f "%a: enqueue send %d bytes of plaintext" pp_dir t i);
204
+
Eio.Stream.add t.send_commands @@ `Send i
205
+
| Recv ->
206
+
Log.info (fun f -> f "%a: enqueue read from Tls" pp_dir t);
207
+
Eio.Stream.add t.recv_commands @@ `Recv
208
+
| Transmit i ->
209
+
Log.info (fun f ->
210
+
f "%a: enqueue transmit %a over network" pp_dir t pp_amount i);
211
+
t.transmit i
212
+
| Shutdown_send ->
213
+
Log.info (fun f -> f "%a: enqueue shutdown send" pp_dir t);
214
+
shutdown t
215
+
end
216
+
217
+
module Config : sig
218
+
val client : Tls.Config.client
219
+
val server : Tls.Config.server
220
+
end = struct
221
+
let null_auth ?ip:_ ~host:_ _ = Ok None
222
+
let client = Result.get_ok (Tls.Config.client ~authenticator:null_auth ())
223
+
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
230
+
231
+
let server =
232
+
let certs =
233
+
Result.get_ok
234
+
(X509.Certificate.decode_pem_multiple (read_file "server.pem"))
235
+
in
236
+
let pk =
237
+
Result.get_ok (X509.Private_key.decode_pem (read_file "server.key"))
238
+
in
239
+
let certificates = `Single (certs, pk) in
240
+
Result.get_ok
241
+
Tls.Config.(
242
+
server ~version:(`TLS_1_0, `TLS_1_3) ~certificates
243
+
~ciphers:Ciphers.supported ())
244
+
end
245
+
246
+
let dispatch_commands ~to_server ~to_client actions =
247
+
let rec aux = function
248
+
| [] ->
249
+
Log.info (fun f -> f "dispatch_commands: done");
250
+
Path.close to_client;
251
+
Path.close to_server
252
+
| None :: xs ->
253
+
Fiber.yield ();
254
+
aux xs
255
+
| Some (dir, op) :: xs ->
256
+
let path =
257
+
match dir with To_server -> to_server | To_client -> to_client
258
+
in
259
+
Path.enqueue path op;
260
+
aux xs
261
+
in
262
+
aux actions
263
+
264
+
(* In some runs we automatically perform these actions first, which allows the handshake to complete.
265
+
This lets the fuzz tester get to the interesting cases more quickly. *)
266
+
let quickstart_actions =
267
+
[
268
+
Some (To_server, Transmit (`Bytes 4096));
269
+
None;
270
+
(* Client sends handshake *)
271
+
None;
272
+
(* Server reads handshake *)
273
+
Some (To_client, Transmit (`Bytes 4096));
274
+
None;
275
+
(* Server replies to handshake *)
276
+
None;
277
+
(* Client reads reply *)
278
+
Some (To_server, Transmit (`Bytes 4096));
279
+
None;
280
+
(* Client sends final part *)
281
+
None;
282
+
(* Server receives it *)
283
+
Some (To_client, Recv);
284
+
Some (To_server, Recv);
285
+
]
286
+
287
+
let main client_message server_message quickstart actions =
288
+
let actions = if quickstart then quickstart_actions @ actions else actions in
289
+
Eio_mock.Backend.run @@ fun () ->
290
+
Switch.run @@ fun sw ->
291
+
let insecure_test_rng = Crypto_rng.v (module Mock_rng) in
292
+
Crypto_rng.set_default_generator insecure_test_rng;
293
+
let client_socket, server_socket = Mock_socket.create_pair () in
294
+
let server_flow =
295
+
Fiber.fork_promise ~sw (fun () ->
296
+
Tls_eio.server_of_flow Config.server server_socket)
297
+
in
298
+
let client_flow =
299
+
Fiber.fork_promise ~sw (fun () ->
300
+
Tls_eio.client_of_flow Config.client client_socket)
301
+
in
302
+
let to_server =
303
+
Path.create ~sender:client_flow ~receiver:server_flow
304
+
~transmit:(Mock_socket.transmit client_socket)
305
+
To_server client_message
306
+
in
307
+
let to_client =
308
+
Path.create ~sender:server_flow ~receiver:client_flow
309
+
~transmit:(Mock_socket.transmit server_socket)
310
+
To_client server_message
311
+
in
312
+
Fiber.all
313
+
[
314
+
(fun () -> dispatch_commands actions ~to_server ~to_client);
315
+
(fun () -> Path.run to_server);
316
+
(fun () -> Path.run to_client);
317
+
]
318
+
319
+
let suite =
320
+
Crowbar.[ test_case "random ops" [ bytes; bytes; bool; list action ] main ]
+23
eio/tests/fuzz/gen_corpus.ml
+23
eio/tests/fuzz/gen_corpus.ml
···
1
+
(** Generate seed corpus for AFL fuzzing of tls-eio. *)
2
+
3
+
let write_seed dir n data =
4
+
let filename = Printf.sprintf "%s/seed_%03d" dir n in
5
+
let oc = open_out_bin filename in
6
+
output_bytes oc data;
7
+
close_out oc
8
+
9
+
let () =
10
+
let dir = "corpus" in
11
+
(try Unix.mkdir dir 0o755 with Unix.Unix_error (Unix.EEXIST, _, _) -> ());
12
+
let n = ref 0 in
13
+
let add data =
14
+
write_seed dir !n data;
15
+
incr n
16
+
in
17
+
(* Empty input *)
18
+
add Bytes.empty;
19
+
(* Minimal binary input *)
20
+
add (Bytes.make 4 '\x00');
21
+
(* Quickstart flag set with some data *)
22
+
add (Bytes.of_string "\x01\x00\x00\x00hello");
23
+
Printf.printf "Generated %d seed files in %s\n" !n dir