diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index f883c22..230f85f 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -18,7 +18,7 @@ jobs: strategy: fail-fast: false matrix: - ocaml-compiler: ["5.2.1"] + ocaml-compiler: ["5.5.1"] steps: - name: Checkout @@ -50,9 +50,25 @@ jobs: - name: Install system dependencies run: sudo apt-get update && sudo apt-get install -y libsqlite3-dev pkg-config + - name: Restore opam switch cache + id: opam-cache + uses: actions/cache/restore@v4 + with: + path: ~/.opam + key: ${{ runner.os }}-ocaml-${{ matrix.ocaml-compiler }}-opam-${{ hashFiles('*.opam') }} + restore-keys: | + ${{ runner.os }}-ocaml-${{ matrix.ocaml-compiler }}-opam- + - name: Install OCaml dependencies run: opam install . --deps-only --with-test -y + - name: Save opam switch cache + if: steps.opam-cache.outputs.cache-hit != 'true' + uses: actions/cache/save@v4 + with: + path: ~/.opam + key: ${{ steps.opam-cache.outputs.cache-primary-key }} + - name: Cache upstream DataScript id: cache-upstream-datascript uses: actions/cache@v4 diff --git a/bench/memory_scenario.ml b/bench/memory_scenario.ml index ebced9f..6884248 100644 --- a/bench/memory_scenario.ml +++ b/bench/memory_scenario.ml @@ -162,7 +162,7 @@ let canonical_value attr = function | Float value -> "float:" ^ string_of_float value | Nil -> "nil" | Uuid value -> "uuid:" ^ value - | Instant value -> "instant:" ^ string_of_int value + | Instant value -> "instant:" ^ Int64.to_string value | Regex value -> "regex:" ^ value | TxRef -> "tx-ref" | Ref_to _ -> "ref-to" diff --git a/datascript-ocaml-lg.opam b/datascript-ocaml-lg.opam index 70f0b18..90b6fa3 100644 --- a/datascript-ocaml-lg.opam +++ b/datascript-ocaml-lg.opam @@ -10,3 +10,6 @@ depends: [ "lg" ] build: [["dune" "build" "-p" name "-j" jobs]] +pin-depends: [ + ["lg.dev" "git+https://github.com/logseq/lg.git#main"] +] diff --git a/examples/logseq_query_runner.ml b/examples/logseq_query_runner.ml index 33ba58c..8c375b9 100644 --- a/examples/logseq_query_runner.ml +++ b/examples/logseq_query_runner.ml @@ -42,7 +42,7 @@ let rec edn_value = function | Bool false -> "false" | Keyword value -> edn_keyword value | Uuid value -> "#uuid " ^ json_string value - | Instant value -> string_of_int value + | Instant value -> Int64.to_string value | Regex value -> "#\"" ^ String.escaped value ^ "\"" | Ref value -> string_of_int value | List values -> "(" ^ String.concat " " (List.map edn_value values) ^ ")" diff --git a/examples/logseq_sqlite_storage.ml b/examples/logseq_sqlite_storage.ml index 9935500..2f24e6e 100644 --- a/examples/logseq_sqlite_storage.ml +++ b/examples/logseq_sqlite_storage.ml @@ -246,8 +246,8 @@ let rec value_to_transit = function | 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) + | Uuid value -> Transit.Uuid value + | Instant value -> Transit.Date 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) @@ -393,12 +393,12 @@ let rec value_of_transit = function 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) + Instant 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.Date value -> Instant value | Transit.Uuid value -> Uuid value | Transit.Uri value -> String value | Transit.Keyword value -> Keyword value @@ -409,8 +409,8 @@ let rec value_of_transit = function | 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 ("m", Transit.Int value) -> Instant (Int64.of_int value) + | Transit.Tagged ("m", Transit.Int64 value) -> Instant value | Transit.Tagged ("regex", Transit.String value) -> Regex value | Transit.Tagged (tag, value) -> Vector [ String tag; value_of_transit value ] diff --git a/impl/built_ins.ml b/impl/built_ins.ml index c3b52f6..8059d62 100644 --- a/impl/built_ins.ml +++ b/impl/built_ins.ml @@ -290,7 +290,7 @@ let string_of_query_value = function | Bool false -> "false" | Keyword value -> ":" ^ value | Uuid value -> value - | Instant value -> string_of_int value + | Instant value -> Int64.to_string value | Regex value -> value | Ref entity_id -> string_of_int entity_id | List _ | Vector _ | Map _ | Set _ | Tuple _ | TxRef | Ref_to _ -> invalid_arg "cannot stringify composite query value" @@ -320,7 +320,7 @@ let rec print_query_value ~readably = function | Bool false -> "false" | Keyword value -> ":" ^ value | Uuid value -> value - | Instant value -> string_of_int value + | Instant value -> Int64.to_string value | Regex value -> "#\"" ^ value ^ "\"" | Ref entity_id -> string_of_int entity_id | List values -> "(" ^ print_query_values ~readably values ^ ")" diff --git a/impl/datascript.ml b/impl/datascript.ml index 4a945a9..7cecfb9 100644 --- a/impl/datascript.ml +++ b/impl/datascript.ml @@ -191,7 +191,7 @@ let rec edn_string_of_value = function | Keyword value -> ":" ^ value | Symbol value -> value | Uuid value -> "#uuid \"" ^ value ^ "\"" - | Instant millis -> string_of_int millis + | Instant millis -> Int64.to_string millis | Regex value -> "#\"" ^ String.escaped value ^ "\"" | Ref entity_id -> string_of_int entity_id | TxRef -> ":db/current-tx" @@ -352,6 +352,7 @@ let transact_resolve_context : Transact_impl.context = ; is_reverse_ref ; reverse_ref ; cardinality + ; is_unique_identity ; max_eid_with_entity_id = Db_impl.max_eid_with_entity_id ; max_eid_in_value } @@ -688,8 +689,15 @@ let transact_apply_context : Transact_impl.apply_context = { resolve_context = transact_resolve_context ; is_filtered ; schema_from_transaction_datoms = - (fun ~strict ~removed_attrs ~removed_fields ~ignored_schema_entities schema datoms -> - schema_from_transaction_datoms ~strict ~removed_attrs ~removed_fields ~ignored_schema_entities schema datoms) + (fun ?(validate = true) ~strict ~removed_attrs ~removed_fields ~ignored_schema_entities schema datoms -> + schema_from_transaction_datoms + ~validate + ~strict + ~removed_attrs + ~removed_fields + ~ignored_schema_entities + schema + datoms) ; schema_datoms = schema_datoms_for_tx ; schema_fields ; current_attr_value = current_attr_value_db @@ -1092,6 +1100,9 @@ let query_entity_id_term db = function let query_value_term = function | QValue value -> Some value + (* a variable bound to an entity id substitutes to QEntity; in value position + that entity is the ref value of the datom *) + | QEntity entity_id -> Some (Ref entity_id) | _ -> None let query_tx_term = function diff --git a/impl/parser.ml b/impl/parser.ml index 7f877b2..1392de3 100644 --- a/impl/parser.ml +++ b/impl/parser.ml @@ -64,7 +64,11 @@ let parse_instant_millis value = in let days = days_from_civil year month day in let local_minutes = ((days * 24 + hour) * 60) + minute in - (((local_minutes - timezone_offset_minutes) * 60 + second) * 1000) + millis + (* epoch milliseconds exceed int32; compute in int64 *) + let ( - ) = Int64.sub and ( + ) = Int64.add and ( * ) = Int64.mul in + let to_i = Int64.of_int in + (((to_i local_minutes - to_i timezone_offset_minutes) * 60L + to_i second) * 1000L) + + to_i millis let read_edn input = let length = String.length input in @@ -335,7 +339,7 @@ let rec query_form_of_value = function | Map entries -> QueryFormMap (List.map (fun (key, value) -> query_form_of_value key, query_form_of_value value) entries) | Uuid value -> QueryFormTagged ("uuid", QueryFormString value) - | Instant value -> QueryFormInt value + | Instant value -> QueryFormInt (Int64.to_int value) | Regex value -> QueryFormTagged ("regex", QueryFormString value) | Ref entity_id -> QueryFormInt entity_id | TxRef diff --git a/impl/pull_parser.ml b/impl/pull_parser.ml index f49a9cb..fd5e5f8 100644 --- a/impl/pull_parser.ml +++ b/impl/pull_parser.ml @@ -100,7 +100,7 @@ let pull_string_of_value = function | Bool false -> "false" | Keyword value -> ":" ^ value | Uuid value -> value - | Instant value -> string_of_int value + | Instant value -> Int64.to_string value | Regex value -> value | Ref entity_id -> string_of_int entity_id | List _ | Vector _ | Map _ | Set _ | Tuple _ | TxRef | Ref_to _ -> invalid_arg "cannot stringify composite pull value" diff --git a/impl/schema.ml b/impl/schema.ml index 560bf7d..2342a1d 100644 --- a/impl/schema.ml +++ b/impl/schema.ml @@ -285,6 +285,7 @@ let replace_schema_attr schema (attr, spec) = let schema_from_transaction_datoms ?(strict = true) + ?(validate = true) ?(removed_attrs = []) ?(removed_fields = []) ?(ignored_schema_entities = []) @@ -302,7 +303,7 @@ let schema_from_transaction_datoms | Some entry -> replace_schema_attr schema entry | None -> schema) schema - |> validate_schema + |> fun schema -> if validate then validate_schema schema else schema let split_namespaced_attr attr = diff --git a/impl/schema.mli b/impl/schema.mli index 2a61f43..e30bc6b 100644 --- a/impl/schema.mli +++ b/impl/schema.mli @@ -9,6 +9,7 @@ val schema_has_no_history : schema -> attr -> bool val schema_fields : attr list val schema_from_transaction_datoms : ?strict:bool -> + ?validate:bool -> ?removed_attrs:attr list -> ?removed_fields:(attr * attr) list -> ?ignored_schema_entities:entity_id list -> diff --git a/impl/transact.ml b/impl/transact.ml index b20b237..341027e 100644 --- a/impl/transact.ml +++ b/impl/transact.ml @@ -12,6 +12,7 @@ type context = ; is_reverse_ref : attr -> bool ; reverse_ref : attr -> attr ; cardinality : db -> attr -> cardinality + ; is_unique_identity : db -> attr -> bool ; max_eid_with_entity_id : int -> entity_id -> entity_id ; max_eid_in_value : int -> value -> int } @@ -186,10 +187,13 @@ let resolve_value_for_attr context db attr datoms tx max_eid tempids value = let attr_expands_collection context db attr = context.cardinality db attr = Many || context.is_reverse_ref attr -let ref_lookup_collection_value = function - | (List _ | Vector _) as value -> - (match entity_ref_of_ref_attr_value value with - | Some _ -> true +(* upstream maybe-wrap-multival: in a multival context a 2-element collection is + a lookup ref only when its head names a :db.unique/identity attr; any other + collection expands into individual values *) +let ref_lookup_collection_value context db = function + | List [ attr; _ ] | Vector [ attr; _ ] -> + (match attr_name_of_value attr with + | Some attr -> context.is_unique_identity db attr | None -> false) | _ -> false @@ -209,7 +213,7 @@ let resolve_optional_existing_entity_ref context db datoms tx max_eid tempids = Some e, max_eid, tempids let resolve_tx_value_for_attr context db attr datoms tx max_eid tempids = function - | One_value ((List values | Vector values) as value) when attr_expands_collection context db attr && not (ref_lookup_collection_value value) -> + | One_value ((List values | Vector values) as value) when attr_expands_collection context db attr && not (ref_lookup_collection_value context db value) -> let values, max_eid, tempids = List.fold_left (fun (values, max_eid, tempids) value -> @@ -309,7 +313,7 @@ let remap_tempid_entity old_e new_e tempids = type apply_context = { resolve_context : context ; is_filtered : db -> bool - ; schema_from_transaction_datoms : strict:bool -> removed_attrs:attr list -> removed_fields:(attr * attr) list -> ignored_schema_entities:entity_id list -> schema -> datom list -> schema + ; schema_from_transaction_datoms : ?validate:bool -> strict:bool -> removed_attrs:attr list -> removed_fields:(attr * attr) list -> ignored_schema_entities:entity_id list -> schema -> datom list -> schema ; schema_datoms : db -> datom list -> datom list ; schema_fields : attr list ; current_attr_value : db -> entity_id -> attr -> value option @@ -359,8 +363,12 @@ let apply_tx context tx_ops db = in let refresh_schema tx_db tx_data = let schema_datoms = context.schema_datoms (db_with_current_metadata tx_db) tx_data in + (* mid-tx refreshes can see a partially-installed schema spec (e.g. + db.type/tuple before its db/tupleTypes land); upstream does not + revalidate the whole schema during a transaction *) current_schema := context.schema_from_transaction_datoms + ~validate:false ~strict:false ~removed_attrs:!removed_schema_attrs ~removed_fields:!removed_schema_fields diff --git a/impl/transact.mli b/impl/transact.mli index 14fb2c5..b309be6 100644 --- a/impl/transact.mli +++ b/impl/transact.mli @@ -12,6 +12,7 @@ type context = ; is_reverse_ref : attr -> bool ; reverse_ref : attr -> attr ; cardinality : db -> attr -> cardinality + ; is_unique_identity : db -> attr -> bool ; max_eid_with_entity_id : int -> entity_id -> entity_id ; max_eid_in_value : int -> value -> int } @@ -28,7 +29,7 @@ val entity_ref_of_ref_attr_value : value -> entity_ref option val ref_attr_for_value_resolution : context -> db -> attr -> attr option val resolve_value_for_attr : context -> db -> attr -> db -> tx -> entity_id -> (string * entity_id) list -> value -> value * entity_id * (string * entity_id) list val attr_expands_collection : context -> db -> attr -> bool -val ref_lookup_collection_value : value -> bool +val ref_lookup_collection_value : context -> db -> value -> bool val resolve_existing_entity_ref : context -> db -> db -> tx -> entity_id -> (string * entity_id) list -> entity_ref -> entity_id * entity_id * (string * entity_id) list val resolve_optional_existing_entity_ref : context -> db -> db -> tx -> entity_id -> (string * entity_id) list -> entity_ref -> entity_id option * entity_id * (string * entity_id) list val resolve_tx_value_for_attr : context -> db -> attr -> db -> tx -> entity_id -> (string * entity_id) list -> tx_value -> tx_value * entity_id * (string * entity_id) list @@ -42,7 +43,7 @@ val remap_tempid_entity : entity_id -> entity_id -> (string * entity_id) list -> type apply_context = { resolve_context : context ; is_filtered : db -> bool - ; schema_from_transaction_datoms : strict:bool -> removed_attrs:attr list -> removed_fields:(attr * attr) list -> ignored_schema_entities:entity_id list -> schema -> datom list -> schema + ; schema_from_transaction_datoms : ?validate:bool -> strict:bool -> removed_attrs:attr list -> removed_fields:(attr * attr) list -> ignored_schema_entities:entity_id list -> schema -> datom list -> schema ; schema_datoms : db -> datom list -> datom list ; schema_fields : attr list ; current_attr_value : db -> entity_id -> attr -> value option diff --git a/impl/util.ml b/impl/util.ml index b0497da..34ef436 100644 --- a/impl/util.ml +++ b/impl/util.ml @@ -264,7 +264,7 @@ let rec clojure_hasheq = function |> murmur3_hash_ordered | Ref value -> murmur3_hash_long (Int64.of_int value) | Uuid value -> java_uuid_hash value - | Instant value -> murmur3_hash_long (Int64.of_int value) + | Instant value -> murmur3_hash_long value | Regex value -> Hashtbl.hash value | TxRef -> Hashtbl.hash TxRef | Ref_to value -> Hashtbl.hash (Ref_to value) diff --git a/js/datascript_js.ml b/js/datascript_js.ml index aa133ba..8373955 100644 --- a/js/datascript_js.ml +++ b/js/datascript_js.ml @@ -217,7 +217,7 @@ let rec json_of_value = function | Bool value -> `Bool value | Keyword value -> `String (":" ^ value) | Uuid value -> `String value - | Instant value -> `Int value + | Instant value -> `Intlit (Int64.to_string value) | Regex value -> `String value | Ref entity_id -> `Int entity_id | List values | Vector values | Set values -> `List (List.map json_of_value values) diff --git a/melange/datascript_melange_storage.ml b/melange/datascript_melange_storage.ml index 2cabab9..6b61983 100644 --- a/melange/datascript_melange_storage.ml +++ b/melange/datascript_melange_storage.ml @@ -182,8 +182,8 @@ let rec value_to_transit = function | 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) + | Uuid value -> Transit.Uuid value + | Instant value -> Transit.Date 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) @@ -211,12 +211,12 @@ let rec value_of_transit = function Int64.compare value (Int64.of_int min_int) >= 0 && Int64.compare value (Int64.of_int max_int) <= 0 then Int (Int64.to_int value) - else Instant (Int64.to_int value) + else Instant value | Float value -> Float value | Binary value -> String value | Big_decimal value -> Float (float_of_string value) | Big_int value -> Transit.Int64 (Int64.of_string value) |> value_of_transit - | Date value -> Instant (Int64.to_int value) + | Date value -> Instant value | Uuid value -> Uuid value | Uri value -> String value | Keyword value -> Keyword value @@ -226,8 +226,8 @@ let rec value_of_transit = function | Set values -> Set (List.map value_of_transit values) | List values -> List (List.map value_of_transit values) | Tagged ("u", Transit.String value) -> Uuid value - | Tagged ("m", Transit.Int value) -> Instant value - | Tagged ("m", Transit.Int64 value) -> Instant (Int64.to_int value) + | Tagged ("m", Transit.Int value) -> Instant (Int64.of_int value) + | Tagged ("m", Transit.Int64 value) -> Instant value | Tagged ("regex", Transit.String value) -> Regex value | Tagged (tag, value) -> Vector [ String tag; value_of_transit value ] diff --git a/sqlite/datascript_sqlite_codec.ml b/sqlite/datascript_sqlite_codec.ml index 05f9b69..e54ce94 100644 --- a/sqlite/datascript_sqlite_codec.ml +++ b/sqlite/datascript_sqlite_codec.ml @@ -182,8 +182,8 @@ let rec value_to_transit = function | 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) + | Uuid value -> Transit.Uuid value + | Instant value -> Transit.Date 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) @@ -211,12 +211,12 @@ let rec value_of_transit = function Int64.compare value (Int64.of_int min_int) >= 0 && Int64.compare value (Int64.of_int max_int) <= 0 then Int (Int64.to_int value) - else Instant (Int64.to_int value) + else Instant value | Float value -> Float value | Binary value -> String value | Big_decimal value -> Float (float_of_string value) | Big_int value -> Transit.Int64 (Int64.of_string value) |> value_of_transit - | Date value -> Instant (Int64.to_int value) + | Date value -> Instant value | Uuid value -> Uuid value | Uri value -> String value | Keyword value -> Keyword value @@ -226,8 +226,8 @@ let rec value_of_transit = function | Set values -> Set (List.map value_of_transit values) | List values -> List (List.map value_of_transit values) | Tagged ("u", Transit.String value) -> Uuid value - | Tagged ("m", Transit.Int value) -> Instant value - | Tagged ("m", Transit.Int64 value) -> Instant (Int64.to_int value) + | Tagged ("m", Transit.Int value) -> Instant (Int64.of_int value) + | Tagged ("m", Transit.Int64 value) -> Instant value | Tagged ("regex", Transit.String value) -> Regex value | Tagged (tag, value) -> Vector [ String tag; value_of_transit value ] diff --git a/test/cross_runtime_ocaml.ml b/test/cross_runtime_ocaml.ml index cba8203..3190de0 100644 --- a/test/cross_runtime_ocaml.ml +++ b/test/cross_runtime_ocaml.ml @@ -78,7 +78,7 @@ let rec value_json = function | Bool value -> json_bool value | Keyword value -> json_string (":" ^ value) | Uuid value -> json_string value - | Instant value -> json_int value + | Instant value -> json_int (Int64.to_int value) | Regex value -> json_string value | Ref value -> json_int value | List values | Vector values | Set values -> json_list (List.map value_json values) diff --git a/test/dune b/test/dune index 62a5721..4fd498e 100644 --- a/test/dune +++ b/test/dune @@ -121,7 +121,13 @@ (test (name test_sqlite_storage) (modules test_sqlite_storage) - (libraries datascript-ocaml-native logseq_sqlite_storage unix sqlite3 melange-transit-native)) + (libraries + datascript-ocaml-native + datascript-ocaml-native.sqlite + logseq_sqlite_storage + unix + sqlite3 + melange-transit-native)) (test (name test_sqlite_package) diff --git a/test/sqlite_cross_runtime_native.ml b/test/sqlite_cross_runtime_native.ml index efd4c1e..58c114a 100644 --- a/test/sqlite_cross_runtime_native.ml +++ b/test/sqlite_cross_runtime_native.ml @@ -131,7 +131,7 @@ let string_of_value = function | Bool value -> "bool:" ^ string_of_bool value | Keyword value -> "keyword:" ^ value | Uuid value -> "uuid:" ^ value - | Instant value -> "instant:" ^ string_of_int value + | Instant value -> "instant:" ^ Int64.to_string value | Regex value -> "regex:" ^ value | Ref entity_id -> "ref:" ^ string_of_int entity_id | List _ | Vector _ | Set _ | Map _ | Tuple _ -> "compound" diff --git a/test/test_datascript.ml b/test/test_datascript.ml index 8d89f58..ecdcba3 100644 --- a/test/test_datascript.ml +++ b/test/test_datascript.ml @@ -46,7 +46,7 @@ let rec debug_value = function | Bool value -> string_of_bool value | Keyword value -> ":" ^ value | Uuid value -> "#uuid " ^ value - | Instant value -> "#inst " ^ string_of_int value + | Instant value -> "#inst " ^ Int64.to_string value | Regex value -> "#\"" ^ value ^ "\"" | Ref value -> "Ref " ^ string_of_int value | List values -> "[" ^ (values |> List.map debug_value |> String.concat " ") ^ "]" @@ -2672,7 +2672,7 @@ let test_upstream_components_and_explode_parity_batch () = let test_init_db_preserves_uuid_and_instant_values () = let uuid = Uuid "65ec87fb-0000-0000-0000-000000000001" in - let instant = Instant 1_710_000_123_456 in + let instant = Instant 1_710_000_123_456L in let db = init_db ~schema:[ "uuid", indexed; "created-at", indexed ] @@ -3338,14 +3338,14 @@ let test_edn_reader_parses_common_literals () = in assert_equal_triples "db_with_string parses EDN set, regex, uuid, and instant literals" - [ 1, "created-at", Instant 1_710_000_123_456 + [ 1, "created-at", Instant 1_710_000_123_456L ; 1, "pattern", Regex "[a-z]+[0-9]+" ; 1, "tags", Keyword "admin" ; 1, "tags", Keyword "user" ; 1, "uuid", Uuid "65ec87fb-0000-0000-0000-000000000001" - ; 2, "created-at", Instant 1_710_000_123_456 - ; 3, "created-at", Instant 1_710_000_123_456 - ; 4, "created-at", Instant 1_710_000_123_456 + ; 2, "created-at", Instant 1_710_000_123_456L + ; 3, "created-at", Instant 1_710_000_123_456L + ; 4, "created-at", Instant 1_710_000_123_456L ] (datoms db Eavt ()); assert_equal_query @@ -17259,12 +17259,12 @@ let test_uuid_and_instant_value_type_schema_validates_values () = empty_db ~schema:[ "uuid", uuid_attr; "created-at", instant_attr ] () |> db_with [ Add (Entity_id 1, "uuid", Uuid "65ec87fb-0000-0000-0000-000000000001") - ; Add (Entity_id 1, "created-at", Instant 1_710_000_123_456) + ; Add (Entity_id 1, "created-at", Instant 1_710_000_123_456L) ] in assert_equal_triples "uuid and instant valueType attrs accept matching values" - [ 1, "created-at", Instant 1_710_000_123_456 + [ 1, "created-at", Instant 1_710_000_123_456L ; 1, "uuid", Uuid "65ec87fb-0000-0000-0000-000000000001" ] (datoms db Eavt ()); @@ -17298,7 +17298,7 @@ let test_schema_transactions_install_uuid_and_instant_value_types () = ] } ; Add (Entity_id 1, "uuid", Uuid "65ec87fb-0000-0000-0000-000000000001") - ; Add (Entity_id 1, "created-at", Instant 1_710_000_123_456) + ; Add (Entity_id 1, "created-at", Instant 1_710_000_123_456L) ] in if List.assoc_opt "uuid" (schema db) <> Some { indexed with value_type = Some UuidType } then diff --git a/test/test_db.ml b/test/test_db.ml index 5c19e0a..6cb612c 100644 --- a/test/test_db.ml +++ b/test/test_db.ml @@ -26,7 +26,7 @@ let rec debug_value = function | Bool value -> string_of_bool value | Keyword value -> ":" ^ value | Uuid value -> "#uuid " ^ value - | Instant value -> "#inst " ^ string_of_int value + | Instant value -> "#inst " ^ Int64.to_string value | Regex value -> "#\"" ^ value ^ "\"" | Ref value -> "Ref " ^ string_of_int value | List values -> "[" ^ (values |> List.map debug_value |> String.concat " ") ^ "]" diff --git a/test/test_pull_api.ml b/test/test_pull_api.ml index f05352c..642fde8 100644 --- a/test/test_pull_api.ml +++ b/test/test_pull_api.ml @@ -81,7 +81,7 @@ let rec string_of_value = function | Bool value -> string_of_bool value | Keyword value -> ":" ^ value | Uuid value -> "#uuid " ^ value - | Instant value -> "#inst " ^ string_of_int value + | Instant value -> "#inst " ^ Int64.to_string value | Regex value -> "#\"" ^ value ^ "\"" | Ref value -> "Ref " ^ string_of_int value | List values -> "[" ^ String.concat " " (List.map string_of_value values) ^ "]" diff --git a/test/test_query_engine_fixes.ml b/test/test_query_engine_fixes.ml index a7e031a..9d39142 100644 --- a/test/test_query_engine_fixes.ml +++ b/test/test_query_engine_fixes.ml @@ -123,6 +123,77 @@ let test_logseq_parent_rule () = (q_string ~inputs:[ Arg_rules rules ] db "[:find ?p :in $ % :where (parent ?p 4)]") +(* Bug A: a bound head arg — literal or :in-bound — must flow into recursive + rule calls. With two disjoint trees, a dropped binding leaks the other + tree's children. *) +let test_recursive_rule_bound_head_arg () = + let schema = + let base_attr = + { cardinality = One; unique = None; indexed = false; is_component = false + ; no_history = false; doc = None; value_type = None; tuple_attrs = None + ; tuple_types = None } + in + [ "block/parent", { base_attr with value_type = Some RefType } ] + in + let db = + empty_db ~schema () + |> db_with + (* tree 1: 1 <- 2 <- 3 ; tree 2: 5 <- 6 <- 7 *) + [ Entity { db_id = Some (Entity_id 1); attrs = [] } + ; Entity { db_id = Some (Entity_id 2); attrs = [ "block/parent", One_value (Ref 1) ] } + ; Entity { db_id = Some (Entity_id 3); attrs = [ "block/parent", One_value (Ref 2) ] } + ; Entity { db_id = Some (Entity_id 5); attrs = [] } + ; Entity { db_id = Some (Entity_id 6); attrs = [ "block/parent", One_value (Ref 5) ] } + ; Entity { db_id = Some (Entity_id 7); attrs = [ "block/parent", One_value (Ref 6) ] } + ] + in + let rules = + rules_of_string + "[[(parent ?p ?c) [?c :block/parent ?p]] + [(parent ?p ?c) [?t :block/parent ?p] (parent ?t ?c)]]" + in + assert_rows + "(parent 1 ?c) with two trees returns only tree-1 descendants" + [ [ Result_entity 2 ]; [ Result_entity 3 ] ] + (q_string ~inputs:[ Arg_rules rules ] db + "[:find ?c :in $ % :where (parent 1 ?c)]"); + assert_rows + "(parent ?p ?c) with :in-bound ?p returns only its descendants" + [ [ Result_entity 2 ]; [ Result_entity 3 ] ] + (q_string ~inputs:[ Arg_scalar (Result_entity 1); Arg_rules rules ] db + "[:find ?c :in $ ?p % :where (parent ?p ?c)]") + +(* Bug B: Arg_scalar (Result_entity e) binds the entity as the :in input, + same as Arg_scalar (Result_value (Ref e)) — a second tree exposes leaks *) +let test_in_scalar_result_entity () = + let schema = + let base_attr = + { cardinality = One; unique = None; indexed = false; is_component = false + ; no_history = false; doc = None; value_type = None; tuple_attrs = None + ; tuple_types = None } + in + [ "block/parent", { base_attr with value_type = Some RefType } ] + in + let db = + empty_db ~schema () + |> db_with + [ Entity { db_id = Some (Entity_id 1); attrs = [] } + ; Entity { db_id = Some (Entity_id 2); attrs = [ "block/parent", One_value (Ref 1) ] } + ; Entity { db_id = Some (Entity_id 5); attrs = [] } + ; Entity { db_id = Some (Entity_id 6); attrs = [ "block/parent", One_value (Ref 5) ] } + ] + in + assert_rows + ":in ?x bound to Arg_scalar (Result_entity 1) filters ref datoms" + [ [ Result_entity 2 ] ] + (q_string ~inputs:[ Arg_scalar (Result_entity 1) ] db + "[:find ?c :in $ ?x :where [?c :block/parent ?x]]"); + assert_rows + ":in ?x bound to Arg_scalar (Result_value (Ref 1)) filters ref datoms" + [ [ Result_entity 2 ] ] + (q_string ~inputs:[ Arg_scalar (Result_value (Ref 1)) ] db + "[:find ?c :in $ ?x :where [?c :block/parent ?x]]") + (* Upstream "Mutually recursive rules" (test-rules): two rules recursing into each other *) let test_mutually_recursive_rules () = @@ -472,6 +543,100 @@ let test_entity_map_lookup_ref_never_resolves_raises () = then failf "unexpected error message: %s" msg) +(* Bug D: upstream maybe-wrap-multival — inside a multival attr a 2-element + collection is a lookup ref only when its head names a unique-identity attr; + otherwise it expands into individual values *) +let refs_datoms db = + datoms db Aevt ~a:"block/refs" () + |> List.of_seq + |> List.map (fun d -> d.e, d.v) + +let test_many_ref_vector_of_idents_expands () = + (* logseq repro: {:block/tags [:logseq.class/Page :logseq.class/Task]} — the + head keyword is not an attr at all, so the vector is a collection *) + let db = + empty_db ~schema:(block_schema ()) () + |> db_with + [ Add (Entity_id 10, "db/ident", Keyword "logseq.class/Page") + ; Add (Entity_id 11, "db/ident", Keyword "logseq.class/Task") + ] + |> db_with + [ Entity + { db_id = Some (Entity_id 1) + ; attrs = + [ "block/refs" + , One_value + (Vector [ Keyword "logseq.class/Page"; Keyword "logseq.class/Task" ]) + ] + } + ] + in + let refs = refs_datoms db in + if refs <> [ 1, Ref 10; 1, Ref 11 ] then + failf "vector of ident keywords should expand into one datom per ident, got %d" + (List.length refs) + +let test_many_ref_vector_of_same_ident_idempotent () = + let db = + empty_db ~schema:(block_schema ()) () + |> db_with [ Add (Entity_id 10, "db/ident", Keyword "logseq.class/Page") ] + |> db_with + [ Entity + { db_id = Some (Entity_id 1) + ; attrs = + [ "block/refs" + , One_value + (Vector [ Keyword "logseq.class/Page"; Keyword "logseq.class/Page" ]) + ] + } + ] + in + let refs = refs_datoms db in + if refs <> [ 1, Ref 10 ] then + failf "duplicate ident refs should yield a single datom, got %d" (List.length refs) + +let test_many_ref_vector_with_unique_head_is_lookup_ref () = + (* Same 2-vector whose head names a unique-identity attr stays a lookup ref *) + let u1 = "11111111-1111-1111-1111-111111111111" in + let db = + empty_db ~schema:(block_schema ()) () + |> db_with + [ Entity { db_id = Some (Entity_id 1); attrs = [ "block/uuid", One_value (Uuid u1) ] } + ; Entity + { db_id = Some (Entity_id 9) + ; attrs = + [ "block/refs" + , One_value (Vector [ Keyword "block/uuid"; Uuid u1 ]) + ] + } + ] + in + let refs = refs_datoms db in + if refs <> [ 9, Ref 1 ] then + failf "2-vector headed by a unique attr should resolve as a lookup ref to e=1" + +let test_entity_map_lookup_ref_vector_form () = + (* {:block/parent [:block/uuid u]} — single-attr lookup ref in vector form *) + let u1 = "11111111-1111-1111-1111-111111111111" in + let db = + empty_db ~schema:(block_schema ()) () + |> db_with + [ Entity { db_id = None; attrs = [ "block/uuid", One_value (Uuid u1) ] } + ; Entity + { db_id = None + ; attrs = + [ "block/parent", One_value (Vector [ Keyword "block/uuid"; Uuid u1 ]) ] + } + ] + in + let parent_datoms = + datoms db Aevt ~a:"block/parent" () + |> List.of_seq + |> List.map (fun d -> d.e, d.v) + in + if parent_datoms <> [ 2, Ref 1 ] then + failf "vector lookup ref should resolve to e=1" + (* Bug 6: EDN reader accepts ' and friends inside symbol/keyword bodies *) let test_edn_symbol_special_chars () = (match Parser.read_edn "{:user.property/foo*+!_'?<>=- nil}" with @@ -494,6 +659,8 @@ let () = ; "rule_branches_positional_binding", test_rule_branches_positional_binding ; "recursive_rule_swapped_args", test_recursive_rule_swapped_args ; "logseq_parent_rule", test_logseq_parent_rule + ; "recursive_rule_bound_head_arg", test_recursive_rule_bound_head_arg + ; "in_scalar_result_entity", test_in_scalar_result_entity ; "mutually_recursive_rules", test_mutually_recursive_rules ; "rule_joined_with_clauses", test_rule_joined_with_clauses ; "predicate_over_in_scalar", test_predicate_over_in_scalar @@ -507,5 +674,9 @@ let () = ; "entity_map_lookup_ref_later_tx_entity_many_values", test_entity_map_lookup_ref_later_tx_entity_many_values ; "add_op_lookup_ref_later_tx_entity", test_add_op_lookup_ref_later_tx_entity ; "entity_map_lookup_ref_never_resolves_raises", test_entity_map_lookup_ref_never_resolves_raises + ; "many_ref_vector_of_idents_expands", test_many_ref_vector_of_idents_expands + ; "many_ref_vector_of_same_ident_idempotent", test_many_ref_vector_of_same_ident_idempotent + ; "many_ref_vector_with_unique_head_is_lookup_ref", test_many_ref_vector_with_unique_head_is_lookup_ref + ; "entity_map_lookup_ref_vector_form", test_entity_map_lookup_ref_vector_form ; "edn_symbol_special_chars", test_edn_symbol_special_chars ] diff --git a/test/test_serialize.ml b/test/test_serialize.ml index a28268a..71aa8a6 100644 --- a/test/test_serialize.ml +++ b/test/test_serialize.ml @@ -138,7 +138,7 @@ let test_serialize__serialize () = ; attrs = [ "name", One_value (String "Ivan") ; "aka", Many_values [ String "IV"; String "Terrible" ] - ; "created-at", One_value (Instant 1_710_000_123_456) + ; "created-at", One_value (Instant 1_710_000_123_456L) ; "uuid", One_value (Uuid "65ec87fb-0000-0000-0000-000000000001") ] } diff --git a/test/test_sqlite_storage.ml b/test/test_sqlite_storage.ml index 4624070..58c6e22 100644 --- a/test/test_sqlite_storage.ml +++ b/test/test_sqlite_storage.ml @@ -203,7 +203,7 @@ let rec string_of_value = function | Bool value -> string_of_bool value | Keyword value -> ":" ^ value | Uuid value -> "#uuid " ^ Printf.sprintf "%S" value - | Instant value -> string_of_int value + | Instant value -> Int64.to_string value | Regex value -> "#\"" ^ String.escaped value ^ "\"" | Ref entity_id -> string_of_int entity_id | List values -> "[" ^ String.concat " " (List.map string_of_value values) ^ "]" @@ -643,6 +643,52 @@ let test_sqlite_storage_round_trips_ocaml_payloads () = if List.map (fun datom -> datom.e, datom.a, datom.v) names <> [ 1, "name", String "Ada" ] then failwith "SQLite storage should preserve stored datoms") +(* Instant and Uuid must serialize through Transit's cljs-compatible date/uuid + reps (~t verbose / ~m normal, ~u) rather than ~#m/~#u tagged maps, and + epoch-millisecond timestamps must not truncate to int32. *) +let test_sqlite_codec_instant_uuid_transit_reps () = + let expect label expected actual = if expected <> actual then failf "%s" label in + let millis = 1_758_000_000_000L in + let uuid = "550e8400-e29b-41d4-a716-446655440000" in + let instant_rep = Datascript_sqlite_codec.value_to_transit (Instant millis) in + expect + "Instant encodes as a Transit date rep" + (Transit.Date millis) + instant_rep; + let uuid_rep = Datascript_sqlite_codec.value_to_transit (Uuid uuid) in + expect "Uuid encodes as a Transit uuid rep" (Transit.Uuid uuid) uuid_rep; + expect + "Instant round-trips without int32 truncation" + (Instant millis) + (Datascript_sqlite_codec.value_of_transit instant_rep); + expect + "Uuid round-trips" + (Uuid uuid) + (Datascript_sqlite_codec.value_of_transit uuid_rep); + (* blobs written by older builds with ~#m/~#u tagged maps still decode *) + expect + "legacy ~#m tagged Instant still decodes" + (Instant millis) + (Datascript_sqlite_codec.value_of_transit (Transit.Tagged ("m", Transit.Int64 millis))); + expect + "legacy ~#u tagged Uuid still decodes" + (Uuid uuid) + (Datascript_sqlite_codec.value_of_transit (Transit.Tagged ("u", Transit.String uuid))); + let contains text needle = + let rec search index = + index + String.length needle <= String.length text + && (String.sub text index (String.length needle) = needle || search (index + 1)) + in + search 0 + in + (* scalar roots are wrapped in a {"~#'": ...} verbose quoting *) + let verbose = Transit.to_string ~mode:Transit.Verbose instant_rep in + if not (contains verbose "\"~t") then + failf "verbose Instant should encode as ~t, got %s" verbose; + let verbose_uuid = Transit.to_string ~mode:Transit.Verbose uuid_rep in + if not (contains verbose_uuid "\"~u") then + failf "verbose Uuid should encode as ~u, got %s" verbose_uuid + 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" @@ -2880,6 +2926,7 @@ let () = test_sqlite_storage_validates_db_attribute_transactions (); test_sqlite_storage_random_property_txs (); test_sqlite_storage_round_trips_ocaml_payloads (); + test_sqlite_codec_instant_uuid_transit_reps (); test_sqlite_storage_raw_layout_after_transact (); test_sqlite_storage_does_not_require_sqlite3_binary (); test_sqlite_storage_store_and_delete_are_separate (); diff --git a/type/datascript_types.ml b/type/datascript_types.ml index c09e317..055ee6d 100644 --- a/type/datascript_types.ml +++ b/type/datascript_types.ml @@ -18,7 +18,7 @@ and value = | Bool of bool | Keyword of string | Uuid of string - | Instant of int + | Instant of int64 | Regex of string | Ref of entity_id | List of value list