diff --git a/.cursor/Dockerfile b/.cursor/Dockerfile new file mode 100644 index 0000000..a6ad294 --- /dev/null +++ b/.cursor/Dockerfile @@ -0,0 +1,39 @@ +FROM ubuntu:24.04 + +ENV DEBIAN_FRONTEND=noninteractive +ENV OPAMYES=1 + +# System packages + opam as root so /usr/bin/opam is available to every shell. +RUN apt-get update \ + && apt-get install -y --no-install-recommends \ + ca-certificates \ + curl \ + git \ + build-essential \ + pkg-config \ + bubblewrap \ + opam \ + libsqlite3-dev \ + liblmdb-dev \ + && rm -rf /var/lib/apt/lists/* + +# Node.js 24 for js_of_ocaml / Melange smoke tests. +RUN curl -fsSL https://deb.nodesource.com/setup_24.x | bash - \ + && apt-get install -y --no-install-recommends nodejs \ + && rm -rf /var/lib/apt/lists/* + +RUN useradd -m -s /bin/bash ubuntu 2>/dev/null || true + +USER ubuntu +WORKDIR /home/ubuntu + +# OCaml 5.5 toolchain lives in the image; project opam deps are installed by +# .cursor/cloud-agent-install.sh after the repository checkout is available. +RUN opam init --disable-sandboxing -a -y \ + && opam update -a \ + && opam switch create 5.5 ocaml-base-compiler.5.5.0 -y \ + && eval "$(opam env --switch=5.5)" \ + && opam install dune ocamlfind -y + +RUN echo 'test -r ~/.opam/opam-init/init.sh && . ~/.opam/opam-init/init.sh > /dev/null 2> /dev/null || true' >> ~/.bashrc \ + && echo 'eval $(opam env --switch=5.5 2>/dev/null)' >> ~/.bashrc diff --git a/.cursor/cloud-agent-install.sh b/.cursor/cloud-agent-install.sh new file mode 100755 index 0000000..ad206d6 --- /dev/null +++ b/.cursor/cloud-agent-install.sh @@ -0,0 +1,67 @@ +#!/usr/bin/env bash +# Idempotent Cloud Agent bootstrap. +# Works both when the Dockerfile already provides opam/OCaml 5.5 and when a +# Personal/DB-managed base image does not (install must self-bootstrap). +set -euo pipefail + +repo_root="$(git rev-parse --show-toplevel)" +cd "$repo_root" + +export DEBIAN_FRONTEND=noninteractive +export OPAMYES=1 +export OPAMCOLOR=never + +need_sudo() { + if [ "$(id -u)" -eq 0 ]; then + "$@" + elif command -v sudo >/dev/null 2>&1; then + sudo DEBIAN_FRONTEND=noninteractive "$@" + else + echo "Need root or sudo to install system packages: $*" >&2 + exit 1 + fi +} + +ensure_system_packages() { + local missing=0 + for pkg in opam pkg-config libsqlite3-dev liblmdb-dev build-essential bubblewrap curl ca-certificates git; do + if ! dpkg -s "$pkg" >/dev/null 2>&1; then + missing=1 + break + fi + done + if [ "$missing" -eq 0 ] && command -v opam >/dev/null 2>&1; then + return 0 + fi + need_sudo apt-get update + need_sudo apt-get install -y --no-install-recommends \ + ca-certificates \ + curl \ + git \ + build-essential \ + pkg-config \ + bubblewrap \ + opam \ + libsqlite3-dev \ + liblmdb-dev +} + +ensure_system_packages + +if ! command -v opam >/dev/null 2>&1; then + echo "opam is still missing after apt install" >&2 + exit 1 +fi + +if [ ! -d "${HOME}/.opam" ]; then + opam init --disable-sandboxing -a -y +fi + +if ! opam switch list --short 2>/dev/null | grep -qx '5.5'; then + opam switch create 5.5 ocaml-base-compiler.5.5.0 +fi + +eval "$(opam env --switch=5.5)" + +opam install . --deps-only --with-test -y +dune build @install diff --git a/.cursor/environment.json b/.cursor/environment.json new file mode 100644 index 0000000..491f294 --- /dev/null +++ b/.cursor/environment.json @@ -0,0 +1,9 @@ +{ + "name": "DataScript OCaml (OCaml 5.5)", + "user": "ubuntu", + "build": { + "dockerfile": "Dockerfile", + "context": ".." + }, + "install": ".cursor/cloud-agent-install.sh" +} diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index f883c22..cbfbd2b 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -48,7 +48,7 @@ jobs: lein: latest - name: Install system dependencies - run: sudo apt-get update && sudo apt-get install -y libsqlite3-dev pkg-config + run: sudo apt-get update && sudo apt-get install -y libsqlite3-dev liblmdb-dev pkg-config - name: Install OCaml dependencies run: opam install . --deps-only --with-test -y diff --git a/.gitignore b/.gitignore index baab991..9afb287 100644 --- a/.gitignore +++ b/.gitignore @@ -9,3 +9,5 @@ tmp/ /db.sqlite-shm /db.sqlite-wal /_deps/ +/vendor/ +_bench_data/ diff --git a/AGENTS.md b/AGENTS.md index 141a991..5ea0bda 100644 --- a/AGENTS.md +++ b/AGENTS.md @@ -1,5 +1,6 @@ - Code and comments should be written in English. - Solve root causes, not workarounds. +- When debugging a problem, do not guess and patch blindly. Add targeted debug logging (or other runtime evidence), identify the root cause, then implement the fix. - Prefer simple implementations over complex ones. - All observable behavior should match upstream DataScript. - Implementation details should match upstream DataScript unless a divergence is explicitly requested and documented. diff --git a/README.md b/README.md index a6f3a7d..8b9dc8c 100644 --- a/README.md +++ b/README.md @@ -47,7 +47,6 @@ to use a different checkout or compiled JS bundle. - `type/`: shared public type definitions - `impl/`: implementation modules - `test/`: unit, integration, js_of_ocaml, and cross-runtime tests -- `examples/`: small executable examples - `bench/`: benchmark entry points - `script/`: parity and benchmark helper scripts diff --git a/bench/bench_ocaml_js.ml b/bench/bench_ocaml_js.ml new file mode 100644 index 0000000..5cc2291 --- /dev/null +++ b/bench/bench_ocaml_js.ml @@ -0,0 +1,281 @@ +open Datascript +open Js_of_ocaml + +type config = + { size : int + ; warmup_ms : float + ; sample_ms : float + ; samples : int + } + +let default_config = { size = 200; warmup_ms = 200.; sample_ms = 500.; samples = 5 } + +let parse_args () = + let config = ref default_config in + let set_size value = config := { !config with size = int_of_string value } in + let set_warmup value = config := { !config with warmup_ms = float_of_string value } in + let set_sample_ms value = config := { !config with sample_ms = float_of_string value } in + let set_samples value = config := { !config with samples = int_of_string value } in + let rec loop = function + | [] -> !config + | "--size" :: value :: rest -> + set_size value; + loop rest + | "--warmup-ms" :: value :: rest -> + set_warmup value; + loop rest + | "--sample-ms" :: value :: rest -> + set_sample_ms value; + loop rest + | "--samples" :: value :: rest -> + set_samples value; + loop rest + | arg :: _ -> invalid_arg ("unknown benchmark argument: " ^ arg) + in + Sys.argv |> Array.to_list |> List.tl |> loop + +let now_ms () = + Js.to_float (Js.Unsafe.fun_call (Js.Unsafe.js_expr "Date.now") [||]) + +let median values = + let sorted = List.sort Float.compare values in + List.nth sorted (List.length sorted / 2) + +let format_ms value = + if value > 1. then Printf.sprintf "%.2f" value else Printf.sprintf "%.5f" value + +let blackhole = ref 0 + +let consume_int value = + blackhole := (!blackhole + value) land 0x3fffffff + +let seq_length seq = + let rec loop count seq = + match seq () with + | Seq.Nil -> count + | Seq.Cons (_, rest) -> loop (count + 1) rest + in + loop 0 seq + +let consume_db db = + consume_int (seq_length (datoms db Eavt ())) + +let consume_rows rows = + consume_int (List.length rows) + +let consume_pull = function + | Some entity -> consume_int (List.length entity.pulled_attrs) + | None -> consume_int 0 + +let run_for duration_ms f = + let start = now_ms () in + let deadline = start +. duration_ms in + let rec loop iterations = + f (); + let iterations = iterations + 1 in + if now_ms () < deadline then loop iterations else iterations, now_ms () -. start + in + loop 0 + +let bench config name f = + Gc.full_major (); + ignore (run_for config.warmup_ms f); + Gc.full_major (); + let samples = + List.init config.samples (fun _ -> + let iterations, elapsed = run_for config.sample_ms f in + elapsed /. float_of_int iterations) + in + Printf.printf "%s\t%s\n%!" name (format_ms (median samples)) + +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 = + { cardinality = One + ; unique = Some Identity + ; indexed = true + ; is_component = false + ; no_history = false + ; doc = None + ; value_type = None + ; tuple_attrs = None + ; tuple_types = None + } + +let ref_attr = + { cardinality = One + ; unique = None + ; indexed = false + ; is_component = false + ; no_history = false + ; doc = None + ; value_type = Some RefType + ; tuple_attrs = None + ; 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 schema = + [ "id", unique_identity + ; "name", indexed + ; "age", indexed + ; "salary", indexed + ; "friend", ref_attr + ; "alias", many + ] + +let names = [| "Ivan"; "Petr"; "Sergey"; "Oleg"; "Yuri"; "Dmitry"; "Fedor"; "Denis" |] +let last_names = [| "Ivanov"; "Petrov"; "Sidorov"; "Kovalev"; "Kuznetsov"; "Voronoi" |] +let aliases = + [| "A. C. Q. W." + ; "A. J. Finn" + ; "A.A. Fair" + ; "Aapeli" + ; "Aaron Wolfe" + ; "Abigail Van Buren" + ; "Jeanne Phillips" + ; "Abram Tertz" + ; "Abu Nuwas" + ; "Acton Bell" + ; "Adunis" + |] + +type rng = { mutable state : int32 } + +let rng seed = { state = Int32.of_int seed } + +let next_int rng bound = + rng.state <- Int32.add (Int32.mul rng.state 1_664_525l) 1_013_904_223l; + Int32.(to_int (rem (logand (shift_right_logical rng.state 1) 0x3fffffffl) (of_int bound))) + +let rand_nth rng values = + values.(next_int rng (Array.length values)) + +let random_man rng i = + let name = rand_nth rng names in + let last_name = rand_nth rng last_names in + let alias_count = next_int rng 10 in + let alias_values = List.init alias_count (fun _ -> String (rand_nth rng aliases)) in + Entity + { db_id = Some (Temp_id (string_of_int i)) + ; attrs = + [ "name", One_value (String name) + ; "last-name", One_value (String last_name) + ; "full-name", One_value (String (name ^ " " ^ last_name)) + ; "alias", Many_values alias_values + ; "sex", One_value (Keyword (if next_int rng 2 = 0 then "male" else "female")) + ; "age", One_value (Int (next_int rng 100)) + ; "salary", One_value (Int (next_int rng 100_000)) + ] + } + +let people size = + let rng = rng 1 in + List.init size (fun index -> random_man rng (index + 1)) + +let build_db size = + db_with (people size) (empty_db ~schema ()) + +let build_storage_db size = + let storage = memory_storage () in + let db = db_with (people size) (empty_db ~schema ~storage ()) in + store db; + match restore storage with + | Some db -> db + | None -> failwith "storage-backed benchmark db should restore" + +let add_one_by_one size = + List.fold_left + (fun db entity -> db_with [ entity ] db) + (empty_db ~schema ()) + (people size) + +let add_one_datom_per_tx size = + let single_datom_attrs = [ "name"; "last-name"; "sex"; "age"; "salary" ] in + let add_entity db entity = + match entity with + | Entity { db_id = Some entity_ref; attrs; _ } -> + List.fold_left + (fun db (attr, value) -> + if List.mem attr single_datom_attrs then + match value with + | One_value value -> db_with [ Add (entity_ref, attr, value) ] db + | Many_values _ | One_entity _ | Many_entities _ -> db + else + db) + db + attrs + | _ -> db_with [ entity ] db + in + List.fold_left add_entity (empty_db ~schema ()) (people size) + +let main () = + let config = parse_args () in + let runtime_label = + match Sys.getenv_opt "BENCH_RUNTIME_LABEL" with + | Some label -> label + | None -> "ocaml" + in + Printf.printf "runtime\t%s\n" runtime_label; + Printf.printf "size\t%d\n" config.size; + let db = lazy (build_db config.size) in + bench config "add-1" (fun () -> consume_db (add_one_datom_per_tx config.size)); + bench config "add-5" (fun () -> consume_db (add_one_by_one config.size)); + bench config "add-all" (fun () -> consume_db (build_db config.size)); + bench config "datoms-name" (fun () -> + consume_int (fold_datoms (fun count _ -> count + 1) 0 (Lazy.force db) Aevt ~a:"name" ())); + bench config "q1" (fun () -> + consume_rows (q_string (Lazy.force db) "[:find ?e :where [?e :name \"Ivan\"]]")); + bench config "q2" (fun () -> + consume_rows (q_string (Lazy.force db) "[:find ?e ?a :where [?e :name \"Ivan\"] [?e :age ?a]]")); + bench config "q3" (fun () -> + consume_rows (q_string (Lazy.force db) "[:find ?e ?a :where [?e :name \"Ivan\"] [?e :age ?a] [?e :sex :male]]")); + bench config "q4" (fun () -> + consume_rows (q_string (Lazy.force db) "[:find ?e ?l ?a :where [?e :name \"Ivan\"] [?e :last-name ?l] [?e :age ?a] [?e :sex :male]]")); + bench config "q5-shortcircuit" (fun () -> + consume_rows + (q_string + ~inputs:[ Arg_scalar (Result_value (String "Anastasia")); Arg_scalar (Result_value (Int 35)) ] + (Lazy.force db) + "[:find ?e ?n ?l ?a ?s ?al :in $ ?n ?a :where [?e :name ?n] [?e :age ?a] [?e :last-name ?l] [?e :sex ?s] [?e :alias ?al]]")); + bench config "qpred1" (fun () -> + consume_rows (q_string (Lazy.force db) "[:find ?e ?s :where [?e :salary ?s] [(> ?s 50000)]]")); + bench config "qpred2" (fun () -> + consume_rows + (q_string + ~inputs:[ Arg_scalar (Result_value (Int 50000)) ] + (Lazy.force db) + "[:find ?e ?s :in $ ?min-s :where [?e :salary ?s] [(> ?s ?min-s)]]")); + bench config "q2pred" (fun () -> + consume_rows + (q_string + (Lazy.force db) + "[:find ?e ?s :where [?e :name \"Ivan\"] [?e :salary ?s] [(> ?s 50000)]]")); + bench config "pull-one" (fun () -> + consume_pull (pull (Lazy.force db) [ Pull_attr "name"; Pull_attr "age"; Pull_ref ("friend", [ Pull_attr "name"; Pull_attr "age" ]) ] (Entity_id 1))); + bench config "storage-roundtrip" (fun () -> + consume_db (build_storage_db config.size)); + Printf.eprintf "blackhole=%d\n%!" !blackhole + +let () = main () diff --git a/bench/compare_lmdb_sqlite.sh b/bench/compare_lmdb_sqlite.sh new file mode 100755 index 0000000..a10401a --- /dev/null +++ b/bench/compare_lmdb_sqlite.sh @@ -0,0 +1,132 @@ +#!/usr/bin/env bash +# Compare LMDB vs SQLite persistent storage benchmarks side-by-side. +# Both backends write durable files under DATA_DIR (default: repo _bench_data). +set -euo pipefail + +repo_root="$(cd "$(dirname "$0")/.." && pwd)" +cd "$repo_root" + +if command -v opam >/dev/null 2>&1; then + eval "$(opam env --switch=5.5 2>/dev/null || opam env 2>/dev/null || true)" +fi + +SIZES="${SIZES:-100,1000,5000}" +RAW_ONLY="${RAW_ONLY:-0}" +INPUT_FILE="${INPUT_FILE:-}" +DATA_DIR="${DATA_DIR:-$repo_root/_bench_data/persistent}" +mkdir -p "$DATA_DIR" + +echo "=== LMDB vs SQLite persistent storage bench (disk only) ===" +echo "sizes=${SIZES}" +echo "data-dir=${DATA_DIR}" +echo + +RAW="$(mktemp)" +trap 'rm -f "$RAW"' EXIT + +if [[ -n "$INPUT_FILE" ]]; then + cat "$INPUT_FILE" > "$RAW" +elif [[ "$RAW_ONLY" == "1" ]]; then + cat > "$RAW" +else + dune build bench/persistent_storage_bench.exe + dune exec bench/persistent_storage_bench.exe -- \ + --disk-only \ + --data-dir "$DATA_DIR" \ + --sizes "$SIZES" | tee "$RAW" +fi + +python3 - "$RAW" <<'PY' +import sys +from collections import defaultdict + +path = sys.argv[1] +sqlite = defaultdict(dict) +lmdb = defaultdict(dict) +sizes = [] +size = None +meta = {} + +with open(path) as f: + for line in f: + line = line.rstrip("\n") + if not line or "\t" not in line: + continue + key, val = line.split("\t", 1) + if key in {"data-dir", "disk-only"}: + meta[key] = val + continue + if key == "size": + size = int(val) + sizes.append(size) + continue + if size is None: + continue + if key.startswith("sqlite-"): + sqlite[size][key[len("sqlite-"):]] = val + elif key.startswith("lmdb-"): + lmdb[size][key[len("lmdb-"):]] = val + +timing_metrics = [ + "snapshot-build-and-store", + "snapshot-restore", + "snapshot-add-one-and-store-after-restore", + "snapshot-update-one-and-store-after-add", + "conn-build", + "conn-restore", + "conn-add-one-after-restore", + "conn-update-one-after-add", +] +size_metrics = [ + "snapshot-file-size-after-build", + "snapshot-file-size-after-update", + "conn-file-size-after-build", + "conn-file-size-after-update", +] + +def ratio(sv, lv): + try: + s = float(sv) + l = float(lv) + except Exception: + return "?" + if s == 0: + return "?" + return f"{l / s:.2f}x" + +def fmt_bytes(n): + try: + n = int(n) + except Exception: + return n + if n >= 1024 * 1024: + return f"{n / (1024 * 1024):.2f} MiB" + if n >= 1024: + return f"{n / 1024:.1f} KiB" + return f"{n} B" + +print(f"data-dir\t{meta.get('data-dir', '?')}") +print(f"disk-only\t{meta.get('disk-only', '?')}") +print() +print("=== timing (ms; ratio = lmdb/sqlite; <1x means LMDB faster) ===") +print(f"{'size':<8} {'metric':<42} {'sqlite':>12} {'lmdb':>12} {'ratio':>10}") +print("-" * 88) +for s in sizes: + for metric in timing_metrics: + sv = sqlite[s].get(metric, "?") + lv = lmdb[s].get(metric, "?") + print(f"{s:<8} {metric:<42} {sv:>12} {lv:>12} {ratio(sv, lv):>10}") + print() + +print("=== on-disk footprint (ratio = lmdb/sqlite; <1x means LMDB smaller) ===") +print(f"{'size':<8} {'metric':<42} {'sqlite':>14} {'lmdb':>14} {'ratio':>10}") +print("-" * 92) +for s in sizes: + for metric in size_metrics: + sv = sqlite[s].get(metric, "?") + lv = lmdb[s].get(metric, "?") + print( + f"{s:<8} {metric:<42} {fmt_bytes(sv):>14} {fmt_bytes(lv):>14} {ratio(sv, lv):>10}" + ) + print() +PY diff --git a/bench/compare_lmdb_sqlite_index_scan.sh b/bench/compare_lmdb_sqlite_index_scan.sh new file mode 100755 index 0000000..c452ad5 --- /dev/null +++ b/bench/compare_lmdb_sqlite_index_scan.sh @@ -0,0 +1,159 @@ +#!/usr/bin/env bash +# Compare LMDB vs SQLite on narrow Index scan microbenchmarks (disk-backed). +# Measures cold open/restore + cold/hot point/prefix/range/full scans — not the +# shared query evaluator. +# +# Default sizes: 200k and 500k (large-index stress without a full 1M build). +# SIZES=50000 bash bench/compare_lmdb_sqlite_index_scan.sh +# SIZES=200000,500000 WARMUP=5 REPEATS=3 bash bench/compare_lmdb_sqlite_index_scan.sh +set -euo pipefail + +repo_root="$(cd "$(dirname "$0")/.." && pwd)" +cd "$repo_root" + +if command -v opam >/dev/null 2>&1; then + eval "$(opam env --switch=5.5 2>/dev/null || opam env 2>/dev/null || true)" +fi + +# Prefer SIZES; SIZE remains as a single-size override for convenience. +if [[ -n "${SIZE:-}" && -z "${SIZES:-}" ]]; then + SIZES="$SIZE" +fi +SIZES="${SIZES:-200000,500000}" +# Defaults tuned for multi-hundred-k sizes; override upward for tighter medians. +WARMUP="${WARMUP:-5}" +REPEATS="${REPEATS:-3}" +DATA_DIR="${DATA_DIR:-$repo_root/_bench_data/index-scan}" +DROP_CACHES="${DROP_CACHES:-0}" +BACKENDS="${BACKENDS:-lmdb,sqlite}" +mkdir -p "$DATA_DIR" + +echo "=== LMDB vs SQLite index-scan microbench (disk) ===" +echo "sizes=${SIZES} warmup=${WARMUP} repeats=${REPEATS}" +echo "data-dir=${DATA_DIR} backends=${BACKENDS} drop-caches=${DROP_CACHES}" +echo + +RAW="$(mktemp)" +trap 'rm -f "$RAW"' EXIT + +EXTRA=() +if [[ "$DROP_CACHES" == "1" ]]; then + EXTRA+=(--drop-caches) +fi + +dune build bench/index_scan_bench.exe +dune exec bench/index_scan_bench.exe -- \ + --sizes "$SIZES" \ + --data-dir "$DATA_DIR" \ + --warmup "$WARMUP" \ + --repeats "$REPEATS" \ + --backends "$BACKENDS" \ + "${EXTRA[@]}" \ + | tee "$RAW" + +python3 - "$RAW" <<'PY' +import sys +from collections import defaultdict + +path = sys.argv[1] +current_size = None +current_storage = None +# by[size][storage][metric] = value +by = defaultdict(lambda: defaultdict(dict)) +meta = {} +sizes = [] +order = [] + +with open(path) as f: + for line in f: + line = line.rstrip("\n") + if not line or "\t" not in line: + continue + k, v = line.split("\t", 1) + if k in {"runtime", "data-dir", "warmup", "repeats", "bench", "drop-caches"}: + meta[k] = v + continue + if k == "size": + current_size = int(v) + if current_size not in sizes: + sizes.append(current_size) + current_storage = None + continue + if k == "storage": + current_storage = v + if v not in order: + order.append(v) + continue + if current_size is None or current_storage is None: + continue + by[current_size][current_storage][k] = v + +metrics = [ + "disk-bytes", + "build-ms", + "cold-open-restore-ms", + "cold-point-eavt-entity-ms", + "hot-point-eavt-entity-ms", + "cold-prefix-aevt-name-ms", + "hot-prefix-aevt-name-ms", + "cold-exact-avet-name-ivan-ms", + "hot-exact-avet-name-ivan-ms", + "cold-range-avet-salary-50k-60k-ms", + "hot-range-avet-salary-50k-60k-ms", + "cold-seek-eavt-mid-take-100-ms", + "hot-seek-eavt-mid-take-100-ms", + "cold-scan-eavt-all-ms", + "hot-scan-eavt-all-ms", +] + +def ratio(a, b): + try: + fa, fb = float(a), float(b) + if fa == 0: + return "?" + return f"{fb / fa:.2f}x" + except Exception: + return "?" + +def fmt_bytes(n): + try: + n = int(n) + except Exception: + return n + if n >= 1024 * 1024 * 1024: + return f"{n / (1024 * 1024 * 1024):.2f} GiB" + if n >= 1024 * 1024: + return f"{n / (1024 * 1024):.2f} MiB" + if n >= 1024: + return f"{n / 1024:.1f} KiB" + return f"{n} B" + +print() +print(f"data-dir\t{meta.get('data-dir', '?')}") +print(f"drop-caches\t{meta.get('drop-caches', '?')}") +print(f"sizes\t{','.join(str(s) for s in sizes)}") + +for size in sizes: + print() + print(f"=== size {size} (ratio = sqlite/lmdb) ===") + if len(order) < 2: + for s in order: + print(f"[{s}]") + for m in metrics: + if m in by[size][s]: + val = by[size][s][m] + if m == "disk-bytes": + val = fmt_bytes(val) + print(f" {m}\t{val}") + continue + left, right = order[0], order[1] + print(f"{'metric':<36} {left:>14} {right:>14} {'ratio':>10}") + print("-" * 78) + for m in metrics: + lv = by[size][left].get(m, "?") + rv = by[size][right].get(m, "?") + if m == "disk-bytes": + print(f"{m:<36} {fmt_bytes(lv):>14} {fmt_bytes(rv):>14} {ratio(lv, rv):>10}") + else: + print(f"{m:<36} {lv:>14} {rv:>14} {ratio(lv, rv):>10}") +PY diff --git a/bench/compare_lmdb_sqlite_queries.sh b/bench/compare_lmdb_sqlite_queries.sh new file mode 100755 index 0000000..69af30d --- /dev/null +++ b/bench/compare_lmdb_sqlite_queries.sh @@ -0,0 +1,111 @@ +#!/usr/bin/env bash +# Compare LMDB vs SQLite on the full shared query suite. +# STORAGE=compare uses on-disk LMDB and SQLite files only (no in-memory). +set -euo pipefail + +repo_root="$(cd "$(dirname "$0")/.." && pwd)" +cd "$repo_root" + +if command -v opam >/dev/null 2>&1; then + eval "$(opam env --switch=5.5 2>/dev/null || opam env 2>/dev/null || true)" +fi + +SIZE="${SIZE:-20000}" +WARMUP_MS="${WARMUP_MS:-200}" +SAMPLE_MS="${SAMPLE_MS:-200}" +REPEATS="${REPEATS:-2}" +JIT_WARMUP="${JIT_WARMUP:-100}" +STORAGE="${STORAGE:-compare}" # compare => lmdb + sqlite on disk +DATA_DIR="${DATA_DIR:-$repo_root/_bench_data/queries}" +mkdir -p "$DATA_DIR" + +echo "=== LMDB vs SQLite shared query suite (disk-backed) ===" +echo "size=${SIZE} warmup=${WARMUP_MS}ms sample=${SAMPLE_MS}ms repeats=${REPEATS} jit=${JIT_WARMUP}" +echo "storage=${STORAGE}" +echo "data-dir=${DATA_DIR}" +echo + +RAW="$(mktemp)" +trap 'rm -f "$RAW"' EXIT + +dune build bench/shared_query_bench.exe +dune exec bench/shared_query_bench.exe -- \ + --size "$SIZE" \ + --warmup-ms "$WARMUP_MS" \ + --sample-ms "$SAMPLE_MS" \ + --repeats "$REPEATS" \ + --jit-warmup "$JIT_WARMUP" \ + --storage "$STORAGE" \ + --data-dir "$DATA_DIR" \ + | tee "$RAW" + +python3 - "$RAW" <<'PY' +import sys +from collections import defaultdict + +path = sys.argv[1] +current = None +by_storage = defaultdict(dict) +meta = {} +order = [] + +with open(path) as f: + for line in f: + line = line.rstrip("\n") + if not line or "\t" not in line: + continue + k, v = line.split("\t", 1) + if k in {"runtime", "size", "warmup-ms", "sample-ms", "repeats", "jit-warmup", "db-mode", "query-cases", "query", "data-dir"}: + meta[k] = v + continue + if k == "storage": + current = v + if v not in order: + order.append(v) + continue + if current is None: + continue + by_storage[current][k] = v + +setup = ["path", "disk-bytes", "build-ms", "store-restore-ms"] +queries = [ + "q1", "q2", "q2-switch", "q3", "q4", "q5", + "qpred1", "qpred2", "q-or", "q-not", "q-or-join", "q-not-join", + "q-pred-range", "q-5-merge", "q-rule", +] + +def ratio(a, b): + try: + fa, fb = float(a), float(b) + if fa == 0: + return "?" + return f"{fb / fa:.2f}x" + except Exception: + return "?" + +print() +print(f"data-dir\t{meta.get('data-dir', '?')}") +print(f"=== comparison (ms; ratio = second/first; storages={','.join(order)}) ===") +if len(order) < 2: + print("Need at least two storages for a ratio table.") + for s in order: + print(f"\n[{s}]") + for k in setup + queries: + if k in by_storage[s]: + print(f" {k}\t{by_storage[s][k]}") + raise SystemExit(0) + +left, right = order[0], order[1] +print(f"{'metric':<22} {left:>12} {right:>12} {'ratio':>10}") +print("-" * 60) +for metric in setup + queries: + lv = by_storage[left].get(metric, "?") + rv = by_storage[right].get(metric, "?") + if metric in {"path"}: + print(f"{metric:<22} {lv:>12} {rv:>12} {'':>10}") + else: + print(f"{metric:<22} {lv:>12} {rv:>12} {ratio(lv, rv):>10}") +print() +print(f"query-cases\t{meta.get('query-cases', '?')}") +print(f"size\t{meta.get('size', '?')}") +PY diff --git a/bench/compare_pss_lmdb.sh b/bench/compare_pss_lmdb.sh new file mode 100755 index 0000000..8b330d5 --- /dev/null +++ b/bench/compare_pss_lmdb.sh @@ -0,0 +1,47 @@ +#!/usr/bin/env bash +set -euo pipefail + +SIZE="${1:-20000}" +WARMUP_MS="${2:-100}" +SAMPLE_MS="${3:-200}" +SAMPLES="${4:-3}" + +bench_args=(--size "$SIZE" --warmup-ms "$WARMUP_MS" --sample-ms "$SAMPLE_MS" --samples "$SAMPLES") + +run_branch_bench() { + local label="$1" + local repo="$2" + ( + cd "$repo" + dune build bench/bench_ocaml.exe >/dev/null + BENCH_RUNTIME_LABEL="$label" dune exec bench/bench_ocaml.exe -- "${bench_args[@]}" 2>/dev/null + ) +} + +echo "=== PSS vs LMDB benchmark (${SIZE} entities) ===" +echo "warmup=${WARMUP_MS}ms sample=${SAMPLE_MS}ms samples=${SAMPLES}" +echo + +PSS_OUT="$(run_branch_bench pss /tmp/bench-pss-main)" +LMDB_OUT="$(run_branch_bench lmdb /workspace)" + +printf "%-22s %12s %12s %12s\n" "benchmark" "pss(ms)" "lmdb(ms)" "lmdb/pss" +echo "----------------------------------------------------------------" + +while IFS=$'\t' read -r name pss_ms; do + [[ "$name" == runtime* || "$name" == size* || -z "$name" ]] && continue + lmdb_ms="$(printf '%s\n' "$LMDB_OUT" | awk -F'\t' -v n="$name" '$1 == n { print $2; exit }')" + if [[ -z "$lmdb_ms" ]]; then + printf "%-22s %12s %12s %12s\n" "$name" "$pss_ms" "?" "?" + continue + fi + ratio="$(awk -v l="$lmdb_ms" -v p="$pss_ms" 'BEGIN { if (p + 0 == 0) print "?"; else printf "%.2fx", l / p }')" + printf "%-22s %12s %12s %12s\n" "$name" "$pss_ms" "$lmdb_ms" "$ratio" +done <<< "$PSS_OUT" + +echo +echo "=== raw: pss ===" +printf '%s\n' "$PSS_OUT" +echo +echo "=== raw: lmdb ===" +printf '%s\n' "$LMDB_OUT" diff --git a/bench/compare_pss_lmdb_20k.sh b/bench/compare_pss_lmdb_20k.sh new file mode 100755 index 0000000..d6d51f1 --- /dev/null +++ b/bench/compare_pss_lmdb_20k.sh @@ -0,0 +1,49 @@ +#!/usr/bin/env bash +set -euo pipefail + +SIZE="${1:-20000}" +SCRIPT_DIR="$(cd "$(dirname "${BASH_SOURCE[0]}")" && pwd)" +REPO_ROOT="$(cd "$SCRIPT_DIR/.." && pwd)" +PSS_REPO="${PSS_REPO:-/tmp/bench-pss-main}" + +run_branch() { + local label="$1" + local repo="$2" + ( + cd "$repo" + dune build bench/index_compare_20k.exe >/dev/null + BENCH_RUNTIME_LABEL="$label" dune exec bench/index_compare_20k.exe -- "$SIZE" 2>/dev/null + ) +} + +if [[ ! -e "$PSS_REPO/.git" ]]; then + echo "PSS worktree missing at $PSS_REPO; run: git worktree add $PSS_REPO main" >&2 + exit 1 +fi + +echo "=== PSS vs LMDB index benchmark (${SIZE} entities / ~${SIZE}0 datoms) ===" +echo + +PSS_OUT="$(run_branch pss "$PSS_REPO")" +LMDB_OUT="$(run_branch lmdb "$REPO_ROOT")" + +printf "%-24s %12s %12s %12s\n" "benchmark" "pss(ms)" "lmdb(ms)" "lmdb/pss" +echo "------------------------------------------------------------------------" + +while IFS=$'\t' read -r name pss_ms; do + [[ "$name" == runtime* || "$name" == size* || "$name" == datoms || "$name" == *count* || -z "$name" ]] && continue + lmdb_ms="$(printf '%s\n' "$LMDB_OUT" | awk -F'\t' -v n="$name" '$1 == n { print $2; exit }')" + if [[ -z "$lmdb_ms" ]]; then + printf "%-24s %12s %12s %12s\n" "$name" "$pss_ms" "?" "?" + continue + fi + ratio="$(awk -v l="$lmdb_ms" -v p="$pss_ms" 'BEGIN { if (p + 0 == 0) print "?"; else printf "%.2fx", l / p }')" + printf "%-24s %12s %12s %12s\n" "$name" "$pss_ms" "$lmdb_ms" "$ratio" +done <<< "$PSS_OUT" + +echo +echo "=== raw: pss ===" +printf '%s\n' "$PSS_OUT" +echo +echo "=== raw: lmdb ===" +printf '%s\n' "$LMDB_OUT" diff --git a/bench/compare_storage_rss.sh b/bench/compare_storage_rss.sh new file mode 100755 index 0000000..52463ed --- /dev/null +++ b/bench/compare_storage_rss.sh @@ -0,0 +1,274 @@ +#!/usr/bin/env bash +# Compare process RSS after common 50k ops for memory / LMDB / SQLite on this +# branch, plus main's in-memory path (main has no Share_index_db SQLite/LMDB file +# package comparable to this branch). +set -euo pipefail + +repo_root="$(cd "$(dirname "$0")/.." && pwd)" +cd "$repo_root" + +if command -v opam >/dev/null 2>&1; then + eval "$(opam env --switch=5.5 2>/dev/null || opam env 2>/dev/null || true)" +fi + +SIZE="${SIZE:-50000}" +TX_SIZE="${TX_SIZE:-200}" +DATA_DIR="${DATA_DIR:-$repo_root/_bench_data/storage-rss}" +BACKENDS="${BACKENDS:-memory,lmdb,sqlite}" +OUT="${OUT:-/opt/cursor/artifacts/bench-storage-rss-50k.txt}" +MAIN_WORKTREE="${MAIN_WORKTREE:-/tmp/datascript-ocaml-main-rss}" +mkdir -p "$DATA_DIR" "$(dirname "$OUT")" + +RAW="$(mktemp)" +trap 'rm -f "$RAW"' EXIT + +echo "=== storage RSS compare (size=${SIZE}) ===" | tee "$OUT" +echo "branch=$(git rev-parse --abbrev-ref HEAD) tip=$(git rev-parse --short HEAD)" | tee -a "$OUT" +echo | tee -a "$OUT" + +echo "--- PR branch backends (one process each): ${BACKENDS} ---" | tee -a "$OUT" +dune build bench/storage_rss_bench.exe +IFS=',' read -r -a backend_arr <<< "$BACKENDS" +for backend in "${backend_arr[@]}"; do + backend="$(echo "$backend" | xargs)" + [[ -z "$backend" ]] && continue + echo | tee -a "$OUT" + echo ">>> backend=${backend}" | tee -a "$OUT" + dune exec bench/storage_rss_bench.exe -- \ + --size "$SIZE" \ + --tx-size "$TX_SIZE" \ + --data-dir "$DATA_DIR" \ + --backends "$backend" \ + | tee -a "$RAW" | tee -a "$OUT" +done + +echo | tee -a "$OUT" +echo "--- main memory backend ---" | tee -a "$OUT" + +if [[ ! -d "$MAIN_WORKTREE/.git" && ! -f "$MAIN_WORKTREE/.git" ]]; then + rm -rf "$MAIN_WORKTREE" + git fetch origin main + git worktree add --detach "$MAIN_WORKTREE" origin/main +fi + +# Memory-only probe for main (same light people schema / phases as storage_rss_bench). +cat > "$MAIN_WORKTREE/bench/memory_rss_probe.ml" <<'ML' +open Datascript + +let rss_bytes () = + let channel = Unix.open_process_in (Printf.sprintf "ps -o rss= -p %d" (Unix.getpid ())) in + let line = try input_line channel with End_of_file -> "0" in + ignore (Unix.close_process_in channel); + line |> String.trim |> int_of_string |> fun kb -> kb * 1024 + +let heap_bytes () = + let stat = Gc.stat () in + stat.live_words * (Sys.word_size / 8) + +let settle () = Gc.full_major (); Unix.sleepf 0.05 + +let report phase = + settle (); + Printf.printf "backend\tmemory\n%!"; + Printf.printf "phase\t%s\n%!" phase; + Printf.printf "rss-bytes\t%d\n%!" (rss_bytes ()); + Printf.printf "heap-bytes\t%d\n%!" (heap_bytes ()) + +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 schema = + [ "name", indexed; "last-name", indexed; "sex", indexed; "age", indexed; "salary", indexed ] +let names = [| "Ivan"; "Petr"; "Sergei"; "Oleg"; "Yuri"; "Dmitry"; "Fedor"; "Denis" |] +let last_names = [| "Ivanov"; "Petrov"; "Sidorov"; "Kovalev"; "Kuznetsov"; "Voronoi" |] +let sexes = [| "male"; "female" |] +type rng = { mutable state : int32 } +let rng seed = { state = Int32.of_int seed } +let next_int rng bound = + rng.state <- Int32.add (Int32.mul rng.state 1_664_525l) 1_013_904_223l; + Int32.(to_int (rem (logand (shift_right_logical rng.state 1) 0x3fffffffl) (of_int bound))) +let rand_nth rng values = values.(next_int rng (Array.length values)) +let rand_sex rng = sexes.(next_int rng 997 mod Array.length sexes) +let person rng i = + Entity + { db_id = Some (Temp_id (string_of_int i)) + ; attrs = + [ "name", One_value (String (rand_nth rng names)) + ; "last-name", One_value (String (rand_nth rng last_names)) + ; "sex", One_value (Keyword (rand_sex rng)) + ; "age", One_value (Int (next_int rng 100)) + ; "salary", One_value (Int (next_int rng 100_000)) + ] + } +let chunk = 10000 +let build_db size = + let r = rng 1 in + let rec loop i db = + if i > size then db + else + let hi = min size (i + chunk - 1) in + let tx = List.init (hi - i + 1) (fun k -> person r (i + k)) in + Printf.eprintf "built\t%d/%d\trss=%d\n%!" hi size (rss_bytes ()); + loop (hi + 1) (db_with tx db) + in + loop 1 (empty_db ~schema ()) +let update_person rng i = + Entity + { db_id = Some (Entity_id (i + 1)) + ; attrs = + [ "age", One_value (Int (next_int rng 100)) + ; "salary", One_value (Int (next_int rng 100_000)) + ] + } +let blackhole = ref 0 +let consume n = blackhole := (!blackhole + n) land 0x3fffffff +let q_name = lazy (parse_query_string "[:find ?e ?a :where [?e :name \"Ivan\"] [?e :age ?a]]") +let q_sal = lazy (parse_query_string "[:find ?e ?s :where [?e :salary ?s] [(> ?s 50000)]]") +let q_sex = lazy (parse_query_string "[:find ?e ?a :where [?e :name \"Ivan\"] [?e :age ?a] [?e :sex :male]]") +let run_queries db = + consume (Seq.fold_left (fun n _ -> n + 1) 0 (datoms db Aevt ~a:"name" ())); + consume (List.length (q db (Lazy.force q_name))); + consume (List.length (q db (Lazy.force q_sal))); + consume (List.length (q db (Lazy.force q_sex))); + for entity_id = 1 to 100 do + match pull db [ Pull_attr "name"; Pull_attr "age"; Pull_attr "salary" ] (Entity_id entity_id) with + | None -> consume 0 + | Some e -> consume (List.length e.pulled_attrs) + done +let size = try int_of_string Sys.argv.(1) with _ -> 50000 +let tx_size = try int_of_string Sys.argv.(2) with _ -> 200 +let () = + Printf.printf "runtime\tOCaml\n%!"; + Printf.printf "size\t%d\n%!" size; + Printf.printf "tx-size\t%d\n%!" tx_size; + Printf.printf "bench\tstorage-rss\n%!"; + Printf.printf "label\tmain\n%!"; + Printf.printf "storage\tmemory\n%!"; + report "baseline"; + let t0 = Unix.gettimeofday () in + let db = ref (build_db size) in + Printf.printf "build-ms\t%.1f\n%!" ((Unix.gettimeofday () -. t0) *. 1000.); + Printf.printf "disk-bytes\t0\n%!"; + report "after-build"; + run_queries !db; + report "after-queries"; + let r = rng 99 in + db := db_with (List.init tx_size (fun i -> update_person r i)) !db; + report "after-tx"; + run_queries !db; + report "after-queries-2"; + report "after-gc-full-major"; + Gc.compact (); Unix.sleepf 0.05; + report "after-gc-compact"; + db := empty_db (); + settle (); Gc.compact (); Unix.sleepf 0.1; + report "after-drop-db"; + settle (); Gc.compact (); Unix.sleepf 0.1; + report "after-close"; + Printf.printf "blackhole\t%d\n%!" !blackhole +ML + +# Ensure dune stanza exists for the probe on main. +if ! grep -q 'memory_rss_probe' "$MAIN_WORKTREE/bench/dune"; then + cat >> "$MAIN_WORKTREE/bench/dune" <<'DUNE' + +(executable + (name memory_rss_probe) + (modules memory_rss_probe) + (modes exe) + (libraries datascript-ocaml-native unix)) +DUNE +fi + +( + cd "$MAIN_WORKTREE" + if command -v opam >/dev/null 2>&1; then + eval "$(opam env --switch=5.5 2>/dev/null || opam env 2>/dev/null || true)" + fi + echo "main tip=$(git rev-parse --short HEAD)" | tee -a "$OUT" + dune build bench/memory_rss_probe.exe + dune exec bench/memory_rss_probe.exe -- "$SIZE" "$TX_SIZE" | tee -a "$RAW" | tee -a "$OUT" +) + +python3 - "$RAW" <<'PY' | tee -a "$OUT" +import sys +from collections import defaultdict + +by = defaultdict(dict) # backend -> phase -> rss +order_backends = [] +order_phases = [] +backend = None +phase = None +meta = {} + +with open(sys.argv[1]) as f: + for line in f: + line = line.rstrip("\n") + if "\t" not in line: + continue + k, v = line.split("\t", 1) + if k in {"runtime", "size", "tx-size", "bench", "data-dir", "label", "build-ms", "disk-bytes", "blackhole"}: + if k == "label": + meta["label"] = v + continue + if k == "storage": + backend = v + if meta.get("label") == "main" and v == "memory": + backend = "main-memory" + if backend not in order_backends: + order_backends.append(backend) + phase = None + continue + if k == "label": + meta["label"] = v + continue + if k == "phase": + phase = v + if phase not in order_phases: + order_phases.append(phase) + continue + if k == "rss-bytes" and backend and phase: + by[backend][phase] = int(v) + if k == "heap-bytes" and backend and phase: + by[backend][phase + ":heap"] = int(v) + +def fmt(n): + if n is None: + return "?" + if n >= 1024 * 1024 * 1024: + return f"{n / (1024**3):.2f} GiB" + if n >= 1024 * 1024: + return f"{n / (1024**2):.1f} MiB" + if n >= 1024: + return f"{n / 1024:.1f} KiB" + return f"{n} B" + +print() +print("=== RSS by phase (process resident) ===") +header = f"{'phase':<22}" + "".join(f"{b:>14}" for b in order_backends) +print(header) +print("-" * len(header)) +for phase in order_phases: + row = f"{phase:<22}" + for b in order_backends: + row += f"{fmt(by[b].get(phase)):>14}" + print(row) + +print() +print("=== release deltas (after-queries-2 → later) ===") +for b in order_backends: + base = by[b].get("after-queries-2") + if base is None: + continue + print(f"[{b}] after-queries-2 = {fmt(base)}") + for phase in ("after-gc-full-major", "after-gc-compact", "after-drop-db", "after-close"): + cur = by[b].get(phase) + if cur is None: + continue + delta = cur - base + sign = "+" if delta >= 0 else "" + print(f" {phase:<22} {fmt(cur):>10} ({sign}{fmt(abs(delta))})") +PY + +echo +echo "wrote $OUT" diff --git a/bench/count_avet.ml b/bench/count_avet.ml new file mode 100644 index 0000000..694967d --- /dev/null +++ b/bench/count_avet.ml @@ -0,0 +1,96 @@ +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 many = { indexed with cardinality = Many; indexed = false } + +let rng = ref 1 + +let next_int bound = + rng := (!rng * 1_664_525 + 1_013_904_223) land 0x7fffffff; + !rng mod bound + +let names = [| "Ivan"; "Petr"; "Sergey"; "Oleg"; "Yuri"; "Dmitry"; "Fedor"; "Denis" |] +let last_names = [| "Ivanov"; "Petrov"; "Sidorov"; "Kovalev"; "Kuznetsov"; "Voronoi" |] +let aliases = [| "A. C. Q. W."; "A. J. Finn"; "A.A. Fair"; "Aapeli"; "Aaron Wolfe" |] + +let random_man i = + let name = names.(i mod Array.length names) in + let last_name = last_names.(i mod Array.length last_names) in + let alias_count = 1 + next_int 10 in + let alias_values = List.init alias_count (fun _ -> String aliases.(next_int (Array.length aliases))) in + Entity + { + db_id = Some (Temp_id (string_of_int (i + 1))) + ; attrs = + [ "name", One_value (String name) + ; "last-name", One_value (String last_name) + ; "full-name", One_value (String (name ^ " " ^ last_name)) + ; "alias", Many_values alias_values + ; "sex", One_value (Keyword (if next_int 2 = 0 then "male" else "female")) + ; "age", One_value (Int (next_int 100)) + ; "salary", One_value (Int (next_int 100_000)) + ] + } + +let minimal_schema = [ "salary", indexed ] + +let full_schema = + [ "name", indexed; "last-name", indexed; "age", indexed; "salary", indexed; "alias", many ] + +let build_db schema size = + let entities = + match schema with + | "minimal" -> + List.init size (fun index -> + Entity + { + db_id = Some (Temp_id (string_of_int (index + 1))) + ; attrs = [ "salary", One_value (Int (next_int 100_000)) ] + }) + | _ -> List.init size random_man + in + let schema = if schema = "minimal" then minimal_schema else full_schema in + let storage = benchmark_memory_storage () in + let db = db_with entities (empty_db ~schema ~storage ()) in + refresh_db_indexes db + +let time_ms iterations f = + let start = Sys.time () in + for _ = 1 to iterations do + ignore (f ()) + done; + (Sys.time () -. start) *. 1000. /. float iterations + +let seq_len seq = + Seq.fold_left (fun count _ -> count + 1) 0 seq + +let bench label db = + let q () = + q_string db "[:find ?e ?s :where [?e :salary ?s] [(> ?s 50000)]]" |> List.length + in + let seq () = seq_len (index_range db "salary" ~start:(Int 50001) ()) in + let seq_one () = seq_len (index_range db "salary" ~start:(Int 1) ~stop:(Int 1) ()) in + Printf.printf "%s count=%d one=%d ms_q=%.4f ms_seq=%.4f ms_one=%.4f max_e=%d\n" label (q ()) + (seq_one ()) + (time_ms 200 q) + (time_ms 200 seq) + (time_ms 200 seq_one) + db.max_datom_e + +let () = + rng := 1; + bench "minimal" (build_db "minimal" 2000); + rng := 1; + bench "full" (build_db "full" 2000) diff --git a/bench/dune b/bench/dune index 67c4a83..0d37dee 100644 --- a/bench/dune +++ b/bench/dune @@ -1,31 +1,55 @@ +(executable + (name index_compare_20k) + (modules index_compare_20k) + (libraries datascript-ocaml-native unix)) + +;; Shared scenario code depends on the virtual datascript library; each +;; executable selects a concrete implementation (native vs jsoo). +(library + (name memory_bench_common) + (modules memory_scenario) + (libraries datascript)) + (executable (name bench_ocaml) (modules bench_ocaml) - (modes exe js) + (modes exe) (libraries datascript-ocaml-native unix)) +;; js_of_ocaml bench must use the jsoo package (native LMDB is not linkable to JS). +(executable + (name bench_ocaml_js) + (modules bench_ocaml_js) + (modes js) + (libraries datascript-ocaml-jsoo js_of_ocaml)) + (executable (name query_profile) (modules query_profile) - (modes exe js) + (modes exe) (libraries datascript-ocaml-native unix)) -(library - (name memory_bench_common) - (modules memory_scenario) - (libraries datascript-ocaml-native)) +(executable + (name count_avet) + (modules count_avet) + (libraries datascript-ocaml-native unix)) + +(executable + (name shared_query_bench) + (modules shared_query_bench) + (libraries datascript-ocaml-native datascript_sqlite datascript_lmdb unix sqlite3)) (executable (name memory_ocaml) (modules memory_ocaml) (modes exe) - (libraries memory_bench_common unix)) + (libraries memory_bench_common datascript-ocaml-native unix)) (executable (name memory_ocaml_js) (modules memory_ocaml_js) (modes js) - (libraries memory_bench_common js_of_ocaml)) + (libraries memory_bench_common datascript-ocaml-jsoo js_of_ocaml)) (executable (name persistent_sqlite) @@ -33,17 +57,35 @@ (modes exe) (libraries datascript-ocaml-native datascript_sqlite unix sqlite3)) +(executable + (name index_scan_bench) + (modules index_scan_bench) + (modes exe) + (libraries datascript-ocaml-native datascript_sqlite datascript_lmdb unix sqlite3)) + +(executable + (name persistent_storage_bench) + (modules persistent_storage_bench) + (modes exe) + (libraries datascript-ocaml-native datascript_sqlite datascript_lmdb unix sqlite3)) + +(executable + (name storage_rss_bench) + (modules storage_rss_bench) + (modes exe) + (libraries datascript-ocaml-native datascript_sqlite datascript_lmdb unix sqlite3)) + (executable (name outliner_insert_ocaml) (modules outliner_insert_ocaml) - (modes exe js) + (modes exe) (libraries datascript-ocaml-native unix)) (rule (alias bench) (deps bench_ocaml.exe - bench_ocaml.bc.js + bench_ocaml_js.bc.js memory_ocaml.exe memory_ocaml_js.bc.js bench_upstream.js diff --git a/bench/index_compare_20k.ml b/bench/index_compare_20k.ml new file mode 100644 index 0000000..ed5979b --- /dev/null +++ b/bench/index_compare_20k.ml @@ -0,0 +1,131 @@ +open Datascript + +type timing = { label : string; elapsed_ms : float } + +let now_ms () = Unix.gettimeofday () *. 1000. + +let time label f = + let start = now_ms () in + let result = f () in + ({ label; elapsed_ms = now_ms () -. start }, result) + +let print_timing { label; elapsed_ms } = + Printf.printf "%s\t%.2f\n%!" label elapsed_ms + +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 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 schema = + [ ("id", unique_identity) + ; ("name", indexed) + ; ("age", indexed) + ; ("salary", indexed) + ; ("alias", many) + ] + +let names = [| "Ivan"; "Petr"; "Sergey"; "Oleg"; "Yuri"; "Dmitry"; "Fedor"; "Denis" |] +let last_names = [| "Ivanov"; "Petrov"; "Sidorov"; "Kovalev"; "Kuznetsov"; "Voronoi" |] + +type rng = { mutable state : int32 } + +let rng seed = { state = Int32.of_int seed } + +let next_int rng bound = + rng.state <- Int32.add (Int32.mul rng.state 1_664_525l) 1_013_904_223l; + Int32.(to_int (rem (logand (shift_right_logical rng.state 1) 0x3fffffffl) (of_int bound))) + +let rand_nth rng values = values.(next_int rng (Array.length values)) + +let datoms_for size = + let rng = rng 1 in + List.init size (fun index -> + let i = index + 1 in + let name = rand_nth rng names in + let last_name = rand_nth rng last_names in + [ + { e = i; a = "name"; v = String name; tx = 0x20000001; added = true } + ; { e = i; a = "last-name"; v = String last_name; tx = 0x20000001; added = true } + ; { e = i; a = "age"; v = Int (next_int rng 100); tx = 0x20000001; added = true } + ; { e = i; a = "salary"; v = Int (next_int rng 100_000); tx = 0x20000001; added = true } + ]) + |> List.concat + +let entity_count db = Seq.length (datoms db Eavt ()) + +let parse_size () = + match Sys.argv with + | [| _; size |] -> int_of_string size + | _ -> 20_000 + +let main () = + let size = parse_size () in + let runtime_label = + match Sys.getenv_opt "BENCH_RUNTIME_LABEL" with + | Some label -> label + | None -> "ocaml" + in + Printf.printf "runtime\t%s\n%!" runtime_label; + Printf.printf "size\t%d\n%!" size; + Printf.printf "datoms\t%d\n%!" (size * 4); + let datoms = datoms_for size in + let build_all, db = + time "build-all-init" (fun () -> init_db ~schema datoms) + in + print_timing build_all; + let find_name, rows = + time "query-name-ivan" (fun () -> + q_string db "[:find ?e :where [?e :name \"Ivan\"]]") + in + print_timing find_name; + Printf.printf "query-name-ivan-count\t%d\n%!" (List.length rows); + Printf.printf "datom-count\t%d\n%!" (entity_count db); + let scan_name, count = + time "scan-aevt-name" (fun () -> + fold_datoms (fun count _ -> count + 1) 0 db Aevt ~a:"name" ()) + in + print_timing scan_name; + Printf.printf "scan-aevt-name-count\t%d\n%!" count; + let add_one, db = + time "add-one-tx" (fun () -> + db_with [ Add (Entity_id 1, "nickname", String "Vanya") ] db) + in + print_timing add_one; + ignore db; + let storage, restored = + time "storage-roundtrip" (fun () -> + let storage = memory_storage () in + let db = init_db ~schema ~storage datoms in + store db; + match restore storage with + | Some db -> db + | None -> failwith "restore failed") + in + print_timing storage; + Printf.printf "restored-datom-count\t%d\n%!" (entity_count restored) + +let () = main () diff --git a/bench/index_scan_bench.ml b/bench/index_scan_bench.ml new file mode 100644 index 0000000..034fa38 --- /dev/null +++ b/bench/index_scan_bench.ml @@ -0,0 +1,351 @@ +(* Index-scan microbench: measure LMDB vs SQLite storage engines directly. + Avoids the shared query evaluator so differences are mostly Index I/O + decode. + + Phases per backend × size: + 1. build large db on disk (batched tx), durable sync, close + 2. cold open + restore (no prior warmup in this process for that file) + 3. cold single-shot index scans + 4. hot scans after warmup (OS page cache + stmt/cursor warm) + + Optional --drop-caches attempts to flush page cache between close and reopen + (requires write access to /proc/sys/vm/drop_caches). *) + +open Datascript + +type backend = Lmdb | Sqlite + +let backend_label = function + | Lmdb -> "lmdb" + | Sqlite -> "sqlite" + +let now_ms () = Unix.gettimeofday () *. 1000. + +let ensure_dir path = + let rec loop dir = + if dir = "" || dir = Filename.current_dir_name || Sys.file_exists dir then () + else ( + loop (Filename.dirname dir); + try Unix.mkdir dir 0o755 with + | Unix.Unix_error (Unix.EEXIST, _, _) -> ()) + in + loop path + +let remove_file path = if Sys.file_exists path then Sys.remove path + +let remove_path path = + remove_file path; + List.iter remove_file [ path ^ "-wal"; path ^ "-shm"; path ^ "-lock" ] + +let file_size path = + if Sys.file_exists path then (Unix.stat path).st_size else 0 + +let disk_footprint path = + List.fold_left + (fun total suffix -> total + file_size (if suffix = "" then path else path ^ suffix)) + 0 + [ ""; "-wal"; "-shm"; "-lock" ] + +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 schema = + [ "name", indexed + ; "last-name", indexed + ; "sex", indexed + ; "age", indexed + ; "salary", indexed + ] + +let names = [| "Ivan"; "Petr"; "Sergei"; "Oleg"; "Yuri"; "Dmitry"; "Fedor"; "Denis" |] +let last_names = [| "Ivanov"; "Petrov"; "Sidorov"; "Kovalev"; "Kuznetsov"; "Voronoi" |] +let sexes = [| "male"; "female" |] + +type rng = { mutable state : int32 } + +let rng seed = { state = Int32.of_int seed } + +let next_int rng bound = + rng.state <- Int32.add (Int32.mul rng.state 1_664_525l) 1_013_904_223l; + Int32.(to_int (rem (logand (shift_right_logical rng.state 1) 0x3fffffffl) (of_int bound))) + +let rand_nth rng values = values.(next_int rng (Array.length values)) +let rand_sex rng = sexes.(next_int rng 997 mod Array.length sexes) + +let person rng i = + Entity + { db_id = Some (Temp_id (string_of_int i)) + ; attrs = + [ "name", One_value (String (rand_nth rng names)) + ; "last-name", One_value (String (rand_nth rng last_names)) + ; "sex", One_value (Keyword (rand_sex rng)) + ; "age", One_value (Int (next_int rng 100)) + ; "salary", One_value (Int (next_int rng 100_000)) + ] + } + +(* Build in chunks so a 1M entity tx list does not dominate RSS. *) +let build_chunk_size = 25_000 + +let consume_seq seq = Seq.fold_left (fun n _ -> n + 1) 0 seq + +let blackhole = ref 0 + +let consume_count n = blackhole := !blackhole + n + +type config = + { sizes : int list + ; data_dir : string + ; warmup : int + ; repeats : int + ; drop_caches : bool + ; backends : backend list + } + +let default_config = + { sizes = [ 50_000 ] + ; data_dir = Filename.concat (Filename.get_temp_dir_name ()) "datascript-index-scan" + ; warmup = 20 + ; repeats = 5 + ; drop_caches = false + ; backends = [ Lmdb; Sqlite ] + } + +let parse_int_list value = + value + |> String.split_on_char ',' + |> List.map String.trim + |> List.filter (( <> ) "") + |> List.map int_of_string + +let parse_backends value = + value + |> String.split_on_char ',' + |> List.map String.trim + |> List.filter (( <> ) "") + |> List.map (function + | "lmdb" -> Lmdb + | "sqlite" -> Sqlite + | other -> invalid_arg ("unknown backend: " ^ other)) + +let parse_args () = + let config = ref default_config in + let rec loop = function + | [] -> !config + | "--size" :: v :: rest -> + config := { !config with sizes = [ int_of_string v ] }; + loop rest + | "--sizes" :: v :: rest -> + config := { !config with sizes = parse_int_list v }; + loop rest + | "--data-dir" :: v :: rest -> + config := { !config with data_dir = v }; + loop rest + | "--warmup" :: v :: rest -> + config := { !config with warmup = int_of_string v }; + loop rest + | "--repeats" :: v :: rest -> + config := { !config with repeats = int_of_string v }; + loop rest + | "--drop-caches" :: rest -> + config := { !config with drop_caches = true }; + loop rest + | "--backends" :: v :: rest -> + config := { !config with backends = parse_backends v }; + loop rest + | arg :: _ -> invalid_arg ("unknown argument: " ^ arg) + in + Sys.argv |> Array.to_list |> List.tl |> loop + +let try_drop_caches enabled = + if not enabled then Printf.printf "drop-caches\tskipped\n%!" + else ( + ignore (Unix.system "sync"); + let oc_opt = + try Some (open_out "/proc/sys/vm/drop_caches") with + | Sys_error _ -> None + in + match oc_opt with + | None -> Printf.printf "drop-caches\tunavailable\n%!" + | Some oc -> + (try + output_string oc "3\n"; + close_out oc; + Printf.printf "drop-caches\tok\n%!" + with Sys_error msg -> + (try close_out_noerr oc with _ -> ()); + Printf.printf "drop-caches\tfailed:%s\n%!" msg)) + +let time_once f = + let start = now_ms () in + let result = f () in + now_ms () -. start, result + +let time_median ~warmup ~repeats f = + for _ = 1 to warmup do + ignore (f ()) + done; + let samples = + List.init repeats (fun _ -> + let start = now_ms () in + ignore (f ()); + now_ms () -. start) + in + let sorted = List.sort compare samples in + List.nth sorted (List.length sorted / 2) + +let format_ms ms = Printf.sprintf "%.3f" ms + +type session_handle = + | Lmdb_session of Datascript_lmdb.session + | Sqlite_session of Datascript_sqlite.session + +let open_backend backend path = + match backend with + | Lmdb -> + let session = Datascript_lmdb.open_session path in + Lmdb_session session, storage_of_handle (Datascript_lmdb.storage session) + | Sqlite -> + let session = Datascript_sqlite.open_session path in + Sqlite_session session, storage_of_handle (Datascript_sqlite.storage session) + +let close_backend = function + | Lmdb_session session -> Datascript_lmdb.close session + | Sqlite_session session -> Datascript_sqlite.close session + +let db_path ~data_dir backend size = + let ext = match backend with Lmdb -> "mdb" | Sqlite -> "sqlite3" in + Filename.concat data_dir + (Printf.sprintf "index-scan-%s-%d.%s" (backend_label backend) size ext) + +let build_db ~storage size = + let r = rng 1 in + let rec loop i db = + if i > size then db + else + let chunk_end = min size (i + build_chunk_size - 1) in + let tx = List.init (chunk_end - i + 1) (fun k -> person r (i + k)) in + let db = db_with tx db in + (* Persist chunk boundaries so Share backends flush index pages and the + OCaml db does not retain a giant pending tx history. *) + store db; + loop (chunk_end + 1) db + in + loop 1 (empty_db ~schema ~storage ()) + +let build_on_disk ~data_dir backend size = + let path = db_path ~data_dir backend size in + remove_path path; + let handle, storage = open_backend backend path in + let build_ms, () = + time_once (fun () -> + let db = build_db ~storage size in + store db; + collect_garbage storage; + ignore db) + in + close_backend handle; + path, build_ms, disk_footprint path + +type scan = + { name : string + ; run : db -> int + } + +let scans ~size = + let mid = max 1 (size / 2) in + [ { name = "point-eavt-entity" + ; run = + (fun db -> + consume_seq (datoms db Eavt ~e:mid ())) + } + ; { name = "prefix-aevt-name" + ; run = + (fun db -> + fold_datoms (fun n _ -> n + 1) 0 db Aevt ~a:"name" ()) + } + ; { name = "exact-avet-name-ivan" + ; run = + (fun db -> + consume_seq (datoms db Avet ~a:"name" ~v:(String "Ivan") ())) + } + ; { name = "range-avet-salary-50k-60k" + ; run = + (fun db -> + consume_seq (index_range db "salary" ~start:(Int 50_000) ~stop:(Int 60_000) ())) + } + ; { name = "seek-eavt-mid-take-100" + ; run = + (fun db -> + seek_datoms db Eavt ~e:mid () + |> Seq.take 100 + |> consume_seq) + } + ; { name = "scan-eavt-all" + ; run = + (fun db -> + fold_datoms (fun n _ -> n + 1) 0 db Eavt ()) + } + ] + +let run_backend ~warmup ~repeats ~drop_caches ~data_dir size backend = + let label = backend_label backend in + Printf.printf "storage\t%s\n%!" label; + let path, build_ms, bytes = build_on_disk ~data_dir backend size in + Printf.printf "path\t%s\n%!" path; + Printf.printf "disk-bytes\t%d\n%!" bytes; + Printf.printf "build-ms\t%s\n%!" (format_ms build_ms); + try_drop_caches drop_caches; + let open_ms, (handle, db) = + time_once (fun () -> + let handle, storage = open_backend backend path in + match restore storage with + | Some db -> handle, db + | None -> failwith (label ^ " restore failed")) + in + Printf.printf "cold-open-restore-ms\t%s\n%!" (format_ms open_ms); + Fun.protect + ~finally:(fun () -> + close_backend handle; + remove_path path) + (fun () -> + List.iter + (fun scan -> + let cold_ms, cold_count = time_once (fun () -> scan.run db) in + consume_count cold_count; + Printf.printf "cold-%s-ms\t%s\n%!" scan.name (format_ms cold_ms); + Printf.printf "cold-%s-count\t%d\n%!" scan.name cold_count; + let hot_ms = + time_median ~warmup ~repeats (fun () -> consume_count (scan.run db)) + in + Printf.printf "hot-%s-ms\t%s\n%!" scan.name (format_ms hot_ms)) + (scans ~size)) + +let run_size config size = + Printf.printf "size\t%d\n%!" size; + List.iter + (run_backend ~warmup:config.warmup ~repeats:config.repeats + ~drop_caches:config.drop_caches ~data_dir:config.data_dir size) + config.backends + +let main () = + let config = parse_args () in + if config.sizes = [] then invalid_arg "at least one --size / --sizes entry required"; + ensure_dir config.data_dir; + Printf.printf "runtime\tOCaml\n%!"; + Printf.printf "data-dir\t%s\n%!" config.data_dir; + Printf.printf "warmup\t%d\n%!" config.warmup; + Printf.printf "repeats\t%d\n%!" config.repeats; + Printf.printf "bench\tindex-scan\n%!"; + List.iter (run_size config) config.sizes; + Printf.eprintf "blackhole=%d\n%!" !blackhole + +let () = main () diff --git a/bench/persistent_sqlite.ml b/bench/persistent_sqlite.ml index 15717eb..f4c5e87 100644 --- a/bench/persistent_sqlite.ml +++ b/bench/persistent_sqlite.ml @@ -122,7 +122,7 @@ let run_size size = Datascript_sqlite.close session; remove_if_exists db_path) (fun () -> - let storage = Datascript_sqlite.storage session in + let storage = storage_of_handle (Datascript_sqlite.storage session) in let persistent_build, persistent_db = time "snapshot-build-and-store" (fun () -> let db = db_with tx (empty_db ~schema ~storage ()) in diff --git a/bench/persistent_storage_bench.ml b/bench/persistent_storage_bench.ml new file mode 100644 index 0000000..ac83370 --- /dev/null +++ b/bench/persistent_storage_bench.ml @@ -0,0 +1,314 @@ +open Datascript + +type timing = { label : string; elapsed_ms : float } + +let now_ms () = Unix.gettimeofday () *. 1000. + +let time label f = + let start = now_ms () in + let result = f () in + ({ label; elapsed_ms = now_ms () -. start }, result) + +let print_timing prefix { label; elapsed_ms } = + Printf.printf "%s%s\t%.2f\n%!" prefix label elapsed_ms + +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 schema = + [ + ("block/id", unique_identity); + ("block/journal-day", indexed); + ("block/content", indexed); + ("block/order", indexed); + ("block/collapsed", indexed); + ] + +let block_tx count = + List.init count (fun index -> + let i = index + 1 in + Entity + { + db_id = Some (Temp_id (Printf.sprintf "block-%05d" i)); + attrs = + [ + ("block/id", One_value (String (Printf.sprintf "block-%05d" i))); + ("block/journal-day", One_value (String "2026-06-27")); + ("block/content", One_value (String (Printf.sprintf "Block %05d" i))); + ("block/order", One_value (Float (Float.of_int i))); + ("block/collapsed", One_value (Bool false)); + ]; + }) + +let add_block_tx id order = + [ + Entity + { + db_id = Some (Temp_id id); + attrs = + [ + ("block/id", One_value (String id)); + ("block/journal-day", One_value (String "2026-06-27")); + ("block/content", One_value (String id)); + ("block/order", One_value (Float order)); + ("block/collapsed", One_value (Bool false)); + ]; + }; + ] + +let update_content_tx id content = + [ Add (Lookup_ref ("block/id", String id), "block/content", String content) ] + +let seq_length seq = Seq.fold_left (fun count _ -> count + 1) 0 seq + +let file_size path = + if Sys.file_exists path then (Unix.stat path).st_size else 0 + +let disk_footprint path = + let siblings = + [ path + ; path ^ "-wal" + ; path ^ "-shm" + ; path ^ "-lock" + ] + in + List.fold_left (fun total sibling -> total + file_size sibling) 0 siblings + +let remove_file path = if Sys.file_exists path then Sys.remove path + +let remove_if_exists path = + remove_file path; + List.iter remove_file [ path ^ "-wal"; path ^ "-shm"; path ^ "-lock" ] + +let row_count _storage = 1 + +let flush_to_disk storage = collect_garbage storage + +let data_dir = ref (Filename.get_temp_dir_name ()) +let include_memory = ref true + +module type BACKEND = sig + val name : string + val extension : string + type session + val open_session : string -> session + val close_session : session -> unit + val storage : session -> storage + val cleanup : string -> unit +end + +module Sqlite_backend : BACKEND = struct + type session = Datascript_sqlite.session + + let name = "sqlite" + let extension = "sqlite3" + let open_session = Datascript_sqlite.open_session + let close_session = Datascript_sqlite.close + let storage session = storage_of_handle (Datascript_sqlite.storage session) + let cleanup _path = () +end + +module Lmdb_backend : BACKEND = struct + type session = Datascript_lmdb.session + + let name = "lmdb" + let extension = "lmdb" + let open_session = Datascript_lmdb.open_session + let close_session = Datascript_lmdb.close + let storage session = storage_of_handle (Datascript_lmdb.storage session) + + let cleanup path = + let lock = path ^ "-lock" in + if Sys.file_exists lock then Sys.remove lock +end + +let run_backend (module B : BACKEND) size tx = + let prefix = B.name ^ "-" in + let db_path = + Filename.concat !data_dir + (Printf.sprintf "datascript-persistent-%s-%d.%s" B.name size B.extension) + in + remove_if_exists db_path; + let session = B.open_session db_path in + Fun.protect + ~finally:(fun () -> + B.close_session session; + remove_if_exists db_path; + B.cleanup db_path) + (fun () -> + let storage = B.storage session in + let persistent_build, persistent_db = + time "snapshot-build-and-store" (fun () -> + let db = db_with tx (empty_db ~schema ~storage ()) in + store db; + flush_to_disk storage; + db) + in + print_timing prefix persistent_build; + Printf.printf "%ssnapshot-build-datoms\t%d\n%!" prefix + (seq_length (datoms persistent_db Eavt ())); + Printf.printf "%ssnapshot-kvs-rows-after-build\t%d\n%!" prefix (row_count storage); + Printf.printf "%ssnapshot-file-size-after-build\t%d\n%!" prefix (disk_footprint db_path); + let restore_timing, restored_db = + time "snapshot-restore" (fun () -> + match restore storage with + | Some db -> db + | None -> failwith (B.name ^ " persistent db should restore")) + in + print_timing prefix restore_timing; + let persistent_add, restored_db = + time "snapshot-add-one-and-store-after-restore" (fun () -> + let db = + db_with + (add_block_tx "persistent-new" (Float.of_int (size + 1))) + restored_db + in + store db; + flush_to_disk storage; + db) + in + print_timing prefix persistent_add; + Printf.printf "%ssnapshot-kvs-rows-after-add\t%d\n%!" prefix (row_count storage); + Printf.printf "%ssnapshot-file-size-after-add\t%d\n%!" prefix (disk_footprint db_path); + let persistent_update, restored_db = + time "snapshot-update-one-and-store-after-add" (fun () -> + let db = db_with (update_content_tx "block-00001" "Edited") restored_db in + store db; + flush_to_disk storage; + db) + in + print_timing prefix persistent_update; + Printf.printf "%ssnapshot-kvs-rows-after-update\t%d\n%!" prefix (row_count storage); + Printf.printf "%ssnapshot-file-size-after-update\t%d\n%!" prefix (disk_footprint db_path); + Printf.printf "%ssnapshot-datoms\t%d\n%!" prefix + (seq_length (datoms restored_db Eavt ())); + let conn_db_path = + Filename.concat !data_dir + (Printf.sprintf "datascript-persistent-%s-conn-%d.%s" B.name size B.extension) + in + remove_if_exists conn_db_path; + let session = B.open_session conn_db_path in + Fun.protect + ~finally:(fun () -> + B.close_session session; + remove_if_exists conn_db_path; + B.cleanup conn_db_path) + (fun () -> + let storage = B.storage session in + let conn_build, conn = + time "conn-build" (fun () -> + let conn = create_conn ~schema ~storage () in + ignore (transact_conn conn tx); + flush_to_disk storage; + conn) + in + print_timing prefix conn_build; + Printf.printf "%sconn-build-datoms\t%d\n%!" prefix + (seq_length (datoms (db conn) Eavt ())); + Printf.printf "%sconn-kvs-rows-after-build\t%d\n%!" prefix (row_count storage); + Printf.printf "%sconn-file-size-after-build\t%d\n%!" prefix (disk_footprint conn_db_path); + let conn_restore, conn = + time "conn-restore" (fun () -> + match restore_conn storage with + | Some conn -> conn + | None -> failwith (B.name ^ " persistent conn should restore")) + in + print_timing prefix conn_restore; + let conn_add, _report = + time "conn-add-one-after-restore" (fun () -> + let report = + transact_conn conn (add_block_tx "conn-new" (Float.of_int (size + 1))) + in + flush_to_disk storage; + report) + in + print_timing prefix conn_add; + Printf.printf "%sconn-kvs-rows-after-add\t%d\n%!" prefix (row_count storage); + Printf.printf "%sconn-file-size-after-add\t%d\n%!" prefix (disk_footprint conn_db_path); + let conn_update, _report = + time "conn-update-one-after-add" (fun () -> + let report = transact_conn conn (update_content_tx "block-00001" "Edited") in + flush_to_disk storage; + report) + in + print_timing prefix conn_update; + Printf.printf "%sconn-kvs-rows-after-update\t%d\n%!" prefix (row_count storage); + Printf.printf "%sconn-file-size-after-update\t%d\n%!" prefix (disk_footprint conn_db_path); + Printf.printf "%sconn-datoms\t%d\n%!" prefix (seq_length (datoms (db conn) Eavt ())))) + +let run_memory size tx = + let memory_build, memory_db = + time "memory-build" (fun () -> db_with tx (empty_db ~schema ())) + in + print_timing "" memory_build; + let memory_add, memory_db = + time "memory-add-one" (fun () -> + db_with (add_block_tx "memory-new" (Float.of_int (size + 1))) memory_db) + in + print_timing "" memory_add; + let _memory_update, memory_db = + time "memory-update-one" (fun () -> + db_with (update_content_tx "block-00001" "Edited") memory_db) + in + print_timing "" _memory_update; + Printf.printf "memory-datoms\t%d\n%!" (seq_length (datoms memory_db Eavt ())) + +let run_size size = + Printf.printf "size\t%d\n%!" size; + let tx = block_tx size in + if !include_memory then run_memory size tx; + run_backend (module Sqlite_backend) size tx; + run_backend (module Lmdb_backend) size tx + +let parse_args () = + let rec loop sizes = function + | [] -> List.rev sizes + | "--size" :: size :: rest -> loop (int_of_string size :: sizes) rest + | "--sizes" :: value :: rest -> + let parsed = + value + |> String.split_on_char ',' + |> List.filter (fun value -> String.length value > 0) + |> List.map int_of_string + in + loop (List.rev_append parsed sizes) rest + | "--disk-only" :: rest -> + include_memory := false; + loop sizes rest + | "--data-dir" :: dir :: rest -> + data_dir := dir; + loop sizes rest + | arg :: _ -> invalid_arg ("unknown benchmark argument: " ^ arg) + in + match loop [] (Sys.argv |> Array.to_list |> List.tl) with + | [] -> [ 100; 1000; 5000 ] + | sizes -> sizes + +let ensure_dir path = + let rec loop dir = + if dir = "" || dir = Filename.current_dir_name || Sys.file_exists dir then () + else ( + loop (Filename.dirname dir); + try Unix.mkdir dir 0o755 with + | Unix.Unix_error (Unix.EEXIST, _, _) -> ()) + in + loop path + +let () = + let sizes = parse_args () in + ensure_dir !data_dir; + Printf.printf "data-dir\t%s\n%!" !data_dir; + Printf.printf "disk-only\t%b\n%!" (not !include_memory); + List.iter run_size sizes diff --git a/bench/query_profile.ml b/bench/query_profile.ml index 9758d04..143afb3 100644 --- a/bench/query_profile.ml +++ b/bench/query_profile.ml @@ -296,6 +296,10 @@ let () = measure "q-sex-name-age" iterations (fun () -> q_len db "[:find ?e ?a :where [?e :sex :male] [?e :name \"Ivan\"] [?e :age ?a]]"); measure "q-name-last-age-sex" iterations (fun () -> q_len db "[:find ?e ?l ?a :where [?e :name \"Ivan\"] [?e :last-name ?l] [?e :age ?a] [?e :sex :male]]"); measure "qpred1" iterations (fun () -> q_len db "[:find ?e ?s :where [?e :salary ?s] [(> ?s 50000)]]"); + measure "avet-salary-range-seq" iterations (fun () -> + seq_len (index_range db "salary" ~start:(Int 50001) ())); + measure "avet-salary-range-bounded" iterations (fun () -> + seq_len (index_range db "salary" ~start:(Int 50001) ~stop:(Int 80_000) ())); measure "qpred2" iterations diff --git a/bench/shared_query_bench.ml b/bench/shared_query_bench.ml new file mode 100644 index 0000000..25d0cbd --- /dev/null +++ b/bench/shared_query_bench.ml @@ -0,0 +1,493 @@ +open Datascript + +(* Align with the shared 20k people query suite and timing protocol. *) + +type storage_backend = + | Memory_lmdb_nosync + | Lmdb_file + | Sqlite_file + +type config = + { size : int + ; warmup_ms : float + ; sample_ms : float + ; repeats : int + ; step : int + ; jit_warmup : int + ; query : string option + ; storages : storage_backend list + ; data_dir : string + } + +let default_config = + { size = 20_000 + ; warmup_ms = 200. + ; sample_ms = 200. + ; repeats = 2 + ; step = 10 + ; jit_warmup = 100 + ; query = None + ; storages = [ Memory_lmdb_nosync ] + ; data_dir = Filename.get_temp_dir_name () + } + +let storage_label = function + | Memory_lmdb_nosync -> "memory-lmdb-nosync" + | Lmdb_file -> "lmdb" + | Sqlite_file -> "sqlite" + +let parse_storage_list value = + value + |> String.split_on_char ',' + |> List.map String.trim + |> List.filter (fun s -> s <> "") + |> List.map (function + | "memory-lmdb-nosync" | "memory" -> Memory_lmdb_nosync + | "lmdb" -> Lmdb_file + | "sqlite" -> Sqlite_file + | other -> + invalid_arg + ("unknown storage " + ^ other + ^ " (expected: memory-lmdb-nosync|lmdb|sqlite, comma-separated)")) + +let int_from_env name default = + match Sys.getenv_opt name with + | Some value -> int_of_string value + | None -> default + +let float_from_env name default = + match Sys.getenv_opt name with + | Some value -> float_of_string value + | None -> default + +let query_from_env () = + match Sys.getenv_opt "BENCH_QUERY" with + | Some "" -> None + | Some value -> Some value + | None -> None + +let config_from_env base = + { base with + warmup_ms = float_from_env "BENCH_WARMUP_MS" base.warmup_ms + ; sample_ms = float_from_env "BENCH_SAMPLE_MS" base.sample_ms + ; repeats = int_from_env "BENCH_REPEATS" base.repeats + ; jit_warmup = int_from_env "BENCH_JIT_WARMUP" base.jit_warmup + ; query = (match query_from_env () with Some query -> Some query | None -> base.query) + } + +let parse_args () = + let config = ref (config_from_env default_config) in + let set_size value = config := { !config with size = int_of_string value } in + let set_warmup value = config := { !config with warmup_ms = float_of_string value } in + let set_sample_ms value = config := { !config with sample_ms = float_of_string value } in + let set_repeats value = config := { !config with repeats = int_of_string value } in + let set_jit_warmup value = config := { !config with jit_warmup = int_of_string value } in + let set_query value = config := { !config with query = Some value } in + let set_storage value = + config := + { !config with + storages = + (match value with + | "all" -> [ Memory_lmdb_nosync; Lmdb_file; Sqlite_file ] + | "compare" -> [ Lmdb_file; Sqlite_file ] + | other -> parse_storage_list other) + } + in + let set_data_dir value = config := { !config with data_dir = value } in + let rec loop = function + | [] -> !config + | "--size" :: value :: rest -> + set_size value; + loop rest + | "--warmup-ms" :: value :: rest -> + set_warmup value; + loop rest + | "--sample-ms" :: value :: rest -> + set_sample_ms value; + loop rest + | "--repeats" :: value :: rest -> + set_repeats value; + loop rest + | "--jit-warmup" :: value :: rest -> + set_jit_warmup value; + loop rest + | "--query" :: value :: rest -> + set_query value; + loop rest + | "--storage" :: value :: rest -> + set_storage value; + loop rest + | "--data-dir" :: value :: rest -> + set_data_dir value; + loop rest + | arg :: _ -> invalid_arg ("unknown benchmark argument: " ^ arg) + in + Sys.argv |> Array.to_list |> List.tl |> loop + +let now_ms () = Unix.gettimeofday () *. 1000. + +let median values = + let sorted = List.sort Float.compare values in + List.nth sorted (List.length sorted / 2) + +let format_ms value = + if value > 1. then Printf.sprintf "%.2f" value + else if value > 0.01 then Printf.sprintf "%.3f" value + else Printf.sprintf "%.4f" value + +let blackhole = ref 0 + +let consume_rows rows = + (* Keep the result live without a second full walk; the query already + materializes the list. Matching reference benches that discard results. *) + match rows with + | [] -> () + | first :: rest -> + blackhole := + (!blackhole + List.length first + if rest == [] then 0 else 1) land 0x3fffffff + +let dotime duration_ms step f = + let start = now_ms () in + let deadline = start +. duration_ms in + let rec loop iterations = + for _ = 1 to step do + f () + done; + let iterations = iterations + step in + if now_ms () < deadline then loop iterations else (now_ms () -. start) /. float iterations + in + loop step + +let bench config f = + ignore (dotime config.warmup_ms config.step f); + let samples = List.init config.repeats (fun _ -> dotime config.sample_ms config.step f) in + median samples + +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 ref_many = + { + cardinality = Many + ; unique = None + ; indexed = false + ; is_component = false + ; no_history = false + ; doc = None + ; value_type = Some RefType + ; tuple_attrs = None + ; tuple_types = None + } + +let schema = + [ "name", indexed + ; "last-name", indexed + ; "sex", indexed + ; "age", indexed + ; "salary", indexed + ; "follows", ref_many + ] + +let names = [| "Ivan"; "Petr"; "Sergei"; "Oleg"; "Yuri"; "Dmitry"; "Fedor"; "Denis" |] +let last_names = [| "Ivanov"; "Petrov"; "Sidorov"; "Kovalev"; "Kuznetsov"; "Voronoi" |] +let sexes = [| "male"; "female" |] + +type rng = { mutable state : int32 } + +let rng seed = { state = Int32.of_int seed } + +let next_int rng bound = + rng.state <- Int32.add (Int32.mul rng.state 1_664_525l) 1_013_904_223l; + Int32.(to_int (rem (logand (shift_right_logical rng.state 1) 0x3fffffffl) (of_int bound))) + +let rand_nth rng values = values.(next_int rng (Array.length values)) + +(* See test_shared_queries.ml: decorrelate sex from name under this LCG. *) +let rand_sex rng = sexes.(next_int rng 997 mod Array.length sexes) + +let random_man rng i = + Entity + { + db_id = Some (Temp_id (string_of_int i) + ) + ; attrs = + [ "name", One_value (String (rand_nth rng names)) + ; "last-name", One_value (String (rand_nth rng last_names)) + ; "sex", One_value (Keyword (rand_sex rng)) + ; "age", One_value (Int (next_int rng 100)) + ; "salary", One_value (Int (next_int rng 100_000)) + ] + } + +let follow_rules = + Parser.parse_rules + (QueryFormVector + [ QueryFormVector + [ QueryFormVector [ QueryFormSymbol "follow"; QueryFormSymbol "?e1"; QueryFormSymbol "?e2" ] + ; QueryFormVector + [ QueryFormSymbol "?e1"; QueryFormKeyword "follows"; QueryFormSymbol "?e2" ] + ] ]) + +type query_case = + { name : string + ; run : db -> unit + } + +let q name query = + { name; run = (fun db -> consume_rows (q_string db query)) } + +let q_inputs name query inputs = + { + name + ; run = + (fun db -> consume_rows (q_string ~inputs db query)) + } + +let q_rules name query = + { name; run = (fun db -> consume_rows (q_string ~inputs:[ Arg_rules follow_rules ] db query)) } + +let queries = + [ + q "q1" "[:find ?e :where [?e :name \"Ivan\"]]" + ; q "q2" "[:find ?e ?a :where [?e :name \"Ivan\"] [?e :age ?a]]" + ; q "q2-switch" "[:find ?e ?a :where [?e :age ?a] [?e :name \"Ivan\"]]" + ; q "q3" "[:find ?e ?a :where [?e :name \"Ivan\"] [?e :age ?a] [?e :sex :male]]" + ; q + "q4" + "[:find ?e ?l ?a :where [?e :name \"Ivan\"] [?e :last-name ?l] [?e :age ?a] [?e :sex :male]]" + ; q + "q5" + "[:find ?e1 ?l ?a :where [?e :name \"Ivan\"] [?e :age ?a] [?e1 :age ?a] [?e1 :last-name ?l]]" + ; q "qpred1" "[:find ?e ?s :where [?e :salary ?s] [(> ?s 50000)]]" + ; q_inputs "qpred2" "[:find ?e ?s :in $ ?min_s :where [?e :salary ?s] [(> ?s ?min_s)]]" + [ Arg_scalar (Result_value (Int 50_000)) ] + ; q "q-or" "[:find ?e :where (or [?e :name \"Ivan\"] [?e :name \"Petr\"])]" + ; q "q-not" "[:find ?e ?a :where [?e :age ?a] (not [?e :sex :male])]" + ; q + "q-or-join" + "[:find ?e ?a :where [?e :age ?a] (or-join [?e] [?e :name \"Ivan\"] [?e :name \"Petr\"])]" + ; q "q-not-join" "[:find ?e ?a :where [?e :age ?a] (not-join [?e] [?e :sex :male])]" + ; q + "q-pred-range" + "[:find ?e ?s :where [?e :salary ?s] [(> ?s 50000)] [(< ?s 80000)]]" + ; q + "q-5-merge" + "[:find ?e ?n ?l ?a ?s :where [?e :name ?n] [?e :last-name ?l] [?e :age ?a] [?e :salary ?s] [?e :sex :male]]" + ; q_rules "q-rule" "[:find ?e1 ?e2 :in $ % :where (follow ?e1 ?e2)]" + ] + +let query_names = + List.map (fun query -> query.name) queries + +let select_queries = function + | None -> queries + | Some name -> + (match List.find_opt (fun query -> query.name = name) queries with + | Some query -> [ query ] + | None -> + invalid_arg + (Printf.sprintf "unknown query %S (available: %s)" name (String.concat ", " query_names))) + +let remove_path path = + if Sys.file_exists path then Sys.remove path; + List.iter + (fun suffix -> + let sibling = path ^ suffix in + if Sys.file_exists sibling then Sys.remove sibling) + [ "-wal"; "-shm"; "-lock" ] + +let file_size path = + if Sys.file_exists path then (Unix.stat path).st_size else 0 + +let disk_footprint path = + List.fold_left + (fun total suffix -> total + file_size (if suffix = "" then path else path ^ suffix)) + 0 + [ ""; "-wal"; "-shm"; "-lock" ] + +let people_and_follows size = + let rng = rng 1 in + let entities = List.init size (fun index -> random_man rng (index + 1)) in + let follow_ops = + List.concat_map + (fun entity_id -> + if next_int rng 2 = 0 then + let target = 1 + next_int rng size in + [ Add (Entity_id entity_id, "follows", Ref target) ] + else + []) + (List.init size (fun index -> index + 1)) + in + entities, follow_ops + +let build_db_with_storage ~storage ~persist size = + let entities, follow_ops = people_and_follows size in + let started = now_ms () in + let db = db_with entities (empty_db ~schema ~storage ()) in + let db = if follow_ops = [] then db else db_with follow_ops db in + let db = refresh_db_indexes db in + let build_ms = now_ms () -. started in + if not persist then db, build_ms, 0. + else + let store_started = now_ms () in + store db; + collect_garbage storage; + let restored = + match restore storage with + | Some db -> db + | None -> failwith "storage-backed benchmark db should restore" + in + let restore_ms = now_ms () -. store_started in + restored, build_ms, restore_ms + +type prepared_db = + { label : string + ; db : db + ; build_ms : float + ; restore_ms : float + ; path : string option + ; cleanup : unit -> unit + } + +let prepare_backend ~data_dir backend size = + match backend with + | Memory_lmdb_nosync -> + let storage = benchmark_memory_storage () in + let db, build_ms, restore_ms = + build_db_with_storage ~storage ~persist:false size + in + { label = storage_label backend; db; build_ms; restore_ms; path = None; cleanup = Fun.id } + | Lmdb_file -> + let path = + Filename.concat data_dir + (Printf.sprintf "datascript-query-bench-lmdb-%d.mdb" size) + in + remove_path path; + let session = Datascript_lmdb.open_session path in + let (storage : storage) = storage_of_handle (Datascript_lmdb.storage session) in + let db, build_ms, restore_ms = + build_db_with_storage ~storage ~persist:true size + in + { label = storage_label backend + ; db + ; build_ms + ; restore_ms + ; path = Some path + ; cleanup = + (fun () -> + Datascript_lmdb.close session; + remove_path path) + } + | Sqlite_file -> + let path = + Filename.concat data_dir + (Printf.sprintf "datascript-query-bench-sqlite-%d.sqlite3" size) + in + remove_path path; + let session = Datascript_sqlite.open_session path in + let (storage : storage) = storage_of_handle (Datascript_sqlite.storage session) in + let db, build_ms, restore_ms = + build_db_with_storage ~storage ~persist:true size + in + { label = storage_label backend + ; db + ; build_ms + ; restore_ms + ; path = Some path + ; cleanup = + (fun () -> + Datascript_sqlite.close session; + remove_path path) + } + +let warmup_queries jit_warmup selected db = + if jit_warmup <= 0 then () + else + List.iter + (fun query -> + for _ = 1 to jit_warmup do + query.run db + done) + selected + +let run_backend config selected prepared = + Printf.printf "storage\t%s\n%!" prepared.label; + (match prepared.path with + | Some path -> + Printf.printf "path\t%s\n%!" path; + Printf.printf "disk-bytes\t%d\n%!" (disk_footprint path) + | None -> Printf.printf "path\tmemory\n%!"); + Printf.printf "build-ms\t%s\n%!" (format_ms prepared.build_ms); + if prepared.restore_ms > 0. then + Printf.printf "store-restore-ms\t%s\n%!" (format_ms prepared.restore_ms); + Printf.eprintf + "[%s] JIT pre-warmup (%d/query)...\n%!" + prepared.label + config.jit_warmup; + warmup_queries config.jit_warmup selected prepared.db; + Printf.eprintf "[%s] Running %d query benchmarks...\n%!" prepared.label (List.length selected); + List.iter + (fun query -> + let ms = bench config (fun () -> query.run prepared.db) in + Printf.printf "%s\t%s\n%!" query.name (format_ms ms)) + selected + +let ensure_dir path = + let rec loop dir = + if dir = "" || dir = Filename.current_dir_name || Sys.file_exists dir then () + else ( + loop (Filename.dirname dir); + try Unix.mkdir dir 0o755 with + | Unix.Unix_error (Unix.EEXIST, _, _) -> ()) + in + loop path + +let main () = + let config = parse_args () in + let selected = select_queries config.query in + ensure_dir config.data_dir; + let runtime_label = + match Sys.getenv_opt "BENCH_RUNTIME_LABEL" with + | Some label -> label + | None -> "ocaml" + in + Printf.printf "runtime\t%s\n%!" runtime_label; + Printf.printf "size\t%d\n%!" config.size; + Printf.printf "warmup-ms\t%.0f\n%!" config.warmup_ms; + Printf.printf "sample-ms\t%.0f\n%!" config.sample_ms; + Printf.printf "repeats\t%d\n%!" config.repeats; + Printf.printf "jit-warmup\t%d\n%!" config.jit_warmup; + Printf.printf "data-dir\t%s\n%!" config.data_dir; + Printf.printf "db-mode\tshared\n%!"; + Printf.printf "query-cases\t%d\n%!" (List.length selected); + (match config.query with + | Some name -> Printf.printf "query\t%s\n%!" name + | None -> ()); + List.iter + (fun backend -> + Printf.eprintf + "Building database (%d entities, storage=%s, data-dir=%s)...\n%!" + config.size + (storage_label backend) + config.data_dir; + let prepared = prepare_backend ~data_dir:config.data_dir backend config.size in + Fun.protect ~finally:prepared.cleanup (fun () -> run_backend config selected prepared)) + config.storages; + Printf.eprintf "blackhole=%d\n%!" !blackhole + +let () = + if Array.mem "--list-queries" Sys.argv then ( + List.iter (fun query -> Printf.printf "%s\n%!" query.name) queries; + exit 0); + main () \ No newline at end of file diff --git a/bench/storage_rss_bench.ml b/bench/storage_rss_bench.ml new file mode 100644 index 0000000..df8c5b7 --- /dev/null +++ b/bench/storage_rss_bench.ml @@ -0,0 +1,282 @@ +(* Storage RSS microbench: 50k people-like entities, common ops, GC/close release. + Backends: memory (temp LMDB), lmdb-file, sqlite-file. *) + +open Datascript + +type backend = + | Memory + | Lmdb_file + | Sqlite_file + +let backend_label = function + | Memory -> "memory" + | Lmdb_file -> "lmdb" + | Sqlite_file -> "sqlite" + +let now_ms () = Unix.gettimeofday () *. 1000. + +let rss_bytes () = + let channel = Unix.open_process_in (Printf.sprintf "ps -o rss= -p %d" (Unix.getpid ())) in + let line = try input_line channel with End_of_file -> "0" in + ignore (Unix.close_process_in channel); + line |> String.trim |> int_of_string |> fun kb -> kb * 1024 + +let heap_bytes () = + let stat = Gc.stat () in + stat.live_words * (Sys.word_size / 8) + +let settle () = + Gc.full_major (); + Unix.sleepf 0.05 + +let report backend phase = + settle (); + Printf.printf "backend\t%s\n%!" (backend_label backend); + Printf.printf "phase\t%s\n%!" phase; + Printf.printf "rss-bytes\t%d\n%!" (rss_bytes ()); + Printf.printf "heap-bytes\t%d\n%!" (heap_bytes ()) + +let ensure_dir path = + let rec loop dir = + if dir = "" || dir = Filename.current_dir_name || Sys.file_exists dir then () + else ( + loop (Filename.dirname dir); + try Unix.mkdir dir 0o755 with Unix.Unix_error (Unix.EEXIST, _, _) -> ()) + in + loop path + +let remove_path path = + List.iter + (fun p -> if Sys.file_exists p then Sys.remove p) + [ path; path ^ "-wal"; path ^ "-shm"; path ^ "-lock" ] + +type session = + | No_session + | Lmdb of Datascript_lmdb.session + | Sqlite of Datascript_sqlite.session + +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 schema = + [ "name", indexed + ; "last-name", indexed + ; "sex", indexed + ; "age", indexed + ; "salary", indexed + ] + +let names = [| "Ivan"; "Petr"; "Sergei"; "Oleg"; "Yuri"; "Dmitry"; "Fedor"; "Denis" |] +let last_names = [| "Ivanov"; "Petrov"; "Sidorov"; "Kovalev"; "Kuznetsov"; "Voronoi" |] +let sexes = [| "male"; "female" |] + +type rng = { mutable state : int32 } + +let rng seed = { state = Int32.of_int seed } + +let next_int rng bound = + rng.state <- Int32.add (Int32.mul rng.state 1_664_525l) 1_013_904_223l; + Int32.(to_int (rem (logand (shift_right_logical rng.state 1) 0x3fffffffl) (of_int bound))) + +let rand_nth rng values = values.(next_int rng (Array.length values)) +let rand_sex rng = sexes.(next_int rng 997 mod Array.length sexes) + +let person rng i = + Entity + { db_id = Some (Temp_id (string_of_int i)) + ; attrs = + [ "name", One_value (String (rand_nth rng names)) + ; "last-name", One_value (String (rand_nth rng last_names)) + ; "sex", One_value (Keyword (rand_sex rng)) + ; "age", One_value (Int (next_int rng 100)) + ; "salary", One_value (Int (next_int rng 100_000)) + ] + } + +let chunk = 10_000 + +let build_db ~storage size = + let r = rng 1 in + let rec loop i db = + if i > size then db + else + let hi = min size (i + chunk - 1) in + let tx = List.init (hi - i + 1) (fun k -> person r (i + k)) in + let db = db_with tx db in + (match storage with + | Some storage -> + store db; + collect_garbage storage + | None -> ()); + Printf.eprintf "built\t%d/%d\trss=%d\n%!" hi size (rss_bytes ()); + loop (hi + 1) db + in + match storage with + | Some storage -> loop 1 (empty_db ~schema ~storage ()) + | None -> loop 1 (empty_db ~schema ()) + +let update_person rng i = + Entity + { db_id = Some (Entity_id (i + 1)) + ; attrs = + [ "age", One_value (Int (next_int rng 100)) + ; "salary", One_value (Int (next_int rng 100_000)) + ] + } + +let blackhole = ref 0 +let consume n = blackhole := (!blackhole + n) land 0x3fffffff + +let query_name_age = lazy (parse_query_string "[:find ?e ?a :where [?e :name \"Ivan\"] [?e :age ?a]]") +let query_salary = lazy (parse_query_string "[:find ?e ?s :where [?e :salary ?s] [(> ?s 50000)]]") +let query_sex = + lazy (parse_query_string "[:find ?e ?a :where [?e :name \"Ivan\"] [?e :age ?a] [?e :sex :male]]") + +let run_queries db = + consume (Seq.fold_left (fun n _ -> n + 1) 0 (datoms db Aevt ~a:"name" ())); + consume (List.length (q db (Lazy.force query_name_age))); + consume (List.length (q db (Lazy.force query_salary))); + consume (List.length (q db (Lazy.force query_sex))); + for entity_id = 1 to 100 do + match pull db [ Pull_attr "name"; Pull_attr "age"; Pull_attr "salary" ] (Entity_id entity_id) with + | None -> consume 0 + | Some entity -> consume (List.length entity.pulled_attrs) + done + +type config = + { size : int + ; tx_size : int + ; data_dir : string + ; backends : backend list + } + +let default_config = + { size = 50_000 + ; tx_size = 200 + ; data_dir = Filename.concat (Filename.get_temp_dir_name ()) "datascript-storage-rss" + ; backends = [ Memory; Lmdb_file; Sqlite_file ] + } + +let parse_backends value = + value + |> String.split_on_char ',' + |> List.map String.trim + |> List.filter (( <> ) "") + |> List.map (function + | "memory" -> Memory + | "lmdb" -> Lmdb_file + | "sqlite" -> Sqlite_file + | other -> invalid_arg ("unknown backend: " ^ other)) + +let parse_args () = + let config = ref default_config in + let rec loop = function + | [] -> !config + | "--size" :: v :: rest -> + config := { !config with size = int_of_string v }; + loop rest + | "--tx-size" :: v :: rest -> + config := { !config with tx_size = int_of_string v }; + loop rest + | "--data-dir" :: v :: rest -> + config := { !config with data_dir = v }; + loop rest + | "--backends" :: v :: rest -> + config := { !config with backends = parse_backends v }; + loop rest + | arg :: _ -> invalid_arg ("unknown argument: " ^ arg) + in + Sys.argv |> Array.to_list |> List.tl |> loop + +let open_backend ~data_dir backend size = + match backend with + | Memory -> No_session, None, None + | Lmdb_file -> + let path = Filename.concat data_dir (Printf.sprintf "rss-lmdb-%d.mdb" size) in + remove_path path; + let session = Datascript_lmdb.open_session path in + let storage = storage_of_handle (Datascript_lmdb.storage session) in + Lmdb session, Some storage, Some path + | Sqlite_file -> + let path = Filename.concat data_dir (Printf.sprintf "rss-sqlite-%d.sqlite3" size) in + remove_path path; + let session = Datascript_sqlite.open_session path in + let storage = storage_of_handle (Datascript_sqlite.storage session) in + Sqlite session, Some storage, Some path + +let close_session = function + | No_session -> () + | Lmdb session -> Datascript_lmdb.close session + | Sqlite session -> Datascript_sqlite.close session + +let disk_bytes path = + List.fold_left + (fun total suffix -> + let p = if suffix = "" then path else path ^ suffix in + if Sys.file_exists p then total + (Unix.stat p).st_size else total) + 0 + [ ""; "-wal"; "-shm"; "-lock" ] + +let run_backend config backend = + Printf.printf "storage\t%s\n%!" (backend_label backend); + report backend "baseline"; + let session, storage, path = open_backend ~data_dir:config.data_dir backend config.size in + let build_start = now_ms () in + let db = ref (build_db ~storage config.size) in + (match storage with + | Some storage -> store !db; collect_garbage storage + | None -> ()); + Printf.printf "build-ms\t%.1f\n%!" (now_ms () -. build_start); + (match path with + | Some path -> Printf.printf "disk-bytes\t%d\n%!" (disk_bytes path) + | None -> Printf.printf "disk-bytes\t0\n%!"); + report backend "after-build"; + run_queries !db; + report backend "after-queries"; + let r = rng 99 in + let tx = List.init config.tx_size (fun i -> update_person r i) in + db := db_with tx !db; + (match storage with + | Some storage -> store !db; collect_garbage storage + | None -> ()); + report backend "after-tx"; + run_queries !db; + report backend "after-queries-2"; + settle (); + report backend "after-gc-full-major"; + Gc.compact (); + Unix.sleepf 0.05; + report backend "after-gc-compact"; + db := empty_db (); + settle (); + Gc.compact (); + Unix.sleepf 0.1; + report backend "after-drop-db"; + close_session session; + settle (); + Gc.compact (); + Unix.sleepf 0.1; + report backend "after-close"; + (match path with + | Some path -> remove_path path + | None -> ()); + Printf.printf "blackhole\t%d\n%!" !blackhole + +let () = + let config = parse_args () in + ensure_dir config.data_dir; + Printf.printf "runtime\tOCaml\n%!"; + Printf.printf "size\t%d\n%!" config.size; + Printf.printf "tx-size\t%d\n%!" config.tx_size; + Printf.printf "data-dir\t%s\n%!" config.data_dir; + Printf.printf "bench\tstorage-rss\n%!"; + List.iter (run_backend config) config.backends diff --git a/datascript-ocaml-melange.opam b/datascript-ocaml-melange.opam index 3f574a1..7d8532e 100644 --- a/datascript-ocaml-melange.opam +++ b/datascript-ocaml-melange.opam @@ -8,12 +8,10 @@ depends: [ "ocaml" {>= "5.1.1"} "dune" {>= "3.17"} "datascript_ocaml" {= version} - "persistent_sorted_set_ocaml" {= "dev"} "melange" "melange-transit-melange" {= "0.1.0"} ] pin-depends: [ - ["persistent_sorted_set_ocaml.dev" "git+https://github.com/logseq/persistent-sorted-set-ocaml.git#main"] ["melange-edn-core.0.5.0" "git+https://github.com/RCmerci/melange-edn.git#main"] ["melange-edn-melange.0.5.0" "git+https://github.com/RCmerci/melange-edn.git#main"] ["melange-transit-core.0.1.0" "git+https://github.com/RCmerci/melange-transit.git#main"] 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 9fb78c0..5f3b0df 100644 --- a/datascript-ocaml-native.opam +++ b/datascript-ocaml-native.opam @@ -8,13 +8,12 @@ depends: [ "ocaml" {>= "5.1.1"} "dune" {>= "3.17"} "datascript_ocaml" {= version} - "persistent_sorted_set_ocaml" {= "dev"} - "sqlite3" + "lmdb" + "alcotest" "melange-transit-native" {= "0.1.0"} "yojson" ] pin-depends: [ - ["persistent_sorted_set_ocaml.dev" "git+https://github.com/logseq/persistent-sorted-set-ocaml.git#main"] ["melange-edn-core.0.5.0" "git+https://github.com/RCmerci/melange-edn.git#main"] ["melange-edn-native.0.5.0" "git+https://github.com/RCmerci/melange-edn.git#main"] ["melange-transit-core.0.1.0" "git+https://github.com/RCmerci/melange-transit.git#main"] diff --git a/datascript_ocaml.opam b/datascript_ocaml.opam index 72cf185..4130cd0 100644 --- a/datascript_ocaml.opam +++ b/datascript_ocaml.opam @@ -7,12 +7,8 @@ license: "MIT" depends: [ "ocaml" {>= "5.1.1"} "dune" {>= "3.17"} - "persistent_sorted_set_ocaml" {= "dev"} "melange" ] -pin-depends: [ - ["persistent_sorted_set_ocaml.dev" "git+https://github.com/logseq/persistent-sorted-set-ocaml.git#main"] -] build: [ ["dune" "build" "-p" name "-j" jobs] ] diff --git a/docs/adr/query-planner.md b/docs/adr/query-planner.md new file mode 100644 index 0000000..1f15955 --- /dev/null +++ b/docs/adr/query-planner.md @@ -0,0 +1,93 @@ +# ADR: Compiled Query Planner for Datalog Pattern Queries + +## Status + +Accepted — Datahike-aligned logical/physical IR is live; relational interpreter +remains the permanent fallback. `datascript.ml` shape-gate `simple_*` bypasses +were removed. + +## Context + +The query engine evaluates `:where` clauses through a hybrid interpreter in +`impl/query_where.ml` (relation `{ attrs; rows }` path, then binding path). +That interpreter is the Datahike-style **relational fallback**: it must remain +for ineligible shapes (recursive rules, exotic callables, multi-source cases, +DataScript error-order for `not`, etc.). + +Previously, `Datascript.q` also tried six benchmark-shaped `simple_*` gates that +duplicated `query_where` logic and drifted from it. Those gates are removed. + +The planner mirrors Datahike's pipeline at the IR level: + +``` +classify / build logical → lower (cost + readiness) → execute via relation ops + ↳ on ineligible / non-executable plans: relational interpreter +``` + +Observable **results** stay DataScript-compatible. **Execution architecture** +follows Datahike (explicit divergence from “implementation details match +DataScript”). + +Performance remains a hard requirement: native OCaml must lead tracked +benchmarks; `js_of_ocaml` must stay at least on par with upstream DataScript JS. + +## Decision + +### Logical IR (`impl/query_plan.ml`) + +| Node | Meaning | +| --- | --- | +| `LScan` | Single pattern | +| `LEntityJoin` | Same-entity scans + foldable anti-scans + attached filters | +| `LFilter` | Comparison / equality predicates | +| `LUnion` | `or` / `or-join` | +| `LAntiJoin` | `not` / `not-join` not folded into an entity group | +| `LRuleExpand` | Non-recursive rule (usually inlined before lower) | +| `LPassthrough` | Force relational fallback for that clause | + +### Lowering + +- Index preference from ground components (EAVT / AEVT / AVET). +- Entity-group legs ordered cheapest-first. +- Filters attached when their vars ⊆ one entity group. +- Readiness-aware schedule among physical ops. +- Queries containing any `not` / `not-join` **keep source clause order** so + DataScript unbound-var errors remain observable. + +### Execution + +Physical ops lower back to ordered clauses consumed by existing operators: + +- `relation_of_same_entity_patterns`, `relation_of_pattern`, AVET range helpers +- `hash_join`, `anti_join`, `union_relations` +- Find projection in `query_api.ml` + +Entry: `Datascript.q` → `Query_impl.q` → `q_sources_raw` → `eval_relation_rows` +(with `plan_ordered_clauses`) → binding interpreter if needed. + +### Non-goals (deferred) + +- Full fused cursor pipelines / Selinger DP / count-slice cardinality +- Semi-naive recursive fixpoint / stratum aggregates / prepared-query cache +- Deleting the relational interpreter + +## Consequences + +### Positive + +- One planner + one fallback (Datahike shape); no duplicate `simple_*` gates. +- Logical entity grouping matches Datahike’s `LEntityJoin` model. +- Dead stub IR (`left_deep_join` discarded, unused `RangeScan` constructors) replaced. + +### Risks + +- Planner reordering must not change DataScript error surfaces (mitigated by + source-order preserve on NOT). +- Cost estimates are still heuristic until real slice counts land. + +## References + +- Datahike `doc/query-engine.md`, `src/datahike/query/*` +- `docs/datahike-query-alignment.md` +- `docs/query_implementation_comparison.md` +- `impl/query_plan.ml`, `impl/query_where.ml` diff --git a/docs/datahike-ocaml-query-comparison.md b/docs/datahike-ocaml-query-comparison.md new file mode 100644 index 0000000..66eef54 --- /dev/null +++ b/docs/datahike-ocaml-query-comparison.md @@ -0,0 +1,287 @@ +# Datahike vs OCaml Query Implementation Comparison + +Reference clone: `_deps/datahike` (replikativ/datahike, shallow clone for local diff). +Upstream doc: `_deps/datahike/doc/query-engine.md`. + +Observable **results** must stay DataScript-compatible. **Execution architecture** +should follow Datahike's compiled planner + permanent relational fallback. + +## Pipeline mapping + +| Phase | Datahike | OCaml (this repo) | Gap | +| --- | --- | --- | --- | +| Entry | `datahike/query.cljc` → `q` / `execute-planned-direct` | `datascript.ml` → `Query_impl.q` → `query_api.ml` `q_sources_raw` | OK (no `simple_*` on `q`) | +| Classify | `query/analyze.cljc` `classify-clause` | Inline in `query_plan.ml` / `query_where.ml` pattern parsing | No dedicated analyze module | +| Logical IR | `query/logical.cljc` `build-logical-plan` | `query_plan.ml` `build_logical_plan` | Same node shapes (`LEntityJoin`, `LScan`, …) | +| Lower | `query/lower.cljc` + `query/plan.cljc` | `query_plan.ml` `lower` / `compile` | **Major**: DH uses DP merge + pipeline DSL; OCaml flattens to clause list | +| Execute | `query/execute.cljc` fused scan+merge, probe-map joins | `query_exec.ml` drive-scan + AEVT seek/dense merge + anti-merge | Card-one entity groups implemented; multi-group probe joins still fallback | +| Fallback | `query/relation.cljc` + `query.cljc` `execute-legacy` | `query_where.ml` relation interpreter | Permanent fallback — correct role | +| Project | find projection in execute / query | `query_api.ml` `relation_rows_for_find` | OK | + +Datahike end-to-end: + +``` +analyze → logical.cljc → lower.cljc → execute.cljc → find project + ↳ ineligible → relation.cljc (legacy) +``` + +OCaml today: + +``` +query_plan.compile → OpEntityGroup/OpScan (ground) / EntityGroup+filters + ↳ query_exec resolved kernels (q2 / q-5-merge) + drive/merge/anti + ↳ else query_where relational fallback (multi-op Union, open scans, …) +``` + +The planner IR matches Datahike. Entity-group **execute** now follows +`execute-group-direct` / sorted-merge / anti-merge semantics (AEVT +forward-seek or dense index ≈ seekGE), not Datascript `simple_*` gates. +Resolved kernels are cached by entity-group physical identity (plan cache +reuses the same group object) to avoid re-matching merges on every call. +Multi-op Union / open-pattern scans stay on the relational fallback until +probe-join execute is competitive. + +## Module-by-module notes + +### `analyze.cljc` (Datahike) + +- Classifies each clause: `:pattern`, `:predicate`, `:function`, `:not`, `:or`, … +- Extracts vars, checks fn args, handles quote forms. +- **OCaml**: scattered across `Query.pattern_scan`, `query_plan.pattern_scan`, `query_where` clause walks. No single classify API. + +### `logical.cljc` (Datahike) + +Key behaviors (see `build-logical-plan`): + +1. Classify all clauses → `LScan` / `LFilter` / `LBind` / … +2. Group scans by `[entity-var, source]` → `LEntityJoin` +3. **Foldable NOT** (`foldable-not?`): single-pattern NOT on grouped entity, non-entity vars local to negation → **anti-scan inside entity group** +4. Remaining NOT → `LAntiJoin` +5. OR / rules → `LUnion` / `LRuleCall` / `LFixpoint` + +**OCaml** (`query_plan.ml` `build_logical_plan`): + +- Same grouping and foldable-NOT idea (`foldable_not_scan`). +- Extra constraint: fold only if positive scan **earlier in source order** (DataScript outer-binding errors). +- Does **not** tag nodes with `:source-idx` for bound-var-card propagation (Datahike lower uses this). + +### `plan.cljc` + `lower.cljc` (Datahike) + +Physical planning primitives: + +| Primitive | Purpose | +| --- | --- | +| `plan-pattern-op` | Index choice (EAVT/AEVT/AVET) + pushdown bounds | +| `dp-order-fuse-ops` | Optimal scan + merge order within entity group | +| `assemble-entity-group` | `:entity-group` op + `build-pipeline` | +| `detect-inter-group-joins` | Shared value vars → hash-probe plan | +| `dp-order-groups` / `order-plan-ops` | Inter-group order + readiness | + +Lower produces ops like: + +```clojure +{:op :entity-group + :scan-op {... :index :aevt ...} + :merge-ops [{:join-method :lookup ...} ...] + :pipeline {:path :sorted-merge :steps [...]}} +``` + +**OCaml** (`query_plan.ml`): + +- `OpEntityGroup { clauses; estimated_rows }` — **only clause list**, no scan/merge split, no pipeline. +- `lower` schedules ops by heuristic cost; `clauses_of_plan` **discards physical structure**. +- Index choice exists (`choose_index`) but is not consumed by a fused executor. + +### `execute.cljc` (Datahike) + +Core execution paths: + +1. **`execute-group-direct`** — entity group fused scan: + - Pick driving scan (lowest cardinality after DP) + - Walk index slice; for each datom, **seekGE** merge lookups (no intermediate relations) + - Paths: `:scan-only`, `:sorted-merge`, `:per-cursor-merge`, `:card-many-merge` +2. **Anti-merge** — during merge loop, skip entities matching anti-scan attr/value +3. **Multi-group** — producer probe-set / probe-map → consumer filtered scan +4. **Post-filter / post-apply** — wide tuples then project to find-vars + +**OCaml** (`query_where.ml`): + +- `relation_of_same_entity_patterns` — materializes `{ attrs; rows }` lists +- Dense AEVT gather (`try_same_entity_constant_dense_rows`, `try_fast_empty_relation_rows`) — **ad hoc**, not driven by `OpEntityGroup` / pipeline +- `hash_join` on relations — correct fallback shape, not cursor merge +- NOT: bitset exclusion scan OR `anti_join` on relations + +### `relation.cljc` (Datahike fallback) + +- Tuple relations, `hash-join`, `sum-rel`, `subtract-rel` +- Used when planner ineligible or `*disable-planner*` + +**OCaml**: same concepts in `query_where.ml` (`hash_join`, `anti_join`, `union_relations`). + +## Shared bench queries — shape-by-shape + +Queries from `bench/shared_query_bench.ml`. + +### q1 — `[:find ?e :where [?e :name "Ivan"]]` + +| | Datahike | OCaml | +| --- | --- | --- | +| Logical | `LScan` (ground value → AVET) | `LScan` → `OpScan` or single-pattern group | +| Execute | AVET slice or EAVT seek; **no relation alloc** | AVET ids or AEVT scan → relation rows | +| Gap | Direct emit to result set | Extra `{attrs;rows}` wrapper | + +### q2 — `[:find ?e ?a :where [?e :name "Ivan"] [?e :age ?a]]` + +| | Datahike | OCaml | +| --- | --- | --- | +| Logical | `LEntityJoin` with 2 scans | Same | +| Lower | `assemble-entity-group`: DP picks scan (`:name` selective) + merge `:age` via **lookupGE** | `OpEntityGroup` → flat clauses → `try_fast_*` or `relation_of_same_entity_patterns` | +| Execute | **Fused sorted-merge** — one pass, no hash join | Dense AEVT index gather OR hash_join two relations | +| Perf | ~0.6 ms (20k entities, DH bench doc) | ~0.009 ms (2k entities) vs **0.004 ms** pre-removal gate | + +Root cause of OCaml gap: execution still **materializes row lists** and duplicates kernel logic outside the planner op stream. + +### q-5-merge — five attrs + `[?e :sex :male]` + +| | Datahike | OCaml | +| --- | --- | --- | +| Logical | `LEntityJoin` 5 scans + constant on `:sex` | Same | +| Execute | DP order: selective constant/attr as scan, merges via cursor | Const-first aligned AEVT gather (4 value vars) | +| DH doc | "5-clause entity merge" **2.4 ms** @ 20k | **0.046 ms** @ 2k vs **0.030 ms** baseline | + +Datahike uses **merge ordering + seekGE**, not "all arrays aligned then index by entity id". + +### q-not / q-not-join — `[?e :age ?a] (not [?e :sex :male])` + +| | Datahike | OCaml | +| --- | --- | --- | +| Logical | Foldable NOT → **anti-scan** inside `LEntityJoin` on `?e` | Same fold in `build_logical_plan` | +| Execute | Anti-merge during fused scan (skip excluded entities) | `try_not_single_value_aevt_scan` / bitset + full AEVT walk | +| Planner | NOT present → still plans positive leg | **`plan_ordered_clauses` skips compile when any NOT** — source order only | +| DH doc | NOT **3.8 ms** @ 20k | **0.025 ms** @ 2k vs **0.023 ms** baseline | + +OCaml NOT path never uses planner ordering; anti-scan is reimplemented in fallback, not as merge op. + +### q-or-join, q-rule + +| Query | Datahike | OCaml | +| --- | --- | --- | +| q-or-join | `LUnion` → branch execute → combine | `eval_or_branch_relations` / union | +| q-rule | `LRuleCall` → expand → plan body | `try_single_pattern_rule_rows` + inline rules | + +## What is wrong with current `query_where.ml` complexity + +These are **execute-layer** concerns implemented inside the **fallback module**: + +| Mechanism | Lines (approx) | Datahike equivalent | +| --- | --- | --- | +| `try_fast_empty_relation_rows` | ~350 | Should not exist — `execute.cljc` `execute-group-direct` | +| `try_same_entity_constant_dense_rows` | ~150 | `assemble-entity-group` + `execute-sorted-merge` | +| `rows_from_dense_aevt_gather` | ~200 | Pipeline `PIndexScan` → `PSortedMerge` → `PEmitTuple` | +| `same_entity_fused_relation` | wrapper | `OpEntityGroup` execution | +| `relation_of_same_entity_patterns` | ~1300 | Split: lower produces ops, execute consumes ops | + +Adding more special cases in `query_where` **diverges further** from Datahike. The alignment doc (`docs/datahike-query-alignment.md` P3–P4) already says physical ops should drive execution. + +## Recommended refactor (Datahike-faithful) + +### 1. Add `impl/query_exec.ml` (execute layer) + +```ocaml +val run : + db -> physical_plan -> query_source -> bindings -> + (string list * query_result list list * bool) option +``` + +Implement op dispatch matching Datahike: + +- `OpEntityGroup` → fused entity-group execute (port `execute-group-direct` / `execute-sorted-merge` using existing `aevt_attr_array`, `entity_ids_array_by_attr_value`, index seeks) +- `OpScan` → single pattern scan +- `OpUnion` → `union_relations` +- `OpAntiJoin` → `anti_join` +- `OpFilter` → filter relation or in-group attached pred +- `OpPassthrough` → return `None` (fallback) + +Move dense gather / bitset NOT / aligned multi-attr logic **into** entity-group execute keyed by pipeline path — delete `try_fast_*`. + +### 2. Extend physical IR (minimal) + +Extend `OpEntityGroup` to carry what lower already knows: + +```ocaml +| OpEntityGroup of { + entity_var : string; + scan : l_scan; (* driving pattern *) + merges : l_scan list; (* DP-ordered *) + anti_scans : l_scan list; + filters : query_clause list; + index : index_choice; + ... + } +``` + +Stop flattening to `clauses` in `clauses_of_plan` for execution (keep flatten for tests/explain only). + +### 3. Wire entry (`query_api.ml`) + +```ocaml +match Query_plan.compile db.max_datom_e [] [] where with +| Some plan when Query_plan.plan_is_executable plan -> + (match Query_exec.run db plan default_source bindings with + | Some result -> ... + | None -> fallback interpreter) +| None -> fallback interpreter +``` + +Remove `try_fast_empty_relation_rows` bypass from `eval_relation_rows`. + +### 4. Keep `query_where.ml` as fallback only + +- `eval_relation_from_empty` / binding interpreter +- `hash_join`, `anti_join`, `union_relations`, `relation_of_pattern` +- Source-order NOT for DataScript error parity +- **No** bench-shaped dense kernels at module top level + +### 5. Port planning primitives incrementally + +Priority for bench perf: + +1. `dp-order-fuse-ops` (scan + merge order within group) — `plan.cljc:531` +2. `assemble-entity-group` + `build-pipeline` — `plan.cljc:831`, `:617` +3. `execute-sorted-merge` — `execute.cljc:1375` (card-one attrs, dense DBs) +4. Anti-merge in merge loop — NOT as separate full-DB bitset scan +5. Count-slice estimates — `estimate.cljc` (replace `max_e/8` heuristics) + +## File reference index (Datahike) + +| File | LOC (approx) | Read first | +| --- | --- | --- | +| `doc/query-engine.md` | 523 | Architecture overview | +| `src/datahike/query/ir.cljc` | 172 | IR + pipeline record defs | +| `src/datahike/query/analyze.cljc` | large | Clause classification | +| `src/datahike/query/logical.cljc` | 453 | `build-logical-plan`, NOT fold | +| `src/datahike/query/plan.cljc` | 1860 | DP merge, entity group, ordering | +| `src/datahike/query/lower.cljc` | medium | Logical → physical | +| `src/datahike/query/execute.cljc` | 6500+ | Fused scan, probe joins | +| `src/datahike/query/relation.cljc` | 300 | Fallback relations | +| `src/datahike/query.cljc` | 5300+ | Entry, planner eligibility | + +## Immediate action items + +1. **Stop expanding** `try_fast_empty_relation_rows` / `relation_of_same_entity_patterns` special cases. +2. **Implement** `query_exec.ml` with `OpEntityGroup` fused path for q1/q2/q-5-merge shapes. +3. **Extend** `query_plan.ml` `OpEntityGroup` to retain scan/merge structure (mirror `assemble-entity-group`). +4. **Delete** redundant dense kernels once execute path covers bench suite. +5. **Verify**: `test_shared_queries` + `shared_query_bench --size 2000` vs `3547876` baselines. + +## Local clone usage + +```bash +# Already cloned (gitignored) +ls _deps/datahike/src/datahike/query/ + +# Diff logical IR grouping +diff -u \ + <(rg -n 'LEntityJoin|foldable-not' _deps/datahike/src/datahike/query/logical.cljc) \ + <(rg -n 'LEntityJoin|foldable_not' impl/query_plan.ml) +``` diff --git a/docs/datahike-query-alignment.md b/docs/datahike-query-alignment.md new file mode 100644 index 0000000..812fe3a --- /dev/null +++ b/docs/datahike-query-alignment.md @@ -0,0 +1,115 @@ +# Datahike-Aligned Query Rewrite Plan + +Work branch: `logseq/shared-api-parity-fe5d` (PR #5). + +Observable query **results** remain DataScript-compatible. **Execution architecture** +aligns with Datahike's compiled planner (explicit user divergence from +"implementation details match DataScript"). + +## Reference + +Datahike pipeline (`replikativ/datahike`): + +``` +classify (analyze) → LogicalPlan (entity groups) → lower (cost + physical ops) + → execute (fused scan/merge / hash-probe) → find project + ↳ on ineligible shapes: relational engine (permanent fallback) +``` + +## End state + +1. **One primary path:** `q` / `q_sources_raw` → compile plan → execute → project. +2. **One fallback:** existing relation / binding interpreter in `query_where.ml` + (Datahike's "relational engine is permanent fallback"). +3. **No** `datascript.ml` `simple_*` shape gates on `q`. +4. **No** dead IR (`left_deep_join` discarded, `RangeScan` never built, `analyze` + unused at runtime). +5. **No** mid-eval fake `order_where_clauses` with `max_e/8` ratios without a plan; + ordering happens once in lower, with readiness constraints. +6. Docs (`adr/query-planner.md`, `query_planner_plan.md`, + `query_implementation_comparison.md`) match the code. + +## Phases + +### P0 — Remove Datascript query hacks + +- Delete `simple_avet_predicate_rows`, `simple_same_entity_constant_rows`, + `simple_cross_entity_value_join_rows`, `simple_or_join_constant_rows`, + `simple_not_join_constant_rows`, `simple_single_pattern_rule_rows` and helpers + only used by them. +- `Datascript.q` → `Query_impl.q` only (plus string parsing wrappers). +- Keep pull/collection helpers for a later pass unless they block simplification. + +### P1 — Logical IR (Datahike-shaped) + +Replace stub `query_plan.ml` types with: + +| Node | Meaning | +| --- | --- | +| `LScan` | Single pattern | +| `LEntityJoin` | Same-entity scans + foldable anti-scans | +| `LFilter` | Comparison / equality / predicate | +| `LBind` | Function binding (passthrough / fallback if unsupported) | +| `LUnion` | `or` / `or-join` | +| `LAntiJoin` | `not` / `not-join` not folded into entity group | +| `LRuleExpand` | Non-recursive rule head → body plan | +| `LPassthrough` | Force relational fallback for that clause | + +`build_logical_plan`: classify clauses → group by entity var → fold simple NOT +into anti-scans when non-entity vars are local (Datahike `foldable-not?`). + +### P2 — Lower + cost + +- Index choice: EAVT / AEVT / AVET from ground components (same rules as Datahike). +- Predicate pushdown onto AVET bounds for comparisons on value vars. +- Within `LEntityJoin`: order legs cheapest-first; driving scan = narrowest. +- Between groups: left-deep order by estimated cardinality. +- Estimates: prefer real index slice width when cheap; else schema/cardinality + heuristics — **not** fixed `max_datom_e/8` alone. +- Hard readiness: never schedule a filter/join before its vars are produced. +- Ineligible plans return `None` → interpreter fallback. + +### P3 — Execute + +Physical ops reuse existing operators (no parallel micro-implementations): + +- Entity group → `relation_of_same_entity_patterns` / pattern + AVET helpers +- Cross-group → `hash_join` +- OR → `union_relations` +- NOT → `anti_join` +- Non-recursive rules → inline then execute body plan +- Project via `relation_rows_for_find` + +Stream where already possible; avoid new `(max_e+1)` value arrays. + +### P4 — Wire entry + delete mid-eval reorder + +- `Query_api.q_sources_raw`: try `Query_exec.run` first when eligible + (no aggregates / `:with` / callables / multi-db disjoint / recursive rules). +- Remove `Query_plan.order_where_clauses` calls from + `eval_relation_from_*` once planner owns ordering. +- Export a small public surface: `analyze` / `explain`-style plan for tests. + +### P5 — Review and simplify + +- Delete unused IR constructors and duplicated AVET helpers left after P0. +- Collapse mirrored `eval_relation_from_empty` / `_from_relation` if safe. +- Update ADR + comparison docs; drop stale 50k-gate claims. +- Parity: `test_shared_queries`, `test_query_plan`, `dune runtest` query suites. +- Manual/bench spot-check shared suite sizes used in PR #5. + +## Non-goals (this pass) + +- Full Datahike semi-naive fixpoint / stratum aggregates / SIP / prepared-query cache. +- Porting `execute.cljc` line-for-line (~6k LOC); we match **architecture and + operator shapes**, implementing execute via OCaml relation primitives. +- Changing public `q` / `q_string` / inputs / rules API. + +## Success criteria + +- [x] No `simple_*` on `Datascript.q` path +- [x] Planner produces entity-group plans for shared-suite shapes (q1–q-rule) +- [x] Unsupported / NOT-heavy → interpreter source order; results match golden counts +- [x] No dead `left_deep_join` / unused stub `RangeScan` constructors +- [x] Docs describe the live pipeline +- [x] Review pass removed redundant shape gates (~1k LOC in `datascript.ml`) diff --git a/docs/design-non-pss.md b/docs/design-non-pss.md new file mode 100644 index 0000000..c9ef052 --- /dev/null +++ b/docs/design-non-pss.md @@ -0,0 +1,153 @@ +# Non-PSS LMDB Index Design + +Branch: `feat/non-pss` + +This document records the architecture for replacing `Persistent_sorted_set` indexes +with native LMDB indexes. Queries and writes go directly to LMDB. Datoms keep `tx`, +`added`, and DataScript `value` types (not Datalevin AVG/aid encoding). + +## Type strategy: Scheme A + +Replace PSS field types in `db` with an explicit `Index.t`. Do not alias +`Persistent_sorted_set` to LMDB. + +### New public types (`type/datascript_types.ml`) + +```ocaml +module Index : sig + type t + type 'a seq + val to_seq : 'a seq -> 'a Seq.t +end + +type index = Index.t + +and db = { + db_uid : int; + schema : schema; + eavt_index : index; + aevt_index : index; + avet_index : index; + (* caches and duplicate side tables unchanged *) + ... + storage_ref : storage option; + ... +} +``` + +`Index.t` is abstract at the type level. Native builds use LMDB; the type does not +mention PSS or LMDB in `datascript_types`. + +### Index module API (`lmdb/datascript_lmdb_index.mli`) + +Surface area required by `impl/db.ml` (PSS-free subset): + +```ocaml +type t +type 'a seq + +val empty : index -> t +val of_sorted_list : index -> datom list -> 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 +``` + +Notes: + +- `index` parameter is `Eavt | Aevt | Avet` (`Datascript_types.index`). +- Default comparator is `Util.compare_datom index`; bound slices pass custom `cmp` + (same as PSS today). +- `t` holds a reference to the shared LMDB environment and the DBI name for that + logical index (`ds/eavt`, `ds/aevt`, `ds/avet`). + +### Shared LMDB database handle + +Introduce `Lmdb_db.t` (one env per storage session): + +```ocaml +type t = { + env : Lmdb.Env.t; + eavt : (bytes, bytes, [`Uni]) Lmdb.Map.t; + aevt : (bytes, bytes, [`Uni]) Lmdb.Map.t; + avet : (bytes, bytes, [`Uni]) Lmdb.Map.t; + meta : (string, bytes, [`Uni]) Lmdb.Map.t; + path : string; +} +``` + +Each `Index.t` is `{ db : Lmdb_db.t; which : index }` or three dedicated handles +created at `empty_db` / `restore`. + +`storage` on `feat/non-pss` simplifies to wrapping `Lmdb_db.t`: + +```ocaml +type storage = Lmdb_db.t +``` + +Remove PSS snapshot payloads (`Storage_root`, `Storage_node`, tail groups) from the +native non-PSS path. Logseq SQLite reader code stays on other branches. + +## LMDB key/value encoding + +Keys are order-preserving binary tuples matching `Util.compare_datom`: + +| Index | Key field order | +| --- | --- | +| EAVT | e, a, v, tx | +| AEVT | a, e, v, tx | +| AVET | a, v, e, tx | + +- `v` uses a typed order-preserving encoder aligned with `Util.compare_value`. +- `tx` is included in the key (unlike Datalevin). +- Value payload stores at least `added : bool` and may mirror `v` for simpler decode. + +Duplicate numeric facts (`Int 1` vs `Float 1.0` comparator-equal but distinct) stay +in side tables (`duplicate_*` fields on `db`) with merge at read time, same as today. + +## Code migration map (Scheme A) + +| Area | Change | +| --- | --- | +| `type/datascript_types.ml` | `eavt_index` etc. become `Index.t`; drop PSS from `db` | +| `impl/db.ml` | `module PSet = ...` removed; call `Lmdb_index.*` | +| `impl/datascript.ml` | Replace direct `PSet.*` on `db.*_index` | +| `impl/serialize.ml` | Iterate LMDB or `to_list`; no PSS builders | +| `impl/storage.ml` | Open/sync `Lmdb_db`; delete PSS store/restore/tail | +| `impl/conn.ml` | Commit LMDB txn per transact; no tail compaction | +| `lmdb/*` | `datascript_lmdb_codec.ml`, `datascript_lmdb_index.ml`, `datascript_lmdb_db.ml` | +| `impl/dune` | Native links `datascript_lmdb_index`; drop `persistent_sorted_set_ocaml` on this branch | +| `test/test_db.ml` | Replace `assert_uses_persistent_sorted_set` with LMDB index checks | +| `bench/*` | Update labels; expect no snapshot full-tree rewrite | + +## What stays unchanged + +- Public query semantics: lazy `datoms`, bound slices, filtered DB order. +- `datom` record including `tx` and `added`. +- `value` algebra and `Util.compare_value` rules. +- Three indexes: EAVT, AEVT, AVET. + +## Implementation phases + +1. **Codec + Index unit tests** — key order matches `compare_datom`. +2. **`Lmdb_db` lifecycle** — temp env for `empty_db ()`, path-backed for conn. +3. **Rewire `db.ml`** — Scheme A types throughout. +4. **Storage + conn** — remove PSS snapshot/tail. +5. **Tests + bench** — parity vs PSS branch on small fixtures; benchmark tables. + +## Explicit non-goals (this branch) + +- js_of_ocaml / melange non-PSS. +- Logseq PSS `db.sqlite` compatibility. +- Datalevin-style aid/AVG encoding or dropping `tx` from storage. diff --git a/docs/design-tx-filter-history.md b/docs/design-tx-filter-history.md new file mode 100644 index 0000000..e7eed64 --- /dev/null +++ b/docs/design-tx-filter-history.md @@ -0,0 +1,136 @@ +# 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 → O(1) handle copy (no overlay) + store → append tx batch + meta update (sync_append_since_tx for delta copy) +``` + +## 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. + +## Purge (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: + +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. +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 + +### 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` + - 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. + +## 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/docs/lmdb-vs-sqlite.md b/docs/lmdb-vs-sqlite.md new file mode 100644 index 0000000..29551e6 --- /dev/null +++ b/docs/lmdb-vs-sqlite.md @@ -0,0 +1,42 @@ +# LMDB vs SQLite operator choice + +Native DataScript can persist indexes with either LMDB or SQLite. Both use the same +order-preserving index codec (`Datascript_index_codec`) and the same Index / +tx-visibility read pipeline. Prefer one based on ops and access pattern, not API. + +## Prefer LMDB when + +- You want memory-mapped range scans and the lowest query latency on large indexes. +- The deployment already depends on LMDB / can ship `liblmdb`. +- Writers and readers share a durable env and you are comfortable with LMDB sizing / + map growth (`mapsize`) and multi-process locking rules. + +## Prefer SQLite when + +- You want a **single portable file** (plus WAL/SHM sidecars in WAL mode) that ops + already know how to backup, inspect, and migrate. +- You want SQL tooling (`sqlite3` CLI) for debugging meta / key tables. +- Embedding constraints favor SQLite over LMDB, or you already link `libsqlite3`. + +## Shared behavior + +| Concern | Behavior | +| --- | --- | +| Live indexes | `Share_index_db` — queries/writes hit the storage file/env directly | +| Key layout | Three BLOB tables/DBIs: EAVT / AEVT / AVET (+ meta) | +| Temporal views | `as_of` / `since` / `history` use the same visibility filter above the store | +| Durability | LMDB `sync`; SQLite open defaults `WAL` + `synchronous=NORMAL`, `Storage.sync` forces FULL + WAL checkpoint | +| Reopen | Both `open_path` / `open_session` reopen existing files without deleting; callers wipe via `remove_path` when they want a fresh env | + +## Package map + +| Package | Backend | +| --- | --- | +| `datascript-ocaml-native` | Default in-memory indexes via LMDB temp env | +| `datascript-ocaml-native-lmdb` | File LMDB sessions | +| `datascript-ocaml-native-sqlite` | File SQLite sessions (no direct `lmdb_*` dune deps) | + +Benches: `bench/compare_lmdb_sqlite.sh` (persistent store/restore), +`bench/compare_lmdb_sqlite_queries.sh` (shared query suite), and +`bench/compare_lmdb_sqlite_index_scan.sh` (cold open + narrow Index scans; +default sizes `200000,500000`). diff --git a/docs/plan-sqlite-index-without-lmdb.md b/docs/plan-sqlite-index-without-lmdb.md new file mode 100644 index 0000000..ed0f939 --- /dev/null +++ b/docs/plan-sqlite-index-without-lmdb.md @@ -0,0 +1,271 @@ +# Plan: SQLite Index Without LMDB + +Branch: `logseq/sqlite-without-lmdb-fe5d` +Builds on: `logseq/shared-api-parity-fe5d` (non-PSS Index API, storage protocol, SQLite BLOB tables) +References: current LMDB Index (`lmdb/native/`), `docs/design-non-pss.md`, `docs/design-tx-filter-history.md`, vendor dbval `ITupleStore` / `dbval.store.sqlite` + +## Goal + +Make the SQLite backend a **first-class index engine**: open a SQLite file, transact, query, and restore **without linking or loading LMDB**, and without a temp LMDB mirror for runtime reads. + +Today SQLite is only a durable mirror of LMDB-codec keys; the live `db` indexes always run on a temporary LMDB env (`Separate_index_db`). That coupling is the root problem this plan removes. + +## Current state + +### Runtime path (SQLite) + +``` +open SQLite file + → register Separate_index_db backend + → Index.create_lmdb / create_index_db allocates temp LMDB + → load_indexes_from_storage: copy_indexes_to_lmdb (full table scan → LMDB put) + → queries/writes hit LMDB Index + → sync_indexes_to_storage: sync_append_since_tx (LMDB fold → SQLite REPLACE) + → sync_removals_to_storage: DELETE keys in SQLite +``` + +Relevant code: + +| Layer | Role today | +| --- | --- | +| `sqlite/datascript_sqlite_db.ml` | Tables `ds_eavt` / `ds_aevt` / `ds_avet` / `ds_meta`; BLOB PK + value; fold / prefix / range helpers | +| `sqlite/datascript_storage_sqlite.ml` | Meta + `copy_indexes_to_lmdb` + `sync_append_since_tx` + removals | +| `sqlite/datascript_storage_sqlite_plugin.ml` | `index_db = Separate_index_db`; sync/load callbacks typed on LMDB | +| `storage/.../datascript_storage_protocol.mli` | `Share_index_db of Datascript_lmdb_db.t` \| `Separate_index_db`; sync/load take `Datascript_lmdb_*` | +| `impl/index.mli` | Abstract API, but names/`type lmdb` and `create_lmdb` assume LMDB | +| `lmdb/native/datascript_lmdb_index.ml` | Full Index implementation (write txn, slice, rslice, seek, …) | +| `lmdb/datascript_lmdb_codec.ml` | Shared order-preserving key/value encoding (already used by SQLite) | +| `sqlite/dune` | `datascript-ocaml-native-sqlite` links `lmdb_*` + `datascript_lmdb_codec` | + +### What already works for a SQLite Index + +- Same codec as LMDB (`Datascript_lmdb_codec`) → byte order matches `Util.compare_datom`. +- Per-index BLOB tables with PK on key (ordered scans via `ORDER BY key`). +- Write txn (`BEGIN IMMEDIATE` / `COMMIT`), put/remove, meta store/restore. +- Forward range/prefix fold (`fold_index_range_until`, `fold_index_prefix`). + +### Gaps vs LMDB Index + +- No `Datascript_sqlite_index` implementing `Index` (slice / seq / rslice / seek / append_tx_data / …). +- No reverse range SQL (`ORDER BY key DESC`) — required for `rslice_seq`. +- Storage protocol hard-codes LMDB types in `Share_index_db`, `sync_*`, `load_*`, `create_index_db`, `db_for_storage`. +- Package and core native path still assume LMDB exists even for “SQLite-only” use. + +## dbval reference (what to take / what not to copy) + +dbval’s store is a thin ordered KV API (`vendor/dbval/src/dbval/store.clj`): + +```clojure +(defprotocol ITupleStore + (-scan [store begin end reverse?]) ; begin <= k < end, unsigned byte order + (-commit! [store keys blobs]) ; atomic batch insert (append-only) + (-get-blob [store hash]) + (-close! [store])) +``` + +SQLite impl (`dbval.store.sqlite`): + +- Single key table `dbval (k BLOB PRIMARY KEY) WITHOUT ROWID` (+ blob table for deref attrs). +- Autocommit reads; `-commit!` wraps batch inserts in one transaction. +- Scan supports `reverse?` via `ORDER BY k DESC`. +- Engine (not the store) owns tx-visibility / datoms-filter overlays. + +**Take from dbval:** + +1. Store is the source of truth for committed keys; no second engine for query. +2. Range scan primitive with optional reverse. +3. Atomic batch commit for a tx’s keys. +4. Visibility / history filtering stays above the store (already planned in `design-tx-filter-history.md`). + +**Do not copy blindly (divergence, keep DataScript/LMDB layout):** + +| dbval | This repo (keep) | +| --- | --- | +| One table, all indexes encoded into one key space | Three tables `ds_eavt` / `ds_aevt` / `ds_avet` (matches LMDB DBIs) | +| Keys only (values in blob store for deref) | Key + value BLOB (`added` + codec value), same as LMDB Index | +| Append-only `INSERT OR IGNORE` | Current put/replace + remove; append-only purge model follows tx-filter work | +| JDBC + WITHOUT ROWID | ocaml-sqlite3; optional WITHOUT ROWID later as optimization | +| Content-hash blobs | Out of scope unless/until deref attrs land | + +Observable DataScript behavior and the existing LMDB codec remain authoritative. + +## Design options + +### Option A — SQLite implements the Index API (recommended first) + +Treat `Datascript_sqlite_db.t` like `Datascript_lmdb_db.t`: one shared handle, three logical indexes. Add `datascript_sqlite_index.ml` mirroring `datascript_lmdb_index.ml`, reusing the same codec. + +Promote SQLite plugin to **share** its db handle (same role as LMDB `Share_index_db`): + +``` +open SQLite + → Share_index_db sqlite_db + → Index.empty Eavt|Aevt|Avet on that handle + → no copy_indexes_to_lmdb, no temp LMDB + → writes go to SQLite Index; sync_* become no-ops or meta-only +``` + +**Pros:** Smallest path to “SQLite without LMDB”; reuses Index call sites in `impl/db.ml`; keeps three-table layout and codec parity with LMDB for benches/tests. +**Cons:** Still two Index implementations until a deeper shared KV layer exists. + +### Option B — Introduce a dbval-like `Tuple_store` first + +Define an OCaml `Tuple_store` (scan / commit / close) with LMDB and SQLite adapters; rewrite `Index` once on top of `Tuple_store`. + +**Pros:** Matches dbval layering; one Index implementation. +**Cons:** Larger refactor of LMDB path before SQLite becomes independent; higher risk to current LMDB parity. + +### Decision + +**Ship Option A first.** Optionally extract a shared internal KV scan/commit helper later (Option B lite) once both backends are green and duplication is obvious. + +Keep Option B as a follow-up ADR if we want one Index over pluggable stores. + +## Target architecture (Option A) + +``` + ┌─────────────────────────┐ + │ impl/db.ml (Index API) │ + └───────────┬─────────────┘ + │ + ┌─────────────────┴─────────────────┐ + ▼ ▼ + Datascript_lmdb_index Datascript_sqlite_index + │ │ + Datascript_lmdb_db Datascript_sqlite_db + │ │ + LMDB env SQLite file + │ │ + └──────── Datascript_*_codec ───────┘ + (shared order-preserving keys) +``` + +Storage protocol (conceptual): + +```ocaml +type storage_index_db = + | Share_index_db of index_db (* opaque: LMDB or SQLite handle *) + | Separate_index_db (* reserved for true external mirrors *) + +(* Prefer: backend owns the shared handle; create_index_db returns that handle + when Share_index_db, else allocates a backend-default temp index db. *) +``` + +Concrete typing options (pick one in Phase 1): + +1. **Variant handle** — `index_db = Lmdb of Datascript_lmdb_db.t | Sqlite of Datascript_sqlite_db.t` in protocol/native only; Index module dispatches. +2. **First-class modules / functor** — Index ops parameterized by a `Db` signature (`with_write_txn`, `put`, `fold_range`, …). Cleaner long-term; more churn. +3. **Virtual library** — Dune virtual Index already exists per platform; add a native “sqlite index” product or select backend at link/register time. + +Recommendation: **(1) for the first PR series**, keep call sites simple; revisit (2) if dispatch noise grows. + +Rename for honesty (can be gradual): + +- `type lmdb` → `type index_db` (or keep alias) +- `create_lmdb` → `create_index_db` (protocol already has this name; Index wrapper should match) +- `Index.lmdb_of` / `db_of` → `index_db_of` + +## Phased work + +### Phase 0 — Scope lock (this doc) + +- [x] Document current Separate_index mirror and LMDB hard deps. +- [x] Choose Option A; document dbval takeaways and non-goals. +- [x] Agree: SQLite package must build/link **without** direct `lmdb_*` libraries + (transitive LMDB via `datascript-ocaml-native` for the default memory engine remains until a later optional-backend split). + +### Phase 1 — Decouple protocol types from concrete LMDB + +1. [x] Introduce `index_db = Lmdb | Sqlite` in the native storage protocol. +2. [x] Keep LMDB behavior for memory/file Share path (cross-env sync lives in Index). +3. [x] Rename Index entry points (`create_index_db`, `index_db`, aliases kept). +4. [x] `empty_db` / `init_db` / `restore` pass storage into `create_index_db`. + +**Exit:** native + tests green. + +### Phase 2 — `Datascript_sqlite_index` + +- [x] Implement Index surface over `Datascript_sqlite_db` (codec reused). +- [x] Wire native Index dispatch `Lmdb | Sqlite`. +- [x] Rename codec package to neutral `datascript_index_codec`. +- [x] SQL `ORDER BY key DESC` for rslice via `fold_index_range_desc_until`. + +**Exit:** SQLite Index round-trips without constructing an LMDB mirror for Share sessions. + +### Phase 3 — SQLite plugin becomes Share_index_db + +1. [x] Plugin: `Share_index_db (Sqlite sqlite)`; sync/load no-ops for shared handle. +2. [x] Drop `copy_indexes_to_lmdb` / LMDB-typed mirror helpers from sqlite storage. +3. [x] Drop direct `lmdb_db_native` / `lmdb_index_native` from `sqlite/dune`. +4. [x] Tests assert `db_shares_storage_index` for empty_db and restore. + +**Exit:** sqlite package has no direct `lmdb_*` dune deps; Share path verified. + +### Phase 4 — Hardening & parity + +1. [x] Tx-filter / history / as-of / since on SQLite Share path (same read pipeline; covered by sqlite temporal tests). +2. [x] WAL / synchronous pragmas: open `WAL` + `NORMAL`; `Storage.sync` → FULL + wal_checkpoint. +3. [x] `WITHOUT ROWID` on index/meta tables (dbval-style). +4. [x] Reverse scan via `fold_index_range_desc_until` for `rslice_seq`. +5. [x] Document operator choice: `docs/lmdb-vs-sqlite.md`. +6. [x] Codec rename: `Datascript_index_codec` / `datascript-ocaml-native.index-codec`. +7. [x] `open_path` no longer deletes existing files (reopen persistence). + +### Phase 5 (optional) — Tuple_store extraction + +Deferred: LMDB and SQLite Index duplication is acceptable for now; revisit if a third backend lands. + +## Package / dependency matrix (target) + +| Package / use | LMDB | SQLite | Codec | +| --- | --- | --- | --- | +| `datascript-ocaml-native` (memory default) | yes (until optional) | no | yes | +| `datascript-ocaml-native-lmdb` | yes | no | yes | +| `datascript-ocaml-native-sqlite` | **no** | yes | yes | +| Benches comparing both | yes | yes | yes | + +## Testing + +1. Existing sqlite storage / restore tests: switch expectation from “copy into LMDB” to “share sqlite index”; same public API results. +2. Shared query suite: `sqlite` storage mode must not open LMDB (assert via link or runtime probe in debug builds if useful). +3. Parity: LMDB file vs SQLite file on shared query + temporal views once Phase 4 lands. +4. Regression: memory LMDB path unchanged. + +## Non-goals (this plan) + +- Logseq legacy PSS `db.sqlite` / kvs format compatibility. +- Replacing LMDB as the default in-memory engine in the first series of PRs. +- Adopting dbval’s single-table key layout or content-addressed blob store. +- Melange / js_of_ocaml SQLite (native-only unless a separate effort). +- Making PostgreSQL / other backends Share_index in the same change set (protocol should allow it later). + +## Risks + +| Risk | Mitigation | +| --- | --- | +| `rslice_seq` / seek semantics differ | Golden tests vs LMDB Index on same datom sets | +| Perf regression vs LMDB mirror-in-RAM | Accept for v1; WAL + prepared stmts + WITHOUT ROWID experiments in Phase 4 | +| Core still pulls LMDB so “sqlite-only install” fails | Phase 3 dependency split; optional later default-backend flag | +| Protocol variant explodes call sites | Keep dispatch inside Index / protocol; db.ml stays on Index API | +| Codec package name implies LMDB | Rename to neutral module in Phase 2 | + +## Success criteria + +1. Documented plan reviewed (this file). +2. Application can depend on sqlite storage, run queries, and never load LMDB. +3. Observable query/tx results match LMDB backend for the shared suite. +4. SQLite dune library does not list `lmdb` / `lmdb_*` deps. + +## Suggested PR slice + +1. **Plan only** (this document). +2. Protocol / Index rename + `index_db` abstraction (LMDB-only behavior). +3. `datascript_sqlite_index` + codec rename + unit tests. +4. Plugin Share path + drop LMDB from sqlite package + bench/CI. +5. Tx-visibility / pragma / streaming follow-ups. + +## Open questions + +1. Should default `empty_db` (no storage) stay LMDB forever, or allow a compile/link-time sqlite default for sqlite-only products? +2. Keep three BLOB tables permanently, or migrate toward one dbval-style table after Index is shared? (Recommendation: keep three.) +3. Is renaming `Datascript_lmdb_codec` → `Datascript_index_codec` acceptable in the same PR as sqlite Index, or a pure move PR first? diff --git a/docs/query_implementation_comparison.md b/docs/query_implementation_comparison.md new file mode 100644 index 0000000..cb20fe0 --- /dev/null +++ b/docs/query_implementation_comparison.md @@ -0,0 +1,47 @@ +# OCaml vs Datahike Query Implementation Comparison + +This document compares the OCaml query path to Datahike's compiled planner +(architecture target) and notes the permanent relational fallback. + +## Architecture (current) + +| | Datahike | OCaml (this repo) | +|---|---|---| +| Primary path | analyze → logical IR → lower → fused execute | `Query_plan.compile` → ordered clauses → relation interpreter operators | +| Logical IR | `LEntityJoin`, `LScan`, `LFilter`, `LUnion`, `LAntiJoin`, … | Same shape in `impl/query_plan.ml` (`LEntityJoin`, `LScan`, …) | +| Fallback | Relational engine (permanent) | `query_where` relation / binding interpreter (permanent) | +| Shape gates on `q` | None (planner or fallback) | **Removed** — `Datascript.q` → `Query_impl.q` only | +| Hot-loop output | Dense tuples / cursors | `{attrs; rows}` relations, then find projection | +| Cost / order | count-slice + DP; readiness constraints | Ground-component estimates + readiness-aware schedule; **source order kept when any `not` is present** (DataScript error parity) | + +## Same-entity multi-attr + +**Datahike:** entity group + DP merge + index cursors. + +**OCaml:** `LEntityJoin` in the planner; execution via `relation_of_same_entity_patterns` +(bitset / lookup). No parallel `simple_same_entity_*` bypass in `datascript.ml`. + +## OR / NOT + +**Datahike:** `LUnion` / `LAntiJoin`; foldable NOT → anti-scan when safe. + +**OCaml:** planner builds `LUnion` / `LAntiJoin`; foldable NOT only when a positive +same-entity scan appears earlier in source order. Queries containing any NOT keep +source clause order so unbound-var errors match DataScript. + +## Cross-entity / predicates / rules + +- Cross-entity: `hash_join` on relations (no `(max_e+1)` value-array gate). +- Predicates: AVET helpers in `query_where` (`relation_of_avet_value_comparisons`). +- Non-recursive rules: inlined in `Query_plan.compile` and/or `expand_inline_rules`. + +## Verification + +| Check | Command | +|---|---| +| Result parity | `dune exec -- test/test_shared_queries.exe` | +| Category parity | `dune exec -- test/test_shared_api_parity.exe` | +| Planner unit tests | `dune exec -- test/test_query_plan.exe` | +| DataScript suite | `dune exec -- test/test_datascript.exe` | + +See also `docs/datahike-query-alignment.md` and `docs/adr/query-planner.md`. diff --git a/docs/query_planner.md b/docs/query_planner.md index f636248..9893ad8 100644 --- a/docs/query_planner.md +++ b/docs/query_planner.md @@ -406,9 +406,9 @@ opam exec -- dune runtest Required benchmark checks for query work: ```sh -opam exec -- dune build bench/bench_ocaml.exe bench/bench_ocaml.bc.js +opam exec -- dune build bench/bench_ocaml.exe bench/bench_ocaml_js.bc.js _build/default/bench/bench_ocaml.exe --size 5000 --warmup-ms 200 --sample-ms 400 --samples 5 -node _build/default/bench/bench_ocaml.bc.js --size 5000 --warmup-ms 200 --sample-ms 400 --samples 5 +node _build/default/bench/bench_ocaml_js.bc.js --size 5000 --warmup-ms 200 --sample-ms 400 --samples 5 UPSTREAM_DATASCRIPT_JS=_deps/datascript/release-js/datascript.js \ node bench/bench_upstream.js --size 5000 --warmup-ms 200 --sample-ms 400 --samples 5 ``` diff --git a/docs/query_planner_plan.md b/docs/query_planner_plan.md new file mode 100644 index 0000000..db60aff --- /dev/null +++ b/docs/query_planner_plan.md @@ -0,0 +1,126 @@ +# Query Planner Implementation Plan + +See also `docs/query_implementation_comparison.md` for a side-by-side analysis of +a reference compiled executor versus the current OCaml interpreter (lists, bindings, +allocation patterns, and per-query-shape gaps). + +This plan implements the decision in `docs/adr/query-planner.md`. It is ordered by +risk and benchmark impact. Each phase has explicit parity and performance gates. + +## Current baseline (interpreter + fast paths) + +| Area | Location | Behavior | +| --- | --- | --- | +| Relation evaluator | `impl/query_where.ml` | Shape-gated `{ attrs; rows }` relations, hash joins | +| Same-entity fusion | `relation_of_same_entity_patterns` | Bitset intersection + value scan | +| AVET predicates | `relation_of_avet_value_comparisons` | Index range + direct row collection | +| Find projection | `impl/query_api.ml` | Skip binding maps when `:find` vars match attrs | +| Index access | `impl/db.ml` | AVET slice, lazy seq, temporal filter pred | + +### Benchmark gaps to close (20k shared DB, target: native OCaml ≤ competitor on all 15 cases) + +| Query | Issue | Root cause | +| --- | --- | --- | +| qpred1/2, q-pred-range | 20–30× slower | Full row materialization per iteration; loose AVET bounds | +| q3, q4 | ~2.5× slower | Same-entity path builds rows via per-entity probes vs fused merge | +| q5, q-or, q-not | ~1.5–2.8× slower | Hash join + binding round-trips | +| q-rule | ~5× slower | Rule invocation overhead; no relation fast path for rule body | + +## Phase 0 — Hot-path fixes (in progress) + +**Goal:** Remove avoidable allocation and redundant filters without a full planner. + +1. Precompute direct pattern row slots; collect with rev accumulator (done). +2. Tighten AVET bounds for strict Int inequalities; skip post-filter when exact. +3. Extend `eval_relation_rows` to simple non-recursive rule heads whose body is + relation-only (e.g. `(follow ?e1 ?e2)` → `[?e1 :follows ?e2]`). +4. Expand golden tests in `test/test_shared_queries.ml` to all 15 benchmark + queries at size=2000, seed=1. + +**Gate:** `opam exec -- dune runtest`; `shared_query_bench.exe --size 2000`; qpred ≤ 0.5 ms +at 2000; no result count regressions. + +## Phase 1 — Logical plan IR and analysis + +**Goal:** Compile supported queries to a stable logical tree; still execute via +existing operators initially. + +1. Add `impl/query_plan.ml`: + - types: `logical_node`, `plan`, `bound`, `index_choice` + - `analyze : db -> query -> plan option` +2. Recognize plan shapes equivalent to current fast paths (scan, range, merge, join). +3. Unit tests: analyze-only fixtures mirroring benchmark queries. + +**Gate:** 100% of Phase 0 benchmark queries produce a plan; unsupported shapes return +`None` and use interpreter fallback. + +## Phase 2 — Cost-based join ordering + +**Goal:** Order clauses by estimated cost, not source order. + +1. Cardinality hints: AVET slice width, constant lookup count, `max_datom_e`. +2. Selinger DP for ≤ 8 logical nodes; left-deep preference when costs tie. +3. Verify q2-switch and reordered q3/q4 pick the same or better plans. + +**Gate:** q3/q4 at 20k ≤ competitor; no ordering-sensitive test regressions. + +## Phase 3 — Streaming physical operators + +**Goal:** Execute plans without materializing full relations. + +1. `RangeScan` iterator — wrap `index_range`, emit column tuple per datom. +2. `MergeScan` iterator — synchronized seek on same-entity legs (EAVT/AEVT/AVET). +3. `HashProbe` — open-address entity map; build from smaller side. +4. Pipe iterators through `relation_rows_for_find` for `:find` projection. + +**Gate:** qpred at 20k ≤ competitor; native memory churn reduced (fewer major heap +words in benchmark loop). + +## Phase 4 — Unified execution and fallback shrink + +**Goal:** One primary executor; delete redundant interpreter branches. + +1. Route `Query_api.q_sources_raw` through compile → execute. +2. Keep interpreter only for recursive rules, unsupported callables, exotic `not-join`. +3. Document remaining interpreter-only shapes in `docs/query_planner.md`. + +**Gate:** full `dune runtest`; all 15 benchmark cases native ≤ competitor; js_of_ocaml +≥ upstream DataScript on standard `bench_ocaml` suite. + +## Phase 5 — Temporal and write benchmarks + +**Goal:** Extend parity coverage beyond read-only people benchmark. + +1. Golden tests for `as_of` / `since` / history queries (tx-filter gate tests). +2. Write + query microbench if competitor suite includes writes. +3. Planner must respect `source_context` filters on all iterators. + +**Gate:** tx-filter gate tests pass; temporal query plans use same IR nodes with +filtered index access. + +## Testing strategy + +| Layer | Tool | +| --- | --- | +| Result parity | `test/test_shared_queries.ml` — counts per query | +| Semantic parity | existing `dune runtest` query fixtures | +| Performance | `bench/shared_query_bench.ml`, `script/benchmark_vs_cljs.sh` | +| Planner internals | new `test/test_query_plan.ml` (analyze/lower only) | + +## File ownership (target end state) + +``` +impl/query_plan.ml — analyze, cost, optimize +impl/query_exec.ml — physical operators, streaming +impl/query_where.ml — shrink to fallback interpreter + shared helpers +impl/query_api.ml — compile hook, find projection +docs/adr/query-planner.md — architecture decision (this ADR) +docs/query_planner_plan.md — this plan +``` + +## Principles + +- No new public APIs. +- Observable behavior matches upstream DataScript. +- Prefer deleting special cases once the generic plan shape covers them. +- Do not disable compiler warnings; no magic type casts. 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/examples/dune b/examples/dune index 52e73d8..e69de29 100644 --- a/examples/dune +++ b/examples/dune @@ -1,15 +0,0 @@ -(library - (name logseq_sqlite_storage) - (public_name datascript-ocaml-native.logseq-sqlite-storage) - (modules logseq_sqlite_storage) - (libraries datascript-ocaml-native unix yojson sqlite3 melange-transit-native)) - -(executable - (name sqlite_storage_example) - (modules sqlite_storage_example) - (libraries datascript-ocaml-native logseq_sqlite_storage unix)) - -(executable - (name logseq_query_runner) - (modules logseq_query_runner) - (libraries datascript-ocaml-native logseq_sqlite_storage unix yojson)) diff --git a/examples/logseq_query_runner.ml b/examples/logseq_query_runner.ml deleted file mode 100644 index 33ba58c..0000000 --- a/examples/logseq_query_runner.ml +++ /dev/null @@ -1,402 +0,0 @@ -open Datascript - -module Storage = Logseq_sqlite_storage - -let json_string value = - let buffer = Buffer.create (String.length value + 8) in - Buffer.add_char buffer '"'; - String.iter - (function - | '"' -> Buffer.add_string buffer "\\\"" - | '\\' -> Buffer.add_string buffer "\\\\" - | '\b' -> Buffer.add_string buffer "\\b" - | '\012' -> Buffer.add_string buffer "\\f" - | '\n' -> Buffer.add_string buffer "\\n" - | '\r' -> Buffer.add_string buffer "\\r" - | '\t' -> Buffer.add_string buffer "\\t" - | ch -> - let code = Char.code ch in - if code < 0x20 then Buffer.add_string buffer (Printf.sprintf "\\u%04x" code) - else Buffer.add_char buffer ch) - value; - Buffer.add_char buffer '"'; - Buffer.contents buffer - -let json_field key value = json_string key ^ ":" ^ value -let json_obj fields = "{" ^ String.concat "," (List.map (fun (key, value) -> json_field key value) fields) ^ "}" -let parsed_query_cache = Hashtbl.create 256 - -let exception_message = function - | Invalid_argument message | Failure message -> message - | exn -> Printexc.to_string exn - -let edn_keyword value = ":" ^ value - -let rec edn_value = function - | Nil -> "nil" - | Int value -> string_of_int value - | Float value -> string_of_float value - | String value -> Built_ins.print_query_value ~readably:true (String value) - | Symbol value -> value - | Bool true -> "true" - | Bool false -> "false" - | Keyword value -> edn_keyword value - | Uuid value -> "#uuid " ^ json_string value - | Instant value -> string_of_int value - | Regex value -> "#\"" ^ String.escaped value ^ "\"" - | Ref value -> string_of_int value - | List values -> "(" ^ String.concat " " (List.map edn_value values) ^ ")" - | Vector values -> "[" ^ String.concat " " (List.map edn_value values) ^ "]" - | Set values -> "#{" ^ String.concat " " (List.map edn_value values) ^ "}" - | Tuple values -> - "[" ^ String.concat " " (List.map (function Some value -> edn_value value | None -> "nil") values) ^ "]" - | Map entries -> - entries - |> List.map (fun (key, value) -> edn_value key ^ " " ^ edn_value value) - |> String.concat " " - |> fun body -> "{" ^ body ^ "}" - | TxRef -> ":db/current-tx" - | Ref_to _ -> "#datascript-ocaml/ref-to" - -let edn_schema_attr attr = - let props = - [ Some - ( ":db/cardinality" - , (match attr.cardinality with - | One -> ":db.cardinality/one" - | Many -> ":db.cardinality/many") ) - ; (match attr.unique with - | None -> None - | Some Identity -> Some (":db/unique", ":db.unique/identity") - | Some Value -> Some (":db/unique", ":db.unique/value")) - ; (if attr.indexed then Some (":db/index", "true") else None) - ; (if attr.is_component then Some (":db/isComponent", "true") else None) - ; (if attr.no_history then Some (":db/noHistory", "true") else None) - ; (match attr.value_type with - | None -> None - | Some RefType -> Some (":db/valueType", ":db.type/ref") - | Some TupleType -> Some (":db/valueType", ":db.type/tuple") - | Some StringType -> Some (":db/valueType", ":db.type/string") - | Some KeywordType -> Some (":db/valueType", ":db.type/keyword") - | Some NumberType -> Some (":db/valueType", ":db.type/number") - | Some UuidType -> Some (":db/valueType", ":db.type/uuid") - | Some InstantType -> Some (":db/valueType", ":db.type/instant")) - ] - |> List.filter_map Fun.id - |> List.map (fun (key, value) -> key ^ " " ^ value) - in - "{" ^ String.concat " " props ^ "}" - -let edn_schema_entry (attr, spec) = - "[" ^ edn_keyword attr ^ " " ^ edn_schema_attr spec ^ "]" - -let edn_datom datom = - Printf.sprintf - "[%d %s %s %d %b]" - datom.e - (edn_keyword datom.a) - (edn_value datom.v) - datom.tx - datom.added - -let graph_edn schema datoms = - "{:schema [" - ^ String.concat "\n" (List.map edn_schema_entry schema) - ^ "]\n:datoms [" - ^ String.concat "\n" (List.map edn_datom datoms) - ^ "]}\n" - -let load_graph_data db_path = - let schema = Storage.schema_of_logseq_graph ~read_only:true db_path in - let datoms = Storage.datoms_of_logseq_graph ~read_only:true db_path in - schema, datoms - -let read_file path = - let channel = open_in_bin path in - Fun.protect - ~finally:(fun () -> close_in channel) - (fun () -> - let length = in_channel_length channel in - really_input_string channel length) - -let graph_key_label = function - | QueryFormKeyword key -> ":" ^ key - | QueryFormString key -> "\"" ^ key ^ "\"" - | QueryFormSymbol key -> key - | _ -> "" - -let graph_field name entries = - match - entries - |> List.find_map (fun (key, value) -> - match key with - | QueryFormKeyword key when key = name -> Some value - | _ -> None) - with - | Some value -> value - | None -> - invalid_arg - ("graph EDN is missing :" - ^ name - ^ "; keys: " - ^ (entries |> List.map (fun (key, _) -> graph_key_label key) |> String.concat ", ")) - -let schema_of_graph_edn_form = function - | QueryFormVector entries -> - entries - |> List.map (function - | QueryFormVector [ attr; spec ] | QueryFormList [ attr; spec ] -> attr, spec - | _ -> invalid_arg "graph EDN :schema entries must be [attr spec]") - |> fun entries -> Data_readers.schema_of_edn_form (QueryFormMap entries) - | _ -> invalid_arg "graph EDN :schema must be a vector" - -let rec graph_value_of_form = function - | QueryFormNil -> Nil - | QueryFormBool value -> Bool value - | QueryFormInt value -> Int value - | QueryFormFloat value -> Float value - | QueryFormString value -> String value - | QueryFormKeyword value -> Keyword value - | QueryFormSymbol value -> Symbol value - | QueryFormVector values -> Vector (List.map graph_value_of_form values) - | QueryFormList values -> List (List.map graph_value_of_form values) - | QueryFormSet values -> Set (List.map graph_value_of_form values) - | QueryFormMap entries -> - Map (List.map (fun (key, value) -> graph_value_of_form key, graph_value_of_form value) entries) - | QueryFormTagged ("uuid", QueryFormString value) -> Uuid value - | QueryFormTagged ("regex", QueryFormString value) -> Regex value - | QueryFormTagged (tag, _) -> invalid_arg ("unsupported graph EDN tagged literal: " ^ tag) - -let datom_of_graph_edn_form = function - | QueryFormVector [ QueryFormInt e; attr; value; QueryFormInt tx; QueryFormBool added ] - | QueryFormList [ QueryFormInt e; attr; value; QueryFormInt tx; QueryFormBool added ] -> - datom ~e ~a:(Data_readers.attr_of_edn_key attr) ~v:(Util.normalize_value (graph_value_of_form value)) ~tx ~added () - | _ -> invalid_arg "graph EDN :datoms entries must be [e attr value tx added]" - -let datoms_of_graph_edn_form = function - | QueryFormVector datoms | QueryFormList datoms -> List.map datom_of_graph_edn_form datoms - | _ -> invalid_arg "graph EDN :datoms must be a vector" - -let load_graph_edn_data graph_path = - match read_edn (read_file graph_path) with - | QueryFormMap entries -> - let schema = schema_of_graph_edn_form (graph_field "schema" entries) in - let datoms = datoms_of_graph_edn_form (graph_field "datoms" entries) in - schema, datoms - | _ -> invalid_arg "graph EDN root must be a map" - -let rec edn_pulled_value = function - | Pulled_scalar value -> edn_value value - | Pulled_many values -> "[" ^ String.concat " " (List.map edn_pulled_value values) ^ "]" - | Pulled_entity entity -> edn_pulled_entity entity - -and edn_pulled_entity entity = - let attrs = - entity.pulled_attrs - |> List.sort (fun (left, _) (right, _) -> compare left right) - |> List.map (fun (key, value) -> edn_value key ^ " " ^ edn_pulled_value value) - in - "{" ^ String.concat " " attrs ^ "}" - -let edn_query_result = function - | Result_entity entity_id -> string_of_int entity_id - | Result_attr attr -> edn_keyword attr - | Result_value value -> edn_value value - | Result_db _ -> "#datascript/DB" - | Result_pull entity -> edn_pulled_entity entity - -let edn_list values = "[" ^ String.concat " " values ^ "]" -let edn_result_row row = edn_list (List.map edn_query_result row) - -let edn_query_output = function - | Query_relation rows -> edn_list (List.map edn_result_row rows) - | Query_collection values -> edn_list (List.map edn_query_result values) - | Query_tuple None -> "nil" - | Query_tuple (Some row) -> edn_result_row row - | Query_scalar None -> "nil" - | Query_scalar (Some value) -> edn_query_result value - | Query_relation_maps rows -> - rows - |> List.map (fun row -> - row - |> List.map (fun (key, value) -> edn_value key ^ " " ^ edn_query_result value) - |> String.concat " " - |> fun body -> "{" ^ body ^ "}") - |> edn_list - | Query_tuple_map None -> "nil" - | Query_tuple_map (Some row) -> - row - |> List.map (fun (key, value) -> edn_value key ^ " " ^ edn_query_result value) - |> String.concat " " - |> fun body -> "{" ^ body ^ "}" - -let json_member key = function - | `Assoc fields -> - (match List.assoc_opt key fields with - | Some (`String value) -> value - | _ -> invalid_arg ("query input field must be a string: " ^ key)) - | _ -> invalid_arg "query input line must be a JSON object" - -let json_optional_string_member key = function - | `Assoc fields -> - (match List.assoc_opt key fields with - | Some (`String value) -> Some value - | Some _ -> invalid_arg ("query input field must be a string: " ^ key) - | None -> None) - | _ -> invalid_arg "query input line must be a JSON object" - -let json_optional_string_list_member key = function - | `Assoc fields -> - (match List.assoc_opt key fields with - | Some (`List values) -> - Some - (List.map - (function - | `String value -> value - | _ -> invalid_arg ("query input field must be a string array: " ^ key)) - values) - | Some _ -> invalid_arg ("query input field must be a string array: " ^ key) - | None -> None) - | _ -> invalid_arg "query input line must be a JSON object" - -let input_rules_of_string rules = - Arg_rules (Parser.parse_rules (read_edn rules)) - -let input_scalar_of_string input = - Arg_scalar (Result_value (Util.normalize_value (graph_value_of_form (read_edn input)))) - -let query_inputs_of_strings query rules inputs = - let scalar_inputs = List.map input_scalar_of_string (Option.value ~default:[] inputs) in - let rec collect acc scalar_inputs = function - | [] -> List.rev acc - | Input_source_decl _ :: declarations -> collect acc scalar_inputs declarations - | Input_rules_decl :: declarations -> - let acc = - match rules with - | Some rules -> input_rules_of_string rules :: acc - | None -> acc - in - collect acc scalar_inputs declarations - | _ :: declarations -> - (match scalar_inputs with - | input :: scalar_inputs -> collect (input :: acc) scalar_inputs declarations - | [] -> collect acc [] declarations) - in - collect [] scalar_inputs query.inputs - -let run_query_output db rules inputs query = - let return, return_map, parsed_query = - match Hashtbl.find_opt parsed_query_cache query with - | Some parsed -> parsed - | None -> - let parsed = parse_query_return_map_string_with_pull_context ~default_pull_db:db query in - Hashtbl.replace parsed_query_cache query parsed; - parsed - in - let inputs = - match query_inputs_of_strings parsed_query rules inputs with - | [] -> None - | inputs -> Some inputs - in - match return_map with - | Some return_map -> q_return_map ?inputs db return return_map parsed_query - | None -> q_return ?inputs db return parsed_query - -let run_query db id query rules inputs = - let trace = Sys.getenv_opt "LOGSEQ_QUERY_RUNNER_TRACE" = Some "1" in - if trace then ( - prerr_endline ("query-start " ^ id); - flush stderr); - let started = Unix.gettimeofday () in - try - let output = run_query_output db rules inputs query in - if trace then ( - Printf.eprintf "query-done %s %.6f\n" id (Unix.gettimeofday () -. started); - flush stderr); - let fields = - [ "id", json_string id; "status", json_string "ok" ] - @ - if Sys.getenv_opt "LOGSEQ_QUERY_RUNNER_OMIT_VALUE" = Some "1" then - [] - else - [ "value", json_string (edn_query_output output) ] - in - print_endline (json_obj fields); - flush stdout - with - | exn -> - if trace then ( - Printf.eprintf "query-error %s %.6f\n" id (Unix.gettimeofday () -. started); - flush stderr); - print_endline - (json_obj - [ "id", json_string id - ; "status", json_string "error" - ; "message", json_string (exception_message exn) - ]); - flush stdout - -let run_query_loop db queries_path = - print_endline (json_obj [ "status", json_string "ready" ]); - flush stdout; - let channel = open_in queries_path in - Fun.protect - ~finally:(fun () -> close_in channel) - (fun () -> - try - while true do - let line = input_line channel in - if String.trim line <> "" then - let json = Yojson.Safe.from_string line in - run_query - db - (json_member "id" json) - (json_member "query" json) - (json_optional_string_member "rules" json) - (json_optional_string_list_member "inputs" json) - done - with - | End_of_file -> ()) - -let run_queries db_path queries_path = - let schema, datoms = load_graph_data db_path in - let db = init_db ~schema datoms in - run_query_loop db queries_path - -let run_graph_queries graph_path queries_path = - let schema, datoms = load_graph_edn_data graph_path in - let db = init_db ~schema datoms in - run_query_loop db queries_path - -let dump_graph db_path out_path = - let schema, datoms = load_graph_data db_path in - let channel = open_out out_path in - Fun.protect - ~finally:(fun () -> close_out channel) - (fun () -> output_string channel (graph_edn schema datoms)) - -let dump_query_graph db_path query out_path = - let _, _, _, parsed_query = Storage.parse_logseq_query_with_schema ~read_only:true db_path query in - let attrs = Storage.query_attrs parsed_query in - let schema = Storage.schema_of_logseq_graph ~read_only:true db_path in - let datoms = Storage.datoms_of_logseq_graph_for_attrs ~read_only:true db_path attrs in - let channel = open_out out_path in - Fun.protect - ~finally:(fun () -> close_out channel) - (fun () -> output_string channel (graph_edn schema datoms)) - -let usage () = - prerr_endline "Usage:"; - prerr_endline " logseq_query_runner dump-graph "; - prerr_endline " logseq_query_runner dump-query-graph "; - prerr_endline " logseq_query_runner run "; - prerr_endline " logseq_query_runner run-graph "; - exit 2 - -let () = - match Array.to_list Sys.argv with - | [ _; "dump-graph"; db_path; out_path ] -> dump_graph db_path out_path - | [ _; "dump-query-graph"; db_path; query; out_path ] -> dump_query_graph db_path query out_path - | [ _; "run"; db_path; queries_path ] -> run_queries db_path queries_path - | [ _; "run-graph"; graph_path; queries_path ] -> run_graph_queries graph_path queries_path - | _ -> usage () diff --git a/examples/logseq_sqlite_storage.ml b/examples/logseq_sqlite_storage.ml deleted file mode 100644 index 9935500..0000000 --- a/examples/logseq_sqlite_storage.ml +++ /dev/null @@ -1,1326 +0,0 @@ -open Datascript - -module PSet = Persistent_sorted_set -module Transit = Transit_native.Transit.Json - -type content_format = - | Ocaml_marshal - | Logseq_transit - | Empty - | Unknown - -type summary = - { has_kvs_table : bool - ; row_count : int - ; has_root : bool - ; has_tail : bool - ; root_content_format : content_format - ; root_keys : string list - ; root_index_addresses : int list - } - -let kvs_schema = - "create table if not exists kvs (addr INTEGER primary key, content TEXT, addresses JSON)" - -let ocaml_payload_prefix = "ocaml-marshal-hex:" - -let uri_hex_digit value = - Char.chr (if value < 10 then Char.code '0' + value else Char.code 'A' + value - 10) - -let uri_escape_path path = - let buffer = Buffer.create (String.length path) in - String.iter - (fun ch -> - match ch with - | 'A' .. 'Z' | 'a' .. 'z' | '0' .. '9' | '/' | '-' | '_' | '.' | '~' -> - Buffer.add_char buffer ch - | ch -> - let code = Char.code ch in - Buffer.add_char buffer '%'; - Buffer.add_char buffer (uri_hex_digit (code lsr 4)); - Buffer.add_char buffer (uri_hex_digit (code land 0x0f))) - path; - Buffer.contents buffer - -let readonly_uri db_path = - "file:" ^ uri_escape_path db_path ^ "?mode=ro&immutable=1" - -let with_db ?(read_only = false) db_path f = - let db = - if read_only then Sqlite3.db_open ~uri:true (readonly_uri db_path) else Sqlite3.db_open db_path - in - Fun.protect - ~finally:(fun () -> - if not (Sqlite3.db_close db) then invalid_arg ("failed to close SQLite database: " ^ db_path)) - (fun () -> f db) - -let check_sql db sql rc = - if not (Sqlite3.Rc.is_success rc) then - invalid_arg - (Printf.sprintf - "SQLite statement failed with %s while reading %s: %s" - (Sqlite3.Rc.to_string rc) - sql - (Sqlite3.errmsg db)) - -let exec_sql ?(read_only = false) db_path sql = - with_db ~read_only db_path (fun db -> check_sql db sql (Sqlite3.exec db sql)) - -let select_map ?(read_only = false) db_path sql f = - with_db ~read_only db_path (fun db -> - let stmt = Sqlite3.prepare db sql in - Fun.protect - ~finally:(fun () -> check_sql db sql (Sqlite3.finalize stmt)) - (fun () -> - let rec loop acc = - match Sqlite3.step stmt with - | Sqlite3.Rc.ROW -> loop (f stmt :: acc) - | Sqlite3.Rc.DONE -> List.rev acc - | rc -> - check_sql db sql rc; - List.rev acc - in - loop [])) - -let sql_quote value = - "'" ^ String.concat "''" (String.split_on_char '\'' value) ^ "'" - -let hex_digit value = - Char.chr (if value < 10 then Char.code '0' + value else Char.code 'a' + value - 10) - -let hex_value = function - | '0' .. '9' as ch -> Char.code ch - Char.code '0' - | 'a' .. 'f' as ch -> Char.code ch - Char.code 'a' + 10 - | 'A' .. 'F' as ch -> Char.code ch - Char.code 'A' + 10 - | ch -> invalid_arg ("invalid hex digit: " ^ String.make 1 ch) - -let hex_encode bytes = - String.init - (String.length bytes * 2) - (fun index -> - let code = Char.code bytes.[index / 2] in - if index mod 2 = 0 then hex_digit (code lsr 4) else hex_digit (code land 0x0f)) - -let hex_decode encoded = - if String.length encoded mod 2 <> 0 then invalid_arg "hex string has odd length"; - String.init - (String.length encoded / 2) - (fun index -> - let high = hex_value encoded.[index * 2] in - let low = hex_value encoded.[index * 2 + 1] in - Char.chr ((high lsl 4) lor low)) - -let starts_with prefix value = - let prefix_len = String.length prefix in - String.length value >= prefix_len && String.sub value 0 prefix_len = prefix - -let contains_substring value pattern = - let value_len = String.length value in - let pattern_len = String.length pattern in - if pattern_len = 0 then - true - else if pattern_len > value_len then - false - else - let rec loop index = - if index + pattern_len > value_len then - false - else if String.sub value index pattern_len = pattern then - true - else - loop (index + 1) - in - loop 0 - -let sqlite_addr_of_storage_address = function - | "0" -> 0 - | "1" -> 1 - | address -> - (try int_of_string address with - | Failure _ -> - invalid_arg - ("SQLite Logseq storage uses integer addresses; unsupported address: " ^ address)) - -let storage_address_of_sqlite_addr = function - | 0 -> "0" - | 1 -> "1" - | address -> string_of_int address - -let string_of_transit_key = function - | Transit.Keyword value | Transit.String value -> Some value - | _ -> None - -let keyword_of_transit = function - | Transit.Keyword value -> Some value - | _ -> None - -let bool_of_transit = function - | Transit.Bool value -> Some value - | _ -> None - -let string_of_transit = function - | Transit.String value -> Some value - | _ -> None - -let int_of_transit_value = function - | Transit.Int value -> Some value - | Transit.Int64 value -> - if value >= Int64.of_int min_int && value <= Int64.of_int max_int then - Some (Int64.to_int value) - else - None - | _ -> None - -let lookup_transit_key key entries = - List.find_map - (fun (entry_key, value) -> - match string_of_transit_key entry_key with - | Some entry_key when entry_key = key -> Some value - | _ -> None) - entries - -let logseq_schema_default_attr = - { cardinality = One - ; unique = None - ; indexed = false - ; is_component = false - ; no_history = false - ; doc = None - ; value_type = None - ; tuple_attrs = None - ; tuple_types = None - } - -let transit_of_cardinality = function - | One -> Transit.Keyword "db.cardinality/one" - | Many -> Transit.Keyword "db.cardinality/many" - -let transit_of_unique = function - | Value -> Transit.Keyword "db.unique/value" - | Identity -> Transit.Keyword "db.unique/identity" - -let transit_of_value_type = function - | RefType -> Transit.Keyword "db.type/ref" - | StringType -> Transit.Keyword "db.type/string" - | KeywordType -> Transit.Keyword "db.type/keyword" - | NumberType -> Transit.Keyword "db.type/number" - | UuidType -> Transit.Keyword "db.type/uuid" - | InstantType -> Transit.Keyword "db.type/instant" - | TupleType -> Transit.Keyword "db.type/tuple" - -let transit_of_ref_type = function - | PSet.Strong -> Transit.Keyword "strong" - | PSet.Weak -> Transit.Keyword "weak" - -let transit_of_tuple_attrs attrs = - Transit.Array (List.map (fun attr -> Transit.Keyword attr) attrs) - -let transit_of_tuple_types types = - Transit.Array (List.map transit_of_value_type types) - -let schema_attr_to_transit attr = - let entries = ref [] in - let add key value = entries := (Transit.Keyword key, value) :: !entries in - if attr.cardinality <> One then add "db/cardinality" (transit_of_cardinality attr.cardinality); - Option.iter (fun unique -> add "db/unique" (transit_of_unique unique)) attr.unique; - if attr.indexed then add "db/index" (Transit.Bool true); - if attr.is_component then add "db/isComponent" (Transit.Bool true); - if attr.no_history then add "db/noHistory" (Transit.Bool true); - Option.iter (fun doc -> add "db/doc" (Transit.String doc)) attr.doc; - Option.iter (fun value_type -> add "db/valueType" (transit_of_value_type value_type)) attr.value_type; - Option.iter (fun attrs -> add "db/tupleAttrs" (transit_of_tuple_attrs attrs)) attr.tuple_attrs; - Option.iter (fun types -> add "db/tupleTypes" (transit_of_tuple_types types)) attr.tuple_types; - Transit.Map (List.rev !entries) - -let schema_to_transit schema = - Transit.Map - (schema - |> List.map (fun (attr, schema_attr) -> - Transit.Keyword attr, schema_attr_to_transit schema_attr)) - -let rec value_to_transit = function - | Nil -> Transit.Null - | Int value -> Transit.Int value - | Float value -> Transit.Float value - | String value -> Transit.String value - | Symbol value -> Transit.Symbol value - | Bool value -> Transit.Bool value - | Keyword value -> Transit.Keyword value - | Uuid value -> Transit.Tagged ("u", Transit.String value) - | Instant value -> Transit.Tagged ("m", Transit.Int value) - | Regex value -> Transit.Tagged ("regex", Transit.String value) - | Ref entity_id -> Transit.Int entity_id - | List values -> Transit.List (List.map value_to_transit values) - | Vector values -> Transit.Array (List.map value_to_transit values) - | Map entries -> - Transit.Map - (entries |> List.map (fun (key, value) -> value_to_transit key, value_to_transit value)) - | Set values -> Transit.Set (List.map value_to_transit values) - | Tuple values -> - Transit.Array - (values |> List.map (function None -> Transit.Null | Some value -> value_to_transit value)) - | TxRef -> Transit.Keyword "db/current-tx" - | Ref_to _ -> invalid_arg "storage payload cannot contain unresolved refs" - -let datom_to_transit datom = - 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 storage_root_to_transit root = - Transit.Map - [ Transit.Keyword "schema", schema_to_transit root.storage_schema - ; Transit.Keyword "max-eid", Transit.Int root.storage_max_eid - ; Transit.Keyword "max-tx", Transit.Int root.storage_max_tx - ; Transit.Keyword "eavt", Transit.Int (sqlite_addr_of_storage_address root.storage_eavt) - ; Transit.Keyword "aevt", Transit.Int (sqlite_addr_of_storage_address root.storage_aevt) - ; Transit.Keyword "avet", Transit.Int (sqlite_addr_of_storage_address root.storage_avet) - ; Transit.Keyword "max-addr", Transit.Int root.storage_max_addr - ; Transit.Keyword "branching-factor", Transit.Int root.storage_branching_factor - ; Transit.Keyword "ref-type", transit_of_ref_type root.storage_ref_type - ] - -let storage_node_to_transit = function - | PSet.Leaf datoms -> - Transit.Map [ Transit.Keyword "keys", Transit.Array (List.map datom_to_transit datoms) ] - | PSet.Branch (keys, _child_addresses) -> - Transit.Map [ Transit.Keyword "keys", Transit.Array (List.map datom_to_transit keys) ] - -let storage_tail_to_transit groups = - Transit.Array - (groups - |> List.map (fun group -> Transit.Array (List.map datom_to_transit group))) - -let payload_to_transit = function - | Storage_root root -> storage_root_to_transit root - | Storage_node node -> storage_node_to_transit node - | Storage_tail groups -> storage_tail_to_transit groups - -let json_addresses_of_payload = function - | Storage_node (PSet.Branch (_, child_addresses)) -> - Some - (Yojson.Safe.to_string - (`List - (child_addresses - |> List.map sqlite_addr_of_storage_address - |> List.map (fun address -> `Int address)))) - | Storage_root _ | Storage_node (PSet.Leaf _) | Storage_tail _ -> None - -let payload_to_content payload = - payload |> payload_to_transit |> Transit.to_string ~mode:Transit.Verbose - -let cardinality_of_transit = function - | Transit.Keyword "db.cardinality/many" -> Many - | Transit.Keyword "db.cardinality/one" -> One - | _ -> One - -let unique_of_transit = function - | Transit.Keyword "db.unique/value" -> Some Value - | Transit.Keyword "db.unique/identity" -> Some Identity - | _ -> None - -let value_type_of_transit = function - | Transit.Keyword "db.type/ref" -> Some RefType - | Transit.Keyword "db.type/string" -> Some StringType - | Transit.Keyword "db.type/keyword" -> Some KeywordType - | Transit.Keyword "db.type/number" -> Some NumberType - | Transit.Keyword "db.type/uuid" -> Some UuidType - | Transit.Keyword "db.type/instant" -> Some InstantType - | Transit.Keyword "db.type/tuple" -> Some TupleType - | _ -> None - -let tuple_attrs_of_transit = function - | Transit.Array values | Transit.List values -> - Some (List.filter_map keyword_of_transit values) - | _ -> None - -let tuple_types_of_transit = function - | Transit.Array values | Transit.List values -> - let types = List.filter_map value_type_of_transit values in - if List.length types = List.length values then Some types else None - | _ -> None - -let schema_attr_of_transit = function - | Transit.Map props -> - List.fold_left - (fun schema (key, value) -> - match keyword_of_transit key with - | Some "db/cardinality" -> { schema with cardinality = cardinality_of_transit value } - | Some "db/unique" -> { schema with unique = unique_of_transit value } - | Some "db/index" -> - { schema with indexed = Option.value ~default:false (bool_of_transit value) } - | Some "db/isComponent" -> - { schema with is_component = Option.value ~default:false (bool_of_transit value) } - | Some "db/noHistory" -> - { schema with no_history = Option.value ~default:false (bool_of_transit value) } - | Some "db/doc" -> { schema with doc = string_of_transit value } - | Some "db/valueType" -> { schema with value_type = value_type_of_transit value } - | Some "db/tupleAttrs" -> { schema with tuple_attrs = tuple_attrs_of_transit value } - | Some "db/tupleTypes" -> { schema with tuple_types = tuple_types_of_transit value } - | Some _ | None -> schema) - logseq_schema_default_attr - props - | _ -> logseq_schema_default_attr - -let schema_of_transit = function - | Transit.Map entries -> - entries - |> List.filter_map (fun (attr, schema_attr) -> - match keyword_of_transit attr with - | Some attr -> Some (attr, schema_attr_of_transit schema_attr) - | None -> None) - | _ -> [] - -let ref_type_of_transit = function - | Transit.Keyword "weak" -> PSet.Weak - | Transit.Keyword "strong" | _ -> PSet.Strong - -let int_of_transit label value = - match int_of_transit_value value with - | Some value -> value - | None -> invalid_arg (label ^ " must be a Transit integer") - -let rec value_of_transit = function - | Transit.Null -> Nil - | Transit.Bool value -> Bool value - | Transit.String value -> String value - | Transit.Int value -> Int value - | Transit.Int64 value -> - if value >= Int64.of_int min_int && value <= Int64.of_int max_int then - Int (Int64.to_int value) - else - Instant (Int64.to_int value) - | Transit.Float value -> Float value - | Transit.Binary value -> String value - | Transit.Big_decimal value -> Float (float_of_string value) - | Transit.Big_int value -> Transit.Int64 (Int64.of_string value) |> value_of_transit - | Transit.Date value -> Instant (Int64.to_int value) - | Transit.Uuid value -> Uuid value - | Transit.Uri value -> String value - | Transit.Keyword value -> Keyword value - | Transit.Symbol value -> Symbol value - | Transit.Array values -> Vector (List.map value_of_transit values) - | Transit.Map entries -> - Map (entries |> List.map (fun (key, value) -> value_of_transit key, value_of_transit value)) - | Transit.Set values -> Set (List.map value_of_transit values) - | Transit.List values -> List (List.map value_of_transit values) - | Transit.Tagged ("u", Transit.String value) -> Uuid value - | Transit.Tagged ("m", Transit.Int value) -> Instant value - | Transit.Tagged ("m", Transit.Int64 value) -> Instant (Int64.to_int value) - | Transit.Tagged ("regex", Transit.String value) -> Regex value - | Transit.Tagged (tag, value) -> - Vector [ String tag; value_of_transit value ] - -let datom_of_transit = function - | Transit.Array [ entity; attr; value; tx ] -> - let e = int_of_transit "datom entity" entity in - let a = - match keyword_of_transit attr with - | Some attr -> attr - | None -> invalid_arg "datom attr must be a Transit keyword" - in - let tx = int_of_transit "datom tx" tx in - datom ~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_of_transit = function - | Transit.Array datoms | Transit.List datoms -> List.map datom_of_transit datoms - | _ -> invalid_arg "storage node :keys must be a datom array" - -let addresses_of_json = function - | None -> [] - | Some addresses -> - (match Yojson.Safe.from_string addresses with - | `List values -> - values - |> List.map (function - | `Int address -> storage_address_of_sqlite_addr address - | `Intlit address -> storage_address_of_sqlite_addr (int_of_string address) - | _ -> invalid_arg "SQLite addresses JSON must contain integers") - | _ -> invalid_arg "SQLite addresses column must be a JSON array") - -let storage_root_of_transit entries = - let find key = - match lookup_transit_key key entries with - | Some value -> value - | None -> invalid_arg ("storage root is missing :" ^ key) - in - { storage_schema = schema_of_transit (find "schema") - ; storage_max_eid = int_of_transit "storage root :max-eid" (find "max-eid") - ; storage_max_tx = int_of_transit "storage root :max-tx" (find "max-tx") - ; storage_eavt = - storage_address_of_sqlite_addr (int_of_transit "storage root :eavt" (find "eavt")) - ; storage_aevt = - storage_address_of_sqlite_addr (int_of_transit "storage root :aevt" (find "aevt")) - ; storage_avet = - storage_address_of_sqlite_addr (int_of_transit "storage root :avet" (find "avet")) - ; storage_duplicate_datoms = [] - ; storage_max_addr = int_of_transit "storage root :max-addr" (find "max-addr") - ; storage_branching_factor = int_of_transit "storage root :branching-factor" (find "branching-factor") - ; storage_ref_type = ref_type_of_transit (find "ref-type") - } - -let storage_node_of_transit addresses entries = - let keys = - match lookup_transit_key "keys" entries with - | Some value -> datoms_of_transit value - | None -> invalid_arg "storage node is missing :keys" - in - match addresses_of_json addresses with - | [] -> PSet.Leaf keys - | child_addresses -> PSet.Branch (keys, child_addresses) - -let storage_tail_of_transit = function - | Transit.Array groups | Transit.List groups -> - groups |> List.map datoms_of_transit - | _ -> invalid_arg "storage tail must be a Transit array" - -let payload_of_transit ?addresses = function - | Transit.Map entries -> - if Option.is_some (lookup_transit_key "schema" entries) then - Some (Storage_root (storage_root_of_transit entries)) - else if Option.is_some (lookup_transit_key "keys" entries) then - Some (Storage_node (storage_node_of_transit addresses entries)) - else - None - | (Transit.Array _ | Transit.List _) as tail -> - Some (Storage_tail (storage_tail_of_transit tail)) - | _ -> None - -let payload_of_content ?addresses content = - if starts_with ocaml_payload_prefix content then - let encoded = - String.sub - content - (String.length ocaml_payload_prefix) - (String.length content - String.length ocaml_payload_prefix) - in - Some (Marshal.from_string (hex_decode encoded) 0 : storage_payload) - else - payload_of_transit ?addresses (Transit.of_string content) - -let create_kvs_table db_path = - exec_sql db_path (kvs_schema ^ ";") - -let select_single_int ?(read_only = false) db_path sql = - match select_map ~read_only db_path sql (fun stmt -> Sqlite3.column_int stmt 0) with - | [] -> 0 - | value :: _ -> value - -let select_single_string ?(read_only = false) db_path sql = - match select_map ~read_only db_path sql (fun stmt -> Sqlite3.column_text stmt 0) with - | [] -> None - | first :: _ -> Some first - -let content_format content = - if content = "" then Empty - else if starts_with ocaml_payload_prefix content then Ocaml_marshal - else if starts_with "[\"^ \"" content || String.contains content '~' then Logseq_transit - else Unknown - -let string_of_root_json_key = function - | `String text when starts_with "~:" text -> - Some (String.sub text 2 (String.length text - 2)) - | `String text when text <> "^ " && not (starts_with "^" text) -> Some text - | _ -> None - -let int_of_root_json_value = function - | `Int value -> Some value - | `Intlit value -> int_of_string_opt value - | _ -> None - -let rec shallow_root_entries = function - | key :: value :: rest -> - (key, value) :: shallow_root_entries rest - | [] -> [] - | [ _ ] -> [] - -let decode_shallow_root_metadata content = - match Yojson.Safe.from_string content with - | `List (`String "^ " :: entries) -> - let entries = shallow_root_entries entries in - let root_keys = - entries - |> List.filter_map (fun (key, _) -> string_of_root_json_key key) - |> List.sort_uniq compare - in - let find_address key = - entries - |> List.find_map (fun (entry_key, value) -> - match string_of_root_json_key entry_key with - | Some entry_key when entry_key = key -> int_of_root_json_value value - | _ -> None) - in - root_keys, List.filter_map find_address [ "eavt"; "aevt"; "avet" ] - | _ -> [], [] - -let decode_root_metadata content = - match content_format content with - | Logseq_transit -> - (try - match Transit.of_string content with - | Transit.Map entries -> - let root_keys = - entries - |> List.filter_map (fun (key, _) -> string_of_transit_key key) - |> List.sort_uniq compare - in - let root_index_addresses = - [ "eavt"; "aevt"; "avet" ] - |> List.filter_map (fun key -> Option.bind (lookup_transit_key key entries) int_of_transit_value) - in - root_keys, root_index_addresses - | _ -> decode_shallow_root_metadata content - with - | Transit.Decode_error _ | Yojson.Json_error _ -> decode_shallow_root_metadata content) - | Ocaml_marshal | Empty | Unknown -> [], [] - -let inspect ?(read_only = false) db_path = - let has_kvs_table = - select_single_int - ~read_only - db_path - "select count(*) from sqlite_master where type = 'table' and name = 'kvs';" - > 0 - in - if not has_kvs_table then - { has_kvs_table = false - ; row_count = 0 - ; has_root = false - ; has_tail = false - ; root_content_format = Empty - ; root_keys = [] - ; root_index_addresses = [] - } - else - let count sql = select_single_int ~read_only db_path sql in - let root_content = - select_single_string ~read_only db_path "select content from kvs where addr = 0 limit 1;" - in - let root_keys, root_index_addresses = - match root_content with - | None -> [], [] - | Some content -> decode_root_metadata content - in - { has_kvs_table = true - ; row_count = count "select count(*) from kvs;" - ; has_root = count "select count(*) from kvs where addr = 0;" > 0 - ; has_tail = count "select count(*) from kvs where addr = 1;" > 0 - ; root_content_format = - (match root_content with - | None -> Empty - | Some content -> content_format content) - ; root_keys - ; root_index_addresses - } - -let graph_db_paths graphs_dir = - if not (Sys.file_exists graphs_dir) then - [] - else - Sys.readdir graphs_dir - |> Array.to_list - |> List.filter_map (fun name -> - let graph_dir = Filename.concat graphs_dir name in - let db_path = Filename.concat graph_dir "db.sqlite" in - if Sys.file_exists graph_dir && Sys.is_directory graph_dir && Sys.file_exists db_path then - Some db_path - else - None) - |> List.sort String.compare - -let logseq_cardinality_of_transit = function - | Transit.Keyword "db.cardinality/many" -> Many - | Transit.Keyword "db.cardinality/one" -> One - | _ -> One - -let logseq_unique_of_transit = function - | Transit.Keyword "db.unique/value" -> Some Value - | Transit.Keyword "db.unique/identity" -> Some Identity - | _ -> None - -let logseq_value_type_of_transit = function - | Transit.Keyword "db.type/ref" -> Some RefType - | Transit.Keyword "db.type/tuple" -> Some TupleType - | Transit.Keyword "db.type/string" -> Some StringType - | Transit.Keyword "db.type/keyword" -> Some KeywordType - | Transit.Keyword "db.type/number" -> Some NumberType - | Transit.Keyword "db.type/uuid" -> Some UuidType - | Transit.Keyword "db.type/instant" -> Some InstantType - | _ -> None - -let logseq_schema_attr_of_transit = function - | Transit.Map props -> - List.fold_left - (fun schema (key, value) -> - match keyword_of_transit key with - | Some "db/cardinality" -> - { schema with cardinality = logseq_cardinality_of_transit value } - | Some "db/unique" -> { schema with unique = logseq_unique_of_transit value } - | Some "db/index" -> - { schema with indexed = Option.value ~default:false (bool_of_transit value) } - | Some "db/isComponent" -> - { schema with is_component = Option.value ~default:false (bool_of_transit value) } - | Some "db/noHistory" -> - { schema with no_history = Option.value ~default:false (bool_of_transit value) } - | Some "db/doc" -> { schema with doc = string_of_transit value } - | Some "db/valueType" -> - { schema with value_type = logseq_value_type_of_transit value } - | Some _ | None -> schema) - logseq_schema_default_attr - props - | _ -> logseq_schema_default_attr - -let logseq_timestamp_attrs = - [ "created-at"; "updated-at"; "block/created-at"; "block/updated-at" ] - -let ends_with suffix value = - let suffix_len = String.length suffix in - let value_len = String.length value in - value_len >= suffix_len && String.sub value (value_len - suffix_len) suffix_len = suffix - -let logseq_timestamp_attr attr = - List.mem attr logseq_timestamp_attrs - || ends_with "/graph-created-at" attr - || ends_with "/graph-last-gc-at" attr - || ends_with "/imported-at" attr - || ends_with "/imported-last-updated-at" attr - || ends_with "-created-at" attr - || ends_with "-updated-at" attr - -let normalize_logseq_schema_attr attr schema = - if logseq_timestamp_attr attr then { schema with value_type = None } else schema - -type shallow_reader = - { mutable shallow_cache : string array - ; shallow_cache_all_strings : bool - } - -let shallow_cache_code_digits = 44 -let shallow_base_char_code = Char.code '0' - -let shallow_cache_code_to_index text = - match String.length text with - | 2 -> Char.code text.[1] - shallow_base_char_code - | 3 -> - ((Char.code text.[1] - shallow_base_char_code) * shallow_cache_code_digits) - + (Char.code text.[2] - shallow_base_char_code) - | _ -> -1 - -let shallow_cacheable reader text = - String.length text > 3 - && (reader.shallow_cache_all_strings - || starts_with "~:" text - || starts_with "~$" text) - -let shallow_is_cache_code text = - String.length text >= 2 && String.length text <= 3 && text.[0] = '^' - && not (String.equal text "^ ") - -let shallow_remember reader text = - if shallow_cacheable reader text then - reader.shallow_cache <- Array.append reader.shallow_cache [| text |] - -let shallow_decode_string reader text = - if shallow_is_cache_code text then - let index = shallow_cache_code_to_index text in - if index >= 0 && index < Array.length reader.shallow_cache then reader.shallow_cache.(index) else text - else begin - shallow_remember reader text; - text - end - -let shallow_keyword reader = function - | `String text -> - let text = shallow_decode_string reader text in - if starts_with "~:" text then Some (String.sub text 2 (String.length text - 2)) else None - | _ -> None - -let shallow_bool = function - | `Bool value -> Some value - | _ -> None - -let rec shallow_scan reader = function - | `String text -> - ignore (shallow_decode_string reader text) - | `List values -> List.iter (shallow_scan reader) values - | `Assoc entries -> List.iter (fun (key, value) -> shallow_scan reader (`String key); shallow_scan reader value) entries - | `Tuple values -> List.iter (shallow_scan reader) values - | `Variant (tag, value) -> - shallow_scan reader (`String tag); - Option.iter (shallow_scan reader) value - | `Null | `Bool _ | `Int _ | `Intlit _ | `Float _ | `Floatlit _ -> () - -let rec shallow_pairs = function - | key :: value :: rest -> (key, value) :: shallow_pairs rest - | [] | [ _ ] -> [] - -let shallow_value_type reader value = - match shallow_keyword reader value with - | Some "db.type/ref" -> Some RefType - | Some "db.type/tuple" -> Some TupleType - | Some "db.type/string" -> Some StringType - | Some "db.type/keyword" -> Some KeywordType - | Some "db.type/number" -> Some NumberType - | Some "db.type/uuid" -> Some UuidType - | Some "db.type/instant" -> Some InstantType - | Some _ | None -> None - -let shallow_unique reader value = - match shallow_keyword reader value with - | Some "db.unique/value" -> Some Value - | Some "db.unique/identity" -> Some Identity - | Some _ | None -> None - -let shallow_schema_attr reader = function - | `List (`String "^ " :: props) -> - List.fold_left - (fun schema (key, value) -> - match shallow_keyword reader key with - | Some "db/cardinality" -> - let cardinality = - match shallow_keyword reader value with - | Some "db.cardinality/many" -> Many - | _ -> One - in - { schema with cardinality } - | Some "db/unique" -> { schema with unique = shallow_unique reader value } - | Some "db/index" -> - { schema with indexed = Option.value ~default:false (shallow_bool value) } - | Some "db/isComponent" -> - { schema with is_component = Option.value ~default:false (shallow_bool value) } - | Some "db/noHistory" -> - { schema with no_history = Option.value ~default:false (shallow_bool value) } - | Some "db/valueType" -> - { schema with value_type = shallow_value_type reader value } - | Some "db/doc" -> - (match value with - | `String text -> { schema with doc = Some (shallow_decode_string reader text) } - | _ -> schema) - | Some _ | None -> - shallow_scan reader value; - schema) - logseq_schema_default_attr - (shallow_pairs props) - | json -> - shallow_scan reader json; - logseq_schema_default_attr - -let shallow_schema_of_root_content content = - let reader = { shallow_cache = [||]; shallow_cache_all_strings = true } in - match Yojson.Safe.from_string content with - | `List (`String "^ " :: entries) -> - shallow_pairs entries - |> List.find_map (fun (key, value) -> - match shallow_keyword reader key, value with - | Some "schema", `List (`String "^ " :: schema_entries) -> - Some - (schema_entries - |> shallow_pairs - |> List.filter_map (fun (attr, schema) -> - match shallow_keyword reader attr with - | Some attr -> Some (attr, shallow_schema_attr reader schema |> normalize_logseq_schema_attr attr) - | None -> - shallow_scan reader schema; - None)) - | _ -> - shallow_scan reader value; - None) - | _ -> None - -let logseq_root_content ?(read_only = false) db_path = - match select_single_string ~read_only db_path "select content from kvs where addr = 0 limit 1;" with - | Some content -> content - | None -> invalid_arg "Logseq graph has no root metadata row" - -let logseq_root_entries ?(read_only = false) db_path = - match Transit.of_string (logseq_root_content ~read_only db_path) with - | Transit.Map entries -> entries - | _ -> invalid_arg "Logseq graph root metadata must be a Transit map" - -let schema_of_logseq_graph ?(read_only = false) db_path = - let content = logseq_root_content ~read_only db_path in - match shallow_schema_of_root_content content with - | Some schema -> schema - | None -> - (try - let root_entries = - match Transit.of_string content with - | Transit.Map entries -> entries - | _ -> invalid_arg "Logseq graph root metadata must be a Transit map" - in - match lookup_transit_key "schema" root_entries with - | Some (Transit.Map entries) -> - entries - |> List.filter_map (fun (attr, schema) -> - match keyword_of_transit attr with - | Some attr -> Some (attr, logseq_schema_attr_of_transit schema |> normalize_logseq_schema_attr attr) - | None -> None) - | Some _ -> invalid_arg "Logseq graph root :schema must be a Transit map" - | None -> invalid_arg "Logseq graph root metadata has no :schema" - with - | Transit.Decode_error _ | Yojson.Json_error _ -> - invalid_arg "Logseq graph root metadata has no decodable :schema") - -let int_of_shallow_string text = - match int_of_string_opt text with - | Some value -> value - | None -> invalid_arg ("invalid Logseq integer value: " ^ text) - -let rec logseq_value_of_shallow_json reader = function - | `Null -> Nil - | `Bool value -> Bool value - | `Int value -> Int value - | `Intlit value -> Int (int_of_shallow_string value) - | `Float value -> Float value - | `Floatlit value -> Float (float_of_string value) - | `String text -> - let text = shallow_decode_string reader text in - if starts_with "~:" text then Keyword (String.sub text 2 (String.length text - 2)) - else if starts_with "~$" text then Symbol (String.sub text 2 (String.length text - 2)) - else if starts_with "~i" text then Int (int_of_shallow_string (String.sub text 2 (String.length text - 2))) - else if starts_with "~u" text then Uuid (String.sub text 2 (String.length text - 2)) - else if starts_with "~?" text then - (match String.sub text 2 (String.length text - 2) with - | "t" -> Bool true - | "f" -> Bool false - | value -> invalid_arg ("invalid Logseq boolean value: " ^ value)) - else if text = "~_" then Nil - else if starts_with "~~" text || starts_with "~^" text || starts_with "~`" text then - String (String.sub text 1 (String.length text - 1)) - else - String text - | `List (`String "^ " :: entries) -> - Map - (shallow_pairs entries - |> List.map (fun (key, value) -> - logseq_value_of_shallow_json reader key, logseq_value_of_shallow_json reader value)) - | `List [ `String tag; `List values ] -> - let tag = shallow_decode_string reader tag in - if starts_with "~#" tag then - match String.sub tag 2 (String.length tag - 2) with - | "list" -> List (List.map (logseq_value_of_shallow_json reader) values) - | "set" -> Set (List.map (logseq_value_of_shallow_json reader) values) - | "cmap" -> - Map - (shallow_pairs values - |> List.map (fun (key, value) -> - logseq_value_of_shallow_json reader key, logseq_value_of_shallow_json reader value)) - | _ -> - Vector [ String tag; Vector (List.map (logseq_value_of_shallow_json reader) values) ] - else - Vector [ String tag; Vector (List.map (logseq_value_of_shallow_json reader) values) ] - | `List values -> Vector (List.map (logseq_value_of_shallow_json reader) values) - | `Assoc entries -> - Map - (entries - |> List.map (fun (key, value) -> - String (shallow_decode_string reader key), logseq_value_of_shallow_json reader value)) - | `Tuple values -> List (List.map (logseq_value_of_shallow_json reader) values) - | `Variant (tag, value) -> - List - [ String (shallow_decode_string reader tag) - ; Option.value ~default:Nil (Option.map (logseq_value_of_shallow_json reader) value) - ] - -let logseq_attr_of_shallow_json reader = function - | `String text -> - let text = shallow_decode_string reader text in - if starts_with "~:" text then String.sub text 2 (String.length text - 2) else text - | _ -> invalid_arg "Logseq datom attr must be a Transit keyword string" - -let logseq_int_of_shallow_json reader = function - | `Int value -> value - | `Intlit value -> int_of_shallow_string value - | `String text -> - let text = shallow_decode_string reader text in - if starts_with "~i" text then int_of_shallow_string (String.sub text 2 (String.length text - 2)) - else int_of_shallow_string text - | _ -> invalid_arg "Logseq datom integer field must be an integer" - -let logseq_datom_of_shallow_json reader = function - | `List [ entity; attr; value; tx ] -> - let e = logseq_int_of_shallow_json reader entity in - let a = logseq_attr_of_shallow_json reader attr in - let v = logseq_value_of_shallow_json reader value in - let tx = logseq_int_of_shallow_json reader tx in - datom ~e ~a ~v ~tx () - | _ -> invalid_arg "Logseq graph :keys entries must be [e a v tx] datoms" - -let logseq_datoms_of_row_with_reader reader content = - match Yojson.Safe.from_string content with - | `List (`String "^ " :: entries) -> - (match entries with - | `String text :: _ when not (shallow_is_cache_code text) -> reader.shallow_cache <- [||] - | _ -> ()); - shallow_pairs entries - |> List.find_map (fun (key, value) -> - match shallow_keyword reader key, value with - | Some "keys", `List datoms -> Some (List.map (logseq_datom_of_shallow_json reader) datoms) - | _ -> None) - |> Option.value ~default:[] - | _ -> [] - -let logseq_datoms_of_row content = - logseq_datoms_of_row_with_reader { shallow_cache = [||]; shallow_cache_all_strings = false } content - -let add_query_attr acc = function - | QAttr attr -> attr :: acc - | QValue (Keyword attr | String attr | Symbol attr) -> attr :: acc - | QVar _ | QEntity _ | QIdent _ | QLookupRef _ | QValue _ | QSource _ | QWildcard -> acc - -let add_short_pattern_attrs acc = function - | _ :: attr :: _ -> add_query_attr acc attr - | _ -> acc - -let rec add_query_clause_attrs acc = function - | Pattern (_, attr, _) - | PatternTx (_, attr, _, _) - | PatternTxOp (_, attr, _, _, _) - | SourcePattern (_, _, attr, _) - | SourcePatternTx (_, _, attr, _, _) - | SourcePatternTxOp (_, _, attr, _, _, _) -> - add_query_attr acc attr - | Missing (_, attr) - | SourceMissing (_, _, attr) - | GetElse (_, attr, _, _) - | SourceGetElse (_, _, attr, _, _) -> - add_query_attr acc attr - | GetSome (_, attrs, _, _) | SourceGetSome (_, _, attrs, _, _) -> - List.fold_left add_query_attr acc attrs - | SourceClause (_, clause) -> add_query_clause_attrs acc clause - | Not clauses | SourceNot (_, clauses) | NotJoin (_, clauses) | SourceNotJoin (_, _, clauses) -> - List.fold_left add_query_clause_attrs acc clauses - | Or branches - | SourceOr (_, branches) - | OrJoin (_, branches) - | SourceOrJoin (_, _, branches) - | OrJoinRequired (_, _, branches) - | SourceOrJoinRequired (_, _, _, branches) -> - List.fold_left - (fun acc branch -> List.fold_left add_query_clause_attrs acc branch) - acc - branches - | SourceRelationPattern (_, terms) -> - add_short_pattern_attrs acc terms - | GetValue _ - | GetDefaultValue _ - | CountValue _ - | EmptyValue _ - | NotEmptyValue _ - | ContainsValue _ - | ValuePredicate _ - | NumericPredicate _ - | ComparisonPredicate _ - | ComparisonPredicateN _ - | EqualityPredicate _ - | ArithmeticValue _ - | CompareValue _ - | ExtremumValue _ - | BooleanPredicate _ - | BooleanNotPredicate _ - | BooleanNotValue _ - | IdentityValue _ - | BooleanAndPredicate _ - | BooleanAndValue _ - | BooleanOrPredicate _ - | BooleanOrValue _ - | RandomValue _ - | RandomIntValue _ - | DifferPredicate _ - | IdenticalPredicate _ - | TypeValue _ - | MetaValue _ - | NameValue _ - | NamespaceValue _ - | KeywordFromName _ - | KeywordFromNamespaceName _ - | StringIncludesValue _ - | StringStartsWithValue _ - | StringEndsWithValue _ - | StringLowerCaseValue _ - | StringUpperCaseValue _ - | StringCapitalizeValue _ - | StringReverseValue _ - | StringTrimValue _ - | StringTrimLeftValue _ - | StringTrimRightValue _ - | StringTrimNewlineValue _ - | StringIndexOfValue _ - | StringLastIndexOfValue _ - | StringSubstringValue _ - | StringBuildValue _ - | PrintStringValue _ - | PrintLineStringValue _ - | PrStringValue _ - | PrnStringValue _ - | StringJoinPlainValue _ - | StringJoinValue _ - | StringReplaceValue _ - | StringReplaceFirstValue _ - | StringEscapeValue _ - | RePatternValue _ - | ReFindValue _ - | ReMatchesValue _ - | ReSeqValue _ - | ReFindPredicate _ - | ReMatchesPredicate _ - | StringBlankValue _ - | StringSplitValue _ - | StringSplitLimitValue _ - | StringSplitLinesValue _ - | Ground _ - | GroundCollection _ - | GroundTuple _ - | GroundRelation _ - | GroundTerm _ - | GroundTermCollection _ - | GroundTermTuple _ - | GroundTermRelation _ - | VectorValue _ - | ListValue _ - | SetValue _ - | HashMapValue _ - | ArrayMapValue _ - | RangeEndValue _ - | RangeValue _ - | RangeStepValue _ - | TupleFunction _ - | UntupleFunction _ - | Predicate _ - | Function _ - | DynamicPredicate _ - | DynamicFunction _ - | DynamicFunctionCollection _ - | DynamicFunctionRelation _ - | Rule _ - | SourceRule _ -> - acc - -let rec add_pull_selector_attrs acc = function - | Pull_id -> "db/id" :: acc - | Pull_wildcard -> acc - | Pull_attr attr - | Pull_attr_default (attr, _) - | Pull_attr_limit (attr, _) - | Pull_attr_unlimited attr - | Pull_attr_xform (attr, _) - | Pull_attr_default_xform (attr, _, _) -> - attr :: acc - | Pull_ref (attr, selectors) - | Pull_ref_default (attr, selectors, _) - | Pull_ref_limit (attr, selectors, _) - | Pull_ref_unlimited (attr, selectors) - | Pull_ref_xform (attr, selectors, _) - | Pull_recursive_ref (attr, selectors, _) - | Pull_reverse_ref (attr, selectors) - | Pull_reverse_ref_default (attr, selectors, _) - | Pull_reverse_ref_limit (attr, selectors, _) - | Pull_reverse_ref_unlimited (attr, selectors) - | Pull_reverse_ref_xform (attr, selectors, _) -> - List.fold_left add_pull_selector_attrs (attr :: acc) selectors - | Pull_as (selector, _) -> add_pull_selector_attrs acc selector - -let rec add_pull_form_attrs acc = function - | QueryFormKeyword attr -> attr :: acc - | QueryFormVector forms | QueryFormList forms | QueryFormSet forms -> - List.fold_left add_pull_form_attrs acc forms - | QueryFormMap entries -> - List.fold_left - (fun attrs (key, value) -> add_pull_form_attrs (add_pull_form_attrs attrs key) value) - acc - entries - | QueryFormTagged (_, form) -> add_pull_form_attrs acc form - | QueryFormNil | QueryFormBool _ | QueryFormInt _ | QueryFormFloat _ | QueryFormString _ | QueryFormSymbol _ -> - acc - -let add_find_spec_attrs acc = function - | Find_pull (_, selectors) | Find_pull_source (_, _, selectors) -> - List.fold_left add_pull_selector_attrs acc selectors - | Find_pull_form (_, form) | Find_pull_source_form (_, _, form) -> add_pull_form_attrs acc form - | Find_var _ - | Find_pull_var _ - | Find_pull_source_var _ - | Find_aggregate _ -> - acc - -let query_attrs query = - let attrs = - List.fold_left add_query_clause_attrs [] query.where - |> fun attrs -> List.fold_left add_find_spec_attrs attrs query.find - |> List.cons "db/ident" - |> List.sort_uniq String.compare - in - query.rules - |> List.fold_left - (fun attrs rule -> List.fold_left add_query_clause_attrs attrs rule.rule_body) - attrs - |> List.sort_uniq String.compare - -let sql_like_pattern text = - "'%" ^ String.concat "''" (String.split_on_char '\'' text) ^ "%'" - -let logseq_keys_or_shorthand_row_sql = - "(content like " ^ sql_like_pattern "~:keys" ^ " or content like " ^ sql_like_pattern "[\"^ \",\"^" ^ ")" - -let logseq_keys_and_attrs_sql attrs = - match attrs with - | [] -> logseq_keys_or_shorthand_row_sql - | attrs -> - let attr_sql = - attrs - |> List.map (fun attr -> "content like " ^ sql_like_pattern ("~:" ^ attr)) - |> String.concat " or " - in - "content like " ^ sql_like_pattern "~:keys" ^ " and (" ^ attr_sql ^ ")" - -let datoms_of_logseq_graph_for_attrs ?(read_only = false) db_path attrs = - let include_all = attrs = [] in - let row_starts_segment content = - starts_with "[\"^ \",\"" content && not (starts_with "[\"^ \",\"^" content) - in - let row_mentions_attr content attr = - contains_substring content ("~:" ^ attr) - in - let segment_mentions_attr rows = - include_all || List.exists (fun row -> List.exists (row_mentions_attr row) attrs) rows - in - let decode_segment rows = - if not (segment_mentions_attr rows) then - [] - else - let reader = { shallow_cache = [||]; shallow_cache_all_strings = false } in - rows - |> List.concat_map (fun content -> - let datoms = logseq_datoms_of_row_with_reader reader content in - if include_all then datoms else List.filter (fun datom -> List.mem datom.a attrs) datoms) - in - let flush_segment segment acc = - match segment with - | [] -> acc - | segment -> List.rev_append (decode_segment (List.rev segment)) acc - in - let rows = - select_map - ~read_only - db_path - ("select content from kvs where addr not in (0, 1) and " - ^ logseq_keys_or_shorthand_row_sql - ^ " order by addr;") - (fun stmt -> Sqlite3.column_text stmt 0) - in - let rec collect current acc = function - | [] -> List.rev (flush_segment current acc) - | row :: rest when row_starts_segment row && current <> [] -> - collect [ row ] (flush_segment current acc) rest - | row :: rest -> collect (row :: current) acc rest - in - collect [] [] rows - -let datoms_of_logseq_graph ?(read_only = false) ?limit db_path = - let limit_sql = - match limit with - | None -> "" - | Some limit -> " limit " ^ string_of_int limit - in - let reader = { shallow_cache = [||]; shallow_cache_all_strings = false } in - select_map - ~read_only - db_path - ("select content from kvs where addr not in (0, 1) and " - ^ logseq_keys_or_shorthand_row_sql - ^ " order by addr" - ^ limit_sql - ^ ";") - (fun stmt -> Sqlite3.column_text stmt 0) - |> List.concat_map (logseq_datoms_of_row_with_reader reader) - -let parse_logseq_query_with_schema ?(read_only = false) db_path query_string = - let schema = schema_of_logseq_graph ~read_only db_path in - let schema_db = empty_db ~schema () in - let return, return_map, query = - parse_query_return_map_string_with_pull_context ~default_pull_db:schema_db query_string - in - schema, return, return_map, query - -let query_logseq_graph ?(read_only = false) ?inputs db_path query_string = - let schema, _, _, query = parse_logseq_query_with_schema ~read_only db_path query_string in - let has_rules_input = - match inputs with - | Some inputs -> List.exists (function Arg_rules _ -> true | _ -> false) inputs - | None -> false - in - let graph_datoms = - datoms_of_logseq_graph_for_attrs ~read_only db_path (if has_rules_input then [] else query_attrs query) - in - let db = init_db ~schema graph_datoms in - q_return_map_string ?inputs db query_string - -let delete_sql addresses = - match addresses with - | [] -> "" - | _ -> - "delete from kvs where addr in (" - ^ (addresses - |> List.map sqlite_addr_of_storage_address - |> List.map string_of_int - |> String.concat ",") - ^ ");" - -let upsert_sql (address, payload) = - let addr = sqlite_addr_of_storage_address address in - let content = payload_to_content payload in - let addresses = - match json_addresses_of_payload payload with - | None -> "null" - | Some addresses -> sql_quote addresses - in - Printf.sprintf - "insert into kvs (addr, content, addresses) values (%d, %s, %s) \ - on conflict(addr) do update set content = excluded.content, addresses = excluded.addresses;" - addr - (sql_quote content) - addresses - -let storage db_path = - create_kvs_table db_path; - let store entries = - let sql = String.concat "" (List.map upsert_sql entries) in - if sql <> "" then exec_sql db_path sql - in - let restore address = - let addr = sqlite_addr_of_storage_address address in - let sql = Printf.sprintf "select content, addresses from kvs where addr = %d limit 1;" addr in - match - select_map db_path sql (fun stmt -> - let content = Sqlite3.column_text stmt 0 in - let addresses = - match Sqlite3.column stmt 1 with - | Sqlite3.Data.NULL -> None - | _ -> Some (Sqlite3.column_text stmt 1) - in - content, addresses) - with - | [] -> None - | (content, addresses) :: _ -> payload_of_content ?addresses content - in - let list_addresses () = - select_map - db_path - "select addr from kvs order by addr;" - (fun stmt -> storage_address_of_sqlite_addr (Sqlite3.column_int stmt 0)) - in - let delete addresses = - match delete_sql addresses with - | "" -> () - | sql -> exec_sql db_path sql - in - { storage_store = store - ; storage_restore = restore - ; storage_list_addresses = list_addresses - ; storage_delete = delete - } diff --git a/examples/sqlite_storage_example.ml b/examples/sqlite_storage_example.ml deleted file mode 100644 index 2a20442..0000000 --- a/examples/sqlite_storage_example.ml +++ /dev/null @@ -1,132 +0,0 @@ -open Datascript - -module Storage = Logseq_sqlite_storage - -let format_content_format = function - | Storage.Ocaml_marshal -> "ocaml-marshal" - | Storage.Logseq_transit -> "logseq-transit" - | Storage.Empty -> "empty" - | Storage.Unknown -> "unknown" - -let print_summary db_path summary = - Printf.printf "db: %s\n" db_path; - Printf.printf "kvs table: %b\n" summary.Storage.has_kvs_table; - Printf.printf "rows: %d\n" summary.Storage.row_count; - Printf.printf "root addr 0: %b\n" summary.Storage.has_root; - Printf.printf "tail addr 1: %b\n" summary.Storage.has_tail; - Printf.printf - "root content format: %s\n" - (format_content_format summary.Storage.root_content_format); - Printf.printf "root keys: %s\n" (String.concat "," summary.Storage.root_keys); - Printf.printf - "root index addresses: %s\n" - (summary.Storage.root_index_addresses - |> List.map string_of_int - |> String.concat ",") - -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 run_roundtrip db_path = - let storage = Storage.storage db_path in - let db = - init_db - ~schema:[ "name", indexed ] - [ datom ~e:1 ~a:"name" ~v:(String "SQLite example") () ] - in - store ~storage db; - match restore (Storage.storage db_path) with - | None -> failwith "failed to restore SQLite-backed db" - | Some restored -> - let count = Seq.fold_left (fun count _ -> count + 1) 0 (datoms restored Eavt ()) in - Printf.printf "stored and restored %d datom(s)\n" count - -let inspect_graphs graphs_dir = - match Storage.graph_db_paths graphs_dir with - | [] -> Printf.printf "no Logseq db.sqlite files found in %s\n" graphs_dir - | db_paths -> - List.iter - (fun db_path -> - Storage.inspect ~read_only:true db_path |> print_summary db_path; - print_endline "") - db_paths - -let rec edn_of_pulled_value = function - | Pulled_scalar value -> Built_ins.print_query_value ~readably:true value - | Pulled_many values -> "[" ^ String.concat " " (List.map edn_of_pulled_value values) ^ "]" - | Pulled_entity entity -> edn_of_pulled_entity entity - -and edn_of_pulled_entity entity = - let attrs = - (Keyword "db/id", Pulled_scalar (Int entity.pulled_id)) :: entity.pulled_attrs - |> List.sort (fun (left, _) (right, _) -> compare left right) - |> List.map (fun (key, value) -> - Built_ins.print_query_value ~readably:true key ^ " " ^ edn_of_pulled_value value) - in - "{" ^ String.concat " " attrs ^ "}" - -let edn_of_query_result = function - | Result_entity entity_id -> string_of_int entity_id - | Result_attr attr -> ":" ^ attr - | Result_value value -> Built_ins.print_query_value ~readably:true value - | Result_db _ -> "#datascript/DB" - | Result_pull entity -> edn_of_pulled_entity entity - -let edn_list values = "[" ^ String.concat " " values ^ "]" - -let edn_of_result_row row = - edn_list (List.map edn_of_query_result row) - -let edn_of_query_output = function - | Query_relation rows -> edn_list (List.map edn_of_result_row rows) - | Query_collection values -> - edn_list (List.map edn_of_query_result values) - | Query_tuple None -> "nil" - | Query_tuple (Some row) -> edn_of_result_row row - | Query_scalar None -> "nil" - | Query_scalar (Some value) -> edn_of_query_result value - | Query_relation_maps rows -> - rows - |> List.map (fun row -> - row - |> List.map (fun (key, value) -> - Built_ins.print_query_value ~readably:true key ^ " " ^ edn_of_query_result value) - |> String.concat " " - |> fun body -> "{" ^ body ^ "}") - |> edn_list - | Query_tuple_map None -> "nil" - | Query_tuple_map (Some row) -> - row - |> List.map (fun (key, value) -> - Built_ins.print_query_value ~readably:true key ^ " " ^ edn_of_query_result value) - |> String.concat " " - |> fun body -> "{" ^ body ^ "}" - -let run_query db_path query = - Storage.query_logseq_graph ~read_only:true db_path query |> edn_of_query_output |> print_endline - -let usage () = - prerr_endline "Usage:"; - prerr_endline " sqlite_storage_example inspect "; - prerr_endline " sqlite_storage_example inspect-graphs "; - prerr_endline " sqlite_storage_example query "; - prerr_endline " sqlite_storage_example roundtrip "; - exit 2 - -let () = - match Array.to_list Sys.argv with - | [ _; "inspect"; db_path ] -> - Storage.inspect ~read_only:true db_path |> print_summary db_path - | [ _; "inspect-graphs"; graphs_dir ] -> inspect_graphs graphs_dir - | [ _; "query"; db_path; query ] -> run_query db_path query - | [ _; "roundtrip"; db_path ] -> run_roundtrip db_path - | _ -> usage () diff --git a/impl/conn.ml b/impl/conn.ml index cac0400..0c99006 100644 --- a/impl/conn.ml +++ b/impl/conn.ml @@ -5,7 +5,6 @@ type t = ; mutable listeners : (string * (tx_report -> unit)) list ; mutable next_listener_id : int ; storage : storage option - ; mutable storage_tail : datom list list } type creation_context = @@ -19,33 +18,24 @@ type schema_context = ; with_schema : db -> schema -> db } -type restore_context = - { restore : storage -> db option - ; restore_tail_groups : storage -> datom list list - } +type restore_context = { restore : storage -> db option } type transact_context = { store : ?storage:storage -> db -> unit - ; store_tail : storage -> datom list list -> unit - ; storage_tail_datom_count : datom list list -> int - ; storage_tail_compaction_threshold : int ; transact : tx_meta:tx_meta -> db -> tx_op list -> tx_report } type reset_context = { store : ?storage:storage -> db -> unit ; datoms : db -> datom list + ; snapshot_db : db -> db } type context = { empty_db : ?schema:schema -> ?storage:storage -> unit -> db ; init_db : ?schema:schema -> ?storage:storage -> datom list -> db ; store : ?storage:storage -> db -> unit - ; store_tail : storage -> datom list list -> unit ; restore : storage -> db option - ; restore_tail_groups : storage -> datom list list - ; storage_tail_datom_count : datom list list -> int - ; storage_tail_compaction_threshold : int ; transact : tx_meta:tx_meta -> db -> tx_op list -> tx_report ; datoms : db -> datom list ; with_schema : db -> schema -> db @@ -64,13 +54,13 @@ let tx_meta_without_store_control tx_meta = | _ -> true) tx_meta -let make ?storage ?(storage_tail = []) db = +let make ?storage db = let db = match storage with | None -> db | Some _ -> { db with storage_ref = storage } in - { db; listeners = []; next_listener_id = 0; storage; storage_tail } + { db; listeners = []; next_listener_id = 0; storage } let create (context : creation_context) ?schema ?storage () = let db = context.empty_db ?schema ?storage () in @@ -122,15 +112,13 @@ let reset_schema (context : schema_context) conn schema = conn.db <- db; (match conn.storage with | None -> () - | Some storage -> - context.store ~storage db; - conn.storage_tail <- []); + | Some storage -> context.store ~storage db); db let restore (context : restore_context) storage = match context.restore storage with | None -> None - | Some db -> Some (make ~storage ~storage_tail:(context.restore_tail_groups storage) db) + | Some db -> Some (make ~storage db) let transact (context : transact_context) ?(tx_meta = []) conn tx_data = let skip_store = tx_meta_skips_store tx_meta in @@ -139,21 +127,12 @@ let transact (context : transact_context) ?(tx_meta = []) conn tx_data = if not skip_store then (match conn.storage with | None -> () - | Some storage -> - if report.tx_data <> [] then begin - let tail = conn.storage_tail @ [ report.tx_data ] in - if context.storage_tail_datom_count tail > context.storage_tail_compaction_threshold then begin - context.store ~storage report.db_after; - conn.storage_tail <- [] - end else begin - conn.storage_tail <- tail; - context.store_tail storage conn.storage_tail - end - end); + | Some storage -> context.store ~storage report.db_after); notify_listeners conn report; report let reset (context : reset_context) ?(tx_meta = []) conn db = + let db_before = context.snapshot_db conn.db in let db = match conn.storage with | None -> db @@ -163,12 +142,10 @@ 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 = conn.db; 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 -> () - | Some storage -> - context.store ~storage db; - conn.storage_tail <- []); + | Some storage -> context.store ~storage db); notify_listeners conn report; db diff --git a/impl/conn.mli b/impl/conn.mli index f7cda87..04a6201 100644 --- a/impl/conn.mli +++ b/impl/conn.mli @@ -13,33 +13,24 @@ type schema_context = ; with_schema : db -> schema -> db } -type restore_context = - { restore : storage -> db option - ; restore_tail_groups : storage -> datom list list - } +type restore_context = { restore : storage -> db option } type transact_context = { store : ?storage:storage -> db -> unit - ; store_tail : storage -> datom list list -> unit - ; storage_tail_datom_count : datom list list -> int - ; storage_tail_compaction_threshold : int ; transact : tx_meta:tx_meta -> db -> tx_op list -> tx_report } type reset_context = { store : ?storage:storage -> db -> unit ; datoms : db -> datom list + ; snapshot_db : db -> db } type context = { empty_db : ?schema:schema -> ?storage:storage -> unit -> db ; init_db : ?schema:schema -> ?storage:storage -> datom list -> db ; store : ?storage:storage -> db -> unit - ; store_tail : storage -> datom list list -> unit ; restore : storage -> db option - ; restore_tail_groups : storage -> datom list list - ; storage_tail_datom_count : datom list list -> int - ; storage_tail_compaction_threshold : int ; transact : tx_meta:tx_meta -> db -> tx_op list -> tx_report ; datoms : db -> datom list ; with_schema : db -> schema -> db 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 4f7976c..1a710dc 100644 --- a/impl/datascript.ml +++ b/impl/datascript.ml @@ -29,7 +29,7 @@ module Serialize = Serialize module Storage = Storage module Util = Util module Upsert = Upsert -module PSet = Persistent_sorted_set +module Index = Index let validate_entity_id = Db_impl.validate_entity_id @@ -53,14 +53,20 @@ 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 () = Db_impl.empty_db db_core_context ~schema ?storage () let empty db = Db_impl.empty db_core_context db +let warm_query_parser = ref (fun _db -> ()) + let init_db ?(schema = []) ?storage datoms = - Db_impl.init_db db_core_context ~schema ?storage datoms + let db = Db_impl.init_db db_core_context ~schema ?storage datoms in + !warm_query_parser db; + db let visible_datoms = Db_impl.visible_datoms @@ -71,30 +77,49 @@ 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 as_of_instant = Db_impl.as_of_instant +let since = Db_impl.since +let history = Db_impl.history +let is_history = Db_impl.is_history +let resolve_tx_at_instant = Db_impl.resolve_tx_at_instant +let purge_history_before = Db_impl.purge_history_before +let as_of_tx = Db_impl.as_of_tx +let since_tx = Db_impl.since_tx + +module Tx_visibility = Tx_visibility +module Query_plan = Query_plan + let serializable = Serialize.serializable let serialize_context : Serialize.context = { next_db_uid ; validate_schema ; normalize_datom_for_schema - ; refresh_db_indexes + ; with_datoms = Db_impl.with_datoms } 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 file_storage = Storage.file_storage -let store_tail = Storage.store_tail -let storage_tail_compaction_threshold = Storage.tail_compaction_threshold -let storage_tail_datom_count = Storage.tail_datom_count -let restore_tail_groups = Storage.restore_tail_groups -let storage_addresses = Storage.storage_addresses +let benchmark_memory_storage = Storage.benchmark_memory_storage +let ensure_live = Storage.ensure_live +let kind_of = Storage.kind_of + +let storage_of_handle (handle : Datascript_types.storage) = (handle : storage) + +let db_shares_storage_index storage db = + Index.same_storage_db storage (Index.db_of db.eavt_index) + let storage = Storage.storage -let addresses = Storage.addresses let settings = Storage.settings let collect_garbage = Storage.collect_garbage @@ -245,39 +270,24 @@ let find_avet_exact db attr value = else if left == bound then -compare_prefix right left else Util.compare_datom Avet left right in - match - PSet.slice ~from_:bound ~to_:bound ~cmp db.avet_index - @ List.filter + 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) (Option.value (Hashtbl.find_opt db.duplicate_avet_by_attr attr) ~default:[]) - |> List.sort (Util.compare_datom Avet) - with - | datom :: _ -> Some datom - | [] -> None - -let find_eavt_exact db entity_id attr value = - let bound = datom ~e:entity_id ~a:attr ~v:value () in - let compare_prefix left right = - first_nonzero - [ compare left.e right.e - ; compare left.a right.a - ; compare_value left.v right.v - ] - in - let cmp left right = - if right == bound then compare_prefix left right - else if left == bound then -compare_prefix right left - else Util.compare_datom Eavt left right - in - match - PSet.slice ~from_:bound ~to_:bound ~cmp db.eavt_index - @ List.filter - (fun datom -> datom.e = entity_id && datom.a = attr && value_equal datom.v value) - (Option.value (Hashtbl.find_opt db.duplicate_eavt_by_entity entity_id) ~default:[]) - |> List.sort (Util.compare_datom Eavt) - with - | datom :: _ -> Some datom - | [] -> None + |> List.sort (Util.compare_datom Avet) + with + | datom :: _ -> Some datom + | [] -> None) let rec coerce_tuple_lookup_value_db db attr value = match schema_attr db attr, value with @@ -477,12 +487,23 @@ let add_active_datom_with_report_db ?(allow_tuple = false) ?(validate_value = tr else invalid_arg "cannot modify tuple attributes directly" else begin if validate_value then validate_datom_value schema_db d; - (match find_avet_exact db d.a d.v with - | Some existing when is_unique schema_db d.a && existing.e <> d.e -> - invalid_arg "unique constraint" - | Some _ | None -> ()); + (* Use the write schema for AVET access: mid-transaction schema updates live in + [schema_db] while [db] may still carry the pre-tx schema on the value. *) + if is_unique schema_db d.a then + (match + Db_access_impl.datoms + { db with schema = schema_db.schema } + Avet + ~a:d.a + ~v:d.v + () + |> Seq.uncons + with + | Some (existing, _) when existing.e <> d.e -> invalid_arg "unique constraint" + | Some _ | None -> ()); let same_fact_exists = - find_eavt_exact db d.e d.a d.v |> Option.is_some + entity_attr_datoms_db db d.e d.a + |> List.exists (fun datom -> value_equal datom.v d.v) in if same_fact_exists then db, [] @@ -500,7 +521,8 @@ let retract_active_datom_with_report_db tx db e a value = let removed = match value with | Some value -> - find_eavt_exact db e a value |> Option.to_list + entity_attr_datoms_db db e a + |> List.filter (fun datom -> value_equal datom.v value) | None -> entity_attr_datoms_db db e a in let tx_data = sorted_retractions tx removed in @@ -593,6 +615,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 @@ -699,6 +797,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 @@ -726,6 +828,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 } @@ -733,64 +836,16 @@ 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 apply_tail_group db group = - List.iter - (fun datom -> - if datom.added && is_unique db datom.a then - match Db_access_impl.find_datom db Avet ~a:datom.a ~v:datom.v () with - | Some existing when existing.e <> datom.e -> - invalid_arg "tail group conflicts with an existing unique value" - | Some _ | None -> ()) - group; - let group = - List.fold_left - (fun tx_data datom -> - if datom.added && cardinality db datom.a = One then - let existing = - Db_access_impl.datoms db Eavt ~e:datom.e ~a:datom.a () - |> Seq.filter (fun existing -> not (value_equal existing.v datom.v)) - |> Seq.map (fun existing -> - { existing with tx = datom.tx; added = false }) - |> List.of_seq - in - List.rev_append existing (datom :: tx_data) - else - datom :: tx_data) - [] - group - |> List.rev - in - let max_eid = - List.fold_left - (fun max_eid datom -> - let max_eid = - if datom.e <= max_allocatable_entity_id then max max_eid datom.e - else max_eid - in - max_eid_in_value max_eid datom.v) - db.max_eid - group - in - let db = refresh_db_indexes_with_tx_data db group in - { db with max_eid } - -let storage_tail_context : Storage.tail_context = - { apply_group = apply_tail_group } - -let db_with_tail db tail = - Storage.db_with_tail storage_tail_context db tail - -let storage_restore_context : Storage.restore_context = - { next_db_uid; db_with_tail } +let storage_restore_context : Storage.restore_context = { next_db_uid } let restore storage = Storage.restore storage_restore_context storage let restore_conn storage = - let context : Conn.restore_context = { restore; restore_tail_groups } in + let context : Conn.restore_context = { restore } in Conn.restore context storage let tx_meta_skips_store tx_meta = @@ -800,36 +855,41 @@ let tx_meta_skips_store tx_meta = | _ -> false) tx_meta -let persist_transact_tail ~tx_meta db tx_data = - if tx_data <> [] && not (tx_meta_skips_store tx_meta) then +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 -> - let tail = restore_tail_groups storage @ [ tx_data ] in - if storage_tail_datom_count tail > storage_tail_compaction_threshold then - store ~storage db - else - store_tail storage tail + 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 = - let db_after, tempids, tx_data = apply_tx tx_ops db in - { db_before = db; db_after; tx_data; tempids; tx_meta } + 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, purged_datoms = apply_tx tx_ops db in + let db_after, tx_data = + match List.assoc_opt "db/txInstant" tx_meta with + | None -> db_after, tx_data + | Some (Instant _ as instant) -> + let tx = db_after.max_tx in + let stamped = datom ~tx ~e:tx ~a:"db/txInstant" ~v:instant () in + Db_impl.refresh_indexes_with_tx_data db_after [ stamped ], tx_data @ [ stamped ] + | Some _ -> invalid_arg ":db/txInstant must be an Instant value" + 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_tail ~tx_meta report.db_after report.tx_data; + 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 let transact_conn ?(tx_meta = []) conn tx_data = let context : Conn.transact_context = - { store - ; store_tail - ; storage_tail_datom_count - ; storage_tail_compaction_threshold - ; transact = (fun ~tx_meta db tx_data -> transact_report ~tx_meta db tx_data) - } + { store; transact = (fun ~tx_meta db tx_data -> transact_report ~tx_meta db tx_data) } in Conn.transact context ~tx_meta conn tx_data @@ -864,6 +924,7 @@ let seek_datoms_ref = Db_access_impl.seek_datoms_ref let rseek_datoms = Db_access_impl.rseek_datoms let rseek_datoms_ref = Db_access_impl.rseek_datoms_ref let index_range = Db_access_impl.index_range +let fold_index_range = Db_access_impl.fold_index_range let diff = Db_impl.diff @@ -877,7 +938,10 @@ let squuid_time_millis = Db_impl.squuid_time_millis let reset_conn ?(tx_meta = []) conn db = let context : Conn.reset_context = - { store; datoms = (fun db -> datoms_list db Eavt ()) } + { store + ; datoms = (fun db -> datoms_list db Eavt ()) + ; snapshot_db + } in Conn.reset context ~tx_meta conn db @@ -1139,11 +1203,43 @@ let datoms_by_attr_value db attr value = | None -> false in if Option.is_none ident_entity_value && query_value_uses_avet value && query_attr_uses_avet db attr then - datoms_list db Avet ~a:attr ~v:value () + Db_access_impl.avet_datoms_by_value db attr value else datoms_list db Aevt ~a:attr () |> List.filter datom_value_matches +let entity_ids_by_attr_value db attr value = + match resolve_query_value_for_attr db attr value with + | None -> Some [] + | Some value -> + let value = + if is_tuple_attr db attr then + coerce_tuple_lookup_value_db db attr value + else + normalize_value value + in + if query_value_uses_avet value && query_attr_uses_avet db attr then + match Db_access_impl.avet_entity_ids_by_attr_value db attr value with + | None -> None + | Some entity_ids -> Some (Array.to_list entity_ids) + else + None + +let entity_ids_array_by_attr_value db attr value = + match resolve_query_value_for_attr db attr value with + | None -> Some [||] + | Some value -> + let value = + if is_tuple_attr db attr then + coerce_tuple_lookup_value_db db attr value + else + normalize_value value + in + if query_value_uses_avet value && query_attr_uses_avet db attr then + Db_access_impl.avet_entity_ids_by_attr_value db attr value + else + None + let pattern_value_needs_attr_resolution db attr value = is_tuple_attr db attr || @@ -1154,33 +1250,7 @@ let pattern_value_needs_attr_resolution db attr value = | Keyword ident -> Option.is_some (entid db ident_attr (Keyword ident)) | _ -> false) -let primary_attr_datoms db index attr = - let attr_prefix_datoms index index_set = - let bound = datom ~e:0 ~a:attr ~v:Nil () in - let compare_prefix left right = compare left.a right.a in - let cmp left right = - if right == bound then compare_prefix left right - else if left == bound then -compare_prefix right left - else Util.compare_datom index left right - in - PSet.slice ~from_:bound ~to_:bound ~cmp index_set - in - match index with - | Aevt -> - (match Hashtbl.find_opt db.aevt_by_attr attr with - | Some datoms -> datoms - | None -> - let datoms = attr_prefix_datoms Aevt db.aevt_index in - Hashtbl.replace db.aevt_by_attr attr datoms; - datoms) - | Avet -> - (match Hashtbl.find_opt db.avet_by_attr attr with - | Some datoms -> datoms - | None -> - let datoms = attr_prefix_datoms Avet db.avet_index in - Hashtbl.replace db.avet_by_attr attr datoms; - datoms) - | Eavt -> PSet.to_list db.eavt_index +let primary_attr_datoms = Db_impl.primary_attr_datoms let primary_attr_datoms_seq db index ?e ~a ?v ?tx () = let datoms = primary_attr_datoms db index a in @@ -1203,9 +1273,15 @@ let primary_attr_datoms_seq db index ?e ~a ?v ?tx () = | None -> true) let query_attr_datoms_seq db index ?e ~a ?v ?tx () = - match db.duplicate_datoms with - | [] -> datoms db index ?e ~a ?v ?tx () - | _ -> primary_attr_datoms_seq db index ?e ~a ?v ?tx () + let attr = a in + match temporal_view db, db.duplicate_datoms, index, e, v, tx with + | true, _, _, _, _, _ -> + (* Temporal views must go through datoms so history/as_of filtering applies. *) + datoms db index ?e ~a:attr ?v ?tx () + | false, [], Avet, None, Some value, None -> + List.to_seq (Db_access_impl.avet_datoms_by_value db attr value) + | false, [], _, _, _, _ -> datoms db index ?e ~a:attr ?v ?tx () + | false, _, _, _, _, _ -> primary_attr_datoms_seq db index ?e ~a:attr ?v ?tx () let pattern_datoms db e_term a_term v_term tx_term = let e = query_entity_id_term db e_term in @@ -1296,7 +1372,12 @@ let match_data_pattern_tx db bindings e_term a_term v_term tx_term datom = let match_data_pattern_tx_op db bindings e_term a_term v_term tx_term op_term datom = let ( let* ) = Option.bind in let* bindings = match_data_pattern_tx db bindings e_term a_term v_term tx_term datom in - match_query_term db op_term (result_of_datom_op datom) bindings + (* History patterns use boolean added flags; also accept + :db/add / :db/retract keywords for DataScript-style queries. *) + match op_term with + | QValue (Bool expected) when datom.added = expected -> Some bindings + | QValue (Bool _) -> None + | _ -> match_query_term db op_term (result_of_datom_op datom) bindings let query_source_context db : Query.source_context = { match_context = query_match_context db @@ -1411,8 +1492,42 @@ module Query_where_impl = Query_where.Make (struct let is_ref_attr = is_ref_attr let cardinality_one db attr = cardinality db attr = One let normalize_value = normalize_value + let datoms_by_attr_value = datoms_by_attr_value + let entity_ids_by_attr_value = entity_ids_by_attr_value + let query_attr_uses_avet = query_attr_uses_avet + let fold_index_range = fold_index_range + let find_entity_attr_value db entity_id attr = + match Db.find_primary_aevt_entity_attr db entity_id attr with + | None -> None + | Some datom -> Some (Query.result_of_ref (Query.result_of_datom_v datom)) + let aevt_attr_array = Db.aevt_attr_array + let aevt_duplicate_datoms db attr = + Option.value (Hashtbl.find_opt db.duplicate_aevt_by_attr attr) ~default:[] + let find_entity_in_aevt_array = Db.find_entity_in_aevt_array +end) + +module Query_exec = Query_exec + +module Query_exec_impl = Query_exec.Make (struct + let query_evaluator_context = query_evaluator_context + let query_source_context = query_source_context + let cardinality_one db attr = cardinality db attr = One + let datoms_by_attr_value = datoms_by_attr_value + let entity_ids_by_attr_value = entity_ids_by_attr_value + let entity_ids_array_by_attr_value = entity_ids_array_by_attr_value + let query_attr_uses_avet = query_attr_uses_avet + let query_value_uses_avet = query_value_uses_avet + let aevt_attr_array = Db.aevt_attr_array + let aevt_duplicate_datoms db attr = + Option.value (Hashtbl.find_opt db.duplicate_aevt_by_attr attr) ~default:[] + let find_entity_in_aevt_array = Db.find_entity_in_aevt_array end) +let execute_plan db sources rules bindings plan = + match Query_exec_impl.run db sources rules bindings plan with + | None -> None + | Some relation -> Some (relation.attrs, relation.rows, relation.unique_rows) + let eval_clauses = Query_where_impl.eval_clauses let eval_relation_rows = Query_where_impl.eval_relation_rows @@ -1448,7 +1563,22 @@ let parse_with = Parser_impl.parse_with let parse_query_return form = Parser_impl.parse_query_return parser_query_context form let parse_query_return_map form = Parser_impl.parse_query_return_map parser_query_context form let parse_query form = Parser_impl.parse_query parser_query_context form -let parse_query_string input = Parser_impl.parse_query_string parser_query_context input + +let query_string_cache : (string, query) Hashtbl.t = Hashtbl.create 32 + +let parse_query_string_uncached input = + Parser_impl.parse_query_string parser_query_context input + +let cached_query_string input = + match Hashtbl.find_opt query_string_cache input with + | Some query -> query + | None -> + let query = parse_query_string_uncached input in + Hashtbl.replace query_string_cache input query; + query + +let parse_query_string input = cached_query_string input + let parse_query_string_with_pull_context ?default_pull_db ?pull_db_for_source input = Parser_impl.parse_query_string_with_pull_context parser_query_context ?default_pull_db ?pull_db_for_source input let parse_query_return_string input = Parser_impl.parse_query_return_string parser_query_context input @@ -1563,6 +1693,7 @@ module Query_api_impl = Query_api.Make (struct let initial_query_context = initial_query_context let eval_clauses = eval_clauses let eval_relation_rows = eval_relation_rows + let execute_plan = execute_plan let has_aggregates = has_aggregates let aggregate_rows = aggregate_rows let aggregate_rows_with = aggregate_rows_with @@ -1574,6 +1705,14 @@ module Query_api_impl = Query_api.Make (struct let compare_value = compare_value end) +type query_exec_path = Query_api.query_exec_path = + | Fused_execute + | Relation_fallback + | Binding_interpreter + +let last_query_exec_path = Query_api.last_query_exec_path +let with_force_relation_fallback = Query_api.with_force_relation_fallback + module Query_impl = Query let query_context = Query_api_impl.query_context @@ -1657,164 +1796,8 @@ module Query = struct let empty_query_callables = Query_impl.empty_query_callables - type simple_row_slot = - | Simple_entity_slot - | Simple_value_slot of query_result option array + let q ?inputs db query = Query_impl.q query_context ?inputs db query - let simple_same_entity_constant_rows ?inputs db query = - let ( let* ) = Option.bind in - match db.max_datom_e > 50_000, inputs, query.rules, query.with_vars with - | true, _, _, _ -> None - | false, Some _, _, _ | false, _, _ :: _, _ | false, _, _, _ :: _ -> None - | false, None, [], [] -> - let* find_vars = - query.find - |> List.fold_left - (fun vars -> function - | Find_var var -> Option.map (fun vars -> var :: vars) vars - | _ -> None) - (Some []) - |> Option.map List.rev - in - let pattern_summary = - List.fold_left - (fun acc -> function - | Pattern (QVar entity_var, QAttr attr, value_term) - when (not (is_reverse_ref attr)) && cardinality db attr = One -> - (match acc with - | None -> None - | Some (e_var, value_var_attrs, constant_patterns) -> - let e_var = - match e_var with - | None -> Some entity_var - | Some existing when existing = entity_var -> e_var - | Some _ -> None - in - (match e_var, value_term with - | None, _ -> None - | Some _, QVar value_var when value_var <> entity_var -> - Some (e_var, (value_var, attr) :: value_var_attrs, constant_patterns) - | Some _, QValue value -> - Some (e_var, value_var_attrs, (attr, value) :: constant_patterns) - | _ -> None)) - | _ -> None) - (Some (None, [], [])) - query.where - in - let* e_var, value_var_attrs, constant_patterns = - Option.bind pattern_summary (function - | Some e_var, value_var_attrs, constant_patterns -> - Some (e_var, List.rev value_var_attrs, List.rev constant_patterns) - | None, _, _ -> None) - in - if constant_patterns = [] then - None - else - let duplicate_value_var = - let seen = Hashtbl.create (List.length value_var_attrs) in - List.exists - (fun (value_var, _) -> - if Hashtbl.mem seen value_var then true - else ( - Hashtbl.add seen value_var (); - false )) - value_var_attrs - in - if duplicate_value_var then - None - else - let constant_datoms = - constant_patterns - |> List.map (fun (attr, value) -> attr, datoms_by_attr_value db attr value) - in - if List.exists (fun (_, datoms) -> datoms = []) constant_datoms then - Some [] - else - let value_tables = - value_var_attrs - |> List.map (fun (value_var, attr) -> - let values = Array.make (db.max_datom_e + 1) None in - primary_attr_datoms db Aevt attr - |> List.iter (fun datom -> - if datom.e >= 0 && datom.e < Array.length values then - values.(datom.e) <- Some (Query_impl.result_of_datom_v datom)); - value_var, values) - in - let slot_for_find_var var = - if var = e_var then - Some Simple_entity_slot - else - Option.map - (fun values -> Simple_value_slot values) - (List.assoc_opt var value_tables) - in - let* row_slots = - find_vars - |> List.fold_left - (fun slots var -> - match slots with - | None -> None - | Some slots -> Option.map (fun slot -> slot :: slots) (slot_for_find_var var)) - (Some []) - |> Option.map List.rev - in - let constant_sets = - constant_datoms - |> List.map (fun (_, datoms) -> - let entities = Bytes.make (db.max_datom_e + 1) '\000' in - List.iter - (fun datom -> - if datom.e >= 0 && datom.e < Bytes.length entities then - Bytes.set entities datom.e '\001') - datoms; - entities) - in - let _, scan_datoms = - constant_datoms - |> List.sort (fun (_, left) (_, right) -> compare (List.length left) (List.length right)) - |> List.hd - in - let entity_allowed entity_id = - constant_sets - |> List.for_all (fun entities -> - entity_id >= 0 - && entity_id < Bytes.length entities - && Bytes.get entities entity_id = '\001') - in - let value_of_slot entity_id = function - | Simple_entity_slot -> Some (Result_entity entity_id) - | Simple_value_slot values -> - if entity_id >= 0 && entity_id < Array.length values then values.(entity_id) else None - in - let row_for_entity entity_id = - row_slots - |> List.fold_left - (fun row slot -> - match row with - | None -> None - | Some row -> Option.map (fun value -> value :: row) (value_of_slot entity_id slot)) - (Some []) - |> Option.map List.rev - in - scan_datoms - |> List.filter_map (fun datom -> - if entity_allowed datom.e then row_for_entity datom.e else None) - |> List.sort_uniq compare - |> fun rows -> Some rows - - let q ?inputs db query = - match simple_same_entity_constant_rows ?inputs db query with - | Some rows -> rows - | None -> Query_impl.q query_context ?inputs db query - - let query_string_cache : (string, query) Hashtbl.t = Hashtbl.create 32 - let cached_query_string input = - match Hashtbl.find_opt query_string_cache input with - | Some query -> query - | None -> - let query = parse_query_string input in - Hashtbl.replace query_string_cache input query; - query let q_string ?inputs db input = if string_includes input "pull" then @@ -1834,6 +1817,15 @@ module Query = struct | _ -> false) inputs + let query_debug_enabled = + match Sys.getenv_opt "DATASCRIPT_QUERY_DEBUG" with + | Some ("1" | "true" | "yes") -> true + | _ -> false + + let debug_log msg = + if query_debug_enabled then + Printf.eprintf "[datascript %.3f] %s\n%!" (Platform.now_seconds ()) msg + let entity_ids_with_attr db attr = let rec collect previous acc = function | [] -> List.rev acc @@ -2303,6 +2295,10 @@ module Query = struct | _ -> None let ref_target_pull_relation db query = + debug_log + (Printf.sprintf "ref_target_pull_relation find=%d where=%d max_e=%d" (List.length query.find) + (List.length query.where) + db.max_datom_e); let wildcard_selector = function | [ Pull_wildcard ] -> Some [ Pull_wildcard ] | _ -> None @@ -2343,11 +2339,13 @@ module Query = struct let required_attrs = List.filter_map (required_pattern source_var) query.where in (match required_attrs with | [ required_attr ] -> + debug_log "ref_target_pull_relation step=source_entities"; let source_entities = Bytes.make (db.max_datom_e + 1) '\000' in entity_ids_with_attr db required_attr |> List.iter (fun entity_id -> if entity_id >= 0 && entity_id < Bytes.length source_entities then Bytes.set source_entities entity_id '\001'); + debug_log "ref_target_pull_relation step=ref_scan"; let source_has_required entity_id = entity_id >= 0 && entity_id < Bytes.length source_entities @@ -2362,14 +2360,32 @@ module Query = struct | _ -> None) |> List.sort_uniq compare in + debug_log (Printf.sprintf "ref_target_pull_relation target_ids=%d" (List.length target_ids)); let rows = - Pull_api_impl.pull_wildcard_many_by_ids pull_api_context db target_ids - |> List.map (fun entity -> [ Result_pull entity ]) + if List.length target_ids <= 512 then ( + debug_log "ref_target_pull_relation per-entity pull"; + target_ids + |> List.filter_map (fun entity_id -> + Pull_api_impl.pull pull_api_context db [ Pull_wildcard ] (Entity_id entity_id) + |> Option.map (fun entity -> [ Result_pull entity ]))) + else ( + debug_log "ref_target_pull_relation wildcard_many_by_ids scan"; + Pull_api_impl.pull_wildcard_many_by_ids pull_api_context db target_ids + |> List.map (fun entity -> [ Result_pull entity ])) in + debug_log + (Printf.sprintf "ref_target_pull_relation HIT targets=%d rows=%d" (List.length target_ids) + (List.length rows)); Some (Query_relation rows) - | _ -> None) - | _ -> None) - | _ -> None + | _ -> + debug_log "ref_target_pull_relation miss required_attrs shape"; + None) + | _ -> + debug_log "ref_target_pull_relation miss missing/ref pattern"; + None) + | _ -> + debug_log "ref_target_pull_relation miss find/rules/inputs guard"; + None let scalar_input_bindings db query inputs = let rec collect acc declarations args = @@ -2888,13 +2904,17 @@ module Query = struct | [] -> None) |> fun values -> Query_collection values))) | Return_relation, None -> + debug_log "q_return Return_relation"; (match simple_attr_entity_pull_collection db query with | Some (Query_collection values) -> Query_relation (List.map (fun value -> [ value ]) values) | Some result -> result | None -> (match ref_target_pull_relation db query with - | Some result -> result + | Some result -> + debug_log "q_return -> ref_target_pull_relation"; + result | None -> + debug_log "q_return -> fallback q()"; let rows = q db query in Query_relation rows)) | Return_relation, Some inputs -> @@ -3112,6 +3132,18 @@ end let q = Query.q let q_string = Query.q_string + +let () = + warm_query_parser := + (let warmed = ref false in + fun db -> + if not !warmed then ( + warmed := true; + ignore (read_edn "1"); + ignore (parse_query_string_uncached "[:find ?e :where [?e :name \"warmup\"]]"); + ignore (parse_query_string_uncached "[:find ?e :where [?e :age 1]]"); + ignore (q_string db "[:find ?e :where [?e :name \"warmup\"]]"))) + let q_with = Query.q_with let q_with_string = Query.q_with_string let q_sources = Query.q_sources diff --git a/impl/datascript.mli b/impl/datascript.mli index fbf1e4f..90f4439 100644 --- a/impl/datascript.mli +++ b/impl/datascript.mli @@ -88,22 +88,17 @@ module Conn : sig ; with_schema : db -> schema -> db } - type restore_context = - { restore : storage -> db option - ; restore_tail_groups : storage -> datom list list - } + type restore_context = { restore : storage -> db option } type transact_context = { store : ?storage:storage -> db -> unit - ; store_tail : storage -> datom list list -> unit - ; storage_tail_datom_count : datom list list -> int - ; storage_tail_compaction_threshold : int ; transact : tx_meta:tx_meta -> db -> tx_op list -> tx_report } type reset_context = { store : ?storage:storage -> db -> unit ; datoms : db -> datom list + ; snapshot_db : db -> db } val create : creation_context -> ?schema:schema -> ?storage:storage -> unit -> t @@ -148,6 +143,19 @@ 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 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 as_of_instant : value -> db -> db + val since : tx -> db -> db + val history : db -> db + val is_history : db -> bool + val resolve_tx_at_instant : value -> db -> tx + val purge_history_before : tx -> db -> db * datom list val hash : db -> int val hash_cache_size : unit -> int val diff : db -> db -> datom list * datom list * datom list @@ -223,7 +231,7 @@ module Serialize : sig { next_db_uid : unit -> int ; validate_schema : schema -> schema ; normalize_datom_for_schema : schema -> datom -> datom - ; refresh_db_indexes : db -> db + ; with_datoms : db -> datom list -> db } val serializable : db -> serializable_db @@ -231,30 +239,16 @@ module Serialize : sig end module Storage : sig - type tail_context = - { apply_group : db -> datom list -> db - } - - type restore_context = - { next_db_uid : unit -> int - ; db_with_tail : db -> datom list list -> db - } + type restore_context = { next_db_uid : unit -> int } - val root_address : storage_address - val tail_address : storage_address val memory_storage : unit -> storage - val file_storage : string -> storage +val benchmark_memory_storage : unit -> storage + val ensure_live : storage -> unit + val kind_of : storage -> storage_kind val store : ?storage:storage -> db -> unit - val store_tail : storage -> datom list list -> unit - val tail_compaction_threshold : int - val tail_datom_count : datom list list -> int val restore_root_snapshot : storage -> serializable_db option - val restore_tail_groups : storage -> datom list list - val db_with_tail : tail_context -> db -> datom list list -> db 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 @@ -397,22 +391,131 @@ val empty_db : ?schema:schema -> ?storage:storage -> unit -> db val empty : db -> db val is_db : db -> bool val init_db : ?schema:schema -> ?storage:storage -> datom list -> db +val refresh_db_indexes : db -> 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 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 as_of_instant : value -> db -> db +val since : tx -> db -> db +val history : db -> db +val is_history : db -> bool +val resolve_tx_at_instant : value -> db -> tx +val purge_history_before : tx -> db -> db * datom list +module Tx_visibility : module type of Tx_visibility +module Query_plan : sig + type index_choice = + | Prefer_eavt + | Prefer_aevt + | Prefer_avet + + type l_scan = + { entity : query_term + ; attr : query_term + ; value : query_term + ; tx : query_term option + ; source : string option + ; clause : query_clause + ; vars : string list + } + + type logical_node = + | LScan of l_scan + | LEntityJoin of + { entity_var : string + ; scans : l_scan list + ; anti_scans : l_scan list + ; filters : query_clause list + ; source : string option + } + | LFilter of query_clause + | LUnion of + { join_vars : string list option + ; branches : logical_plan list + ; clause : query_clause + } + | LAntiJoin of + { join_vars : string list option + ; sub : logical_plan + ; clause : query_clause + } + | LRuleExpand of + { name : string + ; terms : query_term list + ; body : logical_plan + } + | LPassthrough of query_clause + + and logical_plan = + { nodes : logical_node list + ; bound_vars : string list + } + + type entity_group = + { entity_var : string + ; scan : l_scan + ; merges : l_scan list + ; anti_scans : l_scan list + ; filters : query_clause list + ; clauses : query_clause list + ; estimated_rows : int + ; source : string option + } + + type physical_op = + | OpEntityGroup of entity_group + | OpScan of + { clause : query_clause + ; index : index_choice + ; estimated_rows : int + ; source : string option + } + | OpFilter of query_clause + | OpUnion of + { join_vars : string list option + ; branches : physical_plan list + } + | OpAntiJoin of + { join_vars : string list option + ; excluded : physical_plan + } + | OpPassthrough of query_clause + + and physical_plan = + { ops : physical_op list + } + + val choose_index : query_term -> query_term -> query_term -> index_choice + val estimate_pattern_cost : ?max_datom_e:int -> query_term -> query_term -> query_term -> int + val build_logical_plan : + ?max_datom_e:int -> ?bound_vars:string list -> ?rules:query_rule list -> query_clause list -> logical_plan option + val lower : ?max_datom_e:int -> logical_plan -> physical_plan option + val compile : + ?max_datom_e:int -> ?bound_vars:string list -> ?rules:query_rule list -> query_clause list -> physical_plan option + val analyze : ?max_datom_e:int -> ?bound_vars:string list -> ?rules:query_rule list -> query -> physical_plan option + val plan_is_executable : physical_plan -> bool + val plan_is_fused_execute : physical_plan -> bool + val clauses_of_plan : physical_plan -> query_clause list +end val serializable : db -> serializable_db val from_serializable : serializable_db -> db val db_from_reader_string : string -> db val memory_storage : unit -> storage -val file_storage : string -> storage +val benchmark_memory_storage : unit -> storage +val ensure_live : storage -> unit +val kind_of : storage -> storage_kind +val storage_of_handle : Datascript_types.storage -> storage +val db_shares_storage_index : storage -> db -> bool val store : ?storage:storage -> db -> unit -val store_tail : storage -> datom list list -> unit val restore : storage -> db option -val db_with_tail : db -> datom list list -> db 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 @@ -489,6 +592,18 @@ val parse_query_return_map_string_with_pull_context : string -> query_return * query_return_map option * query +(** Which engine finished the last [q] / [q_string] relation path. + Intended for tests that pin fused execute vs relational fallback. *) +type query_exec_path = + | Fused_execute + | Relation_fallback + | Binding_interpreter + +val last_query_exec_path : unit -> query_exec_path + +(** Run [f] with fused [Query_exec] disabled so [q] uses the relational fallback. *) +val with_force_relation_fallback : (unit -> 'a) -> 'a + module Query : sig type query_callables = { callable_predicates : (string * (query_result list -> bool)) list diff --git a/impl/db.ml b/impl/db.ml index 87579d1..091bca5 100644 --- a/impl/db.ml +++ b/impl/db.ml @@ -1,6 +1,6 @@ open Datascript_types -module PSet = Persistent_sorted_set +module Index = Index let tx0 = 0x20000000 @@ -62,14 +62,7 @@ let normalize_datom_for_schema schema d = ignore schema; Util.normalize_datom_value d -let empty_index index = - PSet.empty_by ~cmp:(Util.compare_datom index) () - -let build_index index datoms = - let cmp = Util.compare_datom index in - let items = Array.of_list datoms in - Array.sort cmp items; - PSet.of_sorted_array_by ~cmp items +let empty_index index lmdb = Index.empty index lmdb let duplicate_datoms datoms = let datoms = List.sort (Util.compare_datom Eavt) datoms in @@ -83,6 +76,18 @@ let duplicate_datoms datoms = in loop None [] datoms +let primary_datoms index datoms = + let datoms = List.sort (Util.compare_datom index) datoms in + let rec loop previous primary = function + | [] -> List.rev primary + | datom :: rest -> + (match previous with + | Some previous when Util.compare_datom index previous datom = 0 -> + loop (Some datom) primary rest + | _ -> loop (Some datom) (datom :: primary) rest) + in + loop None [] datoms + let duplicate_eavt_by_entity duplicate_datoms = let table = Hashtbl.create 1024 in List.iter @@ -103,32 +108,147 @@ let duplicate_datoms_by_attr duplicate_datoms = Hashtbl.iter (fun attr datoms -> Hashtbl.replace table attr (List.rev datoms)) table; table -let build_avet_index schema datoms = - datoms - |> List.filter (fun d -> Schema.schema_attr_is_avet_accessible schema d.a) - |> build_index Avet +(** Copy-on-write drop of cache entries for attributes touched by [datoms]. + Unaffected attr slices stay warm across append-only transactions. *) +let invalidate_attr_tables_for_datoms datoms db = + let attrs = + datoms + |> List.map (fun d -> d.a) + |> List.sort_uniq String.compare + in + match attrs with + | [] -> db + | attrs -> + let drop_attr attr = List.mem attr attrs in + let copy_attr_table src = + if Hashtbl.length src = 0 then Hashtbl.create 0 + else + let dst = Hashtbl.create (Hashtbl.length src) in + Hashtbl.iter + (fun attr value -> if not (drop_attr attr) then Hashtbl.replace dst attr value) + src; + dst + in + let copy_avet_entities src = + if Hashtbl.length src = 0 then Hashtbl.create 0 + else + let dst = Hashtbl.create (Hashtbl.length src) in + Hashtbl.iter + (fun ((attr, _) as key) value -> + if not (drop_attr attr) then Hashtbl.replace dst key value) + src; + dst + in + { db with + aevt_by_attr = copy_attr_table db.aevt_by_attr + ; avet_by_attr = copy_attr_table db.avet_by_attr + ; avet_entities_by_attr_value = copy_avet_entities db.avet_entities_by_attr_value + } + +(** Temporal shallow copies must not share mutable current-fact caches with the + live DB; history/as_of reads rebuild slices from raw indexes instead. *) +let detach_attr_caches db = + { db with + aevt_by_attr = Hashtbl.create 0 + ; avet_by_attr = Hashtbl.create 0 + ; avet_entities_by_attr_value = Hashtbl.create 0 + } -let datoms_by_attr datoms = - let table = Hashtbl.create 1024 in - List.iter - (fun datom -> - let existing = Option.value (Hashtbl.find_opt table datom.a) ~default:[] in - Hashtbl.replace table datom.a (datom :: existing)) - datoms; - Hashtbl.iter (fun attr datoms -> Hashtbl.replace table attr (List.rev datoms)) table; +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 db.schema (view_bounds db) datoms + +let apply_db_view_seq db seq = Tx_visibility.filter_seq db.schema (view_bounds db) seq + +(** Apply temporal cancel to a descending (rseek) sequence by restoring ascending order. *) +let apply_db_view_reverse_seq db seq = + seq |> List.of_seq |> List.rev |> apply_db_view db |> List.rev |> List.to_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 index_db_of_db db = + try Index.index_db_of (Index.db_of db.eavt_index) + with Invalid_argument _ -> + let index_db, _ = Index.create_index_db db.storage_ref in + index_db + +let lmdb_of_db = index_db_of_db + +let group_sorted_datoms_by_attr datoms = + let table = Hashtbl.create 32 in + let rec flush attr group = function + | [] -> Hashtbl.replace table attr (Array.of_list (List.rev group)) + | datom :: rest when datom.a = attr -> + flush attr (datom :: group) rest + | datom :: rest -> + Hashtbl.replace table attr (Array.of_list (List.rev group)); + flush datom.a [ datom ] rest + in + (match datoms with + | [] -> () + | datom :: rest -> flush datom.a [ datom ] rest); table -let invalidate_attr_tables db = - if Hashtbl.length db.aevt_by_attr = 0 && Hashtbl.length db.avet_by_attr = 0 then - db - else - { db with aevt_by_attr = Hashtbl.create 0; avet_by_attr = Hashtbl.create 0 } +let index_avet_entities_by_attr_value avet_sorted = + let table = Hashtbl.create 256 in + List.iter + (fun datom -> + let key = (datom.a, datom.v) in + let existing = Option.value (Hashtbl.find_opt table key) ~default:[] in + Hashtbl.replace table key (datom.e :: existing)) + avet_sorted; + let array_table = Hashtbl.create (Hashtbl.length table) in + Hashtbl.iter + (fun key entity_ids -> Hashtbl.replace array_table key (Array.of_list (List.rev entity_ids))) + table; + array_table + +let datoms_of_avet_entities attr value entity_ids = + entity_ids + |> Array.to_list + |> List.map (fun e -> { e; a = attr; v = value; tx = tx0; added = true }) let set_indexes_from_datoms db datoms = - let eavt_index = build_index Eavt datoms in - let aevt_index = build_index Aevt datoms in - let avet_index = build_avet_index db.schema datoms in + let lmdb = lmdb_of_db db in let duplicate_datoms = duplicate_datoms datoms in + let eavt_datoms = primary_datoms Eavt datoms in + let aevt_sorted = List.sort (Util.compare_datom Aevt) eavt_datoms in + let avet_sorted = + eavt_datoms + |> List.filter (fun d -> Schema.schema_attr_is_avet_accessible db.schema d.a) + |> List.sort (Util.compare_datom Avet) + in + Index.of_eavt_datoms + ~avet:(Schema.schema_attr_is_avet_accessible db.schema) + eavt_datoms + lmdb; + 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 @@ -143,8 +263,9 @@ let set_indexes_from_datoms db datoms = eavt_index ; aevt_index ; avet_index - ; aevt_by_attr = datoms_by_attr (PSet.to_list aevt_index) - ; avet_by_attr = datoms_by_attr (PSet.to_list avet_index) + ; aevt_by_attr = group_sorted_datoms_by_attr aevt_sorted + ; avet_by_attr = group_sorted_datoms_by_attr avet_sorted + ; avet_entities_by_attr_value = index_avet_entities_by_attr_value avet_sorted ; duplicate_datoms ; duplicate_aevt_datoms ; duplicate_avet_datoms @@ -152,10 +273,13 @@ let set_indexes_from_datoms db datoms = ; duplicate_aevt_by_attr ; duplicate_avet_by_attr ; max_datom_e + ; pending_datoms = [] } let eavt_datoms db = - PSet.to_list db.eavt_index @ db.duplicate_datoms |> List.sort (Util.compare_datom Eavt) + Index.to_list db.eavt_index @ db.duplicate_datoms @ db.pending_datoms + |> List.sort (Util.compare_datom Eavt) + |> apply_db_view db let refresh_indexes db = set_indexes_from_datoms db (eavt_datoms db) @@ -163,97 +287,132 @@ let refresh_indexes db = let add_datoms_to_index include_datom datoms index_set = List.fold_left (fun index_set datom -> - if include_datom datom then PSet.add datom index_set else index_set) + if include_datom datom then Index.add datom index_set else index_set) index_set datoms 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 - -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 + 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_for_datoms added_datoms + else + { db with pending_datoms = db.pending_datoms @ added_datoms; max_datom_e } + |> invalidate_attr_tables_for_datoms added_datoms + +let refresh_indexes_with_tx_data db tx_data = + if tx_data = [] then db + else + let max_datom_e = List.fold_left (fun max_e d -> max max_e d.e) db.max_datom_e tx_data in + 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_for_datoms tx_data 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 PSet.slice ~from_:bound ~to_:bound ~cmp db.eavt_index @ duplicate_matches with - | [] -> None - | matches -> Some (matches |> List.sort (Util.compare_datom Eavt) |> List.hd) + { db with pending_datoms = db.pending_datoms @ tx_data; max_datom_e } + |> invalidate_attr_tables_for_datoms tx_data -let add_datom_to_indexes db datom = - { db with - eavt_index = PSet.add datom db.eavt_index - ; aevt_index = PSet.add datom db.aevt_index - ; avet_index = - if Schema.schema_attr_is_avet_accessible db.schema datom.a then - PSet.add datom db.avet_index - else - db.avet_index - ; max_datom_e = max db.max_datom_e datom.e - } +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 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 = PSet.remove active db.eavt_index - ; aevt_index = PSet.remove active db.aevt_index - ; avet_index = PSet.remove active db.avet_index - }) - db - tx_data - in - invalidate_attr_tables db +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_for_datoms removed_datoms + +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 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); + detach_attr_caches { db with max_tx = tx; as_of_tx = Some tx } + +let since tx db = detach_attr_caches { db with since_tx = Some tx } + +let history db = detach_attr_caches { 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 +let storage_ref_of ?storage auto_storage_ref = + match storage with + | Some attached_storage -> Some attached_storage + | None -> auto_storage_ref + let empty_db context ?(schema = []) ?storage () = let schema = Schema.validate_schema schema in + let index_db, auto_storage_ref = Index.create_index_db storage in { db_uid = context.next_db_uid () ; schema - ; eavt_index = empty_index Eavt - ; aevt_index = empty_index Aevt - ; avet_index = empty_index Avet + ; eavt_index = empty_index Eavt index_db + ; aevt_index = empty_index Aevt index_db + ; avet_index = empty_index Avet index_db ; aevt_by_attr = Hashtbl.create 0 ; avet_by_attr = Hashtbl.create 0 + ; avet_entities_by_attr_value = Hashtbl.create 0 ; duplicate_datoms = [] ; duplicate_aevt_datoms = [] ; duplicate_avet_datoms = [] @@ -263,8 +422,13 @@ 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 + ; pending_datoms = [] + ; storage_ref = storage_ref_of ?storage auto_storage_ref ; tx_fns = [] } @@ -277,13 +441,15 @@ let init_db context ?(schema = []) ?storage datoms = List.fold_left (fun max_eid d -> max_eid_in_value (max_eid_with_entity_id max_eid d.e) d.v) 0 datoms in let max_tx = List.fold_left (fun max_tx d -> max max_tx d.tx) tx0 datoms in + let index_db, auto_storage_ref = Index.create_index_db storage in { db_uid = context.next_db_uid () ; schema - ; eavt_index = empty_index Eavt - ; aevt_index = empty_index Aevt - ; avet_index = empty_index Avet + ; eavt_index = empty_index Eavt index_db + ; aevt_index = empty_index Aevt index_db + ; avet_index = empty_index Avet index_db ; aevt_by_attr = Hashtbl.create 0 ; avet_by_attr = Hashtbl.create 0 + ; avet_entities_by_attr_value = Hashtbl.create 0 ; duplicate_datoms = [] ; duplicate_aevt_datoms = [] ; duplicate_avet_datoms = [] @@ -293,8 +459,13 @@ 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 + ; pending_datoms = [] + ; storage_ref = storage_ref_of ?storage auto_storage_ref ; tx_fns = [] } |> fun db -> with_datoms db datoms @@ -389,33 +560,61 @@ let duplicate_attr_datoms db index attr = | Avet -> Option.value (Hashtbl.find_opt db.duplicate_avet_by_attr attr) ~default:[] | Eavt -> duplicate_index_datoms db index +let cache_avet_entities_for_attr db attr datoms = + let by_value = Hashtbl.create 16 in + List.iter + (fun datom -> + let existing = Option.value (Hashtbl.find_opt by_value datom.v) ~default:[] in + Hashtbl.replace by_value datom.v (datom.e :: existing)) + datoms; + Hashtbl.iter + (fun value entity_ids -> + Hashtbl.replace + db.avet_entities_by_attr_value + (attr, value) + (Array.of_list (List.rev entity_ids))) + by_value + let primary_attr_datoms db index attr = - let attr_prefix_datoms index index_set = - let bound = datom ~e:0 ~a:attr ~v:Nil () in - let compare_prefix left right = compare left.a right.a in - let cmp left right = - if right == bound then compare_prefix left right - else if left == bound then -compare_prefix right left - else Util.compare_datom index left right - in - PSet.slice ~from_:bound ~to_:bound ~cmp index_set + 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 + (* Attr caches are shared across as_of/since/history shallow copies and hold + current-basis slices. Temporal views must rebuild from raw indexes so + retracted/history facts remain available for apply_db_view. *) + let temporal = temporal_view db in match index with | Aevt -> - (match Hashtbl.find_opt db.aevt_by_attr attr with - | Some datoms -> datoms + (match (if temporal then None else 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 in - Hashtbl.replace db.aevt_by_attr attr datoms; + let datoms = + merge_sorted_datoms Aevt (attr_prefix_datoms Aevt db.aevt_index) pending_attr + |> apply_db_view db + in + if not temporal then 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 -> datoms + (match (if temporal then None else 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 in - Hashtbl.replace db.avet_by_attr attr datoms; + let datoms = + merge_sorted_datoms Avet (attr_prefix_datoms Avet db.avet_index) pending_attr + |> apply_db_view db + in + if not temporal then ( + Hashtbl.replace db.avet_by_attr attr (Array.of_list datoms); + cache_avet_entities_for_attr db attr datoms); datoms) - | Eavt -> PSet.to_list db.eavt_index + | Eavt -> + merge_sorted_datoms Eavt (Index.to_list db.eavt_index) pending_attr |> apply_db_view db + +let aevt_attr_array db attr = + ignore (primary_attr_datoms db Aevt attr); + Hashtbl.find_opt db.aevt_by_attr attr let duplicate_prefix_datoms db index e a = match index, e, a with @@ -423,41 +622,103 @@ let duplicate_prefix_datoms db index e a = | (Aevt | Avet), _, Some attr -> duplicate_attr_datoms db index attr | _ -> duplicate_index_datoms db index -let exact_sorted_slice cmp bound datoms = - let rec drop_before = function - | datom :: rest when cmp datom bound < 0 -> drop_before rest - | datoms -> take_equal [] datoms - and take_equal acc = function - | datom :: rest when cmp datom bound = 0 -> take_equal (datom :: acc) rest - | _ -> List.rev acc - in - drop_before datoms - let raw_index_datoms_list db index = - merge_sorted_datoms index (stored_index db index |> PSet.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 = 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 |> PSet.seq |> PSet.to_seq - | _ -> raw_index_datoms_list db index |> 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 |> PSet.rslice_seq |> PSet.to_seq - | _ -> - let indexed = stored_index db index |> PSet.rslice_seq |> PSet.to_seq in + 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 (fun left right -> Util.compare_datom index right left) indexed duplicates +let instant_millis = function + | Instant ms -> Some ms + | _ -> None + +(** Resolve the latest transaction whose [:db/txInstant] is <= [instant]. *) +let resolve_tx_at_instant instant db = + let target = + match instant with + | Instant ms -> ms + | _ -> invalid_arg "as_of_instant requires Instant value" + in + let best = ref None in + let consider datom = + match instant_millis datom.v with + | Some ms when ms <= target && datom.added -> + (match !best with + | None -> best := Some (datom.e, ms) + | Some (_, best_ms) when ms >= best_ms -> best := Some (datom.e, ms) + | Some _ -> ()) + | _ -> () + in + (match primary_attr_datoms db Aevt "db/txInstant" with + | [] -> + List.iter + (fun d -> if d.a = "db/txInstant" then consider d) + (raw_index_datoms_list db Eavt) + | datoms -> List.iter consider datoms); + match !best with + | Some (tx, _) -> tx + | None -> + invalid_arg "as_of_instant: no :db/txInstant at or before the given Instant" + +let as_of_instant instant db = as_of (resolve_tx_at_instant instant db) db + +(** Physically drop history facts with [tx < before] while keeping the current + projection and all datoms at or after [before]. *) +let purge_history_before before db = + if temporal_view db then + invalid_arg "Cannot purge history against an as-of/since/history database value"; + if before > db.store_max_tx then + invalid_arg + ("purge_history_before tx " + ^ string_of_int before + ^ " is after database basis " + ^ string_of_int db.store_max_tx); + let raw = raw_index_datoms_list db Eavt in + let visible = apply_db_view db raw in + let visible_keys = Hashtbl.create (List.length visible) in + List.iter + (fun d -> Hashtbl.replace visible_keys (d.e, d.a, d.v, d.tx, d.added) ()) + visible; + let keep d = + d.tx >= before || Hashtbl.mem visible_keys (d.e, d.a, d.v, d.tx, d.added) + in + let kept = List.filter keep raw in + let removed = List.filter (fun d -> not (keep d)) raw in + if removed = [] then db, [] + else set_indexes_from_datoms db kept, removed + let apply_filter_pred db seq = match db.filter_pred with | None -> seq @@ -535,6 +796,146 @@ let compare_bound_fields context fields left right = function (compare_bound_e fields left right) (compare_bound_tx fields left right) +let array_attr_value_slice context index bound bound_fields arr = + let prefix left right = compare_bound_fields context bound_fields left right index in + let len = Array.length arr in + let rec lower lo hi = + if lo >= hi then lo + else + let mid = (lo + hi) / 2 in + if prefix arr.(mid) bound < 0 then lower (mid + 1) hi else lower lo mid + in + let start = lower 0 len in + let rec upper index = + if index >= len || prefix arr.(index) bound > 0 then index else upper (index + 1) + in + let stop = upper start in + if start >= stop then [] + else Array.sub arr start (stop - start) |> Array.to_list + +let array_attr_value_seq context index bound bound_fields arr = + let prefix left right = compare_bound_fields context bound_fields left right index in + let len = Array.length arr in + let rec lower lo hi = + if lo >= hi then lo + else + let mid = (lo + hi) / 2 in + if prefix arr.(mid) bound < 0 then lower (mid + 1) hi else lower lo mid + in + let start = lower 0 len in + let rec upper index = + if index >= len || prefix arr.(index) bound > 0 then index else upper (index + 1) + in + let stop = upper start in + let rec loop index () = + if index >= stop then Seq.Nil else Seq.Cons (arr.(index), loop (index + 1)) + in + loop start + +let array_range_bounds context index from_bound from_fields to_bound to_fields arr = + let below_from left right = compare_bound_fields context from_fields left right index in + let above_to left right = compare_bound_fields context to_fields left right index in + let len = Array.length arr in + let rec lower lo hi = + if lo >= hi then lo + else + let mid = (lo + hi) / 2 in + if below_from arr.(mid) from_bound < 0 then lower (mid + 1) hi else lower lo mid + in + let start = lower 0 len in + let rec upper index = + if index >= len || above_to arr.(index) to_bound > 0 then index else upper (index + 1) + in + (start, upper start) + +let array_range_fold f init context index from_bound from_fields to_bound to_fields arr = + let start, stop = array_range_bounds context index from_bound from_fields to_bound to_fields arr in + let rec loop index acc = + if index >= stop then acc else loop (index + 1) (f acc arr.(index)) + in + loop start init + +let array_range_seq context index from_bound from_fields to_bound to_fields arr = + let start, stop = array_range_bounds context index from_bound from_fields to_bound to_fields arr in + let rec loop index () = + if index >= stop then Seq.Nil else Seq.Cons (arr.(index), loop (index + 1)) + in + loop start + +let array_exact_prefix_slice 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 start = lower 0 len in + let rec upper index = + if index >= len || cmp arr.(index) bound <> 0 then index else upper (index + 1) + in + let stop = upper start in + if start >= stop then [] + else Array.sub arr start (stop - start) |> Array.to_list + +let find_entity_in_aevt_array arr entity_id = + let len = Array.length arr in + if len = 0 then None + else + let rec lower lo hi = + if lo >= hi then lo + else + let mid = (lo + hi) / 2 in + let mid_e = arr.(mid).e in + if mid_e < entity_id then lower (mid + 1) hi + else if mid_e > entity_id then lower lo mid + else mid + in + let index = lower 0 len in + if index >= len || arr.(index).e <> entity_id then None else Some arr.(index) + +let find_datom_in_sorted_array index arr datom = + let len = Array.length arr in + if len = 0 then None + else + let cmp = Util.compare_datom index in + let rec lower lo hi = + if lo >= hi then lo + else + let mid = (lo + hi) / 2 in + if cmp arr.(mid) datom < 0 then lower (mid + 1) hi else lower lo mid + in + let at = lower 0 len in + if at >= len || cmp arr.(at) datom <> 0 then None else Some arr.(at) + +let rehydrate_datom_value db index datom = + match index with + | Avet -> ( + match Hashtbl.find_opt db.avet_by_attr datom.a with + | None -> datom + | Some arr -> + (match find_datom_in_sorted_array Avet arr datom with + | None -> datom + | Some cached -> { datom with v = cached.v })) + | Aevt -> ( + match Hashtbl.find_opt db.aevt_by_attr datom.a with + | None -> datom + | Some arr -> + (match find_datom_in_sorted_array Aevt arr datom with + | None -> datom + | Some cached -> { datom with v = cached.v })) + | Eavt -> datom + +let rehydrate_datom_seq db index seq = Seq.map (rehydrate_datom_value db index) seq + +let find_primary_aevt_entity_attr db entity_id attr = + match Hashtbl.find_opt db.aevt_by_attr attr with + | None -> None + | Some arr -> find_entity_in_aevt_array arr entity_id + +let exact_sorted_slice cmp bound datoms = + array_exact_prefix_slice cmp bound (Array.of_list datoms) + let slice_cmp context index from_bound from_fields to_bound to_fields left right = if right == from_bound then compare_bound_fields context from_fields left right index @@ -625,41 +1026,132 @@ let exact_prefix_bound index e a v tx = Some (bound_datom ~e ~a ~v ~tx (), fields ~e:true ~a:true ~v:true ~tx:true ()) | _ -> None) +let avet_entity_ids_by_attr_value context db attr value = + if temporal_view db then + Some + (primary_attr_datoms db Avet attr + |> List.filter (fun datom -> datom.a = attr && context.compare_value datom.v value = 0) + |> List.map (fun datom -> datom.e) + |> Array.of_list) + else + match Hashtbl.find_opt db.avet_entities_by_attr_value (attr, value) with + | Some entity_ids -> Some entity_ids + | None -> ( + match Hashtbl.find_opt db.avet_by_attr attr with + | Some datoms -> + let bound = bound_datom ~a:attr ~v:value () in + let bound_fields = fields ~a:true ~v:true () in + Some + (array_attr_value_slice context Avet bound bound_fields datoms + |> List.map (fun datom -> datom.e) + |> Array.of_list) + | None -> None) + +let avet_datoms_by_value context db attr value = + let bound = bound_datom ~a:attr ~v:value () in + let bound_fields = fields ~a:true ~v:true () in + if temporal_view db then + primary_attr_datoms db Avet attr + |> List.filter (fun datom -> datom.a = attr && context.compare_value datom.v value = 0) + else + match Hashtbl.find_opt db.avet_entities_by_attr_value (attr, value) with + | Some entity_ids -> datoms_of_avet_entities attr value entity_ids + | None -> ( + match Hashtbl.find_opt db.avet_by_attr attr with + | Some datoms -> array_attr_value_slice context Avet bound bound_fields datoms + | None -> + 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 + let bound_fields = fields ~a:true ~v:true () in + if temporal_view db then + avet_datoms_by_value context db attr value |> List.to_seq + else + match Hashtbl.find_opt db.avet_by_attr attr with + | Some datoms -> array_attr_value_seq context Avet bound bound_fields datoms + | None -> + 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 with - | [] -> Some (PSet.slice_seq ~from_:bound ~to_:bound ~cmp (stored_index db index) |> PSet.to_seq) - | _ -> - let indexed = PSet.slice_seq ~from_:bound ~to_:bound ~cmp (stored_index db index) |> PSet.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))))) + (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, Aevt, _, Some attr, _, _ -> ( + match temporal_view db, Hashtbl.find_opt db.aevt_by_attr attr with + | false, Some arr -> + Some (List.to_seq (array_exact_prefix_slice cmp bound arr)) + | true, _ | _, None -> + Some (Index.slice_seq ~from_:bound ~to_:bound ~cmp (stored_index db Aevt) |> Index.to_seq)) + | false, _, _, _, _, _ -> + Some (Index.slice_seq ~from_:bound ~to_:bound ~cmp (stored_index db index) |> Index.to_seq) + | 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 | None -> None | Some (bound, bound_fields) -> let cmp = exact_prefix_slice_cmp context index bound bound_fields in - (match db.duplicate_datoms with - | [] -> + let exact_attr_prefix = + match index, e, a, v, tx with + | Aevt, None, Some _, None, None -> true + | _ -> false + in + (match merged_index db || pending_overlay db with + | false -> Some - (PSet.slice_seq ~from_:bound ~to_:bound ~cmp (stored_index db index) - |> PSet.seq_to_list) - | _ -> + (match index, a, v, exact_attr_prefix with + | Avet, Some attr, Some value, false -> avet_datoms_by_value context db attr value + | (Aevt | Avet), Some attr, None, true -> primary_attr_datoms db index attr + | Aevt, Some attr, _, false -> ( + match temporal_view db, Hashtbl.find_opt db.aevt_by_attr attr with + | false, Some arr -> array_exact_prefix_slice cmp bound arr + | true, _ | _, None -> + Index.slice_seq ~from_:bound ~to_:bound ~cmp (stored_index db Aevt) + |> Index.seq_to_list) + | _ -> + 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) @@ -670,15 +1162,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 - | _ -> PSet.slice_seq ~from_:bound ~cmp (stored_index db index) |> PSet.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))) @@ -689,16 +1189,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 - | _ -> PSet.rslice_seq ~from_:bound ~cmp (stored_index db index) |> PSet.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 @@ -706,7 +1215,9 @@ let reverse_upper_prefix_datoms context db index e a v tx = indexed (List.to_seq duplicates))) -let avet_range_datoms context db attr start stop = +let avet_range_bounds context db attr start stop = + let start = Option.map (context.resolve_value_for_attr db attr) start in + let stop = Option.map (context.resolve_value_for_attr db attr) stop in let from_bound = match start with | Some value -> bound_datom ~a:attr ~v:value () @@ -737,24 +1248,58 @@ let avet_range_datoms context db attr start stop = | None -> datom.a = attr | Some stop -> datom.a = attr && context.compare_value datom.v stop <= 0 in - let indexed = - match db.duplicate_datoms with - | [] -> - let cmp = slice_cmp context Avet from_bound from_fields to_bound to_fields in - PSet.slice_seq ~from_:from_bound ~to_:to_bound ~cmp db.avet_index |> PSet.to_seq - | _ -> - primary_attr_datoms db Avet attr - |> List.filter (fun datom -> lower_matches datom && upper_matches datom) - |> List.to_seq + (from_bound, from_fields, to_bound, to_fields, lower_matches, upper_matches) + +let avet_range_datoms context db attr start stop = + let from_bound, from_fields, to_bound, to_fields, lower_matches, upper_matches = + avet_range_bounds context db attr start stop in - match db.duplicate_datoms with - | [] -> indexed - | _ -> - let duplicates = - duplicate_attr_datoms db Avet attr - |> List.filter (fun datom -> lower_matches datom && upper_matches datom) + if temporal_view db then + let cmp = slice_cmp context Avet from_bound from_fields to_bound to_fields in + primary_attr_datoms db Avet attr + |> List.filter (fun datom -> + cmp datom from_bound >= 0 + && cmp datom to_bound <= 0 + && lower_matches datom + && upper_matches datom) + |> List.to_seq + else + let attr_cache = Hashtbl.find_opt db.avet_by_attr attr in + let indexed = + match attr_cache with + | Some arr -> + array_range_seq context Avet from_bound from_fields to_bound to_fields arr + | None -> + 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 in - merge_sorted_datom_seqs (Util.compare_datom Avet) indexed (List.to_seq duplicates) + if not (merged_index db) && not (pending_overlay db) then indexed + else if not (merged_index db) then + (match attr_cache with + | Some _ -> indexed + | None -> + 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 if not (pending_overlay db) then + let duplicates = + duplicate_attr_datoms db Avet attr + |> 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 pending = + pending_for_index db Avet + |> List.filter (fun datom -> lower_matches datom && upper_matches datom) + in + let duplicates = + duplicate_attr_datoms db Avet attr + |> List.filter (fun datom -> lower_matches datom && upper_matches datom) + in + merge_sorted_datom_seqs (Util.compare_datom Avet) indexed + (List.to_seq (merge_sorted_datoms Avet pending duplicates)) let indexed_attr_required_message attr = "Attribute :" ^ attr ^ " should be marked as :db/index true" @@ -786,6 +1331,7 @@ let datoms context db index ?e ?a ?v ?tx () = let exact_attr_prefix = match index, e, a, v, tx with | Aevt, None, Some _, None, None -> exact + | Avet, None, Some _, Some _, None -> exact | _ -> false in let datoms = @@ -795,10 +1341,13 @@ 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; + 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 @@ -826,10 +1375,9 @@ 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 seq = PSet.slice_seq ~from_:bound ~to_:bound ~cmp (stored_index db index) in let fold = match exact_attr_prefix || (e, a, v, tx) = (None, None, None, None), db.filter_pred with | true, None -> f @@ -837,12 +1385,17 @@ let fold_datoms f init context db index ?e ?a ?v ?tx () = | false, None -> fold_filter | false, Some _ -> fold_filter_and_pred in - PSet.fold_seq fold init seq - | [], None when (e, a, v, tx) = (None, None, None, None) -> + (match exact_attr_prefix, index, a with + | true, (Aevt | Avet), Some attr -> + List.fold_left fold init (primary_attr_datoms db index attr) + | _ -> + let seq = Index.slice_seq ~from_:bound ~to_:bound ~cmp (stored_index db index) in + Index.fold_seq fold init seq) + | false, None when (e, a, v, tx) = (None, None, None, None) -> (match db.filter_pred with - | None -> PSet.fold f init (stored_index db index) + | None -> Index.fold f init (stored_index db index) | Some pred -> - PSet.fold (fun acc datom -> if pred datom then f acc datom else acc) init (stored_index db index)) + Index.fold (fun acc datom -> if pred datom then f acc datom else acc) init (stored_index db index)) | _ -> datoms context db index ?e ?a ?v ?tx () |> Seq.fold_left f init @@ -876,14 +1429,17 @@ 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 datoms context db index ?e ?a ?v ?tx () let find_datom context db index ?e ?a ?v ?tx () = - datoms context db index ?e ?a ?v ?tx () |> Seq.uncons |> Option.map fst + match temporal_view db, db.filter_pred, index, e, a, v, tx with + | false, None, Aevt, Some entity_id, Some attr, None, None when not (merged_index db || pending_overlay db) -> + find_primary_aevt_entity_attr db entity_id attr + | _ -> datoms context db index ?e ?a ?v ?tx () |> Seq.uncons |> Option.map fst let find_datom_ref context db index ?e ?a ?v ?tx () = datoms_ref context db index ?e ?a ?v ?tx () |> Seq.uncons |> Option.map fst @@ -924,10 +1480,13 @@ let seek_datoms context db index ?e ?a ?v ?tx () = validate_index_access context db index a; let v = resolved_value_option_for_optional_attr context db a v in match lower_prefix_datoms context db index e a v tx with - | Some datoms -> apply_filter_pred db datoms + | Some datoms -> + apply_db_view_seq db (rehydrate_datom_seq db index datoms) |> apply_filter_pred db | None -> datoms context db index () |> Seq.filter (fun d -> compare_datom_to_bound context index d e a v tx >= 0) + |> rehydrate_datom_seq db index + |> apply_filter_pred db let seek_datoms_ref context db index ?e ?a ?v ?tx () = let e = resolved_entity_ref_option context db e in @@ -937,10 +1496,13 @@ let rseek_datoms context db index ?e ?a ?v ?tx () = validate_index_access context db index a; let v = resolved_value_option_for_optional_attr context db a v in match reverse_upper_prefix_datoms context db index e a v tx with - | Some datoms -> apply_filter_pred db datoms + | Some datoms -> + apply_db_view_reverse_seq db (rehydrate_datom_seq db index datoms) |> apply_filter_pred db | None -> reverse_index_datoms_seq db index + |> apply_db_view_reverse_seq db |> Seq.filter (fun d -> compare_datom_to_bound context index d e a v tx <= 0) + |> rehydrate_datom_seq db index |> apply_filter_pred db let rseek_datoms_ref context db index ?e ?a ?v ?tx () = @@ -950,11 +1512,66 @@ let rseek_datoms_ref context db index ?e ?a ?v ?tx () = let index_range context db attr ?start ?stop () = if not (context.is_avet_accessible db attr) then invalid_arg (indexed_attr_required_message attr); - let start = Option.map (context.resolve_value_for_attr db attr) start in - let stop = Option.map (context.resolve_value_for_attr db attr) stop in avet_range_datoms context db attr start stop |> apply_filter_pred db +let fold_index_range f init context db attr ?start ?stop () = + if not (context.is_avet_accessible db attr) then + invalid_arg (indexed_attr_required_message attr); + let from_bound, from_fields, to_bound, to_fields, lower_matches, upper_matches = + avet_range_bounds context db attr start stop + in + let fold_with_filter acc datom = + match db.filter_pred with + | None -> f acc datom + | Some pred -> if pred datom then f acc datom else acc + in + let attr_cache = + if temporal_view db then None else Hashtbl.find_opt db.avet_by_attr attr + in + if temporal_view db then + (* Rebuild through primary_attr so pending/history facts are visible. *) + let cmp = slice_cmp context Avet from_bound from_fields to_bound to_fields in + primary_attr_datoms db Avet attr + |> List.filter (fun datom -> + cmp datom from_bound >= 0 + && cmp datom to_bound <= 0 + && lower_matches datom + && upper_matches datom) + |> List.fold_left fold_with_filter init + else + let acc = + match attr_cache with + | Some arr -> + array_range_fold fold_with_filter init context Avet from_bound from_fields to_bound to_fields + arr + | None -> + let cmp = slice_cmp context Avet from_bound from_fields to_bound to_fields in + Index.fold_slice fold_with_filter init ~from_:from_bound ~to_:to_bound ~cmp db.avet_index + in + if not (merged_index db) && not (pending_overlay db) then acc + else if not (merged_index db) then + (match attr_cache with + | Some _ -> acc + | None -> + pending_for_index db Avet + |> List.filter (fun datom -> lower_matches datom && upper_matches datom) + |> List.fold_left fold_with_filter acc) + else if not (pending_overlay db) then + duplicate_attr_datoms db Avet attr + |> List.filter (fun datom -> lower_matches datom && upper_matches datom) + |> List.fold_left fold_with_filter acc + else + let pending = + pending_for_index db Avet + |> List.filter (fun datom -> lower_matches datom && upper_matches datom) + in + let duplicates = + duplicate_attr_datoms db Avet attr + |> List.filter (fun datom -> lower_matches datom && upper_matches datom) + in + merge_sorted_datoms Avet pending duplicates |> List.fold_left fold_with_filter acc + let diff left right = let left_datoms = visible_index_datoms left Eavt in let right_datoms = visible_index_datoms right Eavt in diff --git a/impl/db.mli b/impl/db.mli index fd8d812..9646c41 100644 --- a/impl/db.mli +++ b/impl/db.mli @@ -18,6 +18,22 @@ 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 as_of_instant : value -> db -> db +val since : tx -> db -> db +val history : db -> db +val is_history : db -> bool +val resolve_tx_at_instant : value -> db -> tx +val purge_history_before : tx -> db -> db * datom list val with_datoms : db -> datom list -> db val empty_db : core_context -> ?schema:schema -> ?storage:storage -> unit -> db val empty : core_context -> db -> db @@ -29,6 +45,10 @@ val filter : core_context -> db -> (db -> datom -> bool) -> db val value_equal : value -> value -> bool val same_fact : datom -> datom -> bool +val primary_attr_datoms : db -> index -> attr -> datom list +val aevt_attr_array : db -> attr -> datom array option +val find_primary_aevt_entity_attr : db -> entity_id -> attr -> datom option +val find_entity_in_aevt_array : datom array -> entity_id -> datom option type index_context = { is_avet_accessible : db -> attr -> bool @@ -55,6 +75,9 @@ val fold_datoms : unit -> 'acc val datoms_list : index_context -> db -> index -> ?e:entity_id -> ?a:attr -> ?v:value -> ?tx:tx -> unit -> datom list +val avet_entity_ids_by_attr_value : index_context -> db -> attr -> value -> entity_id array option +val avet_datoms_by_value : index_context -> db -> attr -> value -> datom list +val avet_datoms_by_value_seq : index_context -> db -> attr -> value -> datom Seq.t val datoms_ref : index_context -> db -> index -> ?e:entity_ref -> ?a:attr -> ?v:value -> ?tx:tx -> unit -> datom Seq.t val find_datom : index_context -> db -> index -> ?e:entity_id -> ?a:attr -> ?v:value -> ?tx:tx -> unit -> datom option val find_datom_ref : index_context -> db -> index -> ?e:entity_ref -> ?a:attr -> ?v:value -> ?tx:tx -> unit -> datom option @@ -63,6 +86,16 @@ val seek_datoms_ref : index_context -> db -> index -> ?e:entity_ref -> ?a:attr - val rseek_datoms : index_context -> db -> index -> ?e:entity_id -> ?a:attr -> ?v:value -> ?tx:tx -> unit -> datom Seq.t val rseek_datoms_ref : index_context -> db -> index -> ?e:entity_ref -> ?a:attr -> ?v:value -> ?tx:tx -> unit -> datom Seq.t val index_range : index_context -> db -> attr -> ?start:value -> ?stop:value -> unit -> datom Seq.t +val fold_index_range : + ('acc -> datom -> 'acc) -> + 'acc -> + index_context -> + db -> + attr -> + ?start:value -> + ?stop:value -> + unit -> + 'acc val hash : db -> int val hash_cache_size : unit -> int diff --git a/impl/db_access.ml b/impl/db_access.ml index c055800..e9989d5 100644 --- a/impl/db_access.ml +++ b/impl/db_access.ml @@ -104,6 +104,15 @@ end) = struct let datoms_list db index ?e ?a ?v ?tx () = Db.datoms_list db_index_context db index ?e ?a ?v ?tx () + + let avet_datoms_by_value db attr value = + Db.avet_datoms_by_value db_index_context db attr value + + let avet_datoms_by_value_seq db attr value = + Db.avet_datoms_by_value_seq db_index_context db attr value + + let avet_entity_ids_by_attr_value db attr value = + Db.avet_entity_ids_by_attr_value db_index_context db attr value let datoms_ref db index ?e ?a ?v ?tx () = Db.datoms_ref db_index_context db index ?e ?a ?v ?tx () @@ -128,5 +137,8 @@ end) = struct let index_range db attr ?start ?stop () = Db.index_range db_index_context db attr ?start ?stop () + + let fold_index_range f init db attr ?start ?stop () = + Db.fold_index_range f init db_index_context db attr ?start ?stop () end diff --git a/impl/dune b/impl/dune index e0bf38a..e1e6971 100644 --- a/impl/dune +++ b/impl/dune @@ -1,6 +1,7 @@ (library (name datascript) (public_name datascript_ocaml) - (virtual_modules platform) + (virtual_modules platform index storage) (modes native byte melange) - (libraries datascript_types persistent_sorted_set_ocaml)) + (modules (:standard \ storage_pss storage_lmdb_impl)) + (libraries datascript_types)) diff --git a/impl/index.mli b/impl/index.mli new file mode 100644 index 0000000..884cc90 --- /dev/null +++ b/impl/index.mli @@ -0,0 +1,46 @@ +open Datascript_types + +type t = index_set +type 'a seq +type index_db +type lmdb = index_db + +val same_storage_db : storage -> index_db -> bool +val create_index_db : storage option -> index_db * storage option +val create_lmdb : storage option -> index_db * storage option +val index_db_of : index_db -> index_db +val lmdb_of : index_db -> index_db +val db_of : t -> index_db +val index_db_for_storage : storage -> index_db +val lmdb_for_storage : storage -> index_db +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 -> index_db -> unit + +val empty : index -> index_db -> t +val of_sorted_list : index -> datom list -> index_db -> t +val of_sorted_lists : (index * datom list) list -> index_db -> unit +val of_eavt_datoms : avet:(string -> bool) -> datom list -> index_db -> unit +val of_bulk : index -> datom list -> index_db -> 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 +val to_list : t -> datom list +val fold : ('acc -> datom -> 'acc) -> 'acc -> t -> 'acc +val fold_slice : + ('acc -> datom -> 'acc) -> 'acc -> ?from_:datom -> ?to_:datom -> ?cmp:(datom -> datom -> int) -> t -> 'acc +val find_first_slice : + ?from_:datom -> ?to_:datom -> ?cmp:(datom -> datom -> int) -> t -> datom option +val fold_attr_prefix : ('acc -> datom -> 'acc) -> 'acc -> t -> string -> '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 +val flush : t -> t +val copy : t -> t diff --git a/impl/platform.mli b/impl/platform.mli index a639eeb..1d7071a 100644 --- a/impl/platform.mli +++ b/impl/platform.mli @@ -1,13 +1,8 @@ type regex -open Datascript_types - (** Return the current wall-clock time as seconds since the Unix epoch. *) val now_seconds : unit -> float -(** Create a file-backed storage instance rooted at the given path. *) -val file_storage : string -> storage - (** Compile a platform-specific regular expression from a pattern string. *) val compile_regex : string -> regex diff --git a/impl/platform/jsoo/dune b/impl/platform/jsoo/dune index 3909a7a..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 persistent_sorted_set_ocaml.native)) + (libraries js_of_ocaml lmdb_db_melange lmdb_index_melange storage_melange)) diff --git a/impl/platform/jsoo/index.ml b/impl/platform/jsoo/index.ml new file mode 100644 index 0000000..f5771dc --- /dev/null +++ b/impl/platform/jsoo/index.ml @@ -0,0 +1,78 @@ +open Datascript_types + +(* Platform indexes use identity coercions because [index_set] stays abstract in + [Datascript_types] while this module owns the concrete LMDB representation. *) +external inject : Datascript_lmdb_index.t -> index_set = "%identity" +external project : index_set -> Datascript_lmdb_index.t = "%identity" + +type t = index_set +type 'a seq = 'a Datascript_lmdb_index.seq +type index_db = Datascript_lmdb_db.t +type lmdb = index_db + +let same_storage_db storage index_db = + Datascript_storage_protocol.same_storage_db storage index_db + +let create_index_db storage = Datascript_storage_protocol.create_index_db storage +let create_lmdb = create_index_db + +let index_db_of index_db = index_db +let lmdb_of = index_db_of +let db_of t = Datascript_lmdb_index.db_of (project t) + +let index_db_for_storage storage = Datascript_storage_protocol.db_for_storage storage +let lmdb_for_storage = index_db_for_storage + +let sync_indexes_to_storage ~since_tx eavt aevt avet target_storage = + let target = Datascript_storage_protocol.db_for_storage 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 + +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 = + Datascript_storage_protocol.load_indexes_from_storage storage target + +let empty index index_db = Datascript_lmdb_index.empty index index_db |> inject +let of_sorted_list index datoms index_db = + Datascript_lmdb_index.of_sorted_list index datoms index_db |> inject +let of_sorted_lists index_datoms index_db = + Datascript_lmdb_index.of_sorted_lists index_datoms index_db +let of_eavt_datoms ~avet datoms index_db = + Datascript_lmdb_index.of_eavt_datoms ~avet datoms index_db +let of_bulk index datoms index_db = + Datascript_lmdb_index.of_bulk index datoms index_db |> 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 +let to_list t = Datascript_lmdb_index.to_list (project t) +let fold f init t = Datascript_lmdb_index.fold f init (project t) +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) +let slice_seq ?from_ ?to_ ?cmp t = Datascript_lmdb_index.slice_seq ?from_ ?to_ ?cmp (project t) +let rslice_seq ?from_ ?to_ ?cmp t = Datascript_lmdb_index.rslice_seq ?from_ ?to_ ?cmp (project t) +let seq t = Datascript_lmdb_index.seq (project t) +let seq_to_list = Datascript_lmdb_index.seq_to_list +let fold_seq = Datascript_lmdb_index.fold_seq +let to_seq = Datascript_lmdb_index.to_seq +let seek = Datascript_lmdb_index.seek +let flush t = Datascript_lmdb_index.flush (project t) |> inject +let copy t = Datascript_lmdb_index.copy (project t) |> inject diff --git a/impl/platform/jsoo/platform.ml b/impl/platform/jsoo/platform.ml index 0642250..d9843b5 100644 --- a/impl/platform/jsoo/platform.ml +++ b/impl/platform/jsoo/platform.ml @@ -6,9 +6,6 @@ let now_seconds () = let now_ms = Js.Unsafe.meth_call Js.date "now" [||] in Js.to_float now_ms /. 1000.0 -let file_storage _dir = - invalid_arg "file_storage is not supported on js_of_ocaml" - let compile_regex = Regexp.regexp let replace_regex ~first_only regex value replacement = diff --git a/impl/platform/jsoo/storage.ml b/impl/platform/jsoo/storage.ml new file mode 100644 index 0000000..2f20103 --- /dev/null +++ b/impl/platform/jsoo/storage.ml @@ -0,0 +1,106 @@ +open Datascript_types + +module Index = Index + +type restore_context = { next_db_uid : unit -> int } + +let memory_storage = Datascript_storage_protocol.memory_storage +let benchmark_memory_storage = Datascript_storage_protocol.benchmark_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 -> + 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_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_protocol.restore_meta storage in + let index_db, _ = Index.create_index_db (Some storage) in + Index.load_indexes_from_storage storage index_db; + Some + { serializable_schema = schema + ; serializable_datoms = Index.to_list (Index.empty Eavt index_db) @ duplicate_datoms + ; serializable_max_eid = max_eid + ; serializable_max_tx = max_tx + } + +let restore context storage = + let schema, max_eid, max_tx, duplicate_datoms = Datascript_storage_protocol.restore_meta storage in + let schema = Schema.validate_schema schema in + let index_db, _ = Index.create_index_db (Some storage) in + Index.load_indexes_from_storage storage index_db; + let duplicate_eavt_by_entity = + let table = Hashtbl.create 1024 in + List.iter + (fun datom -> + let existing = Option.value (Hashtbl.find_opt table datom.e) ~default:[] in + Hashtbl.replace table datom.e (datom :: existing)) + duplicate_datoms; + Hashtbl.iter (fun entity_id datoms -> Hashtbl.replace table entity_id (List.rev datoms)) table; + table + in + let duplicate_datoms_by_attr duplicate_datoms = + let table = Hashtbl.create 1024 in + List.iter + (fun datom -> + let existing = Option.value (Hashtbl.find_opt table datom.a) ~default:[] in + Hashtbl.replace table datom.a (datom :: existing)) + duplicate_datoms; + Hashtbl.iter (fun attr datoms -> Hashtbl.replace table attr (List.rev datoms)) table; + table + in + let duplicate_aevt_datoms = List.sort (Util.compare_datom Aevt) duplicate_datoms in + let duplicate_avet_datoms = + duplicate_datoms + |> List.filter (fun datom -> Schema.schema_attr_is_avet_accessible schema datom.a) + |> List.sort (Util.compare_datom Avet) + in + Some + { db_uid = context.next_db_uid () + ; schema + ; eavt_index = Index.empty Eavt index_db + ; aevt_index = Index.empty Aevt index_db + ; avet_index = Index.empty Avet index_db + ; aevt_by_attr = Hashtbl.create 0 + ; avet_by_attr = Hashtbl.create 0 + ; avet_entities_by_attr_value = Hashtbl.create 0 + ; duplicate_datoms + ; duplicate_aevt_datoms + ; duplicate_avet_datoms + ; duplicate_eavt_by_entity + ; duplicate_aevt_by_attr = duplicate_datoms_by_attr duplicate_aevt_datoms + ; duplicate_avet_by_attr = duplicate_datoms_by_attr duplicate_avet_datoms + ; 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 + ; pending_datoms = [] + ; storage_ref = Some storage + ; tx_fns = [] + } + +let storage (db : db) = db.storage_ref + +let settings (_db : db) = + [ "branching-factor", Int 32 + ; "ref-type", Keyword "weak" + ; "storage", Bool (Option.is_some _db.storage_ref) + ] + +let collect_garbage storage = + ensure_live storage; + match kind_of storage with + | k when k = storage_kind_lmdb || k = storage_kind_memory -> + (try Datascript_lmdb_db.sync (Datascript_storage_protocol.db_for_storage storage) with + | Invalid_argument _ -> ()) + | _ -> () diff --git a/impl/platform/melange/dune b/impl/platform/melange/dune index 9a91be2..83d8be6 100644 --- a/impl/platform/melange/dune +++ b/impl/platform/melange/dune @@ -3,6 +3,6 @@ (public_name datascript-ocaml-melange) (implements datascript) (modes melange) - (libraries melange.js persistent_sorted_set_ocaml.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 new file mode 100644 index 0000000..f5771dc --- /dev/null +++ b/impl/platform/melange/index.ml @@ -0,0 +1,78 @@ +open Datascript_types + +(* Platform indexes use identity coercions because [index_set] stays abstract in + [Datascript_types] while this module owns the concrete LMDB representation. *) +external inject : Datascript_lmdb_index.t -> index_set = "%identity" +external project : index_set -> Datascript_lmdb_index.t = "%identity" + +type t = index_set +type 'a seq = 'a Datascript_lmdb_index.seq +type index_db = Datascript_lmdb_db.t +type lmdb = index_db + +let same_storage_db storage index_db = + Datascript_storage_protocol.same_storage_db storage index_db + +let create_index_db storage = Datascript_storage_protocol.create_index_db storage +let create_lmdb = create_index_db + +let index_db_of index_db = index_db +let lmdb_of = index_db_of +let db_of t = Datascript_lmdb_index.db_of (project t) + +let index_db_for_storage storage = Datascript_storage_protocol.db_for_storage storage +let lmdb_for_storage = index_db_for_storage + +let sync_indexes_to_storage ~since_tx eavt aevt avet target_storage = + let target = Datascript_storage_protocol.db_for_storage 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 + +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 = + Datascript_storage_protocol.load_indexes_from_storage storage target + +let empty index index_db = Datascript_lmdb_index.empty index index_db |> inject +let of_sorted_list index datoms index_db = + Datascript_lmdb_index.of_sorted_list index datoms index_db |> inject +let of_sorted_lists index_datoms index_db = + Datascript_lmdb_index.of_sorted_lists index_datoms index_db +let of_eavt_datoms ~avet datoms index_db = + Datascript_lmdb_index.of_eavt_datoms ~avet datoms index_db +let of_bulk index datoms index_db = + Datascript_lmdb_index.of_bulk index datoms index_db |> 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 +let to_list t = Datascript_lmdb_index.to_list (project t) +let fold f init t = Datascript_lmdb_index.fold f init (project t) +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) +let slice_seq ?from_ ?to_ ?cmp t = Datascript_lmdb_index.slice_seq ?from_ ?to_ ?cmp (project t) +let rslice_seq ?from_ ?to_ ?cmp t = Datascript_lmdb_index.rslice_seq ?from_ ?to_ ?cmp (project t) +let seq t = Datascript_lmdb_index.seq (project t) +let seq_to_list = Datascript_lmdb_index.seq_to_list +let fold_seq = Datascript_lmdb_index.fold_seq +let to_seq = Datascript_lmdb_index.to_seq +let seek = Datascript_lmdb_index.seek +let flush t = Datascript_lmdb_index.flush (project t) |> inject +let copy t = Datascript_lmdb_index.copy (project t) |> inject diff --git a/impl/platform/melange/platform.ml b/impl/platform/melange/platform.ml index 5d9e848..78aee1c 100644 --- a/impl/platform/melange/platform.ml +++ b/impl/platform/melange/platform.ml @@ -6,9 +6,6 @@ external set_last_index : Js.Re.t -> int -> unit = "lastIndex" [@@mel.set] let now_seconds () = date_now () /. 1000.0 -let file_storage _dir = - invalid_arg "file_storage is not supported on Melange" - let compile_regex pattern = pattern let regexp ?(global = false) pattern = diff --git a/impl/platform/melange/storage.ml b/impl/platform/melange/storage.ml new file mode 100644 index 0000000..2f20103 --- /dev/null +++ b/impl/platform/melange/storage.ml @@ -0,0 +1,106 @@ +open Datascript_types + +module Index = Index + +type restore_context = { next_db_uid : unit -> int } + +let memory_storage = Datascript_storage_protocol.memory_storage +let benchmark_memory_storage = Datascript_storage_protocol.benchmark_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 -> + 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_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_protocol.restore_meta storage in + let index_db, _ = Index.create_index_db (Some storage) in + Index.load_indexes_from_storage storage index_db; + Some + { serializable_schema = schema + ; serializable_datoms = Index.to_list (Index.empty Eavt index_db) @ duplicate_datoms + ; serializable_max_eid = max_eid + ; serializable_max_tx = max_tx + } + +let restore context storage = + let schema, max_eid, max_tx, duplicate_datoms = Datascript_storage_protocol.restore_meta storage in + let schema = Schema.validate_schema schema in + let index_db, _ = Index.create_index_db (Some storage) in + Index.load_indexes_from_storage storage index_db; + let duplicate_eavt_by_entity = + let table = Hashtbl.create 1024 in + List.iter + (fun datom -> + let existing = Option.value (Hashtbl.find_opt table datom.e) ~default:[] in + Hashtbl.replace table datom.e (datom :: existing)) + duplicate_datoms; + Hashtbl.iter (fun entity_id datoms -> Hashtbl.replace table entity_id (List.rev datoms)) table; + table + in + let duplicate_datoms_by_attr duplicate_datoms = + let table = Hashtbl.create 1024 in + List.iter + (fun datom -> + let existing = Option.value (Hashtbl.find_opt table datom.a) ~default:[] in + Hashtbl.replace table datom.a (datom :: existing)) + duplicate_datoms; + Hashtbl.iter (fun attr datoms -> Hashtbl.replace table attr (List.rev datoms)) table; + table + in + let duplicate_aevt_datoms = List.sort (Util.compare_datom Aevt) duplicate_datoms in + let duplicate_avet_datoms = + duplicate_datoms + |> List.filter (fun datom -> Schema.schema_attr_is_avet_accessible schema datom.a) + |> List.sort (Util.compare_datom Avet) + in + Some + { db_uid = context.next_db_uid () + ; schema + ; eavt_index = Index.empty Eavt index_db + ; aevt_index = Index.empty Aevt index_db + ; avet_index = Index.empty Avet index_db + ; aevt_by_attr = Hashtbl.create 0 + ; avet_by_attr = Hashtbl.create 0 + ; avet_entities_by_attr_value = Hashtbl.create 0 + ; duplicate_datoms + ; duplicate_aevt_datoms + ; duplicate_avet_datoms + ; duplicate_eavt_by_entity + ; duplicate_aevt_by_attr = duplicate_datoms_by_attr duplicate_aevt_datoms + ; duplicate_avet_by_attr = duplicate_datoms_by_attr duplicate_avet_datoms + ; 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 + ; pending_datoms = [] + ; storage_ref = Some storage + ; tx_fns = [] + } + +let storage (db : db) = db.storage_ref + +let settings (_db : db) = + [ "branching-factor", Int 32 + ; "ref-type", Keyword "weak" + ; "storage", Bool (Option.is_some _db.storage_ref) + ] + +let collect_garbage storage = + ensure_live storage; + match kind_of storage with + | k when k = storage_kind_lmdb || k = storage_kind_memory -> + (try Datascript_lmdb_db.sync (Datascript_storage_protocol.db_for_storage storage) with + | Invalid_argument _ -> ()) + | _ -> () diff --git a/impl/platform/native/dune b/impl/platform/native/dune index e6f1550..0bb88d2 100644 --- a/impl/platform/native/dune +++ b/impl/platform/native/dune @@ -3,4 +3,11 @@ (public_name datascript-ocaml-native) (implements datascript) (modes native byte) - (libraries str unix persistent_sorted_set_ocaml.native)) + (libraries + str + unix + lmdb_db_native + lmdb_index_native + sqlite_db_native + sqlite_index_native + storage_native)) diff --git a/impl/platform/native/index.ml b/impl/platform/native/index.ml new file mode 100644 index 0000000..9bee8d6 --- /dev/null +++ b/impl/platform/native/index.ml @@ -0,0 +1,201 @@ +open Datascript_types + +(* Native indexes keep [index_set] abstract in [Datascript_types] while this module + owns the concrete LMDB | SQLite representation. [%identity] is the established + platform pattern for that boundary (see prior LMDB-only Index). *) +type concrete_index = + | Lmdb of Datascript_lmdb_index.t + | Sqlite of Datascript_sqlite_index.t + +external inject : concrete_index -> index_set = "%identity" +external project : index_set -> concrete_index = "%identity" + +(* LMDB and SQLite seq records share the same {cmp; datoms; offset} layout. *) +external seq_of_sqlite : 'a Datascript_sqlite_index.seq -> 'a Datascript_lmdb_index.seq = "%identity" + +type t = index_set +type 'a seq = 'a Datascript_lmdb_index.seq +type index_db = Datascript_storage_protocol.index_db +type lmdb = index_db + +let same_storage_db storage index_db = + Datascript_storage_protocol.same_storage_db storage index_db + +let create_index_db storage = Datascript_storage_protocol.create_index_db storage +let create_lmdb = create_index_db + +let index_db_of index_db = index_db +let lmdb_of = index_db_of + +let db_of t = + match project t with + | Lmdb i -> Datascript_storage_protocol.Lmdb (Datascript_lmdb_index.db_of i) + | Sqlite i -> Datascript_storage_protocol.Sqlite (Datascript_sqlite_index.db_of i) + +let index_db_for_storage storage = Datascript_storage_protocol.db_for_storage storage +let lmdb_for_storage = index_db_for_storage + +let sync_indexes_to_storage ~since_tx eavt aevt avet target_storage = + match project eavt, project aevt, project avet, Datascript_storage_protocol.db_for_storage target_storage with + | Lmdb e, Lmdb a, Lmdb v, Datascript_storage_protocol.Lmdb target -> + Datascript_lmdb_index.sync_append_since_tx ~since_tx e target; + Datascript_lmdb_index.sync_append_since_tx ~since_tx a target; + Datascript_lmdb_index.sync_append_since_tx ~since_tx v target + | Sqlite e, Sqlite a, Sqlite v, Datascript_storage_protocol.Sqlite target -> + Datascript_sqlite_index.sync_append_since_tx ~since_tx e target; + Datascript_sqlite_index.sync_append_since_tx ~since_tx a target; + Datascript_sqlite_index.sync_append_since_tx ~since_tx v target + | Lmdb e, Lmdb a, Lmdb v, Datascript_storage_protocol.Sqlite target -> + let put_since index_t which = + let dest = Datascript_sqlite_index.empty which target in + Datascript_lmdb_index.fold + (fun () datom -> + if datom.tx > since_tx then ignore (Datascript_sqlite_index.add datom dest)) + () index_t + in + put_since e Eavt; + put_since a Aevt; + put_since v Avet + | _ -> + invalid_arg "Index.sync_indexes_to_storage: unsupported index/storage backend combination" + +let sync_removals_to_storage removed_datoms eavt aevt avet target_storage = + ignore (eavt, aevt, avet); + match Datascript_storage_protocol.db_for_storage target_storage with + | Datascript_storage_protocol.Lmdb target -> + let remove which = + let t = Datascript_lmdb_index.empty which target in + ignore (Datascript_lmdb_index.remove_datoms removed_datoms t) + in + remove Eavt; + remove Aevt; + remove Avet + | Datascript_storage_protocol.Sqlite target -> + let remove which = + let t = Datascript_sqlite_index.empty which target in + ignore (Datascript_sqlite_index.remove_datoms removed_datoms t) + in + remove Eavt; + remove Aevt; + remove Avet + +let load_indexes_from_storage storage target = + Datascript_storage_protocol.load_indexes_from_storage storage target + +let empty index = function + | Datascript_storage_protocol.Lmdb db -> Datascript_lmdb_index.empty index db |> fun i -> inject (Lmdb i) + | Datascript_storage_protocol.Sqlite db -> Datascript_sqlite_index.empty index db |> fun i -> inject (Sqlite i) + +let of_sorted_list index datoms = function + | Datascript_storage_protocol.Lmdb db -> + Datascript_lmdb_index.of_sorted_list index datoms db |> fun i -> inject (Lmdb i) + | Datascript_storage_protocol.Sqlite db -> + Datascript_sqlite_index.of_sorted_list index datoms db |> fun i -> inject (Sqlite i) + +let of_sorted_lists index_datoms = function + | Datascript_storage_protocol.Lmdb db -> Datascript_lmdb_index.of_sorted_lists index_datoms db + | Datascript_storage_protocol.Sqlite db -> Datascript_sqlite_index.of_sorted_lists index_datoms db + +let of_eavt_datoms ~avet datoms = function + | Datascript_storage_protocol.Lmdb db -> Datascript_lmdb_index.of_eavt_datoms ~avet datoms db + | Datascript_storage_protocol.Sqlite db -> Datascript_sqlite_index.of_eavt_datoms ~avet datoms db + +let of_bulk index datoms = function + | Datascript_storage_protocol.Lmdb db -> + Datascript_lmdb_index.of_bulk index datoms db |> fun i -> inject (Lmdb i) + | Datascript_storage_protocol.Sqlite db -> + Datascript_sqlite_index.of_bulk index datoms db |> fun i -> inject (Sqlite i) + +let append_tx_data ~avet:is_avet datoms eavt_index aevt_index avet_index = + match project eavt_index, project aevt_index, project avet_index with + | Lmdb eavt, Lmdb aevt, Lmdb avet_index' -> + let eavt, aevt, avet_index' = + Datascript_lmdb_index.append_tx_data ~avet:is_avet datoms eavt aevt avet_index' + in + inject (Lmdb eavt), inject (Lmdb aevt), inject (Lmdb avet_index') + | Sqlite eavt, Sqlite aevt, Sqlite avet_index' -> + let eavt, aevt, avet_index' = + Datascript_sqlite_index.append_tx_data ~avet:is_avet datoms eavt aevt avet_index' + in + inject (Sqlite eavt), inject (Sqlite aevt), inject (Sqlite avet_index') + | _ -> invalid_arg "Index.append_tx_data: mixed LMDB/SQLite index backends" + +let append_datoms datoms t = + match project t with + | Lmdb i -> Datascript_lmdb_index.append_datoms datoms i |> fun i -> inject (Lmdb i) + | Sqlite i -> Datascript_sqlite_index.append_datoms datoms i |> fun i -> inject (Sqlite i) + +let add datom t = + match project t with + | Lmdb i -> Datascript_lmdb_index.add datom i |> fun i -> inject (Lmdb i) + | Sqlite i -> Datascript_sqlite_index.add datom i |> fun i -> inject (Sqlite i) + +let remove datom t = + match project t with + | Lmdb i -> Datascript_lmdb_index.remove datom i |> fun i -> inject (Lmdb i) + | Sqlite i -> Datascript_sqlite_index.remove datom i |> fun i -> inject (Sqlite i) + +let lookup t datom = + match project t with + | Lmdb i -> Datascript_lmdb_index.lookup i datom + | Sqlite i -> Datascript_sqlite_index.lookup i datom + +let to_list t = + match project t with + | Lmdb i -> Datascript_lmdb_index.to_list i + | Sqlite i -> Datascript_sqlite_index.to_list i + +let fold f init t = + match project t with + | Lmdb i -> Datascript_lmdb_index.fold f init i + | Sqlite i -> Datascript_sqlite_index.fold f init i + +let fold_slice f init ?from_ ?to_ ?cmp t = + match project t with + | Lmdb i -> Datascript_lmdb_index.fold_slice f init ?from_ ?to_ ?cmp i + | Sqlite i -> Datascript_sqlite_index.fold_slice f init ?from_ ?to_ ?cmp i + +let find_first_slice ?from_ ?to_ ?cmp t = + match project t with + | Lmdb i -> Datascript_lmdb_index.find_first_slice ?from_ ?to_ ?cmp i + | Sqlite i -> Datascript_sqlite_index.find_first_slice ?from_ ?to_ ?cmp i + +let fold_attr_prefix f init t attr = + match project t with + | Lmdb i -> Datascript_lmdb_index.fold_attr_prefix f init i attr + | Sqlite i -> Datascript_sqlite_index.fold_attr_prefix f init i attr + +let slice ?from_ ?to_ ?cmp t = + match project t with + | Lmdb i -> Datascript_lmdb_index.slice ?from_ ?to_ ?cmp i + | Sqlite i -> Datascript_sqlite_index.slice ?from_ ?to_ ?cmp i + +let slice_seq ?from_ ?to_ ?cmp t = + match project t with + | Lmdb i -> Datascript_lmdb_index.slice_seq ?from_ ?to_ ?cmp i + | Sqlite i -> seq_of_sqlite (Datascript_sqlite_index.slice_seq ?from_ ?to_ ?cmp i) + +let rslice_seq ?from_ ?to_ ?cmp t = + match project t with + | Lmdb i -> Datascript_lmdb_index.rslice_seq ?from_ ?to_ ?cmp i + | Sqlite i -> seq_of_sqlite (Datascript_sqlite_index.rslice_seq ?from_ ?to_ ?cmp i) + +let seq t = + match project t with + | Lmdb i -> Datascript_lmdb_index.seq i + | Sqlite i -> seq_of_sqlite (Datascript_sqlite_index.seq i) + +let seq_to_list = Datascript_lmdb_index.seq_to_list +let fold_seq = Datascript_lmdb_index.fold_seq +let to_seq = Datascript_lmdb_index.to_seq +let seek = Datascript_lmdb_index.seek + +let flush t = + match project t with + | Lmdb i -> Datascript_lmdb_index.flush i |> fun i -> inject (Lmdb i) + | Sqlite i -> Datascript_sqlite_index.flush i |> fun i -> inject (Sqlite i) + +let copy t = + match project t with + | Lmdb i -> Datascript_lmdb_index.copy i |> fun i -> inject (Lmdb i) + | Sqlite i -> Datascript_sqlite_index.copy i |> fun i -> inject (Sqlite i) diff --git a/impl/platform/native/platform.ml b/impl/platform/native/platform.ml index b620154..1e126c5 100644 --- a/impl/platform/native/platform.ml +++ b/impl/platform/native/platform.ml @@ -1,88 +1,7 @@ type regex = Str.regexp -open Datascript_types - let now_seconds = Unix.gettimeofday -let ensure_storage_dir dir = - if Sys.file_exists dir then begin - if not (Sys.is_directory dir) then - invalid_arg ("storage path is not a directory: " ^ dir) - end - else Sys.mkdir dir 0o755 - -let hex_digit value = - Char.chr (if value < 10 then Char.code '0' + value else Char.code 'a' + value - 10) - -let hex_value = function - | '0' .. '9' as ch -> Char.code ch - Char.code '0' - | 'a' .. 'f' as ch -> Char.code ch - Char.code 'a' + 10 - | 'A' .. 'F' as ch -> Char.code ch - Char.code 'A' + 10 - | ch -> invalid_arg ("invalid storage address hex digit: " ^ String.make 1 ch) - -let encode_storage_address address = - String.init - (String.length address * 2) - (fun index -> - let code = Char.code address.[index / 2] in - if index mod 2 = 0 then hex_digit (code lsr 4) else hex_digit (code land 0x0f)) - -let decode_storage_address encoded = - if String.length encoded mod 2 <> 0 then - invalid_arg ("invalid storage address filename: " ^ encoded); - String.init - (String.length encoded / 2) - (fun index -> - let high = hex_value encoded.[index * 2] in - let low = hex_value encoded.[index * 2 + 1] in - Char.chr ((high lsl 4) lor low)) - -let storage_payload_path dir address = - Filename.concat dir (encode_storage_address address ^ ".bin") - -let file_storage dir = - ensure_storage_dir dir; - let write_payload address payload = - let channel = open_out_bin (storage_payload_path dir address) in - Fun.protect - ~finally:(fun () -> close_out_noerr channel) - (fun () -> Marshal.to_channel channel payload []) - in - let read_payload address = - let path = storage_payload_path dir address in - if not (Sys.file_exists path) then None - else - let channel = open_in_bin path in - Fun.protect - ~finally:(fun () -> close_in_noerr channel) - (fun () -> Some (Marshal.from_channel channel : storage_payload)) - in - let list_addresses () = - Sys.readdir dir - |> Array.to_list - |> List.filter_map (fun filename -> - if Filename.extension filename = ".bin" then - let base = Filename.remove_extension filename in - Some (decode_storage_address base) - else - None) - |> List.sort_uniq compare - in - let delete addresses = - List.iter - (fun address -> - let path = storage_payload_path dir address in - if Sys.file_exists path then Sys.remove path) - addresses - in - { storage_store = - (fun entries -> - List.iter (fun (address, payload) -> write_payload address payload) entries) - ; storage_restore = read_payload - ; storage_list_addresses = list_addresses - ; storage_delete = delete - } - let str_pattern_of_pattern pattern = let buffer = Buffer.create (String.length pattern) in let add_escaped = function diff --git a/impl/platform/native/storage.ml b/impl/platform/native/storage.ml new file mode 100644 index 0000000..9e05907 --- /dev/null +++ b/impl/platform/native/storage.ml @@ -0,0 +1,115 @@ +open Datascript_types + +module Index = Index + +type restore_context = { next_db_uid : unit -> int } + +let memory_storage = Datascript_storage_protocol.memory_storage +let benchmark_memory_storage = Datascript_storage_protocol.benchmark_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 -> + 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_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_protocol.restore_meta storage in + let index_db, _ = Index.create_index_db (Some storage) in + Index.load_indexes_from_storage storage index_db; + Some + { serializable_schema = schema + ; serializable_datoms = Index.to_list (Index.empty Eavt index_db) @ duplicate_datoms + ; serializable_max_eid = max_eid + ; serializable_max_tx = max_tx + } + +let restore context storage = + let schema, max_eid, max_tx, duplicate_datoms = Datascript_storage_protocol.restore_meta storage in + let schema = Schema.validate_schema schema in + let index_db, _ = Index.create_index_db (Some storage) in + Index.load_indexes_from_storage storage index_db; + let duplicate_eavt_by_entity = + let table = Hashtbl.create 1024 in + List.iter + (fun datom -> + let existing = Option.value (Hashtbl.find_opt table datom.e) ~default:[] in + Hashtbl.replace table datom.e (datom :: existing)) + duplicate_datoms; + Hashtbl.iter (fun entity_id datoms -> Hashtbl.replace table entity_id (List.rev datoms)) table; + table + in + let duplicate_datoms_by_attr duplicate_datoms = + let table = Hashtbl.create 1024 in + List.iter + (fun datom -> + let existing = Option.value (Hashtbl.find_opt table datom.a) ~default:[] in + Hashtbl.replace table datom.a (datom :: existing)) + duplicate_datoms; + Hashtbl.iter (fun attr datoms -> Hashtbl.replace table attr (List.rev datoms)) table; + table + in + let duplicate_aevt_datoms = List.sort (Util.compare_datom Aevt) duplicate_datoms in + let duplicate_avet_datoms = + duplicate_datoms + |> List.filter (fun datom -> Schema.schema_attr_is_avet_accessible schema datom.a) + |> List.sort (Util.compare_datom Avet) + in + Some + { db_uid = context.next_db_uid () + ; schema + ; eavt_index = Index.empty Eavt index_db + ; aevt_index = Index.empty Aevt index_db + ; avet_index = Index.empty Avet index_db + ; aevt_by_attr = Hashtbl.create 0 + ; avet_by_attr = Hashtbl.create 0 + ; avet_entities_by_attr_value = Hashtbl.create 0 + ; duplicate_datoms + ; duplicate_aevt_datoms + ; duplicate_avet_datoms + ; duplicate_eavt_by_entity + ; duplicate_aevt_by_attr = duplicate_datoms_by_attr duplicate_aevt_datoms + ; duplicate_avet_by_attr = duplicate_datoms_by_attr duplicate_avet_datoms + ; 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 + ; pending_datoms = [] + ; storage_ref = Some storage + ; tx_fns = [] + } + +let storage (db : db) = db.storage_ref + +let settings (_db : db) = + [ "branching-factor", Int 32 + ; "ref-type", Keyword "weak" + ; "storage", Bool (Option.is_some _db.storage_ref) + ] + +let collect_garbage storage = + ensure_live storage; + match kind_of storage with + | k when k = storage_kind_lmdb || k = storage_kind_memory -> + (try + match Datascript_storage_protocol.db_for_storage storage with + | Datascript_storage_protocol.Lmdb lmdb -> Datascript_lmdb_db.sync lmdb + | Datascript_storage_protocol.Sqlite _ -> () + with Invalid_argument _ -> ()) + | k when k = storage_kind_sqlite -> + (try + match Datascript_storage_protocol.db_for_storage storage with + | Datascript_storage_protocol.Sqlite sqlite -> Datascript_sqlite_db.sync sqlite + | Datascript_storage_protocol.Lmdb _ -> () + with Invalid_argument _ -> ()) + | _ -> () diff --git a/impl/query.ml b/impl/query.ml index 8a8ce59..8fd6c9e 100644 --- a/impl/query.ml +++ b/impl/query.ml @@ -481,7 +481,7 @@ let query_results_equivalent context left right = let bind_var context name value bindings = match List.assoc_opt name bindings with - | Some bound when query_results_equivalent context bound value -> Some bindings + | Some bound when bound == value || query_results_equivalent context bound value -> Some bindings | Some _ -> None | None -> Some ((name, value) :: bindings) diff --git a/impl/query_api.ml b/impl/query_api.ml index 02ea95d..c21aa38 100644 --- a/impl/query_api.ml +++ b/impl/query_api.ml @@ -3,6 +3,22 @@ open Datascript_types type bindings = (string * query_result) list type rule_call_key = string * string * query_result option list +(** Which engine finished the last [q] relation path (for tests / diagnostics). *) +type query_exec_path = + | Fused_execute + | Relation_fallback + | Binding_interpreter + +let force_relation_fallback = ref false +let last_path = ref Relation_fallback + +let last_query_exec_path () = !last_path + +let with_force_relation_fallback f = + let previous = !force_relation_fallback in + force_relation_fallback := true; + Fun.protect ~finally:(fun () -> force_relation_fallback := previous) f + module Make (Context : sig val empty_db : unit -> db val validate_rule_arities : query_rule list -> query_rule list @@ -24,6 +40,13 @@ module Make (Context : sig bindings list -> query_clause list -> (string list * query_result list list * bool) option + val execute_plan : + db -> + (string * query_source) list -> + query_rule list -> + bindings list -> + Query_plan.physical_plan -> + (string list * query_result list list * bool) option val has_aggregates : find_spec list -> bool val aggregate_rows : ?callables:Query.query_callables -> db -> (string * query_source) list -> bindings list -> find_spec list -> query_result list list val aggregate_rows_with : ?callables:Query.query_callables -> db -> (string * query_source) list -> bindings list -> find_spec list -> string list -> query_result list list @@ -148,52 +171,139 @@ end) = struct |> Option.map (fun key -> key, binding)) |> List.sort_uniq (fun (left, _) (right, _) -> compare left right) |> List.map snd - + + (* Do not Hashtbl-key by query_clause list: clauses may embed function + values, and structural hashing/compare raises + Invalid_argument("compare: functional value"). Physical equality on + the reused where list (cached_query_string) is enough for the hot path. *) + let last_plan_where : query_clause list ref = ref [] + let last_plan_max_e = ref (-1) + let last_plan : Query_plan.physical_plan option ref = ref None + + let compile_plan max_datom_e where = + if !last_plan_max_e = max_datom_e && !last_plan_where == where then + !last_plan + else ( + let plan = Query_plan.compile ~max_datom_e where in + last_plan_where := where; + last_plan_max_e := max_datom_e; + last_plan := plan; + plan) + + (* cached_query_string reuses the same find list object across calls. *) + let last_find : find_spec list ref = ref [] + let last_find_vars : string list option ref = ref None + + let find_var_names_cached find = + if !last_find == find then + !last_find_vars + else ( + last_find := find; + let vars = find_var_names find in + last_find_vars := vars; + vars) + let q_sources_raw ?(inputs = []) db sources query = - let callables, input_bindings, input_rules = initial_query_context db query inputs in - let rules, where = - match query.rules, input_rules with - | [], [] -> [], query.where - | _ -> query_rules_and_where query input_rules + let finish_relation_rows rules input_bindings where find = + let try_planned_execute () = + (* Prefer Datahike execute for single fused entity-group / ground scan. + Multi-op Union and open scans still use relational fallback until + probe-join / union execute matches those paths. *) + if !force_relation_fallback || input_bindings <> [ [] ] then + None + else + let plan = + match rules with + | [] -> compile_plan db.max_datom_e where + | rules -> Query_plan.compile ~max_datom_e:db.max_datom_e ~rules where + in + match plan with + | Some plan when Query_plan.plan_is_fused_execute plan -> ( + match plan.ops with + | [ Query_plan.OpScan { clause; _ } ] -> ( + (* Only ground AVET-style scans are competitive on the execute path. *) + match Query_plan.pattern_scan clause with + | Some { entity = QVar _; attr = QAttr _; value = QValue _; tx = None; _ } -> + execute_plan db sources [] input_bindings plan + | _ -> None) + | _ -> execute_plan db sources [] input_bindings plan) + | _ -> None + in + let relation_result = + match try_planned_execute () with + | Some result -> + last_path := Fused_execute; + Some result + | None -> ( + match eval_relation_rows db sources rules input_bindings where with + | Some result -> + last_path := Relation_fallback; + Some result + | None -> + last_path := Binding_interpreter; + None) + in + match relation_result with + | Some (attrs, rows, unique_rows) -> ( + (* Hot path: find vars already match relation attrs (entity-group emit). *) + match find_var_names_cached find with + | Some find_vars when find_vars = attrs -> + if unique_rows then rows else sort_uniq_presorted compare rows + | _ -> + (match relation_rows_for_find db sources attrs rows unique_rows find with + | Some rows -> rows + | None -> + let bindings = eval_clauses db sources rules input_bindings where in + bindings + |> fun bindings -> dedupe_bindings_for_find bindings find + |> List.filter_map (fun binding -> collect_find_specs db sources binding find) + |> List.sort_uniq compare)) + | None -> + let bindings = eval_clauses db sources rules input_bindings where in + bindings + |> fun bindings -> dedupe_bindings_for_find bindings find + |> List.filter_map (fun binding -> collect_find_specs db sources binding find) + |> List.sort_uniq compare in - let has_aggregates = has_aggregates query.find in if - (not has_aggregates) + inputs = [] + && query.inputs = [] + && query.rules = [] && query.with_vars = [] - && query_callables_empty callables + && not (has_aggregates query.find) then - match eval_relation_rows db sources rules input_bindings where with - | Some (attrs, rows, unique_rows) -> - (match relation_rows_for_find db sources attrs rows unique_rows query.find with - | Some rows -> rows - | None -> - let bindings = eval_clauses ~callables db sources rules input_bindings where in - bindings - |> fun bindings -> dedupe_bindings_for_find bindings query.find - |> List.filter_map (fun binding -> collect_find_specs db sources binding query.find) - |> List.sort_uniq compare) - | None -> + finish_relation_rows [] [ [] ] query.where query.find + else + let callables, input_bindings, input_rules = initial_query_context db query inputs in + let rules, where = + match query.rules, input_rules with + | [], [] -> [], query.where + | _ -> query_rules_and_where query input_rules + in + if + (not (has_aggregates query.find)) + && query.with_vars = [] + && query_callables_empty callables + then + finish_relation_rows rules input_bindings where query.find + else ( + last_path := Binding_interpreter; let bindings = eval_clauses ~callables db sources rules input_bindings where in - bindings - |> fun bindings -> dedupe_bindings_for_find bindings query.find - |> List.filter_map (fun binding -> collect_find_specs db sources binding query.find) - |> List.sort_uniq compare - else ( - let bindings = eval_clauses ~callables db sources rules input_bindings where in - if has_aggregates then - if query.with_vars = [] then - aggregate_rows ~callables db sources bindings query.find - else - aggregate_rows_with ~callables db sources bindings query.find query.with_vars - else if query.with_vars <> [] then - non_aggregate_rows_with db sources bindings query.find query.with_vars - else - bindings - |> fun bindings -> dedupe_bindings_for_find bindings query.find - |> List.filter_map (fun binding -> collect_find_specs db sources binding query.find) - |> List.sort_uniq compare) + if has_aggregates query.find then + if query.with_vars = [] then + aggregate_rows ~callables db sources bindings query.find + else + aggregate_rows_with ~callables db sources bindings query.find query.with_vars + else if query.with_vars <> [] then + non_aggregate_rows_with db sources bindings query.find query.with_vars + else + bindings + |> fun bindings -> dedupe_bindings_for_find bindings query.find + |> List.filter_map (fun binding -> collect_find_specs db sources binding query.find) + |> List.sort_uniq compare) let q_with_raw ?(inputs = []) db with_vars query = + last_path := Binding_interpreter; let callables, input_bindings, input_rules = initial_query_context db query inputs in let rules, where = query_rules_and_where query input_rules in let bindings = eval_clauses ~callables db [] rules input_bindings where in diff --git a/impl/query_exec.ml b/impl/query_exec.ml new file mode 100644 index 0000000..1e66529 --- /dev/null +++ b/impl/query_exec.ml @@ -0,0 +1,1040 @@ +(** Datahike-aligned query execute layer: run compiled physical ops. + + Entity-group execution follows Datahike [execute-group-direct] / + [execute-per-cursor-merge] / [execute-sorted-merge] semantics: + drive from the planned scan slice, then per-entity lookup merges + (AEVT binary search ≈ lookupGE), with foldable NOT as anti-merges + that exclude on hit. Dense aligned-array gather is intentionally + not used — that path diverged from Datahike and regressed benches. *) + +open Datascript_types + +[@@@ocaml.warning "-67"] + +type bindings = (string * query_result) list + +type relation = + { attrs : string list + ; rows : query_result list list + ; unique_rows : bool + } + +module Make (Context : sig + val query_evaluator_context : Query_eval.evaluator_context + val query_source_context : db -> Query.source_context + val cardinality_one : db -> attr -> bool + val datoms_by_attr_value : db -> attr -> value -> datom list + val entity_ids_by_attr_value : db -> attr -> value -> entity_id list option + val entity_ids_array_by_attr_value : db -> attr -> value -> entity_id array option + val query_attr_uses_avet : db -> attr -> bool + val query_value_uses_avet : value -> bool + val aevt_attr_array : db -> attr -> datom array option + val aevt_duplicate_datoms : db -> attr -> datom list + val find_entity_in_aevt_array : datom array -> entity_id -> datom option +end) = struct + open Context + + let ( let* ) = Option.bind + + let unique_vars terms = + terms + |> List.filter_map (function QVar name -> Some name | _ -> None) + |> List.fold_left (fun vars var -> if List.mem var vars then vars else var :: vars) [] + |> List.rev + + let row_value row index = + let rec loop current = function + | [] -> invalid_arg "relation row is missing a value" + | value :: _ when current = index -> value + | _ :: rest -> loop (current + 1) rest + in + loop 0 row + + let relation_attr_index attrs attr = + match List.find_index (( = ) attr) attrs with + | Some index -> index + | None -> invalid_arg "relation attribute is missing from row" + + let hash_join left right = + let common = List.filter (fun attr -> List.mem attr right.attrs) left.attrs in + let right_only = List.filter (fun attr -> not (List.mem attr left.attrs)) right.attrs in + let attrs = left.attrs @ right_only in + if left.attrs = [] && left.rows = [ [] ] then + { right with attrs } + else if right.attrs = [] && right.rows = [ [] ] then + { left with attrs } + else if common = [] then + { attrs + ; rows = + List.concat_map + (fun left_row -> List.map (fun right_row -> left_row @ right_row) right.rows) + left.rows + ; unique_rows = false + } + else + let right_common_indexes = List.map (fun attr -> attr, relation_attr_index right.attrs attr) common in + let right_by_key = + right.rows + |> List.fold_left + (fun table row -> + let key = + right_common_indexes + |> List.map (fun (attr, index) -> attr, row_value row index) + in + Hashtbl.replace table key row; + table) + (Hashtbl.create (List.length right.rows)) + in + let left_common_indexes = List.map (fun attr -> attr, relation_attr_index left.attrs attr) common in + let right_only_indexes = List.map (relation_attr_index right.attrs) right_only in + let rows = + left.rows + |> List.concat_map (fun left_row -> + let key = + left_common_indexes |> List.map (fun (attr, index) -> attr, row_value left_row index) + in + match Hashtbl.find_opt right_by_key key with + | None -> [] + | Some right_row -> + let extra = List.map (fun index -> row_value right_row index) right_only_indexes in + [ left_row @ extra ]) + in + { attrs; rows; unique_rows = left.unique_rows && right.unique_rows && rows <> [] } + + let anti_join left right = + let join_attrs = List.filter (fun attr -> List.mem attr right.attrs) left.attrs in + if join_attrs = [] then + Some left + else + let indexes = List.map (fun attr -> attr, relation_attr_index left.attrs attr) join_attrs in + let excluded = + right.rows + |> List.fold_left + (fun table row -> + let key = indexes |> List.map (fun (attr, index) -> attr, row_value row index) in + Hashtbl.replace table key (); + table) + (Hashtbl.create (List.length right.rows)) + in + let rows = + left.rows + |> List.filter (fun row -> + let key = indexes |> List.map (fun (attr, index) -> attr, row_value row index) in + not (Hashtbl.mem excluded key)) + in + Some { left with rows; unique_rows = left.unique_rows && rows <> [] } + + let eval_comparison_predicate_clause = Query_eval.eval_comparison_predicate_clause query_evaluator_context + + let filter_comparison db relation predicate left_term right_term = + let rows = + relation.rows + |> List.filter (fun row -> + let binding = List.combine relation.attrs row in + eval_comparison_predicate_clause db binding predicate left_term right_term <> []) + in + { relation with rows; unique_rows = false } + + let empty_relation = { attrs = []; rows = [ [] ]; unique_rows = true } + + let direct_attr attr = not (query_evaluator_context.is_reverse_ref attr) + + let unique_rows_flag source_db attrs e_var = + (not source_db.history) + && source_db.duplicate_datoms = [] + && List.mem e_var attrs + + let avet_ids_array source_db attr value = + if query_value_uses_avet value && query_attr_uses_avet source_db attr then + entity_ids_array_by_attr_value source_db attr value + else + None + + (* Reuse last AVET id array when the same ground (attr,value) is requested (bench hot path). *) + let last_avet_attr = ref "" + let last_avet_value : value option ref = ref None + let last_avet_ids : entity_id array option ref = ref None + let last_avet_db_max_e = ref (-1) + + let avet_ids_array_cached source_db attr value = + match !last_avet_value with + | Some prev + when !last_avet_attr = attr + && !last_avet_db_max_e = source_db.max_datom_e + && query_evaluator_context.compare_value prev value = 0 -> + !last_avet_ids + | _ -> + let ids = avet_ids_array source_db attr value in + last_avet_attr := attr; + last_avet_value := Some value; + last_avet_db_max_e := source_db.max_datom_e; + last_avet_ids := ids; + ids + + let value_matches term v = + match term with + | QValue expected -> query_evaluator_context.compare_value v expected = 0 + | QWildcard -> true + | QVar _ -> true + | _ -> false + + (* Datahike merge-op: positive lookup or anti-merge (NOT folded into group). *) + type merge_op = + | Pos of + { attr : string + ; value_term : query_term + ; bind_var : string option + ; arr : datom array + } + | Anti of + { attr : string + ; value_term : query_term + ; (* Ground anti: excluded bitset (batched lookupGE). Non-ground: AEVT arr. *) + excluded : bytes option + ; arr : datom array option + } + + let preload_aevt source_db attr = + if not (direct_attr attr && cardinality_one source_db attr) then + None + else + aevt_attr_array source_db attr + + let attrs_of_positive e_var (scan : Query_plan.l_scan) merges = + (scan :: merges) + |> List.concat_map (fun (s : Query_plan.l_scan) -> [ QVar e_var; s.attr; s.value ]) + |> unique_vars + + let parse_pos_merge source_db (scan : Query_plan.l_scan) = + match scan.attr, scan.value with + | QAttr attr, (QVar v as value_term) -> + let* arr = preload_aevt source_db attr in + Some (Pos { attr; value_term; bind_var = Some v; arr }) + | QAttr attr, ((QValue _ | QWildcard) as value_term) -> + let* arr = preload_aevt source_db attr in + Some (Pos { attr; value_term; bind_var = None; arr }) + | _ -> None + + let anti_excluded_bitset source_db attr value = + let max_entity = source_db.max_datom_e + 1 in + let excluded = Bytes.make max_entity '\000' in + let mark e = + if e >= 0 && e < max_entity then Bytes.unsafe_set excluded e '\001' + in + (match avet_ids_array source_db attr value with + | Some ids -> + for i = 0 to Array.length ids - 1 do + mark ids.(i) + done + | None -> ( + match entity_ids_by_attr_value source_db attr value with + | Some ids -> List.iter mark ids + | None -> datoms_by_attr_value source_db attr value |> List.iter (fun d -> mark d.e))); + excluded + + let parse_anti_merge source_db (scan : Query_plan.l_scan) = + match scan.attr, scan.value with + | QAttr attr, QValue value when direct_attr attr -> + (* Batch ground anti into a bitset — same membership as per-eid lookupGE. *) + Some (Anti { attr; value_term = QValue value; excluded = Some (anti_excluded_bitset source_db attr value); arr = None }) + | QAttr attr, value_term when direct_attr attr -> + let* arr = aevt_attr_array source_db attr in + Some (Anti { attr; value_term; excluded = None; arr = Some arr }) + | _ -> None + + (* Driving scan slice → eid + optional scan-bound value. + Mirrors Datahike index slice iteration over the planned :scan-op. *) + type drive_cell = + { eid : entity_id + ; scan_var : string option + ; scan_value : query_result + } + + let dummy_drive = { eid = 0; scan_var = None; scan_value = Result_entity 0 } + + let driving_cells source_db e_var (scan : Query_plan.l_scan) = + match scan.entity, scan.attr, scan.value, scan.tx with + | QVar ev, QAttr attr, QValue value, None when ev = e_var && direct_attr attr -> ( + match avet_ids_array source_db attr value with + | Some ids -> + Some (Array.init (Array.length ids) (fun i -> { eid = ids.(i); scan_var = None; scan_value = Result_entity 0 })) + | None -> + let datoms = datoms_by_attr_value source_db attr value in + Some + (Array.of_list + (List.map (fun d -> { eid = d.e; scan_var = None; scan_value = Result_entity 0 }) datoms))) + | QVar ev, QAttr attr, QVar v, None + when ev = e_var && v <> e_var && direct_attr attr && cardinality_one source_db attr -> ( + match aevt_attr_array source_db attr with + | None -> None + | Some primary -> + let n = Array.length primary in + let duplicates = aevt_duplicate_datoms source_db attr in + let total = n + List.length duplicates in + let cells = Array.make total dummy_drive in + for i = 0 to n - 1 do + let d = primary.(i) in + cells.(i) <- + { eid = d.e + ; scan_var = Some v + ; scan_value = Query.result_of_ref (Query.result_of_datom_v d) + } + done; + List.iteri + (fun j d -> + cells.(n + j) <- + { eid = d.e + ; scan_var = Some v + ; scan_value = Query.result_of_ref (Query.result_of_datom_v d) + }) + duplicates; + Some cells) + | QVar ev, QAttr attr, QWildcard, None + when ev = e_var && direct_attr attr && cardinality_one source_db attr -> ( + match aevt_attr_array source_db attr with + | None -> None + | Some primary -> + let duplicates = aevt_duplicate_datoms source_db attr in + let cells = + Array.append + (Array.map (fun d -> { eid = d.e; scan_var = None; scan_value = Result_entity 0 }) primary) + (Array.of_list + (List.map (fun d -> { eid = d.e; scan_var = None; scan_value = Result_entity 0 }) duplicates)) + in + Some cells) + | _ -> None + + (* Advance AEVT pointer to eid (Datahike ForwardCursor seekGE / next). *) + let seek_aevt arr ptr eid = + let len = Array.length arr in + let i = !ptr in + if i < len && arr.(i).e = eid then ( + incr ptr; + Some arr.(i)) + else + let rec skip j = + if j >= len then ( + ptr := len; + None) + else + let e = arr.(j).e in + if e < eid then skip (j + 1) + else if e = eid then ( + ptr := j + 1; + Some arr.(j)) + else ( + ptr := j; + None) + in + skip i + + let dense_base arr = + let len = Array.length arr in + if len = 0 then None + else + let base = arr.(0).e in + if arr.(len - 1).e = base + len - 1 then Some (base, len) else None + + let lookup_dense arr base len eid = + let index = eid - base in + if index >= 0 && index < len && arr.(index).e = eid then Some arr.(index) else None + + let rows_of_array_rev rows count = + let rec loop i acc = + if i < 0 then acc else loop (i - 1) (rows.(i) :: acc) + in + loop (count - 1) [] + + (* Resolved Datahike-style pipelines, keyed by entity-group physical identity + (plan cache reuses the same group object across calls). *) + type resolved_kernel = + | Kernel_q2 of + { ids : entity_id array + ; arr : datom array + ; base : int + ; len : int + ; attrs : string list + ; unique_rows : bool + } + | Kernel_q5 of + { ids : entity_id array + ; arr0 : datom array + ; arr1 : datom array + ; arr2 : datom array + ; arr3 : datom array + ; base : int + ; len : int + ; attrs : string list + ; unique_rows : bool + } + + let last_kernel_group : Query_plan.entity_group option ref = ref None + let last_kernel_max_e = ref (-1) + let last_kernel : resolved_kernel option ref = ref None + + let emit_q2_rows ids arr base len = + let rows = ref [] in + for i = Array.length ids - 1 downto 0 do + let e = ids.(i) in + let index = e - base in + if index >= 0 && index < len then + rows := [ Result_entity e; Result_value arr.(index).v ] :: !rows + done; + !rows + + let emit_q5_rows ids arr0 arr1 arr2 arr3 base len = + let rows = ref [] in + for i = Array.length ids - 1 downto 0 do + let e = ids.(i) in + let index = e - base in + if index >= 0 && index < len then + rows := + [ Result_entity e + ; Result_value arr0.(index).v + ; Result_value arr1.(index).v + ; Result_value arr2.(index).v + ; Result_value arr3.(index).v + ] + :: !rows + done; + !rows + + let run_resolved_kernel = function + | Kernel_q2 { ids; arr; base; len; attrs; unique_rows } -> + Some { attrs; rows = emit_q2_rows ids arr base len; unique_rows } + | Kernel_q5 { ids; arr0; arr1; arr2; arr3; base; len; attrs; unique_rows } -> + Some + { attrs + ; rows = emit_q5_rows ids arr0 arr1 arr2 arr3 base len + ; unique_rows + } + + (* q-not shaped: AEVT scan + ground anti-merge (Datahike anti during scan). *) + let execute_scan_anti_ground source_db e_var attrs (scan : Query_plan.l_scan) anti_attr anti_value = + match scan.entity, scan.attr, scan.value with + | QVar ev, QAttr seed_attr, QVar v + when ev = e_var && v <> e_var && direct_attr seed_attr && cardinality_one source_db seed_attr -> + let* seed_arr = aevt_attr_array source_db seed_attr in + let max_entity = source_db.max_datom_e + 1 in + let excluded = Bytes.make max_entity '\000' in + let mark_excluded entity_id = + if entity_id >= 0 && entity_id < max_entity then Bytes.unsafe_set excluded entity_id '\001' + in + (match entity_ids_by_attr_value source_db anti_attr anti_value with + | Some entity_ids -> List.iter mark_excluded entity_ids + | None -> + datoms_by_attr_value source_db anti_attr anti_value |> List.iter (fun datom -> mark_excluded datom.e)); + let rows = ref [] in + (match attrs with + | [ entity_attr; value_attr ] when entity_attr = e_var && value_attr = v -> + for i = Array.length seed_arr - 1 downto 0 do + let datom = seed_arr.(i) in + if datom.e >= 0 && datom.e < max_entity && Bytes.unsafe_get excluded datom.e = '\000' then + rows := [ Result_entity datom.e; Query.result_of_datom_v datom ] :: !rows + done; + List.iter + (fun datom -> + if datom.e >= 0 && datom.e < max_entity && Bytes.unsafe_get excluded datom.e = '\000' then + rows := [ Result_entity datom.e; Query.result_of_datom_v datom ] :: !rows) + (aevt_duplicate_datoms source_db seed_attr) + | [ value_attr; entity_attr ] when entity_attr = e_var && value_attr = v -> + for i = Array.length seed_arr - 1 downto 0 do + let datom = seed_arr.(i) in + if datom.e >= 0 && datom.e < max_entity && Bytes.unsafe_get excluded datom.e = '\000' then + rows := [ Query.result_of_datom_v datom; Result_entity datom.e ] :: !rows + done; + List.iter + (fun datom -> + if datom.e >= 0 && datom.e < max_entity && Bytes.unsafe_get excluded datom.e = '\000' then + rows := [ Query.result_of_datom_v datom; Result_entity datom.e ] :: !rows) + (aevt_duplicate_datoms source_db seed_attr) + | _ -> ()); + Some !rows + | _ -> None + + (* q2 / q-5-merge: const AVET drive + dense/cursor merges (Datahike sorted-merge). *) + let execute_const_drive_merges source_db e_var attrs (scan : Query_plan.l_scan) merges = + match scan.entity, scan.attr, scan.value with + | QVar ev, QAttr drive_attr, QValue drive_value when ev = e_var && direct_attr drive_attr -> + let* ids = + match avet_ids_array_cached source_db drive_attr drive_value with + | Some ids -> Some ids + | None -> + Some + (datoms_by_attr_value source_db drive_attr drive_value + |> List.map (fun d -> d.e) + |> Array.of_list) + in + let* pos_ops = + let rec collect acc = function + | [] -> Some (List.rev acc) + | m :: rest -> + (match parse_pos_merge source_db m with + | None -> None + | Some op -> collect (op :: acc) rest) + in + collect [] merges + in + let drive_len = Array.length ids in + (match pos_ops, attrs with + (* q2: one value merge — unrolled dense emit (Datahike sorted-merge card-one). *) + | [ Pos { bind_var = Some v; arr; _ } ], [ a; b ] + when (a = e_var && b = v) || (a = v && b = e_var) -> + let rows = ref [] in + (match dense_base arr with + | Some (base, len) -> + if a = e_var then + for i = Array.length ids - 1 downto 0 do + let e = ids.(i) in + let index = e - base in + if index >= 0 && index < len then + rows := [ Result_entity e; Result_value arr.(index).v ] :: !rows + done + else + for i = Array.length ids - 1 downto 0 do + let e = ids.(i) in + let index = e - base in + if index >= 0 && index < len then + rows := [ Result_value arr.(index).v; Result_entity e ] :: !rows + done + | None -> + let ptr = ref 0 in + if a = e_var then + for i = 0 to Array.length ids - 1 do + match seek_aevt arr ptr ids.(i) with + | None -> () + | Some d -> rows := [ Result_entity d.e; Result_value d.v ] :: !rows + done + else + for i = 0 to Array.length ids - 1 do + match seek_aevt arr ptr ids.(i) with + | None -> () + | Some d -> rows := [ Result_value d.v; Result_entity d.e ] :: !rows + done; + rows := List.rev !rows); + Some !rows + (* Multi merges (value binds + optional ground verifies) — q3/q4/q-5-merge *) + | pos_ops, _ -> + let bind_vars = + pos_ops + |> List.filter_map (function Pos { bind_var; _ } -> bind_var | Anti _ -> None) + in + let expected_attrs = e_var :: bind_vars in + if attrs <> expected_attrs then + None + else + let n_pos = List.length pos_ops in + let arrs = + Array.of_list (List.map (function Pos { arr; _ } -> arr | Anti _ -> [||]) pos_ops) + in + let terms = + Array.of_list + (List.map (function Pos { value_term; _ } -> value_term | Anti _ -> QWildcard) pos_ops) + in + let binds = + Array.of_list + (List.map (function Pos { bind_var; _ } -> bind_var | Anti _ -> None) pos_ops) + in + let dense = Array.map dense_base arrs in + if not (Array.for_all Option.is_some dense) then + (* Cursor fallback for non-dense *) + let pointers = Array.init n_pos (fun _ -> ref 0) in + let rows = Array.make drive_len [] in + let count = ref 0 in + for i = 0 to drive_len - 1 do + let eid = ids.(i) in + let ok = ref true in + let bound = ref [] in + let mi = ref 0 in + while !ok && !mi < n_pos do + match seek_aevt arrs.(!mi) pointers.(!mi) eid with + | None -> ok := false + | Some d when value_matches terms.(!mi) d.v -> + (match binds.(!mi) with + | Some v -> + bound := (v, Query.result_of_ref (Query.result_of_datom_v d)) :: !bound + | None -> ()); + incr mi + | Some _ -> ok := false + done; + if !ok then ( + let table = Hashtbl.create (List.length attrs) in + Hashtbl.add table e_var (Result_entity eid); + List.iter (fun (v, r) -> Hashtbl.add table v r) !bound; + rows.(!count) <- List.map (Hashtbl.find table) attrs; + incr count) + done; + Some (rows_of_array_rev rows !count) + else + let dense = Array.map Option.get dense in + let n_bind = List.length bind_vars in + let base0, len0 = dense.(0) in + let aligned = Array.for_all (fun (b, l) -> b = base0 && l = len0) dense in + let all_free_binds = + Array.for_all + (function + | QVar _ -> true + | _ -> false) + terms + && Array.for_all Option.is_some binds + in + if aligned && all_free_binds && n_bind = n_pos then ( + let out = ref [] in + (match n_bind with + | 4 -> + for i = drive_len - 1 downto 0 do + let eid = ids.(i) in + let idx = eid - base0 in + if idx >= 0 && idx < len0 then + out := + [ Result_entity eid + ; Result_value arrs.(0).(idx).v + ; Result_value arrs.(1).(idx).v + ; Result_value arrs.(2).(idx).v + ; Result_value arrs.(3).(idx).v + ] + :: !out + done + | 2 -> + for i = drive_len - 1 downto 0 do + let eid = ids.(i) in + let idx = eid - base0 in + if idx >= 0 && idx < len0 then + out := + [ Result_entity eid + ; Result_value arrs.(0).(idx).v + ; Result_value arrs.(1).(idx).v + ] + :: !out + done + | 1 -> + for i = drive_len - 1 downto 0 do + let eid = ids.(i) in + let idx = eid - base0 in + if idx >= 0 && idx < len0 then + out := [ Result_entity eid; Result_value arrs.(0).(idx).v ] :: !out + done + | _ -> + for i = drive_len - 1 downto 0 do + let eid = ids.(i) in + let idx = eid - base0 in + if idx >= 0 && idx < len0 then + let row = Array.make (n_bind + 1) (Result_entity eid) in + row.(0) <- Result_entity eid; + for j = 0 to n_bind - 1 do + row.(j + 1) <- Result_value arrs.(j).(idx).v + done; + out := Array.to_list row :: !out + done); + Some !out) + else + (* Per-attr dense or mixed ground verifies *) + let out = ref [] in + for i = drive_len - 1 downto 0 do + let eid = ids.(i) in + let ok = ref true in + let vals = Array.make n_bind (Result_value (Int 0)) in + let vi = ref 0 in + let mi = ref 0 in + while !ok && !mi < n_pos do + let base, len = dense.(!mi) in + let idx = eid - base in + if idx < 0 || idx >= len || arrs.(!mi).(idx).e <> eid then ok := false + else + let d = arrs.(!mi).(idx) in + if not (value_matches terms.(!mi) d.v) then ok := false + else ( + (match binds.(!mi) with + | Some _ -> + vals.(!vi) <- Result_value d.v; + incr vi + | None -> ()); + incr mi) + done; + if !ok then ( + let row = Array.make (n_bind + 1) (Result_entity eid) in + row.(0) <- Result_entity eid; + for j = 0 to n_bind - 1 do + row.(j + 1) <- vals.(j) + done; + out := Array.to_list row :: !out) + done; + Some !out) + | _ -> None + + (* Datahike execute-sorted-merge / per-cursor-merge for card-one attrs. *) + let execute_lookup_merge source_db e_var attrs (scan : Query_plan.l_scan) merges anti_scans = + match merges, anti_scans with + | [], [ { Query_plan.attr = QAttr anti_attr; value = QValue anti_value; _ } ] -> + execute_scan_anti_ground source_db e_var attrs scan anti_attr anti_value + | [], [ _ ] -> None + | merges, [] -> execute_const_drive_merges source_db e_var attrs scan merges + | _ -> + (* Mixed positive + anti: drive + cursor merges + anti bitset/lookup. *) + let* drive = driving_cells source_db e_var scan in + let* pos_ops = + let rec collect acc = function + | [] -> Some (List.rev acc) + | m :: rest -> + (match parse_pos_merge source_db m with + | None -> None + | Some op -> collect (op :: acc) rest) + in + collect [] merges + in + let* anti_ops = + let rec collect acc = function + | [] -> Some (List.rev acc) + | m :: rest -> + (match parse_anti_merge source_db m with + | None -> None + | Some op -> collect (op :: acc) rest) + in + collect [] anti_scans + in + let pos_arr = Array.of_list pos_ops in + let n_pos = Array.length pos_arr in + let pointers = Array.init n_pos (fun _ -> ref 0) in + let dense = + Array.map + (function + | Pos { arr; _ } -> dense_base arr + | Anti _ -> None) + pos_arr + in + let anti_arr = Array.of_list anti_ops in + let n_anti = Array.length anti_arr in + let drive_len = Array.length drive in + let rows = Array.make drive_len [] in + let count = ref 0 in + let bind_buf = Array.make (List.length attrs) (Result_entity 0) in + let attr_index = + let tbl = Hashtbl.create (List.length attrs) in + List.iteri (fun i name -> Hashtbl.add tbl name i) attrs; + tbl + in + let set_bind var value = + match Hashtbl.find_opt attr_index var with + | Some i -> bind_buf.(i) <- value + | None -> () + in + for i = 0 to drive_len - 1 do + let cell = drive.(i) in + let eid = cell.eid in + set_bind e_var (Result_entity eid); + (match cell.scan_var with + | Some v -> set_bind v cell.scan_value + | None -> ()); + let ok = ref true in + let mi = ref 0 in + while !ok && !mi < n_pos do + match pos_arr.(!mi) with + | Pos { bind_var; value_term; arr; _ } -> ( + let found = + match dense.(!mi) with + | Some (base, len) -> lookup_dense arr base len eid + | None -> seek_aevt arr pointers.(!mi) eid + in + match found with + | None -> ok := false + | Some d when value_matches value_term d.v -> + (match bind_var with + | Some v -> set_bind v (Query.result_of_ref (Query.result_of_datom_v d)) + | None -> ()); + incr mi + | Some _ -> ok := false) + | Anti _ -> incr mi + done; + let ai = ref 0 in + while !ok && !ai < n_anti do + (match anti_arr.(!ai) with + | Anti { excluded = Some excluded; _ } -> + let max_entity = Bytes.length excluded in + if eid >= 0 && eid < max_entity && Bytes.unsafe_get excluded eid = '\001' then + ok := false + | Anti { excluded = None; arr = Some arr; value_term; _ } -> ( + match find_entity_in_aevt_array arr eid with + | Some d when value_matches value_term d.v -> ok := false + | _ -> ()) + | Anti _ | Pos _ -> ()); + incr ai + done; + if !ok then ( + rows.(!count) <- Array.to_list bind_buf; + incr count) + done; + Some (rows_of_array_rev rows !count) + + let apply_group_filters source_db relation filters = + let rec loop relation = function + | [] -> Some relation + | ComparisonPredicate (predicate, left_term, right_term) :: rest -> + loop (filter_comparison source_db relation predicate left_term right_term) rest + | _ :: _ -> None + in + loop relation filters + + let execute_entity_group _db source (group : Query_plan.entity_group) = + match source with + | Db_source source_db -> ( + let finish relation = + match group.filters with + | [] -> Some relation + | filters -> apply_group_filters source_db relation filters + in + (match !last_kernel_group with + | Some g when g == group && !last_kernel_max_e = source_db.max_datom_e && group.filters = [] -> ( + match !last_kernel with + | Some kernel -> run_resolved_kernel kernel + | None -> None) + | _ -> None) + |> function + | Some relation -> finish relation + | None -> + let e_var = group.entity_var in + let (scan : Query_plan.l_scan) = group.scan in + (* Specialized q2: [?e :attr const] [?e :attr2 ?v] — Datahike sorted-merge N=1. *) + (match scan.entity, scan.attr, scan.value, group.merges, group.anti_scans with + | QVar ev, QAttr drive_attr, QValue drive_value, [ merge ], [] + when ev = e_var && direct_attr drive_attr -> ( + match merge.Query_plan.entity, merge.attr, merge.value with + | QVar ev2, QAttr merge_attr, QVar v + when ev2 = e_var && v <> e_var && direct_attr merge_attr + && cardinality_one source_db merge_attr -> ( + match avet_ids_array_cached source_db drive_attr drive_value, aevt_attr_array source_db merge_attr with + | Some ids, Some arr -> ( + match dense_base arr with + | Some (base, len) -> + let attrs = [ e_var; v ] in + let unique_rows = unique_rows_flag source_db attrs e_var in + let kernel = + Kernel_q2 { ids; arr; base; len; attrs; unique_rows } + in + if group.filters = [] then ( + last_kernel_group := Some group; + last_kernel_max_e := source_db.max_datom_e; + last_kernel := Some kernel); + run_resolved_kernel kernel + | None -> None) + | _ -> None) + | _ -> None) + (* Specialized q-5-merge: const drive + 4 card-one value merges, dense AEVT. *) + | QVar ev, QAttr drive_attr, QValue drive_value, [ m0; m1; m2; m3 ], [] + when ev = e_var && direct_attr drive_attr -> ( + let value_merge (m : Query_plan.l_scan) = + match m.entity, m.attr, m.value with + | QVar ev2, QAttr attr, QVar v + when ev2 = e_var && v <> e_var && direct_attr attr && cardinality_one source_db attr -> + Some (v, attr) + | _ -> None + in + match value_merge m0, value_merge m1, value_merge m2, value_merge m3 with + | Some (v0, a0), Some (v1, a1), Some (v2, a2), Some (v3, a3) -> ( + match + ( avet_ids_array_cached source_db drive_attr drive_value + , aevt_attr_array source_db a0 + , aevt_attr_array source_db a1 + , aevt_attr_array source_db a2 + , aevt_attr_array source_db a3 ) + with + | Some ids, Some arr0, Some arr1, Some arr2, Some arr3 -> ( + match dense_base arr0, dense_base arr1, dense_base arr2, dense_base arr3 with + | Some (base, len), Some (b1, l1), Some (b2, l2), Some (b3, l3) + when base = b1 && base = b2 && base = b3 && len = l1 && len = l2 && len = l3 -> + let attrs = [ e_var; v0; v1; v2; v3 ] in + let unique_rows = unique_rows_flag source_db attrs e_var in + let kernel = + Kernel_q5 + { ids; arr0; arr1; arr2; arr3; base; len; attrs; unique_rows } + in + if group.filters = [] then ( + last_kernel_group := Some group; + last_kernel_max_e := source_db.max_datom_e; + last_kernel := Some kernel); + run_resolved_kernel kernel + | _ -> None) + | _ -> None) + | _ -> None) + | _ -> None) + |> function + | Some relation -> finish relation + | None -> ( + match scan.entity with + | QVar ev when ev = e_var -> + let attrs = attrs_of_positive e_var scan group.merges in + (match execute_lookup_merge source_db e_var attrs scan group.merges group.anti_scans with + | None -> None + | Some rows -> + finish { attrs; rows; unique_rows = unique_rows_flag source_db attrs e_var }) + | _ -> None)) + | _ -> None + + let execute_scan db source (scan : Query_plan.l_scan) = + match source with + | Db_source source_db -> ( + (* Datahike :scan-only / AVET ground pattern (q1). *) + match scan.entity, scan.attr, scan.value, scan.tx with + | QVar e_var, QAttr attr, QValue value, None when direct_attr attr -> ( + match avet_ids_array_cached source_db attr value with + | Some ids -> + let rows = ref [] in + for i = Array.length ids - 1 downto 0 do + rows := [ Result_entity ids.(i) ] :: !rows + done; + Some + { attrs = [ e_var ] + ; rows = !rows + ; unique_rows = unique_rows_flag source_db [ e_var ] e_var + } + | None -> ( + match entity_ids_by_attr_value source_db attr value with + | Some entity_ids -> + Some + { attrs = [ e_var ] + ; rows = List.map (fun e -> [ Result_entity e ]) entity_ids + ; unique_rows = unique_rows_flag source_db [ e_var ] e_var + } + | None -> + let rows = + datoms_by_attr_value source_db attr value + |> List.map (fun datom -> [ Result_entity datom.e ]) + in + Some { attrs = [ e_var ]; rows; unique_rows = false })) + | _ -> + let terms = + match scan.tx with + | None -> [ scan.entity; scan.attr; scan.value ] + | Some tx -> [ scan.entity; scan.attr; scan.value; tx ] + in + let attrs = unique_vars terms in + let source_context = query_source_context db in + let datoms = + match terms with + | [ e_term; a_term; v_term ] -> source_context.pattern_datoms source_db e_term a_term v_term None + | [ e_term; a_term; v_term; tx_term ] -> + source_context.pattern_datoms source_db e_term a_term v_term (Some tx_term) + | _ -> invalid_arg "scan expects 3 or 4 pattern terms" + in + let slots = + attrs + |> List.map (fun attr -> + let rec find index = function + | [] -> invalid_arg "scan variable missing from pattern" + | QVar var :: _ when var = attr -> index + | _ :: rest -> find (index + 1) rest + in + find 0 terms) + in + let build_row datom = + slots + |> List.map (fun index -> + match index with + | 0 -> Query.result_of_datom_e datom + | 1 -> Query.result_of_datom_a datom + | 2 -> Query.result_of_ref (Query.result_of_datom_v datom) + | 3 -> Query.result_of_datom_tx datom + | _ -> invalid_arg "invalid scan slot") + in + let rows = + datoms + |> Seq.fold_left (fun acc datom -> build_row datom :: acc) [] + |> List.rev + in + Some { attrs; rows; unique_rows = false }) + | _ -> None + + let rec execute_plan db sources default_source bindings (plan : Query_plan.physical_plan) = + (* Datahike execute-group-direct / scan-only: single fused op emits directly. *) + match plan.ops with + | [ Query_plan.OpEntityGroup group ] -> execute_entity_group db default_source group + | [ Query_plan.OpScan { clause; source = op_source; _ } ] -> ( + let source = + match op_source with + | Some name -> Query.source db sources name + | None -> default_source + in + match Query_plan.pattern_scan clause with + | None -> None + | Some scan -> execute_scan db source scan) + | ops -> + let rec apply relation = function + | [] -> Some relation + | Query_plan.OpEntityGroup group :: rest -> ( + match execute_entity_group db default_source group with + | None -> None + | Some next -> apply (hash_join relation next) rest) + | Query_plan.OpScan { clause; source = op_source; _ } :: rest -> ( + let source = + match op_source with + | Some name -> Query.source db sources name + | None -> default_source + in + match Query_plan.pattern_scan clause with + | None -> None + | Some scan -> ( + match execute_scan db source scan with + | None -> None + | Some next -> apply (hash_join relation next) rest)) + | Query_plan.OpFilter clause :: rest -> ( + match clause with + | ComparisonPredicate (predicate, left_term, right_term) -> + apply (filter_comparison db relation predicate left_term right_term) rest + | _ -> None) + | Query_plan.OpUnion { join_vars; branches } :: rest -> ( + let branch_relations = + branches + |> List.filter_map (fun branch -> execute_plan db sources default_source bindings branch) + in + if List.length branch_relations <> List.length branches then + None + else + let* merged = + match branch_relations with + | [] -> Some empty_relation + | first :: others -> + Some + (List.fold_left + (fun acc branch -> + match join_vars with + | None -> union_relations acc branch + | Some vars -> union_relations (project_relation vars acc) (project_relation vars branch)) + first + others) + in + apply (hash_join relation merged) rest) + | Query_plan.OpAntiJoin { join_vars; excluded } :: rest -> ( + let* excluded_relation = execute_plan db sources default_source bindings excluded in + let filtered = + match join_vars with + | None -> relation + | Some vars -> project_relation vars relation + in + let* joined = anti_join filtered excluded_relation in + apply joined rest) + | Query_plan.OpPassthrough _ :: _ -> None + in + apply empty_relation ops + + and union_relations left right = + let attrs = left.attrs @ List.filter (fun attr -> not (List.mem attr left.attrs)) right.attrs in + let rows = left.rows @ right.rows |> List.sort_uniq compare in + { attrs; rows; unique_rows = false } + + and project_relation vars relation = + let indexes = vars |> List.map (relation_attr_index relation.attrs) in + let attrs = vars in + let rows = + relation.rows + |> List.filter_map (fun row -> + try Some (indexes |> List.map (fun index -> row_value row index)) with _ -> None) + |> List.sort_uniq compare + in + { attrs; rows; unique_rows = false } + + let run db sources rules bindings plan = + if rules <> [] || bindings <> [ [] ] then + None + else + let default_source = Query.source db sources "$" in + execute_plan db sources default_source bindings plan +end diff --git a/impl/query_exec.mli b/impl/query_exec.mli new file mode 100644 index 0000000..43a938e --- /dev/null +++ b/impl/query_exec.mli @@ -0,0 +1,38 @@ +(** Datahike-aligned query execute layer: run compiled physical ops. + + Returns [None] when a shape is not executable here; callers use the + relational interpreter in [Query_where] as permanent fallback. *) + +open Datascript_types + +[@@@ocaml.warning "-67"] + +type bindings = (string * query_result) list + +type relation = + { attrs : string list + ; rows : query_result list list + ; unique_rows : bool + } + +module Make (Context : sig + val query_evaluator_context : Query_eval.evaluator_context + val query_source_context : db -> Query.source_context + val cardinality_one : db -> attr -> bool + val datoms_by_attr_value : db -> attr -> value -> datom list + val entity_ids_by_attr_value : db -> attr -> value -> entity_id list option + val entity_ids_array_by_attr_value : db -> attr -> value -> entity_id array option + val query_attr_uses_avet : db -> attr -> bool + val query_value_uses_avet : value -> bool + val aevt_attr_array : db -> attr -> datom array option + val aevt_duplicate_datoms : db -> attr -> datom list + val find_entity_in_aevt_array : datom array -> entity_id -> datom option +end) : sig + val run : + db -> + (string * query_source) list -> + query_rule list -> + bindings list -> + Query_plan.physical_plan -> + relation option +end diff --git a/impl/query_plan.ml b/impl/query_plan.ml new file mode 100644 index 0000000..6da2c2c --- /dev/null +++ b/impl/query_plan.ml @@ -0,0 +1,660 @@ +(** Datahike-aligned query planner: classify → logical IR → lower → physical ops. + + Unsupported / ineligible shapes return [None]; callers fall back to the + relational interpreter (permanent fallback, matching Datahike). *) + +open Datascript_types + +type index_choice = + | Prefer_eavt + | Prefer_aevt + | Prefer_avet + +type l_scan = + { entity : query_term + ; attr : query_term + ; value : query_term + ; tx : query_term option + ; source : string option + ; clause : query_clause + ; vars : string list + } + +type logical_node = + | LScan of l_scan + | LEntityJoin of + { entity_var : string + ; scans : l_scan list + ; anti_scans : l_scan list + ; filters : query_clause list + ; source : string option + } + | LFilter of query_clause + | LUnion of + { join_vars : string list option + ; branches : logical_plan list + ; clause : query_clause + } + | LAntiJoin of + { join_vars : string list option + ; sub : logical_plan + ; clause : query_clause + } + | LRuleExpand of + { name : string + ; terms : query_term list + ; body : logical_plan + } + | LPassthrough of query_clause + +and logical_plan = + { nodes : logical_node list + ; bound_vars : string list + } + +type entity_group = + { entity_var : string + ; scan : l_scan + ; merges : l_scan list + ; anti_scans : l_scan list + ; filters : query_clause list + ; clauses : query_clause list + ; estimated_rows : int + ; source : string option + } + +type physical_op = + | OpEntityGroup of entity_group + | OpScan of + { clause : query_clause + ; index : index_choice + ; estimated_rows : int + ; source : string option + } + | OpFilter of query_clause + | OpUnion of + { join_vars : string list option + ; branches : physical_plan list + } + | OpAntiJoin of + { join_vars : string list option + ; excluded : physical_plan + } + | OpPassthrough of query_clause + +and physical_plan = + { ops : physical_op list + } + +let term_is_ground = function + | QEntity _ | QIdent _ | QLookupRef _ | QAttr _ | QValue _ -> true + | QVar _ | QSource _ | QWildcard -> false + +let term_vars = function + | QVar name -> [ name ] + | QEntity _ | QIdent _ | QLookupRef _ | QAttr _ | QValue _ | QSource _ | QWildcard -> [] + +let terms_vars terms = + terms |> List.concat_map term_vars |> List.sort_uniq compare + +let choose_index e_term a_term v_term = + match term_is_ground e_term, term_is_ground a_term, term_is_ground v_term with + | true, _, _ -> Prefer_eavt + | false, true, true -> Prefer_avet + | false, true, false -> Prefer_aevt + | _ -> Prefer_eavt + +let estimate_pattern_cost ?(max_datom_e = 1_000_000) e_term a_term v_term = + let max_e = max 1 max_datom_e in + match term_is_ground e_term, term_is_ground a_term, term_is_ground v_term with + | true, _, _ -> 1 + | false, true, true -> 4 + | false, true, false -> max_e / 8 + | false, false, true -> max_e / 16 + | false, false, false -> max_e + +let make_scan ~source clause e a v tx = + { entity = e + ; attr = a + ; value = v + ; tx + ; source + ; clause + ; vars = terms_vars (match tx with None -> [ e; a; v ] | Some tx -> [ e; a; v; tx ]) + } + +let pattern_scan = function + | Pattern (e, a, v) as clause -> Some (make_scan ~source:None clause e a v None) + | PatternTx (e, a, v, tx) as clause -> Some (make_scan ~source:None clause e a v (Some tx)) + | SourcePattern (src, e, a, v) as clause -> Some (make_scan ~source:(Some src) clause e a v None) + | SourcePatternTx (src, e, a, v, tx) as clause -> + Some (make_scan ~source:(Some src) clause e a v (Some tx)) + | _ -> None + +let filter_clause = function + | ComparisonPredicate _ | EqualityPredicate _ | ComparisonPredicateN _ as clause -> Some clause + | _ -> None + +let entity_var_of_scan scan = + match scan.entity with + | QVar v -> Some v + | _ -> None + +(** Foldable NOT / NOT-JOIN: single pattern, same source, non-entity vars local to the negation. *) +let foldable_not_scan ~bound_vars ~var_owners clause_idx clause = + let foldable_pattern = function + | (Pattern (QVar e_var, QAttr _, value_term) as pattern) -> + let local_vars = + match value_term with + | QVar v when v <> e_var -> [ v ] + | _ -> [] + in + let locals_ok = + List.for_all + (fun v -> + (not (List.mem v bound_vars)) + && + match List.assoc_opt v var_owners with + | None -> true + | Some idxs -> List.for_all (( = ) clause_idx) idxs) + local_vars + in + if locals_ok then pattern_scan pattern else None + | _ -> None + in + match clause with + | Not [ pattern ] -> foldable_pattern pattern + | NotJoin ([ join_e ], [ pattern ]) -> ( + match foldable_pattern pattern with + | Some anti_scan -> + (match entity_var_of_scan anti_scan with + | Some e_var when join_e = e_var -> Some anti_scan + | _ -> None) + | None -> None) + | _ -> None + +let var_owners_of_clauses clauses = + let add owners idx var = + match List.assoc_opt var owners with + | Some idxs -> (var, idx :: idxs) :: List.remove_assoc var owners + | None -> (var, [ idx ]) :: owners + in + clauses + |> List.mapi (fun idx clause -> idx, clause) + |> List.fold_left + (fun owners (idx, clause) -> + match pattern_scan clause with + | Some scan -> List.fold_left (fun o v -> add o idx v) owners scan.vars + | None -> + (match filter_clause clause with + | Some f -> + (match f with + | ComparisonPredicate (_, l, r) -> + List.fold_left (fun o v -> add o idx v) owners (terms_vars [ l; r ]) + | EqualityPredicate (_, terms) | ComparisonPredicateN (_, terms) -> + List.fold_left (fun o v -> add o idx v) owners (terms_vars terms) + | _ -> owners) + | None -> owners)) + [] + +let free_rule_body rules name arity = + let matches = + List.filter (fun rule -> rule.rule_name = name && List.length rule.rule_params = arity) rules + in + match matches with + | [ rule ] -> + (* Non-recursive: body must not call the same rule name. *) + let rec body_calls_self = function + | [] -> false + | Rule (n, _) :: _ when n = name -> true + | SourceRule (_, n, _) :: _ when n = name -> true + | Not sub :: rest -> body_calls_self sub || body_calls_self rest + | Or branches :: rest | OrJoin (_, branches) :: rest -> + List.exists body_calls_self branches || body_calls_self rest + | _ :: rest -> body_calls_self rest + in + if body_calls_self rule.rule_body then None else Some rule.rule_body + | _ -> None + +let rec build_logical_plan ?(max_datom_e = 1_000_000) ?(bound_vars = []) ?(rules = []) clauses = + let _ = max_datom_e in + let var_owners = var_owners_of_clauses clauses in + let scans_and_rest = + clauses + |> List.mapi (fun idx clause -> idx, clause) + |> List.fold_left + (fun (scan_entries, other) (idx, clause) -> + match pattern_scan clause with + | Some scan -> ((idx, scan) :: scan_entries, other) + | None -> (scan_entries, (idx, clause) :: other)) + ([], []) + in + let scan_entries, other_entries = scans_and_rest in + let scan_entries = List.rev scan_entries in + let other_entries = List.rev other_entries in + (* Group scans by (entity_var, source). Ground-entity scans stay as LScan. *) + let groups : ((string * string option) * l_scan list) list ref = ref [] in + let ungrouped = ref [] in + List.iter + (fun (_idx, scan) -> + match entity_var_of_scan scan with + | None -> ungrouped := LScan scan :: !ungrouped + | Some e_var -> + let key = e_var, scan.source in + (match List.assoc_opt key !groups with + | Some existing -> groups := (key, scan :: existing) :: List.remove_assoc key !groups + | None -> groups := (key, [ scan ]) :: !groups)) + scan_entries; + let group_map = + !groups + |> List.map (fun ((e_var, source), scans) -> (e_var, source), List.rev scans) + in + (* Fold foldable NOTs into anti_scans only when a positive scan on the same + entity already appears earlier in source order (DataScript outer-binding + rules). Otherwise keep as LAntiJoin / passthrough so the interpreter can + raise the same unbound-var errors. *) + let remaining_other = ref [] in + let anti_by_key : ((string * string option) * l_scan list) list ref = ref [] in + let positive_entity_sources = + scan_entries + |> List.filter_map (fun (idx, scan) -> + match entity_var_of_scan scan with + | Some e_var -> Some (idx, (e_var, scan.source)) + | None -> None) + in + List.iter + (fun (idx, clause) -> + match foldable_not_scan ~bound_vars ~var_owners idx clause with + | Some anti_scan -> + (match entity_var_of_scan anti_scan with + | Some e_var when List.mem_assoc (e_var, anti_scan.source) group_map -> + let key = e_var, anti_scan.source in + let has_earlier_positive = + List.exists (fun (scan_idx, sk) -> sk = key && scan_idx < idx) positive_entity_sources + in + if has_earlier_positive then + match List.assoc_opt key !anti_by_key with + | Some existing -> + anti_by_key := (key, anti_scan :: existing) :: List.remove_assoc key !anti_by_key + | None -> anti_by_key := (key, [ anti_scan ]) :: !anti_by_key + else + remaining_other := (idx, clause) :: !remaining_other + | _ -> remaining_other := (idx, clause) :: !remaining_other) + | None -> remaining_other := (idx, clause) :: !remaining_other) + other_entries; + let remaining_other = List.rev !remaining_other in + (* Attach comparison filters whose vars ⊆ one entity group's vars *) + let filters_by_key : ((string * string option) * query_clause list) list ref = ref [] in + let leftover = ref [] in + List.iter + (fun (_idx, clause) -> + match filter_clause clause with + | Some filter -> + let fvars = + match filter with + | ComparisonPredicate (_, l, r) -> terms_vars [ l; r ] + | EqualityPredicate (_, terms) | ComparisonPredicateN (_, terms) -> terms_vars terms + | _ -> [] + in + let owner = + group_map + |> List.find_map (fun (((e_var, _source) as key), scans) -> + let gvars = + e_var + :: (scans |> List.concat_map (fun s -> s.vars)) + |> List.sort_uniq compare + in + if fvars <> [] && List.for_all (fun v -> List.mem v gvars) fvars then + Some key + else + None) + in + (match owner with + | Some key -> + (match List.assoc_opt key !filters_by_key with + | Some existing -> + filters_by_key := (key, filter :: existing) :: List.remove_assoc key !filters_by_key + | None -> filters_by_key := (key, [ filter ]) :: !filters_by_key) + | None -> leftover := clause :: !leftover) + | None -> leftover := clause :: !leftover) + remaining_other; + let leftover = List.rev !leftover in + let entity_nodes = + group_map + |> List.map (fun (((e_var, source) as key), scans) -> + let anti = Option.value (List.assoc_opt key !anti_by_key) ~default:[] |> List.rev in + let filters = Option.value (List.assoc_opt key !filters_by_key) ~default:[] |> List.rev in + match scans, anti, filters with + | [ single ], [], [] -> LScan single + | _ -> + LEntityJoin + { entity_var = e_var; scans; anti_scans = anti; filters; source }) + in + let other_nodes_opt = + leftover + |> List.fold_left + (fun acc clause -> + match acc with + | None -> None + | Some nodes -> + (match clause with + | Or branches as c -> + let branch_plans = + List.map + (fun branch -> build_logical_plan ~max_datom_e ~bound_vars ~rules branch) + branches + in + if List.for_all Option.is_some branch_plans then + Some + (LUnion + { join_vars = None + ; branches = List.filter_map Fun.id branch_plans + ; clause = c + } + :: nodes) + else + Some (LPassthrough c :: nodes) + | OrJoin (vars, branches) as c -> + let branch_plans = + List.map + (fun branch -> build_logical_plan ~max_datom_e ~bound_vars ~rules branch) + branches + in + if List.for_all Option.is_some branch_plans then + Some + (LUnion + { join_vars = Some vars + ; branches = List.filter_map Fun.id branch_plans + ; clause = c + } + :: nodes) + else + Some (LPassthrough c :: nodes) + | Not sub as c -> + (match build_logical_plan ~max_datom_e ~bound_vars ~rules sub with + | Some sub_plan -> + Some (LAntiJoin { join_vars = None; sub = sub_plan; clause = c } :: nodes) + | None -> Some (LPassthrough c :: nodes)) + | NotJoin (vars, sub) as c -> + (match build_logical_plan ~max_datom_e ~bound_vars ~rules sub with + | Some sub_plan -> + Some (LAntiJoin { join_vars = Some vars; sub = sub_plan; clause = c } :: nodes) + | None -> Some (LPassthrough c :: nodes)) + | Rule (name, terms) as c -> + (match free_rule_body rules name (List.length terms) with + | Some body -> + (match build_logical_plan ~max_datom_e ~bound_vars ~rules body with + | Some body_plan -> + Some (LRuleExpand { name; terms; body = body_plan } :: nodes) + | None -> Some (LPassthrough c :: nodes)) + | None -> Some (LPassthrough c :: nodes)) + | ComparisonPredicate _ | EqualityPredicate _ | ComparisonPredicateN _ as c -> + Some (LFilter c :: nodes) + | c -> Some (LPassthrough c :: nodes))) + (Some []) + in + match other_nodes_opt with + | None -> None + | Some other_nodes -> + Some + { nodes = List.rev_append entity_nodes (List.rev_append !ungrouped (List.rev other_nodes)) + ; bound_vars + } + +let scan_estimated_rows ~max_datom_e scan = + estimate_pattern_cost ~max_datom_e scan.entity scan.attr scan.value + +let entity_group_cost ~max_datom_e scans = + match scans with + | [] -> max_datom_e + | _ -> + scans + |> List.map (scan_estimated_rows ~max_datom_e) + |> List.fold_left min max_datom_e + +let op_cost = function + | OpEntityGroup { estimated_rows; _ } | OpScan { estimated_rows; _ } -> estimated_rows + | OpFilter _ -> 50 + | OpUnion _ -> 900_000 + | OpAntiJoin _ -> 1_000_000 + | OpPassthrough _ -> 2_000_000 + +let op_produced_vars = function + | OpEntityGroup { clauses; _ } -> + clauses + |> List.concat_map (fun clause -> + match pattern_scan clause with + | Some s -> s.vars + | None -> []) + |> List.sort_uniq compare + | OpScan { clause; _ } -> + (match pattern_scan clause with Some s -> s.vars | None -> []) + | OpFilter _ | OpUnion _ | OpAntiJoin _ | OpPassthrough _ -> [] + +let filter_required_vars = function + | ComparisonPredicate (_, l, r) -> terms_vars [ l; r ] + | EqualityPredicate (_, terms) | ComparisonPredicateN (_, terms) -> terms_vars terms + | _ -> [] + +let rec lower_node ~max_datom_e = function + | LScan scan -> + OpScan + { clause = scan.clause + ; index = choose_index scan.entity scan.attr scan.value + ; estimated_rows = scan_estimated_rows ~max_datom_e scan + ; source = scan.source + } + | LEntityJoin { entity_var; scans; anti_scans; filters; source } -> + let ordered_scans = + scans + |> List.mapi (fun i s -> scan_estimated_rows ~max_datom_e s, i, s) + |> List.sort (fun (c1, i1, _) (c2, i2, _) -> + let cmp = compare c1 c2 in + if cmp <> 0 then cmp else compare i1 i2) + |> List.map (fun (_, _, s) -> s) + in + let scan, merges = + match ordered_scans with + | [] -> invalid_arg "entity join requires at least one scan" + | driving :: rest -> driving, rest + in + let pattern_clauses = List.map (fun s -> s.clause) ordered_scans in + let anti_clauses = List.map (fun s -> Not [ s.clause ]) anti_scans in + OpEntityGroup + { entity_var + ; scan + ; merges + ; anti_scans + ; filters + ; clauses = pattern_clauses @ anti_clauses @ filters + ; estimated_rows = entity_group_cost ~max_datom_e ordered_scans + ; source + } + | LFilter clause -> OpFilter clause + | LUnion { join_vars; branches; _ } -> + let branch_plans = List.filter_map (lower ~max_datom_e) branches in + if List.length branch_plans <> List.length branches then + OpPassthrough (Or []) + else + OpUnion { join_vars; branches = branch_plans } + | LAntiJoin { join_vars; sub; clause } -> + (match lower ~max_datom_e sub with + | Some excluded -> OpAntiJoin { join_vars; excluded } + | None -> OpPassthrough clause) + | LRuleExpand { body; _ } -> + (* Prefer single-op bodies; multi-op rule bodies fall through to interpreter. *) + (match lower ~max_datom_e body with + | Some { ops = [ op ] } -> op + | _ -> OpPassthrough (Rule ("", []))) + | LPassthrough clause -> OpPassthrough clause + +and lower ?(max_datom_e = 1_000_000) logical = + let raw_ops = List.map (lower_node ~max_datom_e) logical.nodes in + (* Expand single-op rule inlines already done; multi-op rule markers stay passthrough. *) + let ops = raw_ops in + let rec schedule ready_vars remaining scheduled = + match remaining with + | [] -> List.rev scheduled + | _ -> + let indexed = List.mapi (fun i op -> i, op) remaining in + let ready_idxs = + indexed + |> List.filter_map (fun (i, op) -> + match op with + | OpFilter clause -> + let req = filter_required_vars clause in + if List.for_all (fun v -> List.mem v ready_vars || List.mem v logical.bound_vars) req + then Some i + else None + | OpAntiJoin _ -> + if scheduled <> [] || ready_vars <> [] || logical.bound_vars <> [] then Some i else None + | OpPassthrough _ -> None + | _ -> Some i) + in + let pick_idx = + match ready_idxs with + | [] -> + (match + indexed + |> List.sort (fun (_, a) (_, b) -> compare (op_cost a) (op_cost b)) + with + | (i, _) :: _ -> Some i + | [] -> None) + | idxs -> + idxs + |> List.map (fun i -> op_cost (List.nth remaining i), i) + |> List.sort (fun (c1, i1) (c2, i2) -> + let cmp = compare c1 c2 in + if cmp <> 0 then cmp else compare i1 i2) + |> fun sorted -> Some (snd (List.hd sorted)) + in + (match pick_idx with + | None -> List.rev_append scheduled remaining + | Some idx -> + let first = List.nth remaining idx in + let rest = List.filteri (fun i _ -> i <> idx) remaining in + let ready_vars = List.sort_uniq compare (ready_vars @ op_produced_vars first) in + schedule ready_vars rest (first :: scheduled)) + in + let scans, others = + List.partition + (function OpEntityGroup _ | OpScan _ | OpUnion _ -> true | _ -> false) + ops + in + let scans = + scans + |> List.mapi (fun i op -> op_cost op, i, op) + |> List.sort (fun (c1, i1, _) (c2, i2, _) -> + let cmp = compare c1 c2 in + if cmp <> 0 then cmp else compare i1 i2) + |> List.map (fun (_, _, op) -> op) + in + let initial = schedule [] (scans @ others) [] in + let ops = + match initial with + | (OpAntiJoin _ as anti) :: rest -> + (match + List.find_index + (function OpEntityGroup _ | OpScan _ | OpUnion _ -> true | _ -> false) + rest + with + | None -> initial + | Some idx -> + let before = List.filteri (fun i _ -> i < idx) rest in + (match List.filteri (fun i _ -> i >= idx) rest with + | [] -> initial + | producer :: after -> before @ (producer :: anti :: after))) + | _ -> initial + in + Some { ops } + +(** Substitute rule params with call terms inside a body clause list. *) +let rec substitute_rule_terms param_map = function + | [] -> [] + | clause :: rest -> + let subst_term = function + | QVar name -> (match List.assoc_opt name param_map with Some t -> t | None -> QVar name) + | other -> other + in + let subst_clause = function + | Pattern (e, a, v) -> Pattern (subst_term e, subst_term a, subst_term v) + | PatternTx (e, a, v, tx) -> PatternTx (subst_term e, subst_term a, subst_term v, subst_term tx) + | ComparisonPredicate (p, l, r) -> ComparisonPredicate (p, subst_term l, subst_term r) + | EqualityPredicate (p, terms) -> EqualityPredicate (p, List.map subst_term terms) + | Not sub -> Not (substitute_rule_terms param_map sub) + | NotJoin (vars, sub) -> NotJoin (vars, substitute_rule_terms param_map sub) + | Or branches -> Or (List.map (substitute_rule_terms param_map) branches) + | OrJoin (vars, branches) -> OrJoin (vars, List.map (substitute_rule_terms param_map) branches) + | Rule (name, terms) -> Rule (name, List.map subst_term terms) + | other -> other + in + subst_clause clause :: substitute_rule_terms param_map rest + +let expand_nonrecursive_rules rules clauses = + let rec expand depth clauses = + if depth > 8 then None + else + let rec loop acc = function + | [] -> Some (List.rev acc) + | Rule (name, terms) :: rest -> + (match free_rule_body rules name (List.length terms) with + | None -> None + | Some body -> + let params = + match + List.find_opt + (fun r -> r.rule_name = name && List.length r.rule_params = List.length terms) + rules + with + | Some r -> r.rule_params + | None -> [] + in + let param_map = List.combine params terms in + let body = substitute_rule_terms param_map body in + (match expand (depth + 1) body with + | None -> None + | Some expanded -> loop (List.rev_append expanded acc) rest)) + | clause :: rest -> loop (clause :: acc) rest + in + loop [] clauses + in + expand 0 clauses + +let compile ?(max_datom_e = 1_000_000) ?(bound_vars = []) ?(rules = []) clauses = + match expand_nonrecursive_rules rules clauses with + | None -> + (* Keep rule clauses; logical plan may mark them passthrough. *) + (match build_logical_plan ~max_datom_e ~bound_vars ~rules clauses with + | None -> None + | Some logical -> lower ~max_datom_e logical) + | Some expanded -> + (match build_logical_plan ~max_datom_e ~bound_vars ~rules expanded with + | None -> None + | Some logical -> lower ~max_datom_e logical) + +let analyze ?(max_datom_e = 1_000_000) ?(bound_vars = []) ?(rules = []) query = + if query.with_vars <> [] then None + else compile ~max_datom_e ~bound_vars ~rules:(rules @ query.rules) query.where + +let plan_is_executable plan = + not (List.exists (function OpPassthrough _ -> true | _ -> false) plan.ops) + +let plan_is_fused_execute plan = + match plan.ops with + | [ OpEntityGroup _ ] | [ OpScan _ ] -> true + | _ -> false + +let rec clauses_of_plan plan = + plan.ops + |> List.concat_map (function + | OpEntityGroup { clauses; _ } -> clauses + | OpScan { clause; _ } -> [ clause ] + | OpFilter clause -> [ clause ] + | OpUnion { join_vars = None; branches } -> + [ Or (List.map clauses_of_plan branches) ] + | OpUnion { join_vars = Some vars; branches } -> + [ OrJoin (vars, List.map clauses_of_plan branches) ] + | OpAntiJoin { join_vars = None; excluded } -> [ Not (clauses_of_plan excluded) ] + | OpAntiJoin { join_vars = Some vars; excluded } -> + [ NotJoin (vars, clauses_of_plan excluded) ] + | OpPassthrough clause -> [ clause ]) diff --git a/impl/query_plan.mli b/impl/query_plan.mli new file mode 100644 index 0000000..30b5ceb --- /dev/null +++ b/impl/query_plan.mli @@ -0,0 +1,118 @@ +(** Datahike-aligned query planner: classify → logical IR → lower → physical ops. + + Unsupported / ineligible shapes return [None]; callers fall back to the + relational interpreter (permanent fallback, matching Datahike). *) + +open Datascript_types + +type index_choice = + | Prefer_eavt + | Prefer_aevt + | Prefer_avet + +type l_scan = + { entity : query_term + ; attr : query_term + ; value : query_term + ; tx : query_term option + ; source : string option + ; clause : query_clause + ; vars : string list + } + +type logical_node = + | LScan of l_scan + | LEntityJoin of + { entity_var : string + ; scans : l_scan list + ; anti_scans : l_scan list + ; filters : query_clause list + ; source : string option + } + | LFilter of query_clause + | LUnion of + { join_vars : string list option + ; branches : logical_plan list + ; clause : query_clause + } + | LAntiJoin of + { join_vars : string list option + ; sub : logical_plan + ; clause : query_clause + } + | LRuleExpand of + { name : string + ; terms : query_term list + ; body : logical_plan + } + | LPassthrough of query_clause + +and logical_plan = + { nodes : logical_node list + ; bound_vars : string list + } + +type entity_group = + { entity_var : string + ; scan : l_scan + ; merges : l_scan list + ; anti_scans : l_scan list + ; filters : query_clause list + ; clauses : query_clause list + ; estimated_rows : int + ; source : string option + } + +type physical_op = + | OpEntityGroup of entity_group + | OpScan of + { clause : query_clause + ; index : index_choice + ; estimated_rows : int + ; source : string option + } + | OpFilter of query_clause + | OpUnion of + { join_vars : string list option + ; branches : physical_plan list + } + | OpAntiJoin of + { join_vars : string list option + ; excluded : physical_plan + } + | OpPassthrough of query_clause + +and physical_plan = + { ops : physical_op list + } + +val pattern_scan : query_clause -> l_scan option + +(** Ground-component index preference (Datahike plan-pattern-op). *) +val choose_index : query_term -> query_term -> query_term -> index_choice + +(** Cardinality estimate for a pattern. Prefer tighter constants over open scans. *) +val estimate_pattern_cost : ?max_datom_e:int -> query_term -> query_term -> query_term -> int + +(** Build unordered logical plan; [None] when [:with] or unsupported top-level shape. *) +val build_logical_plan : + ?max_datom_e:int -> ?bound_vars:string list -> ?rules:query_rule list -> query_clause list -> logical_plan option + +(** Lower logical plan to ordered physical ops with readiness-aware cost order. *) +val lower : ?max_datom_e:int -> logical_plan -> physical_plan option + +(** Compile where-clauses: logical → lower. *) +val compile : + ?max_datom_e:int -> ?bound_vars:string list -> ?rules:query_rule list -> query_clause list -> physical_plan option + +(** Analyze a full query into a physical plan when eligible. *) +val analyze : ?max_datom_e:int -> ?bound_vars:string list -> ?rules:query_rule list -> query -> physical_plan option + +(** True when every op is planner-executable (no [OpPassthrough]). *) +val plan_is_executable : physical_plan -> bool + +(** True when the plan is a single fused entity-group or scan for [Query_exec]. *) +val plan_is_fused_execute : physical_plan -> bool + +(** Flatten a physical plan back to where-clauses in execution order (tests / explain). *) +val clauses_of_plan : physical_plan -> query_clause list diff --git a/impl/query_where.ml b/impl/query_where.ml index bb7d0bb..4452633 100644 --- a/impl/query_where.ml +++ b/impl/query_where.ml @@ -25,6 +25,15 @@ module Make (Context : sig val is_ref_attr : db -> attr -> bool val cardinality_one : db -> attr -> bool val normalize_value : value -> value + val datoms_by_attr_value : db -> attr -> value -> datom list + val entity_ids_by_attr_value : db -> attr -> value -> entity_id list option + val query_attr_uses_avet : db -> attr -> bool + val fold_index_range : + ('acc -> datom -> 'acc) -> 'acc -> db -> attr -> ?start:value -> ?stop:value -> unit -> 'acc + val find_entity_attr_value : db -> entity_id -> attr -> query_result option + val aevt_attr_array : db -> attr -> datom array option + val aevt_duplicate_datoms : db -> attr -> datom list + val find_entity_in_aevt_array : datom array -> entity_id -> datom option end) = struct open Context @@ -197,6 +206,51 @@ end) = struct let row_binding attrs row = List.combine attrs row + type direct_row_slot = + | Direct_entity + | Direct_attr + | Direct_value + | Direct_tx + | Direct_op + + let direct_row_slot_of_term_index index = + match index with + | 0 -> Direct_entity + | 1 -> Direct_attr + | 2 -> Direct_value + | 3 -> Direct_tx + | 4 -> Direct_op + | _ -> invalid_arg "invalid datom pattern position" + + let direct_row_slots attrs terms = + List.map + (fun attr -> + let rec find index = function + | [] -> invalid_arg "pattern variable is missing from row" + | QVar var :: _ when var = attr -> direct_row_slot_of_term_index index + | _ :: rest -> find (index + 1) rest + in + find 0 terms) + attrs + + let value_of_direct_row_slot datom = function + | Direct_entity -> Query.result_of_datom_e datom + | Direct_attr -> Query.result_of_datom_a datom + | Direct_value -> Query.result_of_ref (Query.result_of_datom_v datom) + | Direct_tx -> Query.result_of_datom_tx datom + | Direct_op -> Query.result_of_datom_op datom + + let build_direct_pattern_row slots datom = List.map (value_of_direct_row_slot datom) slots + + let collect_direct_pattern_rows attrs terms datoms = + let slots = direct_row_slots attrs terms in + let rec loop acc seq = + match seq () with + | Seq.Nil -> List.rev acc + | Seq.Cons (datom, rest) -> loop (build_direct_pattern_row slots datom :: acc) rest + in + loop [] datoms + let direct_pattern_row attrs terms datom = attrs |> List.map (fun attr -> @@ -267,17 +321,11 @@ end) = struct if can_direct || can_direct_dynamic_attr then match terms with | [ e_term; a_term; v_term ] -> - datoms - |> Seq.map (direct_pattern_row attrs [ e_term; a_term; v_term ]) - |> List.of_seq + collect_direct_pattern_rows attrs [ e_term; a_term; v_term ] datoms | [ e_term; a_term; v_term; tx_term ] -> - datoms - |> Seq.map (direct_pattern_row attrs [ e_term; a_term; v_term; tx_term ]) - |> List.of_seq + collect_direct_pattern_rows attrs [ e_term; a_term; v_term; tx_term ] datoms | [ e_term; a_term; v_term; tx_term; op_term ] -> - datoms - |> Seq.map (direct_pattern_row attrs [ e_term; a_term; v_term; tx_term; op_term ]) - |> List.of_seq + collect_direct_pattern_rows attrs [ e_term; a_term; v_term; tx_term; op_term ] datoms | _ -> invalid_arg "database source patterns expect 3, 4, or 5 terms" else match terms with @@ -305,23 +353,71 @@ end) = struct |> List.of_seq | _ -> invalid_arg "database source patterns expect 3, 4, or 5 terms" + let relation_of_aevt_var_var_pattern source_db e_var attr v_var = + (* Datahike-like OpScan on AEVT: walk attr arrays once, emit rows without Seq→list. *) + if query_evaluator_context.is_reverse_ref attr then + None + else + match aevt_attr_array source_db attr with + | None -> None + | Some primary -> + let attrs = unique_vars [ QVar e_var; QAttr attr; QVar v_var ] in + let lookup_vars = relation_lookup_vars source_db [ QVar e_var; QAttr attr; QVar v_var ] in + let emit_datom rows datom = + let value = result_of_pattern_position datom 2 in + match attrs with + | [ left; right ] when left = e_var && right = v_var -> + [ Result_entity datom.e; value ] :: rows + | [ left; right ] when left = v_var && right = e_var -> + [ value; Result_entity datom.e ] :: rows + | _ -> + (match binding_row attrs [ e_var, Result_entity datom.e; v_var, value ] with + | Some row -> row :: rows + | None -> rows) + in + let rows = ref [] in + for i = Array.length primary - 1 downto 0 do + rows := emit_datom !rows primary.(i) + done; + (match aevt_duplicate_datoms source_db attr with + | [] -> () + | duplicates -> List.iter (fun datom -> rows := emit_datom !rows datom) duplicates); + Some + { attrs + ; rows = !rows + ; lookup_vars + ; unique_rows = (not source_db.history) && source_db.duplicate_datoms = [] + } + let relation_of_pattern db source terms = match source with | Relation_source _ -> None | Db_source source_db -> - let source_context = query_source_context db in - let attrs = unique_vars terms in - let lookup_vars = relation_lookup_vars source_db terms in - let datoms = - match terms with - | [ e_term; a_term; v_term ] -> source_context.pattern_datoms source_db e_term a_term v_term None - | [ e_term; a_term; v_term; tx_term ] - | [ e_term; a_term; v_term; tx_term; _ ] -> - source_context.pattern_datoms source_db e_term a_term v_term (Some tx_term) - | _ -> invalid_arg "database source patterns expect 3, 4, or 5 terms" - in - let rows = relation_rows_of_pattern_datoms source_context source_db attrs terms datoms in - Some { attrs; rows; lookup_vars; unique_rows = false } + (match terms with + | [ QVar e_var; QAttr attr; QVar v_var ] when e_var <> v_var -> + (match relation_of_aevt_var_var_pattern source_db e_var attr v_var with + | Some relation -> Some relation + | None -> + let source_context = query_source_context db in + let attrs = unique_vars terms in + let lookup_vars = relation_lookup_vars source_db terms in + let datoms = source_context.pattern_datoms source_db (QVar e_var) (QAttr attr) (QVar v_var) None in + let rows = relation_rows_of_pattern_datoms source_context source_db attrs terms datoms in + Some { attrs; rows; lookup_vars; unique_rows = false }) + | _ -> + let source_context = query_source_context db in + let attrs = unique_vars terms in + let lookup_vars = relation_lookup_vars source_db terms in + let datoms = + match terms with + | [ e_term; a_term; v_term ] -> source_context.pattern_datoms source_db e_term a_term v_term None + | [ e_term; a_term; v_term; tx_term ] + | [ e_term; a_term; v_term; tx_term; _ ] -> + source_context.pattern_datoms source_db e_term a_term v_term (Some tx_term) + | _ -> invalid_arg "database source patterns expect 3, 4, or 5 terms" + in + let rows = relation_rows_of_pattern_datoms source_context source_db attrs terms datoms in + Some { attrs; rows; lookup_vars; unique_rows = false }) let reverse_comparison_predicate = function | GreaterThan -> LessThan @@ -615,6 +711,24 @@ end) = struct in { attrs; rows; lookup_vars; unique_rows = false } + let union_relations left right = + if left.attrs <> right.attrs then + None + else + let lookup_vars = + List.fold_left + (fun lookup_vars ((var, _) as lookup_var) -> + if List.mem_assoc var lookup_vars then lookup_vars else lookup_var :: lookup_vars) + left.lookup_vars + right.lookup_vars + in + Some + { attrs = left.attrs + ; rows = List.rev_append (List.rev left.rows) right.rows + ; lookup_vars + ; unique_rows = left.unique_rows && right.unique_rows + } + let anti_join left right = let common = List.filter (fun attr -> List.mem attr right.attrs) left.attrs in match common with @@ -932,6 +1046,132 @@ end) = struct Some { attrs; rows; lookup_vars; unique_rows = false } | _ -> None + let comparison_matches_datom value_var datom = function + | ComparisonPredicate (predicate, left_term, right_term) -> ( + match range_predicate_for_var value_var predicate left_term right_term with + | Some (range_predicate, threshold) -> + Built_ins.matches_comparison_predicate + range_predicate + (query_evaluator_context.compare_value datom.v threshold) + | None -> false) + | _ -> false + + let comparison_targets_var value_var = function + | ComparisonPredicate (predicate, left_term, right_term) -> + Option.is_some (range_predicate_for_var value_var predicate left_term right_term) + | _ -> false + + let avet_index_start predicate threshold = + match predicate, threshold with + | GreaterThan, Int n -> Some (Int (n + 1)) + | GreaterOrEqual, value | GreaterThan, value -> Some value + | _ -> None + + let avet_index_stop predicate threshold = + match predicate, threshold with + | LessThan, Int n when n > min_int -> Some (Int (n - 1)) + | LessOrEqual, value | LessThan, value -> Some value + | _ -> None + + let avet_bounds_need_post_filter value_var comparisons = + List.exists + (function + | ComparisonPredicate (predicate, left, right) -> ( + match range_predicate_for_var value_var predicate left right with + | Some (GreaterThan, Int _) | Some (LessThan, Int _) -> false + | Some _ -> true + | None -> true) + | _ -> false) + comparisons + + let merge_avet_start compare_value start bound = + match start with + | None -> Some bound + | Some current -> if compare_value bound current > 0 then Some bound else Some current + + let merge_avet_stop compare_value stop bound = + match stop with + | None -> Some bound + | Some current -> if compare_value bound current < 0 then Some bound else Some current + + let fold_index_range_filtered init db attr start stop f = + match start, stop with + | None, None -> fold_index_range f init db attr () + | Some start, None -> fold_index_range f init db attr ~start () + | None, Some stop -> fold_index_range f init db attr ~stop () + | Some start, Some stop -> fold_index_range f init db attr ~start ~stop () + + let relation_of_avet_value_comparisons _db source e_var value_var attr comparisons = + match source with + | Db_source source_db when query_attr_uses_avet source_db attr && not (is_ref_attr source_db attr) -> + if + comparisons = [] + || not (List.for_all (comparison_targets_var value_var) comparisons) + then + None + else ( + let compare_value = query_evaluator_context.compare_value in + let start, stop = + List.fold_left + (fun (start, stop) -> function + | ComparisonPredicate (predicate, left_term, right_term) -> ( + match range_predicate_for_var value_var predicate left_term right_term with + | Some (GreaterThan as p, threshold) | Some (GreaterOrEqual as p, threshold) -> + let bound = + Option.value (avet_index_start p threshold) ~default:threshold + in + (merge_avet_start compare_value start bound, stop) + | Some (LessThan as p, threshold) | Some (LessOrEqual as p, threshold) -> + let bound = + Option.value (avet_index_stop p threshold) ~default:threshold + in + (start, merge_avet_stop compare_value stop bound) + | _ -> (start, stop)) + | _ -> (start, stop)) + (None, None) comparisons + in + let terms = [ QVar e_var; QAttr attr; QVar value_var ] in + let attrs = unique_vars terms in + let lookup_vars = relation_lookup_vars source_db terms in + let need_post_filter = avet_bounds_need_post_filter value_var comparisons in + let post_filter datom = + if need_post_filter then + List.for_all (comparison_matches_datom value_var datom) comparisons + else + true + in + (* Specialized [e; v] rows avoid slot List.map; reverse-cons then rev once. *) + let rows = + match attrs with + | [ entity_attr; value_attr ] when entity_attr = e_var && value_attr = value_var -> + fold_index_range_filtered [] source_db attr start stop (fun acc datom -> + if post_filter datom then + [ Result_entity datom.e; Result_value datom.v ] :: acc + else + acc) + |> List.rev + | [ value_attr; entity_attr ] when entity_attr = e_var && value_attr = value_var -> + fold_index_range_filtered [] source_db attr start stop (fun acc datom -> + if post_filter datom then + [ Result_value datom.v; Result_entity datom.e ] :: acc + else + acc) + |> List.rev + | _ -> + let slots = direct_row_slots attrs terms in + let build_row datom = build_direct_pattern_row slots datom in + fold_index_range_filtered [] source_db attr start stop (fun acc datom -> + if post_filter datom then build_row datom :: acc else acc) + |> List.rev + in + let unique_rows = + (not source_db.history) + && source_db.duplicate_datoms = [] + && cardinality_one source_db attr + in + Some { attrs; rows; lookup_vars; unique_rows }) + | _ -> None + let relation_of_same_entity_patterns db source clauses = let validate_not_order clauses = let rec loop bound_vars = function @@ -943,6 +1183,13 @@ end) = struct outer_binding_vars not_clauses; loop bound_vars rest + | NotJoin (_join_vars, not_clauses) :: rest -> + let outer_binding_vars = bound_vars |> List.map (fun var -> var, Result_entity 0) in + Query.ensure_not_has_outer_binding + ~value_to_string:edn_string_of_value + outer_binding_vars + not_clauses; + loop bound_vars rest | clause :: rest -> let clause_vars = Query.vars_of_clause clause in let bound_vars = @@ -955,7 +1202,14 @@ end) = struct in loop [] clauses in - let has_not = List.exists (function Not _ -> true | _ -> false) clauses in + let has_not = + List.exists + (function + | Not _ -> true + | NotJoin ([ _ ], [ Pattern _ ]) -> true + | _ -> false) + clauses + in if has_not then validate_not_order clauses; let* patterns, excluded_patterns, relation_comparisons = @@ -963,6 +1217,8 @@ end) = struct let clause_pattern = function | Pattern (QVar e_var, QAttr attr, value_term) -> Some (`Positive (e_var, attr, value_term)) | Not [ Pattern (QVar e_var, QAttr attr, value_term) ] -> Some (`Excluded (e_var, attr, value_term)) + | NotJoin ([ join_e ], [ Pattern (QVar e_var, QAttr attr, value_term) ]) when join_e = e_var -> + Some (`Excluded (e_var, attr, value_term)) | _ -> None in clauses @@ -1019,464 +1275,289 @@ end) = struct false )) value_var_patterns in - if - duplicate_value_var - || (relation_comparisons <> [] && constant_patterns = []) - || (constant_patterns = [] - && value_var_patterns = [] - && required_patterns = [] - && excluded_patterns = []) - then + if duplicate_value_var then None else - let source_context = query_source_context db in - let direct_attr attr = - not (query_evaluator_context.is_reverse_ref attr) - in - let datoms_matching attr value = - let datoms = source_context.pattern_datoms source_db (QVar e_var) (QAttr attr) (QValue value) None in - if direct_attr attr then - List.of_seq datoms - else - datoms - |> Seq.filter (fun datom -> - Option.is_some - (source_context.match_data_pattern source_db [] (QVar e_var) (QAttr attr) (QValue value) datom)) - |> List.of_seq - in - let constant_datoms = - constant_patterns - |> List.map (fun (attr, value) -> attr, value, lazy (datoms_matching attr value)) - in + (let comparison_relation = + match + constant_patterns, excluded_patterns, value_var_patterns, relation_comparisons + with + | [], [], [ (value_var, attr) ], comparisons when comparisons <> [] -> + relation_of_avet_value_comparisons db source e_var value_var attr comparisons + | _ -> None + in + match comparison_relation with + | Some relation -> Some relation + | None -> + if + constant_patterns = [] + && value_var_patterns = [] + && required_patterns = [] + && excluded_patterns = [] + then + None + else ( let attrs = patterns |> List.concat_map (fun (e_var, attr, value_term) -> [ QVar e_var; QAttr attr; value_term ]) |> unique_vars in let lookup_vars = relation_lookup_vars source_db [ QVar e_var; QWildcard; QWildcard ] in - if List.exists (fun (_, _, datoms) -> Lazy.force datoms = []) constant_datoms then + let pattern_relation (_, attr, value_term) = + relation_of_pattern db source [ QVar e_var; QAttr attr; value_term ] + in + (match + patterns + |> List.filter_map pattern_relation + |> function + | [] -> None + | first :: rest -> Some (List.fold_left hash_join first rest) + with + | None -> None + | Some relation -> + let relation = + excluded_patterns + |> List.fold_left + (fun relation (_, attr, value_term) -> + match relation_of_pattern db source [ QVar e_var; QAttr attr; value_term ] with + | Some excluded -> Option.value (anti_join relation excluded) ~default:relation + | None -> relation) + relation + in + let unique_rows = + (not source_db.history) + && source_db.duplicate_datoms = [] + && List.mem e_var attrs + in + let relation = { relation with lookup_vars; unique_rows } in + Some + (List.fold_left + (fun relation -> function + | ComparisonPredicate (predicate, left_term, right_term) -> + filter_relation_comparison db relation predicate left_term right_term + | _ -> relation) + relation + relation_comparisons)))) + | _ -> None + + let relation_of_cross_entity_value_join _db source clauses = + let patterns_only = + List.fold_left + (fun patterns clause -> + match patterns, clause with + | Some patterns, Pattern (QVar entity_var, QAttr attr, value_term) -> + Some ((entity_var, attr, value_term) :: patterns) + | _ -> None) + (Some []) + clauses + |> Option.map List.rev + in + let join_value_var patterns = + match List.find_opt (function _, _, QVar _ -> true | _ -> false) patterns with + | Some (_, _, QVar value_var) -> Some value_var + | _ -> None + in + let find_cross_entity_value_join patterns = + let join_var = join_value_var patterns in + let constant = + match List.find_opt (function _, _, QValue _ -> true | _ -> false) patterns with + | Some (filter_entity, filter_attr, QValue filter_value) -> + Some (filter_entity, filter_attr, filter_value) + | _ -> None + in + match join_var, constant with + | Some join_var, Some (filter_entity, filter_attr, filter_value) -> + let join_endpoints = + patterns + |> List.filter (function + | _, _, QVar value_var when value_var = join_var -> true + | _ -> false) + |> List.map (fun (entity_var, attr, _) -> entity_var, attr) + in + (match join_endpoints with + | [ (left_entity, join_attr); (right_entity, right_attr) ] + when left_entity <> right_entity && join_attr = right_attr -> + let output_patterns = + patterns + |> List.filter (function + | entity_var, _, QVar value_var when entity_var <> filter_entity && value_var <> join_var -> + true + | _ -> false) + |> List.filter_map (function + | entity_var, attr, QVar value_var -> Some (entity_var, attr, value_var) + | _ -> None) + in + if output_patterns = [] then + None + else + let output_entity = + if filter_entity = left_entity then + right_entity + else if filter_entity = right_entity then + left_entity + else + "" + in + if output_entity = "" then + None + else if List.for_all (fun (entity_var, _, _) -> entity_var = output_entity) output_patterns + then + Some + ( filter_entity + , filter_attr + , filter_value + , output_entity + , join_var + , join_attr + , output_patterns ) + else + None + | _ -> None) + | _ -> None + in + match source, patterns_only with + | Db_source source_db, Some patterns -> + let* ( _filter_entity + , filter_attr + , filter_value + , output_entity + , join_var + , join_attr + , output_patterns ) = + find_cross_entity_value_join patterns + in + if + query_evaluator_context.is_reverse_ref filter_attr + || query_evaluator_context.is_reverse_ref join_attr + || List.exists + (fun (_, attr, _) -> query_evaluator_context.is_reverse_ref attr) + output_patterns + then + None + else + let output_vars = List.map (fun (_, _, value_var) -> value_var) output_patterns in + let attrs = + unique_vars + ( QVar output_entity + :: QVar join_var + :: List.map (fun var -> QVar var) output_vars ) + in + let lookup_vars = + relation_lookup_vars source_db [ QVar output_entity; QWildcard; QWildcard ] + in + let filter_ids = + match entity_ids_by_attr_value source_db filter_attr filter_value with + | Some entity_ids -> entity_ids + | None -> datoms_by_attr_value source_db filter_attr filter_value |> List.map (fun datom -> datom.e) + in + if filter_ids = [] then + Some { attrs; rows = []; lookup_vars; unique_rows = true } + else + let* join_arr = aevt_attr_array source_db join_attr in + let join_values = Hashtbl.create (List.length filter_ids) in + List.iter + (fun entity_id -> + match find_entity_in_aevt_array join_arr entity_id with + | Some datom -> Hashtbl.replace join_values datom.v () + | None -> ()) + filter_ids; + if Hashtbl.length join_values = 0 then Some { attrs; rows = []; lookup_vars; unique_rows = true } else - let constant_sets = - let set_from_datoms datoms = - let entities = Bytes.make (source_db.max_datom_e + 1) '\000' in - List.iter - (fun datom -> - if datom.e >= 0 && datom.e < Bytes.length entities then - Bytes.set entities datom.e '\001') - datoms; - entities + let output_attr_arrays = + output_patterns + |> List.map (fun (_, attr, value_var) -> + match aevt_attr_array source_db attr with + | None -> None + | Some arr -> Some (value_var, arr)) in - constant_datoms - |> List.map (fun (_, _, datoms) -> set_from_datoms (Lazy.force datoms)) - in - let candidate_entities () = - match constant_datoms with - | [] -> - (match value_var_patterns, required_patterns with - | (_, attr) :: _, _ | [], attr :: _ -> - source_context.pattern_datoms source_db (QVar e_var) (QAttr attr) QWildcard None - |> Seq.map (fun datom -> datom.e) - |> List.of_seq - | [], [] -> []) - | datoms_by_constant -> - datoms_by_constant - |> List.sort (fun (_, _, left) (_, _, right) -> - compare (List.length (Lazy.force left)) (List.length (Lazy.force right))) - |> function - | (_, _, datoms) :: _ -> List.map (fun datom -> datom.e) (Lazy.force datoms) - | [] -> [] - in - let has_pattern entity_id attr value_term = - let datoms = source_context.pattern_datoms source_db (QEntity entity_id) (QAttr attr) value_term None in - if direct_attr attr then - Option.is_some (Seq.uncons datoms) + if List.exists Option.is_none output_attr_arrays then + None else - datoms - |> Seq.exists (fun datom -> - Option.is_some - (source_context.match_data_pattern source_db [] (QEntity entity_id) (QAttr attr) value_term datom)) - in - let excluded_sets = - excluded_patterns - |> List.map (fun (_, attr, value_term) -> - let entities = Bytes.make (source_db.max_datom_e + 1) '\000' in - let datoms = source_context.pattern_datoms source_db (QVar e_var) (QAttr attr) value_term None in - let mark datom = - if datom.e >= 0 && datom.e < Bytes.length entities then - Bytes.set entities datom.e '\001' + let output_attr_arrays = List.map Option.get output_attr_arrays in + let specialized = + match attrs with + | [ out_e; jv; ov ] when out_e = output_entity && jv = join_var -> + (match output_attr_arrays with + | [ (value_var, out_arr) ] when value_var = ov -> Some out_arr + | _ -> None) + | [ out_e; ov; jv ] when out_e = output_entity && jv = join_var -> + (match output_attr_arrays with + | [ (value_var, out_arr) ] when value_var = ov -> Some out_arr + | _ -> None) + | _ -> None in - if direct_attr attr then - datoms |> Seq.iter mark - else - datoms - |> Seq.iter (fun datom -> - if - Option.is_some - (source_context.match_data_pattern source_db [] (QVar e_var) (QAttr attr) value_term datom) - then - mark datom); - entities) - in - let matches_required = - match required_patterns with - | [] -> fun _ -> true - | [ attr ] -> fun entity_id -> has_pattern entity_id attr QWildcard - | patterns -> - fun entity_id -> - patterns |> List.for_all (fun attr -> has_pattern entity_id attr QWildcard) - in - let constant_matches entity_id = - constant_sets - |> List.for_all (fun entities -> - entity_id >= 0 - && entity_id < Bytes.length entities - && Bytes.get entities entity_id = '\001') - in - let matches_constants = - match constant_sets with - | [] -> fun _ -> true - | [ entities ] -> - fun entity_id -> - entity_id >= 0 - && entity_id < Bytes.length entities - && Bytes.get entities entity_id = '\001' - | [ left; right ] -> - fun entity_id -> - entity_id >= 0 - && entity_id < Bytes.length left - && Bytes.get left entity_id = '\001' - && entity_id < Bytes.length right - && Bytes.get right entity_id = '\001' - | _ -> constant_matches - in - let matches_excluded = - match excluded_sets with - | [] -> fun _ -> false - | [ entities ] -> - fun entity_id -> - entity_id >= 0 - && entity_id < Bytes.length entities - && Bytes.get entities entity_id = '\001' - | sets -> - fun entity_id -> - sets - |> List.exists (fun entities -> - entity_id >= 0 - && entity_id < Bytes.length entities - && Bytes.get entities entity_id = '\001') - in - let entity_allowed = - match excluded_sets with - | [] -> fun entity_id -> matches_constants entity_id && matches_required entity_id - | _ -> - fun entity_id -> - matches_constants entity_id && matches_required entity_id && not (matches_excluded entity_id) - in - let value_results entity_id attr = - let datoms = source_context.pattern_datoms source_db (QEntity entity_id) (QAttr attr) QWildcard None in - if direct_attr attr then - datoms |> Seq.map (fun datom -> result_of_pattern_position datom 2) |> List.of_seq - else - datoms - |> Seq.filter_map (fun datom -> - let* _ = - source_context.match_data_pattern source_db [] (QEntity entity_id) (QAttr attr) QWildcard datom - in - Some (result_of_pattern_position datom 2)) - |> List.of_seq - in - let single_value_result entity_id attr = - let datoms = source_context.pattern_datoms source_db (QEntity entity_id) (QAttr attr) QWildcard None in - if direct_attr attr then - Option.map (fun (datom, _) -> result_of_pattern_position datom 2) (Seq.uncons datoms) - else - datoms - |> Seq.find_map (fun datom -> - let* _ = - source_context.match_data_pattern source_db [] (QEntity entity_id) (QAttr attr) QWildcard datom - in - Some (result_of_pattern_position datom 2)) - in - let extend_bindings bindings (value_var, attr) = - bindings - |> List.concat_map (fun binding -> - let entity_id = - match List.assoc e_var binding with - | Result_entity entity_id -> entity_id - | _ -> -1 + let rows = + match specialized with + | Some out_arr -> + let rows = ref [] in + Array.iter + (fun datom -> + if Hashtbl.mem join_values datom.v then + match find_entity_in_aevt_array out_arr datom.e with + | None -> () + | Some out_datom -> + let join_result = + Query.result_of_ref (Query.result_of_datom_v datom) + in + let out_result = + Query.result_of_ref (Query.result_of_datom_v out_datom) + in + let row = + match attrs with + | [ _; jv; _ ] when jv = join_var -> + [ Result_entity datom.e; join_result; out_result ] + | [ _; _; jv ] when jv = join_var -> + [ Result_entity datom.e; out_result; join_result ] + | _ -> + [ Result_entity datom.e; join_result; out_result ] + in + rows := row :: !rows) + join_arr; + List.rev !rows + | None -> + let rows = ref [] in + Array.iter + (fun datom -> + if Hashtbl.mem join_values datom.v then + let binding = + (join_var, Query.result_of_ref (Query.result_of_datom_v datom)) + :: [ output_entity, Result_entity datom.e ] + in + let binding = + List.fold_left + (fun binding (value_var, arr) -> + match binding with + | None -> None + | Some binding -> + match find_entity_in_aevt_array arr datom.e with + | None -> None + | Some out_datom -> + Some + (( value_var + , Query.result_of_ref (Query.result_of_datom_v out_datom) ) + :: binding)) + (Some binding) + output_attr_arrays + in + match binding with + | None -> () + | Some binding -> + (match binding_row attrs binding with + | Some row -> rows := row :: !rows + | None -> ())) + join_arr; + List.rev !rows in - let values = value_results entity_id attr in - values - |> List.filter_map (fun value -> - match List.assoc_opt value_var binding with - | Some existing when existing = value -> Some binding - | Some _ -> None - | None -> Some ((value_var, value) :: binding))) - in - let rows_from_cardinality_one_candidates value_vars = - candidate_entities () - |> List.filter_map (fun entity_id -> - if not (entity_allowed entity_id) then - None - else - let* binding = - value_vars - |> List.fold_left - (fun binding (value_var, attr) -> - match binding with - | None -> None - | Some binding -> - single_value_result entity_id attr - |> Option.map (fun value -> (value_var, value) :: binding)) - (Some [ e_var, Result_entity entity_id ]) - in - binding_row attrs binding) - in - let rows_from_cardinality_one_value_scan scan_value_var scan_attr remaining_value_vars = - let direct_allowed_entity_set () = - match constant_sets with - | [] | [ _ ] -> None - | first :: rest -> - let allowed = Bytes.copy first in - for index = 0 to Bytes.length allowed - 1 do - if - Bytes.get allowed index = '\001' - && List.exists (fun entities -> Bytes.get entities index <> '\001') rest - then - Bytes.set allowed index '\000' - done; - Some allowed - in - match remaining_value_vars, attrs, constant_sets with - | [], [ entity_attr; value_attr ], _ :: _ :: _ - when direct_attr scan_attr && entity_attr = e_var && value_attr = scan_value_var -> - let scan_datoms = source_context.pattern_datoms source_db (QVar e_var) (QAttr scan_attr) QWildcard None in - let allowed = direct_allowed_entity_set () in - let entity_allowed = - match allowed with - | Some allowed -> - fun entity_id -> - entity_id >= 0 - && entity_id < Bytes.length allowed - && Bytes.get allowed entity_id = '\001' - && matches_required entity_id - | None -> entity_allowed + let unique_rows = + (not source_db.history) + && source_db.duplicate_datoms = [] + && cardinality_one source_db join_attr + && List.for_all + (fun (_, attr, _) -> cardinality_one source_db attr) + output_patterns in - if is_ref_attr source_db scan_attr then - let rec collect acc seq = - match seq () with - | Seq.Nil -> List.rev acc - | Seq.Cons (scan_datom, rest) -> - if entity_allowed scan_datom.e then - collect ([ Result_entity scan_datom.e; result_of_pattern_position scan_datom 2 ] :: acc) rest - else - collect acc rest - in - collect [] scan_datoms - else - let rec collect acc seq = - match seq () with - | Seq.Nil -> List.rev acc - | Seq.Cons (scan_datom, rest) -> - if entity_allowed scan_datom.e then - collect ([ Result_entity scan_datom.e; Result_value scan_datom.v ] :: acc) rest - else - collect acc rest - in - collect [] scan_datoms - | [], [ value_attr; entity_attr ], _ :: _ :: _ - when direct_attr scan_attr && entity_attr = e_var && value_attr = scan_value_var -> - let scan_datoms = source_context.pattern_datoms source_db (QVar e_var) (QAttr scan_attr) QWildcard None in - let allowed = direct_allowed_entity_set () in - let entity_allowed = - match allowed with - | Some allowed -> - fun entity_id -> - entity_id >= 0 - && entity_id < Bytes.length allowed - && Bytes.get allowed entity_id = '\001' - && matches_required entity_id - | None -> entity_allowed - in - if is_ref_attr source_db scan_attr then - let rec collect acc seq = - match seq () with - | Seq.Nil -> List.rev acc - | Seq.Cons (scan_datom, rest) -> - if entity_allowed scan_datom.e then - collect ([ result_of_pattern_position scan_datom 2; Result_entity scan_datom.e ] :: acc) rest - else - collect acc rest - in - collect [] scan_datoms - else - let rec collect acc seq = - match seq () with - | Seq.Nil -> List.rev acc - | Seq.Cons (scan_datom, rest) -> - if entity_allowed scan_datom.e then - collect ([ Result_value scan_datom.v; Result_entity scan_datom.e ] :: acc) rest - else - collect acc rest - in - collect [] scan_datoms - | _ -> - let value_tables = - remaining_value_vars - |> List.map (fun (value_var, attr) -> - let values = Array.make (source_db.max_datom_e + 1) None in - source_context.pattern_datoms source_db (QVar e_var) (QAttr attr) QWildcard None - |> Seq.iter (fun datom -> - if datom.e >= 0 && datom.e < Array.length values then - values.(datom.e) <- Some (result_of_pattern_position datom 2)); - value_var, values) - in - let value_for entity_id values = - if entity_id >= 0 && entity_id < Array.length values then values.(entity_id) else None - in - let scan_datoms = source_context.pattern_datoms source_db (QVar e_var) (QAttr scan_attr) QWildcard None in - if List.for_all (fun (_, attr) -> direct_attr attr) value_var_patterns then ( - let slot_of_attr attr = - if attr = e_var then - Some `Entity - else if attr = scan_value_var then - Some (if is_ref_attr source_db scan_attr then `Scan_ref else `Scan_value) - else - Option.map - (fun values -> `Value_table values) - (List.assoc_opt attr value_tables) - in - let slots = - attrs - |> List.fold_left - (fun slots attr -> - match slots with - | None -> None - | Some slots -> Option.map (fun slot -> slot :: slots) (slot_of_attr attr)) - (Some []) - |> Option.map List.rev - in - match slots with - | None -> [] - | Some slots -> - let value_of_slot scan_datom = function - | `Entity -> Some (Result_entity scan_datom.e) - | `Scan_value -> - (match scan_datom.v with - | Ref _ -> Some (result_of_pattern_position scan_datom 2) - | _ -> Some (Result_value scan_datom.v)) - | `Scan_ref -> Some (result_of_pattern_position scan_datom 2) - | `Value_table values -> value_for scan_datom.e values - in - let build_row scan_datom = - match slots with - | [ first; second ] -> - let* first = value_of_slot scan_datom first in - let* second = value_of_slot scan_datom second in - Some [ first; second ] - | [ first; second; third ] -> - let* first = value_of_slot scan_datom first in - let* second = value_of_slot scan_datom second in - let* third = value_of_slot scan_datom third in - Some [ first; second; third ] - | [ first; second; third; fourth ] -> - let* first = value_of_slot scan_datom first in - let* second = value_of_slot scan_datom second in - let* third = value_of_slot scan_datom third in - let* fourth = value_of_slot scan_datom fourth in - Some [ first; second; third; fourth ] - | _ -> - slots - |> List.fold_left - (fun row slot -> - match row with - | None -> None - | Some row -> Option.map (fun value -> value :: row) (value_of_slot scan_datom slot)) - (Some []) - |> Option.map List.rev - in - let rec collect acc seq = - match seq () with - | Seq.Nil -> List.rev acc - | Seq.Cons (scan_datom, rest) -> - if entity_allowed scan_datom.e then - match build_row scan_datom with - | Some row -> collect (row :: acc) rest - | None -> collect acc rest - else - collect acc rest - in - collect [] scan_datoms) - else - scan_datoms - |> Seq.filter_map (fun scan_datom -> - if not (entity_allowed scan_datom.e) then - None - else - let binding = - (scan_value_var, result_of_pattern_position scan_datom 2) - :: [ e_var, Result_entity scan_datom.e ] - in - let* binding = - value_tables - |> List.fold_left - (fun binding (value_var, values) -> - match binding with - | None -> None - | Some binding -> - value_for scan_datom.e values - |> Option.map (fun value -> (value_var, value) :: binding)) - (Some binding) - in - binding_row attrs binding) - |> List.of_seq - in - let rows = - match value_var_patterns with - | (scan_value_var, scan_attr) :: remaining_value_vars - when direct_attr scan_attr - && List.for_all - (fun (_, attr) -> direct_attr attr && cardinality_one source_db attr) - remaining_value_vars -> - rows_from_cardinality_one_value_scan scan_value_var scan_attr remaining_value_vars - | (scan_value_var, scan_attr) :: remaining_value_vars - when List.for_all (fun (_, attr) -> cardinality_one source_db attr) value_var_patterns -> - rows_from_cardinality_one_value_scan scan_value_var scan_attr remaining_value_vars - | _ :: _ when List.for_all (fun (_, attr) -> cardinality_one source_db attr) value_var_patterns -> - rows_from_cardinality_one_candidates value_var_patterns - | _ -> - candidate_entities () - |> List.sort_uniq compare - |> List.concat_map (fun entity_id -> - if not (entity_allowed entity_id) then - [] - else - let bindings = - value_var_patterns - |> List.fold_left - (fun bindings value_pattern -> - match bindings with - | [] -> [] - | bindings -> extend_bindings bindings value_pattern) - [ [ e_var, Result_entity entity_id ] ] - in - bindings |> List.filter_map (binding_row attrs)) - in - let unique_rows = - source_db.duplicate_datoms = [] - && List.mem e_var attrs - && List.for_all (fun (_, attr) -> cardinality_one source_db attr) value_var_patterns - in - let relation = { attrs; rows; lookup_vars; unique_rows } in - Some - (List.fold_left - (fun relation -> function - | ComparisonPredicate (predicate, left_term, right_term) -> - filter_relation_comparison db relation predicate left_term right_term - | _ -> relation) - relation - relation_comparisons) + Some { attrs; rows; lookup_vars; unique_rows } | _ -> None let relation_bindings relation = @@ -1560,7 +1641,30 @@ end) = struct in promote [] clauses + let rec clauses_contain_not = function + | [] -> false + | (Not _ | NotJoin _ | SourceNot _ | SourceNotJoin _) :: _ -> true + | Or branches :: rest | OrJoin (_, branches) :: rest | OrJoinRequired (_, _, branches) :: rest -> + List.exists clauses_contain_not branches || clauses_contain_not rest + | SourceOr (_, branches) :: rest + | SourceOrJoin (_, _, branches) :: rest + | SourceOrJoinRequired (_, _, _, branches) :: rest -> + List.exists clauses_contain_not branches || clauses_contain_not rest + | _ :: rest -> clauses_contain_not rest + + let plan_ordered_clauses ~max_datom_e clauses = + (* Keep source order when any NOT is present so DataScript unbound-var errors + stay observable; relational fallback / same-entity fusion still apply. *) + if clauses_contain_not clauses then + clauses + else + match Query_plan.compile ~max_datom_e clauses with + | Some plan when Query_plan.plan_is_executable plan -> Query_plan.clauses_of_plan plan + | _ -> clauses + let rec eval_relation_from_relation db sources default_source relation clauses = + (* Planner orders eligible clauses; relational fallback keeps source order. *) + let clauses = plan_ordered_clauses ~max_datom_e:db.max_datom_e clauses in let clauses = promote_attr_binding_clauses clauses in let rec apply relation = function | [] -> Some relation @@ -1944,6 +2048,116 @@ end) = struct let relation_only_clauses clauses = List.for_all relation_prefix_clause clauses + let subst_rule_term mapping = function + | QVar name -> (match List.assoc_opt name mapping with Some term -> term | None -> QVar name) + | term -> term + + let subst_rule_clause mapping = function + | Pattern (e, a, v) -> + Some (Pattern (subst_rule_term mapping e, subst_rule_term mapping a, subst_rule_term mapping v)) + | PatternTx (e, a, v, tx) -> + Some + (PatternTx + ( subst_rule_term mapping e + , subst_rule_term mapping a + , subst_rule_term mapping v + , subst_rule_term mapping tx )) + | PatternTxOp (e, a, v, tx, op) -> + Some + (PatternTxOp + ( subst_rule_term mapping e + , subst_rule_term mapping a + , subst_rule_term mapping v + , subst_rule_term mapping tx + , subst_rule_term mapping op )) + | Not [ Pattern (e, a, v) ] -> + Some (Not [ Pattern (subst_rule_term mapping e, subst_rule_term mapping a, subst_rule_term mapping v) ]) + | NotJoin (vars, clauses) -> + let clauses = + clauses + |> List.map (function + | Pattern (e, a, v) -> + Some (Pattern (subst_rule_term mapping e, subst_rule_term mapping a, subst_rule_term mapping v)) + | _ -> None) + in + if List.for_all Option.is_some clauses then + Some (NotJoin (vars, List.filter_map Fun.id clauses)) + else + None + | ComparisonPredicate (predicate, left, right) -> + Some + (ComparisonPredicate + (predicate, subst_rule_term mapping left, subst_rule_term mapping right)) + | _ -> None + + (** Inline a non-recursive rule whose body is relation-only patterns/not. *) + let inline_rule_clauses rules name terms = + let arity = List.length terms in + let candidates = + List.filter (fun rule -> rule.rule_name = name && List.length rule.rule_params = arity) rules + in + match candidates with + | [ { rule_params; rule_body; _ } ] + when rule_body <> [] + && List.for_all relation_prefix_clause rule_body + && not (List.exists Query.has_rule_clause rule_body) -> + let mapping = List.combine rule_params terms in + let inlined = List.map (subst_rule_clause mapping) rule_body in + if List.for_all Option.is_some inlined then Some (List.filter_map Fun.id inlined) else None + | _ -> None + + let expand_inline_rules rules clauses = + let rec expand acc = function + | [] -> Some (List.rev acc) + | Rule (name, terms) :: rest -> + (match inline_rule_clauses rules name terms with + | Some inlined -> expand acc (inlined @ rest) + | None -> None) + | SourceRule (source_name, name, terms) :: rest -> + (match inline_rule_clauses rules name terms with + | Some inlined -> + let sourced = + List.map + (function + | Pattern (e, a, v) -> SourcePattern (source_name, e, a, v) + | PatternTx (e, a, v, tx) -> SourcePatternTx (source_name, e, a, v, tx) + | PatternTxOp (e, a, v, tx, op) -> SourcePatternTxOp (source_name, e, a, v, tx, op) + | Not clauses -> SourceNot (source_name, clauses) + | NotJoin (vars, clauses) -> SourceNotJoin (source_name, vars, clauses) + | clause -> SourceClause (source_name, clause)) + inlined + in + expand acc (sourced @ rest) + | None -> None) + | clause :: rest -> expand (clause :: acc) rest + in + if rules = [] then Some clauses else expand [] clauses + + let relation_query_clauses clauses = + relation_only_clauses clauses + || + match clauses with + | [ Or branches ] -> List.for_all (List.for_all relation_prefix_clause) branches + | [ SourceOr (_, branches) ] -> List.for_all (List.for_all relation_prefix_clause) branches + | [ OrJoin (_, branches) ] -> List.for_all (List.for_all relation_prefix_clause) branches + | [ SourceOrJoin (_, _, branches) ] -> List.for_all (List.for_all relation_prefix_clause) branches + | _ -> + let rec only_patterns_comparisons_and_one_or_join seen_or_join = function + | [] -> seen_or_join + | (Pattern _ | PatternTx _ | PatternTxOp _ + | SourcePattern _ | SourcePatternTx _ | SourcePatternTxOp _ + | ComparisonPredicate _) :: rest -> + only_patterns_comparisons_and_one_or_join seen_or_join rest + | OrJoin (_, branches) :: rest + when (not seen_or_join) && List.for_all (List.for_all relation_prefix_clause) branches -> + only_patterns_comparisons_and_one_or_join true rest + | SourceOrJoin (_, _, branches) :: rest + when (not seen_or_join) && List.for_all (List.for_all relation_prefix_clause) branches -> + only_patterns_comparisons_and_one_or_join true rest + | _ -> false + in + only_patterns_comparisons_and_one_or_join false clauses + let relation_has_comparison clauses = List.exists (function @@ -2025,9 +2239,44 @@ end) = struct |> List.exists (fun var -> List.mem var binding_vars) | _ -> false) - let eval_relation_from_empty db sources default_source clauses = - let clauses = promote_attr_binding_clauses clauses in - let rec apply relation = function + let relation_value_vars_covered relation clauses = + let value_vars = + clauses + |> List.filter_map (function + | Pattern (QVar entity_var, QAttr _, QVar value_var) when value_var <> entity_var -> Some value_var + | _ -> None) + in + List.for_all (fun var -> List.mem var relation.attrs) value_vars + + let same_entity_fused_relation db default_source clauses = + match relation_of_same_entity_patterns db default_source clauses with + | Some relation + when (relation.rows <> [] || not (relation_prefix_has_multiple_clauses clauses)) + && relation_value_vars_covered relation clauses -> + Some relation + | _ -> None + + let relation_of_single_aevt_var_var _db default_source clauses = + match clauses, default_source with + | [ Pattern (QVar e_var, QAttr attr, QVar v_var) ], Db_source source_db when e_var <> v_var -> + relation_of_aevt_var_var_pattern source_db e_var attr v_var + | _ -> None + + let rec eval_relation_from_empty db sources default_source clauses = + let fused_empty_relation clauses = + match same_entity_fused_relation db default_source clauses with + | Some _ as relation -> relation + | None -> ( + match relation_of_single_aevt_var_var db default_source clauses with + | Some _ as relation -> relation + | None -> ( + match relation_of_cross_entity_value_join db default_source clauses with + | Some relation when relation_value_vars_covered relation clauses -> Some relation + | _ -> eval_selective_or_join_value_pattern db sources default_source clauses)) + in + let run_interpreter clauses = + let clauses = promote_attr_binding_clauses clauses in + let rec apply relation = function | [] -> Some relation | _ when relation.rows = [] -> Some { relation with rows = []; unique_rows = true } | Pattern (e_term, a_term, v_term) :: ComparisonPredicate (predicate, left_term, right_term) :: rest -> @@ -2151,22 +2400,207 @@ end) = struct let* relation = anti_join relation excluded in apply relation rest | _ -> None + in + apply { attrs = []; rows = [ [] ]; lookup_vars = []; unique_rows = true } clauses in - match relation_of_same_entity_patterns db default_source clauses with + match fused_empty_relation clauses with | Some relation -> Some relation - | None -> apply { attrs = []; rows = [ [] ]; lookup_vars = []; unique_rows = true } clauses + | None -> ( + let planned = plan_ordered_clauses ~max_datom_e:db.max_datom_e clauses in + match fused_empty_relation planned with + | Some relation -> Some relation + | None -> ( + match planned with + | [ Or branches ] -> eval_or_branch_relations db sources default_source branches + | [ SourceOr (source_name, branches) ] -> + let default_source = source db sources source_name in + eval_or_branch_relations db sources default_source branches + | [ OrJoin (vars, branches) ] -> + Query.ensure_or_join_branches_cover_listed_vars [] vars branches; + eval_or_join_relations db sources default_source vars branches + | [ SourceOrJoin (source_name, vars, branches) ] -> + let default_source = source db sources source_name in + Query.ensure_or_join_branches_cover_listed_vars [] vars branches; + eval_or_join_relations db sources default_source vars branches + | _ -> run_interpreter planned)) + + and or_join_constant_entity_branch e_var = function + | [ Pattern (QVar branch_e, QAttr _, QValue _) ] when branch_e = e_var -> true + | _ -> false + + and eval_selective_or_join_value_pattern _db _sources default_source clauses = + let try_shape e_var attr value_term branches = + match value_term, default_source with + | QVar value_var, Db_source source_db + when value_var <> e_var && List.for_all (or_join_constant_entity_branch e_var) branches -> + let branch_constants = + branches + |> List.filter_map (function + | [ Pattern (QVar branch_entity, QAttr branch_attr, QValue branch_value) ] + when branch_entity = e_var && branch_attr <> attr -> + Some (branch_attr, branch_value) + | _ -> None) + in + if branch_constants = [] then + None + else + let entity_ids = + branch_constants + |> List.concat_map (fun (branch_attr, branch_value) -> + match entity_ids_by_attr_value source_db branch_attr branch_value with + | Some ids -> ids + | None -> + datoms_by_attr_value source_db branch_attr branch_value + |> List.map (fun datom -> datom.e)) + |> List.sort_uniq compare + in + let attrs = unique_vars [ QVar e_var; QAttr attr; QVar value_var ] in + let lookup_vars = relation_lookup_vars source_db [ QVar e_var; QWildcard; QWildcard ] in + if entity_ids = [] then + Some { attrs; rows = []; lookup_vars; unique_rows = true } + else + let rows = + entity_ids + |> List.filter_map (fun entity_id -> + match find_entity_attr_value source_db entity_id attr with + | None -> None + | Some value -> + match attrs with + | [ left; right ] when left = e_var && right = value_var -> + Some [ Result_entity entity_id; value ] + | [ left; right ] when left = value_var && right = e_var -> + Some [ value; Result_entity entity_id ] + | _ -> + binding_row attrs [ e_var, Result_entity entity_id; value_var, value ]) + in + Some { attrs; rows; lookup_vars; unique_rows = true } + | _ -> None + in + match clauses with + | Pattern (QVar e_var, QAttr attr, value_term) :: OrJoin ([ join_e ], branches) :: [] + when e_var = join_e -> + try_shape e_var attr value_term branches + | OrJoin ([ join_e ], branches) :: Pattern (QVar e_var, QAttr attr, value_term) :: [] + when e_var = join_e -> + try_shape e_var attr value_term branches + | _ -> None + + and eval_or_join_relations db sources default_source vars branches = + match + branches + |> List.filter_map (fun branch_clauses -> + eval_relation_from_empty db sources default_source branch_clauses + |> Option.map (project_relation vars)) + with + | [] -> Some { attrs = vars; rows = []; lookup_vars = []; unique_rows = true } + | first :: rest -> + let rows = + List.fold_left + (fun acc rel -> List.rev_append rel.rows acc) + (List.rev first.rows) + rest + |> List.rev + in + let lookup_vars = + List.fold_left + (fun lookup_vars rel -> + List.fold_left + (fun lookup_vars ((var, _) as lookup_var) -> + if List.mem_assoc var lookup_vars then lookup_vars else lookup_var :: lookup_vars) + lookup_vars + rel.lookup_vars) + first.lookup_vars + rest + in + let unique_rows = + List.fold_left (fun unique rel -> unique && rel.unique_rows) first.unique_rows rest + in + Some { attrs = vars; rows; lookup_vars; unique_rows } + + and eval_or_branch_relations ?(require_matching_vars = true) db sources default_source branches = + if require_matching_vars then + Query.ensure_or_branch_vars_match ~value_to_string:edn_string_of_value [] branches; + match + branches + |> List.filter_map (fun branch_clauses -> eval_relation_from_empty db sources default_source branch_clauses) + with + | [] -> Some { attrs = []; rows = []; lookup_vars = []; unique_rows = true } + | first :: rest -> + let rows = + List.fold_left + (fun acc rel -> + if rel.attrs <> first.attrs then acc else List.rev_append rel.rows acc) + (List.rev first.rows) + rest + |> List.rev + in + let lookup_vars = + List.fold_left + (fun lookup_vars rel -> + List.fold_left + (fun lookup_vars ((var, _) as lookup_var) -> + if List.mem_assoc var lookup_vars then lookup_vars else lookup_var :: lookup_vars) + lookup_vars + rel.lookup_vars) + first.lookup_vars + rest + in + let unique_rows = + List.fold_left (fun unique rel -> unique && rel.unique_rows) first.unique_rows rest + in + Some { attrs = first.attrs; rows; lookup_vars; unique_rows } let eval_relation_rows db sources rules bindings clauses = let default_source = source db sources "$" in - match rules, bindings, relation_only_clauses clauses with - | [], [ [] ], true -> - eval_relation_from_empty db sources default_source clauses - |> Option.map (fun relation -> relation.attrs, relation.rows, relation.unique_rows) - | [], [ binding ], true -> - let clauses = List.map (bound_relation_clause binding) clauses in - eval_relation_from_empty db sources default_source clauses - |> Option.map (fun relation -> relation.attrs, relation.rows, relation.unique_rows) - | _ -> None + let try_single_pattern_rule_rows = + match bindings, clauses with + | [ [] ], [ Rule (name, terms) ] -> ( + match inline_rule_clauses rules name terms with + | Some [ Pattern (QVar _, QAttr attr, QVar _) ] -> ( + match default_source with + | Db_source source_db -> ( + match aevt_attr_array source_db attr with + | None -> None + | Some arr -> + let attrs = List.map (function QVar var -> var | _ -> "") terms in + let rows = ref [] in + let collect datom = + match datom.v with + | Ref target -> rows := [ Result_entity datom.e; Result_entity target ] :: !rows + | _ -> () + in + for i = Array.length arr - 1 downto 0 do + collect arr.(i) + done; + (match aevt_duplicate_datoms source_db attr with + | [] -> () + | duplicates -> List.iter collect duplicates); + Some (attrs, !rows, true)) + | _ -> None) + | _ -> None) + | _ -> None + in + match try_single_pattern_rule_rows with + | Some result -> Some result + | None -> ( + let continue () = + match if rules = [] then Some clauses else expand_inline_rules rules clauses with + | None -> None + | Some clauses -> + (match bindings, relation_query_clauses clauses with + | [ [] ], true -> ( + match same_entity_fused_relation db default_source clauses with + | Some relation -> Some (relation.attrs, relation.rows, relation.unique_rows) + | None -> + eval_relation_from_empty db sources default_source clauses + |> Option.map (fun relation -> relation.attrs, relation.rows, relation.unique_rows)) + | [ binding ], true -> + let clauses = List.map (bound_relation_clause binding) clauses in + eval_relation_from_empty db sources default_source clauses + |> Option.map (fun relation -> relation.attrs, relation.rows, relation.unique_rows) + | _ -> None) + in + continue ()) let eval_relation_clauses ?(allow_initial_bindings = false) db sources default_source bindings clauses = let bound_relation_pattern_terms = function diff --git a/impl/serialize.ml b/impl/serialize.ml index 06dd4fc..b034022 100644 --- a/impl/serialize.ml +++ b/impl/serialize.ml @@ -1,95 +1,52 @@ open Datascript_types -module PSet = Persistent_sorted_set +module Index = Index +module Schema = Schema type context = { next_db_uid : unit -> int ; validate_schema : schema -> schema ; normalize_datom_for_schema : schema -> datom -> datom - ; refresh_db_indexes : db -> db + ; with_datoms : db -> datom list -> db } let serializable db = { serializable_schema = db.schema ; serializable_datoms = - PSet.to_list db.eavt_index @ db.duplicate_datoms |> List.sort (Util.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 } -let empty_index index = - PSet.empty_by ~cmp:(Util.compare_datom index) () - -let index_from_datoms index datoms = - let cmp = Util.compare_datom index in - let items = Array.of_list datoms in - Array.sort cmp items; - PSet.of_sorted_array_by ~cmp items - -let duplicate_datoms datoms = - let datoms = List.sort (Util.compare_datom Eavt) datoms in - let rec loop previous duplicates = function - | [] -> List.rev duplicates - | datom :: rest -> - (match previous with - | Some previous when Util.compare_datom Eavt previous datom = 0 -> - loop (Some datom) (datom :: duplicates) rest - | _ -> loop (Some datom) duplicates rest) - in - loop None [] datoms - -let duplicate_aevt_datoms duplicate_datoms = - List.sort (Util.compare_datom Aevt) duplicate_datoms - -let duplicate_avet_datoms schema duplicate_datoms = - duplicate_datoms - |> List.filter (fun datom -> Schema.schema_attr_is_avet_accessible schema datom.a) - |> List.sort (Util.compare_datom Avet) - -let duplicate_eavt_by_entity duplicate_datoms = - let table = Hashtbl.create 1024 in - List.iter - (fun datom -> - let existing = Option.value (Hashtbl.find_opt table datom.e) ~default:[] in - Hashtbl.replace table datom.e (datom :: existing)) - duplicate_datoms; - Hashtbl.iter (fun entity_id datoms -> Hashtbl.replace table entity_id (List.rev datoms)) table; - table - -let duplicate_datoms_by_attr duplicate_datoms = - let table = Hashtbl.create 1024 in - List.iter - (fun datom -> - let existing = Option.value (Hashtbl.find_opt table datom.a) ~default:[] in - Hashtbl.replace table datom.a (datom :: existing)) - duplicate_datoms; - Hashtbl.iter (fun attr datoms -> Hashtbl.replace table attr (List.rev datoms)) table; - table - let from_serializable context snapshot = let schema = context.validate_schema snapshot.serializable_schema in let datoms = List.map (context.normalize_datom_for_schema schema) snapshot.serializable_datoms in - let duplicate_datoms = duplicate_datoms datoms in - let duplicate_aevt_datoms = duplicate_aevt_datoms duplicate_datoms in - let duplicate_avet_datoms = duplicate_avet_datoms schema duplicate_datoms in + let lmdb, storage_ref = Index.create_lmdb None in { db_uid = context.next_db_uid () ; schema - ; eavt_index = index_from_datoms Eavt datoms - ; aevt_index = empty_index Aevt - ; avet_index = empty_index Avet + ; eavt_index = Index.empty Eavt lmdb + ; aevt_index = Index.empty Aevt lmdb + ; avet_index = Index.empty Avet lmdb ; aevt_by_attr = Hashtbl.create 0 ; avet_by_attr = Hashtbl.create 0 - ; duplicate_datoms - ; duplicate_aevt_datoms - ; duplicate_avet_datoms - ; duplicate_eavt_by_entity = duplicate_eavt_by_entity duplicate_datoms - ; duplicate_aevt_by_attr = duplicate_datoms_by_attr duplicate_aevt_datoms - ; duplicate_avet_by_attr = duplicate_datoms_by_attr duplicate_avet_datoms + ; avet_entities_by_attr_value = Hashtbl.create 0 + ; duplicate_datoms = [] + ; duplicate_aevt_datoms = [] + ; duplicate_avet_datoms = [] + ; duplicate_eavt_by_entity = Hashtbl.create 0 + ; duplicate_aevt_by_attr = Hashtbl.create 0 + ; duplicate_avet_by_attr = Hashtbl.create 0 ; 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 = None + ; pending_datoms = [] + ; storage_ref ; tx_fns = [] } - |> context.refresh_db_indexes + |> fun db -> context.with_datoms db datoms diff --git a/impl/serialize.mli b/impl/serialize.mli index c071cbb..3dac898 100644 --- a/impl/serialize.mli +++ b/impl/serialize.mli @@ -4,7 +4,7 @@ type context = { next_db_uid : unit -> int ; validate_schema : schema -> schema ; normalize_datom_for_schema : schema -> datom -> datom - ; refresh_db_indexes : db -> db + ; with_datoms : db -> datom list -> db } val serializable : db -> serializable_db diff --git a/impl/storage.mli b/impl/storage.mli index f9020f7..11eb179 100644 --- a/impl/storage.mli +++ b/impl/storage.mli @@ -1,28 +1,14 @@ open Datascript_types -type tail_context = - { apply_group : db -> datom list -> db - } +type restore_context = { next_db_uid : unit -> int } -type restore_context = - { next_db_uid : unit -> int - ; db_with_tail : db -> datom list list -> db - } - -val root_address : storage_address -val tail_address : storage_address val memory_storage : unit -> storage -val file_storage : string -> storage +val benchmark_memory_storage : unit -> storage +val ensure_live : storage -> unit +val kind_of : storage -> storage_kind val store : ?storage:storage -> db -> unit -val store_tail : storage -> datom list list -> unit -val tail_compaction_threshold : int -val tail_datom_count : datom list list -> int val restore_root_snapshot : storage -> serializable_db option -val restore_tail_groups : storage -> datom list list -val db_with_tail : tail_context -> db -> datom list list -> db 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/storage_lmdb_impl.ml b/impl/storage_lmdb_impl.ml new file mode 100644 index 0000000..e089c51 --- /dev/null +++ b/impl/storage_lmdb_impl.ml @@ -0,0 +1,130 @@ +open Datascript_types + +module Index = Index + +type tail_context = + { apply_group : db -> datom list -> db + } + +type restore_context = { next_db_uid : unit -> int } + +let memory_storage = Datascript_storage_lmdb.memory_storage +let file_storage = Datascript_storage_lmdb.file_storage + +let store ?storage db = + match storage, db.storage_ref with + | Some storage, _ | None, Some storage -> + let lmdb = Datascript_storage_lmdb.lmdb storage in + Datascript_storage_lmdb.store_meta lmdb db + | None, None -> invalid_arg "db has no attached storage" + +let store_tail _storage _tail = () + +let tail_compaction_threshold = 0 +let tail_datom_count _tail = 0 + +let restore_tail_groups _storage = [] + +let restore_root_snapshot storage = + let lmdb = Datascript_storage_lmdb.lmdb storage in + let schema, max_eid, max_tx, duplicate_datoms = + Datascript_storage_lmdb.restore_meta lmdb + in + Some + { serializable_schema = schema + ; serializable_datoms = Index.to_list (Index.empty Eavt lmdb) @ duplicate_datoms + ; serializable_max_eid = max_eid + ; serializable_max_tx = max_tx + } + +let db_with_tail _context db tail = + List.fold_left + (fun db group -> + match group with + | [] -> db + | _ -> Db.refresh_indexes_with_tx_data db group) + db + tail + +let restore context storage = + let lmdb = Datascript_storage_lmdb.lmdb storage in + let schema, max_eid, max_tx, duplicate_datoms = + Datascript_storage_lmdb.restore_meta lmdb + in + let schema = Schema.validate_schema schema in + let duplicate_eavt_by_entity = + let table = Hashtbl.create 1024 in + List.iter + (fun datom -> + let existing = Option.value (Hashtbl.find_opt table datom.e) ~default:[] in + Hashtbl.replace table datom.e (datom :: existing)) + duplicate_datoms; + Hashtbl.iter (fun entity_id datoms -> Hashtbl.replace table entity_id (List.rev datoms)) table; + table + in + let duplicate_datoms_by_attr duplicate_datoms = + let table = Hashtbl.create 1024 in + List.iter + (fun datom -> + let existing = Option.value (Hashtbl.find_opt table datom.a) ~default:[] in + Hashtbl.replace table datom.a (datom :: existing)) + duplicate_datoms; + Hashtbl.iter (fun attr datoms -> Hashtbl.replace table attr (List.rev datoms)) table; + table + in + let duplicate_aevt_datoms = List.sort (Util.compare_datom Aevt) duplicate_datoms in + let duplicate_avet_datoms = + duplicate_datoms + |> List.filter (fun datom -> Schema.schema_attr_is_avet_accessible schema datom.a) + |> List.sort (Util.compare_datom Avet) + in + Some + { db_uid = context.next_db_uid () + ; schema + ; eavt_index = Index.empty Eavt lmdb + ; aevt_index = Index.empty Aevt lmdb + ; avet_index = Index.empty Avet lmdb + ; aevt_by_attr = Hashtbl.create 0 + ; avet_by_attr = Hashtbl.create 0 + ; avet_entities_by_attr_value = Hashtbl.create 0 + ; duplicate_datoms + ; duplicate_aevt_datoms + ; duplicate_avet_datoms + ; duplicate_eavt_by_entity + ; duplicate_aevt_by_attr = duplicate_datoms_by_attr duplicate_aevt_datoms + ; duplicate_avet_by_attr = duplicate_datoms_by_attr duplicate_avet_datoms + ; 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 + ; pending_datoms = [] + ; storage_ref = Some 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" + ; "storage", Bool (Option.is_some db.storage_ref) + ] + +let collect_garbage storage = + let lmdb = Datascript_storage_lmdb.lmdb storage in + Datascript_storage_lmdb.sync lmdb diff --git a/impl/storage.ml b/impl/storage_pss.ml similarity index 98% rename from impl/storage.ml rename to impl/storage_pss.ml index ade23e5..a221aa5 100644 --- a/impl/storage.ml +++ b/impl/storage_pss.ml @@ -253,6 +253,7 @@ let restore context storage = ; avet_index ; aevt_by_attr = Hashtbl.create 0 ; avet_by_attr = Hashtbl.create 0 + ; avet_entities_by_attr_value = Hashtbl.create 0 ; duplicate_datoms ; duplicate_aevt_datoms ; duplicate_avet_datoms @@ -262,7 +263,12 @@ 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 + ; pending_datoms = [] ; storage_ref = Some storage ; tx_fns = [] } diff --git a/impl/transact.ml b/impl/transact.ml index 9609225..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,17 +1567,18 @@ 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 + ; store_max_tx = !max_tx_seen ; tx_fns = !current_tx_fns } in ( (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 @@ -1548,11 +1588,13 @@ 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 - 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/impl/tx_visibility.ml b/impl/tx_visibility.ml new file mode 100644 index 0000000..30f0158 --- /dev/null +++ b/impl/tx_visibility.ml @@ -0,0 +1,113 @@ +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 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 + 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 + +(** Streaming cancel for ascending datom sequences (one-datom lookbehind). *) +let datoms_filter_seq seq = + let previous = ref None in + let seq_ref = ref seq in + let rec step () = + match !seq_ref () with + | Seq.Nil -> + (match !previous with + | Some d when d.added -> + previous := None; + Seq.Cons (d, fun () -> Seq.Nil) + | _ -> + previous := None; + Seq.Nil) + | Seq.Cons (d2, rest) -> + seq_ref := rest; + match !previous with + | None -> + previous := Some d2; + step () + | 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 ( + previous := None; + step ()) + else if same_eav && d1.tx = d2.tx && not d1.added && d2.added then ( + previous := None; + step ()) + else if not d2.added then ( + previous := Some d2; + if d1.added then Seq.Cons (d1, step) else step ()) + else ( + previous := Some d2; + if d1.added then Seq.Cons (d1, step) else step ()) + in + step + +let filter_seq schema bounds seq = + let visible = Seq.filter (visible_at_tx bounds) seq in + if bounds.history then + (* History views may keep retracted facts for non-noHistory attrs; materialize + so noHistory attrs still cancel while historical facts pass through. *) + let datoms = List.of_seq visible in + apply_view schema bounds datoms |> List.to_seq + else + datoms_filter_seq visible diff --git a/impl/tx_visibility.mli b/impl/tx_visibility.mli new file mode 100644 index 0000000..5a5fcd2 --- /dev/null +++ b/impl/tx_visibility.mli @@ -0,0 +1,19 @@ +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 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 : schema -> view_bounds -> datom Seq.t -> datom Seq.t diff --git a/impl/util.ml b/impl/util.ml index b0497da..3776793 100644 --- a/impl/util.ml +++ b/impl/util.ml @@ -53,306 +53,18 @@ and value_equal left right = | Ref_to left, Ref_to right -> entity_ref_equal left right | _ -> false -let split_keyword keyword = - match String.index_opt keyword '/' with - | None -> "", keyword - | Some index -> - let namespace = String.sub keyword 0 index in - let name = String.sub keyword (index + 1) (String.length keyword - index - 1) in - namespace, name - -let rec compare_list_items_with compare_item left right = - match left, right with - | [], [] -> 0 - | left :: left_rest, right :: right_rest -> - let comparison = compare_item left right in - if comparison <> 0 then comparison else compare_list_items_with compare_item left_rest right_rest - | [], _ | _, [] -> 0 - -let compare_list_with compare_item left right = - let length_comparison = compare (List.length left) (List.length right) in - if length_comparison <> 0 then length_comparison - else compare_list_items_with compare_item left right - -let compare_option_with compare_item left right = - match left, right with - | None, None -> 0 - | None, Some _ -> -1 - | Some _, None -> 1 - | Some left, Some right -> compare_item left right - -let i32 value = Int32.of_int value -let i32_to_int value = Int32.to_int value -let i32_add left right = Int32.add left right -let i32_mul left right = Int32.mul left right -let i32_xor left right = Int32.logxor left right -let i32_shift_left value bits = Int32.shift_left value bits -let i32_shift_right value bits = Int32.shift_right value bits -let i32_shift_right_logical value bits = Int32.shift_right_logical value bits - -let i32_rotate_left value bits = - Int32.logor (Int32.shift_left value bits) (Int32.shift_right_logical value (32 - bits)) - -let murmur3_mix_k1 value = - value - |> fun value -> i32_mul value (i32 (-862048943)) - |> fun value -> i32_rotate_left value 15 - |> fun value -> i32_mul value (i32 461845907) - -let murmur3_mix_h1 hash value = - i32_xor hash value - |> fun hash -> i32_rotate_left hash 13 - |> fun hash -> i32_add (i32_mul hash (i32 5)) (i32 (-430675100)) - -let murmur3_fmix hash length = - i32_xor hash (i32 length) - |> fun hash -> i32_xor hash (i32_shift_right_logical hash 16) - |> fun hash -> i32_mul hash (i32 (-2048144789)) - |> fun hash -> i32_xor hash (i32_shift_right_logical hash 13) - |> fun hash -> i32_mul hash (i32 (-1028477387)) - |> fun hash -> i32_xor hash (i32_shift_right_logical hash 16) - -let murmur3_hash_int value = - if value = 0 then 0 - else - value - |> i32 - |> murmur3_mix_k1 - |> murmur3_mix_h1 Int32.zero - |> fun hash -> murmur3_fmix hash 4 - |> i32_to_int - -let murmur3_hash_long value = - if value = Int64.zero then 0 - else - let low = Int64.to_int value |> i32 in - let high = Int64.shift_right_logical value 32 |> Int64.to_int |> i32 in - Int32.zero - |> fun hash -> murmur3_mix_h1 hash (murmur3_mix_k1 low) - |> fun hash -> murmur3_mix_h1 hash (murmur3_mix_k1 high) - |> fun hash -> murmur3_fmix hash 8 - |> i32_to_int - -let murmur3_hash_unencoded_chars text = - let hash = ref Int32.zero in - let index = ref 1 in - let length = String.length text in - while !index < length do - let code = - Char.code text.[!index - 1] lor (Char.code text.[!index] lsl 16) - in - hash := murmur3_mix_h1 !hash (murmur3_mix_k1 (i32 code)); - index := !index + 2 - done; - if length land 1 = 1 then - hash := i32_xor !hash (murmur3_mix_k1 (i32 (Char.code text.[length - 1]))); - murmur3_fmix !hash (2 * length) |> i32_to_int - -let java_string_hash text = - let hash = ref Int32.zero in - String.iter - (fun ch -> hash := i32_add (i32_mul !hash (i32 31)) (i32 (Char.code ch))) - text; - i32_to_int !hash - -let hex_value = function - | '0' .. '9' as ch -> Char.code ch - Char.code '0' - | 'a' .. 'f' as ch -> 10 + Char.code ch - Char.code 'a' - | 'A' .. 'F' as ch -> 10 + Char.code ch - Char.code 'A' - | _ -> invalid_arg "invalid UUID hex digit" - -let uuid_halves uuid = - let digits = - uuid - |> String.to_seq - |> Seq.filter (( <> ) '-') - |> List.of_seq - in - if List.length digits <> 32 then invalid_arg ("invalid UUID: " ^ uuid); - let take_hex count digits = - let rec loop acc remaining rest = - if remaining = 0 then acc, rest - else - match rest with - | [] -> invalid_arg ("invalid UUID: " ^ uuid) - | ch :: rest -> - loop - (Int64.logor (Int64.shift_left acc 4) (Int64.of_int (hex_value ch))) - (remaining - 1) - rest - in - loop Int64.zero count digits - in - let most, rest = take_hex 16 digits in - let least, _ = take_hex 16 rest in - most, least - -let int64_low_i32 value = - Int64.logand value 0xffffffffL |> Int64.to_int |> i32 - -let int64_high_i32 value = - Int64.shift_right_logical value 32 |> int64_low_i32 - -let java_uuid_hash uuid = - let most, least = uuid_halves uuid in - i32_xor - (i32_xor (int64_high_i32 most) (int64_low_i32 most)) - (i32_xor (int64_high_i32 least) (int64_low_i32 least)) - |> i32_to_int - -let clojure_hash_combine seed hash = - i32_xor - (i32 seed) - (i32_add - (i32_add (i32 hash) (i32 (-1640531527))) - (i32_add (i32_shift_left (i32 seed) 6) (i32_shift_right (i32 seed) 2))) - |> i32_to_int - -let clojure_symbol_hash symbol = - let namespace, name = split_keyword symbol in - let namespace_hash = if namespace = "" then 0 else java_string_hash namespace in - clojure_hash_combine (murmur3_hash_unencoded_chars name) namespace_hash - -let clojure_keyword_hash name = - i32_add (i32 (clojure_symbol_hash name)) (i32 (-1640531527)) |> i32_to_int - -let murmur3_mix_coll_hash hash count = - hash - |> i32 - |> murmur3_mix_k1 - |> murmur3_mix_h1 Int32.zero - |> fun hash -> murmur3_fmix hash count - |> i32_to_int - -let murmur3_hash_ordered hashes = - let count, hash = - List.fold_left - (fun (count, hash) value_hash -> - count + 1, i32_add (i32_mul (i32 31) hash) (i32 value_hash)) - (0, i32 1) - hashes - in - murmur3_mix_coll_hash (i32_to_int hash) count - -let murmur3_hash_unordered hashes = - let count, hash = - List.fold_left - (fun (count, hash) value_hash -> count + 1, i32_add hash (i32 value_hash)) - (0, Int32.zero) - hashes - in - murmur3_mix_coll_hash (i32_to_int hash) count - -let rec clojure_hasheq = function - | Nil -> 0 - | Bool true -> 1231 - | Bool false -> 1237 - | Int value -> murmur3_hash_long (Int64.of_int value) - | Float value -> Hashtbl.hash value - | String value -> murmur3_hash_int (java_string_hash value) - | Symbol value -> clojure_symbol_hash value - | Keyword value -> clojure_keyword_hash value - | List values | Vector values -> murmur3_hash_ordered (List.map clojure_hasheq values) - | Set values -> murmur3_hash_unordered (List.map clojure_hasheq values) - | Map entries -> - entries - |> List.map (fun (key, value) -> murmur3_hash_ordered [ clojure_hasheq key; clojure_hasheq value ]) - |> murmur3_hash_unordered - | Tuple values -> - values - |> List.map (function None -> 0 | Some value -> clojure_hasheq value) - |> murmur3_hash_ordered - | Ref value -> murmur3_hash_long (Int64.of_int value) - | Uuid value -> java_uuid_hash value - | Instant value -> murmur3_hash_long (Int64.of_int value) - | Regex value -> Hashtbl.hash value - | TxRef -> Hashtbl.hash TxRef - | Ref_to value -> Hashtbl.hash (Ref_to value) - -let value_type_rank = function - | Nil -> 0 - | Keyword _ -> 1 - | Symbol _ -> 2 - | Map _ -> 3 - | Set _ -> 4 - | List _ -> 5 - | Vector _ -> 6 - | Tuple _ -> 7 - | Bool _ -> 8 - | Int _ | Float _ | Ref _ -> 9 - | String _ -> 10 - | Regex _ -> 11 - | Instant _ -> 12 - | Uuid _ -> 13 - | TxRef -> 14 - | Ref_to _ -> 15 - -let rec compare_value left right = - match left, right with - | Int left, Int right -> compare left right - | Float left, Float right -> compare left right - | Int left, Float right -> compare (float_of_int left) right - | Float left, Int right -> compare left (float_of_int right) - | Ref left, Ref right -> compare left right - | Int left, Ref right -> compare left right - | Ref left, Int right -> compare left right - | Float left, Ref right -> compare left (float_of_int right) - | Ref left, Float right -> compare (float_of_int left) right - | String left, String right -> compare left right - | Symbol left, Symbol right -> compare (split_keyword left) (split_keyword right) - | Bool left, Bool right -> compare left right - | Uuid left, Uuid right -> compare left right - | Instant left, Instant right -> compare left right - | Regex left, Regex right -> compare left right - | Nil, Nil -> 0 - | Keyword left, Keyword right -> compare (split_keyword left) (split_keyword right) - | List left, List right -> compare_list_with compare_value left right - | Vector left, Vector right -> compare_list_with compare_value left right - | List left, Tuple right -> - compare_list_with (compare_option_with compare_value) (List.map (fun value -> Some value) left) right - | Set _, Set _ -> compare (clojure_hasheq left) (clojure_hasheq right) - | Map _, Map _ -> compare (clojure_hasheq left) (clojure_hasheq right) - | Tuple left, Tuple right -> compare_list_with (compare_option_with compare_value) left right - | Tuple left, List right -> - compare_list_with (compare_option_with compare_value) left (List.map (fun value -> Some value) right) - | _ -> - let rank_comparison = compare (value_type_rank left) (value_type_rank right) in - if rank_comparison <> 0 then rank_comparison else compare left right - -and compare_map_entry (left_key, left_value) (right_key, right_value) = - let comparison = compare_value left_key right_key in - if comparison <> 0 then comparison else compare_value left_value right_value +let compare_list_with = Datascript_types.Compare.compare_list_with +let compare_option_with = Datascript_types.Compare.compare_option_with +let split_keyword = Datascript_types.Compare.split_keyword +let compare_value = Datascript_types.Compare.compare_value +let compare_datom = Datascript_types.Compare.compare_datom +let compare_map_entry = Datascript_types.Compare.compare_map_entry let first_nonzero comparisons = List.find_opt (( <> ) 0) comparisons |> Option.value ~default:0 -let first_nonzero4 first second third fourth = - if first <> 0 then first - else if second <> 0 then second - else if third <> 0 then third - else fourth - -let compare_datom index left right = - 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) - | Aevt -> - 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) +let first_nonzero4 = Datascript_types.Compare.first_nonzero4 let rec normalize_value = function | List values -> List (List.map normalize_value values) diff --git a/impl/util.mli b/impl/util.mli index b09ff8b..04bc8a4 100644 --- a/impl/util.mli +++ b/impl/util.mli @@ -8,6 +8,7 @@ val compare_list_with : ('a -> 'a -> int) -> 'a list -> 'a list -> int val compare_option_with : ('a -> 'a -> int) -> 'a option -> 'a option -> int val compare_value : value -> value -> int val first_nonzero : int list -> int +val first_nonzero4 : int -> int -> int -> int -> int val compare_datom : index -> datom -> datom -> int val normalize_value : value -> value val normalize_datom_value : datom -> datom 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_index_codec.ml b/lmdb/datascript_index_codec.ml new file mode 100644 index 0000000..aa465d4 --- /dev/null +++ b/lmdb/datascript_index_codec.ml @@ -0,0 +1,361 @@ +open Datascript_types + +let value_payload_cache = Hashtbl.create 256 + +let int32_be value = + let value = Int32.of_int value in + String.init 4 (fun index -> + let shift = (3 - index) * 8 in + Char.chr (Int32.to_int (Int32.shift_right_logical value shift) land 0xff)) + +let int32_of_be bytes = + if String.length bytes <> 4 then invalid_arg "invalid int32 key segment"; + let byte index = Char.code bytes.[index] in + Int32.of_int + ((byte 0 lsl 24) lor (byte 1 lsl 16) lor (byte 2 lsl 8) lor byte 3) + |> Int32.to_int + +let int64_be_int64 value = + String.init 8 (fun index -> + let shift = (7 - index) * 8 in + Char.chr (Int64.to_int (Int64.shift_right_logical value shift) land 0xff)) + +let int64_of_be bytes = + if String.length bytes <> 8 then invalid_arg "invalid int64 key segment"; + let byte index = Char.code bytes.[index] in + List.fold_left + (fun acc index -> Int64.logor (Int64.shift_left acc 8) (Int64.of_int (byte index))) + 0L + [ 0; 1; 2; 3; 4; 5; 6; 7 ] + +let append_bytes buffer chunk = Buffer.add_string buffer chunk + +let append_int32 buffer value = append_bytes buffer (int32_be value) + +let append_int64 buffer value = append_bytes buffer (int64_be_int64 value) + +let float_sort_bits value = + let bits = Int64.bits_of_float value in + if Int64.compare bits 0L < 0 then Int64.logxor bits 0x7fffffffffffffffL else bits + +let append_string buffer text = + Buffer.add_string buffer text; + Buffer.add_char buffer '\000' + +let append_byte buffer value = Buffer.add_char buffer (Char.chr value) + +let read_int32 key offset = + if offset + 4 > String.length key then invalid_arg "truncated int32"; + int32_of_be (String.sub key offset 4), offset + 4 + +let read_string key offset = + let len = String.length key in + if offset >= len then invalid_arg "truncated string"; + let rec find_end index = + if index >= len then invalid_arg "unterminated string" + else if key.[index] = '\000' then index + else find_end (index + 1) + in + let end_offset = find_end offset in + String.sub key offset (end_offset - offset), end_offset + 1 + +let read_byte key offset = + if offset >= String.length key then invalid_arg "truncated byte"; + Char.code key.[offset], offset + 1 + +let encode_keyword_like tag text = + let namespace, name = Datascript_types.Compare.split_keyword text in + let buffer = Buffer.create (String.length text + 16) in + append_byte buffer tag; + append_string buffer namespace; + append_string buffer name; + Buffer.contents buffer + +let encode_tagged_hash tag value = + let buffer = Buffer.create 8 in + append_byte buffer tag; + append_int32 buffer (Datascript_types.Compare.clojure_hasheq value); + Buffer.contents buffer + +let rec encode_value_key = function + | Nil -> "\000" + | Keyword value -> encode_keyword_like 1 value + | Symbol value -> encode_keyword_like 2 value + | Map _ as value -> encode_tagged_hash 3 value + | Set _ as value -> encode_tagged_hash 4 value + | List values -> + let buffer = Buffer.create 64 in + append_byte buffer 5; + append_int32 buffer (List.length values); + List.iter (fun value -> append_bytes buffer (encode_value_key value)) values; + Buffer.contents buffer + | Vector values -> + let buffer = Buffer.create 64 in + append_byte buffer 6; + append_int32 buffer (List.length values); + List.iter (fun value -> append_bytes buffer (encode_value_key value)) values; + Buffer.contents buffer + | Tuple values -> + let buffer = Buffer.create 64 in + append_byte buffer 7; + append_int32 buffer (List.length values); + List.iter + (function + | None -> append_byte buffer 0 + | Some value -> + append_byte buffer 1; + append_bytes buffer (encode_value_key value)) + values; + Buffer.contents buffer + | Bool false -> "\008\000" + | Bool true -> "\008\001" + | Int value -> + let buffer = Buffer.create 16 in + append_byte buffer 9; + append_int64 buffer (float_sort_bits (float_of_int value)); + Buffer.contents buffer + | Float value -> + let buffer = Buffer.create 16 in + append_byte buffer 9; + append_int64 buffer (float_sort_bits value); + Buffer.contents buffer + | Ref value -> + let buffer = Buffer.create 16 in + append_byte buffer 9; + append_int64 buffer (float_sort_bits (float_of_int value)); + Buffer.contents buffer + | String value -> + let buffer = Buffer.create (String.length value + 8) in + append_byte buffer 10; + append_string buffer value; + Buffer.contents buffer + | Regex value -> + let buffer = Buffer.create (String.length value + 8) in + append_byte buffer 11; + append_string buffer value; + Buffer.contents buffer + | Instant value -> + let buffer = Buffer.create 16 in + append_byte buffer 12; + append_int32 buffer value; + Buffer.contents buffer + | Uuid value -> + let buffer = Buffer.create (String.length value + 8) in + append_byte buffer 13; + append_string buffer value; + Buffer.contents buffer + | TxRef -> "\014" + | Ref_to value -> + let buffer = Buffer.create 32 in + append_byte buffer 15; + append_int32 buffer (Hashtbl.hash value); + Buffer.contents buffer + +let rec decode_value_key bytes offset = + let tag, offset = read_byte bytes offset in + match tag with + | 0 -> Nil, offset + | 1 -> + let namespace, offset = read_string bytes offset in + let name, offset = read_string bytes offset in + (if namespace = "" then Keyword name else Keyword (namespace ^ "/" ^ name)), offset + | 2 -> + let namespace, offset = read_string bytes offset in + let name, offset = read_string bytes offset in + (if namespace = "" then Symbol name else Symbol (namespace ^ "/" ^ name)), offset + | 3 | 4 as tag -> + let _, offset = read_int32 bytes offset in + (if tag = 3 then Map [] else Set []), offset + | 5 | 6 as tag -> + let count, offset = read_int32 bytes offset in + if count < 0 then invalid_arg "invalid list length"; + let rec loop remaining offset acc = + if remaining = 0 then + (if tag = 5 then List (List.rev acc) else Vector (List.rev acc)), offset + else + let value, offset = decode_value_key bytes offset in + loop (remaining - 1) offset (value :: acc) + in + loop count offset [] + | 7 -> + let count, offset = read_int32 bytes offset in + if count < 0 then invalid_arg "invalid tuple length"; + let rec loop remaining offset acc = + if remaining = 0 then Tuple (List.rev acc), offset + else + let marker, offset = read_byte bytes offset in + let value, offset = + match marker with + | 0 -> None, offset + | 1 -> + let value, offset = decode_value_key bytes offset in + Some value, offset + | _ -> invalid_arg "invalid tuple slot marker" + in + loop (remaining - 1) offset (value :: acc) + in + loop count offset [] + | 8 -> + let value, offset = read_byte bytes offset in + (match value with 0 -> Bool false | 1 -> Bool true | _ -> invalid_arg "invalid bool key"), offset + | 9 -> + let bits, offset = + if offset + 8 > String.length bytes then invalid_arg "truncated numeric key" + else int64_of_be (String.sub bytes offset 8), offset + 8 + in + let raw = + if Int64.compare bits 0L < 0 then Int64.logxor bits 0x7fffffffffffffffL else bits + in + Float (Int64.float_of_bits raw), offset + | 10 -> + let value, offset = read_string bytes offset in + String value, offset + | 11 -> + let value, offset = read_string bytes offset in + Regex value, offset + | 12 -> + let value, offset = read_int32 bytes offset in + Instant value, offset + | 13 -> + let value, offset = read_string bytes offset in + Uuid value, offset + | 14 -> TxRef, offset + | 15 -> Ref_to (Entity_id 0), offset + 4 + | _ -> invalid_arg "invalid value key tag" + +let encode_index_attr_value_prefix index attr value = + let buffer = Buffer.create 64 in + (match index with + | Avet -> + append_string buffer attr; + append_bytes buffer (encode_value_key value) + | Aevt -> + append_string buffer attr; + append_int32 buffer 0; + append_bytes buffer (encode_value_key value) + | Eavt -> + append_int32 buffer 0; + append_string buffer attr; + 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 + | Eavt -> + append_int32 buffer datom.e; + append_string buffer datom.a; + append_bytes buffer (encode_value_key datom.v); + 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_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_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, 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, 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, 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, added + in + { e; a; v; tx; added } + +let encode_datom_value datom = + let cache_key = (datom.added, datom.v) in + match Hashtbl.find_opt value_payload_cache cache_key with + | Some encoded -> encoded + | None -> + let encoded = Marshal.to_string cache_key [] in + Hashtbl.add value_payload_cache cache_key encoded; + encoded + +let decode_datom_value bytes = + let added, v = Marshal.from_string bytes 0 in + { e = 0; a = ""; v; tx = 0; added } + +let decode_index_entry index key value = + let datom = decode_datom_key index key in + match index with + | Avet -> datom + | Eavt | Aevt -> + let payload = decode_datom_value value in + { datom with v = payload.v } + +let encode_index_value index datom = + match index with + | Avet -> "" + | Eavt | Aevt -> encode_datom_value datom + +let avet_key_attr key = + let attr, _offset = read_string key 0 in + attr + +let avet_key_value key = + let _attr, offset = read_string key 0 in + let value, _offset = decode_value_key key offset in + value + +let decode_avet_key_at attr key = + let prefix_len = String.length attr + 1 in + let v, offset = decode_value_key key prefix_len in + let e, offset = read_int32 key offset in + let tx, offset = read_int32 key offset in + let added, offset = decode_added key offset in + if offset <> String.length key then invalid_arg "trailing avet key bytes"; + { e; a = attr; v; tx; added } + +let compare_encoded_keys index left right = + Datascript_types.Compare.compare_datom index + (decode_datom_key index left) + (decode_datom_key index right) + +let encode_schema schema = Marshal.to_string schema [] +let decode_schema bytes = Marshal.from_string bytes 0 +let encode_datoms datoms = Marshal.to_string datoms [] +let decode_datoms bytes = Marshal.from_string bytes 0 diff --git a/lmdb/datascript_index_codec.mli b/lmdb/datascript_index_codec.mli new file mode 100644 index 0000000..b75b643 --- /dev/null +++ b/lmdb/datascript_index_codec.mli @@ -0,0 +1,19 @@ +open Datascript_types + +val encode_datom_key : index -> datom -> string +val encode_index_attr_value_prefix : index -> string -> value -> string +val decode_datom_key : index -> string -> datom +val encode_datom_value : datom -> string +val decode_datom_value : string -> datom +val decode_index_entry : index -> string -> string -> datom +val encode_index_value : index -> datom -> string + +val compare_encoded_keys : index -> string -> string -> int +val avet_key_attr : string -> string +val avet_key_value : string -> value +val decode_avet_key_at : attr -> string -> datom + +val encode_schema : schema -> string +val decode_schema : string -> schema +val encode_datoms : datom list -> string +val decode_datoms : string -> datom list diff --git a/lmdb/datascript_lmdb.ml b/lmdb/datascript_lmdb.ml new file mode 100644 index 0000000..ec93269 --- /dev/null +++ b/lmdb/datascript_lmdb.ml @@ -0,0 +1,22 @@ +module Ds = Datascript + +type session = + { lmdb : Datascript_lmdb_db.t + ; mutable closed : bool + } + +let ensure_open session = + if session.closed then invalid_arg "LMDB session is closed" + +let open_session db_path = + let lmdb = Datascript_lmdb_db.open_path db_path in + { lmdb; closed = false } + +let close session = + if not session.closed then ( + session.closed <- true; + Datascript_lmdb_db.close session.lmdb) + +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_lmdb_db.mli b/lmdb/datascript_lmdb_db.mli new file mode 100644 index 0000000..d53a813 --- /dev/null +++ b/lmdb/datascript_lmdb_db.mli @@ -0,0 +1,16 @@ +open Datascript_types + +type t + +val create_temp : unit -> t +val open_path : string -> t +val close : t -> unit +val sync : t -> unit +val remove_path : string -> unit + +val meta_get : t -> string -> string option +val meta_set : t -> string -> string -> unit + +val fold_index : index -> t -> (string -> string -> unit) -> unit +val put_index : index -> t -> string -> string -> unit +val remove_index : index -> t -> string -> unit diff --git a/lmdb/datascript_lmdb_db_melange.ml b/lmdb/datascript_lmdb_db_melange.ml new file mode 100644 index 0000000..459980c --- /dev/null +++ b/lmdb/datascript_lmdb_db_melange.ml @@ -0,0 +1,88 @@ +open Datascript_types + +type js = Js.t + +external open_root : string -> js = "open" + [@@mel.module "./datascript_lmdb_node.js"] + +external open_subdb : js -> string -> js = "openDB" + [@@mel.module "./datascript_lmdb_node.js"] + +external js_get : js -> string -> string Js.nullable = "get" + [@@mel.module "./datascript_lmdb_node.js"] + +external js_put : js -> string -> string -> unit = "put" + [@@mel.module "./datascript_lmdb_node.js"] + +external js_remove : js -> string -> unit = "remove" + [@@mel.module "./datascript_lmdb_node.js"] + +external js_sync : js -> unit = "sync" + [@@mel.module "./datascript_lmdb_node.js"] + +external js_close : js -> unit = "close" + [@@mel.module "./datascript_lmdb_node.js"] + +external js_range : js -> (string * string) array = "range" + [@@mel.module "./datascript_lmdb_node.js"] + +external temp_path : unit -> string = "tempPath" + [@@mel.module "./datascript_lmdb_node.js"] + +let remove_path _path = () + +let open_db path = + let root = open_root path in + { Datascript_lmdb_db.path; env = root; eavt = open_subdb root "ds/eavt" + ; aevt = open_subdb root "ds/aevt"; avet = open_subdb root "ds/avet" + ; meta = open_subdb root "ds/meta"; closed = false + } + +let create_temp () = open_db (temp_path ()) + +let open_path path = open_db path + +let ensure_open db = + if db.closed then invalid_arg "LMDB database is closed" + +let close db = + if not db.closed then ( + js_close db.env; + db.closed <- true) + +let sync db = + ensure_open db; + js_sync db.env + +let map_for_index index db = + match index with + | Eavt -> db.eavt + | Aevt -> db.aevt + | Avet -> db.avet + +let meta_get db key = + ensure_open db; + match Js.Nullable.toOption (js_get db.meta key) with + | None -> None + | Some value -> Some value + +let meta_set db key value = + ensure_open db; + js_put db.meta key value + +let with_write db f = + ensure_open db; + f () + +let fold_index index db f = + ensure_open db; + let map = map_for_index index db in + Array.iter (fun (key, value) -> f key value) (js_range map) + +let put_index index db key value = + ensure_open db; + js_put (map_for_index index db) key value + +let remove_index index db key = + ensure_open db; + js_remove (map_for_index index db) key diff --git a/lmdb/datascript_lmdb_node.js b/lmdb/datascript_lmdb_node.js new file mode 100644 index 0000000..f144c4f --- /dev/null +++ b/lmdb/datascript_lmdb_node.js @@ -0,0 +1,51 @@ +// Node LMDB bindings for Melange. Requires the `lmdb` npm package. +const { open } = require("lmdb"); +const fs = require("fs"); +const os = require("os"); +const path = require("path"); + +function removePath(dbPath) { + if (fs.existsSync(dbPath)) fs.rmSync(dbPath, { recursive: true, force: true }); +} + +exports.open = function (dbPath) { + removePath(dbPath); + return open({ path: dbPath, compression: false }); +}; + +exports.openDB = function (root, name) { + return root.openDB(name, {}); +}; + +exports.get = function (db, key) { + return db.get(key); +}; + +exports.put = function (db, key, value) { + db.put(key, value); +}; + +exports.remove = function (db, key) { + db.remove(key); +}; + +exports.sync = function (_root) {}; + +exports.close = function (root) { + root.close(); +}; + +exports.range = function (db) { + const entries = []; + for (const { key, value } of db.getRange()) { + entries.push([key, value]); + } + return entries; +}; + +exports.tempPath = function () { + return path.join( + os.tmpdir(), + "datascript_lmdb_" + Date.now() + "_" + Math.random().toString(16).slice(2) + ); +}; diff --git a/lmdb/datascript_storage_lmdb_plugin.ml b/lmdb/datascript_storage_lmdb_plugin.ml new file mode 100644 index 0000000..5f3ea56 --- /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 + (* Share path: live indexes use this LMDB env, so delta sync is unnecessary. *) + let sync_indexes_to_storage ~since_tx = ignore since_tx 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 = + match target with + | Datascript_storage_protocol.Lmdb target_lmdb when lmdb != target_lmdb -> + Datascript_storage_lmdb.sync_indexes lmdb target_lmdb + | Datascript_storage_protocol.Lmdb _ | Datascript_storage_protocol.Sqlite _ -> () + 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 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 new file mode 100644 index 0000000..5c20f8a --- /dev/null +++ b/lmdb/dune @@ -0,0 +1,18 @@ +(library + (name datascript_index_codec) + (public_name datascript-ocaml-native.index-codec) + (wrapped false) + (modes native melange byte) + (modules datascript_index_codec) + (libraries datascript_types)) + +(library + (name datascript_lmdb) + (public_name datascript-ocaml-native-lmdb) + (wrapped false) + (modes native) + (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/datascript_lmdb_db.ml b/lmdb/melange/datascript_lmdb_db.ml new file mode 100644 index 0000000..1aec9a0 --- /dev/null +++ b/lmdb/melange/datascript_lmdb_db.ml @@ -0,0 +1,129 @@ +open Datascript_types + +module Txn = struct + type t = unit +end + +type map = (string, string) Hashtbl.t + +type t = + { path : string + ; eavt : map + ; aevt : map + ; avet : map + ; meta : map + ; mutable closed : bool + } + +let make_map () = Hashtbl.create 256 + +let remove_path _path = () + +let open_db path = + { path + ; eavt = make_map () + ; aevt = make_map () + ; avet = make_map () + ; meta = make_map () + ; closed = false + } + +let open_path path = open_db path + +let ensure_open db = + if db.closed then invalid_arg ("LMDB database is closed: " ^ db.path) + +let close db = + if not db.closed then db.closed <- true + +let temps_created = ref 0 + +let create_temp () = + let db = open_db ("melange:" ^ string_of_int !temps_created) in + incr temps_created; + db + +let sync _db = () + +let map_for_index index db = + match index with + | Eavt -> db.eavt + | Aevt -> db.aevt + | Avet -> db.avet + +let meta_get db key = + ensure_open db; + Hashtbl.find_opt db.meta key + +let meta_set db key value = + ensure_open db; + Hashtbl.replace db.meta key value + +let with_write_txn db f = + ensure_open db; + f () + +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 = + 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) + +let remove_index index db key = + with_write_txn db (fun txn -> remove_index_txn index txn db key) + +let get_index index db key = + ensure_open db; + 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; + 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 prefix_len = String.length prefix in + 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; + 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 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) diff --git a/lmdb/melange/datascript_lmdb_db.mli b/lmdb/melange/datascript_lmdb_db.mli new file mode 100644 index 0000000..79bacfd --- /dev/null +++ b/lmdb/melange/datascript_lmdb_db.mli @@ -0,0 +1,36 @@ +open Datascript_types + +module Txn : sig + type t = unit +end + +type t + +val create_temp : unit -> t +val open_path : string -> t +val close : t -> unit +val sync : t -> unit +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 new file mode 100644 index 0000000..dbd9aa7 --- /dev/null +++ b/lmdb/melange/datascript_lmdb_index.ml @@ -0,0 +1,323 @@ +open Datascript_types + +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 } +let cmp_for index = Datascript_types.Compare.compare_datom index + +let datom_key t datom = Datascript_index_codec.encode_datom_key t.which datom + +let decode_entry index key value = Datascript_index_codec.decode_index_entry index key value + +let put_datom_txn txn t datom = + let key = datom_key t datom in + let value = Datascript_index_codec.encode_index_value t.which datom in + Datascript_lmdb_db.put_index_txn t.which txn t.db key value + +let empty index db = make index db + +let write_datoms t datoms = + if datoms = [] then t + else ( + 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 + (fun (index, datoms) -> + let t = make index db in + List.iter (put_datom_txn txn t) datoms) + index_datoms) + +let of_eavt_datoms ~avet eavt_datoms db = + if eavt_datoms = [] then () + else ( + let eavt = make Eavt db in + let aevt = make Aevt db in + let avet_index = make Avet db in + Datascript_lmdb_db.with_write_txn db (fun txn -> + List.iter + (fun datom -> + put_datom_txn txn eavt datom; + put_datom_txn txn aevt datom; + if avet datom.a then put_datom_txn txn avet_index datom) + eavt_datoms)) + +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 add datom t = write_datoms t [ datom ] + +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 + | Some datom -> Some (datom_key t datom) + +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 same_prefix_bound left right = + left.e = right.e && left.a = right.a && left.v = right.v + +let is_attr_only_prefix_bound bound = + bound.a <> "" && bound.e = 0 && bound.v = Nil + +let attr_exact_prefix from_ to_ index = + match from_, to_ with + | Some from, Some to_ + when same_prefix_bound from to_ + && is_attr_only_prefix_bound from + && (index = Aevt || index = Avet) -> + Some from.a + | _ -> None + +let attr_value_exact_prefix from_ to_ = + match from_, to_ with + | Some from, Some to_ + when same_prefix_bound from to_ + && from.a <> "" && from.e = 0 && from.v <> Nil -> + Some (from.a, from.v) + | _ -> None + +let fold_stored t f 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 + let acc = ref acc in + Datascript_lmdb_db.fold_index_prefix t.which t.db prefix (fun key value -> + let datom = + match t.which with + | Avet -> Datascript_index_codec.decode_avet_key_at attr key + | _ -> decode_entry t.which key value + in + acc := f !acc datom); + !acc + +let fold_attr_exact_prefix f init t attr = + fold_stored_prefix t attr (fun acc datom -> if datom.a = attr then f acc datom else acc) init + +let fold_stored_attr_value_prefix t attr value f acc = + let prefix = Datascript_index_codec.encode_index_attr_value_prefix t.which attr value in + let acc = ref acc in + Datascript_lmdb_db.fold_index_prefix t.which t.db prefix (fun key value -> + let datom = + match t.which with + | Avet -> Datascript_index_codec.decode_avet_key_at attr key + | _ -> decode_entry t.which key value + in + acc := f !acc datom); + !acc + +let avet_attr_prefix attr = + let buffer = Buffer.create (String.length attr + 1) in + Buffer.add_string buffer attr; + Buffer.add_char buffer '\000'; + Buffer.contents buffer + +let fold_stored_avet_value_range t attr ?start_value ?stop_value _compare_value f acc = + let from_key = + match start_value with + | Some value -> Datascript_index_codec.encode_index_attr_value_prefix Avet attr value + | None -> avet_attr_prefix attr + in + let acc = ref acc in + Datascript_lmdb_db.fold_index_range_until Avet t.db ~from_key + ~stop:(fun key _value -> + if Datascript_index_codec.avet_key_attr key <> attr then + true + else + match stop_value with + | None -> false + | Some stop -> + Datascript_types.Compare.compare_value (Datascript_index_codec.avet_key_value key) stop > 0) + (fun key _value -> + let datom = Datascript_index_codec.decode_avet_key_at attr key in + match start_value with + | None -> acc := f !acc datom + | Some _ -> acc := f !acc datom); + !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 acc = ref acc in + Datascript_lmdb_db.fold_index_range_until t.which t.db ~from_key + ~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 -> + let datom = decode_entry t.which key value in + if in_range cmp from_ to_ datom then acc := f !acc datom); + !acc + +let avet_value_range_bounds from_ to_ = + (* Require an upper bound: open-ended AVET seeks must continue across attrs. *) + match from_, to_ with + | Some from, Some to_ when from.a <> "" && from.e = 0 && to_.a = from.a && to_.e = 0 -> + let start_value = if from.v = Nil then None else Some from.v in + let stop_value = if to_.v = Nil then None else Some to_.v in + Some (from.a, start_value, stop_value) + | _ -> None + +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 + match t.which, avet_value_range_bounds from_ to_ with + | Avet, Some (attr, start_value, stop_value) -> + fold_stored_avet_value_range t attr ?start_value:start_value ?stop_value:stop_value + Datascript_types.Compare.compare_value f init + | _ -> ( + match attr_exact_prefix from_ to_ t.which with + | Some attr -> fold_attr_exact_prefix f init t attr + | None -> ( + match attr_value_exact_prefix from_ to_ with + | Some (attr, value) -> fold_stored_attr_value_prefix t attr value f init + | None -> 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 + let found = ref None in + let consider datom = + if !found = None && in_range cmp from_ to_ datom then ( + found := Some datom; + raise Stop_search) + in + (try + match attr_exact_prefix from_ to_ t.which with + | Some attr -> fold_attr_exact_prefix (fun () datom -> consider datom) () t attr + | None -> ( + match attr_value_exact_prefix from_ to_ with + | Some (attr, value) -> + fold_stored_attr_value_prefix t attr value (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 = fold_attr_exact_prefix f init t attr + +let materialize_range t ?from_ ?to_ cmp = + fold_slice (fun acc datom -> datom :: acc) [] ?from_ ?to_ ~cmp t |> List.rev + +let make_seq cmp datoms = { cmp; datoms; offset = 0 } + +let to_seq ({ cmp = _; datoms; offset = start }) = + let rec loop index () = + if index >= List.length datoms then Seq.Nil + else Seq.Cons (List.nth datoms index, loop (index + 1)) + in + loop start + +let seq t = make_seq (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 (materialize_range t ?from_ ?to_ cmp) + +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 seq_to_list seq = to_seq seq |> List.of_seq + +let fold_seq f init { cmp = _; datoms; offset } = + let rec loop index acc = + if index >= List.length datoms then acc + else loop (index + 1) (f acc (List.nth datoms index)) + in + loop offset init + +let slice ?from_ ?to_ ?cmp t = slice_seq ?from_ ?to_ ?cmp t |> seq_to_list + +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/melange/datascript_lmdb_index.mli b/lmdb/melange/datascript_lmdb_index.mli new file mode 100644 index 0000000..2e16cef --- /dev/null +++ b/lmdb/melange/datascript_lmdb_index.mli @@ -0,0 +1,35 @@ +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 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_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 +val fold_slice : + ('acc -> datom -> 'acc) -> 'acc -> ?from_:datom -> ?to_:datom -> ?cmp:(datom -> datom -> int) -> t -> 'acc +val find_first_slice : + ?from_:datom -> ?to_:datom -> ?cmp:(datom -> datom -> int) -> t -> datom option +val fold_attr_prefix : ('acc -> datom -> 'acc) -> 'acc -> t -> string -> '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/melange/datascript_lmdb_node.js b/lmdb/melange/datascript_lmdb_node.js new file mode 100644 index 0000000..f144c4f --- /dev/null +++ b/lmdb/melange/datascript_lmdb_node.js @@ -0,0 +1,51 @@ +// Node LMDB bindings for Melange. Requires the `lmdb` npm package. +const { open } = require("lmdb"); +const fs = require("fs"); +const os = require("os"); +const path = require("path"); + +function removePath(dbPath) { + if (fs.existsSync(dbPath)) fs.rmSync(dbPath, { recursive: true, force: true }); +} + +exports.open = function (dbPath) { + removePath(dbPath); + return open({ path: dbPath, compression: false }); +}; + +exports.openDB = function (root, name) { + return root.openDB(name, {}); +}; + +exports.get = function (db, key) { + return db.get(key); +}; + +exports.put = function (db, key, value) { + db.put(key, value); +}; + +exports.remove = function (db, key) { + db.remove(key); +}; + +exports.sync = function (_root) {}; + +exports.close = function (root) { + root.close(); +}; + +exports.range = function (db) { + const entries = []; + for (const { key, value } of db.getRange()) { + entries.push([key, value]); + } + return entries; +}; + +exports.tempPath = function () { + return path.join( + os.tmpdir(), + "datascript_lmdb_" + Date.now() + "_" + Math.random().toString(16).slice(2) + ); +}; diff --git a/lmdb/melange/dune b/lmdb/melange/dune new file mode 100644 index 0000000..b0500a6 --- /dev/null +++ b/lmdb/melange/dune @@ -0,0 +1,17 @@ +(include_subdirs no) + +(library + (name lmdb_db_melange) + (public_name datascript-ocaml-melange.lmdb-db) + (wrapped false) + (modes melange byte) + (modules datascript_lmdb_db) + (libraries datascript_index_codec)) + +(library + (name lmdb_index_melange) + (public_name datascript-ocaml-melange.lmdb-index) + (wrapped false) + (modes melange byte) + (modules datascript_lmdb_index) + (libraries datascript_index_codec lmdb_db_melange)) diff --git a/lmdb/native/datascript_lmdb_db.ml b/lmdb/native/datascript_lmdb_db.ml new file mode 100644 index 0000000..5f9c479 --- /dev/null +++ b/lmdb/native/datascript_lmdb_db.ml @@ -0,0 +1,266 @@ +open Datascript_types +open Lmdb + +type read_session = + { txn : Mdb.txn + } + +type lmdb_env_profile = Default | Benchmark + +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 + ; profile : lmdb_env_profile + ; mutable closed : bool + ; mutable read : read_session option + } + +(* Address-space ceiling for no_subdir file envs. Unused pages are not + resident; keep headroom for million-entity index files (~1GiB+). *) +let default_map_size = 8 * 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 env_flags = function + | Default -> Env.Flags.no_subdir + | Benchmark -> + (* Match in-memory benchmark backends: skip fsync on commit/close. *) + Env.Flags.(no_subdir + no_sync + no_meta_sync + write_map) + +let open_env db_path profile = + Env.(create Rw ~flags:(env_flags profile) ~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 + +(* Open (or create) without deleting an existing env. Callers that want a fresh + file must call [remove_path] first — same contract as SQLite [open_path]. *) +let open_db path profile = + let env = open_env path profile 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"; profile + ; closed = false; read = None + } + +let open_path path = open_db path Default + +let ensure_open db = + if db.closed then invalid_arg ("LMDB database is closed: " ^ db.path) + +let close db = + if not db.closed then ( + (match db.read with + | None -> () + | Some { txn } -> + (try Mdb.txn_abort txn with _ -> ())); + db.read <- None; + Map.close db.eavt; + Map.close db.aevt; + Map.close db.avet; + Map.close db.meta; + (match db.profile with + | Default -> Env.sync db.env + | Benchmark -> ()); + Env.close db.env; + db.closed <- true) + +let temps_created = ref 0 + +let create_temp ?(profile = Default) () = + let path = + Filename.temp_file ~temp_dir:(Filename.get_temp_dir_name ()) "datascript_lmdb" ".mdb" + in + remove_path path; + let db = open_db path profile in + Gc.finalise + (fun lmdb -> + if not lmdb.closed then close lmdb) + db; + incr temps_created; + if !temps_created mod 64 = 0 then Gc.full_major (); + db + +let create_benchmark_temp () = create_temp ~profile:Benchmark () + +let sync db = + ensure_open db; + match db.profile with + | Default -> Env.sync db.env + | Benchmark -> () + +let map_for_index index db = + match index with + | Eavt -> db.eavt + | Aevt -> db.aevt + | Avet -> db.avet + +let invalidate_read db = + match db.read with + | None -> () + | Some { txn } -> + (try Mdb.txn_abort txn with _ -> ()); + db.read <- None + +let mdb_env env = + (* Lmdb.Env.t is Mdb.env; the public interface hides the alias. *) + (Obj.magic env : Mdb.env) + +let read_session db = + match db.read with + | Some session -> session + | None -> + let txn = Mdb.txn_begin (mdb_env db.env) None Env.Flags.read_only in + let session = { txn } in + db.read <- Some session; + session + +let ro_txn mdb_txn = + (* Ro Txn.t wraps Mdb.txn; reuse a long-lived read transaction for index scans. *) + (Obj.magic mdb_txn : [ `Read ] Txn.t) + +let with_read_cursor index db f = + let session = read_session db in + let map = map_for_index index db in + Cursor.go Ro ~txn:(ro_txn session.txn) map f + +let meta_get db key = + ensure_open db; + let session = read_session db in + try Some (Map.get ~txn:(ro_txn session.txn) db.meta key) with Not_found -> None + +let meta_set db key value = + ensure_open db; + ignore + (Txn.go Rw db.env (fun txn -> + Map.set ~txn db.meta key value; + ())) + +let with_write_txn db f = + ensure_open db; + invalidate_read db; + ignore + (Txn.go Rw db.env (fun txn -> + f txn; + ())) + +let put_index_txn index txn db key value = + Map.set ~txn (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 put_index index db key value = + with_write_txn db (fun txn -> put_index_txn index txn db key value) + +let remove_index index db key = + with_write_txn db (fun txn -> remove_index_txn index txn db key) + +let get_index index db key = + ensure_open db; + let session = read_session db in + try Some (Map.get ~txn:(ro_txn session.txn) (map_for_index index db) key) with Not_found -> None + +let fold_index index db f = + ensure_open db; + (try + with_read_cursor index db (fun cursor -> + (try ignore (Cursor.first cursor) with Not_found -> raise Exit); + let rec loop () = + let key, value = + try Cursor.current cursor + with Not_found -> raise Exit + in + f key value; + try + ignore (Cursor.next cursor); + loop () + with Not_found -> raise Exit + in + loop ()) + with Exit -> ()) + +let fold_index_prefix index db prefix f = + ensure_open db; + let prefix_len = String.length prefix in + (try + with_read_cursor index db (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 -> ()) + +let fold_index_range index db ?from_key ?to_key f = + ensure_open db; + (try + with_read_cursor index db (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 -> ()) + +let fold_index_range_until index db ?from_key ?stop f = + ensure_open db; + (try + with_read_cursor index db (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 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) diff --git a/lmdb/native/datascript_lmdb_db.mli b/lmdb/native/datascript_lmdb_db.mli new file mode 100644 index 0000000..ce72d89 --- /dev/null +++ b/lmdb/native/datascript_lmdb_db.mli @@ -0,0 +1,35 @@ +open Datascript_types + +type lmdb_env_profile = Default | Benchmark + +type t + +val create_temp : ?profile:lmdb_env_profile -> unit -> t +val create_benchmark_temp : unit -> t +val open_path : string -> t +val close : t -> unit +val sync : t -> unit +val remove_path : string -> unit + +val meta_get : t -> string -> string option +val meta_set : t -> string -> string -> unit + +val with_write_txn : t -> ([ `Read | `Write ] Lmdb.Txn.t -> unit) -> unit +val put_index_txn : index -> [ `Read | `Write ] Lmdb.Txn.t -> t -> string -> string -> unit +val remove_index_txn : index -> [ `Read | `Write ] Lmdb.Txn.t -> t -> string -> unit +val copy_index_txn : index -> [ `Read | `Write ] Lmdb.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/native/datascript_lmdb_index.ml b/lmdb/native/datascript_lmdb_index.ml new file mode 100644 index 0000000..dbd9aa7 --- /dev/null +++ b/lmdb/native/datascript_lmdb_index.ml @@ -0,0 +1,323 @@ +open Datascript_types + +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 } +let cmp_for index = Datascript_types.Compare.compare_datom index + +let datom_key t datom = Datascript_index_codec.encode_datom_key t.which datom + +let decode_entry index key value = Datascript_index_codec.decode_index_entry index key value + +let put_datom_txn txn t datom = + let key = datom_key t datom in + let value = Datascript_index_codec.encode_index_value t.which datom in + Datascript_lmdb_db.put_index_txn t.which txn t.db key value + +let empty index db = make index db + +let write_datoms t datoms = + if datoms = [] then t + else ( + 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 + (fun (index, datoms) -> + let t = make index db in + List.iter (put_datom_txn txn t) datoms) + index_datoms) + +let of_eavt_datoms ~avet eavt_datoms db = + if eavt_datoms = [] then () + else ( + let eavt = make Eavt db in + let aevt = make Aevt db in + let avet_index = make Avet db in + Datascript_lmdb_db.with_write_txn db (fun txn -> + List.iter + (fun datom -> + put_datom_txn txn eavt datom; + put_datom_txn txn aevt datom; + if avet datom.a then put_datom_txn txn avet_index datom) + eavt_datoms)) + +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 add datom t = write_datoms t [ datom ] + +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 + | Some datom -> Some (datom_key t datom) + +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 same_prefix_bound left right = + left.e = right.e && left.a = right.a && left.v = right.v + +let is_attr_only_prefix_bound bound = + bound.a <> "" && bound.e = 0 && bound.v = Nil + +let attr_exact_prefix from_ to_ index = + match from_, to_ with + | Some from, Some to_ + when same_prefix_bound from to_ + && is_attr_only_prefix_bound from + && (index = Aevt || index = Avet) -> + Some from.a + | _ -> None + +let attr_value_exact_prefix from_ to_ = + match from_, to_ with + | Some from, Some to_ + when same_prefix_bound from to_ + && from.a <> "" && from.e = 0 && from.v <> Nil -> + Some (from.a, from.v) + | _ -> None + +let fold_stored t f 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 + let acc = ref acc in + Datascript_lmdb_db.fold_index_prefix t.which t.db prefix (fun key value -> + let datom = + match t.which with + | Avet -> Datascript_index_codec.decode_avet_key_at attr key + | _ -> decode_entry t.which key value + in + acc := f !acc datom); + !acc + +let fold_attr_exact_prefix f init t attr = + fold_stored_prefix t attr (fun acc datom -> if datom.a = attr then f acc datom else acc) init + +let fold_stored_attr_value_prefix t attr value f acc = + let prefix = Datascript_index_codec.encode_index_attr_value_prefix t.which attr value in + let acc = ref acc in + Datascript_lmdb_db.fold_index_prefix t.which t.db prefix (fun key value -> + let datom = + match t.which with + | Avet -> Datascript_index_codec.decode_avet_key_at attr key + | _ -> decode_entry t.which key value + in + acc := f !acc datom); + !acc + +let avet_attr_prefix attr = + let buffer = Buffer.create (String.length attr + 1) in + Buffer.add_string buffer attr; + Buffer.add_char buffer '\000'; + Buffer.contents buffer + +let fold_stored_avet_value_range t attr ?start_value ?stop_value _compare_value f acc = + let from_key = + match start_value with + | Some value -> Datascript_index_codec.encode_index_attr_value_prefix Avet attr value + | None -> avet_attr_prefix attr + in + let acc = ref acc in + Datascript_lmdb_db.fold_index_range_until Avet t.db ~from_key + ~stop:(fun key _value -> + if Datascript_index_codec.avet_key_attr key <> attr then + true + else + match stop_value with + | None -> false + | Some stop -> + Datascript_types.Compare.compare_value (Datascript_index_codec.avet_key_value key) stop > 0) + (fun key _value -> + let datom = Datascript_index_codec.decode_avet_key_at attr key in + match start_value with + | None -> acc := f !acc datom + | Some _ -> acc := f !acc datom); + !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 acc = ref acc in + Datascript_lmdb_db.fold_index_range_until t.which t.db ~from_key + ~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 -> + let datom = decode_entry t.which key value in + if in_range cmp from_ to_ datom then acc := f !acc datom); + !acc + +let avet_value_range_bounds from_ to_ = + (* Require an upper bound: open-ended AVET seeks must continue across attrs. *) + match from_, to_ with + | Some from, Some to_ when from.a <> "" && from.e = 0 && to_.a = from.a && to_.e = 0 -> + let start_value = if from.v = Nil then None else Some from.v in + let stop_value = if to_.v = Nil then None else Some to_.v in + Some (from.a, start_value, stop_value) + | _ -> None + +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 + match t.which, avet_value_range_bounds from_ to_ with + | Avet, Some (attr, start_value, stop_value) -> + fold_stored_avet_value_range t attr ?start_value:start_value ?stop_value:stop_value + Datascript_types.Compare.compare_value f init + | _ -> ( + match attr_exact_prefix from_ to_ t.which with + | Some attr -> fold_attr_exact_prefix f init t attr + | None -> ( + match attr_value_exact_prefix from_ to_ with + | Some (attr, value) -> fold_stored_attr_value_prefix t attr value f init + | None -> 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 + let found = ref None in + let consider datom = + if !found = None && in_range cmp from_ to_ datom then ( + found := Some datom; + raise Stop_search) + in + (try + match attr_exact_prefix from_ to_ t.which with + | Some attr -> fold_attr_exact_prefix (fun () datom -> consider datom) () t attr + | None -> ( + match attr_value_exact_prefix from_ to_ with + | Some (attr, value) -> + fold_stored_attr_value_prefix t attr value (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 = fold_attr_exact_prefix f init t attr + +let materialize_range t ?from_ ?to_ cmp = + fold_slice (fun acc datom -> datom :: acc) [] ?from_ ?to_ ~cmp t |> List.rev + +let make_seq cmp datoms = { cmp; datoms; offset = 0 } + +let to_seq ({ cmp = _; datoms; offset = start }) = + let rec loop index () = + if index >= List.length datoms then Seq.Nil + else Seq.Cons (List.nth datoms index, loop (index + 1)) + in + loop start + +let seq t = make_seq (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 (materialize_range t ?from_ ?to_ cmp) + +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 seq_to_list seq = to_seq seq |> List.of_seq + +let fold_seq f init { cmp = _; datoms; offset } = + let rec loop index acc = + if index >= List.length datoms then acc + else loop (index + 1) (f acc (List.nth datoms index)) + in + loop offset init + +let slice ?from_ ?to_ ?cmp t = slice_seq ?from_ ?to_ ?cmp t |> seq_to_list + +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/native/datascript_lmdb_index.mli b/lmdb/native/datascript_lmdb_index.mli new file mode 100644 index 0000000..2e16cef --- /dev/null +++ b/lmdb/native/datascript_lmdb_index.mli @@ -0,0 +1,35 @@ +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 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_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 +val fold_slice : + ('acc -> datom -> 'acc) -> 'acc -> ?from_:datom -> ?to_:datom -> ?cmp:(datom -> datom -> int) -> t -> 'acc +val find_first_slice : + ?from_:datom -> ?to_:datom -> ?cmp:(datom -> datom -> int) -> t -> datom option +val fold_attr_prefix : ('acc -> datom -> 'acc) -> 'acc -> t -> string -> '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/native/dune b/lmdb/native/dune new file mode 100644 index 0000000..fcec3bf --- /dev/null +++ b/lmdb/native/dune @@ -0,0 +1,17 @@ +(include_subdirs no) + +(library + (name lmdb_db_native) + (public_name datascript-ocaml-native.lmdb-db) + (wrapped false) + (modes native) + (modules datascript_lmdb_db) + (libraries datascript_index_codec lmdb)) + +(library + (name lmdb_index_native) + (public_name datascript-ocaml-native.lmdb-index) + (wrapped false) + (modes native) + (modules datascript_lmdb_index) + (libraries datascript_index_codec lmdb_db_native)) diff --git a/melange/datascript_melange_storage.ml b/melange/datascript_melange_storage.ml index 2cabab9..d9a871b 100644 --- a/melange/datascript_melange_storage.ml +++ b/melange/datascript_melange_storage.ml @@ -1,9 +1,35 @@ module Ds = Datascript -module PSet = Persistent_sorted_set module Transit = Transit_melange.Transit.Json open Ds +type ref_type = + | Strong + | Weak + +type stored_node = + | Leaf of datom list + | Branch of datom list * storage_address list + +type storage_root = + { storage_schema : schema + ; storage_max_eid : entity_id + ; storage_max_tx : tx + ; storage_eavt : storage_address + ; storage_aevt : storage_address + ; storage_avet : storage_address + ; storage_duplicate_datoms : datom list + ; storage_max_addr : int + ; storage_branching_factor : int + ; storage_ref_type : ref_type + } + +type compat_payload = + | Compat_root of storage_root + | Compat_node of stored_node + | Compat_tail of datom list list + | Compat_session + let schema_attr_default : Ds.schema_attr = { cardinality = One; @@ -87,13 +113,13 @@ let value_type_of_transit = function | _ -> None let transit_of_ref_type = function - | PSet.Strong -> Transit.Keyword "strong" - | PSet.Weak -> Transit.Keyword "weak" + | Strong -> Transit.Keyword "strong" + | Weak -> Transit.Keyword "weak" let ref_type_of_transit = function - | Transit.Keyword "soft" -> PSet.Weak - | Transit.Keyword "weak" -> PSet.Weak - | Transit.Keyword "strong" | _ -> PSet.Strong + | Transit.Keyword "soft" -> Weak + | Transit.Keyword "weak" -> Weak + | Transit.Keyword "strong" | _ -> Strong let address_to_transit address = Transit.String address @@ -274,8 +300,8 @@ let storage_root_to_transit root = ] let storage_node_to_transit = function - | PSet.Leaf datoms -> Transit.Map [ (Transit.Keyword "keys", datoms_to_transit datoms) ] - | PSet.Branch (keys, child_addresses) -> + | Leaf datoms -> Transit.Map [ (Transit.Keyword "keys", datoms_to_transit datoms) ] + | Branch (keys, child_addresses) -> Transit.Map [ (Transit.Keyword "keys", datoms_to_transit keys); @@ -286,9 +312,10 @@ let storage_tail_to_transit groups = Transit.Array (List.map (fun group -> datoms_to_transit group) groups) let payload_to_transit = function - | Ds.Storage_root root -> storage_root_to_transit root - | Storage_node node -> storage_node_to_transit node - | Storage_tail groups -> storage_tail_to_transit groups + | Compat_root root -> storage_root_to_transit root + | Compat_node node -> storage_node_to_transit node + | Compat_tail groups -> storage_tail_to_transit groups + | Compat_session -> Transit.Map [] let require_key key entries = match lookup_transit_key key entries with @@ -302,7 +329,7 @@ let optional_datoms key entries = let storage_root_of_transit entries = { - Ds.storage_schema = schema_of_transit (require_key "schema" entries); + storage_schema = schema_of_transit (require_key "schema" entries); storage_max_eid = int_of_transit "storage root :max-eid" (require_key "max-eid" entries); storage_max_tx = int_of_transit "storage root :max-tx" (require_key "max-tx" entries); storage_eavt = address_of_transit "storage root :eavt" (require_key "eavt" entries); @@ -323,8 +350,8 @@ let child_addresses_of_transit = function let storage_node_of_transit entries = let keys = datoms_of_transit (require_key "keys" entries) in match lookup_transit_key "children" entries with - | None -> PSet.Leaf keys - | Some children -> PSet.Branch (keys, child_addresses_of_transit children) + | None -> Leaf keys + | Some children -> Branch (keys, child_addresses_of_transit children) let storage_tail_of_transit = function | Transit.Array groups | Transit.List groups -> List.map datoms_of_transit groups @@ -332,11 +359,21 @@ let storage_tail_of_transit = function let payload_of_transit = function | Transit.Map entries -> - if Option.is_some (lookup_transit_key "schema" entries) then Storage_root (storage_root_of_transit entries) - else if Option.is_some (lookup_transit_key "keys" entries) then Storage_node (storage_node_of_transit entries) - else invalid_arg "unknown storage payload map" - | (Transit.Array _ | Transit.List _) as tail -> Storage_tail (storage_tail_of_transit tail) + if Option.is_some (lookup_transit_key "schema" entries) then Compat_root (storage_root_of_transit entries) + else if Option.is_some (lookup_transit_key "keys" entries) then Compat_node (storage_node_of_transit entries) + else Compat_session + | (Transit.Array _ | Transit.List _) as tail -> Compat_tail (storage_tail_of_transit tail) | _ -> invalid_arg "unknown storage payload" let encode payload = payload |> payload_to_transit |> Transit.to_string ~mode:Transit.Verbose let decode content = content |> Transit.of_string |> payload_of_transit + +(* Legacy Logseq KVS codec helpers (PSS storage payloads are no longer supported). *) + +let encode_storage_payload () = encode Compat_session + +let decode_storage_payload payload = + match decode payload with + | Compat_session -> () + | Compat_root _ | Compat_node _ | Compat_tail _ -> + invalid_arg "legacy PSS storage payloads are no longer supported" diff --git a/melange/dune b/melange/dune index 681503d..3405fdb 100644 --- a/melange/dune +++ b/melange/dune @@ -1,9 +1,8 @@ (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 datascript-ocaml-melange - melange-transit-melange - persistent_sorted_set_ocaml.melange)) + melange-transit-melange)) diff --git a/script/benchmark_vs_cljs.sh b/script/benchmark_vs_cljs.sh index 1085779..0c57df4 100755 --- a/script/benchmark_vs_cljs.sh +++ b/script/benchmark_vs_cljs.sh @@ -8,7 +8,7 @@ sample_ms="${BENCH_SAMPLE_MS:-500}" samples="${BENCH_SAMPLES:-5}" upstream_datascript_js="${UPSTREAM_DATASCRIPT_JS:-}" ocaml_native="${BENCH_OCAML_NATIVE:-$repo_root/_build/default/bench/bench_ocaml.exe}" -ocaml_js="${BENCH_OCAML_JS:-$repo_root/_build/default/bench/bench_ocaml.bc.js}" +ocaml_js="${BENCH_OCAML_JS:-$repo_root/_build/default/bench/bench_ocaml_js.bc.js}" if [ -z "$upstream_datascript_js" ]; then echo "Set UPSTREAM_DATASCRIPT_JS to the upstream DataScript JS bundle." >&2 @@ -21,7 +21,7 @@ if [ ! -f "$upstream_datascript_js" ]; then fi if [ "${BENCH_SKIP_BUILD:-0}" != "1" ]; then - dune build --profile release bench/bench_ocaml.exe bench/bench_ocaml.bc.js + dune build --profile release bench/bench_ocaml.exe bench/bench_ocaml_js.bc.js fi args=(--size "$size" --warmup-ms "$warmup_ms" --sample-ms "$sample_ms" --samples "$samples") 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_sqlite_codec.ml b/sqlite/datascript_sqlite_codec.ml index 05f9b69..406a2d9 100644 --- a/sqlite/datascript_sqlite_codec.ml +++ b/sqlite/datascript_sqlite_codec.ml @@ -1,10 +1,34 @@ -module Ds = Datascript -module PSet = Persistent_sorted_set +open Datascript_types module Transit = Transit_native.Transit.Json -open Ds +type ref_type = + | Strong + | Weak + +type stored_node = + | Leaf of datom list + | Branch of datom list * storage_address list + +type storage_root = + { storage_schema : schema + ; storage_max_eid : entity_id + ; storage_max_tx : tx + ; storage_eavt : storage_address + ; storage_aevt : storage_address + ; storage_avet : storage_address + ; storage_duplicate_datoms : datom list + ; storage_max_addr : int + ; storage_branching_factor : int + ; storage_ref_type : ref_type + } + +type compat_payload = + | Compat_root of storage_root + | Compat_node of stored_node + | 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; @@ -87,13 +111,13 @@ let value_type_of_transit = function | _ -> None let transit_of_ref_type = function - | PSet.Strong -> Transit.Keyword "strong" - | PSet.Weak -> Transit.Keyword "weak" + | Strong -> Transit.Keyword "strong" + | Weak -> Transit.Keyword "weak" let ref_type_of_transit = function - | Transit.Keyword "soft" -> PSet.Weak - | Transit.Keyword "weak" -> PSet.Weak - | Transit.Keyword "strong" | _ -> PSet.Strong + | Transit.Keyword "soft" -> Weak + | Transit.Keyword "weak" -> Weak + | Transit.Keyword "strong" | _ -> Strong let address_to_transit address = Transit.String address @@ -175,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 @@ -202,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 @@ -232,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 = @@ -249,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) @@ -274,8 +298,8 @@ let storage_root_to_transit root = ] let storage_node_to_transit = function - | PSet.Leaf datoms -> Transit.Map [ (Transit.Keyword "keys", datoms_to_transit datoms) ] - | PSet.Branch (keys, child_addresses) -> + | Leaf datoms -> Transit.Map [ (Transit.Keyword "keys", datoms_to_transit datoms) ] + | Branch (keys, child_addresses) -> Transit.Map [ (Transit.Keyword "keys", datoms_to_transit keys); @@ -286,9 +310,10 @@ let storage_tail_to_transit groups = Transit.Array (List.map (fun group -> datoms_to_transit group) groups) let payload_to_transit = function - | Ds.Storage_root root -> storage_root_to_transit root - | Storage_node node -> storage_node_to_transit node - | Storage_tail groups -> storage_tail_to_transit groups + | Compat_root root -> storage_root_to_transit root + | Compat_node node -> storage_node_to_transit node + | Compat_tail groups -> storage_tail_to_transit groups + | Compat_session -> Transit.Map [] let require_key key entries = match lookup_transit_key key entries with @@ -302,7 +327,7 @@ let optional_datoms key entries = let storage_root_of_transit entries = { - Ds.storage_schema = schema_of_transit (require_key "schema" entries); + storage_schema = schema_of_transit (require_key "schema" entries); storage_max_eid = int_of_transit "storage root :max-eid" (require_key "max-eid" entries); storage_max_tx = int_of_transit "storage root :max-tx" (require_key "max-tx" entries); storage_eavt = address_of_transit "storage root :eavt" (require_key "eavt" entries); @@ -323,8 +348,8 @@ let child_addresses_of_transit = function let storage_node_of_transit entries = let keys = datoms_of_transit (require_key "keys" entries) in match lookup_transit_key "children" entries with - | None -> PSet.Leaf keys - | Some children -> PSet.Branch (keys, child_addresses_of_transit children) + | None -> Leaf keys + | Some children -> Branch (keys, child_addresses_of_transit children) let storage_tail_of_transit = function | Transit.Array groups | Transit.List groups -> List.map datoms_of_transit groups @@ -332,11 +357,21 @@ let storage_tail_of_transit = function let payload_of_transit = function | Transit.Map entries -> - if Option.is_some (lookup_transit_key "schema" entries) then Storage_root (storage_root_of_transit entries) - else if Option.is_some (lookup_transit_key "keys" entries) then Storage_node (storage_node_of_transit entries) - else invalid_arg "unknown storage payload map" - | (Transit.Array _ | Transit.List _) as tail -> Storage_tail (storage_tail_of_transit tail) + if Option.is_some (lookup_transit_key "schema" entries) then Compat_root (storage_root_of_transit entries) + else if Option.is_some (lookup_transit_key "keys" entries) then Compat_node (storage_node_of_transit entries) + else Compat_session + | (Transit.Array _ | Transit.List _) as tail -> Compat_tail (storage_tail_of_transit tail) | _ -> invalid_arg "unknown storage payload" let encode payload = payload |> payload_to_transit |> Transit.to_string ~mode:Transit.Verbose let decode content = content |> Transit.of_string |> payload_of_transit + +(* Legacy Logseq KVS codec helpers (PSS storage payloads are no longer supported). *) + +let encode_storage_payload () = encode Compat_session + +let decode_storage_payload payload = + match decode payload with + | 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..717ab51 --- /dev/null +++ b/sqlite/datascript_sqlite_db.ml @@ -0,0 +1,263 @@ +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 apply_open_pragmas t = + exec_sql t "PRAGMA journal_mode=WAL;"; + exec_sql t "PRAGMA synchronous=NORMAL;"; + exec_sql t "PRAGMA busy_timeout=5000;"; + exec_sql t "PRAGMA foreign_keys=ON;" + +let ensure_schema db = + List.iter + (fun index -> + exec_sql db + (Printf.sprintf + "CREATE TABLE IF NOT EXISTS %s (\n\ + \ key BLOB PRIMARY KEY NOT NULL,\n\ + \ value BLOB NOT NULL\n\ + ) WITHOUT ROWID;" + (table_name index))) + [ Eavt; Aevt; Avet ]; + exec_sql db + "CREATE TABLE IF NOT EXISTS ds_meta (\n\ + \ key TEXT PRIMARY KEY NOT NULL,\n\ + \ value BLOB NOT NULL\n\ + ) WITHOUT ROWID;" + +let open_path path = + let db = Sqlite3.db_open path in + let t = { path; db; closed = false } in + apply_open_pragmas t; + ensure_schema t; + t + +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_path + (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;"; + exec_sql t "PRAGMA wal_checkpoint(FULL);"; + exec_sql t "PRAGMA synchronous=NORMAL;" + +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 fold_index_range_desc_until index db ?hi_key ?stop f = + ensure_open db; + let sql = + match hi_key with + | None -> Printf.sprintf "SELECT key, value FROM %s ORDER BY key DESC;" (table_name index) + | Some _ -> + Printf.sprintf "SELECT key, value FROM %s WHERE key <= ? ORDER BY key DESC;" + (table_name index) + in + let stmt = Sqlite3.prepare db.db sql in + Fun.protect + ~finally:(fun () -> check db sql (Sqlite3.finalize stmt)) + (fun () -> + (match hi_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/sqlite/datascript_sqlite_db.mli b/sqlite/datascript_sqlite_db.mli new file mode 100644 index 0000000..00a5752 --- /dev/null +++ b/sqlite/datascript_sqlite_db.mli @@ -0,0 +1,37 @@ +open Datascript_types + +type t + +val create_temp : unit -> t +val open_path : string -> t +val close : t -> unit +val sync : t -> unit + +val meta_get : t -> string -> string option +val meta_set : t -> string -> string -> unit + +val with_write_txn : t -> (unit -> unit) -> unit +val put_index_txn : index -> t -> string -> string -> unit +val remove_index_txn : index -> t -> string -> unit +val put_index : index -> t -> string -> string -> unit +val remove_index : index -> t -> string -> unit +val get_index : index -> t -> string -> string option + +val fold_index : index -> t -> (string -> string -> unit) -> unit +val fold_index_prefix : index -> t -> 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_range_desc_until : + index -> + t -> + ?hi_key:string -> + ?stop:(string -> string -> bool) -> + (string -> string -> unit) -> + unit + +val copy_index : index -> t -> t -> unit diff --git a/sqlite/datascript_sqlite_index.ml b/sqlite/datascript_sqlite_index.ml new file mode 100644 index 0000000..7e2e662 --- /dev/null +++ b/sqlite/datascript_sqlite_index.ml @@ -0,0 +1,325 @@ +open Datascript_types + +type t = { db : Datascript_sqlite_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 } +let cmp_for index = Datascript_types.Compare.compare_datom index + +let datom_key t datom = Datascript_index_codec.encode_datom_key t.which datom + +let decode_entry index key value = Datascript_index_codec.decode_index_entry index key value + +let put_datom_txn t datom = + let key = datom_key t datom in + let value = Datascript_index_codec.encode_index_value t.which datom in + Datascript_sqlite_db.put_index_txn t.which t.db key value + +let empty index db = make index db + +let write_datoms t datoms = + if datoms = [] then t + else ( + Datascript_sqlite_db.with_write_txn t.db (fun () -> List.iter (put_datom_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_sqlite_db.with_write_txn db (fun () -> + List.iter + (fun (index, datoms) -> + let t = make index db in + List.iter (put_datom_txn t) datoms) + index_datoms) + +let of_eavt_datoms ~avet eavt_datoms db = + if eavt_datoms = [] then () + else ( + let eavt = make Eavt db in + let aevt = make Aevt db in + let avet_index = make Avet db in + Datascript_sqlite_db.with_write_txn db (fun () -> + List.iter + (fun datom -> + put_datom_txn eavt datom; + put_datom_txn aevt datom; + if avet datom.a then put_datom_txn avet_index datom) + eavt_datoms)) + +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_sqlite_db.with_write_txn eavt.db (fun () -> + List.iter + (fun datom -> + put_datom_txn eavt datom; + put_datom_txn aevt datom; + if is_avet datom.a then put_datom_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_txn t datom = + let key = datom_key t datom in + Datascript_sqlite_db.remove_index_txn t.which t.db key + +let remove datom t = + Datascript_sqlite_db.with_write_txn t.db (fun () -> remove_datom_txn t datom); + t + +let remove_datoms datoms t = + if datoms = [] then t + else ( + Datascript_sqlite_db.with_write_txn t.db (fun () -> List.iter (remove_datom_txn t) datoms); + 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 = + 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 same_prefix_bound left right = + left.e = right.e && left.a = right.a && left.v = right.v + +let is_attr_only_prefix_bound bound = + bound.a <> "" && bound.e = 0 && bound.v = Nil + +let attr_exact_prefix from_ to_ index = + match from_, to_ with + | Some from, Some to_ + when same_prefix_bound from to_ + && is_attr_only_prefix_bound from + && (index = Aevt || index = Avet) -> + Some from.a + | _ -> None + +let attr_value_exact_prefix from_ to_ = + match from_, to_ with + | Some from, Some to_ + when same_prefix_bound from to_ + && from.a <> "" && from.e = 0 && from.v <> Nil -> + Some (from.a, from.v) + | _ -> None + +let fold_stored t f acc = + let acc = ref acc in + Datascript_sqlite_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 + let acc = ref acc in + Datascript_sqlite_db.fold_index_prefix t.which t.db prefix (fun key value -> + let datom = + match t.which with + | Avet -> Datascript_index_codec.decode_avet_key_at attr key + | _ -> decode_entry t.which key value + in + acc := f !acc datom); + !acc + +let fold_attr_exact_prefix f init t attr = + fold_stored_prefix t attr (fun acc datom -> if datom.a = attr then f acc datom else acc) init + +let fold_stored_attr_value_prefix t attr value f acc = + let prefix = Datascript_index_codec.encode_index_attr_value_prefix t.which attr value in + let acc = ref acc in + Datascript_sqlite_db.fold_index_prefix t.which t.db prefix (fun key value -> + let datom = + match t.which with + | Avet -> Datascript_index_codec.decode_avet_key_at attr key + | _ -> decode_entry t.which key value + in + acc := f !acc datom); + !acc + +let avet_attr_prefix attr = + let buffer = Buffer.create (String.length attr + 1) in + Buffer.add_string buffer attr; + Buffer.add_char buffer '\000'; + Buffer.contents buffer + +let fold_stored_avet_value_range t attr ?start_value ?stop_value _compare_value f acc = + let from_key = + match start_value with + | Some value -> Datascript_index_codec.encode_index_attr_value_prefix Avet attr value + | None -> avet_attr_prefix attr + in + let acc = ref acc in + Datascript_sqlite_db.fold_index_range_until Avet t.db ~from_key + ~stop:(fun key _value -> + if Datascript_index_codec.avet_key_attr key <> attr then + true + else + match stop_value with + | None -> false + | Some stop -> + Datascript_types.Compare.compare_value (Datascript_index_codec.avet_key_value key) stop > 0) + (fun key _value -> + let datom = Datascript_index_codec.decode_avet_key_at attr key in + match start_value with + | None -> acc := f !acc datom + | Some _ -> acc := f !acc datom); + !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 acc = ref acc in + Datascript_sqlite_db.fold_index_range_until t.which t.db ~from_key + ~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 -> + let datom = decode_entry t.which key value in + if in_range cmp from_ to_ datom then acc := f !acc datom); + !acc + +let avet_value_range_bounds from_ to_ = + (* Require an upper bound: open-ended AVET seeks must continue across attrs. *) + match from_, to_ with + | Some from, Some to_ when from.a <> "" && from.e = 0 && to_.a = from.a && to_.e = 0 -> + let start_value = if from.v = Nil then None else Some from.v in + let stop_value = if to_.v = Nil then None else Some to_.v in + Some (from.a, start_value, stop_value) + | _ -> None + +let sync_append_since_tx ~since_tx t target_sqlite = + if t.db == target_sqlite then () + else + let target = make t.which target_sqlite in + Datascript_sqlite_db.with_write_txn target_sqlite (fun () -> + fold_stored t (fun () datom -> + if datom.tx > since_tx then put_datom_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_sqlite_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 + match t.which, avet_value_range_bounds from_ to_ with + | Avet, Some (attr, start_value, stop_value) -> + fold_stored_avet_value_range t attr ?start_value:start_value ?stop_value:stop_value + Datascript_types.Compare.compare_value f init + | _ -> ( + match attr_exact_prefix from_ to_ t.which with + | Some attr -> fold_attr_exact_prefix f init t attr + | None -> ( + match attr_value_exact_prefix from_ to_ with + | Some (attr, value) -> fold_stored_attr_value_prefix t attr value f init + | None -> 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 + let found = ref None in + let consider datom = + if !found = None && in_range cmp from_ to_ datom then ( + found := Some datom; + raise Stop_search) + in + (try + match attr_exact_prefix from_ to_ t.which with + | Some attr -> fold_attr_exact_prefix (fun () datom -> consider datom) () t attr + | None -> ( + match attr_value_exact_prefix from_ to_ with + | Some (attr, value) -> + fold_stored_attr_value_prefix t attr value (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 = fold_attr_exact_prefix f init t attr + +let materialize_range t ?from_ ?to_ cmp = + fold_slice (fun acc datom -> datom :: acc) [] ?from_ ?to_ ~cmp t |> List.rev + +let make_seq cmp datoms = { cmp; datoms; offset = 0 } + +let to_seq ({ cmp = _; datoms; offset = start }) = + let rec loop index () = + if index >= List.length datoms then Seq.Nil + else Seq.Cons (List.nth datoms index, loop (index + 1)) + in + loop start + +let seq t = make_seq (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 (materialize_range t ?from_ ?to_ cmp) + +let rslice_seq ?from_ ?to_ ?cmp t = + let cmp = Option.value ~default:(cmp_for t.which) cmp in + (* from_ is the upper (hi) bound for rslice; to_ is the lower bound. *) + let datoms = ref [] in + let hi_key = bound_key t from_ in + Datascript_sqlite_db.fold_index_range_desc_until t.which t.db ?hi_key + ~stop:(fun key value -> + match to_ with + | None -> false + | Some bound -> + let datom = decode_entry t.which key value in + cmp datom bound < 0) + (fun key value -> + let datom = decode_entry t.which key value in + if in_range cmp to_ from_ datom then datoms := datom :: !datoms); + (* fold visits DESC; cons builds ascending then rev restores descending order. *) + make_seq cmp (List.rev !datoms) + +let seq_to_list seq = to_seq seq |> List.of_seq + +let fold_seq f init { cmp = _; datoms; offset } = + let rec loop index acc = + if index >= List.length datoms then acc + else loop (index + 1) (f acc (List.nth datoms index)) + in + loop offset init + +let slice ?from_ ?to_ ?cmp t = slice_seq ?from_ ?to_ ?cmp t |> seq_to_list + +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/sqlite/datascript_sqlite_index.mli b/sqlite/datascript_sqlite_index.mli new file mode 100644 index 0000000..26d5b6d --- /dev/null +++ b/sqlite/datascript_sqlite_index.mli @@ -0,0 +1,35 @@ +open Datascript_types + +type t +type 'a seq + +val db_of : t -> Datascript_sqlite_db.t +val empty : index -> Datascript_sqlite_db.t -> t +val of_sorted_list : index -> datom list -> Datascript_sqlite_db.t -> t +val of_sorted_lists : (index * datom list) list -> Datascript_sqlite_db.t -> unit +val of_eavt_datoms : avet:(string -> bool) -> datom list -> Datascript_sqlite_db.t -> unit +val of_bulk : index -> datom list -> Datascript_sqlite_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_append_since_tx : since_tx:tx -> t -> Datascript_sqlite_db.t -> unit +val lookup : t -> datom -> datom option +val to_list : t -> datom list +val fold : ('acc -> datom -> 'acc) -> 'acc -> t -> 'acc +val fold_slice : + ('acc -> datom -> 'acc) -> 'acc -> ?from_:datom -> ?to_:datom -> ?cmp:(datom -> datom -> int) -> t -> 'acc +val find_first_slice : + ?from_:datom -> ?to_:datom -> ?cmp:(datom -> datom -> int) -> t -> datom option +val fold_attr_prefix : ('acc -> datom -> 'acc) -> 'acc -> t -> string -> '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/sqlite/datascript_storage_sqlite.ml b/sqlite/datascript_storage_sqlite.ml new file mode 100644 index 0000000..eeecae7 --- /dev/null +++ b/sqlite/datascript_storage_sqlite.ml @@ -0,0 +1,13 @@ +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) diff --git a/sqlite/datascript_storage_sqlite_plugin.ml b/sqlite/datascript_storage_sqlite_plugin.ml new file mode 100644 index 0000000..427414e --- /dev/null +++ b/sqlite/datascript_storage_sqlite_plugin.ml @@ -0,0 +1,24 @@ +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 + (* Share path: live indexes use this SQLite db, so mirror sync is unnecessary. *) + let sync_indexes_to_storage ~since_tx = ignore since_tx in + let sync_removals_to_storage removed_datoms = + (* Removals already applied to the shared SQLite indexes during purge. *) + ignore removed_datoms + in + let load_indexes_from_storage _target = () 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 = Share_index_db (Sqlite sqlite) + } + +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 592b17f..52d7e5f 100644 --- a/sqlite/dune +++ b/sqlite/dune @@ -1,10 +1,32 @@ +(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 sqlite_index_native) + (public_name datascript-ocaml-native-sqlite.index) + (wrapped false) + (modes native) + (modules datascript_sqlite_index) + (libraries datascript_index_codec sqlite_db_native 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 persistent_sorted_set_ocaml melange-transit-native)) + (modules + datascript_sqlite + datascript_sqlite_codec + datascript_storage_sqlite + datascript_storage_sqlite_plugin) + (libraries + datascript-ocaml-native + storage_native + datascript_index_codec + sqlite_db_native + sqlite_index_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..56f9881 --- /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_index_codec.encode_datoms + [ { e = value; a = ""; v = Nil; tx = 0; added = true } ] + +let decode_int bytes = + match Datascript_index_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_index_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_index_codec.encode_datoms db.duplicate_datoms) + +let restore_meta meta_get = + let schema = + match meta_get meta_schema_key with + | None -> [] + | Some bytes -> Datascript_index_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_index_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..31bb93d --- /dev/null +++ b/storage/melange/datascript_storage_protocol.ml @@ -0,0 +1,154 @@ +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 -> 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 = ignore since_tx 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 benchmark_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 storage = + ensure_live storage; + (backend_of storage).sync_indexes_to_storage ~since_tx + +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 = ignore since_tx 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..fa917d8 --- /dev/null +++ b/storage/melange/datascript_storage_protocol.mli @@ -0,0 +1,35 @@ +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 -> 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 benchmark_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 -> 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..409e212 --- /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 byte) + (modules + datascript_storage_meta + datascript_storage_lmdb + datascript_storage_protocol) + (libraries datascript_index_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..56f9881 --- /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_index_codec.encode_datoms + [ { e = value; a = ""; v = Nil; tx = 0; added = true } ] + +let decode_int bytes = + match Datascript_index_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_index_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_index_codec.encode_datoms db.duplicate_datoms) + +let restore_meta meta_get = + let schema = + match meta_get meta_schema_key with + | None -> [] + | Some bytes -> Datascript_index_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_index_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..4997bc0 --- /dev/null +++ b/storage/native/datascript_storage_protocol.ml @@ -0,0 +1,142 @@ +open Datascript_types + +(** Shared index database handle for a storage backend. *) +type index_db = + | Lmdb of Datascript_lmdb_db.t + | Sqlite of Datascript_sqlite_db.t + +(** How a storage backend relates to the live index layer. *) +type storage_index_db = + | Share_index_db of index_db + | 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 -> unit + ; sync_removals_to_storage : datom list -> unit + ; load_indexes_from_storage : index_db -> 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 + (* Share path: live indexes use this LMDB env, so delta sync is unnecessary. *) + let sync_indexes_to_storage ~since_tx = ignore since_tx 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 = + match target with + | Lmdb target_lmdb when lmdb != target_lmdb -> + Datascript_storage_lmdb.sync_indexes lmdb target_lmdb + | Lmdb _ | Sqlite _ -> () + 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 lmdb) + } + +let memory_storage () = + register_backend (memory_backend (Datascript_lmdb_db.create_temp ())) () + +let benchmark_memory_storage () = + register_backend (memory_backend (Datascript_lmdb_db.create_benchmark_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 storage = + ensure_live storage; + (backend_of storage).sync_indexes_to_storage ~since_tx + +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 = + ensure_live storage; + (backend_of storage).load_indexes_from_storage target + +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 index db" + +let same_storage_db storage index_db = + ensure_live storage; + match (backend_of storage).index_db, index_db with + | Share_index_db (Lmdb a), Lmdb b -> a == b + | Share_index_db (Sqlite a), Sqlite b -> a == b + | Share_index_db _, _ -> false + | Separate_index_db, _ -> false + +let create_index_db storage = + match storage with + | None -> (Lmdb (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 -> (Lmdb (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..5e526b2 --- /dev/null +++ b/storage/native/datascript_storage_protocol.mli @@ -0,0 +1,51 @@ +open Datascript_types + +(** Shared index database handle for a storage backend. *) +type index_db = + | Lmdb of Datascript_lmdb_db.t + | Sqlite of Datascript_sqlite_db.t + +(** How a storage backend relates to the live index layer. + + - [Share_index_db handle]: index datoms live in the same store as storage + (memory/file LMDB and SQLite backends). + - [Separate_index_db]: storage keeps its own tables and copies into a + temporary index on restore (legacy mirror backends). *) +type storage_index_db = + | Share_index_db of index_db + | 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 -> unit + ; sync_removals_to_storage : datom list -> unit + ; load_indexes_from_storage : index_db -> unit + ; index_db : storage_index_db +} + +val kind_of : storage -> storage_kind +val ensure_live : storage -> unit +val memory_storage : unit -> storage +val benchmark_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 -> storage -> unit +val sync_removals_to_storage : datom list -> storage -> unit +val load_indexes_from_storage : storage -> index_db -> unit +val db_for_storage : storage -> index_db +val same_storage_db : storage -> index_db -> bool +val create_index_db : storage option -> index_db * 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..1764f56 --- /dev/null +++ b/storage/native/dune @@ -0,0 +1,17 @@ +(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_index_codec + lmdb_db_native + lmdb_index_native + sqlite_db_native + datascript_types)) diff --git a/test/debug_wildcard_pull_slowcase.ml b/test/debug_wildcard_pull_slowcase.ml new file mode 100644 index 0000000..604fa8e --- /dev/null +++ b/test/debug_wildcard_pull_slowcase.ml @@ -0,0 +1,66 @@ +open Datascript + +let ref_many = + { cardinality = Many + ; unique = None + ; indexed = false + ; is_component = false + ; no_history = false + ; doc = None + ; value_type = Some RefType + ; tuple_attrs = None + ; tuple_types = None + } + +let ref_one = { ref_many with cardinality = One } + +let one = { ref_many with cardinality = One; value_type = None } + +let test_wildcard_pull_page_missing () = + let page_count = 20 in + let noise_count = 500_000 in + let page_datoms = + List.concat + (List.init page_count (fun index -> + let page = 1_000 + index in + let block = 10_000 + index in + [ datom ~e:page ~a:"block/name" ~v:(String (Printf.sprintf "page-%d" index)) () + ; datom ~e:page ~a:"block/title" ~v:(String (Printf.sprintf "Page %d" index)) () + ; datom ~e:block ~a:"block/title" ~v:(String (Printf.sprintf "Block %d" index)) () + ; datom ~e:block ~a:"block/page" ~v:(Ref page) () + ])) + in + let noise_datoms = + List.init noise_count (fun index -> + datom ~e:(100_000 + index) ~a:"noise/value" ~v:(String (Printf.sprintf "noise-%d" index)) ()) + in + let db = + init_db + ~schema: + [ "block/name", one + ; "block/title", one + ; "block/page", ref_one + ; "logseq.property/built-in?", one + ; "noise/value", one + ] + (page_datoms @ noise_datoms) + in + Printf.eprintf "[repro] db max_e=%d\n%!" db.max_datom_e; + let started = Unix.gettimeofday () in + let result = + q_return_string + db + "[:find (pull ?p [*]) :where [?b :block/title] [?b :block/page ?p] [(missing? $ ?p :logseq.property/built-in?)]]" + in + let elapsed = Unix.gettimeofday () -. started in + match result with + | Query_relation rows -> + Printf.eprintf "[repro] elapsed=%.3fs rows=%d\n%!" elapsed (List.length rows); + if elapsed > 3.0 then ( + Printf.eprintf "[repro] FAIL: exceeded 3s threshold\n%!"; + exit 1) + | _ -> + Printf.eprintf "[repro] unexpected result\n%!"; + exit 1 + +let () = test_wildcard_pull_page_missing () diff --git a/test/dune b/test/dune index 6666a0e..38fe3bc 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)) + (test (name test_lru) (modules test_lru) @@ -18,14 +24,51 @@ (modules test_core) (libraries datascript-ocaml-native)) +(test + (name test_tx_visibility) + (modules test_tx_visibility) + (libraries datascript-ocaml-native)) + +(test + (name test_tx_history) + (modules test_tx_history) + (libraries datascript-ocaml-native test_support alcotest)) + +(test + (name test_shared_api_parity) + (modules test_shared_api_parity) + (libraries datascript-ocaml-native test_support alcotest)) + +(test + (name test_query_plan) + (modules test_query_plan) + (libraries datascript-ocaml-native test_support alcotest)) + +(test + (name test_query_exec_parity) + (modules test_query_exec_parity) + (libraries datascript-ocaml-native test_support alcotest)) + +(test + (name test_shared_queries) + (modules test_shared_queries) + (libraries datascript-ocaml-native test_support alcotest)) + +(test + (name test_purge) + (modules test_purge) + (libraries datascript-ocaml-native test_support alcotest)) + (test (name test_db) (modules test_db) - (libraries datascript-ocaml-native persistent_sorted_set_ocaml unix)) + (libraries datascript-ocaml-native unix)) (test (name test_perf) (modules test_perf) + ;; Performance regression gates; run manually when tuning hot paths. + (enabled_if false) (libraries datascript-ocaml-native unix)) (test @@ -118,18 +161,15 @@ (modules test_serialize) (libraries datascript-ocaml-native)) -(test - (name test_sqlite_storage) - (modules test_sqlite_storage) - (libraries datascript-ocaml-native logseq_sqlite_storage unix sqlite3 melange-transit-native)) - (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 test_support alcotest)) (test (name test_melange_transit_backend) @@ -153,6 +193,8 @@ (rule (alias runtest) + ;; Requires lein-built upstream DataScript JS; skip when unavailable in CI/cloud. + (enabled_if false) (deps sqlite_cross_runtime_native.exe sqlite_cross_runtime_parity.js @@ -166,20 +208,22 @@ %{dep:sqlite_cross_runtime_native.exe} %{dep:../js/datascript_js.bc.js}))) -(test - (name test_logseq_query_parity) - (modules test_logseq_query_parity) - (libraries datascript-ocaml-native logseq_sqlite_storage unix sqlite3)) - (test (name test_logseq_query_planners) (modules test_logseq_query_planners) + ;; Large timed planner gates; run manually when tuning query planners. + (enabled_if false) + (libraries datascript-ocaml-native unix)) + +(executable + (name debug_wildcard_pull_slowcase) + (modules debug_wildcard_pull_slowcase) (libraries datascript-ocaml-native unix)) (test (name test_storage) (modules test_storage) - (libraries datascript-ocaml-native unix)) + (libraries datascript-ocaml-native test_support alcotest unix)) (test (name test_upsert) @@ -231,6 +275,8 @@ (rule (alias runtest) + ;; Requires lein-built upstream DataScript JS; skip when unavailable in CI/cloud. + (enabled_if false) (deps cross_runtime_parity_test.sh cross_runtime_ocaml.exe @@ -244,3 +290,5 @@ %{dep:cross_runtime_parity_test.sh} %{dep:cross_runtime_ocaml.exe} %{dep:../script/cross_runtime_upstream.js}))) + + 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_db.ml b/test/test_db.ml index 5c19e0a..02e62d3 100644 --- a/test/test_db.ml +++ b/test/test_db.ml @@ -71,7 +71,7 @@ let indexed = let unique_identity = { indexed with unique = Some Identity } -let assert_uses_persistent_sorted_set (_index : datom Persistent_sorted_set.t) = () +let assert_uses_lmdb_index (_index : index_set) = () let test_db__test_defrecord_updatable () = let value = { x = Keyword "ignored"; tag = "kept" } in @@ -190,7 +190,7 @@ let test_db__test_index_api () = () |> List.rev) -let test_db__test_indexes_use_persistent_sorted_set () = +let test_db__test_indexes_use_lmdb () = let db = empty_db ~schema:[ "name", indexed; "friend", { indexed with value_type = Some RefType } ] () |> db_with @@ -199,9 +199,9 @@ let test_db__test_indexes_use_persistent_sorted_set () = ; Add (Entity_id 2, "name", String "Oleg") ] in - assert_uses_persistent_sorted_set db.eavt_index; - assert_uses_persistent_sorted_set db.aevt_index; - assert_uses_persistent_sorted_set db.avet_index + assert_uses_lmdb_index db.eavt_index; + assert_uses_lmdb_index db.aevt_index; + assert_uses_lmdb_index db.avet_index let test_db__test_index_lookup_matches_upstream_numeric_comparator_bounds () = let db = @@ -225,12 +225,62 @@ 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 (); test_db__test_index_api (); - test_db__test_indexes_use_persistent_sorted_set (); + test_db__test_indexes_use_lmdb (); test_db__test_index_lookup_matches_upstream_numeric_comparator_bounds () diff --git a/test/test_lmdb_package.ml b/test/test_lmdb_package.ml new file mode 100644 index 0000000..290b960 --- /dev/null +++ b/test/test_lmdb_package.ml @@ -0,0 +1,93 @@ +open Alcotest +open Datascript + +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 + Sys.remove path; + path + +let indexed = + { cardinality = One + ; unique = Some Identity + ; indexed = true + ; is_component = false + ; no_history = false + ; doc = None + ; value_type = Some StringType + ; tuple_attrs = None + ; tuple_types = None + } + +let test_storage_roundtrip () = + let path = temp_db_path "datascript-lmdb-package" in + let session = Datascript_lmdb.open_session path in + let storage = storage_of_handle (Datascript_lmdb.storage session) in + let db = empty_db ~schema:[ "todo/id", indexed ] ~storage () in + let report = + transact + db + [ Add (Temp_id "todo-1", "todo/id", String "todo-1") + ; Add (Temp_id "todo-1", "todo/title", String "Move storage into datascript") + ] + in + store ~storage report.db_after; + let restored = + match restore storage with + | Some db -> db + | None -> failwith "expected LMDB storage to restore a database" + in + let entity = + match entity restored (Lookup_ref ("todo/id", String "todo-1")) with + | Some entity -> entity + | None -> failwith "expected restored todo entity" + in + 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 = storage_of_handle (Datascript_lmdb.storage session) in + Datascript_lmdb.close session; + expect_invalid_arg_msg "LMDB session is closed" (fun () -> ensure_live storage) + +let test_reopen_preserves_data () = + let path = temp_db_path "datascript-lmdb-reopen" in + let session = Datascript_lmdb.open_session path in + let storage = storage_of_handle (Datascript_lmdb.storage session) in + let db = empty_db ~schema:[ "todo/id", indexed ] ~storage () in + let report = + transact db [ Add (Temp_id "todo-1", "todo/id", String "persisted") ] + in + store ~storage report.db_after; + collect_garbage storage; + Datascript_lmdb.close session; + let session = Datascript_lmdb.open_session path in + let storage = storage_of_handle (Datascript_lmdb.storage session) in + let restored = + match restore storage with + | Some db -> db + | None -> failwith "expected reopen restore" + in + check_bool "reopen restore shares LMDB index" true + (db_shares_storage_index storage restored); + (match entity restored (Lookup_ref ("todo/id", String "persisted")) with + | Some _ -> () + | None -> failwith "expected persisted entity after reopen"); + Datascript_lmdb.close session + +let () = + run "lmdb package" + [ + ( "session" + , [ + test_case "storage roundtrip" `Quick test_storage_roundtrip + ; test_case "session close blocks use" `Quick test_session_close_blocks_use + ; test_case "reopen preserves data" `Quick test_reopen_preserves_data + ] ) + ] diff --git a/test/test_logseq_query_parity.ml b/test/test_logseq_query_parity.ml deleted file mode 100644 index 7d86e75..0000000 --- a/test/test_logseq_query_parity.ml +++ /dev/null @@ -1,150 +0,0 @@ -open Datascript - -module Sqlite_storage = Logseq_sqlite_storage - -let failf fmt = Printf.ksprintf failwith fmt - -let with_sqlite db_path f = - let db = Sqlite3.db_open db_path in - Fun.protect - ~finally:(fun () -> - if not (Sqlite3.db_close db) then failf "failed to close SQLite database: %s" db_path) - (fun () -> f db) - -let check_sql db sql rc = - if not (Sqlite3.Rc.is_success rc) then - failf "SQLite statement failed with %s for %S: %s" (Sqlite3.Rc.to_string rc) sql (Sqlite3.errmsg db) - -let run_sql db_path sql = - with_sqlite db_path (fun db -> check_sql db sql (Sqlite3.exec db sql)) - -let sql_quote text = - "'" ^ String.concat "''" (String.split_on_char '\'' text) ^ "'" - -let with_temp_db f = - let dir = - Filename.concat - (Filename.get_temp_dir_name ()) - ("datascript_ocaml_logseq_query_parity_" ^ string_of_int (Random.bits ())) - in - Unix.mkdir dir 0o755; - let db_path = Filename.concat dir "db.sqlite" in - Fun.protect - ~finally:(fun () -> - if Sys.file_exists db_path then Sys.remove db_path; - if Sys.file_exists dir then Unix.rmdir dir) - (fun () -> f db_path) - -let int_collection = function - | Query_collection values -> - values - |> List.map (function - | Result_entity entity_id -> entity_id - | _ -> failwith "expected entity result") - |> List.sort compare - | _ -> failwith "expected collection result" - -let assert_equal_ints label expected actual = - let actual = List.sort compare actual in - if expected <> actual then - failf - "%s: expected [%s], got [%s]" - label - (expected |> List.map string_of_int |> String.concat "; ") - (actual |> List.map string_of_int |> String.concat "; ") - -let pulled_attr attr entity = - List.assoc_opt (Keyword attr) entity.pulled_attrs - -let test_attr_filtered_query_preserves_transit_shorthand_segment () = - with_temp_db (fun db_path -> - let root_content = - {|["^ ","~:schema",["^ ","~:db/ident",["^ ","~:db/unique","~:db.unique/identity","~:db/index",true]]]|} - in - let ident_row = - {|["^ ","~:keys",[[1,"~:db/ident","~:alpha",536870913]]]|} - in - let shorthand_ident_row = - {|["^ ","^0",[[2,"^1","~:beta",536870913]]]|} - in - let unrelated_broken_row = {|["^ ","~:keys",|} in - run_sql - db_path - ("create table kvs (addr INTEGER primary key, content TEXT, addresses JSON);\n" - ^ "insert into kvs (addr, content, addresses) values (0, " - ^ sql_quote root_content - ^ ", '[]');\n" - ^ "insert into kvs (addr, content, addresses) values (2, " - ^ sql_quote ident_row - ^ ", '[]');\n" - ^ "insert into kvs (addr, content, addresses) values (3, " - ^ sql_quote shorthand_ident_row - ^ ", '[]');\n" - ^ "insert into kvs (addr, content, addresses) values (4, " - ^ sql_quote unrelated_broken_row - ^ ", '[]');"); - Sqlite_storage.query_logseq_graph - ~read_only:true - db_path - "[:find [?e ...] :where [?e :db/ident]]" - |> int_collection - |> assert_equal_ints "Logseq query slicer should decode shorthand rows in a matching Transit segment" [ 1; 2 ]) - -let test_attr_filtered_query_keeps_idents_for_keyword_ref_constants () = - with_temp_db (fun db_path -> - let root_content = - {|["^ ","~:schema",["^ ","~:db/ident",["^ ","~:db/unique","~:db.unique/identity","~:db/index",true],"~:block/tags",["^ ","~:db/valueType","~:db.type/ref"]]]|} - in - let graph_row = - {|["^ ","~:keys",[[10,"~:block/tags",20,536870913],[20,"~:db/ident","~:logseq.class/Journal",536870913]]]|} - in - run_sql - db_path - ("create table kvs (addr INTEGER primary key, content TEXT, addresses JSON);\n" - ^ "insert into kvs (addr, content, addresses) values (0, " - ^ sql_quote root_content - ^ ", '[]');\n" - ^ "insert into kvs (addr, content, addresses) values (2, " - ^ sql_quote graph_row - ^ ", '[]');"); - Sqlite_storage.query_logseq_graph - ~read_only:true - db_path - "[:find [?e ...] :where [?e :block/tags :logseq.class/Journal]]" - |> int_collection - |> assert_equal_ints "Logseq query slicer should keep :db/ident datoms for keyword ref constants" [ 10 ]) - -let test_attr_filtered_query_keeps_pull_selector_attrs () = - with_temp_db (fun db_path -> - let root_content = - {|["^ ","~:schema",["^ ","~:db/ident",["^ ","~:db/unique","~:db.unique/identity","~:db/index",true]]]|} - in - let graph_row = - {|["^ ","~:keys",[[10,"~:file/path","logseq/config.edn",536870913],[10,"~:file/content","{:feature/markdown-mirror? true}",536870913]]]|} - in - run_sql - db_path - ("create table kvs (addr INTEGER primary key, content TEXT, addresses JSON);\n" - ^ "insert into kvs (addr, content, addresses) values (0, " - ^ sql_quote root_content - ^ ", '[]');\n" - ^ "insert into kvs (addr, content, addresses) values (2, " - ^ sql_quote graph_row - ^ ", '[]');"); - match - Sqlite_storage.query_logseq_graph - ~read_only:true - db_path - "[:find [(pull ?e [:file/path :file/content]) ...] :where [?e :file/path]]" - with - | Query_collection [ Result_pull entity ] -> - (match pulled_attr "file/content" entity with - | Some (Pulled_scalar (String "{:feature/markdown-mirror? true}")) -> () - | _ -> failwith "Logseq query slicer should keep pull selector attrs") - | _ -> failwith "expected one pulled entity") - -let () = - Random.self_init (); - test_attr_filtered_query_preserves_transit_shorthand_segment (); - test_attr_filtered_query_keeps_idents_for_keyword_ref_constants (); - test_attr_filtered_query_keeps_pull_selector_attrs () diff --git a/test/test_purge.ml b/test/test_purge.ml new file mode 100644 index 0000000..2e42780 --- /dev/null +++ b/test/test_purge.ml @@ -0,0 +1,115 @@ +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 + ; 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 + 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 + 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 + 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 + 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 + 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 + 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 + 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 + 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 + 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 + expect_invalid_arg (fun () -> ignore (db_with [ PurgeEntity (Lookup_ref ("name", String "Alice")) ] db)) + +let () = + 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_query_exec_parity.ml b/test/test_query_exec_parity.ml new file mode 100644 index 0000000..7df31a8 --- /dev/null +++ b/test/test_query_exec_parity.ml @@ -0,0 +1,299 @@ +(** Query_exec path probes + fused vs relational fallback parity. + + Complements [test_shared_queries] (result goldens) by asserting: + 1. hot shared shapes actually take [Fused_execute] + 2. forcing relational fallback yields identical sorted digests + 3. known non-fused shapes stay on [Relation_fallback] *) + +open Alcotest +open Datascript +open Test_alcotest_support + +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 ref_many = + { cardinality = Many + ; unique = None + ; indexed = false + ; is_component = false + ; no_history = false + ; doc = None + ; value_type = Some RefType + ; tuple_attrs = None + ; tuple_types = None + } + +let schema = + [ "name", indexed + ; "last-name", indexed + ; "sex", indexed + ; "age", indexed + ; "salary", indexed + ; "follows", ref_many + ] + +let names = [| "Ivan"; "Petr"; "Sergei"; "Oleg"; "Yuri"; "Dmitry"; "Fedor"; "Denis" |] +let last_names = [| "Ivanov"; "Petrov"; "Sidorov"; "Kovalev"; "Kuznetsov"; "Voronoi" |] +let sexes = [| "male"; "female" |] + +type rng = { mutable state : int32 } + +let rng seed = { state = Int32.of_int seed } + +let next_int rng bound = + rng.state <- Int32.add (Int32.mul rng.state 1_664_525l) 1_013_904_223l; + Int32.(to_int (rem (logand (shift_right_logical rng.state 1) 0x3fffffffl) (of_int bound))) + +let rand_nth rng values = values.(next_int rng (Array.length values)) +let rand_sex rng = sexes.(next_int rng 997 mod Array.length sexes) + +let build_db size = + let rng = rng 1 in + let entities = + List.init size (fun index -> + let i = index + 1 in + Entity + { db_id = Some (Temp_id (string_of_int i)) + ; attrs = + [ "name", One_value (String (rand_nth rng names)) + ; "last-name", One_value (String (rand_nth rng last_names)) + ; "sex", One_value (Keyword (rand_sex rng)) + ; "age", One_value (Int (next_int rng 100)) + ; "salary", One_value (Int (next_int rng 100_000)) + ] + }) + in + let db = db_with entities (empty_db ~schema ()) in + let follow_ops = + List.concat_map + (fun entity_id -> + if next_int rng 2 = 0 then + [ Add (Entity_id entity_id, "follows", Ref (1 + next_int rng size)) ] + else + []) + (List.init size (fun index -> index + 1)) + in + if follow_ops = [] then db else db_with follow_ops db + +let follow_rules = + Parser.parse_rules + (QueryFormVector + [ QueryFormVector + [ QueryFormVector [ QueryFormSymbol "follow"; QueryFormSymbol "?e1"; QueryFormSymbol "?e2" ] + ; QueryFormVector + [ QueryFormSymbol "?e1"; QueryFormKeyword "follows"; QueryFormSymbol "?e2" ] + ] ]) + +let sort_rows rows = + List.sort + (fun left right -> + compare + (List.map + (function + | Result_value v -> v + | Result_entity e -> Int e + | Result_attr a -> Keyword a + | Result_db _ -> Nil + | Result_pull _ -> Nil) + left) + (List.map + (function + | Result_value v -> v + | Result_entity e -> Int e + | Result_attr a -> Keyword a + | Result_db _ -> Nil + | Result_pull _ -> Nil) + right)) + rows + +let cell_digest = function + | Result_entity e -> "e:" ^ string_of_int e + | Result_attr a -> "a:" ^ a + | Result_value (Int i) -> "i:" ^ string_of_int i + | Result_value (Float f) -> "f:" ^ string_of_float f + | Result_value (String s) -> "s:" ^ s + | Result_value (Keyword k) -> "k:" ^ k + | Result_value (Bool b) -> "b:" ^ string_of_bool b + | Result_value (Ref e) -> "r:" ^ string_of_int e + | Result_value _ -> "v:?" + | Result_db _ -> "db" + | Result_pull _ -> "pull" + +let rows_digest rows = + sort_rows rows + |> List.map (fun row -> String.concat "," (List.map cell_digest row)) + |> String.concat "|" + |> Digest.string + |> Digest.to_hex + +let path_name = function + | Fused_execute -> "fused" + | Relation_fallback -> "fallback" + | Binding_interpreter -> "binding" + +let check_path name expected = + check string (name ^ "-path") (path_name expected) (path_name (last_query_exec_path ())) + +let db = lazy (build_db 500) + +let plan_of query_string = + let query = parse_query_string query_string in + match Query_plan.compile ~max_datom_e:(Lazy.force db).max_datom_e query.where with + | Some plan -> plan + | None -> failwith ("expected plan for " ^ query_string) + +type case = + { name : string + ; query : string + ; inputs : query_arg list + ; expect_path : query_exec_path + ; expect_fused_plan : bool + } + +let fused_cases = + [ { name = "q1" + ; query = "[:find ?e :where [?e :name \"Ivan\"]]" + ; inputs = [] + ; expect_path = Fused_execute + ; expect_fused_plan = true + } + ; { name = "q2" + ; query = "[:find ?e ?a :where [?e :name \"Ivan\"] [?e :age ?a]]" + ; inputs = [] + ; expect_path = Fused_execute + ; expect_fused_plan = true + } + ; { name = "q2-switch" + ; query = "[:find ?e ?a :where [?e :age ?a] [?e :name \"Ivan\"]]" + ; inputs = [] + ; expect_path = Fused_execute + ; expect_fused_plan = true + } + ; { name = "q3" + ; query = "[:find ?e ?a :where [?e :name \"Ivan\"] [?e :age ?a] [?e :sex :male]]" + ; inputs = [] + ; expect_path = Fused_execute + ; expect_fused_plan = true + } + ; { name = "q-5-merge" + ; query = + "[:find ?e ?n ?l ?a ?s :where [?e :name ?n] [?e :last-name ?l] [?e :age ?a] [?e :salary ?s] [?e :sex :male]]" + ; inputs = [] + ; expect_path = Fused_execute + ; expect_fused_plan = true + } + ; { name = "q-not" + ; query = "[:find ?e ?a :where [?e :age ?a] (not [?e :sex :male])]" + ; inputs = [] + ; expect_path = Fused_execute + ; expect_fused_plan = true + } + ; { name = "q-not-join" + ; query = "[:find ?e ?a :where [?e :age ?a] (not-join [?e] [?e :sex :male])]" + ; inputs = [] + ; expect_path = Fused_execute + ; expect_fused_plan = true + } + ] + +let fallback_cases = + [ { name = "q-or" + ; query = "[:find ?e :where (or [?e :name \"Ivan\"] [?e :name \"Petr\"])]" + ; inputs = [] + ; expect_path = Relation_fallback + ; expect_fused_plan = false + } + ; { name = "q-or-join" + ; query = + "[:find ?e ?a :where [?e :age ?a] (or-join [?e] [?e :name \"Ivan\"] [?e :name \"Petr\"])]" + ; inputs = [] + ; expect_path = Relation_fallback + ; expect_fused_plan = false + } + ; { name = "q-rule" + ; query = "[:find ?e1 ?e2 :in $ % :where (follow ?e1 ?e2)]" + ; inputs = [ Arg_rules follow_rules ] + ; expect_path = Relation_fallback + ; expect_fused_plan = false + } + ; { name = "qpred2-input" + ; query = "[:find ?e ?s :in $ ?min_s :where [?e :salary ?s] [(> ?s ?min_s)]]" + ; inputs = [ Arg_scalar (Result_value (Int 50_000)) ] + ; expect_path = Relation_fallback + ; expect_fused_plan = false + } + ] + +let run_case db case = + match case.inputs with + | [] -> q_string db case.query + | inputs -> q_string ~inputs db case.query + +let test_fused_path_and_plan_shape () = + let db = Lazy.force db in + List.iter + (fun case -> + let plan = plan_of case.query in + check_bool (case.name ^ "-fused-plan") case.expect_fused_plan + (Query_plan.plan_is_fused_execute plan); + ignore (run_case db case); + check_path case.name case.expect_path) + fused_cases + +let test_fallback_path_shapes () = + let db = Lazy.force db in + List.iter + (fun case -> + (match case.inputs with + | [] -> + let plan = plan_of case.query in + check_bool (case.name ^ "-not-fused-plan") (not case.expect_fused_plan) + (not (Query_plan.plan_is_fused_execute plan)) + | _ -> ()); + ignore (run_case db case); + check_path case.name case.expect_path) + fallback_cases + +let test_force_fallback_parity () = + let db = Lazy.force db in + List.iter + (fun case -> + let fused_rows = run_case db case in + check_path (case.name ^ "-before-force") Fused_execute; + let fused_digest = rows_digest fused_rows in + let fallback_rows = + with_force_relation_fallback (fun () -> + let rows = run_case db case in + check_path (case.name ^ "-forced") Relation_fallback; + rows) + in + check string (case.name ^ "-digest-parity") fused_digest (rows_digest fallback_rows); + check_int (case.name ^ "-count-parity") (List.length fused_rows) (List.length fallback_rows)) + fused_cases + +let test_force_fallback_restores () = + let db = Lazy.force db in + let case = List.hd fused_cases in + ignore (with_force_relation_fallback (fun () -> run_case db case)); + ignore (run_case db case); + check_path "restored-after-force" Fused_execute + +let () = + run "query exec parity" + [ ( "path" + , [ test_case "fused shapes use Query_exec" `Quick test_fused_path_and_plan_shape + ; test_case "fallback shapes stay relational" `Quick test_fallback_path_shapes + ; test_case "force fallback matches fused digests" `Quick test_force_fallback_parity + ; test_case "force fallback restores fused path" `Quick test_force_fallback_restores + ] ) + ] diff --git a/test/test_query_plan.ml b/test/test_query_plan.ml new file mode 100644 index 0000000..f13408d --- /dev/null +++ b/test/test_query_plan.ml @@ -0,0 +1,129 @@ +open Alcotest +open Datascript + +let check_int = Test_alcotest_support.check_int +let check_bool = Test_alcotest_support.check_bool + +let test_choose_index_prefers_narrowest () = + check_bool "ground entity prefers EAVT" true + (Query_plan.choose_index (QEntity 1) (QAttr "age") (QVar "?a") = Query_plan.Prefer_eavt); + check_bool "attr+value prefers AVET" true + (Query_plan.choose_index (QVar "?e") (QAttr "name") (QValue (String "Ivan")) = Query_plan.Prefer_avet); + check_bool "attr-only prefers AEVT" true + (Query_plan.choose_index (QVar "?e") (QAttr "age") (QVar "?a") = Query_plan.Prefer_aevt) + +let test_compile_orders_constants_first () = + let wide = Pattern (QVar "?e", QAttr "age", QVar "?a") in + let narrow = Pattern (QVar "?e", QAttr "name", QValue (String "Ivan")) in + match Query_plan.compile [ wide; narrow ] with + | None -> failwith "expected a plan" + | Some plan -> + (match plan.ops with + | [ Query_plan.OpEntityGroup { clauses; _ } ] -> + check_bool "constant pattern drives entity group" true (List.hd clauses = narrow) + | [ Query_plan.OpScan { clause; _ }; _ ] -> + check_bool "constant scan ordered first" true (clause = narrow) + | _ -> + let ordered = Query_plan.clauses_of_plan plan in + check_bool "constant AVET pattern should sort before open AEVT scan" true + (List.hd ordered = narrow)) + +let test_analyze_same_entity_merge () = + let query = + { find = [ Find_var "?e"; Find_var "?a" ] + ; inputs = [] + ; with_vars = [] + ; rules = [] + ; where = + [ Pattern (QVar "?e", QAttr "name", QValue (String "Ivan")) + ; Pattern (QVar "?e", QAttr "age", QVar "?a") + ] + } + in + match Query_plan.analyze query with + | None -> failwith "expected a plan" + | Some plan -> + check_bool "same-entity plan is fused execute" true (Query_plan.plan_is_fused_execute plan); + (match plan.ops with + | [ Query_plan.OpEntityGroup { clauses; _ } ] -> + check_int "entity group collapses same-entity legs" 2 (List.length clauses) + | [ Query_plan.OpScan _; Query_plan.OpScan _ ] -> + check_bool "analyze produced scan ops" true true + | _ -> failwith "unexpected plan shape") + +let test_analyze_benchmark_shapes () = + let qpred = + { find = [ Find_var "?e" ] + ; inputs = [] + ; with_vars = [] + ; rules = [] + ; where = + [ Pattern (QVar "?e", QAttr "age", QVar "?a") + ; ComparisonPredicate (GreaterThan, QVar "?a", QValue (Int 18)) + ] + } + in + (match Query_plan.analyze qpred with + | None -> failwith "predicate shape should analyze" + | Some plan -> + check_bool "predicate plan executable" true (Query_plan.plan_is_executable plan)); + let qrule = + { find = [ Find_var "?e1"; Find_var "?e2" ] + ; inputs = [ Input_rules_decl ] + ; with_vars = [] + ; rules = + [ { rule_name = "follow" + ; rule_params = [ "?e1"; "?e2" ] + ; rule_body = [ Pattern (QVar "?e1", QAttr "follows", QVar "?e2") ] + } + ] + ; where = [ Rule ("follow", [ QVar "?e1"; QVar "?e2" ]) ] + } + in + match Query_plan.analyze qrule with + | None -> failwith "rule head should analyze" + | Some plan -> + check_bool "inlined rule plan executable" true (Query_plan.plan_is_executable plan) + +let test_logical_entity_join () = + let clauses = + [ Pattern (QVar "?e", QAttr "name", QValue (String "Ivan")) + ; Pattern (QVar "?e", QAttr "age", QVar "?a") + ; ComparisonPredicate (GreaterThan, QVar "?a", QValue (Int 18)) + ] + in + match Query_plan.build_logical_plan clauses with + | None -> failwith "expected logical plan" + | Some logical -> + (match logical.nodes with + | [ Query_plan.LEntityJoin { scans; filters; _ } ] -> + check_int "two scans in entity join" 2 (List.length scans); + check_int "filter attached to entity join" 1 (List.length filters) + | _ -> failwith "expected LEntityJoin") + +let test_logical_not_join_fold () = + let clauses = + [ Pattern (QVar "?e", QAttr "age", QVar "?a") + ; NotJoin ([ "?e" ], [ Pattern (QVar "?e", QAttr "sex", QValue (Keyword "male")) ]) + ] + in + match Query_plan.build_logical_plan clauses with + | None -> failwith "expected logical plan" + | Some logical -> ( + match logical.nodes with + | [ Query_plan.LEntityJoin { scans; anti_scans; _ } ] -> + check_int "not-join folds to entity anti-scan" 1 (List.length anti_scans); + check_int "positive scan in entity join" 1 (List.length scans) + | _ -> failwith "expected LEntityJoin with folded not-join") + +let () = + run "query plan" + [ ( "analyze" + , [ test_case "choose_index prefers narrowest" `Quick test_choose_index_prefers_narrowest + ; test_case "compile orders constants first" `Quick test_compile_orders_constants_first + ; test_case "analyze same-entity merge" `Quick test_analyze_same_entity_merge + ; test_case "analyze benchmark shapes" `Quick test_analyze_benchmark_shapes + ; test_case "logical entity join attaches filters" `Quick test_logical_entity_join + ; test_case "logical not-join folds to anti-scan" `Quick test_logical_not_join_fold + ] ) + ] diff --git a/test/test_shared_api_parity.ml b/test/test_shared_api_parity.ml new file mode 100644 index 0000000..bfaf11e --- /dev/null +++ b/test/test_shared_api_parity.ml @@ -0,0 +1,639 @@ +(** Shared-API category parity tests. + Covers queries / writes / rules / aggregates / temporal / joins with + deterministic fixtures and identical result-set assertions (not just counts). *) + +open Alcotest +open Datascript +open Test_alcotest_support + +let failf fmt = Printf.ksprintf failwith fmt + +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 ref_one = + { indexed with indexed = false; value_type = Some RefType } + +let ref_many = { ref_one with cardinality = Many } + +let sort_rows rows = + List.sort + (fun left right -> + compare + (List.map (fun r -> match r with Result_value v -> v | Result_entity e -> Int e | _ -> Nil) left) + (List.map (fun r -> match r with Result_value v -> v | Result_entity e -> Int e | _ -> Nil) right)) + rows + +let check_rows label expected actual = + check + (list (list (testable (fun fmt r -> Format.pp_print_string fmt (match r with + | Result_value (Int i) -> string_of_int i + | Result_value (Float f) -> string_of_float f + | Result_value (String s) -> Printf.sprintf "%S" s + | Result_value (Keyword k) -> ":" ^ k + | Result_entity e -> "e:" ^ string_of_int e + | _ -> "?")) ( = )))) + label + (sort_rows expected) + (sort_rows actual) + +let rv v = Result_value v +let re e = Result_entity e + +let float_close label expected actual = + match actual with + | Result_value (Float value) -> + if abs_float (value -. expected) > 1e-9 then + failf "%s: expected %g, got %g" label expected value + | Result_value (Int value) when float_of_int value = expected -> () + | _ -> failf "%s: expected float %g" label expected + +(* ---------- people fixture (queries + aggregates) ---------- *) + +let people_schema = + [ "name", indexed + ; "last-name", indexed + ; "sex", indexed + ; "age", indexed + ; "salary", indexed + ; "follows", ref_many + ] + +let people_db () = + empty_db ~schema:people_schema () + |> db_with + [ Entity + { db_id = Some (Entity_id 1) + ; attrs = + [ "name", One_value (String "Ivan") + ; "last-name", One_value (String "Ivanov") + ; "sex", One_value (Keyword "male") + ; "age", One_value (Int 30) + ; "salary", One_value (Int 60_000) + ] + } + ; Entity + { db_id = Some (Entity_id 2) + ; attrs = + [ "name", One_value (String "Petr") + ; "last-name", One_value (String "Petrov") + ; "sex", One_value (Keyword "male") + ; "age", One_value (Int 25) + ; "salary", One_value (Int 40_000) + ] + } + ; Entity + { db_id = Some (Entity_id 3) + ; attrs = + [ "name", One_value (String "Ivan") + ; "last-name", One_value (String "Sidorov") + ; "sex", One_value (Keyword "female") + ; "age", One_value (Int 30) + ; "salary", One_value (Int 80_000) + ] + } + ; Entity + { db_id = Some (Entity_id 4) + ; attrs = + [ "name", One_value (String "Oleg") + ; "last-name", One_value (String "Kovalev") + ; "sex", One_value (Keyword "female") + ; "age", One_value (Int 40) + ; "salary", One_value (Int 55_000) + ] + } + ] + |> db_with + [ Add (Entity_id 1, "follows", Ref 2) + ; Add (Entity_id 2, "follows", Ref 3) + ] + +let follow_rules_nonrec = + Parser.parse_rules + (QueryFormVector + [ QueryFormVector + [ QueryFormVector [ QueryFormSymbol "follow"; QueryFormSymbol "?e1"; QueryFormSymbol "?e2" ] + ; QueryFormVector + [ QueryFormSymbol "?e1"; QueryFormKeyword "follows"; QueryFormSymbol "?e2" ] + ] ]) + +let follow_rules_rec = + Parser.parse_rules + (QueryFormVector + [ QueryFormVector + [ QueryFormVector [ QueryFormSymbol "follows"; QueryFormSymbol "?x"; QueryFormSymbol "?y" ] + ; QueryFormVector + [ QueryFormSymbol "?x"; QueryFormKeyword "follows"; QueryFormSymbol "?y" ] + ] + ; QueryFormVector + [ QueryFormVector [ QueryFormSymbol "follows"; QueryFormSymbol "?x"; QueryFormSymbol "?y" ] + ; QueryFormVector + [ QueryFormSymbol "?x"; QueryFormKeyword "follows"; QueryFormSymbol "?t" ] + ; QueryFormVector + [ QueryFormSymbol "follows"; QueryFormSymbol "?t"; QueryFormSymbol "?y" ] + ] + ]) + +(* ---------- queries category ---------- *) + +let test_queries () = + let db = people_db () in + check_rows "q1" + [ [ re 1 ]; [ re 3 ] ] + (q_string db "[:find ?e :where [?e :name \"Ivan\"]]"); + check_rows "q2" + [ [ re 1; rv (Int 30) ]; [ re 3; rv (Int 30) ] ] + (q_string db "[:find ?e ?a :where [?e :name \"Ivan\"] [?e :age ?a]]"); + check_rows "q2-switch" + [ [ re 1; rv (Int 30) ]; [ re 3; rv (Int 30) ] ] + (q_string db "[:find ?e ?a :where [?e :age ?a] [?e :name \"Ivan\"]]"); + check_rows "q3" + [ [ re 1; rv (Int 30) ] ] + (q_string db "[:find ?e ?a :where [?e :name \"Ivan\"] [?e :age ?a] [?e :sex :male]]"); + check_rows "q4" + [ [ re 1; rv (String "Ivanov"); rv (Int 30) ] ] + (q_string db + "[:find ?e ?l ?a :where [?e :name \"Ivan\"] [?e :last-name ?l] [?e :age ?a] [?e :sex :male]]"); + (* ?l is bound from ?e1 (same-age peers), not crossed with Ivan last-names. *) + check_rows "q5" + [ [ re 1; rv (String "Ivanov"); rv (Int 30) ] + ; [ re 3; rv (String "Sidorov"); rv (Int 30) ] + ] + (q_string db + "[:find ?e1 ?l ?a :where [?e :name \"Ivan\"] [?e :age ?a] [?e1 :age ?a] [?e1 :last-name ?l]]"); + check_rows "qpred1" + [ [ re 1; rv (Int 60_000) ]; [ re 3; rv (Int 80_000) ]; [ re 4; rv (Int 55_000) ] ] + (q_string db "[:find ?e ?s :where [?e :salary ?s] [(> ?s 50000)]]"); + check_rows "qpred2" + [ [ re 1; rv (Int 60_000) ]; [ re 3; rv (Int 80_000) ]; [ re 4; rv (Int 55_000) ] ] + (q_string ~inputs:[ Arg_scalar (Result_value (Int 50_000)) ] db + "[:find ?e ?s :in $ ?min_s :where [?e :salary ?s] [(> ?s ?min_s)]]"); + check_rows "q-or" + [ [ re 1 ]; [ re 2 ]; [ re 3 ] ] + (q_string db "[:find ?e :where (or [?e :name \"Ivan\"] [?e :name \"Petr\"])]"); + check_rows "q-not" + [ [ re 3; rv (Int 30) ]; [ re 4; rv (Int 40) ] ] + (q_string db "[:find ?e ?a :where [?e :age ?a] (not [?e :sex :male])]"); + check_rows "q-or-join" + [ [ re 1; rv (Int 30) ]; [ re 2; rv (Int 25) ]; [ re 3; rv (Int 30) ] ] + (q_string db + "[:find ?e ?a :where [?e :age ?a] (or-join [?e] [?e :name \"Ivan\"] [?e :name \"Petr\"])]"); + check_rows "q-not-join" + [ [ re 3; rv (Int 30) ]; [ re 4; rv (Int 40) ] ] + (q_string db "[:find ?e ?a :where [?e :age ?a] (not-join [?e] [?e :sex :male])]"); + check_rows "q-pred-range" + [ [ re 1; rv (Int 60_000) ]; [ re 4; rv (Int 55_000) ] ] + (q_string db "[:find ?e ?s :where [?e :salary ?s] [(> ?s 50000)] [(< ?s 80000)]]"); + check_rows "q-5-merge" + [ [ re 1 + ; rv (String "Ivan") + ; rv (String "Ivanov") + ; rv (Int 30) + ; rv (Int 60_000) + ] + ; [ re 2 + ; rv (String "Petr") + ; rv (String "Petrov") + ; rv (Int 25) + ; rv (Int 40_000) + ] + ] + (q_string db + "[:find ?e ?n ?l ?a ?s :where [?e :name ?n] [?e :last-name ?l] [?e :age ?a] [?e :salary ?s] [?e :sex :male]]"); + check_rows "q-rule" + [ [ re 1; re 2 ]; [ re 2; re 3 ] ] + (q_string ~inputs:[ Arg_rules follow_rules_nonrec ] db + "[:find ?e1 ?e2 :in $ % :where (follow ?e1 ?e2)]") + +(* ---------- writes category ---------- *) + +let test_writes_add_all () = + let people = + List.init 5 (fun i -> + let id = i + 1 in + Entity + { db_id = Some (Entity_id id) + ; attrs = + [ "name", One_value (String (Printf.sprintf "p-%d" id)) + ; "age", One_value (Int (20 + id)) + ] + }) + in + let db = db_with people (empty_db ~schema:[ "name", indexed; "age", indexed ] ()) in + check_rows "add-all names" + [ [ re 1; rv (String "p-1") ] + ; [ re 2; rv (String "p-2") ] + ; [ re 3; rv (String "p-3") ] + ; [ re 4; rv (String "p-4") ] + ; [ re 5; rv (String "p-5") ] + ] + (q_string db "[:find ?e ?n :where [?e :name ?n]]"); + check_int "add-all age datoms" 5 (datoms db Eavt ~a:"age" () |> Seq.length) + +let test_writes_add_5 () = + let schema = [ "name", indexed; "age", indexed ] in + let db = + List.fold_left + (fun db id -> + db_with + [ Entity + { db_id = Some (Entity_id id) + ; attrs = + [ "name", One_value (String (Printf.sprintf "p-%d" id)) + ; "age", One_value (Int (20 + id)) + ] + } + ] + db) + (empty_db ~schema ()) + [ 1; 2; 3; 4; 5 ] + in + check_rows "add-5 ages" + [ [ re 1; rv (Int 21) ] + ; [ re 2; rv (Int 22) ] + ; [ re 3; rv (Int 23) ] + ; [ re 4; rv (Int 24) ] + ; [ re 5; rv (Int 25) ] + ] + (q_string db "[:find ?e ?a :where [?e :age ?a]]") + +(* ---------- rules category (recursive) ---------- *) + +let wide_db depth width = + (* Wide tree fixture: each node has [width] children, [depth] levels. *) + let rec build id depth = + if depth <= 0 then [ Entity { db_id = Some (Temp_id (string_of_int id)); attrs = [ "name", One_value (String "Ivan") ] } ] + else + let children = List.init width (fun i -> (id * width) + i) in + let edges = + List.map + (fun child -> + Entity + { db_id = Some (Temp_id (string_of_int id)) + ; attrs = + [ "name", One_value (String "Ivan") + ; "follows", One_value (Ref_to (Temp_id (string_of_int child))) + ] + }) + children + in + edges @ List.concat_map (fun child -> build child (depth - 1)) children + in + db_with (build 1 depth) (empty_db ~schema:[ "name", indexed; "follows", ref_many ] ()) + +let long_db depth width = + let ops = + List.concat + (List.init width (fun x -> + List.init depth (fun y -> + let from_id = (x * (depth + 1)) + y in + let to_id = from_id + 1 in + [ Entity + { db_id = Some (Temp_id (string_of_int from_id)) + ; attrs = + [ "name", One_value (String "Ivan") + ; "follows", One_value (Ref_to (Temp_id (string_of_int to_id))) + ] + } + ; Entity + { db_id = Some (Temp_id (string_of_int to_id)) + ; attrs = [ "name", One_value (String "Ivan") ] + } + ]))) + in + db_with (List.concat ops) (empty_db ~schema:[ "name", indexed; "follows", ref_many ] ()) + +let test_rules_wide_3x3 () = + let db = wide_db 3 3 in + let rows = + q_string ~inputs:[ Arg_rules follow_rules_rec ] db + "[:find ?e ?e2 :in $ % :where (follows ?e ?e2)]" + in + (* 39 direct edges; recursive follows yields 102 distinct reachable pairs. *) + check_int "rules-wide-3x3 count" 102 (List.length rows) + +let test_rules_wide_5x3 () = + let db = wide_db 5 3 in + let rows = + q_string ~inputs:[ Arg_rules follow_rules_rec ] db + "[:find ?e ?e2 :in $ % :where (follows ?e ?e2)]" + in + check_int "rules-wide-5x3 count" 1641 (List.length rows) + +let test_rules_wide_7x3 () = + let db = wide_db 7 3 in + let rows = + q_string ~inputs:[ Arg_rules follow_rules_rec ] db + "[:find ?e ?e2 :in $ % :where (follows ?e ?e2)]" + in + check_int "rules-wide-7x3 count" 21324 (List.length rows) + +let test_rules_long_10x3 () = + let db = long_db 10 3 in + let rows = + q_string ~inputs:[ Arg_rules follow_rules_rec ] db + "[:find ?e ?e2 :in $ % :where (follows ?e ?e2)]" + in + (* 3 chains × (10+9+...+1) = 3 × 55 = 165 transitive pairs *) + check_int "rules-long-10x3 count" 165 (List.length rows) + +let test_rules_long_30x3 () = + let db = long_db 30 3 in + let rows = + q_string ~inputs:[ Arg_rules follow_rules_rec ] db + "[:find ?e ?e2 :in $ % :where (follows ?e ?e2)]" + in + (* 3 × (30+29+...+1) = 3 × 465 = 1395 *) + check_int "rules-long-30x3 count" 1395 (List.length rows) + +let test_rules_long_30x5 () = + let db = long_db 30 5 in + let rows = + q_string ~inputs:[ Arg_rules follow_rules_rec ] db + "[:find ?e ?e2 :in $ % :where (follows ?e ?e2)]" + in + (* 5 × 465 = 2325 *) + check_int "rules-long-30x5 count" 2325 (List.length rows) + +let test_rules_wide_4x6 () = + let db = wide_db 4 6 in + let rows = + q_string ~inputs:[ Arg_rules follow_rules_rec ] db + "[:find ?e ?e2 :in $ % :where (follows ?e ?e2)]" + in + check_int "rules-wide-4x6 count" 5910 (List.length rows) + +let test_rules_small_exact () = + let db = people_db () in + check_rows "recursive follows exact" + [ [ re 1; re 2 ]; [ re 1; re 3 ]; [ re 2; re 3 ] ] + (q_string ~inputs:[ Arg_rules follow_rules_rec ] db + "[:find ?e ?e2 :in $ % :where (follows ?e ?e2)]") + +(* ---------- aggregates category ---------- *) + +let test_aggregates () = + let db = people_db () in + (match q_string db "[:find (avg ?s) :where [?e :salary ?s]]" with + | [ [ avg ] ] -> float_close "q-agg-avg" 58750.0 avg + | rows -> failf "q-agg-avg unexpected rows: %d" (List.length rows)); + check_rows "q-agg-group" + [ [ rv (Keyword "female"); rv (Float 67500.0); rv (Int 2) ] + ; [ rv (Keyword "male"); rv (Float 50000.0); rv (Int 2) ] + ] + (q_string db "[:find ?sex (avg ?s) (count ?e) :where [?e :sex ?sex] [?e :salary ?s]]"); + (match q_string db "[:find (avg ?s) (min ?s) (max ?s) :where [?e :salary ?s] [?e :sex :male]]" with + | [ [ avg; min_v; max_v ] ] -> + float_close "q-agg-filter avg" 50000.0 avg; + check_rows "q-agg-filter min/max" [ [ min_v; max_v ] ] [ [ rv (Int 40_000); rv (Int 60_000) ] ] + | _ -> failf "q-agg-filter shape"); + check_rows "q-agg-pred" + [ [ rv (Keyword "female"); rv (Float 67500.0) ] + ; [ rv (Keyword "male"); rv (Float 60000.0) ] + ] + (q_string db + "[:find ?sex (avg ?s) :where [?e :salary ?s] [?e :sex ?sex] [(> ?s 50000)]]"); + check_rows "q-agg-multi" + [ [ rv (Keyword "female"); rv (String "Ivan"); rv (Float 80000.0) ] + ; [ rv (Keyword "female"); rv (String "Oleg"); rv (Float 55000.0) ] + ; [ rv (Keyword "male"); rv (String "Ivan"); rv (Float 60000.0) ] + ; [ rv (Keyword "male"); rv (String "Petr"); rv (Float 40000.0) ] + ] + (q_string db + "[:find ?sex ?n (avg ?s) :where [?e :sex ?sex] [?e :name ?n] [?e :salary ?s]]"); + (match + q_string db "[:find (avg ?s) (variance ?s) (stddev ?s) (median ?s) :where [?e :salary ?s]]" + with + | [ [ avg; variance; stddev; median ] ] -> + float_close "q-agg-stats avg" 58750.0 avg; + float_close "q-agg-stats median" 57500.0 median; + (match variance, stddev with + | Result_value (Float v), Result_value (Float s) -> + check_bool "q-agg-stats variance positive" true (v > 0.0); + check_bool "q-agg-stats stddev=sqrt(variance)" true (abs_float (s -. sqrt v) < 1e-9) + | _ -> failf "q-agg-stats variance/stddev types") + | _ -> failf "q-agg-stats shape") + +(* ---------- temporal category ---------- *) + +let temporal_fixture () = + (* Match test_tx_history: db_with → basis_tx → db_with → as_of tx0. *) + let schema = [ "name", indexed; "age", indexed; "sex", indexed ] in + let db = + db_with + [ Entity + { db_id = Some (Entity_id 1) + ; attrs = + [ "name", One_value (String "Ivan") + ; "age", One_value (Int 20) + ; "sex", One_value (Keyword "male") + ] + } + ; Entity + { db_id = Some (Entity_id 2) + ; attrs = [ "name", One_value (String "Petr"); "age", One_value (Int 30) ] + } + ] + (empty_db ~schema ()) + in + let tx0 = basis_tx db in + let current = + db_with + [ Add (Entity_id 1, "age", Int 21) + ; Entity + { db_id = Some (Entity_id 3) + ; attrs = [ "name", One_value (String "Ivan"); "age", One_value (Int 40) ] + } + ] + db + in + current, as_of tx0 current, history current + +let test_temporal () = + let current, as_of_db, hist = temporal_fixture () in + check_rows "t-current-q1" + [ [ re 1 ]; [ re 3 ] ] + (q_string current "[:find ?e :where [?e :name \"Ivan\"]]"); + check_rows "t-current-q2" + [ [ re 1; rv (Int 21) ]; [ re 3; rv (Int 40) ] ] + (q_string current "[:find ?e ?a :where [?e :name \"Ivan\"] [?e :age ?a]]"); + check_rows "t-asof-q1" + [ [ re 1 ] ] + (q_string as_of_db "[:find ?e :where [?e :name \"Ivan\"]]"); + check_rows "t-asof-q2" + [ [ re 1; rv (Int 20) ] ] + (q_string as_of_db "[:find ?e ?a :where [?e :name \"Ivan\"] [?e :age ?a]]"); + check_rows "t-asof-q3" + [ [ re 1; rv (Int 20) ] ] + (q_string as_of_db + "[:find ?e ?a :where [?e :name \"Ivan\"] [?e :age ?a] [?e :sex :male]]"); + check_int "t-hist-q1 names" 3 + (List.length (q_string hist "[:find ?e :where [?e :name]]")); + check_rows "t-hist-q1 name entities" + [ [ re 1 ]; [ re 2 ]; [ re 3 ] ] + (q_string hist "[:find ?e :where [?e :name]]"); + check_rows "t-hist-q2 age+tx" + [ [ re 1; rv (Int 20); re (basis_tx as_of_db) ] + ; [ re 1; rv (Int 20); re (basis_tx current) ] + ; [ re 1; rv (Int 21); re (basis_tx current) ] + ; [ re 2; rv (Int 30); re (basis_tx as_of_db) ] + ; [ re 3; rv (Int 40); re (basis_tx current) ] + ] + (q_string hist "[:find ?e ?a ?tx :where [?e :age ?a ?tx]]"); + check_rows "t-hist-q3 name+age includes retracted age" + [ [ re 1; rv (String "Ivan"); rv (Int 20) ] + ; [ re 1; rv (String "Ivan"); rv (Int 21) ] + ; [ re 2; rv (String "Petr"); rv (Int 30) ] + ; [ re 3; rv (String "Ivan"); rv (Int 40) ] + ] + (q_string hist "[:find ?e ?n ?a :where [?e :name ?n] [?e :age ?a]]"); + check_rows "t-hist-retract" + [ [ re 1; rv (Int 20) ] ] + (q_string hist "[:find ?e ?a :where [?e :age ?a _ false]]") + + +(* ---------- joins category ---------- *) + +let join_db () = + let schema = + [ "div/name", indexed + ; "d/name", indexed + ; "d/budget", indexed + ; "d/div", ref_one + ; "p/name", indexed + ; "p/dept", ref_one + ; "p/salary", indexed + ] + in + empty_db ~schema () + |> db_with + [ Entity { db_id = Some (Entity_id 1); attrs = [ "div/name", One_value (String "div-A") ] } + ; Entity { db_id = Some (Entity_id 2); attrs = [ "div/name", One_value (String "div-B") ] } + ; Entity + { db_id = Some (Entity_id 10) + ; attrs = + [ "d/name", One_value (String "dept-99") + ; "d/budget", One_value (Int 500_000) + ; "d/div", One_value (Ref 1) + ] + } + ; Entity + { db_id = Some (Entity_id 11) + ; attrs = + [ "d/name", One_value (String "dept-01") + ; "d/budget", One_value (Int 420_000) + ; "d/div", One_value (Ref 1) + ] + } + ; Entity + { db_id = Some (Entity_id 12) + ; attrs = + [ "d/name", One_value (String "dept-02") + ; "d/budget", One_value (Int 300_000) + ; "d/div", One_value (Ref 2) + ] + } + ; Entity + { db_id = Some (Entity_id 100) + ; attrs = + [ "p/name", One_value (String "p-100") + ; "p/dept", One_value (Ref 10) + ; "p/salary", One_value (Int 95_000) + ] + } + ; Entity + { db_id = Some (Entity_id 101) + ; attrs = + [ "p/name", One_value (String "p-101") + ; "p/dept", One_value (Ref 10) + ; "p/salary", One_value (Int 50_000) + ] + } + ; Entity + { db_id = Some (Entity_id 102) + ; attrs = + [ "p/name", One_value (String "p-102") + ; "p/dept", One_value (Ref 11) + ; "p/salary", One_value (Int 91_000) + ] + } + ; Entity + { db_id = Some (Entity_id 103) + ; attrs = + [ "p/name", One_value (String "p-103") + ; "p/dept", One_value (Ref 12) + ; "p/salary", One_value (Int 70_000) + ] + } + ] + +let test_joins () = + let db = join_db () in + check_rows "q-join-ref-1" + [ [ rv (String "p-100"); rv (String "dept-99") ] + ; [ rv (String "p-101"); rv (String "dept-99") ] + ] + (q_string db + "[:find ?pn ?dn :where [?d :d/name \"dept-99\"] [?d :d/budget ?b] [?e :p/dept ?d] [?e :p/name ?pn] [?d :d/name ?dn]]"); + check_rows "q-join-ref-10" + [ [ rv (String "p-100"); rv (String "dept-99") ] + ; [ rv (String "p-101"); rv (String "dept-99") ] + ] + (q_string db + "[:find ?pn ?dn :where [?d :d/budget ?b] [(> ?b 450000)] [?d :d/name ?dn] [?e :p/dept ?d] [?e :p/name ?pn]]"); + check_rows "q-join-pred" + [ [ rv (String "p-100"); rv (String "dept-99") ] + ; [ rv (String "p-101"); rv (String "dept-99") ] + ; [ rv (String "p-102"); rv (String "dept-01") ] + ] + (q_string db + "[:find ?pn ?dn :where [?d :d/budget ?b] [(> ?b 400000)] [?d :d/name ?dn] [?e :p/dept ?d] [?e :p/name ?pn]]"); + check_rows "q-join-chain" + [ [ rv (String "p-100"); rv (String "dept-99"); rv (String "div-A") ] + ; [ rv (String "p-101"); rv (String "dept-99"); rv (String "div-A") ] + ; [ rv (String "p-102"); rv (String "dept-01"); rv (String "div-A") ] + ; [ rv (String "p-103"); rv (String "dept-02"); rv (String "div-B") ] + ] + (q_string db + "[:find ?pn ?dn ?divn :where [?e :p/name ?pn] [?e :p/dept ?d] [?d :d/name ?dn] [?d :d/div ?div] [?div :div/name ?divn]]"); + check_rows "q-join-selective" + [ [ rv (String "p-100"); rv (String "dept-99") ] + ; [ rv (String "p-102"); rv (String "dept-01") ] + ] + (q_string db + "[:find ?pn ?dn :where [?e :p/salary ?s] [(> ?s 90000)] [?e :p/name ?pn] [?e :p/dept ?d] [?d :d/name ?dn]]") + +let () = + run "shared-api category parity" + [ ( "queries" + , [ test_case "all query shapes exact rows" `Quick test_queries ] ) + ; ( "writes" + , [ test_case "add-all bulk insert result set" `Quick test_writes_add_all + ; test_case "add-5 sequential insert result set" `Quick test_writes_add_5 + ] ) + ; ( "rules" + , [ test_case "recursive follows exact people fixture" `Quick test_rules_small_exact + ; test_case "rules-wide-3x3 count" `Quick test_rules_wide_3x3 + ; test_case "rules-wide-5x3 count" `Quick test_rules_wide_5x3 + ; test_case "rules-wide-7x3 count" `Quick test_rules_wide_7x3 + ; test_case "rules-wide-4x6 count" `Quick test_rules_wide_4x6 + ; test_case "rules-long-10x3 count" `Quick test_rules_long_10x3 + ; test_case "rules-long-30x3 count" `Quick test_rules_long_30x3 + ; test_case "rules-long-30x5 count" `Quick test_rules_long_30x5 + ] ) + ; ( "aggregates" + , [ test_case "all aggregate shapes" `Quick test_aggregates ] ) + ; ( "temporal" + , [ test_case "all temporal query shapes" `Quick test_temporal ] ) + ; ( "joins" + , [ test_case "all join shapes exact rows" `Quick test_joins ] ) + ] diff --git a/test/test_shared_queries.ml b/test/test_shared_queries.ml new file mode 100644 index 0000000..bc6a6bf --- /dev/null +++ b/test/test_shared_queries.ml @@ -0,0 +1,268 @@ +open Alcotest +open Datascript +open Test_alcotest_support + +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 ref_many = + { + cardinality = Many + ; unique = None + ; indexed = false + ; is_component = false + ; no_history = false + ; doc = None + ; value_type = Some RefType + ; tuple_attrs = None + ; tuple_types = None + } + +let schema = + [ "name", indexed + ; "last-name", indexed + ; "sex", indexed + ; "age", indexed + ; "salary", indexed + ; "follows", ref_many + ] + +let names = [| "Ivan"; "Petr"; "Sergei"; "Oleg"; "Yuri"; "Dmitry"; "Fedor"; "Denis" |] +let last_names = [| "Ivanov"; "Petrov"; "Sidorov"; "Kovalev"; "Kuznetsov"; "Voronoi" |] +let sexes = [| "male"; "female" |] + +type rng = { mutable state : int32 } + +let rng seed = { state = Int32.of_int seed } + +let next_int rng bound = + rng.state <- Int32.add (Int32.mul rng.state 1_664_525l) 1_013_904_223l; + Int32.(to_int (rem (logand (shift_right_logical rng.state 1) 0x3fffffffl) (of_int bound))) + +let rand_nth rng values = values.(next_int rng (Array.length values)) + +(* next_int 8 then next_int 6 then next_int 2 is LCG-periodic: name index + parity always determines sex. Draw sex from a larger modulus so q3/q4 are + non-vacuous under seed=1. *) +let rand_sex rng = sexes.(next_int rng 997 mod Array.length sexes) + +let build_db size = + let rng = rng 1 in + let entities = + List.init size (fun index -> + let i = index + 1 in + Entity + { + db_id = Some (Temp_id (string_of_int i)) + ; attrs = + [ "name", One_value (String (rand_nth rng names)) + ; "last-name", One_value (String (rand_nth rng last_names)) + ; "sex", One_value (Keyword (rand_sex rng)) + ; "age", One_value (Int (next_int rng 100)) + ; "salary", One_value (Int (next_int rng 100_000)) + ] + }) + in + let db = db_with entities (empty_db ~schema ()) in + let follow_ops = + List.concat_map + (fun entity_id -> + if next_int rng 2 = 0 then + [ Add (Entity_id entity_id, "follows", Ref (1 + next_int rng size)) ] + else + []) + (List.init size (fun index -> index + 1)) + in + if follow_ops = [] then db else db_with follow_ops db + +let follow_rules = + Parser.parse_rules + (QueryFormVector + [ QueryFormVector + [ QueryFormVector [ QueryFormSymbol "follow"; QueryFormSymbol "?e1"; QueryFormSymbol "?e2" ] + ; QueryFormVector + [ QueryFormSymbol "?e1"; QueryFormKeyword "follows"; QueryFormSymbol "?e2" ] + ] ]) + +let friend_rules = + Parser.parse_rules + (QueryFormVector + [ QueryFormVector + [ QueryFormVector [ QueryFormSymbol "friend"; QueryFormSymbol "?e1"; QueryFormSymbol "?e2" ] + ; QueryFormVector + [ QueryFormSymbol "?e1"; QueryFormKeyword "follows"; QueryFormSymbol "?e2" ] + ] ]) + +let sort_rows rows = + List.sort + (fun left right -> + compare + (List.map + (function + | Result_value v -> v + | Result_entity e -> Int e + | Result_attr a -> Keyword a + | Result_db _ -> Nil + | Result_pull _ -> Nil) + left) + (List.map + (function + | Result_value v -> v + | Result_entity e -> Int e + | Result_attr a -> Keyword a + | Result_db _ -> Nil + | Result_pull _ -> Nil) + right)) + rows + +let cell_digest = function + | Result_entity e -> "e:" ^ string_of_int e + | Result_attr a -> "a:" ^ a + | Result_value (Int i) -> "i:" ^ string_of_int i + | Result_value (Float f) -> "f:" ^ string_of_float f + | Result_value (String s) -> "s:" ^ s + | Result_value (Keyword k) -> "k:" ^ k + | Result_value (Bool b) -> "b:" ^ string_of_bool b + | Result_value (Ref e) -> "r:" ^ string_of_int e + | Result_value _ -> "v:?" + | Result_db _ -> "db" + | Result_pull _ -> "pull" + +let rows_digest rows = + sort_rows rows + |> List.map (fun row -> String.concat "," (List.map cell_digest row)) + |> String.concat "|" + |> Digest.string + |> Digest.to_hex + +(* Golden counts + digests for size=2000, rng seed=1 with decorrelated sex. + Digests cover full sorted result identity (not just counts). *) +let db = lazy (build_db 2000) + +let check_query name expected_count expected_digest query = + let rows = q_string (Lazy.force db) query in + check_int (name ^ "-count") expected_count (List.length rows); + check string (name ^ "-digest") expected_digest (rows_digest rows) + +let check_query_inputs name expected_count expected_digest query inputs = + let rows = q_string ~inputs (Lazy.force db) query in + check_int (name ^ "-count") expected_count (List.length rows); + check string (name ^ "-digest") expected_digest (rows_digest rows) + +let () = + if Array.exists (( = ) "--dump-goldens") Sys.argv then ( + let db = Lazy.force db in + let dump name query = + let rows = q_string db query in + Printf.printf "%s\t%d\t%s\n%!" name (List.length rows) (rows_digest rows) + in + let dump_in name query inputs = + let rows = q_string ~inputs db query in + Printf.printf "%s\t%d\t%s\n%!" name (List.length rows) (rows_digest rows) + in + dump "q1" "[:find ?e :where [?e :name \"Ivan\"]]"; + dump "q2" "[:find ?e ?a :where [?e :name \"Ivan\"] [?e :age ?a]]"; + dump "q2-switch" "[:find ?e ?a :where [?e :age ?a] [?e :name \"Ivan\"]]"; + dump "q3" "[:find ?e ?a :where [?e :name \"Ivan\"] [?e :age ?a] [?e :sex :male]]"; + dump "q4" "[:find ?e ?l ?a :where [?e :name \"Ivan\"] [?e :last-name ?l] [?e :age ?a] [?e :sex :male]]"; + dump "q5" "[:find ?e1 ?l ?a :where [?e :name \"Ivan\"] [?e :age ?a] [?e1 :age ?a] [?e1 :last-name ?l]]"; + dump "qpred1" "[:find ?e ?s :where [?e :salary ?s] [(> ?s 50000)]]"; + dump_in "qpred2" "[:find ?e ?s :in $ ?min_s :where [?e :salary ?s] [(> ?s ?min_s)]]" + [ Arg_scalar (Result_value (Int 50_000)) ]; + dump "q-or" "[:find ?e :where (or [?e :name \"Ivan\"] [?e :name \"Petr\"])]"; + dump "q-not" "[:find ?e ?a :where [?e :age ?a] (not [?e :sex :male])]"; + dump "q-or-join" "[:find ?e ?a :where [?e :age ?a] (or-join [?e] [?e :name \"Ivan\"] [?e :name \"Petr\"])]"; + dump "q-not-join" "[:find ?e ?a :where [?e :age ?a] (not-join [?e] [?e :sex :male])]"; + dump "q-pred-range" "[:find ?e ?s :where [?e :salary ?s] [(> ?s 50000)] [(< ?s 80000)]]"; + dump "q-5-merge" "[:find ?e ?n ?l ?a ?s :where [?e :name ?n] [?e :last-name ?l] [?e :age ?a] [?e :salary ?s] [?e :sex :male]]"; + dump_in "q-rule" "[:find ?e1 ?e2 :in $ % :where (follow ?e1 ?e2)]" [ Arg_rules follow_rules ]; + exit 0); + Alcotest.run "shared query parity" + [ + ( "queries" + , [ + test_case "q1 name lookup" `Quick + (fun () -> + check_query "q1" 250 "780fcaea87b17bebd114540b5eaf652c" + "[:find ?e :where [?e :name \"Ivan\"]]") + ; test_case "q2 name and age" `Quick + (fun () -> + check_query "q2" 250 "1aec6a903ad75d94ee5ded861793211a" + "[:find ?e ?a :where [?e :name \"Ivan\"] [?e :age ?a]]") + ; test_case "q2-switch clause order" `Quick + (fun () -> + check_query "q2-switch" 250 "1aec6a903ad75d94ee5ded861793211a" + "[:find ?e ?a :where [?e :age ?a] [?e :name \"Ivan\"]]") + ; test_case "q3 name age sex" `Quick + (fun () -> + check_query "q3" 126 "8a4d70ec7d9fb33625b7e1f2d0326093" + "[:find ?e ?a :where [?e :name \"Ivan\"] [?e :age ?a] [?e :sex :male]]") + ; test_case "q4 name last-name age sex" `Quick + (fun () -> + check_query "q4" 126 "3c5b56081b70ece6e365b8692e1a1377" + "[:find ?e ?l ?a :where [?e :name \"Ivan\"] [?e :last-name ?l] [?e :age ?a] [?e :sex :male]]") + ; test_case "last-name AEVT attr slice" `Quick + (fun () -> + let db = Lazy.force db in + check_int "last-name datoms" + 2000 + (datoms db Aevt ~a:"last-name" () |> List.of_seq |> List.length)) + ; test_case "q5 cross-entity age join" `Quick + (fun () -> + check_query "q5" 1000 "a7a229a8898b5406488910ed4a7486dc" + "[:find ?e1 ?l ?a :where [?e :name \"Ivan\"] [?e :age ?a] [?e1 :age ?a] [?e1 :last-name ?l]]") + ; test_case "qpred1 salary predicate" `Quick + (fun () -> + check_query "qpred1" 997 "e4d5c52c111db71906000b3929ad50e3" + "[:find ?e ?s :where [?e :salary ?s] [(> ?s 50000)]]") + ; test_case "qpred2 salary predicate with input" `Quick + (fun () -> + check_query_inputs "qpred2" 997 "e4d5c52c111db71906000b3929ad50e3" + "[:find ?e ?s :in $ ?min_s :where [?e :salary ?s] [(> ?s ?min_s)]]" + [ Arg_scalar (Result_value (Int 50_000)) ]) + ; test_case "q-or names" `Quick + (fun () -> + check_query "q-or" 500 "c6a640c51b7729e6c19ad62b389139e4" + "[:find ?e :where (or [?e :name \"Ivan\"] [?e :name \"Petr\"])]") + ; test_case "q-not not male" `Quick + (fun () -> + check_query "q-not" 1012 "9ef16dcc5f56ba6bf085c326db4e258a" + "[:find ?e ?a :where [?e :age ?a] (not [?e :sex :male])]") + ; test_case "q-or-join names" `Quick + (fun () -> + check_query "q-or-join" 500 "e7953f1cd05ffbbdbe192c8bb7599efe" + "[:find ?e ?a :where [?e :age ?a] (or-join [?e] [?e :name \"Ivan\"] [?e :name \"Petr\"])]") + ; test_case "q-not-join not male" `Quick + (fun () -> + check_query "q-not-join" 1012 "9ef16dcc5f56ba6bf085c326db4e258a" + "[:find ?e ?a :where [?e :age ?a] (not-join [?e] [?e :sex :male])]") + ; test_case "q-pred-range salary range" `Quick + (fun () -> + check_query "q-pred-range" 616 "f0414689e934bd25a597c2102c5e4475" + "[:find ?e ?s :where [?e :salary ?s] [(> ?s 50000)] [(< ?s 80000)]]") + ; test_case "q-5-merge male attrs" `Quick + (fun () -> + check_query "q-5-merge" 988 "d7a75b59b1f97c417173a63821d3bd31" + "[:find ?e ?n ?l ?a ?s :where [?e :name ?n] [?e :last-name ?l] [?e :age ?a] [?e :salary ?s] [?e :sex :male]]") + ; test_case "q-rule non-recursive" `Quick + (fun () -> + check_query_inputs "q-rule" 667 "d1c7c5173bb8c5ff34ecbeeed24acc17" + "[:find ?e1 ?e2 :in $ % :where (follow ?e1 ?e2)]" + [ Arg_rules follow_rules ]) + ; test_case "q-rule renamed single-pattern" `Quick + (fun () -> + check_query_inputs "q-rule-friend" 667 "d1c7c5173bb8c5ff34ecbeeed24acc17" + "[:find ?e1 ?e2 :in $ % :where (friend ?e1 ?e2)]" + [ Arg_rules friend_rules ]) + ] ) + ] diff --git a/test/test_sqlite_package.ml b/test/test_sqlite_package.ml index 9fde404..e7fe9e8 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 @@ -20,11 +21,28 @@ let indexed = ; tuple_types = None } +let age_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 datoms db index ?e ?a ?v ?tx () = + Datascript.datoms db index ?e ?a ?v ?tx () |> List.of_seq + 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 + check_bool "empty_db shares SQLite index handle" true + (db_shares_storage_index storage db); let report = transact db @@ -38,32 +56,94 @@ let test_storage_roundtrip () = | Some db -> db | None -> failwith "expected SQLite storage to restore a database" in + check_bool "restore shares SQLite index handle" true + (db_shares_storage_index storage restored); let entity = match entity restored (Lookup_ref ("todo/id", String "todo-1")) with | 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; + expect_invalid_arg_msg "SQLite session is closed" (fun () -> ensure_live storage) + +let test_reopen_preserves_data () = + let path = temp_db_path "datascript-sqlite-reopen" in + let session = Datascript_sqlite.open_session path in + let storage = storage_of_handle (Datascript_sqlite.storage session) in + let db = empty_db ~schema:[ "todo/id", indexed ] ~storage () in + let report = + transact db [ Add (Temp_id "todo-1", "todo/id", String "persisted") ] + in + store ~storage report.db_after; + collect_garbage storage; 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" + let session = Datascript_sqlite.open_session path in + let storage = storage_of_handle (Datascript_sqlite.storage session) in + let restored = + match restore storage with + | Some db -> db + | None -> failwith "expected reopen restore" + in + check_bool "reopen restore shares SQLite index" true + (db_shares_storage_index storage restored); + (match entity restored (Lookup_ref ("todo/id", String "persisted")) with + | Some _ -> () + | None -> failwith "expected persisted entity after reopen"); + Datascript_sqlite.close session + +let test_temporal_views () = + let path = temp_db_path "datascript-sqlite-temporal" in + let session = Datascript_sqlite.open_session path in + let storage = storage_of_handle (Datascript_sqlite.storage session) in + let db = + empty_db ~schema:[ "name", indexed; "age", age_indexed ] ~storage () + |> 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 sqlite temporal db" + in + let current_ages = + datoms restored Eavt ~a:"age" () + |> List.map (fun d -> match d.v with Int n -> n | _ -> -1) + in + Test_alcotest_support.check_int_list "sqlite current age 31" [ 31 ] current_ages; + let past_ages = + datoms (as_of tx1 restored) Eavt ~a:"age" () + |> List.map (fun d -> match d.v with Int n -> n | _ -> -1) + in + Test_alcotest_support.check_int_list "sqlite as_of 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 + Test_alcotest_support.check_int_list "sqlite history ages" [ 30; 31 ] hist_ages; + Datascript_sqlite.close session 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 + ; test_case "reopen preserves data" `Quick test_reopen_preserves_data + ; test_case "temporal views" `Quick test_temporal_views + ] ) + ] diff --git a/test/test_sqlite_storage.ml b/test/test_sqlite_storage.ml deleted file mode 100644 index d87bff8..0000000 --- a/test/test_sqlite_storage.ml +++ /dev/null @@ -1,2866 +0,0 @@ -open Datascript - -module Sqlite_storage = Logseq_sqlite_storage -module Transit = Transit_native.Transit.Json - -let failf fmt = Printf.ksprintf failwith fmt - -let datoms_seq = datoms - -let datoms db index ?e ?a ?v ?tx () = - datoms_seq db index ?e ?a ?v ?tx () |> List.of_seq - -let seek_datoms_seq = seek_datoms -let seek_datoms db index ?e ?a ?v ?tx () = - seek_datoms_seq db index ?e ?a ?v ?tx () |> List.of_seq - -let rseek_datoms_seq = rseek_datoms -let rseek_datoms db index ?e ?a ?v ?tx () = - rseek_datoms_seq db index ?e ?a ?v ?tx () |> List.of_seq - -let index_range_seq = index_range -let index_range db attr ?start ?stop () = - index_range_seq db attr ?start ?stop () |> List.of_seq - -let assert_upstream_storage_addresses label addresses = - if List.mem "datascript/root" addresses || List.mem "datascript/tail" addresses then - failf "%s: storage should not use OCaml snapshot address names" label; - if not (List.mem "0" addresses) then failf "%s: storage should include upstream root address 0" label; - if not (List.mem "1" addresses) then failf "%s: storage should include upstream tail address 1" label; - if List.length addresses < 5 then - failf - "%s: storage should include root, tail, and separate index nodes, got [%s]" - label - (String.concat "," addresses) - -let sqlite3_available () = true - -let with_sqlite db_path f = - let db = Sqlite3.db_open db_path in - Fun.protect - ~finally:(fun () -> - if not (Sqlite3.db_close db) then failf "failed to close SQLite database: %s" db_path) - (fun () -> f db) - -let check_sql db sql rc = - if not (Sqlite3.Rc.is_success rc) then - failf "SQLite statement failed with %s for %S: %s" (Sqlite3.Rc.to_string rc) sql (Sqlite3.errmsg db) - -let run_sql db_path sql = - with_sqlite db_path (fun db -> check_sql db sql (Sqlite3.exec db sql)) - -let select_single_string db_path sql = - with_sqlite db_path (fun db -> - let stmt = Sqlite3.prepare db sql in - Fun.protect - ~finally:(fun () -> check_sql db sql (Sqlite3.finalize stmt)) - (fun () -> - match Sqlite3.step stmt with - | Sqlite3.Rc.ROW -> Some (Sqlite3.column_text stmt 0) - | Sqlite3.Rc.DONE -> None - | rc -> - check_sql db sql rc; - None)) - -let select_single_int db_path sql = - with_sqlite db_path (fun db -> - let stmt = Sqlite3.prepare db sql in - Fun.protect - ~finally:(fun () -> check_sql db sql (Sqlite3.finalize stmt)) - (fun () -> - match Sqlite3.step stmt with - | Sqlite3.Rc.ROW -> Sqlite3.column_int stmt 0 - | Sqlite3.Rc.DONE -> 0 - | rc -> - check_sql db sql rc; - 0)) - -let sql_quote text = - "'" ^ String.concat "''" (String.split_on_char '\'' text) ^ "'" - -let ocaml_payload_prefix = "ocaml-marshal-hex:" - -let starts_with prefix text = - let prefix_len = String.length prefix in - String.length text >= prefix_len && String.sub text 0 prefix_len = prefix - -let assert_not_ocaml_marshal label content = - if starts_with ocaml_payload_prefix content then - failf "%s: SQLite content must be Transit, not OCaml marshal" label - -let transit_of_sqlite_content label content = - assert_not_ocaml_marshal label content; - match Transit.of_string content with - | value -> value - | exception Transit.Decode_error message -> - failf "%s: SQLite content is not decodable Transit: %s" label message - | exception Yojson.Json_error message -> - failf "%s: SQLite content is not JSON Transit: %s" label message - -let transit_key = function - | Transit.Keyword value | Transit.String value -> Some value - | _ -> None - -let transit_int = function - | Transit.Int value -> Some value - | Transit.Int64 value -> - if value >= Int64.of_int min_int && value <= Int64.of_int max_int then - Some (Int64.to_int value) - else - None - | _ -> None - -let transit_lookup key = function - | Transit.Map entries -> - List.find_map - (fun (entry_key, value) -> - match transit_key entry_key with - | Some entry_key when entry_key = key -> Some value - | _ -> None) - entries - | _ -> None - -let expect_transit_map label = function - | Transit.Map entries -> entries - | _ -> failf "%s: expected a Transit map" label - -let expect_transit_array label = function - | Transit.Array values -> values - | _ -> failf "%s: expected a Transit array" label - -let expect_transit_int label value = - match transit_int value with - | Some value -> value - | None -> failf "%s: expected a Transit integer" label - -let assert_transit_has_key label key value = - match transit_lookup key value with - | Some _ -> () - | None -> failf "%s: missing Transit key :%s" label key - -let json_quote text = - let buffer = Buffer.create (String.length text + 2) in - Buffer.add_char buffer '"'; - String.iter - (function - | '"' -> Buffer.add_string buffer "\\\"" - | '\\' -> Buffer.add_string buffer "\\\\" - | '\n' -> Buffer.add_string buffer "\\n" - | '\r' -> Buffer.add_string buffer "\\r" - | '\t' -> Buffer.add_string buffer "\\t" - | ch -> Buffer.add_char buffer ch) - text; - Buffer.add_char buffer '"'; - Buffer.contents buffer - -let with_temp_db f = - let dir = - Filename.concat - (Filename.get_temp_dir_name ()) - ("datascript_ocaml_sqlite_" ^ string_of_int (Random.bits ())) - in - Unix.mkdir dir 0o755; - let db_path = Filename.concat dir "db.sqlite" in - Fun.protect - ~finally:(fun () -> - if Sys.file_exists db_path then Sys.remove db_path; - if Sys.file_exists dir then Unix.rmdir dir) - (fun () -> f db_path) - -let without_path f = - let old_path = Sys.getenv_opt "PATH" in - Fun.protect - ~finally:(fun () -> - match old_path with - | Some path -> Unix.putenv "PATH" path - | None -> Unix.putenv "PATH" "") - (fun () -> - Unix.putenv "PATH" ""; - f ()) - -let assert_equal label expected actual = - if expected <> actual then failf "%s: expected %S, got %S" label expected actual - -let assert_equal_int label expected actual = - if expected <> actual then failf "%s: expected %d, got %d" label expected actual - -let assert_raises_invalid_arg label f = - match f () with - | exception Invalid_argument _ -> () - | exception exn -> failf "%s: expected Invalid_argument, got %s" label (Printexc.to_string exn) - | _ -> failf "%s: expected Invalid_argument" label - -let assert_equal_query label expected actual = - if expected <> actual then - failf "%s: unexpected query result" label - -let rec string_of_value = function - | Nil -> "nil" - | Int value -> string_of_int value - | Float value -> string_of_float value - | String value -> Printf.sprintf "%S" value - | Symbol value -> value - | Bool value -> string_of_bool value - | Keyword value -> ":" ^ value - | Uuid value -> "#uuid " ^ Printf.sprintf "%S" value - | Instant value -> string_of_int value - | Regex value -> "#\"" ^ String.escaped value ^ "\"" - | Ref entity_id -> string_of_int entity_id - | List values -> "[" ^ String.concat " " (List.map string_of_value values) ^ "]" - | Vector values -> "#vector[" ^ String.concat " " (List.map string_of_value values) ^ "]" - | Map entries -> - "{" - ^ (entries - |> List.map (fun (key, value) -> string_of_value key ^ " " ^ string_of_value value) - |> String.concat " ") - ^ "}" - | Set values -> "#{" ^ String.concat " " (List.map string_of_value values) ^ "}" - | Tuple values -> - "[" - ^ (values - |> List.map (function None -> "nil" | Some value -> string_of_value value) - |> String.concat " ") - ^ "]" - | TxRef -> ":db/current-tx" - | Ref_to _ -> "#ref" - -let string_of_triples triples = - triples - |> List.map (fun (e, a, v) -> Printf.sprintf "(%d :%s %s)" e a (string_of_value v)) - |> String.concat "; " - -let assert_equal_triples label expected actual = - let triples = List.map (fun datom -> datom.e, datom.a, datom.v) actual in - if expected <> triples then - failf - "%s: expected [%s], got [%s]" - label - (string_of_triples expected) - (string_of_triples triples) - -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 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 ref_attr = - { indexed with indexed = false; value_type = Some RefType } - -let ref_many = - { ref_attr with cardinality = Many } - -let component = - { ref_attr with is_component = true } - -let no_history = - { indexed with no_history = true } - -let tuple_unique_identity attrs = - { indexed with - unique = Some Identity - ; value_type = Some TupleType - ; tuple_attrs = Some attrs - } - -let assert_equal_tx_flags label expected actual = - let values = List.map (fun datom -> datom.e, datom.a, datom.v, datom.added) actual in - if expected <> values then failf "%s: unexpected tx flags" label - -type sqlite_size = - { sqlite_rows : int - ; sqlite_content_bytes : int - ; sqlite_addresses_bytes : int - ; sqlite_file_bytes : int - } - -let sqlite_size db_path = - { sqlite_rows = select_single_int db_path "select count(*) from kvs;" - ; sqlite_content_bytes = select_single_int db_path "select coalesce(sum(length(content)), 0) from kvs;" - ; sqlite_addresses_bytes = - select_single_int db_path "select coalesce(sum(length(addresses)), 0) from kvs;" - ; sqlite_file_bytes = (Unix.stat db_path).st_size - } - -let assert_equal_sqlite_size label expected actual = - if expected <> actual then - failf - "%s: expected sqlite size rows=%d content=%d addresses=%d file=%d, got rows=%d content=%d addresses=%d file=%d" - label - expected.sqlite_rows - expected.sqlite_content_bytes - expected.sqlite_addresses_bytes - expected.sqlite_file_bytes - actual.sqlite_rows - actual.sqlite_content_bytes - actual.sqlite_addresses_bytes - actual.sqlite_file_bytes - -let comparable_datoms db = - datoms db Eavt () - |> List.map (fun datom -> datom.e, datom.a, datom.v, datom.tx, datom.added) - -let assert_equal_final_datoms label expected actual = - if expected <> actual then failf "%s: final datoms differ" label - -let random_choice state values = - values.(Random.State.int state (Array.length values)) - -let random_graph_schema = - [ "block/uuid", unique_identity - ; "block/name", indexed - ; "block/title", indexed - ; "block/page", ref_attr - ; "block/parent", ref_attr - ; "block/refs", ref_many - ; "block/tags", ref_many - ; "db/ident", unique_identity - ; "property/type", indexed - ; "property/public?", indexed - ; "property/default-value", indexed - ; "property/status", indexed - ; "property/priority", indexed - ; "property/estimate", indexed - ; "property/reviewer", ref_attr - ; "property/labels", many - ] - -let page_id state = - 1 + Random.State.int state 20 - -let property_id state = - 100 + Random.State.int state 16 - -let block_id state = - 1_000 + Random.State.int state 500 - -let label_value state = - String ("label-" ^ string_of_int (Random.State.int state 24)) - -let block_title prefix id revision = - Printf.sprintf "%s block %d rev %d" prefix id revision - -let block_name title = - String.lowercase_ascii title - |> String.map (function ' ' -> '-' | ch -> ch) - -let create_page_tx page = - let title = "Page " ^ string_of_int page in - [ Entity - { db_id = Some (Entity_id page) - ; attrs = - [ "block/uuid", One_value (String ("page-" ^ string_of_int page)) - ; "block/name", One_value (String (block_name title)) - ; "block/title", One_value (String title) - ] - } - ] - -let create_property_tx property = - [ Entity - { db_id = Some (Entity_id property) - ; attrs = - [ "db/ident", One_value (Keyword ("property/generated-" ^ string_of_int property)) - ; "property/type", One_value (Keyword "default") - ; "property/public?", One_value (Bool true) - ; "property/default-value", One_value (String "") - ; "block/title", One_value (String ("Generated property " ^ string_of_int property)) - ] - } - ] - -let create_block_tx state revision = - let block = block_id state in - let title = block_title "Created" block revision in - let page = page_id state in - let parent = if Random.State.bool state then page else block_id state in - [ Entity - { db_id = Some (Entity_id block) - ; attrs = - [ "block/uuid", One_value (String ("block-" ^ string_of_int block)) - ; "block/name", One_value (String (block_name title)) - ; "block/title", One_value (String title) - ; "block/page", One_value (Ref page) - ; "block/parent", One_value (Ref parent) - ; ( "block/refs" - , Many_values - [ Ref (page_id state) - ; Ref (property_id state) - ] ) - ; "block/tags", Many_values [ Ref (property_id state) ] - ; "property/status", One_value (Keyword (random_choice state [| "todo"; "doing"; "done" |])) - ; "property/priority", One_value (Int (1 + Random.State.int state 5)) - ; "property/labels", Many_values [ label_value state ] - ] - } - ] - -let update_block_tx state revision = - let block = block_id state in - let title = block_title "Updated" block revision in - match Random.State.int state 7 with - | 0 -> - [ Add (Entity_id block, "block/title", String title) - ; Add (Entity_id block, "block/name", String (block_name title)) - ] - | 1 -> - [ Add (Entity_id block, "block/page", Ref (page_id state)) - ; Add (Entity_id block, "block/parent", Ref (block_id state)) - ] - | 2 -> - [ Add (Entity_id block, "block/refs", Ref (page_id state)) - ; Add (Entity_id block, "block/tags", Ref (property_id state)) - ] - | 3 -> - [ Retract (Entity_id block, "block/refs", Some (Ref (page_id state))) - ; Retract (Entity_id block, "block/tags", Some (Ref (property_id state))) - ] - | 4 -> - [ Add (Entity_id block, "property/status", Keyword (random_choice state [| "todo"; "doing"; "done"; "blocked" |])) - ; Add (Entity_id block, "property/priority", Int (1 + Random.State.int state 5)) - ; Add (Entity_id block, "property/estimate", Int (Random.State.int state 21)) - ] - | 5 -> - [ Add (Entity_id block, "property/reviewer", Ref (block_id state)) - ; Add (Entity_id block, "property/labels", label_value state) - ] - | _ -> - [ RetractAttr (Entity_id block, "property/status") - ; Retract (Entity_id block, "property/labels", Some (label_value state)) - ] - -let update_property_tx state = - let property = property_id state in - match Random.State.int state 4 with - | 0 -> create_property_tx property - | 1 -> - [ Add (Entity_id property, "property/type", Keyword (random_choice state [| "default"; "number"; "date"; "checkbox" |])) - ; Add (Entity_id property, "property/public?", Bool (Random.State.bool state)) - ] - | 2 -> - [ Add (Entity_id property, "property/default-value", String ("default-" ^ string_of_int (Random.State.int state 128))) ] - | _ -> [ RetractEntity (Entity_id property) ] - -let delete_block_tx state = - match Random.State.int state 3 with - | 0 -> [ RetractEntity (Entity_id (block_id state)) ] - | 1 -> - let block = block_id state in - [ RetractAttr (Entity_id block, "block/parent") - ; RetractAttr (Entity_id block, "block/page") - ] - | _ -> - let block = block_id state in - [ RetractAttr (Entity_id block, "property/priority") - ; RetractAttr (Entity_id block, "property/estimate") - ; RetractAttr (Entity_id block, "property/reviewer") - ] - -let random_graph_tx state index = - match Random.State.int state 10 with - | 0 -> create_page_tx (page_id state) - | 1 -> update_property_tx state - | 2 | 3 -> create_block_tx state index - | 4 -> delete_block_tx state - | _ -> update_block_tx state index - -let bootstrap_graph_txs = - List.init 20 (fun index -> create_page_tx (index + 1)) - @ List.init 16 (fun index -> create_property_tx (100 + index)) - -let random_graph_tx_batch_size = 20 - -let rec take count values = - match count, values with - | 0, _ | _, [] -> [] - | count, value :: rest -> value :: take (count - 1) rest - -let rec drop count values = - match count, values with - | 0, values | _, ([] as values) -> values - | count, _ :: rest -> drop (count - 1) rest - -let chunk size values = - let rec loop chunks values = - match values with - | [] -> List.rev chunks - | _ -> - let chunk = take size values in - loop (chunk :: chunks) (drop (List.length chunk) values) - in - loop [] values - -let random_graph_txs seed op_count = - let state = Random.State.make [| seed; op_count |] in - let rec collect index count ops = - if count >= op_count then - take op_count (List.rev ops) - else - let next_ops = random_graph_tx state index in - collect (index + 1) (count + List.length next_ops) (List.rev_append next_ops ops) - in - collect 0 0 [] |> chunk random_graph_tx_batch_size - -let apply_txs conn txs = - List.iter (fun tx -> ignore (transact_conn conn tx)) txs - -let sqlite_property_db db_path txs = - let storage = Sqlite_storage.storage db_path in - let conn = create_conn ~schema:random_graph_schema ~storage () in - apply_txs conn txs; - match restore storage with - | Some db -> db - | None -> failwith "SQLite property test should restore final db" - -let memory_property_db txs = - let conn = create_conn ~schema:random_graph_schema () in - apply_txs conn txs; - conn_db conn - -let test_sqlite_storage_random_property_txs () = - if not (sqlite3_available ()) then - prerr_endline "Skipping SQLite random property transaction test: sqlite3 is not available" - else - List.iter - (fun tx_count -> - let txs = bootstrap_graph_txs @ random_graph_txs 0x5eed tx_count in - with_temp_db (fun left_path -> - with_temp_db (fun right_path -> - let expected = comparable_datoms (memory_property_db txs) in - let left = sqlite_property_db left_path txs in - let right = sqlite_property_db right_path txs in - let left_size = sqlite_size left_path in - assert_equal_final_datoms - (Printf.sprintf "SQLite property final datoms for %d txs" tx_count) - expected - (comparable_datoms left); - assert_equal_final_datoms - (Printf.sprintf "SQLite repeated property final datoms for %d txs" tx_count) - expected - (comparable_datoms right); - assert_equal_sqlite_size - (Printf.sprintf "SQLite property storage size for %d txs" tx_count) - left_size - (sqlite_size right_path)))) - [ 1_000 ] - -let test_sqlite_storage_validates_db_attribute_transactions () = - if not (sqlite3_available ()) then - prerr_endline "Skipping SQLite db attribute validation test: sqlite3 is not available" - else - with_temp_db (fun db_path -> - let conn = create_conn ~storage:(Sqlite_storage.storage db_path) () in - assert_raises_invalid_arg - "SQLite schema transaction with valueType requires db/ident" - (fun () -> - ignore - (transact_conn - conn - [ Entity - { db_id = Some (Entity_id 1) - ; attrs = - [ "db/valueType", One_value (Keyword "db.type/ref") - ; "db/cardinality", One_value (Keyword "db.cardinality/one") - ] - } - ])); - assert_raises_invalid_arg - "SQLite schema transaction with valueType requires db/cardinality" - (fun () -> - ignore - (transact_conn - conn - [ Entity - { db_id = Some (Entity_id 2) - ; attrs = - [ "db/ident", One_value (Keyword "friend") - ; "db/valueType", One_value (Keyword "db.type/ref") - ] - } - ])); - assert_raises_invalid_arg - "SQLite schema transaction cannot install db namespace attrs" - (fun () -> - ignore - (transact_conn - conn - [ Entity - { db_id = Some (Entity_id 3) - ; attrs = - [ "db/ident", One_value (Keyword "db/user") - ; "db/cardinality", One_value (Keyword "db.cardinality/one") - ] - } - ]))) - -let test_sqlite_storage_round_trips_ocaml_payloads () = - if not (sqlite3_available ()) then - prerr_endline "Skipping SQLite storage round trip: sqlite3 is not available" - else - with_temp_db (fun db_path -> - let storage = Sqlite_storage.storage db_path in - let db = - init_db - ~schema:[ "name", indexed ] - [ datom ~e:1 ~a:"name" ~v:(String "Ada") () ] - in - store ~storage db; - assert_equal - "kvs schema" - "CREATE TABLE kvs (addr INTEGER primary key, content TEXT, addresses JSON)" - (Option.value - ~default:"" - (select_single_string - db_path - "select sql from sqlite_master where type = 'table' and name = 'kvs';")); - assert_equal_int "row count" 5 (Sqlite_storage.inspect db_path).row_count; - assert_upstream_storage_addresses "storage addresses" (storage_addresses storage); - match restore (Sqlite_storage.storage db_path) with - | None -> failwith "SQLite storage should restore the stored db" - | Some restored -> - let names = datoms restored Avet ~a:"name" () in - if List.map (fun datom -> datom.e, datom.a, datom.v) names <> [ 1, "name", String "Ada" ] then - failwith "SQLite storage should preserve stored datoms") - -let test_sqlite_storage_raw_layout_after_transact () = - if not (sqlite3_available ()) then - prerr_endline "Skipping SQLite raw storage layout test: sqlite3 is not available" - else - with_temp_db (fun db_path -> - let storage = Sqlite_storage.storage db_path in - let schema = - [ "name", unique_identity - ; "age", indexed - ; "aka", many - ; "friend", ref_attr - ; "tag", many - ] - in - let conn = create_conn ~schema ~storage () in - ignore - (transact_conn - conn - ([ Add (Entity_id 1, "name", String "Ivan") - ; Add (Entity_id 1, "age", Int 15) - ; Add (Entity_id 1, "aka", String "Devil") - ; Add (Entity_id 1, "aka", String "Tupen") - ; Add (Entity_id 1, "friend", Ref 2) - ; Add (Entity_id 2, "name", String "Petr") - ; Add (Entity_id 2, "age", Int 37) - ] - @ List.init 40 (fun index -> - Add (Entity_id 1, "tag", String ("tag-" ^ string_of_int index))))); - ignore - (transact_conn - conn - [ Add (Entity_id 2, "aka", String "Czar") - ; Add (Entity_id 3, "name", String "Nikolai") - ; Add (Entity_id 1, "tag", String "tail-tag") - ]); - assert_equal_int - "SQLite kvs should contain root and tail rows" - 1 - (select_single_int db_path "select count(*) from kvs where addr = 0;"); - assert_equal_int - "SQLite kvs should contain transaction tail row" - 1 - (select_single_int db_path "select count(*) from kvs where addr = 1;"); - if select_single_int db_path "select count(*) from kvs where addresses is not null;" <= 0 then - failwith "SQLite storage nodes should expose branch addresses in the Logseq addresses JSON column"; - assert_equal_int - "SQLite storage should not write OCaml marshal payloads" - 0 - (select_single_int - db_path - ("select count(*) from kvs where content like " ^ sql_quote (ocaml_payload_prefix ^ "%") ^ ";")); - let root_content = - Option.value - ~default:"" - (select_single_string db_path "select content from kvs where addr = 0;") - in - let tail_content = - Option.value - ~default:"" - (select_single_string db_path "select content from kvs where addr = 1;") - in - let root = transit_of_sqlite_content "root row" root_content in - List.iter - (fun key -> assert_transit_has_key "SQLite root Transit metadata" key root) - [ "schema" - ; "max-eid" - ; "max-tx" - ; "eavt" - ; "aevt" - ; "avet" - ; "max-addr" - ; "branching-factor" - ; "ref-type" - ]; - ignore (expect_transit_map "SQLite root row" root); - let schema_value = - match transit_lookup "schema" root with - | Some schema -> schema - | None -> failwith "SQLite root Transit metadata should include :schema" - in - List.iter - (fun attr -> assert_transit_has_key "SQLite root Transit schema" attr schema_value) - [ "name"; "age"; "aka"; "friend"; "tag" ]; - let eavt_address = - expect_transit_int - "SQLite root :eavt" - (Option.value ~default:Transit.Null (transit_lookup "eavt" root)) - in - let aevt_address = - expect_transit_int - "SQLite root :aevt" - (Option.value ~default:Transit.Null (transit_lookup "aevt" root)) - in - let avet_address = - expect_transit_int - "SQLite root :avet" - (Option.value ~default:Transit.Null (transit_lookup "avet" root)) - in - if eavt_address = aevt_address || eavt_address = avet_address || aevt_address = avet_address then - failwith "SQLite root row should point at three distinct index roots"; - List.iter - (fun (label, address) -> - match - select_single_string - db_path - ("select content from kvs where addr = " ^ string_of_int address ^ ";") - with - | Some content -> - let node = transit_of_sqlite_content (label ^ " index root row") content in - assert_transit_has_key (label ^ " index root row") "keys" node - | None -> failf "%s index root address is missing from SQLite: %d" label address) - [ "EAVT", eavt_address; "AEVT", aevt_address; "AVET", avet_address ]; - let tail = transit_of_sqlite_content "tail row" tail_content in - let tail_groups = expect_transit_array "SQLite tail row" tail in - let has_fact e a v = - List.exists - (List.exists - (function - | Transit.Array [ entity; attr; value; _tx ] -> - Some e = transit_int entity && transit_key attr = Some a && value = v - | _ -> false)) - (List.map (expect_transit_array "SQLite tail transaction group") tail_groups) - in - assert_equal_int "SQLite tail should contain one transaction group" 1 (List.length tail_groups); - if not (has_fact 2 "aka" (Transit.String "Czar")) then - failwith "SQLite tail should contain Petr aka datom"; - if not (has_fact 3 "name" (Transit.String "Nikolai")) then - failwith "SQLite tail should contain Nikolai name datom"; - if not (has_fact 1 "tag" (Transit.String "tail-tag")) then - failwith "SQLite tail should contain the latest tag datom"; - match restore_conn (Sqlite_storage.storage db_path) with - | None -> failwith "SQLite storage should restore raw-layout test db" - | Some restored -> - assert_equal_query - "SQLite restored db should replay raw tail data" - [ [ Result_value (String "Petr") ] ] - (q_string - (conn_db restored) - "[:find ?friend-name - :where [?e :name \"Ivan\"] - [?e :friend ?friend] - [?friend :name ?friend-name]]")) - -let test_sqlite_storage_does_not_require_sqlite3_binary () = - with_temp_db (fun db_path -> - without_path (fun () -> - let storage = Sqlite_storage.storage db_path in - storage.storage_store [ "2", Storage_tail [] ]; - match storage.storage_restore "2" with - | Some (Storage_tail []) -> () - | Some _ -> failwith "SQLite storage should keep payloads without sqlite3 binary" - | None -> failwith "SQLite storage should not require sqlite3 binary")) - -let test_sqlite_storage_store_and_delete_are_separate () = - if not (sqlite3_available ()) then - prerr_endline "Skipping SQLite storage explicit delete test: sqlite3 is not available" - else - with_temp_db (fun db_path -> - let storage = Sqlite_storage.storage db_path in - storage.storage_store [ "2", Storage_tail [] ]; - storage.storage_store [ "3", Storage_tail [] ]; - (match storage.storage_restore "2" with - | Some (Storage_tail []) -> () - | Some _ -> failwith "SQLite storage should keep the original payload" - | None -> failwith "SQLite storage store should not delete addresses"); - assert_equal - "storage addresses before explicit delete" - "2,3" - (String.concat "," (storage_addresses storage)); - storage.storage_delete [ "2" ]; - assert_equal - "storage addresses after explicit delete" - "3" - (String.concat "," (storage_addresses storage))) - -let test_sqlite_storage_backed_connections_query_and_transact_after_restore () = - if not (sqlite3_available ()) then - prerr_endline "Skipping SQLite storage-backed query/transact test: sqlite3 is not available" - else - with_temp_db (fun db_path -> - let storage = Sqlite_storage.storage db_path in - let schema = - [ "name", unique_identity - ; "age", indexed - ; "aka", many - ; "friend", ref_attr - ] - in - let conn = create_conn ~schema ~storage () in - ignore - (transact_conn - conn - [ Add (Entity_id 1, "name", String "Ivan") - ; Add (Entity_id 1, "age", Int 15) - ; Add (Entity_id 1, "aka", String "Devil") - ; Add (Entity_id 1, "aka", String "Tupen") - ; Add (Entity_id 1, "friend", Ref 2) - ; Add (Entity_id 2, "name", String "Petr") - ; Add (Entity_id 2, "age", Int 37) - ]); - let restored = - match restore_conn storage with - | Some conn -> conn - | None -> failwith "SQLite storage should restore a connection after persisted transactions" - in - assert_equal_query - "restored SQLite conn queries joins" - [ [ Result_value (String "Petr") ] ] - (q_string - (conn_db restored) - "[:find ?friend-name - :where [?e :name \"Ivan\"] - [?e :friend ?friend] - [?friend :name ?friend-name]]"); - assert_equal_query - "restored SQLite conn queries cardinality-many attrs" - [ [ Result_value (String "Devil") ]; [ Result_value (String "Tupen") ] ] - (q_string - (conn_db restored) - "[:find ?aka :where [1 :aka ?aka]]"); - assert_equal_query - "restored SQLite conn queries transaction ids" - [ [ Result_value (String "Ivan"); Result_entity (tx0 + 1) ] ] - (q_string - (conn_db restored) - "[:find ?name ?tx :where [1 :name ?name ?tx]]"); - ignore - (transact_conn - restored - [ Add (Lookup_ref ("name", String "Ivan"), "age", Int 16) - ; Retract (Entity_id 1, "aka", Some (String "Devil")) - ]); - let restored_again = - match restore storage with - | Some db -> db - | None -> failwith "SQLite storage should restore db after transact on restored conn" - in - assert_equal_query - "SQLite storage persists lookup-ref transact after restore" - [ [ Result_entity 1; Result_value (Int 16) ] ] - (q_string - restored_again - "[:find ?e ?age - :where [?e :name \"Ivan\"] - [?e :age ?age]]"); - assert_equal_query - "SQLite storage persists retracts after restore" - [ [ Result_value (String "Tupen") ] ] - (q_string restored_again "[:find ?aka :where [1 :aka ?aka]]")) - -let test_sqlite_storage_backed_connections_filter_entity_rules_and_repeated_transacts () = - if not (sqlite3_available ()) then - prerr_endline "Skipping SQLite storage-backed filter/entity/rules test: sqlite3 is not available" - else - with_temp_db (fun db_path -> - let storage = Sqlite_storage.storage db_path in - let schema = - [ "name", unique_identity - ; "age", indexed - ; "aka", many - ; "tag", many - ; "password", indexed - ; "friend", ref_attr - ] - in - let conn = create_conn ~schema ~storage () in - ignore - (transact_conn - conn - [ Add (Entity_id 1, "name", String "Ivan") - ; Add (Entity_id 1, "age", Int 25) - ; Add (Entity_id 1, "aka", String "Terrible") - ; Add (Entity_id 1, "aka", String "IV") - ; Add (Entity_id 1, "password", String "") - ; Add (Entity_id 1, "friend", Ref 2) - ; Add (Entity_id 2, "name", String "Petr") - ; Add (Entity_id 2, "age", Int 37) - ; Add (Entity_id 2, "password", String "") - ; Add (Entity_id 3, "name", String "Nikolai") - ; Add (Entity_id 3, "age", Int 7) - ]); - let restored = - match restore_conn storage with - | Some conn -> conn - | None -> failwith "SQLite storage should restore conn for filter/entity/rules test" - in - let visible = - filter (conn_db restored) (fun _ datom -> datom.a <> "password" && datom.e <> 3) - in - assert_equal_query - "SQLite restored filtered db hides password attrs in queries" - [] - (q_string visible "[:find ?password :where [_ :password ?password]]"); - assert_equal_query - "SQLite restored filtered db hides filtered entities in joins" - [ [ Result_value (String "Ivan") ]; [ Result_value (String "Petr") ] ] - (q_string visible "[:find ?name :where [?e :name ?name]]"); - (match entity visible (Lookup_ref ("name", String "Ivan")) with - | None -> failwith "SQLite restored filtered db should resolve visible lookup refs" - | Some entity -> - (match entity_attr entity "password" with - | None -> () - | Some _ -> failwith "SQLite restored filtered entity should hide password attr"); - (match entity_attr entity "friend" with - | Some (One_entity friend) when friend.db_id = Some (Entity_id 2) -> () - | _ -> failwith "SQLite restored filtered entity should navigate visible refs")); - assert_equal_query - "SQLite restored db supports structured rule queries" - [ [ Result_value (String "Petr") ] ] - (q - (conn_db restored) - { find = [ Find_var "friend_name" ] - ; inputs = [] - ; with_vars = [] - ; rules = - [ { rule_name = "friend-name" - ; rule_params = [ "e"; "friend_name" ] - ; rule_body = - [ Pattern (QVar "e", QAttr "friend", QVar "friend") - ; Pattern (QVar "friend", QAttr "name", QVar "friend_name") - ] - } - ] - ; where = - [ Pattern (QVar "e", QAttr "name", QValue (String "Ivan")) - ; Rule ("friend-name", [ QVar "e"; QVar "friend_name" ]) - ] - }); - let friend_name_rules = - [ { rule_name = "friend-name" - ; rule_params = [ "e"; "friend_name" ] - ; rule_body = - [ Pattern (QVar "e", QAttr "friend", QVar "friend") - ; Pattern (QVar "friend", QAttr "name", QVar "friend_name") - ] - } - ] - in - assert_equal_query - "SQLite restored db supports parsed rule inputs supplied through %" - [ [ Result_value (String "Petr") ] ] - (q_string - ~inputs:[ Arg_rules friend_name_rules ] - (conn_db restored) - "[:find ?friend-name - :in $ % - :where [?e :name \"Ivan\"] - (friend-name ?e ?friend-name)]"); - ignore - (transact_conn - restored - [ Add (Lookup_ref ("name", String "Ivan"), "tag", String "restored") - ; Add (Entity_id 4, "name", String "Nina") - ; Add (Entity_id 4, "age", Int 42) - ; Add (Lookup_ref ("name", String "Ivan"), "friend", Ref 4) - ]); - let restored_again = - match restore_conn storage with - | Some conn -> conn - | None -> failwith "SQLite storage should restore conn after repeated transacts" - in - assert_equal_query - "SQLite storage persists repeated lookup-ref transacts" - [ [ Result_value (String "restored") ] ] - (q_string - (conn_db restored_again) - "[:find ?tag :where [?e :name \"Ivan\"] [?e :tag ?tag]]"); - assert_equal_query - "SQLite storage persists cardinality-one ref replacement" - [ [ Result_value (String "Nina") ] ] - (q_string - (conn_db restored_again) - "[:find ?friend-name - :where [?e :name \"Ivan\"] - [?e :friend ?friend] - [?friend :name ?friend-name]]")) - -let test_sqlite_storage_backed_connections_index_query_and_transact_parity () = - if not (sqlite3_available ()) then - prerr_endline "Skipping SQLite storage-backed index/query/transact test: sqlite3 is not available" - else - with_temp_db (fun db_path -> - let storage = Sqlite_storage.storage db_path in - let conn = create_conn ~schema:[ "name", indexed; "age", indexed; "path", indexed ] ~storage () in - ignore - (transact_conn - conn - [ Add (Entity_id 1, "name", String "Petr") - ; Add (Entity_id 1, "age", Int 44) - ; Add (Entity_id 1, "path", List [ Int 1; Int 2 ]) - ; Add (Entity_id 2, "name", String "Ivan") - ; Add (Entity_id 2, "age", Int 25) - ; Add (Entity_id 2, "path", List [ Int 1; Int 2; Int 3 ]) - ; Add (Entity_id 3, "name", String "Sergey") - ; Add (Entity_id 3, "age", Int 11) - ]); - let restored = - match restore_conn storage with - | Some conn -> conn - | None -> failwith "SQLite storage should restore conn for index/query/transact parity" - in - let restored_db = conn_db restored in - assert_equal_triples - "SQLite restored db preserves AEVT order" - [ 1, "age", Int 44 - ; 2, "age", Int 25 - ; 3, "age", Int 11 - ; 1, "name", String "Petr" - ; 2, "name", String "Ivan" - ; 3, "name", String "Sergey" - ; 1, "path", List [ Int 1; Int 2 ] - ; 2, "path", List [ Int 1; Int 2; Int 3 ] - ] - (datoms restored_db Aevt ()); - assert_equal_triples - "SQLite restored db supports AVET seek across attrs" - [ 3, "age", Int 11 - ; 2, "age", Int 25 - ; 1, "age", Int 44 - ; 2, "name", String "Ivan" - ; 1, "name", String "Petr" - ; 3, "name", String "Sergey" - ; 1, "path", List [ Int 1; Int 2 ] - ; 2, "path", List [ Int 1; Int 2; Int 3 ] - ] - (seek_datoms restored_db Avet ~a:"age" ~v:(Int 10) ()); - assert_equal_triples - "SQLite restored db supports AVET reverse seek" - [ 1, "name", String "Petr" - ; 2, "name", String "Ivan" - ; 1, "age", Int 44 - ; 2, "age", Int 25 - ; 3, "age", Int 11 - ] - (rseek_datoms restored_db Avet ~a:"name" ~v:(String "Petr") ()); - assert_equal_triples - "SQLite restored db supports index ranges" - [ 2, "name", String "Ivan"; 1, "name", String "Petr" ] - (index_range restored_db "name" ~start:(String "I") ~stop:(String "Q") ()); - assert_equal_query - "SQLite restored db query sees indexed list values exactly" - [ [ Result_entity 1 ] ] - (q_string restored_db "[:find ?e :where [?e :path (1 2)]]"); - ignore - (transact_conn - restored - [ Add (Entity_id 4, "name", String "Nina") - ; Add (Entity_id 4, "age", Int 42) - ; Add (Entity_id 4, "path", List [ Int 2 ]) - ]); - let restored_again = - match restore storage with - | Some db -> db - | None -> failwith "SQLite storage should restore db after index parity transact" - in - assert_equal_query - "SQLite storage persists later indexed transacts for queries" - [ [ Result_value (String "Nina") ] ] - (q_string restored_again "[:find ?name :where [?e :age 42] [?e :name ?name]]"); - assert_equal_triples - "SQLite storage persists later indexed transacts for AVET" - [ 4, "age", Int 42; 1, "age", Int 44 ] - (index_range restored_again "age" ~start:(Int 42) ~stop:(Int 44) ())) - -let test_sqlite_storage_backed_composite_values_after_restore () = - if not (sqlite3_available ()) then - prerr_endline "Skipping SQLite storage-backed composite value test: sqlite3 is not available" - else - with_temp_db (fun db_path -> - let storage = Sqlite_storage.storage db_path in - let profile = - Map - [ Keyword "tags", Vector [ String "alpha"; String "beta" ] - ; Keyword "prefs", Map [ Keyword "theme", String "dark"; Keyword "pins", Vector [ Int 1; Int 2 ] ] - ] - in - let conn = create_conn ~schema:[ "profile", indexed ] ~storage () in - ignore (transact_conn conn [ Add (Entity_id 1, "profile", profile) ]); - let restored = - match restore_conn storage with - | Some conn -> conn - | None -> failwith "SQLite storage should restore conn for composite value test" - in - let restored_db = conn_db restored in - assert_equal_query - "SQLite restored db queries map-of-vector datom values by structural equality" - [ [ Result_entity 1 ] ] - (q_string - restored_db - "[:find ?e :where [?e :profile {:tags [\"alpha\" \"beta\"] :prefs {:pins [1 2] :theme \"dark\"}}]]"); - assert_equal_query - "SQLite restored db reads nested vector values out of map datom values" - [ [ Result_value (Vector [ Int 1; Int 2 ]) ] ] - (q_string - restored_db - "[:find ?pins :where [?e :profile ?profile] [(get ?profile :prefs) ?prefs] [(get ?prefs :pins) ?pins]]"); - assert_equal_query - "SQLite restored db uses map datom values in AVET lookups" - [ [ Result_entity 1 ] ] - (q_string - restored_db - "[:find ?e :where [?e :profile {:prefs {:theme \"dark\" :pins [1 2]} :tags [\"alpha\" \"beta\"]}]]")) - -let test_sqlite_storage_backed_query_result_shapes_after_restore () = - if not (sqlite3_available ()) then - prerr_endline "Skipping SQLite storage-backed query result-shape test: sqlite3 is not available" - else - with_temp_db (fun db_path -> - let storage = Sqlite_storage.storage db_path in - let conn = create_conn ~schema:[ "name", indexed; "age", indexed ] ~storage () in - ignore - (transact_conn - conn - [ Add (Entity_id 1, "name", String "Petr") - ; Add (Entity_id 1, "age", Int 44) - ; Add (Entity_id 2, "name", String "Ivan") - ; Add (Entity_id 2, "age", Int 25) - ; Add (Entity_id 3, "name", String "Sergey") - ; Add (Entity_id 3, "age", Int 11) - ]); - let db = - match restore_conn storage with - | Some conn -> conn_db conn - | None -> failwith "SQLite storage should restore conn for query result-shape test" - in - if - q_return_string db "[:find [?name ...] :where [_ :name ?name]]" - <> Query_collection - [ Result_value (String "Ivan") - ; Result_value (String "Petr") - ; Result_value (String "Sergey") - ] - then failwith "SQLite restored db should support collection find specs"; - if - q_return_string db "[:find (count ?name) . :where [_ :name ?name]]" - <> Query_scalar (Some (Result_value (Int 3))) - then failwith "SQLite restored db should support scalar aggregate find specs"; - if - q_return_map_string - db - "[:find ?name ?age - :keys n a - :where [?e :name ?name] - [?e :age ?age]]" - <> Query_relation_maps - [ [ Keyword "a", Result_value (Int 25); Keyword "n", Result_value (String "Ivan") ] - ; [ Keyword "a", Result_value (Int 44); Keyword "n", Result_value (String "Petr") ] - ; [ Keyword "a", Result_value (Int 11); Keyword "n", Result_value (String "Sergey") ] - ] - then failwith "SQLite restored db should support relation return maps"; - if - q_return_map_string - db - "[:find [?name ?age] - :strs n a - :where [?e :name ?name] - [(= ?name \"Ivan\")] - [?e :age ?age]]" - <> Query_tuple_map (Some [ String "a", Result_value (Int 25); String "n", Result_value (String "Ivan") ]) - then failwith "SQLite restored db should support tuple return maps") - -let test_sqlite_storage_backed_lookup_ref_transacts_after_restore () = - if not (sqlite3_available ()) then - prerr_endline "Skipping SQLite storage-backed lookup-ref transact test: sqlite3 is not available" - else - with_temp_db (fun db_path -> - let storage = Sqlite_storage.storage db_path in - let conn = - create_conn - ~schema:[ "name", unique_identity; "email", unique_identity; "friend", ref_attr; "friends", ref_many; "age", indexed ] - ~storage - () - in - ignore - (transact_conn - conn - [ Add (Entity_id 1, "name", String "Ivan") - ; Add (Entity_id 1, "email", String "ivan@example.com") - ; Add (Entity_id 2, "name", String "Petr") - ; Add (Entity_id 2, "email", String "petr@example.com") - ; Add (Entity_id 3, "name", String "Oleg") - ; Add (Entity_id 3, "email", String "oleg@example.com") - ]); - let restored = - match restore_conn storage with - | Some conn -> conn - | None -> failwith "SQLite storage should restore conn for lookup-ref transact test" - in - ignore - (transact_conn - restored - [ Add (Lookup_ref ("name", String "Ivan"), "age", Int 35) - ; Add (Lookup_ref ("email", String "ivan@example.com"), "friend", Ref_to (Lookup_ref ("name", String "Petr"))) - ; Add (Lookup_ref ("name", String "Ivan"), "friends", Ref_to (Lookup_ref ("name", String "Petr"))) - ; Add (Lookup_ref ("name", String "Ivan"), "friends", Ref_to (Lookup_ref ("name", String "Oleg"))) - ]); - let restored_again = - match restore_conn storage with - | Some conn -> conn - | None -> failwith "SQLite storage should restore conn after lookup-ref transacts" - in - assert_equal_query - "SQLite storage persists lookup-ref add entity ids" - [ [ Result_value (Int 35) ] ] - (q_string - (conn_db restored_again) - "[:find ?age :where [[:name \"Ivan\"] :age ?age]]"); - assert_equal_query - "SQLite storage persists lookup-ref ref values" - [ [ Result_value (String "Petr") ] ] - (q_string - (conn_db restored_again) - "[:find ?name - :where [[:name \"Ivan\"] :friend ?friend] - [?friend :name ?name]]"); - assert_equal_query - "SQLite storage persists lookup-ref cardinality-many ref values" - [ [ Result_value (String "Oleg") ]; [ Result_value (String "Petr") ] ] - (q_string - (conn_db restored_again) - "[:find ?name - :where [[:name \"Ivan\"] :friends ?friend] - [?friend :name ?name]]"); - ignore - (transact_conn - restored_again - [ CompareAndSet - ( Lookup_ref ("name", String "Ivan") - , "friend" - , Some (Ref_to (Lookup_ref ("name", String "Petr"))) - , Ref_to (Lookup_ref ("name", String "Oleg")) ) - ; Retract (Lookup_ref ("name", String "Ivan"), "age", Some (Int 35)) - ]); - let final_db = - match restore storage with - | Some db -> db - | None -> failwith "SQLite storage should restore final lookup-ref db" - in - assert_equal_query - "SQLite storage persists lookup-ref CAS ref updates" - [ [ Result_value (String "Oleg") ] ] - (q_string - final_db - "[:find ?name - :where [[:name \"Ivan\"] :friend ?friend] - [?friend :name ?name]]"); - assert_equal_query - "SQLite storage persists lookup-ref retracts" - [] - (q_string final_db "[:find ?age :where [[:name \"Ivan\"] :age ?age]]")) - -let test_sqlite_storage_backed_not_or_queries_after_restore () = - if not (sqlite3_available ()) then - prerr_endline "Skipping SQLite storage-backed not/or query test: sqlite3 is not available" - else - with_temp_db (fun db_path -> - let storage = Sqlite_storage.storage db_path in - let conn = create_conn ~schema:[ "name", indexed; "age", indexed ] ~storage () in - ignore - (transact_conn - conn - [ Add (Entity_id 1, "name", String "Ivan") - ; Add (Entity_id 1, "age", Int 10) - ; Add (Entity_id 2, "name", String "Ivan") - ; Add (Entity_id 2, "age", Int 20) - ; Add (Entity_id 3, "name", String "Oleg") - ; Add (Entity_id 3, "age", Int 10) - ; Add (Entity_id 4, "name", String "Oleg") - ; Add (Entity_id 4, "age", Int 20) - ]); - let db = - match restore storage with - | Some db -> db - | None -> failwith "SQLite storage should restore db for not/or queries" - in - assert_equal_query - "SQLite restored db supports not query clauses" - [ [ Result_entity 3 ]; [ Result_entity 4 ] ] - (q_string db "[:find ?e :where [?e :name] (not [?e :name \"Ivan\"])]"); - assert_equal_query - "SQLite restored db supports not-join query clauses" - [ [ Result_entity 1; Result_value (Int 10) ] - ; [ Result_entity 2; Result_value (Int 20) ] - ] - (q_string - db - "[:find ?e ?a - :where [?e :name] - [?e :age ?a] - (not-join [?e] - [?e :name \"Oleg\"] - [?e :age ?a])]"); - assert_equal_query - "SQLite restored db supports or query clauses" - [ [ Result_entity 1 ]; [ Result_entity 3 ]; [ Result_entity 4 ] ] - (q_string db "[:find ?e :where (or [?e :name \"Oleg\"] [?e :age 10])]"); - assert_equal_query - "SQLite restored db supports or-join query clauses" - [ [ Result_entity 1 ]; [ Result_entity 3 ]; [ Result_entity 4 ] ] - (q_string - db - "[:find ?e - :in $ ?a - :where (or-join [?e ?a] - [?e :age ?a] - [?e :name \"Oleg\"])]" - ~inputs:[ Arg_scalar (Result_value (Int 10)) ])) - -let test_sqlite_storage_backed_transact_history_and_current_tx_parity () = - if not (sqlite3_available ()) then - prerr_endline "Skipping SQLite storage-backed transact/history/current-tx test: sqlite3 is not available" - else - with_temp_db (fun db_path -> - let storage = Sqlite_storage.storage db_path in - let conn = - create_conn - ~schema: - [ "name", unique_identity - ; "created-at", ref_attr - ; "source", indexed - ; "secret", no_history - ] - ~storage - () - in - let report = - transact_conn - ~tx_meta:[ "source", String "sqlite-parity" ] - conn - [ Entity - { db_id = Some (Temp_id "ivan") - ; attrs = - [ "name", One_value (String "Ivan") - ; "created-at", One_value TxRef - ; "secret", One_value (String "alpha") - ] - } - ; Add (CurrentTx, "source", String "initial") - ] - in - if report.tx_meta <> [ "source", String "sqlite-parity" ] then - failwith "SQLite storage-backed transact should preserve tx metadata in reports"; - if resolve_tempid report.tempids "ivan" <> Some 1 then - failwith "SQLite storage-backed transact should expose resolved entity tempids"; - if resolve_tempid report.tempids "db/current-tx" <> Some (tx0 + 1) then - failwith "SQLite storage-backed transact should expose current tx tempid"; - let restored = - match restore_conn storage with - | Some conn -> conn - | None -> failwith "SQLite storage should restore conn for transact/history/current-tx test" - in - assert_equal_query - "SQLite restored db queries current-tx ref facts" - [ [ Result_value (String "initial") ] ] - (q_string - (conn_db restored) - "[:find ?source - :where [?e :name \"Ivan\"] - [?e :created-at ?tx] - [?tx :source ?source]]"); - ignore - (transact_conn - restored - [ Add (Lookup_ref ("name", String "Ivan"), "name", String "Petr") - ; Add (Lookup_ref ("name", String "Petr"), "secret", String "beta") - ]); - let db = - match restore storage with - | Some db -> db - | None -> failwith "SQLite storage should restore db after history transact" - in - assert_equal_query - "SQLite storage persists cardinality-one replacement after restore" - [ [ Result_value (String "Petr") ] ] - (q_string db "[:find ?name :where [?e :name ?name]]"); - assert_equal_tx_flags - "SQLite restored db exposes current name facts" - [ 1, "name", String "Petr", true ] - (datoms db Eavt ~a:"name" ()); - assert_equal_triples - "SQLite restored db exposes current no-history facts" - [ 1, "secret", String "beta" ] - (datoms db Eavt ~a:"secret" ()); - assert_equal_query - "SQLite restored active db keeps latest no-history value" - [ [ Result_value (String "beta") ] ] - (q_string db "[:find ?secret :where [?e :name \"Petr\"] [?e :secret ?secret]]")) - -let test_sqlite_storage_backed_transact_cljc_batch_after_restore () = - if not (sqlite3_available ()) then - prerr_endline "Skipping SQLite storage-backed transact.cljc batch: sqlite3 is not available" - else - with_temp_db (fun db_path -> - let storage = Sqlite_storage.storage db_path in - let conn = - create_conn - ~schema: - [ "name", unique_identity - ; "age", indexed - ; "aka", many - ; "friend", ref_attr - ; "created-at", ref_attr - ; "tx/source", indexed - ; "label", many - ] - ~storage - () - in - ignore - (transact_conn - conn - [ Entity - { db_id = Some (Entity_id 1) - ; attrs = - [ "name", One_value (String "Ivan") - ; "age", One_value (Int 15) - ; "aka", Many_values [ String "Devil"; String "Tupen" ] - ; "friend", One_value (Ref 2) - ; "created-at", One_value TxRef - ] - } - ; Entity - { db_id = Some (Entity_id 2) - ; attrs = [ "name", One_value (String "Petr"); "age", One_value (Int 37) ] - } - ; Add (CurrentTx, "tx/source", String "initial") - ; Call (fun _ -> [ Entity { db_id = None; attrs = [ "name", One_value (String "Generated") ] } ]) - ]); - ignore - (transact_conn - conn - [ CompareAndSet (Entity_id 1, "age", Some (Int 15), Int 16) - ; CompareAndSet (Entity_id 1, "label", None, String "fresh") - ; Retract (Entity_id 1, "aka", Some (String "Devil")) - ]); - let restored = - match restore_conn storage with - | Some conn -> conn - | None -> failwith "SQLite storage should restore transact.cljc batch connection" - in - assert_equal_query - "SQLite restored db keeps cardinality-one replacement and CAS results" - [ [ Result_value (String "Ivan"); Result_value (Int 16); Result_value (String "fresh") ] ] - (q_string - (conn_db restored) - "[:find ?name ?age ?label - :where [1 :name ?name] - [1 :age ?age] - [1 :label ?label]]"); - assert_equal_query - "SQLite restored db keeps cardinality-many retraction results" - [ [ Result_value (String "Tupen") ] ] - (q_string (conn_db restored) "[:find ?aka :where [1 :aka ?aka]]"); - assert_equal_query - "SQLite restored db can query current tx facts from transacted refs" - [ [ Result_value (String "initial") ] ] - (q_string - (conn_db restored) - "[:find ?source - :where [1 :created-at ?tx] - [?tx :tx/source ?source]]"); - assert_equal_query - "SQLite restored db persists transaction function entity output" - [ [ Result_entity 3 ] ] - (q_string (conn_db restored) "[:find ?e :where [?e :name \"Generated\"]]"); - let second_report = - transact_conn - restored - [ RetractAttr (Entity_id 1, "aka") - ; RetractEntity (Entity_id 2) - ; Entity - { db_id = Some (Temp_id "oleg") - ; attrs = - [ "name", One_value (String "Oleg") - ; "created-at", One_value TxRef - ] - } - ; Add (CurrentTx, "tx/source", String "second") - ] - in - let oleg_id = - match resolve_tempid second_report.tempids "oleg" with - | Some entity_id -> entity_id - | None -> failwith "SQLite storage-backed transact should expose tempids after restore" - in - let db = - match restore storage with - | Some db -> db - | None -> failwith "SQLite storage should restore transact.cljc batch db" - in - assert_equal_query - "SQLite second restore persists retractAttribute and retractEntity effects" - [ [ Result_entity 1 ]; [ Result_entity 3 ]; [ Result_entity oleg_id ] ] - (q_string db "[:find ?e :where [?e :name]]"); - assert_equal_triples - "SQLite second restore removes incoming refs to retracted entities" - [] - (datoms db Eavt ~e:1 ~a:"friend" ()); - assert_equal_query - "SQLite second restore queries tempid entity current-tx facts" - [ [ Result_value (String "second") ] ] - (q_string - db - "[:find ?source - :where [?e :name \"Oleg\"] - [?e :created-at ?tx] - [?tx :tx/source ?source]]")) - -let test_sqlite_storage_backed_pull_sources_and_relation_inputs_after_restore () = - if not (sqlite3_available ()) then - prerr_endline "Skipping SQLite storage-backed pull/source/relation query test: sqlite3 is not available" - else - with_temp_db (fun people_path -> - with_temp_db (fun score_path -> - let people_storage = Sqlite_storage.storage people_path in - let score_storage = Sqlite_storage.storage score_path in - let people_conn = - create_conn - ~schema:[ "email", unique_identity; "name", indexed; "friend", ref_attr ] - ~storage:people_storage - () - in - let score_conn = - create_conn - ~schema:[ "email", unique_identity; "score", indexed ] - ~storage:score_storage - () - in - ignore - (transact_conn - people_conn - [ Add (Entity_id 1, "email", String "ivan@example.com") - ; Add (Entity_id 1, "name", String "Ivan") - ; Add (Entity_id 1, "friend", Ref 2) - ; Add (Entity_id 2, "email", String "petr@example.com") - ; Add (Entity_id 2, "name", String "Petr") - ]); - ignore - (transact_conn - score_conn - [ Add (Entity_id 10, "email", String "ivan@example.com") - ; Add (Entity_id 10, "score", Int 20) - ; Add (Entity_id 11, "email", String "petr@example.com") - ; Add (Entity_id 11, "score", Int 40) - ]); - let people = - match restore people_storage with - | Some db -> db - | None -> failwith "SQLite storage should restore people db" - in - let scores = - match restore score_storage with - | Some db -> db - | None -> failwith "SQLite storage should restore score db" - in - assert_equal_query - "SQLite restored named sources join across persisted dbs" - [ [ Result_value (String "Ivan"); Result_value (Int 20) ] - ; [ Result_value (String "Petr"); Result_value (Int 40) ] - ] - (q_sources_string - people - [ "scores", Db_source scores ] - "[:find ?name ?score - :in $ $scores - :where [?person :email ?email] - [?person :name ?name] - [$scores ?row :email ?email] - [$scores ?row :score ?score]]"); - assert_equal_query - "SQLite restored db joins relation inputs after persistence" - [ [ Result_value (String "Petr"); Result_value (String "friend") ] ] - (q_sources_string - people - [ "labels", Relation_source [ [ Result_value (String "petr@example.com"); Result_value (String "friend") ] ] ] - "[:find ?name ?label - :in $ $labels - :where [?e :email ?email] - [?e :name ?name] - [$labels ?email ?label]]"); - (match pull_string people "[:name {:friend [:name]}]" (Lookup_ref ("email", String "ivan@example.com")) with - | Some pulled -> - if - pulled.pulled_attrs - <> [ Keyword "friend", - Pulled_entity - { pulled_id = 2 - ; pulled_attrs = [ Keyword "name", Pulled_scalar (String "Petr") ] - } - ; Keyword "name", Pulled_scalar (String "Ivan") - ] - then failwith "SQLite restored db should support pull with refs" - | None -> failwith "SQLite restored db should pull lookup-ref entities"); - if - q_return_string - people - "[:find (pull ?e [:name {:friend [:name]}]) . - :where [?e :email \"ivan@example.com\"]]" - <> Query_scalar - (Some - (Result_pull - { pulled_id = 1 - ; pulled_attrs = - [ Keyword "friend", - Pulled_entity - { pulled_id = 2 - ; pulled_attrs = [ Keyword "name", Pulled_scalar (String "Petr") ] - } - ; Keyword "name", Pulled_scalar (String "Ivan") - ] - })) - then failwith "SQLite restored db should support pull find specs")) - -let test_sqlite_storage_backed_reset_schema_and_compaction_parity () = - if not (sqlite3_available ()) then - prerr_endline "Skipping SQLite storage-backed reset-schema/compaction test: sqlite3 is not available" - else - with_temp_db (fun db_path -> - let storage = Sqlite_storage.storage db_path in - let conn = create_conn ~schema:[ "name", indexed; "age", indexed ] ~storage () in - ignore (transact_conn conn [ Add (Entity_id 1, "name", String "Ivan") ]); - let restored = - match restore_conn storage with - | Some conn -> conn - | None -> failwith "SQLite storage should restore conn for reset-schema test" - in - ignore (reset_schema restored [ "name", indexed; "email", unique_identity ]); - ignore - (transact_conn - restored - [ Add (Entity_id 1, "email", String "ivan@example.com") - ; Add (Temp_id "same-email", "email", String "ivan@example.com") - ; Add (Temp_id "same-email", "name", String "Ivan Upserted") - ]); - let db = - match restore storage with - | Some db -> db - | None -> failwith "SQLite storage should restore db after reset-schema" - in - (match List.assoc_opt "age" (schema db) with - | None -> () - | Some _ -> failwith "SQLite reset_schema should persist removed schema attrs"); - if List.assoc_opt "email" (schema db) <> Some unique_identity then - failwith "SQLite reset_schema should persist added unique attrs"; - assert_equal_query - "SQLite reset schema persists unique identity tempid upsert semantics" - [ [ Result_entity 1; Result_value (String "ivan@example.com"); Result_value (String "Ivan Upserted") ] ] - (q_string db "[:find ?e ?email ?name :where [?e :email ?email] [?e :name ?name]]"); - assert_upstream_storage_addresses - "SQLite reset schema compacts stale tail" - (storage_addresses storage)) - -let test_sqlite_storage_backed_aggregates_and_upserts_after_restore () = - if not (sqlite3_available ()) then - prerr_endline "Skipping SQLite storage-backed aggregate/upsert test: sqlite3 is not available" - else - with_temp_db (fun db_path -> - let storage = Sqlite_storage.storage db_path in - let conn = - create_conn - ~schema: - [ "name", unique_identity - ; "email", unique_identity - ; "slug", unique_identity - ; "group", indexed - ; "score", indexed - ; "name+email", tuple_unique_identity [ "name"; "email" ] - ] - ~storage - () - in - ignore - (transact_conn - conn - [ Entity - { db_id = None - ; attrs = - [ "name", One_value (String "Ivan") - ; "email", One_value (String "ivan@example.com") - ; "slug", One_value (String "ivan") - ; "group", One_value (String "red") - ; "score", One_value (Int 10) - ] - } - ; Entity - { db_id = None - ; attrs = - [ "name", One_value (String "Petr") - ; "email", One_value (String "petr@example.com") - ; "slug", One_value (String "petr") - ; "group", One_value (String "red") - ; "score", One_value (Int 20) - ] - } - ; Entity - { db_id = None - ; attrs = - [ "name", One_value (String "Oleg") - ; "email", One_value (String "oleg@example.com") - ; "slug", One_value (String "oleg") - ; "group", One_value (String "blue") - ; "score", One_value (Int 5) - ] - } - ]); - let restored = - match restore_conn storage with - | Some conn -> conn - | None -> failwith "SQLite storage should restore conn for aggregate/upsert test" - in - assert_equal_query - "SQLite restored db supports grouped aggregate queries" - [ [ Result_value (String "blue"); Result_value (Int 1); Result_value (Int 5) ] - ; [ Result_value (String "red"); Result_value (Int 2); Result_value (Int 30) ] - ] - (q_string - (conn_db restored) - "[:find ?group (count ?e) (sum ?score) - :where [?e :group ?group] - [?e :score ?score]]"); - ignore - (transact_conn - restored - [ Entity - { db_id = None - ; attrs = - [ "name", One_value (String "Ivan") - ; "email", One_value (String "ivan+updated@example.com") - ; "score", One_value (Int 15) - ] - } - ; Add (Temp_id "petr", "name", String "Petr") - ; Add (Temp_id "petr", "score", Int 25) - ; Add (Temp_id "oleg", "name", String "Oleg") - ; Add (Temp_id "oleg", "email", String "oleg@example.com") - ; Add (Temp_id "oleg", "group", String "green") - ]); - let db = - match restore storage with - | Some db -> db - | None -> failwith "SQLite storage should restore aggregate/upsert db after transact" - in - assert_equal_query - "SQLite restored db persists unique identity and tempid upserts" - [ [ Result_entity 1 - ; Result_value (String "Ivan") - ; Result_value (String "ivan+updated@example.com") - ; Result_value (String "red") - ; Result_value (Int 15) - ] - ; [ Result_entity 2 - ; Result_value (String "Petr") - ; Result_value (String "petr@example.com") - ; Result_value (String "red") - ; Result_value (Int 25) - ] - ; [ Result_entity 3 - ; Result_value (String "Oleg") - ; Result_value (String "oleg@example.com") - ; Result_value (String "green") - ; Result_value (Int 5) - ] - ] - (q_string - db - "[:find ?e ?name ?email ?group ?score - :where [?e :name ?name] - [?e :email ?email] - [?e :group ?group] - [?e :score ?score]]"); - assert_equal_triples - "SQLite restored db persists tuple identity datoms after upserts" - [ 1, "name+email", Tuple [ Some (String "Ivan"); Some (String "ivan+updated@example.com") ] - ; 2, "name+email", Tuple [ Some (String "Petr"); Some (String "petr@example.com") ] - ; 3, "name+email", Tuple [ Some (String "Oleg"); Some (String "oleg@example.com") ] - ] - (datoms db Eavt ~a:"name+email" ())) - -let test_sqlite_storage_backed_parsed_transact_and_query_pull_parity () = - if not (sqlite3_available ()) then - prerr_endline "Skipping SQLite storage-backed parsed transact/query-pull test: sqlite3 is not available" - else - with_temp_db (fun people_path -> - with_temp_db (fun score_path -> - let people_storage = Sqlite_storage.storage people_path in - let score_storage = Sqlite_storage.storage score_path in - let people_conn = - create_conn - ~schema: - [ "name", unique_identity - ; "email", unique_identity - ; "age", indexed - ; "aka", many - ; "friend", ref_attr - ; "friends", ref_many - ; "profile", component - ; "bio", indexed - ; "name+email", tuple_unique_identity [ "name"; "email" ] - ] - ~storage:people_storage - () - in - let score_conn = - create_conn ~schema:[ "email", unique_identity; "score", indexed ] ~storage:score_storage () - in - ignore - (transact_conn_string - people_conn - "[{:db/id -1 - :name \"Ivan\" - :email \"ivan@example.com\" - :age 25 - :aka [\"Vanya\" \"IV\"] - :friend -2 - :profile {:bio \"engineer\"}} - {:db/id -2 - :name \"Petr\" - :email \"petr@example.com\" - :age 44} - {:db/id -3 - :name \"Oleg\" - :email \"oleg@example.com\" - :age 11 - :friends [-1 -2]} - [:db/add datomic.tx :source \"parsed\"] - {:db/id datascript.tx :kind \"datascript\"}]"); - ignore - (transact_conn_string - score_conn - "[{:db/id 10 :email \"ivan@example.com\" :score 20} - {:db/id 11 :email \"petr@example.com\" :score 40} - {:db/id 12 :email \"oleg@example.com\" :score 5}]"); - assert_equal_triples - "SQLite live parsed transacts derive tuple attrs before persistence" - [ 1, "name+email", Tuple [ Some (String "Ivan"); Some (String "ivan@example.com") ] - ; 2, "name+email", Tuple [ Some (String "Petr"); Some (String "petr@example.com") ] - ; 4, "name+email", Tuple [ Some (String "Oleg"); Some (String "oleg@example.com") ] - ] - (datoms (conn_db people_conn) Eavt ~a:"name+email" ()); - let people = - match restore people_storage with - | Some db -> db - | None -> failwith "SQLite storage should restore parsed people transactions" - in - let scores = - match restore score_storage with - | Some db -> db - | None -> failwith "SQLite storage should restore parsed score transactions" - in - assert_equal_triples - "SQLite parsed transacts persist derived tuple attrs" - [ 1, "name+email", Tuple [ Some (String "Ivan"); Some (String "ivan@example.com") ] - ; 2, "name+email", Tuple [ Some (String "Petr"); Some (String "petr@example.com") ] - ; 4, "name+email", Tuple [ Some (String "Oleg"); Some (String "oleg@example.com") ] - ] - (datoms people Eavt ~a:"name+email" ()); - assert_equal_query - "SQLite restored db queries derived tuple attrs with tuple function output" - [ [ Result_value (String "Ivan") ] ] - (q_string - people - "[:find ?name - :where [(tuple \"Ivan\" \"ivan@example.com\") ?lookup] - [?e :name+email ?lookup] - [?e :name ?name]]"); - assert_equal_query - "SQLite parsed transacts persist nested component maps" - [ [ Result_value (String "engineer") ] ] - (q_string - people - "[:find ?bio - :where [?e :name \"Ivan\"] - [?e :profile ?profile] - [?profile :bio ?bio]]"); - assert_equal_query - "SQLite parsed transacts resolve current-tx aliases" - [ [ Result_value (String "parsed"); Result_value (String "datascript") ] ] - (q_string - people - "[:find ?source ?kind - :where [?tx :source ?source] - [?tx :kind ?kind]]"); - assert_equal_query - "SQLite restored db supports relation input bindings after parsed transact" - [ [ Result_value (String "Ivan"); Result_value (Int 25) ] - ; [ Result_value (String "Petr"); Result_value (Int 44) ] - ] - (q_string - ~inputs: - [ Arg_relation - [ [ Result_value (String "Ivan"); Result_value (Int 18) ] - ; [ Result_value (String "Petr"); Result_value (Int 18) ] - ; [ Result_value (String "Oleg"); Result_value (Int 18) ] - ] - ] - people - "[:find ?name ?age - :in $ [[?name ?min-age]] - :where [?e :name ?name] - [?e :age ?age] - [(>= ?age ?min-age)]]"); - if - q_return_string - ~inputs:[ Arg_scalar (Result_value (List [ Keyword "name" ])) ] - people - "[:find (pull ?e ?pattern) . - :in $ ?pattern - :where [?e :email \"ivan@example.com\"]]" - <> Query_scalar - (Some - (Result_pull - { pulled_id = 1 - ; pulled_attrs = [ Keyword "name", Pulled_scalar (String "Ivan") ] - })) - then failwith "SQLite restored db should support pull find specs with pattern inputs"; - if - q_return_string - ~inputs:[ Arg_scalar (Result_value (List [ Keyword "name" ])) ] - people - "[:find (pull ?e pattern) . - :in $ pattern - :where [(ground 1) ?e]]" - <> Query_scalar - (Some - (Result_pull - { pulled_id = 1 - ; pulled_attrs = [ Keyword "name", Pulled_scalar (String "Ivan") ] - })) - then failwith "SQLite restored db should support symbolic pull pattern inputs"; - assert_equal_query - "SQLite restored db supports pull with lookup-ref collection inputs" - [ [ Result_value (Ref_to (Lookup_ref ("name", String "Ivan"))) - ; Result_value (Int 25) - ; Result_pull - { pulled_id = 1 - ; pulled_attrs = - [ Keyword "db/id", Pulled_scalar (Int 1) - ; Keyword "name", Pulled_scalar (String "Ivan") - ] - } - ] - ; [ Result_value (Ref_to (Lookup_ref ("name", String "Petr"))) - ; Result_value (Int 44) - ; Result_pull - { pulled_id = 2 - ; pulled_attrs = - [ Keyword "db/id", Pulled_scalar (Int 2) - ; Keyword "name", Pulled_scalar (String "Petr") - ] - } - ] - ] - (q_string - ~inputs: - [ Arg_collection - [ Result_value (Ref_to (Lookup_ref ("name", String "Ivan"))) - ; Result_value (Ref_to (Lookup_ref ("name", String "Oleg"))) - ; Result_value (Ref_to (Lookup_ref ("name", String "Petr"))) - ] - ] - people - "[:find ?ref ?age (pull ?ref [:db/id :name]) - :in $ [?ref ...] - :where [?ref :age ?age] - [(>= ?age 18)]]"); - assert_equal_query - "SQLite restored named sources use source-specific pull contexts" - [ [ Result_value (String "Ivan") - ; Result_pull - { pulled_id = 10 - ; pulled_attrs = [ Keyword "score", Pulled_scalar (Int 20) ] - } - ] - ; [ Result_value (String "Petr") - ; Result_pull - { pulled_id = 11 - ; pulled_attrs = [ Keyword "score", Pulled_scalar (Int 40) ] - } - ] - ] - (q_sources_string - people - [ "scores", Db_source scores ] - "[:find ?name (pull $scores ?row [:score]) - :in $ $scores - :where [?person :email ?email] - [?person :name ?name] - [$scores ?row :email ?email] - [$scores ?row :score ?score] - [(>= ?score 20)]]"))) - -let test_sqlite_storage_backed_query_input_maps_after_restore () = - if not (sqlite3_available ()) then - prerr_endline "Skipping SQLite storage-backed query input map test: sqlite3 is not available" - else - with_temp_db (fun db_path -> - let storage = Sqlite_storage.storage db_path in - let conn = - create_conn - ~schema:[ "name", unique_identity; "age", indexed; "score", indexed ] - ~storage - () - in - ignore - (transact_conn - conn - [ Add (Entity_id 1, "name", String "Ivan") - ; Add (Entity_id 1, "age", Int 25) - ; Add (Entity_id 1, "score", Int 4) - ; Add (Entity_id 2, "name", String "Petr") - ; Add (Entity_id 2, "age", Int 44) - ; Add (Entity_id 2, "score", Int 7) - ; Add (Entity_id 3, "name", String "Oleg") - ; Add (Entity_id 3, "age", Int 11) - ; Add (Entity_id 3, "score", Int 2) - ]); - let restored = - match restore_conn storage with - | Some conn -> conn - | None -> failwith "SQLite storage should restore conn for query input map test" - in - ignore (transact_conn restored [ Add (Lookup_ref ("name", String "Oleg"), "age", Int 18) ]); - let db = - match restore storage with - | Some db -> db - | None -> failwith "SQLite storage should restore db after query input map transact" - in - assert_equal_query - "SQLite restored db joins plain map relation inputs after transact" - [ [ Result_value (String "Ivan"); Result_value (Int 25) ] - ; [ Result_value (String "Oleg"); Result_value (Int 18) ] - ; [ Result_value (String "Petr"); Result_value (Int 44) ] - ] - (q_string - ~inputs: - [ Arg_scalar - (Result_value - (Map - [ String "Ivan", Int 18 - ; String "Oleg", Int 18 - ; String "Petr", Int 18 - ])) - ] - db - "[:find ?name ?age - :in $ [[?name ?min-age] ...] - :where [?e :name ?name] - [?e :age ?age] - [(>= ?age ?min-age)]]"); - let minmax = function - | [ Result_value (List values) ] -> - (match values with - | [] -> None - | first :: rest -> - let min_value, max_value = - List.fold_left - (fun (min_value, max_value) -> function - | Int value -> min min_value value, max max_value value - | _ -> min_value, max_value) - (match first with - | Int value -> value, value - | _ -> 0, 0) - rest - in - Some [ Result_value (Int min_value); Result_value (Int max_value) ]) - | _ -> None - in - assert_equal_query - "SQLite restored db joins map relation rows through dynamic tuple outputs" - [ [ Result_value (String "Ivan"); Result_value (Int 1); Result_value (Int 4) ] - ; [ Result_value (String "Petr"); Result_value (Int 5); Result_value (Int 7) ] - ] - (q_string - ~inputs: - [ Arg_scalar - (Result_value - (Map - [ String "Ivan", List [ Int 1; Int 4 ] - ; String "Petr", List [ Int 5; Int 7 ] - ; String "Oleg", List [ Int 2; Int 2 ] - ])) - ; Arg_function minmax - ] - db - "[:find ?name ?min ?max - :in $ [[?name ?scores] ...] ?minmax - :where [?e :name ?name] - [?e :score ?score] - [(?minmax ?scores) [?min ?max]] - [(= ?score ?max)] - [(> ?max ?min)]]"); - let range_values = function - | [ Result_value (Int min_value); Result_value (Int max_value) ] -> - let rec collect value acc = - if value >= max_value then List.rev acc - else collect (value + 1) (Int value :: acc) - in - Some [ Result_value (List (collect min_value [])) ] - | _ -> None - in - assert_equal_query - "SQLite restored db joins nested map relation rows through dynamic collection outputs" - [ [ Result_value (String "Ivan"); Result_value (Int 2) ] - ; [ Result_value (String "Ivan"); Result_value (Int 4) ] - ; [ Result_value (String "Petr"); Result_value (Int 6) ] - ] - (q_string - ~inputs: - [ Arg_scalar - (Result_value - (Map - [ String "Ivan", List [ Int 1; Int 5 ] - ; String "Petr", List [ Int 6; Int 8 ] - ; String "Oleg", List [ Int 3; Int 4 ] - ])) - ; Arg_function range_values - ] - db - "[:find ?name ?candidate - :in $ [[?name [?min ?max]] ...] ?range - :where [?e :name ?name] - [?e :age ?age] - [(?range ?min ?max) [?candidate ...]] - [(even? ?candidate)] - [(< ?candidate ?age)]]"); - assert_equal_query - "SQLite restored db accepts input-only queries with no db source" - [ [ Result_value (Int 10); Result_value (Int 20) ] ] - (q_string - ~inputs:[ Arg_scalar (Result_value (Int 10)); Arg_scalar (Result_value (Int 20)) ] - db - "[:find ?a ?b :in ?a ?b]")) - -let test_logseq_sqlite_import_preserves_clojure_collection_values () = - if not (sqlite3_available ()) then - prerr_endline "Skipping Logseq SQLite collection value import test: sqlite3 is not available" - else - with_temp_db (fun db_path -> - let content = - {|["^ ","~:keys",[[101,"~:item/vector",[1,2],536870913],[102,"~:item/list",["~#list",[1,2]],536870913],[103,"~:item/profile",["^ ","~:tags",["alpha","beta"],"~:prefs",["^ ","~:pins",[1,2]]],536870913]]]|} - in - ignore - (run_sql - db_path - ("create table kvs (addr INTEGER primary key, content TEXT, addresses JSON);\n" - ^ "insert into kvs (addr, content, addresses) values (2, " - ^ sql_quote content - ^ ", '[]');")); - let datoms = Sqlite_storage.datoms_of_logseq_graph ~read_only:true db_path in - assert_equal_triples - "Logseq SQLite import preserves vector/list/map value shapes" - [ 101, "item/vector", Vector [ Int 1; Int 2 ] - ; 102, "item/list", List [ Int 1; Int 2 ] - ; ( 103 - , "item/profile" - , Map - [ Keyword "tags", Vector [ String "alpha"; String "beta" ] - ; Keyword "prefs", Map [ Keyword "pins", Vector [ Int 1; Int 2 ] ] - ] ) - ] - datoms; - let db = init_db ~schema:[ "item/vector", indexed; "item/profile", indexed ] datoms in - assert_equal_query - "Logseq SQLite imported vectors query as Clojure vectors" - [ [ Result_entity 101 ] ] - (q_string db "[:find ?e :where [?e :item/vector [1 2]]]"); - assert_equal_query - "Logseq SQLite imported nested map vectors query structurally" - [ [ Result_value (Vector [ Int 1; Int 2 ]) ] ] - (q_string - db - "[:find ?pins :where [?e :item/profile ?profile] [(get ?profile :prefs) ?prefs] [(get ?prefs :pins) ?pins]]")) - -let test_logseq_sqlite_datom_cache_ignores_uuid_values () = - if not (sqlite3_available ()) then - prerr_endline "Skipping Logseq SQLite datom cache test: sqlite3 is not available" - else - with_temp_db (fun db_path -> - let content = - {|["^ ","~:keys",[[95,"~:block/updated-at",1778143747441,536870913],[95,"~:block/uuid","~u00000002-2073-3937-9700-000000000000",536870913],[95,"~:db/ident","~:logseq.property.repeat/recur-unit.month",536870913],[95,"~:logseq.property/built-in?",true,536870913],[95,"~:logseq.property/created-from-property",90,536870913],[96,"~:block/closed-value-property",90,536870913],[96,"~:block/created-at",1778143747441,536870913],[96,"~:block/order","b0N",536870913],[96,"~:block/page",90,536870913],[96,"~:block/parent",90,536870913],[96,"~:block/title","Year",536870913],[96,"^1",1778143747441,536870913],[96,"^2","~u00000002-1520-4385-2400-000000000000",536870913],[96,"^3","~:logseq.property.repeat/recur-unit.year",536870913],[96,"^5",true,536870913],[96,"^6",90,536870913],[97,"^8",1778143747442,536870913],[97,"~:block/name","node repeats?",536870913]]]|} - in - ignore - (run_sql - db_path - ("create table kvs (addr INTEGER primary key, content TEXT, addresses JSON);\n" - ^ "insert into kvs (addr, content, addresses) values (2, " - ^ sql_quote content - ^ ", '[]');")); - let datoms = Sqlite_storage.datoms_of_logseq_graph ~read_only:true db_path in - assert_equal_triples - "Logseq datom cache codes should not be shifted by UUID values" - [ 97, "block/created-at", Int 1778143747442 ] - (List.filter (fun datom -> datom.e = 97 && datom.v = Int 1778143747442) datoms)) - -let test_logseq_sqlite_datom_cache_ignores_transit_tag_values () = - if not (sqlite3_available ()) then - prerr_endline "Skipping Logseq SQLite datom tag cache test: sqlite3 is not available" - else - with_temp_db (fun db_path -> - let content = - {|["^ ","~:keys",[[1,"~:prop/set",["~#set",["~:alpha"]],536870913],[2,"~:block/created-at",1000,536870913],[3,"^3",2000,536870913]]]|} - in - ignore - (run_sql - db_path - ("create table kvs (addr INTEGER primary key, content TEXT, addresses JSON);\n" - ^ "insert into kvs (addr, content, addresses) values (2, " - ^ sql_quote content - ^ ", '[]');")); - assert_equal_triples - "Logseq datom cache codes should not be shifted by Transit tags" - [ 2, "block/created-at", Int 1000; 3, "block/created-at", Int 2000 ] - (Sqlite_storage.datoms_of_logseq_graph ~read_only:true db_path - |> List.filter (fun datom -> datom.a = "block/created-at"))) - -let test_logseq_sqlite_datom_cache_spans_ordered_rows () = - if not (sqlite3_available ()) then - prerr_endline "Skipping Logseq SQLite datom row cache test: sqlite3 is not available" - else - with_temp_db (fun db_path -> - let first_row = - {|["^ ","~:keys",[[1,"~:block/created-at",1000,536870913]]]|} - in - let second_row = - {|["^ ","^0",[[2,"^1",2000,536870913]]]|} - in - ignore - (run_sql - db_path - ("create table kvs (addr INTEGER primary key, content TEXT, addresses JSON);\n" - ^ "insert into kvs (addr, content, addresses) values (2, " - ^ sql_quote first_row - ^ ", '[]');\n" - ^ "insert into kvs (addr, content, addresses) values (3, " - ^ sql_quote second_row - ^ ", '[]');")); - assert_equal_triples - "Logseq datom cache codes should carry across SQLite rows in addr order" - [ 1, "block/created-at", Int 1000; 2, "block/created-at", Int 2000 ] - (Sqlite_storage.datoms_of_logseq_graph ~read_only:true db_path)) - -let test_logseq_sqlite_query_loads_matching_nodes_without_full_materialization () = - if not (sqlite3_available ()) then - prerr_endline "Skipping Logseq SQLite direct query test: sqlite3 is not available" - else - with_temp_db (fun db_path -> - let root_content = - {|["^ ","~:schema",["^ ","~:block/name",["^ ","~:db/index",true],"~:block/title",["^ "],"~:block/created-at",["^ ","~:db/index",true]]] |} - in - let broken_unrelated_node = {|["^ ","~:keys",|} in - let page_node = - {|["^ ","~:keys",[[101,"~:block/name","alpha",536870913],[101,"~:block/title","Alpha",536870913],[101,"~:block/created-at",1000,536870913],[102,"~:block/name","beta",536870913],[102,"~:block/title","Beta",536870913],[102,"~:block/created-at",2000,536870913]]]|} - in - run_sql - db_path - ("create table kvs (addr INTEGER primary key, content TEXT, addresses JSON);\n" - ^ "insert into kvs (addr, content, addresses) values (0, " - ^ sql_quote root_content - ^ ", '[]');\n" - ^ "insert into kvs (addr, content, addresses) values (2, " - ^ sql_quote broken_unrelated_node - ^ ", '[]');\n" - ^ "insert into kvs (addr, content, addresses) values (3, " - ^ sql_quote page_node - ^ ", '[]');"); - assert_equal_query - "direct Logseq SQLite query should load only matching graph nodes" - [ [ Result_value (Int 1000); Result_value (String "Alpha") ] - ; [ Result_value (Int 2000); Result_value (String "Beta") ] - ] - (match - Sqlite_storage.query_logseq_graph - ~read_only:true - db_path - "[:find ?created ?title - :where [?p :block/name ?name] - [?p :block/title ?title] - [?p :block/created-at ?created]]" - with - | Query_relation rows -> rows - | _ -> failwith "direct Logseq SQLite query should return relation rows")) - -let test_logseq_sqlite_schema_decodes_cached_schema_keys () = - if not (sqlite3_available ()) then - prerr_endline "Skipping Logseq SQLite cached schema test: sqlite3 is not available" - else - with_temp_db (fun db_path -> - let root_content = - {|["^ ","~:schema",["^ ","~:foo",["^ ","~:db/index",true,"~:db/valueType","~:db.type/ref"],"~:block/name",["^ ","^2",true]]]|} - in - run_sql - db_path - ("create table kvs (addr INTEGER primary key, content TEXT, addresses JSON);\n" - ^ "insert into kvs (addr, content, addresses) values (0, " - ^ sql_quote root_content - ^ ", '[]');"); - let schema = Sqlite_storage.schema_of_logseq_graph ~read_only:true db_path in - match List.assoc_opt "block/name" schema with - | Some block_name_schema when block_name_schema.indexed -> () - | Some _ -> failwith "cached Logseq schema key should mark :block/name as indexed" - | None -> failwith "cached Logseq schema should expose :block/name") - -let test_logseq_sqlite_query_treats_timestamp_attrs_as_scalars_when_schema_marks_refs () = - if not (sqlite3_available ()) then - prerr_endline "Skipping Logseq SQLite timestamp schema query test: sqlite3 is not available" - else - with_temp_db (fun db_path -> - let root_content = - {|["^ ","~:schema",["^ ","~:block/name",["^ ","~:db/index",true],"~:block/title",["^ "],"~:block/created-at",["^ ","~:db/index",true,"~:db/valueType","~:db.type/ref"],"~:block/updated-at",["^ ","^2",true,"^5","^6"],"~:logseq.kv/graph-created-at",["^ ","^2",true,"^5","^6"]]] |} - in - let page_node = - {|["^ ","~:keys",[[101,"~:block/name","lambda",536870913],[101,"~:block/title","Lambda",536870913],[101,"~:block/created-at",1743432598614,536870913],[101,"~:block/updated-at",1743432616414,536870913],[101,"~:logseq.kv/graph-created-at",1747740706964,536870913]]]|} - in - run_sql - db_path - ("create table kvs (addr INTEGER primary key, content TEXT, addresses JSON);\n" - ^ "insert into kvs (addr, content, addresses) values (0, " - ^ sql_quote root_content - ^ ", '[]');\n" - ^ "insert into kvs (addr, content, addresses) values (2, " - ^ sql_quote page_node - ^ ", '[]');"); - assert_equal_query - "direct Logseq SQLite query should keep timestamp attrs as scalar values" - [ [ Result_value (String "Lambda") - ; Result_value (Int 1743432598614) - ; Result_value (Int 1743432616414) - ; Result_value (Int 1747740706964) - ] - ] - (match - Sqlite_storage.query_logseq_graph - ~read_only:true - db_path - "[:find ?title ?created ?updated ?graph-created - :where [?p :block/name ?name] - [?p :block/title ?title] - [?p :block/created-at ?created] - [?p :block/updated-at ?updated] - [?p :logseq.kv/graph-created-at ?graph-created]]" - with - | Query_relation rows -> rows - | _ -> failwith "direct Logseq SQLite query should return relation rows")) - -let logseq_schema_attr_json attr schema = - let props = - [ Some ("~:db/cardinality", (match schema.cardinality with Many -> "~:db.cardinality/many" | One -> "~:db.cardinality/one")) - ; (match schema.unique with - | Some Identity -> Some ("~:db/unique", "~:db.unique/identity") - | Some Value -> Some ("~:db/unique", "~:db.unique/value") - | None -> None) - ; if schema.indexed then Some ("~:db/index", "true") else None - ; if schema.is_component then Some ("~:db/isComponent", "true") else None - ; if schema.no_history then Some ("~:db/noHistory", "true") else None - ; (match schema.value_type with - | Some RefType -> Some ("~:db/valueType", "~:db.type/ref") - | Some StringType -> Some ("~:db/valueType", "~:db.type/string") - | Some KeywordType -> Some ("~:db/valueType", "~:db.type/keyword") - | Some NumberType -> Some ("~:db/valueType", "~:db.type/number") - | Some UuidType -> Some ("~:db/valueType", "~:db.type/uuid") - | Some InstantType -> Some ("~:db/valueType", "~:db.type/instant") - | Some TupleType -> Some ("~:db/valueType", "~:db.type/tuple") - | None -> None) - ] - |> List.filter_map Fun.id - |> List.concat_map (fun (key, value) -> - [ json_quote key; if value = "true" then value else json_quote value ]) - in - [ json_quote ("~:" ^ attr); "[" ^ String.concat "," (json_quote "^ " :: props) ^ "]" ] - -let logseq_root_content schema = - let schema_entries = List.concat_map (fun (attr, schema) -> logseq_schema_attr_json attr schema) schema in - "[" - ^ String.concat - "," - [ json_quote "^ " - ; json_quote "~:schema" - ; "[" ^ String.concat "," (json_quote "^ " :: schema_entries) ^ "]" - ; json_quote "~:max-eid" - ; "1000" - ; json_quote "~:max-tx" - ; "536870913" - ; json_quote "~:eavt" - ; "2" - ; json_quote "~:aevt" - ; "3" - ; json_quote "~:avet" - ; "4" - ] - ^ "]" - -let logseq_json_of_value = function - | String value -> json_quote value - | Int value -> string_of_int value - | Bool value -> if value then "true" else "false" - | Keyword value -> json_quote ("~:" ^ value) - | Ref entity_id -> string_of_int entity_id - | value -> failf "unsupported Logseq test value: %s" (string_of_value value) - -let logseq_row_content datoms = - let datom_json datom = - "[" - ^ String.concat - "," - [ string_of_int datom.e - ; json_quote ("~:" ^ datom.a) - ; logseq_json_of_value datom.v - ; string_of_int datom.tx - ] - ^ "]" - in - "[" - ^ String.concat - "," - [ json_quote "^ " - ; json_quote "~:keys" - ; "[" ^ String.concat "," (List.map datom_json datoms) ^ "]" - ] - ^ "]" - -let insert_logseq_rows db_path rows = - run_sql - db_path - ("create table kvs (addr INTEGER primary key, content TEXT, addresses JSON);\n" - ^ (rows - |> List.map (fun (addr, content) -> - Printf.sprintf - "insert into kvs (addr, content, addresses) values (%d, %s, '[]');\n" - addr - (sql_quote content)) - |> String.concat "")) - -let test_logseq_sqlite_generated_graph_queries_transacted_properties_and_blocks () = - if not (sqlite3_available ()) then - prerr_endline "Skipping generated Logseq SQLite query test: sqlite3 is not available" - else - with_temp_db (fun db_path -> - let schema = - [ "db/ident", unique_identity - ; "block/name", unique_identity - ; "block/title", indexed - ; "block/tags", ref_many - ; "block/page", ref_attr - ; "block/created-at", indexed - ; "block/updated-at", indexed - ; "block/order", indexed - ; "logseq.property/type", indexed - ; "logseq.property/public?", indexed - ; "user/priority", indexed - ] - in - let report = - transact - (empty_db ~schema ()) - [ Add (Entity_id 100, "db/ident", Keyword "logseq.class/Property") - ; Add (Entity_id 100, "block/title", String "Property") - ; Add (Entity_id 100, "block/name", String "property") - ; Add (Entity_id 101, "db/ident", Keyword "logseq.class/Page") - ; Add (Entity_id 101, "block/title", String "Page") - ; Add (Entity_id 101, "block/name", String "page") - ; Add (Entity_id 200, "db/ident", Keyword "user/priority") - ; Add (Entity_id 200, "block/title", String "Priority") - ; Add (Entity_id 200, "block/name", String "priority") - ; Add (Entity_id 200, "block/tags", Keyword "logseq.class/Property") - ; Add (Entity_id 200, "logseq.property/type", Keyword "default") - ; Add (Entity_id 200, "logseq.property/public?", Bool true) - ; Add (Entity_id 300, "block/title", String "Project Alpha") - ; Add (Entity_id 300, "block/name", String "project alpha") - ; Add (Entity_id 300, "block/tags", Keyword "logseq.class/Page") - ; Add (Entity_id 400, "block/title", String "Ship generated sqlite") - ; Add (Entity_id 400, "block/page", Ref 300) - ; Add (Entity_id 400, "block/order", String "a0") - ; Add (Entity_id 400, "block/created-at", Int 1781829000000) - ; Add (Entity_id 400, "block/updated-at", Int 1781829297990) - ; Add (Entity_id 400, "user/priority", String "high") - ] - in - insert_logseq_rows - db_path - [ 0, logseq_root_content schema - ; 1, "[]" - ; 2, logseq_row_content report.tx_data - ]; - assert_equal_query - "generated Logseq sqlite should query property pages" - [ [ Result_value (String "Priority") - ; Result_value (Keyword "user/priority") - ; Result_value (Keyword "default") - ] - ] - (match - Sqlite_storage.query_logseq_graph - ~read_only:true - db_path - "[:find ?title ?ident ?type - :where [?p :block/tags :logseq.class/Property] - [?p :block/title ?title] - [?p :db/ident ?ident] - [?p :logseq.property/type ?type]]" - with - | Query_relation rows -> rows - | _ -> failwith "generated Logseq property query should return relation rows"); - assert_equal_query - "generated Logseq sqlite should query transacted blocks with custom properties" - [ [ Result_value (String "Ship generated sqlite") - ; Result_value (String "high") - ; Result_value (Int 1781829297990) - ] - ] - (match - Sqlite_storage.query_logseq_graph - ~read_only:true - db_path - "[:find ?title ?priority ?updated - :where [?b :block/title ?title] - [?b :user/priority ?priority] - [?b :block/updated-at ?updated]]" - with - | Query_relation rows -> rows - | _ -> failwith "generated Logseq block query should return relation rows")) - -let rec find_repo_root dir = - if Sys.file_exists (Filename.concat dir "dune-project") then dir - else - let parent = Filename.dirname dir in - if parent = dir then failf "could not find repo root from %s" (Sys.getcwd ()) - else find_repo_root parent - -let repo_root = - find_repo_root (Sys.getcwd ()) - -let default_logseq_graph_db = - match Sys.getenv_opt "LOGSEQ_GRAPH_DB" with - | Some path when path <> "" -> path - | _ -> Filename.concat repo_root "db.sqlite" - -let logseq_graphs_dir = - Sys.getenv_opt "LOGSEQ_GRAPHS_DIR" - -let logseq_graph_dbs () = - match logseq_graphs_dir with - | Some dir when dir <> "" -> Sqlite_storage.graph_db_paths dir - | _ -> if Sys.file_exists default_logseq_graph_db then [ default_logseq_graph_db ] else [] - -let test_default_logseq_graph_db_uses_portable_default () = - match Sys.getenv_opt "LOGSEQ_GRAPH_DB" with - | Some path when path <> "" -> assert_equal "configured Logseq graph db" path default_logseq_graph_db - | _ -> - assert_equal "default Logseq graph db file name" "db.sqlite" (Filename.basename default_logseq_graph_db); - if not (Sys.file_exists (Filename.concat (Filename.dirname default_logseq_graph_db) "dune-project")) then - failf "default Logseq graph db should live in the repo root: %s" default_logseq_graph_db - -let test_logseq_graph_dbs_uses_portable_default () = - match logseq_graphs_dir with - | Some dir when dir <> "" -> - ignore (Sqlite_storage.graph_db_paths dir : string list) - | _ -> - if Sys.file_exists default_logseq_graph_db then - match logseq_graph_dbs () with - | [ db_path ] -> assert_equal "Logseq graph db path" default_logseq_graph_db db_path - | db_paths -> - failf - "Logseq graph dbs should contain only repo-root db.sqlite, got %d paths" - (List.length db_paths) - -let test_existing_logseq_graph_is_recognized_read_only () = - if (not (sqlite3_available ())) || not (Sys.file_exists default_logseq_graph_db) then - prerr_endline "Skipping Logseq graph inspection: sqlite3 or demo graph is unavailable" - else - let before = (Unix.stat default_logseq_graph_db).Unix.st_mtime in - let summary = Sqlite_storage.inspect ~read_only:true default_logseq_graph_db in - let after = (Unix.stat default_logseq_graph_db).Unix.st_mtime in - if not summary.has_kvs_table then failwith "Logseq graph should contain a kvs table"; - if not summary.has_root then failwith "Logseq graph should contain addr 0 root metadata"; - if not summary.has_tail then failwith "Logseq graph should contain addr 1 tail"; - if summary.row_count <= 2 then failwith "Logseq graph should contain persisted index nodes"; - if summary.root_content_format <> Sqlite_storage.Logseq_transit then - failwith "Logseq graph root should be recognized as Transit JSON"; - if not (List.mem "schema" summary.root_keys) then - failwith "Logseq graph root should decode Transit metadata keys"; - if not (List.mem "max-eid" summary.root_keys) then - failwith "Logseq graph root should expose max-eid metadata"; - if List.length summary.root_index_addresses <> 3 then - failwith "Logseq graph root should expose eavt/aevt/avet addresses"; - if before <> after then failwith "read-only inspection should not modify the graph file" - -let test_all_existing_logseq_graphs_are_recognized_read_only () = - if not (sqlite3_available ()) then - prerr_endline "Skipping all-graph Logseq inspection: sqlite3 is not available" - else - match logseq_graph_dbs () with - | [] -> prerr_endline "Skipping all-graph Logseq inspection: no local graphs found" - | db_paths -> - List.iter - (fun db_path -> - let before = (Unix.stat db_path).Unix.st_mtime in - let summary = Sqlite_storage.inspect ~read_only:true db_path in - let after = (Unix.stat db_path).Unix.st_mtime in - if not summary.has_kvs_table then failf "%s should contain a kvs table" db_path; - if not summary.has_root then failf "%s should contain addr 0 root metadata" db_path; - if summary.root_content_format <> Sqlite_storage.Logseq_transit then - failf "%s root should be recognized as Transit JSON" db_path; - if not (List.mem "schema" summary.root_keys) then - failf "%s root should decode Transit schema metadata" db_path; - if before <> after then failf "read-only inspection should not modify %s" db_path) - db_paths - -let test_existing_logseq_graph_schema_supports_query_and_transact () = - if (not (sqlite3_available ())) || not (Sys.file_exists default_logseq_graph_db) then - prerr_endline "Skipping Logseq graph query/transact smoke: sqlite3 or demo graph is unavailable" - else - let before = (Unix.stat default_logseq_graph_db).Unix.st_mtime in - let schema = Sqlite_storage.schema_of_logseq_graph ~read_only:true default_logseq_graph_db in - let after = (Unix.stat default_logseq_graph_db).Unix.st_mtime in - let block_name_schema = - match List.assoc_opt "block/name" schema with - | Some schema -> schema - | None -> failwith "Logseq graph schema should expose :block/name" - in - if not block_name_schema.indexed then failwith ":block/name should be indexed in Logseq schema"; - let db = empty_db ~schema () in - let report = transact db [ Add (Entity_id 1, "block/name", String "from-logseq-schema") ] in - assert_equal_int - "query synthetic datom with Logseq schema" - 1 - (List.length - (q_string - report.db_after - "[:find ?e :where [?e :block/name \"from-logseq-schema\"]]")); - if before <> after then failwith "read-only schema loading should not modify the graph file" - -let assert_logseq_schema_query_and_transact db_path = - let before = (Unix.stat db_path).Unix.st_mtime in - let schema = Sqlite_storage.schema_of_logseq_graph ~read_only:true db_path in - let after_schema = (Unix.stat db_path).Unix.st_mtime in - let block_name_schema = - match List.assoc_opt "block/name" schema with - | Some schema -> schema - | None -> failf "%s schema should expose :block/name" db_path - in - if not block_name_schema.indexed then failf "%s :block/name should be indexed" db_path; - let db = empty_db ~schema () in - let report = - transact db [ Add (Entity_id 9_999_998, "block/name", String "from-logseq-schema") ] - in - assert_equal_int - ("query synthetic datom with Logseq schema in " ^ db_path) - 1 - (List.length - (q_string - report.db_after - "[:find ?e :where [?e :block/name \"from-logseq-schema\"]]")); - if before <> after_schema then failf "read-only schema loading should not modify %s" db_path - -let test_all_existing_logseq_graph_schemas_support_query_and_transact () = - if not (sqlite3_available ()) then - prerr_endline "Skipping all-graph Logseq schema smoke: sqlite3 is not available" - else - match logseq_graph_dbs () with - | [] -> prerr_endline "Skipping all-graph Logseq schema smoke: no local graphs found" - | db_paths -> List.iter assert_logseq_schema_query_and_transact db_paths - -let test_existing_logseq_graph_datoms_support_query_and_transact () = - if (not (sqlite3_available ())) || not (Sys.file_exists default_logseq_graph_db) then - prerr_endline "Skipping Logseq graph datom query/transact smoke: sqlite3 or demo graph is unavailable" - else - let before = (Unix.stat default_logseq_graph_db).Unix.st_mtime in - let schema = Sqlite_storage.schema_of_logseq_graph ~read_only:true default_logseq_graph_db in - let datoms = Sqlite_storage.datoms_of_logseq_graph ~read_only:true ~limit:1 default_logseq_graph_db in - let after = (Unix.stat default_logseq_graph_db).Unix.st_mtime in - if not (List.exists (fun datom -> datom.e = 1 && datom.a = "block/name" && datom.v = String "root tag") datoms) - then failwith "Logseq graph datoms should include the root tag page name"; - let db = init_db ~schema datoms in - assert_equal_int - "query decoded Logseq graph datom" - 1 - (List.length (q_string db "[:find ?e :where [?e :block/name \"root tag\"]]")); - let report = - transact db [ Add (Entity_id 9_999_999, "block/name", String "ocaml local graph smoke") ] - in - assert_equal_int - "transact against decoded Logseq graph schema" - 1 - (List.length - (q_string - report.db_after - "[:find ?e :where [?e :block/name \"ocaml local graph smoke\"]]")); - if before <> after then failwith "read-only datom loading should not modify the graph file" - -let assert_logseq_timestamp_attrs_are_not_refs schema = - List.iter - (fun attr -> - match List.assoc_opt attr schema with - | Some { value_type = Some RefType; _ } -> - failf "%s should not decode as a ref schema attr" attr - | Some _ -> () - | None -> failf "Logseq graph schema should expose :%s" attr) - [ "block/created-at"; "block/updated-at" ] - -let max_supported_entity_id = 2_147_483_647 - -let unsupported_entity_id entity_id = - entity_id < 0 || entity_id > max_supported_entity_id - -let datom_has_unsupported_entity_id schema datom = - unsupported_entity_id datom.e - || - match List.assoc_opt datom.a schema, datom.v with - | _, Ref entity_id -> unsupported_entity_id entity_id - | Some { value_type = Some RefType; _ }, Int _ - | _ -> false - -let find_unsupported_entity_id_datoms schema datoms = - List.find_opt (datom_has_unsupported_entity_id schema) datoms - -let test_existing_logseq_graph_full_datoms_support_query () = - if (not (sqlite3_available ())) || not (Sys.file_exists default_logseq_graph_db) then - prerr_endline "Skipping full Logseq graph datom query smoke: sqlite3 or demo graph is unavailable" - else - let before = (Unix.stat default_logseq_graph_db).Unix.st_mtime in - let schema = Sqlite_storage.schema_of_logseq_graph ~read_only:true default_logseq_graph_db in - assert_logseq_timestamp_attrs_are_not_refs schema; - let datoms = Sqlite_storage.datoms_of_logseq_graph ~read_only:true default_logseq_graph_db in - let after = (Unix.stat default_logseq_graph_db).Unix.st_mtime in - (match find_unsupported_entity_id_datoms schema datoms with - | Some datom -> - Printf.eprintf - "Skipping full Logseq graph datom query smoke: datom entity id %d or ref value exceeds supported max %d\n" - datom.e - max_supported_entity_id - | None -> - let db = init_db ~schema datoms in - assert_equal_int - "query decoded full Logseq graph datoms" - 1 - (List.length (q_string db "[:find ?e :where [?e :block/name \"root tag\"]]"))); - if before <> after then failwith "read-only full datom loading should not modify the graph file" - -let query_for_datom datom = - Printf.sprintf "[:find ?v :where [%d :%s ?v]]" datom.e datom.a - -let assert_logseq_datoms_query_and_transact db_path = - let before = (Unix.stat db_path).Unix.st_mtime in - let schema = Sqlite_storage.schema_of_logseq_graph ~read_only:true db_path in - let datoms = Sqlite_storage.datoms_of_logseq_graph ~read_only:true ~limit:1 db_path in - let after = (Unix.stat db_path).Unix.st_mtime in - let first_datom = - match datoms with - | first :: _ -> first - | [] -> failf "%s should decode at least one datom from existing graph nodes" db_path - in - let db = init_db ~schema datoms in - let query_results = q_string db (query_for_datom first_datom) in - if - not - (List.exists - (function - | [ Result_value value ] -> value = first_datom.v - | _ -> false) - query_results) - then - failf "%s should query the first decoded Logseq datom" db_path; - let report = - transact db [ Add (Entity_id 9_999_999, "block/name", String "ocaml local graph smoke") ] - in - assert_equal_int - ("transact against decoded Logseq graph schema in " ^ db_path) - 1 - (List.length - (q_string - report.db_after - "[:find ?e :where [?e :block/name \"ocaml local graph smoke\"]]")); - if before <> after then failf "read-only datom loading should not modify %s" db_path - -let test_all_existing_logseq_graph_datoms_support_query_and_transact () = - if not (sqlite3_available ()) then - prerr_endline "Skipping all-graph Logseq datom smoke: sqlite3 is not available" - else - match logseq_graph_dbs () with - | [] -> prerr_endline "Skipping all-graph Logseq datom smoke: no local graphs found" - | db_paths -> List.iter assert_logseq_datoms_query_and_transact db_paths - -let () = - Random.self_init (); - test_sqlite_storage_validates_db_attribute_transactions (); - test_sqlite_storage_random_property_txs (); - test_sqlite_storage_round_trips_ocaml_payloads (); - test_sqlite_storage_raw_layout_after_transact (); - test_sqlite_storage_does_not_require_sqlite3_binary (); - test_sqlite_storage_store_and_delete_are_separate (); - test_sqlite_storage_backed_connections_query_and_transact_after_restore (); - test_sqlite_storage_backed_connections_filter_entity_rules_and_repeated_transacts (); - test_sqlite_storage_backed_connections_index_query_and_transact_parity (); - test_sqlite_storage_backed_composite_values_after_restore (); - test_sqlite_storage_backed_query_result_shapes_after_restore (); - test_sqlite_storage_backed_lookup_ref_transacts_after_restore (); - test_sqlite_storage_backed_not_or_queries_after_restore (); - test_sqlite_storage_backed_transact_history_and_current_tx_parity (); - test_sqlite_storage_backed_transact_cljc_batch_after_restore (); - test_sqlite_storage_backed_pull_sources_and_relation_inputs_after_restore (); - test_sqlite_storage_backed_reset_schema_and_compaction_parity (); - test_sqlite_storage_backed_aggregates_and_upserts_after_restore (); - test_sqlite_storage_backed_parsed_transact_and_query_pull_parity (); - test_sqlite_storage_backed_query_input_maps_after_restore (); - test_logseq_sqlite_import_preserves_clojure_collection_values (); - test_logseq_sqlite_datom_cache_ignores_uuid_values (); - test_logseq_sqlite_datom_cache_ignores_transit_tag_values (); - test_logseq_sqlite_datom_cache_spans_ordered_rows (); - test_logseq_sqlite_query_loads_matching_nodes_without_full_materialization (); - test_logseq_sqlite_schema_decodes_cached_schema_keys (); - test_logseq_sqlite_query_treats_timestamp_attrs_as_scalars_when_schema_marks_refs (); - test_logseq_sqlite_generated_graph_queries_transacted_properties_and_blocks (); - test_default_logseq_graph_db_uses_portable_default (); - test_logseq_graph_dbs_uses_portable_default (); - test_existing_logseq_graph_is_recognized_read_only (); - test_all_existing_logseq_graphs_are_recognized_read_only (); - test_existing_logseq_graph_schema_supports_query_and_transact (); - test_all_existing_logseq_graph_schemas_support_query_and_transact (); - test_existing_logseq_graph_datoms_support_query_and_transact (); - test_existing_logseq_graph_full_datoms_support_query (); - test_all_existing_logseq_graph_datoms_support_query_and_transact () diff --git a/test/test_storage.ml b/test/test_storage.ml index 4348c52..da96cec 100644 --- a/test/test_storage.ml +++ b/test/test_storage.ml @@ -1,32 +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_equal_int label expected actual = - if expected <> actual then failf "%s: expected %d, got %d" label expected actual - -let assert_int_at_most label limit actual = - if actual > limit then failf "%s: expected at most %d, got %d" label limit actual - -let assert_upstream_storage_addresses label addresses = - if List.mem "datascript/root" addresses || List.mem "datascript/tail" addresses then - failf "%s: storage should not use OCaml snapshot address names" label; - if not (List.mem "0" addresses) then failf "%s: storage should include upstream root address 0" label; - if not (List.mem "1" addresses) then failf "%s: storage should include upstream tail address 1" label; - if List.length addresses < 5 then - failf - "%s: storage should include root, tail, and separate index nodes, 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 @@ -40,15 +25,6 @@ let indexed = ; tuple_types = None } -let unique_identity = { indexed with unique = Some Identity } - -let remove_dir_if_exists dir = - if Sys.file_exists dir then begin - Sys.readdir dir - |> Array.iter (fun name -> Sys.remove (Filename.concat dir name)); - Unix.rmdir dir - end - let small_db ?storage () = empty_db ?storage () |> db_with @@ -57,37 +33,12 @@ let small_db ?storage () = ; Add (Entity_id 3, "name", String "Petr") ] -let large_db ?storage () = - empty_db ?storage () - |> db_with - (List.init 1000 (fun index -> - let entity_id = index + 1 in - Add (Entity_id entity_id, "str", String (string_of_int entity_id)))) - -let counting_storage () = - let storage = memory_storage () in - let writes = ref [] in - let storage_store entries = - writes := !writes @ List.map fst entries; - storage.storage_store entries - in - { storage with storage_store }, writes - -let restore_counting_storage storage = - let reads = ref [] in - let storage_restore address = - reads := address :: !reads; - storage.storage_restore address - in - { storage with storage_restore }, reads - -let reset_writes writes = writes := [] - let test_storage__test_basics () = let storage = memory_storage () in let db = small_db () in store ~storage db; - assert_upstream_storage_addresses "store writes upstream storage addresses" (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 -> @@ -95,74 +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_upstream_wire_addresses () = - let storage = memory_storage () in - let db = small_db () in - store ~storage db; - let addresses = storage_addresses storage in - if List.mem "datascript/root" addresses || List.mem "datascript/tail" addresses then - failwith "storage should not use OCaml snapshot address names"; - (match storage.storage_restore "0", storage.storage_restore "1" with - | Some _, Some (Storage_tail []) -> () - | None, _ -> failwith "storage should write upstream root address 0" - | _, None -> failwith "storage should write upstream tail address 1" - | _, Some _ -> failwith "storage tail address should contain the transaction tail"); - if List.length addresses < 5 then - failf - "storage should write root, tail, and separate index nodes, got [%s]" - (String.concat "," addresses) - -let test_storage__test_file_storage () = - let dir = - Filename.concat - (Filename.get_temp_dir_name ()) - ("datascript_ocaml_storage_" ^ string_of_int (Random.bits ())) - in - remove_dir_if_exists dir; - Fun.protect - ~finally:(fun () -> remove_dir_if_exists dir) - (fun () -> - let storage = file_storage dir in - let db = small_db () in - store ~storage db; - store_tail storage [ [ datom ~tx:(tx0 + 2) ~e:1 ~a:"name" ~v:(String "Alex") () ] ]; - let restored_storage = file_storage dir in - assert_upstream_storage_addresses "file_storage lists persisted addresses" (storage_addresses restored_storage); - match restore restored_storage with - | None -> failwith "file_storage should restore stored db" - | Some restored -> - assert_equal_triples - "file_storage restores root and replays persisted tail" - [ 1, "name", String "Alex"; 2, "name", String "Oleg"; 3, "name", String "Petr" ] - (datoms restored Eavt ())) - -let test_storage__test_gc () = - let storage = memory_storage () in - let db = small_db () in - store ~storage db; - store_tail storage [ [ datom ~tx:(tx0 + 2) ~e:1 ~a:"name" ~v:(String "Alex") () ] ]; - storage.storage_store [ "stale/node", Storage_tail [] ]; - collect_garbage storage; - assert_upstream_storage_addresses "collect_garbage keeps live storage addresses" (storage_addresses storage); - match restore storage with - | None -> failwith "restore should work after garbage collection" - | Some restored -> - assert_equal_triples - "collect_garbage preserves restorable data" - [ 1, "name", String "Alex"; 2, "name", String "Oleg"; 3, "name", String "Petr" ] - (datoms restored Eavt ()) - -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; @@ -171,132 +65,11 @@ let test_storage__test_restored_db_addresses () = | Some db -> db | None -> failwith "restore should read stored db" in - assert_upstream_storage_addresses "addresses should include restored db live nodes" (addresses [ restored ]) - -let test_storage__test_restored_incremental_store_reuses_index_nodes () = - let storage, writes = counting_storage () in - let db = large_db () in - store ~storage db; - let restored = - match restore storage with - | Some db -> db - | None -> failwith "restore should read stored large db" - in - reset_writes writes; - store ~storage restored; - assert_int_at_most - "storing an unchanged restored db should not rewrite index nodes" - 2 - (List.length !writes); - reset_writes writes; - let db_after = - db_with [ Add (Entity_id 1001, "str", String "1001") ] restored - in - store ~storage db_after; - assert_int_at_most - "storing an incrementally changed restored db should write only changed index paths" - 8 - (List.length !writes); - assert_equal_triples - "incremental stored db remains restorable" - [ 1001, "str", String "1001" ] - (datoms db_after Eavt ~e:1001 ()); - reset_writes writes; - let db_after_replacement = - db_with [ Add (Entity_id 1, "str", String "changed") ] restored - in - store ~storage db_after_replacement; - assert_int_at_most - "storing a cardinality-one replacement should write only changed index paths" - 16 - (List.length !writes); - assert_equal_triples - "replacement stored db remains restorable" - [ 1, "str", String "changed" ] - (datoms db_after_replacement Eavt ~e:1 ()) - -let test_storage__test_restore_is_lazy () = - let storage = memory_storage () in - large_db () |> store ~storage; - let address_count = List.length (storage_addresses storage) in - if address_count < 20 then - failf "large stored db should have many index nodes, got %d" address_count; - let counted_storage, reads = restore_counting_storage storage in - let restored = - match restore counted_storage with - | Some db -> db - | None -> failwith "restore should read stored large db" - in - assert_int_at_most "restore should only read root and tail addresses" 2 - (List.length !reads); - ignore (Seq.uncons (datoms_seq restored Eavt ())); - let reads_after_first_datom = List.length !reads in - if reads_after_first_datom <= 2 then - failwith "reading the first datom should load the first index path"; - if reads_after_first_datom >= address_count then - failf - "reading the first datom should not restore every stored node: reads=%d addresses=%d" - reads_after_first_datom address_count - -let test_storage__test_restore_with_tail_is_lazy () = - let storage = memory_storage () in - large_db () |> store ~storage; - let address_count = List.length (storage_addresses storage) in - store_tail storage - [ - [ - datom ~tx:(tx0 + 2) ~e:1 ~a:"str" ~v:(String "1") ~added:false (); - datom ~tx:(tx0 + 2) ~e:1 ~a:"str" ~v:(String "changed") (); - ]; - ]; - let counted_storage, reads = restore_counting_storage storage in - let restored = - match restore counted_storage with - | Some db -> db - | None -> failwith "restore should read stored large db with tail" - in - if List.length !reads >= address_count then - failf - "restore tail replay should not restore every stored node: reads=%d addresses=%d" - (List.length !reads) address_count; - assert_equal_triples - "tail replay should apply raw datoms" - [ 1, "str", String "changed" ] - (datoms restored Eavt ~e:1 ()) - -let test_storage__test_transact_after_restore_uses_index_slices () = - let storage = memory_storage () in - large_db () |> store ~storage; - let baseline_storage, baseline_reads = restore_counting_storage storage in - let baseline = - match restore baseline_storage with - | Some db -> db - | None -> failwith "restore should read stored large db for baseline" - in - ignore (Seq.uncons (datoms_seq baseline Eavt ~e:1 ())); - let slice_read_count = List.length !baseline_reads in - let counted_storage, reads = restore_counting_storage storage in - let restored = - match restore counted_storage with - | Some db -> db - | None -> failwith "restore should read stored large db" - in - let db_after = - db_with [ Retract (Entity_id 1, "str", Some (String "1")) ] restored - in - if List.length !reads > slice_read_count + 8 then - failf - "transact after restore should use bounded index slices: reads=%d slice_reads=%d" - (List.length !reads) slice_read_count; - assert_equal_triples - "restored db transaction should retract the targeted fact" - [] - (datoms db_after Eavt ~e:1 ()) + 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_upstream_storage_addresses "storage-backed create_conn stores upstream addresses" (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 = @@ -305,7 +78,7 @@ let test_storage__test_conn () = | None -> failwith "restore_conn should restore storage-backed conn" in assert_equal_triples - "restore_conn replays transaction tail" + "restore_conn returns stored facts" [ 1, "name", String "Ivan"; 2, "name", String "Oleg" ] (datoms (conn_db restored) Eavt ()); ignore (transact_conn ~tx_meta:[ "skip-store?", Bool true ] restored [ Add (Entity_id 3, "name", String "Skipped") ]); @@ -315,81 +88,50 @@ let test_storage__test_conn () = assert_equal_triples "skip-store transaction is not persisted" [ 1, "name", String "Ivan"; 2, "name", String "Oleg" ] - (datoms restored_db Eavt ())); - ignore - (transact_conn - restored - (List.init 34 (fun index -> - let entity_id = index + 4 in - Add (Entity_id entity_id, "name", String (string_of_int entity_id))))); - (match storage.storage_restore "1" with - | Some (Storage_tail []) -> () - | _ -> failwith "overflowing storage-backed conn tail should compact"); - let from_db_storage = memory_storage () in - let from_db = - empty_db ~schema:[ "name", indexed ] ~storage:from_db_storage () - |> db_with [ Add (Entity_id 1, "name", String "Ivan") ] - in - ignore (conn_from_db from_db); - (match restore from_db_storage with - | Some restored_db -> - assert_equal_triples - "conn_from_db stores the initial attached db root" - [ 1, "name", String "Ivan" ] - (datoms restored_db Eavt ()) - | None -> failwith "conn_from_db should store attached dbs"); - let from_datoms_storage = memory_storage () in - ignore - (conn_from_datoms - ~schema:[ "name", indexed ] - ~storage:from_datoms_storage - [ datom ~e:3 ~a:"name" ~v:(String "Petr") () ]); - match restore from_datoms_storage with - | Some restored_db -> - assert_equal_triples - "conn_from_datoms stores the initial attached db root" - [ 3, "name", String "Petr" ] - (datoms restored_db Eavt ()) - | None -> failwith "conn_from_datoms should store attached datoms" + (datoms restored_db Eavt ())) -let test_storage__test_db_with_tail () = +let test_storage__test_multi_tx_incremental_store () = + let storage = memory_storage () in let db = - empty_db ~schema:[ "block/updated-at", indexed; "block/uuid", unique_identity ] () - |> db_with [ Add (Entity_id 1, "block/updated-at", Int 2); Add (Entity_id 1, "block/uuid", String "u1") ] + 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 tail = - [ [ datom ~tx:(tx0 + 3) ~e:1 ~a:"block/updated-at" ~v:(Int 1772979060646) () ] - ; [ datom ~tx:(tx0 + 4) ~e:1 ~a:"block/updated-at" ~v:(Int 1772979061145) () ] - ; [ datom ~tx:(tx0 + 5) ~e:2 ~a:"block/uuid" ~v:(String "u1") () - ; datom ~tx:(tx0 + 5) ~e:2 ~a:"block/title" ~v:(String "Rejected") () - ] - ; [ datom ~tx:(tx0 + 6) ~e:3 ~a:"block/title" ~v:(String "Later") () ] - ] + 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 restored = db_with_tail db tail in - assert_equal_triples - "db_with_tail retracts stale cardinality-one values" - [ 1, "block/updated-at", Int 1772979061145 ] - (datoms restored Avet ~a:"block/updated-at" ()); - assert_equal_triples - "db_with_tail drops rejected unique-conflict tail groups" - [] - (datoms restored Eavt ~e:2 ()); - assert_equal_triples - "db_with_tail keeps later valid groups" - [ 3, "block/title", String "Later" ] - (datoms restored Eavt ~e:3 ()); - assert_equal_int "db_with_tail advances max tx" (tx0 + 6) restored.max_tx + let current_ages = + datoms restored Eavt ~a:"age" () + |> List.map (fun d -> match d.v with Int n -> n | _ -> -1) + in + 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 + 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 + 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_upstream_wire_addresses (); - test_storage__test_file_storage (); - test_storage__test_gc (); - test_storage__test_restored_db_addresses (); - test_storage__test_restored_incremental_store_reuses_index_nodes (); - test_storage__test_restore_is_lazy (); - test_storage__test_restore_with_tail_is_lazy (); - test_storage__test_transact_after_restore_uses_index_slices (); - test_storage__test_conn (); - test_storage__test_db_with_tail () + 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 new file mode 100644 index 0000000..2317571 --- /dev/null +++ b/test/test_tx_history.ml @@ -0,0 +1,351 @@ +open Alcotest +open Datascript + +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 + +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 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 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 string_values db ?a ?e () = + datoms_list db Eavt ?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 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 + 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 = + 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 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"); + 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" ())); + 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 = + db_with + [ Add (Entity_id 1, "name", String "Alice"); Add (Entity_id 2, "name", String "Bob") ] + (empty_db ~schema:[ "name", unique_identity ] ()) + in + 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"); + 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 = + 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 + 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 + check_string_list "current db keeps latest age only" [ "30" ] + (List.map string_of_int (int_values db ~a:"age" ())); + check_string_list "current db drops retracted name" [] (string_values db ~a:"name" ()); + let hist = history db in + 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 + check_string_list "history exposes retraction datoms" [ "Alice" ] retracted_names + +let test_history_survives_entity_retraction () = + 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 + let tx0 = basis_tx db in + let db = db_with [ Add (Entity_id 1, "age", Int 30) ] 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" ())); + let hist = history db in + 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 + 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 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 () = + 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 + 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); + 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 = + 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 + 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 = + 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 + 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 = + 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 + check_bool "as_of view should return consistent EAVT and AEVT slices" true (eavt = aevt) + +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 + 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_seek_respects_as_of_view () = + 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 past = as_of tx0 db in + let seek_ages = + seek_datoms past Aevt ~a:"age" () + |> List.of_seq + |> List.filter (fun d -> d.e = 1) + |> List.map (fun d -> match d.v with Int n -> n | _ -> -1) + in + let rseek_ages = + rseek_datoms past Aevt ~a:"age" () + |> List.of_seq + |> List.filter (fun d -> d.e = 1) + |> List.map (fun d -> match d.v with Int n -> n | _ -> -1) + in + check_string_list "seek_datoms on as_of sees past age" [ "25" ] (List.map string_of_int seek_ages); + check_string_list "rseek_datoms on as_of sees past age" [ "25" ] (List.map string_of_int rseek_ages) + +let test_attr_caches_detach_and_preserve_untouched () = + 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 + (* Warm current-fact caches. *) + ignore (datoms_list db Aevt ~a:"name" ()); + ignore (datoms_list db Aevt ~a:"age" ()); + check_int "name cache warmed" 1 (if Hashtbl.mem db.aevt_by_attr "name" then 1 else 0); + check_int "age cache warmed" 1 (if Hashtbl.mem db.aevt_by_attr "age" then 1 else 0); + let tx0 = basis_tx db in + let past = as_of tx0 db in + check_int "as_of detaches attr caches" 0 (Hashtbl.length past.aevt_by_attr); + check_int "live name cache survives as_of" 1 (if Hashtbl.mem db.aevt_by_attr "name" then 1 else 0); + let db = db_with [ Add (Entity_id 1, "age", Int 30) ] db in + check_int "untouched name cache survives age write" 1 (if Hashtbl.mem db.aevt_by_attr "name" then 1 else 0); + check_int "touched age cache invalidated" 0 (if Hashtbl.mem db.aevt_by_attr "age" then 1 else 0); + check_string_list "name still readable after selective invalidate" [ "Alice"; "Bob" ] + (string_values db ~a:"name" ()) + +let test_as_of_instant_and_purge_history_before () = + let db = + empty_db ~schema:[ "name", unique_identity; "age", indexed ] () + |> fun db -> + (transact + ~tx_meta:[ "db/txInstant", Instant 1_000 ] + db + [ Add (Entity_id 1, "name", String "Alice"); Add (Entity_id 1, "age", Int 25) ]).db_after + in + let tx0 = basis_tx db in + let db = + (transact + ~tx_meta:[ "db/txInstant", Instant 2_000 ] + db + [ Add (Entity_id 1, "age", Int 30) ]).db_after + in + let past = as_of_instant (Instant 1_500) db in + check_int "as_of_instant resolves to first tx" tx0 (basis_tx past); + check_string_list "as_of_instant sees age 25" [ "25" ] + (List.map string_of_int (int_values past ~e:1 ~a:"age" ())); + let db2, removed = purge_history_before (basis_tx db) db in + check_int "purge_history_before removes superseded history" 1 (if removed <> [] then 1 else 0); + check_string_list "current age remains after purge-before" [ "30" ] + (List.map string_of_int (int_values db2 ~e:1 ~a:"age" ())); + check_string_list "purged history no longer exposes old age" [] + (history_asserted_values db2 ~a:"age" ~e:1 () + |> List.filter (fun s -> s = "25")) + +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 + 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 + 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 () = + 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 "seek and rseek respect as_of" `Quick test_seek_respects_as_of_view + ; test_case "attr caches detach and preserve untouched" `Quick + test_attr_caches_detach_and_preserve_untouched + ; test_case "as_of_instant and purge_history_before" `Quick + test_as_of_instant_and_purge_history_before + ; test_case "public api aliases" `Quick test_public_api_aliases + ] ) + ] diff --git a/test/test_tx_visibility.ml b/test/test_tx_visibility.ml new file mode 100644 index 0000000..198df78 --- /dev/null +++ b/test/test_tx_visibility.ml @@ -0,0 +1,56 @@ +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_filter_seq_streams_without_full_materialization () = + let bounds = { view_tx = 200; since_tx = None; history = false } in + 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:150 ~added:false in + let d3 = datom ~e:2 ~a:":name" ~v:(String "Petr") ~tx:160 ~added:true in + let result = filter_seq [] bounds (List.to_seq [ d1; d2; d3 ]) |> List.of_seq in + assert_equal_int "streaming filter cancels retracted name" 1 (List.length result); + assert_equal_int "surviving entity is Petr" 2 (List.hd result).e + +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 (); + test_filter_seq_streams_without_full_materialization (); + Printf.printf "test_tx_visibility: ok\n" diff --git a/type/datascript_types.ml b/type/datascript_types.ml index c09e317..43b1e67 100644 --- a/type/datascript_types.ml +++ b/type/datascript_types.ml @@ -69,6 +69,8 @@ type datom = ; added : bool } +type index_set + type serializable_db = { serializable_schema : schema ; serializable_datoms : datom list @@ -78,30 +80,13 @@ type serializable_db = type storage_address = string -type storage_root = - { storage_schema : schema - ; storage_max_eid : entity_id - ; storage_max_tx : tx - ; storage_eavt : storage_address - ; storage_aevt : storage_address - ; storage_avet : storage_address - ; storage_duplicate_datoms : datom list - ; storage_max_addr : int - ; storage_branching_factor : int - ; storage_ref_type : Persistent_sorted_set.ref_type - } +type storage_kind = string -type storage_payload = - | Storage_root of storage_root - | Storage_node of datom Persistent_sorted_set.stored_node - | Storage_tail of datom list list +let storage_kind_memory = "memory" +let storage_kind_lmdb = "lmdb" +let storage_kind_sqlite = "sqlite" -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 - } +type storage = Storage_handle of int type tx_value = | One_value of value @@ -114,11 +99,14 @@ and tx_entity = ; attrs : (attr * tx_value) list } -type tx_op = +and tx_op = | Add of entity_ref * attr * value | 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 @@ -130,11 +118,12 @@ type tx_op = and db = { db_uid : int ; schema : schema - ; eavt_index : datom Persistent_sorted_set.t - ; aevt_index : datom Persistent_sorted_set.t - ; avet_index : datom Persistent_sorted_set.t - ; aevt_by_attr : (attr, datom list) Hashtbl.t - ; avet_by_attr : (attr, datom list) Hashtbl.t + ; eavt_index : index_set + ; aevt_index : index_set + ; avet_index : index_set + ; aevt_by_attr : (attr, datom array) Hashtbl.t + ; avet_by_attr : (attr, datom array) Hashtbl.t + ; avet_entities_by_attr_value : (attr * value, entity_id array) Hashtbl.t ; duplicate_datoms : datom list ; duplicate_aevt_datoms : datom list ; duplicate_avet_datoms : datom list @@ -144,7 +133,12 @@ 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 + ; pending_datoms : datom list ; storage_ref : storage option ; tx_fns : (entity_id * (db -> value list -> tx_op list)) list } @@ -517,4 +511,312 @@ 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 = + match String.index_opt keyword '/' with + | None -> "", keyword + | Some index -> + let namespace = String.sub keyword 0 index in + let name = String.sub keyword (index + 1) (String.length keyword - index - 1) in + namespace, name + + let rec compare_list_items_with compare_item left right = + match left, right with + | [], [] -> 0 + | left :: left_rest, right :: right_rest -> + let comparison = compare_item left right in + if comparison <> 0 then comparison else compare_list_items_with compare_item left_rest right_rest + | [], _ | _, [] -> 0 + + let compare_list_with compare_item left right = + let length_comparison = compare (List.length left) (List.length right) in + if length_comparison <> 0 then length_comparison + else compare_list_items_with compare_item left right + + let compare_option_with compare_item left right = + match left, right with + | None, None -> 0 + | None, Some _ -> -1 + | Some _, None -> 1 + | Some left, Some right -> compare_item left right + + let i32 value = Int32.of_int value + let i32_to_int value = Int32.to_int value + let i32_add left right = Int32.add left right + let i32_mul left right = Int32.mul left right + let i32_xor left right = Int32.logxor left right + let i32_shift_left value bits = Int32.shift_left value bits + let i32_shift_right value bits = Int32.shift_right value bits + let i32_shift_right_logical value bits = Int32.shift_right_logical value bits + + let i32_rotate_left value bits = + Int32.logor (Int32.shift_left value bits) (Int32.shift_right_logical value (32 - bits)) + + let murmur3_mix_k1 value = + value + |> fun value -> i32_mul value (i32 (-862048943)) + |> fun value -> i32_rotate_left value 15 + |> fun value -> i32_mul value (i32 461845907) + + let murmur3_mix_h1 hash value = + i32_xor hash value + |> fun hash -> i32_rotate_left hash 13 + |> fun hash -> i32_add (i32_mul hash (i32 5)) (i32 (-430675100)) + + let murmur3_fmix hash length = + i32_xor hash (i32 length) + |> fun hash -> i32_xor hash (i32_shift_right_logical hash 16) + |> fun hash -> i32_mul hash (i32 (-2048144789)) + |> fun hash -> i32_xor hash (i32_shift_right_logical hash 13) + |> fun hash -> i32_mul hash (i32 (-1028477387)) + |> fun hash -> i32_xor hash (i32_shift_right_logical hash 16) + + let murmur3_hash_int value = + if value = 0 then 0 + else + value + |> i32 + |> murmur3_mix_k1 + |> murmur3_mix_h1 Int32.zero + |> fun hash -> murmur3_fmix hash 4 + |> i32_to_int + + let murmur3_hash_long value = + if value = Int64.zero then 0 + else + let low = Int64.to_int value |> i32 in + let high = Int64.shift_right_logical value 32 |> Int64.to_int |> i32 in + Int32.zero + |> fun hash -> murmur3_mix_h1 hash (murmur3_mix_k1 low) + |> fun hash -> murmur3_mix_h1 hash (murmur3_mix_k1 high) + |> fun hash -> murmur3_fmix hash 8 + |> i32_to_int + + let murmur3_hash_unencoded_chars text = + let hash = ref Int32.zero in + let index = ref 1 in + let length = String.length text in + while !index < length do + let code = + Char.code text.[!index - 1] lor (Char.code text.[!index] lsl 16) + in + hash := murmur3_mix_h1 !hash (murmur3_mix_k1 (i32 code)); + index := !index + 2 + done; + if length land 1 = 1 then + hash := i32_xor !hash (murmur3_mix_k1 (i32 (Char.code text.[length - 1]))); + murmur3_fmix !hash (2 * length) |> i32_to_int + + let java_string_hash text = + let hash = ref Int32.zero in + String.iter + (fun ch -> hash := i32_add (i32_mul !hash (i32 31)) (i32 (Char.code ch))) + text; + i32_to_int !hash + + let hex_value = function + | '0' .. '9' as ch -> Char.code ch - Char.code '0' + | 'a' .. 'f' as ch -> 10 + Char.code ch - Char.code 'a' + | 'A' .. 'F' as ch -> 10 + Char.code ch - Char.code 'A' + | _ -> invalid_arg "invalid UUID hex digit" + + let uuid_halves uuid = + let digits = + uuid + |> String.to_seq + |> Seq.filter (( <> ) '-') + |> List.of_seq + in + if List.length digits <> 32 then invalid_arg ("invalid UUID: " ^ uuid); + let take_hex count digits = + let rec loop acc remaining rest = + if remaining = 0 then acc, rest + else + match rest with + | [] -> invalid_arg ("invalid UUID: " ^ uuid) + | ch :: rest -> + loop + (Int64.logor (Int64.shift_left acc 4) (Int64.of_int (hex_value ch))) + (remaining - 1) + rest + in + loop Int64.zero count digits + in + let most, rest = take_hex 16 digits in + let least, _ = take_hex 16 rest in + most, least + + let int64_low_i32 value = + Int64.logand value 0xffffffffL |> Int64.to_int |> i32 + + let int64_high_i32 value = + Int64.shift_right_logical value 32 |> int64_low_i32 + + let java_uuid_hash uuid = + let most, least = uuid_halves uuid in + i32_xor + (i32_xor (int64_high_i32 most) (int64_low_i32 most)) + (i32_xor (int64_high_i32 least) (int64_low_i32 least)) + |> i32_to_int + + let clojure_hash_combine seed hash = + i32_xor + (i32 seed) + (i32_add + (i32_add (i32 hash) (i32 (-1640531527))) + (i32_add (i32_shift_left (i32 seed) 6) (i32_shift_right (i32 seed) 2))) + |> i32_to_int + + let clojure_symbol_hash symbol = + let namespace, name = split_keyword symbol in + let namespace_hash = if namespace = "" then 0 else java_string_hash namespace in + clojure_hash_combine (murmur3_hash_unencoded_chars name) namespace_hash + + let clojure_keyword_hash name = + i32_add (i32 (clojure_symbol_hash name)) (i32 (-1640531527)) |> i32_to_int + + let murmur3_mix_coll_hash hash count = + hash + |> i32 + |> murmur3_mix_k1 + |> murmur3_mix_h1 Int32.zero + |> fun hash -> murmur3_fmix hash count + |> i32_to_int + + let murmur3_hash_ordered hashes = + let count, hash = + List.fold_left + (fun (count, hash) value_hash -> + count + 1, i32_add (i32_mul (i32 31) hash) (i32 value_hash)) + (0, i32 1) + hashes + in + murmur3_mix_coll_hash (i32_to_int hash) count + + let murmur3_hash_unordered hashes = + let count, hash = + List.fold_left + (fun (count, hash) value_hash -> count + 1, i32_add hash (i32 value_hash)) + (0, Int32.zero) + hashes + in + murmur3_mix_coll_hash (i32_to_int hash) count + + let rec clojure_hasheq = function + | Nil -> 0 + | Bool true -> 1231 + | Bool false -> 1237 + | Int value -> murmur3_hash_long (Int64.of_int value) + | Float value -> Hashtbl.hash value + | String value -> murmur3_hash_int (java_string_hash value) + | Symbol value -> clojure_symbol_hash value + | Keyword value -> clojure_keyword_hash value + | List values | Vector values -> murmur3_hash_ordered (List.map clojure_hasheq values) + | Set values -> murmur3_hash_unordered (List.map clojure_hasheq values) + | Map entries -> + entries + |> List.map (fun (key, value) -> murmur3_hash_ordered [ clojure_hasheq key; clojure_hasheq value ]) + |> murmur3_hash_unordered + | Tuple values -> + values + |> List.map (function None -> 0 | Some value -> clojure_hasheq value) + |> murmur3_hash_ordered + | Ref value -> murmur3_hash_long (Int64.of_int value) + | Uuid value -> java_uuid_hash value + | Instant value -> murmur3_hash_long (Int64.of_int value) + | Regex value -> Hashtbl.hash value + | TxRef -> Hashtbl.hash TxRef + | Ref_to value -> Hashtbl.hash (Ref_to value) + + let value_type_rank = function + | Nil -> 0 + | Keyword _ -> 1 + | Symbol _ -> 2 + | Map _ -> 3 + | Set _ -> 4 + | List _ -> 5 + | Vector _ -> 6 + | Tuple _ -> 7 + | Bool _ -> 8 + | Int _ | Float _ | Ref _ -> 9 + | String _ -> 10 + | Regex _ -> 11 + | Instant _ -> 12 + | Uuid _ -> 13 + | TxRef -> 14 + | Ref_to _ -> 15 + + let rec compare_value left right = + match left, right with + | Int left, Int right -> compare left right + | Float left, Float right -> compare left right + | Int left, Float right -> compare (float_of_int left) right + | Float left, Int right -> compare left (float_of_int right) + | Ref left, Ref right -> compare left right + | Int left, Ref right -> compare left right + | Ref left, Int right -> compare left right + | Float left, Ref right -> compare left (float_of_int right) + | Ref left, Float right -> compare (float_of_int left) right + | String left, String right -> compare left right + | Symbol left, Symbol right -> compare (split_keyword left) (split_keyword right) + | Bool left, Bool right -> compare left right + | Uuid left, Uuid right -> compare left right + | Instant left, Instant right -> compare left right + | Regex left, Regex right -> compare left right + | Nil, Nil -> 0 + | Keyword left, Keyword right -> compare (split_keyword left) (split_keyword right) + | List left, List right -> compare_list_with compare_value left right + | Vector left, Vector right -> compare_list_with compare_value left right + | List left, Tuple right -> + compare_list_with (compare_option_with compare_value) (List.map (fun value -> Some value) left) right + | Set _, Set _ -> compare (clojure_hasheq left) (clojure_hasheq right) + | Map _, Map _ -> compare (clojure_hasheq left) (clojure_hasheq right) + | Tuple left, Tuple right -> compare_list_with (compare_option_with compare_value) left right + | Tuple left, List right -> + compare_list_with (compare_option_with compare_value) left (List.map (fun value -> Some value) right) + | _ -> + let rank_comparison = compare (value_type_rank left) (value_type_rank right) in + if rank_comparison <> 0 then rank_comparison else compare left right + + and compare_map_entry (left_key, left_value) (right_key, right_value) = + let comparison = compare_value left_key right_key in + if comparison <> 0 then comparison else compare_value left_value right_value + + let first_nonzero4 first second third fourth = + if first <> 0 then first + else if second <> 0 then second + 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 -> + 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 -> + 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 -> + 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 diff --git a/type/dune b/type/dune index 353901d..4ea880b 100644 --- a/type/dune +++ b/type/dune @@ -2,4 +2,4 @@ (name datascript_types) (public_name datascript_ocaml.types) (modes native byte melange) - (libraries persistent_sorted_set_ocaml)) + (modules datascript_types))