From 441f2f3359d6f59e4f26f1d5751926d26b1c7cf9 Mon Sep 17 00:00:00 2001 From: Marcos Magueta Date: Thu, 3 Sep 2026 16:55:45 -0300 Subject: Substantial relation kernel object --- lib/kernel/SubstantialRelation.ml | 147 +++++++++++++++++++++++++++++++++++++ lib/kernel/SubstantialRelation.mli | 44 +++++++++++ 2 files changed, 191 insertions(+) create mode 100644 lib/kernel/SubstantialRelation.ml create mode 100644 lib/kernel/SubstantialRelation.mli (limited to 'lib/kernel') diff --git a/lib/kernel/SubstantialRelation.ml b/lib/kernel/SubstantialRelation.ml new file mode 100644 index 0000000..8658f87 --- /dev/null +++ b/lib/kernel/SubstantialRelation.ml @@ -0,0 +1,147 @@ +module Make (S : Abstract.Storage.STORAGE) = struct + module SI = Storage.Make (S) + + module Error = struct + open Concepts.Condition + + let malformed_relation () = + condition "malformed-substantial-relation" + "The on-disk representation of a substantial relation did not conform to what was \ + expected. Is your database corrupted?" + empty + + let malformed_tuple_key length = + condition "malformed-tuple-key" "A tuple key did not have the expected hash size" + ("length" |=| Concepts.Value.Integer length) + + let invalid_tuple_root root = + condition "invalid-tuple-root" + "The tuple-set root for a substantial relation is missing from the backend. Either your \ + storage is corrupted, or this is a bug in RNT!" + ("hash" |=| Concepts.Value.String (Concepts.Hash.to_hum_string root)) + end + + module TupleKey = struct + type t = Concepts.Hash.hash + + let encode = Concepts.Hash.blob_of_hash + + let decode blob = + let raw = Concepts.Blob.bytes_of_blob blob |> Bytes.to_string in + if String.length raw = Concepts.Hash.size then Ok (Concepts.Hash.of_raw_string raw) + else Error (Error.malformed_tuple_key (String.length raw)) + + let compare = Concepts.Hash.compare + end + + module TupleSet = Merkle.Make (S) (TupleKey) + + type t = + { heading: Concepts.Hash.hash; + predicate: Concepts.Hash.hash option; + local_constraints: Concepts.Hash.hash option; + tuples: TupleSet.address; + indexes: Concepts.Hash.hash option } + + module rec Representation : (Concepts.Encoding.Record.S with type t = t) = + Concepts.Encoding.Record.Make (Body) + + and Body : Concepts.Encoding.Record.BODY = struct + type nonrec t = t + + let tag = 'R' + let malformed = Error.malformed_relation + + let fields {heading; predicate; local_constraints; tuples; indexes} = + let open Concepts.Encoding in + [ "heading", Value.bencode_of_hash heading; + "predicate", Value.bencode_of_option Value.bencode_of_hash predicate; + "local-constraints", Value.bencode_of_option Value.bencode_of_hash local_constraints; + "tuples", Value.bencode_of_hash tuples; + "indexes", Value.bencode_of_option Value.bencode_of_hash indexes ] + + let of_fields fields = + let open Utilities.Result in + let open Concepts.Encoding in + let* heading = Bencode.field "heading" fields |> fmap Value.hash_of_bencode in + let* predicate = + Bencode.field "predicate" fields |> fmap (Value.option_of_bencode Value.hash_of_bencode) + in + let* local_constraints = + Bencode.field "local-constraints" fields + |> fmap (Value.option_of_bencode Value.hash_of_bencode) + in + let* tuples = Bencode.field "tuples" fields |> fmap Value.hash_of_bencode in + let* indexes = + Bencode.field "indexes" fields |> fmap (Value.option_of_bencode Value.hash_of_bencode) + in + Ok {heading; predicate; local_constraints; tuples; indexes} + end + + let heading {heading; _} = heading + let predicate {predicate; _} = predicate + let local_constraints {local_constraints; _} = local_constraints + let tuples {tuples; _} = tuples + let indexes {indexes; _} = indexes + let hash relation = Representation.to_blob relation |> Concepts.Hash.hash_of_blob + + let tuple_node tx relation = + let open Utilities.Result in + let* tuples = TupleSet.find tx relation.tuples in + Option.to_result ~none:(Error.invalid_tuple_root relation.tuples) tuples + + let empty tx ~heading ?predicate ?local_constraints ?indexes () = + let open Utilities.Result in + let* tuples = TupleSet.empty_under tx in + Ok {heading; predicate; local_constraints; tuples; indexes} + + let store tx relation = SI.store_blob tx (Representation.to_blob relation) + + let contains_tuple tx relation tuple = + let open Utilities.Result in + let tuple = Concepts.Hash.hash_of_blob tuple in + let* node = tuple_node tx relation in + let* present = TupleSet.lookup tx tuple node in + Ok (Option.is_some present) + + class relation storage value = + object (self) + inherit Lifecycle.null + val storage : S.connection = storage + val relation : t = value + method heading = Ok relation.heading + method predicate = Ok relation.predicate + method local_constraints = Ok relation.local_constraints + method tuples = Ok relation.tuples + + method contains tuple = + SI.with_transaction storage (fun tx -> contains_tuple tx relation tuple) + + method protocols : Protocols.Handle.protocol list = Protocols.[Relation.make self] + method hash = hash relation + end + + let make conn ~heading ?predicate ?local_constraints ?indexes () = + let open Utilities.Result in + SI.with_transaction conn (fun tx -> + let* relation = empty tx ~heading ?predicate ?local_constraints ?indexes () in + let* _ = store tx relation in + Ok (new relation conn relation |> Protocols.Handle.make) ) + + let load_value tx addr = + let open Utilities.Result in + let* data = SI.get_req tx (S.Hash addr) in + Representation.of_blob data + + let load tx conn addr = + let open Utilities.Result in + let* relation = load_value tx addr in + Ok (new relation conn relation |> Protocols.Handle.make) + + let assert_tuple tx relation tuple = + let open Utilities.Result in + let* tuple = SI.store_blob tx tuple in + let* node = tuple_node tx relation in + let* node = TupleSet.insert tx tuple tuple node in + Ok {relation with tuples= TupleSet.hash_of node} +end diff --git a/lib/kernel/SubstantialRelation.mli b/lib/kernel/SubstantialRelation.mli new file mode 100644 index 0000000..db86fe2 --- /dev/null +++ b/lib/kernel/SubstantialRelation.mli @@ -0,0 +1,44 @@ +module Make (S : Abstract.Storage.STORAGE) : sig + type t + + val empty : + S.transaction -> + heading:Concepts.Hash.hash -> + ?predicate:Concepts.Hash.hash -> + ?local_constraints:Concepts.Hash.hash -> + ?indexes:Concepts.Hash.hash -> + unit -> + (t, Concepts.Condition.condition) result + + val store : S.transaction -> t -> (Concepts.Hash.hash, Concepts.Condition.condition) result + + val make : + S.connection -> + heading:Concepts.Hash.hash -> + ?predicate:Concepts.Hash.hash -> + ?local_constraints:Concepts.Hash.hash -> + ?indexes:Concepts.Hash.hash -> + unit -> + (Protocols.Handle.t, Concepts.Condition.condition) result + + val load_value : S.transaction -> Concepts.Hash.hash -> (t, Concepts.Condition.condition) result + + val load : + S.transaction -> + S.connection -> + Concepts.Hash.hash -> + (Protocols.Handle.t, Concepts.Condition.condition) result + + val heading : t -> Concepts.Hash.hash + val predicate : t -> Concepts.Hash.hash option + val local_constraints : t -> Concepts.Hash.hash option + val tuples : t -> Concepts.Hash.hash + val indexes : t -> Concepts.Hash.hash option + val hash : t -> Concepts.Hash.hash + + val assert_tuple : + S.transaction -> t -> Concepts.Blob.t -> (t, Concepts.Condition.condition) result + + val contains_tuple : + S.transaction -> t -> Concepts.Blob.t -> (bool, Concepts.Condition.condition) result +end -- cgit v1.2.3