From 90dfbd7892601fc180e6ccef1784e522d481879f Mon Sep 17 00:00:00 2001 From: Cursor Agent Date: Thu, 27 Aug 2026 08:30:32 +0000 Subject: [PATCH 1/9] Add dbval-aligned temporal db API (phase 1) Introduce tx visibility filtering and public history/time-travel API matching dbval.core: basis_tx, as_of/as_of_t, since/since_t, history, temporal_view. - db fields: max_tx (basis), store_max_tx, as_of_tx, since_tx, history - tx_visibility module with datoms_filter matching dbval semantics - transact rejects temporal views with dbval-compatible error message - design doc for overlay removal and append-only migration Co-authored-by: Tienson Qin --- docs/design-tx-filter-history.md | 120 +++++++++++++++++++++++++++++++ impl/datascript.ml | 12 ++++ impl/datascript.mli | 15 ++++ impl/db.ml | 42 ++++++++++- impl/db.mli | 7 ++ impl/platform/jsoo/storage.ml | 4 ++ impl/platform/melange/storage.ml | 4 ++ impl/platform/native/storage.ml | 4 ++ impl/serialize.ml | 4 ++ impl/storage_lmdb_impl.ml | 4 ++ impl/storage_pss.ml | 4 ++ impl/transact.ml | 2 + impl/tx_visibility.ml | 61 ++++++++++++++++ impl/tx_visibility.mli | 18 +++++ test/dune | 5 ++ test/test_db.ml | 50 +++++++++++++ test/test_tx_visibility.ml | 46 ++++++++++++ type/datascript_types.ml | 4 ++ 18 files changed, 404 insertions(+), 2 deletions(-) create mode 100644 docs/design-tx-filter-history.md create mode 100644 impl/tx_visibility.ml create mode 100644 impl/tx_visibility.mli create mode 100644 test/test_tx_visibility.ml diff --git a/docs/design-tx-filter-history.md b/docs/design-tx-filter-history.md new file mode 100644 index 0000000..66be49c --- /dev/null +++ b/docs/design-tx-filter-history.md @@ -0,0 +1,120 @@ +# Tx-Filter Index Design (dbval-style) + +Branch: `logseq/tx-filter-history-fe5d` +Builds on: `logseq/non-pss-lmdb-fe5d` (LMDB overlay optimizations, PR #2) + +## Goal + +Remove the LMDB in-memory overlay (`additions` / `removals` / `bulk`) and replace it with an +append-only datom store plus **transaction visibility filters** on read, matching the dbval model. +Expose dbval-compatible `history`, `as_of`, `since`, `basis_tx`, `as_of_t`, `since_t`, and `temporal_view` on the public API. + +## Current model (to remove) + +``` +Index.t = LMDB + overlay lists + add/remove → mutate overlay (O(1)) + read → merge LMDB cursor + overlay hashtables + snapshot_db → Index.copy (shallow list copy) + store → sync_merged_to_lmdb (full merge + rewrite) +``` + +## Target model + +``` +Index.t = LMDB append-only (keys include tx + added flag in value) + add/remove → append assert/retract datoms at new tx (no key delete) + read → cursor scan + tx-visibility + datoms-filter + snapshot_db → O(1) handle copy (overlay copy until append-only migration) + store → append tx batch + meta update (no full rewrite) +``` + +Reference: dbval `tx-visibility-xform` and `datoms-filter` in `dbval.db`. + +## DB view fields + +Extend `db` with dbval-compatible view fields: + +| Field | dbval equivalent | Meaning | +| --- | --- | --- | +| `max_tx` | `max-tx` | Basis: upper bound for reads (`tx <= max_tx`) | +| `store_max_tx` | store `q-max-tx` | Committed store high water (for `as_of` validation) | +| `as_of_tx` | `as-of-tx` | Set by `as_of`; marks temporal view | +| `since_tx` | `since-tx` | Set by `since`; lower bound (`tx > since_tx`) | +| `history` | `history?` | Skip `datoms-filter` when true | + +Public API (matches dbval.core): + +- `basis_tx db` → `max_tx` +- `as_of tx db` → `{ max_tx = tx; as_of_tx = Some tx }` +- `as_of_t db` → `as_of_tx` +- `since tx db` → `{ since_tx = Some tx }` +- `since_t db` → `since_tx` +- `history db` → `{ history = true }` +- `temporal_view db` → read-only guard (as-of / since / history) + +Transact rejects temporal views with dbval-compatible error message. + +## Read pipeline + +For ascending index scans: + +1. LMDB cursor over key range +2. Decode datom; drop if `d.tx > max_tx` (basis) +3. Drop if `since_tx` set and `d.tx <= since_tx` +4. Unless `history`, run `datoms_filter` (cancel add/retract pairs in stream order) +5. Apply `filter_pred` if set +6. Apply query component filters (`?e`, `?a`, …) + +`datoms_filter` follows dbval semantics: consecutive datoms with same `[e,a,v]` cancel +when a retract follows an add; same-tx add/retract pairs cancel; orphaned retracts are dropped. + +## Write pipeline + +### transact + +1. `db_before = snapshot_db db` → `{ db with view_tx = db.max_tx }` (no index copy) +2. Apply tx ops; collect `tx_data` (full assert/retract log) +3. `db_after`: append all `tx_data` to three indexes; bump `max_tx`; refresh attr caches +4. `persist_transact`: append-only store write + +Reject transact on temporal views (`temporal_view` / as-of / since / history). + +### init / bulk load + +Single-tx bulk append (`of_bulk` → direct LMDB write batch). No overlay staging. + +## Storage + +- **store**: append new datoms for the tx + update meta (`max_tx`, `max_eid`, schema) +- **restore**: open LMDB env, read meta, rebuild attr caches from filtered scan at `max_tx` +- Remove `sync_merged_to_lmdb` clear-and-rewrite path + +PSS tail replay (`impl/storage_pss.ml`) is the closest in-repo precedent for append-only persistence. + +## Phased migration + +| Phase | Deliverable | +| --- | --- | +| 1 | Design doc, `db` view fields, `tx_visibility` module, public API stubs, unit tests for filter | +| 2 | Wire visibility filter into `datoms` / `fold_datoms` read paths | +| 3 | Append-only index writes; delete overlay types and merge logic | +| 4 | O(1) `snapshot_db`; transact/store append-only | +| 5 | Full `history` / multi-tx storage roundtrip tests | +| 6 | Benchmark regression check; melange/jsoo sync | + +## Risks + +- **Performance**: per-read `datoms-filter` cost vs current overlay merge; mitigate with current-fact + projection cache or lazy filter on slices. +- **Storage growth**: append-only history requires compaction strategy (future work). +- **Attr caches**: `aevt_by_attr` / AVET entity-id maps must be rebuilt or incrementally updated + from filtered current facts, not raw index contents. +- **Melange**: native index changes must be mirrored in `lmdb/melange/`. + +## Compatibility + +- `:db/noHistory` schema attrs: retractions still append; filter rules discard prior asserts. +- `?tx:` on `datoms`: exact-tx filter within the resolved stream. +- Upstream DataScript has no full `history` in the checked-out revision; we implement dbval-grade + time travel as an extension documented here. diff --git a/impl/datascript.ml b/impl/datascript.ml index 8953437..3d29e86 100644 --- a/impl/datascript.ml +++ b/impl/datascript.ml @@ -76,6 +76,16 @@ let unfiltered_db db = Db_impl.unfiltered db_core_context db let filter db pred = Db_impl.filter db_core_context db pred +let basis_tx = Db_impl.basis_tx +let as_of_t = Db_impl.as_of_t +let since_t = Db_impl.since_t +let temporal_view = Db_impl.temporal_view +let as_of = Db_impl.as_of +let since = Db_impl.since +let history = Db_impl.history + +module Tx_visibility = Tx_visibility + let serializable = Serialize.serializable let serialize_context : Serialize.context = @@ -763,6 +773,8 @@ let persist_transact ~tx_meta db = | Some storage -> store ~storage db let transact_report ?(tx_meta = []) db tx_ops = + if Db_impl.temporal_view db then + invalid_arg "Cannot transact against an as-of/since/history database value"; let db_before = snapshot_db db in let db_after, tempids, tx_data = apply_tx tx_ops db in { db_before; db_after; tx_data; tempids; tx_meta } diff --git a/impl/datascript.mli b/impl/datascript.mli index 7fa533b..3ec0683 100644 --- a/impl/datascript.mli +++ b/impl/datascript.mli @@ -143,6 +143,13 @@ module Db : sig val rseek_datoms : db -> index -> ?e:entity_id -> ?a:attr -> ?v:value -> ?tx:tx -> unit -> datom Seq.t val rseek_datoms_ref : db -> index -> ?e:entity_ref -> ?a:attr -> ?v:value -> ?tx:tx -> unit -> datom Seq.t val index_range : db -> attr -> ?start:value -> ?stop:value -> unit -> datom Seq.t + val basis_tx : db -> tx + val as_of_t : db -> tx option + val since_t : db -> tx option + val temporal_view : db -> bool + val as_of : tx -> db -> db + val since : tx -> db -> db + val history : db -> db val hash : db -> int val hash_cache_size : unit -> int val diff : db -> db -> datom list * datom list * datom list @@ -380,6 +387,14 @@ val init_db : ?schema:schema -> ?storage:storage -> datom list -> db val filter : db -> (db -> datom -> bool) -> db val is_filtered : db -> bool val unfiltered_db : db -> db +val basis_tx : db -> tx +val as_of_t : db -> tx option +val since_t : db -> tx option +val temporal_view : db -> bool +val as_of : tx -> db -> db +val since : tx -> db -> db +val history : db -> db +module Tx_visibility : module type of Tx_visibility val serializable : db -> serializable_db val from_serializable : serializable_db -> db val db_from_reader_string : string -> db diff --git a/impl/db.ml b/impl/db.ml index c24023a..0b58c4c 100644 --- a/impl/db.ml +++ b/impl/db.ml @@ -290,6 +290,36 @@ let snapshot_db db = ; avet_index = Index.copy db.avet_index } +let view_bounds db = + { Tx_visibility.view_tx = db.max_tx; since_tx = db.since_tx; history = db.history } + +let temporal_view db = + Option.is_some db.as_of_tx || Option.is_some db.since_tx || db.history + +let apply_db_view db datoms = Tx_visibility.apply_view (view_bounds db) datoms + +let apply_db_view_seq db seq = + if temporal_view db then Tx_visibility.filter_seq (view_bounds db) seq else seq + +let basis_tx db = db.max_tx + +let as_of_t db = db.as_of_tx + +let since_t db = db.since_tx + +let as_of tx db = + if tx > db.store_max_tx then + invalid_arg + ("as_of tx " + ^ string_of_int tx + ^ " is after database basis " + ^ string_of_int db.store_max_tx); + { db with max_tx = tx; as_of_tx = Some tx } + +let since tx db = { db with since_tx = Some tx } + +let history db = { db with history = true } + let with_datoms db datoms = set_indexes_from_datoms db datoms @@ -318,6 +348,10 @@ let empty_db context ?(schema = []) ?storage () = ; max_eid = 0 ; max_datom_e = 0 ; max_tx = tx0 + ; store_max_tx = tx0 + ; as_of_tx = None + ; since_tx = None + ; history = false ; filter_pred = None ; storage_ref = storage_ref_of ?storage auto_storage_ref ; tx_fns = [] @@ -350,6 +384,10 @@ let init_db context ?(schema = []) ?storage datoms = ; max_eid ; max_datom_e = 0 ; max_tx + ; store_max_tx = max_tx + ; as_of_tx = None + ; since_tx = None + ; history = false ; filter_pred = None ; storage_ref = storage_ref_of ?storage auto_storage_ref ; tx_fns = [] @@ -941,7 +979,7 @@ let datoms context db index ?e ?a ?v ?tx () = datoms |> Seq.filter (fun d -> matches e d.e && matches a d.a && matches_value context v d.v && matches tx d.tx) in - apply_filter_pred db datoms + apply_db_view_seq db datoms |> apply_filter_pred db let fold_datoms f init context db index ?e ?a ?v ?tx () = validate_index_access context db index a; @@ -1026,7 +1064,7 @@ let datoms_list context db index ?e ?a ?v ?tx () = datoms |> List.filter (fun d -> matches e d.e && matches a d.a && matches_value context v d.v && matches tx d.tx) in - apply_filter_pred_list db datoms + apply_db_view db datoms |> apply_filter_pred_list db let datoms_ref context db index ?e ?a ?v ?tx () = let e = resolved_entity_ref_option context db e in diff --git a/impl/db.mli b/impl/db.mli index 7cace2e..e0b3ce7 100644 --- a/impl/db.mli +++ b/impl/db.mli @@ -19,6 +19,13 @@ val refresh_indexes : db -> db val refresh_indexes_with_added_datoms : db -> datom list -> db val refresh_indexes_with_tx_data : db -> datom list -> db val snapshot_db : db -> db +val basis_tx : db -> tx +val as_of_t : db -> tx option +val since_t : db -> tx option +val temporal_view : db -> bool +val as_of : tx -> db -> db +val since : tx -> db -> db +val history : db -> db val with_datoms : db -> datom list -> db val empty_db : core_context -> ?schema:schema -> ?storage:storage -> unit -> db val empty : core_context -> db -> db diff --git a/impl/platform/jsoo/storage.ml b/impl/platform/jsoo/storage.ml index 92340fc..ffb9b84 100644 --- a/impl/platform/jsoo/storage.ml +++ b/impl/platform/jsoo/storage.ml @@ -77,6 +77,10 @@ let restore context storage = ; max_eid ; max_datom_e = max_eid ; max_tx + ; store_max_tx = max_tx + ; as_of_tx = None + ; since_tx = None + ; history = false ; filter_pred = None ; storage_ref = Some storage ; tx_fns = [] diff --git a/impl/platform/melange/storage.ml b/impl/platform/melange/storage.ml index 92340fc..ffb9b84 100644 --- a/impl/platform/melange/storage.ml +++ b/impl/platform/melange/storage.ml @@ -77,6 +77,10 @@ let restore context storage = ; max_eid ; max_datom_e = max_eid ; max_tx + ; store_max_tx = max_tx + ; as_of_tx = None + ; since_tx = None + ; history = false ; filter_pred = None ; storage_ref = Some storage ; tx_fns = [] diff --git a/impl/platform/native/storage.ml b/impl/platform/native/storage.ml index 92340fc..ffb9b84 100644 --- a/impl/platform/native/storage.ml +++ b/impl/platform/native/storage.ml @@ -77,6 +77,10 @@ let restore context storage = ; max_eid ; max_datom_e = max_eid ; max_tx + ; store_max_tx = max_tx + ; as_of_tx = None + ; since_tx = None + ; history = false ; filter_pred = None ; storage_ref = Some storage ; tx_fns = [] diff --git a/impl/serialize.ml b/impl/serialize.ml index e039a09..38edf45 100644 --- a/impl/serialize.ml +++ b/impl/serialize.ml @@ -39,6 +39,10 @@ let from_serializable context snapshot = ; max_eid = snapshot.serializable_max_eid ; max_datom_e = 0 ; max_tx = snapshot.serializable_max_tx + ; store_max_tx = snapshot.serializable_max_tx + ; as_of_tx = None + ; since_tx = None + ; history = false ; filter_pred = None ; storage_ref ; tx_fns = [] diff --git a/impl/storage_lmdb_impl.ml b/impl/storage_lmdb_impl.ml index b65fcfb..033a66f 100644 --- a/impl/storage_lmdb_impl.ml +++ b/impl/storage_lmdb_impl.ml @@ -96,6 +96,10 @@ let restore context storage = ; max_eid ; max_datom_e = max_eid ; max_tx + ; store_max_tx = max_tx + ; as_of_tx = None + ; since_tx = None + ; history = false ; filter_pred = None ; storage_ref = Some storage ; tx_fns = [] diff --git a/impl/storage_pss.ml b/impl/storage_pss.ml index cc8819c..28586ca 100644 --- a/impl/storage_pss.ml +++ b/impl/storage_pss.ml @@ -263,6 +263,10 @@ let restore context storage = ; max_eid = root.storage_max_eid ; max_datom_e = root.storage_max_eid ; max_tx = root.storage_max_tx + ; store_max_tx = root.storage_max_tx + ; as_of_tx = None + ; since_tx = None + ; history = false ; filter_pred = None ; storage_ref = Some storage ; tx_fns = [] diff --git a/impl/transact.ml b/impl/transact.ml index 9609225..38b4f10 100644 --- a/impl/transact.ml +++ b/impl/transact.ml @@ -1532,6 +1532,7 @@ let apply_tx context tx_ops db = schema ; max_eid ; max_tx = !max_tx_seen + ; store_max_tx = !max_tx_seen ; tx_fns = !current_tx_fns } in @@ -1548,6 +1549,7 @@ let apply_tx context tx_ops db = schema = db.schema ; max_eid = db.max_eid ; max_tx = db.max_tx + ; store_max_tx = db.store_max_tx ; tx_fns = db.tx_fns } else diff --git a/impl/tx_visibility.ml b/impl/tx_visibility.ml new file mode 100644 index 0000000..9420208 --- /dev/null +++ b/impl/tx_visibility.ml @@ -0,0 +1,61 @@ +open Datascript_types + +(** Upper/lower transaction bounds for a database view. *) +type view_bounds = + { view_tx : tx + ; since_tx : tx option + ; history : bool + } + +let default_bounds max_tx = + { view_tx = max_tx; since_tx = None; history = false } + +let visible_at_tx bounds datom = + datom.tx <= bounds.view_tx + && + match bounds.since_tx with + | None -> true + | Some since_tx -> datom.tx > since_tx + +(** Cancel add/retract pairs in ascending index order (dbval `datoms-filter` semantics). *) +let datoms_filter datoms = + let previous = ref None in + let result = ref [] in + let flush_previous () = + match !previous with + | None -> () + | Some d when d.added -> result := d :: !result + | Some _ -> () + in + List.iter + (fun d2 -> + match !previous with + | None -> previous := Some d2 + | Some d1 -> + let same_eav = d1.e = d2.e && d1.a = d2.a && Compare.compare_value d1.v d2.v = 0 in + if same_eav && d1.added && not d2.added then + (* later tx retract cancels add *) + previous := None + else if same_eav && d1.tx = d2.tx && not d1.added && d2.added then + (* same-tx retract then add cancels both *) + previous := None + else if not d2.added then ( + (* unrelated retract: keep d1 if it was an add, track d2 *) + if d1.added then result := d1 :: !result; + previous := Some d2) + else ( + if d1.added then result := d1 :: !result; + previous := Some d2)) + datoms; + flush_previous (); + List.rev !result + +let apply_view bounds datoms = + let visible = List.filter (visible_at_tx bounds) datoms in + if bounds.history then visible else datoms_filter visible + +let filter_seq bounds seq = + let datoms = + Seq.fold_left (fun acc datom -> datom :: acc) [] seq |> List.rev + in + apply_view bounds datoms |> List.to_seq diff --git a/impl/tx_visibility.mli b/impl/tx_visibility.mli new file mode 100644 index 0000000..444d99c --- /dev/null +++ b/impl/tx_visibility.mli @@ -0,0 +1,18 @@ +open Datascript_types + +type view_bounds = + { view_tx : tx + ; since_tx : tx option + ; history : bool + } + +val default_bounds : tx -> view_bounds + +val visible_at_tx : view_bounds -> datom -> bool + +(** Resolve current facts from an ascending datom stream up to [view_bounds]. *) +val apply_view : view_bounds -> datom list -> datom list + +val datoms_filter : datom list -> datom list + +val filter_seq : view_bounds -> datom Seq.t -> datom Seq.t diff --git a/test/dune b/test/dune index 87b8181..8ec7760 100644 --- a/test/dune +++ b/test/dune @@ -18,6 +18,11 @@ (modules test_core) (libraries datascript-ocaml-native)) +(test + (name test_tx_visibility) + (modules test_tx_visibility) + (libraries datascript-ocaml-native)) + (test (name test_db) (modules test_db) diff --git a/test/test_db.ml b/test/test_db.ml index 453044a..02e62d3 100644 --- a/test/test_db.ml +++ b/test/test_db.ml @@ -225,9 +225,59 @@ let test_db__test_index_lookup_matches_upstream_numeric_comparator_bounds () = [ 1, "x", Int 1; 2, "x", Float 1.0 ] (Db.index_range db "x" ~start:(Float 1.0) ~stop:(Float 1.0) () |> List.of_seq) +let test_db__test_db_view_api () = + let db = + db_with + [ Add (Entity_id 1, "name", String "Alice") + ; Add (Entity_id 1, "age", Int 30) + ] + (empty_db ~schema:[ "name", indexed; "age", indexed ] ()) + in + let tx1 = basis_tx db in + let db = + db_with + [ Add (Entity_id 1, "age", Int 31) + ; Add (Entity_id 2, "name", String "Bob") + ] + db + in + let tx2 = basis_tx db in + assert_equal_int "basis_tx tracks latest transaction" tx2 (basis_tx db); + assert_equal_int "temporal_view is false on current db" 0 (if temporal_view db then 1 else 0); + let past = as_of tx1 db in + (match as_of_t past with + | Some tx when tx = tx1 -> () + | _ -> failwith "as_of should record as_of_t like dbval"); + assert_equal_int "as_of lowers basis_tx" tx1 (basis_tx past); + assert_equal_int "as_of creates temporal view" 1 (if temporal_view past then 1 else 0); + let delta = since tx1 db in + (match since_t delta with + | Some tx when tx = tx1 -> () + | _ -> failwith "since should record since_t like dbval"); + assert_equal_int "since creates temporal view" 1 (if temporal_view delta then 1 else 0); + let hist = history db in + assert_equal_int "history creates temporal view" 1 (if temporal_view hist then 1 else 0); + (try + ignore (as_of (basis_tx db + 1) db); + failwith "as_of beyond store basis should fail" + with Invalid_argument _ -> ()); + (try + let _ = transact (as_of tx1 db) [ Add (Entity_id 3, "name", String "Carol") ] in + failwith "transact on temporal view should fail" + with Invalid_argument _ -> ()); + (try + let _ = transact (since tx1 db) [ Add (Entity_id 3, "name", String "Carol") ] in + failwith "transact on since view should fail" + with Invalid_argument _ -> ()); + (try + let _ = transact (history db) [ Add (Entity_id 3, "name", String "Carol") ] in + failwith "transact on history view should fail" + with Invalid_argument _ -> ()) + let () = test_db__test_defrecord_updatable (); test_db__test_db_hash_cache (); + test_db__test_db_view_api (); test_db__test_uuid (); test_db__test_squuid_uses_wall_clock_time (); test_db__test_diff (); diff --git a/test/test_tx_visibility.ml b/test/test_tx_visibility.ml new file mode 100644 index 0000000..5c19b1e --- /dev/null +++ b/test/test_tx_visibility.ml @@ -0,0 +1,46 @@ +open Datascript_types +open Datascript.Tx_visibility + +let datom ~e ~a ~v ~tx ~added = + { e; a; v; tx; added } + +let assert_equal_int label expected actual = + if expected <> actual then + Printf.ksprintf failwith "%s: expected %d, got %d" label expected actual + +let assert_equal_bool label expected actual = + if expected <> actual then + Printf.ksprintf failwith "%s: expected %b, got %b" label expected actual + +let test_datoms_filter_cancels_later_retract () = + let d1 = datom ~e:1 ~a:":name" ~v:(String "Ivan") ~tx:100 ~added:true in + let d2 = datom ~e:1 ~a:":name" ~v:(String "Ivan") ~tx:200 ~added:false in + let result = datoms_filter [ d1; d2 ] in + assert_equal_int "later retract cancels add" 0 (List.length result) + +let test_datoms_filter_keeps_active_add () = + let d1 = datom ~e:1 ~a:":name" ~v:(String "Ivan") ~tx:100 ~added:true in + let result = datoms_filter [ d1 ] in + assert_equal_int "single add is kept" 1 (List.length result) + +let test_datoms_filter_same_tx_cancel () = + let retract = datom ~e:1 ~a:":name" ~v:(String "Ivan") ~tx:100 ~added:false in + let add = datom ~e:1 ~a:":name" ~v:(String "Ivan") ~tx:100 ~added:true in + let result = datoms_filter [ retract; add ] in + assert_equal_int "same-tx retract then add cancel" 0 (List.length result) + +let test_visible_at_tx_respects_bounds () = + let bounds = { view_tx = 200; since_tx = Some 100; history = false } in + let before = datom ~e:1 ~a:":a" ~v:(String "x") ~tx:100 ~added:true in + let inside = datom ~e:1 ~a:":a" ~v:(String "y") ~tx:150 ~added:true in + let after = datom ~e:1 ~a:":a" ~v:(String "z") ~tx:250 ~added:true in + assert_equal_bool "since excludes boundary tx" false (visible_at_tx bounds before); + assert_equal_bool "inside range is visible" true (visible_at_tx bounds inside); + assert_equal_bool "view_tx excludes future tx" false (visible_at_tx bounds after) + +let () = + test_datoms_filter_cancels_later_retract (); + test_datoms_filter_keeps_active_add (); + test_datoms_filter_same_tx_cancel (); + test_visible_at_tx_respects_bounds (); + Printf.printf "test_tx_visibility: ok\n" diff --git a/type/datascript_types.ml b/type/datascript_types.ml index b0ccf6e..7bc4a9f 100644 --- a/type/datascript_types.ml +++ b/type/datascript_types.ml @@ -131,6 +131,10 @@ and db = ; max_eid : entity_id ; max_datom_e : entity_id ; max_tx : tx + ; store_max_tx : tx + ; as_of_tx : tx option + ; since_tx : tx option + ; history : bool ; filter_pred : (datom -> bool) option ; storage_ref : storage option ; tx_fns : (entity_id * (db -> value list -> tx_op list)) list From 6820cd1026d6a81c0f6d19041ce5c148fa4ee65e Mon Sep 17 00:00:00 2001 From: Cursor Agent Date: Thu, 27 Aug 2026 08:39:38 +0000 Subject: [PATCH 2/9] Remove LMDB overlay: append-only index with tx-filter reads Replace overlay merge model with append-only LMDB writes and dbval-style tx visibility on all read paths. - Simplify Index.t to { db, which }; remove additions/removals/bulk - append_tx_data: single LMDB txn for EAVT/AEVT/AVET on transact - init via of_eavt_datoms (one txn); snapshot_db is O(1) shared handle - refresh_indexes_with_tx_data appends full tx_data (add + retract) - apply_db_view on datoms/eavt/attr caches for datoms-filter + basis - test_tx_history: as_of, since, history integration tests Known regression: add-one-tx ~1.4ms vs ~0.01ms overlay (LMDB write cost). Store still copies full index when session/storage envs differ. Co-authored-by: Tienson Qin --- impl/db.ml | 124 +++----- impl/index.mli | 2 + impl/platform/jsoo/index.ml | 9 + impl/platform/melange/index.ml | 9 + impl/platform/native/index.ml | 9 + lmdb/native/datascript_lmdb_index.ml | 422 +++++--------------------- lmdb/native/datascript_lmdb_index.mli | 2 + test/dune | 5 + test/test_tx_history.ml | 97 ++++++ 9 files changed, 245 insertions(+), 434 deletions(-) create mode 100644 test/test_tx_history.ml diff --git a/impl/db.ml b/impl/db.ml index 0b58c4c..b9b21c7 100644 --- a/impl/db.ml +++ b/impl/db.ml @@ -118,6 +118,13 @@ let invalidate_attr_tables db = ; avet_entities_by_attr_value = Hashtbl.create 0 } +let view_bounds db = + { Tx_visibility.view_tx = db.max_tx; since_tx = db.since_tx; history = db.history } + +let apply_db_view db datoms = Tx_visibility.apply_view (view_bounds db) datoms + +let apply_db_view_seq db seq = Tx_visibility.filter_seq (view_bounds db) seq + let lmdb_of_db db = try Index.lmdb_of (Index.db_of db.eavt_index) with Invalid_argument _ -> @@ -163,9 +170,13 @@ let set_indexes_from_datoms db datoms = |> List.filter (fun d -> Schema.schema_attr_is_avet_accessible db.schema d.a) |> List.sort (Util.compare_datom Avet) in - let eavt_index = Index.of_bulk Eavt eavt_datoms lmdb in - let aevt_index = Index.of_bulk Aevt aevt_sorted lmdb in - let avet_index = Index.of_bulk Avet avet_sorted lmdb in + Index.of_eavt_datoms + ~avet:(Schema.schema_attr_is_avet_accessible db.schema) + eavt_datoms + lmdb; + let eavt_index = Index.empty Eavt lmdb in + let aevt_index = Index.empty Aevt lmdb in + let avet_index = Index.empty Avet lmdb in let duplicate_aevt_datoms = List.sort (Util.compare_datom Aevt) duplicate_datoms in let duplicate_avet_datoms = duplicate_datoms @@ -193,7 +204,9 @@ let set_indexes_from_datoms db datoms = } let eavt_datoms db = - Index.to_list db.eavt_index @ db.duplicate_datoms |> List.sort (Util.compare_datom Eavt) + Index.to_list db.eavt_index @ db.duplicate_datoms + |> List.sort (Util.compare_datom Eavt) + |> apply_db_view db let refresh_indexes db = set_indexes_from_datoms db (eavt_datoms db) @@ -225,82 +238,22 @@ let refresh_indexes_with_added_datoms db added_datoms = } |> invalidate_attr_tables -let find_active_datom_by_fact db datom = - let bound = { datom with tx = tx0; added = true } in - let compare_to_fact left right = - Util.first_nonzero - [ compare left.e right.e - ; compare left.a right.a - ; Util.compare_value left.v right.v - ] - in - let cmp left right = - if right == bound then - compare_to_fact left right - else - Util.compare_datom Eavt left right - in - let duplicate_matches = - Option.value (Hashtbl.find_opt db.duplicate_eavt_by_entity datom.e) ~default:[] - |> List.filter (fun active -> active.a = datom.a && value_equal active.v datom.v) - in - match Index.find_first_slice ~from_:bound ~to_:bound ~cmp db.eavt_index with - | Some active when active.e = datom.e && active.a = datom.a && value_equal active.v datom.v -> Some active - | _ -> ( - match duplicate_matches with - | [] -> None - | matches -> Some (matches |> List.sort (Util.compare_datom Eavt) |> List.hd)) - -let add_datom_to_indexes db datom = - { db with - eavt_index = Index.add datom db.eavt_index - ; aevt_index = Index.add datom db.aevt_index - ; avet_index = - if Schema.schema_attr_is_avet_accessible db.schema datom.a then - Index.add datom db.avet_index - else - db.avet_index - ; max_datom_e = max db.max_datom_e datom.e - } - let refresh_indexes_with_tx_data db tx_data = - let db = - List.fold_left - (fun db datom -> - if datom.added then - add_datom_to_indexes db datom - else - match find_active_datom_by_fact db datom with - | None -> db - | Some active -> - { db with - eavt_index = Index.remove active db.eavt_index - ; aevt_index = Index.remove active db.aevt_index - ; avet_index = Index.remove active db.avet_index - }) - db - tx_data - in - invalidate_attr_tables db - -let snapshot_db db = - { db with - eavt_index = Index.copy db.eavt_index - ; aevt_index = Index.copy db.aevt_index - ; avet_index = Index.copy db.avet_index - } + if tx_data = [] then db + else + let avet attr = Schema.schema_attr_is_avet_accessible db.schema attr in + let max_datom_e = List.fold_left (fun max_e d -> max max_e d.e) db.max_datom_e tx_data in + let eavt_index, aevt_index, avet_index = + Index.append_tx_data ~avet tx_data db.eavt_index db.aevt_index db.avet_index + in + { db with eavt_index; aevt_index; avet_index; max_datom_e } + |> invalidate_attr_tables -let view_bounds db = - { Tx_visibility.view_tx = db.max_tx; since_tx = db.since_tx; history = db.history } +let snapshot_db db = db let temporal_view db = Option.is_some db.as_of_tx || Option.is_some db.since_tx || db.history -let apply_db_view db datoms = Tx_visibility.apply_view (view_bounds db) datoms - -let apply_db_view_seq db seq = - if temporal_view db then Tx_visibility.filter_seq (view_bounds db) seq else seq - let basis_tx db = db.max_tx let as_of_t db = db.as_of_tx @@ -488,25 +441,22 @@ let primary_attr_datoms db index attr = let attr_prefix_datoms _index index_set = Index.fold_attr_prefix (fun acc datom -> datom :: acc) [] index_set attr |> List.rev in - let attr_prefix_array index index_set = - Array.of_list (attr_prefix_datoms index index_set) - in match index with | Aevt -> (match Hashtbl.find_opt db.aevt_by_attr attr with | Some datoms -> Array.to_list datoms | None -> - let datoms = attr_prefix_array Aevt db.aevt_index in - Hashtbl.replace db.aevt_by_attr attr datoms; - Array.to_list datoms) + let datoms = attr_prefix_datoms Aevt db.aevt_index |> apply_db_view db in + Hashtbl.replace db.aevt_by_attr attr (Array.of_list datoms); + datoms) | Avet -> (match Hashtbl.find_opt db.avet_by_attr attr with | Some datoms -> Array.to_list datoms | None -> - let datoms = attr_prefix_array Avet db.avet_index in - Hashtbl.replace db.avet_by_attr attr datoms; - Array.to_list datoms) - | Eavt -> Index.to_list db.eavt_index + let datoms = attr_prefix_datoms Avet db.avet_index |> apply_db_view db in + Hashtbl.replace db.avet_by_attr attr (Array.of_list datoms); + datoms) + | Eavt -> apply_db_view db (Index.to_list db.eavt_index) let duplicate_prefix_datoms db index e a = match index, e, a with @@ -518,15 +468,15 @@ let raw_index_datoms_list db index = merge_sorted_datoms index (stored_index db index |> Index.to_list) (duplicate_index_datoms db index) let visible_index_datoms db index = - let datoms = raw_index_datoms_list db index in + let datoms = apply_db_view db (raw_index_datoms_list db index) in match db.filter_pred with | None -> datoms | Some pred -> List.filter pred datoms let index_datoms_seq db index = match db.duplicate_datoms with - | [] -> stored_index db index |> Index.seq |> Index.to_seq - | _ -> raw_index_datoms_list db index |> List.to_seq + | [] -> stored_index db index |> Index.seq |> Index.to_seq |> apply_db_view_seq db + | _ -> raw_index_datoms_list db index |> apply_db_view db |> List.to_seq let reverse_index_datoms_seq db index = match db.duplicate_datoms with diff --git a/impl/index.mli b/impl/index.mli index 2b6ff6f..390355a 100644 --- a/impl/index.mli +++ b/impl/index.mli @@ -16,6 +16,8 @@ val of_sorted_list : index -> datom list -> lmdb -> t val of_sorted_lists : (index * datom list) list -> lmdb -> unit val of_eavt_datoms : avet:(string -> bool) -> datom list -> lmdb -> unit val of_bulk : index -> datom list -> lmdb -> t +val append_datoms : datom list -> t -> t +val append_tx_data : avet:(attr -> bool) -> datom list -> t -> t -> t -> t * t * t val add : datom -> t -> t val remove : datom -> t -> t val lookup : t -> datom -> datom option diff --git a/impl/platform/jsoo/index.ml b/impl/platform/jsoo/index.ml index 953e2cb..602eaac 100644 --- a/impl/platform/jsoo/index.ml +++ b/impl/platform/jsoo/index.ml @@ -35,6 +35,15 @@ let of_sorted_lists index_datoms lmdb = Datascript_lmdb_index.of_sorted_lists in let of_eavt_datoms ~avet datoms lmdb = Datascript_lmdb_index.of_eavt_datoms ~avet datoms lmdb let of_bulk index datoms lmdb = Datascript_lmdb_index.of_bulk index datoms lmdb |> inject +let append_tx_data ~avet:is_avet datoms eavt_index aevt_index avet_index = + let eavt, aevt, avet_index' = + Datascript_lmdb_index.append_tx_data ~avet:is_avet datoms (project eavt_index) (project aevt_index) + (project avet_index) + in + inject eavt, inject aevt, inject avet_index' + +let append_datoms datoms t = Datascript_lmdb_index.append_datoms datoms (project t) |> inject + let add datom t = Datascript_lmdb_index.add datom (project t) |> inject let remove datom t = Datascript_lmdb_index.remove datom (project t) |> inject let lookup t datom = Datascript_lmdb_index.lookup (project t) datom diff --git a/impl/platform/melange/index.ml b/impl/platform/melange/index.ml index 953e2cb..602eaac 100644 --- a/impl/platform/melange/index.ml +++ b/impl/platform/melange/index.ml @@ -35,6 +35,15 @@ let of_sorted_lists index_datoms lmdb = Datascript_lmdb_index.of_sorted_lists in let of_eavt_datoms ~avet datoms lmdb = Datascript_lmdb_index.of_eavt_datoms ~avet datoms lmdb let of_bulk index datoms lmdb = Datascript_lmdb_index.of_bulk index datoms lmdb |> inject +let append_tx_data ~avet:is_avet datoms eavt_index aevt_index avet_index = + let eavt, aevt, avet_index' = + Datascript_lmdb_index.append_tx_data ~avet:is_avet datoms (project eavt_index) (project aevt_index) + (project avet_index) + in + inject eavt, inject aevt, inject avet_index' + +let append_datoms datoms t = Datascript_lmdb_index.append_datoms datoms (project t) |> inject + let add datom t = Datascript_lmdb_index.add datom (project t) |> inject let remove datom t = Datascript_lmdb_index.remove datom (project t) |> inject let lookup t datom = Datascript_lmdb_index.lookup (project t) datom diff --git a/impl/platform/native/index.ml b/impl/platform/native/index.ml index fb4d676..5923ebe 100644 --- a/impl/platform/native/index.ml +++ b/impl/platform/native/index.ml @@ -35,6 +35,15 @@ let of_sorted_lists index_datoms lmdb = Datascript_lmdb_index.of_sorted_lists in let of_eavt_datoms ~avet datoms lmdb = Datascript_lmdb_index.of_eavt_datoms ~avet datoms lmdb let of_bulk index datoms lmdb = Datascript_lmdb_index.of_bulk index datoms lmdb |> inject +let append_tx_data ~avet:is_avet datoms eavt_index aevt_index avet_index = + let eavt, aevt, avet_index' = + Datascript_lmdb_index.append_tx_data ~avet:is_avet datoms (project eavt_index) (project aevt_index) + (project avet_index) + in + inject eavt, inject aevt, inject avet_index' + +let append_datoms datoms t = Datascript_lmdb_index.append_datoms datoms (project t) |> inject + let add datom t = Datascript_lmdb_index.add datom (project t) |> inject let remove datom t = Datascript_lmdb_index.remove datom (project t) |> inject let lookup t datom = Datascript_lmdb_index.lookup (project t) datom diff --git a/lmdb/native/datascript_lmdb_index.ml b/lmdb/native/datascript_lmdb_index.ml index fda02f8..0a7ab40 100644 --- a/lmdb/native/datascript_lmdb_index.ml +++ b/lmdb/native/datascript_lmdb_index.ml @@ -1,22 +1,14 @@ open Datascript_types -type t = - { db : Datascript_lmdb_db.t - ; which : index - ; additions : datom list - ; additions_arr : datom array option - ; removals : datom list - ; bulk : bool - } +type t = { db : Datascript_lmdb_db.t; which : index } type 'a seq = { cmp : datom -> datom -> int; datoms : datom list; offset : int } exception Stop_search let db_of t = t.db -let make index db = { db; which = index; additions = []; additions_arr = None; removals = []; bulk = false } +let make index db = { db; which = index } let cmp_for index = Datascript_types.Compare.compare_datom index -let overlay_empty t = t.additions = [] && t.removals = [] let datom_key t datom = Datascript_lmdb_codec.encode_datom_key t.which datom @@ -30,20 +22,16 @@ let put_datom_txn txn t datom = let value = Datascript_lmdb_codec.encode_datom_value datom in Datascript_lmdb_db.put_index_txn t.which txn t.db key value -let remove_datom_txn txn t datom = - let key = datom_key t datom in - Datascript_lmdb_db.remove_index_txn t.which txn t.db key - let empty index db = make index db -let of_sorted_list index datoms db = - let t = empty index db in +let write_datoms t datoms = if datoms = [] then t else ( - Datascript_lmdb_db.with_write_txn db (fun txn -> - List.iter (put_datom_txn txn t) datoms); + Datascript_lmdb_db.with_write_txn t.db (fun txn -> List.iter (put_datom_txn txn t) datoms); t) +let of_sorted_list index datoms db = write_datoms (empty index db) datoms + let of_sorted_lists index_datoms db = Datascript_lmdb_db.with_write_txn db (fun txn -> List.iter @@ -66,43 +54,29 @@ let of_eavt_datoms ~avet eavt_datoms db = if avet datom.a then put_datom_txn txn avet_index datom) eavt_datoms)) -let of_bulk index datoms db = - { db; which = index; additions = []; additions_arr = Some (Array.of_list datoms); removals = []; bulk = true } +let of_bulk index datoms db = of_sorted_list index datoms db -let array_find_first cmp bound arr = - let len = Array.length arr in - let rec lower lo hi = - if lo >= hi then lo - else - let mid = (lo + hi) / 2 in - if cmp arr.(mid) bound < 0 then lower (mid + 1) hi else lower lo mid - in - let index = lower 0 len in - if index < len && cmp arr.(index) bound = 0 then Some arr.(index) else None - -let array_lower_bound cmp bound arr = - let len = Array.length arr in - let rec lower lo hi = - if lo >= hi then lo - else - let mid = (lo + hi) / 2 in - if cmp arr.(mid) bound < 0 then lower (mid + 1) hi else lower lo mid - in - lower 0 len - -let sorted_bulk_array t = - match t.additions_arr with - | Some arr -> arr - | None -> - let arr = Array.of_list t.additions in - Array.sort (cmp_for t.which) arr; - arr - -let bulk_datoms t = - let base = Array.to_list (sorted_bulk_array t) in - match t.additions with - | [] -> base - | overlay -> List.merge (cmp_for t.which) (List.sort (cmp_for t.which) overlay) base +let append_tx_data ~avet:is_avet datoms eavt aevt avet_index = + if datoms = [] then (eavt, aevt, avet_index) + else ( + Datascript_lmdb_db.with_write_txn eavt.db (fun txn -> + List.iter + (fun datom -> + put_datom_txn txn eavt datom; + put_datom_txn txn aevt datom; + if is_avet datom.a then put_datom_txn txn avet_index datom) + datoms); + (eavt, aevt, avet_index)) + +let append_datoms datoms t = write_datoms t datoms + +let add datom t = write_datoms t [ datom ] + +let remove _datom t = t + +let bound_key t = function + | None -> None + | Some datom -> Some (datom_key t datom) let in_range cmp lower upper datom = let above_lower = @@ -117,288 +91,77 @@ let in_range cmp lower upper datom = in above_lower && below_upper -let array_fold_in_range cmp from_ to_ arr f init = - let len = Array.length arr in - let start = - match from_ with - | None -> 0 - | Some bound -> array_lower_bound cmp bound arr - in - let rec loop index acc = - if index >= len then acc - else - let datom = arr.(index) in - if not (in_range cmp from_ to_ datom) then acc - else loop (index + 1) (f acc datom) - in - loop start init - -let array_materialize_range cmp from_ to_ arr = - array_fold_in_range cmp from_ to_ arr (fun acc datom -> datom :: acc) [] |> List.rev - -let array_fold_attr_prefix f init attr arr index = - let cmp = cmp_for index in - let bound = { e = 0; a = attr; v = Nil; tx = 0; added = true } in - let start = array_lower_bound cmp bound arr in - let len = Array.length arr in - let rec loop i acc = - if i >= len then acc - else - let datom = arr.(i) in - if datom.a <> attr then acc else loop (i + 1) (f acc datom) - in - loop start init - -let values_equal left right = - match left, right with - | String left, String right - | Symbol left, Symbol right - | Keyword left, Keyword right - | Uuid left, Uuid right - | Regex left, Regex right -> - left = right - | Bool left, Bool right -> left = right - | Int left, Int right - | Ref left, Ref right - | Int left, Ref right - | Ref left, Int right -> - left = right - | Instant left, Instant right -> left = right - | Nil, Nil -> true - | TxRef, TxRef -> true - | _ -> Compare.compare_value left right = 0 - -let array_fold_attr_value_prefix f init attr value arr index = - let cmp = cmp_for index in - let bound = { e = 0; a = attr; v = value; tx = 0; added = true } in - let start = array_lower_bound cmp bound arr in - let len = Array.length arr in - let rec loop i acc = - if i >= len then acc - else - let datom = arr.(i) in - if datom.a <> attr || not (values_equal datom.v value) then acc - else loop (i + 1) (f acc datom) - in - loop start init - -let additions_only t = - t.bulk && t.removals = [] && (t.additions <> [] || Option.is_some t.additions_arr) - -let add datom t = - if additions_only t then - { t with additions = datom :: t.additions } - else ( - let key = datom_key t datom in - let additions = datom :: List.filter (fun d -> datom_key t d <> key) t.additions in - let removals = List.filter (fun d -> datom_key t d <> key) t.removals in - { t with additions; removals }) - -let remove datom t = - let key = datom_key t datom in - let stored_additions = - match t.additions_arr with - | Some arr -> Array.to_list arr - | None -> t.additions - in - let additions = List.filter (fun d -> datom_key t d <> key) stored_additions in - let already_removed = List.exists (fun d -> datom_key t d = key) t.removals in - let removals = - if already_removed || List.exists (fun d -> datom_key t d = key) stored_additions then t.removals - else datom :: t.removals - in - { t with additions; additions_arr = None; removals } - -let overlay_tables t = - let stored_additions = - match t.additions_arr with - | Some arr -> Array.to_list arr - | None -> t.additions - in - let removed = Hashtbl.create (List.length t.removals) in - List.iter (fun datom -> Hashtbl.add removed (datom_key t datom) ()) t.removals; - let added = Hashtbl.create (List.length stored_additions) in - List.iter (fun datom -> Hashtbl.replace added (datom_key t datom) datom) stored_additions; - removed, added - -let stored_visible key removed added = - not (Hashtbl.mem removed key || Hashtbl.mem added key) - -let bound_key t = function - | None -> None - | Some datom -> Some (datom_key t datom) - let fold_stored t f acc = - if overlay_empty t then - let acc = ref acc in - Datascript_lmdb_db.fold_index t.which t.db (fun key value -> - acc := f !acc (decode_entry t.which key value)); - !acc - else - let removed, added = overlay_tables t in - let acc = ref acc in - Datascript_lmdb_db.fold_index t.which t.db (fun key value -> - if stored_visible key removed added then - acc := f !acc (decode_entry t.which key value)); - !acc + let acc = ref acc in + Datascript_lmdb_db.fold_index t.which t.db (fun key value -> + acc := f !acc (decode_entry t.which key value)); + !acc let fold_stored_prefix t attr f acc = let prefix = attr ^ "\000" in - if overlay_empty t then - let acc = ref acc in - Datascript_lmdb_db.fold_index_prefix t.which t.db prefix (fun key value -> - acc := f !acc (decode_entry t.which key value)); - !acc - else - let removed, added = overlay_tables t in - let acc = ref acc in - Datascript_lmdb_db.fold_index_prefix t.which t.db prefix (fun key value -> - if stored_visible key removed added then - acc := f !acc (decode_entry t.which key value)); - !acc + let acc = ref acc in + Datascript_lmdb_db.fold_index_prefix t.which t.db prefix (fun key value -> + acc := f !acc (decode_entry t.which key value)); + !acc let fold_stored_attr_value_prefix t attr value f acc = let prefix = Datascript_lmdb_codec.encode_index_attr_value_prefix t.which attr value in - if overlay_empty t then - let acc = ref acc in - Datascript_lmdb_db.fold_index_prefix t.which t.db prefix (fun key value -> - acc := f !acc (decode_entry t.which key value)); - !acc - else - let removed, added = overlay_tables t in - let acc = ref acc in - Datascript_lmdb_db.fold_index_prefix t.which t.db prefix (fun key value -> - if stored_visible key removed added then - acc := f !acc (decode_entry t.which key value)); - !acc + let acc = ref acc in + Datascript_lmdb_db.fold_index_prefix t.which t.db prefix (fun key value -> + acc := f !acc (decode_entry t.which key value)); + !acc let fold_stored_bounded t ?from_ ?to_ cmp f acc = match bound_key t from_ with | None -> fold_stored t f acc | Some from_key -> - let removed, added = - if overlay_empty t then (Hashtbl.create 0, Hashtbl.create 0) else overlay_tables t - in let acc = ref acc in Datascript_lmdb_db.fold_index_range_until t.which t.db ~from_key - ~stop:(fun key value -> - if not (stored_visible key removed added) then false - else - match to_ with - | Some bound -> - let datom = decode_entry t.which key value in - cmp datom bound > 0 - | None -> false) + ~stop:(fun _key _value -> + match to_ with + | Some bound -> + let datom = decode_entry t.which _key _value in + cmp datom bound > 0 + | None -> false) (fun key value -> - if stored_visible key removed added then - let datom = decode_entry t.which key value in - if in_range cmp from_ to_ datom then acc := f !acc datom); + let datom = decode_entry t.which key value in + if in_range cmp from_ to_ datom then acc := f !acc datom); !acc -let fold_overlay t f acc = List.fold_left f acc t.additions - -let fold_bulk_slice f init ?from_ ?to_ ?cmp t = - let cmp = Option.value ~default:(cmp_for t.which) cmp in - let apply acc datom = if in_range cmp from_ to_ datom then f acc datom else acc in - let arr = sorted_bulk_array t in - let acc = - match from_, to_ with - | Some bound, Some bound' when bound == bound' && bound.a <> "" && bound.v <> Nil && bound.e = 0 -> - array_fold_attr_value_prefix f init bound.a bound.v arr t.which - | _ -> array_fold_in_range cmp from_ to_ arr f init - in - List.fold_left apply acc t.additions - -let fold_datoms f init t = - if additions_only t then - let acc = Array.fold_left (fun acc datom -> f acc datom) init (sorted_bulk_array t) in - List.fold_left f acc t.additions - else ( - let acc = fold_stored t f init in - fold_overlay t f acc) - -let collect_datoms t = - if overlay_empty t then fold_stored t (fun acc datom -> datom :: acc) [] - else fold_datoms (fun acc datom -> datom :: acc) [] t |> List.sort (cmp_for t.which) - let clear_index_txn txn index lmdb = Datascript_lmdb_db.fold_index index lmdb (fun key _ -> Datascript_lmdb_db.remove_index_txn index txn lmdb key) let sync_merged_to_lmdb t target_lmdb = - let write_datom_txn txn datom = - let key = datom_key t datom in - let value = Datascript_lmdb_codec.encode_datom_value datom in - Datascript_lmdb_db.put_index_txn t.which txn target_lmdb key value - in - if additions_only t then - Datascript_lmdb_db.with_write_txn target_lmdb (fun txn -> - Array.iter (write_datom_txn txn) (sorted_bulk_array t); - List.iter (write_datom_txn txn) t.additions) - else if overlay_empty t then - Datascript_lmdb_db.with_write_txn target_lmdb (fun txn -> - clear_index_txn txn t.which target_lmdb; - Datascript_lmdb_db.copy_index_txn t.which txn t.db target_lmdb) + if t.db == target_lmdb then () else - let merged = collect_datoms t in Datascript_lmdb_db.with_write_txn target_lmdb (fun txn -> clear_index_txn txn t.which target_lmdb; - List.iter (write_datom_txn txn) merged) - -let copy_list xs = List.map (fun x -> x) xs + Datascript_lmdb_db.copy_index_txn t.which txn t.db target_lmdb) -let copy t = { t with additions = copy_list t.additions; removals = copy_list t.removals } +let copy t = t -let flush t = - if overlay_empty t then t - else ( - Datascript_lmdb_db.with_write_txn t.db (fun txn -> - List.iter (remove_datom_txn txn t) t.removals; - List.iter (put_datom_txn txn t) t.additions); - { t with additions = []; additions_arr = None; removals = [] }) +let flush t = t -let to_list t = - if additions_only t then bulk_datoms t - else if overlay_empty t then List.rev (fold_stored t (fun acc datom -> datom :: acc) []) - else collect_datoms t +let to_list t = List.rev (fold_stored t (fun acc datom -> datom :: acc) []) -let fold f init t = fold_datoms f init t +let fold f init t = fold_stored t f init let lookup t datom = - let key = datom_key t datom in - if List.exists (fun d -> datom_key t d = key) t.removals then None - else - (match List.find_opt (fun d -> datom_key t d = key) t.additions with - | Some datom -> Some datom - | None -> ( - match t.additions_arr with - | Some arr -> - let cmp = cmp_for t.which in - (match array_find_first cmp datom arr with - | Some found when datom_key t found = key -> Some found - | _ -> None) - | None -> ( - match Datascript_lmdb_db.get_index t.which t.db key with - | None -> None - | Some value -> Some (decode_entry t.which key value)))) + match Datascript_lmdb_db.get_index t.which t.db (datom_key t datom) with + | None -> None + | Some value -> Some (decode_entry t.which (datom_key t datom) value) let fold_slice f init ?from_ ?to_ ?cmp t = - if additions_only t then fold_bulk_slice f init ?from_ ?to_ ?cmp t - else - let cmp = Option.value ~default:(cmp_for t.which) cmp in - let apply acc datom = if in_range cmp from_ to_ datom then f acc datom else acc in - if not (overlay_empty t) then - collect_datoms t - |> List.filter (fun datom -> in_range cmp from_ to_ datom) - |> List.fold_left f init - else - match from_, to_ with - | Some bound, Some bound' when bound == bound' && bound.a <> "" && bound.e = 0 && bound.v = Nil - && (t.which = Aevt || t.which = Avet) -> - fold_stored_prefix t bound.a apply init - | Some bound, Some bound' when bound == bound' && bound.a <> "" && bound.v <> Nil && bound.e = 0 -> - fold_stored_attr_value_prefix t bound.a bound.v apply init - | _ -> fold_stored_bounded t ?from_ ?to_ cmp apply init + let cmp = Option.value ~default:(cmp_for t.which) cmp in + let apply acc datom = if in_range cmp from_ to_ datom then f acc datom else acc in + match from_, to_ with + | Some bound, Some bound' when bound == bound' && bound.a <> "" && bound.e = 0 && bound.v = Nil + && (t.which = Aevt || t.which = Avet) -> + fold_stored_prefix t bound.a apply init + | Some bound, Some bound' when bound == bound' && bound.a <> "" && bound.v <> Nil && bound.e = 0 -> + fold_stored_attr_value_prefix t bound.a bound.v apply init + | _ -> fold_stored_bounded t ?from_ ?to_ cmp apply init let find_first_slice ?from_ ?to_ ?cmp t = let cmp = Option.value ~default:(cmp_for t.which) cmp in @@ -409,56 +172,21 @@ let find_first_slice ?from_ ?to_ ?cmp t = raise Stop_search) in (try - if additions_only t then ( - List.iter consider t.additions; - match from_, to_ with - | Some bound, Some bound' when bound == bound' && bound.a <> "" && bound.v <> Nil && bound.e = 0 -> - ignore - (array_fold_attr_value_prefix - (fun () datom -> consider datom) - () - bound.a - bound.v - (sorted_bulk_array t) - t.which) - | Some bound, Some bound' when bound == bound' -> ( - match array_find_first cmp bound (sorted_bulk_array t) with - | Some datom when !found = None && in_range cmp from_ to_ datom -> - found := Some datom; - raise Stop_search - | _ -> ()) - | _ -> - if !found = None then - ignore (array_fold_in_range cmp from_ to_ (sorted_bulk_array t) (fun () datom -> consider datom) ())) - else if not (overlay_empty t) then - collect_datoms t |> List.iter consider - else - match from_, to_ with - | Some bound, Some bound' when bound == bound' && bound.a <> "" && bound.e = 0 && bound.v = Nil - && (t.which = Aevt || t.which = Avet) -> - fold_stored_prefix t bound.a (fun () datom -> consider datom) () - | Some bound, Some bound' when bound == bound' && bound.a <> "" && bound.v <> Nil && bound.e = 0 -> - fold_stored_attr_value_prefix t bound.a bound.v (fun () datom -> consider datom) () - | _ -> fold_stored_bounded t ?from_ ?to_ cmp (fun () datom -> consider datom) () + match from_, to_ with + | Some bound, Some bound' when bound == bound' && bound.a <> "" && bound.e = 0 && bound.v = Nil + && (t.which = Aevt || t.which = Avet) -> + fold_stored_prefix t bound.a (fun () datom -> consider datom) () + | Some bound, Some bound' when bound == bound' && bound.a <> "" && bound.v <> Nil && bound.e = 0 -> + fold_stored_attr_value_prefix t bound.a bound.v (fun () datom -> consider datom) () + | _ -> fold_stored_bounded t ?from_ ?to_ cmp (fun () datom -> consider datom) () with Stop_search -> ()); !found let fold_attr_prefix f init t attr = - let apply acc datom = if datom.a = attr then f acc datom else acc in - if additions_only t then - let arr = sorted_bulk_array t in - let acc = array_fold_attr_prefix f init attr arr t.which in - List.fold_left apply acc t.additions - else if not (overlay_empty t) then - collect_datoms t - |> List.filter (fun datom -> datom.a = attr) - |> List.fold_left f init - else - fold_stored_prefix t attr apply init + fold_stored_prefix t attr (fun acc datom -> if datom.a = attr then f acc datom else acc) init let materialize_range t ?from_ ?to_ cmp = - if additions_only t then array_materialize_range cmp from_ to_ (sorted_bulk_array t) - else fold_slice (fun acc datom -> datom :: acc) [] ?from_ ?to_ ~cmp t |> List.rev + fold_slice (fun acc datom -> datom :: acc) [] ?from_ ?to_ ~cmp t |> List.rev let make_seq cmp datoms = { cmp; datoms; offset = 0 } diff --git a/lmdb/native/datascript_lmdb_index.mli b/lmdb/native/datascript_lmdb_index.mli index cc85977..992ad74 100644 --- a/lmdb/native/datascript_lmdb_index.mli +++ b/lmdb/native/datascript_lmdb_index.mli @@ -9,6 +9,8 @@ val of_sorted_list : index -> datom list -> Datascript_lmdb_db.t -> t val of_sorted_lists : (index * datom list) list -> Datascript_lmdb_db.t -> unit val of_eavt_datoms : avet:(string -> bool) -> datom list -> Datascript_lmdb_db.t -> unit val of_bulk : index -> datom list -> Datascript_lmdb_db.t -> t +val append_datoms : datom list -> t -> t +val append_tx_data : avet:(string -> bool) -> datom list -> t -> t -> t -> t * t * t val add : datom -> t -> t val remove : datom -> t -> t val flush : t -> t diff --git a/test/dune b/test/dune index 8ec7760..e69509e 100644 --- a/test/dune +++ b/test/dune @@ -23,6 +23,11 @@ (modules test_tx_visibility) (libraries datascript-ocaml-native)) +(test + (name test_tx_history) + (modules test_tx_history) + (libraries datascript-ocaml-native)) + (test (name test_db) (modules test_db) diff --git a/test/test_tx_history.ml b/test/test_tx_history.ml new file mode 100644 index 0000000..e553d74 --- /dev/null +++ b/test/test_tx_history.ml @@ -0,0 +1,97 @@ +open Datascript + +let failf fmt = Printf.ksprintf failwith fmt + +let assert_equal_int label expected actual = + if expected <> actual then failf "%s: expected %d, got %d" label expected actual + +let indexed = + { cardinality = One + ; unique = None + ; indexed = true + ; is_component = false + ; no_history = false + ; doc = None + ; value_type = None + ; tuple_attrs = None + ; tuple_types = None + } + +let unique_identity = { indexed with unique = Some Identity } + +let ages db = + datoms db Eavt ~a:":age" () + |> Seq.map (fun d -> d.v) + |> List.of_seq + +let test_history_exposes_retractions () = + let db = + db_with + [ Add (Entity_id 1, ":name", String "Alice") + ; Add (Entity_id 1, ":age", Int 30) + ] + (empty_db ~schema:[ "name", unique_identity; "age", indexed ] ()) + in + let tx1 = basis_tx db in + let db = db_with [ Add (Entity_id 1, ":age", Int 31) ] db in + let current = + ages db + |> List.map (function Int n -> n | _ -> -1) + in + assert_equal_int "current db keeps latest age" 1 (List.length current); + if current <> [ 31 ] then failf "current ages should be [31], got %S" (string_of_int (List.hd current)); + let past = as_of tx1 db in + let past_ages = + ages past + |> List.map (function Int n -> n | _ -> -1) + in + if past_ages <> [ 30 ] then failf "as_of should see age 30, got %d entries" (List.length past_ages); + let hist = history db in + let hist_ages = + datoms hist Eavt ~a:":age" () + |> Seq.filter (fun d -> d.added) + |> Seq.map (fun d -> match d.v with Int n -> n | _ -> -1) + |> List.of_seq + |> List.sort compare + in + if hist_ages <> [ 30; 31 ] then + failf "history should expose both asserted ages, got [%s]" + (String.concat "; " (List.map string_of_int hist_ages)) + +let test_since_sees_post_tx_datoms () = + let db = + db_with + [ Add (Entity_id 1, ":name", String "Alice") + ; Add (Entity_id 2, ":name", String "Bob") + ] + (empty_db ~schema:[ "name", unique_identity ] ()) + in + let tx1 = basis_tx db in + let db = db_with [ Add (Entity_id 3, ":name", String "Carol") ] db in + let names delta = + datoms delta Aevt ~a:":name" () + |> Seq.map (fun d -> match d.v with String s -> s | _ -> "") + |> List.of_seq + |> List.sort compare + in + if names db <> [ "Alice"; "Bob"; "Carol" ] then failf "current db missing Carol"; + let delta = since tx1 db in + if names delta <> [ "Carol" ] then failf "since tx1 should only see Carol" + +let test_with_tx_preserves_db_before_basis () = + let db = + db_with [ Add (Entity_id 1, ":name", String "Alice") ] (empty_db ~schema:[ "name", indexed ] ()) + in + let before_basis = basis_tx db in + let report = + with_tx db [ Add (Entity_id 2, ":name", String "Bob") ] + in + assert_equal_int "input db unchanged" before_basis (basis_tx db); + assert_equal_int "db_before pins old basis" before_basis (basis_tx report.db_before); + assert_equal_int "db_after advances basis" 1 (if basis_tx report.db_after > before_basis then 1 else 0) + +let () = + test_history_exposes_retractions (); + test_since_sees_post_tx_datoms (); + test_with_tx_preserves_db_before_basis (); + Printf.printf "test_tx_history: ok\n" From 5e2e4302d04b968a3fff70a73260086b37f54662 Mon Sep 17 00:00:00 2001 From: Cursor Agent Date: Thu, 27 Aug 2026 08:54:13 +0000 Subject: [PATCH 3/9] Add session pending_datoms staging for fast transact without storage Defer LMDB writes for incremental transacts on databases without attached storage into db.pending_datoms. Bulk init still writes session LMDB directly. Store flushes pending via flush_pending_datoms before syncing indexes. Read paths merge pending_overlay with LMDB cursors without forcing full list materialization when only duplicates are absent. Fix find_eavt/find_avet and exact-prefix/seek paths to include pending datoms. Co-authored-by: Tienson Qin --- impl/datascript.ml | 16 +- impl/db.ml | 241 ++++++++++++++++++++++--------- impl/db.mli | 1 + impl/platform/jsoo/storage.ml | 1 + impl/platform/melange/storage.ml | 1 + impl/platform/native/storage.ml | 1 + impl/serialize.ml | 4 +- impl/storage_lmdb_impl.ml | 1 + impl/storage_pss.ml | 1 + type/datascript_types.ml | 1 + 10 files changed, 194 insertions(+), 74 deletions(-) diff --git a/impl/datascript.ml b/impl/datascript.ml index 3d29e86..b496148 100644 --- a/impl/datascript.ml +++ b/impl/datascript.ml @@ -99,7 +99,7 @@ let from_serializable snapshot = Serialize.from_serializable serialize_context snapshot let store ?storage db = - Storage.store ?storage db + Storage.store ?storage (Db_impl.flush_pending_datoms db) let memory_storage = Storage.memory_storage let storage_addresses = Storage.storage_addresses @@ -258,6 +258,13 @@ let find_avet_exact db attr value = match Index.find_first_slice ~from_:bound ~to_:bound ~cmp db.avet_index with | Some datom when datom.a = attr && value_equal datom.v value -> Some datom | _ -> ( + match + List.find_opt + (fun datom -> datom.a = attr && value_equal datom.v value) + db.pending_datoms + with + | Some datom -> Some datom + | None -> match List.filter (fun datom -> datom.a = attr && value_equal datom.v value) @@ -284,6 +291,13 @@ let find_eavt_exact db entity_id attr value = match Index.find_first_slice ~from_:bound ~to_:bound ~cmp db.eavt_index with | Some datom when datom.e = entity_id && datom.a = attr && value_equal datom.v value -> Some datom | _ -> ( + match + List.find_opt + (fun datom -> datom.e = entity_id && datom.a = attr && value_equal datom.v value) + db.pending_datoms + with + | Some datom -> Some datom + | None -> match List.filter (fun datom -> datom.e = entity_id && datom.a = attr && value_equal datom.v value) diff --git a/impl/db.ml b/impl/db.ml index b9b21c7..16fe275 100644 --- a/impl/db.ml +++ b/impl/db.ml @@ -125,6 +125,31 @@ let apply_db_view db datoms = Tx_visibility.apply_view (view_bounds db) datoms let apply_db_view_seq db seq = Tx_visibility.filter_seq (view_bounds db) seq +let indexes_on_storage db = Option.is_some db.storage_ref + +let merged_index db = db.duplicate_datoms <> [] + +let pending_overlay db = db.pending_datoms <> [] + +let pending_for_index db index = + let datoms = + match index with + | Avet -> + List.filter (fun d -> Schema.schema_attr_is_avet_accessible db.schema d.a) db.pending_datoms + | Eavt | Aevt -> db.pending_datoms + in + List.sort (Util.compare_datom index) datoms + +let flush_pending_datoms db = + match db.pending_datoms with + | [] -> db + | pending -> + let avet attr = Schema.schema_attr_is_avet_accessible db.schema attr in + let eavt_index, aevt_index, avet_index = + Index.append_tx_data ~avet pending db.eavt_index db.aevt_index db.avet_index + in + { db with pending_datoms = []; eavt_index; aevt_index; avet_index } + let lmdb_of_db db = try Index.lmdb_of (Index.db_of db.eavt_index) with Invalid_argument _ -> @@ -174,9 +199,9 @@ let set_indexes_from_datoms db datoms = ~avet:(Schema.schema_attr_is_avet_accessible db.schema) eavt_datoms lmdb; - let eavt_index = Index.empty Eavt lmdb in - let aevt_index = Index.empty Aevt lmdb in - let avet_index = Index.empty Avet lmdb in + let eavt_index = Index.empty Eavt lmdb + and aevt_index = Index.empty Aevt lmdb + and avet_index = Index.empty Avet lmdb in let duplicate_aevt_datoms = List.sort (Util.compare_datom Aevt) duplicate_datoms in let duplicate_avet_datoms = duplicate_datoms @@ -201,10 +226,11 @@ let set_indexes_from_datoms db datoms = ; duplicate_aevt_by_attr ; duplicate_avet_by_attr ; max_datom_e + ; pending_datoms = [] } let eavt_datoms db = - Index.to_list db.eavt_index @ db.duplicate_datoms + Index.to_list db.eavt_index @ db.duplicate_datoms @ db.pending_datoms |> List.sort (Util.compare_datom Eavt) |> apply_db_view db @@ -220,34 +246,42 @@ let add_datoms_to_index include_datom datoms index_set = let refresh_indexes_with_added_datoms db added_datoms = let max_datom_e = List.fold_left (fun max_e d -> max max_e d.e) db.max_datom_e added_datoms in - { db with - eavt_index = add_datoms_to_index (fun _ -> true) added_datoms db.eavt_index - ; aevt_index = add_datoms_to_index (fun _ -> true) added_datoms db.aevt_index - ; avet_index = - add_datoms_to_index - (fun d -> Schema.schema_attr_is_avet_accessible db.schema d.a) - added_datoms - db.avet_index - ; duplicate_datoms = db.duplicate_datoms - ; duplicate_aevt_datoms = db.duplicate_aevt_datoms - ; duplicate_avet_datoms = db.duplicate_avet_datoms - ; duplicate_eavt_by_entity = db.duplicate_eavt_by_entity - ; duplicate_aevt_by_attr = db.duplicate_aevt_by_attr - ; duplicate_avet_by_attr = db.duplicate_avet_by_attr - ; max_datom_e - } - |> invalidate_attr_tables + if indexes_on_storage db then + { db with + eavt_index = add_datoms_to_index (fun _ -> true) added_datoms db.eavt_index + ; aevt_index = add_datoms_to_index (fun _ -> true) added_datoms db.aevt_index + ; avet_index = + add_datoms_to_index + (fun d -> Schema.schema_attr_is_avet_accessible db.schema d.a) + added_datoms + db.avet_index + ; duplicate_datoms = db.duplicate_datoms + ; duplicate_aevt_datoms = db.duplicate_aevt_datoms + ; duplicate_avet_datoms = db.duplicate_avet_datoms + ; duplicate_eavt_by_entity = db.duplicate_eavt_by_entity + ; duplicate_aevt_by_attr = db.duplicate_aevt_by_attr + ; duplicate_avet_by_attr = db.duplicate_avet_by_attr + ; max_datom_e + } + |> invalidate_attr_tables + else + { db with pending_datoms = db.pending_datoms @ added_datoms; max_datom_e } + |> invalidate_attr_tables let refresh_indexes_with_tx_data db tx_data = if tx_data = [] then db else - let avet attr = Schema.schema_attr_is_avet_accessible db.schema attr in let max_datom_e = List.fold_left (fun max_e d -> max max_e d.e) db.max_datom_e tx_data in - let eavt_index, aevt_index, avet_index = - Index.append_tx_data ~avet tx_data db.eavt_index db.aevt_index db.avet_index - in - { db with eavt_index; aevt_index; avet_index; max_datom_e } - |> invalidate_attr_tables + if indexes_on_storage db then + let avet attr = Schema.schema_attr_is_avet_accessible db.schema attr in + let eavt_index, aevt_index, avet_index = + Index.append_tx_data ~avet tx_data db.eavt_index db.aevt_index db.avet_index + in + { db with eavt_index; aevt_index; avet_index; max_datom_e } + |> invalidate_attr_tables + else + { db with pending_datoms = db.pending_datoms @ tx_data; max_datom_e } + |> invalidate_attr_tables let snapshot_db db = db @@ -306,6 +340,7 @@ let empty_db context ?(schema = []) ?storage () = ; since_tx = None ; history = false ; filter_pred = None + ; pending_datoms = [] ; storage_ref = storage_ref_of ?storage auto_storage_ref ; tx_fns = [] } @@ -342,6 +377,7 @@ let init_db context ?(schema = []) ?storage datoms = ; since_tx = None ; history = false ; filter_pred = None + ; pending_datoms = [] ; storage_ref = storage_ref_of ?storage auto_storage_ref ; tx_fns = [] } @@ -441,22 +477,32 @@ let primary_attr_datoms db index attr = let attr_prefix_datoms _index index_set = Index.fold_attr_prefix (fun acc datom -> datom :: acc) [] index_set attr |> List.rev in + let pending_attr = + List.filter (fun d -> d.a = attr) db.pending_datoms |> List.sort (Util.compare_datom index) + in match index with | Aevt -> (match Hashtbl.find_opt db.aevt_by_attr attr with | Some datoms -> Array.to_list datoms | None -> - let datoms = attr_prefix_datoms Aevt db.aevt_index |> apply_db_view db in + let datoms = + merge_sorted_datoms Aevt (attr_prefix_datoms Aevt db.aevt_index) pending_attr + |> apply_db_view db + in Hashtbl.replace db.aevt_by_attr attr (Array.of_list datoms); datoms) | Avet -> (match Hashtbl.find_opt db.avet_by_attr attr with | Some datoms -> Array.to_list datoms | None -> - let datoms = attr_prefix_datoms Avet db.avet_index |> apply_db_view db in + let datoms = + merge_sorted_datoms Avet (attr_prefix_datoms Avet db.avet_index) pending_attr + |> apply_db_view db + in Hashtbl.replace db.avet_by_attr attr (Array.of_list datoms); datoms) - | Eavt -> apply_db_view db (Index.to_list db.eavt_index) + | Eavt -> + merge_sorted_datoms Eavt (Index.to_list db.eavt_index) pending_attr |> apply_db_view db let duplicate_prefix_datoms db index e a = match index, e, a with @@ -465,7 +511,9 @@ let duplicate_prefix_datoms db index e a = | _ -> duplicate_index_datoms db index let raw_index_datoms_list db index = - merge_sorted_datoms index (stored_index db index |> Index.to_list) (duplicate_index_datoms db index) + merge_sorted_datoms index + (stored_index db index |> Index.to_list) + (pending_for_index db index @ duplicate_index_datoms db index) let visible_index_datoms db index = let datoms = apply_db_view db (raw_index_datoms_list db index) in @@ -474,14 +522,25 @@ let visible_index_datoms db index = | Some pred -> List.filter pred datoms let index_datoms_seq db index = - match db.duplicate_datoms with - | [] -> stored_index db index |> Index.seq |> Index.to_seq |> apply_db_view_seq db - | _ -> raw_index_datoms_list db index |> apply_db_view db |> List.to_seq + match merged_index db, pending_overlay db with + | false, false -> + stored_index db index |> Index.seq |> Index.to_seq |> apply_db_view_seq db + | false, true -> + let stored = stored_index db index |> Index.seq |> Index.to_seq in + let pending = pending_for_index db index |> List.to_seq in + merge_sorted_datom_seqs (Util.compare_datom index) stored pending |> apply_db_view_seq db + | true, _ -> + raw_index_datoms_list db index |> apply_db_view db |> List.to_seq let reverse_index_datoms_seq db index = - match db.duplicate_datoms with - | [] -> stored_index db index |> Index.rslice_seq |> Index.to_seq - | _ -> + match merged_index db, pending_overlay db with + | false, false -> + stored_index db index |> Index.rslice_seq |> Index.to_seq + | false, true -> + let stored = stored_index db index |> Index.rslice_seq |> Index.to_seq in + let pending = pending_for_index db index |> List.rev |> List.to_seq in + merge_sorted_datom_seqs (fun left right -> Util.compare_datom index right left) stored pending + | true, _ -> let indexed = stored_index db index |> Index.rslice_seq |> Index.to_seq in let duplicates = duplicate_index_datoms db index |> List.rev |> List.to_seq in merge_sorted_datom_seqs @@ -733,9 +792,13 @@ let avet_datoms_by_value context db attr value = match Hashtbl.find_opt db.avet_by_attr attr with | Some datoms -> array_attr_value_slice context Avet bound bound_fields datoms | None -> - let cmp = exact_prefix_slice_cmp context Avet bound bound_fields in - Index.slice_seq ~from_:bound ~to_:bound ~cmp (stored_index db Avet) - |> Index.seq_to_list) + if merged_index db || pending_overlay db then + primary_attr_datoms db Avet attr + |> List.filter (fun datom -> datom.a = attr && context.compare_value datom.v value = 0) + else + let cmp = exact_prefix_slice_cmp context Avet bound bound_fields in + Index.slice_seq ~from_:bound ~to_:bound ~cmp (stored_index db Avet) + |> Index.seq_to_list) let avet_datoms_by_value_seq context db attr value = let bound = bound_datom ~a:attr ~v:value () in @@ -743,35 +806,48 @@ let avet_datoms_by_value_seq context db attr value = match Hashtbl.find_opt db.avet_by_attr attr with | Some datoms -> array_attr_value_seq context Avet bound bound_fields datoms | None -> - let cmp = exact_prefix_slice_cmp context Avet bound bound_fields in - Index.slice_seq ~from_:bound ~to_:bound ~cmp (stored_index db Avet) |> Index.to_seq + if merged_index db then + primary_attr_datoms db Avet attr + |> List.filter (fun datom -> datom.a = attr && context.compare_value datom.v value = 0) + |> List.to_seq + else + let cmp = exact_prefix_slice_cmp context Avet bound bound_fields in + Index.slice_seq ~from_:bound ~to_:bound ~cmp (stored_index db Avet) |> Index.to_seq let exact_prefix_datoms context db index e a v tx = match exact_prefix_bound index e a v tx with | None -> None | Some (bound, bound_fields) -> (match index, e, a, v, tx with - | (Aevt | Avet), None, Some attr, None, None when db.duplicate_datoms <> [] -> + | (Aevt | Avet), None, Some attr, None, None when merged_index db || pending_overlay db -> let indexed = primary_attr_datoms db index attr in let duplicates = duplicate_attr_datoms db index attr in Some (merge_sorted_datom_seqs (Util.compare_datom index) (List.to_seq indexed) (List.to_seq duplicates)) | _ -> let cmp = exact_prefix_slice_cmp context index bound bound_fields in - (match index, a, db.duplicate_datoms with - | (Aevt | Avet), Some attr, _ :: _ -> + (match index, a, merged_index db || pending_overlay db with + | (Aevt | Avet), Some attr, true -> let indexed = primary_attr_datoms db index attr |> exact_sorted_slice cmp bound in let duplicates = duplicate_prefix_datoms db index e a |> exact_sorted_slice cmp bound in Some (merge_sorted_datom_seqs (Util.compare_datom index) (List.to_seq indexed) (List.to_seq duplicates)) | _ -> - (match db.duplicate_datoms, index, e, a, v, tx with - | [], Avet, None, Some _, Some _, None -> + (match merged_index db || pending_overlay db, index, e, a, v, tx with + | false, Avet, None, Some _, Some _, None -> Some (avet_datoms_by_value_seq context db (Option.get a) (Option.get v)) - | [], _, _, _, _, _ -> + | false, _, _, _, _, _ -> Some (Index.slice_seq ~from_:bound ~to_:bound ~cmp (stored_index db index) |> Index.to_seq) - | _ -> - let indexed = Index.slice_seq ~from_:bound ~to_:bound ~cmp (stored_index db index) |> Index.to_seq in - let duplicates = duplicate_prefix_datoms db index e a |> exact_sorted_slice cmp bound in - Some (merge_sorted_datom_seqs (Util.compare_datom index) indexed (List.to_seq duplicates))))) + | true, _, _, _, _, _ -> + if merged_index db then + let datoms = + raw_index_datoms_list db index |> exact_sorted_slice cmp bound + in + Some (List.to_seq datoms) + else + let indexed = Index.slice_seq ~from_:bound ~to_:bound ~cmp (stored_index db index) |> Index.to_seq in + let pending = + pending_for_index db index |> exact_sorted_slice cmp bound |> List.to_seq + in + Some (merge_sorted_datom_seqs (Util.compare_datom index) indexed pending)))) let exact_prefix_datoms_list context db index e a v tx = match exact_prefix_bound index e a v tx with @@ -783,8 +859,8 @@ let exact_prefix_datoms_list context db index e a v tx = | Aevt, None, Some _, None, None -> true | _ -> false in - (match db.duplicate_datoms with - | [] -> + (match merged_index db || pending_overlay db with + | false -> Some (match index, a, v, exact_attr_prefix with | Avet, Some attr, Some value, false -> avet_datoms_by_value context db attr value @@ -792,7 +868,7 @@ let exact_prefix_datoms_list context db index e a v tx = | _ -> Index.slice_seq ~from_:bound ~to_:bound ~cmp (stored_index db index) |> Index.seq_to_list) - | _ -> + | true -> exact_prefix_datoms context db index e a v tx |> Option.map List.of_seq) @@ -803,15 +879,23 @@ let lower_prefix_datoms context db index e a v tx = let cmp = slice_cmp context index bound bound_fields bound bound_fields in let indexed = match index, e, a, v, tx with - | (Aevt | Avet), None, Some attr, None, None when db.duplicate_datoms <> [] -> + | (Aevt | Avet), None, Some attr, None, None when merged_index db || pending_overlay db -> primary_attr_datoms db index attr |> List.filter (fun datom -> cmp datom bound >= 0) |> List.to_seq + | _ when pending_overlay db && not (merged_index db) -> + let stored = Index.slice_seq ~from_:bound ~cmp (stored_index db index) |> Index.to_seq in + let pending = + pending_for_index db index + |> List.filter (fun datom -> cmp datom bound >= 0) + |> List.to_seq + in + merge_sorted_datom_seqs (Util.compare_datom index) stored pending | _ -> Index.slice_seq ~from_:bound ~cmp (stored_index db index) |> Index.to_seq in - (match db.duplicate_datoms with - | [] -> Some indexed - | _ -> + (match merged_index db || pending_overlay db with + | false -> Some indexed + | true -> let duplicates = duplicate_prefix_datoms db index e a |> List.filter (fun datom -> cmp datom bound >= 0) in Some (merge_sorted_datom_seqs (Util.compare_datom index) indexed (List.to_seq duplicates))) @@ -822,16 +906,25 @@ let reverse_upper_prefix_datoms context db index e a v tx = let cmp = slice_cmp context index bound bound_fields bound bound_fields in let indexed = match index, e, a, v, tx with - | (Aevt | Avet), None, Some attr, None, None when db.duplicate_datoms <> [] -> + | (Aevt | Avet), None, Some attr, None, None when merged_index db || pending_overlay db -> primary_attr_datoms db index attr |> List.filter (fun datom -> cmp datom bound <= 0) |> List.rev |> List.to_seq + | _ when pending_overlay db && not (merged_index db) -> + let stored = Index.rslice_seq ~from_:bound ~cmp (stored_index db index) |> Index.to_seq in + let pending = + pending_for_index db index + |> List.filter (fun datom -> cmp datom bound <= 0) + |> List.rev + |> List.to_seq + in + merge_sorted_datom_seqs (fun left right -> Util.compare_datom index right left) stored pending | _ -> Index.rslice_seq ~from_:bound ~cmp (stored_index db index) |> Index.to_seq in - (match db.duplicate_datoms with - | [] -> Some indexed - | _ -> + (match merged_index db || pending_overlay db with + | false -> Some indexed + | true -> let duplicates = duplicate_prefix_datoms db index e a |> List.filter (fun datom -> cmp datom bound <= 0) |> List.rev in Some (merge_sorted_datom_seqs @@ -871,18 +964,22 @@ let avet_range_datoms context db attr start stop = | Some stop -> datom.a = attr && context.compare_value datom.v stop <= 0 in let indexed = - match db.duplicate_datoms with - | [] -> + if not (merged_index db) then let cmp = slice_cmp context Avet from_bound from_fields to_bound to_fields in Index.slice_seq ~from_:from_bound ~to_:to_bound ~cmp db.avet_index |> Index.to_seq - | _ -> + else primary_attr_datoms db Avet attr |> List.filter (fun datom -> lower_matches datom && upper_matches datom) |> List.to_seq in - match db.duplicate_datoms with - | [] -> indexed - | _ -> + if not (merged_index db) && not (pending_overlay db) then indexed + else if not (merged_index db) then + let duplicates = + pending_for_index db Avet + |> List.filter (fun datom -> lower_matches datom && upper_matches datom) + in + merge_sorted_datom_seqs (Util.compare_datom Avet) indexed (List.to_seq duplicates) + else let duplicates = duplicate_attr_datoms db Avet attr |> List.filter (fun datom -> lower_matches datom && upper_matches datom) @@ -960,8 +1057,8 @@ let fold_datoms f init context db index ?e ?a ?v ?tx () = | Some pred when not (pred datom) -> acc | _ -> fold_filter acc datom in - match db.duplicate_datoms, exact_prefix_bound index e a prefix_v prefix_tx with - | [], Some (bound, bound_fields) -> + match merged_index db || pending_overlay db, exact_prefix_bound index e a prefix_v prefix_tx with + | false, Some (bound, bound_fields) -> let cmp = exact_prefix_slice_cmp context index bound bound_fields in let fold = match exact_attr_prefix || (e, a, v, tx) = (None, None, None, None), db.filter_pred with @@ -976,7 +1073,7 @@ let fold_datoms f init context db index ?e ?a ?v ?tx () = | _ -> let seq = Index.slice_seq ~from_:bound ~to_:bound ~cmp (stored_index db index) in Index.fold_seq fold init seq) - | [], None when (e, a, v, tx) = (None, None, None, None) -> + | false, None when (e, a, v, tx) = (None, None, None, None) -> (match db.filter_pred with | None -> Index.fold f init (stored_index db index) | Some pred -> diff --git a/impl/db.mli b/impl/db.mli index e0b3ce7..b3922a4 100644 --- a/impl/db.mli +++ b/impl/db.mli @@ -18,6 +18,7 @@ val normalize_datom_for_schema : schema -> datom -> datom val refresh_indexes : db -> db val refresh_indexes_with_added_datoms : db -> datom list -> db val refresh_indexes_with_tx_data : db -> datom list -> db +val flush_pending_datoms : db -> db val snapshot_db : db -> db val basis_tx : db -> tx val as_of_t : db -> tx option diff --git a/impl/platform/jsoo/storage.ml b/impl/platform/jsoo/storage.ml index ffb9b84..324bf5f 100644 --- a/impl/platform/jsoo/storage.ml +++ b/impl/platform/jsoo/storage.ml @@ -82,6 +82,7 @@ let restore context storage = ; since_tx = None ; history = false ; filter_pred = None + ; pending_datoms = [] ; storage_ref = Some storage ; tx_fns = [] } diff --git a/impl/platform/melange/storage.ml b/impl/platform/melange/storage.ml index ffb9b84..324bf5f 100644 --- a/impl/platform/melange/storage.ml +++ b/impl/platform/melange/storage.ml @@ -82,6 +82,7 @@ let restore context storage = ; since_tx = None ; history = false ; filter_pred = None + ; pending_datoms = [] ; storage_ref = Some storage ; tx_fns = [] } diff --git a/impl/platform/native/storage.ml b/impl/platform/native/storage.ml index ffb9b84..324bf5f 100644 --- a/impl/platform/native/storage.ml +++ b/impl/platform/native/storage.ml @@ -82,6 +82,7 @@ let restore context storage = ; since_tx = None ; history = false ; filter_pred = None + ; pending_datoms = [] ; storage_ref = Some storage ; tx_fns = [] } diff --git a/impl/serialize.ml b/impl/serialize.ml index 38edf45..b034022 100644 --- a/impl/serialize.ml +++ b/impl/serialize.ml @@ -13,7 +13,8 @@ type context = let serializable db = { serializable_schema = db.schema ; serializable_datoms = - Index.to_list db.eavt_index @ db.duplicate_datoms |> List.sort (Datascript_types.Compare.compare_datom Eavt) + Index.to_list db.eavt_index @ db.duplicate_datoms @ db.pending_datoms + |> List.sort (Datascript_types.Compare.compare_datom Eavt) ; serializable_max_eid = db.max_eid ; serializable_max_tx = db.max_tx } @@ -44,6 +45,7 @@ let from_serializable context snapshot = ; since_tx = None ; history = false ; filter_pred = None + ; pending_datoms = [] ; storage_ref ; tx_fns = [] } diff --git a/impl/storage_lmdb_impl.ml b/impl/storage_lmdb_impl.ml index 033a66f..0cabc84 100644 --- a/impl/storage_lmdb_impl.ml +++ b/impl/storage_lmdb_impl.ml @@ -101,6 +101,7 @@ let restore context storage = ; since_tx = None ; history = false ; filter_pred = None + ; pending_datoms = [] ; storage_ref = Some storage ; tx_fns = [] } diff --git a/impl/storage_pss.ml b/impl/storage_pss.ml index 28586ca..a221aa5 100644 --- a/impl/storage_pss.ml +++ b/impl/storage_pss.ml @@ -268,6 +268,7 @@ let restore context storage = ; since_tx = None ; history = false ; filter_pred = None + ; pending_datoms = [] ; storage_ref = Some storage ; tx_fns = [] } diff --git a/type/datascript_types.ml b/type/datascript_types.ml index 7bc4a9f..df89771 100644 --- a/type/datascript_types.ml +++ b/type/datascript_types.ml @@ -136,6 +136,7 @@ and db = ; since_tx : tx option ; history : bool ; filter_pred : (datom -> bool) option + ; pending_datoms : datom list ; storage_ref : storage option ; tx_fns : (entity_id * (db -> value list -> tx_op list)) list } From 3487d7a171a07441eb6722063658d4c089b22fff Mon Sep 17 00:00:00 2001 From: Cursor Agent Date: Thu, 27 Aug 2026 08:58:47 +0000 Subject: [PATCH 4/9] Store: append-only delta index sync instead of full rewrite Add sync_append_since_tx to copy only datoms with tx > stored meta max_tx when session and storage LMDB envs differ. Skip index copy when envs are shared (storage-attached dbs). Add test_storage multi-tx incremental store with as_of/history after restore. Co-authored-by: Tienson Qin --- impl/index.mli | 2 +- impl/platform/jsoo/index.ml | 8 +++--- impl/platform/jsoo/storage.ml | 8 +++++- impl/platform/melange/index.ml | 8 +++--- impl/platform/melange/storage.ml | 8 +++++- impl/platform/native/index.ml | 8 +++--- impl/platform/native/storage.ml | 8 +++++- lmdb/native/datascript_lmdb_index.ml | 9 +++++++ lmdb/native/datascript_lmdb_index.mli | 1 + test/test_storage.ml | 37 ++++++++++++++++++++++++++- 10 files changed, 80 insertions(+), 17 deletions(-) diff --git a/impl/index.mli b/impl/index.mli index 390355a..b29b1fe 100644 --- a/impl/index.mli +++ b/impl/index.mli @@ -8,7 +8,7 @@ val create_lmdb : storage option -> lmdb * storage option val lmdb_of : lmdb -> lmdb val db_of : t -> lmdb val lmdb_for_storage : storage -> lmdb -val sync_indexes_to_storage : t -> t -> t -> storage -> unit +val sync_indexes_to_storage : since_tx:tx -> t -> t -> t -> storage -> unit val load_indexes_from_storage : storage -> lmdb -> unit val empty : index -> lmdb -> t diff --git a/impl/platform/jsoo/index.ml b/impl/platform/jsoo/index.ml index 602eaac..7c7426e 100644 --- a/impl/platform/jsoo/index.ml +++ b/impl/platform/jsoo/index.ml @@ -19,11 +19,11 @@ let db_of t = Datascript_lmdb_index.db_of (project t) let lmdb_for_storage storage = Datascript_storage_lmdb.lmdb storage -let sync_indexes_to_storage eavt aevt avet target_storage = +let sync_indexes_to_storage ~since_tx eavt aevt avet target_storage = let target = Datascript_storage_lmdb.lmdb target_storage in - Datascript_lmdb_index.sync_merged_to_lmdb (project eavt) target; - Datascript_lmdb_index.sync_merged_to_lmdb (project aevt) target; - Datascript_lmdb_index.sync_merged_to_lmdb (project avet) target + Datascript_lmdb_index.sync_append_since_tx ~since_tx (project eavt) target; + Datascript_lmdb_index.sync_append_since_tx ~since_tx (project aevt) target; + Datascript_lmdb_index.sync_append_since_tx ~since_tx (project avet) target let load_indexes_from_storage storage target_lmdb = let source = Datascript_storage_lmdb.lmdb storage in diff --git a/impl/platform/jsoo/storage.ml b/impl/platform/jsoo/storage.ml index 324bf5f..fb36caa 100644 --- a/impl/platform/jsoo/storage.ml +++ b/impl/platform/jsoo/storage.ml @@ -9,7 +9,13 @@ let memory_storage = Datascript_storage_lmdb.memory_storage let store ?storage db = match storage, db.storage_ref with | Some target_storage, _ | None, Some target_storage -> - Index.sync_indexes_to_storage db.eavt_index db.aevt_index db.avet_index target_storage; + let target_lmdb = Index.lmdb_for_storage target_storage in + if Index.db_of db.eavt_index != target_lmdb then ( + let _, _, stored_max_tx, _ = + Datascript_storage_lmdb.restore_meta (Datascript_storage_lmdb.lmdb target_storage) + in + Index.sync_indexes_to_storage ~since_tx:stored_max_tx db.eavt_index db.aevt_index db.avet_index + target_storage); Datascript_storage_lmdb.store_db target_storage db | None, None -> invalid_arg "db has no attached storage" diff --git a/impl/platform/melange/index.ml b/impl/platform/melange/index.ml index 602eaac..7c7426e 100644 --- a/impl/platform/melange/index.ml +++ b/impl/platform/melange/index.ml @@ -19,11 +19,11 @@ let db_of t = Datascript_lmdb_index.db_of (project t) let lmdb_for_storage storage = Datascript_storage_lmdb.lmdb storage -let sync_indexes_to_storage eavt aevt avet target_storage = +let sync_indexes_to_storage ~since_tx eavt aevt avet target_storage = let target = Datascript_storage_lmdb.lmdb target_storage in - Datascript_lmdb_index.sync_merged_to_lmdb (project eavt) target; - Datascript_lmdb_index.sync_merged_to_lmdb (project aevt) target; - Datascript_lmdb_index.sync_merged_to_lmdb (project avet) target + Datascript_lmdb_index.sync_append_since_tx ~since_tx (project eavt) target; + Datascript_lmdb_index.sync_append_since_tx ~since_tx (project aevt) target; + Datascript_lmdb_index.sync_append_since_tx ~since_tx (project avet) target let load_indexes_from_storage storage target_lmdb = let source = Datascript_storage_lmdb.lmdb storage in diff --git a/impl/platform/melange/storage.ml b/impl/platform/melange/storage.ml index 324bf5f..fb36caa 100644 --- a/impl/platform/melange/storage.ml +++ b/impl/platform/melange/storage.ml @@ -9,7 +9,13 @@ let memory_storage = Datascript_storage_lmdb.memory_storage let store ?storage db = match storage, db.storage_ref with | Some target_storage, _ | None, Some target_storage -> - Index.sync_indexes_to_storage db.eavt_index db.aevt_index db.avet_index target_storage; + let target_lmdb = Index.lmdb_for_storage target_storage in + if Index.db_of db.eavt_index != target_lmdb then ( + let _, _, stored_max_tx, _ = + Datascript_storage_lmdb.restore_meta (Datascript_storage_lmdb.lmdb target_storage) + in + Index.sync_indexes_to_storage ~since_tx:stored_max_tx db.eavt_index db.aevt_index db.avet_index + target_storage); Datascript_storage_lmdb.store_db target_storage db | None, None -> invalid_arg "db has no attached storage" diff --git a/impl/platform/native/index.ml b/impl/platform/native/index.ml index 5923ebe..c8b1632 100644 --- a/impl/platform/native/index.ml +++ b/impl/platform/native/index.ml @@ -19,11 +19,11 @@ let db_of t = Datascript_lmdb_index.db_of (project t) let lmdb_for_storage storage = Datascript_storage_lmdb.lmdb storage -let sync_indexes_to_storage eavt aevt avet target_storage = +let sync_indexes_to_storage ~since_tx eavt aevt avet target_storage = let target = Datascript_storage_lmdb.lmdb target_storage in - Datascript_lmdb_index.sync_merged_to_lmdb (project eavt) target; - Datascript_lmdb_index.sync_merged_to_lmdb (project aevt) target; - Datascript_lmdb_index.sync_merged_to_lmdb (project avet) target + Datascript_lmdb_index.sync_append_since_tx ~since_tx (project eavt) target; + Datascript_lmdb_index.sync_append_since_tx ~since_tx (project aevt) target; + Datascript_lmdb_index.sync_append_since_tx ~since_tx (project avet) target let load_indexes_from_storage storage target_lmdb = let source = Datascript_storage_lmdb.lmdb storage in diff --git a/impl/platform/native/storage.ml b/impl/platform/native/storage.ml index 324bf5f..fb36caa 100644 --- a/impl/platform/native/storage.ml +++ b/impl/platform/native/storage.ml @@ -9,7 +9,13 @@ let memory_storage = Datascript_storage_lmdb.memory_storage let store ?storage db = match storage, db.storage_ref with | Some target_storage, _ | None, Some target_storage -> - Index.sync_indexes_to_storage db.eavt_index db.aevt_index db.avet_index target_storage; + let target_lmdb = Index.lmdb_for_storage target_storage in + if Index.db_of db.eavt_index != target_lmdb then ( + let _, _, stored_max_tx, _ = + Datascript_storage_lmdb.restore_meta (Datascript_storage_lmdb.lmdb target_storage) + in + Index.sync_indexes_to_storage ~since_tx:stored_max_tx db.eavt_index db.aevt_index db.avet_index + target_storage); Datascript_storage_lmdb.store_db target_storage db | None, None -> invalid_arg "db has no attached storage" diff --git a/lmdb/native/datascript_lmdb_index.ml b/lmdb/native/datascript_lmdb_index.ml index 0a7ab40..6587093 100644 --- a/lmdb/native/datascript_lmdb_index.ml +++ b/lmdb/native/datascript_lmdb_index.ml @@ -139,6 +139,15 @@ let sync_merged_to_lmdb t target_lmdb = clear_index_txn txn t.which target_lmdb; Datascript_lmdb_db.copy_index_txn t.which txn t.db target_lmdb) +let sync_append_since_tx ~since_tx t target_lmdb = + if t.db == target_lmdb then () + else + let target = make t.which target_lmdb in + Datascript_lmdb_db.with_write_txn target_lmdb (fun txn -> + fold_stored t (fun () datom -> + if datom.tx > since_tx then put_datom_txn txn target datom) + ()) + let copy t = t let flush t = t diff --git a/lmdb/native/datascript_lmdb_index.mli b/lmdb/native/datascript_lmdb_index.mli index 992ad74..5b9f0b8 100644 --- a/lmdb/native/datascript_lmdb_index.mli +++ b/lmdb/native/datascript_lmdb_index.mli @@ -16,6 +16,7 @@ val remove : datom -> t -> t val flush : t -> t val copy : t -> t val sync_merged_to_lmdb : t -> Datascript_lmdb_db.t -> unit +val sync_append_since_tx : since_tx:tx -> t -> Datascript_lmdb_db.t -> unit val lookup : t -> datom -> datom option val to_list : t -> datom list val fold : ('acc -> datom -> 'acc) -> 'acc -> t -> 'acc diff --git a/test/test_storage.ml b/test/test_storage.ml index 39e363c..c37dbbc 100644 --- a/test/test_storage.ml +++ b/test/test_storage.ml @@ -92,7 +92,42 @@ let test_storage__test_conn () = [ 1, "name", String "Ivan"; 2, "name", String "Oleg" ] (datoms restored_db Eavt ())) +let test_storage__test_multi_tx_incremental_store () = + let storage = memory_storage () in + let db = + empty_db ~schema:[ "name", indexed; "age", indexed ] () + |> db_with [ Add (Entity_id 1, "name", String "Alice"); Add (Entity_id 1, "age", Int 30) ] + in + let tx1 = basis_tx db in + store ~storage db; + let db = db_with [ Add (Entity_id 1, "age", Int 31) ] db in + store ~storage db; + let restored = + match restore storage with + | Some db -> db + | None -> failwith "restore should read incrementally stored db" + in + let current_ages = + datoms restored Eavt ~a:"age" () + |> List.map (fun d -> match d.v with Int n -> n | _ -> -1) + in + if current_ages <> [ 31 ] then failf "restored db should see current age 31, got %S" (string_of_int (List.hd current_ages)); + let past = as_of tx1 restored in + let past_ages = + datoms past Eavt ~a:"age" () + |> List.map (fun d -> match d.v with Int n -> n | _ -> -1) + in + if past_ages <> [ 30 ] then failf "restored as_of should see historical age 30"; + let hist_ages = + datoms (history restored) Eavt ~a:"age" () + |> List.filter (fun d -> d.added) + |> List.map (fun d -> match d.v with Int n -> n | _ -> -1) + |> List.sort compare + in + if hist_ages <> [ 30; 31 ] then failf "restored history should expose both age assertions" + let () = test_storage__test_basics (); test_storage__test_restored_db_addresses (); - test_storage__test_conn () + test_storage__test_conn (); + test_storage__test_multi_tx_incremental_store () From 04d0a3f808392f85c0c102fa7b386d10b8c362e5 Mon Sep 17 00:00:00 2001 From: Cursor Agent Date: Thu, 27 Aug 2026 09:28:23 +0000 Subject: [PATCH 5/9] Add Datahike-style purge (excise) API for permanent datom removal Implement :db/purge, :db.purge/attribute, and :db.purge/entity transaction operations that physically remove datoms from current and history views, matching Datahike purge semantics. Purge searches the history stream, deletes keys from append-only LMDB indexes, and syncs removals to persistent storage. Also includes tx-filter history fixes (codec added flag, transact read ceiling, public temporal API) and test_purge regression coverage. Co-authored-by: Tienson Qin --- .gitignore | 1 + docs/design-tx-filter-history.md | 22 ++- impl/conn.ml | 2 +- impl/data_readers.ml | 6 + impl/datascript.ml | 100 ++++++++++- impl/datascript.mli | 6 + impl/db.ml | 40 +++++ impl/db.mli | 4 + impl/index.mli | 1 + impl/platform/jsoo/index.ml | 12 ++ impl/platform/melange/index.ml | 12 ++ impl/platform/native/index.ml | 12 ++ impl/transact.ml | 98 ++++++++--- impl/transact.mli | 7 +- js/datascript_js.ml | 1 + lmdb/datascript_lmdb_codec.ml | 36 +++- lmdb/melange/datascript_lmdb_codec.ml | 36 +++- lmdb/melange/datascript_lmdb_index.ml | 234 +++++++++++-------------- lmdb/melange/datascript_lmdb_index.mli | 4 + lmdb/native/datascript_lmdb_index.ml | 16 +- lmdb/native/datascript_lmdb_index.mli | 1 + test/dune | 21 +++ test/test_purge.ml | 109 ++++++++++++ type/datascript_types.ml | 43 +++-- 24 files changed, 623 insertions(+), 201 deletions(-) create mode 100644 test/test_purge.ml diff --git a/.gitignore b/.gitignore index baab991..ee5c5fa 100644 --- a/.gitignore +++ b/.gitignore @@ -9,3 +9,4 @@ tmp/ /db.sqlite-shm /db.sqlite-wal /_deps/ +/vendor/ diff --git a/docs/design-tx-filter-history.md b/docs/design-tx-filter-history.md index 66be49c..f2a2308 100644 --- a/docs/design-tx-filter-history.md +++ b/docs/design-tx-filter-history.md @@ -55,6 +55,20 @@ Public API (matches dbval.core): Transact rejects temporal views with dbval-compatible error message. +## Purge (Datahike-compatible excise) + +Physical removal of datoms from current **and** history (GDPR-style), unlike retract: + +| Op | EDN | Effect | +| --- | --- | --- | +| `Purge` | `[:db/purge e a v]` | Remove one fact from all indices | +| `PurgeAttr` | `[:db.purge/attribute e a]` | Remove all values of attr on entity | +| `PurgeEntity` | `[:db.purge/entity e]` | Remove entity + incoming refs + components | + +Implementation searches the history view (`history = true`, no `datoms-filter`), then +`Index.remove` deletes keys from EAVT/AEVT/AVET. Persistent storage sync uses +`sync_removals_to_storage` on `transact`. Purge does not append to `tx_data`. + ## Read pipeline For ascending index scans: @@ -68,6 +82,8 @@ For ascending index scans: `datoms_filter` follows dbval semantics: consecutive datoms with same `[e,a,v]` cancel when a retract follows an add; same-tx add/retract pairs cancel; orphaned retracts are dropped. +LMDB keys include `[tx, added]` after index components so add/retract pairs for the same fact +sort adjacently (assert before retract at the same tx). ## Write pipeline @@ -86,9 +102,9 @@ Single-tx bulk append (`of_bulk` → direct LMDB write batch). No overlay stagin ## Storage -- **store**: append new datoms for the tx + update meta (`max_tx`, `max_eid`, schema) -- **restore**: open LMDB env, read meta, rebuild attr caches from filtered scan at `max_tx` -- Remove `sync_merged_to_lmdb` clear-and-rewrite path + - **store**: append new datoms for the tx + update meta (`max_tx`, `max_eid`, schema) + - **restore**: open LMDB env, read meta, rebuild attr caches from filtered scan at `max_tx` + - Remove `sync_merged_to_lmdb` clear-and-rewrite path; use `sync_append_since_tx` for delta copy when session and storage envs differ PSS tail replay (`impl/storage_pss.ml`) is the closest in-repo precedent for append-only persistence. diff --git a/impl/conn.ml b/impl/conn.ml index 66a36aa..0c99006 100644 --- a/impl/conn.ml +++ b/impl/conn.ml @@ -142,7 +142,7 @@ let reset (context : reset_context) ?(tx_meta = []) conn db = List.map (fun datom -> { datom with added = false }) (context.datoms conn.db) @ context.datoms db in - let report = { db_before; db_after = db; tx_data; tempids = []; tx_meta } in + let report = { db_before; db_after = db; tx_data; tempids = []; tx_meta; purged_datoms = [] } in conn.db <- db; (match conn.storage with | None -> () diff --git a/impl/data_readers.ml b/impl/data_readers.ml index afb1aea..4e1b95f 100644 --- a/impl/data_readers.ml +++ b/impl/data_readers.ml @@ -182,6 +182,8 @@ let tx_op_of_edn_form context = function Retract (tx_entity_ref_of_edn_form context entity_ref, tx_attr_of_edn_key attr, Some (tx_scalar_value_of_edn_form context value)) | "db/cas" | "db.fn/cas" -> invalid_arg "db/cas requires entity, attr, expected value, and new value" + | "db/purge" | "db.purge/datom" -> + Purge (tx_entity_ref_of_edn_form context entity_ref, tx_attr_of_edn_key attr, tx_scalar_value_of_edn_form context value) | _ -> invalid_arg "Unknown operation") | op :: entity_ref :: attr :: expected :: value_or_tx :: [] -> (match tx_op_name_of_edn_form op with @@ -202,11 +204,15 @@ let tx_op_of_edn_form context = function | "retract" | "db/retract" -> Retract (tx_entity_ref_of_edn_form context entity_ref, tx_attr_of_edn_key attr, None) | "db/retractAttribute" | "db.fn/retractAttribute" -> RetractAttr (tx_entity_ref_of_edn_form context entity_ref, tx_attr_of_edn_key attr) + | "db.purge/attribute" | "db/purgeAttribute" -> + PurgeAttr (tx_entity_ref_of_edn_form context entity_ref, tx_attr_of_edn_key attr) | _ -> invalid_arg "Unknown operation") | [ op; entity_ref ] -> (match tx_op_name_of_edn_form op with | "db/retractEntity" | "db.fn/retractEntity" -> RetractEntity (tx_entity_ref_of_edn_form context entity_ref) + | "db.purge/entity" | "db/purgeEntity" -> + PurgeEntity (tx_entity_ref_of_edn_form context entity_ref) | _ -> invalid_arg "Unknown operation") | [] -> invalid_arg "empty EDN transaction vector" | _ :: _ -> invalid_arg "Unknown operation") diff --git a/impl/datascript.ml b/impl/datascript.ml index b496148..11d7452 100644 --- a/impl/datascript.ml +++ b/impl/datascript.ml @@ -53,6 +53,7 @@ let normalize_datom_for_schema = Db_impl.normalize_datom_for_schema let refresh_db_indexes = Db_impl.refresh_indexes let refresh_db_indexes_with_added_datoms = Db_impl.refresh_indexes_with_added_datoms let refresh_db_indexes_with_tx_data = Db_impl.refresh_indexes_with_tx_data +let refresh_db_indexes_with_removed_datoms = Db_impl.refresh_indexes_with_removed_datoms let snapshot_db = Db_impl.snapshot_db let empty_db ?(schema = []) ?storage () = @@ -83,6 +84,9 @@ let temporal_view = Db_impl.temporal_view let as_of = Db_impl.as_of let since = Db_impl.since let history = Db_impl.history +let is_history = Db_impl.is_history +let as_of_tx = Db_impl.as_of_tx +let since_tx = Db_impl.since_tx module Tx_visibility = Tx_visibility @@ -621,6 +625,82 @@ and refresh_tuple_attrs_for_source_db schema_db tx db e source_attr tx_data = db, tx_data @ tuple_tx_data) (db, tx_data) +let history_db db = { db with history = true } + +let historical_datoms db ?e ?a ?v () = + Db_access_impl.datoms (history_db db) Eavt ?e ?a ?v () |> List.of_seq + +let historical_fact_datoms db e a value = + historical_datoms db ~e ~a () + |> List.filter (fun datom -> value_equal datom.v value) + +let purge_not_found_message entity_ref = + "Can't find entity with ID " + ^ (match entity_ref with + | Entity_id e -> string_of_int e + | Temp_id tempid -> tempid + | Ident ident -> ":" ^ ident + | Lookup_ref (attr, String s) -> "[:" ^ attr ^ " \"" ^ s ^ "\"]" + | Lookup_ref (attr, value) -> "[:" ^ attr ^ " " ^ edn_string_of_value value ^ "]" + | CurrentTx -> "db/current-tx") + ^ " to be purged" + +let resolve_entity_for_purge db entity_ref = + match Db_access_impl.entid_ref db entity_ref with + | Some entity_id -> entity_id + | None -> invalid_arg (purge_not_found_message entity_ref) + +let unique_historical_datoms datoms = + datoms |> List.sort_uniq (Util.compare_datom Eavt) + +let purge_datoms_with_report_db _tx db removed_datoms = + let removed_datoms = unique_historical_datoms removed_datoms in + refresh_db_indexes_with_removed_datoms db removed_datoms, removed_datoms + +let purge_datom_with_report_db tx db e a value = + let removed = historical_fact_datoms db e a value in + if removed = [] then invalid_arg (purge_not_found_message (Entity_id e)); + purge_datoms_with_report_db tx db removed + +let purge_attr_with_report_db tx db e a = + let removed = historical_datoms db ~e ~a () in + if removed = [] then invalid_arg (purge_not_found_message (Entity_id e)); + let component_ids = + removed + |> List.filter (fun datom -> is_component db datom.a) + |> List.filter_map (fun datom -> ref_value_id datom.v) + in + let component_datoms = + component_ids + |> List.concat_map (fun component_e -> historical_datoms db ~e:component_e ()) + in + purge_datoms_with_report_db tx db (removed @ component_datoms) + +let purge_entity_with_report_db schema_db tx db e = + let initial_entity_datoms = historical_datoms db ~e () in + if initial_entity_datoms = [] then invalid_arg (purge_not_found_message (Entity_id e)); + let ids = component_entity_closure_db schema_db db [] e in + let all_entity_datoms = + ids + |> List.concat_map (fun entity_id -> historical_datoms db ~e:entity_id ()) + in + let ref_datoms = + ids + |> List.concat_map (fun entity_id -> + incoming_ref_datoms db [ entity_id ] + |> List.filter (fun datom -> datom.e <> entity_id)) + in + let component_entity_ids = + all_entity_datoms + |> List.filter (fun datom -> is_component schema_db datom.a) + |> List.filter_map (fun datom -> ref_value_id datom.v) + in + let component_datoms = + component_entity_ids + |> List.concat_map (fun component_e -> historical_datoms db ~e:component_e ()) + in + purge_datoms_with_report_db tx db (all_entity_datoms @ ref_datoms @ component_datoms) + let add_user_datom_with_report_db schema_db tx db d = let db, tx_data = add_active_datom_with_report_db schema_db tx db d in refresh_tuple_attrs_for_source_db schema_db tx db d.e d.a tx_data @@ -727,6 +807,10 @@ let transact_apply_context : Transact_impl.apply_context = ; retract_user_attr_with_report = retract_user_attr_with_report_db ; retract_active_datom_with_report = retract_active_datom_with_report_db ; retract_entity_with_report = retract_entity_with_report_db + ; purge_datom_with_report = purge_datom_with_report_db + ; purge_attr_with_report = purge_attr_with_report_db + ; purge_entity_with_report = purge_entity_with_report_db + ; resolve_entity_for_purge = resolve_entity_for_purge ; compare_and_set_matches = compare_and_set_matches_db ; compare_and_set_failure_message = compare_and_set_failure_message_db ; datom @@ -754,6 +838,7 @@ let transact_apply_context : Transact_impl.apply_context = ; refresh_tuple_attrs_for_source = refresh_tuple_attrs_for_source_db ; refresh_db_indexes_with_added_datoms ; refresh_db_indexes_with_tx_data + ; refresh_db_indexes_with_removed_datoms ; refresh_db_identity } @@ -761,7 +846,7 @@ let apply_tx tx_ops db = Transact_impl.apply_tx transact_apply_context tx_ops db let db_with tx_ops db = - let db_after, _, _ = apply_tx tx_ops db in + let db_after, _, _, _ = apply_tx tx_ops db in db_after let storage_restore_context : Storage.restore_context = { next_db_uid } @@ -780,22 +865,25 @@ let tx_meta_skips_store tx_meta = | _ -> false) tx_meta -let persist_transact ~tx_meta db = +let persist_transact ~tx_meta db ?(purged_datoms = []) () = if not (tx_meta_skips_store tx_meta) then match db.storage_ref with | None -> () - | Some storage -> store ~storage db + | Some storage -> + if purged_datoms <> [] then + Index.sync_removals_to_storage purged_datoms db.eavt_index db.aevt_index db.avet_index storage; + store ~storage db let transact_report ?(tx_meta = []) db tx_ops = if Db_impl.temporal_view db then invalid_arg "Cannot transact against an as-of/since/history database value"; let db_before = snapshot_db db in - let db_after, tempids, tx_data = apply_tx tx_ops db in - { db_before; db_after; tx_data; tempids; tx_meta } + let db_after, tempids, tx_data, purged_datoms = apply_tx tx_ops db in + { db_before; db_after; tx_data; tempids; tx_meta; purged_datoms } let transact ?(tx_meta = []) db tx_ops = let report = transact_report ~tx_meta db tx_ops in - persist_transact ~tx_meta report.db_after; + persist_transact ~tx_meta report.db_after ~purged_datoms:report.purged_datoms (); report let with_tx ?tx_meta db tx_ops = transact ?tx_meta db tx_ops diff --git a/impl/datascript.mli b/impl/datascript.mli index 3ec0683..f342f73 100644 --- a/impl/datascript.mli +++ b/impl/datascript.mli @@ -145,11 +145,14 @@ module Db : sig val index_range : db -> attr -> ?start:value -> ?stop:value -> unit -> datom Seq.t val basis_tx : db -> tx val as_of_t : db -> tx option + val as_of_tx : db -> tx option val since_t : db -> tx option + val since_tx : db -> tx option val temporal_view : db -> bool val as_of : tx -> db -> db val since : tx -> db -> db val history : db -> db + val is_history : db -> bool val hash : db -> int val hash_cache_size : unit -> int val diff : db -> db -> datom list * datom list * datom list @@ -389,11 +392,14 @@ val is_filtered : db -> bool val unfiltered_db : db -> db val basis_tx : db -> tx val as_of_t : db -> tx option +val as_of_tx : db -> tx option val since_t : db -> tx option +val since_tx : db -> tx option val temporal_view : db -> bool val as_of : tx -> db -> db val since : tx -> db -> db val history : db -> db +val is_history : db -> bool module Tx_visibility : module type of Tx_visibility val serializable : db -> serializable_db val from_serializable : serializable_db -> db diff --git a/impl/db.ml b/impl/db.ml index 16fe275..7e4ddaa 100644 --- a/impl/db.ml +++ b/impl/db.ml @@ -283,6 +283,40 @@ let refresh_indexes_with_tx_data db tx_data = { db with pending_datoms = db.pending_datoms @ tx_data; max_datom_e } |> invalidate_attr_tables +let same_stored_datom left right = + left.e = right.e + && left.a = right.a + && left.tx = right.tx + && left.added = right.added + && value_equal left.v right.v + +let without_stored_datoms removed datoms = + List.filter (fun datom -> not (List.exists (same_stored_datom datom) removed)) datoms + +let refresh_indexes_with_removed_datoms db removed_datoms = + if removed_datoms = [] then db + else + let remove_from index = + List.fold_left (fun index datom -> Index.remove datom index) index removed_datoms + in + let eavt_index = remove_from db.eavt_index in + let aevt_index = remove_from db.aevt_index in + let avet_index = remove_from db.avet_index in + let duplicate_datoms = without_stored_datoms removed_datoms db.duplicate_datoms in + let duplicate_aevt_datoms = without_stored_datoms removed_datoms db.duplicate_aevt_datoms in + let duplicate_avet_datoms = without_stored_datoms removed_datoms db.duplicate_avet_datoms in + let pending_datoms = without_stored_datoms removed_datoms db.pending_datoms in + { db with + eavt_index + ; aevt_index + ; avet_index + ; duplicate_datoms + ; duplicate_aevt_datoms + ; duplicate_avet_datoms + ; pending_datoms + } + |> invalidate_attr_tables + let snapshot_db db = db let temporal_view db = @@ -307,6 +341,12 @@ let since tx db = { db with since_tx = Some tx } let history db = { db with history = true } +let is_history db = db.history + +let as_of_tx = as_of_t + +let since_tx = since_t + let with_datoms db datoms = set_indexes_from_datoms db datoms diff --git a/impl/db.mli b/impl/db.mli index b3922a4..91ae60f 100644 --- a/impl/db.mli +++ b/impl/db.mli @@ -18,15 +18,19 @@ val normalize_datom_for_schema : schema -> datom -> datom val refresh_indexes : db -> db val refresh_indexes_with_added_datoms : db -> datom list -> db val refresh_indexes_with_tx_data : db -> datom list -> db +val refresh_indexes_with_removed_datoms : db -> datom list -> db val flush_pending_datoms : db -> db val snapshot_db : db -> db val basis_tx : db -> tx val as_of_t : db -> tx option +val as_of_tx : db -> tx option val since_t : db -> tx option +val since_tx : db -> tx option val temporal_view : db -> bool val as_of : tx -> db -> db val since : tx -> db -> db val history : db -> db +val is_history : db -> bool val with_datoms : db -> datom list -> db val empty_db : core_context -> ?schema:schema -> ?storage:storage -> unit -> db val empty : core_context -> db -> db diff --git a/impl/index.mli b/impl/index.mli index b29b1fe..7ce3e83 100644 --- a/impl/index.mli +++ b/impl/index.mli @@ -9,6 +9,7 @@ val lmdb_of : lmdb -> lmdb val db_of : t -> lmdb val lmdb_for_storage : storage -> lmdb val sync_indexes_to_storage : since_tx:tx -> t -> t -> t -> storage -> unit +val sync_removals_to_storage : datom list -> t -> t -> t -> storage -> unit val load_indexes_from_storage : storage -> lmdb -> unit val empty : index -> lmdb -> t diff --git a/impl/platform/jsoo/index.ml b/impl/platform/jsoo/index.ml index 7c7426e..c38a442 100644 --- a/impl/platform/jsoo/index.ml +++ b/impl/platform/jsoo/index.ml @@ -25,6 +25,18 @@ let sync_indexes_to_storage ~since_tx eavt aevt avet target_storage = Datascript_lmdb_index.sync_append_since_tx ~since_tx (project aevt) target; Datascript_lmdb_index.sync_append_since_tx ~since_tx (project avet) target +let sync_removals_to_storage removed_datoms _eavt _aevt _avet target_storage = + if removed_datoms = [] then () + else + let target_lmdb = Datascript_storage_lmdb.lmdb target_storage in + let remove index = + let t = Datascript_lmdb_index.empty index target_lmdb in + ignore (Datascript_lmdb_index.remove_datoms removed_datoms t) + in + remove Eavt; + remove Aevt; + remove Avet + let load_indexes_from_storage storage target_lmdb = let source = Datascript_storage_lmdb.lmdb storage in if source != target_lmdb then Datascript_storage_lmdb.sync_indexes source target_lmdb diff --git a/impl/platform/melange/index.ml b/impl/platform/melange/index.ml index 7c7426e..c38a442 100644 --- a/impl/platform/melange/index.ml +++ b/impl/platform/melange/index.ml @@ -25,6 +25,18 @@ let sync_indexes_to_storage ~since_tx eavt aevt avet target_storage = Datascript_lmdb_index.sync_append_since_tx ~since_tx (project aevt) target; Datascript_lmdb_index.sync_append_since_tx ~since_tx (project avet) target +let sync_removals_to_storage removed_datoms _eavt _aevt _avet target_storage = + if removed_datoms = [] then () + else + let target_lmdb = Datascript_storage_lmdb.lmdb target_storage in + let remove index = + let t = Datascript_lmdb_index.empty index target_lmdb in + ignore (Datascript_lmdb_index.remove_datoms removed_datoms t) + in + remove Eavt; + remove Aevt; + remove Avet + let load_indexes_from_storage storage target_lmdb = let source = Datascript_storage_lmdb.lmdb storage in if source != target_lmdb then Datascript_storage_lmdb.sync_indexes source target_lmdb diff --git a/impl/platform/native/index.ml b/impl/platform/native/index.ml index c8b1632..d1a4996 100644 --- a/impl/platform/native/index.ml +++ b/impl/platform/native/index.ml @@ -25,6 +25,18 @@ let sync_indexes_to_storage ~since_tx eavt aevt avet target_storage = Datascript_lmdb_index.sync_append_since_tx ~since_tx (project aevt) target; Datascript_lmdb_index.sync_append_since_tx ~since_tx (project avet) target +let sync_removals_to_storage removed_datoms _eavt _aevt _avet target_storage = + if removed_datoms = [] then () + else + let target_lmdb = Datascript_storage_lmdb.lmdb target_storage in + let remove index = + let t = Datascript_lmdb_index.empty index target_lmdb in + ignore (Datascript_lmdb_index.remove_datoms removed_datoms t) + in + remove Eavt; + remove Aevt; + remove Avet + let load_indexes_from_storage storage target_lmdb = let source = Datascript_storage_lmdb.lmdb storage in if source != target_lmdb then Datascript_storage_lmdb.sync_indexes source target_lmdb diff --git a/impl/transact.ml b/impl/transact.ml index 38b4f10..821e5d4 100644 --- a/impl/transact.ml +++ b/impl/transact.ml @@ -308,6 +308,10 @@ type apply_context = ; retract_user_attr_with_report : db -> tx -> db -> entity_id -> attr -> value option -> db * datom list ; retract_active_datom_with_report : tx -> db -> entity_id -> attr -> value option -> db * datom list ; retract_entity_with_report : db -> tx -> db -> entity_id -> db * datom list + ; purge_datom_with_report : tx -> db -> entity_id -> attr -> value -> db * datom list + ; purge_attr_with_report : tx -> db -> entity_id -> attr -> db * datom list + ; purge_entity_with_report : db -> tx -> db -> entity_id -> db * datom list + ; resolve_entity_for_purge : db -> entity_ref -> entity_id ; compare_and_set_matches : db -> entity_id -> attr -> value option -> bool ; compare_and_set_failure_message : db -> entity_id -> attr -> value option -> string ; datom : ?tx:tx -> ?added:bool -> e:entity_id -> a:attr -> v:value -> unit -> datom @@ -325,15 +329,18 @@ type apply_context = ; refresh_tuple_attrs_for_source : db -> tx -> db -> entity_id -> attr -> datom list -> db * datom list ; refresh_db_indexes_with_added_datoms : db -> datom list -> db ; refresh_db_indexes_with_tx_data : db -> datom list -> db + ; refresh_db_indexes_with_removed_datoms : db -> datom list -> db ; refresh_db_identity : db -> db } let apply_tx context tx_ops db = if context.is_filtered db then invalid_arg "filtered db is read-only"; + let input_db = db in let append_tx_data tx_data_rev datom_tx_data = List.rev_append datom_tx_data tx_data_rev in - let tx = db.max_tx + 1 in + let tx = input_db.max_tx + 1 in + let db = { input_db with max_tx = tx } in let current_schema = ref db.schema in let current_tx_fns = ref db.tx_fns in let removed_schema_attrs = ref [] in @@ -402,6 +409,10 @@ let apply_tx context tx_ops db = | Some value -> max_explicit_value max_eid value | None -> max_eid) | RetractEntity entity_ref | RetractAttr (entity_ref, _) -> max_explicit_entity_ref max_eid entity_ref + | Purge (entity_ref, _, value) -> + let max_eid = max_explicit_entity_ref max_eid entity_ref in + max_explicit_value max_eid value + | PurgeAttr (entity_ref, _) | PurgeEntity entity_ref -> max_explicit_entity_ref max_eid entity_ref | CompareAndSet (entity_ref, _, expected, new_value) -> let max_eid = max_explicit_entity_ref max_eid entity_ref in let max_eid = @@ -420,6 +431,7 @@ let apply_tx context tx_ops db = in let initial_max_eid = List.fold_left max_explicit_tx_op db.max_eid tx_ops in let max_tx_seen = ref tx in + let purged_datoms = ref [] in let mark_entity_tempid entity_tempids = function | Temp_id tempid -> tempid :: entity_tempids | _ -> entity_tempids @@ -601,6 +613,7 @@ let apply_tx context tx_ops db = attr = "db/ident" || List.mem attr context.schema_fields | Entity entity -> tx_entity_has_schema_fields entity | Retract _ | RetractEntity _ | RetractAttr _ -> true + | Purge _ | PurgeAttr _ | PurgeEntity _ -> true | CompareAndSet (_, attr, _, _) -> attr = "db/ident" || List.mem attr context.schema_fields | InstallTxFn _ | CallIdent _ | Call _ -> false in @@ -671,6 +684,22 @@ let apply_tx context tx_ops db = note_schema_field_retraction datoms e a; let datoms, datom_tx_data = context.retract_user_attr_with_report db tx datoms e a None in datoms, max_eid, tempids, entity_tempids, append_tx_data tx_data datom_tx_data) + | Purge (e, a, v) -> + let e = context.resolve_entity_for_purge (current_db ()) e in + let v, max_eid, tempids = resolve_value_for_attr context.resolve_context db a datoms tx max_eid tempids v in + let datoms, removed = context.purge_datom_with_report tx datoms e a v in + purged_datoms := !purged_datoms @ removed; + datoms, max_eid, tempids, entity_tempids, tx_data + | PurgeAttr (e, a) -> + let e = context.resolve_entity_for_purge (current_db ()) e in + let datoms, removed = context.purge_attr_with_report tx datoms e a in + purged_datoms := !purged_datoms @ removed; + datoms, max_eid, tempids, entity_tempids, tx_data + | PurgeEntity e -> + let e = context.resolve_entity_for_purge (current_db ()) e in + let datoms, removed = context.purge_entity_with_report (current_db ()) tx datoms e in + purged_datoms := !purged_datoms @ removed; + datoms, max_eid, tempids, entity_tempids, tx_data | CompareAndSet (e, a, expected, new_value) -> let e, max_eid, tempids = resolve_existing_entity_ref context.resolve_context db datoms tx max_eid tempids e in let expected, max_eid, tempids = resolve_optional_value_for_attr context.resolve_context db a datoms tx max_eid tempids expected in @@ -1078,22 +1107,6 @@ let apply_tx context tx_ops db = false) facts in - let duplicate_cardinality_one_fact facts = - let seen = Hashtbl.create (List.length facts) in - List.exists - (fun d -> - context.resolve_context.cardinality db d.a = One - && - let key = d.e, d.a in - if Hashtbl.mem seen key then true - else ( - Hashtbl.add seen key (); - false )) - facts - in - let entity_is_new d = - d.e > db.max_datom_e - in let existing_unique_conflict d = unique_attr d.a && @@ -1112,12 +1125,23 @@ let apply_tx context tx_ops db = (left.e, left.a, left.v, left.tx) (right.e, right.a, right.v, right.tx) in - let existing_attr_datoms d = - if entity_is_new d then [] else context.existing_entity_attr_datoms db d.e d.a + let existing_attr_datoms acc_tx_data d = + let from_db = + context.existing_entity_attr_datoms db d.e d.a + |> List.filter (fun ex -> + not (List.exists (fun pd -> not pd.added && context.same_fact pd ex) acc_tx_data)) + in + let from_acc = + acc_tx_data + |> List.filter (fun pd -> pd.added && pd.e = d.e && pd.a = d.a) + |> List.filter (fun pd -> + not (List.exists (fun pd2 -> not pd2.added && context.same_fact pd pd2) acc_tx_data)) + in + from_db @ from_acc in - let tx_data_for_fact d = + let tx_data_for_fact acc_tx_data d = let d = { d with v = context.resolve_context.normalize_value d.v } in - let existing = existing_attr_datoms d in + let existing = existing_attr_datoms acc_tx_data d in let same_fact_exists = List.exists (context.same_fact d) existing in match context.resolve_context.cardinality db d.a with | Many -> if same_fact_exists then [] else [ d ] @@ -1311,6 +1335,14 @@ let apply_tx context tx_ops db = , entity_tempids , tx_data ) in + let writes_tuple_source = function + | Entity { attrs; _ } -> + List.exists (fun (attr, _) -> context.tuple_attrs_for_source db attr <> []) attrs + | Add (_, attr, _) -> context.tuple_attrs_for_source db attr <> [] + | _ -> false + in + if List.exists writes_tuple_source tx_ops then None + else match try_new_tempid_entities () with | Some result -> Some result | None when not (List.for_all supported_tx_op tx_ops) -> None @@ -1471,10 +1503,17 @@ let apply_tx context tx_ops db = | None -> None | Some (facts_rev, max_eid, tempids, entity_tempids) -> let facts = List.rev facts_rev in - if duplicate_fact facts || duplicate_unique facts || duplicate_cardinality_one_fact facts || conflicts_with_existing facts then + if duplicate_fact facts || duplicate_unique facts || conflicts_with_existing facts then None else - let tx_data = List.concat_map tx_data_for_fact facts in + let tx_data = + List.fold_left + (fun acc fact -> + let datom_tx_data = tx_data_for_fact acc fact in + acc @ datom_tx_data) + [] + facts + in let max_eid = List.fold_left (fun max_eid d -> context.resolve_context.max_eid_in_value (context.resolve_context.max_eid_with_entity_id max_eid d.e) d.v) @@ -1507,7 +1546,7 @@ let apply_tx context tx_ops db = in datoms, max_eid, tempids, entity_tempids, tx_data, None in - let tx_data = + let base_tx_data = match fast_tx_data with | Some tx_data -> tx_data | None -> List.rev tx_data @@ -1518,7 +1557,7 @@ let apply_tx context tx_ops db = match fast_tx_data with | Some _ -> db.schema | None -> - let schema_datoms = context.schema_datoms (db_with_current_metadata datoms) tx_data in + let schema_datoms = context.schema_datoms (db_with_current_metadata datoms) base_tx_data in context.schema_from_transaction_datoms ~strict:true ~removed_attrs:!removed_schema_attrs @@ -1528,7 +1567,7 @@ let apply_tx context tx_ops db = schema_datoms in let db_after = - { db with + { input_db with schema ; max_eid ; max_tx = !max_tx_seen @@ -1539,7 +1578,7 @@ let apply_tx context tx_ops db = ( (match fast_tx_data with | Some _ -> db_after - |> (fun db -> context.refresh_db_indexes_with_tx_data db tx_data) + |> (fun db -> context.refresh_db_indexes_with_tx_data db base_tx_data) |> context.refresh_db_identity | None -> db_after @@ -1553,8 +1592,9 @@ let apply_tx context tx_ops db = ; tx_fns = db.tx_fns } else - context.refresh_db_indexes_with_tx_data db tx_data) + context.refresh_db_indexes_with_tx_data db base_tx_data) |> context.refresh_db_identity) , tempids - , tx_data + , base_tx_data + , !purged_datoms ) diff --git a/impl/transact.mli b/impl/transact.mli index 14fb2c5..f5229e3 100644 --- a/impl/transact.mli +++ b/impl/transact.mli @@ -55,6 +55,10 @@ type apply_context = ; retract_user_attr_with_report : db -> tx -> db -> entity_id -> attr -> value option -> db * datom list ; retract_active_datom_with_report : tx -> db -> entity_id -> attr -> value option -> db * datom list ; retract_entity_with_report : db -> tx -> db -> entity_id -> db * datom list + ; purge_datom_with_report : tx -> db -> entity_id -> attr -> value -> db * datom list + ; purge_attr_with_report : tx -> db -> entity_id -> attr -> db * datom list + ; purge_entity_with_report : db -> tx -> db -> entity_id -> db * datom list + ; resolve_entity_for_purge : db -> entity_ref -> entity_id ; compare_and_set_matches : db -> entity_id -> attr -> value option -> bool ; compare_and_set_failure_message : db -> entity_id -> attr -> value option -> string ; datom : ?tx:tx -> ?added:bool -> e:entity_id -> a:attr -> v:value -> unit -> datom @@ -72,7 +76,8 @@ type apply_context = ; refresh_tuple_attrs_for_source : db -> tx -> db -> entity_id -> attr -> datom list -> db * datom list ; refresh_db_indexes_with_added_datoms : db -> datom list -> db ; refresh_db_indexes_with_tx_data : db -> datom list -> db + ; refresh_db_indexes_with_removed_datoms : db -> datom list -> db ; refresh_db_identity : db -> db } -val apply_tx : apply_context -> tx_op list -> db -> db * (string * entity_id) list * datom list +val apply_tx : apply_context -> tx_op list -> db -> db * (string * entity_id) list * datom list * datom list diff --git a/js/datascript_js.ml b/js/datascript_js.ml index aa133ba..3f4503a 100644 --- a/js/datascript_js.ml +++ b/js/datascript_js.ml @@ -286,6 +286,7 @@ let json_of_tx_report report = [ "db_before", `String "" ; "db_after", `String "" ; "tx_data", `List (List.map json_of_datom report.tx_data) + ; "purged_datoms", `List (List.map json_of_datom report.purged_datoms) ; "tempids", tempids_object report.tempids ; "tx_meta", `List (List.map (fun (key, value) -> `List [ `String key; json_of_value value ]) report.tx_meta) ] diff --git a/lmdb/datascript_lmdb_codec.ml b/lmdb/datascript_lmdb_codec.ml index dfc7b12..333d275 100644 --- a/lmdb/datascript_lmdb_codec.ml +++ b/lmdb/datascript_lmdb_codec.ml @@ -239,6 +239,10 @@ let encode_index_attr_value_prefix index attr value = append_bytes buffer (encode_value_key value)); Buffer.contents buffer +let append_added buffer added = + (* dbval sort order: asserts before retracts at the same [e a v tx]. *) + append_byte buffer (if added then 0 else 1) + let encode_datom_key index datom = let buffer = Buffer.create 64 in (match index with @@ -246,45 +250,61 @@ let encode_datom_key index datom = append_int32 buffer datom.e; append_string buffer datom.a; append_bytes buffer (encode_value_key datom.v); - append_int32 buffer datom.tx + append_int32 buffer datom.tx; + append_added buffer datom.added | Aevt -> append_string buffer datom.a; append_int32 buffer datom.e; append_bytes buffer (encode_value_key datom.v); - append_int32 buffer datom.tx + append_int32 buffer datom.tx; + append_added buffer datom.added | Avet -> append_string buffer datom.a; append_bytes buffer (encode_value_key datom.v); append_int32 buffer datom.e; - append_int32 buffer datom.tx); + append_int32 buffer datom.tx; + append_added buffer datom.added); Buffer.contents buffer +let decode_added bytes offset = + let marker, offset = read_byte bytes offset in + let added = + match marker with + | 0 -> true + | 1 -> false + | _ -> invalid_arg "invalid datom added key marker" + in + added, offset + let decode_datom_key index bytes = - let e, a, v, tx = + let e, a, v, tx, added = match index with | Eavt -> let e, offset = read_int32 bytes 0 in let a, offset = read_string bytes offset in let v, offset = decode_value_key bytes offset in let tx, offset = read_int32 bytes offset in + let added, offset = decode_added bytes offset in if offset <> String.length bytes then invalid_arg "trailing eavt key bytes"; - e, a, v, tx + e, a, v, tx, added | Aevt -> let a, offset = read_string bytes 0 in let e, offset = read_int32 bytes offset in let v, offset = decode_value_key bytes offset in let tx, offset = read_int32 bytes offset in + let added, offset = decode_added bytes offset in if offset <> String.length bytes then invalid_arg "trailing aevt key bytes"; - e, a, v, tx + e, a, v, tx, added | Avet -> let a, offset = read_string bytes 0 in let v, offset = decode_value_key bytes offset in let e, offset = read_int32 bytes offset in let tx, offset = read_int32 bytes offset in + let added, offset = decode_added bytes offset in if offset <> String.length bytes then invalid_arg "trailing avet key bytes"; - e, a, v, tx + e, a, v, tx, added in - { e; a; v; tx; added = true } + { e; a; v; tx; added } let encode_datom_value datom = let cache_key = (datom.added, datom.v) in diff --git a/lmdb/melange/datascript_lmdb_codec.ml b/lmdb/melange/datascript_lmdb_codec.ml index dfc7b12..333d275 100644 --- a/lmdb/melange/datascript_lmdb_codec.ml +++ b/lmdb/melange/datascript_lmdb_codec.ml @@ -239,6 +239,10 @@ let encode_index_attr_value_prefix index attr value = append_bytes buffer (encode_value_key value)); Buffer.contents buffer +let append_added buffer added = + (* dbval sort order: asserts before retracts at the same [e a v tx]. *) + append_byte buffer (if added then 0 else 1) + let encode_datom_key index datom = let buffer = Buffer.create 64 in (match index with @@ -246,45 +250,61 @@ let encode_datom_key index datom = append_int32 buffer datom.e; append_string buffer datom.a; append_bytes buffer (encode_value_key datom.v); - append_int32 buffer datom.tx + append_int32 buffer datom.tx; + append_added buffer datom.added | Aevt -> append_string buffer datom.a; append_int32 buffer datom.e; append_bytes buffer (encode_value_key datom.v); - append_int32 buffer datom.tx + append_int32 buffer datom.tx; + append_added buffer datom.added | Avet -> append_string buffer datom.a; append_bytes buffer (encode_value_key datom.v); append_int32 buffer datom.e; - append_int32 buffer datom.tx); + append_int32 buffer datom.tx; + append_added buffer datom.added); Buffer.contents buffer +let decode_added bytes offset = + let marker, offset = read_byte bytes offset in + let added = + match marker with + | 0 -> true + | 1 -> false + | _ -> invalid_arg "invalid datom added key marker" + in + added, offset + let decode_datom_key index bytes = - let e, a, v, tx = + let e, a, v, tx, added = match index with | Eavt -> let e, offset = read_int32 bytes 0 in let a, offset = read_string bytes offset in let v, offset = decode_value_key bytes offset in let tx, offset = read_int32 bytes offset in + let added, offset = decode_added bytes offset in if offset <> String.length bytes then invalid_arg "trailing eavt key bytes"; - e, a, v, tx + e, a, v, tx, added | Aevt -> let a, offset = read_string bytes 0 in let e, offset = read_int32 bytes offset in let v, offset = decode_value_key bytes offset in let tx, offset = read_int32 bytes offset in + let added, offset = decode_added bytes offset in if offset <> String.length bytes then invalid_arg "trailing aevt key bytes"; - e, a, v, tx + e, a, v, tx, added | Avet -> let a, offset = read_string bytes 0 in let v, offset = decode_value_key bytes offset in let e, offset = read_int32 bytes offset in let tx, offset = read_int32 bytes offset in + let added, offset = decode_added bytes offset in if offset <> String.length bytes then invalid_arg "trailing avet key bytes"; - e, a, v, tx + e, a, v, tx, added in - { e; a; v; tx; added = true } + { e; a; v; tx; added } let encode_datom_value datom = let cache_key = (datom.added, datom.v) in diff --git a/lmdb/melange/datascript_lmdb_index.ml b/lmdb/melange/datascript_lmdb_index.ml index 5b7558e..1eae738 100644 --- a/lmdb/melange/datascript_lmdb_index.ml +++ b/lmdb/melange/datascript_lmdb_index.ml @@ -1,45 +1,37 @@ open Datascript_types -type t = - { db : Datascript_lmdb_db.t - ; which : index - ; additions : datom list - ; removals : datom list - } +type t = { db : Datascript_lmdb_db.t; which : index } type 'a seq = { cmp : datom -> datom -> int; datoms : datom list; offset : int } +exception Stop_search + let db_of t = t.db -let make index db = { db; which = index; additions = []; removals = [] } +let make index db = { db; which = index } let cmp_for index = Datascript_types.Compare.compare_datom index -let overlay_empty t = t.additions = [] && t.removals = [] let datom_key t datom = Datascript_lmdb_codec.encode_datom_key t.which datom let decode_entry index key value = let datom = Datascript_lmdb_codec.decode_datom_key index key in let payload = Datascript_lmdb_codec.decode_datom_value value in - { datom with added = payload.added; v = payload.v } + { datom with v = payload.v } let put_datom_txn txn t datom = let key = datom_key t datom in let value = Datascript_lmdb_codec.encode_datom_value datom in Datascript_lmdb_db.put_index_txn t.which txn t.db key value -let remove_datom_txn txn t datom = - let key = datom_key t datom in - Datascript_lmdb_db.remove_index_txn t.which txn t.db key - let empty index db = make index db -let of_sorted_list index datoms db = - let t = empty index db in +let write_datoms t datoms = if datoms = [] then t else ( - Datascript_lmdb_db.with_write_txn db (fun txn -> - List.iter (put_datom_txn txn t) datoms); + Datascript_lmdb_db.with_write_txn t.db (fun txn -> List.iter (put_datom_txn txn t) datoms); t) +let of_sorted_list index datoms db = write_datoms (empty index db) datoms + let of_sorted_lists index_datoms db = Datascript_lmdb_db.with_write_txn db (fun txn -> List.iter @@ -62,35 +54,41 @@ let of_eavt_datoms ~avet eavt_datoms db = if avet datom.a then put_datom_txn txn avet_index datom) eavt_datoms)) -let of_bulk index datoms db = { db; which = index; additions = datoms; removals = [] } +let of_bulk index datoms db = of_sorted_list index datoms db + +let append_tx_data ~avet:is_avet datoms eavt aevt avet_index = + if datoms = [] then (eavt, aevt, avet_index) + else ( + Datascript_lmdb_db.with_write_txn eavt.db (fun txn -> + List.iter + (fun datom -> + put_datom_txn txn eavt datom; + put_datom_txn txn aevt datom; + if is_avet datom.a then put_datom_txn txn avet_index datom) + datoms); + (eavt, aevt, avet_index)) + +let append_datoms datoms t = write_datoms t datoms -let additions_only t = t.additions <> [] && t.removals = [] +let add datom t = write_datoms t [ datom ] -let add datom t = +let remove_datom_txn txn t datom = let key = datom_key t datom in - let additions = datom :: List.filter (fun d -> datom_key t d <> key) t.additions in - let removals = List.filter (fun d -> datom_key t d <> key) t.removals in - { t with additions; removals } + Datascript_lmdb_db.remove_index_txn t.which txn t.db key let remove datom t = - let key = datom_key t datom in - let additions = List.filter (fun d -> datom_key t d <> key) t.additions in - let already_removed = List.exists (fun d -> datom_key t d = key) t.removals in - let removals = - if already_removed || List.exists (fun d -> datom_key t d = key) t.additions then t.removals - else datom :: t.removals - in - { t with additions; removals } + Datascript_lmdb_db.with_write_txn t.db (fun txn -> remove_datom_txn txn t datom); + t -let overlay_tables t = - let removed = Hashtbl.create (List.length t.removals) in - List.iter (fun datom -> Hashtbl.add removed (datom_key t datom) ()) t.removals; - let added = Hashtbl.create (List.length t.additions) in - List.iter (fun datom -> Hashtbl.replace added (datom_key t datom) datom) t.additions; - removed, added +let remove_datoms datoms t = + if datoms = [] then t + else ( + Datascript_lmdb_db.with_write_txn t.db (fun txn -> List.iter (remove_datom_txn txn t) datoms); + t) -let stored_visible key removed added = - not (Hashtbl.mem removed key || Hashtbl.mem added key) +let bound_key t = function + | None -> None + | Some datom -> Some (datom_key t datom) let in_range cmp lower upper datom = let above_lower = @@ -105,97 +103,86 @@ let in_range cmp lower upper datom = in above_lower && below_upper -let bound_key t = function - | None -> None - | Some datom -> Some (datom_key t datom) - -exception Stop_search - let fold_stored t f acc = - if overlay_empty t then - let acc = ref acc in - Datascript_lmdb_db.fold_index t.which t.db (fun key value -> - acc := f !acc (decode_entry t.which key value)); - !acc - else - let removed, added = overlay_tables t in - let acc = ref acc in - Datascript_lmdb_db.fold_index t.which t.db (fun key value -> - if stored_visible key removed added then - acc := f !acc (decode_entry t.which key value)); - !acc + let acc = ref acc in + Datascript_lmdb_db.fold_index t.which t.db (fun key value -> + acc := f !acc (decode_entry t.which key value)); + !acc let fold_stored_prefix t attr f acc = let prefix = attr ^ "\000" in - if overlay_empty t then - let acc = ref acc in - Datascript_lmdb_db.fold_index_prefix t.which t.db prefix (fun key value -> - acc := f !acc (decode_entry t.which key value)); - !acc - else - let removed, added = overlay_tables t in - let acc = ref acc in - Datascript_lmdb_db.fold_index_prefix t.which t.db prefix (fun key value -> - if stored_visible key removed added then - acc := f !acc (decode_entry t.which key value)); - !acc + let acc = ref acc in + Datascript_lmdb_db.fold_index_prefix t.which t.db prefix (fun key value -> + acc := f !acc (decode_entry t.which key value)); + !acc let fold_stored_attr_value_prefix t attr value f acc = let prefix = Datascript_lmdb_codec.encode_index_attr_value_prefix t.which attr value in - if overlay_empty t then - let acc = ref acc in - Datascript_lmdb_db.fold_index_prefix t.which t.db prefix (fun key value -> - acc := f !acc (decode_entry t.which key value)); - !acc - else - let removed, added = overlay_tables t in - let acc = ref acc in - Datascript_lmdb_db.fold_index_prefix t.which t.db prefix (fun key value -> - if stored_visible key removed added then - acc := f !acc (decode_entry t.which key value)); - !acc + let acc = ref acc in + Datascript_lmdb_db.fold_index_prefix t.which t.db prefix (fun key value -> + acc := f !acc (decode_entry t.which key value)); + !acc let fold_stored_bounded t ?from_ ?to_ cmp f acc = match bound_key t from_ with | None -> fold_stored t f acc | Some from_key -> - let removed, added = - if overlay_empty t then (Hashtbl.create 0, Hashtbl.create 0) else overlay_tables t - in let acc = ref acc in Datascript_lmdb_db.fold_index_range_until t.which t.db ~from_key - ~stop:(fun key value -> - if not (stored_visible key removed added) then false - else - match to_ with - | Some bound -> - let datom = decode_entry t.which key value in - cmp datom bound > 0 - | None -> false) + ~stop:(fun _key _value -> + match to_ with + | Some bound -> + let datom = decode_entry t.which _key _value in + cmp datom bound > 0 + | None -> false) (fun key value -> - if stored_visible key removed added then - let datom = decode_entry t.which key value in - if in_range cmp from_ to_ datom then acc := f !acc datom); + let datom = decode_entry t.which key value in + if in_range cmp from_ to_ datom then acc := f !acc datom); !acc -let fold_stored_bounded t ?from_ ?to_ cmp f acc = +let clear_index_txn txn index lmdb = + Datascript_lmdb_db.fold_index index lmdb (fun key _ -> + Datascript_lmdb_db.remove_index_txn index txn lmdb key) + +let sync_merged_to_lmdb t target_lmdb = + if t.db == target_lmdb then () + else + Datascript_lmdb_db.with_write_txn target_lmdb (fun txn -> + clear_index_txn txn t.which target_lmdb; + Datascript_lmdb_db.copy_index_txn t.which txn t.db target_lmdb) + +let sync_append_since_tx ~since_tx t target_lmdb = + if t.db == target_lmdb then () + else + let target = make t.which target_lmdb in + Datascript_lmdb_db.with_write_txn target_lmdb (fun txn -> + fold_stored t (fun () datom -> + if datom.tx > since_tx then put_datom_txn txn target datom) + ()) + +let copy t = t + +let flush t = t + +let to_list t = List.rev (fold_stored t (fun acc datom -> datom :: acc) []) + +let fold f init t = fold_stored t f init + +let lookup t datom = + match Datascript_lmdb_db.get_index t.which t.db (datom_key t datom) with + | None -> None + | Some value -> Some (decode_entry t.which (datom_key t datom) value) + +let fold_slice f init ?from_ ?to_ ?cmp t = let cmp = Option.value ~default:(cmp_for t.which) cmp in let apply acc datom = if in_range cmp from_ to_ datom then f acc datom else acc in - if not (overlay_empty t) then - collect_datoms t - |> List.filter (fun datom -> in_range cmp from_ to_ datom) - |> List.fold_left f init - else - let acc = - match from_, to_ with - | Some bound, Some bound' when bound == bound' && bound.a <> "" && bound.e = 0 && bound.v = Nil - && (t.which = Aevt || t.which = Avet) -> - fold_stored_prefix t bound.a apply init - | Some bound, Some bound' when bound == bound' && bound.a <> "" && bound.v <> Nil && bound.e = 0 -> - fold_stored_attr_value_prefix t bound.a bound.v apply init - | _ -> fold_stored_bounded t ?from_ ?to_ cmp apply init - in - acc + match from_, to_ with + | Some bound, Some bound' when bound == bound' && bound.a <> "" && bound.e = 0 && bound.v = Nil + && (t.which = Aevt || t.which = Avet) -> + fold_stored_prefix t bound.a apply init + | Some bound, Some bound' when bound == bound' && bound.a <> "" && bound.v <> Nil && bound.e = 0 -> + fold_stored_attr_value_prefix t bound.a bound.v apply init + | _ -> fold_stored_bounded t ?from_ ?to_ cmp apply init let find_first_slice ?from_ ?to_ ?cmp t = let cmp = Option.value ~default:(cmp_for t.which) cmp in @@ -206,27 +193,18 @@ let find_first_slice ?from_ ?to_ ?cmp t = raise Stop_search) in (try - if not (overlay_empty t) then - collect_datoms t |> List.iter consider - else - match from_, to_ with - | Some bound, Some bound' when bound == bound' && bound.a <> "" && bound.e = 0 && bound.v = Nil - && (t.which = Aevt || t.which = Avet) -> - fold_stored_prefix t bound.a (fun () datom -> consider datom) () - | Some bound, Some bound' when bound == bound' && bound.a <> "" && bound.v <> Nil && bound.e = 0 -> - fold_stored_attr_value_prefix t bound.a bound.v (fun () datom -> consider datom) () - | _ -> fold_stored_bounded t ?from_ ?to_ cmp (fun () datom -> consider datom) () + match from_, to_ with + | Some bound, Some bound' when bound == bound' && bound.a <> "" && bound.e = 0 && bound.v = Nil + && (t.which = Aevt || t.which = Avet) -> + fold_stored_prefix t bound.a (fun () datom -> consider datom) () + | Some bound, Some bound' when bound == bound' && bound.a <> "" && bound.v <> Nil && bound.e = 0 -> + fold_stored_attr_value_prefix t bound.a bound.v (fun () datom -> consider datom) () + | _ -> fold_stored_bounded t ?from_ ?to_ cmp (fun () datom -> consider datom) () with Stop_search -> ()); !found let fold_attr_prefix f init t attr = - let apply acc datom = if datom.a = attr then f acc datom else acc in - if not (overlay_empty t) then - collect_datoms t - |> List.filter (fun datom -> datom.a = attr) - |> List.fold_left f init - else - fold_stored_prefix t attr apply init + fold_stored_prefix t attr (fun acc datom -> if datom.a = attr then f acc datom else acc) init let materialize_range t ?from_ ?to_ cmp = fold_slice (fun acc datom -> datom :: acc) [] ?from_ ?to_ ~cmp t |> List.rev diff --git a/lmdb/melange/datascript_lmdb_index.mli b/lmdb/melange/datascript_lmdb_index.mli index cc85977..17eb56a 100644 --- a/lmdb/melange/datascript_lmdb_index.mli +++ b/lmdb/melange/datascript_lmdb_index.mli @@ -9,11 +9,15 @@ val of_sorted_list : index -> datom list -> Datascript_lmdb_db.t -> t val of_sorted_lists : (index * datom list) list -> Datascript_lmdb_db.t -> unit val of_eavt_datoms : avet:(string -> bool) -> datom list -> Datascript_lmdb_db.t -> unit val of_bulk : index -> datom list -> Datascript_lmdb_db.t -> t +val append_datoms : datom list -> t -> t +val append_tx_data : avet:(string -> bool) -> datom list -> t -> t -> t -> t * t * t val add : datom -> t -> t val remove : datom -> t -> t +val remove_datoms : datom list -> t -> t val flush : t -> t val copy : t -> t val sync_merged_to_lmdb : t -> Datascript_lmdb_db.t -> unit +val sync_append_since_tx : since_tx:tx -> t -> Datascript_lmdb_db.t -> unit val lookup : t -> datom -> datom option val to_list : t -> datom list val fold : ('acc -> datom -> 'acc) -> 'acc -> t -> 'acc diff --git a/lmdb/native/datascript_lmdb_index.ml b/lmdb/native/datascript_lmdb_index.ml index 6587093..1eae738 100644 --- a/lmdb/native/datascript_lmdb_index.ml +++ b/lmdb/native/datascript_lmdb_index.ml @@ -15,7 +15,7 @@ let datom_key t datom = Datascript_lmdb_codec.encode_datom_key t.which datom let decode_entry index key value = let datom = Datascript_lmdb_codec.decode_datom_key index key in let payload = Datascript_lmdb_codec.decode_datom_value value in - { datom with added = payload.added; v = payload.v } + { datom with v = payload.v } let put_datom_txn txn t datom = let key = datom_key t datom in @@ -72,7 +72,19 @@ let append_datoms datoms t = write_datoms t datoms let add datom t = write_datoms t [ datom ] -let remove _datom t = t +let remove_datom_txn txn t datom = + let key = datom_key t datom in + Datascript_lmdb_db.remove_index_txn t.which txn t.db key + +let remove datom t = + Datascript_lmdb_db.with_write_txn t.db (fun txn -> remove_datom_txn txn t datom); + t + +let remove_datoms datoms t = + if datoms = [] then t + else ( + Datascript_lmdb_db.with_write_txn t.db (fun txn -> List.iter (remove_datom_txn txn t) datoms); + t) let bound_key t = function | None -> None diff --git a/lmdb/native/datascript_lmdb_index.mli b/lmdb/native/datascript_lmdb_index.mli index 5b9f0b8..17eb56a 100644 --- a/lmdb/native/datascript_lmdb_index.mli +++ b/lmdb/native/datascript_lmdb_index.mli @@ -13,6 +13,7 @@ val append_datoms : datom list -> t -> t val append_tx_data : avet:(string -> bool) -> datom list -> t -> t -> t -> t * t * t val add : datom -> t -> t val remove : datom -> t -> t +val remove_datoms : datom list -> t -> t val flush : t -> t val copy : t -> t val sync_merged_to_lmdb : t -> Datascript_lmdb_db.t -> unit diff --git a/test/dune b/test/dune index e69509e..b56d731 100644 --- a/test/dune +++ b/test/dune @@ -3,6 +3,16 @@ (modules test_datascript) (libraries datascript-ocaml-native unix)) +(executable + (name debug_cardinality) + (modules debug_cardinality) + (libraries datascript-ocaml-native)) + +(executable + (name debug_entity) + (modules debug_entity) + (libraries datascript-ocaml-native)) + (test (name test_lru) (modules test_lru) @@ -28,6 +38,11 @@ (modules test_tx_history) (libraries datascript-ocaml-native)) +(test + (name test_purge) + (modules test_purge) + (libraries datascript-ocaml-native)) + (test (name test_db) (modules test_db) @@ -259,3 +274,9 @@ %{dep:cross_runtime_parity_test.sh} %{dep:cross_runtime_ocaml.exe} %{dep:../script/cross_runtime_upstream.js}))) +(executable (name debug_tuple) (modules debug_tuple) (libraries datascript-ocaml-native)) + +(executable + (name debug_query) + (modules debug_query) + (libraries datascript-ocaml-native)) diff --git a/test/test_purge.ml b/test/test_purge.ml new file mode 100644 index 0000000..7fa5c89 --- /dev/null +++ b/test/test_purge.ml @@ -0,0 +1,109 @@ +open Datascript + +let indexed = + { cardinality = One + ; unique = None + ; indexed = true + ; is_component = false + ; no_history = false + ; doc = None + ; value_type = None + ; tuple_attrs = None + ; tuple_types = None + } + +let unique_identity = { indexed with unique = Some Identity } + +let datoms_list db ?e ?a () = + datoms db Eavt ?e ?a () |> List.of_seq + +let int_values db ?a ?e () = + datoms_list db ?a ?e () + |> List.map (fun d -> match d.v with Int n -> n | _ -> -1) + |> List.sort compare + +let history_int_values db ?a ?e () = + datoms_list (history db) ?a ?e () + |> List.filter (fun d -> d.added) + |> List.map (fun d -> match d.v with Int n -> n | _ -> -1) + |> List.sort compare + +let history_all_int_values db ?a ?e () = + datoms_list (history db) ?a ?e () + |> List.map (fun d -> match d.v with Int n -> n | _ -> -1) + |> List.sort compare + +let string_values db ?a ?e () = + datoms_list db ?a ?e () + |> List.map (fun d -> match d.v with String s -> s | _ -> "") + |> List.sort compare + +let setup_db () = + db_with + [ Add (Entity_id 1, "name", String "Alice") + ; Add (Entity_id 1, "age", Int 25) + ; Add (Entity_id 2, "name", String "Bob") + ; Add (Entity_id 2, "age", Int 35) + ] + (empty_db ~schema:[ "name", unique_identity; "age", indexed ] ()) + +let test_purge_datom_from_current_and_history () = + let db = setup_db () in + let db = db_with [ Retract (Lookup_ref ("name", String "Alice"), "age", Some (Int 25)) ] db in + if int_values db ~a:"age" ~e:1 () <> [] then failwith "Alice age should be absent after retract"; + if history_int_values db ~a:"age" ~e:1 () <> [ 25 ] then + failwith "Alice age should remain in history after retract"; + let db = db_with [ Purge (Lookup_ref ("name", String "Bob"), "age", Int 35) ] db in + if int_values db ~a:"age" ~e:2 () <> [] then failwith "Bob age should be absent after purge"; + if history_all_int_values db ~a:"age" ~e:2 () <> [] then + failwith "Bob age should be absent from history after purge"; + let db = db_with [ Purge (Lookup_ref ("name", String "Alice"), "age", Int 25) ] db in + if history_all_int_values db ~a:"age" ~e:1 () <> [] then + failwith "purged retracted datom should leave history" + +let test_purge_attribute () = + let db = setup_db () in + let db = db_with [ PurgeAttr (Lookup_ref ("name", String "Alice"), "age") ] db in + if int_values db ~a:"age" ~e:1 () <> [] then failwith "Alice age should be absent after attribute purge"; + if history_all_int_values db ~a:"age" ~e:1 () <> [] then + failwith "Alice age should be absent from history"; + if string_values db ~a:"name" () <> [ "Alice"; "Bob" ] then failwith "Alice name should remain"; + let db = setup_db () in + let db = db_with [ RetractAttr (Lookup_ref ("name", String "Bob"), "age") ] db in + if int_values db ~a:"age" ~e:2 () <> [] then failwith "Bob age should be absent after retract attribute"; + if history_int_values db ~a:"age" ~e:2 () <> [ 35 ] then failwith "Bob age should remain in history"; + let db = db_with [ PurgeAttr (Lookup_ref ("name", String "Bob"), "age") ] db in + if history_all_int_values db ~a:"age" ~e:2 () <> [] then failwith "Bob age should be purged from history" + +let test_purge_entity () = + let db = setup_db () in + let db = db_with [ PurgeEntity (Lookup_ref ("name", String "Alice")) ] db in + if string_values db ~a:"name" () <> [ "Bob" ] then failwith "Alice should be removed from current db"; + if string_values (history db) ~a:"name" () <> [ "Bob" ] then failwith "Alice should be removed from history"; + let db = setup_db () in + let db = db_with [ RetractEntity (Lookup_ref ("name", String "Bob")) ] db in + if string_values db ~a:"name" () <> [ "Alice" ] then failwith "Bob should be retracted from current db"; + if not (List.mem "Bob" (string_values (history db) ~a:"name" ())) then + failwith "Bob should remain in history"; + let db = db_with [ PurgeEntity (Lookup_ref ("name", String "Bob")) ] db in + if List.mem "Bob" (string_values (history db) ~a:"name" ()) then + failwith "Bob should be purged from history" + +let test_purge_missing_entity_fails () = + let db = setup_db () in + let db = db_with [ PurgeEntity (Lookup_ref ("name", String "Alice")) ] db in + (match db_with [ PurgeEntity (Lookup_ref ("name", String "Alice")) ] db with + | exception Invalid_argument message when + (try + let len = String.length "to be purged" in + String.length message >= len + && String.sub message (String.length message - len) len = "to be purged" + with _ -> false) -> + () + | _ -> failwith "expected purge of missing entity to fail") + +let () = + test_purge_datom_from_current_and_history (); + test_purge_attribute (); + test_purge_entity (); + test_purge_missing_entity_fails () diff --git a/type/datascript_types.ml b/type/datascript_types.ml index df89771..b669943 100644 --- a/type/datascript_types.ml +++ b/type/datascript_types.ml @@ -105,6 +105,9 @@ and tx_op = | Retract of entity_ref * attr * value option | RetractEntity of entity_ref | RetractAttr of entity_ref * attr + | Purge of entity_ref * attr * value + | PurgeAttr of entity_ref * attr + | PurgeEntity of entity_ref | CompareAndSet of entity_ref * attr * value option * value | Entity of tx_entity | Raw_datom of datom @@ -509,6 +512,7 @@ type tx_report = ; tx_data : datom list ; tempids : (string * entity_id) list ; tx_meta : tx_meta + ; purged_datoms : datom list } module Compare = struct let split_keyword keyword = @@ -787,24 +791,33 @@ module Compare = struct else if third <> 0 then third else fourth + let compare_added left right = + compare (if left.added then 0 else 1) (if right.added then 0 else 1) + let compare_datom index left right = + let tiebreak_added comparison = + if comparison <> 0 then comparison else compare_added left right + in match index with | Eavt -> - first_nonzero4 - (compare left.e right.e) - (compare left.a right.a) - (compare_value left.v right.v) - (compare left.tx right.tx) + tiebreak_added + (first_nonzero4 + (compare left.e right.e) + (compare left.a right.a) + (compare_value left.v right.v) + (compare left.tx right.tx)) | Aevt -> - first_nonzero4 - (compare left.a right.a) - (compare left.e right.e) - (compare_value left.v right.v) - (compare left.tx right.tx) + tiebreak_added + (first_nonzero4 + (compare left.a right.a) + (compare left.e right.e) + (compare_value left.v right.v) + (compare left.tx right.tx)) | Avet -> - first_nonzero4 - (compare left.a right.a) - (compare_value left.v right.v) - (compare left.e right.e) - (compare left.tx right.tx) + tiebreak_added + (first_nonzero4 + (compare left.a right.a) + (compare_value left.v right.v) + (compare left.e right.e) + (compare left.tx right.tx)) end From ab4c7ecb87791edcf7405ffdcddca582943efc09 Mon Sep 17 00:00:00 2001 From: Cursor Agent Date: Thu, 27 Aug 2026 09:29:53 +0000 Subject: [PATCH 6/9] Expand tx_history tests for dbval/Datahike temporal API coverage Cover basis_tx, as_of/since bounds, history retractions, entity retraction trails, temporal view transact guards, view immutability, index parity, and public API aliases. Co-authored-by: Tienson Qin --- test/test_tx_history.ml | 275 ++++++++++++++++++++++++++++++++-------- 1 file changed, 225 insertions(+), 50 deletions(-) diff --git a/test/test_tx_history.ml b/test/test_tx_history.ml index e553d74..50e3e6e 100644 --- a/test/test_tx_history.ml +++ b/test/test_tx_history.ml @@ -5,6 +5,16 @@ let failf fmt = Printf.ksprintf failwith fmt let assert_equal_int label expected actual = if expected <> actual then failf "%s: expected %d, got %d" label expected actual +let assert_equal_bool label expected actual = + if expected <> actual then failf "%s: expected %b, got %b" label expected actual + +let assert_equal_string_list label expected actual = + if expected <> actual then + failf "%s: expected [%s], got [%s]" label (String.concat "; " expected) (String.concat "; " actual) + +let datoms_list db index ?e ?a ?v ?tx () = + datoms db index ?e ?a ?v ?tx () |> List.of_seq + let indexed = { cardinality = One ; unique = None @@ -17,81 +27,246 @@ let indexed = ; tuple_types = None } +let many = + { cardinality = Many + ; unique = None + ; indexed = false + ; is_component = false + ; no_history = false + ; doc = None + ; value_type = None + ; tuple_attrs = None + ; tuple_types = None + } + let unique_identity = { indexed with unique = Some Identity } -let ages db = - datoms db Eavt ~a:":age" () - |> Seq.map (fun d -> d.v) - |> List.of_seq +let int_values db ?a ?e () = + datoms_list db Eavt ?a ?e () + |> List.map (fun d -> match d.v with Int n -> n | _ -> -1) + |> List.sort compare -let test_history_exposes_retractions () = +let string_values db ?a ?e () = + datoms_list db ?a ?e () + |> List.map (fun d -> match d.v with String s -> s | _ -> "") + |> List.sort compare + +let history_asserted_values db ?a ?e () = + datoms_list (history db) Eavt ?a ?e () + |> List.filter (fun d -> d.added) + |> List.map (fun d -> match d.v with Int n -> string_of_int n | String s -> s | _ -> "?") + |> List.sort compare + +let expect_invalid_arg f = + match f () with + | exception Invalid_argument _ -> () + | _ -> failwith "expected Invalid_argument" + +let test_basis_tx_tracks_latest_transaction () = + let db = + empty_db ~schema:[ "age", indexed ] () + |> db_with [ Add (Entity_id 1, "age", Int 25) ] + in + let tx0 = basis_tx db in + let db = db_with [ Add (Entity_id 1, "age", Int 30) ] db in + let tx1 = basis_tx db in + assert_equal_int "basis advances across transactions" 1 (if tx1 > tx0 then 1 else 0); + assert_equal_int "current view uses latest basis" 30 (List.hd (int_values db ~a:"age" ())); + +let test_as_of_point_in_time () = let db = db_with - [ Add (Entity_id 1, ":name", String "Alice") - ; Add (Entity_id 1, ":age", Int 30) + [ Add (Entity_id 1, "name", String "Alice"); Add (Entity_id 1, "age", Int 25) + ; Add (Entity_id 2, "name", String "Bob"); Add (Entity_id 2, "age", Int 35) ] (empty_db ~schema:[ "name", unique_identity; "age", indexed ] ()) in - let tx1 = basis_tx db in - let db = db_with [ Add (Entity_id 1, ":age", Int 31) ] db in - let current = - ages db - |> List.map (function Int n -> n | _ -> -1) + let tx0 = basis_tx db in + let db = db_with [ Add (Entity_id 1, "age", Int 30) ] db in + let past = as_of tx0 db in + (match as_of_t past, as_of_tx past with + | Some tx, Some tx' when tx = tx0 && tx' = tx0 -> () + | _ -> failwith "as_of should expose as_of_t and as_of_tx"); + assert_equal_int "as_of lowers basis_tx" tx0 (basis_tx past); + assert_equal_int "as_of is a temporal view" 1 (if temporal_view past then 1 else 0); + assert_equal_bool "as_of is not history" false (is_history past); + assert_equal_string_list "as_of tx0 sees Alice age 25" [ "25" ] + (List.map string_of_int (int_values past ~e:1 ~a:"age" ())); + assert_equal_string_list "as_of tx0 sees Bob age 35" [ "35" ] + (List.map string_of_int (int_values past ~e:2 ~a:"age" ())); + +let test_since_delta_is_exclusive () = + let db = + db_with + [ Add (Entity_id 1, "name", String "Alice"); Add (Entity_id 2, "name", String "Bob") ] + (empty_db ~schema:[ "name", unique_identity ] ()) in - assert_equal_int "current db keeps latest age" 1 (List.length current); - if current <> [ 31 ] then failf "current ages should be [31], got %S" (string_of_int (List.hd current)); - let past = as_of tx1 db in - let past_ages = - ages past - |> List.map (function Int n -> n | _ -> -1) + let tx0 = basis_tx db in + let db = db_with [ Add (Entity_id 3, "name", String "Carol") ] db in + let delta = since tx0 db in + (match since_t delta, since_tx delta with + | Some tx, Some tx' when tx = tx0 && tx' = tx0 -> () + | _ -> failwith "since should expose since_t and since_tx"); + assert_equal_int "since keeps latest basis_tx" (basis_tx db) (basis_tx delta); + assert_equal_int "since is a temporal view" 1 (if temporal_view delta then 1 else 0); + assert_equal_bool "since is not history" false (is_history delta); + assert_equal_string_list "since after tx0 only sees Carol" [ "Carol" ] (string_values delta ~a:"name" ()); + +let test_history_exposes_assertions_and_retractions () = + let db = + db_with + [ Add (Entity_id 1, "name", String "Alice"); Add (Entity_id 1, "age", Int 25) ] + (empty_db ~schema:[ "name", unique_identity; "age", indexed ] ()) in - if past_ages <> [ 30 ] then failf "as_of should see age 30, got %d entries" (List.length past_ages); + let db = db_with [ Add (Entity_id 1, "age", Int 30) ] db in + let db = db_with [ Retract (Entity_id 1, "name", Some (String "Alice")) ] db in + assert_equal_string_list "current db keeps latest age only" [ "30" ] + (List.map string_of_int (int_values db ~a:"age" ())); + assert_equal_string_list "current db drops retracted name" [] (string_values db ~a:"name" ()); let hist = history db in - let hist_ages = - datoms hist Eavt ~a:":age" () - |> Seq.filter (fun d -> d.added) - |> Seq.map (fun d -> match d.v with Int n -> n | _ -> -1) - |> List.of_seq - |> List.sort compare + assert_equal_bool "history enables history flag" true (is_history hist); + assert_equal_int "history is temporal" 1 (if temporal_view hist then 1 else 0); + assert_equal_string_list "history keeps asserted ages" [ "25"; "30" ] (history_asserted_values hist ~a:"age" ()); + let retracted_names = + datoms_list hist Eavt ~a:"name" () + |> List.filter (fun d -> not d.added) + |> List.map (fun d -> match d.v with String s -> s | _ -> "") in - if hist_ages <> [ 30; 31 ] then - failf "history should expose both asserted ages, got [%s]" - (String.concat "; " (List.map string_of_int hist_ages)) + if retracted_names <> [ "Alice" ] then + failf "history should expose retraction datoms, got [%s]" (String.concat "; " retracted_names); + () -let test_since_sees_post_tx_datoms () = +let test_history_survives_entity_retraction () = let db = db_with - [ Add (Entity_id 1, ":name", String "Alice") - ; Add (Entity_id 2, ":name", String "Bob") - ] - (empty_db ~schema:[ "name", unique_identity ] ()) + [ Add (Entity_id 1, "name", String "Alice"); Add (Entity_id 1, "age", Int 25) ] + (empty_db ~schema:[ "name", unique_identity; "age", indexed ] ()) in + let tx0 = basis_tx db in + let db = db_with [ Add (Entity_id 1, "age", Int 30) ] db in let tx1 = basis_tx db in - let db = db_with [ Add (Entity_id 3, ":name", String "Carol") ] db in - let names delta = - datoms delta Aevt ~a:":name" () - |> Seq.map (fun d -> match d.v with String s -> s | _ -> "") - |> List.of_seq - |> List.sort compare + let db = db_with [ RetractEntity (Entity_id 1) ] db in + assert_equal_string_list "retracted entity absent from current db" [] (int_values db ~e:1 ~a:"age" ()); + let hist = history db in + assert_equal_string_list "history after retraction keeps age trail" [ "25"; "30" ] + (history_asserted_values hist ~e:1 ~a:"age" ()); + let past = as_of tx0 hist in + assert_equal_string_list "history + as_of tx0 sees bootstrap age" [ "25" ] + (List.map string_of_int (int_values past ~e:1 ~a:"age" ())); + let delta = since tx1 hist in + assert_equal_string_list "history + since tx1 sees post-update age only" [ "30" ] + (history_asserted_values delta ~e:1 ~a:"age" ()); + +let test_temporal_views_reject_transact () = + let db = + db_with [ Add (Entity_id 1, "name", String "Alice") ] (empty_db ~schema:[ "name", indexed ] ()) + in + let tx0 = basis_tx db in + expect_invalid_arg (fun () -> + ignore (transact (as_of tx0 db) [ Add (Entity_id 2, "name", String "Bob") ])); + expect_invalid_arg (fun () -> + ignore (transact (since tx0 db) [ Add (Entity_id 2, "name", String "Bob") ])); + expect_invalid_arg (fun () -> + ignore (transact (history db) [ Add (Entity_id 2, "name", String "Bob") ])); + +let test_as_of_beyond_store_basis_fails () = + let db = + db_with [ Add (Entity_id 1, "name", String "Alice") ] (empty_db ~schema:[ "name", indexed ] ()) + in + expect_invalid_arg (fun () -> ignore (as_of (basis_tx db + 1) db)); + +let test_view_constructors_do_not_mutate_input_db () = + let db = + db_with + [ Add (Entity_id 1, "name", String "Alice"); Add (Entity_id 1, "age", Int 25) ] + (empty_db ~schema:[ "name", unique_identity; "age", indexed ] ()) in - if names db <> [ "Alice"; "Bob"; "Carol" ] then failf "current db missing Carol"; - let delta = since tx1 db in - if names delta <> [ "Carol" ] then failf "since tx1 should only see Carol" + let tx0 = basis_tx db in + let before_datoms = datoms_list db Eavt () in + ignore (as_of tx0 db); + ignore (since tx0 db); + ignore (history db); + assert_equal_int "input basis unchanged" tx0 (basis_tx db); + assert_equal_bool "input is not temporal" false (temporal_view db); + assert_equal_bool "input is not history" false (is_history db); + if datoms_list db Eavt () <> before_datoms then failwith "view constructors must not mutate input db"; let test_with_tx_preserves_db_before_basis () = let db = - db_with [ Add (Entity_id 1, ":name", String "Alice") ] (empty_db ~schema:[ "name", indexed ] ()) + db_with [ Add (Entity_id 1, "name", String "Alice") ] (empty_db ~schema:[ "name", indexed ] ()) in let before_basis = basis_tx db in - let report = - with_tx db [ Add (Entity_id 2, ":name", String "Bob") ] - in - assert_equal_int "input db unchanged" before_basis (basis_tx db); + let report = with_tx db [ Add (Entity_id 2, "name", String "Bob") ] in + assert_equal_int "original db basis unchanged" before_basis (basis_tx db); assert_equal_int "db_before pins old basis" before_basis (basis_tx report.db_before); - assert_equal_int "db_after advances basis" 1 (if basis_tx report.db_after > before_basis then 1 else 0) + assert_equal_int "db_after advances basis" 1 (if basis_tx report.db_after > before_basis then 1 else 0); + +let test_history_as_of_composition () = + let db = + db_with + [ Add (Entity_id 1, "name", String "Alice"); Add (Entity_id 1, "age", Int 25) + ; Add (Entity_id 2, "name", String "Bob"); Add (Entity_id 2, "age", Int 35) + ] + (empty_db ~schema:[ "name", unique_identity; "age", indexed ] ()) + in + let tx0 = basis_tx db in + let db = db_with [ Add (Entity_id 1, "age", Int 30) ] db in + let bootstrap = as_of tx0 (history db) in + assert_equal_string_list "history then as_of tx0 sees bootstrap ages" [ "25"; "35" ] + (List.map string_of_int (int_values bootstrap ~a:"age" ())); + +let test_temporal_views_preserve_index_parity () = + let db = + db_with + [ Add (Entity_id 1, "name", String "Alice"); Add (Entity_id 1, "age", Int 30) ] + (empty_db ~schema:[ "name", unique_identity; "age", indexed ] ()) + in + let tx0 = basis_tx db in + let db = db_with [ Add (Entity_id 1, "age", Int 31) ] db in + let past = as_of tx0 db in + let eavt = datoms_list past Eavt ~e:1 ~a:"age" () |> List.map (fun d -> d.v) in + let aevt = datoms_list past Aevt ~a:"age" () |> List.filter (fun d -> d.e = 1) |> List.map (fun d -> d.v) in + if eavt <> aevt then failwith "as_of view should return consistent EAVT and AEVT slices"; + +let test_history_cardinality_many () = + let db = + db_with + [ Add (Entity_id 1, "name", String "Alice") + ; Add (Entity_id 1, "tag", String "a") + ; Add (Entity_id 1, "tag", String "b") + ] + (empty_db ~schema:[ "name", unique_identity; "tag", many ] ()) + in + let db = db_with [ Retract (Entity_id 1, "tag", Some (String "a")) ] db in + assert_equal_string_list "current many attr keeps surviving value" [ "b" ] (string_values db ~a:"tag" ()); + assert_equal_string_list "history many attr keeps both assertions" [ "a"; "b" ] + (history_asserted_values db ~a:"tag" ()); + +let test_public_api_aliases () = + let db = + db_with [ Add (Entity_id 1, "name", String "Alice") ] (empty_db ~schema:[ "name", indexed ] ()) + in + let tx0 = basis_tx db in + assert_equal_bool "plain db is not history" false (is_history db); + (match (as_of_t db, as_of_tx db, since_t db, since_tx db) with + | None, None, None, None -> () + | _ -> failwith "plain db should not expose temporal markers"); + let past = as_of tx0 db in + assert_equal_bool "is_history mirrors history flag" true (is_history (history db)); + assert_equal_bool "is_history false on as_of" false (is_history past); let () = - test_history_exposes_retractions (); - test_since_sees_post_tx_datoms (); + test_basis_tx_tracks_latest_transaction (); + test_as_of_point_in_time (); + test_since_delta_is_exclusive (); + test_history_exposes_assertions_and_retractions (); + test_history_survives_entity_retraction (); + test_temporal_views_reject_transact (); + test_as_of_beyond_store_basis_fails (); + test_view_constructors_do_not_mutate_input_db (); test_with_tx_preserves_db_before_basis (); + test_history_as_of_composition (); + test_temporal_views_preserve_index_parity (); + test_history_cardinality_many (); + test_public_api_aliases (); Printf.printf "test_tx_history: ok\n" From 2ebfa6bef7d2c797d7a0cbedd998b72e9a5ae10f Mon Sep 17 00:00:00 2001 From: Cursor Agent Date: Thu, 27 Aug 2026 10:08:02 +0000 Subject: [PATCH 7/9] Make storage backends pluggable with string kinds and separate packages - Replace fixed storage_kind variants with extensible string labels (storage_kind_memory/lmdb/sqlite constants for built-in names) - Unify all backends behind storage_backend callbacks registered via Datascript_storage_protocol.register_backend - Default datascript-ocaml-native.storage package: memory only - Optional opam packages: datascript-ocaml-native-lmdb and datascript-ocaml-native-sqlite with plugin modules - Migrate storage/history/purge tests to Alcotest Co-authored-by: Tienson Qin --- datascript-ocaml-native-lmdb.opam | 15 ++ datascript-ocaml-native-sqlite.opam | 15 ++ datascript-ocaml-native.opam | 2 +- dune-project | 9 +- impl/datascript.ml | 6 +- impl/datascript.mli | 9 +- impl/db.ml | 4 +- impl/index.mli | 1 + impl/platform/jsoo/dune | 6 +- impl/platform/jsoo/index.ml | 34 ++-- impl/platform/jsoo/storage.ml | 32 +--- impl/platform/melange/dune | 6 +- impl/platform/melange/index.ml | 34 ++-- impl/platform/melange/storage.ml | 32 +--- impl/platform/native/dune | 7 +- impl/platform/native/index.ml | 33 ++-- impl/platform/native/storage.ml | 32 +--- impl/storage.mli | 4 +- impl/tx_visibility.ml | 19 +- impl/tx_visibility.mli | 7 +- lmdb/datascript_lmdb.ml | 83 +-------- lmdb/datascript_storage_lmdb_plugin.ml | 34 ++++ lmdb/datascript_storage_lmdb_plugin.mli | 3 + lmdb/dune | 11 +- lmdb/melange/dune | 8 - lmdb/native/dune | 8 - sqlite/datascript_sqlite.ml | 43 +---- sqlite/datascript_storage_sqlite.ml | 52 ++++++ sqlite/datascript_storage_sqlite_plugin.ml | 28 +++ sqlite/datascript_storage_sqlite_plugin.mli | 3 + sqlite/dune | 29 +++- storage/dune | 1 + storage/melange/datascript_storage_lmdb.ml | 22 +++ storage/melange/datascript_storage_meta.ml | 47 +++++ .../melange/datascript_storage_protocol.ml | 164 ++++++++++++++++++ .../melange/datascript_storage_protocol.mli | 40 +++++ storage/melange/dune | 12 ++ storage/native/datascript_storage_lmdb.ml | 22 +++ storage/native/datascript_storage_meta.ml | 47 +++++ storage/native/datascript_storage_protocol.ml | 137 +++++++++++++++ .../native/datascript_storage_protocol.mli | 51 ++++++ storage/native/dune | 16 ++ test/dune | 19 +- test/test_alcotest_support.ml | 17 ++ test/test_lmdb_package.ml | 35 ++-- test/test_purge.ml | 76 ++++---- test/test_sqlite_package.ml | 36 ++-- test/test_storage.ml | 44 ++--- test/test_tx_history.ml | 145 ++++++++-------- type/datascript_types.ml | 13 +- 50 files changed, 1056 insertions(+), 497 deletions(-) create mode 100644 datascript-ocaml-native-lmdb.opam create mode 100644 datascript-ocaml-native-sqlite.opam create mode 100644 lmdb/datascript_storage_lmdb_plugin.ml create mode 100644 lmdb/datascript_storage_lmdb_plugin.mli create mode 100644 sqlite/datascript_storage_sqlite.ml create mode 100644 sqlite/datascript_storage_sqlite_plugin.ml create mode 100644 sqlite/datascript_storage_sqlite_plugin.mli create mode 100644 storage/dune create mode 100644 storage/melange/datascript_storage_lmdb.ml create mode 100644 storage/melange/datascript_storage_meta.ml create mode 100644 storage/melange/datascript_storage_protocol.ml create mode 100644 storage/melange/datascript_storage_protocol.mli create mode 100644 storage/melange/dune create mode 100644 storage/native/datascript_storage_lmdb.ml create mode 100644 storage/native/datascript_storage_meta.ml create mode 100644 storage/native/datascript_storage_protocol.ml create mode 100644 storage/native/datascript_storage_protocol.mli create mode 100644 storage/native/dune create mode 100644 test/test_alcotest_support.ml diff --git a/datascript-ocaml-native-lmdb.opam b/datascript-ocaml-native-lmdb.opam new file mode 100644 index 0000000..efb8b4f --- /dev/null +++ b/datascript-ocaml-native-lmdb.opam @@ -0,0 +1,15 @@ +opam-version: "2.0" +synopsis: "LMDB persistent storage for DataScript OCaml" +description: "File-backed LMDB storage sessions for datascript-ocaml-native." +maintainer: "rcmerci" +authors: ["rcmerci"] +license: "MIT" +depends: [ + "ocaml" {>= "5.1.1"} + "dune" {>= "3.17"} + "datascript-ocaml-native" {= version} + "lmdb" +] +build: [ + ["dune" "build" "-p" name "-j" jobs] +] diff --git a/datascript-ocaml-native-sqlite.opam b/datascript-ocaml-native-sqlite.opam new file mode 100644 index 0000000..68db38b --- /dev/null +++ b/datascript-ocaml-native-sqlite.opam @@ -0,0 +1,15 @@ +opam-version: "2.0" +synopsis: "SQLite persistent storage for DataScript OCaml" +description: "File-backed SQLite storage sessions for datascript-ocaml-native." +maintainer: "rcmerci" +authors: ["rcmerci"] +license: "MIT" +depends: [ + "ocaml" {>= "5.1.1"} + "dune" {>= "3.17"} + "datascript-ocaml-native" {= version} + "sqlite3" +] +build: [ + ["dune" "build" "-p" name "-j" jobs] +] diff --git a/datascript-ocaml-native.opam b/datascript-ocaml-native.opam index 3858445..5f3b0df 100644 --- a/datascript-ocaml-native.opam +++ b/datascript-ocaml-native.opam @@ -8,8 +8,8 @@ depends: [ "ocaml" {>= "5.1.1"} "dune" {>= "3.17"} "datascript_ocaml" {= version} - "sqlite3" "lmdb" + "alcotest" "melange-transit-native" {= "0.1.0"} "yojson" ] diff --git a/dune-project b/dune-project index 910cc6b..1e506ca 100644 --- a/dune-project +++ b/dune-project @@ -7,7 +7,14 @@ (name datascript_ocaml)) (package - (name datascript-ocaml-native)) + (name datascript-ocaml-native) + (depends alcotest)) + +(package + (name datascript-ocaml-native-lmdb)) + +(package + (name datascript-ocaml-native-sqlite)) (package (name datascript-ocaml-jsoo)) diff --git a/impl/datascript.ml b/impl/datascript.ml index 11d7452..51c3888 100644 --- a/impl/datascript.ml +++ b/impl/datascript.ml @@ -106,9 +106,11 @@ let store ?storage db = Storage.store ?storage (Db_impl.flush_pending_datoms db) let memory_storage = Storage.memory_storage -let storage_addresses = Storage.storage_addresses +let ensure_live = Storage.ensure_live +let kind_of = Storage.kind_of + +let storage_of_handle (handle : Datascript_types.storage) = (handle : storage) let storage = Storage.storage -let addresses = Storage.addresses let settings = Storage.settings let collect_garbage = Storage.collect_garbage diff --git a/impl/datascript.mli b/impl/datascript.mli index f342f73..aa4aed1 100644 --- a/impl/datascript.mli +++ b/impl/datascript.mli @@ -239,12 +239,12 @@ module Storage : sig type restore_context = { next_db_uid : unit -> int } val memory_storage : unit -> storage + val ensure_live : storage -> unit + val kind_of : storage -> storage_kind val store : ?storage:storage -> db -> unit val restore_root_snapshot : storage -> serializable_db option val restore : restore_context -> storage -> db option - val storage_addresses : storage -> storage_address list val storage : db -> storage option - val addresses : db list -> storage_address list val settings : db -> (attr * value) list val collect_garbage : storage -> unit end @@ -405,12 +405,13 @@ val serializable : db -> serializable_db val from_serializable : serializable_db -> db val db_from_reader_string : string -> db val memory_storage : unit -> storage +val ensure_live : storage -> unit +val kind_of : storage -> storage_kind +val storage_of_handle : Datascript_types.storage -> storage val store : ?storage:storage -> db -> unit val restore : storage -> db option val storage : db -> storage option -val addresses : db list -> storage_address list val settings : db -> (attr * value) list -val storage_addresses : storage -> storage_address list val collect_garbage : storage -> unit val db_hash : db -> int val db_hash_cache_size : unit -> int diff --git a/impl/db.ml b/impl/db.ml index 7e4ddaa..f40e69a 100644 --- a/impl/db.ml +++ b/impl/db.ml @@ -121,9 +121,9 @@ let invalidate_attr_tables db = let view_bounds db = { Tx_visibility.view_tx = db.max_tx; since_tx = db.since_tx; history = db.history } -let apply_db_view db datoms = Tx_visibility.apply_view (view_bounds db) datoms +let apply_db_view db datoms = Tx_visibility.apply_view db.schema (view_bounds db) datoms -let apply_db_view_seq db seq = Tx_visibility.filter_seq (view_bounds db) seq +let apply_db_view_seq db seq = Tx_visibility.filter_seq db.schema (view_bounds db) seq let indexes_on_storage db = Option.is_some db.storage_ref diff --git a/impl/index.mli b/impl/index.mli index 7ce3e83..8b5d203 100644 --- a/impl/index.mli +++ b/impl/index.mli @@ -4,6 +4,7 @@ type t = index_set type 'a seq type lmdb +val same_storage_db : storage -> lmdb -> bool val create_lmdb : storage option -> lmdb * storage option val lmdb_of : lmdb -> lmdb val db_of : t -> lmdb diff --git a/impl/platform/jsoo/dune b/impl/platform/jsoo/dune index efd469d..c31ce0a 100644 --- a/impl/platform/jsoo/dune +++ b/impl/platform/jsoo/dune @@ -3,8 +3,4 @@ (public_name datascript-ocaml-jsoo) (implements datascript) (modes byte) - (libraries - js_of_ocaml - lmdb_db_native - lmdb_index_native - storage_lmdb_native)) + (libraries js_of_ocaml lmdb_db_native lmdb_index_native storage_native)) diff --git a/impl/platform/jsoo/index.ml b/impl/platform/jsoo/index.ml index c38a442..d307c5d 100644 --- a/impl/platform/jsoo/index.ml +++ b/impl/platform/jsoo/index.ml @@ -9,37 +9,26 @@ type t = index_set type 'a seq = 'a Datascript_lmdb_index.seq type lmdb = Datascript_lmdb_db.t -let create_lmdb storage = - match storage with - | Some storage -> (Datascript_storage_lmdb.lmdb storage, Some storage) - | None -> (Datascript_lmdb_db.create_temp (), None) +let same_storage_db storage index_lmdb = + Datascript_storage_protocol.same_storage_db storage index_lmdb + +let create_lmdb storage = Datascript_storage_protocol.create_index_db storage let lmdb_of lmdb = lmdb let db_of t = Datascript_lmdb_index.db_of (project t) -let lmdb_for_storage storage = Datascript_storage_lmdb.lmdb storage +let lmdb_for_storage storage = Datascript_storage_protocol.db_for_storage storage let sync_indexes_to_storage ~since_tx eavt aevt avet target_storage = - let target = Datascript_storage_lmdb.lmdb target_storage in - Datascript_lmdb_index.sync_append_since_tx ~since_tx (project eavt) target; - Datascript_lmdb_index.sync_append_since_tx ~since_tx (project aevt) target; - Datascript_lmdb_index.sync_append_since_tx ~since_tx (project avet) target + Datascript_storage_protocol.sync_indexes_to_storage ~since_tx (project eavt) (project aevt) + (project avet) target_storage -let sync_removals_to_storage removed_datoms _eavt _aevt _avet target_storage = - if removed_datoms = [] then () - else - let target_lmdb = Datascript_storage_lmdb.lmdb target_storage in - let remove index = - let t = Datascript_lmdb_index.empty index target_lmdb in - ignore (Datascript_lmdb_index.remove_datoms removed_datoms t) - in - remove Eavt; - remove Aevt; - remove Avet +let sync_removals_to_storage removed_datoms eavt aevt avet target_storage = + ignore (eavt, aevt, avet); + Datascript_storage_protocol.sync_removals_to_storage removed_datoms target_storage let load_indexes_from_storage storage target_lmdb = - let source = Datascript_storage_lmdb.lmdb storage in - if source != target_lmdb then Datascript_storage_lmdb.sync_indexes source target_lmdb + Datascript_storage_protocol.load_indexes_from_storage storage target_lmdb let empty index lmdb = Datascript_lmdb_index.empty index lmdb |> inject let of_sorted_list index datoms lmdb = Datascript_lmdb_index.of_sorted_list index datoms lmdb |> inject @@ -65,7 +54,6 @@ let fold_slice f init ?from_ ?to_ ?cmp t = Datascript_lmdb_index.fold_slice f init ?from_ ?to_ ?cmp (project t) let find_first_slice ?from_ ?to_ ?cmp t = Datascript_lmdb_index.find_first_slice ?from_ ?to_ ?cmp (project t) - let fold_attr_prefix f init t attr = Datascript_lmdb_index.fold_attr_prefix f init (project t) attr let slice ?from_ ?to_ ?cmp t = Datascript_lmdb_index.slice ?from_ ?to_ ?cmp (project t) diff --git a/impl/platform/jsoo/storage.ml b/impl/platform/jsoo/storage.ml index fb36caa..b93592e 100644 --- a/impl/platform/jsoo/storage.ml +++ b/impl/platform/jsoo/storage.ml @@ -4,25 +4,22 @@ module Index = Index type restore_context = { next_db_uid : unit -> int } -let memory_storage = Datascript_storage_lmdb.memory_storage +let memory_storage = Datascript_storage_protocol.memory_storage +let ensure_live = Datascript_storage_protocol.ensure_live +let kind_of = Datascript_storage_protocol.kind_of let store ?storage db = match storage, db.storage_ref with | Some target_storage, _ | None, Some target_storage -> - let target_lmdb = Index.lmdb_for_storage target_storage in - if Index.db_of db.eavt_index != target_lmdb then ( - let _, _, stored_max_tx, _ = - Datascript_storage_lmdb.restore_meta (Datascript_storage_lmdb.lmdb target_storage) - in + if not (Index.same_storage_db target_storage (Index.db_of db.eavt_index)) then ( + let _, _, stored_max_tx, _ = Datascript_storage_protocol.restore_meta target_storage in Index.sync_indexes_to_storage ~since_tx:stored_max_tx db.eavt_index db.aevt_index db.avet_index target_storage); - Datascript_storage_lmdb.store_db target_storage db + Datascript_storage_protocol.store_db target_storage db | None, None -> invalid_arg "db has no attached storage" let restore_root_snapshot storage = - let schema, max_eid, max_tx, duplicate_datoms = - Datascript_storage_lmdb.restore_meta (Datascript_storage_lmdb.lmdb storage) - in + let schema, max_eid, max_tx, duplicate_datoms = Datascript_storage_protocol.restore_meta storage in let lmdb, _ = Index.create_lmdb None in Index.load_indexes_from_storage storage lmdb; Some @@ -33,9 +30,7 @@ let restore_root_snapshot storage = } let restore context storage = - let schema, max_eid, max_tx, duplicate_datoms = - Datascript_storage_lmdb.restore_meta (Datascript_storage_lmdb.lmdb storage) - in + let schema, max_eid, max_tx, duplicate_datoms = Datascript_storage_protocol.restore_meta storage in let schema = Schema.validate_schema schema in let lmdb, _ = Index.create_lmdb None in Index.load_indexes_from_storage storage lmdb; @@ -93,19 +88,8 @@ let restore context storage = ; tx_fns = [] } -let storage_addresses storage = storage.storage_list_addresses () let storage (db : db) = db.storage_ref -let storage_root_addresses storage = storage.storage_list_addresses () - -let addresses dbs = - dbs - |> List.concat_map (fun db -> - match db.storage_ref with - | None -> [] - | Some storage -> storage_root_addresses storage) - |> List.sort_uniq compare - let settings (_db : db) = [ "branching-factor", Int 32 ; "ref-type", Keyword "weak" diff --git a/impl/platform/melange/dune b/impl/platform/melange/dune index 917d3df..83d8be6 100644 --- a/impl/platform/melange/dune +++ b/impl/platform/melange/dune @@ -3,10 +3,6 @@ (public_name datascript-ocaml-melange) (implements datascript) (modes melange) - (libraries - melange.js - lmdb_db_melange - lmdb_index_melange - storage_lmdb_melange) + (libraries melange.js lmdb_db_melange lmdb_index_melange storage_melange) (preprocess (pps melange.ppx))) diff --git a/impl/platform/melange/index.ml b/impl/platform/melange/index.ml index c38a442..d307c5d 100644 --- a/impl/platform/melange/index.ml +++ b/impl/platform/melange/index.ml @@ -9,37 +9,26 @@ type t = index_set type 'a seq = 'a Datascript_lmdb_index.seq type lmdb = Datascript_lmdb_db.t -let create_lmdb storage = - match storage with - | Some storage -> (Datascript_storage_lmdb.lmdb storage, Some storage) - | None -> (Datascript_lmdb_db.create_temp (), None) +let same_storage_db storage index_lmdb = + Datascript_storage_protocol.same_storage_db storage index_lmdb + +let create_lmdb storage = Datascript_storage_protocol.create_index_db storage let lmdb_of lmdb = lmdb let db_of t = Datascript_lmdb_index.db_of (project t) -let lmdb_for_storage storage = Datascript_storage_lmdb.lmdb storage +let lmdb_for_storage storage = Datascript_storage_protocol.db_for_storage storage let sync_indexes_to_storage ~since_tx eavt aevt avet target_storage = - let target = Datascript_storage_lmdb.lmdb target_storage in - Datascript_lmdb_index.sync_append_since_tx ~since_tx (project eavt) target; - Datascript_lmdb_index.sync_append_since_tx ~since_tx (project aevt) target; - Datascript_lmdb_index.sync_append_since_tx ~since_tx (project avet) target + Datascript_storage_protocol.sync_indexes_to_storage ~since_tx (project eavt) (project aevt) + (project avet) target_storage -let sync_removals_to_storage removed_datoms _eavt _aevt _avet target_storage = - if removed_datoms = [] then () - else - let target_lmdb = Datascript_storage_lmdb.lmdb target_storage in - let remove index = - let t = Datascript_lmdb_index.empty index target_lmdb in - ignore (Datascript_lmdb_index.remove_datoms removed_datoms t) - in - remove Eavt; - remove Aevt; - remove Avet +let sync_removals_to_storage removed_datoms eavt aevt avet target_storage = + ignore (eavt, aevt, avet); + Datascript_storage_protocol.sync_removals_to_storage removed_datoms target_storage let load_indexes_from_storage storage target_lmdb = - let source = Datascript_storage_lmdb.lmdb storage in - if source != target_lmdb then Datascript_storage_lmdb.sync_indexes source target_lmdb + Datascript_storage_protocol.load_indexes_from_storage storage target_lmdb let empty index lmdb = Datascript_lmdb_index.empty index lmdb |> inject let of_sorted_list index datoms lmdb = Datascript_lmdb_index.of_sorted_list index datoms lmdb |> inject @@ -65,7 +54,6 @@ let fold_slice f init ?from_ ?to_ ?cmp t = Datascript_lmdb_index.fold_slice f init ?from_ ?to_ ?cmp (project t) let find_first_slice ?from_ ?to_ ?cmp t = Datascript_lmdb_index.find_first_slice ?from_ ?to_ ?cmp (project t) - let fold_attr_prefix f init t attr = Datascript_lmdb_index.fold_attr_prefix f init (project t) attr let slice ?from_ ?to_ ?cmp t = Datascript_lmdb_index.slice ?from_ ?to_ ?cmp (project t) diff --git a/impl/platform/melange/storage.ml b/impl/platform/melange/storage.ml index fb36caa..b93592e 100644 --- a/impl/platform/melange/storage.ml +++ b/impl/platform/melange/storage.ml @@ -4,25 +4,22 @@ module Index = Index type restore_context = { next_db_uid : unit -> int } -let memory_storage = Datascript_storage_lmdb.memory_storage +let memory_storage = Datascript_storage_protocol.memory_storage +let ensure_live = Datascript_storage_protocol.ensure_live +let kind_of = Datascript_storage_protocol.kind_of let store ?storage db = match storage, db.storage_ref with | Some target_storage, _ | None, Some target_storage -> - let target_lmdb = Index.lmdb_for_storage target_storage in - if Index.db_of db.eavt_index != target_lmdb then ( - let _, _, stored_max_tx, _ = - Datascript_storage_lmdb.restore_meta (Datascript_storage_lmdb.lmdb target_storage) - in + if not (Index.same_storage_db target_storage (Index.db_of db.eavt_index)) then ( + let _, _, stored_max_tx, _ = Datascript_storage_protocol.restore_meta target_storage in Index.sync_indexes_to_storage ~since_tx:stored_max_tx db.eavt_index db.aevt_index db.avet_index target_storage); - Datascript_storage_lmdb.store_db target_storage db + Datascript_storage_protocol.store_db target_storage db | None, None -> invalid_arg "db has no attached storage" let restore_root_snapshot storage = - let schema, max_eid, max_tx, duplicate_datoms = - Datascript_storage_lmdb.restore_meta (Datascript_storage_lmdb.lmdb storage) - in + let schema, max_eid, max_tx, duplicate_datoms = Datascript_storage_protocol.restore_meta storage in let lmdb, _ = Index.create_lmdb None in Index.load_indexes_from_storage storage lmdb; Some @@ -33,9 +30,7 @@ let restore_root_snapshot storage = } let restore context storage = - let schema, max_eid, max_tx, duplicate_datoms = - Datascript_storage_lmdb.restore_meta (Datascript_storage_lmdb.lmdb storage) - in + let schema, max_eid, max_tx, duplicate_datoms = Datascript_storage_protocol.restore_meta storage in let schema = Schema.validate_schema schema in let lmdb, _ = Index.create_lmdb None in Index.load_indexes_from_storage storage lmdb; @@ -93,19 +88,8 @@ let restore context storage = ; tx_fns = [] } -let storage_addresses storage = storage.storage_list_addresses () let storage (db : db) = db.storage_ref -let storage_root_addresses storage = storage.storage_list_addresses () - -let addresses dbs = - dbs - |> List.concat_map (fun db -> - match db.storage_ref with - | None -> [] - | Some storage -> storage_root_addresses storage) - |> List.sort_uniq compare - let settings (_db : db) = [ "branching-factor", Int 32 ; "ref-type", Keyword "weak" diff --git a/impl/platform/native/dune b/impl/platform/native/dune index ea3584c..b589ad8 100644 --- a/impl/platform/native/dune +++ b/impl/platform/native/dune @@ -3,9 +3,4 @@ (public_name datascript-ocaml-native) (implements datascript) (modes native byte) - (libraries - str - unix - lmdb_db_native - lmdb_index_native - storage_lmdb_native)) + (libraries str unix lmdb_db_native lmdb_index_native storage_native)) diff --git a/impl/platform/native/index.ml b/impl/platform/native/index.ml index d1a4996..d307c5d 100644 --- a/impl/platform/native/index.ml +++ b/impl/platform/native/index.ml @@ -9,37 +9,26 @@ type t = index_set type 'a seq = 'a Datascript_lmdb_index.seq type lmdb = Datascript_lmdb_db.t -let create_lmdb storage = - match storage with - | Some storage -> (Datascript_storage_lmdb.lmdb storage, Some storage) - | None -> (Datascript_lmdb_db.create_temp (), None) +let same_storage_db storage index_lmdb = + Datascript_storage_protocol.same_storage_db storage index_lmdb + +let create_lmdb storage = Datascript_storage_protocol.create_index_db storage let lmdb_of lmdb = lmdb let db_of t = Datascript_lmdb_index.db_of (project t) -let lmdb_for_storage storage = Datascript_storage_lmdb.lmdb storage +let lmdb_for_storage storage = Datascript_storage_protocol.db_for_storage storage let sync_indexes_to_storage ~since_tx eavt aevt avet target_storage = - let target = Datascript_storage_lmdb.lmdb target_storage in - Datascript_lmdb_index.sync_append_since_tx ~since_tx (project eavt) target; - Datascript_lmdb_index.sync_append_since_tx ~since_tx (project aevt) target; - Datascript_lmdb_index.sync_append_since_tx ~since_tx (project avet) target + Datascript_storage_protocol.sync_indexes_to_storage ~since_tx (project eavt) (project aevt) + (project avet) target_storage -let sync_removals_to_storage removed_datoms _eavt _aevt _avet target_storage = - if removed_datoms = [] then () - else - let target_lmdb = Datascript_storage_lmdb.lmdb target_storage in - let remove index = - let t = Datascript_lmdb_index.empty index target_lmdb in - ignore (Datascript_lmdb_index.remove_datoms removed_datoms t) - in - remove Eavt; - remove Aevt; - remove Avet +let sync_removals_to_storage removed_datoms eavt aevt avet target_storage = + ignore (eavt, aevt, avet); + Datascript_storage_protocol.sync_removals_to_storage removed_datoms target_storage let load_indexes_from_storage storage target_lmdb = - let source = Datascript_storage_lmdb.lmdb storage in - if source != target_lmdb then Datascript_storage_lmdb.sync_indexes source target_lmdb + Datascript_storage_protocol.load_indexes_from_storage storage target_lmdb let empty index lmdb = Datascript_lmdb_index.empty index lmdb |> inject let of_sorted_list index datoms lmdb = Datascript_lmdb_index.of_sorted_list index datoms lmdb |> inject diff --git a/impl/platform/native/storage.ml b/impl/platform/native/storage.ml index fb36caa..b93592e 100644 --- a/impl/platform/native/storage.ml +++ b/impl/platform/native/storage.ml @@ -4,25 +4,22 @@ module Index = Index type restore_context = { next_db_uid : unit -> int } -let memory_storage = Datascript_storage_lmdb.memory_storage +let memory_storage = Datascript_storage_protocol.memory_storage +let ensure_live = Datascript_storage_protocol.ensure_live +let kind_of = Datascript_storage_protocol.kind_of let store ?storage db = match storage, db.storage_ref with | Some target_storage, _ | None, Some target_storage -> - let target_lmdb = Index.lmdb_for_storage target_storage in - if Index.db_of db.eavt_index != target_lmdb then ( - let _, _, stored_max_tx, _ = - Datascript_storage_lmdb.restore_meta (Datascript_storage_lmdb.lmdb target_storage) - in + if not (Index.same_storage_db target_storage (Index.db_of db.eavt_index)) then ( + let _, _, stored_max_tx, _ = Datascript_storage_protocol.restore_meta target_storage in Index.sync_indexes_to_storage ~since_tx:stored_max_tx db.eavt_index db.aevt_index db.avet_index target_storage); - Datascript_storage_lmdb.store_db target_storage db + Datascript_storage_protocol.store_db target_storage db | None, None -> invalid_arg "db has no attached storage" let restore_root_snapshot storage = - let schema, max_eid, max_tx, duplicate_datoms = - Datascript_storage_lmdb.restore_meta (Datascript_storage_lmdb.lmdb storage) - in + let schema, max_eid, max_tx, duplicate_datoms = Datascript_storage_protocol.restore_meta storage in let lmdb, _ = Index.create_lmdb None in Index.load_indexes_from_storage storage lmdb; Some @@ -33,9 +30,7 @@ let restore_root_snapshot storage = } let restore context storage = - let schema, max_eid, max_tx, duplicate_datoms = - Datascript_storage_lmdb.restore_meta (Datascript_storage_lmdb.lmdb storage) - in + let schema, max_eid, max_tx, duplicate_datoms = Datascript_storage_protocol.restore_meta storage in let schema = Schema.validate_schema schema in let lmdb, _ = Index.create_lmdb None in Index.load_indexes_from_storage storage lmdb; @@ -93,19 +88,8 @@ let restore context storage = ; tx_fns = [] } -let storage_addresses storage = storage.storage_list_addresses () let storage (db : db) = db.storage_ref -let storage_root_addresses storage = storage.storage_list_addresses () - -let addresses dbs = - dbs - |> List.concat_map (fun db -> - match db.storage_ref with - | None -> [] - | Some storage -> storage_root_addresses storage) - |> List.sort_uniq compare - let settings (_db : db) = [ "branching-factor", Int 32 ; "ref-type", Keyword "weak" diff --git a/impl/storage.mli b/impl/storage.mli index 0bc203b..80a34af 100644 --- a/impl/storage.mli +++ b/impl/storage.mli @@ -3,11 +3,11 @@ open Datascript_types type restore_context = { next_db_uid : unit -> int } val memory_storage : unit -> storage +val ensure_live : storage -> unit +val kind_of : storage -> storage_kind val store : ?storage:storage -> db -> unit val restore_root_snapshot : storage -> serializable_db option val restore : restore_context -> storage -> db option -val storage_addresses : storage -> storage_address list val storage : db -> storage option -val addresses : db list -> storage_address list val settings : db -> (attr * value) list val collect_garbage : storage -> unit diff --git a/impl/tx_visibility.ml b/impl/tx_visibility.ml index 9420208..a765207 100644 --- a/impl/tx_visibility.ml +++ b/impl/tx_visibility.ml @@ -50,12 +50,23 @@ let datoms_filter datoms = flush_previous (); List.rev !result -let apply_view bounds datoms = +let schema_has_no_history schema attr = + match List.assoc_opt attr schema with + | Some { no_history = true; _ } -> true + | _ -> false + +let apply_view schema bounds datoms = let visible = List.filter (visible_at_tx bounds) datoms in - if bounds.history then visible else datoms_filter visible + if bounds.history then + let no_history, historical = + List.partition (fun d -> schema_has_no_history schema d.a) visible + in + datoms_filter no_history @ historical + else + datoms_filter visible -let filter_seq bounds seq = +let filter_seq schema bounds seq = let datoms = Seq.fold_left (fun acc datom -> datom :: acc) [] seq |> List.rev in - apply_view bounds datoms |> List.to_seq + apply_view schema bounds datoms |> List.to_seq diff --git a/impl/tx_visibility.mli b/impl/tx_visibility.mli index 444d99c..5a5fcd2 100644 --- a/impl/tx_visibility.mli +++ b/impl/tx_visibility.mli @@ -10,9 +10,10 @@ val default_bounds : tx -> view_bounds val visible_at_tx : view_bounds -> datom -> bool -(** Resolve current facts from an ascending datom stream up to [view_bounds]. *) -val apply_view : view_bounds -> datom list -> datom list +(** Resolve facts from an ascending datom stream up to [view_bounds]. + When [history] is true, [no_history] attrs still project to current facts only. *) +val apply_view : schema -> view_bounds -> datom list -> datom list val datoms_filter : datom list -> datom list -val filter_seq : view_bounds -> datom Seq.t -> datom Seq.t +val filter_seq : schema -> view_bounds -> datom Seq.t -> datom Seq.t diff --git a/lmdb/datascript_lmdb.ml b/lmdb/datascript_lmdb.ml index 300cfe3..ec93269 100644 --- a/lmdb/datascript_lmdb.ml +++ b/lmdb/datascript_lmdb.ml @@ -1,89 +1,22 @@ module Ds = Datascript -open Lmdb type session = - { path : string - ; env : Env.t - ; map : (string, string, [ `Uni ]) Map.t + { lmdb : Datascript_lmdb_db.t ; mutable closed : bool } -let kvs_map_name = "kvs" -let default_map_size = 1024 * 1024 * 1024 - -let lock_path path = path ^ "-lock" - -let remove_files path = - if Sys.file_exists path then Sys.remove path; - let lock = lock_path path in - if Sys.file_exists lock then Sys.remove lock - let ensure_open session = if session.closed then invalid_arg "LMDB session is closed" -let open_env db_path = - Env.(create Rw ~flags:Flags.no_subdir ~map_size:default_map_size ~max_maps:8 db_path) - -let open_map env = - try Map.open_existing Nodup ~key:Conv.string ~value:Conv.string ~name:kvs_map_name env - with Not_found -> - Map.create Nodup ~key:Conv.string ~value:Conv.string ~name:kvs_map_name env - let open_session db_path = - remove_files db_path; - let env = open_env db_path in - let map = open_map env in - { path = db_path; env; map; closed = false } + let lmdb = Datascript_lmdb_db.open_path db_path in + { lmdb; closed = false } let close session = if not session.closed then ( - Map.close session.map; - Env.sync session.env; - Env.close session.env; - session.closed <- true) - -let encode_payload payload = Datascript_sqlite_codec.encode_storage_payload payload + session.closed <- true; + Datascript_lmdb_db.close session.lmdb) -let decode_payload content = Datascript_sqlite_codec.decode_storage_payload content - -let storage session : Ds.storage = - { storage_store = - (fun entries -> - ensure_open session; - ignore - (Txn.go Rw session.env (fun txn -> - List.iter - (fun (address, payload) -> - Map.set ~txn session.map address (encode_payload payload)) - entries; - None))) - ; storage_restore = - (fun address -> - ensure_open session; - (try Some (Map.get session.map address |> decode_payload) - with Not_found -> None)) - ; storage_list_addresses = - (fun () -> - ensure_open session; - let addresses = ref [] in - let next = Map.to_dispenser session.map in - let rec loop () = - match next () with - | None -> () - | Some (address, _) -> - addresses := address :: !addresses; - loop () - in - loop (); - List.rev !addresses) - ; storage_delete = - (fun addresses -> - ensure_open session; - ignore - (Txn.go Rw session.env (fun txn -> - List.iter - (fun address -> - try Map.remove ~txn session.map address with Not_found -> ()) - addresses; - None))) - } +let storage session = + ensure_open session; + Datascript_storage_lmdb_plugin.wrap_lmdb ~check_live:(fun () -> ensure_open session) session.lmdb diff --git a/lmdb/datascript_storage_lmdb_plugin.ml b/lmdb/datascript_storage_lmdb_plugin.ml new file mode 100644 index 0000000..d4583bd --- /dev/null +++ b/lmdb/datascript_storage_lmdb_plugin.ml @@ -0,0 +1,34 @@ +open Datascript_types + +let backend_of_lmdb lmdb = + let restore_meta () = Datascript_storage_lmdb.restore_meta lmdb in + let store_meta db = Datascript_storage_lmdb.store_meta lmdb db in + let sync_indexes_to_storage ~since_tx eavt aevt avet = + Datascript_lmdb_index.sync_append_since_tx ~since_tx eavt lmdb; + Datascript_lmdb_index.sync_append_since_tx ~since_tx aevt lmdb; + Datascript_lmdb_index.sync_append_since_tx ~since_tx avet lmdb + in + let sync_removals_to_storage removed_datoms = + let remove index = + let t = Datascript_lmdb_index.empty index lmdb in + ignore (Datascript_lmdb_index.remove_datoms removed_datoms t) + in + remove Eavt; + remove Aevt; + remove Avet + in + let load_indexes_from_storage target_lmdb = + if lmdb != target_lmdb then Datascript_storage_lmdb.sync_indexes lmdb target_lmdb + in + { + Datascript_storage_protocol.kind = storage_kind_lmdb + ; restore_meta + ; store_meta + ; sync_indexes_to_storage + ; sync_removals_to_storage + ; load_indexes_from_storage + ; index_db = Share_index_db lmdb + } + +let wrap_lmdb ?check_live db = + Datascript_storage_protocol.register_backend (backend_of_lmdb db) ?check_live () diff --git a/lmdb/datascript_storage_lmdb_plugin.mli b/lmdb/datascript_storage_lmdb_plugin.mli new file mode 100644 index 0000000..16f92bb --- /dev/null +++ b/lmdb/datascript_storage_lmdb_plugin.mli @@ -0,0 +1,3 @@ +open Datascript_types + +val wrap_lmdb : ?check_live:(unit -> unit) -> Datascript_lmdb_db.t -> storage diff --git a/lmdb/dune b/lmdb/dune index 38bda56..2db373d 100644 --- a/lmdb/dune +++ b/lmdb/dune @@ -8,16 +8,11 @@ (library (name datascript_lmdb) - (public_name datascript-ocaml-native.lmdb) + (public_name datascript-ocaml-native-lmdb) (wrapped false) (modes native) - (modules datascript_lmdb) - (libraries - datascript-ocaml-native - datascript_sqlite - lmdb_db_native - storage_lmdb_native - lmdb)) + (modules datascript_lmdb datascript_storage_lmdb_plugin) + (libraries datascript-ocaml-native storage_native lmdb_db_native)) (subdir native) (subdir melange) diff --git a/lmdb/melange/dune b/lmdb/melange/dune index dadefd3..06573ba 100644 --- a/lmdb/melange/dune +++ b/lmdb/melange/dune @@ -15,11 +15,3 @@ (modes melange) (modules datascript_lmdb_index) (libraries datascript_lmdb_codec lmdb_db_melange)) - -(library - (name storage_lmdb_melange) - (public_name datascript-ocaml-melange.storage-lmdb) - (wrapped false) - (modes melange) - (modules datascript_storage_lmdb) - (libraries datascript_lmdb_codec lmdb_db_melange datascript_types)) diff --git a/lmdb/native/dune b/lmdb/native/dune index f573531..eb696bf 100644 --- a/lmdb/native/dune +++ b/lmdb/native/dune @@ -15,11 +15,3 @@ (modes native) (modules datascript_lmdb_index) (libraries datascript_lmdb_codec lmdb_db_native)) - -(library - (name storage_lmdb_native) - (public_name datascript-ocaml-native.storage-lmdb) - (wrapped false) - (modes native) - (modules datascript_storage_lmdb) - (libraries datascript_lmdb_codec lmdb_db_native datascript_types)) diff --git a/sqlite/datascript_sqlite.ml b/sqlite/datascript_sqlite.ml index 82b6e9c..cfcb898 100644 --- a/sqlite/datascript_sqlite.ml +++ b/sqlite/datascript_sqlite.ml @@ -1,49 +1,22 @@ module Ds = Datascript type session = - { path : string + { sqlite : Datascript_sqlite_db.t ; mutable closed : bool } -external sqlite_open : string -> unit = "datascript_sqlite_open" -external sqlite_close : string -> unit = "datascript_sqlite_close" -external sqlite_store : string -> (string * string) list -> unit = "datascript_sqlite_store" -external sqlite_restore : string -> string -> string option = "datascript_sqlite_restore" -external sqlite_list_addresses : string -> string list = "datascript_sqlite_list_addresses" -external sqlite_delete : string -> string list -> unit = "datascript_sqlite_delete" - let ensure_open session = if session.closed then invalid_arg "SQLite session is closed" let open_session path = - sqlite_open path; - { path; closed = false } + let sqlite = Datascript_sqlite_db.open_path path in + { sqlite; closed = false } let close session = if not session.closed then ( - sqlite_close session.path; - session.closed <- true) + session.closed <- true; + Datascript_sqlite_db.close session.sqlite) -let storage session : Ds.storage = - { storage_store = - (fun entries -> - ensure_open session; - sqlite_store session.path - (List.map - (fun (address, payload) -> - (address, Datascript_sqlite_codec.encode payload)) - entries)) - ; storage_restore = - (fun address -> - ensure_open session; - sqlite_restore session.path address - |> Option.map Datascript_sqlite_codec.decode) - ; storage_list_addresses = - (fun () -> - ensure_open session; - sqlite_list_addresses session.path) - ; storage_delete = - (fun addresses -> - ensure_open session; - sqlite_delete session.path addresses) - } +let storage session = + ensure_open session; + Datascript_storage_sqlite_plugin.wrap_sqlite ~check_live:(fun () -> ensure_open session) session.sqlite diff --git a/sqlite/datascript_storage_sqlite.ml b/sqlite/datascript_storage_sqlite.ml new file mode 100644 index 0000000..ae738e4 --- /dev/null +++ b/sqlite/datascript_storage_sqlite.ml @@ -0,0 +1,52 @@ +open Datascript_types + +type t = Datascript_sqlite_db.t + +let create_temp () = Datascript_sqlite_db.create_temp () +let open_path path = Datascript_sqlite_db.open_path path +let close = Datascript_sqlite_db.close +let sync = Datascript_sqlite_db.sync + +let store_meta sqlite_db db = + Datascript_storage_meta.store_meta (Datascript_sqlite_db.meta_set sqlite_db) db; + sync sqlite_db + +let restore_meta sqlite_db = + Datascript_storage_meta.restore_meta (Datascript_sqlite_db.meta_get sqlite_db) + +let copy_indexes_to_lmdb from_db to_lmdb = + Datascript_lmdb_db.with_write_txn to_lmdb (fun txn -> + List.iter + (fun index -> + Datascript_sqlite_db.fold_index index from_db (fun key value -> + Datascript_lmdb_db.put_index_txn index txn to_lmdb key value)) + [ Eavt; Aevt; Avet ]) + +let decode_entry index key value = + let datom = Datascript_lmdb_codec.decode_datom_key index key in + let payload = Datascript_lmdb_codec.decode_datom_value value in + { datom with v = payload.v } + +let remove_datom index sqlite_db datom = + let key = Datascript_lmdb_codec.encode_datom_key index datom in + Datascript_sqlite_db.remove_index index sqlite_db key + +let sync_append_since_tx ~since_tx index source_lmdb target_db = + Datascript_sqlite_db.with_write_txn target_db (fun () -> + Datascript_lmdb_db.fold_index index source_lmdb (fun key value -> + let datom = decode_entry index key value in + if datom.tx > since_tx then ( + let key = Datascript_lmdb_codec.encode_datom_key index datom in + let value = Datascript_lmdb_codec.encode_datom_value datom in + Datascript_sqlite_db.put_index_txn index target_db key value))) + +let remove_datoms datoms target_db = + if datoms = [] then () + else + Datascript_sqlite_db.with_write_txn target_db (fun () -> + List.iter + (fun datom -> + remove_datom Eavt target_db datom; + remove_datom Aevt target_db datom; + remove_datom Avet target_db datom) + datoms) diff --git a/sqlite/datascript_storage_sqlite_plugin.ml b/sqlite/datascript_storage_sqlite_plugin.ml new file mode 100644 index 0000000..9ee380b --- /dev/null +++ b/sqlite/datascript_storage_sqlite_plugin.ml @@ -0,0 +1,28 @@ +open Datascript_types + +let backend_of_sqlite sqlite = + let restore_meta () = Datascript_storage_sqlite.restore_meta sqlite in + let store_meta db = Datascript_storage_sqlite.store_meta sqlite db in + let sync_indexes_to_storage ~since_tx eavt aevt avet = + Datascript_storage_sqlite.sync_append_since_tx ~since_tx Eavt (Datascript_lmdb_index.db_of eavt) sqlite; + Datascript_storage_sqlite.sync_append_since_tx ~since_tx Aevt (Datascript_lmdb_index.db_of aevt) sqlite; + Datascript_storage_sqlite.sync_append_since_tx ~since_tx Avet (Datascript_lmdb_index.db_of avet) sqlite + in + let sync_removals_to_storage removed_datoms = + Datascript_storage_sqlite.remove_datoms removed_datoms sqlite + in + let load_indexes_from_storage target_lmdb = + Datascript_storage_sqlite.copy_indexes_to_lmdb sqlite target_lmdb + in + { + Datascript_storage_protocol.kind = storage_kind_sqlite + ; restore_meta + ; store_meta + ; sync_indexes_to_storage + ; sync_removals_to_storage + ; load_indexes_from_storage + ; index_db = Separate_index_db + } + +let wrap_sqlite ?check_live db = + Datascript_storage_protocol.register_backend (backend_of_sqlite db) ?check_live () diff --git a/sqlite/datascript_storage_sqlite_plugin.mli b/sqlite/datascript_storage_sqlite_plugin.mli new file mode 100644 index 0000000..45351e4 --- /dev/null +++ b/sqlite/datascript_storage_sqlite_plugin.mli @@ -0,0 +1,3 @@ +open Datascript_types + +val wrap_sqlite : ?check_live:(unit -> unit) -> Datascript_sqlite_db.t -> storage diff --git a/sqlite/dune b/sqlite/dune index 576111a..0ff82e1 100644 --- a/sqlite/dune +++ b/sqlite/dune @@ -1,10 +1,25 @@ +(library + (name sqlite_db_native) + (public_name datascript-ocaml-native-sqlite.db) + (wrapped false) + (modes native) + (modules datascript_sqlite_db) + (libraries sqlite3 datascript_types)) + (library (name datascript_sqlite) - (public_name datascript-ocaml-native.sqlite) + (public_name datascript-ocaml-native-sqlite) (wrapped false) - (foreign_stubs - (language c) - (names datascript_sqlite_stubs)) - (c_library_flags - (:standard -L%{env:DATASCRIPT_SQLITE_LIB_DIR=.} -lsqlite3)) - (libraries datascript-ocaml-native melange-transit-native)) + (modules + datascript_sqlite + datascript_sqlite_codec + datascript_storage_sqlite + datascript_storage_sqlite_plugin) + (libraries + datascript-ocaml-native + storage_native + lmdb_db_native + lmdb_index_native + datascript_lmdb_codec + sqlite_db_native + melange-transit-native)) diff --git a/storage/dune b/storage/dune new file mode 100644 index 0000000..81e1ab4 --- /dev/null +++ b/storage/dune @@ -0,0 +1 @@ +(include_subdirs unqualified) diff --git a/storage/melange/datascript_storage_lmdb.ml b/storage/melange/datascript_storage_lmdb.ml new file mode 100644 index 0000000..ecce615 --- /dev/null +++ b/storage/melange/datascript_storage_lmdb.ml @@ -0,0 +1,22 @@ +open Datascript_types + +type t = Datascript_lmdb_db.t + +let create_temp () = Datascript_lmdb_db.create_temp () +let open_path path = Datascript_lmdb_db.open_path path +let close = Datascript_lmdb_db.close +let sync = Datascript_lmdb_db.sync + +let store_meta lmdb db = + Datascript_storage_meta.store_meta (Datascript_lmdb_db.meta_set lmdb) db; + sync lmdb + +let restore_meta lmdb = Datascript_storage_meta.restore_meta (Datascript_lmdb_db.meta_get lmdb) + +let sync_indexes from_lmdb to_lmdb = + if from_lmdb != to_lmdb then + Datascript_lmdb_db.with_write_txn to_lmdb (fun txn -> + List.iter + (fun index -> + Datascript_lmdb_db.copy_index_txn index txn from_lmdb to_lmdb) + [ Eavt; Aevt; Avet ]) diff --git a/storage/melange/datascript_storage_meta.ml b/storage/melange/datascript_storage_meta.ml new file mode 100644 index 0000000..a9709f0 --- /dev/null +++ b/storage/melange/datascript_storage_meta.ml @@ -0,0 +1,47 @@ +open Datascript_types + +let meta_schema_key = "schema" +let meta_max_eid_key = "max_eid" +let meta_max_tx_key = "max_tx" +let meta_duplicates_key = "duplicate_datoms" + +let encode_int value = + Datascript_lmdb_codec.encode_datoms + [ { e = value; a = ""; v = Nil; tx = 0; added = true } ] + +let decode_int bytes = + match Datascript_lmdb_codec.decode_datoms bytes with + | { e; _ } :: _ -> e + | [] -> 0 + +type meta_get = string -> string option +type meta_set = string -> string -> unit + +let store_meta meta_set db = + meta_set meta_schema_key (Datascript_lmdb_codec.encode_schema db.schema); + meta_set meta_max_eid_key (encode_int db.max_eid); + meta_set meta_max_tx_key (encode_int db.max_tx); + meta_set meta_duplicates_key (Datascript_lmdb_codec.encode_datoms db.duplicate_datoms) + +let restore_meta meta_get = + let schema = + match meta_get meta_schema_key with + | None -> [] + | Some bytes -> Datascript_lmdb_codec.decode_schema bytes + in + let max_eid = + match meta_get meta_max_eid_key with + | None -> 0 + | Some bytes -> decode_int bytes + in + let max_tx = + match meta_get meta_max_tx_key with + | None -> 0x20000000 + | Some bytes -> decode_int bytes + in + let duplicate_datoms = + match meta_get meta_duplicates_key with + | None -> [] + | Some bytes -> Datascript_lmdb_codec.decode_datoms bytes + in + schema, max_eid, max_tx, duplicate_datoms diff --git a/storage/melange/datascript_storage_protocol.ml b/storage/melange/datascript_storage_protocol.ml new file mode 100644 index 0000000..5dc9a7f --- /dev/null +++ b/storage/melange/datascript_storage_protocol.ml @@ -0,0 +1,164 @@ +open Datascript_types + +type storage_index_db = + | Share_index_db of Datascript_lmdb_db.t + | Separate_index_db + +type storage_backend = { + kind : storage_kind + ; restore_meta : unit -> schema * entity_id * tx * datom list + ; store_meta : db -> unit + ; sync_indexes_to_storage : + since_tx:tx -> + Datascript_lmdb_index.t -> + Datascript_lmdb_index.t -> + Datascript_lmdb_index.t -> + unit + ; sync_removals_to_storage : datom list -> unit + ; load_indexes_from_storage : Datascript_lmdb_db.t -> unit + ; index_db : storage_index_db +} + +type backend_state = { + check_live : (unit -> unit) option + ; backend : storage_backend +} + +let registry : (int, backend_state) Hashtbl.t = Hashtbl.create 16 +let next_id = ref 0 + +let register_backend backend ?check_live () = + incr next_id; + let id = !next_id in + let state = { backend; check_live } in + Hashtbl.replace registry id state; + Storage_handle id + +let id_of = function + | Storage_handle id -> id + +let state_of storage = + match Hashtbl.find_opt registry (id_of storage) with + | Some state -> state + | None -> invalid_arg "unknown storage handle" + +let backend_of storage = (state_of storage).backend + +let ensure_live storage = + let state = state_of storage in + Option.iter (fun check -> check ()) state.check_live + +let kind_of storage = (backend_of storage).kind + +let memory_backend lmdb = + let restore_meta () = Datascript_storage_lmdb.restore_meta lmdb in + let store_meta db = Datascript_storage_lmdb.store_meta lmdb db in + let sync_indexes_to_storage ~since_tx eavt aevt avet = + Datascript_lmdb_index.sync_append_since_tx ~since_tx eavt lmdb; + Datascript_lmdb_index.sync_append_since_tx ~since_tx aevt lmdb; + Datascript_lmdb_index.sync_append_since_tx ~since_tx avet lmdb + in + let sync_removals_to_storage removed_datoms = + let remove index = + let t = Datascript_lmdb_index.empty index lmdb in + ignore (Datascript_lmdb_index.remove_datoms removed_datoms t) + in + remove Eavt; + remove Aevt; + remove Avet + in + let load_indexes_from_storage target_lmdb = + if lmdb != target_lmdb then Datascript_storage_lmdb.sync_indexes lmdb target_lmdb + in + { + kind = storage_kind_memory + ; restore_meta + ; store_meta + ; sync_indexes_to_storage + ; sync_removals_to_storage + ; load_indexes_from_storage + ; index_db = Share_index_db lmdb + } + +let memory_storage () = + register_backend (memory_backend (Datascript_lmdb_db.create_temp ())) () + +let restore_meta storage = + ensure_live storage; + (backend_of storage).restore_meta () + +let store_db storage db = + ensure_live storage; + (backend_of storage).store_meta db + +let sync_indexes_to_storage ~since_tx eavt aevt avet storage = + ensure_live storage; + (backend_of storage).sync_indexes_to_storage ~since_tx eavt aevt avet + +let sync_removals_to_storage removed_datoms storage = + ensure_live storage; + (backend_of storage).sync_removals_to_storage removed_datoms + +let load_indexes_from_storage storage target_lmdb = + ensure_live storage; + (backend_of storage).load_indexes_from_storage target_lmdb + +let db_for_storage storage = + ensure_live storage; + match (backend_of storage).index_db with + | Share_index_db db -> db + | Separate_index_db -> + invalid_arg "storage backend uses a separate index db, expected shared LMDB index db" + +let same_storage_db storage index_lmdb = + ensure_live storage; + match (backend_of storage).index_db with + | Share_index_db db -> db == index_lmdb + | Separate_index_db -> false + +let create_index_db storage = + match storage with + | None -> (Datascript_lmdb_db.create_temp (), None) + | Some storage -> + ensure_live storage; + (match (backend_of storage).index_db with + | Share_index_db db -> (db, Some storage) + | Separate_index_db -> (Datascript_lmdb_db.create_temp (), Some storage)) + +let backend_of_lmdb lmdb = + let restore_meta () = Datascript_storage_lmdb.restore_meta lmdb in + let store_meta db = Datascript_storage_lmdb.store_meta lmdb db in + let sync_indexes_to_storage ~since_tx eavt aevt avet = + Datascript_lmdb_index.sync_append_since_tx ~since_tx eavt lmdb; + Datascript_lmdb_index.sync_append_since_tx ~since_tx aevt lmdb; + Datascript_lmdb_index.sync_append_since_tx ~since_tx avet lmdb + in + let sync_removals_to_storage removed_datoms = + let remove index = + let t = Datascript_lmdb_index.empty index lmdb in + ignore (Datascript_lmdb_index.remove_datoms removed_datoms t) + in + remove Eavt; + remove Aevt; + remove Avet + in + let load_indexes_from_storage target_lmdb = + if lmdb != target_lmdb then Datascript_storage_lmdb.sync_indexes lmdb target_lmdb + in + { + kind = storage_kind_lmdb + ; restore_meta + ; store_meta + ; sync_indexes_to_storage + ; sync_removals_to_storage + ; load_indexes_from_storage + ; index_db = Share_index_db lmdb + } + +let wrap_lmdb ?check_live db = + register_backend (backend_of_lmdb db) ?check_live () + +let register_plugin = register_backend + +type plugin = storage_backend +type index_db_mode = storage_index_db diff --git a/storage/melange/datascript_storage_protocol.mli b/storage/melange/datascript_storage_protocol.mli new file mode 100644 index 0000000..e24bb0f --- /dev/null +++ b/storage/melange/datascript_storage_protocol.mli @@ -0,0 +1,40 @@ +open Datascript_types + +type storage_index_db = + | Share_index_db of Datascript_lmdb_db.t + | Separate_index_db + +type storage_backend = { + kind : storage_kind + ; restore_meta : unit -> schema * entity_id * tx * datom list + ; store_meta : db -> unit + ; sync_indexes_to_storage : + since_tx:tx -> + Datascript_lmdb_index.t -> + Datascript_lmdb_index.t -> + Datascript_lmdb_index.t -> + unit + ; sync_removals_to_storage : datom list -> unit + ; load_indexes_from_storage : Datascript_lmdb_db.t -> unit + ; index_db : storage_index_db +} + +val kind_of : storage -> storage_kind +val ensure_live : storage -> unit +val memory_storage : unit -> storage +val register_backend : storage_backend -> ?check_live:(unit -> unit) -> unit -> storage +val restore_meta : storage -> schema * entity_id * tx * datom list +val store_db : storage -> db -> unit +val sync_indexes_to_storage : + since_tx:tx -> Datascript_lmdb_index.t -> Datascript_lmdb_index.t -> Datascript_lmdb_index.t -> storage -> unit +val sync_removals_to_storage : datom list -> storage -> unit +val load_indexes_from_storage : storage -> Datascript_lmdb_db.t -> unit +val db_for_storage : storage -> Datascript_lmdb_db.t +val same_storage_db : storage -> Datascript_lmdb_db.t -> bool +val create_index_db : storage option -> Datascript_lmdb_db.t * storage option + +type plugin = storage_backend +type index_db_mode = storage_index_db +val register_plugin : storage_backend -> ?check_live:(unit -> unit) -> unit -> storage + +val wrap_lmdb : ?check_live:(unit -> unit) -> Datascript_lmdb_db.t -> storage diff --git a/storage/melange/dune b/storage/melange/dune new file mode 100644 index 0000000..5e771a8 --- /dev/null +++ b/storage/melange/dune @@ -0,0 +1,12 @@ +(include_subdirs no) + +(library + (name storage_melange) + (public_name datascript-ocaml-melange.storage) + (wrapped false) + (modes melange) + (modules + datascript_storage_meta + datascript_storage_lmdb + datascript_storage_protocol) + (libraries datascript_lmdb_codec lmdb_db_melange lmdb_index_melange datascript_types)) diff --git a/storage/native/datascript_storage_lmdb.ml b/storage/native/datascript_storage_lmdb.ml new file mode 100644 index 0000000..ecce615 --- /dev/null +++ b/storage/native/datascript_storage_lmdb.ml @@ -0,0 +1,22 @@ +open Datascript_types + +type t = Datascript_lmdb_db.t + +let create_temp () = Datascript_lmdb_db.create_temp () +let open_path path = Datascript_lmdb_db.open_path path +let close = Datascript_lmdb_db.close +let sync = Datascript_lmdb_db.sync + +let store_meta lmdb db = + Datascript_storage_meta.store_meta (Datascript_lmdb_db.meta_set lmdb) db; + sync lmdb + +let restore_meta lmdb = Datascript_storage_meta.restore_meta (Datascript_lmdb_db.meta_get lmdb) + +let sync_indexes from_lmdb to_lmdb = + if from_lmdb != to_lmdb then + Datascript_lmdb_db.with_write_txn to_lmdb (fun txn -> + List.iter + (fun index -> + Datascript_lmdb_db.copy_index_txn index txn from_lmdb to_lmdb) + [ Eavt; Aevt; Avet ]) diff --git a/storage/native/datascript_storage_meta.ml b/storage/native/datascript_storage_meta.ml new file mode 100644 index 0000000..a9709f0 --- /dev/null +++ b/storage/native/datascript_storage_meta.ml @@ -0,0 +1,47 @@ +open Datascript_types + +let meta_schema_key = "schema" +let meta_max_eid_key = "max_eid" +let meta_max_tx_key = "max_tx" +let meta_duplicates_key = "duplicate_datoms" + +let encode_int value = + Datascript_lmdb_codec.encode_datoms + [ { e = value; a = ""; v = Nil; tx = 0; added = true } ] + +let decode_int bytes = + match Datascript_lmdb_codec.decode_datoms bytes with + | { e; _ } :: _ -> e + | [] -> 0 + +type meta_get = string -> string option +type meta_set = string -> string -> unit + +let store_meta meta_set db = + meta_set meta_schema_key (Datascript_lmdb_codec.encode_schema db.schema); + meta_set meta_max_eid_key (encode_int db.max_eid); + meta_set meta_max_tx_key (encode_int db.max_tx); + meta_set meta_duplicates_key (Datascript_lmdb_codec.encode_datoms db.duplicate_datoms) + +let restore_meta meta_get = + let schema = + match meta_get meta_schema_key with + | None -> [] + | Some bytes -> Datascript_lmdb_codec.decode_schema bytes + in + let max_eid = + match meta_get meta_max_eid_key with + | None -> 0 + | Some bytes -> decode_int bytes + in + let max_tx = + match meta_get meta_max_tx_key with + | None -> 0x20000000 + | Some bytes -> decode_int bytes + in + let duplicate_datoms = + match meta_get meta_duplicates_key with + | None -> [] + | Some bytes -> Datascript_lmdb_codec.decode_datoms bytes + in + schema, max_eid, max_tx, duplicate_datoms diff --git a/storage/native/datascript_storage_protocol.ml b/storage/native/datascript_storage_protocol.ml new file mode 100644 index 0000000..fc8b542 --- /dev/null +++ b/storage/native/datascript_storage_protocol.ml @@ -0,0 +1,137 @@ +open Datascript_types + +(** How a storage backend relates to the in-memory LMDB index layer. *) +type storage_index_db = + | Share_index_db of Datascript_lmdb_db.t + | Separate_index_db + +(** Callback bundle for a pluggable storage backend (LMDB file, SQLite, PostgreSQL, ...). *) +type storage_backend = { + kind : storage_kind + ; restore_meta : unit -> schema * entity_id * tx * datom list + ; store_meta : db -> unit + ; sync_indexes_to_storage : + since_tx:tx -> + Datascript_lmdb_index.t -> + Datascript_lmdb_index.t -> + Datascript_lmdb_index.t -> + unit + ; sync_removals_to_storage : datom list -> unit + ; load_indexes_from_storage : Datascript_lmdb_db.t -> unit + ; index_db : storage_index_db +} + +type backend_state = { + check_live : (unit -> unit) option + ; backend : storage_backend +} + +let registry : (int, backend_state) Hashtbl.t = Hashtbl.create 16 +let next_id = ref 0 + +let register_backend backend ?check_live () = + incr next_id; + let id = !next_id in + let state = { backend; check_live } in + Hashtbl.replace registry id state; + Storage_handle id + +let id_of = function + | Storage_handle id -> id + +let state_of storage = + match Hashtbl.find_opt registry (id_of storage) with + | Some state -> state + | None -> invalid_arg "unknown storage handle" + +let backend_of storage = (state_of storage).backend + +let ensure_live storage = + let state = state_of storage in + Option.iter (fun check -> check ()) state.check_live + +let kind_of storage = (backend_of storage).kind + +let memory_backend lmdb = + let restore_meta () = Datascript_storage_lmdb.restore_meta lmdb in + let store_meta db = Datascript_storage_lmdb.store_meta lmdb db in + let sync_indexes_to_storage ~since_tx eavt aevt avet = + Datascript_lmdb_index.sync_append_since_tx ~since_tx eavt lmdb; + Datascript_lmdb_index.sync_append_since_tx ~since_tx aevt lmdb; + Datascript_lmdb_index.sync_append_since_tx ~since_tx avet lmdb + in + let sync_removals_to_storage removed_datoms = + let remove index = + let t = Datascript_lmdb_index.empty index lmdb in + ignore (Datascript_lmdb_index.remove_datoms removed_datoms t) + in + remove Eavt; + remove Aevt; + remove Avet + in + let load_indexes_from_storage target_lmdb = + if lmdb != target_lmdb then Datascript_storage_lmdb.sync_indexes lmdb target_lmdb + in + { + kind = storage_kind_memory + ; restore_meta + ; store_meta + ; sync_indexes_to_storage + ; sync_removals_to_storage + ; load_indexes_from_storage + ; index_db = Share_index_db lmdb + } + +let memory_storage () = + register_backend (memory_backend (Datascript_lmdb_db.create_temp ())) () + +let restore_meta storage = + ensure_live storage; + (backend_of storage).restore_meta () + +let store_db storage db = + ensure_live storage; + (backend_of storage).store_meta db + +let sync_indexes_to_storage ~since_tx eavt aevt avet storage = + ensure_live storage; + (backend_of storage).sync_indexes_to_storage ~since_tx eavt aevt avet + +let sync_removals_to_storage removed_datoms storage = + ensure_live storage; + (backend_of storage).sync_removals_to_storage removed_datoms + +let load_indexes_from_storage storage target_lmdb = + ensure_live storage; + (backend_of storage).load_indexes_from_storage target_lmdb + +let db_for_storage storage = + ensure_live storage; + match (backend_of storage).index_db with + | Share_index_db db -> db + | Separate_index_db -> + invalid_arg "storage backend uses a separate index db, expected shared LMDB index db" + +let same_storage_db storage index_lmdb = + ensure_live storage; + match (backend_of storage).index_db with + | Share_index_db db -> db == index_lmdb + | Separate_index_db -> false + +let create_index_db storage = + match storage with + | None -> (Datascript_lmdb_db.create_temp (), None) + | Some storage -> + ensure_live storage; + (match (backend_of storage).index_db with + | Share_index_db db -> (db, Some storage) + | Separate_index_db -> (Datascript_lmdb_db.create_temp (), Some storage)) + +(** Backwards-compatible alias. *) +let register_plugin = register_backend + +(** Backwards-compatible alias. *) +type plugin = storage_backend + +(** Backwards-compatible alias. *) +type index_db_mode = storage_index_db diff --git a/storage/native/datascript_storage_protocol.mli b/storage/native/datascript_storage_protocol.mli new file mode 100644 index 0000000..9ebf073 --- /dev/null +++ b/storage/native/datascript_storage_protocol.mli @@ -0,0 +1,51 @@ +open Datascript_types + +(** How a storage backend relates to the in-memory LMDB index layer. + + - [Share_index_db lmdb]: index datoms live in the same LMDB env as storage + (memory and file LMDB backends). + - [Separate_index_db]: storage keeps its own index tables and copies into a + temp LMDB index on restore (SQLite and similar backends). *) +type storage_index_db = + | Share_index_db of Datascript_lmdb_db.t + | Separate_index_db + +(** Callback bundle for a pluggable storage backend. + + Third-party packages (LMDB file, SQLite, PostgreSQL, ...) register an + implementation via {!register_backend}. Use any unique {!storage_kind} string, + for example ["pg"]. *) +type storage_backend = { + kind : storage_kind + ; restore_meta : unit -> schema * entity_id * tx * datom list + ; store_meta : db -> unit + ; sync_indexes_to_storage : + since_tx:tx -> + Datascript_lmdb_index.t -> + Datascript_lmdb_index.t -> + Datascript_lmdb_index.t -> + unit + ; sync_removals_to_storage : datom list -> unit + ; load_indexes_from_storage : Datascript_lmdb_db.t -> unit + ; index_db : storage_index_db +} + +val kind_of : storage -> storage_kind +val ensure_live : storage -> unit +val memory_storage : unit -> storage + +val register_backend : storage_backend -> ?check_live:(unit -> unit) -> unit -> storage +val restore_meta : storage -> schema * entity_id * tx * datom list +val store_db : storage -> db -> unit +val sync_indexes_to_storage : + since_tx:tx -> Datascript_lmdb_index.t -> Datascript_lmdb_index.t -> Datascript_lmdb_index.t -> storage -> unit +val sync_removals_to_storage : datom list -> storage -> unit +val load_indexes_from_storage : storage -> Datascript_lmdb_db.t -> unit +val db_for_storage : storage -> Datascript_lmdb_db.t +val same_storage_db : storage -> Datascript_lmdb_db.t -> bool +val create_index_db : storage option -> Datascript_lmdb_db.t * storage option + +(** Backwards-compatible aliases. *) +type plugin = storage_backend +type index_db_mode = storage_index_db +val register_plugin : storage_backend -> ?check_live:(unit -> unit) -> unit -> storage diff --git a/storage/native/dune b/storage/native/dune new file mode 100644 index 0000000..98a0e1d --- /dev/null +++ b/storage/native/dune @@ -0,0 +1,16 @@ +(include_subdirs no) + +(library + (name storage_native) + (public_name datascript-ocaml-native.storage) + (wrapped false) + (modes native) + (modules + datascript_storage_meta + datascript_storage_lmdb + datascript_storage_protocol) + (libraries + datascript_lmdb_codec + lmdb_db_native + lmdb_index_native + datascript_types)) diff --git a/test/dune b/test/dune index b56d731..89c637a 100644 --- a/test/dune +++ b/test/dune @@ -3,6 +3,12 @@ (modules test_datascript) (libraries datascript-ocaml-native unix)) +(library + (name test_support) + (modules test_alcotest_support) + (wrapped false) + (libraries alcotest)) + (executable (name debug_cardinality) (modules debug_cardinality) @@ -36,12 +42,12 @@ (test (name test_tx_history) (modules test_tx_history) - (libraries datascript-ocaml-native)) + (libraries datascript-ocaml-native test_support alcotest)) (test (name test_purge) (modules test_purge) - (libraries datascript-ocaml-native)) + (libraries datascript-ocaml-native test_support alcotest)) (test (name test_db) @@ -151,15 +157,12 @@ (test (name test_sqlite_package) (modules test_sqlite_package) - (libraries - datascript-ocaml-native - datascript-ocaml-native.sqlite - datascript-ocaml-native.logseq-sqlite-storage)) + (libraries datascript-ocaml-native datascript-ocaml-native-sqlite test_support alcotest)) (test (name test_lmdb_package) (modules test_lmdb_package) - (libraries datascript-ocaml-native datascript-ocaml-native.lmdb)) + (libraries datascript-ocaml-native datascript-ocaml-native-lmdb test_support alcotest)) (test (name test_melange_transit_backend) @@ -209,7 +212,7 @@ (test (name test_storage) (modules test_storage) - (libraries datascript-ocaml-native unix)) + (libraries datascript-ocaml-native test_support alcotest unix)) (test (name test_upsert) diff --git a/test/test_alcotest_support.ml b/test/test_alcotest_support.ml new file mode 100644 index 0000000..7180eb8 --- /dev/null +++ b/test/test_alcotest_support.ml @@ -0,0 +1,17 @@ +open Alcotest + +let check_int label expected actual = check int label expected actual + +let check_bool label expected actual = check bool label expected actual + +let check_string_list label expected actual = check (list string) label expected actual + +let check_int_list label expected actual = check (list int) label expected actual + +let expect_invalid_arg f = + match_raises "Invalid_argument" (function Invalid_argument _ -> true | _ -> false) f + +let expect_invalid_arg_msg message f = + match_raises message + (function Invalid_argument msg when String.equal msg message -> true | _ -> false) + f diff --git a/test/test_lmdb_package.ml b/test/test_lmdb_package.ml index 403fa2a..51c727c 100644 --- a/test/test_lmdb_package.ml +++ b/test/test_lmdb_package.ml @@ -1,7 +1,8 @@ +open Alcotest open Datascript -let require condition message = - if not condition then failwith message +let check_bool = Test_alcotest_support.check_bool +let expect_invalid_arg_msg = Test_alcotest_support.expect_invalid_arg_msg let temp_db_path name = let path = Filename.temp_file name ".lmdb" in @@ -23,7 +24,7 @@ let indexed = let test_storage_roundtrip () = let path = temp_db_path "datascript-lmdb-package" in let session = Datascript_lmdb.open_session path in - let storage = Datascript_lmdb.storage session in + let storage = storage_of_handle (Datascript_lmdb.storage session) in let db = empty_db ~schema:[ "todo/id", indexed ] ~storage () in let report = transact @@ -43,26 +44,24 @@ let test_storage_roundtrip () = | Some entity -> entity | None -> failwith "expected restored todo entity" in - require - (entity_attr entity "todo/title" = Some (One_value (String "Move storage into datascript"))) - "expected restored entity title"; - require - (List.mem Storage.root_address (storage_addresses storage)) - "expected LMDB storage to contain the root address"; + check_bool "expected restored entity title" true + (entity_attr entity "todo/title" = Some (One_value (String "Move storage into datascript"))); + check_bool "expected LMDB storage backend" true (kind_of storage = storage_kind_lmdb); Datascript_lmdb.close session let test_session_close_blocks_use () = let path = temp_db_path "datascript-lmdb-session-close" in let session = Datascript_lmdb.open_session path in - let storage = Datascript_lmdb.storage session in + let storage = storage_of_handle (Datascript_lmdb.storage session) in Datascript_lmdb.close session; - match storage.storage_list_addresses () with - | _ -> failwith "expected closed LMDB session to reject storage operations" - | exception Invalid_argument message -> - require - (String.equal message "LMDB session is closed") - "expected closed session error message" + expect_invalid_arg_msg "LMDB session is closed" (fun () -> ensure_live storage) let () = - test_storage_roundtrip (); - test_session_close_blocks_use () + run "lmdb package" + [ + ( "session" + , [ + test_case "storage roundtrip" `Quick test_storage_roundtrip + ; test_case "session close blocks use" `Quick test_session_close_blocks_use + ] ) + ] diff --git a/test/test_purge.ml b/test/test_purge.ml index 7fa5c89..2e42780 100644 --- a/test/test_purge.ml +++ b/test/test_purge.ml @@ -1,5 +1,11 @@ +open Alcotest open Datascript +let check_int_list = Test_alcotest_support.check_int_list +let check_string_list = Test_alcotest_support.check_string_list +let check_bool = Test_alcotest_support.check_bool +let expect_invalid_arg = Test_alcotest_support.expect_invalid_arg + let indexed = { cardinality = One ; unique = None @@ -50,60 +56,60 @@ let setup_db () = let test_purge_datom_from_current_and_history () = let db = setup_db () in let db = db_with [ Retract (Lookup_ref ("name", String "Alice"), "age", Some (Int 25)) ] db in - if int_values db ~a:"age" ~e:1 () <> [] then failwith "Alice age should be absent after retract"; - if history_int_values db ~a:"age" ~e:1 () <> [ 25 ] then - failwith "Alice age should remain in history after retract"; + check_int_list "Alice age should be absent after retract" [] (int_values db ~a:"age" ~e:1 ()); + check_int_list "Alice age should remain in history after retract" [ 25 ] + (history_int_values db ~a:"age" ~e:1 ()); let db = db_with [ Purge (Lookup_ref ("name", String "Bob"), "age", Int 35) ] db in - if int_values db ~a:"age" ~e:2 () <> [] then failwith "Bob age should be absent after purge"; - if history_all_int_values db ~a:"age" ~e:2 () <> [] then - failwith "Bob age should be absent from history after purge"; + check_int_list "Bob age should be absent after purge" [] (int_values db ~a:"age" ~e:2 ()); + check_int_list "Bob age should be absent from history after purge" [] + (history_all_int_values db ~a:"age" ~e:2 ()); let db = db_with [ Purge (Lookup_ref ("name", String "Alice"), "age", Int 25) ] db in - if history_all_int_values db ~a:"age" ~e:1 () <> [] then - failwith "purged retracted datom should leave history" + check_int_list "purged retracted datom should leave history" [] + (history_all_int_values db ~a:"age" ~e:1 ()) let test_purge_attribute () = let db = setup_db () in let db = db_with [ PurgeAttr (Lookup_ref ("name", String "Alice"), "age") ] db in - if int_values db ~a:"age" ~e:1 () <> [] then failwith "Alice age should be absent after attribute purge"; - if history_all_int_values db ~a:"age" ~e:1 () <> [] then - failwith "Alice age should be absent from history"; - if string_values db ~a:"name" () <> [ "Alice"; "Bob" ] then failwith "Alice name should remain"; + check_int_list "Alice age should be absent after attribute purge" [] (int_values db ~a:"age" ~e:1 ()); + check_int_list "Alice age should be absent from history" [] + (history_all_int_values db ~a:"age" ~e:1 ()); + check_string_list "Alice name should remain" [ "Alice"; "Bob" ] (string_values db ~a:"name" ()); let db = setup_db () in let db = db_with [ RetractAttr (Lookup_ref ("name", String "Bob"), "age") ] db in - if int_values db ~a:"age" ~e:2 () <> [] then failwith "Bob age should be absent after retract attribute"; - if history_int_values db ~a:"age" ~e:2 () <> [ 35 ] then failwith "Bob age should remain in history"; + check_int_list "Bob age should be absent after retract attribute" [] (int_values db ~a:"age" ~e:2 ()); + check_int_list "Bob age should remain in history" [ 35 ] (history_int_values db ~a:"age" ~e:2 ()); let db = db_with [ PurgeAttr (Lookup_ref ("name", String "Bob"), "age") ] db in - if history_all_int_values db ~a:"age" ~e:2 () <> [] then failwith "Bob age should be purged from history" + check_int_list "Bob age should be purged from history" [] + (history_all_int_values db ~a:"age" ~e:2 ()) let test_purge_entity () = let db = setup_db () in let db = db_with [ PurgeEntity (Lookup_ref ("name", String "Alice")) ] db in - if string_values db ~a:"name" () <> [ "Bob" ] then failwith "Alice should be removed from current db"; - if string_values (history db) ~a:"name" () <> [ "Bob" ] then failwith "Alice should be removed from history"; + check_string_list "Alice should be removed from current db" [ "Bob" ] (string_values db ~a:"name" ()); + check_string_list "Alice should be removed from history" [ "Bob" ] + (string_values (history db) ~a:"name" ()); let db = setup_db () in let db = db_with [ RetractEntity (Lookup_ref ("name", String "Bob")) ] db in - if string_values db ~a:"name" () <> [ "Alice" ] then failwith "Bob should be retracted from current db"; - if not (List.mem "Bob" (string_values (history db) ~a:"name" ())) then - failwith "Bob should remain in history"; + check_string_list "Bob should be retracted from current db" [ "Alice" ] (string_values db ~a:"name" ()); + check_bool "Bob should remain in history" true + (List.mem "Bob" (string_values (history db) ~a:"name" ())); let db = db_with [ PurgeEntity (Lookup_ref ("name", String "Bob")) ] db in - if List.mem "Bob" (string_values (history db) ~a:"name" ()) then - failwith "Bob should be purged from history" + check_bool "Bob should be purged from history" false + (List.mem "Bob" (string_values (history db) ~a:"name" ())) let test_purge_missing_entity_fails () = let db = setup_db () in let db = db_with [ PurgeEntity (Lookup_ref ("name", String "Alice")) ] db in - (match db_with [ PurgeEntity (Lookup_ref ("name", String "Alice")) ] db with - | exception Invalid_argument message when - (try - let len = String.length "to be purged" in - String.length message >= len - && String.sub message (String.length message - len) len = "to be purged" - with _ -> false) -> - () - | _ -> failwith "expected purge of missing entity to fail") + expect_invalid_arg (fun () -> ignore (db_with [ PurgeEntity (Lookup_ref ("name", String "Alice")) ] db)) let () = - test_purge_datom_from_current_and_history (); - test_purge_attribute (); - test_purge_entity (); - test_purge_missing_entity_fails () + run "purge" + [ + ( "operations" + , [ + test_case "purge datom from current and history" `Quick test_purge_datom_from_current_and_history + ; test_case "purge attribute" `Quick test_purge_attribute + ; test_case "purge entity" `Quick test_purge_entity + ; test_case "purge missing entity fails" `Quick test_purge_missing_entity_fails + ] ) + ] diff --git a/test/test_sqlite_package.ml b/test/test_sqlite_package.ml index 9fde404..7a8e5b2 100644 --- a/test/test_sqlite_package.ml +++ b/test/test_sqlite_package.ml @@ -1,7 +1,8 @@ +open Alcotest open Datascript -let require condition message = - if not condition then failwith message +let check_bool = Test_alcotest_support.check_bool +let expect_invalid_arg_msg = Test_alcotest_support.expect_invalid_arg_msg let temp_db_path name = let path = Filename.temp_file name ".sqlite" in @@ -23,7 +24,7 @@ let indexed = let test_storage_roundtrip () = let path = temp_db_path "datascript-sqlite-package" in let session = Datascript_sqlite.open_session path in - let storage = Datascript_sqlite.storage session in + let storage = storage_of_handle (Datascript_sqlite.storage session) in let db = empty_db ~schema:[ "todo/id", indexed ] ~storage () in let report = transact @@ -43,27 +44,24 @@ let test_storage_roundtrip () = | Some entity -> entity | None -> failwith "expected restored todo entity" in - require - (entity_attr entity "todo/title" = Some (One_value (String "Move storage into datascript"))) - "expected restored entity title"; - require - (List.mem Storage.root_address (storage_addresses storage)) - "expected SQLite storage to contain the root address"; - let _packaged_logseq_reader = Logseq_sqlite_storage.inspect in + check_bool "expected restored entity title" true + (entity_attr entity "todo/title" = Some (One_value (String "Move storage into datascript"))); + check_bool "expected SQLite storage backend" true (kind_of storage = storage_kind_sqlite); Datascript_sqlite.close session let test_session_close_blocks_use () = let path = temp_db_path "datascript-sqlite-session-close" in let session = Datascript_sqlite.open_session path in - let storage = Datascript_sqlite.storage session in + let storage = storage_of_handle (Datascript_sqlite.storage session) in Datascript_sqlite.close session; - match storage.storage_list_addresses () with - | _ -> failwith "expected closed SQLite session to reject storage operations" - | exception Invalid_argument message -> - require - (String.equal message "SQLite session is closed") - "expected closed session error message" + expect_invalid_arg_msg "SQLite session is closed" (fun () -> ensure_live storage) let () = - test_storage_roundtrip (); - test_session_close_blocks_use () + run "sqlite package" + [ + ( "session" + , [ + test_case "storage roundtrip" `Quick test_storage_roundtrip + ; test_case "session close blocks use" `Quick test_session_close_blocks_use + ] ) + ] diff --git a/test/test_storage.ml b/test/test_storage.ml index c37dbbc..da96cec 100644 --- a/test/test_storage.ml +++ b/test/test_storage.ml @@ -1,19 +1,17 @@ +open Alcotest open Datascript -let failf fmt = Printf.ksprintf failwith fmt +let check_bool = Test_alcotest_support.check_bool let datoms_seq = datoms let datoms db index ?e ?a ?v ?tx () = datoms_seq db index ?e ?a ?v ?tx () |> List.of_seq -let assert_lmdb_addresses label addresses = - if addresses <> [ "lmdb" ] then - failf "%s: expected LMDB storage address [lmdb], got [%s]" label (String.concat "," addresses) - let assert_equal_triples label expected actual = let actual = List.map (fun d -> d.e, d.a, d.v) actual in - if expected <> actual then failf "%s: unexpected datoms" label + if expected <> actual then + Alcotest.failf "%s: unexpected datoms" label let indexed = { cardinality = One @@ -39,7 +37,8 @@ let test_storage__test_basics () = let storage = memory_storage () in let db = small_db () in store ~storage db; - assert_lmdb_addresses "store writes LMDB storage address" (storage_addresses storage); + check_bool "memory storage should use Memory backend" true + (kind_of storage = storage_kind_memory); (match restore storage with | None -> failwith "restore should read stored db" | Some restored -> @@ -47,17 +46,17 @@ let test_storage__test_basics () = "restore returns stored facts" [ 1, "name", String "Ivan"; 2, "name", String "Oleg"; 3, "name", String "Petr" ] (datoms restored Eavt ()); - if List.assoc_opt "storage" (settings restored) <> Some (Bool true) then - failwith "settings should expose storage attachment"); + check_bool "settings should expose storage attachment" true + (List.assoc_opt "storage" (settings restored) = Some (Bool true))); let attached_storage = memory_storage () in let attached = empty_db ~schema:[ "name", indexed ] ~storage:attached_storage () in store attached; (match restore attached_storage with | None -> failwith "store should use db-attached storage" | Some restored -> - if schema restored <> [ "name", indexed ] then failwith "restore should preserve schema") + check_bool "restore should preserve schema" true (schema restored = [ "name", indexed ])) -let test_storage__test_restored_db_addresses () = +let test_storage__test_restored_db_has_storage () = let storage = memory_storage () in let db = small_db () in store ~storage db; @@ -66,12 +65,11 @@ let test_storage__test_restored_db_addresses () = | Some db -> db | None -> failwith "restore should read stored db" in - assert_lmdb_addresses "addresses should include restored db live nodes" (addresses [ restored ]) + check_bool "restored db should remain storage-backed" true (Option.is_some restored.storage_ref) let test_storage__test_conn () = let storage = memory_storage () in let conn = create_conn ~schema:[ "name", indexed ] ~storage () in - assert_lmdb_addresses "storage-backed create_conn stores LMDB address" (storage_addresses storage); ignore (transact_conn conn [ Add (Entity_id 1, "name", String "Ivan") ]); ignore (transact_conn conn [ Add (Entity_id 2, "name", String "Oleg") ]); let restored = @@ -111,23 +109,29 @@ let test_storage__test_multi_tx_incremental_store () = datoms restored Eavt ~a:"age" () |> List.map (fun d -> match d.v with Int n -> n | _ -> -1) in - if current_ages <> [ 31 ] then failf "restored db should see current age 31, got %S" (string_of_int (List.hd current_ages)); + Test_alcotest_support.check_int_list "restored db should see current age 31" [ 31 ] current_ages; let past = as_of tx1 restored in let past_ages = datoms past Eavt ~a:"age" () |> List.map (fun d -> match d.v with Int n -> n | _ -> -1) in - if past_ages <> [ 30 ] then failf "restored as_of should see historical age 30"; + Test_alcotest_support.check_int_list "restored as_of should see historical age 30" [ 30 ] past_ages; let hist_ages = datoms (history restored) Eavt ~a:"age" () |> List.filter (fun d -> d.added) |> List.map (fun d -> match d.v with Int n -> n | _ -> -1) |> List.sort compare in - if hist_ages <> [ 30; 31 ] then failf "restored history should expose both age assertions" + Test_alcotest_support.check_int_list "restored history should expose both age assertions" [ 30; 31 ] hist_ages let () = - test_storage__test_basics (); - test_storage__test_restored_db_addresses (); - test_storage__test_conn (); - test_storage__test_multi_tx_incremental_store () + run "storage" + [ + ( "memory" + , [ + test_case "basics" `Quick test_storage__test_basics + ; test_case "restored db has storage" `Quick test_storage__test_restored_db_has_storage + ; test_case "conn" `Quick test_storage__test_conn + ; test_case "multi tx incremental store" `Quick test_storage__test_multi_tx_incremental_store + ] ) + ] diff --git a/test/test_tx_history.ml b/test/test_tx_history.ml index 50e3e6e..2a89f12 100644 --- a/test/test_tx_history.ml +++ b/test/test_tx_history.ml @@ -1,16 +1,10 @@ +open Alcotest open Datascript -let failf fmt = Printf.ksprintf failwith fmt - -let assert_equal_int label expected actual = - if expected <> actual then failf "%s: expected %d, got %d" label expected actual - -let assert_equal_bool label expected actual = - if expected <> actual then failf "%s: expected %b, got %b" label expected actual - -let assert_equal_string_list label expected actual = - if expected <> actual then - failf "%s: expected [%s], got [%s]" label (String.concat "; " expected) (String.concat "; " actual) +let check_int = Test_alcotest_support.check_int +let check_bool = Test_alcotest_support.check_bool +let check_string_list = Test_alcotest_support.check_string_list +let expect_invalid_arg = Test_alcotest_support.expect_invalid_arg let datoms_list db index ?e ?a ?v ?tx () = datoms db index ?e ?a ?v ?tx () |> List.of_seq @@ -47,7 +41,7 @@ let int_values db ?a ?e () = |> List.sort compare let string_values db ?a ?e () = - datoms_list db ?a ?e () + datoms_list db Eavt ?a ?e () |> List.map (fun d -> match d.v with String s -> s | _ -> "") |> List.sort compare @@ -57,11 +51,6 @@ let history_asserted_values db ?a ?e () = |> List.map (fun d -> match d.v with Int n -> string_of_int n | String s -> s | _ -> "?") |> List.sort compare -let expect_invalid_arg f = - match f () with - | exception Invalid_argument _ -> () - | _ -> failwith "expected Invalid_argument" - let test_basis_tx_tracks_latest_transaction () = let db = empty_db ~schema:[ "age", indexed ] () @@ -70,8 +59,8 @@ let test_basis_tx_tracks_latest_transaction () = let tx0 = basis_tx db in let db = db_with [ Add (Entity_id 1, "age", Int 30) ] db in let tx1 = basis_tx db in - assert_equal_int "basis advances across transactions" 1 (if tx1 > tx0 then 1 else 0); - assert_equal_int "current view uses latest basis" 30 (List.hd (int_values db ~a:"age" ())); + check_int "basis advances across transactions" 1 (if tx1 > tx0 then 1 else 0); + check_int "current view uses latest basis" 30 (List.hd (int_values db ~a:"age" ())) let test_as_of_point_in_time () = let db = @@ -87,13 +76,13 @@ let test_as_of_point_in_time () = (match as_of_t past, as_of_tx past with | Some tx, Some tx' when tx = tx0 && tx' = tx0 -> () | _ -> failwith "as_of should expose as_of_t and as_of_tx"); - assert_equal_int "as_of lowers basis_tx" tx0 (basis_tx past); - assert_equal_int "as_of is a temporal view" 1 (if temporal_view past then 1 else 0); - assert_equal_bool "as_of is not history" false (is_history past); - assert_equal_string_list "as_of tx0 sees Alice age 25" [ "25" ] + check_int "as_of lowers basis_tx" tx0 (basis_tx past); + check_int "as_of is a temporal view" 1 (if temporal_view past then 1 else 0); + check_bool "as_of is not history" false (is_history past); + check_string_list "as_of tx0 sees Alice age 25" [ "25" ] (List.map string_of_int (int_values past ~e:1 ~a:"age" ())); - assert_equal_string_list "as_of tx0 sees Bob age 35" [ "35" ] - (List.map string_of_int (int_values past ~e:2 ~a:"age" ())); + check_string_list "as_of tx0 sees Bob age 35" [ "35" ] + (List.map string_of_int (int_values past ~e:2 ~a:"age" ())) let test_since_delta_is_exclusive () = let db = @@ -107,10 +96,10 @@ let test_since_delta_is_exclusive () = (match since_t delta, since_tx delta with | Some tx, Some tx' when tx = tx0 && tx' = tx0 -> () | _ -> failwith "since should expose since_t and since_tx"); - assert_equal_int "since keeps latest basis_tx" (basis_tx db) (basis_tx delta); - assert_equal_int "since is a temporal view" 1 (if temporal_view delta then 1 else 0); - assert_equal_bool "since is not history" false (is_history delta); - assert_equal_string_list "since after tx0 only sees Carol" [ "Carol" ] (string_values delta ~a:"name" ()); + check_int "since keeps latest basis_tx" (basis_tx db) (basis_tx delta); + check_int "since is a temporal view" 1 (if temporal_view delta then 1 else 0); + check_bool "since is not history" false (is_history delta); + check_string_list "since after tx0 only sees Carol" [ "Carol" ] (string_values delta ~a:"name" ()) let test_history_exposes_assertions_and_retractions () = let db = @@ -120,21 +109,19 @@ let test_history_exposes_assertions_and_retractions () = in let db = db_with [ Add (Entity_id 1, "age", Int 30) ] db in let db = db_with [ Retract (Entity_id 1, "name", Some (String "Alice")) ] db in - assert_equal_string_list "current db keeps latest age only" [ "30" ] + check_string_list "current db keeps latest age only" [ "30" ] (List.map string_of_int (int_values db ~a:"age" ())); - assert_equal_string_list "current db drops retracted name" [] (string_values db ~a:"name" ()); + check_string_list "current db drops retracted name" [] (string_values db ~a:"name" ()); let hist = history db in - assert_equal_bool "history enables history flag" true (is_history hist); - assert_equal_int "history is temporal" 1 (if temporal_view hist then 1 else 0); - assert_equal_string_list "history keeps asserted ages" [ "25"; "30" ] (history_asserted_values hist ~a:"age" ()); + check_bool "history enables history flag" true (is_history hist); + check_int "history is temporal" 1 (if temporal_view hist then 1 else 0); + check_string_list "history keeps asserted ages" [ "25"; "30" ] (history_asserted_values hist ~a:"age" ()); let retracted_names = datoms_list hist Eavt ~a:"name" () |> List.filter (fun d -> not d.added) |> List.map (fun d -> match d.v with String s -> s | _ -> "") in - if retracted_names <> [ "Alice" ] then - failf "history should expose retraction datoms, got [%s]" (String.concat "; " retracted_names); - () + check_string_list "history exposes retraction datoms" [ "Alice" ] retracted_names let test_history_survives_entity_retraction () = let db = @@ -146,16 +133,17 @@ let test_history_survives_entity_retraction () = let db = db_with [ Add (Entity_id 1, "age", Int 30) ] db in let tx1 = basis_tx db in let db = db_with [ RetractEntity (Entity_id 1) ] db in - assert_equal_string_list "retracted entity absent from current db" [] (int_values db ~e:1 ~a:"age" ()); + check_string_list "retracted entity absent from current db" [] + (List.map string_of_int (int_values db ~e:1 ~a:"age" ())); let hist = history db in - assert_equal_string_list "history after retraction keeps age trail" [ "25"; "30" ] + check_string_list "history after retraction keeps age trail" [ "25"; "30" ] (history_asserted_values hist ~e:1 ~a:"age" ()); let past = as_of tx0 hist in - assert_equal_string_list "history + as_of tx0 sees bootstrap age" [ "25" ] + check_string_list "history + as_of tx0 sees bootstrap age" [ "25" ] (List.map string_of_int (int_values past ~e:1 ~a:"age" ())); let delta = since tx1 hist in - assert_equal_string_list "history + since tx1 sees post-update age only" [ "30" ] - (history_asserted_values delta ~e:1 ~a:"age" ()); + check_string_list "history + since tx1 sees post-update age only" [ "30" ] + (history_asserted_values delta ~e:1 ~a:"age" ()) let test_temporal_views_reject_transact () = let db = @@ -167,13 +155,13 @@ let test_temporal_views_reject_transact () = expect_invalid_arg (fun () -> ignore (transact (since tx0 db) [ Add (Entity_id 2, "name", String "Bob") ])); expect_invalid_arg (fun () -> - ignore (transact (history db) [ Add (Entity_id 2, "name", String "Bob") ])); + ignore (transact (history db) [ Add (Entity_id 2, "name", String "Bob") ])) let test_as_of_beyond_store_basis_fails () = let db = db_with [ Add (Entity_id 1, "name", String "Alice") ] (empty_db ~schema:[ "name", indexed ] ()) in - expect_invalid_arg (fun () -> ignore (as_of (basis_tx db + 1) db)); + expect_invalid_arg (fun () -> ignore (as_of (basis_tx db + 1) db)) let test_view_constructors_do_not_mutate_input_db () = let db = @@ -186,10 +174,12 @@ let test_view_constructors_do_not_mutate_input_db () = ignore (as_of tx0 db); ignore (since tx0 db); ignore (history db); - assert_equal_int "input basis unchanged" tx0 (basis_tx db); - assert_equal_bool "input is not temporal" false (temporal_view db); - assert_equal_bool "input is not history" false (is_history db); - if datoms_list db Eavt () <> before_datoms then failwith "view constructors must not mutate input db"; + check_int "input basis unchanged" tx0 (basis_tx db); + check_bool "input is not temporal" false (temporal_view db); + check_bool "input is not history" false (is_history db); + check_bool "view constructors must not mutate input db" + true + (datoms_list db Eavt () = before_datoms) let test_with_tx_preserves_db_before_basis () = let db = @@ -197,9 +187,9 @@ let test_with_tx_preserves_db_before_basis () = in let before_basis = basis_tx db in let report = with_tx db [ Add (Entity_id 2, "name", String "Bob") ] in - assert_equal_int "original db basis unchanged" before_basis (basis_tx db); - assert_equal_int "db_before pins old basis" before_basis (basis_tx report.db_before); - assert_equal_int "db_after advances basis" 1 (if basis_tx report.db_after > before_basis then 1 else 0); + check_int "original db basis unchanged" before_basis (basis_tx db); + check_int "db_before pins old basis" before_basis (basis_tx report.db_before); + check_int "db_after advances basis" 1 (if basis_tx report.db_after > before_basis then 1 else 0) let test_history_as_of_composition () = let db = @@ -212,8 +202,8 @@ let test_history_as_of_composition () = let tx0 = basis_tx db in let db = db_with [ Add (Entity_id 1, "age", Int 30) ] db in let bootstrap = as_of tx0 (history db) in - assert_equal_string_list "history then as_of tx0 sees bootstrap ages" [ "25"; "35" ] - (List.map string_of_int (int_values bootstrap ~a:"age" ())); + check_string_list "history then as_of tx0 sees bootstrap ages" [ "25"; "35" ] + (List.map string_of_int (int_values bootstrap ~a:"age" ())) let test_temporal_views_preserve_index_parity () = let db = @@ -226,7 +216,7 @@ let test_temporal_views_preserve_index_parity () = let past = as_of tx0 db in let eavt = datoms_list past Eavt ~e:1 ~a:"age" () |> List.map (fun d -> d.v) in let aevt = datoms_list past Aevt ~a:"age" () |> List.filter (fun d -> d.e = 1) |> List.map (fun d -> d.v) in - if eavt <> aevt then failwith "as_of view should return consistent EAVT and AEVT slices"; + check_bool "as_of view should return consistent EAVT and AEVT slices" true (eavt = aevt) let test_history_cardinality_many () = let db = @@ -238,35 +228,42 @@ let test_history_cardinality_many () = (empty_db ~schema:[ "name", unique_identity; "tag", many ] ()) in let db = db_with [ Retract (Entity_id 1, "tag", Some (String "a")) ] db in - assert_equal_string_list "current many attr keeps surviving value" [ "b" ] (string_values db ~a:"tag" ()); - assert_equal_string_list "history many attr keeps both assertions" [ "a"; "b" ] - (history_asserted_values db ~a:"tag" ()); + check_string_list "current many attr keeps surviving value" [ "b" ] (string_values db ~a:"tag" ()); + check_string_list "history many attr keeps both assertions" [ "a"; "b" ] + (history_asserted_values db ~a:"tag" ()) let test_public_api_aliases () = let db = db_with [ Add (Entity_id 1, "name", String "Alice") ] (empty_db ~schema:[ "name", indexed ] ()) in let tx0 = basis_tx db in - assert_equal_bool "plain db is not history" false (is_history db); + check_bool "plain db is not history" false (is_history db); (match (as_of_t db, as_of_tx db, since_t db, since_tx db) with | None, None, None, None -> () | _ -> failwith "plain db should not expose temporal markers"); let past = as_of tx0 db in - assert_equal_bool "is_history mirrors history flag" true (is_history (history db)); - assert_equal_bool "is_history false on as_of" false (is_history past); + check_bool "is_history mirrors history flag" true (is_history (history db)); + check_bool "is_history false on as_of" false (is_history past) let () = - test_basis_tx_tracks_latest_transaction (); - test_as_of_point_in_time (); - test_since_delta_is_exclusive (); - test_history_exposes_assertions_and_retractions (); - test_history_survives_entity_retraction (); - test_temporal_views_reject_transact (); - test_as_of_beyond_store_basis_fails (); - test_view_constructors_do_not_mutate_input_db (); - test_with_tx_preserves_db_before_basis (); - test_history_as_of_composition (); - test_temporal_views_preserve_index_parity (); - test_history_cardinality_many (); - test_public_api_aliases (); - Printf.printf "test_tx_history: ok\n" + run "tx history" + [ + ( "views" + , [ + test_case "basis_tx tracks latest transaction" `Quick test_basis_tx_tracks_latest_transaction + ; test_case "as_of point in time" `Quick test_as_of_point_in_time + ; test_case "since delta is exclusive" `Quick test_since_delta_is_exclusive + ; test_case "history exposes assertions and retractions" `Quick + test_history_exposes_assertions_and_retractions + ; test_case "history survives entity retraction" `Quick test_history_survives_entity_retraction + ; test_case "temporal views reject transact" `Quick test_temporal_views_reject_transact + ; test_case "as_of beyond store basis fails" `Quick test_as_of_beyond_store_basis_fails + ; test_case "view constructors do not mutate input db" `Quick + test_view_constructors_do_not_mutate_input_db + ; test_case "with_tx preserves db_before basis" `Quick test_with_tx_preserves_db_before_basis + ; test_case "history as_of composition" `Quick test_history_as_of_composition + ; test_case "temporal views preserve index parity" `Quick test_temporal_views_preserve_index_parity + ; test_case "history cardinality many" `Quick test_history_cardinality_many + ; test_case "public api aliases" `Quick test_public_api_aliases + ] ) + ] diff --git a/type/datascript_types.ml b/type/datascript_types.ml index b669943..700b9f9 100644 --- a/type/datascript_types.ml +++ b/type/datascript_types.ml @@ -80,14 +80,13 @@ type serializable_db = type storage_address = string -type storage_payload = Storage_session +type storage_kind = string -type storage = - { storage_store : (storage_address * storage_payload) list -> unit - ; storage_restore : storage_address -> storage_payload option - ; storage_list_addresses : unit -> storage_address list - ; storage_delete : storage_address list -> unit - } +let storage_kind_memory = "memory" +let storage_kind_lmdb = "lmdb" +let storage_kind_sqlite = "sqlite" + +type storage = Storage_handle of int type tx_value = | One_value of value From 2c04b6d562dac9695be630319fa625a5f5ee2db0 Mon Sep 17 00:00:00 2001 From: Cursor Agent Date: Thu, 27 Aug 2026 10:13:51 +0000 Subject: [PATCH 8/9] Fix tx_history since+history test to use exclusive since tx0 Since tx is exclusive (tx > since_tx), post-bootstrap age updates appear in since tx0 history, not since tx1 where age 30 was asserted. Co-authored-by: Tienson Qin --- test/test_tx_history.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/test/test_tx_history.ml b/test/test_tx_history.ml index 2a89f12..66a70a1 100644 --- a/test/test_tx_history.ml +++ b/test/test_tx_history.ml @@ -131,7 +131,7 @@ let test_history_survives_entity_retraction () = in let tx0 = basis_tx db in let db = db_with [ Add (Entity_id 1, "age", Int 30) ] db in - let tx1 = basis_tx db in + ignore (basis_tx db); let db = db_with [ RetractEntity (Entity_id 1) ] db in check_string_list "retracted entity absent from current db" [] (List.map string_of_int (int_values db ~e:1 ~a:"age" ())); @@ -141,8 +141,8 @@ let test_history_survives_entity_retraction () = let past = as_of tx0 hist in check_string_list "history + as_of tx0 sees bootstrap age" [ "25" ] (List.map string_of_int (int_values past ~e:1 ~a:"age" ())); - let delta = since tx1 hist in - check_string_list "history + since tx1 sees post-update age only" [ "30" ] + let delta = since tx0 hist in + check_string_list "history + since tx0 sees post-update age only" [ "30" ] (history_asserted_values delta ~e:1 ~a:"age" ()) let test_temporal_views_reject_transact () = From e1457b546426bec34bd703e8c7e5aa50229ecfac Mon Sep 17 00:00:00 2001 From: Cursor Agent Date: Thu, 27 Aug 2026 10:25:16 +0000 Subject: [PATCH 9/9] Remove sync_merged overlay path and fix temporal fold_datoms - Delete dead sync_merged_to_lmdb and stale lmdb root copies; storage lives under lmdb/native and storage/native only. - Route fold_datoms through datoms() on temporal views so tx-filter/history apply to full-index scans. - Replace melange LMDB db with in-memory Hashtbl backend matching native API; enable byte mode for jsoo via melange lmdb/storage libraries. - Add sqlite/datascript_sqlite_db.ml and tidy codec imports. - Update design doc and bench row_count after list_addresses removal. Co-authored-by: Tienson Qin --- bench/persistent_storage_bench.ml | 2 +- docs/design-tx-filter-history.md | 6 +- impl/db.ml | 3 + impl/platform/jsoo/dune | 2 +- lmdb/datascript_lmdb_index.ml | 106 ----------- lmdb/datascript_lmdb_index.mli | 30 ---- lmdb/datascript_storage_lmdb.ml | 80 --------- lmdb/dune | 2 +- lmdb/melange/datascript_lmdb_db.ml | 201 +++++++-------------- lmdb/melange/datascript_lmdb_db.mli | 20 +++ lmdb/melange/datascript_lmdb_index.ml | 11 -- lmdb/melange/datascript_lmdb_index.mli | 1 - lmdb/melange/datascript_storage_lmdb.ml | 101 ----------- lmdb/melange/dune | 6 +- lmdb/native/datascript_lmdb_index.ml | 11 -- lmdb/native/datascript_lmdb_index.mli | 1 - lmdb/native/datascript_storage_lmdb.ml | 101 ----------- melange/dune | 2 +- sqlite/datascript_sqlite_codec.ml | 21 ++- sqlite/datascript_sqlite_db.ml | 223 ++++++++++++++++++++++++ storage/melange/dune | 2 +- test/dune | 16 -- 22 files changed, 330 insertions(+), 618 deletions(-) delete mode 100644 lmdb/datascript_lmdb_index.ml delete mode 100644 lmdb/datascript_lmdb_index.mli delete mode 100644 lmdb/datascript_storage_lmdb.ml delete mode 100644 lmdb/melange/datascript_storage_lmdb.ml delete mode 100644 lmdb/native/datascript_storage_lmdb.ml create mode 100644 sqlite/datascript_sqlite_db.ml diff --git a/bench/persistent_storage_bench.ml b/bench/persistent_storage_bench.ml index 1dd101d..1715c35 100644 --- a/bench/persistent_storage_bench.ml +++ b/bench/persistent_storage_bench.ml @@ -78,7 +78,7 @@ let file_size path = let remove_if_exists path = if Sys.file_exists path then Sys.remove path -let row_count storage = List.length (storage_addresses storage) +let row_count _storage = 1 module type BACKEND = sig val name : string diff --git a/docs/design-tx-filter-history.md b/docs/design-tx-filter-history.md index f2a2308..0e02f06 100644 --- a/docs/design-tx-filter-history.md +++ b/docs/design-tx-filter-history.md @@ -15,8 +15,8 @@ Expose dbval-compatible `history`, `as_of`, `since`, `basis_tx`, `as_of_t`, `sin Index.t = LMDB + overlay lists add/remove → mutate overlay (O(1)) read → merge LMDB cursor + overlay hashtables - snapshot_db → Index.copy (shallow list copy) - store → sync_merged_to_lmdb (full merge + rewrite) + snapshot_db → O(1) handle copy (no overlay) + store → append tx batch + meta update (sync_append_since_tx for delta copy) ``` ## Target model @@ -104,7 +104,7 @@ Single-tx bulk append (`of_bulk` → direct LMDB write batch). No overlay stagin - **store**: append new datoms for the tx + update meta (`max_tx`, `max_eid`, schema) - **restore**: open LMDB env, read meta, rebuild attr caches from filtered scan at `max_tx` - - Remove `sync_merged_to_lmdb` clear-and-rewrite path; use `sync_append_since_tx` for delta copy when session and storage envs differ + - Storage sync uses `sync_append_since_tx` for delta copy when session and storage envs differ PSS tail replay (`impl/storage_pss.ml`) is the closest in-repo precedent for append-only persistence. diff --git a/impl/db.ml b/impl/db.ml index f40e69a..5053511 100644 --- a/impl/db.ml +++ b/impl/db.ml @@ -1070,6 +1070,9 @@ let datoms context db index ?e ?a ?v ?tx () = let fold_datoms f init context db index ?e ?a ?v ?tx () = validate_index_access context db index a; + if temporal_view db then + datoms context db index ?e ?a ?v ?tx () |> Seq.fold_left f init + else let v = resolved_value_option_for_optional_attr context db a v in let prefix_v, prefix_tx = match index, e, a, v with diff --git a/impl/platform/jsoo/dune b/impl/platform/jsoo/dune index c31ce0a..fa29b42 100644 --- a/impl/platform/jsoo/dune +++ b/impl/platform/jsoo/dune @@ -3,4 +3,4 @@ (public_name datascript-ocaml-jsoo) (implements datascript) (modes byte) - (libraries js_of_ocaml lmdb_db_native lmdb_index_native storage_native)) + (libraries js_of_ocaml lmdb_db_melange lmdb_index_melange storage_melange)) diff --git a/lmdb/datascript_lmdb_index.ml b/lmdb/datascript_lmdb_index.ml deleted file mode 100644 index 35cd033..0000000 --- a/lmdb/datascript_lmdb_index.ml +++ /dev/null @@ -1,106 +0,0 @@ -open Datascript_types - -type t = { db : Datascript_lmdb_db.t; which : index } - -type 'a seq = { cmp : datom -> datom -> int; datoms : datom list; offset : int } - -let db_of t = t.db -let make index db = { db; which = index } -let cmp_for index = Datascript_types.Compare.compare_datom index - -let decode_entry index key value = - let datom = Datascript_lmdb_codec.decode_datom_key index key in - let payload = Datascript_lmdb_codec.decode_datom_value value in - { datom with added = payload.added; v = payload.v } - -let put_datom t datom = - let key = Datascript_lmdb_codec.encode_datom_key t.which datom in - let value = Datascript_lmdb_codec.encode_datom_value datom in - Datascript_lmdb_db.put_index t.which t.db key value - -let remove_datom t datom = - let key = Datascript_lmdb_codec.encode_datom_key t.which datom in - Datascript_lmdb_db.remove_index t.which t.db key - -let empty index db = make index db - -let of_sorted_list index datoms db = - let t = empty index db in - List.iter (put_datom t) datoms; - t - -let add datom t = - put_datom t datom; - t - -let remove datom t = - remove_datom t datom; - t - -let collect_datoms t = - let datoms = ref [] in - Datascript_lmdb_db.fold_index t.which t.db (fun key value -> - datoms := decode_entry t.which key value :: !datoms); - List.rev !datoms - -let to_list t = collect_datoms t -let fold f init t = List.fold_left f init (to_list t) - -let in_range cmp lower upper datom = - let above_lower = - match lower with - | None -> true - | Some lower -> cmp datom lower >= 0 - in - let below_upper = - match upper with - | None -> true - | Some upper -> cmp datom upper <= 0 - in - above_lower && below_upper - -let make_seq ?(cmp = cmp_for Eavt) ?from_ ?to_ datoms = - let datoms = List.filter (in_range cmp from_ to_) datoms in - { cmp; datoms; offset = 0 } - -let to_seq ({ datoms; offset } as seq) = - let rec loop index () = - if index >= List.length datoms then Seq.Nil - else Seq.Cons (List.nth datoms index, loop (index + 1)) - in - loop seq.offset - -let seq t = make_seq ~cmp:(cmp_for t.which) (to_list t) - -let slice_seq ?from_ ?to_ ?cmp t = - let cmp = Option.value ~default:(cmp_for t.which) cmp in - make_seq ~cmp ?from_ ?to_ (to_list t) - -let rslice_seq ?from_ ?to_ ?cmp t = - let cmp = Option.value ~default:(cmp_for t.which) cmp in - let datoms = - to_list t - |> List.filter (fun datom -> - match from_ with - | None -> true - | Some bound -> cmp datom bound <= 0) - |> List.filter (fun datom -> - match to_ with - | None -> true - | Some bound -> cmp datom bound >= 0) - |> List.rev - in - make_seq ~cmp datoms - -let slice ?from_ ?to_ ?cmp t = slice_seq ?from_ ?to_ ?cmp t |> seq_to_list - -let seq_to_list seq = to_seq seq |> List.of_seq -let fold_seq f init seq = List.fold_left f init (seq_to_list seq) - -let seek bound seq = - let rec count index = - if index >= List.length seq.datoms then index - else if seq.cmp (List.nth seq.datoms index) bound >= 0 then index - else count (index + 1) - in - { seq with offset = count 0 } diff --git a/lmdb/datascript_lmdb_index.mli b/lmdb/datascript_lmdb_index.mli deleted file mode 100644 index 9fe6431..0000000 --- a/lmdb/datascript_lmdb_index.mli +++ /dev/null @@ -1,30 +0,0 @@ -open Datascript_types - -type t -type 'a seq - -val db_of : t -> Datascript_lmdb_db.t - -val empty : index -> Datascript_lmdb_db.t -> t -val of_sorted_list : index -> datom list -> Datascript_lmdb_db.t -> t - -val add : datom -> t -> t -val remove : datom -> t -> t - -val to_list : t -> datom list -val fold : ('acc -> datom -> 'acc) -> 'acc -> t -> 'acc - -val slice : - ?from_:datom -> ?to_:datom -> ?cmp:(datom -> datom -> int) -> t -> datom list - -val slice_seq : - ?from_:datom -> ?to_:datom -> ?cmp:(datom -> datom -> int) -> t -> datom seq - -val rslice_seq : - ?from_:datom -> ?to_:datom -> ?cmp:(datom -> datom -> int) -> t -> datom seq - -val seq : t -> datom seq -val seq_to_list : datom seq -> datom list -val fold_seq : ('acc -> datom -> 'acc) -> 'acc -> datom seq -> 'acc -val to_seq : datom seq -> datom Seq.t -val seek : datom -> datom seq -> datom seq diff --git a/lmdb/datascript_storage_lmdb.ml b/lmdb/datascript_storage_lmdb.ml deleted file mode 100644 index 405958e..0000000 --- a/lmdb/datascript_storage_lmdb.ml +++ /dev/null @@ -1,80 +0,0 @@ -open Datascript_types - -type t = Datascript_lmdb_db.t - -let registry : (storage, t) Hashtbl.t = Hashtbl.create 16 - -let lmdb storage = - match Hashtbl.find_opt registry storage with - | Some lmdb -> lmdb - | None -> invalid_arg "storage is not LMDB-backed" - -let register storage lmdb = Hashtbl.replace registry storage lmdb - -let create_temp () = Datascript_lmdb_db.create_temp () -let open_path path = Datascript_lmdb_db.open_path path -let close = Datascript_lmdb_db.close -let sync = Datascript_lmdb_db.sync - -let meta_get = Datascript_lmdb_db.meta_get -let meta_set = Datascript_lmdb_db.meta_set - -let meta_schema_key = "schema" -let meta_max_eid_key = "max_eid" -let meta_max_tx_key = "max_tx" -let meta_duplicates_key = "duplicate_datoms" - -let wrap lmdb = - let storage = - { storage_store = - (fun _entries -> sync lmdb) - ; storage_restore = - (fun address -> - if String.equal address "lmdb" then Some Storage_session else None) - ; storage_list_addresses = (fun () -> [ "lmdb" ]) - ; storage_delete = (fun _addresses -> ()) - } - in - register storage lmdb; - storage - -let memory_storage () = wrap (create_temp ()) - -let encode_int value = - Datascript_lmdb_codec.encode_datoms - [ { e = value; a = ""; v = Nil; tx = 0; added = true } ] - -let decode_int bytes = - match Datascript_lmdb_codec.decode_datoms bytes with - | { e; _ } :: _ -> e - | [] -> 0 - -let store_meta lmdb db = - meta_set lmdb meta_schema_key (Datascript_lmdb_codec.encode_schema db.schema); - meta_set lmdb meta_max_eid_key (encode_int db.max_eid); - meta_set lmdb meta_max_tx_key (encode_int db.max_tx); - meta_set lmdb meta_duplicates_key (Datascript_lmdb_codec.encode_datoms db.duplicate_datoms); - sync lmdb - -let restore_meta lmdb = - let schema = - match meta_get lmdb meta_schema_key with - | None -> [] - | Some bytes -> Datascript_lmdb_codec.decode_schema bytes - in - let max_eid = - match meta_get lmdb meta_max_eid_key with - | None -> 0 - | Some bytes -> decode_int bytes - in - let max_tx = - match meta_get lmdb meta_max_tx_key with - | None -> 0x20000000 - | Some bytes -> decode_int bytes - in - let duplicate_datoms = - match meta_get lmdb meta_duplicates_key with - | None -> [] - | Some bytes -> Datascript_lmdb_codec.decode_datoms bytes - in - schema, max_eid, max_tx, duplicate_datoms diff --git a/lmdb/dune b/lmdb/dune index 2db373d..ac72902 100644 --- a/lmdb/dune +++ b/lmdb/dune @@ -2,7 +2,7 @@ (name datascript_lmdb_codec) (public_name datascript-ocaml-native.lmdb-codec) (wrapped false) - (modes native melange) + (modes native melange byte) (modules datascript_lmdb_codec) (libraries datascript_types)) diff --git a/lmdb/melange/datascript_lmdb_db.ml b/lmdb/melange/datascript_lmdb_db.ml index 1937eaf..1aec9a0 100644 --- a/lmdb/melange/datascript_lmdb_db.ml +++ b/lmdb/melange/datascript_lmdb_db.ml @@ -1,36 +1,31 @@ open Datascript_types -open Lmdb + +module Txn = struct + type t = unit +end + +type map = (string, string) Hashtbl.t type t = { path : string - ; env : Env.t - ; eavt : (string, string, [ `Uni ]) Map.t - ; aevt : (string, string, [ `Uni ]) Map.t - ; avet : (string, string, [ `Uni ]) Map.t - ; meta : (string, string, [ `Uni ]) Map.t + ; eavt : map + ; aevt : map + ; avet : map + ; meta : map ; mutable closed : bool } -let default_map_size = 1024 * 1024 * 1024 -let lock_path path = path ^ "-lock" - -let remove_path path = - if Sys.file_exists path then Sys.remove path; - let lock = lock_path path in - if Sys.file_exists lock then Sys.remove lock +let make_map () = Hashtbl.create 256 -let open_env db_path = - Env.(create Rw ~flags:Flags.no_subdir ~map_size:default_map_size ~max_maps:8 db_path) - -let open_named_map env name = - try Map.open_existing Nodup ~key:Conv.string ~value:Conv.string ~name env - with Not_found -> Map.create Nodup ~key:Conv.string ~value:Conv.string ~name env +let remove_path _path = () let open_db path = - remove_path path; - let env = open_env path in - { path; env; eavt = open_named_map env "ds/eavt"; aevt = open_named_map env "ds/aevt" - ; avet = open_named_map env "ds/avet"; meta = open_named_map env "ds/meta"; closed = false + { path + ; eavt = make_map () + ; aevt = make_map () + ; avet = make_map () + ; meta = make_map () + ; closed = false } let open_path path = open_db path @@ -39,36 +34,16 @@ let ensure_open db = if db.closed then invalid_arg ("LMDB database is closed: " ^ db.path) let close db = - if not db.closed then ( - Map.close db.eavt; - Map.close db.aevt; - Map.close db.avet; - Map.close db.meta; - Env.sync db.env; - Env.close db.env; - db.closed <- true) + if not db.closed then db.closed <- true let temps_created = ref 0 let create_temp () = - let db = - open_db - (Filename.temp_file - ~temp_dir:(Filename.get_temp_dir_name ()) - "datascript_lmdb" - ".mdb") - in - Gc.finalise - (fun lmdb -> - if not lmdb.closed then close lmdb) - db; + let db = open_db ("melange:" ^ string_of_int !temps_created) in incr temps_created; - if !temps_created mod 64 = 0 then Gc.full_major (); db -let sync db = - ensure_open db; - Env.sync db.env +let sync _db = () let map_for_index index db = match index with @@ -78,27 +53,21 @@ let map_for_index index db = let meta_get db key = ensure_open db; - try Some (Map.get db.meta key) with Not_found -> None + Hashtbl.find_opt db.meta key let meta_set db key value = ensure_open db; - ignore - (Txn.go Rw db.env (fun txn -> - Map.set ~txn db.meta key value; - ())) + Hashtbl.replace db.meta key value let with_write_txn db f = ensure_open db; - ignore - (Txn.go Rw db.env (fun txn -> - f txn; - ())) + f () -let put_index_txn index txn db key value = - Map.set ~txn (map_for_index index db) key value +let put_index_txn index _txn db key value = + Hashtbl.replace (map_for_index index db) key value -let remove_index_txn index txn db key = - try Map.remove ~txn (map_for_index index db) key with Not_found -> () +let remove_index_txn index _txn db key = + Hashtbl.remove (map_for_index index db) key let put_index index db key value = with_write_txn db (fun txn -> put_index_txn index txn db key value) @@ -108,97 +77,53 @@ let remove_index index db key = let get_index index db key = ensure_open db; - try Some (Map.get (map_for_index index db) key) with Not_found -> None + Hashtbl.find_opt (map_for_index index db) key + +let sorted_entries map = + Hashtbl.to_seq map + |> Seq.map (fun (key, value) -> (key, value)) + |> List.of_seq + |> List.sort (fun (k1, _) (k2, _) -> String.compare k1 k2) let fold_index index db f = ensure_open db; - let map = map_for_index index db in - let next = Map.to_dispenser map in - let rec loop () = - match next () with - | None -> () - | Some (key, value) -> - f key value; - loop () - in - loop () + List.iter (fun (key, value) -> f key value) (sorted_entries (map_for_index index db)) let fold_index_prefix index db prefix f = ensure_open db; - let map = map_for_index index db in let prefix_len = String.length prefix in - (try - Cursor.go Ro map (fun cursor -> - (try ignore (Cursor.seek_range cursor prefix) with Not_found -> raise Exit); - let rec loop () = - let key, value = - try Cursor.current cursor - with Not_found -> raise Exit - in - if String.length key < prefix_len || String.sub key 0 prefix_len <> prefix then raise Exit; - f key value; - try - ignore (Cursor.next cursor); - loop () - with Not_found -> raise Exit - in - loop ()) - with Exit -> ()) + List.iter + (fun (key, value) -> + if String.length key >= prefix_len && String.sub key 0 prefix_len = prefix then f key value) + (sorted_entries (map_for_index index db)) let fold_index_range index db ?from_key ?to_key f = ensure_open db; - let map = map_for_index index db in - (try - Cursor.go Ro map (fun cursor -> - (match from_key with - | None -> ( - try ignore (Cursor.first cursor) with Not_found -> raise Exit) - | Some key -> ( - try ignore (Cursor.seek_range cursor key) with Not_found -> raise Exit)); - let rec loop () = - let key, value = - try Cursor.current cursor - with Not_found -> raise Exit - in - (match to_key with - | Some bound when String.compare key bound > 0 -> raise Exit - | _ -> ()); - f key value; - try - ignore (Cursor.next cursor); - loop () - with Not_found -> raise Exit - in - loop ()) - with Exit -> ()) + List.iter + (fun (key, value) -> + (match from_key with + | Some bound when String.compare key bound < 0 -> () + | _ -> ( + match to_key with + | Some bound when String.compare key bound > 0 -> () + | _ -> f key value))) + (sorted_entries (map_for_index index db)) let fold_index_range_until index db ?from_key ?stop f = ensure_open db; - let map = map_for_index index db in - (try - Cursor.go Ro map (fun cursor -> - (match from_key with - | None -> ( - try ignore (Cursor.first cursor) with Not_found -> raise Exit) - | Some key -> ( - try ignore (Cursor.seek_range cursor key) with Not_found -> raise Exit)); - let rec loop () = - let key, value = - try Cursor.current cursor - with Not_found -> raise Exit - in - (match stop with - | Some stop when stop key value -> raise Exit - | _ -> ()); - f key value; - try - ignore (Cursor.next cursor); - loop () - with Not_found -> raise Exit - in - loop ()) - with Exit -> ()) + let rec iter = function + | [] -> () + | (key, value) :: rest -> + (match from_key with + | Some bound when String.compare key bound < 0 -> iter rest + | _ -> ( + match stop with + | Some stop when stop key value -> () + | _ -> + f key value; + iter rest)) + in + iter (sorted_entries (map_for_index index db)) let copy_index_txn index txn from_db to_db = - fold_index index from_db (fun key value -> - put_index_txn index txn to_db key value) + fold_index index from_db (fun key value -> put_index_txn index txn to_db key value) diff --git a/lmdb/melange/datascript_lmdb_db.mli b/lmdb/melange/datascript_lmdb_db.mli index d53a813..79bacfd 100644 --- a/lmdb/melange/datascript_lmdb_db.mli +++ b/lmdb/melange/datascript_lmdb_db.mli @@ -1,5 +1,9 @@ open Datascript_types +module Txn : sig + type t = unit +end + type t val create_temp : unit -> t @@ -11,6 +15,22 @@ val remove_path : string -> unit val meta_get : t -> string -> string option val meta_set : t -> string -> string -> unit +val with_write_txn : t -> (Txn.t -> unit) -> unit +val put_index_txn : index -> Txn.t -> t -> string -> string -> unit +val remove_index_txn : index -> Txn.t -> t -> string -> unit +val copy_index_txn : index -> Txn.t -> t -> t -> unit + +val get_index : index -> t -> string -> string option val fold_index : index -> t -> (string -> string -> unit) -> unit +val fold_index_range : + index -> t -> ?from_key:string -> ?to_key:string -> (string -> string -> unit) -> unit +val fold_index_range_until : + index -> + t -> + ?from_key:string -> + ?stop:(string -> string -> bool) -> + (string -> string -> unit) -> + unit +val fold_index_prefix : index -> t -> string -> (string -> string -> unit) -> unit val put_index : index -> t -> string -> string -> unit val remove_index : index -> t -> string -> unit diff --git a/lmdb/melange/datascript_lmdb_index.ml b/lmdb/melange/datascript_lmdb_index.ml index 1eae738..0f9e482 100644 --- a/lmdb/melange/datascript_lmdb_index.ml +++ b/lmdb/melange/datascript_lmdb_index.ml @@ -140,17 +140,6 @@ let fold_stored_bounded t ?from_ ?to_ cmp f acc = if in_range cmp from_ to_ datom then acc := f !acc datom); !acc -let clear_index_txn txn index lmdb = - Datascript_lmdb_db.fold_index index lmdb (fun key _ -> - Datascript_lmdb_db.remove_index_txn index txn lmdb key) - -let sync_merged_to_lmdb t target_lmdb = - if t.db == target_lmdb then () - else - Datascript_lmdb_db.with_write_txn target_lmdb (fun txn -> - clear_index_txn txn t.which target_lmdb; - Datascript_lmdb_db.copy_index_txn t.which txn t.db target_lmdb) - let sync_append_since_tx ~since_tx t target_lmdb = if t.db == target_lmdb then () else diff --git a/lmdb/melange/datascript_lmdb_index.mli b/lmdb/melange/datascript_lmdb_index.mli index 17eb56a..2e16cef 100644 --- a/lmdb/melange/datascript_lmdb_index.mli +++ b/lmdb/melange/datascript_lmdb_index.mli @@ -16,7 +16,6 @@ val remove : datom -> t -> t val remove_datoms : datom list -> t -> t val flush : t -> t val copy : t -> t -val sync_merged_to_lmdb : t -> Datascript_lmdb_db.t -> unit val sync_append_since_tx : since_tx:tx -> t -> Datascript_lmdb_db.t -> unit val lookup : t -> datom -> datom option val to_list : t -> datom list diff --git a/lmdb/melange/datascript_storage_lmdb.ml b/lmdb/melange/datascript_storage_lmdb.ml deleted file mode 100644 index 27eb03a..0000000 --- a/lmdb/melange/datascript_storage_lmdb.ml +++ /dev/null @@ -1,101 +0,0 @@ -open Datascript_types - -type t = Datascript_lmdb_db.t - -module Storage_registry = struct - type t = storage - - let equal left right = left == right - - let hash storage = Hashtbl.hash (Obj.repr storage) -end - -module Registry = Hashtbl.Make (Storage_registry) - -let registry = Registry.create 16 - -let lmdb storage = - match Registry.find_opt registry storage with - | Some lmdb -> lmdb - | None -> invalid_arg "storage is not LMDB-backed" - -let register storage lmdb = Registry.replace registry storage lmdb - -let create_temp () = Datascript_lmdb_db.create_temp () -let open_path path = Datascript_lmdb_db.open_path path -let close = Datascript_lmdb_db.close -let sync = Datascript_lmdb_db.sync - -let meta_get = Datascript_lmdb_db.meta_get -let meta_set = Datascript_lmdb_db.meta_set - -let meta_schema_key = "schema" -let meta_max_eid_key = "max_eid" -let meta_max_tx_key = "max_tx" -let meta_duplicates_key = "duplicate_datoms" - -let wrap lmdb = - let storage = - { storage_store = - (fun _entries -> sync lmdb) - ; storage_restore = - (fun address -> - if String.equal address "lmdb" then Some Storage_session else None) - ; storage_list_addresses = (fun () -> [ "lmdb" ]) - ; storage_delete = (fun _addresses -> ()) - } - in - register storage lmdb; - storage - -let memory_storage () = wrap (create_temp ()) - -let encode_int value = - Datascript_lmdb_codec.encode_datoms - [ { e = value; a = ""; v = Nil; tx = 0; added = true } ] - -let decode_int bytes = - match Datascript_lmdb_codec.decode_datoms bytes with - | { e; _ } :: _ -> e - | [] -> 0 - -let store_meta lmdb db = - meta_set lmdb meta_schema_key (Datascript_lmdb_codec.encode_schema db.schema); - meta_set lmdb meta_max_eid_key (encode_int db.max_eid); - meta_set lmdb meta_max_tx_key (encode_int db.max_tx); - meta_set lmdb meta_duplicates_key (Datascript_lmdb_codec.encode_datoms db.duplicate_datoms); - sync lmdb - -let restore_meta lmdb = - let schema = - match meta_get lmdb meta_schema_key with - | None -> [] - | Some bytes -> Datascript_lmdb_codec.decode_schema bytes - in - let max_eid = - match meta_get lmdb meta_max_eid_key with - | None -> 0 - | Some bytes -> decode_int bytes - in - let max_tx = - match meta_get lmdb meta_max_tx_key with - | None -> 0x20000000 - | Some bytes -> decode_int bytes - in - let duplicate_datoms = - match meta_get lmdb meta_duplicates_key with - | None -> [] - | Some bytes -> Datascript_lmdb_codec.decode_datoms bytes - in - schema, max_eid, max_tx, duplicate_datoms - -let sync_indexes from_lmdb to_lmdb = - if from_lmdb != to_lmdb then - Datascript_lmdb_db.with_write_txn to_lmdb (fun txn -> - List.iter - (fun index -> - Datascript_lmdb_db.copy_index_txn index txn from_lmdb to_lmdb) - [ Eavt; Aevt; Avet ]) - -let store_db storage db = - store_meta (lmdb storage) db diff --git a/lmdb/melange/dune b/lmdb/melange/dune index 06573ba..c4b0fa2 100644 --- a/lmdb/melange/dune +++ b/lmdb/melange/dune @@ -4,14 +4,14 @@ (name lmdb_db_melange) (public_name datascript-ocaml-melange.lmdb-db) (wrapped false) - (modes melange) + (modes melange byte) (modules datascript_lmdb_db) - (libraries datascript_lmdb_codec melange.js)) + (libraries datascript_lmdb_codec)) (library (name lmdb_index_melange) (public_name datascript-ocaml-melange.lmdb-index) (wrapped false) - (modes melange) + (modes melange byte) (modules datascript_lmdb_index) (libraries datascript_lmdb_codec lmdb_db_melange)) diff --git a/lmdb/native/datascript_lmdb_index.ml b/lmdb/native/datascript_lmdb_index.ml index 1eae738..0f9e482 100644 --- a/lmdb/native/datascript_lmdb_index.ml +++ b/lmdb/native/datascript_lmdb_index.ml @@ -140,17 +140,6 @@ let fold_stored_bounded t ?from_ ?to_ cmp f acc = if in_range cmp from_ to_ datom then acc := f !acc datom); !acc -let clear_index_txn txn index lmdb = - Datascript_lmdb_db.fold_index index lmdb (fun key _ -> - Datascript_lmdb_db.remove_index_txn index txn lmdb key) - -let sync_merged_to_lmdb t target_lmdb = - if t.db == target_lmdb then () - else - Datascript_lmdb_db.with_write_txn target_lmdb (fun txn -> - clear_index_txn txn t.which target_lmdb; - Datascript_lmdb_db.copy_index_txn t.which txn t.db target_lmdb) - let sync_append_since_tx ~since_tx t target_lmdb = if t.db == target_lmdb then () else diff --git a/lmdb/native/datascript_lmdb_index.mli b/lmdb/native/datascript_lmdb_index.mli index 17eb56a..2e16cef 100644 --- a/lmdb/native/datascript_lmdb_index.mli +++ b/lmdb/native/datascript_lmdb_index.mli @@ -16,7 +16,6 @@ val remove : datom -> t -> t val remove_datoms : datom list -> t -> t val flush : t -> t val copy : t -> t -val sync_merged_to_lmdb : t -> Datascript_lmdb_db.t -> unit val sync_append_since_tx : since_tx:tx -> t -> Datascript_lmdb_db.t -> unit val lookup : t -> datom -> datom option val to_list : t -> datom list diff --git a/lmdb/native/datascript_storage_lmdb.ml b/lmdb/native/datascript_storage_lmdb.ml deleted file mode 100644 index 27eb03a..0000000 --- a/lmdb/native/datascript_storage_lmdb.ml +++ /dev/null @@ -1,101 +0,0 @@ -open Datascript_types - -type t = Datascript_lmdb_db.t - -module Storage_registry = struct - type t = storage - - let equal left right = left == right - - let hash storage = Hashtbl.hash (Obj.repr storage) -end - -module Registry = Hashtbl.Make (Storage_registry) - -let registry = Registry.create 16 - -let lmdb storage = - match Registry.find_opt registry storage with - | Some lmdb -> lmdb - | None -> invalid_arg "storage is not LMDB-backed" - -let register storage lmdb = Registry.replace registry storage lmdb - -let create_temp () = Datascript_lmdb_db.create_temp () -let open_path path = Datascript_lmdb_db.open_path path -let close = Datascript_lmdb_db.close -let sync = Datascript_lmdb_db.sync - -let meta_get = Datascript_lmdb_db.meta_get -let meta_set = Datascript_lmdb_db.meta_set - -let meta_schema_key = "schema" -let meta_max_eid_key = "max_eid" -let meta_max_tx_key = "max_tx" -let meta_duplicates_key = "duplicate_datoms" - -let wrap lmdb = - let storage = - { storage_store = - (fun _entries -> sync lmdb) - ; storage_restore = - (fun address -> - if String.equal address "lmdb" then Some Storage_session else None) - ; storage_list_addresses = (fun () -> [ "lmdb" ]) - ; storage_delete = (fun _addresses -> ()) - } - in - register storage lmdb; - storage - -let memory_storage () = wrap (create_temp ()) - -let encode_int value = - Datascript_lmdb_codec.encode_datoms - [ { e = value; a = ""; v = Nil; tx = 0; added = true } ] - -let decode_int bytes = - match Datascript_lmdb_codec.decode_datoms bytes with - | { e; _ } :: _ -> e - | [] -> 0 - -let store_meta lmdb db = - meta_set lmdb meta_schema_key (Datascript_lmdb_codec.encode_schema db.schema); - meta_set lmdb meta_max_eid_key (encode_int db.max_eid); - meta_set lmdb meta_max_tx_key (encode_int db.max_tx); - meta_set lmdb meta_duplicates_key (Datascript_lmdb_codec.encode_datoms db.duplicate_datoms); - sync lmdb - -let restore_meta lmdb = - let schema = - match meta_get lmdb meta_schema_key with - | None -> [] - | Some bytes -> Datascript_lmdb_codec.decode_schema bytes - in - let max_eid = - match meta_get lmdb meta_max_eid_key with - | None -> 0 - | Some bytes -> decode_int bytes - in - let max_tx = - match meta_get lmdb meta_max_tx_key with - | None -> 0x20000000 - | Some bytes -> decode_int bytes - in - let duplicate_datoms = - match meta_get lmdb meta_duplicates_key with - | None -> [] - | Some bytes -> Datascript_lmdb_codec.decode_datoms bytes - in - schema, max_eid, max_tx, duplicate_datoms - -let sync_indexes from_lmdb to_lmdb = - if from_lmdb != to_lmdb then - Datascript_lmdb_db.with_write_txn to_lmdb (fun txn -> - List.iter - (fun index -> - Datascript_lmdb_db.copy_index_txn index txn from_lmdb to_lmdb) - [ Eavt; Aevt; Avet ]) - -let store_db storage db = - store_meta (lmdb storage) db diff --git a/melange/dune b/melange/dune index 9e13622..3405fdb 100644 --- a/melange/dune +++ b/melange/dune @@ -1,6 +1,6 @@ (library (name datascript_melange_storage) - (public_name datascript-ocaml-melange.storage) + (public_name datascript-ocaml-melange.logseq-storage-codec) (modes melange) (enabled_if (= %{context_name} default)) (libraries diff --git a/sqlite/datascript_sqlite_codec.ml b/sqlite/datascript_sqlite_codec.ml index 0617ff6..0899bf6 100644 --- a/sqlite/datascript_sqlite_codec.ml +++ b/sqlite/datascript_sqlite_codec.ml @@ -1,8 +1,6 @@ -module Ds = Datascript +open Datascript_types module Transit = Transit_native.Transit.Json -open Ds - type ref_type = | Strong | Weak @@ -30,7 +28,7 @@ type compat_payload = | Compat_tail of datom list list | Compat_session -let schema_attr_default : Ds.schema_attr = +let schema_attr_default : schema_attr = { cardinality = One; unique = None; @@ -201,7 +199,7 @@ let schema_of_transit = function | _ -> [] let rec value_to_transit = function - | Ds.Nil -> Transit.Null + | Nil -> Transit.Null | Int value -> Transit.Int value | Float value -> Transit.Float value | String value -> Transit.String value @@ -228,7 +226,7 @@ let rec value_to_transit = function | Ref_to _ -> invalid_arg "storage payload cannot contain unresolved refs" let rec value_of_transit = function - | Transit.Null -> Ds.Nil + | Transit.Null -> Nil | Bool value -> Bool value | String value -> String value | Int value -> Int value @@ -258,7 +256,7 @@ let rec value_of_transit = function | Tagged (tag, value) -> Vector [ String tag; value_of_transit value ] let datom_to_transit datom = - let tx = if datom.Ds.added then datom.tx else -datom.tx in + let tx = if datom.added then datom.tx else -datom.tx in Transit.Array [ Transit.Int datom.e; Transit.Keyword datom.a; value_to_transit datom.v; Transit.Int tx ] let int_of_transit label value = @@ -275,7 +273,7 @@ let datom_of_transit = function | None -> invalid_arg "datom attr must be a Transit keyword" in let tx = int_of_transit "datom tx" tx in - { Ds.e; a; v = value_of_transit value; tx = abs tx; added = tx >= 0 } + { e; a; v = value_of_transit value; tx = abs tx; added = tx >= 0 } | _ -> invalid_arg "storage datom must be [e a v tx]" let datoms_to_transit datoms = Transit.Array (List.map datom_to_transit datoms) @@ -368,11 +366,12 @@ let payload_of_transit = function let encode payload = payload |> payload_to_transit |> Transit.to_string ~mode:Transit.Verbose let decode content = content |> Transit.of_string |> payload_of_transit -let encode_storage_payload (payload : Ds.storage_payload) = - match payload with Storage_session -> encode Compat_session +(* Legacy Logseq KVS codec helpers kept for examples/logseq_sqlite_storage.ml *) + +let encode_storage_payload () = encode Compat_session let decode_storage_payload payload = match decode payload with - | Compat_session -> Storage_session + | Compat_session -> () | Compat_root _ | Compat_node _ | Compat_tail _ -> invalid_arg "legacy PSS storage payloads are no longer supported" diff --git a/sqlite/datascript_sqlite_db.ml b/sqlite/datascript_sqlite_db.ml new file mode 100644 index 0000000..34b3c26 --- /dev/null +++ b/sqlite/datascript_sqlite_db.ml @@ -0,0 +1,223 @@ +open Datascript_types + +type t = + { path : string + ; db : Sqlite3.db + ; mutable closed : bool + } + +let table_name = function + | Eavt -> "ds_eavt" + | Aevt -> "ds_aevt" + | Avet -> "ds_avet" + +let check t sql rc = + if not (Sqlite3.Rc.is_success rc) then + invalid_arg + (Printf.sprintf "SQLite failed (%s) while running %s: %s" (Sqlite3.Rc.to_string rc) sql + (Sqlite3.errmsg t.db)) + +let ensure_open t = + if t.closed then invalid_arg ("SQLite database is closed: " ^ t.path) + +let exec_sql t sql = + ensure_open t; + check t sql (Sqlite3.exec t.db sql) + +let ensure_schema db = + List.iter + (fun index -> + exec_sql db + (Printf.sprintf + "CREATE TABLE IF NOT EXISTS %s (key BLOB PRIMARY KEY NOT NULL, value BLOB NOT NULL);" + (table_name index))) + [ Eavt; Aevt; Avet ]; + exec_sql db + "CREATE TABLE IF NOT EXISTS ds_meta (key TEXT PRIMARY KEY NOT NULL, value BLOB NOT NULL);" + +let remove_path path = + if Sys.file_exists path then Sys.remove path + +let open_db path = + remove_path path; + let db = Sqlite3.db_open path in + let t = { path; db; closed = false } in + ensure_schema t; + t + +let open_path path = open_db path + +let temps_created = ref 0 + +let close t = + if not t.closed then ( + if not (Sqlite3.db_close t.db) then invalid_arg ("failed to close SQLite database: " ^ t.path); + t.closed <- true) + +let create_temp () = + let t = + open_db + (Filename.temp_file ~temp_dir:(Filename.get_temp_dir_name ()) "datascript_sqlite" ".sqlite") + in + Gc.finalise + (fun t -> + if not t.closed then close t) + t; + incr temps_created; + if !temps_created mod 64 = 0 then Gc.full_major (); + t + +let sync t = + ensure_open t; + exec_sql t "PRAGMA synchronous = FULL;" + +let meta_get db key = + ensure_open db; + let sql = "SELECT value FROM ds_meta WHERE key = ?;" in + let stmt = Sqlite3.prepare db.db sql in + Fun.protect + ~finally:(fun () -> check db sql (Sqlite3.finalize stmt)) + (fun () -> + check db sql (Sqlite3.bind stmt 1 (Sqlite3.Data.TEXT key)); + match Sqlite3.step stmt with + | Sqlite3.Rc.ROW -> Some (Sqlite3.column_blob stmt 0) + | Sqlite3.Rc.DONE -> None + | rc -> + check db sql rc; + None) + +let meta_set db key value = + ensure_open db; + let sql = "REPLACE INTO ds_meta (key, value) VALUES (?, ?);" in + let stmt = Sqlite3.prepare db.db sql in + Fun.protect + ~finally:(fun () -> check db sql (Sqlite3.finalize stmt)) + (fun () -> + check db sql (Sqlite3.bind stmt 1 (Sqlite3.Data.TEXT key)); + check db sql (Sqlite3.bind_blob stmt 2 value); + check db sql (Sqlite3.step stmt)) + +let with_write_txn db f = + ensure_open db; + exec_sql db "BEGIN IMMEDIATE TRANSACTION;"; + (try + f (); + exec_sql db "COMMIT;" + with exn -> + (try exec_sql db "ROLLBACK;" with _ -> ()); + raise exn) + +let put_index_txn index db key value = + let sql = + Printf.sprintf "REPLACE INTO %s (key, value) VALUES (?, ?);" (table_name index) + in + let stmt = Sqlite3.prepare db.db sql in + Fun.protect + ~finally:(fun () -> check db sql (Sqlite3.finalize stmt)) + (fun () -> + check db sql (Sqlite3.bind_blob stmt 1 key); + check db sql (Sqlite3.bind_blob stmt 2 value); + check db sql (Sqlite3.step stmt)) + +let remove_index_txn index db key = + let sql = Printf.sprintf "DELETE FROM %s WHERE key = ?;" (table_name index) in + let stmt = Sqlite3.prepare db.db sql in + Fun.protect + ~finally:(fun () -> check db sql (Sqlite3.finalize stmt)) + (fun () -> + check db sql (Sqlite3.bind_blob stmt 1 key); + check db sql (Sqlite3.step stmt)) + +let put_index index db key value = + with_write_txn db (fun () -> put_index_txn index db key value) + +let remove_index index db key = with_write_txn db (fun () -> remove_index_txn index db key) + +let get_index index db key = + ensure_open db; + let sql = Printf.sprintf "SELECT value FROM %s WHERE key = ?;" (table_name index) in + let stmt = Sqlite3.prepare db.db sql in + Fun.protect + ~finally:(fun () -> check db sql (Sqlite3.finalize stmt)) + (fun () -> + check db sql (Sqlite3.bind_blob stmt 1 key); + match Sqlite3.step stmt with + | Sqlite3.Rc.ROW -> Some (Sqlite3.column_blob stmt 0) + | Sqlite3.Rc.DONE -> None + | rc -> + check db sql rc; + None) + +let fold_index index db f = + ensure_open db; + let sql = Printf.sprintf "SELECT key, value FROM %s ORDER BY key;" (table_name index) in + let stmt = Sqlite3.prepare db.db sql in + Fun.protect + ~finally:(fun () -> check db sql (Sqlite3.finalize stmt)) + (fun () -> + let rec loop () = + match Sqlite3.step stmt with + | Sqlite3.Rc.ROW -> + f (Sqlite3.column_blob stmt 0) (Sqlite3.column_blob stmt 1); + loop () + | Sqlite3.Rc.DONE -> () + | rc -> check db sql rc + in + loop ()) + +let fold_index_prefix index db prefix f = + ensure_open db; + let sql = + Printf.sprintf "SELECT key, value FROM %s WHERE key >= ? ORDER BY key;" (table_name index) + in + let stmt = Sqlite3.prepare db.db sql in + let prefix_len = String.length prefix in + Fun.protect + ~finally:(fun () -> check db sql (Sqlite3.finalize stmt)) + (fun () -> + check db sql (Sqlite3.bind_blob stmt 1 prefix); + let rec loop () = + match Sqlite3.step stmt with + | Sqlite3.Rc.ROW -> + let key = Sqlite3.column_blob stmt 0 in + if String.length key < prefix_len || String.sub key 0 prefix_len <> prefix then () + else ( + f key (Sqlite3.column_blob stmt 1); + loop ()) + | Sqlite3.Rc.DONE -> () + | rc -> check db sql rc + in + loop ()) + +let fold_index_range_until index db ?from_key ?stop f = + ensure_open db; + let sql = + match from_key with + | None -> Printf.sprintf "SELECT key, value FROM %s ORDER BY key;" (table_name index) + | Some _ -> + Printf.sprintf "SELECT key, value FROM %s WHERE key >= ? ORDER BY key;" (table_name index) + in + let stmt = Sqlite3.prepare db.db sql in + Fun.protect + ~finally:(fun () -> check db sql (Sqlite3.finalize stmt)) + (fun () -> + (match from_key with + | None -> () + | Some key -> check db sql (Sqlite3.bind_blob stmt 1 key)); + let rec loop () = + match Sqlite3.step stmt with + | Sqlite3.Rc.ROW -> + let key = Sqlite3.column_blob stmt 0 in + let value = Sqlite3.column_blob stmt 1 in + (match stop with + | Some stop when stop key value -> () + | _ -> + f key value; + loop ()) + | Sqlite3.Rc.DONE -> () + | rc -> check db sql rc + in + loop ()) + +let copy_index index from_db to_db = + fold_index index from_db (fun key value -> put_index index to_db key value) diff --git a/storage/melange/dune b/storage/melange/dune index 5e771a8..2e28473 100644 --- a/storage/melange/dune +++ b/storage/melange/dune @@ -4,7 +4,7 @@ (name storage_melange) (public_name datascript-ocaml-melange.storage) (wrapped false) - (modes melange) + (modes melange byte) (modules datascript_storage_meta datascript_storage_lmdb diff --git a/test/dune b/test/dune index 89c637a..3510aec 100644 --- a/test/dune +++ b/test/dune @@ -9,16 +9,6 @@ (wrapped false) (libraries alcotest)) -(executable - (name debug_cardinality) - (modules debug_cardinality) - (libraries datascript-ocaml-native)) - -(executable - (name debug_entity) - (modules debug_entity) - (libraries datascript-ocaml-native)) - (test (name test_lru) (modules test_lru) @@ -277,9 +267,3 @@ %{dep:cross_runtime_parity_test.sh} %{dep:cross_runtime_ocaml.exe} %{dep:../script/cross_runtime_upstream.js}))) -(executable (name debug_tuple) (modules debug_tuple) (libraries datascript-ocaml-native)) - -(executable - (name debug_query) - (modules debug_query) - (libraries datascript-ocaml-native))