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/compare_ocaml_datahike.sh b/bench/compare_ocaml_datahike.sh new file mode 100755 index 0000000..1c12a58 --- /dev/null +++ b/bench/compare_ocaml_datahike.sh @@ -0,0 +1,188 @@ +#!/usr/bin/env bash +set -euo pipefail + +usage() { + cat <<'EOF' +Usage: compare_ocaml_datahike.sh [SIZE] [QUERY] + +Run OCaml vs Datahike shared query benchmarks. + + SIZE entity count (default: 2000) + QUERY optional single query name, e.g. q3, qpred1, q-rule + +Environment: + BENCH_QUERY same as QUERY positional arg + BENCH_WARMUP_MS warmup duration per benchmark (default: 200, 2000 when FULL=1) + BENCH_SAMPLE_MS sample duration per benchmark (default: 200, 2000 when FULL=1) + BENCH_REPEATS median sample count (default: 2) + BENCH_JIT_WARMUP JIT iterations per query before timing (default: 100) + FULL=1 use publication timing (2000ms warmup/sample) + +Examples: + ./compare_ocaml_datahike.sh 2000 q3 + BENCH_QUERY=qpred1 ./compare_ocaml_datahike.sh + dune exec --release bench/datahike_compare.exe -- --size 2000 --query q3 --list-queries +EOF +} + +SIZE="${1:-2000}" +QUERY="${BENCH_QUERY:-}" + +if [[ "${1:-}" == "-h" || "${1:-}" == "--help" ]]; then + usage + exit 0 +fi + +if [[ -n "${2:-}" ]]; then + QUERY="$2" +fi + +if [[ "$SIZE" == "--help" || "$SIZE" == "-h" ]]; then + usage + exit 0 +fi + +if [[ "${FULL:-0}" == "1" ]]; then + WARMUP_MS="${WARMUP_MS:-2000}" + SAMPLE_MS="${SAMPLE_MS:-2000}" + REPEATS="${REPEATS:-2}" + JIT_WARMUP="${JIT_WARMUP:-100}" +else + WARMUP_MS="${WARMUP_MS:-200}" + SAMPLE_MS="${SAMPLE_MS:-200}" + REPEATS="${REPEATS:-2}" + JIT_WARMUP="${JIT_WARMUP:-100}" +fi + +export BENCH_SIZE="$SIZE" +export BENCH_WARMUP_MS="$WARMUP_MS" +export BENCH_SAMPLE_MS="$SAMPLE_MS" +export BENCH_REPEATS="$REPEATS" +export BENCH_JIT_WARMUP="$JIT_WARMUP" +if [[ -n "$QUERY" ]]; then + export BENCH_QUERY="$QUERY" +fi + +SCRIPT_DIR="$(cd "$(dirname "${BASH_SOURCE[0]}")" && pwd)" +REPO_ROOT="$(cd "$SCRIPT_DIR/.." && pwd)" +DATAHIKE_REPO="${DATAHIKE_REPO:-/tmp/bench-datahike}" +OCAML_BENCH="${REPO_ROOT}/_build/default/bench/datahike_compare.exe" + +ensure_datahike_java() { + if [[ ! -e "$DATAHIKE_REPO/deps.edn" ]]; then + git clone --depth 1 https://github.com/replikativ/datahike.git "$DATAHIKE_REPO" + fi + ( + cd "$DATAHIKE_REPO" + mkdir -p target/classes + local cp + cp="$(clojure -Spath -M:bench)" + if [[ ! -f target/classes/datahike/java/QueryResult.class ]]; then + javac -cp "$cp:target/classes" -d target/classes \ + java/src/datahike/java/IEntity.java \ + java/src/datahike/java/Util.java \ + java/src/datahike/java/QueryResult.java + fi + ) +} + +run_datahike() { + ( + cd "$DATAHIKE_REPO" + DATAHIKE_QUERY_PLANNER=true clojure -M:bench -e \ + "(load-file \"${REPO_ROOT}/bench/datahike_shared_bench.clj\")" \ + 2>/dev/null + ) +} + +run_ocaml() { + local ocaml_args=( + --size "$SIZE" + --warmup-ms "$WARMUP_MS" + --sample-ms "$SAMPLE_MS" + --repeats "$REPEATS" + --jit-warmup "$JIT_WARMUP" + ) + if [[ -n "$QUERY" ]]; then + ocaml_args+=(--query "$QUERY") + fi + ( + cd "$REPO_ROOT" + dune build --profile release bench/datahike_compare.exe >/dev/null + BENCH_RUNTIME_LABEL=ocaml "$OCAML_BENCH" "${ocaml_args[@]}" 2>/dev/null + ) +} + +parse_dh_row() { + local name="$1" + awk -v n="$name" '$1 == n { print $2; exit }' +} + +parse_ocaml_row() { + local name="$1" + awk -F'\t' -v n="$name" '$1 == n { print $2; exit }' +} + +ratio_cell() { + awk -v o="$1" -v d="$2" 'BEGIN { + if (o + 0 == 0 || d + 0 == 0) print "?"; + else printf "%.2fx", o / d + }' +} + +ensure_datahike_java + +if [[ -n "$QUERY" ]]; then + echo "=== OCaml vs Datahike query benchmark (${SIZE} entities, query=${QUERY}) ===" +else + echo "=== OCaml vs Datahike query benchmark (${SIZE} entities) ===" +fi +if [[ "${FULL:-0}" == "1" ]]; then + echo "Protocol: FULL warmup=${WARMUP_MS}ms sample=${SAMPLE_MS}ms repeats=${REPEATS} jit=${JIT_WARMUP} (set FULL=1)" +else + echo "Protocol: fast warmup=${WARMUP_MS}ms sample=${SAMPLE_MS}ms repeats=${REPEATS} jit=${JIT_WARMUP} (use FULL=1 for publication timing)" +fi +echo "Storage: datahike=memory+persistent-set ocaml=memory LMDB index (nosync, see storage row in raw output)" +echo + +START=$(date +%s) +echo "Running Datahike (JVM cold start may take ~30-60s)..." +DH_OUT="$(run_datahike)" +DH_SEC=$(( $(date +%s) - START )) +echo "Running OCaml (${DH_SEC}s for Datahike side)..." +OCAML_START=$(date +%s) +OCAML_OUT="$(run_ocaml)" +OCAML_SEC=$(( $(date +%s) - OCAML_START )) +TOTAL_SEC=$(( $(date +%s) - START )) + +QUERY_ORDER=( + 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 +) + +if [[ -n "$QUERY" ]]; then + QUERY_ORDER=("$QUERY") +fi + +printf "%-14s %12s %12s %12s\n" "benchmark" "datahike(ms)" "ocaml(ms)" "ocaml/dh" +echo "------------------------------------------------------------" + +for name in "${QUERY_ORDER[@]}"; do + dh_ms="$(printf '%s\n' "$DH_OUT" | parse_dh_row "$name")" + ocaml_ms="$(printf '%s\n' "$OCAML_OUT" | parse_ocaml_row "$name")" + if [[ -z "$dh_ms" || -z "$ocaml_ms" ]]; then + printf "%-14s %12s %12s %12s\n" "$name" "${dh_ms:-?}" "${ocaml_ms:-?}" "?" + continue + fi + ratio="$(ratio_cell "$ocaml_ms" "$dh_ms")" + printf "%-14s %12s %12s %12s\n" "$name" "$dh_ms" "$ocaml_ms" "$ratio" +done + +echo +echo "Timing: datahike=${DH_SEC}s ocaml=${OCAML_SEC}s total=${TOTAL_SEC}s" +echo +echo "=== raw: datahike ===" +printf '%s\n' "$DH_OUT" | awk '/^(q|runtime|size|warmup|sample|repeats|jit|Setting|Query planner|Done)/ || /^[[:space:]]*q/ || /^Benchmark/ || /^---/ { print }' +echo +echo "=== raw: ocaml ===" +printf '%s\n' "$OCAML_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/datahike_compare.ml b/bench/datahike_compare.ml new file mode 100644 index 0000000..f0ecfa1 --- /dev/null +++ b/bench/datahike_compare.ml @@ -0,0 +1,312 @@ +open Datascript + +(* Align with Datahike benchmark.datascript-bench: 20k people, query suite, timing protocol. *) + +type config = + { size : int + ; warmup_ms : float + ; sample_ms : float + ; repeats : int + ; step : int + ; jit_warmup : int + ; query : string option + } + +let default_config = + { size = 20_000 + ; warmup_ms = 200. + ; sample_ms = 200. + ; repeats = 2 + ; step = 10 + ; jit_warmup = 100 + ; query = None + } + +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 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 + | 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 = blackhole := (!blackhole + List.length rows) 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_datahike_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 build_db size = + let storage = benchmark_memory_storage () in + let rng = rng 1 in + let entities = List.init size (fun index -> random_man rng (index + 1)) in + let db = db_with entities (empty_db ~schema ~storage ()) 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 + let db = if follow_ops = [] then db else db_with follow_ops db in + refresh_db_indexes db + +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 main () = + let config = parse_args () in + let selected = select_queries config.query 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; + Printf.printf "storage\tmemory-lmdb-nosync-index\n%!"; + 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 "db-mode\tshared\n%!"; + (match config.query with + | Some name -> Printf.printf "query\t%s\n%!" name + | None -> ()); + Printf.eprintf "Building shared database (%d entities)...\n%!" config.size; + let db = build_db config.size in + Printf.eprintf "JIT pre-warmup (%d/query)...\n%!" config.jit_warmup; + warmup_queries config.jit_warmup selected db; + Printf.eprintf "Running benchmarks...\n%!"; + List.iter + (fun query -> + let ms = bench config (fun () -> query.run db) in + Printf.printf "%s\t%s\n%!" query.name (format_ms ms)) + selected; + 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 () diff --git a/bench/datahike_shared_bench.clj b/bench/datahike_shared_bench.clj new file mode 100644 index 0000000..2f1b512 --- /dev/null +++ b/bench/datahike_shared_bench.clj @@ -0,0 +1,88 @@ +(require '[benchmark.datascript-bench :as bench] + '[clojure.string :as str] + '[datahike.api :as d] + '[datahike.query :as q]) + +(alter-var-root #'q/*query-result-cache?* (constantly false)) + +(defn- env-int [name default] + (some-> (System/getenv name) Integer/parseInt (or default))) + +(defn- env-double [name default] + (some-> (System/getenv name) Double/parseDouble (or default))) + +(def bench-size + (some-> (System/getenv "BENCH_SIZE") Integer/parseInt)) + +(def bench-query + (let [value (System/getenv "BENCH_QUERY")] + (when (and value (not (str/blank? value))) + (keyword value)))) + +(def warmup-ms (env-double "BENCH_WARMUP_MS" 200.0)) +(def sample-ms (env-double "BENCH_SAMPLE_MS" 200.0)) +(def bench-repeats (env-int "BENCH_REPEATS" 2)) +(def jit-warmup (env-int "BENCH_JIT_WARMUP" 100)) + +(defn people-of-size [size] + (if (<= size (count bench/people20k)) + (subvec bench/people20k 0 size) + (vec (take size bench/people)))) + +(defn db-with-people [size] + (let [cfg {:store {:backend :memory :id (java.util.UUID/randomUUID)} + :schema-flexibility :write + :keep-history? false + :attribute-refs? true + :search-cache-size 0 + :index :datahike.index/persistent-set}] + (d/delete-database cfg) + (d/create-database cfg) + (let [conn (d/connect cfg)] + (d/transact conn {:tx-data bench/dh-schema}) + (d/transact conn {:tx-data (people-of-size size)}) + (let [db @conn] + (d/release conn) + db)))) + +(defn- query-order [] + (if bench-query + (if (contains? bench/queries bench-query) + [bench-query] + (throw (ex-info (str "unknown query " bench-query + " (available: " + (str/join ", " (map name bench/query-order)) + ")") + {:query bench-query}))) + bench/query-order)) + +(println "runtime\tdatahike") +(println "db-mode\tshared") +(println "storage\tmemory-persistent-set") +(when bench-size + (println (str "size\t" bench-size))) +(when bench-query + (println (str "query\t" (name bench-query)))) +(println (str "warmup-ms\t" (long warmup-ms))) +(println (str "sample-ms\t" (long sample-ms))) +(println (str "repeats\t" bench-repeats)) +(println (str "jit-warmup\t" jit-warmup)) + +(binding [bench/*warmup-t* (long warmup-ms) + bench/*bench-t* (long sample-ms) + bench/*repeats* bench-repeats] + (let [size (or bench-size 20000) + db (db-with-people size) + selected (query-order)] + (println (str "JIT pre-warmup (" jit-warmup "/query)...")) + (when (pos? jit-warmup) + (doseq [qname selected] + (let [{:keys [query args]} (get bench/queries qname) + qargs (or args [])] + (dotimes [_ jit-warmup] + (apply d/q query db qargs))))) + (doseq [qname selected] + (let [{:keys [query args]} (get bench/queries qname) + qargs (or args []) + ms (bench/bench (apply d/q query db qargs))] + (println (name qname) "\t" ms))))) diff --git a/bench/dune b/bench/dune index 2b6fe96..be7a4df 100644 --- a/bench/dune +++ b/bench/dune @@ -20,6 +20,16 @@ (modules memory_scenario) (libraries datascript-ocaml-native)) +(executable + (name count_avet) + (modules count_avet) + (libraries datascript-ocaml-native unix)) + +(executable + (name datahike_compare) + (modules datahike_compare) + (libraries datascript-ocaml-native unix)) + (executable (name memory_ocaml) (modules memory_ocaml) 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/docs/adr/query-planner.md b/docs/adr/query-planner.md new file mode 100644 index 0000000..9c875a3 --- /dev/null +++ b/docs/adr/query-planner.md @@ -0,0 +1,169 @@ +# ADR: Compiled Query Planner for Datalog Pattern Queries + +## Status + +Accepted + +## Context + +The query engine today evaluates `:where` clauses through a hybrid interpreter in +`impl/query_where.ml`. Simple shapes already take dedicated fast paths — same-entity +pattern fusion, AVET range scans for value predicates, hash-join for cross-entity +patterns, and direct relation-to-find projection in `impl/query_api.ml`. This works +well for many upstream DataScript queries and keeps semantics aligned with the public +Clojure/ClojureScript engine. + +However, the interpreter model has structural limits: + +1. **No compile/execute split.** Each query re-derives index choices and clause + ordering from scratch. There is no reusable plan for repeated execution inside + benchmarks, reactive queries, or application hot loops. + +2. **Shape-gated fast paths.** Optimizations are tied to specific clause sequences. + Equivalent queries with reordered clauses or slightly different surface syntax can + miss the fast path and fall back to binding-based evaluation. + +3. **Intermediate materialization.** Even when index access is narrow, many paths + build full `{ attrs; rows }` relations before projection. For large selective + scans (predicate/range queries over indexed attributes), row construction and + list allocation dominate runtime. + +4. **No cost model.** Clause order follows source order or ad hoc heuristics. A + constant lookup followed by a wide scan can be chosen when the reverse order would + probe far fewer datoms. + +5. **Rule and join overhead.** Non-recursive rules and multi-clause joins still + round-trip through binding lists even when the rule body is a single indexed + pattern. + +Industry Datalog engines that compile queries to index plans share a common shape: +analyze clauses into a logical plan, estimate access cost, order joins, lower to +physical operators (range scan, merge scan, hash probe), and stream results without +materializing full binding maps. The OCaml port should converge on that architecture +while preserving DataScript semantics and the existing public query API (`q`, `q`, +inputs, rules, temporal views). + +Performance is a hard requirement: native OCaml must lead tracked benchmark suites, +and `js_of_ocaml` must stay at least on par with upstream DataScript JavaScript. +Planner work is incomplete if it regresses those targets. + +## Decision + +Introduce a **compiled query planner** behind the existing query entry points. The +planner will not add new public APIs. Parsed queries will optionally compile to a +small logical plan IR, optimize clause order, lower to physical operators, and +execute with streaming index access. + +### Logical plan IR + +Represent `:where` clauses as a tree of logical nodes: + +| Node | Meaning | +| --- | --- | +| `Scan` | Single pattern on one index (EAVT, AEVT, AVET, or VAET-equivalent path) | +| `RangeScan` | AVET slice with optional open/closed bounds on value | +| `MergeScan` | Same-entity multi-pattern intersection via synchronized cursors | +| `HashJoin` | Cross-entity or cross-variable join on shared keys | +| `Filter` | Comparison, equality, or callable predicate on bound columns | +| `AntiJoin` | `not` / `not-join` exclusion | +| `Union` | `or` / `or-join` branches | +| `RuleExpand` | Inline non-recursive rule heads | + +Each node carries: + +- bound and free variables +- chosen index and prefix fields (e, a, v, tx) +- estimated row count (cardinality hint) +- source (`$` or named DB) + +### Analysis phase + +1. **Constant propagation** — substitute single-value bindings from inputs and prior + nodes (same as upstream `substitute-constants`). +2. **Index selection** — for each pattern, pick the narrowest index: AVET when attr + and value bounds exist; AEVT when only attr is ground; EAVT when entity is + ground; reverse-ref via VAET path. +3. **Predicate pushdown** — move comparison clauses onto `RangeScan` bounds when the + compared variable is the pattern value and the attribute is AVET-indexed. +4. **Same-entity detection** — collapse consecutive same-entity patterns into one + `MergeScan` node instead of sequential hash joins. + +### Optimization phase + +Use dynamic programming (Selinger-style) over join ordering for up to a small fixed +number of logical nodes (typically ≤ 8, matching practical DataScript query size): + +- **Cost estimates** from index cardinality hints: schema `:db/cardinality`, AVET + slice width, constant lookup size, and `max_datom_e` fallbacks. +- **Join algorithm choice**: entity-key merge for same-entity; hash probe for + cross-entity when build side is smaller. +- **Left-deep bias** for selective scans, mirroring upstream `query_v3` behavior. + +Keep the current fast paths as **recognized plan shapes** during a transition period +so behavior and performance do not regress while the generic planner matures. + +### Physical execution + +Lower logical nodes to streaming operators: + +1. **Range scan iterator** — walk AVET/AEVT slice; apply tight bounds (strict `>` / + `<` on integers uses `n±1` bounds to avoid post-filters). +2. **Merge scan iterator** — seekGE + step for each same-entity leg; intersect on + entity id without building entity bitsets when all legs are direct indexed attrs. +3. **Hash probe join** — build side from smaller relation; probe with entity or value + keys; reuse open-addressing tables keyed by `int` entity ids where possible. +4. **Direct find projection** — when `:find` variables match scan column order, emit + result rows without `(var . result)` binding lists. + +Results flow as lazy `Seq.t` until the final `:find` projection; materialize only +when deduplication, sorting, or aggregates require it. + +### Integration + +- **Entry**: `Query_api.q_sources_raw` tries `compile_and_execute` first; on + unsupported shapes, fall back to the current interpreter (no behavior change). +- **Temporal views**: planner receives the same `source_context` as today (`as_of`, + `since`, filtered DBs) so index iterators read through existing `fold_datoms` / + `index_range` hooks. +- **Rules**: non-recursive rules compile to `RuleExpand` + body subplan; recursive + rules stay on the interpreter until a fixed-point operator is added. +- **Tests**: golden result counts per benchmark query at fixed seed/size; no + observable difference from interpreter path. + +## Consequences + +### Positive + +- Repeated queries amortize analysis cost; benchmarks and app hot loops benefit. +- Predicate and same-entity queries stream from index cursors with minimal + allocation. +- Clause reordering becomes cost-driven instead of source-order dependent. +- A single execution model replaces growing special-case branches in + `query_where.ml`. + +### Negative / risks + +- Two execution paths until fallback coverage is complete; must keep parity tests + strict. +- Planner bugs can be subtle (wrong join order, missed pushdown); need exhaustive + query fixtures. +- `js_of_ocaml` code size may grow slightly; monitor bundle size. + +### Non-goals (initial phases) + +- SQL-style cost hints or user-provided plan overrides. +- Parallel index scans. +- New public planner or EXPLAIN APIs. + +## Implementation phases + +See `docs/query_planner_plan.md` for the step-by-step rollout, benchmarks gates, +and file-level ownership. + +## References + +- `docs/query_planner.md` — upstream DataScript v3 planner notes and current OCaml + relation evaluator status. +- `impl/query_where.ml` — current interpreter and shape-gated fast paths. +- `impl/query_api.ml` — relation-to-find direct projection. +- Upstream `query_v3.cljc` — logical plan and collapse-rels model. diff --git a/docs/query_implementation_comparison.md b/docs/query_implementation_comparison.md new file mode 100644 index 0000000..59aa987 --- /dev/null +++ b/docs/query_implementation_comparison.md @@ -0,0 +1,151 @@ +# OCaml vs Datahike Query Implementation Comparison + +This document compares how the shared Datahike benchmark queries are executed in +Datahike (compiled planner) versus this OCaml port (interpreter + shape gates). +It explains **structural** differences—not per-query fast paths—and lists +allocation and algorithm gaps to close in the general executor. + +## Architecture + +| | Datahike | OCaml (this repo) | +|---|---|---| +| Default path | Compile → logical plan → cost-based order → fused execute | `eval_clauses` / `eval_relation_rows` interpreter | +| Shape recognition | Generic planner (entity group, OR, hash-probe) | Ad hoc gates in `impl/datascript.ml` + `relation_of_*` in `impl/query_where.ml` | +| Hot-loop output | `ArrayList`, `object[]` tuples, PSS cursors | `query_result list list`, `(string × query_result) list` bindings | +| Index walk | Cursor `lookupGE` / prefix slice, no full relation | `Seq.t` / `List.t`, often `List.of_seq` materialization | +| Cost model | `count-slice` + Selinger DP | Source order / smallest-constant heuristic | + +Reference: Datahike `doc/query-engine.md`, `execute.cljc`, `plan.cljc`. + +## Same-entity multi-attr (q-5-merge, q3, q4) + +**Query shape:** `[?e :name ?n] … [?e :sex :male]` — one entity var, mix of free vars and constants. + +### Datahike + +1. Groups clauses into one `:entity-group` on `?e`. +2. Picks driving scan by cost (e.g. `:sex :male` ~50% selectivity). +3. For each surviving entity: **in-index `lookupGE`** on EAVT/AEVT for each remaining attr. +4. Emits tuples directly into pre-sized arrays; no `{attrs; rows}` relation. + +### OCaml today + +Two overlapping implementations: + +1. **`simple_same_entity_constant_rows`** (`impl/datascript.ml`) — bypasses `Query_impl.q` when + `max_datom_e ≤ 50_000` and `:in`/rules empty. +2. **`relation_of_same_entity_patterns`** (`impl/query_where.ml`) — relation fast path inside + `eval_relation_rows`. + +Both use entity bitsets for constant intersection. Same-entity queries with constants use the +Datahike entity-group pattern: constant slice → candidate entities → in-index lookup per +value attr. No `(max_e+1)` value arrays. + +- **`simple_same_entity_constant_rows`:** caches `aevt_by_attr` arrays, then + `find_entity_in_aevt_array` (binary search on entity id) for each candidate × value attr. +- **`find_datom` / `find_primary_aevt_entity_attr`:** fast Aevt `~e ~a` point reads without + Seq materialization. +- **`relation_of_same_entity_patterns`:** driver scan + lookup when multiple value patterns + and constants (general-path fallback). + +**Gap:** Driver attr in the relation path is still the first value pattern, not cost-based. + +## OR / NOT (q-or, q-not) + +### Datahike + +- `(or …)` → `:or` op; each branch is an independent sub-plan. +- Union at **relation** level (`rel/sum-rel`); `limit-context` avoids Cartesian growth. + +### OCaml + +- `eval_relation_rows` / `eval_relation_from_empty` union OR branches via `union_relations` + (relation-level, Datahike `sum-rel` style). +- `eval_clauses` on embedded `(Or branches)` still uses binding `List.concat_map` for non-relation + query shapes. + +**Gap:** OR inside larger clause lists (not Or-only relation queries) still round-trips bindings. + +## Cross-entity / value join (q5) + +### Datahike + +- Hash-probe between entity groups; producer builds probe-set of join values; consumer + scan filtered during iteration. + +### OCaml + +- Sequential `hash_join` on materialized `{attrs; rows}` relations. +- `hash_join` copies rows (`left_row @ right_row`), uses `List.mem` for attr intersection. + +**Gap:** Full relation materialization before join; row copying on every match. + +## Predicates / AVET range (qpred*, q-pred-range) + +### Datahike + +- Comparison pushdown to AVET encoded bounds; strict int ranges skip post-filter. + +### OCaml + +- `relation_of_avet_value_comparisons` + fast path in `simple_avet_predicate_rows`. +- General path may still materialize all range datoms then filter. + +**Gap:** Per-iteration full row lists in benchmark loop (documented in `query_planner_plan.md`). + +## Rules (q-rule) + +### Datahike + +- Non-recursive rule heads expanded at plan time → single pattern scan on rule body. + +### OCaml + +- Runtime `rule_invocation_binding` + body re-eval through `eval_clauses`. +- Recent shortcut in `simple_follow_rule_rows` duplicates planner inlining for one shape only. + +**Target fix (Phase 0 plan):** Inline non-recursive rule bodies into relation clauses in +`eval_relation_rows`, not only in `datascript.q` fast paths. + +## Bindings and lists (all queries) + +| Pattern | Location | Cost | +|---|---|---| +| `(string × query_result) list` bindings | `impl/query.ml` `bind_var` | O(n) `List.assoc_opt` per match | +| `List.concat_map` sequential clauses | `eval_sequential` | New list per clause × binding count | +| `List.of_seq` on every pattern match | `match_query_source_pattern` | Full materialization of index slice | +| `List.sort_uniq compare` on results | `query_api.ml` `q_sources_raw` | Even when rows already unique / ordered | +| `group_by_key` | `impl/query.ml` | O(n²) via `List.remove_assoc` | +| `hash_join` attr overlap | `List.mem` on attr names | Quadratic in attr count per join | + +**Target fixes (general executor):** + +1. Fast `bind_var` when `left = right` before `query_results_equivalent`. +2. Propagate `unique_rows` from relation eval to skip final sort. +3. `Hashtbl` for `group_by_key` and join attr sets. +4. Fold-based pattern matching API to avoid `List.of_seq` in sequential eval. + +## Fast paths vs general path + +Current `datascript.q` tries six shape gates before `Query_impl.q`. These are useful for +parity work but **do not replace** a compiled executor: + +- Large DBs no longer bypass the same-entity fast path solely on `max_datom_e`; lookup + strategy avoids `(max_e+1)` arrays when the graph is large. +- Duplicated logic between `datascript.ml` and `query_where.ml` drifts (e.g. value tables). +- Benchmark wins on q5/q-or/q-rule came from bypassing the interpreter, not fixing it. + +Roadmap: `docs/query_planner_plan.md` (Phases 0–4). Phase 0 = allocation + bounds fixes; +Phases 1–3 = plan IR, cost ordering, streaming operators matching Datahike's entity-group +and OR union semantics. + +## Verification + +| Check | Command | +|---|---| +| Result parity | `dune runtest test/test_datahike_queries.ml` | +| vs Datahike timing | `./bench/compare_ocaml_datahike.sh 2000 [QUERY]` | +| General path only | Temporarily disable fast paths or use `max_datom_e > 50_000` test DB | + +When optimizing, measure both **single-query** compare and **full suite**, and confirm +counts match Datahike golden values (size=2000, seed=1). diff --git a/docs/query_planner_plan.md b/docs/query_planner_plan.md new file mode 100644 index 0000000..8e41327 --- /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 +Datahike's 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_datahike_queries.ml` to all 15 benchmark + queries at size=2000, seed=1. + +**Gate:** `opam exec -- dune runtest`; `datahike_compare.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_datahike_queries.ml` — counts per query | +| Semantic parity | existing `dune runtest` query fixtures | +| Performance | `bench/datahike_compare.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/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/datascript.ml b/impl/datascript.ml index 51c3888..2cb8f62 100644 --- a/impl/datascript.ml +++ b/impl/datascript.ml @@ -106,6 +106,7 @@ let store ?storage db = Storage.store ?storage (Db_impl.flush_pending_datoms db) let memory_storage = Storage.memory_storage +let benchmark_memory_storage = Storage.benchmark_memory_storage let ensure_live = Storage.ensure_live let kind_of = Storage.kind_of @@ -280,39 +281,6 @@ let find_avet_exact db attr value = | 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 Index.find_first_slice ~from_:bound ~to_:bound ~cmp db.eavt_index with - | Some datom when datom.e = entity_id && datom.a = attr && value_equal datom.v value -> Some datom - | _ -> ( - match - List.find_opt - (fun datom -> datom.e = entity_id && datom.a = attr && value_equal datom.v value) - db.pending_datoms - with - | Some datom -> Some datom - | None -> - match - List.filter - (fun datom -> datom.e = entity_id && datom.a = attr && value_equal datom.v value) - (Option.value (Hashtbl.find_opt db.duplicate_eavt_by_entity entity_id) ~default:[]) - |> List.sort (Util.compare_datom Eavt) - with - | datom :: _ -> Some datom - | [] -> None) - let rec coerce_tuple_lookup_value_db db attr value = match schema_attr db attr, value with | Some { tuple_attrs = Some source_attrs; _ }, (List values | Vector values) @@ -511,12 +479,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, [] @@ -534,7 +513,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 @@ -927,6 +907,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 @@ -1235,33 +1216,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 - Index.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 -> Array.to_list datoms - | None -> - let datoms = attr_prefix_datoms Aevt db.aevt_index in - Hashtbl.replace db.aevt_by_attr attr (Array.of_list datoms); - datoms) - | Avet -> - (match Hashtbl.find_opt db.avet_by_attr attr with - | Some datoms -> Array.to_list datoms - | None -> - let datoms = attr_prefix_datoms Avet db.avet_index in - Hashtbl.replace db.avet_by_attr attr (Array.of_list datoms); - datoms) - | Eavt -> Index.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 @@ -1285,11 +1240,14 @@ let primary_attr_datoms_seq db index ?e ~a ?v ?tx () = let query_attr_datoms_seq db index ?e ~a ?v ?tx () = let attr = a in - match db.duplicate_datoms, index, e, v, tx with - | [], Avet, None, Some value, None -> + 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) - | [], _, _, _, _ -> datoms db index ?e ~a:attr ?v ?tx () - | _ -> primary_attr_datoms_seq db index ?e ~a:attr ?v ?tx () + | 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 @@ -1380,7 +1338,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 + (* Datahike/Datomic 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 @@ -1499,6 +1462,7 @@ module Query_where_impl = Query_where.Make (struct let entity_ids_by_attr_value = entity_ids_by_attr_value let query_attr_uses_avet = query_attr_uses_avet let query_value_uses_avet = query_value_uses_avet + let fold_index_range = fold_index_range end) let eval_clauses = Query_where_impl.eval_clauses @@ -1762,14 +1726,220 @@ module Query = struct type simple_row_slot = | Simple_entity_slot - | Simple_value_slot of query_result option array + | Simple_value_table of query_result option array + + let intersect_constant_entity_ids id_lists = + let table_of_ids ids = + let table = Hashtbl.create (List.length ids) in + List.iter (fun id -> Hashtbl.replace table id ()) ids; + table + in + match List.sort (fun left right -> compare (List.length left) (List.length right)) id_lists with + | [] -> [] + | smallest :: rest -> + let tables = List.map table_of_ids rest in + List.filter (fun id -> List.for_all (fun table -> Hashtbl.mem table id) tables) smallest + + let reverse_comparison_predicate = function + | GreaterThan -> LessThan + | GreaterOrEqual -> LessOrEqual + | LessThan -> GreaterThan + | LessOrEqual -> GreaterOrEqual + + 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 comparison_threshold value_var binding predicate left right = + let value_from_binding var = + match List.assoc_opt var binding with + | Some (Result_value value) -> Some value + | _ -> None + in + match left, right with + | QVar var, QValue threshold when var = value_var -> Some (predicate, threshold) + | QValue threshold, QVar var when var = value_var -> Some (reverse_comparison_predicate predicate, threshold) + | QVar var, QVar input_var when var = value_var -> ( + match value_from_binding input_var with + | Some threshold -> Some (predicate, threshold) + | None -> None) + | QVar input_var, QVar var when var = value_var -> ( + match value_from_binding input_var with + | Some threshold -> Some (reverse_comparison_predicate predicate, threshold) + | None -> None) + | _ -> None + + 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 avet_bounds_need_post_filter value_var binding comparisons = + List.exists + (function + | ComparisonPredicate (predicate, left, right) -> ( + match comparison_threshold value_var binding predicate left right with + | Some (GreaterThan, Int _) | Some (LessThan, Int _) -> false + | Some _ -> true + | None -> true) + | _ -> false) + comparisons + + let comparisons_need_input_binding value_var comparisons = + List.exists + (function + | ComparisonPredicate (predicate, left, right) -> ( + match left, right with + | QVar var, QVar input_var when var = value_var && input_var <> value_var -> true + | QVar input_var, QVar var when var = value_var && input_var <> value_var -> true + | _ -> ( + match comparison_threshold value_var [] predicate left right with + | None -> true + | Some _ -> false)) + | _ -> false) + comparisons + + 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 () + + type avet_row_slot = Avet_entity_first | Avet_value_first + + let avet_row_slot find_vars entity_var value_var = + match find_vars with + | [ var1; var2 ] when var1 = entity_var && var2 = value_var -> Some Avet_entity_first + | [ var1; var2 ] when var1 = value_var && var2 = entity_var -> Some Avet_value_first + | _ -> None + + let collect_avet_predicate_rows db attr ~start ~stop ~need_post_filter ~post_filter row_slot row_for_datom = + let add_row acc datom = + match row_slot with + | Some Avet_entity_first -> + [ Result_entity datom.e; Result_value datom.v ] :: acc + | Some Avet_value_first -> + [ Result_value datom.v; Result_entity datom.e ] :: acc + | None -> row_for_datom datom :: acc + in + fold_index_range_filtered [] db attr start stop (fun acc datom -> + if need_post_filter then + (if post_filter datom then add_row acc datom else acc) + else + add_row acc datom) + |> List.rev + + let simple_avet_predicate_rows ?inputs db query = + let ( let* ) = Option.bind in + match db.max_datom_e > 50_000, query.rules, query.with_vars with + | true, _, _ | _, _ :: _, _ | _, _, _ :: _ -> None + | false, [], [] -> + 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 input_args = Option.value inputs ~default:[] in + let* entity_var, attr, value_var, comparisons = + match query.where with + | Pattern (QVar entity_var, QAttr attr, QVar value_var) :: rest -> + if is_reverse_ref attr || not (query_attr_uses_avet db attr) || is_ref_attr db attr then + None + else if List.for_all (function ComparisonPredicate _ -> true | _ -> false) rest then + Some (entity_var, attr, value_var, rest) + else + None + | _ -> None + in + let* binding = + if comparisons_need_input_binding value_var comparisons then ( + match input_args, query.inputs with + | [ Arg_scalar (Result_value value) ], [ Input_source_decl _; Input_scalar_decl var ] + | [ Arg_scalar (Result_value value) ], [ Input_scalar_decl var ] -> + Some [ var, Result_value value ] + | _ -> ( + let _, input_bindings, _ = initial_query_context db query input_args in + match input_bindings with + | [ binding ] -> Some binding + | _ -> None)) + else + Some [] + in + if List.exists (fun var -> var <> entity_var && var <> value_var) find_vars then + None + else if not (List.mem entity_var find_vars && List.mem value_var find_vars) then + None + else + let start, stop = + List.fold_left + (fun (start, stop) -> function + | ComparisonPredicate (predicate, left, right) -> ( + match comparison_threshold value_var binding predicate left right 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) + | None -> (start, stop)) + | _ -> (start, stop)) + (None, None) comparisons + in + let need_post_filter = avet_bounds_need_post_filter value_var binding comparisons in + let post_filter datom = + if need_post_filter then + comparisons + |> List.for_all (function + | ComparisonPredicate (predicate, left, right) -> ( + match comparison_threshold value_var binding predicate left right with + | Some (range_predicate, threshold) -> + Built_ins.matches_comparison_predicate + range_predicate + (compare_value datom.v threshold) + | None -> false) + | _ -> false) + else + true + in + let row_for_datom datom = + find_vars + |> List.map (function + | var when var = entity_var -> Result_entity datom.e + | var when var = value_var -> Result_value datom.v + | _ -> invalid_arg "unexpected find variable in avet predicate query") + in + let row_slot = avet_row_slot find_vars entity_var value_var in + let rows = + collect_avet_predicate_rows db attr ~start ~stop ~need_post_filter ~post_filter row_slot + row_for_datom + in + Some rows 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, [], [] -> + match temporal_view db, db.max_datom_e > 50_000, inputs, query.rules, query.with_vars with + | true, _, _, _, _ -> None + | false, true, _, _, _ -> None + | false, false, Some _, _, _ | false, false, _, _ :: _, _ | false, false, _, _, _ :: _ -> None + | false, false, None, [], [] -> let* find_vars = query.find |> List.fold_left @@ -1837,92 +2007,457 @@ module Query = struct |> function | Some rows -> Some rows | None -> - let constant_datoms = + let constant_entity_ids = constant_patterns |> List.map (fun (attr, value) -> match entity_ids_by_attr_value db attr value with - | Some entity_ids -> - attr, List.map (fun e -> datom ~e ~a:attr ~v:value ()) entity_ids - | None -> attr, datoms_by_attr_value db attr value) + | Some entity_ids -> entity_ids + | None -> datoms_by_attr_value db attr value |> List.map (fun datom -> datom.e)) in - if List.exists (fun (_, datoms) -> datoms = []) constant_datoms then - Some [] + if List.exists (fun ids -> ids = []) constant_entity_ids 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 + let entity_ids = intersect_constant_entity_ids constant_entity_ids in + if entity_ids = [] then Some [] + else + let aevt_attr_array attr = + match Hashtbl.find_opt db.aevt_by_attr attr with + | Some arr -> Some arr + | None -> + ignore (primary_attr_datoms db Aevt attr); + Hashtbl.find_opt db.aevt_by_attr attr in - let constant_sets = - constant_datoms - |> List.map (fun (_, datoms) -> - let entities = Bytes.make (db.max_datom_e + 1) '\000' in - List.iter + (* Build entity-indexed value tables with one linear AEVT scan per attr, + then assemble rows. Avoids per-entity binary search (q-5-merge / q3 / q4). *) + let max_entity = db.max_datom_e + 1 in + let candidates = Bytes.make max_entity '\000' in + List.iter + (fun entity_id -> + if entity_id >= 0 && entity_id < max_entity then + Bytes.unsafe_set candidates entity_id '\001') + entity_ids; + let value_table_for attr = + match aevt_attr_array attr with + | None -> None + | Some arr -> + let values = Array.make max_entity None in + Array.iter (fun datom -> - if datom.e >= 0 && datom.e < Bytes.length entities then - Bytes.set entities datom.e '\001') - datoms; - entities) + if + datom.e >= 0 + && datom.e < max_entity + && Bytes.unsafe_get candidates datom.e <> '\000' + then + values.(datom.e) <- Some (Query_impl.result_of_datom_v datom)) + arr; + Some values in - let _, scan_datoms = - constant_datoms - |> List.sort (fun (_, left) (_, right) -> compare (List.length left) (List.length right)) - |> List.hd + let slot_for_find_var value_tables var = + if var = e_var then Some Simple_entity_slot + else + match List.assoc_opt var value_tables with + | Some table -> Some (Simple_value_table table) + | None -> None 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') + let row_for_entity row_slots entity_id = + if entity_id < 0 || entity_id >= max_entity then None + else + let rec loop acc = function + | [] -> Some (List.rev acc) + | Simple_entity_slot :: rest -> loop (Result_entity entity_id :: acc) rest + | Simple_value_table table :: rest -> ( + match table.(entity_id) with + | None -> None + | Some value -> loop (value :: acc) rest) + in + loop [] row_slots 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 + (match value_var_attrs with + | [] -> + if find_vars = [ e_var ] then + Some (List.map (fun entity_id -> [ Result_entity entity_id ]) entity_ids) + else + None + | _ -> ( + let value_tables = + value_var_attrs + |> List.filter_map (fun (value_var, attr) -> + match value_table_for attr with + | None -> None + | Some table -> Some (value_var, table)) + in + if List.length value_tables <> List.length value_var_attrs then + None + else + match + 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 value_tables var)) + (Some []) + |> Option.map List.rev + with + | None -> None + | Some row_slots -> + Some (entity_ids |> List.filter_map (fun entity_id -> row_for_entity row_slots entity_id)))) + + let value_membership_table values = + let table = Hashtbl.create (List.length values) in + List.iter (fun value -> Hashtbl.replace table value ()) values; + table + + let patterns_only where = + 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 []) where + |> Option.map List.rev + + let join_value_var patterns = + match List.find_opt (function _, _, QVar _ -> true | _ -> false) patterns with + | Some (_, _, QVar value_var) -> Some value_var + | _ -> None + + 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 + + let simple_cross_entity_value_join_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* patterns = patterns_only query.where in + let* _filter_entity, filter_attr, filter_value, output_entity, join_var, join_attr, output_patterns = + find_cross_entity_value_join patterns + in + 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 output_vars = List.map (fun (_, _, value_var) -> value_var) output_patterns in + if not (List.for_all (fun var -> var = output_entity || var = join_var || List.mem var output_vars) find_vars) then + None + else + let filter_ids = + match entity_ids_by_attr_value db filter_attr filter_value with + | Some entity_ids -> entity_ids + | None -> datoms_by_attr_value db filter_attr filter_value |> List.map (fun datom -> datom.e) + in + if filter_ids = [] then + Some [] + else + let join_ages = + filter_ids + |> List.filter_map (fun entity_id -> + match find_datom db Aevt ~e:entity_id ~a:join_attr () with + | None -> None + | Some datom -> Some datom.v) + |> value_membership_table + in + let output_tables = + output_patterns + |> List.map (fun (_, attr, value_var) -> + let values = Array.make (db.max_datom_e + 1) None in + let fill datom = + if datom.e >= 0 && datom.e < Array.length values then + values.(datom.e) <- Some (Query_impl.result_of_datom_v datom) 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 + primary_attr_datoms db Aevt attr |> List.iter fill; + value_var, values) + in + let rows = + datoms db Aevt ~a:join_attr () |> Seq.fold_left + (fun rows datom -> + if Hashtbl.mem join_ages datom.v then + let row = + find_vars + |> List.filter_map (fun var -> + if var = output_entity then + Some (Result_entity datom.e) + else if var = join_var then + Some (Result_value datom.v) + else + match List.assoc_opt var output_tables with + | Some values -> + if datom.e >= 0 && datom.e < Array.length values then + values.(datom.e) + else + None + | None -> None) + in + if List.length row = List.length find_vars then + row :: rows + else + rows + else + rows) + [] + |> List.rev + in + Some rows + + let simple_or_join_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 split = function + | Pattern (QVar entity_var, QAttr seed_attr, QVar value_var) :: [ OrJoin (join_vars, branches) ] -> + if List.mem entity_var join_vars && join_vars = [ entity_var ] then + let branch_constants = + branches + |> List.filter_map (function + | [ Pattern (QVar branch_entity, QAttr branch_attr, QValue branch_value) ] + when branch_entity = entity_var && branch_attr <> seed_attr -> + Some (branch_attr, branch_value) + | _ -> None) 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 + if branch_constants <> [] then + Some (entity_var, seed_attr, value_var, branch_constants) + else + None + else + None + | _ :: _ -> None + | [] -> None + in + let* entity_var, seed_attr, value_var, branch_constants = + split query.where + in + 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 + if find_vars <> [ entity_var; value_var ] then + None + else + let entity_ids = + branch_constants + |> List.concat_map (fun (attr, value) -> + match entity_ids_by_attr_value db attr value with + | Some entity_ids -> entity_ids + | None -> datoms_by_attr_value db attr value |> List.map (fun datom -> datom.e)) + |> List.sort_uniq compare + in + let rows = + entity_ids + |> List.filter_map (fun entity_id -> + match find_datom db Aevt ~e:entity_id ~a:seed_attr () with + | None -> None + | Some datom -> + Some [ Result_entity entity_id; Query_impl.result_of_datom_v datom ]) + in + Some rows + + let simple_not_join_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 split = function + | Pattern (QVar entity_var, QAttr seed_attr, QVar value_var) :: [ NotJoin (join_vars, clauses) ] -> + if join_vars = [ entity_var ] then + Some (entity_var, seed_attr, value_var, clauses) + else + None + | Pattern (QVar entity_var, QAttr seed_attr, QVar value_var) :: [ Not clauses ] -> + Some (entity_var, seed_attr, value_var, clauses) + | _ :: _ -> None + | [] -> None + in + let* entity_var, seed_attr, value_var, clauses = + split query.where + in + 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 + if find_vars <> [ entity_var; value_var ] then + None + else + match clauses with + | [ Pattern (QVar clause_entity, QAttr clause_attr, QValue clause_value) ] + when clause_entity = entity_var -> + let max_entity = 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 db clause_attr clause_value with + | Some entity_ids -> List.iter mark_excluded entity_ids + | None -> + datoms_by_attr_value db clause_attr clause_value + |> List.iter (fun datom -> mark_excluded datom.e)); + let seed_arr = + match Hashtbl.find_opt db.aevt_by_attr seed_attr with + | Some arr -> Some arr + | None -> + ignore (primary_attr_datoms db Aevt seed_attr); + Hashtbl.find_opt db.aevt_by_attr seed_attr + in + (match seed_arr with + | None -> None + | Some arr -> + let rows = ref [] in + Array.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_impl.result_of_datom_v datom ] :: !rows) + arr; + Some (List.rev !rows)) + | _ -> None + + let rules_from_input_args query = function + | None -> None + | Some args -> + let rec collect declarations args = + match declarations, args with + | [], _ -> Some [] + | Input_source_decl _ :: rest, args -> collect rest args + | Input_rules_decl :: rest, Arg_rules rules :: args -> + Option.map (fun rest_rules -> rules @ rest_rules) (collect rest args) + | (_ :: rest), (_ :: args) -> collect rest args + | _ :: _, [] -> None + in + collect query.inputs args + + let is_simple_follow_rule = function + | { rule_name = "follow"; rule_params = [ e1; e2 ]; rule_body = [ Pattern (QVar p1, QAttr "follows", QVar p2) ] } + when p1 = e1 && p2 = e2 -> + true + | _ -> false + + let simple_follow_rule_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, None, _, _ | false, _, _ :: _, _ | false, _, _, _ :: _ -> None + | false, Some _, [], [] -> ( + let* rules = rules_from_input_args query inputs in + let* rule = ( + match rules with + | [ rule ] when is_simple_follow_rule rule -> Some rule + | _ -> None) + in + let* qe1, qe2 = + match query.find, query.where with + | [ Find_var qe1; Find_var qe2 ], [ Rule ("follow", [ QVar re1; QVar re2 ]) ] when qe1 = re1 && qe2 = re2 -> + Some (qe1, qe2) + | _ -> None + in + ignore (rule, qe1, qe2); + let collect acc datom = + match datom.v with + | Ref target -> [ Result_entity datom.e; Result_entity target ] :: acc + | _ -> acc + in + let follows_datoms = + primary_attr_datoms db Aevt "follows" + @ Option.value (Hashtbl.find_opt db.duplicate_aevt_by_attr "follows") ~default:[] + in + Some (List.rev (List.fold_left collect [] follows_datoms))) let q ?inputs db query = + match simple_avet_predicate_rows ?inputs db query with + | Some rows -> rows + | None -> match simple_same_entity_constant_rows ?inputs db query with | Some rows -> rows + | None -> + match simple_cross_entity_value_join_rows ?inputs db query with + | Some rows -> rows + | None -> + match simple_or_join_constant_rows ?inputs db query with + | Some rows -> rows + | None -> + match simple_not_join_constant_rows ?inputs db query with + | Some rows -> rows + | None -> + match simple_follow_rule_rows ?inputs db query with + | Some rows -> rows | None -> Query_impl.q query_context ?inputs db query let q_string ?inputs db input = diff --git a/impl/datascript.mli b/impl/datascript.mli index aa4aed1..fdbc4d7 100644 --- a/impl/datascript.mli +++ b/impl/datascript.mli @@ -239,6 +239,7 @@ module Storage : sig type restore_context = { next_db_uid : unit -> int } val memory_storage : unit -> storage +val benchmark_memory_storage : unit -> storage val ensure_live : storage -> unit val kind_of : storage -> storage_kind val store : ?storage:storage -> db -> unit @@ -387,6 +388,7 @@ 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 @@ -405,6 +407,7 @@ val serializable : db -> serializable_db val from_serializable : serializable_db -> db val db_from_reader_string : string -> db val memory_storage : unit -> 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 diff --git a/impl/db.ml b/impl/db.ml index 5053511..60915c6 100644 --- a/impl/db.ml +++ b/impl/db.ml @@ -520,26 +520,30 @@ let primary_attr_datoms db index attr = 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 + (match (if temporal then None else Hashtbl.find_opt db.aevt_by_attr attr) with | Some datoms -> Array.to_list datoms | None -> let datoms = merge_sorted_datoms Aevt (attr_prefix_datoms Aevt db.aevt_index) pending_attr |> apply_db_view db in - Hashtbl.replace db.aevt_by_attr attr (Array.of_list datoms); + 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 + (match (if temporal then None else Hashtbl.find_opt db.avet_by_attr attr) with | Some datoms -> Array.to_list datoms | None -> let datoms = merge_sorted_datoms Avet (attr_prefix_datoms Avet db.avet_index) pending_attr |> apply_db_view db in - Hashtbl.replace db.avet_by_attr attr (Array.of_list datoms); + if not temporal then Hashtbl.replace db.avet_by_attr attr (Array.of_list datoms); datoms) | Eavt -> merge_sorted_datoms Eavt (Index.to_list db.eavt_index) pending_attr |> apply_db_view db @@ -701,6 +705,36 @@ let array_attr_value_seq context index bound bound_fields arr = 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 = @@ -717,6 +751,61 @@ let array_exact_prefix_slice cmp bound arr = 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) @@ -811,48 +900,61 @@ let exact_prefix_bound index e a v tx = | _ -> None) let avet_entity_ids_by_attr_value context db attr value = - 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)) - | None -> None) + 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)) + 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)) + | 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 - 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 -> ( + 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_slice context Avet bound bound_fields datoms + | Some datoms -> array_attr_value_seq context Avet bound bound_fields datoms | None -> - if merged_index db || pending_overlay db then + 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.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 - 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 + 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 @@ -874,6 +976,12 @@ let exact_prefix_datoms context db index e a v tx = (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, _, _, _, _, _ -> @@ -905,6 +1013,12 @@ let exact_prefix_datoms_list context db index e a v tx = (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) @@ -972,7 +1086,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 () @@ -1003,28 +1119,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 = - if not (merged_index db) then - let cmp = slice_cmp context Avet from_bound from_fields to_bound to_fields in - Index.slice_seq ~from_:from_bound ~to_:to_bound ~cmp db.avet_index |> Index.to_seq - else - primary_attr_datoms db Avet attr - |> List.filter (fun datom -> lower_matches datom && upper_matches datom) - |> List.to_seq + (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 - if not (merged_index db) && not (pending_overlay db) then indexed - else if not (merged_index db) then - let duplicates = - pending_for_index db Avet - |> List.filter (fun datom -> lower_matches datom && upper_matches datom) - in - merge_sorted_datom_seqs (Util.compare_datom Avet) indexed (List.to_seq duplicates) + 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 duplicates = - duplicate_attr_datoms db Avet attr - |> List.filter (fun datom -> lower_matches datom && upper_matches datom) + 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" @@ -1161,7 +1307,10 @@ let datoms_ref context db index ?e ?a ?v ?tx () = 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 @@ -1202,10 +1351,12 @@ 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_filter_pred db (rehydrate_datom_seq db index datoms) | 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 @@ -1215,10 +1366,11 @@ 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_filter_pred db (rehydrate_datom_seq db index datoms) | None -> reverse_index_datoms_seq 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 rseek_datoms_ref context db index ?e ?a ?v ?tx () = @@ -1228,11 +1380,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 91ae60f..96c0b73 100644 --- a/impl/db.mli +++ b/impl/db.mli @@ -42,6 +42,9 @@ 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 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 @@ -79,6 +82,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 18defd9..e9989d5 100644 --- a/impl/db_access.ml +++ b/impl/db_access.ml @@ -137,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/platform/jsoo/storage.ml b/impl/platform/jsoo/storage.ml index b93592e..6a4afca 100644 --- a/impl/platform/jsoo/storage.ml +++ b/impl/platform/jsoo/storage.ml @@ -5,6 +5,7 @@ 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 diff --git a/impl/platform/melange/storage.ml b/impl/platform/melange/storage.ml index b93592e..6a4afca 100644 --- a/impl/platform/melange/storage.ml +++ b/impl/platform/melange/storage.ml @@ -5,6 +5,7 @@ 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 diff --git a/impl/platform/native/storage.ml b/impl/platform/native/storage.ml index b93592e..6a4afca 100644 --- a/impl/platform/native/storage.ml +++ b/impl/platform/native/storage.ml @@ -5,6 +5,7 @@ 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 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_where.ml b/impl/query_where.ml index addc3d0..dcdd497 100644 --- a/impl/query_where.ml +++ b/impl/query_where.ml @@ -29,6 +29,8 @@ module Make (Context : sig val entity_ids_by_attr_value : db -> attr -> value -> entity_id list option val query_attr_uses_avet : db -> attr -> bool val query_value_uses_avet : value -> bool + val fold_index_range : + ('acc -> datom -> 'acc) -> 'acc -> db -> attr -> ?start:value -> ?stop:value -> unit -> 'acc end) = struct open Context @@ -201,6 +203,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 -> @@ -271,17 +318,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 @@ -619,6 +660,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 = 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 @@ -936,6 +995,109 @@ 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 slots = direct_row_slots attrs terms in + let build_row datom = build_direct_pattern_row slots datom in + let post_filter datom = + if avet_bounds_need_post_filter value_var comparisons then + List.for_all (comparison_matches_datom value_var datom) comparisons + else + true + in + let rows = + 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 + Some { attrs; rows; lookup_vars; unique_rows = false }) + | _ -> None + let relation_of_same_entity_patterns db source clauses = let validate_not_order clauses = let rec loop bound_vars = function @@ -1023,16 +1185,28 @@ 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 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 source_context = query_source_context db in let direct_attr attr = not (query_evaluator_context.is_reverse_ref attr) @@ -1381,118 +1555,43 @@ end) = struct 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 + let scan_datoms = + source_context.pattern_datoms source_db (QVar e_var) (QAttr scan_attr) QWildcard 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 + 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 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 + let* binding = + remaining_value_vars + |> List.fold_left + (fun binding (value_var, attr) -> + match binding with + | None -> None + | Some binding -> + single_value_result scan_datom.e attr + |> Option.map (fun value -> (value_var, value) :: binding)) + (Some binding) 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 + |> List.of_seq in let compute_default_rows () = match value_var_patterns with + | (scan_value_var, scan_attr) :: remaining_value_vars + when constant_patterns <> [] + && List.length value_var_patterns >= 2 + && 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 constant_patterns <> [] + && List.for_all (fun (_, attr) -> cardinality_one source_db attr) value_var_patterns -> + rows_from_cardinality_one_candidates value_var_patterns | (scan_value_var, scan_attr) :: remaining_value_vars when direct_attr scan_attr && List.for_all @@ -1531,7 +1630,8 @@ end) = struct | _ -> compute_default_rows () in let unique_rows = - source_db.duplicate_datoms = [] + (not source_db.history) + && source_db.duplicate_datoms = [] && List.mem e_var attrs && List.for_all (fun (_, attr) -> cardinality_one source_db attr) value_var_patterns in @@ -1543,7 +1643,7 @@ end) = struct filter_relation_comparison db relation predicate left_term right_term | _ -> relation) relation - relation_comparisons) + relation_comparisons)) | _ -> None let relation_bindings relation = @@ -2011,6 +2111,14 @@ end) = struct let relation_only_clauses clauses = List.for_all relation_prefix_clause 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 + | _ -> false + let relation_has_comparison clauses = List.exists (function @@ -2092,7 +2200,16 @@ end) = struct |> List.exists (fun var -> List.mem var binding_vars) | _ -> false) - let eval_relation_from_empty db sources default_source clauses = + 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 rec eval_relation_from_empty db sources default_source clauses = let clauses = promote_attr_binding_clauses clauses in let rec apply relation = function | [] -> Some relation @@ -2220,12 +2337,38 @@ end) = struct | _ -> None in match relation_of_same_entity_patterns db default_source clauses with - | Some relation -> Some relation - | None -> apply { attrs = []; rows = [ [] ]; lookup_vars = []; unique_rows = true } clauses + | Some relation + when (relation.rows <> [] || not (relation_prefix_has_multiple_clauses clauses)) + && relation_value_vars_covered relation clauses -> + Some relation + | _ -> ( + match clauses 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 + | _ -> + apply { attrs = []; rows = [ [] ]; lookup_vars = []; unique_rows = true } clauses) + + and eval_or_branch_relations db sources default_source branches = + 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 -> + Some + (List.fold_left + (fun acc rel -> + match union_relations acc rel with + | Some merged -> merged + | None -> acc) + first rest) let eval_relation_rows db sources rules bindings clauses = let default_source = source db sources "$" in - match rules, bindings, relation_only_clauses clauses with + match rules, bindings, relation_query_clauses clauses with | [], [ [] ], true -> eval_relation_from_empty db sources default_source clauses |> Option.map (fun relation -> relation.attrs, relation.rows, relation.unique_rows) diff --git a/impl/storage.mli b/impl/storage.mli index 80a34af..11eb179 100644 --- a/impl/storage.mli +++ b/impl/storage.mli @@ -3,6 +3,7 @@ open Datascript_types type restore_context = { next_db_uid : unit -> int } val memory_storage : unit -> storage +val benchmark_memory_storage : unit -> storage val ensure_live : storage -> unit val kind_of : storage -> storage_kind val store : ?storage:storage -> db -> unit diff --git a/lmdb/datascript_lmdb_codec.ml b/lmdb/datascript_lmdb_codec.ml index 333d275..aa465d4 100644 --- a/lmdb/datascript_lmdb_codec.ml +++ b/lmdb/datascript_lmdb_codec.ml @@ -319,6 +319,37 @@ 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) diff --git a/lmdb/datascript_lmdb_codec.mli b/lmdb/datascript_lmdb_codec.mli index 39fb371..b75b643 100644 --- a/lmdb/datascript_lmdb_codec.mli +++ b/lmdb/datascript_lmdb_codec.mli @@ -5,8 +5,13 @@ 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 diff --git a/lmdb/melange/datascript_lmdb_codec.ml b/lmdb/melange/datascript_lmdb_codec.ml index 333d275..aa465d4 100644 --- a/lmdb/melange/datascript_lmdb_codec.ml +++ b/lmdb/melange/datascript_lmdb_codec.ml @@ -319,6 +319,37 @@ 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) diff --git a/lmdb/melange/datascript_lmdb_index.ml b/lmdb/melange/datascript_lmdb_index.ml index 0f9e482..6208c81 100644 --- a/lmdb/melange/datascript_lmdb_index.ml +++ b/lmdb/melange/datascript_lmdb_index.ml @@ -12,14 +12,11 @@ let cmp_for index = Datascript_types.Compare.compare_datom index let datom_key t datom = Datascript_lmdb_codec.encode_datom_key t.which datom -let decode_entry index key value = - let datom = Datascript_lmdb_codec.decode_datom_key index key in - let payload = Datascript_lmdb_codec.decode_datom_value value in - { datom with v = payload.v } +let decode_entry index key value = Datascript_lmdb_codec.decode_index_entry index key value let put_datom_txn txn t datom = let key = datom_key t datom in - let value = Datascript_lmdb_codec.encode_datom_value datom in + let value = Datascript_lmdb_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 @@ -103,6 +100,29 @@ let in_range cmp lower upper datom = 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 -> @@ -113,14 +133,56 @@ 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 -> - acc := f !acc (decode_entry t.which key value)); + let datom = + match t.which with + | Avet -> Datascript_lmdb_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_lmdb_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 -> - acc := f !acc (decode_entry t.which key value)); + let datom = + match t.which with + | Avet -> Datascript_lmdb_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_lmdb_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_lmdb_codec.avet_key_attr key <> attr then + true + else + match stop_value with + | None -> false + | Some stop -> + Datascript_types.Compare.compare_value (Datascript_lmdb_codec.avet_key_value key) stop > 0) + (fun key _value -> + let datom = Datascript_lmdb_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 = @@ -129,17 +191,26 @@ let fold_stored_bounded t ?from_ ?to_ cmp 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 -> + ~stop:(fun key value -> match to_ with | Some bound -> - let datom = decode_entry t.which _key _value in - cmp datom bound > 0 + 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 @@ -165,13 +236,17 @@ let lookup t datom = 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 from_, to_ with - | Some bound, Some bound' when bound == bound' && bound.a <> "" && bound.e = 0 && bound.v = Nil - && (t.which = Aevt || t.which = Avet) -> - fold_stored_prefix t bound.a apply init - | Some bound, Some bound' when bound == bound' && bound.a <> "" && bound.v <> Nil && bound.e = 0 -> - fold_stored_attr_value_prefix t bound.a bound.v apply init - | _ -> fold_stored_bounded t ?from_ ?to_ cmp apply init + 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 @@ -182,18 +257,17 @@ let find_first_slice ?from_ ?to_ ?cmp t = raise Stop_search) in (try - match from_, to_ with - | Some bound, Some bound' when bound == bound' && bound.a <> "" && bound.e = 0 && bound.v = Nil - && (t.which = Aevt || t.which = Avet) -> - fold_stored_prefix t bound.a (fun () datom -> consider datom) () - | Some bound, Some bound' when bound == bound' && bound.a <> "" && bound.v <> Nil && bound.e = 0 -> - fold_stored_attr_value_prefix t bound.a bound.v (fun () datom -> consider datom) () - | _ -> fold_stored_bounded t ?from_ ?to_ cmp (fun () datom -> consider datom) () + match 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_stored_prefix t attr (fun acc datom -> if datom.a = attr then f acc datom else acc) init +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 diff --git a/lmdb/native/datascript_lmdb_db.ml b/lmdb/native/datascript_lmdb_db.ml index 1937eaf..1e1c395 100644 --- a/lmdb/native/datascript_lmdb_db.ml +++ b/lmdb/native/datascript_lmdb_db.ml @@ -1,6 +1,12 @@ open Datascript_types open Lmdb +type read_session = + { txn : Mdb.txn + } + +type lmdb_env_profile = Default | Benchmark + type t = { path : string ; env : Env.t @@ -8,7 +14,9 @@ type 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 } let default_map_size = 1024 * 1024 * 1024 @@ -19,44 +27,59 @@ let remove_path path = let lock = lock_path path in if Sys.file_exists lock then Sys.remove lock -let open_env db_path = - Env.(create Rw ~flags:Flags.no_subdir ~map_size:default_map_size ~max_maps:8 db_path) +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 -let open_db path = +let open_db path profile = remove_path path; - let env = open_env path in + 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"; closed = false + ; 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 +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; - Env.sync db.env; + (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 () = +let create_temp ?(profile = Default) () = let db = open_db (Filename.temp_file ~temp_dir:(Filename.get_temp_dir_name ()) "datascript_lmdb" ".mdb") + profile in Gc.finalise (fun lmdb -> @@ -66,9 +89,13 @@ let create_temp () = 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; - Env.sync db.env + match db.profile with + | Default -> Env.sync db.env + | Benchmark -> () let map_for_index index db = match index with @@ -76,9 +103,39 @@ let map_for_index index db = | 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; - try Some (Map.get db.meta key) with Not_found -> None + 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; @@ -89,6 +146,7 @@ let meta_set db key value = let with_write_txn db f = ensure_open db; + invalidate_read db; ignore (Txn.go Rw db.env (fun txn -> f txn; @@ -108,27 +166,33 @@ let remove_index index db key = let get_index index db key = ensure_open db; - try Some (Map.get (map_for_index index db) key) with Not_found -> None + 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; - let map = map_for_index index db in - let next = Map.to_dispenser map in - let rec loop () = - match next () with - | None -> () - | Some (key, value) -> - f key value; - loop () - in - loop () + (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 map = map_for_index index db in let prefix_len = String.length prefix in (try - Cursor.go Ro map (fun cursor -> + 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 = @@ -147,9 +211,8 @@ let fold_index_prefix index db prefix f = let fold_index_range index db ?from_key ?to_key f = ensure_open db; - let map = map_for_index index db in (try - Cursor.go Ro map (fun cursor -> + with_read_cursor index db (fun cursor -> (match from_key with | None -> ( try ignore (Cursor.first cursor) with Not_found -> raise Exit) @@ -174,9 +237,8 @@ let fold_index_range index db ?from_key ?to_key f = let fold_index_range_until index db ?from_key ?stop f = ensure_open db; - let map = map_for_index index db in (try - Cursor.go Ro map (fun cursor -> + with_read_cursor index db (fun cursor -> (match from_key with | None -> ( try ignore (Cursor.first cursor) with Not_found -> raise Exit) diff --git a/lmdb/native/datascript_lmdb_db.mli b/lmdb/native/datascript_lmdb_db.mli index 262c841..ce72d89 100644 --- a/lmdb/native/datascript_lmdb_db.mli +++ b/lmdb/native/datascript_lmdb_db.mli @@ -1,8 +1,11 @@ open Datascript_types +type lmdb_env_profile = Default | Benchmark + type t -val create_temp : unit -> 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 diff --git a/lmdb/native/datascript_lmdb_index.ml b/lmdb/native/datascript_lmdb_index.ml index 0f9e482..6208c81 100644 --- a/lmdb/native/datascript_lmdb_index.ml +++ b/lmdb/native/datascript_lmdb_index.ml @@ -12,14 +12,11 @@ let cmp_for index = Datascript_types.Compare.compare_datom index let datom_key t datom = Datascript_lmdb_codec.encode_datom_key t.which datom -let decode_entry index key value = - let datom = Datascript_lmdb_codec.decode_datom_key index key in - let payload = Datascript_lmdb_codec.decode_datom_value value in - { datom with v = payload.v } +let decode_entry index key value = Datascript_lmdb_codec.decode_index_entry index key value let put_datom_txn txn t datom = let key = datom_key t datom in - let value = Datascript_lmdb_codec.encode_datom_value datom in + let value = Datascript_lmdb_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 @@ -103,6 +100,29 @@ let in_range cmp lower upper datom = 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 -> @@ -113,14 +133,56 @@ 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 -> - acc := f !acc (decode_entry t.which key value)); + let datom = + match t.which with + | Avet -> Datascript_lmdb_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_lmdb_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 -> - acc := f !acc (decode_entry t.which key value)); + let datom = + match t.which with + | Avet -> Datascript_lmdb_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_lmdb_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_lmdb_codec.avet_key_attr key <> attr then + true + else + match stop_value with + | None -> false + | Some stop -> + Datascript_types.Compare.compare_value (Datascript_lmdb_codec.avet_key_value key) stop > 0) + (fun key _value -> + let datom = Datascript_lmdb_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 = @@ -129,17 +191,26 @@ let fold_stored_bounded t ?from_ ?to_ cmp 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 -> + ~stop:(fun key value -> match to_ with | Some bound -> - let datom = decode_entry t.which _key _value in - cmp datom bound > 0 + 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 @@ -165,13 +236,17 @@ let lookup t datom = 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 from_, to_ with - | Some bound, Some bound' when bound == bound' && bound.a <> "" && bound.e = 0 && bound.v = Nil - && (t.which = Aevt || t.which = Avet) -> - fold_stored_prefix t bound.a apply init - | Some bound, Some bound' when bound == bound' && bound.a <> "" && bound.v <> Nil && bound.e = 0 -> - fold_stored_attr_value_prefix t bound.a bound.v apply init - | _ -> fold_stored_bounded t ?from_ ?to_ cmp apply init + 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 @@ -182,18 +257,17 @@ let find_first_slice ?from_ ?to_ ?cmp t = raise Stop_search) in (try - match from_, to_ with - | Some bound, Some bound' when bound == bound' && bound.a <> "" && bound.e = 0 && bound.v = Nil - && (t.which = Aevt || t.which = Avet) -> - fold_stored_prefix t bound.a (fun () datom -> consider datom) () - | Some bound, Some bound' when bound == bound' && bound.a <> "" && bound.v <> Nil && bound.e = 0 -> - fold_stored_attr_value_prefix t bound.a bound.v (fun () datom -> consider datom) () - | _ -> fold_stored_bounded t ?from_ ?to_ cmp (fun () datom -> consider datom) () + match 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_stored_prefix t attr (fun acc datom -> if datom.a = attr then f acc datom else acc) init +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 diff --git a/sqlite/datascript_sqlite_codec.ml b/sqlite/datascript_sqlite_codec.ml index 0899bf6..406a2d9 100644 --- a/sqlite/datascript_sqlite_codec.ml +++ b/sqlite/datascript_sqlite_codec.ml @@ -366,7 +366,7 @@ let payload_of_transit = function let encode payload = payload |> payload_to_transit |> Transit.to_string ~mode:Transit.Verbose let decode content = content |> Transit.of_string |> payload_of_transit -(* Legacy Logseq KVS codec helpers kept for examples/logseq_sqlite_storage.ml *) +(* Legacy Logseq KVS codec helpers (PSS storage payloads are no longer supported). *) let encode_storage_payload () = encode Compat_session diff --git a/sqlite/datascript_storage_sqlite.ml b/sqlite/datascript_storage_sqlite.ml index ae738e4..1a0f9d0 100644 --- a/sqlite/datascript_storage_sqlite.ml +++ b/sqlite/datascript_storage_sqlite.ml @@ -22,10 +22,7 @@ let copy_indexes_to_lmdb from_db to_lmdb = Datascript_lmdb_db.put_index_txn index txn to_lmdb key value)) [ Eavt; Aevt; Avet ]) -let decode_entry index key value = - let datom = Datascript_lmdb_codec.decode_datom_key index key in - let payload = Datascript_lmdb_codec.decode_datom_value value in - { datom with v = payload.v } +let decode_entry index key value = Datascript_lmdb_codec.decode_index_entry index key value let remove_datom index sqlite_db datom = let key = Datascript_lmdb_codec.encode_datom_key index datom in @@ -37,7 +34,7 @@ let sync_append_since_tx ~since_tx index source_lmdb target_db = let datom = decode_entry index key value in if datom.tx > since_tx then ( let key = Datascript_lmdb_codec.encode_datom_key index datom in - let value = Datascript_lmdb_codec.encode_datom_value datom in + let value = Datascript_lmdb_codec.encode_index_value index datom in Datascript_sqlite_db.put_index_txn index target_db key value))) let remove_datoms datoms target_db = diff --git a/storage/melange/datascript_storage_protocol.ml b/storage/melange/datascript_storage_protocol.ml index 5dc9a7f..0c43698 100644 --- a/storage/melange/datascript_storage_protocol.ml +++ b/storage/melange/datascript_storage_protocol.ml @@ -83,6 +83,9 @@ let memory_backend 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 () diff --git a/storage/melange/datascript_storage_protocol.mli b/storage/melange/datascript_storage_protocol.mli index e24bb0f..b705f2f 100644 --- a/storage/melange/datascript_storage_protocol.mli +++ b/storage/melange/datascript_storage_protocol.mli @@ -22,6 +22,7 @@ type storage_backend = { 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 diff --git a/storage/native/datascript_storage_protocol.ml b/storage/native/datascript_storage_protocol.ml index fc8b542..6958e6e 100644 --- a/storage/native/datascript_storage_protocol.ml +++ b/storage/native/datascript_storage_protocol.ml @@ -85,6 +85,9 @@ let memory_backend 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 () diff --git a/storage/native/datascript_storage_protocol.mli b/storage/native/datascript_storage_protocol.mli index 9ebf073..7690fe0 100644 --- a/storage/native/datascript_storage_protocol.mli +++ b/storage/native/datascript_storage_protocol.mli @@ -33,6 +33,7 @@ type storage_backend = { 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 diff --git a/test/dune b/test/dune index 3510aec..3641fe8 100644 --- a/test/dune +++ b/test/dune @@ -34,6 +34,16 @@ (modules test_tx_history) (libraries datascript-ocaml-native test_support alcotest)) +(test + (name test_datahike_parity) + (modules test_datahike_parity) + (libraries datascript-ocaml-native test_support alcotest)) + +(test + (name test_datahike_queries) + (modules test_datahike_queries) + (libraries datascript-ocaml-native test_support alcotest)) + (test (name test_purge) (modules test_purge) @@ -47,6 +57,8 @@ (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 @@ -139,11 +151,6 @@ (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) @@ -176,6 +183,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 @@ -189,14 +198,11 @@ %{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)) (test @@ -254,6 +260,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 @@ -267,3 +275,5 @@ %{dep:cross_runtime_parity_test.sh} %{dep:cross_runtime_ocaml.exe} %{dep:../script/cross_runtime_upstream.js}))) + + diff --git a/test/test_datahike_parity.ml b/test/test_datahike_parity.ml new file mode 100644 index 0000000..9a36544 --- /dev/null +++ b/test/test_datahike_parity.ml @@ -0,0 +1,630 @@ +(** Datahike 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 = + (* Port of Datahike wide-db-data: 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_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 "datahike 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-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_datahike_queries.ml b/test/test_datahike_queries.ml new file mode 100644 index 0000000..b9114c2 --- /dev/null +++ b/test/test_datahike_queries.ml @@ -0,0 +1,254 @@ +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 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 "datahike 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 ]) + ] ) + ] 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_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 ()