Minimal SQLite key-value store for OCaml
ocaml-sqlite: add generic read API for any SQLite database
open_ no longer requires a 'kv' table — it parses CREATE TABLE SQL from
sqlite_master to build schemas for every table. New generic read API
(tables, iter_table, fold_table, read_table) lets callers read any SQLite
database. INTEGER PRIMARY KEY columns get rowid substitution, and trailing
NULLs are padded per the SQLite storage optimization.
CLI gains `sql tables DB` and `sql read DB -t TABLE` subcommands.
+820
-65
+110
-16
bin/sql.ml
+110
-16
bin/sql.ml
···
58
58
59
59
(* -- read subcommand -- *)
60
60
61
-
let read () db =
61
+
let pp_value_pipe ppf = function
62
+
| Sqlite.Vnull -> Fmt.string ppf "NULL"
63
+
| Sqlite.Vint n -> Fmt.pf ppf "%Ld" n
64
+
| Sqlite.Vfloat f -> Fmt.pf ppf "%f" f
65
+
| Sqlite.Vblob s -> Fmt.pf ppf "BLOB(%d)" (String.length s)
66
+
| Sqlite.Vtext s -> Fmt.pf ppf "%S" s
67
+
68
+
let read () db table_name =
62
69
Eio_main.run @@ fun env ->
63
70
let cwd = Eio.Stdenv.cwd env in
64
71
Eio.Switch.run @@ fun sw ->
65
72
let path = Eio.Path.(cwd / db) in
66
73
let t = Sqlite.open_ ~sw path in
67
-
if Tty.is_tty () then begin
68
-
let rows = ref [] in
69
-
Sqlite.iter t ~f:(fun k v ->
70
-
rows := [ Tty.Span.text k; Tty.Span.text v ] :: !rows);
71
-
let rows = List.rev !rows in
72
-
let table =
73
-
Tty.Table.(
74
-
of_rows ~border:Tty.Border.rounded [ column "key"; column "value" ] rows)
75
-
in
76
-
Tty.Table.pp Format.std_formatter table
77
-
end
78
-
else Sqlite.iter t ~f:(fun k v -> Fmt.pr "%s|%s@." k v);
74
+
(match table_name with
75
+
| None ->
76
+
(* Original KV behavior *)
77
+
if Tty.is_tty () then begin
78
+
let rows = ref [] in
79
+
Sqlite.iter t ~f:(fun k v ->
80
+
rows := [ Tty.Span.text k; Tty.Span.text v ] :: !rows);
81
+
let rows = List.rev !rows in
82
+
let table =
83
+
Tty.Table.(
84
+
of_rows ~border:Tty.Border.rounded
85
+
[ column "key"; column "value" ]
86
+
rows)
87
+
in
88
+
Tty.Table.pp Format.std_formatter table
89
+
end
90
+
else Sqlite.iter t ~f:(fun k v -> Fmt.pr "%s|%s@." k v)
91
+
| Some name ->
92
+
(* Generic table read *)
93
+
if Tty.is_tty () then begin
94
+
let schemas = Sqlite.tables t in
95
+
let schema = List.find (fun s -> s.Sqlite.tbl_name = name) schemas in
96
+
let cols =
97
+
List.map
98
+
(fun c -> Tty.Table.column c.Sqlite.col_name)
99
+
schema.Sqlite.columns
100
+
in
101
+
let rows = ref [] in
102
+
Sqlite.iter_table t name ~f:(fun _rowid values ->
103
+
let row =
104
+
List.map
105
+
(fun v -> Tty.Span.text (Fmt.str "%a" pp_value_pipe v))
106
+
values
107
+
in
108
+
rows := row :: !rows);
109
+
let rows = List.rev !rows in
110
+
let table = Tty.Table.(of_rows ~border:Tty.Border.rounded cols rows) in
111
+
Tty.Table.pp Format.std_formatter table
112
+
end
113
+
else
114
+
Sqlite.iter_table t name ~f:(fun _rowid values ->
115
+
let strs =
116
+
List.map (fun v -> Fmt.str "%a" pp_value_pipe v) values
117
+
in
118
+
Fmt.pr "%s@." (String.concat "|" strs)));
79
119
Sqlite.close t
80
120
81
121
let read_cmd =
···
85
125
& pos 0 (some string) None
86
126
& info [] ~docv:"DB" ~doc:"Database file path.")
87
127
in
128
+
let table_name =
129
+
Arg.(
130
+
value
131
+
& opt (some string) None
132
+
& info [ "t"; "table" ] ~docv:"TABLE"
133
+
~doc:"Table to read. Defaults to the kv table.")
134
+
in
88
135
let info =
89
136
Cmd.info "read" ~doc:"Read all entries from a database."
90
137
~man:
···
94
141
`P
95
142
"When stdout is a terminal, output is rendered as a table. \
96
143
Otherwise, entries are printed as pipe-separated values.";
144
+
`P
145
+
"Use $(b,--table) to read a specific table. Without it, reads the \
146
+
default $(b,kv) table.";
97
147
`S Manpage.s_examples;
98
148
`P "$(iname) mydb.db";
99
-
`Pre " sqlite3 mydb.db 'SELECT * FROM kv' | head";
149
+
`P "$(iname) mydb.db -t users";
100
150
]
101
151
in
102
-
Cmd.v info Term.(const read $ Vlog.setup "sql" $ db)
152
+
Cmd.v info Term.(const read $ Vlog.setup "sql" $ db $ table_name)
103
153
104
154
(* -- delete subcommand -- *)
105
155
···
140
190
in
141
191
Cmd.v info Term.(const delete $ Vlog.setup "sql" $ db $ keys)
142
192
193
+
(* -- tables subcommand -- *)
194
+
195
+
let tables () db =
196
+
Eio_main.run @@ fun env ->
197
+
let cwd = Eio.Stdenv.cwd env in
198
+
Eio.Switch.run @@ fun sw ->
199
+
let path = Eio.Path.(cwd / db) in
200
+
let t = Sqlite.open_ ~sw path in
201
+
let schemas = Sqlite.tables t in
202
+
List.iter
203
+
(fun (s : Sqlite.schema) ->
204
+
let cols =
205
+
List.map
206
+
(fun (c : Sqlite.column) ->
207
+
let base =
208
+
if c.col_affinity = "" then c.col_name
209
+
else c.col_name ^ " " ^ c.col_affinity
210
+
in
211
+
if c.col_is_rowid_alias then base ^ " PRIMARY KEY" else base)
212
+
s.columns
213
+
in
214
+
Fmt.pr "%s (%s)@." s.tbl_name (String.concat ", " cols))
215
+
schemas;
216
+
Sqlite.close t
217
+
218
+
let tables_cmd =
219
+
let db =
220
+
Arg.(
221
+
required
222
+
& pos 0 (some string) None
223
+
& info [] ~docv:"DB" ~doc:"Database file path.")
224
+
in
225
+
let info =
226
+
Cmd.info "tables" ~doc:"List tables in a database."
227
+
~man:
228
+
[
229
+
`S Manpage.s_description;
230
+
`P "List all tables and their schemas in a SQLite database.";
231
+
`S Manpage.s_examples;
232
+
`P "$(iname) mydb.db";
233
+
]
234
+
in
235
+
Cmd.v info Term.(const tables $ Vlog.setup "sql" $ db)
236
+
143
237
(* -- main -- *)
144
238
145
239
let main_cmd =
···
155
249
be read by the $(b,sqlite3) CLI and vice versa.";
156
250
]
157
251
in
158
-
Cmd.group info [ write_cmd; read_cmd; delete_cmd ]
252
+
Cmd.group info [ write_cmd; read_cmd; delete_cmd; tables_cmd ]
159
253
160
254
let () = exit (Cmd.eval main_cmd)
+351
-39
lib/sqlite.ml
+351
-39
lib/sqlite.ml
···
13
13
let page_size = 4096
14
14
let magic = "SQLite format 3\000"
15
15
16
+
(* Re-export Btree.Record.value so users don't need to depend on btree *)
17
+
18
+
type value = Btree.Record.value =
19
+
| Vnull
20
+
| Vint of int64
21
+
| Vfloat of float
22
+
| Vblob of string
23
+
| Vtext of string
24
+
25
+
let pp_value = Btree.Record.pp_value
26
+
27
+
(* Schema types *)
28
+
29
+
type column = {
30
+
col_name : string;
31
+
col_affinity : string;
32
+
col_is_rowid_alias : bool;
33
+
}
34
+
35
+
type schema = { tbl_name : string; columns : column list; sql : string }
36
+
16
37
(* Per-table state *)
17
38
type kv_table = {
18
39
btree : Btree.Table.t;
···
20
41
mutable next_rowid : int64;
21
42
}
22
43
44
+
type generic_table = { g_btree : Btree.Table.t; g_schema : schema }
45
+
23
46
type t = {
24
47
pager : Btree.Pager.t;
25
-
mutable data : kv_table;
48
+
mutable data : kv_table option;
26
49
mutable named_tables : (string * kv_table) list;
50
+
mutable all_tables : generic_table list;
27
51
}
28
52
53
+
(* CREATE TABLE parser *)
54
+
55
+
let is_space = function ' ' | '\t' | '\n' | '\r' -> true | _ -> false
56
+
57
+
(* Split a string by commas, respecting nested parentheses *)
58
+
let split_respecting_parens s =
59
+
let len = String.length s in
60
+
let buf = Buffer.create 64 in
61
+
let parts = ref [] in
62
+
let depth = ref 0 in
63
+
for i = 0 to len - 1 do
64
+
match s.[i] with
65
+
| '(' ->
66
+
incr depth;
67
+
Buffer.add_char buf '('
68
+
| ')' ->
69
+
decr depth;
70
+
Buffer.add_char buf ')'
71
+
| ',' when !depth = 0 ->
72
+
parts := String.trim (Buffer.contents buf) :: !parts;
73
+
Buffer.clear buf
74
+
| c -> Buffer.add_char buf c
75
+
done;
76
+
let last = String.trim (Buffer.contents buf) in
77
+
if last <> "" then parts := last :: !parts;
78
+
List.rev !parts
79
+
80
+
(* Find the position of the matching closing paren *)
81
+
let find_matching_paren s start =
82
+
let len = String.length s in
83
+
let rec loop i depth =
84
+
if i >= len then None
85
+
else
86
+
match s.[i] with
87
+
| '(' -> loop (i + 1) (depth + 1)
88
+
| ')' -> if depth = 0 then Some i else loop (i + 1) (depth - 1)
89
+
| '\'' ->
90
+
(* Skip single-quoted string literal *)
91
+
let rec skip j =
92
+
if j >= len then loop j 0
93
+
else if s.[j] = '\'' then
94
+
if j + 1 < len && s.[j + 1] = '\'' then skip (j + 2)
95
+
else loop (j + 1) depth
96
+
else skip (j + 1)
97
+
in
98
+
skip (i + 1)
99
+
| '"' ->
100
+
let rec skip j =
101
+
if j >= len then loop j 0
102
+
else if s.[j] = '"' then loop (j + 1) depth
103
+
else skip (j + 1)
104
+
in
105
+
skip (i + 1)
106
+
| _ -> loop (i + 1) depth
107
+
in
108
+
loop (start + 1) 0
109
+
110
+
(* Tokenize a column definition into words, handling quoted identifiers
111
+
and parenthesized type parameters like DECIMAL(10,2) *)
112
+
let tokenize s =
113
+
let len = String.length s in
114
+
let buf = Buffer.create 16 in
115
+
let tokens = ref [] in
116
+
let flush () =
117
+
if Buffer.length buf > 0 then begin
118
+
tokens := Buffer.contents buf :: !tokens;
119
+
Buffer.clear buf
120
+
end
121
+
in
122
+
let i = ref 0 in
123
+
while !i < len do
124
+
match s.[!i] with
125
+
| c when is_space c ->
126
+
flush ();
127
+
incr i
128
+
| '(' ->
129
+
(* Include parenthesized content as part of current token *)
130
+
Buffer.add_char buf '(';
131
+
let depth = ref 1 in
132
+
incr i;
133
+
while !i < len && !depth > 0 do
134
+
(match s.[!i] with '(' -> incr depth | ')' -> decr depth | _ -> ());
135
+
Buffer.add_char buf s.[!i];
136
+
incr i
137
+
done
138
+
| '"' ->
139
+
(* Double-quoted identifier: strip quotes *)
140
+
incr i;
141
+
while !i < len && s.[!i] <> '"' do
142
+
Buffer.add_char buf s.[!i];
143
+
incr i
144
+
done;
145
+
if !i < len then incr i
146
+
| '[' ->
147
+
(* Bracket-quoted identifier: strip brackets *)
148
+
incr i;
149
+
while !i < len && s.[!i] <> ']' do
150
+
Buffer.add_char buf s.[!i];
151
+
incr i
152
+
done;
153
+
if !i < len then incr i
154
+
| '`' ->
155
+
(* Backtick-quoted identifier: strip backticks *)
156
+
incr i;
157
+
while !i < len && s.[!i] <> '`' do
158
+
Buffer.add_char buf s.[!i];
159
+
incr i
160
+
done;
161
+
if !i < len then incr i
162
+
| c ->
163
+
Buffer.add_char buf c;
164
+
incr i
165
+
done;
166
+
flush ();
167
+
List.rev !tokens
168
+
169
+
(* Keywords that start constraint clauses in column definitions *)
170
+
let constraint_keywords =
171
+
[
172
+
"PRIMARY";
173
+
"NOT";
174
+
"UNIQUE";
175
+
"DEFAULT";
176
+
"CHECK";
177
+
"REFERENCES";
178
+
"COLLATE";
179
+
"GENERATED";
180
+
"AUTOINCREMENT";
181
+
"ASC";
182
+
"DESC";
183
+
"ON";
184
+
"CONSTRAINT";
185
+
]
186
+
187
+
(* Check if a column def is a table-level constraint *)
188
+
let is_table_constraint s =
189
+
let upper = String.uppercase_ascii (String.trim s) in
190
+
let starts_with prefix =
191
+
String.length upper >= String.length prefix
192
+
&& String.sub upper 0 (String.length prefix) = prefix
193
+
in
194
+
starts_with "PRIMARY KEY(" || starts_with "PRIMARY KEY "
195
+
|| starts_with "UNIQUE(" || starts_with "UNIQUE " || starts_with "FOREIGN KEY"
196
+
|| starts_with "CONSTRAINT " || starts_with "CHECK(" || starts_with "CHECK "
197
+
198
+
let parse_column_def s =
199
+
if is_table_constraint s then None
200
+
else
201
+
let tokens = tokenize s in
202
+
match tokens with
203
+
| [] -> None
204
+
| name :: rest ->
205
+
(* Collect type tokens until we hit a constraint keyword *)
206
+
let rec collect_type acc = function
207
+
| [] -> (List.rev acc, [])
208
+
| tok :: _ as all
209
+
when List.mem (String.uppercase_ascii tok) constraint_keywords ->
210
+
(List.rev acc, all)
211
+
| tok :: tl -> collect_type (tok :: acc) tl
212
+
in
213
+
let type_tokens, constraint_tokens = collect_type [] rest in
214
+
let affinity = String.concat " " type_tokens in
215
+
(* INTEGER PRIMARY KEY is a rowid alias *)
216
+
let is_rowid_alias =
217
+
String.uppercase_ascii affinity = "INTEGER"
218
+
&&
219
+
let rec has_pk = function
220
+
| "PRIMARY" :: "KEY" :: _ -> true
221
+
| _ :: tl -> has_pk tl
222
+
| [] -> false
223
+
in
224
+
has_pk (List.map String.uppercase_ascii constraint_tokens)
225
+
in
226
+
Some
227
+
{
228
+
col_name = name;
229
+
col_affinity = affinity;
230
+
col_is_rowid_alias = is_rowid_alias;
231
+
}
232
+
233
+
let parse_create_table sql =
234
+
match String.index_opt sql '(' with
235
+
| None -> []
236
+
| Some start -> (
237
+
match find_matching_paren sql start with
238
+
| None -> []
239
+
| Some body_end ->
240
+
let body = String.sub sql (start + 1) (body_end - start - 1) in
241
+
let parts = split_respecting_parens body in
242
+
List.filter_map parse_column_def parts)
243
+
244
+
(* Standard kv table schema *)
245
+
let kv_columns =
246
+
[
247
+
{ col_name = "key"; col_affinity = "TEXT"; col_is_rowid_alias = false };
248
+
{ col_name = "value"; col_affinity = "BLOB"; col_is_rowid_alias = false };
249
+
]
250
+
251
+
let table_sql name = Fmt.str "CREATE TABLE %s (key TEXT, value BLOB)" name
252
+
253
+
let kv_schema name =
254
+
{ tbl_name = name; columns = kv_columns; sql = table_sql name }
255
+
29
256
(* Decode a Record payload into (key, value) *)
30
257
let decode_kv payload =
31
258
match Btree.Record.decode payload with
···
88
315
let rowid_varint = Btree.Varint.encode rowid in
89
316
payload_varint ^ rowid_varint ^ record
90
317
91
-
let table_sql name = Fmt.str "CREATE TABLE %s (key TEXT, value BLOB)" name
92
-
93
318
(* Write page 1: db header + sqlite_master leaf table *)
94
319
let rebuild_page1 t =
95
320
let buf = Bytes.create page_size in
···
98
323
Bytes.set_uint8 buf 100 0x0d;
99
324
Btree.Page.set_u16_be buf 101 0;
100
325
Bytes.set_uint8 buf 107 0;
101
-
(* Collect all tables *)
326
+
(* Collect all tables from all_tables *)
102
327
let tables =
103
-
("kv", Btree.Table.root_page t.data.btree, table_sql "kv")
104
-
:: List.map
105
-
(fun (name, kv) ->
106
-
(name, Btree.Table.root_page kv.btree, table_sql name))
107
-
t.named_tables
328
+
List.map
329
+
(fun gt ->
330
+
(gt.g_schema.tbl_name, Btree.Table.root_page gt.g_btree, gt.g_schema.sql))
331
+
t.all_tables
108
332
in
109
333
let n = List.length tables in
110
334
Btree.Page.set_u16_be buf 103 n;
···
152
376
(* Allocate page 1 for db header + sqlite_master *)
153
377
let _page1 = Btree.Pager.allocate pager in
154
378
(* Create kv data table on page 2 *)
155
-
let data = new_kv_table pager in
156
-
let t = { pager; data; named_tables = [] } in
379
+
let kv = new_kv_table pager in
380
+
let gt = { g_btree = kv.btree; g_schema = kv_schema "kv" } in
381
+
let t = { pager; data = Some kv; named_tables = []; all_tables = [ gt ] } in
157
382
rebuild_page1 t;
158
383
t
159
384
160
385
let in_memory () =
161
386
let pager = Btree.Pager.mem ~page_size () in
162
387
let _page1 = Btree.Pager.allocate pager in
163
-
let data = new_kv_table pager in
164
-
let t = { pager; data; named_tables = [] } in
388
+
let kv = new_kv_table pager in
389
+
let gt = { g_btree = kv.btree; g_schema = kv_schema "kv" } in
390
+
let t = { pager; data = Some kv; named_tables = []; all_tables = [ gt ] } in
165
391
rebuild_page1 t;
166
392
t
167
393
···
180
406
(* Parse sqlite_master at offset 100 *)
181
407
let header = Btree.Page.parse_header page1 100 in
182
408
let ptrs = Btree.Page.cell_pointers page1 100 header in
183
-
let tables = ref [] in
409
+
let raw_tables = ref [] in
184
410
for i = 0 to header.Btree.Page.cell_count - 1 do
185
411
let cell, _ =
186
412
Btree.Cell.parse_table_leaf page1 ptrs.(i) ~usable_size:page_size
···
191
417
Btree.Record.Vtext name;
192
418
_;
193
419
Btree.Record.Vint root;
194
-
_;
420
+
Btree.Record.Vtext sql;
195
421
] ->
196
-
tables := (name, Int64.to_int root) :: !tables
422
+
raw_tables := (name, Int64.to_int root, sql) :: !raw_tables
197
423
| _ -> ()
198
424
done;
199
-
(* Open the main kv table *)
200
-
let kv_root =
201
-
match List.assoc_opt "kv" !tables with
202
-
| Some r -> r
203
-
| None -> failwith "No 'kv' table found in database"
425
+
let raw_tables = List.rev !raw_tables in
426
+
(* Build generic_table for every table *)
427
+
let all_tables =
428
+
List.map
429
+
(fun (name, root, sql) ->
430
+
let btree = Btree.Table.open_ pager ~root_page:root in
431
+
let columns = parse_create_table sql in
432
+
let schema = { tbl_name = name; columns; sql } in
433
+
{ g_btree = btree; g_schema = schema })
434
+
raw_tables
435
+
in
436
+
(* Try to find "kv" table for backward compat *)
437
+
let data =
438
+
match List.find_opt (fun gt -> gt.g_schema.tbl_name = "kv") all_tables with
439
+
| None -> None
440
+
| Some gt ->
441
+
let keys, next_rowid = scan_table gt.g_btree in
442
+
Some { btree = gt.g_btree; keys; next_rowid }
204
443
in
205
-
let kv_btree = Btree.Table.open_ pager ~root_page:kv_root in
206
-
let keys, next_rowid = scan_table kv_btree in
207
-
let data = { btree = kv_btree; keys; next_rowid } in
208
-
(* Open named tables *)
444
+
(* Open named kv tables (non-kv tables with kv schema) *)
209
445
let named =
210
446
List.filter_map
211
-
(fun (name, root) ->
447
+
(fun gt ->
448
+
let name = gt.g_schema.tbl_name in
212
449
if name = "kv" then None
213
450
else
214
-
let btree = Btree.Table.open_ pager ~root_page:root in
215
-
let keys, next_rowid = scan_table btree in
216
-
Some (name, { btree; keys; next_rowid }))
217
-
!tables
451
+
(* Only treat as kv_table if it has the kv schema *)
452
+
match gt.g_schema.columns with
453
+
| [
454
+
{ col_name = "key"; col_affinity = "TEXT"; _ };
455
+
{ col_name = "value"; col_affinity = "BLOB"; _ };
456
+
] ->
457
+
let keys, next_rowid = scan_table gt.g_btree in
458
+
Some (name, { btree = gt.g_btree; keys; next_rowid })
459
+
| _ -> None)
460
+
all_tables
218
461
in
219
-
{ pager; data; named_tables = named }
462
+
{ pager; data; named_tables = named; all_tables }
463
+
464
+
(* Get the kv_table, raising if no kv table exists *)
465
+
let kv t =
466
+
match t.data with
467
+
| Some d -> d
468
+
| None -> failwith "No 'kv' table in this database"
220
469
221
470
(* KV operations *)
222
471
223
472
let find t key =
224
-
match Hashtbl.find_opt t.data.keys key with
473
+
let d = kv t in
474
+
match Hashtbl.find_opt d.keys key with
225
475
| None -> None
226
476
| Some rowid -> (
227
-
match Btree.Table.find t.data.btree rowid with
477
+
match Btree.Table.find d.btree rowid with
228
478
| None -> None
229
479
| Some payload -> (
230
480
match decode_kv payload with Some (_, v) -> Some v | None -> None))
231
481
232
482
let put t key value =
233
-
let kv = t.data in
483
+
let kv = kv t in
234
484
let record =
235
485
Btree.Record.encode [ Btree.Record.Vtext key; Btree.Record.Vblob value ]
236
486
in
···
243
493
Hashtbl.replace kv.keys key rowid
244
494
245
495
let delete t key =
246
-
match Hashtbl.find_opt t.data.keys key with
496
+
let d = kv t in
497
+
match Hashtbl.find_opt d.keys key with
247
498
| None -> ()
248
499
| Some rowid ->
249
-
Btree.Table.delete t.data.btree rowid;
250
-
Hashtbl.remove t.data.keys key
500
+
Btree.Table.delete d.btree rowid;
501
+
Hashtbl.remove d.keys key
251
502
252
-
let mem t key = Hashtbl.mem t.data.keys key
503
+
let mem t key =
504
+
let d = kv t in
505
+
Hashtbl.mem d.keys key
253
506
254
507
let iter t ~f =
255
-
Btree.Table.iter t.data.btree (fun _rowid payload ->
508
+
let d = kv t in
509
+
Btree.Table.iter d.btree (fun _rowid payload ->
256
510
match decode_kv payload with Some (k, v) -> f k v | None -> ())
257
511
258
512
let fold t ~init ~f =
···
266
520
267
521
let close t = sync t
268
522
523
+
(* Generic read API *)
524
+
525
+
let tables t = List.map (fun gt -> gt.g_schema) t.all_tables
526
+
527
+
let find_table t name =
528
+
match List.find_opt (fun gt -> gt.g_schema.tbl_name = name) t.all_tables with
529
+
| Some gt -> gt
530
+
| None -> Fmt.failwith "No table %S found in database" name
531
+
532
+
(* Find the index of the rowid alias column, if any *)
533
+
let rowid_alias_index columns =
534
+
let rec find i = function
535
+
| [] -> None
536
+
| c :: _ when c.col_is_rowid_alias -> Some i
537
+
| _ :: rest -> find (i + 1) rest
538
+
in
539
+
find 0 columns
540
+
541
+
(* Apply rowid substitution and trailing Vnull padding *)
542
+
let fixup_values ~schema ~rowid values =
543
+
let n_cols = List.length schema.columns in
544
+
let len = List.length values in
545
+
let values =
546
+
if len < n_cols then
547
+
values @ List.init (n_cols - len) (fun _ -> Btree.Record.Vnull)
548
+
else values
549
+
in
550
+
match rowid_alias_index schema.columns with
551
+
| None -> values
552
+
| Some idx ->
553
+
List.mapi
554
+
(fun i v ->
555
+
if i = idx then
556
+
match v with
557
+
| Btree.Record.Vnull -> Btree.Record.Vint rowid
558
+
| v -> v
559
+
else v)
560
+
values
561
+
562
+
let iter_table t name ~f =
563
+
let gt = find_table t name in
564
+
let schema = gt.g_schema in
565
+
Btree.Table.iter gt.g_btree (fun rowid payload ->
566
+
let values = Btree.Record.decode payload in
567
+
let values = fixup_values ~schema ~rowid values in
568
+
f rowid values)
569
+
570
+
let fold_table t name ~init ~f =
571
+
let acc = ref init in
572
+
iter_table t name ~f:(fun rowid values -> acc := f rowid values !acc);
573
+
!acc
574
+
575
+
let read_table t name =
576
+
fold_table t name ~init:[] ~f:(fun rowid values acc -> (rowid, values) :: acc)
577
+
|> List.rev
578
+
269
579
(* Namespaced Tables *)
270
580
271
581
module Table = struct
···
292
602
| Some kv -> { parent; name; kv }
293
603
| None ->
294
604
let kv = new_kv_table parent.pager in
605
+
let gt = { g_btree = kv.btree; g_schema = kv_schema name } in
295
606
parent.named_tables <- (name, kv) :: parent.named_tables;
607
+
parent.all_tables <- parent.all_tables @ [ gt ];
296
608
{ parent; name; kv }
297
609
298
610
let find t key =
+74
-8
lib/sqlite.mli
+74
-8
lib/sqlite.mli
···
6
6
(** Pure OCaml B-tree backed key-value store.
7
7
8
8
A simple key-value store with SQLite-compatible semantics using a pure OCaml
9
-
B-tree implementation. Supports namespaced tables. *)
9
+
B-tree implementation. Supports namespaced tables and reading any SQLite
10
+
database. *)
10
11
11
12
type t
12
13
(** A B-tree backed key-value store. *)
13
14
15
+
(** {1 Record Values}
16
+
17
+
Re-exported from {!Btree.Record} so users don't need to depend on btree
18
+
directly. *)
19
+
20
+
type value = Btree.Record.value =
21
+
| Vnull
22
+
| Vint of int64
23
+
| Vfloat of float
24
+
| Vblob of string
25
+
| Vtext of string (** Column values decoded from SQLite records. *)
26
+
27
+
val pp_value : Format.formatter -> value -> unit
28
+
(** Pretty-print a value. *)
29
+
30
+
(** {1 Schema} *)
31
+
32
+
type column = {
33
+
col_name : string;
34
+
col_affinity : string;
35
+
col_is_rowid_alias : bool;
36
+
}
37
+
(** A column definition parsed from CREATE TABLE SQL. [col_is_rowid_alias] is
38
+
[true] for [INTEGER PRIMARY KEY] columns, which are aliases for the rowid.
39
+
*)
40
+
41
+
type schema = { tbl_name : string; columns : column list; sql : string }
42
+
(** Table schema with the original CREATE TABLE SQL. *)
43
+
44
+
(** {1 Database Lifecycle} *)
45
+
14
46
val v : sw:Eio.Switch.t -> Eio.Fs.dir_ty Eio.Path.t -> t
15
47
(** [v ~sw path] creates a new database at [path]. If a file already exists at
16
48
[path], it will be truncated. The switch [sw] controls the lifetime of the
···
21
53
performed. Useful for testing. *)
22
54
23
55
val open_ : sw:Eio.Switch.t -> Eio.Fs.dir_ty Eio.Path.t -> t
24
-
(** [open_ ~sw path] opens an existing database at [path]. The switch [sw]
25
-
controls the lifetime of the underlying file handle.
26
-
@raise Failure if the file doesn't exist. *)
56
+
(** [open_ ~sw path] opens an existing database at [path]. Works with any SQLite
57
+
database, not just ones created by this library. If the database contains a
58
+
[kv] table, the KV API functions below will work; otherwise, use the generic
59
+
read API.
60
+
@raise Failure if the file doesn't exist or is not a valid SQLite database.
61
+
*)
62
+
63
+
val sync : t -> unit
64
+
(** [sync t] flushes all pending writes to disk. *)
65
+
66
+
val close : t -> unit
67
+
(** [close t] syncs and closes the database. *)
68
+
69
+
(** {1 Key-Value API}
70
+
71
+
These functions operate on the default [kv] table. They raise [Failure] if
72
+
the database was opened from a file that has no [kv] table. *)
27
73
28
74
val find : t -> string -> string option
29
75
(** [find t key] returns the value for [key], or [None] if not found. *)
···
43
89
val fold : t -> init:'a -> f:(string -> string -> 'a -> 'a) -> 'a
44
90
(** [fold t ~init ~f] folds over all entries in the store. *)
45
91
46
-
val sync : t -> unit
47
-
(** [sync t] flushes all pending writes to disk. *)
92
+
(** {1 Generic Read API}
93
+
94
+
Read any table in the database, regardless of schema. *)
95
+
96
+
val tables : t -> schema list
97
+
(** [tables t] returns the schema of every table in the database. *)
98
+
99
+
val iter_table : t -> string -> f:(int64 -> value list -> unit) -> unit
100
+
(** [iter_table t name ~f] calls [f rowid values] for each row in table [name].
101
+
For [INTEGER PRIMARY KEY] columns, [Vnull] is replaced with [Vint rowid].
102
+
Trailing [Vnull]s are padded if the record has fewer values than columns.
103
+
@raise Failure if the table doesn't exist. *)
48
104
49
-
val close : t -> unit
50
-
(** [close t] syncs and closes the database. *)
105
+
val fold_table :
106
+
t -> string -> init:'a -> f:(int64 -> value list -> 'a -> 'a) -> 'a
107
+
(** [fold_table t name ~init ~f] folds over all rows in table [name]. *)
108
+
109
+
val read_table : t -> string -> (int64 * value list) list
110
+
(** [read_table t name] returns all rows from table [name] as a list. *)
111
+
112
+
(** {1 Schema Parsing} *)
113
+
114
+
val parse_create_table : string -> column list
115
+
(** [parse_create_table sql] parses a CREATE TABLE statement and returns the
116
+
column definitions. Returns an empty list if parsing fails. *)
51
117
52
118
(** {1 Namespaced Tables}
53
119
+25
-1
test/cram/interop.t
+25
-1
test/cram/interop.t
···
115
115
k02|v02
116
116
k03|v03
117
117
118
+
Generic table support:
119
+
120
+
$ sqlite3 generic.db "CREATE TABLE users (id INTEGER PRIMARY KEY, name TEXT, age INTEGER)"
121
+
$ sqlite3 generic.db "INSERT INTO users VALUES (1, 'Alice', 30)"
122
+
$ sqlite3 generic.db "INSERT INTO users VALUES (2, 'Bob', 25)"
123
+
$ sql tables generic.db
124
+
users (id INTEGER PRIMARY KEY, name TEXT, age INTEGER)
125
+
$ sql read generic.db -t users
126
+
1|"Alice"|30
127
+
2|"Bob"|25
128
+
129
+
Multiple tables:
130
+
131
+
$ sqlite3 multi.db "CREATE TABLE t1 (a TEXT, b INTEGER); CREATE TABLE t2 (x REAL)"
132
+
$ sqlite3 multi.db "INSERT INTO t1 VALUES ('hello', 42)"
133
+
$ sqlite3 multi.db "INSERT INTO t2 VALUES (3.14)"
134
+
$ sql tables multi.db
135
+
t1 (a TEXT, b INTEGER)
136
+
t2 (x REAL)
137
+
$ sql read multi.db -t t1
138
+
"hello"|42
139
+
$ sql read multi.db -t t2
140
+
3.140000
141
+
118
142
Clean up:
119
143
120
-
$ rm -f test.db many.db interop.db cli.db round.db bulk.db
144
+
$ rm -f test.db many.db interop.db cli.db round.db bulk.db generic.db multi.db
+1
-1
test/test.ml
+1
-1
test/test.ml
+258
test/test_sqlite.ml
+258
test/test_sqlite.ml
···
473
473
(Some value) result)
474
474
sizes
475
475
476
+
(* CREATE TABLE parser tests *)
477
+
478
+
let check_columns msg expected actual =
479
+
let pp_col ppf (c : Sqlite.column) =
480
+
Fmt.pf ppf "{name=%S; affinity=%S; rowid=%b}" c.col_name c.col_affinity
481
+
c.col_is_rowid_alias
482
+
in
483
+
let col_eq (a : Sqlite.column) (b : Sqlite.column) =
484
+
a.col_name = b.col_name
485
+
&& a.col_affinity = b.col_affinity
486
+
&& a.col_is_rowid_alias = b.col_is_rowid_alias
487
+
in
488
+
let col_testable = Alcotest.testable pp_col col_eq in
489
+
Alcotest.(check (list col_testable)) msg expected actual
490
+
491
+
let test_parse_simple () =
492
+
let cols =
493
+
Sqlite.parse_create_table "CREATE TABLE kv (key TEXT, value BLOB)"
494
+
in
495
+
check_columns "simple kv schema"
496
+
[
497
+
{ col_name = "key"; col_affinity = "TEXT"; col_is_rowid_alias = false };
498
+
{ col_name = "value"; col_affinity = "BLOB"; col_is_rowid_alias = false };
499
+
]
500
+
cols
501
+
502
+
let test_parse_integer_primary_key () =
503
+
let cols =
504
+
Sqlite.parse_create_table
505
+
"CREATE TABLE users (id INTEGER PRIMARY KEY, name TEXT, age INTEGER)"
506
+
in
507
+
check_columns "integer primary key"
508
+
[
509
+
{ col_name = "id"; col_affinity = "INTEGER"; col_is_rowid_alias = true };
510
+
{ col_name = "name"; col_affinity = "TEXT"; col_is_rowid_alias = false };
511
+
{ col_name = "age"; col_affinity = "INTEGER"; col_is_rowid_alias = false };
512
+
]
513
+
cols
514
+
515
+
let test_parse_if_not_exists () =
516
+
let cols =
517
+
Sqlite.parse_create_table
518
+
"CREATE TABLE IF NOT EXISTS foo (bar TEXT, baz REAL)"
519
+
in
520
+
check_columns "if not exists"
521
+
[
522
+
{ col_name = "bar"; col_affinity = "TEXT"; col_is_rowid_alias = false };
523
+
{ col_name = "baz"; col_affinity = "REAL"; col_is_rowid_alias = false };
524
+
]
525
+
cols
526
+
527
+
let test_parse_nested_parens () =
528
+
let cols =
529
+
Sqlite.parse_create_table
530
+
"CREATE TABLE t (a DECIMAL(10,2), b VARCHAR(255) NOT NULL)"
531
+
in
532
+
check_columns "nested parens in types"
533
+
[
534
+
{
535
+
col_name = "a";
536
+
col_affinity = "DECIMAL(10,2)";
537
+
col_is_rowid_alias = false;
538
+
};
539
+
{
540
+
col_name = "b";
541
+
col_affinity = "VARCHAR(255)";
542
+
col_is_rowid_alias = false;
543
+
};
544
+
]
545
+
cols
546
+
547
+
let test_parse_table_constraints () =
548
+
let cols =
549
+
Sqlite.parse_create_table
550
+
"CREATE TABLE t (a INTEGER, b TEXT, PRIMARY KEY(a), UNIQUE(b))"
551
+
in
552
+
check_columns "table-level constraints skipped"
553
+
[
554
+
{ col_name = "a"; col_affinity = "INTEGER"; col_is_rowid_alias = false };
555
+
{ col_name = "b"; col_affinity = "TEXT"; col_is_rowid_alias = false };
556
+
]
557
+
cols
558
+
559
+
let test_parse_no_type () =
560
+
let cols = Sqlite.parse_create_table "CREATE TABLE t (a, b, c)" in
561
+
check_columns "columns without types"
562
+
[
563
+
{ col_name = "a"; col_affinity = ""; col_is_rowid_alias = false };
564
+
{ col_name = "b"; col_affinity = ""; col_is_rowid_alias = false };
565
+
{ col_name = "c"; col_affinity = ""; col_is_rowid_alias = false };
566
+
]
567
+
cols
568
+
569
+
let test_parse_autoincrement () =
570
+
let cols =
571
+
Sqlite.parse_create_table
572
+
"CREATE TABLE t (id INTEGER PRIMARY KEY AUTOINCREMENT, name TEXT)"
573
+
in
574
+
check_columns "autoincrement"
575
+
[
576
+
{ col_name = "id"; col_affinity = "INTEGER"; col_is_rowid_alias = true };
577
+
{ col_name = "name"; col_affinity = "TEXT"; col_is_rowid_alias = false };
578
+
]
579
+
cols
580
+
581
+
let test_parse_invalid () =
582
+
let cols = Sqlite.parse_create_table "not valid sql at all" in
583
+
Alcotest.(check int) "invalid sql returns empty" 0 (List.length cols)
584
+
585
+
(* Generic table read tests *)
586
+
587
+
let with_temp_path f =
588
+
Eio_main.run @@ fun env ->
589
+
let fs = Eio.Stdenv.fs env in
590
+
let tmp_dir = "/tmp/test_sqlite" in
591
+
(try Eio.Path.mkdirs ~exists_ok:true ~perm:0o755 Eio.Path.(fs / tmp_dir)
592
+
with Eio.Io _ -> ());
593
+
let fpath = Fmt.str "%s/test_%d.db" tmp_dir (Random.int 1_000_000) in
594
+
let path = Eio.Path.(fs / fpath) in
595
+
Fun.protect
596
+
~finally:(fun () -> try Sys.remove fpath with Sys_error _ -> ())
597
+
(fun () -> f env fpath path)
598
+
599
+
let test_open_no_kv () =
600
+
with_temp_path @@ fun _env fpath path ->
601
+
let rc =
602
+
Sys.command
603
+
(Fmt.str
604
+
"sqlite3 '%s' \"CREATE TABLE users (id INTEGER PRIMARY KEY, name \
605
+
TEXT, age INTEGER)\""
606
+
fpath)
607
+
in
608
+
if rc <> 0 then Alcotest.skip ();
609
+
Eio.Switch.run @@ fun sw ->
610
+
let t = Sqlite.open_ ~sw path in
611
+
let schemas = Sqlite.tables t in
612
+
Alcotest.(check int) "one table" 1 (List.length schemas);
613
+
let s = List.hd schemas in
614
+
Alcotest.(check string) "table name" "users" s.Sqlite.tbl_name;
615
+
Alcotest.(check int) "3 columns" 3 (List.length s.Sqlite.columns);
616
+
(* KV API should fail *)
617
+
(try
618
+
Sqlite.iter t ~f:(fun _ _ -> ());
619
+
Alcotest.fail "should have raised"
620
+
with Failure _ -> ());
621
+
Sqlite.close t
622
+
623
+
let test_read_generic_table () =
624
+
with_temp_path @@ fun _env fpath path ->
625
+
let rc =
626
+
Sys.command
627
+
(Fmt.str
628
+
"sqlite3 '%s' \"CREATE TABLE users (id INTEGER PRIMARY KEY, name \
629
+
TEXT, age INTEGER); INSERT INTO users VALUES (1, 'Alice', 30); \
630
+
INSERT INTO users VALUES (2, 'Bob', 25);\""
631
+
fpath)
632
+
in
633
+
if rc <> 0 then Alcotest.skip ();
634
+
Eio.Switch.run @@ fun sw ->
635
+
let t = Sqlite.open_ ~sw path in
636
+
let rows = Sqlite.read_table t "users" in
637
+
Alcotest.(check int) "2 rows" 2 (List.length rows);
638
+
let _rowid1, values1 = List.nth rows 0 in
639
+
(match values1 with
640
+
| [ Sqlite.Vint 1L; Sqlite.Vtext "Alice"; Sqlite.Vint 30L ] -> ()
641
+
| _ ->
642
+
Alcotest.failf "unexpected row 1: %a" Fmt.(list Sqlite.pp_value) values1);
643
+
let _rowid2, values2 = List.nth rows 1 in
644
+
(match values2 with
645
+
| [ Sqlite.Vint 2L; Sqlite.Vtext "Bob"; Sqlite.Vint 25L ] -> ()
646
+
| _ ->
647
+
Alcotest.failf "unexpected row 2: %a" Fmt.(list Sqlite.pp_value) values2);
648
+
Sqlite.close t
649
+
650
+
let test_integer_primary_key () =
651
+
with_temp_path @@ fun _env fpath path ->
652
+
let rc =
653
+
Sys.command
654
+
(Fmt.str
655
+
"sqlite3 '%s' \"CREATE TABLE t (id INTEGER PRIMARY KEY, val TEXT); \
656
+
INSERT INTO t VALUES (42, 'hello');\""
657
+
fpath)
658
+
in
659
+
if rc <> 0 then Alcotest.skip ();
660
+
Eio.Switch.run @@ fun sw ->
661
+
let t = Sqlite.open_ ~sw path in
662
+
let rows = Sqlite.read_table t "t" in
663
+
Alcotest.(check int) "1 row" 1 (List.length rows);
664
+
let rowid, values = List.hd rows in
665
+
Alcotest.(check int64) "rowid is 42" 42L rowid;
666
+
(match values with
667
+
| [ Sqlite.Vint 42L; Sqlite.Vtext "hello" ] -> ()
668
+
| _ ->
669
+
Alcotest.failf "expected [Vint 42; Vtext hello], got: %a"
670
+
Fmt.(list Sqlite.pp_value)
671
+
values);
672
+
Sqlite.close t
673
+
674
+
let test_tables_lists_all () =
675
+
with_temp_path @@ fun _env fpath path ->
676
+
let rc =
677
+
Sys.command
678
+
(Fmt.str
679
+
"sqlite3 '%s' \"CREATE TABLE t1 (a TEXT); CREATE TABLE t2 (b INTEGER, \
680
+
c REAL);\""
681
+
fpath)
682
+
in
683
+
if rc <> 0 then Alcotest.skip ();
684
+
Eio.Switch.run @@ fun sw ->
685
+
let t = Sqlite.open_ ~sw path in
686
+
let schemas = Sqlite.tables t in
687
+
let names =
688
+
List.map (fun (s : Sqlite.schema) -> s.tbl_name) schemas
689
+
|> List.sort String.compare
690
+
in
691
+
Alcotest.(check (list string)) "table names" [ "t1"; "t2" ] names;
692
+
Sqlite.close t
693
+
694
+
let test_fold_table () =
695
+
with_temp_path @@ fun _env fpath path ->
696
+
let rc =
697
+
Sys.command
698
+
(Fmt.str
699
+
"sqlite3 '%s' \"CREATE TABLE nums (n INTEGER); INSERT INTO nums \
700
+
VALUES (10); INSERT INTO nums VALUES (20); INSERT INTO nums VALUES \
701
+
(30);\""
702
+
fpath)
703
+
in
704
+
if rc <> 0 then Alcotest.skip ();
705
+
Eio.Switch.run @@ fun sw ->
706
+
let t = Sqlite.open_ ~sw path in
707
+
let sum =
708
+
Sqlite.fold_table t "nums" ~init:0L ~f:(fun _rowid values acc ->
709
+
match values with [ Sqlite.Vint n ] -> Int64.add acc n | _ -> acc)
710
+
in
711
+
Alcotest.(check int64) "sum of values" 60L sum;
712
+
Sqlite.close t
713
+
714
+
let generic_suite =
715
+
( "generic",
716
+
[
717
+
Alcotest.test_case "parse simple" `Quick test_parse_simple;
718
+
Alcotest.test_case "parse integer pk" `Quick
719
+
test_parse_integer_primary_key;
720
+
Alcotest.test_case "parse if not exists" `Quick test_parse_if_not_exists;
721
+
Alcotest.test_case "parse nested parens" `Quick test_parse_nested_parens;
722
+
Alcotest.test_case "parse table constraints" `Quick
723
+
test_parse_table_constraints;
724
+
Alcotest.test_case "parse no type" `Quick test_parse_no_type;
725
+
Alcotest.test_case "parse autoincrement" `Quick test_parse_autoincrement;
726
+
Alcotest.test_case "parse invalid" `Quick test_parse_invalid;
727
+
Alcotest.test_case "open no kv" `Quick test_open_no_kv;
728
+
Alcotest.test_case "read generic table" `Quick test_read_generic_table;
729
+
Alcotest.test_case "integer primary key" `Quick test_integer_primary_key;
730
+
Alcotest.test_case "tables lists all" `Quick test_tables_lists_all;
731
+
Alcotest.test_case "fold table" `Quick test_fold_table;
732
+
] )
733
+
476
734
let suite =
477
735
( "sqlite",
478
736
List.concat