1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
(** Generic differential testing: OCaml codec vs EverParse C code.
Each harness bundles a codec with C read/write functions (generated by
{!Wire_stubs.to_c_stubs} and {!Wire_stubs.to_ml_stubs}). All diff logic is
generic over any record codec. *)
type 'r harness =
| Harness : {
name : string;
codec : 'r Wire.Codec.t;
ocaml_read : string -> 'a option;
read : string -> 'a option;
write : 'a -> string option;
project : 'r -> 'a;
equal : 'a -> 'a -> bool;
}
-> 'r harness
type result =
| Match
| Both_failed
| Value_mismatch of string
| Only_c_ok of string
| Only_ocaml_ok of string
let wire_size (Harness h) = Wire.Codec.wire_size h.codec
let encode_to_string codec v =
let buf = Bytes.create (Wire.Codec.wire_size codec) in
Wire.Codec.encode codec v buf 0;
Bytes.unsafe_to_string buf
let decode_from_string codec s = Wire.Codec.decode codec (Bytes.of_string s) 0
let default_ocaml_read codec project buf =
let buf_too_short = String.length buf < Wire.Codec.wire_size codec in
if String.length buf = 0 || buf_too_short then None
else
match decode_from_string codec buf with
| Ok v -> Some (project v)
| Error _ -> None
let v ~name ~codec ~read ~write ~project ~equal ?ocaml_read () =
let ocaml_read =
match ocaml_read with
| Some read -> read
| None -> default_ocaml_read codec project
in
Harness { name; codec; ocaml_read; read; write; project; equal }
let read_test (Harness h) buf =
let c_result = h.read buf in
let ocaml_result = h.ocaml_read buf in
match (c_result, ocaml_result) with
| Some c_value, Some ocaml_value ->
if h.equal c_value ocaml_value then Match
else Value_mismatch "values differ"
| None, None -> Both_failed
| Some _, None -> Only_c_ok "OCaml decode returned empty"
| None, Some _ -> Only_ocaml_ok "External read failed"
let write_test (Harness h) value =
let projected = h.project value in
match h.write projected with
| Some c_bytes -> (
match h.ocaml_read c_bytes with
| Some ocaml_value ->
if h.equal projected ocaml_value then Match
else Value_mismatch "values differ after external write"
| None -> Only_c_ok "OCaml rejected external bytes")
| None -> Only_ocaml_ok "External write failed"
let roundtrip_test (Harness h) value =
let ocaml_bytes = encode_to_string h.codec value in
match (h.read ocaml_bytes, h.ocaml_read ocaml_bytes) with
| None, Some _ -> Only_ocaml_ok "External read failed on OCaml-encoded bytes"
| Some _, None -> Only_c_ok "OCaml rejected OCaml-encoded bytes"
| None, None -> Both_failed
| Some c_value, Some ocaml_value -> (
if not (h.equal c_value ocaml_value) then
Value_mismatch "values differ during external read"
else
match h.write c_value with
| None -> Only_ocaml_ok "External write failed"
| Some c_bytes -> (
match h.ocaml_read c_bytes with
| Some final ->
if h.equal c_value final then Match
else Value_mismatch "values differ after full roundtrip"
| None -> Only_c_ok "OCaml rejected external bytes"))
type t = {
name : string;
wire_size : int;
test_read : string -> result;
test_write : string -> result;
test_roundtrip : string -> result;
}
let harness ~name ~codec ~read ~write ~project ~equal ?ocaml_read () =
let h = v ~name ~codec ~read ~write ~project ~equal ?ocaml_read () in
let ws = wire_size h in
let codec_inner = match h with Harness h -> h.codec in
let decode_value buf =
let padded =
if String.length buf >= ws then String.sub buf 0 ws
else
let b = Bytes.make ws '\000' in
Bytes.blit_string buf 0 b 0 (String.length buf);
Bytes.to_string b
in
if String.length padded = 0 then None
else Some (decode_from_string codec_inner padded)
in
{
name = (match h with Harness h -> h.name);
wire_size = ws;
test_read = (fun buf -> read_test h buf);
test_write =
(fun buf ->
match decode_value buf with
| Some (Ok v) -> write_test h v
| Some (Error _) -> Both_failed
| None -> Both_failed);
test_roundtrip =
(fun buf ->
match decode_value buf with
| Some (Ok v) -> roundtrip_test h v
| Some (Error _) -> Both_failed
| None -> Both_failed);
}