Declarative JSON data manipulation for OCaml
ocaml-json: add skip-parse tests + crowbar fuzz harness
Two new dirs:
- ocaml-json/test/test_skip.ml -- alcotest suite with 65 cases:
30 accept-valid (scalars, escapes, numbers, nested containers),
12 reject-structural-error (unclosed, mismatched, missing colon),
6 differential (Json.ignore vs Json.json must agree on corpus-style
inputs), 5 permissive (document known gaps where ignore accepts
inputs json rejects -- the fragility the user flagged), 12 corpus
torture (simdjson corpus files if present at /tmp/jsont_corpus).
- ocaml-json/fuzz/fuzz_skip.ml -- crowbar property test. Property:
for any byte string s, if Json.json accepts s, then Json.ignore
must also accept s. Standalone-runnable; AFL-aware via crowbar.
The permissive-case block explicitly documents content-level
fragility: [1..2], [+5], [1eE2], [\z], short unicode escapes all
round-trip through Json.ignore. The structural-level contract (brackets,
quote matching, colon/comma placement) is enforced. Hardening these
(cheap number shape check, full escape validation) is a follow-up.
+244
+29
fuzz/fuzz_skip.ml
+29
fuzz/fuzz_skip.ml
···
1
+
(* Differential fuzz harness for [Json.ignore] vs [Json.json].
2
+
3
+
Property: on any byte string, if [Json.json] accepts the input, then
4
+
[Json.ignore] must also accept it. The converse does not hold --
5
+
[Json.ignore] is documented to be more permissive at content level
6
+
(does not fully validate number structure or string escapes).
7
+
8
+
AFL-aware driver: run under [afl-fuzz] or with standalone tests via
9
+
[dune exec ocaml-json/fuzz/fuzz_skip.exe]. *)
10
+
11
+
let check_implication s =
12
+
match Json_bytesrw.decode_string Json.json s with
13
+
| Error _ -> () (* json rejected -- ignore's behaviour unconstrained *)
14
+
| Ok _ -> (
15
+
match Json_bytesrw.decode_string Json.ignore s with
16
+
| Ok () -> ()
17
+
| Error e ->
18
+
Crowbar.failf
19
+
"Json.json accepted but Json.ignore rejected input %S: %s" s e)
20
+
21
+
let () =
22
+
Crowbar.run "json.fuzz"
23
+
[
24
+
( "differential",
25
+
[
26
+
Crowbar.test_case "json accepts => ignore accepts"
27
+
[ Crowbar.bytes ] check_implication;
28
+
] );
29
+
]
+4
test/dune
+4
test/dune
+208
test/test_skip.ml
+208
test/test_skip.ml
···
1
+
(* Tests for [Json.ignore]'s skip-parse fast path.
2
+
3
+
Two angles:
4
+
5
+
1. Hand-written positive/negative cases covering the shape grammar
6
+
(string escapes, number formats, nested structures, truncation).
7
+
2. Differential property: on any string, [Json.ignore] and
8
+
[Json.json] agree on Ok/Error status. [Json.ignore] is allowed
9
+
to be more permissive (accept where [Json.json] errors) only at
10
+
content level -- never at structural level. Crowbar generates
11
+
random inputs and asserts the invariant. *)
12
+
13
+
let decode_ignore s = Json_bytesrw.decode_string Json.ignore s
14
+
let decode_dom s = Json_bytesrw.decode_string Json.json s
15
+
16
+
let is_ok = function Ok _ -> true | Error _ -> false
17
+
18
+
(* -- Positive cases: Json.ignore must accept all valid JSON -- *)
19
+
20
+
let test_ignore_accepts_valid name s () =
21
+
match decode_ignore s with
22
+
| Ok () -> ()
23
+
| Error e -> Alcotest.failf "Json.ignore rejected valid input %s: %s" name e
24
+
25
+
let positive_cases =
26
+
[
27
+
("null", "null");
28
+
("true", "true");
29
+
("false", "false");
30
+
("int", "42");
31
+
("neg int", "-17");
32
+
("float", "3.14");
33
+
("exp", "1.5e10");
34
+
("neg exp", "-2.5E-3");
35
+
("zero", "0");
36
+
("empty string", "\"\"");
37
+
("simple string", "\"hello\"");
38
+
("escaped quote", {|"a\"b"|});
39
+
("escaped backslash", {|"a\\b"|});
40
+
("escaped slash", {|"a\/b"|});
41
+
("escaped newline", {|"a\nb"|});
42
+
("escaped tab", {|"a\tb"|});
43
+
("escaped unicode", {|"a\u0041b"|});
44
+
("utf8 content", "\"caf\xc3\xa9\"");
45
+
("empty array", "[]");
46
+
("int array", "[1, 2, 3]");
47
+
("mixed array", "[1, \"a\", null, true]");
48
+
("nested array", "[[1,2],[3,4]]");
49
+
("empty object", "{}");
50
+
("simple object", {|{"a":1}|});
51
+
("multi-member", {|{"a":1,"b":2,"c":3}|});
52
+
("nested object", {|{"a":{"b":{"c":1}}}|});
53
+
("object in array", {|[{"a":1},{"b":2}]|});
54
+
("array in object", {|{"items":[1,2,3]}|});
55
+
("whitespace", " \n\t [ 1 , 2 ] ");
56
+
("unicode escape pair", {|"\uD83D\uDE00"|});
57
+
]
58
+
59
+
(* -- Negative cases: Json.ignore must reject structurally broken input.
60
+
61
+
"Structurally broken" means: mismatched brackets, unclosed strings,
62
+
unclosed containers, or complete absence of a value. The skip path
63
+
is explicitly more permissive on content (numbers, escapes) and may
64
+
accept things Json.json rejects. *)
65
+
66
+
let test_ignore_rejects_malformed name s () =
67
+
match decode_ignore s with
68
+
| Ok () -> Alcotest.failf "Json.ignore accepted malformed input %s" name
69
+
| Error _ -> ()
70
+
71
+
let structural_negatives =
72
+
[
73
+
("empty", "");
74
+
("just whitespace", " \n\t ");
75
+
("unclosed array", "[1, 2");
76
+
("unclosed object", {|{"a":1|});
77
+
("unclosed string", {|"hello|});
78
+
("mismatched close", "[1, 2}");
79
+
("trailing comma in array", "[1, 2,]");
80
+
("missing colon in object", {|{"a" 1}|});
81
+
("missing value after colon", {|{"a":}|});
82
+
("just comma", ",");
83
+
("just close brace", "}");
84
+
("just close bracket", "]");
85
+
]
86
+
87
+
(* -- Differential: Json.ignore and Json.json on the same input --
88
+
89
+
Expected: on all corpus files (known valid), both decode to Ok.
90
+
On a set of synthetic malformed inputs, both return Error -- or at
91
+
worst, Json.ignore accepts something Json.json rejects (content
92
+
permissiveness, documented). The strict structural contract says
93
+
Json.ignore MUST reject what Json.json rejects at the structural
94
+
level. *)
95
+
96
+
let test_diff_valid_both_accept name s () =
97
+
let ri = decode_ignore s and rj = decode_dom s in
98
+
match (ri, rj) with
99
+
| Ok _, Ok _ -> ()
100
+
| Error e, Ok _ ->
101
+
Alcotest.failf "Json.ignore rejected but Json.json accepted %s: %s" name e
102
+
| Ok _, Error e ->
103
+
Alcotest.failf
104
+
"Json.ignore accepted but Json.json rejected %s (content \
105
+
permissiveness): %s"
106
+
name e
107
+
| Error _, Error _ -> ()
108
+
109
+
let differential_cases =
110
+
(* A grab-bag of realistic JSON values from the simdjson corpus
111
+
shapes but small enough to inline. *)
112
+
[
113
+
("null deep", "[[[[[null]]]]]");
114
+
("tight nest", {|{"a":{"b":{"c":{"d":[1,2,3]}}}}|});
115
+
("many numbers", "[1,2,3,4,5,6,7,8,9,10]");
116
+
("escapes in key", {|{"a\"b":1}|});
117
+
("escape in string val", {|{"k":"a\"b"}|});
118
+
("unicode in key", {|{"caf\u00e9":1}|});
119
+
]
120
+
121
+
(* -- Content-permissiveness sanity: document which inputs Json.ignore
122
+
accepts that Json.json rejects. These are the "fragility" cases
123
+
the user flagged. Future hardening work will tighten skip paths
124
+
to reject these too. -- *)
125
+
126
+
let permissive_cases =
127
+
[
128
+
("double dot", "1..2");
129
+
("plus leader", "+5");
130
+
("double exp", "1eE2");
131
+
("bad escape char", {|"a\zb"|});
132
+
("short unicode escape", {|"a\u41b"|});
133
+
]
134
+
135
+
let test_permissive_ignore name s () =
136
+
let ri = decode_ignore s and rj = decode_dom s in
137
+
Alcotest.(check bool)
138
+
(Printf.sprintf "json rejects %s" name)
139
+
false (is_ok rj);
140
+
(* Json.ignore accepts this -- document the behaviour. *)
141
+
match ri with
142
+
| Ok _ -> () (* Expected permissive acceptance. *)
143
+
| Error _ ->
144
+
(* If ignore also rejects, we have tighter validation than
145
+
expected. Note and continue. *)
146
+
Printf.eprintf "(info: Json.ignore also rejected %s)\n" name
147
+
148
+
(* -- Corpus torture test --
149
+
150
+
If the simdjson corpus is present at [/tmp/jsont_corpus/*.json],
151
+
run Json.ignore over each file and assert acceptance. Also check
152
+
that Json.ignore and Json.json agree (both Ok) on every file.
153
+
Skipped silently if the corpus isn't available. *)
154
+
155
+
let read_file path =
156
+
try
157
+
let ic = open_in_bin path in
158
+
let n = in_channel_length ic in
159
+
let b = Bytes.create n in
160
+
really_input ic b 0 n;
161
+
close_in ic;
162
+
Some (Bytes.unsafe_to_string b)
163
+
with _ -> None
164
+
165
+
let corpus_dir = "/tmp/jsont_corpus"
166
+
167
+
let corpus_files () =
168
+
try
169
+
Sys.readdir corpus_dir |> Array.to_list
170
+
|> List.filter (fun n -> Filename.check_suffix n ".json")
171
+
|> List.sort compare
172
+
with _ -> []
173
+
174
+
let test_corpus_file name () =
175
+
match read_file (Filename.concat corpus_dir name) with
176
+
| None -> ()
177
+
| Some s ->
178
+
(match decode_ignore s with
179
+
| Ok () -> ()
180
+
| Error e -> Alcotest.failf "ignore rejected corpus %s: %s" name e);
181
+
(match decode_dom s with
182
+
| Ok _ -> ()
183
+
| Error e -> Alcotest.failf "json rejected corpus %s: %s" name e)
184
+
185
+
(* -- Entry point -- *)
186
+
187
+
let alcotests =
188
+
let positive = List.map (fun (n, s) ->
189
+
Alcotest.test_case ("accept " ^ n) `Quick (test_ignore_accepts_valid n s))
190
+
positive_cases in
191
+
let neg = List.map (fun (n, s) ->
192
+
Alcotest.test_case ("reject " ^ n) `Quick (test_ignore_rejects_malformed n s))
193
+
structural_negatives in
194
+
let diff = List.map (fun (n, s) ->
195
+
Alcotest.test_case ("diff " ^ n) `Quick (test_diff_valid_both_accept n s))
196
+
differential_cases in
197
+
let perm = List.map (fun (n, s) ->
198
+
Alcotest.test_case ("permissive " ^ n) `Quick (test_permissive_ignore n s))
199
+
permissive_cases in
200
+
let corpus = List.map (fun n ->
201
+
Alcotest.test_case ("corpus " ^ n) `Quick (test_corpus_file n))
202
+
(corpus_files ()) in
203
+
("skip-parse", positive @ neg @ diff @ perm @ corpus)
204
+
205
+
let () =
206
+
(* Run alcotest suite. Crowbar uses its own main driver (AFL-aware)
207
+
and is exercised via a separate dune test target. *)
208
+
Alcotest.run ~argv:[| "test_skip" |] "json.skip" [ alcotests ]