gazagnaire.org
OCaml wire format DSL with EverParse 3D output for verified parsers
1(* Staged property-based differential testing: OCaml vs C.
2
3 Stage 0 — generate random schemas + C code to temp dir
4 Stage 1 — compile C roundtrip binary + start subprocess
5 Stage 2 — Crowbar tests: OCaml roundtrip_struct vs C subprocess
6
7 The subprocess protocol is itself defined using wire record codecs:
8 - Request: WireReq { index : uint32; length : uint32 } ++ data[length]
9 - Response: WireResp { result : uint32 } ++ data[result] (result < 0 = error)
10
11 Both sides use wire-generated read/write functions. *)
12
13module Cr = Crowbar
14module Bs = Bytesrw.Bytes.Slice
15
16(* Helper: encode record to string using slice-based API *)
17let encode_to_string codec =
18 let encode = Wire.Staged.unstage (Wire.Record.encode codec) in
19 fun v ->
20 let slice = encode v in
21 Bytes.sub_string (Bs.bytes slice) (Bs.first slice) (Bs.length slice)
22
23(* Helper: decode record from bytes using slice-based API *)
24let decode_from_bytes codec =
25 let decode = Wire.Staged.unstage (Wire.Record.decode codec) in
26 fun b ->
27 if Bytes.length b = 0 then
28 Error (Wire.Unexpected_eof { expected = 1; got = 0 })
29 else
30 let slice = Bs.of_bytes b ~first:0 ~last:(Bytes.length b - 1) in
31 Ok (decode slice)
32
33(* ---- One-space protocol (defined with wire) ---- *)
34
35type request_hdr = { req_index : int32; req_length : int32 }
36
37let request_hdr_codec =
38 Wire.Record.record "WireReq"
39 ~default:{ req_index = 0l; req_length = 0l }
40 [
41 Wire.Record.field "index" Wire.uint32
42 ~get:(fun r -> r.req_index)
43 ~set:(fun v r -> { r with req_index = v });
44 Wire.Record.field "length" Wire.uint32
45 ~get:(fun r -> r.req_length)
46 ~set:(fun v r -> { r with req_length = v });
47 ]
48
49type response_hdr = { resp_result : int32 }
50
51let response_hdr_codec =
52 Wire.Record.record "WireResp" ~default:{ resp_result = 0l }
53 [
54 Wire.Record.field "result" Wire.uint32
55 ~get:(fun r -> r.resp_result)
56 ~set:(fun v _r -> { resp_result = v });
57 ]
58
59let request_hdr_struct = Wire.Record.to_struct request_hdr_codec
60let response_hdr_struct = Wire.Record.to_struct response_hdr_codec
61
62(* Stage the protocol encoders/decoders once *)
63let encode_request_hdr = encode_to_string request_hdr_codec
64let decode_response_hdr = decode_from_bytes response_hdr_codec
65
66(* ---- Field type metadata ---- *)
67
68type ft = {
69 make_field : string -> bool Wire.expr option -> Wire.field;
70 wire_size : int;
71}
72
73let field_types =
74 [|
75 {
76 make_field = (fun n c -> Wire.field n ?constraint_:c Wire.uint8);
77 wire_size = 1;
78 };
79 {
80 make_field = (fun n c -> Wire.field n ?constraint_:c Wire.uint16);
81 wire_size = 2;
82 };
83 {
84 make_field = (fun n c -> Wire.field n ?constraint_:c Wire.uint16be);
85 wire_size = 2;
86 };
87 {
88 make_field = (fun n c -> Wire.field n ?constraint_:c Wire.uint32);
89 wire_size = 4;
90 };
91 {
92 make_field = (fun n c -> Wire.field n ?constraint_:c Wire.uint32be);
93 wire_size = 4;
94 };
95 {
96 make_field = (fun n c -> Wire.field n ?constraint_:c Wire.uint64);
97 wire_size = 8;
98 };
99 {
100 make_field = (fun n c -> Wire.field n ?constraint_:c Wire.uint64be);
101 wire_size = 8;
102 };
103 |]
104
105(* ---- Random schema generation ---- *)
106
107type random_schema = { struct_ : Wire.struct_; wire_size : int }
108
109let gen_constraint_val rng wire_size =
110 match wire_size with
111 | 1 -> Random.State.int rng 256
112 | 2 -> Random.State.int rng 65536
113 | 4 -> Int32.unsigned_to_int (Random.State.bits32 rng) |> Option.get
114 | 8 ->
115 Int64.to_int
116 (Int64.logand (Random.State.bits64 rng) 0x3FFF_FFFF_FFFF_FFFFL)
117 | _ -> 0
118
119let random_struct rng i =
120 let n = 1 + Random.State.int rng 6 in
121 let fields_data =
122 List.init n (fun j ->
123 let ft =
124 field_types.(Random.State.int rng (Array.length field_types))
125 in
126 let name = Fmt.str "f%d" j in
127 let constraint_ =
128 if Random.State.int rng 4 = 0 then
129 let k = gen_constraint_val rng ft.wire_size in
130 Some Wire.Expr.(Wire.ref name <= Wire.int k)
131 else None
132 in
133 (ft.make_field name constraint_, ft.wire_size))
134 in
135 let wire_fields = List.map fst fields_data in
136 let wire_size = List.fold_left (fun acc (_, ws) -> acc + ws) 0 fields_data in
137 let struct_name = Fmt.str "Fuzz%d" i in
138 { struct_ = Wire.struct_ struct_name wire_fields; wire_size }
139
140(* ---- Stage 0: Generate C code ---- *)
141
142let generate_c_main schemas =
143 let buf = Buffer.create 4096 in
144 let ppf = Fmt.with_buffer buf in
145 let p fmt = Fmt.pf ppf (fmt ^^ "@\n") in
146 p "#include <stdio.h>";
147 p "#include <stdlib.h>";
148 p "#include <stdint.h>";
149 p "#include <string.h>";
150 p "#include \"wire.h\"";
151 p "#include \"WireReq.h\"";
152 p "#include \"WireResp.h\"";
153 List.iter
154 (fun rs ->
155 let name = Wire.struct_name rs.struct_ in
156 p "#include \"%s.h\"" name)
157 schemas;
158 p "";
159 p "/* roundtrip: read then write */";
160 p "static int32_t roundtrip(int idx, const uint8_t *buf, uint32_t len,";
161 p " uint8_t *out, uint32_t out_len) {";
162 p " switch (idx) {";
163 List.iteri
164 (fun i rs ->
165 let name = Wire.struct_name rs.struct_ in
166 p " case %d: {" i;
167 p " %s val;" name;
168 p " int32_t rc = %s_read(buf, len, &val);" name;
169 p " if (rc < 0) return rc;";
170 p " return %s_write(&val, out, out_len);" name;
171 p " }")
172 schemas;
173 p " default: return -100;";
174 p " }";
175 p "}";
176 p "";
177 p "int main(void) {";
178 p " uint8_t hdr_buf[8];";
179 p " for (;;) {";
180 p " if (fread(hdr_buf, 1, 8, stdin) != 8) break;";
181 p " WireReq req;";
182 p " if (WireReq_read(hdr_buf, 8, &req) < 0) break;";
183 p " uint8_t *data = malloc(req.length > 0 ? req.length : 1);";
184 p
185 " if (req.length > 0 && fread(data, 1, req.length, stdin) != \
186 req.length) { free(data); break; }";
187 p " uint8_t out[4096];";
188 p
189 " int32_t result = roundtrip((int)req.index, data, req.length, out, \
190 sizeof(out));";
191 p " free(data);";
192 p " WireResp resp;";
193 p " resp.result = (uint32_t)result;";
194 p " uint8_t resp_buf[4];";
195 p " WireResp_write(&resp, resp_buf, 4);";
196 p " fwrite(resp_buf, 1, 4, stdout);";
197 p " if (result > 0) fwrite(out, 1, (size_t)result, stdout);";
198 p " fflush(stdout);";
199 p " }";
200 p " return 0;";
201 p "}";
202 Fmt.flush ppf ();
203 Buffer.contents buf
204
205(* ---- Stage 1: Compile + start subprocess ---- *)
206
207type subprocess = { ic : in_channel; oc : out_channel }
208
209let send_request sub idx buf =
210 let len = String.length buf in
211 let hdr = { req_index = Int32.of_int idx; req_length = Int32.of_int len } in
212 let hdr_bytes = encode_request_hdr hdr in
213 output_string sub.oc hdr_bytes;
214 if len > 0 then output_string sub.oc buf;
215 flush sub.oc
216
217let recv_response sub =
218 let resp_buf = Bytes.create 4 in
219 really_input sub.ic resp_buf 0 4;
220 match decode_response_hdr resp_buf with
221 | Error _ -> None
222 | Ok resp ->
223 let result = Int32.to_int resp.resp_result in
224 if result < 0 then None
225 else begin
226 let out = Bytes.create result in
227 really_input sub.ic out 0 result;
228 Some (Bytes.to_string out)
229 end
230
231let c_roundtrip sub idx buf =
232 send_request sub idx buf;
233 recv_response sub
234
235(* ---- Stage 2: Crowbar tests ---- *)
236
237let pad wire_size buf =
238 if String.length buf >= wire_size then String.sub buf 0 wire_size
239 else
240 let b = Bytes.make wire_size '\000' in
241 Bytes.blit_string buf 0 b 0 (String.length buf);
242 Bytes.to_string b
243
244let () =
245 let seed =
246 match Sys.getenv_opt "D3T_FUZZ_SEED" with
247 | Some s -> int_of_string s
248 | None -> 42
249 in
250 let num_schemas = 50 in
251 let rng = Random.State.make [| seed |] in
252 let schemas = List.init num_schemas (fun i -> random_struct rng i) in
253
254 (* Stage 0: write C code to temp dir *)
255 let tmpdir = Filename.temp_dir "wire_fuzz" "" in
256
257 let write_file path contents =
258 let oc = open_out path in
259 output_string oc contents;
260 close_out oc
261 in
262 write_file (Filename.concat tmpdir "wire.h") (Wire.to_c_runtime ());
263
264 (* Protocol headers — generated by wire *)
265 Wire.to_c_header_file (Filename.concat tmpdir "WireReq.h") request_hdr_struct;
266 Wire.to_c_header_file
267 (Filename.concat tmpdir "WireResp.h")
268 response_hdr_struct;
269
270 List.iter
271 (fun rs ->
272 let name = Wire.struct_name rs.struct_ in
273 write_file
274 (Filename.concat tmpdir (name ^ ".h"))
275 (Wire.to_c_header rs.struct_))
276 schemas;
277
278 let c_main = generate_c_main schemas in
279 write_file (Filename.concat tmpdir "roundtrip.c") c_main;
280
281 (* Stage 1: compile *)
282 let exe_path = Filename.concat tmpdir "roundtrip" in
283 let cc_cmd =
284 Fmt.str "cc -O2 -o %s %s -I %s" (Filename.quote exe_path)
285 (Filename.quote (Filename.concat tmpdir "roundtrip.c"))
286 (Filename.quote tmpdir)
287 in
288 let rc = Sys.command cc_cmd in
289 if rc <> 0 then (
290 Fmt.epr "fuzz_diff: C compilation failed (exit %d)@.cmd: %s@." rc cc_cmd;
291 exit 1);
292
293 (* Start subprocess *)
294 let ic, oc = Unix.open_process exe_path in
295 let sub = { ic; oc } in
296
297 (* Stage 2: register Crowbar tests *)
298 Cr.run "diff"
299 (List.mapi
300 (fun idx rs ->
301 let name = Wire.struct_name rs.struct_ in
302 Cr.test_case (name ^ " fuzz-diff") [ Cr.bytes ] (fun buf ->
303 let buf = pad rs.wire_size buf in
304 let ocaml_result =
305 Wire_diff.Diff.roundtrip_struct rs.struct_ buf
306 in
307 let c_result = c_roundtrip sub idx buf in
308 match (ocaml_result, c_result) with
309 | Ok ocaml_bytes, Some c_bytes ->
310 if ocaml_bytes <> c_bytes then
311 Cr.fail
312 (Fmt.str
313 "%s: roundtrip mismatch (ocaml=%d bytes, c=%d bytes)"
314 name
315 (String.length ocaml_bytes)
316 (String.length c_bytes))
317 | Error _, None -> ()
318 | Ok _, None ->
319 Cr.fail (Fmt.str "%s: OCaml succeeded but C failed" name)
320 | Error e, Some _ ->
321 Cr.fail
322 (Fmt.str "%s: C succeeded but OCaml failed: %a" name
323 Wire.pp_parse_error e)))
324 schemas)