Minimal SQLite key-value store for OCaml
Add transaction support to ocaml-sqlite
Add Pager.snapshot/rollback for capturing and restoring dirty page
state. Expose Table.save_root/restore_root and Index.save_root/
restore_root for B-tree root page rollback after splits.
Build Sqlite.with_transaction on top: snapshots pager state, B-tree
roots, and in-memory KV caches before running the user function. On
exception, all state is rolled back and the exception re-raised.
Five new tests cover commit, KV rollback, unique index rollback,
and nested transaction failure.
+178
+81
lib/sqlite.ml
+81
lib/sqlite.ml
···
583
583
584
584
let close t = sync t
585
585
586
+
(* Transactions *)
587
+
588
+
type kv_snapshot = { ks_keys : (string, int64) Hashtbl.t; ks_next : int64 }
589
+
590
+
let snapshot_kv kv = { ks_keys = Hashtbl.copy kv.keys; ks_next = kv.next_rowid }
591
+
592
+
type txn_snapshot = {
593
+
pager_snap : Btree.Pager.snapshot;
594
+
kv_snap : kv_snapshot option;
595
+
named_snaps : (string * kv_snapshot) list;
596
+
rowid_snaps : (string * int64) list;
597
+
table_roots : (Btree.Table.t * int) list;
598
+
index_roots : (Btree.Index.t * int) list;
599
+
}
600
+
601
+
let snapshot_txn t =
602
+
let table_roots =
603
+
List.map
604
+
(fun gt -> (gt.g_btree, Btree.Table.save_root gt.g_btree))
605
+
t.all_tables
606
+
in
607
+
let index_roots =
608
+
List.concat_map
609
+
(fun gt ->
610
+
List.map
611
+
(fun ui -> (ui.ui_btree, Btree.Index.save_root ui.ui_btree))
612
+
gt.g_unique_indexes)
613
+
t.all_tables
614
+
in
615
+
let rowid_snaps =
616
+
Hashtbl.fold (fun k v acc -> (k, !v) :: acc) t.insert_rowids []
617
+
in
618
+
{
619
+
pager_snap = Btree.Pager.snapshot t.pager;
620
+
kv_snap = Option.map snapshot_kv t.data;
621
+
named_snaps =
622
+
List.map (fun (name, kv) -> (name, snapshot_kv kv)) t.named_tables;
623
+
rowid_snaps;
624
+
table_roots;
625
+
index_roots;
626
+
}
627
+
628
+
let restore_txn t snap =
629
+
Btree.Pager.rollback t.pager snap.pager_snap;
630
+
(* Restore B-tree root pages *)
631
+
List.iter
632
+
(fun (btree, root) -> Btree.Table.restore_root btree root)
633
+
snap.table_roots;
634
+
List.iter
635
+
(fun (idx, root) -> Btree.Index.restore_root idx root)
636
+
snap.index_roots;
637
+
(* Restore KV in-memory state *)
638
+
(match (t.data, snap.kv_snap) with
639
+
| Some kv, Some s ->
640
+
Hashtbl.reset kv.keys;
641
+
Hashtbl.iter (Hashtbl.replace kv.keys) s.ks_keys;
642
+
kv.next_rowid <- s.ks_next
643
+
| _ -> ());
644
+
List.iter
645
+
(fun (name, s) ->
646
+
match List.assoc_opt name t.named_tables with
647
+
| Some kv ->
648
+
Hashtbl.reset kv.keys;
649
+
Hashtbl.iter (Hashtbl.replace kv.keys) s.ks_keys;
650
+
kv.next_rowid <- s.ks_next
651
+
| None -> ())
652
+
snap.named_snaps;
653
+
(* Restore insert_rowids *)
654
+
Hashtbl.reset t.insert_rowids;
655
+
List.iter
656
+
(fun (name, v) -> Hashtbl.replace t.insert_rowids name (ref v))
657
+
snap.rowid_snaps
658
+
659
+
let with_transaction t f =
660
+
let snap = snapshot_txn t in
661
+
match f () with
662
+
| result -> result
663
+
| exception exn ->
664
+
restore_txn t snap;
665
+
raise exn
666
+
586
667
(* Generic read API *)
587
668
588
669
let tables t = List.map (fun gt -> gt.g_schema) t.all_tables
+10
lib/sqlite.mli
+10
lib/sqlite.mli
···
70
70
val close : t -> unit
71
71
(** [close t] syncs and closes the database. *)
72
72
73
+
val with_transaction : t -> (unit -> 'a) -> 'a
74
+
(** [with_transaction t f] runs [f ()] atomically. If [f] raises an exception,
75
+
all modifications to the database are rolled back and the exception is
76
+
re-raised. If [f] returns normally, the changes are kept in memory but not
77
+
yet synced to disk — call {!sync} for durability.
78
+
79
+
Transactions do not nest: calling [with_transaction] inside [f] is permitted
80
+
but the inner transaction has no independent rollback — a failure in the
81
+
inner transaction rolls back to the outermost savepoint. *)
82
+
73
83
(** {1 Key-Value API}
74
84
75
85
These functions operate on the default [kv] table. They raise [Failure] if
+87
test/test_sqlite.ml
+87
test/test_sqlite.ml
···
1180
1180
in
1181
1181
()
1182
1182
1183
+
(* ================================================================ *)
1184
+
(* Transactions *)
1185
+
(* ================================================================ *)
1186
+
1187
+
let test_transaction_commit () =
1188
+
with_temp_db @@ fun _fs db ->
1189
+
Sqlite.with_transaction db (fun () ->
1190
+
Sqlite.put db "a" "1";
1191
+
Sqlite.put db "b" "2");
1192
+
Alcotest.(check (option string)) "a" (Some "1") (Sqlite.find db "a");
1193
+
Alcotest.(check (option string)) "b" (Some "2") (Sqlite.find db "b")
1194
+
1195
+
let test_transaction_rollback () =
1196
+
with_temp_db @@ fun _fs db ->
1197
+
Sqlite.put db "x" "before";
1198
+
(try
1199
+
Sqlite.with_transaction db (fun () ->
1200
+
Sqlite.put db "x" "during";
1201
+
Sqlite.put db "y" "new";
1202
+
Alcotest.(check (option string))
1203
+
"x during" (Some "during") (Sqlite.find db "x");
1204
+
failwith "abort")
1205
+
with Failure _ -> ());
1206
+
Alcotest.(check (option string))
1207
+
"x restored" (Some "before") (Sqlite.find db "x");
1208
+
Alcotest.(check (option string)) "y gone" None (Sqlite.find db "y")
1209
+
1210
+
let test_transaction_rollback_kv () =
1211
+
with_temp_db @@ fun _fs db ->
1212
+
Sqlite.put db "keep" "v1";
1213
+
(try
1214
+
Sqlite.with_transaction db (fun () ->
1215
+
Sqlite.put db "keep" "v2";
1216
+
Sqlite.delete db "keep";
1217
+
Sqlite.put db "tmp" "val";
1218
+
failwith "abort")
1219
+
with Failure _ -> ());
1220
+
Alcotest.(check (option string))
1221
+
"keep restored" (Some "v1") (Sqlite.find db "keep");
1222
+
Alcotest.(check bool) "tmp absent" false (Sqlite.mem db "tmp")
1223
+
1224
+
let test_transaction_rollback_unique () =
1225
+
with_temp_db @@ fun _fs db ->
1226
+
Sqlite.create_table db
1227
+
~sql:"CREATE TABLE t (id INTEGER PRIMARY KEY, email TEXT UNIQUE)";
1228
+
let _ =
1229
+
Sqlite.insert db ~table:"t" [ Sqlite.Vnull; Sqlite.Vtext "a@b.com" ]
1230
+
in
1231
+
(try
1232
+
Sqlite.with_transaction db (fun () ->
1233
+
let _ =
1234
+
Sqlite.insert db ~table:"t" [ Sqlite.Vnull; Sqlite.Vtext "c@d.com" ]
1235
+
in
1236
+
failwith "abort")
1237
+
with Failure _ -> ());
1238
+
(* The rolled-back insert should not block a new insert with the same value *)
1239
+
let _ =
1240
+
Sqlite.insert db ~table:"t" [ Sqlite.Vnull; Sqlite.Vtext "c@d.com" ]
1241
+
in
1242
+
let rows = Sqlite.read_table db "t" in
1243
+
Alcotest.(check int) "two rows" 2 (List.length rows)
1244
+
1245
+
let test_transaction_nested_failure () =
1246
+
with_temp_db @@ fun _fs db ->
1247
+
Sqlite.put db "a" "original";
1248
+
(try
1249
+
Sqlite.with_transaction db (fun () ->
1250
+
Sqlite.put db "a" "outer";
1251
+
Sqlite.with_transaction db (fun () ->
1252
+
Sqlite.put db "a" "inner";
1253
+
failwith "inner abort"))
1254
+
with Failure _ -> ());
1255
+
(* Both inner and outer changes should be rolled back *)
1256
+
Alcotest.(check (option string))
1257
+
"a original" (Some "original") (Sqlite.find db "a")
1258
+
1183
1259
let suite =
1184
1260
( "sqlite",
1185
1261
List.concat
···
1312
1388
test_unique_allows_multiple_nulls;
1313
1389
Alcotest.test_case "unique composite NULL" `Quick
1314
1390
test_unique_composite_null;
1391
+
];
1392
+
[
1393
+
Alcotest.test_case "transaction commit" `Quick test_transaction_commit;
1394
+
Alcotest.test_case "transaction rollback" `Quick
1395
+
test_transaction_rollback;
1396
+
Alcotest.test_case "transaction rollback kv" `Quick
1397
+
test_transaction_rollback_kv;
1398
+
Alcotest.test_case "transaction rollback unique" `Quick
1399
+
test_transaction_rollback_unique;
1400
+
Alcotest.test_case "transaction nested failure" `Quick
1401
+
test_transaction_nested_failure;
1315
1402
];
1316
1403
] )