Minimal SQLite key-value store for OCaml
toml: rename from tomlt, split raw AST into Value submodule
Drops the "t" suffix and follows the value/codec/toml/core pattern
(jsont.json_base style). The internal raw TOML module moves from
[Toml] to [Value] (file: lib/value.ml, was lib/toml.ml) to make room
for the top-level Toml facade (file: lib/toml.ml, was lib/tomlt.ml).
External callers now reach the raw AST through [Toml.Value.X] instead
of [Tomlt.Toml.X]. Every downstream reference updated in lockstep.
+330
-324
-302
test/test_hostile.ml
-302
test/test_hostile.ml
···
1
-
(* Hostile-input tests for ocaml-sqlite.
2
-
3
-
Inspired by SQLite CVE classes: corrupt files must never hang or crash,
4
-
only return errors. Each test crafts a malformed on-disk structure and
5
-
verifies that open_, tables, iter_table, and insert fail cleanly. *)
6
-
7
-
let page_size = 4096
8
-
let magic = "SQLite format 3\000"
9
-
10
-
(* -- Helpers -- *)
11
-
12
-
let write_u16_be buf off v =
13
-
Bytes.set_uint8 buf off ((v lsr 8) land 0xff);
14
-
Bytes.set_uint8 buf (off + 1) (v land 0xff)
15
-
16
-
let write_u32_be buf off v =
17
-
Bytes.set_uint8 buf off ((v lsr 24) land 0xff);
18
-
Bytes.set_uint8 buf (off + 1) ((v lsr 16) land 0xff);
19
-
Bytes.set_uint8 buf (off + 2) ((v lsr 8) land 0xff);
20
-
Bytes.set_uint8 buf (off + 3) (v land 0xff)
21
-
22
-
(* Minimal valid DB header (100 bytes) *)
23
-
let db_header ~page_count =
24
-
let buf = Bytes.make 100 '\000' in
25
-
Bytes.blit_string magic 0 buf 0 16;
26
-
write_u16_be buf 16 page_size;
27
-
Bytes.set_uint8 buf 18 1;
28
-
(* write version *)
29
-
Bytes.set_uint8 buf 19 1;
30
-
(* read version *)
31
-
Bytes.set_uint8 buf 21 64;
32
-
(* max embedded payload fraction *)
33
-
Bytes.set_uint8 buf 22 32;
34
-
(* min embedded payload fraction *)
35
-
Bytes.set_uint8 buf 23 32;
36
-
(* leaf payload fraction *)
37
-
write_u32_be buf 28 page_count;
38
-
Bytes.unsafe_to_string buf
39
-
40
-
(* Write a file with the given pages (page 1 starts at offset 0) *)
41
-
let write_db path pages =
42
-
let data =
43
-
String.concat ""
44
-
(List.map
45
-
(fun page ->
46
-
let s = page in
47
-
let padded = Bytes.make page_size '\000' in
48
-
Bytes.blit_string s 0 padded 0 (min (String.length s) page_size);
49
-
Bytes.unsafe_to_string padded)
50
-
pages)
51
-
in
52
-
Eio.Path.save ~create:(`Or_truncate 0o644) path data
53
-
54
-
let with_temp_hostile f =
55
-
Eio_main.run @@ fun env ->
56
-
let cwd = Eio.Stdenv.cwd env in
57
-
let tmp = Eio.Path.(cwd / "_build" / "test_hostile") in
58
-
(try Eio.Path.mkdirs ~exists_ok:true ~perm:0o755 tmp with Eio.Io _ -> ());
59
-
let name = Fmt.str "hostile_%d.db" (Random.int 1_000_000) in
60
-
let path = Eio.Path.(tmp / name) in
61
-
Eio.Switch.run @@ fun sw -> f sw path
62
-
63
-
(* Try to open and do basic operations; must not hang or crash *)
64
-
let must_fail_or_succeed_safely sw path =
65
-
match Sqlite.open_ ~sw path with
66
-
| exception _ -> () (* clean failure on open *)
67
-
| db ->
68
-
(* If open succeeded, basic operations must not hang *)
69
-
(try ignore (Sqlite.tables db) with _ -> ());
70
-
(try ignore (Sqlite.find db "nonexistent") with _ -> ());
71
-
Sqlite.close db
72
-
73
-
(* -- CVE-2019-19646 inspired: cyclic/self-referential pages -- *)
74
-
75
-
let test_self_referential_page () =
76
-
with_temp_hostile @@ fun sw path ->
77
-
(* Page 1: sqlite_master with a table whose root points to itself *)
78
-
let page1 = Bytes.make page_size '\000' in
79
-
let hdr = db_header ~page_count:2 in
80
-
Bytes.blit_string hdr 0 page1 0 100;
81
-
(* sqlite_master leaf header at offset 100 *)
82
-
Bytes.set_uint8 page1 100 0x0d;
83
-
(* leaf table *)
84
-
write_u16_be page1 103 0;
85
-
(* 0 cells — empty master *)
86
-
write_u16_be page1 105 page_size;
87
-
(* Page 2: interior table page pointing to itself *)
88
-
let page2 = Bytes.make page_size '\000' in
89
-
Bytes.set_uint8 page2 0 0x05;
90
-
(* interior table *)
91
-
write_u16_be page2 3 1;
92
-
(* 1 cell *)
93
-
write_u16_be page2 5 (page_size - 12);
94
-
write_u32_be page2 8 2;
95
-
(* right child = self *)
96
-
(* Cell at end: left_child=2 (self), rowid=1 *)
97
-
let cell_off = page_size - 12 in
98
-
write_u32_be page2 cell_off 2;
99
-
(* left child = page 2 = self *)
100
-
Bytes.set_uint8 page2 (cell_off + 4) 1;
101
-
(* rowid varint = 1 *)
102
-
write_u16_be page2 12 (page_size - 12);
103
-
(* cell pointer *)
104
-
write_db path [ Bytes.unsafe_to_string page1; Bytes.unsafe_to_string page2 ];
105
-
must_fail_or_succeed_safely sw path
106
-
107
-
(* -- CVE-2022-35737 inspired: oversized payload/varint -- *)
108
-
109
-
let test_oversized_varint () =
110
-
with_temp_hostile @@ fun sw path ->
111
-
let page1 = Bytes.make page_size '\000' in
112
-
let hdr = db_header ~page_count:1 in
113
-
Bytes.blit_string hdr 0 page1 0 100;
114
-
(* sqlite_master: leaf with 1 cell containing a huge payload_size varint *)
115
-
Bytes.set_uint8 page1 100 0x0d;
116
-
write_u16_be page1 103 1;
117
-
(* 1 cell *)
118
-
write_u16_be page1 105 200;
119
-
write_u16_be page1 108 200;
120
-
(* cell pointer at offset 200 *)
121
-
(* Cell at 200: payload_size = 9-byte varint (max value) *)
122
-
let cell_off = 200 in
123
-
for i = 0 to 7 do
124
-
Bytes.set_uint8 page1 (cell_off + i) 0xff
125
-
done;
126
-
Bytes.set_uint8 page1 (cell_off + 8) 0x01;
127
-
(* 9th varint byte *)
128
-
write_db path [ Bytes.unsafe_to_string page1 ];
129
-
must_fail_or_succeed_safely sw path
130
-
131
-
(* -- CVE-2020-13434 inspired: size overflow in record encoding -- *)
132
-
133
-
let test_record_header_overflow () =
134
-
with_temp_hostile @@ fun sw path ->
135
-
let page1 = Bytes.make page_size '\000' in
136
-
let hdr = db_header ~page_count:1 in
137
-
Bytes.blit_string hdr 0 page1 0 100;
138
-
Bytes.set_uint8 page1 100 0x0d;
139
-
write_u16_be page1 103 1;
140
-
write_u16_be page1 105 300;
141
-
write_u16_be page1 108 300;
142
-
(* Cell: small payload_size (20), rowid=1, then a record header claiming
143
-
huge header_size *)
144
-
let off = 300 in
145
-
Bytes.set_uint8 page1 off 20;
146
-
(* payload_size varint = 20 *)
147
-
Bytes.set_uint8 page1 (off + 1) 1;
148
-
(* rowid varint = 1 *)
149
-
(* Record: header_size varint = 255 (way bigger than 20-byte payload) *)
150
-
Bytes.set_uint8 page1 (off + 2) 0x81;
151
-
(* varint high byte *)
152
-
Bytes.set_uint8 page1 (off + 3) 0x7f;
153
-
(* varint low = 255 *)
154
-
write_db path [ Bytes.unsafe_to_string page1 ];
155
-
must_fail_or_succeed_safely sw path
156
-
157
-
(* -- CVE-2025-7709 inspired: malformed index B-tree -- *)
158
-
159
-
let test_wrong_page_kind_at_root () =
160
-
with_temp_hostile @@ fun sw path ->
161
-
(* Page 2 is supposed to be a table but has index page kind *)
162
-
let page1 = Bytes.make page_size '\000' in
163
-
let hdr = db_header ~page_count:2 in
164
-
Bytes.blit_string hdr 0 page1 0 100;
165
-
Bytes.set_uint8 page1 100 0x0d;
166
-
write_u16_be page1 103 0;
167
-
write_u16_be page1 105 page_size;
168
-
let page2 = Bytes.make page_size '\000' in
169
-
(* Set page kind to leaf_index (0x0a) instead of leaf_table (0x0d) *)
170
-
Bytes.set_uint8 page2 0 0x0a;
171
-
write_u16_be page2 3 0;
172
-
write_u16_be page2 5 page_size;
173
-
write_db path [ Bytes.unsafe_to_string page1; Bytes.unsafe_to_string page2 ];
174
-
must_fail_or_succeed_safely sw path
175
-
176
-
(* -- CVE-2023-7104 inspired: truncated/malformed WAL -- *)
177
-
178
-
let test_truncated_wal () =
179
-
with_temp_hostile @@ fun sw path ->
180
-
(* Create a valid empty DB first *)
181
-
Eio.Switch.run @@ fun init_sw ->
182
-
let db = Sqlite.open_ ~sw:init_sw ~create:true path in
183
-
Sqlite.put db "key" "value";
184
-
Sqlite.close db;
185
-
(* Now write a truncated WAL file *)
186
-
let wal_path = Eio.Path.(Eio.Path.native_exn path ^ "-wal") in
187
-
let wal_path = Eio.Path.(Eio.Stdenv.cwd (Eio_main.run Fun.id) / wal_path) in
188
-
ignore wal_path;
189
-
(* Write garbage to where the WAL would be *)
190
-
let wal_name = Eio.Path.native_exn path ^ "-wal" in
191
-
let oc = open_out_bin wal_name in
192
-
output_string oc "\x00\x01\x02";
193
-
(* 3 bytes, way too short *)
194
-
close_out oc;
195
-
(* Reopen — must handle the corrupt WAL gracefully *)
196
-
must_fail_or_succeed_safely sw path;
197
-
(* Clean up *)
198
-
try Sys.remove wal_name with Sys_error _ -> ()
199
-
200
-
(* -- Root page beyond file -- *)
201
-
202
-
let test_root_page_out_of_bounds () =
203
-
with_temp_hostile @@ fun sw path ->
204
-
let page1 = Bytes.make page_size '\000' in
205
-
let hdr = db_header ~page_count:1 in
206
-
Bytes.blit_string hdr 0 page1 0 100;
207
-
(* sqlite_master: leaf with a table entry pointing to page 999 *)
208
-
Bytes.set_uint8 page1 100 0x0d;
209
-
write_u16_be page1 103 1;
210
-
let cell_start = 200 in
211
-
write_u16_be page1 105 cell_start;
212
-
write_u16_be page1 108 cell_start;
213
-
(* Build a sqlite_master record: type=table, name=t, tbl=t, root=999, sql *)
214
-
let sql = "CREATE TABLE t (x TEXT)" in
215
-
let payload =
216
-
Btree.Record.encode
217
-
[
218
-
Btree.Record.Vtext "table";
219
-
Btree.Record.Vtext "t";
220
-
Btree.Record.Vtext "t";
221
-
Btree.Record.Vint 999L;
222
-
Btree.Record.Vtext sql;
223
-
]
224
-
in
225
-
let payload_len = String.length payload in
226
-
(* Cell: payload_size varint + rowid varint + payload *)
227
-
Bytes.set_uint8 page1 cell_start payload_len;
228
-
(* payload_size *)
229
-
Bytes.set_uint8 page1 (cell_start + 1) 1;
230
-
(* rowid = 1 *)
231
-
Bytes.blit_string payload 0 page1 (cell_start + 2) payload_len;
232
-
write_db path [ Bytes.unsafe_to_string page1 ];
233
-
(* Open should succeed (just reads master), but accessing the table
234
-
should fail — not crash *)
235
-
match Sqlite.open_ ~sw path with
236
-
| exception _ -> ()
237
-
| db ->
238
-
(try
239
-
Sqlite.fold_table db "t" ~init:() ~f:(fun _ _ () -> ());
240
-
(* If it didn't fail, that's also OK — the table is empty *)
241
-
()
242
-
with _ -> ());
243
-
Sqlite.close db
244
-
245
-
(* -- Empty/garbage file -- *)
246
-
247
-
let test_empty_file () =
248
-
with_temp_hostile @@ fun sw path ->
249
-
Eio.Path.save ~create:(`Or_truncate 0o644) path "";
250
-
must_fail_or_succeed_safely sw path
251
-
252
-
let test_garbage_file () =
253
-
with_temp_hostile @@ fun sw path ->
254
-
Eio.Path.save ~create:(`Or_truncate 0o644) path
255
-
(String.init 4096 (fun _ -> Char.chr (Random.int 256)));
256
-
must_fail_or_succeed_safely sw path
257
-
258
-
(* -- Cell pointer pointing into header -- *)
259
-
260
-
let test_cell_pointer_in_header () =
261
-
with_temp_hostile @@ fun sw path ->
262
-
let page1 = Bytes.make page_size '\000' in
263
-
let hdr = db_header ~page_count:1 in
264
-
Bytes.blit_string hdr 0 page1 0 100;
265
-
Bytes.set_uint8 page1 100 0x0d;
266
-
write_u16_be page1 103 1;
267
-
(* 1 cell *)
268
-
write_u16_be page1 105 50;
269
-
(* content starts inside header! *)
270
-
write_u16_be page1 108 50;
271
-
(* cell pointer into header area *)
272
-
write_db path [ Bytes.unsafe_to_string page1 ];
273
-
must_fail_or_succeed_safely sw path
274
-
275
-
(* -- Page count = 0 -- *)
276
-
277
-
let test_zero_page_count () =
278
-
with_temp_hostile @@ fun sw path ->
279
-
let page1 = Bytes.make page_size '\000' in
280
-
let hdr = db_header ~page_count:0 in
281
-
Bytes.blit_string hdr 0 page1 0 100;
282
-
write_db path [ Bytes.unsafe_to_string page1 ];
283
-
must_fail_or_succeed_safely sw path
284
-
285
-
let suite =
286
-
( "hostile",
287
-
[
288
-
Alcotest.test_case "self-referential page" `Quick
289
-
test_self_referential_page;
290
-
Alcotest.test_case "oversized varint" `Quick test_oversized_varint;
291
-
Alcotest.test_case "record header overflow" `Quick
292
-
test_record_header_overflow;
293
-
Alcotest.test_case "wrong page kind at root" `Quick
294
-
test_wrong_page_kind_at_root;
295
-
Alcotest.test_case "root page out of bounds" `Quick
296
-
test_root_page_out_of_bounds;
297
-
Alcotest.test_case "empty file" `Quick test_empty_file;
298
-
Alcotest.test_case "garbage file" `Quick test_garbage_file;
299
-
Alcotest.test_case "cell pointer in header" `Quick
300
-
test_cell_pointer_in_header;
301
-
Alcotest.test_case "zero page count" `Quick test_zero_page_count;
302
-
] )
-2
test/test_hostile.mli
-2
test/test_hostile.mli
+330
-20
test/test_sqlite.ml
+330
-20
test/test_sqlite.ml
···
1233
1233
(* Non-rowid primary keys *)
1234
1234
(* ================================================================ *)
1235
1235
1236
-
let test_text_primary_key_not_rowid_alias () =
1236
+
let test_text_pk_not_alias () =
1237
1237
with_temp_db @@ fun _fs db ->
1238
1238
(* TEXT PRIMARY KEY is NOT a rowid alias — only INTEGER PRIMARY KEY is.
1239
1239
The value must be stored in the record, not as the B-tree rowid. *)
···
1284
1284
| _ -> Alcotest.failf "persisted: %a" Fmt.(list Sqlite.pp_value) v);
1285
1285
Sqlite.close db)
1286
1286
1287
-
let test_real_primary_key_not_rowid_alias () =
1287
+
let test_real_pk_not_alias () =
1288
1288
with_temp_db @@ fun _fs db ->
1289
1289
(* REAL PRIMARY KEY is NOT a rowid alias either *)
1290
1290
Sqlite.create_table db
···
1382
1382
Sqlite.insert db ~table:"t" [ Sqlite.Vint 10L; Sqlite.Vtext "Bob" ]
1383
1383
in
1384
1384
false
1385
-
with _ -> true
1385
+
with Sqlite.Unique_violation _ | Failure _ -> true
1386
1386
in
1387
1387
Alcotest.(check bool) "duplicate rowid rejected" true raised;
1388
1388
(* Original row must be intact *)
···
1478
1478
Alcotest.(check string) "handle col" "handle" cols);
1479
1479
Sqlite.close db)
1480
1480
1481
-
let test_kv_table_survives_close_with_generic () =
1481
+
let test_kv_survives_close_generic () =
1482
1482
Eio_main.run @@ fun env ->
1483
1483
let fs = Eio.Stdenv.fs env in
1484
1484
let path = Eio.Path.(fs / temp_db "kv_generic") in
···
1514
1514
(* Non-rowid PRIMARY KEY enforcement (bug #2) *)
1515
1515
(* ================================================================ *)
1516
1516
1517
-
let test_text_primary_key_rejects_duplicates () =
1517
+
let test_text_pk_rejects_dups () =
1518
1518
with_temp_db @@ fun _fs db ->
1519
1519
(* TEXT PRIMARY KEY should enforce uniqueness, same as UNIQUE.
1520
1520
Per SQLite spec, PRIMARY KEY implies UNIQUE for non-rowid tables. *)
···
1530
1530
[ Sqlite.Vtext "ABC"; Sqlite.Vtext "second" ]
1531
1531
in
1532
1532
false
1533
-
with _ -> true
1533
+
with Sqlite.Unique_violation _ | Failure _ -> true
1534
1534
in
1535
1535
Alcotest.(check bool) "TEXT PK rejects duplicate" true raised;
1536
1536
(* Original row must be intact *)
1537
1537
let rows = Sqlite.read_table db "t" in
1538
1538
Alcotest.(check int) "still 1 row" 1 (List.length rows)
1539
1539
1540
-
let test_composite_primary_key_rejects_duplicates () =
1540
+
let test_composite_pk_rejects_dups () =
1541
1541
with_temp_db @@ fun _fs db ->
1542
1542
(* PRIMARY KEY (a, b) should enforce uniqueness on the tuple *)
1543
1543
Sqlite.create_table db
···
1553
1553
[ Sqlite.Vtext "x"; Sqlite.Vtext "y"; Sqlite.Vtext "z2" ]
1554
1554
in
1555
1555
false
1556
-
with _ -> true
1556
+
with Sqlite.Unique_violation _ | Failure _ -> true
1557
1557
in
1558
1558
Alcotest.(check bool) "composite PK rejects duplicate" true raised;
1559
1559
(* Different tuple should succeed *)
···
1585
1585
Sqlite.insert db ~table:"t" [ Sqlite.Vtext "A"; Sqlite.Vtext "v2" ]
1586
1586
in
1587
1587
false
1588
-
with _ -> true
1588
+
with Sqlite.Unique_violation _ | Failure _ -> true
1589
1589
in
1590
1590
Alcotest.(check bool) "TEXT PK enforced after reopen" true raised;
1591
1591
Sqlite.close db)
···
1594
1594
(* Transaction rollback for named tables (bug #3 extended) *)
1595
1595
(* ================================================================ *)
1596
1596
1597
-
let test_transaction_rollback_named_table_create () =
1597
+
let test_rollback_named_create () =
1598
1598
with_temp_db @@ fun _fs db ->
1599
1599
(* Table.create inside a rolled-back transaction should not
1600
1600
leave the named table visible. *)
···
1632
1632
Sqlite.insert db ~table:"t" [ Sqlite.Vint 1L; Sqlite.Vtext "c@d.com" ]
1633
1633
in
1634
1634
true
1635
-
with _ -> false
1635
+
with Sqlite.Unique_violation _ | Failure _ -> false
1636
1636
in
1637
1637
if dup_ok then begin
1638
1638
(* Bug: duplicate was accepted. Verify index consistency. *)
···
1692
1692
try
1693
1693
Sqlite.create_table db ~sql:"CREATE TABLE dup (b INTEGER)";
1694
1694
false
1695
-
with _ -> true
1695
+
with Sqlite.Unique_violation _ | Failure _ -> true
1696
1696
in
1697
1697
(* Either it raises, or IF NOT EXISTS is required *)
1698
1698
if not raised then begin
···
1708
1708
in
1709
1709
Alcotest.(check int) "exactly one 'dup' table" 1 dup_count
1710
1710
1711
-
let test_named_table_create_kv_collision () =
1711
+
let test_named_kv_collision () =
1712
1712
with_temp_db @@ fun _fs db ->
1713
1713
(* Table.create ~name:"kv" should not silently collide with the
1714
1714
default kv table. *)
···
1748
1748
let rows = Sqlite.read_table db name in
1749
1749
Alcotest.(check int) "1 row in quoted table" 1 (List.length rows)
1750
1750
1751
+
1752
+
(* {1 Hostile-input cases (formerly test_hostile.ml)} *)
1753
+
1754
+
let page_size = 4096
1755
+
let magic = "SQLite format 3\000"
1756
+
1757
+
(* -- Helpers -- *)
1758
+
1759
+
let write_u16_be buf off v =
1760
+
Bytes.set_uint8 buf off ((v lsr 8) land 0xff);
1761
+
Bytes.set_uint8 buf (off + 1) (v land 0xff)
1762
+
1763
+
let write_u32_be buf off v =
1764
+
Bytes.set_uint8 buf off ((v lsr 24) land 0xff);
1765
+
Bytes.set_uint8 buf (off + 1) ((v lsr 16) land 0xff);
1766
+
Bytes.set_uint8 buf (off + 2) ((v lsr 8) land 0xff);
1767
+
Bytes.set_uint8 buf (off + 3) (v land 0xff)
1768
+
1769
+
(* Minimal valid DB header (100 bytes) *)
1770
+
let db_header ~page_count =
1771
+
let buf = Bytes.make 100 '\000' in
1772
+
Bytes.blit_string magic 0 buf 0 16;
1773
+
write_u16_be buf 16 page_size;
1774
+
Bytes.set_uint8 buf 18 1;
1775
+
(* write version *)
1776
+
Bytes.set_uint8 buf 19 1;
1777
+
(* read version *)
1778
+
Bytes.set_uint8 buf 21 64;
1779
+
(* max embedded payload fraction *)
1780
+
Bytes.set_uint8 buf 22 32;
1781
+
(* min embedded payload fraction *)
1782
+
Bytes.set_uint8 buf 23 32;
1783
+
(* leaf payload fraction *)
1784
+
write_u32_be buf 28 page_count;
1785
+
Bytes.unsafe_to_string buf
1786
+
1787
+
(* Write a file with the given pages (page 1 starts at offset 0) *)
1788
+
let write_db path pages =
1789
+
let data =
1790
+
String.concat ""
1791
+
(List.map
1792
+
(fun page ->
1793
+
let s = page in
1794
+
let padded = Bytes.make page_size '\000' in
1795
+
Bytes.blit_string s 0 padded 0 (min (String.length s) page_size);
1796
+
Bytes.unsafe_to_string padded)
1797
+
pages)
1798
+
in
1799
+
Eio.Path.save ~create:(`Or_truncate 0o644) path data
1800
+
1801
+
let with_temp_hostile f =
1802
+
Eio_main.run @@ fun env ->
1803
+
let cwd = Eio.Stdenv.cwd env in
1804
+
let tmp = Eio.Path.(cwd / "_build" / "test_hostile") in
1805
+
(try Eio.Path.mkdirs ~exists_ok:true ~perm:0o755 tmp with Eio.Io _ -> ());
1806
+
let name = Fmt.str "hostile_%d.db" (Random.int 1_000_000) in
1807
+
let path = Eio.Path.(tmp / name) in
1808
+
Eio.Switch.run @@ fun sw -> f sw path
1809
+
1810
+
(* Hostile-input tests assert "must not hang or crash". Sqlite's documented
1811
+
failure modes are [Failure], [Invalid_argument], [Sys_error] (file-system
1812
+
errors), [End_of_file] (truncated databases) and [Sqlite.Unique_violation].
1813
+
Anything else (asserts, fatal errors) is a bug we want to surface. *)
1814
+
let safe_exn = function
1815
+
| Failure _ | Invalid_argument _ | Sys_error _ | End_of_file
1816
+
| Sqlite.Unique_violation _ ->
1817
+
true
1818
+
| _ -> false
1819
+
1820
+
let try_safely f =
1821
+
try ignore (f ()) with e when safe_exn e -> ()
1822
+
1823
+
(* Try to open and do basic operations; must not hang or crash *)
1824
+
let must_fail_or_succeed_safely sw path =
1825
+
match Sqlite.open_ ~sw path with
1826
+
| exception e when safe_exn e -> () (* clean failure on open *)
1827
+
| db ->
1828
+
(* If open succeeded, basic operations must not hang *)
1829
+
try_safely (fun () -> Sqlite.tables db);
1830
+
try_safely (fun () -> Sqlite.find db "nonexistent");
1831
+
Sqlite.close db
1832
+
1833
+
(* -- CVE-2019-19646 inspired: cyclic/self-referential pages -- *)
1834
+
1835
+
let test_self_referential_page () =
1836
+
with_temp_hostile @@ fun sw path ->
1837
+
(* Page 1: sqlite_master with a table whose root points to itself *)
1838
+
let page1 = Bytes.make page_size '\000' in
1839
+
let hdr = db_header ~page_count:2 in
1840
+
Bytes.blit_string hdr 0 page1 0 100;
1841
+
(* sqlite_master leaf header at offset 100 *)
1842
+
Bytes.set_uint8 page1 100 0x0d;
1843
+
(* leaf table *)
1844
+
write_u16_be page1 103 0;
1845
+
(* 0 cells — empty master *)
1846
+
write_u16_be page1 105 page_size;
1847
+
(* Page 2: interior table page pointing to itself *)
1848
+
let page2 = Bytes.make page_size '\000' in
1849
+
Bytes.set_uint8 page2 0 0x05;
1850
+
(* interior table *)
1851
+
write_u16_be page2 3 1;
1852
+
(* 1 cell *)
1853
+
write_u16_be page2 5 (page_size - 12);
1854
+
write_u32_be page2 8 2;
1855
+
(* right child = self *)
1856
+
(* Cell at end: left_child=2 (self), rowid=1 *)
1857
+
let cell_off = page_size - 12 in
1858
+
write_u32_be page2 cell_off 2;
1859
+
(* left child = page 2 = self *)
1860
+
Bytes.set_uint8 page2 (cell_off + 4) 1;
1861
+
(* rowid varint = 1 *)
1862
+
write_u16_be page2 12 (page_size - 12);
1863
+
(* cell pointer *)
1864
+
write_db path [ Bytes.unsafe_to_string page1; Bytes.unsafe_to_string page2 ];
1865
+
must_fail_or_succeed_safely sw path
1866
+
1867
+
(* -- CVE-2022-35737 inspired: oversized payload/varint -- *)
1868
+
1869
+
let test_oversized_varint () =
1870
+
with_temp_hostile @@ fun sw path ->
1871
+
let page1 = Bytes.make page_size '\000' in
1872
+
let hdr = db_header ~page_count:1 in
1873
+
Bytes.blit_string hdr 0 page1 0 100;
1874
+
(* sqlite_master: leaf with 1 cell containing a huge payload_size varint *)
1875
+
Bytes.set_uint8 page1 100 0x0d;
1876
+
write_u16_be page1 103 1;
1877
+
(* 1 cell *)
1878
+
write_u16_be page1 105 200;
1879
+
write_u16_be page1 108 200;
1880
+
(* cell pointer at offset 200 *)
1881
+
(* Cell at 200: payload_size = 9-byte varint (max value) *)
1882
+
let cell_off = 200 in
1883
+
for i = 0 to 7 do
1884
+
Bytes.set_uint8 page1 (cell_off + i) 0xff
1885
+
done;
1886
+
Bytes.set_uint8 page1 (cell_off + 8) 0x01;
1887
+
(* 9th varint byte *)
1888
+
write_db path [ Bytes.unsafe_to_string page1 ];
1889
+
must_fail_or_succeed_safely sw path
1890
+
1891
+
(* -- CVE-2020-13434 inspired: size overflow in record encoding -- *)
1892
+
1893
+
let test_record_header_overflow () =
1894
+
with_temp_hostile @@ fun sw path ->
1895
+
let page1 = Bytes.make page_size '\000' in
1896
+
let hdr = db_header ~page_count:1 in
1897
+
Bytes.blit_string hdr 0 page1 0 100;
1898
+
Bytes.set_uint8 page1 100 0x0d;
1899
+
write_u16_be page1 103 1;
1900
+
write_u16_be page1 105 300;
1901
+
write_u16_be page1 108 300;
1902
+
(* Cell: small payload_size (20), rowid=1, then a record header claiming
1903
+
huge header_size *)
1904
+
let off = 300 in
1905
+
Bytes.set_uint8 page1 off 20;
1906
+
(* payload_size varint = 20 *)
1907
+
Bytes.set_uint8 page1 (off + 1) 1;
1908
+
(* rowid varint = 1 *)
1909
+
(* Record: header_size varint = 255 (way bigger than 20-byte payload) *)
1910
+
Bytes.set_uint8 page1 (off + 2) 0x81;
1911
+
(* varint high byte *)
1912
+
Bytes.set_uint8 page1 (off + 3) 0x7f;
1913
+
(* varint low = 255 *)
1914
+
write_db path [ Bytes.unsafe_to_string page1 ];
1915
+
must_fail_or_succeed_safely sw path
1916
+
1917
+
(* -- CVE-2025-7709 inspired: malformed index B-tree -- *)
1918
+
1919
+
let test_wrong_root_page_kind () =
1920
+
with_temp_hostile @@ fun sw path ->
1921
+
(* Page 2 is supposed to be a table but has index page kind *)
1922
+
let page1 = Bytes.make page_size '\000' in
1923
+
let hdr = db_header ~page_count:2 in
1924
+
Bytes.blit_string hdr 0 page1 0 100;
1925
+
Bytes.set_uint8 page1 100 0x0d;
1926
+
write_u16_be page1 103 0;
1927
+
write_u16_be page1 105 page_size;
1928
+
let page2 = Bytes.make page_size '\000' in
1929
+
(* Set page kind to leaf_index (0x0a) instead of leaf_table (0x0d) *)
1930
+
Bytes.set_uint8 page2 0 0x0a;
1931
+
write_u16_be page2 3 0;
1932
+
write_u16_be page2 5 page_size;
1933
+
write_db path [ Bytes.unsafe_to_string page1; Bytes.unsafe_to_string page2 ];
1934
+
must_fail_or_succeed_safely sw path
1935
+
1936
+
(* -- CVE-2023-7104 inspired: truncated/malformed WAL -- *)
1937
+
1938
+
let test_truncated_wal () =
1939
+
with_temp_hostile @@ fun sw path ->
1940
+
(* Create a valid empty DB first *)
1941
+
Eio.Switch.run @@ fun init_sw ->
1942
+
let db = Sqlite.open_ ~sw:init_sw ~create:true path in
1943
+
Sqlite.put db "key" "value";
1944
+
Sqlite.close db;
1945
+
(* Now write a truncated WAL file *)
1946
+
let wal_path = Eio.Path.(Eio.Path.native_exn path ^ "-wal") in
1947
+
let wal_path = Eio.Path.(Eio.Stdenv.cwd (Eio_main.run Fun.id) / wal_path) in
1948
+
ignore wal_path;
1949
+
(* Write garbage to where the WAL would be *)
1950
+
let wal_name = Eio.Path.native_exn path ^ "-wal" in
1951
+
let oc = open_out_bin wal_name in
1952
+
output_string oc "\x00\x01\x02";
1953
+
(* 3 bytes, way too short *)
1954
+
close_out oc;
1955
+
(* Reopen — must handle the corrupt WAL gracefully *)
1956
+
must_fail_or_succeed_safely sw path;
1957
+
(* Clean up *)
1958
+
try Sys.remove wal_name with Sys_error _ -> ()
1959
+
1960
+
(* -- Root page beyond file -- *)
1961
+
1962
+
let test_root_page_oob () =
1963
+
with_temp_hostile @@ fun sw path ->
1964
+
let page1 = Bytes.make page_size '\000' in
1965
+
let hdr = db_header ~page_count:1 in
1966
+
Bytes.blit_string hdr 0 page1 0 100;
1967
+
(* sqlite_master: leaf with a table entry pointing to page 999 *)
1968
+
Bytes.set_uint8 page1 100 0x0d;
1969
+
write_u16_be page1 103 1;
1970
+
let cell_start = 200 in
1971
+
write_u16_be page1 105 cell_start;
1972
+
write_u16_be page1 108 cell_start;
1973
+
(* Build a sqlite_master record: type=table, name=t, tbl=t, root=999, sql *)
1974
+
let sql = "CREATE TABLE t (x TEXT)" in
1975
+
let payload =
1976
+
Btree.Record.encode
1977
+
[
1978
+
Btree.Record.Vtext "table";
1979
+
Btree.Record.Vtext "t";
1980
+
Btree.Record.Vtext "t";
1981
+
Btree.Record.Vint 999L;
1982
+
Btree.Record.Vtext sql;
1983
+
]
1984
+
in
1985
+
let payload_len = String.length payload in
1986
+
(* Cell: payload_size varint + rowid varint + payload *)
1987
+
Bytes.set_uint8 page1 cell_start payload_len;
1988
+
(* payload_size *)
1989
+
Bytes.set_uint8 page1 (cell_start + 1) 1;
1990
+
(* rowid = 1 *)
1991
+
Bytes.blit_string payload 0 page1 (cell_start + 2) payload_len;
1992
+
write_db path [ Bytes.unsafe_to_string page1 ];
1993
+
(* Open should succeed (just reads master), but accessing the table
1994
+
should fail — not crash *)
1995
+
match Sqlite.open_ ~sw path with
1996
+
| exception _ -> ()
1997
+
| db ->
1998
+
try_safely (fun () ->
1999
+
Sqlite.fold_table db "t" ~init:() ~f:(fun _ _ () -> ()));
2000
+
Sqlite.close db
2001
+
2002
+
(* -- Empty/garbage file -- *)
2003
+
2004
+
let test_empty_file () =
2005
+
with_temp_hostile @@ fun sw path ->
2006
+
Eio.Path.save ~create:(`Or_truncate 0o644) path "";
2007
+
must_fail_or_succeed_safely sw path
2008
+
2009
+
let test_garbage_file () =
2010
+
with_temp_hostile @@ fun sw path ->
2011
+
Eio.Path.save ~create:(`Or_truncate 0o644) path
2012
+
(String.init 4096 (fun _ -> Char.chr (Random.int 256)));
2013
+
must_fail_or_succeed_safely sw path
2014
+
2015
+
(* -- Cell pointer pointing into header -- *)
2016
+
2017
+
let test_cell_pointer_in_header () =
2018
+
with_temp_hostile @@ fun sw path ->
2019
+
let page1 = Bytes.make page_size '\000' in
2020
+
let hdr = db_header ~page_count:1 in
2021
+
Bytes.blit_string hdr 0 page1 0 100;
2022
+
Bytes.set_uint8 page1 100 0x0d;
2023
+
write_u16_be page1 103 1;
2024
+
(* 1 cell *)
2025
+
write_u16_be page1 105 50;
2026
+
(* content starts inside header! *)
2027
+
write_u16_be page1 108 50;
2028
+
(* cell pointer into header area *)
2029
+
write_db path [ Bytes.unsafe_to_string page1 ];
2030
+
must_fail_or_succeed_safely sw path
2031
+
2032
+
(* -- Page count = 0 -- *)
2033
+
2034
+
let test_zero_page_count () =
2035
+
with_temp_hostile @@ fun sw path ->
2036
+
let page1 = Bytes.make page_size '\000' in
2037
+
let hdr = db_header ~page_count:0 in
2038
+
Bytes.blit_string hdr 0 page1 0 100;
2039
+
write_db path [ Bytes.unsafe_to_string page1 ];
2040
+
must_fail_or_succeed_safely sw path
2041
+
2042
+
2043
+
let hostile_cases =
2044
+
[
2045
+
Alcotest.test_case "hostile: self-referential page" `Quick
2046
+
test_self_referential_page;
2047
+
Alcotest.test_case "hostile: oversized varint" `Quick test_oversized_varint;
2048
+
Alcotest.test_case "hostile: record header overflow" `Quick
2049
+
test_record_header_overflow;
2050
+
Alcotest.test_case "hostile: wrong root page kind" `Quick
2051
+
test_wrong_root_page_kind;
2052
+
Alcotest.test_case "hostile: root page oob" `Quick test_root_page_oob;
2053
+
Alcotest.test_case "hostile: empty file" `Quick test_empty_file;
2054
+
Alcotest.test_case "hostile: garbage file" `Quick test_garbage_file;
2055
+
Alcotest.test_case "hostile: cell pointer in header" `Quick
2056
+
test_cell_pointer_in_header;
2057
+
Alcotest.test_case "hostile: zero page count" `Quick test_zero_page_count;
2058
+
]
2059
+
1751
2060
let suite =
1752
2061
( "sqlite",
1753
2062
List.concat
···
1894
2203
];
1895
2204
[
1896
2205
Alcotest.test_case "text pk not rowid alias" `Quick
1897
-
test_text_primary_key_not_rowid_alias;
2206
+
test_text_pk_not_alias;
1898
2207
Alcotest.test_case "text pk persistence" `Quick
1899
2208
test_text_primary_key_persistence;
1900
2209
Alcotest.test_case "real pk not rowid alias" `Quick
1901
-
test_real_primary_key_not_rowid_alias;
2210
+
test_real_pk_not_alias;
1902
2211
];
1903
2212
[
1904
2213
Alcotest.test_case "rollback create table" `Quick
···
1920
2229
Alcotest.test_case "multi index survives close" `Quick
1921
2230
test_multiple_indexes_survive_close;
1922
2231
Alcotest.test_case "kv with generic survives close" `Quick
1923
-
test_kv_table_survives_close_with_generic;
2232
+
test_kv_survives_close_generic;
1924
2233
];
1925
2234
[
1926
2235
Alcotest.test_case "text pk rejects dupes" `Quick
1927
-
test_text_primary_key_rejects_duplicates;
2236
+
test_text_pk_rejects_dups;
1928
2237
Alcotest.test_case "composite pk rejects dupes" `Quick
1929
-
test_composite_primary_key_rejects_duplicates;
2238
+
test_composite_pk_rejects_dups;
1930
2239
Alcotest.test_case "text pk enforced after reopen" `Quick
1931
2240
test_text_primary_key_persists;
1932
2241
];
1933
2242
[
1934
2243
Alcotest.test_case "rollback named table create" `Quick
1935
-
test_transaction_rollback_named_table_create;
2244
+
test_rollback_named_create;
1936
2245
];
1937
2246
[
1938
2247
Alcotest.test_case "dup rowid index consistency" `Quick
···
1944
2253
Alcotest.test_case "create table duplicate name" `Quick
1945
2254
test_create_table_duplicate_name;
1946
2255
Alcotest.test_case "named table kv collision" `Quick
1947
-
test_named_table_create_kv_collision;
2256
+
test_named_kv_collision;
1948
2257
Alcotest.test_case "quoted table name" `Quick test_quoted_table_name;
1949
2258
];
2259
+
hostile_cases;
1950
2260
] )