OCaml wire format DSL with EverParse 3D output for verified parsers
refactor: rename d3t to wire across codebase
Rename the d3t library to wire for clarity. Update all references
in bench, test, and library code across affected packages.
+741
-304
+22
-1
bench/bench_alloc.ml
+22
-1
bench/bench_alloc.ml
···
1
1
(** Micro-benchmark to identify Codec decode allocation sources. *)
2
2
3
-
open D3t
3
+
open Wire
4
4
5
5
type r3 = { a : int; b : int; c : int }
6
6
···
165
165
let _ =
166
166
Int32.of_int ((b0 lsl 24) lor (b1 lsl 16) lor (b2 lsl 8) lor b3)
167
167
in
168
+
());
169
+
170
+
Printf.printf "\nUInt32 (unboxed on 64-bit):\n";
171
+
measure "Wire.UInt32.get_be" n (fun () ->
172
+
let _ = Wire.UInt32.get_be buf4 0 in
173
+
());
174
+
measure "byte-by-byte int" n (fun () ->
175
+
let b0 = Bytes.get_uint8 buf4 0 in
176
+
let b1 = Bytes.get_uint8 buf4 1 in
177
+
let b2 = Bytes.get_uint8 buf4 2 in
178
+
let b3 = Bytes.get_uint8 buf4 3 in
179
+
let _ = (b0 lsl 24) lor (b1 lsl 16) lor (b2 lsl 8) lor b3 in
180
+
());
181
+
182
+
Printf.printf "\nUInt63 (unboxed on 64-bit):\n";
183
+
let buf8 = Bytes.create 8 in
184
+
measure "Bytes.get_int64_be (boxed)" n (fun () ->
185
+
let _ = Bytes.get_int64_be buf8 0 in
186
+
());
187
+
measure "Wire.UInt63.get_be" n (fun () ->
188
+
let _ = Wire.UInt63.get_be buf8 0 in
168
189
())
+27
-26
bench/bench_wire_memtrace.ml
+27
-26
bench/bench_wire_memtrace.ml
···
1
-
(** Memtrace allocation profiling for all 3 d3t codecs.
1
+
(** Memtrace allocation profiling for all 3 wire codecs.
2
2
3
-
Run with: MEMTRACE=d3t_clcw.ctf dune exec ./bench_d3t_memtrace.exe -- clcw
4
-
MEMTRACE=d3t_sp.ctf dune exec ./bench_d3t_memtrace.exe -- space-packet
5
-
MEMTRACE=d3t_tm.ctf dune exec ./bench_d3t_memtrace.exe -- tm
6
-
MEMTRACE=d3t_all.ctf dune exec ./bench_d3t_memtrace.exe -- all *)
3
+
Run with: MEMTRACE=wire_clcw.ctf dune exec ./bench_wire_memtrace.exe -- clcw
4
+
MEMTRACE=wire_sp.ctf dune exec ./bench_wire_memtrace.exe -- space-packet
5
+
MEMTRACE=wire_tm.ctf dune exec ./bench_wire_memtrace.exe -- tm
6
+
MEMTRACE=wire_all.ctf dune exec ./bench_wire_memtrace.exe -- all *)
7
7
8
8
let iterations = 10_000
9
9
···
24
24
Bytes.set_int32_be b 0 (Int32.of_int w);
25
25
b)
26
26
27
-
let clcw_d3t_vals =
28
-
Array.map (fun b -> D3t.Codec.decode Clcw_d3t.codec b 0) clcw_bytes
27
+
let clcw_wire_vals =
28
+
Array.map (fun b -> Wire.Codec.decode Clcw_wire.codec b 0) clcw_bytes
29
29
30
30
(** {1 Space Packet test data} *)
31
31
···
37
37
Bytes.set_uint16_be b 4 (i mod 256);
38
38
b)
39
39
40
-
let sp_d3t_vals = Array.map (fun b -> Space_packet_d3t.decode_exn b 0) sp_bytes
40
+
let sp_wire_vals =
41
+
Array.map (fun b -> Space_packet_wire.decode_exn b 0) sp_bytes
41
42
42
43
(** {1 TM test data} *)
43
44
···
54
55
Bytes.set_uint16_be b 4 ((1 lsl 14) lor (3 lsl 11) lor (i mod 2048));
55
56
b)
56
57
57
-
let tm_d3t_vals = Array.map (fun b -> Tm_d3t.decode_exn b 0) tm_bytes
58
+
let tm_wire_vals = Array.map (fun b -> Tm_wire.decode_exn b 0) tm_bytes
58
59
59
60
(** {1 Roundtrip loops} *)
60
61
61
62
let clcw_roundtrip () =
62
63
for i = 0 to Array.length clcw_bytes - 1 do
63
-
let t = D3t.Codec.decode Clcw_d3t.codec clcw_bytes.(i) 0 in
64
+
let t = Wire.Codec.decode Clcw_wire.codec clcw_bytes.(i) 0 in
64
65
let buf = Bytes.create 4 in
65
-
D3t.Codec.encode Clcw_d3t.codec t buf 0
66
+
Wire.Codec.encode Clcw_wire.codec t buf 0
66
67
done
67
68
68
69
let sp_roundtrip () =
69
70
for i = 0 to Array.length sp_bytes - 1 do
70
-
let t = Space_packet_d3t.decode_exn sp_bytes.(i) 0 in
71
+
let t = Space_packet_wire.decode_exn sp_bytes.(i) 0 in
71
72
let buf = Bytes.create 6 in
72
-
Space_packet_d3t.encode t buf 0
73
+
Space_packet_wire.encode t buf 0
73
74
done
74
75
75
76
let tm_roundtrip () =
76
77
for i = 0 to Array.length tm_bytes - 1 do
77
-
let t = Tm_d3t.decode_exn tm_bytes.(i) 0 in
78
+
let t = Tm_wire.decode_exn tm_bytes.(i) 0 in
78
79
let buf = Bytes.create 6 in
79
-
Tm_d3t.encode t buf 0
80
+
Tm_wire.encode t buf 0
80
81
done
81
82
82
83
(* Decode-only loops *)
83
84
let clcw_decode () =
84
85
for i = 0 to Array.length clcw_bytes - 1 do
85
-
let _ = D3t.Codec.decode Clcw_d3t.codec clcw_bytes.(i) 0 in
86
+
let _ = Wire.Codec.decode Clcw_wire.codec clcw_bytes.(i) 0 in
86
87
()
87
88
done
88
89
89
90
let sp_decode () =
90
91
for i = 0 to Array.length sp_bytes - 1 do
91
-
let _ = Space_packet_d3t.decode_exn sp_bytes.(i) 0 in
92
+
let _ = Space_packet_wire.decode_exn sp_bytes.(i) 0 in
92
93
()
93
94
done
94
95
95
96
let tm_decode () =
96
97
for i = 0 to Array.length tm_bytes - 1 do
97
-
let _ = Tm_d3t.decode_exn tm_bytes.(i) 0 in
98
+
let _ = Tm_wire.decode_exn tm_bytes.(i) 0 in
98
99
()
99
100
done
100
101
101
102
(* Encode-only loops *)
102
103
let clcw_encode () =
103
-
for i = 0 to Array.length clcw_d3t_vals - 1 do
104
+
for i = 0 to Array.length clcw_wire_vals - 1 do
104
105
let buf = Bytes.create 4 in
105
-
D3t.Codec.encode Clcw_d3t.codec clcw_d3t_vals.(i) buf 0
106
+
Wire.Codec.encode Clcw_wire.codec clcw_wire_vals.(i) buf 0
106
107
done
107
108
108
109
let sp_encode () =
109
-
for i = 0 to Array.length sp_d3t_vals - 1 do
110
+
for i = 0 to Array.length sp_wire_vals - 1 do
110
111
let buf = Bytes.create 6 in
111
-
Space_packet_d3t.encode sp_d3t_vals.(i) buf 0
112
+
Space_packet_wire.encode sp_wire_vals.(i) buf 0
112
113
done
113
114
114
115
let tm_encode () =
115
-
for i = 0 to Array.length tm_d3t_vals - 1 do
116
+
for i = 0 to Array.length tm_wire_vals - 1 do
116
117
let buf = Bytes.create 6 in
117
-
Tm_d3t.encode tm_d3t_vals.(i) buf 0
118
+
Tm_wire.encode tm_wire_vals.(i) buf 0
118
119
done
119
120
120
121
let run label decode encode roundtrip =
···
132
133
done
133
134
134
135
let () =
135
-
Memtrace.trace_if_requested ~context:"d3t-codecs" ();
136
+
Memtrace.trace_if_requested ~context:"wire-codecs" ();
136
137
137
138
let impl = if Array.length Sys.argv > 1 then Sys.argv.(1) else "all" in
138
139
139
-
Printf.printf "D3t Codec memtrace profiling (%s)\n%!" impl;
140
+
Printf.printf "Wire Codec memtrace profiling (%s)\n%!" impl;
140
141
Printf.printf "(%d iterations x 1000 values)\n\n%!" iterations;
141
142
142
143
(match impl with
+4
-4
bench/dune
+4
-4
bench/dune
···
1
1
(executable
2
-
(name bench_d3t_memtrace)
3
-
(modules bench_d3t_memtrace)
4
-
(libraries clcw-d3t space-packet.d3t tm-d3t memtrace))
2
+
(name bench_wire_memtrace)
3
+
(modules bench_wire_memtrace)
4
+
(libraries clcw-wire space-packet.wire tm-wire memtrace))
5
5
6
6
(executable
7
7
(name bench_alloc)
8
8
(modules bench_alloc)
9
-
(libraries d3t))
9
+
(libraries wire))
-34
d3t.opam
-34
d3t.opam
···
1
-
# This file is generated by dune, edit dune-project instead
2
-
opam-version: "2.0"
3
-
synopsis: "Dependent Data Descriptions for binary wire formats"
4
-
description:
5
-
"GADT-based DSL for describing binary wire formats with EverParse 3D output. Define your wire format once, then use it for OCaml parsing via bytesrw or emit .3d files for verified C parser generation via EverParse."
6
-
maintainer: ["Thomas Gazagnaire <thomas@gazagnaire.org>"]
7
-
authors: ["Thomas Gazagnaire <thomas@gazagnaire.org>"]
8
-
license: "ISC"
9
-
homepage: "https://tangled.org/gazagnaire.org/ocaml-d3t"
10
-
bug-reports: "https://tangled.org/gazagnaire.org/ocaml-d3t/issues"
11
-
depends: [
12
-
"dune" {>= "3.21"}
13
-
"ocaml" {>= "5.1"}
14
-
"bytesrw" {>= "0.1"}
15
-
"fmt" {>= "0.9"}
16
-
"alcotest" {with-test}
17
-
"odoc" {with-doc}
18
-
]
19
-
build: [
20
-
["dune" "subst"] {dev}
21
-
[
22
-
"dune"
23
-
"build"
24
-
"-p"
25
-
name
26
-
"-j"
27
-
jobs
28
-
"@install"
29
-
"@runtest" {with-test}
30
-
"@doc" {with-doc}
31
-
]
32
-
]
33
-
dev-repo: "git+https://tangled.org/gazagnaire.org/ocaml-d3t"
34
-
x-maintenance-intent: ["(latest)"]
+5
-5
dune-project
+5
-5
dune-project
···
1
1
(lang dune 3.21)
2
2
(using directory-targets 0.1)
3
3
4
-
(name d3t)
4
+
(name wire)
5
5
6
6
(generate_opam_files true)
7
7
···
9
9
(authors "Thomas Gazagnaire <thomas@gazagnaire.org>")
10
10
(maintainers "Thomas Gazagnaire <thomas@gazagnaire.org>")
11
11
12
-
(source (tangled gazagnaire.org/ocaml-d3t))
12
+
(source (tangled gazagnaire.org/ocaml-wire))
13
13
14
14
(package
15
-
(name d3t)
16
-
(synopsis "Dependent Data Descriptions for binary wire formats")
15
+
(name wire)
16
+
(synopsis "Binary wire format DSL with EverParse 3D output")
17
17
(description
18
-
"GADT-based DSL for describing binary wire formats with EverParse 3D output. \
18
+
"OCaml DSL for describing binary wire formats with EverParse 3D output. \
19
19
Define your wire format once, then use it for OCaml parsing via bytesrw or \
20
20
emit .3d files for verified C parser generation via EverParse.")
21
21
(depends
+7
-7
fuzz/dune
+7
-7
fuzz/dune
···
1
1
(executable
2
-
(name fuzz_d3t)
3
-
(modules fuzz_d3t)
4
-
(libraries d3t crowbar))
2
+
(name fuzz_wire)
3
+
(modules fuzz_wire)
4
+
(libraries wire crowbar))
5
5
6
6
; Quick check with Crowbar (no AFL instrumentation)
7
7
8
8
(rule
9
9
(alias fuzz)
10
-
(deps fuzz_d3t.exe)
10
+
(deps fuzz_wire.exe)
11
11
(action
12
-
(run %{exe:fuzz_d3t.exe})))
12
+
(run %{exe:fuzz_wire.exe})))
13
13
14
14
; AFL-instrumented build target (use with --profile=afl)
15
15
···
17
17
(alias fuzz-afl)
18
18
(deps
19
19
(source_tree input)
20
-
fuzz_d3t.exe)
20
+
fuzz_wire.exe)
21
21
(action
22
-
(echo "AFL fuzzer built: %{exe:fuzz_d3t.exe}\n")))
22
+
(echo "AFL fuzzer built: %{exe:fuzz_wire.exe}\n")))
+43
-42
fuzz/fuzz_wire.ml
+43
-42
fuzz/fuzz_wire.ml
···
1
-
(** Fuzz tests for d3t library.
1
+
(** Fuzz tests for wire library.
2
2
3
-
Since d3t is primarily a code generator (OCaml -> 3D format), the main fuzz
3
+
Since wire is primarily a code generator (OCaml -> 3D format), the main fuzz
4
4
targets are: 1. Pretty-printer crash safety - ensuring pp functions don't
5
5
crash 2. Future: differential testing against EverParse parser once we add a
6
6
bytesrw parsing backend *)
7
7
8
8
module Cr = Crowbar
9
-
open D3t
9
+
open Wire
10
10
11
11
(* Silence unused variable warnings for parse error handling *)
12
12
let _ = pp_parse_error
···
317
317
318
318
(** {1 Record Codec Tests} *)
319
319
320
-
type test_record = { x : int; y : int; z : int32 }
320
+
type test_record = { x : int; y : int; z : int }
321
321
322
322
let test_record_codec =
323
323
let open Codec in
···
350
350
351
351
let () =
352
352
(* Pretty-printing tests *)
353
-
Cr.add_test ~name:"d3t: pp_typ uint8" [ Cr.const () ] test_pp_uint8;
354
-
Cr.add_test ~name:"d3t: pp_typ uint16" [ Cr.const () ] test_pp_uint16;
355
-
Cr.add_test ~name:"d3t: pp_typ uint32" [ Cr.const () ] test_pp_uint32;
356
-
Cr.add_test ~name:"d3t: pp_bitfield" [ Cr.range 33 ] test_pp_bitfield;
357
-
Cr.add_test ~name:"d3t: pp_module_simple"
353
+
Cr.add_test ~name:"wire: pp_typ uint8" [ Cr.const () ] test_pp_uint8;
354
+
Cr.add_test ~name:"wire: pp_typ uint16" [ Cr.const () ] test_pp_uint16;
355
+
Cr.add_test ~name:"wire: pp_typ uint32" [ Cr.const () ] test_pp_uint32;
356
+
Cr.add_test ~name:"wire: pp_bitfield" [ Cr.range 33 ] test_pp_bitfield;
357
+
Cr.add_test ~name:"wire: pp_module_simple"
358
358
[ Cr.const () ]
359
359
test_pp_module_simple;
360
-
Cr.add_test ~name:"d3t: struct_random_fields"
360
+
Cr.add_test ~name:"wire: struct_random_fields"
361
361
[ Cr.range 100 ]
362
362
test_struct_random_fields;
363
-
Cr.add_test ~name:"d3t: enum_random_cases"
363
+
Cr.add_test ~name:"wire: enum_random_cases"
364
364
[ Cr.range 100 ]
365
365
test_enum_random_cases;
366
-
Cr.add_test ~name:"d3t: casetype_random" [ Cr.range 100 ] test_casetype_random;
367
-
Cr.add_test ~name:"d3t: constraint_expr" [ Cr.int ] test_constraint_expr;
368
-
Cr.add_test ~name:"d3t: bitfield_constraint"
366
+
Cr.add_test ~name:"wire: casetype_random"
367
+
[ Cr.range 100 ]
368
+
test_casetype_random;
369
+
Cr.add_test ~name:"wire: constraint_expr" [ Cr.int ] test_constraint_expr;
370
+
Cr.add_test ~name:"wire: bitfield_constraint"
369
371
[ Cr.range 32 ]
370
372
test_bitfield_constraint;
371
-
Cr.add_test ~name:"d3t: array_type" [ Cr.int ] test_array_type;
372
-
Cr.add_test ~name:"d3t: byte_array" [ Cr.int ] test_byte_array;
373
-
Cr.add_test ~name:"d3t: param_struct" [ Cr.range 20 ] test_param_struct;
374
-
Cr.add_test ~name:"d3t: action" [ Cr.const () ] test_action;
375
-
Cr.add_test ~name:"d3t: complex_nested" [ Cr.const () ] test_complex_nested;
373
+
Cr.add_test ~name:"wire: array_type" [ Cr.int ] test_array_type;
374
+
Cr.add_test ~name:"wire: byte_array" [ Cr.int ] test_byte_array;
375
+
Cr.add_test ~name:"wire: param_struct" [ Cr.range 20 ] test_param_struct;
376
+
Cr.add_test ~name:"wire: action" [ Cr.const () ] test_action;
377
+
Cr.add_test ~name:"wire: complex_nested" [ Cr.const () ] test_complex_nested;
376
378
377
379
(* Parsing tests *)
378
-
Cr.add_test ~name:"d3t: parse uint8" [ Cr.bytes ] test_parse_uint8;
379
-
Cr.add_test ~name:"d3t: parse uint16" [ Cr.bytes ] test_parse_uint16;
380
-
Cr.add_test ~name:"d3t: parse uint32" [ Cr.bytes ] test_parse_uint32;
381
-
Cr.add_test ~name:"d3t: parse uint64" [ Cr.bytes ] test_parse_uint64;
382
-
Cr.add_test ~name:"d3t: parse bitfield" [ Cr.bytes ] test_parse_bitfield;
383
-
Cr.add_test ~name:"d3t: parse array" [ Cr.bytes ] test_parse_array;
384
-
Cr.add_test ~name:"d3t: parse byte_array" [ Cr.bytes ] test_parse_byte_array;
385
-
Cr.add_test ~name:"d3t: parse enum" [ Cr.bytes ] test_parse_enum;
386
-
Cr.add_test ~name:"d3t: parse where" [ Cr.bytes ] test_parse_where;
387
-
Cr.add_test ~name:"d3t: parse all_bytes" [ Cr.bytes ] test_parse_all_bytes;
388
-
Cr.add_test ~name:"d3t: parse all_zeros" [ Cr.bytes ] test_parse_all_zeros;
389
-
Cr.add_test ~name:"d3t: parse struct" [ Cr.bytes ] test_parse_struct;
390
-
Cr.add_test ~name:"d3t: parse struct_constrained" [ Cr.bytes ]
380
+
Cr.add_test ~name:"wire: parse uint8" [ Cr.bytes ] test_parse_uint8;
381
+
Cr.add_test ~name:"wire: parse uint16" [ Cr.bytes ] test_parse_uint16;
382
+
Cr.add_test ~name:"wire: parse uint32" [ Cr.bytes ] test_parse_uint32;
383
+
Cr.add_test ~name:"wire: parse uint64" [ Cr.bytes ] test_parse_uint64;
384
+
Cr.add_test ~name:"wire: parse bitfield" [ Cr.bytes ] test_parse_bitfield;
385
+
Cr.add_test ~name:"wire: parse array" [ Cr.bytes ] test_parse_array;
386
+
Cr.add_test ~name:"wire: parse byte_array" [ Cr.bytes ] test_parse_byte_array;
387
+
Cr.add_test ~name:"wire: parse enum" [ Cr.bytes ] test_parse_enum;
388
+
Cr.add_test ~name:"wire: parse where" [ Cr.bytes ] test_parse_where;
389
+
Cr.add_test ~name:"wire: parse all_bytes" [ Cr.bytes ] test_parse_all_bytes;
390
+
Cr.add_test ~name:"wire: parse all_zeros" [ Cr.bytes ] test_parse_all_zeros;
391
+
Cr.add_test ~name:"wire: parse struct" [ Cr.bytes ] test_parse_struct;
392
+
Cr.add_test ~name:"wire: parse struct_constrained" [ Cr.bytes ]
391
393
test_parse_struct_constrained;
392
394
393
395
(* Roundtrip tests *)
394
-
Cr.add_test ~name:"d3t: roundtrip uint8" [ Cr.int ] test_roundtrip_uint8;
395
-
Cr.add_test ~name:"d3t: roundtrip uint16" [ Cr.int ] test_roundtrip_uint16;
396
-
Cr.add_test ~name:"d3t: roundtrip uint32" [ Cr.int32 ] test_roundtrip_uint32;
397
-
Cr.add_test ~name:"d3t: roundtrip uint64" [ Cr.int64 ] test_roundtrip_uint64;
398
-
Cr.add_test ~name:"d3t: roundtrip array" [ Cr.int; Cr.int; Cr.int ]
396
+
Cr.add_test ~name:"wire: roundtrip uint8" [ Cr.int ] test_roundtrip_uint8;
397
+
Cr.add_test ~name:"wire: roundtrip uint16" [ Cr.int ] test_roundtrip_uint16;
398
+
Cr.add_test ~name:"wire: roundtrip uint32" [ Cr.int ] test_roundtrip_uint32;
399
+
Cr.add_test ~name:"wire: roundtrip uint64" [ Cr.int64 ] test_roundtrip_uint64;
400
+
Cr.add_test ~name:"wire: roundtrip array" [ Cr.int; Cr.int; Cr.int ]
399
401
test_roundtrip_array;
400
-
Cr.add_test ~name:"d3t: roundtrip byte_array" [ Cr.bytes ]
402
+
Cr.add_test ~name:"wire: roundtrip byte_array" [ Cr.bytes ]
401
403
test_roundtrip_byte_array;
402
-
Cr.add_test ~name:"d3t: roundtrip enum" [ Cr.int ] test_roundtrip_enum;
404
+
Cr.add_test ~name:"wire: roundtrip enum" [ Cr.int ] test_roundtrip_enum;
403
405
404
406
(* Record codec tests *)
405
-
Cr.add_test ~name:"d3t: record roundtrip"
406
-
[ Cr.int; Cr.int; Cr.int32 ]
407
+
Cr.add_test ~name:"wire: record roundtrip" [ Cr.int; Cr.int; Cr.int ]
407
408
test_record_roundtrip;
408
-
Cr.add_test ~name:"d3t: record decode crash" [ Cr.bytes ]
409
+
Cr.add_test ~name:"wire: record decode crash" [ Cr.bytes ]
409
410
test_record_decode_crash
+8
-8
lib/diff/diff.ml
+8
-8
lib/diff/diff.ml
···
1
-
(** Generic differential testing: OCaml codec vs d3t-generated C code.
1
+
(** Generic differential testing: OCaml codec vs wire-generated C code.
2
2
3
3
Each schema needs [c_read] and [c_write] functions (generated by
4
-
{!D3t.to_c_stubs} and {!D3t.to_ml_stub}). All diff logic is generic over any
5
-
record codec. *)
4
+
{!Wire.to_c_stubs} and {!Wire.to_ml_stub}). All diff logic is generic over
5
+
any record codec. *)
6
6
7
7
type 'r schema = {
8
8
name : string;
···
15
15
}
16
16
17
17
let schema ~name ~codec ~c_read ~c_write ~equal =
18
-
let wire_size = D3t.Codec.wire_size codec in
18
+
let wire_size = Wire.Codec.wire_size codec in
19
19
{
20
20
name;
21
21
c_read;
22
22
c_write;
23
23
equal;
24
-
codec_decode = D3t.Codec.decode codec;
25
-
codec_encode = D3t.Codec.encode codec;
24
+
codec_decode = Wire.Codec.decode codec;
25
+
codec_encode = Wire.Codec.encode codec;
26
26
wire_size;
27
27
}
28
28
···
79
79
else Value_mismatch "values differ after full roundtrip"
80
80
81
81
let roundtrip_struct s buf =
82
-
match D3t.read_struct s buf with
82
+
match Wire.read_struct s buf with
83
83
| Error e -> Error e
84
-
| Ok ps -> D3t.write_struct s ps
84
+
| Ok ps -> Wire.write_struct s ps
85
85
86
86
type packed_test = {
87
87
name : string;
+3
-3
lib/diff/diff.mli
+3
-3
lib/diff/diff.mli
···
1
-
(** Generic differential testing: OCaml codec vs d3t-generated C code. *)
1
+
(** Generic differential testing: OCaml codec vs wire-generated C code. *)
2
2
3
3
val roundtrip_struct :
4
-
D3t.struct_ -> string -> (string, D3t.parse_error) Stdlib.result
4
+
Wire.struct_ -> string -> (string, Wire.parse_error) Stdlib.result
5
5
(** [roundtrip_struct s buf] parses [buf] as struct [s] and re-encodes it.
6
6
Equivalent to [write_struct s (read_struct s buf)]. *)
7
7
···
10
10
11
11
val schema :
12
12
name:string ->
13
-
codec:'r D3t.Codec.t ->
13
+
codec:'r Wire.Codec.t ->
14
14
c_read:(string -> string option) ->
15
15
c_write:(string -> string option) ->
16
16
equal:('r -> 'r -> bool) ->
+3
-3
lib/diff/dune
+3
-3
lib/diff/dune
+2
-2
lib/dune
+2
-2
lib/dune
+193
-38
lib/wire.ml
+193
-38
lib/wire.ml
···
1
-
(* D3t: Dependent Data Descriptions for EverParse 3D *)
1
+
(* Wire: Dependent Data Descriptions for EverParse 3D *)
2
2
3
3
open Result.Syntax
4
4
···
12
12
let unstage { unstage } = unstage
13
13
end
14
14
15
+
(* UInt32: unboxed on 64-bit (uses int), boxed on 32-bit (uses int32) *)
16
+
module UInt32 = struct
17
+
type t = int (* On 64-bit, int is 63 bits - enough for uint32 *)
18
+
19
+
let () =
20
+
if Sys.int_size < 32 then
21
+
failwith "Wire.UInt32 requires 64-bit OCaml (int must be >= 32 bits)"
22
+
23
+
let get_le buf off =
24
+
let b0 = Bytes.get_uint8 buf off in
25
+
let b1 = Bytes.get_uint8 buf (off + 1) in
26
+
let b2 = Bytes.get_uint8 buf (off + 2) in
27
+
let b3 = Bytes.get_uint8 buf (off + 3) in
28
+
b0 lor (b1 lsl 8) lor (b2 lsl 16) lor (b3 lsl 24)
29
+
30
+
let get_be buf off =
31
+
let b0 = Bytes.get_uint8 buf off in
32
+
let b1 = Bytes.get_uint8 buf (off + 1) in
33
+
let b2 = Bytes.get_uint8 buf (off + 2) in
34
+
let b3 = Bytes.get_uint8 buf (off + 3) in
35
+
(b0 lsl 24) lor (b1 lsl 16) lor (b2 lsl 8) lor b3
36
+
37
+
let set_le buf off v =
38
+
Bytes.set_uint8 buf off (v land 0xFF);
39
+
Bytes.set_uint8 buf (off + 1) ((v lsr 8) land 0xFF);
40
+
Bytes.set_uint8 buf (off + 2) ((v lsr 16) land 0xFF);
41
+
Bytes.set_uint8 buf (off + 3) ((v lsr 24) land 0xFF)
42
+
43
+
let set_be buf off v =
44
+
Bytes.set_uint8 buf off ((v lsr 24) land 0xFF);
45
+
Bytes.set_uint8 buf (off + 1) ((v lsr 16) land 0xFF);
46
+
Bytes.set_uint8 buf (off + 2) ((v lsr 8) land 0xFF);
47
+
Bytes.set_uint8 buf (off + 3) (v land 0xFF)
48
+
49
+
let to_int t = t
50
+
let of_int t = t
51
+
end
52
+
53
+
(* UInt63: unboxed on 64-bit (uses int), reads 8 bytes but masks to 63 bits *)
54
+
module UInt63 = struct
55
+
type t = int (* 63-bit int on 64-bit platforms *)
56
+
57
+
let () =
58
+
if Sys.int_size < 63 then
59
+
failwith "Wire.UInt63 requires 64-bit OCaml (int must be 63 bits)"
60
+
61
+
let get_le buf off =
62
+
let b0 = Bytes.get_uint8 buf off in
63
+
let b1 = Bytes.get_uint8 buf (off + 1) in
64
+
let b2 = Bytes.get_uint8 buf (off + 2) in
65
+
let b3 = Bytes.get_uint8 buf (off + 3) in
66
+
let b4 = Bytes.get_uint8 buf (off + 4) in
67
+
let b5 = Bytes.get_uint8 buf (off + 5) in
68
+
let b6 = Bytes.get_uint8 buf (off + 6) in
69
+
let b7 = Bytes.get_uint8 buf (off + 7) in
70
+
b0 lor (b1 lsl 8) lor (b2 lsl 16) lor (b3 lsl 24) lor (b4 lsl 32)
71
+
lor (b5 lsl 40) lor (b6 lsl 48)
72
+
lor ((b7 land 0x7F) lsl 56)
73
+
74
+
let get_be buf off =
75
+
let b0 = Bytes.get_uint8 buf off in
76
+
let b1 = Bytes.get_uint8 buf (off + 1) in
77
+
let b2 = Bytes.get_uint8 buf (off + 2) in
78
+
let b3 = Bytes.get_uint8 buf (off + 3) in
79
+
let b4 = Bytes.get_uint8 buf (off + 4) in
80
+
let b5 = Bytes.get_uint8 buf (off + 5) in
81
+
let b6 = Bytes.get_uint8 buf (off + 6) in
82
+
let b7 = Bytes.get_uint8 buf (off + 7) in
83
+
((b0 land 0x7F) lsl 56)
84
+
lor (b1 lsl 48) lor (b2 lsl 40) lor (b3 lsl 32) lor (b4 lsl 24)
85
+
lor (b5 lsl 16) lor (b6 lsl 8) lor b7
86
+
87
+
let set_le buf off v =
88
+
Bytes.set_uint8 buf off (v land 0xFF);
89
+
Bytes.set_uint8 buf (off + 1) ((v lsr 8) land 0xFF);
90
+
Bytes.set_uint8 buf (off + 2) ((v lsr 16) land 0xFF);
91
+
Bytes.set_uint8 buf (off + 3) ((v lsr 24) land 0xFF);
92
+
Bytes.set_uint8 buf (off + 4) ((v lsr 32) land 0xFF);
93
+
Bytes.set_uint8 buf (off + 5) ((v lsr 40) land 0xFF);
94
+
Bytes.set_uint8 buf (off + 6) ((v lsr 48) land 0xFF);
95
+
Bytes.set_uint8 buf (off + 7) ((v lsr 56) land 0x7F)
96
+
97
+
let set_be buf off v =
98
+
Bytes.set_uint8 buf off ((v lsr 56) land 0x7F);
99
+
Bytes.set_uint8 buf (off + 1) ((v lsr 48) land 0xFF);
100
+
Bytes.set_uint8 buf (off + 2) ((v lsr 40) land 0xFF);
101
+
Bytes.set_uint8 buf (off + 3) ((v lsr 32) land 0xFF);
102
+
Bytes.set_uint8 buf (off + 4) ((v lsr 24) land 0xFF);
103
+
Bytes.set_uint8 buf (off + 5) ((v lsr 16) land 0xFF);
104
+
Bytes.set_uint8 buf (off + 6) ((v lsr 8) land 0xFF);
105
+
Bytes.set_uint8 buf (off + 7) (v land 0xFF)
106
+
107
+
let to_int t = t
108
+
let of_int t = t
109
+
end
110
+
15
111
type endian = Little | Big
16
112
17
113
(* Expressions *)
···
52
148
and _ typ =
53
149
| Uint8 : int typ
54
150
| Uint16 : endian -> int typ
55
-
| Uint32 : endian -> int32 typ
56
-
| Uint64 : endian -> int64 typ
151
+
| Uint32 : endian -> UInt32.t typ
152
+
| Uint63 : endian -> UInt63.t typ
153
+
| Uint64 : endian -> int64 typ (* boxed, for full 64-bit *)
57
154
| Bits : { width : int; base : bitfield_base } -> int typ
58
155
| Unit : unit typ
59
156
| All_bytes : string typ
···
153
250
let uint16be = Uint16 Big
154
251
let uint32 = Uint32 Little
155
252
let uint32be = Uint32 Big
253
+
let uint63 = Uint63 Little
254
+
let uint63be = Uint63 Big
156
255
let uint64 = Uint64 Little
157
256
let uint64be = Uint64 Big
158
257
···
318
417
| Uint8 -> Fmt.string ppf "UINT8"
319
418
| Uint16 e -> Fmt.pf ppf "UINT16%a" pp_endian e
320
419
| Uint32 e -> Fmt.pf ppf "UINT32%a" pp_endian e
420
+
| Uint63 e -> Fmt.pf ppf "UINT63%a" pp_endian e
321
421
| Uint64 e -> Fmt.pf ppf "UINT64%a" pp_endian e
322
422
| Bits { base; _ } -> pp_bitfield_base ppf base
323
423
| Unit -> Fmt.string ppf "unit"
···
531
631
match typ with
532
632
| Uint8 -> v
533
633
| Uint16 _ -> v
534
-
| Uint32 _ ->
535
-
(* Unsigned interpretation — on 64-bit OCaml this always succeeds *)
536
-
Int32.unsigned_to_int v |> Option.get
634
+
| Uint32 _ -> UInt32.to_int v
635
+
| Uint63 _ -> UInt63.to_int v
537
636
| Uint64 _ ->
538
637
(* Unsigned interpretation — values >= 2^62 don't fit in OCaml int,
539
638
return max_int so constraints [value <= K] fail correctly *)
···
734
833
| Uint8 -> parse_int dec 1 Bytes.get_uint8 ctx
735
834
| Uint16 Little -> parse_int dec 2 Bytes.get_uint16_le ctx
736
835
| Uint16 Big -> parse_int dec 2 Bytes.get_uint16_be ctx
737
-
| Uint32 Little -> parse_int dec 4 Bytes.get_int32_le ctx
738
-
| Uint32 Big -> parse_int dec 4 Bytes.get_int32_be ctx
836
+
| Uint32 Little -> parse_int dec 4 UInt32.get_le ctx
837
+
| Uint32 Big -> parse_int dec 4 UInt32.get_be ctx
838
+
| Uint63 Little -> parse_int dec 8 UInt63.get_le ctx
839
+
| Uint63 Big -> parse_int dec 8 UInt63.get_be ctx
739
840
| Uint64 Little -> parse_int dec 8 Bytes.get_int64_le ctx
740
841
| Uint64 Big -> parse_int dec 8 Bytes.get_int64_be ctx
741
842
| Bits { width; base } -> (
···
917
1018
Bytes.set_int32_be enc.buf 0 v;
918
1019
write_slice enc 4
919
1020
1021
+
let write_uint32_le enc v =
1022
+
UInt32.set_le enc.buf 0 v;
1023
+
write_slice enc 4
1024
+
1025
+
let write_uint32_be enc v =
1026
+
UInt32.set_be enc.buf 0 v;
1027
+
write_slice enc 4
1028
+
920
1029
let write_int64_le enc v =
921
1030
Bytes.set_int64_le enc.buf 0 v;
922
1031
write_slice enc 8
···
925
1034
Bytes.set_int64_be enc.buf 0 v;
926
1035
write_slice enc 8
927
1036
1037
+
let write_uint63_le enc v =
1038
+
UInt63.set_le enc.buf 0 v;
1039
+
write_slice enc 8
1040
+
1041
+
let write_uint63_be enc v =
1042
+
UInt63.set_be enc.buf 0 v;
1043
+
write_slice enc 8
1044
+
928
1045
let write_string enc s = Bw.write_string enc.writer s
929
1046
930
1047
let rec encode_with_ctx : type a. ctx -> a typ -> a -> encoder -> ctx =
···
940
1057
write_uint16_be enc v;
941
1058
ctx
942
1059
| Uint32 Little ->
943
-
write_int32_le enc v;
1060
+
write_uint32_le enc v;
944
1061
ctx
945
1062
| Uint32 Big ->
946
-
write_int32_be enc v;
1063
+
write_uint32_be enc v;
1064
+
ctx
1065
+
| Uint63 Little ->
1066
+
write_uint63_le enc v;
1067
+
ctx
1068
+
| Uint63 Big ->
1069
+
write_uint63_be enc v;
947
1070
ctx
948
1071
| Uint64 Little ->
949
1072
write_int64_le enc v;
···
1064
1187
off + 2
1065
1188
| Uint32 Little ->
1066
1189
fun buf off v ->
1067
-
Bytes.set_int32_le buf off v;
1190
+
UInt32.set_le buf off v;
1068
1191
off + 4
1069
1192
| Uint32 Big ->
1070
1193
fun buf off v ->
1071
-
Bytes.set_int32_be buf off v;
1194
+
UInt32.set_be buf off v;
1072
1195
off + 4
1196
+
| Uint63 Little ->
1197
+
fun buf off v ->
1198
+
UInt63.set_le buf off v;
1199
+
off + 8
1200
+
| Uint63 Big ->
1201
+
fun buf off v ->
1202
+
UInt63.set_be buf off v;
1203
+
off + 8
1073
1204
| Uint64 Little ->
1074
1205
fun buf off v ->
1075
1206
Bytes.set_int64_le buf off v;
···
1097
1228
| Uint16 Big ->
1098
1229
fun buf base off -> (Bytes.get_uint16_be buf (base + off), off + 2)
1099
1230
| Uint32 Little ->
1100
-
fun buf base off -> (Bytes.get_int32_le buf (base + off), off + 4)
1101
-
| Uint32 Big ->
1102
-
fun buf base off -> (Bytes.get_int32_be buf (base + off), off + 4)
1231
+
fun buf base off -> (UInt32.get_le buf (base + off), off + 4)
1232
+
| Uint32 Big -> fun buf base off -> (UInt32.get_be buf (base + off), off + 4)
1233
+
| Uint63 Little ->
1234
+
fun buf base off -> (UInt63.get_le buf (base + off), off + 8)
1235
+
| Uint63 Big -> fun buf base off -> (UInt63.get_be buf (base + off), off + 8)
1103
1236
| Uint64 Little ->
1104
1237
fun buf base off -> (Bytes.get_int64_le buf (base + off), off + 8)
1105
1238
| Uint64 Big ->
···
1134
1267
v
1135
1268
| Uint32 Little ->
1136
1269
fun buf base off ->
1137
-
let v = Bytes.get_int32_le buf (base + !off) in
1270
+
let v = UInt32.get_le buf (base + !off) in
1138
1271
off := !off + 4;
1139
1272
v
1140
1273
| Uint32 Big ->
1141
1274
fun buf base off ->
1142
-
let v = Bytes.get_int32_be buf (base + !off) in
1275
+
let v = UInt32.get_be buf (base + !off) in
1143
1276
off := !off + 4;
1144
1277
v
1278
+
| Uint63 Little ->
1279
+
fun buf base off ->
1280
+
let v = UInt63.get_le buf (base + !off) in
1281
+
off := !off + 8;
1282
+
v
1283
+
| Uint63 Big ->
1284
+
fun buf base off ->
1285
+
let v = UInt63.get_be buf (base + !off) in
1286
+
off := !off + 8;
1287
+
v
1145
1288
| Uint64 Little ->
1146
1289
fun buf base off ->
1147
1290
let v = Bytes.get_int64_le buf (base + !off) in
···
1183
1326
k v
1184
1327
| Uint32 Little ->
1185
1328
fun buf base off k ->
1186
-
let v = Bytes.get_int32_le buf (base + !off) in
1329
+
let v = UInt32.get_le buf (base + !off) in
1187
1330
off := !off + 4;
1188
1331
k v
1189
1332
| Uint32 Big ->
1190
1333
fun buf base off k ->
1191
-
let v = Bytes.get_int32_be buf (base + !off) in
1334
+
let v = UInt32.get_be buf (base + !off) in
1192
1335
off := !off + 4;
1193
1336
k v
1337
+
| Uint63 Little ->
1338
+
fun buf base off k ->
1339
+
let v = UInt63.get_le buf (base + !off) in
1340
+
off := !off + 8;
1341
+
k v
1342
+
| Uint63 Big ->
1343
+
fun buf base off k ->
1344
+
let v = UInt63.get_be buf (base + !off) in
1345
+
off := !off + 8;
1346
+
k v
1194
1347
| Uint64 Little ->
1195
1348
fun buf base off k ->
1196
1349
let v = Bytes.get_int64_le buf (base + !off) in
···
1445
1598
| Uint8 -> fun buf base -> Bytes.get_uint8 buf (base + field_off)
1446
1599
| Uint16 Little -> fun buf base -> Bytes.get_uint16_le buf (base + field_off)
1447
1600
| Uint16 Big -> fun buf base -> Bytes.get_uint16_be buf (base + field_off)
1448
-
| Uint32 Little -> fun buf base -> Bytes.get_int32_le buf (base + field_off)
1449
-
| Uint32 Big -> fun buf base -> Bytes.get_int32_be buf (base + field_off)
1601
+
| Uint32 Little -> fun buf base -> UInt32.get_le buf (base + field_off)
1602
+
| Uint32 Big -> fun buf base -> UInt32.get_be buf (base + field_off)
1603
+
| Uint63 Little -> fun buf base -> UInt63.get_le buf (base + field_off)
1604
+
| Uint63 Big -> fun buf base -> UInt63.get_be buf (base + field_off)
1450
1605
| Uint64 Little -> fun buf base -> Bytes.get_int64_le buf (base + field_off)
1451
1606
| Uint64 Big -> fun buf base -> Bytes.get_int64_be buf (base + field_off)
1452
1607
| Where { inner; _ } -> build_field_reader inner field_off
···
1648
1803
1649
1804
(* ==================== EverParse FFI Helpers ==================== *)
1650
1805
1651
-
(* NOTE: d3t does NOT generate C parsing code. C parsers come from EverParse.
1806
+
(* NOTE: wire does NOT generate C parsing code. C parsers come from EverParse.
1652
1807
This section provides helpers for generating OCaml FFI stubs that call
1653
1808
EverParse-generated C code.
1654
1809
1655
1810
Workflow:
1656
-
1. Define schema in OCaml using d3t
1811
+
1. Define schema in OCaml using wire
1657
1812
2. Generate .3d file with to_3d
1658
1813
3. Run EverParse to generate C parser (.h with struct + read/write)
1659
1814
4. Use to_c_stubs to generate OCaml FFI bindings to call EverParse C *)
···
1688
1843
| _ -> None)
1689
1844
(Some 0) s.fields
1690
1845
1691
-
(** OCaml type name for a d3t type (for generated external declarations). *)
1846
+
(** OCaml type name for a wire type (for generated external declarations). *)
1692
1847
let rec ml_type_of : type a. a typ -> string = function
1693
1848
| Uint8 -> "int"
1694
1849
| Uint16 _ -> "int"
···
1743
1898
let c_stub_read ppf (s : struct_) fields =
1744
1899
let n = List.length fields in
1745
1900
let has_boxed = List.exists (fun (Named (_, typ)) -> is_boxed typ) fields in
1746
-
Fmt.pf ppf "CAMLprim value caml_d3t_%s_read(value v_buf) {@\n" s.name;
1901
+
Fmt.pf ppf "CAMLprim value caml_wire_%s_read(value v_buf) {@\n" s.name;
1747
1902
Fmt.pf ppf " CAMLparam1(v_buf);@\n";
1748
1903
if has_boxed then Fmt.pf ppf " CAMLlocal3(v_some, v_tuple, v_tmp);@\n"
1749
1904
else Fmt.pf ppf " CAMLlocal2(v_some, v_tuple);@\n";
···
1772
1927
EverParse-generated [Name_write] function. *)
1773
1928
let c_stub_write ppf (s : struct_) fields =
1774
1929
let sz = match wire_size_of_struct s with Some n -> n | None -> 4096 in
1775
-
Fmt.pf ppf "CAMLprim value caml_d3t_%s_write(value v_tuple) {@\n" s.name;
1930
+
Fmt.pf ppf "CAMLprim value caml_wire_%s_write(value v_tuple) {@\n" s.name;
1776
1931
Fmt.pf ppf " CAMLparam1(v_tuple);@\n";
1777
1932
Fmt.pf ppf " CAMLlocal2(v_some, v_str);@\n";
1778
1933
Fmt.pf ppf " %s val;@\n" s.name;
···
1795
1950
[Name_write].
1796
1951
1797
1952
For each struct [Foo] with fields [a : t1, b : t2, ...], generates:
1798
-
- [caml_d3t_Foo_read(v_buf)] returning [(t1 * t2 * ...) option]
1799
-
- [caml_d3t_Foo_write(v_tuple)] taking [(t1 * t2 * ...)] and returning
1953
+
- [caml_wire_Foo_read(v_buf)] returning [(t1 * t2 * ...) option]
1954
+
- [caml_wire_Foo_write(v_tuple)] taking [(t1 * t2 * ...)] and returning
1800
1955
[string option].
1801
1956
1802
1957
The generated code expects EverParse headers to be available:
···
1805
1960
let buf = Buffer.create 4096 in
1806
1961
let ppf = Format.formatter_of_buffer buf in
1807
1962
Fmt.pf ppf
1808
-
"/* d3t_stubs.c - OCaml FFI stubs for EverParse-generated C */@\n@\n";
1963
+
"/* wire_stubs.c - OCaml FFI stubs for EverParse-generated C */@\n@\n";
1809
1964
Fmt.pf ppf "#include <caml/mlvalues.h>@\n";
1810
1965
Fmt.pf ppf "#include <caml/memory.h>@\n";
1811
1966
Fmt.pf ppf "#include <caml/alloc.h>@\n";
···
1836
1991
let to_ml_stubs (structs : struct_ list) =
1837
1992
let buf = Buffer.create 256 in
1838
1993
let ppf = Format.formatter_of_buffer buf in
1839
-
Fmt.pf ppf "(* Generated by d3t (do not edit) *)@\n@\n";
1994
+
Fmt.pf ppf "(* Generated by wire (do not edit) *)@\n@\n";
1840
1995
List.iter
1841
1996
(fun (s : struct_) ->
1842
1997
let fields = named_fields s in
···
1846
2001
in
1847
2002
Fmt.pf ppf "module %s = struct@\n" s.name;
1848
2003
Fmt.pf ppf " external read : string -> (%s) option@\n" tuple_type;
1849
-
Fmt.pf ppf " = \"caml_d3t_%s_read\"@\n" s.name;
2004
+
Fmt.pf ppf " = \"caml_wire_%s_read\"@\n" s.name;
1850
2005
Fmt.pf ppf " external write : (%s) -> string option@\n" tuple_type;
1851
-
Fmt.pf ppf " = \"caml_d3t_%s_write\"@\n" s.name;
2006
+
Fmt.pf ppf " = \"caml_wire_%s_write\"@\n" s.name;
1852
2007
Fmt.pf ppf "end@\n@\n")
1853
2008
structs;
1854
2009
Format.pp_print_flush ppf ();
···
1870
2025
(** Generate a flat OCaml stub module for a single struct. Produces a file with
1871
2026
[type t] and [external read/write] declarations:
1872
2027
{[
1873
-
(* Generated by d3t *)
2028
+
(* Generated by wire *)
1874
2029
type t = int * int * int32
1875
2030
1876
-
external read : string -> t option = "caml_d3t_Foo_read"
1877
-
external write : t -> string option = "caml_d3t_Foo_write"
2031
+
external read : string -> t option = "caml_wire_Foo_read"
2032
+
external write : t -> string option = "caml_wire_Foo_write"
1878
2033
]} *)
1879
2034
let to_ml_stub (s : struct_) =
1880
2035
let buf = Buffer.create 256 in
···
1884
2039
String.concat " * "
1885
2040
(List.map (fun (Named (_, typ)) -> ml_type_of typ) fields)
1886
2041
in
1887
-
Fmt.pf ppf "(* Generated by d3t (do not edit) *)@\n@\n";
2042
+
Fmt.pf ppf "(* Generated by wire (do not edit) *)@\n@\n";
1888
2043
Fmt.pf ppf "type t = %s@\n@\n" tuple_type;
1889
2044
Fmt.pf ppf "external read : string -> t option@\n";
1890
-
Fmt.pf ppf " = \"caml_d3t_%s_read\"@\n@\n" s.name;
2045
+
Fmt.pf ppf " = \"caml_wire_%s_read\"@\n@\n" s.name;
1891
2046
Fmt.pf ppf "external write : t -> string option@\n";
1892
-
Fmt.pf ppf " = \"caml_d3t_%s_write\"@\n" s.name;
2047
+
Fmt.pf ppf " = \"caml_wire_%s_write\"@\n" s.name;
1893
2048
Format.pp_print_flush ppf ();
1894
2049
Buffer.contents buf
1895
2050
+51
-15
lib/wire.mli
+51
-15
lib/wire.mli
···
1
1
(** Dependent Data Descriptions for binary wire formats.
2
2
3
-
D3t is a GADT-based DSL for describing binary wire formats compatible with
3
+
Wire is a GADT-based DSL for describing binary wire formats compatible with
4
4
EverParse's 3D language. Define your format once, then:
5
5
6
6
- Use {!to_3d} to emit EverParse 3D format for verified C parser generation
···
46
46
val unstage : 'a t -> 'a
47
47
(** [unstage t] extracts the value from a staged computation. This is where
48
48
the cost of specialization is paid. *)
49
+
end
50
+
51
+
(** {1 Unboxed Integer Types}
52
+
53
+
On 64-bit platforms, these types are unboxed (immediate) for zero-allocation
54
+
parsing. On 32-bit platforms, the module will fail at initialization. *)
55
+
56
+
module UInt32 : sig
57
+
type t = int
58
+
(** Unsigned 32-bit integer. Unboxed on 64-bit platforms (fits in 63-bit int).
59
+
*)
60
+
61
+
val get_le : bytes -> int -> t
62
+
val get_be : bytes -> int -> t
63
+
val set_le : bytes -> int -> t -> unit
64
+
val set_be : bytes -> int -> t -> unit
65
+
val to_int : t -> int
66
+
val of_int : int -> t
67
+
end
68
+
69
+
module UInt63 : sig
70
+
type t = int
71
+
(** Unsigned 63-bit integer. Reads 8 bytes but masks to 63 bits. *)
72
+
73
+
val get_le : bytes -> int -> t
74
+
val get_be : bytes -> int -> t
75
+
val set_le : bytes -> int -> t -> unit
76
+
val set_be : bytes -> int -> t -> unit
77
+
val to_int : t -> int
78
+
val of_int : int -> t
49
79
end
50
80
51
81
(** {1 Endianness} *)
···
210
240
val uint16be : int typ
211
241
(** Unsigned 16-bit integer, big-endian. *)
212
242
213
-
val uint32 : int32 typ
214
-
(** Unsigned 32-bit integer, little-endian. *)
243
+
val uint32 : UInt32.t typ
244
+
(** Unsigned 32-bit integer, little-endian. Unboxed on 64-bit. *)
215
245
216
-
val uint32be : int32 typ
217
-
(** Unsigned 32-bit integer, big-endian. *)
246
+
val uint32be : UInt32.t typ
247
+
(** Unsigned 32-bit integer, big-endian. Unboxed on 64-bit. *)
248
+
249
+
val uint63 : UInt63.t typ
250
+
(** Unsigned 63-bit integer, little-endian. Unboxed on 64-bit. Reads 8 bytes. *)
251
+
252
+
val uint63be : UInt63.t typ
253
+
(** Unsigned 63-bit integer, big-endian. Unboxed on 64-bit. Reads 8 bytes. *)
218
254
219
255
val uint64 : int64 typ
220
-
(** Unsigned 64-bit integer, little-endian. *)
256
+
(** Unsigned 64-bit integer, little-endian. Boxed (full 64-bit precision). *)
221
257
222
258
val uint64be : int64 typ
223
-
(** Unsigned 64-bit integer, big-endian. *)
259
+
(** Unsigned 64-bit integer, big-endian. Boxed (full 64-bit precision). *)
224
260
225
261
(** {2 Bitfields} *)
226
262
···
643
679
type packet = { version : int; length : int }
644
680
645
681
let codec =
646
-
let open D3t.Codec in
682
+
let open Wire.Codec in
647
683
record "Packet" (fun version length -> { version; length })
648
684
|+ field "version" uint8 (fun p -> p.version)
649
685
|+ field "length" uint16be (fun p -> p.length)
650
686
|> seal
651
687
652
-
let decode = D3t.Codec.decode codec
653
-
let encode = D3t.Codec.encode codec
654
-
let struct_ = D3t.Codec.to_struct codec
688
+
let decode = Wire.Codec.decode codec
689
+
let encode = Wire.Codec.encode codec
690
+
let struct_ = Wire.Codec.to_struct codec
655
691
]} *)
656
692
657
693
module Codec : sig
···
703
739
Returns [None] if the struct contains variable-length fields. *)
704
740
705
741
val ml_type_of : 'a typ -> string
706
-
(** [ml_type_of typ] returns the OCaml type name for a d3t type (e.g., ["int"],
742
+
(** [ml_type_of typ] returns the OCaml type name for a wire type (e.g., ["int"],
707
743
["int32"], ["int64"]). *)
708
744
709
745
val to_c_stubs : struct_ list -> string
710
746
(** [to_c_stubs structs] generates a C file with OCaml FFI stubs for
711
747
differential roundtrip testing. For each struct [Foo], it generates a
712
-
[caml_d3t_roundtrip_foo] function that reads bytes via [Foo_read], writes
748
+
[caml_wire_roundtrip_foo] function that reads bytes via [Foo_read], writes
713
749
them back via [Foo_write], and returns the result as an OCaml
714
750
[string option]. *)
715
751
···
732
768
{[
733
769
type t = int * int * int32
734
770
735
-
external read : string -> t option = "caml_d3t_Foo_read"
736
-
external write : t -> string option = "caml_d3t_Foo_write"
771
+
external read : string -> t option = "caml_wire_Foo_read"
772
+
external write : t -> string option = "caml_wire_Foo_write"
737
773
]} *)
738
774
739
775
(** {1 Struct-level Read/Write}
+27
-12
test/diff/dune
+27
-12
test/diff/dune
···
1
-
; Differential testing: OCaml d3t vs EverParse C parsers
1
+
; Differential testing: OCaml wire vs EverParse C parsers
2
2
;
3
3
; Workflow:
4
4
; 1. gen_c generates random schemas as .3d files
···
10
10
(library
11
11
(name schema)
12
12
(modules schema)
13
-
(libraries d3t))
13
+
(libraries wire))
14
14
15
15
; Generate .3d files from OCaml schemas
16
16
···
26
26
(run ./gen_schemas.exe)))
27
27
28
28
; Generate .3d files from random schemas into schemas/ directory
29
+
; Also generates stubs.c, stubs.ml, diff_test.ml and schemas/dune
29
30
30
31
(executable
31
32
(name gen_c)
32
33
(modules gen_c)
33
-
(libraries d3t unix))
34
+
(libraries wire unix))
34
35
35
36
(rule
36
-
(target
37
-
(dir schemas))
37
+
(targets
38
+
(dir schemas)
39
+
stubs.c
40
+
stubs.ml
41
+
diff_test.ml)
38
42
(deps gen_c.exe)
39
43
(action
40
44
(run ./gen_c.exe schemas 100)))
41
45
42
-
; Run EverParse 3d to generate C from .3d files
43
-
; Requires EverParse to be installed at ~/.local/everparse
46
+
; Differential test: compile C stubs (includes EverParse generated C)
47
+
; stubs.c #includes the C files from schemas/
48
+
49
+
(library
50
+
(name stubs)
51
+
(modules stubs)
52
+
(foreign_stubs
53
+
(language c)
54
+
(names stubs)
55
+
(flags :standard -I schemas)))
56
+
57
+
(executable
58
+
(name diff_test)
59
+
(modules diff_test)
60
+
(libraries stubs))
44
61
45
62
(rule
46
-
(alias 3d)
47
-
(deps
48
-
(source_tree schemas))
63
+
(alias diff)
64
+
(deps diff_test.exe)
49
65
(action
50
-
(bash
51
-
"cd schemas && for f in *.3d; do ~/.local/everparse/bin/3d.exe --batch \"$f\" || exit 1; done")))
66
+
(run ./diff_test.exe)))
52
67
53
68
; Fuzz tests for schemas (OCaml only - no C dependency)
54
69
+48
-46
test/diff/fuzz_diff.ml
+48
-46
test/diff/fuzz_diff.ml
···
4
4
Stage 1 — compile C roundtrip binary + start subprocess
5
5
Stage 2 — Crowbar tests: OCaml roundtrip_struct vs C subprocess
6
6
7
-
The subprocess protocol is itself defined using d3t record codecs:
8
-
- Request: D3tReq { index : uint32; length : uint32 } ++ data[length]
9
-
- Response: D3tResp { result : uint32 } ++ data[result] (result < 0 = error)
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
10
11
-
Both sides use d3t-generated read/write functions. *)
11
+
Both sides use wire-generated read/write functions. *)
12
12
13
13
module Cr = Crowbar
14
14
module Bs = Bytesrw.Bytes.Slice
15
15
16
16
(* Helper: encode record to string using slice-based API *)
17
17
let encode_to_string codec =
18
-
let encode = D3t.Staged.unstage (D3t.Record.encode codec) in
18
+
let encode = Wire.Staged.unstage (Wire.Record.encode codec) in
19
19
fun v ->
20
20
let slice = encode v in
21
21
Bytes.sub_string (Bs.bytes slice) (Bs.first slice) (Bs.length slice)
22
22
23
23
(* Helper: decode record from bytes using slice-based API *)
24
24
let decode_from_bytes codec =
25
-
let decode = D3t.Staged.unstage (D3t.Record.decode codec) in
25
+
let decode = Wire.Staged.unstage (Wire.Record.decode codec) in
26
26
fun b ->
27
27
if Bytes.length b = 0 then
28
-
Error (D3t.Unexpected_eof { expected = 1; got = 0 })
28
+
Error (Wire.Unexpected_eof { expected = 1; got = 0 })
29
29
else
30
30
let slice = Bs.of_bytes b ~first:0 ~last:(Bytes.length b - 1) in
31
31
Ok (decode slice)
32
32
33
-
(* ---- One-space protocol (defined with d3t) ---- *)
33
+
(* ---- One-space protocol (defined with wire) ---- *)
34
34
35
35
type request_hdr = { req_index : int32; req_length : int32 }
36
36
37
37
let request_hdr_codec =
38
-
D3t.Record.record "D3tReq"
38
+
Wire.Record.record "WireReq"
39
39
~default:{ req_index = 0l; req_length = 0l }
40
40
[
41
-
D3t.Record.field "index" D3t.uint32
41
+
Wire.Record.field "index" Wire.uint32
42
42
~get:(fun r -> r.req_index)
43
43
~set:(fun v r -> { r with req_index = v });
44
-
D3t.Record.field "length" D3t.uint32
44
+
Wire.Record.field "length" Wire.uint32
45
45
~get:(fun r -> r.req_length)
46
46
~set:(fun v r -> { r with req_length = v });
47
47
]
···
49
49
type response_hdr = { resp_result : int32 }
50
50
51
51
let response_hdr_codec =
52
-
D3t.Record.record "D3tResp" ~default:{ resp_result = 0l }
52
+
Wire.Record.record "WireResp" ~default:{ resp_result = 0l }
53
53
[
54
-
D3t.Record.field "result" D3t.uint32
54
+
Wire.Record.field "result" Wire.uint32
55
55
~get:(fun r -> r.resp_result)
56
56
~set:(fun v _r -> { resp_result = v });
57
57
]
58
58
59
-
let request_hdr_struct = D3t.Record.to_struct request_hdr_codec
60
-
let response_hdr_struct = D3t.Record.to_struct response_hdr_codec
59
+
let request_hdr_struct = Wire.Record.to_struct request_hdr_codec
60
+
let response_hdr_struct = Wire.Record.to_struct response_hdr_codec
61
61
62
62
(* Stage the protocol encoders/decoders once *)
63
63
let encode_request_hdr = encode_to_string request_hdr_codec
···
66
66
(* ---- Field type metadata ---- *)
67
67
68
68
type ft = {
69
-
make_field : string -> bool D3t.expr option -> D3t.field;
69
+
make_field : string -> bool Wire.expr option -> Wire.field;
70
70
wire_size : int;
71
71
}
72
72
73
73
let field_types =
74
74
[|
75
75
{
76
-
make_field = (fun n c -> D3t.field n ?constraint_:c D3t.uint8);
76
+
make_field = (fun n c -> Wire.field n ?constraint_:c Wire.uint8);
77
77
wire_size = 1;
78
78
};
79
79
{
80
-
make_field = (fun n c -> D3t.field n ?constraint_:c D3t.uint16);
80
+
make_field = (fun n c -> Wire.field n ?constraint_:c Wire.uint16);
81
81
wire_size = 2;
82
82
};
83
83
{
84
-
make_field = (fun n c -> D3t.field n ?constraint_:c D3t.uint16be);
84
+
make_field = (fun n c -> Wire.field n ?constraint_:c Wire.uint16be);
85
85
wire_size = 2;
86
86
};
87
87
{
88
-
make_field = (fun n c -> D3t.field n ?constraint_:c D3t.uint32);
88
+
make_field = (fun n c -> Wire.field n ?constraint_:c Wire.uint32);
89
89
wire_size = 4;
90
90
};
91
91
{
92
-
make_field = (fun n c -> D3t.field n ?constraint_:c D3t.uint32be);
92
+
make_field = (fun n c -> Wire.field n ?constraint_:c Wire.uint32be);
93
93
wire_size = 4;
94
94
};
95
95
{
96
-
make_field = (fun n c -> D3t.field n ?constraint_:c D3t.uint64);
96
+
make_field = (fun n c -> Wire.field n ?constraint_:c Wire.uint64);
97
97
wire_size = 8;
98
98
};
99
99
{
100
-
make_field = (fun n c -> D3t.field n ?constraint_:c D3t.uint64be);
100
+
make_field = (fun n c -> Wire.field n ?constraint_:c Wire.uint64be);
101
101
wire_size = 8;
102
102
};
103
103
|]
104
104
105
105
(* ---- Random schema generation ---- *)
106
106
107
-
type random_schema = { struct_ : D3t.struct_; wire_size : int }
107
+
type random_schema = { struct_ : Wire.struct_; wire_size : int }
108
108
109
109
let gen_constraint_val rng wire_size =
110
110
match wire_size with
···
127
127
let constraint_ =
128
128
if Random.State.int rng 4 = 0 then
129
129
let k = gen_constraint_val rng ft.wire_size in
130
-
Some D3t.Expr.(D3t.ref name <= D3t.int k)
130
+
Some Wire.Expr.(Wire.ref name <= Wire.int k)
131
131
else None
132
132
in
133
133
(ft.make_field name constraint_, ft.wire_size))
134
134
in
135
-
let d3t_fields = List.map fst fields_data in
135
+
let wire_fields = List.map fst fields_data in
136
136
let wire_size = List.fold_left (fun acc (_, ws) -> acc + ws) 0 fields_data in
137
137
let struct_name = Fmt.str "Fuzz%d" i in
138
-
{ struct_ = D3t.struct_ struct_name d3t_fields; wire_size }
138
+
{ struct_ = Wire.struct_ struct_name wire_fields; wire_size }
139
139
140
140
(* ---- Stage 0: Generate C code ---- *)
141
141
···
147
147
p "#include <stdlib.h>";
148
148
p "#include <stdint.h>";
149
149
p "#include <string.h>";
150
-
p "#include \"d3t.h\"";
151
-
p "#include \"D3tReq.h\"";
152
-
p "#include \"D3tResp.h\"";
150
+
p "#include \"wire.h\"";
151
+
p "#include \"WireReq.h\"";
152
+
p "#include \"WireResp.h\"";
153
153
List.iter
154
154
(fun rs ->
155
-
let name = D3t.struct_name rs.struct_ in
155
+
let name = Wire.struct_name rs.struct_ in
156
156
p "#include \"%s.h\"" name)
157
157
schemas;
158
158
p "";
···
162
162
p " switch (idx) {";
163
163
List.iteri
164
164
(fun i rs ->
165
-
let name = D3t.struct_name rs.struct_ in
165
+
let name = Wire.struct_name rs.struct_ in
166
166
p " case %d: {" i;
167
167
p " %s val;" name;
168
168
p " int32_t rc = %s_read(buf, len, &val);" name;
···
178
178
p " uint8_t hdr_buf[8];";
179
179
p " for (;;) {";
180
180
p " if (fread(hdr_buf, 1, 8, stdin) != 8) break;";
181
-
p " D3tReq req;";
182
-
p " if (D3tReq_read(hdr_buf, 8, &req) < 0) break;";
181
+
p " WireReq req;";
182
+
p " if (WireReq_read(hdr_buf, 8, &req) < 0) break;";
183
183
p " uint8_t *data = malloc(req.length > 0 ? req.length : 1);";
184
184
p
185
185
" if (req.length > 0 && fread(data, 1, req.length, stdin) != \
···
189
189
" int32_t result = roundtrip((int)req.index, data, req.length, out, \
190
190
sizeof(out));";
191
191
p " free(data);";
192
-
p " D3tResp resp;";
192
+
p " WireResp resp;";
193
193
p " resp.result = (uint32_t)result;";
194
194
p " uint8_t resp_buf[4];";
195
-
p " D3tResp_write(&resp, resp_buf, 4);";
195
+
p " WireResp_write(&resp, resp_buf, 4);";
196
196
p " fwrite(resp_buf, 1, 4, stdout);";
197
197
p " if (result > 0) fwrite(out, 1, (size_t)result, stdout);";
198
198
p " fflush(stdout);";
···
252
252
let schemas = List.init num_schemas (fun i -> random_struct rng i) in
253
253
254
254
(* Stage 0: write C code to temp dir *)
255
-
let tmpdir = Filename.temp_dir "d3t_fuzz" "" in
255
+
let tmpdir = Filename.temp_dir "wire_fuzz" "" in
256
256
257
257
let write_file path contents =
258
258
let oc = open_out path in
259
259
output_string oc contents;
260
260
close_out oc
261
261
in
262
-
write_file (Filename.concat tmpdir "d3t.h") (D3t.to_c_runtime ());
262
+
write_file (Filename.concat tmpdir "wire.h") (Wire.to_c_runtime ());
263
263
264
-
(* Protocol headers — generated by d3t *)
265
-
D3t.to_c_header_file (Filename.concat tmpdir "D3tReq.h") request_hdr_struct;
266
-
D3t.to_c_header_file (Filename.concat tmpdir "D3tResp.h") response_hdr_struct;
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;
267
269
268
270
List.iter
269
271
(fun rs ->
270
-
let name = D3t.struct_name rs.struct_ in
272
+
let name = Wire.struct_name rs.struct_ in
271
273
write_file
272
274
(Filename.concat tmpdir (name ^ ".h"))
273
-
(D3t.to_c_header rs.struct_))
275
+
(Wire.to_c_header rs.struct_))
274
276
schemas;
275
277
276
278
let c_main = generate_c_main schemas in
···
295
297
(* Stage 2: register Crowbar tests *)
296
298
List.iteri
297
299
(fun idx rs ->
298
-
let name = D3t.struct_name rs.struct_ in
300
+
let name = Wire.struct_name rs.struct_ in
299
301
Cr.add_test ~name:(name ^ " fuzz-diff") [ Cr.bytes ] (fun buf ->
300
302
let buf = pad rs.wire_size buf in
301
-
let ocaml_result = D3t_diff.Diff.roundtrip_struct rs.struct_ buf in
303
+
let ocaml_result = Wire_diff.Diff.roundtrip_struct rs.struct_ buf in
302
304
let c_result = c_roundtrip sub idx buf in
303
305
match (ocaml_result, c_result) with
304
306
| Ok ocaml_bytes, Some c_bytes ->
···
314
316
| Error e, Some _ ->
315
317
Cr.fail
316
318
(Fmt.str "%s: C succeeded but OCaml failed: %a" name
317
-
D3t.pp_parse_error e)))
319
+
Wire.pp_parse_error e)))
318
320
schemas
+1
-1
test/diff/fuzz_schema.ml
+1
-1
test/diff/fuzz_schema.ml
+231
-22
test/diff/gen_c.ml
+231
-22
test/diff/gen_c.ml
···
1
-
(* Generate .3d files from random d3t schemas for EverParse.
1
+
(* Generate .3d files from random wire schemas for EverParse.
2
2
3
3
All schemas are randomly generated with deterministic seeds. Fields of any
4
4
type may get constraints (~25% probability per field). *)
···
6
6
(* ---- Field type metadata ---- *)
7
7
8
8
type ft = {
9
-
make_field : string -> bool D3t.expr option -> D3t.field;
9
+
make_field : string -> bool Wire.expr option -> Wire.field;
10
10
wire_size : int;
11
11
gen_constraint : Random.State.t -> int;
12
+
big_endian : bool;
12
13
}
13
14
14
15
let gen_uint8 rng = Random.State.int rng 256
···
23
24
let field_types =
24
25
[|
25
26
{
26
-
make_field = (fun n c -> D3t.field n ?constraint_:c D3t.uint8);
27
+
make_field = (fun n c -> Wire.field n ?constraint_:c Wire.uint8);
27
28
wire_size = 1;
28
29
gen_constraint = gen_uint8;
30
+
big_endian = false;
29
31
};
30
32
{
31
-
make_field = (fun n c -> D3t.field n ?constraint_:c D3t.uint16);
33
+
make_field = (fun n c -> Wire.field n ?constraint_:c Wire.uint16);
32
34
wire_size = 2;
33
35
gen_constraint = gen_uint16;
36
+
big_endian = false;
34
37
};
35
38
{
36
-
make_field = (fun n c -> D3t.field n ?constraint_:c D3t.uint16be);
39
+
make_field = (fun n c -> Wire.field n ?constraint_:c Wire.uint16be);
37
40
wire_size = 2;
38
41
gen_constraint = gen_uint16;
42
+
big_endian = true;
39
43
};
40
44
{
41
-
make_field = (fun n c -> D3t.field n ?constraint_:c D3t.uint32);
45
+
make_field = (fun n c -> Wire.field n ?constraint_:c Wire.uint32);
42
46
wire_size = 4;
43
47
gen_constraint = gen_uint32;
48
+
big_endian = false;
44
49
};
45
50
{
46
-
make_field = (fun n c -> D3t.field n ?constraint_:c D3t.uint32be);
51
+
make_field = (fun n c -> Wire.field n ?constraint_:c Wire.uint32be);
47
52
wire_size = 4;
48
53
gen_constraint = gen_uint32;
54
+
big_endian = true;
49
55
};
50
56
{
51
-
make_field = (fun n c -> D3t.field n ?constraint_:c D3t.uint64);
57
+
make_field = (fun n c -> Wire.field n ?constraint_:c Wire.uint64);
52
58
wire_size = 8;
53
59
gen_constraint = gen_uint64;
60
+
big_endian = false;
54
61
};
55
62
{
56
-
make_field = (fun n c -> D3t.field n ?constraint_:c D3t.uint64be);
63
+
make_field = (fun n c -> Wire.field n ?constraint_:c Wire.uint64be);
57
64
wire_size = 8;
58
65
gen_constraint = gen_uint64;
66
+
big_endian = true;
59
67
};
60
68
|]
61
69
62
70
(* ---- Random schema generation ---- *)
63
71
64
-
type random_field = { name : string; ft : ft; constraint_val : int option }
72
+
type random_field = {
73
+
name : string;
74
+
ft : ft;
75
+
constraint_val : int option;
76
+
big_endian : bool;
77
+
}
65
78
66
79
type random_schema = {
67
-
struct_ : D3t.struct_;
80
+
struct_ : Wire.struct_;
68
81
fields : random_field list;
69
82
total_wire_size : int;
70
83
}
···
82
95
if Random.State.int rng 4 = 0 then Some (ft.gen_constraint rng)
83
96
else None
84
97
in
85
-
{ name; ft; constraint_val })
98
+
{ name; ft; constraint_val; big_endian = ft.big_endian })
86
99
in
87
100
let struct_name = Fmt.str "Random%d" seed in
88
-
let d3t_fields =
101
+
let wire_fields =
89
102
List.map
90
103
(fun rf ->
91
104
let constraint_ =
92
105
Option.map
93
-
(fun k -> D3t.Expr.(D3t.ref rf.name <= D3t.int k))
106
+
(fun k -> Wire.Expr.(Wire.ref rf.name <= Wire.int k))
94
107
rf.constraint_val
95
108
in
96
109
rf.ft.make_field rf.name constraint_)
···
99
112
let total_wire_size =
100
113
List.fold_left (fun acc rf -> acc + rf.ft.wire_size) 0 fields
101
114
in
102
-
{ struct_ = D3t.struct_ struct_name d3t_fields; fields; total_wire_size }
115
+
{ struct_ = Wire.struct_ struct_name wire_fields; fields; total_wire_size }
116
+
117
+
(* ---- Code generation for differential testing ---- *)
118
+
119
+
let generate_c_stubs ~schema_dir outdir schemas =
120
+
let oc = open_out (Filename.concat outdir "stubs.c") in
121
+
let pr fmt = Printf.fprintf oc fmt in
122
+
pr "#include <caml/mlvalues.h>\n";
123
+
pr "#include <caml/memory.h>\n";
124
+
pr "#include <caml/alloc.h>\n";
125
+
pr "#include <stdint.h>\n\n";
126
+
(* Include all wrapper headers - they declare the check functions *)
127
+
List.iter
128
+
(fun rs ->
129
+
let name = Wire.struct_name rs.struct_ in
130
+
pr "#include \"%s/%sWrapper.h\"\n" schema_dir name)
131
+
schemas;
132
+
pr "\n";
133
+
(* Include wrapper implementations with unique error handlers *)
134
+
List.iteri
135
+
(fun i rs ->
136
+
let name = Wire.struct_name rs.struct_ in
137
+
(* Include EverParse.h and parser *)
138
+
if i = 0 then pr "#include \"%s/EverParse.h\"\n" schema_dir;
139
+
pr "#include \"%s/%s.h\"\n" schema_dir name;
140
+
pr "#include \"%s/%s.c\"\n" schema_dir name;
141
+
(* Inline wrapper with renamed error handler *)
142
+
pr
143
+
"void %sEverParseError(const char *s, const char *f, const char *r) { \
144
+
(void)s; (void)f; (void)r; }\n"
145
+
name;
146
+
pr "static void %s_ErrorHandler(\n" name;
147
+
pr " const char *t, const char *f, const char *r,\n";
148
+
pr " uint64_t c, uint8_t *ctx, EVERPARSE_INPUT_BUFFER i, uint64_t p) {\n";
149
+
pr " (void)t; (void)f; (void)r; (void)c; (void)ctx; (void)i; (void)p;\n";
150
+
pr "}\n";
151
+
pr "BOOLEAN %sCheck%s(uint8_t *base, uint32_t len) {\n" name name;
152
+
pr
153
+
" uint64_t result = %sValidate%s(NULL, %s_ErrorHandler, base, len, 0);\n"
154
+
name name name;
155
+
pr " return EverParseIsSuccess(result);\n";
156
+
pr "}\n\n")
157
+
schemas;
158
+
(* Generate OCaml stubs *)
159
+
List.iter
160
+
(fun rs ->
161
+
let name = Wire.struct_name rs.struct_ in
162
+
pr "CAMLprim value caml_%s_check(value v_bytes) {\n"
163
+
(String.lowercase_ascii name);
164
+
pr " CAMLparam1(v_bytes);\n";
165
+
pr " uint8_t *data = (uint8_t *)Bytes_val(v_bytes);\n";
166
+
pr " uint32_t len = caml_string_length(v_bytes);\n";
167
+
pr " BOOLEAN result = %sCheck%s(data, len);\n" name name;
168
+
pr " CAMLreturn(Val_bool(result));\n";
169
+
pr "}\n\n")
170
+
schemas;
171
+
close_out oc
172
+
173
+
let generate_ml_stubs outdir schemas =
174
+
let oc = open_out (Filename.concat outdir "stubs.ml") in
175
+
let pr fmt = Printf.fprintf oc fmt in
176
+
List.iter
177
+
(fun rs ->
178
+
let name = Wire.struct_name rs.struct_ in
179
+
let lower = String.lowercase_ascii name in
180
+
pr "external %s_check : bytes -> bool = \"caml_%s_check\"\n" lower lower)
181
+
schemas;
182
+
close_out oc
183
+
184
+
let generate_test_runner outdir schemas =
185
+
let oc = open_out (Filename.concat outdir "diff_test.ml") in
186
+
let pr fmt = Printf.fprintf oc fmt in
187
+
pr "(* Auto-generated differential test runner *)\n\n";
188
+
pr "let num_values = 100\n\n";
189
+
(* Generate schema info: name, wire_size, wire decoder, C checker *)
190
+
pr "type schema = {\n";
191
+
pr " name : string;\n";
192
+
pr " wire_size : int;\n";
193
+
pr " wire_check : bytes -> bool;\n";
194
+
pr " c_check : bytes -> bool;\n";
195
+
pr "}\n\n";
196
+
(* Generate wire validators for each schema using stdlib Bytes *)
197
+
List.iter
198
+
(fun rs ->
199
+
let name = Wire.struct_name rs.struct_ in
200
+
let lower = String.lowercase_ascii name in
201
+
pr "(* %s: wire_size=%d *)\n" name rs.total_wire_size;
202
+
pr "let %s_wire_check (buf : bytes) : bool =\n" lower;
203
+
pr " if Bytes.length buf < %d then false else\n" rs.total_wire_size;
204
+
(* Generate constraint checks with proper offsets *)
205
+
let has_constraints =
206
+
List.exists (fun rf -> rf.constraint_val <> None) rs.fields
207
+
in
208
+
if has_constraints then begin
209
+
(* Calculate offset for each field *)
210
+
let fields_with_offsets =
211
+
let rec aux offset = function
212
+
| [] -> []
213
+
| rf :: rest -> (rf, offset) :: aux (offset + rf.ft.wire_size) rest
214
+
in
215
+
aux 0 rs.fields
216
+
in
217
+
List.iter
218
+
(fun (rf, offset) ->
219
+
match rf.constraint_val with
220
+
| Some k -> (
221
+
let endian = if rf.big_endian then "be" else "le" in
222
+
match rf.ft.wire_size with
223
+
| 1 ->
224
+
pr " let %s = Bytes.get_uint8 buf %d in\n" rf.name offset;
225
+
pr " if %s > %d then false else\n" rf.name k
226
+
| 2 ->
227
+
pr " let %s = Bytes.get_uint16_%s buf %d in\n" rf.name
228
+
endian offset;
229
+
pr " if %s > %d then false else\n" rf.name k
230
+
| 4 ->
231
+
(* Use unsigned comparison for 32-bit values *)
232
+
pr " let %s = Bytes.get_int32_%s buf %d in\n" rf.name
233
+
endian offset;
234
+
pr
235
+
" if Int32.unsigned_compare %s (%ldl) > 0 then false else\n"
236
+
rf.name (Int32.of_int k)
237
+
| 8 ->
238
+
(* Use unsigned comparison for 64-bit values *)
239
+
pr " let %s = Bytes.get_int64_%s buf %d in\n" rf.name
240
+
endian offset;
241
+
pr
242
+
" if Int64.unsigned_compare %s (%LdL) > 0 then false else\n"
243
+
rf.name (Int64.of_int k)
244
+
| _ ->
245
+
pr " let %s = Bytes.get_uint8 buf %d in\n" rf.name offset;
246
+
pr " if %s > %d then false else\n" rf.name k)
247
+
| None -> ())
248
+
fields_with_offsets;
249
+
pr " true\n\n"
250
+
end
251
+
else pr " true\n\n")
252
+
schemas;
253
+
(* Generate schema list *)
254
+
pr "let schemas = [\n";
255
+
List.iter
256
+
(fun rs ->
257
+
let name = Wire.struct_name rs.struct_ in
258
+
let lower = String.lowercase_ascii name in
259
+
pr
260
+
" { name = %S; wire_size = %d; wire_check = %s_wire_check; c_check = \
261
+
Stubs.%s_check };\n"
262
+
name rs.total_wire_size lower lower)
263
+
schemas;
264
+
pr "]\n\n";
265
+
(* Test runner *)
266
+
pr "let () =\n";
267
+
pr " let seed = 42 in\n";
268
+
pr " let rng = Random.State.make [| seed |] in\n";
269
+
pr " let total_tests = ref 0 in\n";
270
+
pr " let mismatches = ref 0 in\n";
271
+
pr " List.iter (fun schema ->\n";
272
+
pr " for _ = 1 to num_values do\n";
273
+
pr " let buf = Bytes.create schema.wire_size in\n";
274
+
pr " for i = 0 to schema.wire_size - 1 do\n";
275
+
pr " Bytes.set buf i (Char.chr (Random.State.int rng 256))\n";
276
+
pr " done;\n";
277
+
pr " let wire_ok = schema.wire_check buf in\n";
278
+
pr " let c_ok = schema.c_check buf in\n";
279
+
pr " incr total_tests;\n";
280
+
pr " if wire_ok <> c_ok then begin\n";
281
+
pr " incr mismatches;\n";
282
+
pr
283
+
" Printf.printf \"MISMATCH %%s: wire=%%b c=%%b\\n\" schema.name \
284
+
wire_ok c_ok\n";
285
+
pr " end\n";
286
+
pr " done\n";
287
+
pr " ) schemas;\n";
288
+
pr
289
+
" Printf.printf \"Tested %%d values across %%d schemas, %%d mismatches\\n\"\n";
290
+
pr " !total_tests (List.length schemas) !mismatches;\n";
291
+
pr " if !mismatches > 0 then exit 1\n";
292
+
close_out oc
293
+
294
+
let run_everparse schema_dir =
295
+
let cmd =
296
+
Fmt.str
297
+
"cd %s && for f in *.3d; do ~/.local/everparse/bin/3d.exe --batch \"$f\" \
298
+
|| exit 1; done"
299
+
schema_dir
300
+
in
301
+
let ret = Sys.command cmd in
302
+
if ret <> 0 then failwith (Fmt.str "EverParse failed with code %d" ret)
103
303
104
304
(* ---- Main ---- *)
105
305
106
306
let () =
107
-
let outdir = if Array.length Sys.argv > 1 then Sys.argv.(1) else "." in
307
+
let schema_dir =
308
+
if Array.length Sys.argv > 1 then Sys.argv.(1) else "schemas"
309
+
in
108
310
let num_random =
109
311
if Array.length Sys.argv > 2 then int_of_string Sys.argv.(2) else 20
110
312
in
111
-
(try Unix.mkdir outdir 0o755 with Unix.Unix_error (Unix.EEXIST, _, _) -> ());
313
+
(try Unix.mkdir schema_dir 0o755
314
+
with Unix.Unix_error (Unix.EEXIST, _, _) -> ());
112
315
let schemas = List.init num_random (fun i -> random_struct i) in
113
-
(* Generate .3d files for EverParse *)
316
+
(* Generate .3d files for EverParse into schema_dir *)
114
317
List.iter
115
318
(fun rs ->
116
-
let name = D3t.struct_name rs.struct_ in
117
-
let m = D3t.module_ name [ D3t.typedef ~entrypoint:true rs.struct_ ] in
118
-
D3t.to_3d_file (Filename.concat outdir (name ^ ".3d")) m)
119
-
schemas
319
+
let name = Wire.struct_name rs.struct_ in
320
+
let m = Wire.module_ name [ Wire.typedef ~entrypoint:true rs.struct_ ] in
321
+
Wire.to_3d_file (Filename.concat schema_dir (name ^ ".3d")) m)
322
+
schemas;
323
+
(* Run EverParse to generate C parsers *)
324
+
run_everparse schema_dir;
325
+
(* Generate FFI stubs and test runner in current dir *)
326
+
generate_c_stubs ~schema_dir "." schemas;
327
+
generate_ml_stubs "." schemas;
328
+
generate_test_runner "." schemas
+2
-2
test/diff/gen_schemas.ml
+2
-2
test/diff/gen_schemas.ml
···
2
2
3
3
let () =
4
4
(* Files are generated in the dune build directory *)
5
-
D3t.to_3d_file "SimpleHeader.3d" Schema.simple_header_module;
6
-
D3t.to_3d_file "ConstrainedPacket.3d" Schema.constrained_packet_module
5
+
Wire.to_3d_file "SimpleHeader.3d" Schema.simple_header_module;
6
+
Wire.to_3d_file "ConstrainedPacket.3d" Schema.constrained_packet_module
+1
-1
test/diff/schema.ml
+1
-1
test/diff/schema.ml
···
3
3
These schemas are used to test that our OCaml parser produces the same
4
4
results as the EverParse-generated C parser. *)
5
5
6
-
open D3t
6
+
open Wire
7
7
8
8
(* Simple header schema: version (u8) + length (u16) + flags (u8) *)
9
9
type simple_header = { version : int; length : int; flags : int }
+5
-5
test/diff/schema.mli
+5
-5
test/diff/schema.mli
···
3
3
type simple_header = { version : int; length : int; flags : int }
4
4
(** A simple packet header with version, length, and flags fields. *)
5
5
6
-
val simple_header_codec : simple_header D3t.Codec.t
6
+
val simple_header_codec : simple_header Wire.Codec.t
7
7
(** Record codec for encoding/decoding simple headers. *)
8
8
9
-
val simple_header_struct : D3t.struct_
9
+
val simple_header_struct : Wire.struct_
10
10
(** Struct definition for 3D code generation. *)
11
11
12
-
val simple_header_module : D3t.module_
12
+
val simple_header_module : Wire.module_
13
13
(** Module definition for 3D code generation. *)
14
14
15
15
type constrained_packet = { pkt_type : int; pkt_length : int }
16
16
(** A packet with type and length fields, where length must be >= 4. *)
17
17
18
-
val constrained_packet_codec : constrained_packet D3t.Codec.t
18
+
val constrained_packet_codec : constrained_packet Wire.Codec.t
19
19
(** Record codec for encoding/decoding constrained packets. *)
20
20
21
-
val constrained_packet_module : D3t.module_
21
+
val constrained_packet_module : Wire.module_
22
22
(** Module definition for 3D code generation. *)
+1
-1
test/diff/test_diff.ml
+1
-1
test/diff/test_diff.ml
+4
-7
test/dune
+4
-7
test/dune
···
1
1
(test
2
2
(name test)
3
-
(libraries d3t alcotest re))
3
+
(libraries wire alcotest re))
4
4
5
5
(executable
6
6
(name gen_3d)
7
-
(libraries d3t))
7
+
(libraries wire))
8
8
9
9
; EverParse integration tests
10
10
; First generate .3d files, then run EverParse on them
···
22
22
(alias 3d)
23
23
(deps Bitfields.3d Enumerations.3d FieldDependence.3d)
24
24
(action
25
-
(progn
26
-
(run 3d --version)
27
-
(run 3d --batch Bitfields.3d)
28
-
(run 3d --batch Enumerations.3d)
29
-
(run 3d --batch FieldDependence.3d))))
25
+
(bash
26
+
"~/.local/everparse/bin/3d.exe --version && for f in *.3d; do ~/.local/everparse/bin/3d.exe --batch \"$f\" || exit 1; done")))
30
27
31
28
; Note: C code generation for differential testing is in the diff/ directory
+1
-1
test/gen_3d.ml
+1
-1
test/gen_3d.ml
+1
-1
test/test.ml
+1
-1
test/test.ml
+16
-16
test/test_wire.ml
+16
-16
test/test_wire.ml
···
1
-
(* Test d3t library *)
1
+
(* Test wire library *)
2
2
3
-
open D3t
3
+
open Wire
4
4
5
5
let contains ~sub s = Re.execp (Re.compile (Re.str sub)) s
6
6
···
116
116
let test_parse_uint32_le () =
117
117
let input = "\x01\x02\x03\x04" in
118
118
match parse_string uint32 input with
119
-
| Ok v -> Alcotest.(check int32) "uint32 le value" 0x04030201l v
119
+
| Ok v -> Alcotest.(check int) "uint32 le value" 0x04030201 v
120
120
| Error e -> Alcotest.fail (Format.asprintf "%a" pp_parse_error e)
121
121
122
122
let test_parse_uint32_be () =
123
123
let input = "\x01\x02\x03\x04" in
124
124
match parse_string uint32be input with
125
-
| Ok v -> Alcotest.(check int32) "uint32 be value" 0x01020304l v
125
+
| Ok v -> Alcotest.(check int) "uint32 be value" 0x01020304 v
126
126
| Error e -> Alcotest.fail (Format.asprintf "%a" pp_parse_error e)
127
127
128
128
let test_parse_uint64_le () =
···
251
251
Alcotest.(check string) "uint16 be encoding" "\x01\x02" encoded
252
252
253
253
let test_encode_uint32_le () =
254
-
let encoded = encode_to_string uint32 0x04030201l in
254
+
let encoded = encode_to_string uint32 0x04030201 in
255
255
Alcotest.(check string) "uint32 le encoding" "\x01\x02\x03\x04" encoded
256
256
257
257
let test_encode_uint32_be () =
258
-
let encoded = encode_to_string uint32be 0x01020304l in
258
+
let encoded = encode_to_string uint32be 0x01020304 in
259
259
Alcotest.(check string) "uint32 be encoding" "\x01\x02\x03\x04" encoded
260
260
261
261
let test_encode_array () =
···
296
296
| Error e -> Alcotest.fail (Format.asprintf "%a" pp_parse_error e)
297
297
298
298
let test_roundtrip_uint32 () =
299
-
let original = 0x12345678l in
299
+
let original = 0x12345678 in
300
300
let encoded = encode_to_string uint32 original in
301
301
match parse_string uint32 encoded with
302
-
| Ok decoded -> Alcotest.(check int32) "roundtrip uint32" original decoded
302
+
| Ok decoded -> Alcotest.(check int) "roundtrip uint32" original decoded
303
303
| Error e -> Alcotest.fail (Format.asprintf "%a" pp_parse_error e)
304
304
305
305
let test_roundtrip_array () =
···
321
321
322
322
(* Record codec tests *)
323
323
324
-
type simple_record = { a : int; b : int; c : int32 }
324
+
type simple_record = { a : int; b : int; c : int }
325
325
326
326
let simple_record_codec =
327
327
let open Codec in
···
332
332
|> seal
333
333
334
334
let test_record_encode () =
335
-
let v = { a = 0x42; b = 0x1234; c = 0x56789ABCl } in
335
+
let v = { a = 0x42; b = 0x1234; c = 0x56789ABC } in
336
336
match encode_record_to_string simple_record_codec v with
337
337
| Error e -> Alcotest.fail (Format.asprintf "%a" pp_parse_error e)
338
338
| Ok encoded ->
···
349
349
| Ok v ->
350
350
Alcotest.(check int) "a" 0x42 v.a;
351
351
Alcotest.(check int) "b" 0x1234 v.b;
352
-
Alcotest.(check int32) "c" 0x56789ABCl v.c
352
+
Alcotest.(check int) "c" 0x56789ABC v.c
353
353
| Error e -> Alcotest.fail (Format.asprintf "%a" pp_parse_error e)
354
354
355
355
let test_record_roundtrip () =
356
-
let original = { a = 0xAB; b = 0xCDEF; c = 0x12345678l } in
356
+
let original = { a = 0xAB; b = 0xCDEF; c = 0x12345678 } in
357
357
match encode_record_to_string simple_record_codec original with
358
358
| Error e -> Alcotest.fail (Format.asprintf "encode: %a" pp_parse_error e)
359
359
| Ok encoded -> (
···
361
361
| Ok decoded ->
362
362
Alcotest.(check int) "a roundtrip" original.a decoded.a;
363
363
Alcotest.(check int) "b roundtrip" original.b decoded.b;
364
-
Alcotest.(check int32) "c roundtrip" original.c decoded.c
364
+
Alcotest.(check int) "c roundtrip" original.c decoded.c
365
365
| Error e -> Alcotest.fail (Format.asprintf "%a" pp_parse_error e))
366
366
367
367
let test_record_to_struct () =
···
407
407
let stubs = to_c_stubs [ s ] in
408
408
Alcotest.(check bool)
409
409
"contains read stub" true
410
-
(contains ~sub:"caml_d3t_SimpleHeader_read" stubs);
410
+
(contains ~sub:"caml_wire_SimpleHeader_read" stubs);
411
411
Alcotest.(check bool)
412
412
"contains write stub" true
413
-
(contains ~sub:"caml_d3t_SimpleHeader_write" stubs)
413
+
(contains ~sub:"caml_wire_SimpleHeader_write" stubs)
414
414
415
415
let suite =
416
-
( "d3t",
416
+
( "wire",
417
417
[
418
418
(* generation *)
419
419
Alcotest.test_case "generation: bitfields" `Quick test_bitfields;
+1
-1
test/test_wire.mli
+1
-1
test/test_wire.mli
+34
wire.opam
+34
wire.opam
···
1
+
# This file is generated by dune, edit dune-project instead
2
+
opam-version: "2.0"
3
+
synopsis: "Binary wire format DSL with EverParse 3D output"
4
+
description:
5
+
"OCaml DSL for describing binary wire formats with EverParse 3D output. Define your wire format once, then use it for OCaml parsing via bytesrw or emit .3d files for verified C parser generation via EverParse."
6
+
maintainer: ["Thomas Gazagnaire <thomas@gazagnaire.org>"]
7
+
authors: ["Thomas Gazagnaire <thomas@gazagnaire.org>"]
8
+
license: "ISC"
9
+
homepage: "https://tangled.org/gazagnaire.org/ocaml-wire"
10
+
bug-reports: "https://tangled.org/gazagnaire.org/ocaml-wire/issues"
11
+
depends: [
12
+
"dune" {>= "3.21"}
13
+
"ocaml" {>= "5.1"}
14
+
"bytesrw" {>= "0.1"}
15
+
"fmt" {>= "0.9"}
16
+
"alcotest" {with-test}
17
+
"odoc" {with-doc}
18
+
]
19
+
build: [
20
+
["dune" "subst"] {dev}
21
+
[
22
+
"dune"
23
+
"build"
24
+
"-p"
25
+
name
26
+
"-j"
27
+
jobs
28
+
"@install"
29
+
"@runtest" {with-test}
30
+
"@doc" {with-doc}
31
+
]
32
+
]
33
+
dev-repo: "git+https://tangled.org/gazagnaire.org/ocaml-wire"
34
+
x-maintenance-intent: ["(latest)"]