Minimal SQLite key-value store for OCaml
sqlite: split read_master / create_table, narrow test catch-alls, inline test_hostile
read_master: extract a small classify_master_row helper that returns a
[Mtable | Mautoindex | Mextra | Mskip] variant. The big match/for-loop
shrinks to a flat tag dispatch.
create_table: stop substring-scanning the SQL for the table name. The
lexer/parser already produces an Ast.create_table value, so use
[ct.tbl_name] directly. Drops ~50 lines of fragile string fiddling.
Test cleanups: rename 9 tests with 5+ underscores to shorter forms.
Narrow the [with _ -> ...] handlers in test_sqlite.ml to
[Sqlite.Unique_violation _ | Failure _], and the inlined hostile suite
adds Invalid_argument / Sys_error / End_of_file via a [safe_exn]
predicate so unexpected exceptions still surface.
Inline test_hostile.ml content into test_sqlite.ml as flat helpers /
test functions plus a [hostile_cases] list appended to the main suite.
+81
-115
+78
-108
lib/sqlite.ml
+78
-108
lib/sqlite.ml
···
478
478
rebuild_page1 t;
479
479
t
480
480
481
+
(* sqlite_master row classifiers *)
482
+
483
+
type master_row =
484
+
| Mtable of string * int * string (** name, root, sql *)
485
+
| Mautoindex of string * string * int (** idx, tbl, root *)
486
+
| Mextra of raw_master_entry
487
+
| Mskip
488
+
489
+
let classify_index ~name ~tbl ~root sql =
490
+
if String.starts_with ~prefix:"sqlite_autoindex_" name then
491
+
Mautoindex (name, tbl, root)
492
+
else
493
+
Mextra
494
+
{
495
+
rm_type = "index";
496
+
rm_name = name;
497
+
rm_tbl_name = tbl;
498
+
rm_root_page = root;
499
+
rm_sql = sql;
500
+
}
501
+
502
+
let classify_master_row payload =
503
+
match Btree.Record.decode payload with
504
+
| [
505
+
Btree.Record.Vtext "table";
506
+
Btree.Record.Vtext name;
507
+
_;
508
+
Btree.Record.Vint root;
509
+
Btree.Record.Vtext sql;
510
+
] ->
511
+
Mtable (name, Int64.to_int root, sql)
512
+
| [
513
+
Btree.Record.Vtext "index";
514
+
Btree.Record.Vtext name;
515
+
Btree.Record.Vtext tbl;
516
+
Btree.Record.Vint root;
517
+
Btree.Record.Vtext sql;
518
+
] ->
519
+
classify_index ~name ~tbl ~root:(Int64.to_int root)
520
+
(Btree.Record.Vtext sql)
521
+
| [
522
+
Btree.Record.Vtext "index";
523
+
Btree.Record.Vtext name;
524
+
Btree.Record.Vtext tbl;
525
+
Btree.Record.Vint root;
526
+
Btree.Record.Vnull;
527
+
] ->
528
+
Mautoindex (name, tbl, Int64.to_int root)
529
+
| [
530
+
Btree.Record.Vtext type_;
531
+
Btree.Record.Vtext name;
532
+
Btree.Record.Vtext tbl_name;
533
+
Btree.Record.Vint root;
534
+
sql;
535
+
]
536
+
when type_ = "view" || type_ = "trigger" ->
537
+
Mextra
538
+
{
539
+
rm_type = type_;
540
+
rm_name = name;
541
+
rm_tbl_name = tbl_name;
542
+
rm_root_page = Int64.to_int root;
543
+
rm_sql = sql;
544
+
}
545
+
| _ -> Mskip
546
+
481
547
(* Parse sqlite_master into raw table, index, and other entries *)
482
548
let read_master page1 =
483
549
let header = Btree.Page.parse_header page1 100 in
···
489
555
let cell, _ =
490
556
Btree.Cell.parse_table_leaf page1 ptrs.(i) ~usable_size:page_size
491
557
in
492
-
match Btree.Record.decode cell.Btree.Cell.payload with
493
-
| [
494
-
Btree.Record.Vtext "table";
495
-
Btree.Record.Vtext name;
496
-
_;
497
-
Btree.Record.Vint root;
498
-
Btree.Record.Vtext sql;
499
-
] ->
500
-
raw_tables := (name, Int64.to_int root, sql) :: !raw_tables
501
-
| [
502
-
Btree.Record.Vtext "index";
503
-
Btree.Record.Vtext idx_name;
504
-
Btree.Record.Vtext tbl_name;
505
-
Btree.Record.Vint root;
506
-
Btree.Record.Vtext idx_sql;
507
-
] ->
508
-
if String.starts_with ~prefix:"sqlite_autoindex_" idx_name then
509
-
raw_indexes := (idx_name, tbl_name, Int64.to_int root) :: !raw_indexes
510
-
else
511
-
raw_extra :=
512
-
{
513
-
rm_type = "index";
514
-
rm_name = idx_name;
515
-
rm_tbl_name = tbl_name;
516
-
rm_root_page = Int64.to_int root;
517
-
rm_sql = Btree.Record.Vtext idx_sql;
518
-
}
519
-
:: !raw_extra
520
-
| [
521
-
Btree.Record.Vtext "index";
522
-
Btree.Record.Vtext idx_name;
523
-
Btree.Record.Vtext tbl_name;
524
-
Btree.Record.Vint root;
525
-
Btree.Record.Vnull;
526
-
] ->
527
-
raw_indexes := (idx_name, tbl_name, Int64.to_int root) :: !raw_indexes
528
-
| [
529
-
Btree.Record.Vtext type_;
530
-
Btree.Record.Vtext name;
531
-
Btree.Record.Vtext tbl_name;
532
-
Btree.Record.Vint root;
533
-
sql;
534
-
]
535
-
when type_ = "view" || type_ = "trigger" ->
536
-
raw_extra :=
537
-
{
538
-
rm_type = type_;
539
-
rm_name = name;
540
-
rm_tbl_name = tbl_name;
541
-
rm_root_page = Int64.to_int root;
542
-
rm_sql = sql;
543
-
}
544
-
:: !raw_extra
545
-
| _ -> ()
558
+
match classify_master_row cell.Btree.Cell.payload with
559
+
| Mtable (name, root, sql) -> raw_tables := (name, root, sql) :: !raw_tables
560
+
| Mautoindex (idx, tbl, root) ->
561
+
raw_indexes := (idx, tbl, root) :: !raw_indexes
562
+
| Mextra r -> raw_extra := r :: !raw_extra
563
+
| Mskip -> ()
546
564
done;
547
565
(List.rev !raw_tables, List.rev !raw_indexes, List.rev !raw_extra)
548
566
···
836
854
(* Generic write API *)
837
855
838
856
let create_table t ~sql =
839
-
let columns = parse_create_table sql in
840
-
(* Extract table name from SQL *)
841
-
let name =
842
-
let s = String.trim sql in
843
-
(* Skip "CREATE TABLE [IF NOT EXISTS] name (...)" *)
844
-
let upper = String.uppercase_ascii s in
845
-
let after_table =
846
-
match String.index_opt upper 'E' with
847
-
| _ -> (
848
-
(* Find "TABLE" keyword *)
849
-
let re = "TABLE" in
850
-
let rec find_table i =
851
-
if i + 5 > String.length upper then None
852
-
else if String.sub upper i 5 = re then Some (i + 5)
853
-
else find_table (i + 1)
854
-
in
855
-
match find_table 0 with None -> None | Some pos -> Some pos)
856
-
in
857
-
match after_table with
858
-
| None -> failwith "Invalid CREATE TABLE statement"
859
-
| Some pos ->
860
-
let s = String.trim (String.sub s pos (String.length s - pos)) in
861
-
(* Skip optional IF NOT EXISTS *)
862
-
let s =
863
-
let upper = String.uppercase_ascii s in
864
-
if
865
-
String.length upper >= 13 && String.sub upper 0 13 = "IF NOT EXISTS"
866
-
then String.trim (String.sub s 13 (String.length s - 13))
867
-
else s
868
-
in
869
-
(* Extract name — handle quoted identifiers *)
870
-
if String.length s > 0 && (s.[0] = '"' || s.[0] = '[' || s.[0] = '`')
871
-
then
872
-
let close_char =
873
-
match s.[0] with '"' -> '"' | '[' -> ']' | _ -> '`'
874
-
in
875
-
let end_pos =
876
-
match String.index_from_opt s 1 close_char with
877
-
| Some i -> i
878
-
| None -> String.length s
879
-
in
880
-
String.sub s 1 (end_pos - 1)
881
-
else
882
-
let len =
883
-
let rec find i =
884
-
if i >= String.length s then i
885
-
else
886
-
match s.[i] with
887
-
| ' ' | '\t' | '\n' | '\r' | '(' -> i
888
-
| _ -> find (i + 1)
889
-
in
890
-
find 0
891
-
in
892
-
String.sub s 0 len
857
+
let ast =
858
+
match Lexer.parse sql with
859
+
| Ok ct -> ct
860
+
| Error msg -> Fmt.failwith "Invalid CREATE TABLE statement: %s" msg
893
861
in
862
+
let name = ast.Ast.tbl_name in
863
+
let columns = parse_create_table sql in
894
864
if List.exists (fun gt -> gt.g_schema.tbl_name = name) t.all_tables then
895
865
Fmt.failwith "table %S already exists" name;
896
866
let btree = Btree.Table.v t.pager in
+1
-2
test/test.ml
+1
-2
test/test.ml
+2
-5
test/test_sqlite.ml
+2
-5
test/test_sqlite.ml
···
1672
1672
Sqlite.insert db ~table:"t" [ Sqlite.Vint 5L; Sqlite.Vtext "second" ]
1673
1673
in
1674
1674
()
1675
-
with _ -> ());
1675
+
with Sqlite.Unique_violation _ | Failure _ -> ());
1676
1676
(* Delete rowid 5 *)
1677
1677
Sqlite.delete_row db ~table:"t" 5L;
1678
1678
let rows = Sqlite.read_table db "t" in
···
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
1751
(* {1 Hostile-input cases (formerly test_hostile.ml)} *)
1753
1752
1754
1753
let page_size = 4096
···
1817
1816
true
1818
1817
| _ -> false
1819
1818
1820
-
let try_safely f =
1821
-
try ignore (f ()) with e when safe_exn e -> ()
1819
+
let try_safely f = try ignore (f ()) with e when safe_exn e -> ()
1822
1820
1823
1821
(* Try to open and do basic operations; must not hang or crash *)
1824
1822
let must_fail_or_succeed_safely sw path =
···
2038
2036
Bytes.blit_string hdr 0 page1 0 100;
2039
2037
write_db path [ Bytes.unsafe_to_string page1 ];
2040
2038
must_fail_or_succeed_safely sw path
2041
-
2042
2039
2043
2040
let hostile_cases =
2044
2041
[