aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorMarcos Magueta <maguetamarcos@gmail.com>2026-05-11 23:10:27 -0300
committerGitHub <noreply@github.com>2026-05-11 23:10:27 -0300
commite3d3e20dfea253de291d5b31059cd55c0eaabf02 (patch)
tree82cf0d46ea3768171c8a87630cab5011d1ccf2a1
parent4fdf3392868c72ff4c33b70d165a177e97f2fece (diff)
downloadSakura-e3d3e20dfea253de291d5b31059cd55c0eaabf02.tar.gz
Sakura-e3d3e20dfea253de291d5b31059cd55c0eaabf02.zip
Multigroup unified reference for hierarchical access
-rw-r--r--README.org4
-rw-r--r--bin/dune9
-rw-r--r--bin/tree.ml165
-rw-r--r--dune-project12
-rw-r--r--flake.nix8
-rw-r--r--lib/algebra.ml190
-rw-r--r--lib/bplustree.ml245
-rw-r--r--lib/catalog.ml194
-rw-r--r--lib/constraint.ml103
-rw-r--r--lib/constraint.mli91
-rw-r--r--lib/dcl/ast.ml15
-rw-r--r--lib/dcl/executor.ml108
-rw-r--r--lib/dcl/parser.ml14
-rw-r--r--lib/dcl/sublanguage.ml29
-rw-r--r--lib/ddl/ast.ml2
-rw-r--r--lib/ddl/executor.ml26
-rw-r--r--lib/dml/executor.ml28
-rw-r--r--lib/domain.ml10
-rw-r--r--lib/drl/executor.ml12
-rw-r--r--lib/drl/gate.ml79
-rw-r--r--lib/drl/sublanguage.ml9
-rw-r--r--lib/drl_verified/drl_verified.ml67
-rw-r--r--lib/drl_verified/drl_verified.mli23
-rw-r--r--lib/dune4
-rw-r--r--lib/error.ml6
-rw-r--r--lib/hashing.ml4
-rw-r--r--lib/icl/executor.ml4
-rw-r--r--lib/listener.ml227
-rw-r--r--lib/management/branch.ml8
-rw-r--r--lib/management/database.ml136
-rw-r--r--lib/management/diff.ml70
-rw-r--r--lib/management/merge.ml288
-rw-r--r--lib/management/multigroup.ml84
-rw-r--r--lib/manipulation.ml1060
-rw-r--r--lib/merkle.ml70
-rw-r--r--lib/nt.ml41
-rw-r--r--lib/prelude/domains.ml98
-rw-r--r--lib/prelude/standard.ml121
-rw-r--r--lib/prl/executor.ml4
-rw-r--r--lib/prl/runtime.ml7
-rw-r--r--lib/relation.ml239
-rw-r--r--lib/scl/executor.ml49
-rw-r--r--lib/session.ml79
-rw-r--r--lib/storable.ml150
-rw-r--r--lib/sublanguage.ml2
-rw-r--r--lib/sublanguage_types.ml4
-rw-r--r--lib/system.ml9
-rw-r--r--lib/tuple.ml10
-rw-r--r--proof/.gitignore11
-rw-r--r--proof/Drl.v67
-rw-r--r--proof/Extraction.v17
-rw-r--r--proof/Makefile14
-rw-r--r--proof/Relation.v26
-rw-r--r--proof/Schema.v5
-rw-r--r--proof/_CoqProject6
-rw-r--r--proof/drl_verified.ml411
-rw-r--r--run_tree.ps138
-rw-r--r--sakura.opam2
-rw-r--r--shared/shabptree/dune5
-rw-r--r--shared/shabptree/shabptree.c1031
-rw-r--r--test/dune12
-rw-r--r--test/test_relational_engine.ml242
62 files changed, 2635 insertions, 3469 deletions
diff --git a/README.org b/README.org
index f42c1fe..7f69d66 100644
--- a/README.org
+++ b/README.org
@@ -13,4 +13,6 @@ We can ephemeral relations that relations that have its values generated on dema
** Provenance
From where an attribute comes from in a generated relation (ephemeral). For example, if a join occurs and blends the attributes from two different relations, the base relations are references on the new generated ephemeral relation as to identify its origins. This is what enables "updatable views", since we always know the source of an attribute.
** Lineage
-What operation produced an attribute. A join, project, etc. \ No newline at end of file
+What operation produced an attribute. A join, project, etc.
+** Entity Group
+** Entity Type
diff --git a/bin/dune b/bin/dune
index b559855..7ce0e91 100644
--- a/bin/dune
+++ b/bin/dune
@@ -3,4 +3,13 @@
(public_name sakura-server)
(modules server)
(libraries relational_engine unix)
+ (link_deps ../shared/shabptree/sakura_shabptree.dll)
+ (modes byte exe))
+
+(executable
+ (name tree)
+ (public_name sakura-tree)
+ (modules tree)
+ (libraries relational_engine unix)
+ (link_deps ../shared/shabptree/sakura_shabptree.dll)
(modes byte exe))
diff --git a/bin/tree.ml b/bin/tree.ml
new file mode 100644
index 0000000..66f5e1c
--- /dev/null
+++ b/bin/tree.ml
@@ -0,0 +1,165 @@
+open Relational_engine
+
+(* Content-addressed store: hash -> bytes. In production this is NT storage. *)
+let store : (string, bytes) Hashtbl.t = Hashtbl.create 64
+
+(* --- Object construction helpers --- *)
+
+let make_tuple ~relation attributes =
+ let attr_map =
+ List.fold_left
+ (fun acc (name, value) ->
+ Tuple.AttributeMap.add name
+ { Attribute.value = Obj.repr (value : string) }
+ acc)
+ Tuple.AttributeMap.empty attributes
+ in
+ { Tuple.relation; attributes = attr_map }
+
+(* Simulate B+ tree root: hash of sorted tuple hashes. *)
+let tuple_tree_pointer tuples =
+ List.map Hashing.hash_tuple tuples
+ |> List.sort String.compare
+ |> List.fold_left ( ^ ) ""
+ |> Conventions.Hash.hash_text
+
+let make_relation ~name ~schema ~cardinality tuples =
+ (new Relation.stored
+ ~name ~schema ~constraints:None
+ ~cardinality:(Conventions.Cardinality.Finite cardinality)
+ ~membership_criteria:(fun _ -> true)
+ ~lineage:None ~provenance:None)
+ #set_tree_pointer (Some (tuple_tree_pointer tuples))
+
+(* --- Persistence layer (writing into the store) --- *)
+
+let persist_tuple tuple =
+ let hash = Hashing.hash_tuple tuple in
+ Hashtbl.add store hash (Marshal.to_bytes tuple [ Marshal.Closures ]);
+ hash
+
+(* Store an ordered list of child hashes at a tree node address. *)
+let persist_tree_node node_hash (child_hashes : string list) =
+ Hashtbl.add store node_hash (Marshal.to_bytes child_hashes [])
+
+(* Store a relation's metadata (name, schema, tree_pointer) at its hash. *)
+let persist_relation (rel : Relation.stored) =
+ Hashtbl.add store rel#hash
+ (Marshal.to_bytes (rel#name, rel#schema, rel#tree_pointer) [])
+
+(* --- Reconstruction layer (reading from the store) --- *)
+
+let load : 'a. string -> 'a = fun hash ->
+ Marshal.from_bytes (Hashtbl.find store hash) 0
+
+let reconstruct_from_tree_pointer mg_tp =
+ let rel_hashes : string list = load mg_tp in
+ List.map (fun rel_hash ->
+ let (name, schema, tp_opt) : string * Schema.t * string option =
+ load rel_hash
+ in
+ let tuples : Tuple.materialized list =
+ match tp_opt with
+ | None -> []
+ | Some tp ->
+ let tuple_hashes : string list = load tp in
+ List.map load tuple_hashes
+ in
+ (name, schema, tuples)
+ ) rel_hashes
+
+(* --- Printing --- *)
+
+let print_tuple (t : Tuple.materialized) =
+ let fields =
+ Tuple.AttributeMap.bindings t.attributes
+ |> List.map (fun (k, attr) ->
+ k ^ " = " ^ (Obj.magic attr.Attribute.value : string))
+ |> String.concat ", "
+ in
+ Printf.printf " { %s }\n" fields
+
+let print_reconstructed relations =
+ List.iter (fun (name, schema, tuples) ->
+ Printf.printf " relation: %s [%s]\n"
+ name
+ (String.concat ", " (List.map (fun (a, d) -> a ^ ":" ^ d) schema));
+ List.iter print_tuple tuples
+ ) relations
+
+(* --- Main --- *)
+
+let boot () =
+ (* Tuples *)
+ let dept_engineering =
+ make_tuple ~relation:"departments" [ ("id", "1"); ("name", "Engineering") ]
+ in
+ let dept_sales =
+ make_tuple ~relation:"departments" [ ("id", "2"); ("name", "Sales") ]
+ in
+ let emp_alice =
+ make_tuple ~relation:"employees"
+ [ ("dept_id", "1"); ("id", "1"); ("name", "Alice") ]
+ in
+ let emp_bob =
+ make_tuple ~relation:"employees"
+ [ ("dept_id", "2"); ("id", "2"); ("name", "Bob") ]
+ in
+
+ (* Persist tuples and capture their hashes *)
+ let dept_eng_hash = persist_tuple dept_engineering in
+ let dept_sales_hash = persist_tuple dept_sales in
+ let emp_alice_hash = persist_tuple emp_alice in
+ let emp_bob_hash = persist_tuple emp_bob in
+
+ (* Build relations with tree_pointers derived from tuple hashes *)
+ let departments =
+ make_relation
+ ~name:"departments"
+ ~schema:[ ("id", "int"); ("name", "string") ]
+ ~cardinality:2
+ [ dept_engineering; dept_sales ]
+ in
+ let employees =
+ make_relation
+ ~name:"employees"
+ ~schema:[ ("id", "int"); ("name", "string"); ("dept_id", "int") ]
+ ~cardinality:2
+ [ emp_alice; emp_bob ]
+ in
+
+ (* Persist each relation's B+ tree node (tuple hashes) at its tree_pointer *)
+ let dept_tp = Option.get departments#tree_pointer in
+ let emp_tp = Option.get employees#tree_pointer in
+ persist_tree_node dept_tp
+ (List.sort String.compare [ dept_eng_hash; dept_sales_hash ]);
+ persist_tree_node emp_tp
+ (List.sort String.compare [ emp_alice_hash; emp_bob_hash ]);
+
+ (* Persist relation metadata at each relation hash *)
+ persist_relation departments;
+ persist_relation employees;
+
+ (* Build multigroup *)
+ let company =
+ List.fold_left
+ (fun mg rel -> mg#add_relation rel)
+ (new Management.Multigroup.multigroup ~name:"company")
+ [ (departments :> Relation.relation); (employees :> Relation.relation) ]
+ in
+
+ (* Persist multigroup's B+ tree node (relation hashes) at its tree_pointer *)
+ let mg_tp = Option.get company#tree_pointer in
+ persist_tree_node mg_tp
+ (List.sort String.compare [ departments#hash; employees#hash ]);
+
+ Printf.printf "=== Built state ===\n";
+ Printf.printf " multigroup hash: %s\n" company#hash;
+ Printf.printf " tree_pointer: %s\n\n" mg_tp;
+
+ (* Drop everything except the tree_pointer and reconstruct *)
+ Printf.printf "=== Reconstructing from tree_pointer only ===\n";
+ let relations = reconstruct_from_tree_pointer mg_tp in
+ print_reconstructed relations
+
+let () = boot ()
diff --git a/dune-project b/dune-project
index 068860b..de83876 100644
--- a/dune-project
+++ b/dune-project
@@ -24,11 +24,13 @@
(description "A longer description")
(depends
ocaml
- dune
- ppx_protocol_conv
- ppx_protocol_conv_xml_light
- sha
- data-encoding
+ dune
+ ppx_protocol_conv
+ ppx_protocol_conv_xml_light
+ sha
+ ctypes
+ ctypes-foreign
+ data-encoding
(ppx_inline_test :with-test)
ppx_deriving
ppx_sexp_conv
diff --git a/flake.nix b/flake.nix
index ba5bad6..127102c 100644
--- a/flake.nix
+++ b/flake.nix
@@ -47,8 +47,10 @@
include = [
".ocamlformat"
"dune-project"
+ (nix-filter.lib.inDirectory "bplustree")
(nix-filter.lib.inDirectory "bin")
(nix-filter.lib.inDirectory "lib")
+ (nix-filter.lib.inDirectory "shared")
(nix-filter.lib.inDirectory "test")
];
};
@@ -83,6 +85,8 @@
ppx_protocol_conv ]
++ (with ocamlPackages; [
sha
+ ctypes
+ ctypes-foreign
data-encoding
ppx_inline_test
ppx_deriving
@@ -162,6 +166,8 @@
ocamlPackages.ppx_sexp_conv
ocamlPackages.lwt
ocamlPackages.lwt-exit
+ ocamlPackages.ctypes
+ ocamlPackages.ctypes-foreign
ppx_protocol_conv
ppx_protocol_conv_xml_light
];
@@ -234,6 +240,8 @@
# Libraries
# ocamlPackages.menhir
ocamlPackages.sha
+ ocamlPackages.ctypes
+ ocamlPackages.ctypes-foreign
ocamlPackages.data-encoding
ocamlPackages.ppx_inline_test
ocamlPackages.ppx_deriving
diff --git a/lib/algebra.ml b/lib/algebra.ml
index 41b2256..0ef16df 100644
--- a/lib/algebra.ml
+++ b/lib/algebra.ml
@@ -20,36 +20,42 @@ module Make (Storage : Management.Physical.S) = struct
in
go gen 0 []
- let to_generator (storage : storage) (rel : Relation.t) : Generator.t =
- match rel.Relation.generator with
- | Some gen -> gen
- | None -> (
+ let to_generator (storage : storage) (rel : #Relation.relation) : Generator.t =
+ match rel#kind with
+ | `Ephemeral | `Domain ->
+ ((Obj.magic rel) : < generator : Generator.t >)#generator
+ | `Pseudo ->
+ ((Obj.magic rel) : < as_generator : (string * Conventions.AbstractValue.t) list -> Generator.t >)#as_generator []
+ | `Stored -> begin
(* TODO: Avoid materializing all tuple hashes/tuples at once.
Current implementation calls tuple_hashes rel which loads all hashes
into memory, then load_tuples which loads all tuples. This defeats
lazy evaluation and scales badly (fails for billions of tuples).
Replace with paginated tuple_hashes or Merkle streaming to load
hashes/tuples on demand in chunks. *)
- let hashes = Ops.tuple_hashes rel in
- match Ops.load_tuples storage hashes with
+ match Ops.load_tuples storage rel#hash with
| Error _ ->
- fun _pos -> Generator.Error ("Failed to load: " ^ rel.Relation.name)
- | Ok ts -> list_generator (List.map (fun t -> Tuple.Materialized t) ts))
-
- let of_generator ~name ~schema ?constraints ?cardinality gen =
+ fun _pos -> Generator.Error ("Failed to load: " ^ rel#name)
+ | Ok ts -> list_generator (List.map (fun t -> Tuple.Materialized t) ts)
+ end
+ let of_generator ~name ~schema ?constraints ?cardinality generator membership_criteria: Relation.ephemeral =
let cardinality =
match cardinality with
| Some c -> c
| None -> Conventions.Cardinality.AlephZero
in
- Relation.make ~hash:None ~name ~schema ~tree:None ~constraints ~cardinality
- ~generator:(Some gen)
- ~membership_criteria:(fun _ _ -> true)
- ~provenance:Relation.Provenance.Undefined
- ~lineage:(Relation.Lineage.Base "derived") ()
+ new Relation.ephemeral
+ ~name
+ ~schema
+ ~constraints
+ ~cardinality
+ ~generator
+ ~membership_criteria
+ ~provenance:None
+ ~lineage:None
let const_relation (pairs : (string * Conventions.AbstractValue.t) list) :
- Relation.t =
+ Relation.ephemeral =
let attrs =
List.fold_left
(fun acc (k, v) -> Tuple.AttributeMap.add k { Attribute.value = v } acc)
@@ -59,7 +65,9 @@ module Make (Storage : Management.Physical.S) = struct
Tuple.Materialized { Tuple.relation = "const"; attributes = attrs }
in
let schema = List.map (fun (k, _) -> (k, "abstract")) pairs in
- of_generator ~name:"const" ~schema (list_generator [ tuple ])
+ (* TODO: Make it always true for now, gotta rework on this generator *)
+ let membership_criteria _tuple = true in
+ of_generator ~name:"const" ~schema (list_generator [ tuple ]) membership_criteria
(* Operators *)
@@ -76,11 +84,14 @@ module Make (Storage : Management.Physical.S) = struct
in
fun pos -> go gen pos
in
+ (* TODO: Make it always true for now, gotta rework on this generator *)
+ let membership_criteria _tuple = true in
Ok
(of_generator
- ~name:("σ_" ^ rel.Relation.name)
- ~schema:rel.Relation.schema ?constraints:rel.Relation.constraints
- lazy_gen)
+ ~name:("σ_" ^ rel#name)
+ ~schema:rel#schema ?constraints:rel#constraints
+ lazy_gen
+ membership_criteria)
let project storage (attrs : string list) rel =
let gen = to_generator storage rel in
@@ -98,7 +109,7 @@ module Make (Storage : Management.Physical.S) = struct
| other -> other
in
let new_schema =
- List.filter (fun (n, _) -> List.mem n attrs) rel.Relation.schema
+ List.filter (fun (n, _) -> List.mem n attrs) rel#schema
in
let lazy_gen =
let rec go g pos =
@@ -110,7 +121,7 @@ module Make (Storage : Management.Physical.S) = struct
fun pos -> go gen pos
in
let filtered_constraints =
- match rel.Relation.constraints with
+ match rel#constraints with
| None | Some [] -> None
| Some cs -> (
let kept =
@@ -123,10 +134,12 @@ module Make (Storage : Management.Physical.S) = struct
in
match kept with [] -> None | _ -> Some kept)
in
+ (* TODO: Make it always true for now, gotta rework on this generator *)
+ let membership_criteria _tuple = true in
Ok
(of_generator
- ~name:("π_" ^ rel.Relation.name)
- ~schema:new_schema ?constraints:filtered_constraints lazy_gen)
+ ~name:("π_" ^ rel#name)
+ ~schema:new_schema ?constraints:filtered_constraints lazy_gen membership_criteria)
let rename storage (renames : (string * string) list) rel =
let rename_key k =
@@ -144,7 +157,7 @@ module Make (Storage : Management.Physical.S) = struct
in
let gen = to_generator storage rel in
let new_schema =
- List.map (fun (n, d) -> (rename_key n, d)) rel.Relation.schema
+ List.map (fun (n, d) -> (rename_key n, d)) rel#schema
in
let lazy_gen =
let rec go g pos =
@@ -156,7 +169,7 @@ module Make (Storage : Management.Physical.S) = struct
fun pos -> go gen pos
in
let renamed_constraints =
- match rel.Relation.constraints with
+ match rel#constraints with
| None | Some [] -> None
| Some cs ->
Some
@@ -164,12 +177,14 @@ module Make (Storage : Management.Physical.S) = struct
(fun (name, c) -> (name, Constraint.rename_vars renames c))
cs)
in
+ (* TODO: Make it always true for now, gotta rework on this generator *)
+ let membership_criteria _tuple = true in
Ok
(of_generator
- ~name:("ρ_" ^ rel.Relation.name)
- ~schema:new_schema ?constraints:renamed_constraints lazy_gen)
+ ~name:("ρ_" ^ rel#name)
+ ~schema:new_schema ?constraints:renamed_constraints lazy_gen membership_criteria)
- let equijoin storage (attrs : string list) left right =
+ let equijoin storage (attrs : string list) left right: (Relation.ephemeral, error) result =
let get_vals attr_list = function
| Tuple.Materialized t ->
List.map
@@ -191,20 +206,20 @@ module Make (Storage : Management.Physical.S) = struct
| _ -> lt
in
let merged_schema =
- left.Relation.schema
+ left#schema
@ List.filter
(fun (n, _) ->
(not (List.mem n attrs))
- && not (List.exists (fun (m, _) -> m = n) left.Relation.schema))
- right.Relation.schema
+ && not (List.exists (fun (m, _) -> m = n) left#schema))
+ right#schema
in
let merged_constraints =
- match (left.Relation.constraints, right.Relation.constraints) with
+ match (left#constraints, right#constraints) with
| None, None -> None
| Some cs, None | None, Some cs -> Some cs
| Some cs1, Some cs2 -> Some (Constraint.merge cs1 cs2)
in
- let name = "⋈_" ^ left.Relation.name ^ "_" ^ right.Relation.name in
+ let name = "⋈_" ^ left#name ^ "_" ^ right#name in
let rec chain_with_cont g cont pos =
match g pos with
| Generator.Done -> cont pos
@@ -235,86 +250,19 @@ module Make (Storage : Management.Physical.S) = struct
in
from_left left_gen 0
in
- let bindings_of_tuple attrs_list = function
- | Tuple.Materialized m ->
- List.filter_map
- (fun attr ->
- match Tuple.AttributeMap.find_opt attr m.Tuple.attributes with
- | Some a -> Some (attr, a.Attribute.value)
- | None -> None)
- attrs_list
- | _ -> []
- in
- match right.Relation.producer with
- | Some right_producer when attrs <> [] ->
- (* Right is a function predicate: for each left tuple, call the producer
- with that tuple's join-attribute bindings to obtain matching right rows. *)
+
+ let right_gen = to_generator storage right in
+ match drain right_gen with
+ | Error e -> Error e
+ | Ok right_tuples ->
let left_gen = to_generator storage left in
- let make_right_producer_join_gen lgen =
- let rec from_left lgen lpos =
- fun _pos ->
- match lgen (Some lpos) with
- | Generator.Done -> Generator.Done
- | Generator.Error e -> Generator.Error e
- | Generator.Value (lt, next_left) -> (
- let bindings = bindings_of_tuple attrs lt in
- match drain (right_producer bindings) with
- | Error (GeneratorError e | StorageError e) -> Generator.Error e
- | Ok right_tuples -> (
- let lv = get_vals attrs lt in
- let matches =
- List.filter_map
- (fun rt ->
- if get_vals attrs rt = lv then Some (merge lt rt)
- else None)
- right_tuples
- in
- match matches with
- | [] -> from_left next_left (lpos + 1) _pos
- | _ ->
- chain_with_cont (list_generator matches)
- (from_left next_left (lpos + 1))
- _pos))
- in
- from_left lgen 0
- in
+ (* TODO: Make it always true for now, gotta rework on this generator *)
+ let membership_criteria _tuple = true in
Ok
(of_generator ~name ~schema:merged_schema
?constraints:merged_constraints
- (make_right_producer_join_gen left_gen))
- | _ -> (
- let right_gen = to_generator storage right in
- match drain right_gen with
- | Error e -> Error e
- | Ok right_tuples ->
- let left_gen_result =
- match left.Relation.producer with
- | Some left_producer when attrs <> [] ->
- (* Left is a function predicate: collect all left tuples by
- calling the producer once per unique binding set from right. *)
- let unique_bindings =
- right_tuples
- |> List.filter_map (fun rt ->
- let b = bindings_of_tuple attrs rt in
- if List.length b = List.length attrs then Some b
- else None)
- |> List.sort_uniq compare
- in
- List.fold_left
- (fun acc bindings ->
- Result.bind acc (fun ts ->
- match drain (left_producer bindings) with
- | Ok new_ts -> Ok (ts @ new_ts)
- | Error e -> Error e))
- (Ok []) unique_bindings
- |> Result.map list_generator
- | _ -> Ok (to_generator storage left)
- in
- Result.bind left_gen_result (fun left_gen ->
- Ok
- (of_generator ~name ~schema:merged_schema
- ?constraints:merged_constraints
- (make_join_gen left_gen right_tuples))))
+ (make_join_gen left_gen right_tuples)
+ membership_criteria)
let union storage rel1 rel2 =
let gen1 = to_generator storage rel1 in
@@ -328,9 +276,11 @@ module Make (Storage : Management.Physical.S) = struct
in
fun pos -> go gen1 gen2 pos
in
- let name = "∪_" ^ rel1.Relation.name ^ "_" ^ rel2.Relation.name in
+ let name = "∪_" ^ rel1#name ^ "_" ^ rel2#name in
+ (* TODO: Make it always true for now, gotta rework on this generator *)
+ let membership_criteria _tuple = true in
(* Conservative: drop constraints since they only hold if both inputs agree *)
- Ok (of_generator ~name ~schema:rel1.Relation.schema chain_gen)
+ Ok (of_generator ~name ~schema:rel1#schema chain_gen membership_criteria)
let attrs_equal (m1 : Attribute.materialized Tuple.AttributeMap.t)
(m2 : Attribute.materialized Tuple.AttributeMap.t) =
@@ -368,10 +318,12 @@ module Make (Storage : Management.Physical.S) = struct
in
fun pos -> go left_gen pos
in
- let name = "−_" ^ rel1.Relation.name ^ "_" ^ rel2.Relation.name in
+ let name = "−_" ^ rel1#name ^ "_" ^ rel2#name in
+ (* TODO: Make it always true for now, gotta rework on this generator *)
+ let membership_criteria _tuple = true in
Ok
- (of_generator ~name ~schema:rel1.Relation.schema
- ?constraints:rel1.Relation.constraints lazy_gen)
+ (of_generator ~name ~schema:rel1#schema
+ ?constraints:rel1#constraints lazy_gen membership_criteria)
let take storage n rel =
let gen = to_generator storage rel in
@@ -386,11 +338,13 @@ module Make (Storage : Management.Physical.S) = struct
in
fun pos -> go gen n pos
in
+ (* TODO: Make it always true for now, gotta rework on this generator *)
+ let membership_criteria _tuple = true in
Ok
(of_generator
- ~name:("τ_" ^ rel.Relation.name)
- ~schema:rel.Relation.schema ?constraints:rel.Relation.constraints
- ~cardinality:(Conventions.Cardinality.Finite n) lazy_gen)
+ ~name:("τ_" ^ rel#name)
+ ~schema:rel#schema ?constraints:rel#constraints
+ ~cardinality:(Conventions.Cardinality.Finite n) lazy_gen membership_criteria)
let materialize storage rel : (Tuple.materialized list, error) Result.t =
match drain (to_generator storage rel) with
diff --git a/lib/bplustree.ml b/lib/bplustree.ml
new file mode 100644
index 0000000..608ff7e
--- /dev/null
+++ b/lib/bplustree.ml
@@ -0,0 +1,245 @@
+open Ctypes
+
+type tree_handle = unit
+
+module Key : sig
+ type t
+
+ val size : int
+ val of_string : string -> t option
+ val to_string : t -> string
+end = struct
+ type t = string
+
+ let size = 32
+
+ let of_string value =
+ if String.length value = size then Some value else None
+
+ let to_string key = key
+end
+
+type t = { handle : tree_handle ptr; mutable closed : bool }
+
+type error =
+ | Not_found
+ | Invalid_argument
+ | Out_of_memory
+ | Io_error
+ | Corrupt_file
+ | Closed
+ | Unknown of int
+
+let tree_ptr = ptr void
+
+let status_ok = 0
+
+let error_of_status = function
+ | 1 -> Not_found
+ | 2 -> Invalid_argument
+ | 3 -> Out_of_memory
+ | 4 -> Io_error
+ | 5 -> Corrupt_file
+ | status -> Unknown status
+
+let status_to_result = function
+ | status when status = status_ok -> Ok ()
+ | status -> Error (error_of_status status)
+
+module Raw = struct
+ open Foreign
+
+ let load_library () =
+ let default_names =
+ if Sys.win32 then
+ [ "sakura_shabptree.dll" ]
+ else if Sys.os_type = "Unix" then
+ [ "libsakura_shabptree.so" ]
+ else
+ [ "libsakura_shabptree.dylib" ]
+ in
+ let candidates =
+ match Sys.getenv_opt "SAKURA_BPLUSTREE_DLL" with
+ | Some filename -> filename :: default_names
+ | None -> default_names
+ in
+ let rec try_load = function
+ | [] -> None
+ | filename :: rest ->
+ (try Some (Dl.dlopen ~filename ~flags:[ Dl.RTLD_NOW ]) with
+ | Dl.DL_error _ -> try_load rest)
+ in
+ try_load candidates
+
+ let library = lazy (load_library ())
+
+ let bind name signature =
+ match Lazy.force library with
+ | Some library -> foreign ~from:library name signature
+ | None -> foreign name signature
+
+ let create = bind "sakura_bptree_create" (void @-> returning tree_ptr)
+ let free = bind "sakura_bptree_free" (tree_ptr @-> returning void)
+ let len = bind "sakura_bptree_len" (tree_ptr @-> returning uint64_t)
+
+ let put =
+ bind "sakura_bptree_put"
+ (tree_ptr @-> ptr uint8_t @-> ptr void @-> uint64_t @-> returning int)
+
+ let get =
+ bind "sakura_bptree_get"
+ (tree_ptr @-> ptr uint8_t @-> ptr (ptr void) @-> ptr uint64_t @-> returning int)
+
+ let remove =
+ bind "sakura_bptree_remove" (tree_ptr @-> ptr uint8_t @-> returning int)
+
+ let save = bind "sakura_bptree_save" (tree_ptr @-> string @-> returning int)
+ let load = bind "sakura_bptree_load" (string @-> ptr tree_ptr @-> returning int)
+
+ let serialize =
+ bind "sakura_bptree_serialize"
+ (tree_ptr @-> ptr (ptr uint8_t) @-> ptr uint64_t @-> returning int)
+
+ let deserialize =
+ bind "sakura_bptree_deserialize"
+ (ptr uint8_t @-> uint64_t @-> ptr tree_ptr @-> returning int)
+
+ let free_buf = bind "free" (ptr uint8_t @-> returning void)
+
+ let status_string =
+ bind "sakura_bptree_status_string" (int @-> returning string)
+end
+
+let uint8_array_of_string value =
+ let len = String.length value in
+ let array = CArray.make uint8_t len in
+ for i = 0 to len - 1 do
+ CArray.set array i (Unsigned.UInt8.of_int (Char.code value.[i]))
+ done;
+ array
+
+let with_key_ptr key f =
+ let c_key = uint8_array_of_string (Key.to_string key) in
+ f (CArray.start c_key)
+
+let with_value_ptr value f =
+ let len = String.length value in
+ if len = 0 then f null 0
+ else
+ let c_value = uint8_array_of_string value in
+ f (to_voidp (CArray.start c_value)) len
+
+let handle tree =
+ if tree.closed then Error Closed else Ok tree.handle
+
+let free tree =
+ if not tree.closed then begin
+ Raw.free tree.handle;
+ tree.closed <- true
+ end
+
+let close tree =
+ free tree;
+ Ok ()
+
+let create () =
+ let handle = Raw.create () in
+ if is_null handle then Error Out_of_memory
+ else
+ let tree = { handle; closed = false } in
+ Gc.finalise free tree;
+ Ok tree
+
+let length tree =
+ match handle tree with
+ | Error error -> Error error
+ | Ok handle -> Ok (Unsigned.UInt64.to_int (Raw.len handle))
+
+let put tree key value =
+ match handle tree with
+ | Error error -> Error error
+ | Ok handle ->
+ with_key_ptr key @@ fun key_ptr ->
+ with_value_ptr value @@ fun value_ptr value_len ->
+ Raw.put handle key_ptr value_ptr (Unsigned.UInt64.of_int value_len)
+ |> status_to_result
+
+let get tree key =
+ match handle tree with
+ | Error error -> Error error
+ | Ok handle ->
+ with_key_ptr key @@ fun key_ptr ->
+ let value_ptr = allocate (ptr void) null in
+ let len_ptr = allocate uint64_t Unsigned.UInt64.zero in
+ match Raw.get handle key_ptr value_ptr len_ptr |> status_to_result with
+ | Error error -> Error error
+ | Ok () ->
+ let len = Unsigned.UInt64.to_int !@len_ptr in
+ let value = from_voidp uint8_t !@value_ptr in
+ Ok (String.init len (fun i -> Char.chr (Unsigned.UInt8.to_int !@(value +@ i))))
+
+let remove tree key =
+ match handle tree with
+ | Error error -> Error error
+ | Ok handle ->
+ with_key_ptr key @@ fun key_ptr -> Raw.remove handle key_ptr |> status_to_result
+
+let save tree path =
+ match handle tree with
+ | Error error -> Error error
+ | Ok handle -> Raw.save handle path |> status_to_result
+
+let load path =
+ let out = allocate tree_ptr null in
+ match Raw.load path out |> status_to_result with
+ | Ok () ->
+ let tree = { handle = !@out; closed = false } in
+ Gc.finalise free tree;
+ Ok tree
+ | Error error -> Error error
+
+let serialize tree =
+ match handle tree with
+ | Error error -> Error error
+ | Ok handle ->
+ let out_ptr = allocate (ptr uint8_t) (from_voidp uint8_t null) in
+ let out_len = allocate uint64_t Unsigned.UInt64.zero in
+ (match Raw.serialize handle out_ptr out_len |> status_to_result with
+ | Error error -> Error error
+ | Ok () ->
+ let len = Unsigned.UInt64.to_int !@out_len in
+ let p = !@out_ptr in
+ let bytes = Bytes.init len (fun i -> Char.chr (Unsigned.UInt8.to_int !@(p +@ i))) in
+ Raw.free_buf p;
+ Ok (Bytes.to_string bytes))
+
+let deserialize data =
+ let len = String.length data in
+ let c_data = uint8_array_of_string data in
+ let out = allocate tree_ptr null in
+ match
+ Raw.deserialize (CArray.start c_data) (Unsigned.UInt64.of_int len) out
+ |> status_to_result
+ with
+ | Error error -> Error error
+ | Ok () ->
+ let tree = { handle = !@out; closed = false } in
+ Gc.finalise free tree;
+ Ok tree
+
+let error_message error =
+ match error with
+ | Closed -> "tree is closed"
+ | Unknown status -> Raw.status_string status
+ | _ ->
+ let status =
+ match error with
+ | Not_found -> 1
+ | Invalid_argument -> 2
+ | Out_of_memory -> 3
+ | Io_error -> 4
+ | Corrupt_file -> 5
+ | Closed -> 2
+ | Unknown status -> status
+ in
+ Raw.status_string status
diff --git a/lib/catalog.ml b/lib/catalog.ml
deleted file mode 100644
index 605c40a..0000000
--- a/lib/catalog.ml
+++ /dev/null
@@ -1,194 +0,0 @@
-(** Multi-multigroup catalog.
-
- Each multigroup gets its own [Atomic.t], so mutations to independent
- multigroups never contend. The [sakura] multigroup is auto-bootstrapped,
- undeletable, and self-referential: it carries a [public:multigroup] relation
- listing every registered multigroup. *)
-
-type t = {
- multigroups : Management.Database.t Atomic.t Utilities.StringMap.t Atomic.t;
- default_multigroup : string;
- mutex : Mutex.t;
-}
-
-let sakura_name = "sakura"
-
-module Make (S : Management.Physical.S with type error = string) = struct
- open Utilities.Result
- module Manip = Manipulation.Make (S)
-
- type nonrec t = t
-
- let map_error r =
- Result.map_error (fun e -> Sexplib.Sexp.to_string (Error.sexp_of_error e)) r
-
- let get catalog name =
- Utilities.StringMap.find_opt name (Atomic.get catalog.multigroups)
-
- let list catalog =
- Utilities.StringMap.bindings (Atomic.get catalog.multigroups)
- |> List.map fst
-
- let publish_multigroups catalog ~expected ~updated =
- if Atomic.compare_and_set catalog.multigroups expected updated then Ok ()
- else Error "Concurrent multigroup map update detected"
-
- let get_string_attr attr (t : Tuple.materialized) =
- Option.map
- (fun a -> (Obj.magic a.Attribute.value : string))
- (Tuple.AttributeMap.find_opt attr t.attributes)
-
- (** Dynlink every library recorded in public:loaded_library. No-op on a fresh
- DB; effective when loading a previously persisted multigroup. *)
- let hydrate_prl_libraries storage (db : Management.Database.t) =
- match
- Management.Database.get_relation db
- Prelude.Catalog.loaded_library_rel_name
- with
- | None -> ()
- | Some rel -> (
- let hashes =
- match rel.Relation.tree with None -> [] | Some t -> Merkle.keys t
- in
- match Manip.load_tuples storage hashes with
- | Error _ -> ()
- | Ok tuples ->
- List.iter
- (fun t ->
- match get_string_attr "path" t with
- | None -> ()
- | Some path -> ignore (Prl.Runtime.load_library path))
- tuples)
-
- (** Swallow errors: a missing prelude relation is non-fatal. *)
- let register_prelude_relation storage db (rel : Relation.t) =
- match
- Manip.create_immutable_relation storage db ~name:rel.name
- ~schema:rel.schema ~generator:(Option.get rel.generator)
- ~membership_criteria:rel.membership_criteria
- ~cardinality:rel.cardinality ~producer:None
- with
- | Ok (new_db, _) -> new_db
- | Error e ->
- Printf.eprintf "Warning: prelude relation %s: %s\n%!" rel.name
- (Sexplib.Sexp.to_string (Error.sexp_of_error e));
- db
-
- (** Create DB + seed catalog + fold in [prelude_relations] + hydrate PRL. *)
- let bootstrap_multigroup storage ~prelude_relations ~name =
- let* db = Manip.create_database storage ~name |> map_error in
- let db =
- List.fold_left (register_prelude_relation storage) db prelude_relations
- in
- hydrate_prl_libraries storage db;
- Ok db
-
- (** Create additional catalog relations beyond the base six. Used to seed
- [public:multigroup] into the sakura multigroup only. *)
- let seed_extra_catalog storage ~definitions db =
- List.fold_left
- (fun acc (name, schema) ->
- let* db = acc in
- let* new_db, _ =
- Manip.create_relation storage db ~name ~schema |> map_error
- in
- Ok new_db)
- (Ok db) definitions
-
- (** Write a tuple into sakura's [public:multigroup] and update the ref. No-op
- if the relation doesn't exist yet (bootstrap ordering). *)
- let register_in_sakura storage sakura_ref mg_name =
- let rec go () =
- let sakura = Atomic.get sakura_ref in
- match
- Management.Database.get_relation sakura
- Prelude.Catalog.multigroup_rel_name
- with
- | None -> Ok ()
- | Some mg_rel ->
- let tuple = Prelude.Catalog.build_multigroup_tuple mg_name in
- let* new_sakura, _, _ =
- Manip.create_tuple storage sakura mg_rel tuple |> map_error
- in
- if Atomic.compare_and_set sakura_ref sakura new_sakura then Ok ()
- else go ()
- in
- go ()
-
- let create storage ~prelude_relations =
- let* sakura_db =
- bootstrap_multigroup storage ~prelude_relations ~name:sakura_name
- in
- let* sakura_db =
- seed_extra_catalog storage
- ~definitions:Prelude.Catalog.sakura_only_definitions sakura_db
- in
- let sakura_ref = Atomic.make sakura_db in
- let* () = register_in_sakura storage sakura_ref sakura_name in
- let map = Utilities.StringMap.singleton sakura_name sakura_ref in
- Ok
- {
- multigroups = Atomic.make map;
- default_multigroup = sakura_name;
- mutex = Mutex.create ();
- }
-
- let add catalog storage ~prelude_relations name =
- Mutex.protect catalog.mutex (fun () ->
- let map = Atomic.get catalog.multigroups in
- if Utilities.StringMap.mem name map then
- Error (Printf.sprintf "Multigroup %s already exists" name)
- else
- let* db = bootstrap_multigroup storage ~prelude_relations ~name in
- let db_ref = Atomic.make db in
- let* () =
- match Utilities.StringMap.find_opt sakura_name map with
- | Some sakura_ref -> register_in_sakura storage sakura_ref name
- | None -> Ok ()
- in
- let new_map = Utilities.StringMap.add name db_ref map in
- let* () =
- publish_multigroups catalog ~expected:map ~updated:new_map
- in
- Ok db_ref)
-
- let unregister_from_sakura storage sakura_ref mg_name =
- let rec go () =
- let sakura = Atomic.get sakura_ref in
- match
- Management.Database.get_relation sakura
- Prelude.Catalog.multigroup_rel_name
- with
- | None -> Ok ()
- | Some mg_rel ->
- let tuple_hash =
- Hashing.hash_tuple (Prelude.Catalog.build_multigroup_tuple mg_name)
- in
- let* new_sakura, _ =
- Manip.retract_tuple storage sakura mg_rel ~tuple_hash |> map_error
- in
- if Atomic.compare_and_set sakura_ref sakura new_sakura then Ok ()
- else go ()
- in
- go ()
-
- let remove catalog storage name =
- if name = sakura_name then Error "Cannot remove the sakura system catalog"
- else
- Mutex.protect catalog.mutex (fun () ->
- let map = Atomic.get catalog.multigroups in
- if not (Utilities.StringMap.mem name map) then
- Error (Printf.sprintf "Multigroup %s does not exist" name)
- else
- let* () =
- match Utilities.StringMap.find_opt sakura_name map with
- | None -> Ok ()
- | Some sakura_ref ->
- unregister_from_sakura storage sakura_ref name
- in
- let new_map = Utilities.StringMap.remove name map in
- let* () =
- publish_multigroups catalog ~expected:map ~updated:new_map
- in
- Ok ())
-end
diff --git a/lib/constraint.ml b/lib/constraint.ml
index 05442ab..5e282c2 100644
--- a/lib/constraint.ml
+++ b/lib/constraint.ml
@@ -30,6 +30,7 @@ type t =
| Or of t list
| Exists of { variable : attr_name; quantifier : relation_name; body : t }
| Forall of { variable : attr_name; quantifier : relation_name; body : t }
+ | Eq of { left : binding_expr; right : binding_expr }
type diagnostic =
| MembershipFailed of {
@@ -58,7 +59,10 @@ let vars_in (c : t) : attr_name list =
let next = FingerTree.append (FingerTree.of_list cs) rest in
loop set next
| Exists { variable; body; _ } | Forall { variable; body; _ } ->
- loop (StringSet.add variable set) (FingerTree.cons rest body))
+ loop (StringSet.add variable set) (FingerTree.cons rest body)
+ | Eq { left; right } ->
+ let add_expr acc = function Var v -> StringSet.add v acc | Const _ -> acc in
+ loop (add_expr (add_expr set left) right) rest)
in
loop StringSet.empty (FingerTree.singleton c) |> StringSet.elements
@@ -89,6 +93,9 @@ let rename_vars (renames : (attr_name * attr_name) list) : t -> t =
| Forall { variable; quantifier; body } ->
let variable' = rename_name variable in
Forall { variable = variable'; quantifier; body = go body }
+ | Eq { left; right } ->
+ let rename_expr = function Var v -> Var (rename_name v) | Const _ as e -> e in
+ Eq { left = rename_expr left; right = rename_expr right }
in
go
@@ -117,6 +124,7 @@ let rec filter_by_attrs (attrs : attr_name list) (c : t) : t option =
match filter_by_attrs (variable :: attrs) body with
| Some body' -> Some (Forall { variable; quantifier; body = body' })
| None -> None)
+ | Eq _ -> if all_present c then Some c else None
let merge (cs1 : (string * t) list) (cs2 : (string * t) list) :
(string * t) list =
@@ -181,6 +189,17 @@ let rec evaluate (ctx : eval_context) (tuple : Tuple.materialized) (c : t) :
| Error d -> Error d)
| And cs -> evaluate_and ctx tuple cs
| Or cs -> evaluate_or ctx tuple cs
+ | Eq { left; right } ->
+ let resolve = function
+ | Const v -> Some v
+ | Var a -> (
+ match Tuple.AttributeMap.find_opt a tuple.attributes with
+ | Some attr -> Some attr.Attribute.value
+ | None -> None)
+ in
+ (match (resolve left, resolve right) with
+ | Some l, Some r -> Ok (l = r)
+ | _ -> Ok false)
| Exists { variable; quantifier; body } -> (
match ctx.iterate_finite quantifier with
| None -> Error (UnboundedQuantifier { variable; quantifier })
@@ -321,7 +340,8 @@ let polarity_of ?(neg = false) (c : t) : polarity_index =
loop acc' (FingerTree.cons rest (is_neg, body))
| Forall { quantifier; body; _ } ->
let acc' = add_pol acc quantifier (with_neg is_neg Negative) in
- loop acc' (FingerTree.cons rest (is_neg, body)))
+ loop acc' (FingerTree.cons rest (is_neg, body))
+ | Eq _ -> loop acc rest)
in
loop PolarityMap.empty (FingerTree.singleton (neg, c))
@@ -378,7 +398,8 @@ let focused_filter (c : t) (dep_rel : relation_name)
loop acc (FingerTree.cons rest body)
| And cs | Or cs ->
let next = FingerTree.append (FingerTree.of_list cs) rest in
- loop acc next)
+ loop acc next
+ | Eq _ -> loop acc rest)
in
loop [] (FingerTree.singleton c)
@@ -407,7 +428,8 @@ let trigger_constants (c : t) (dep_rel : relation_name) :
loop acc (FingerTree.cons rest body)
| And cs | Or cs ->
let next = FingerTree.append (FingerTree.of_list cs) rest in
- loop acc next)
+ loop acc next
+ | Eq _ -> loop acc rest)
in
loop [] (FingerTree.singleton c)
@@ -521,7 +543,17 @@ let substitute_transition (c : t) (dep_rel : relation_name)
(Visit (body_mode, body))
(BuildForall (variable, quantifier))
rest)
- vals)
+ vals
+ | Eq { left; right } ->
+ let subst_expr subs = function
+ | Var v -> (match BindingMap.find_opt v subs with Some v' -> Const v' | None -> Var v)
+ | Const _ as e -> e
+ in
+ let left', right' = match mode with
+ | SubstituteGo -> (left, right)
+ | SubstituteApply subs -> (subst_expr subs left, subst_expr subs right)
+ in
+ loop rest (Eq { left = left'; right = right' } :: vals))
| BuildNot universe -> (
match vals with
| body :: vals' -> loop rest (Not { body; universe } :: vals')
@@ -570,12 +602,10 @@ let gte ~left ~right =
binding = make_comparison_binding ~left ~right;
}
-let eq ~left ~right =
- MemberOf { target = "equal"; binding = make_comparison_binding ~left ~right }
+let eq ~left ~right = Eq { left; right }
let neq ~left ~right =
- MemberOf
- { target = "not_equal"; binding = make_comparison_binding ~left ~right }
+ Not { body = Eq { left; right }; universe = "" }
let between ~value ~low ~high =
And
@@ -591,3 +621,58 @@ let between ~value ~low ~high =
binding = make_comparison_binding ~left:value ~right:high;
};
]
+
+(** Build membership criteria from schema (validates type membership). Returns a
+ function that takes a tree-lookup function and a tuple, checking schema
+ conformance and tree membership at call time. *)
+let build_membership_criteria
+ ~_name
+ ~schema :
+ (*(string -> Merkle.t option) ->*) Tuple.t -> bool =
+ let value_conforms_to_domain domain_name (value : Conventions.AbstractValue.t)
+ =
+ match domain_name with
+ | "integer" -> Obj.is_int value
+ | "natural" -> Obj.is_int value && (Obj.obj value : int) >= 0
+ | "string" -> Obj.tag value = Obj.string_tag
+ | _ ->
+ (* Unknown domain: could be a relation-typed attribute (nested tuple)
+ or a user-defined domain. Accept for now; full validation would
+ require looking up the target relation's schema. *)
+ true
+ in
+ let n_expected = List.length schema in
+ (* fun tree_of tuple -> *)
+ fun tuple ->
+ match tuple with
+ | Tuple.NonMaterialized _nm ->
+ (* begin match tree_of name with
+ | None -> false
+ | Some t ->
+ Merkle.member nm.hash t
+ && Tuple.AttributeMap.cardinal nm.attributes = n_expected
+ && List.for_all
+ (fun (attr_name, _) ->
+ Tuple.AttributeMap.mem attr_name nm.attributes)
+ schema
+ end *)
+ false
+ | Tuple.Materialized m ->
+ Tuple.AttributeMap.cardinal m.attributes = n_expected
+ && List.for_all
+ (fun (attr_name, domain_name) ->
+ match Tuple.AttributeMap.find_opt attr_name m.attributes with
+ | None -> false
+ | Some attr ->
+ value_conforms_to_domain domain_name attr.Attribute.value)
+ schema
+
+(** Mutation direction for cascade constraint checking *)
+type mutation = Insert | Delete
+
+(** Context for a single tuple mutation, used by cascade checking *)
+type mutation_context = {
+ target_relation : string;
+ transition : (string * Conventions.AbstractValue.t) list;
+ kind : mutation;
+ }
diff --git a/lib/constraint.mli b/lib/constraint.mli
deleted file mode 100644
index c86ef89..0000000
--- a/lib/constraint.mli
+++ /dev/null
@@ -1,91 +0,0 @@
-type relation_name = string
-type attr_name = string
-type binding_expr = Var of attr_name | Const of Conventions.AbstractValue.t
-
-module BindingMap : Map.S with type key = String.t
-
-type binding = binding_expr BindingMap.t
-
-type t =
- | MemberOf of { target : relation_name; binding : binding }
- | Not of { body : t; universe : relation_name }
- | And of t list
- | Or of t list
- | Exists of { variable : attr_name; quantifier : relation_name; body : t }
- | Forall of { variable : attr_name; quantifier : relation_name; body : t }
-
-type diagnostic =
- | MembershipFailed of {
- target : string;
- bound_values : (attr_name * Conventions.AbstractValue.t) list;
- }
- | RelationNotFound of string
- | UnboundedQuantifier of { variable : attr_name; quantifier : relation_name }
- | ConstraintFailures of (string * diagnostic) list
-
-val vars_in : t -> attr_name list
-val rename_vars : (attr_name * attr_name) list -> t -> t
-val filter_by_attrs : attr_name list -> t -> t option
-val merge : (string * t) list -> (string * t) list -> (string * t) list
-val member_of : target:relation_name -> binding:binding -> t
-val not_ : universe:relation_name -> t -> t
-val and_ : t list -> t
-val or_ : t list -> t
-val exists : variable:attr_name -> quantifier:relation_name -> t -> t
-val forall : variable:attr_name -> quantifier:relation_name -> t -> t
-
-type eval_context = {
- check_membership :
- relation_name -> (attr_name * Conventions.AbstractValue.t) list -> bool;
- iterate_finite :
- relation_name -> (attr_name * Conventions.AbstractValue.t) list list option;
-}
-
-val bind :
- binding ->
- Tuple.materialized ->
- (attr_name * Conventions.AbstractValue.t) list
-
-val evaluate :
- eval_context -> Tuple.materialized -> t -> (bool, diagnostic) result
-
-val evaluate_named :
- eval_context ->
- Tuple.materialized ->
- (string * t) list ->
- (bool, diagnostic) result
-
-val evaluate_first_failure :
- eval_context ->
- Tuple.materialized ->
- (string * t) list ->
- (bool, diagnostic) result
-
-type polarity = Positive | Negative | Both
-type polarity_index
-
-val polarity_of : ?neg:bool -> t -> polarity_index
-val polarity_find : relation_name -> polarity_index -> polarity option
-
-type timing = Immediate | Deferred
-
-val focused_filter :
- t ->
- relation_name ->
- (attr_name * Conventions.AbstractValue.t) list ->
- (attr_name * Conventions.AbstractValue.t) list
-
-val trigger_constants :
- t -> relation_name -> (attr_name * Conventions.AbstractValue.t) list
-
-val substitute_transition :
- t -> relation_name -> (attr_name * Conventions.AbstractValue.t) list -> t
-
-val make_comparison_binding : left:binding_expr -> right:binding_expr -> binding
-val lt : left:binding_expr -> right:binding_expr -> t
-val lte : left:binding_expr -> right:binding_expr -> t
-val gt : left:binding_expr -> right:binding_expr -> t
-val gte : left:binding_expr -> right:binding_expr -> t
-val eq : left:binding_expr -> right:binding_expr -> t
-val neq : left:binding_expr -> right:binding_expr -> t
-val between : value:binding_expr -> low:binding_expr -> high:binding_expr -> t
diff --git a/lib/dcl/ast.ml b/lib/dcl/ast.ml
deleted file mode 100644
index a55ec19..0000000
--- a/lib/dcl/ast.ml
+++ /dev/null
@@ -1,15 +0,0 @@
-open Sexplib.Std
-
-type merge_strategy = PreferLeft | PreferRight | RevertToAncestor
-[@@deriving sexp]
-
-type statement =
- | CreateBranch of { name : string; hash : string option [@sexp.option] }
- | Checkout of string
- | GetHead
- | GetBranchTip of string
- | UpdateBranchTip of { name : string; hash : string }
- | Merge of { left : string; right : string; strategy : merge_strategy }
- | Use of string
- | CreateMultigroup of string
-[@@deriving sexp]
diff --git a/lib/dcl/executor.ml b/lib/dcl/executor.ml
deleted file mode 100644
index b83f629..0000000
--- a/lib/dcl/executor.ml
+++ /dev/null
@@ -1,108 +0,0 @@
-module Make (Storage : Management.Physical.S with type error = string) = struct
- module Ops = Manipulation.Make (Storage)
- module Branch = Management.Branch.Make (Storage)
- module MergeOps = Management.Merge.Make (Storage) (Ops)
-
- type error =
- | ParseError of string
- | BranchError of Error.t
- | BranchNotFound of string
- | NoDatabaseAtHash of Conventions.Hash.t
- | StorageError of string
- | MergeError of Error.t
- | Conflict of string
-
- let sexp_of_error e =
- let open Sexplib.Sexp in
- match e with
- | ParseError s -> List [ Atom "parse-error"; Atom s ]
- | BranchError s -> List [ Atom "branch-error"; Error.sexp_of_error s ]
- | BranchNotFound s -> List [ Atom "branch-not-found"; Atom s ]
- | NoDatabaseAtHash s -> List [ Atom "no-database-at-hash"; Atom s ]
- | StorageError s -> List [ Atom "storage-error"; Atom s ]
- | MergeError s -> List [ Atom "merge-error"; Error.sexp_of_error s ]
- | Conflict s -> List [ Atom "conflict"; Atom s ]
-
- let convert_strategy : Ast.merge_strategy -> Management.Merge.strategy =
- function
- | Ast.PreferLeft -> Management.Merge.PreferLeft
- | Ast.PreferRight -> Management.Merge.PreferRight
- | Ast.RevertToAncestor -> Management.Merge.RevertToAncestor
-
- type exec_result =
- | DbResult of Management.Database.t * string
- | Switch of string
- | NewMultigroup of string
-
- let execute (storage : Storage.t) (db : Management.Database.t)
- (stmt : Ast.statement) : (exec_result, error) result =
- match stmt with
- | Ast.CreateBranch { name; hash } -> (
- let tip =
- match hash with Some h -> h | None -> db.Management.Database.hash
- in
- match Branch.create storage ~name ~tip with
- | Error e -> Error (StorageError e)
- | Ok () -> Ok (DbResult (db, "Branch " ^ name ^ " created")))
- | Ast.Checkout branch_name -> (
- match Branch.get_tip storage branch_name with
- | Error e -> Error (StorageError e)
- | Ok None -> Error (BranchNotFound branch_name)
- | Ok (Some tip) -> (
- match Branch.checkout storage branch_name with
- | Error e -> Error (StorageError e)
- | Ok () -> (
- match Ops.load_database storage tip with
- | Error e -> Error (BranchError e)
- | Ok None -> Error (NoDatabaseAtHash tip)
- | Ok (Some loaded_db) ->
- Ok (DbResult (loaded_db, "HEAD:" ^ branch_name)))))
- | Ast.GetHead -> (
- match Branch.get_head storage with
- | Error e -> Error (StorageError e)
- | Ok None -> Ok (DbResult (db, "HEAD is unset"))
- | Ok (Some name) -> Ok (DbResult (db, "HEAD:" ^ name)))
- | Ast.GetBranchTip name -> (
- match Branch.get_tip storage name with
- | Error e -> Error (StorageError e)
- | Ok None -> Error (BranchNotFound name)
- | Ok (Some hash) -> Ok (DbResult (db, "branch:" ^ name ^ "=" ^ hash)))
- | Ast.UpdateBranchTip { name; hash } -> (
- match Branch.update_tip storage ~name ~tip:hash with
- | Error e -> Error (StorageError e)
- | Ok () -> Ok (DbResult (db, "Branch " ^ name ^ " updated")))
- | Ast.Merge { left; right; strategy } -> (
- match (Branch.get_tip storage left, Branch.get_tip storage right) with
- | Error e, _ | _, Error e -> Error (StorageError e)
- | Ok None, _ -> Error (BranchNotFound left)
- | _, Ok None -> Error (BranchNotFound right)
- | Ok (Some left_tip), Ok (Some right_tip) -> (
- let strat = convert_strategy strategy in
- match
- MergeOps.merge ~storage ~strategy:strat ~left_tip ~right_tip
- with
- | Error e -> Error (MergeError e)
- | Ok (Management.Merge.Failed conflicts) ->
- let msgs =
- List.map
- (function
- | Management.Merge.TupleConflict { relation; hash } ->
- "tuple conflict in " ^ relation ^ " (" ^ hash ^ ")"
- | Management.Merge.SchemaConflict r ->
- "schema conflict in " ^ r
- | Management.Merge.ConstraintConflict r ->
- "constraint conflict in " ^ r)
- conflicts
- in
- Error (Conflict ("Merge failed: " ^ String.concat "; " msgs))
- | Ok (Management.Merge.Clean merged_db) ->
- let _ =
- Branch.update_tip storage ~name:left
- ~tip:merged_db.Management.Database.hash
- in
- Ok (DbResult (merged_db, "Merged:" ^ right ^ "→" ^ left))))
- | Ast.Use multigroup -> Ok (Switch multigroup)
- | Ast.CreateMultigroup name -> Ok (NewMultigroup name)
-end
-
-module Memory = Make (Management.Physical.Memory)
diff --git a/lib/dcl/parser.ml b/lib/dcl/parser.ml
deleted file mode 100644
index 79d8fc7..0000000
--- a/lib/dcl/parser.ml
+++ /dev/null
@@ -1,14 +0,0 @@
-type error = ParseError of string
-
-let of_sexp sexp =
- (* ppx_sexp_conv encodes no-argument variants as bare atoms, so
- unwrap a single-element list (e.g. (GetHead)) → atom (GetHead). *)
- let sexp =
- match sexp with Sexplib.Sexp.List [ atom ] -> atom | other -> other
- in
- match Ast.statement_of_sexp sexp with
- | stmt -> Ok stmt
- | exception exn -> Error (ParseError (Printexc.to_string exn))
-
-let of_string s = of_sexp (Sexplib.Sexp.of_string s)
-let to_string stmt = Ast.sexp_of_statement stmt |> Sexplib.Sexp.to_string_hum
diff --git a/lib/dcl/sublanguage.ml b/lib/dcl/sublanguage.ml
deleted file mode 100644
index 34d4c62..0000000
--- a/lib/dcl/sublanguage.ml
+++ /dev/null
@@ -1,29 +0,0 @@
-module Make (Storage : Management.Physical.S with type error = string) = struct
- module Exec = Executor.Make (Storage)
-
- type configuration = unit
- type storage = Storage.t
- type ast = Ast.statement
- type error = Exec.error
-
- let name = "dcl"
- let parse _ = Ok ()
-
- let parse_sexp sexp =
- match Parser.of_sexp sexp with
- | Ok r -> Ok r
- | Error (Parser.ParseError s) -> Error (Exec.ParseError s)
-
- let execute storage db ast =
- match Exec.execute storage db ast with
- | Ok (Exec.DbResult (db, _)) -> Ok (Sublanguage_types.Transition db)
- | Ok (Exec.Switch multigroup) ->
- Ok (Sublanguage_types.SessionSwitch multigroup)
- | Ok (Exec.NewMultigroup name) ->
- Ok (Sublanguage_types.CreateMultigroup name)
- | Error e -> Error e
-
- let sexp_of_error = Exec.sexp_of_error
-end
-
-module Memory = Make (Management.Physical.Memory)
diff --git a/lib/ddl/ast.ml b/lib/ddl/ast.ml
index ee39edb..e1e5bad 100644
--- a/lib/ddl/ast.ml
+++ b/lib/ddl/ast.ml
@@ -8,7 +8,7 @@ type cardinality_spec =
[@@deriving sexp]
type statement =
- | CreateDatabase of string
+ | CreateMultigroup of string
| CreateRelation of { name : string; schema : (string * string) list }
| RetractRelation of string
| ClearRelation of string
diff --git a/lib/ddl/executor.ml b/lib/ddl/executor.ml
index 2a0c205..7800466 100644
--- a/lib/ddl/executor.ml
+++ b/lib/ddl/executor.ml
@@ -17,7 +17,7 @@ module Make (Storage : Management.Physical.S) = struct
let wrap_manip r = Result.map_error (fun e -> ManipulationError e) r
let get_rel db name =
- Ops.get_relation db ~name |> Option.to_result ~none:(RelationNotFound name)
+ Ops.get_relation db name |> Option.to_result ~none:(RelationNotFound name)
let convert_cardinality : Ast.cardinality_spec -> Conventions.Cardinality.t =
function
@@ -26,12 +26,12 @@ module Make (Storage : Management.Physical.S) = struct
| Ast.Continuum -> Conventions.Cardinality.Continuum
| Ast.ConstrainedFinite -> Conventions.Cardinality.ConstrainedFinite
- let execute (storage : Storage.t) (db : Management.Database.t)
- (stmt : Ast.statement) : (Management.Database.t * string, error) result =
+ let execute (storage : Storage.t) (db : Management.Multigroup.multigroup)
+ (stmt : Ast.statement) : (Management.Multigroup.multigroup * string, error) result =
match stmt with
- | Ast.CreateDatabase name ->
- let* db = Ops.create_database storage ~name |> wrap_manip in
- Ok (db, "Database created: " ^ name)
+ | Ast.CreateMultigroup name ->
+ let* db = Ops.create_multigroup storage name |> wrap_manip in
+ Ok (db, "Multigroup created: " ^ name)
| Ast.CreateRelation { name; schema = schema_pairs } ->
let schema =
List.fold_left
@@ -39,23 +39,27 @@ module Make (Storage : Management.Physical.S) = struct
Schema.empty schema_pairs
in
let* db, _ =
- Ops.create_relation storage db ~name ~schema |> wrap_manip
+ Ops.create_relation storage db name schema |> wrap_manip
in
Ok (db, "Relation created: " ^ name)
| Ast.RetractRelation name ->
- let* db = Ops.retract_relation storage db ~name |> wrap_manip in
+ let* db = Ops.retract_relation storage db name |> wrap_manip in
Ok (db, "Relation retracted: " ^ name)
| Ast.ClearRelation name ->
let* rel = get_rel db name in
let* db, _ = Ops.clear_relation storage db rel |> wrap_manip in
Ok (db, "Relation cleared: " ^ name)
| Ast.RegisterDomain { name; cardinality } ->
- let domain =
- Domain.make ~name
+ let domain: Relation.domain =
+ new Relation.domain
+ ~name
~generator:(fun _ -> Generator.Error "not enumerable via DDL")
~membership_criteria:(fun _ -> true)
~cardinality:(convert_cardinality cardinality)
- ~compare:Stdlib.compare
+ ~schema:Schema.empty
+ ~provenance:None
+ ~lineage:None
+ ~constraints:None
in
let* db = Ops.register_domain storage db domain |> wrap_manip in
Ok (db, "Domain registered: " ^ name)
diff --git a/lib/dml/executor.ml b/lib/dml/executor.ml
index a4b4e21..ed50479 100644
--- a/lib/dml/executor.ml
+++ b/lib/dml/executor.ml
@@ -25,7 +25,7 @@ module Make (Storage : Management.Physical.S) = struct
let wrap_alg e = AlgebraError e
let get_rel db name =
- match Ops.get_relation db ~name with
+ match Ops.get_relation db name with
| Some r -> Ok r
| None -> Error (RelationNotFound name)
@@ -55,18 +55,18 @@ module Make (Storage : Management.Physical.S) = struct
let materialize_tuples storage rel =
Result.map_error wrap_alg (Alg.materialize storage rel)
- let execute (storage : Storage.t) (db : Management.Database.t)
- (stmt : Ast.statement) : (Management.Database.t, error) result =
+ let execute (storage : Storage.t) (db : Management.Multigroup.multigroup)
+ (stmt : Ast.statement) : (Management.Multigroup.multigroup, error) result =
match stmt with
| Ast.InsertTuple { relation; attributes } ->
let* rel = get_rel db relation in
- let tuple = build_tuple ~relation:rel.Relation.name attributes in
+ let tuple = build_tuple ~relation:rel#name attributes in
let* db, _, _ = Ops.create_tuple storage db rel tuple |> wrap_manip in
Ok db
| Ast.InsertTuples { relation; tuples } ->
let* rel = get_rel db relation in
let tuple_list =
- List.map (build_tuple ~relation:rel.Relation.name) tuples
+ List.map (build_tuple ~relation:rel#name) tuples
in
let* db, _, _ =
Ops.create_tuples storage db rel tuple_list |> wrap_manip
@@ -74,10 +74,10 @@ module Make (Storage : Management.Physical.S) = struct
Ok db
| Ast.DeleteTuple { relation; attributes } ->
let* rel = get_rel db relation in
- let tuple = build_tuple ~relation:rel.Relation.name attributes in
+ let tuple = build_tuple ~relation:rel#name attributes in
let tuple_hash = Hashing.hash_tuple tuple in
let* db, _ =
- Ops.retract_tuple storage db rel ~tuple_hash |> wrap_manip
+ Ops.retract_tuple storage db rel tuple_hash |> wrap_manip
in
Ok db
| Ast.Assign { target; body } ->
@@ -87,7 +87,7 @@ module Make (Storage : Management.Physical.S) = struct
let* db, rel = Ops.clear_relation storage db rel |> wrap_manip in
let* db, _, _ =
Ops.create_tuples storage db rel
- (List.map (retarget rel.Relation.name) tuples)
+ (List.map (retarget rel#name) tuples)
|> wrap_manip
in
Ok db
@@ -97,7 +97,7 @@ module Make (Storage : Management.Physical.S) = struct
let* tuples = materialize_tuples storage result_rel in
let* db, _, _ =
Ops.create_tuples storage db rel
- (List.map (retarget rel.Relation.name) tuples)
+ (List.map (retarget rel#name) tuples)
|> wrap_manip
in
Ok db
@@ -107,16 +107,16 @@ module Make (Storage : Management.Physical.S) = struct
let common =
List.filter_map
(fun (n, _) ->
- if List.exists (fun (m, _) -> m = n) pred_rel.Relation.schema then
+ if List.exists (fun (m, _) -> m = n) pred_rel#schema then
Some n
else None)
- rel.Relation.schema
+ rel#schema
in
let* joined =
Alg.equijoin storage common rel pred_rel |> Result.map_error wrap_alg
in
let* to_delete =
- Alg.project storage (List.map fst rel.Relation.schema) joined
+ Alg.project storage (List.map fst rel#schema) joined
|> Result.map_error wrap_alg
in
let* tuples = materialize_tuples storage to_delete in
@@ -125,10 +125,10 @@ module Make (Storage : Management.Physical.S) = struct
let* db = acc in
let* rel = get_rel db target in
let tuple_hash =
- Hashing.hash_tuple (retarget rel.Relation.name t)
+ Hashing.hash_tuple (retarget rel#name t)
in
let* db, _ =
- Ops.retract_tuple storage db rel ~tuple_hash |> wrap_manip
+ Ops.retract_tuple storage db rel tuple_hash |> wrap_manip
in
Ok db)
(Ok db) tuples
diff --git a/lib/domain.ml b/lib/domain.ml
deleted file mode 100644
index 87ed1a9..0000000
--- a/lib/domain.ml
+++ /dev/null
@@ -1,10 +0,0 @@
-type t = {
- name : Conventions.Name.t;
- generator : Generator.t;
- membership_criteria : Tuple.t -> bool;
- cardinality : Conventions.Cardinality.t;
- compare : Conventions.AbstractValue.t -> Conventions.AbstractValue.t -> int;
-}
-
-let make ~name ~generator ~membership_criteria ~cardinality ~compare =
- { name; generator; membership_criteria; cardinality; compare }
diff --git a/lib/drl/executor.ml b/lib/drl/executor.ml
index 1172553..41bdde5 100644
--- a/lib/drl/executor.ml
+++ b/lib/drl/executor.ml
@@ -24,22 +24,22 @@ module Make (Storage : Management.Physical.S) = struct
let common =
List.filter_map
(fun (n, _) ->
- if List.exists (fun (m, _) -> m = n) filter.Relation.schema then
+ if List.exists (fun (m, _) -> m = n) filter#schema then
Some n
else None)
- source.Relation.schema
+ source#schema
in
- let source_attrs = List.map fst source.Relation.schema in
+ let source_attrs = List.map fst source#schema in
Result.bind
(wrap (Alg.equijoin storage common source filter))
(fun joined -> wrap (Alg.project storage source_attrs joined))
- let rec execute (storage : Storage.t) (db : Management.Database.t)
- (q : Ast.query) : (Relation.t, error) Result.t =
+ let rec execute (storage : Storage.t) (db : Management.Multigroup.multigroup)
+ (q : Ast.query) : (Relation.ephemeral, error) Result.t =
let ( >>= ) = Result.bind in
match q with
| Ast.Base name -> (
- match Ops.get_relation db ~name with
+ match Ops.get_relation db name with
| None -> Error (RelationNotFound name)
| Some rel -> Ok rel)
| Ast.Const pairs ->
diff --git a/lib/drl/gate.ml b/lib/drl/gate.ml
deleted file mode 100644
index a314bce..0000000
--- a/lib/drl/gate.ml
+++ /dev/null
@@ -1,79 +0,0 @@
-(** Finiteness gate for DRL queries.
-
- Converts Sakura types to Coq-extracted types and calls the verified
- [predicted_finite] function. Rejects queries whose result cannot be
- statically proven finite. *)
-
-(* -- string -> char list impedance --------------------------------- *)
-
-let string_to_chars (s : string) : char list =
- List.init (String.length s) (String.get s)
-
-(* -- Sakura AST -> extracted AST ----------------------------------- *)
-
-let rec query_of_ast : Ast.query -> Drl_verified.query = function
- | Ast.Base name -> Drl_verified.Base (string_to_chars name)
- | Ast.Const pairs ->
- Drl_verified.Const
- (List.map
- (fun (k, v) -> (string_to_chars k, value_of_ast_value v))
- pairs)
- | Ast.Select (filter, source) ->
- Drl_verified.Select (query_of_ast filter, query_of_ast source)
- | Ast.Join (attrs, q1, q2) ->
- Drl_verified.Join
- (List.map string_to_chars attrs, query_of_ast q1, query_of_ast q2)
- | Ast.Cartesian (q1, q2) ->
- Drl_verified.Cartesian (query_of_ast q1, query_of_ast q2)
- | Ast.Project (attrs, q) ->
- Drl_verified.Project (List.map string_to_chars attrs, query_of_ast q)
- | Ast.Rename (renames, q) ->
- Drl_verified.Rename
- ( List.map (fun (o, n) -> (string_to_chars o, string_to_chars n)) renames,
- query_of_ast q )
- | Ast.Union (q1, q2) -> Drl_verified.Union (query_of_ast q1, query_of_ast q2)
- | Ast.Diff (q1, q2) -> Drl_verified.Diff (query_of_ast q1, query_of_ast q2)
- | Ast.Take (n, q) -> Drl_verified.Take (n, query_of_ast q)
-
-and value_of_ast_value : Ast.value -> Drl_verified.literal = function
- | Ast.Int n -> Drl_verified.LitInt n
- (* The Coq model has no float literal. This truncation is harmless:
- the finiteness gate inspects only relation names and query structure,
- never literal values. *)
- | Ast.Float f -> Drl_verified.LitInt (int_of_float f)
- | Ast.Str s -> Drl_verified.LitStr (string_to_chars s)
- | Ast.Bool b -> Drl_verified.LitBool b
-
-(* -- database snapshot --------------------------------------------- *)
-
-let is_finite (c : Conventions.Cardinality.t) : bool =
- match c with
- | Conventions.Cardinality.Finite _ | Conventions.Cardinality.ConstrainedFinite
- ->
- true
- | Conventions.Cardinality.AlephZero | Conventions.Cardinality.Continuum ->
- false
-
-let database_snapshot (db : Management.Database.t) : Drl_verified.database =
- Management.Database.RelationMap.fold
- (fun name (rel : Relation.t) acc ->
- let entry : Drl_verified.relation =
- {
- rel_name = string_to_chars name;
- rel_finite = is_finite rel.cardinality;
- }
- in
- (string_to_chars name, entry) :: acc)
- db.relations []
-
-(* -- public interface ---------------------------------------------- *)
-
-let admit (db : Management.Database.t) (ast : Ast.query) : (unit, string) result
- =
- let vdb = database_snapshot db in
- let vq = query_of_ast ast in
- match Drl_verified.predicted_finite vdb vq with
- | Some true -> Ok ()
- | Some false ->
- Error "query produces potentially infinite result; use Take to bound it"
- | None -> Error "referenced relation not found in finiteness check"
diff --git a/lib/drl/sublanguage.ml b/lib/drl/sublanguage.ml
index 29047c3..f47129f 100644
--- a/lib/drl/sublanguage.ml
+++ b/lib/drl/sublanguage.ml
@@ -15,12 +15,9 @@ module Make (Storage : Management.Physical.S) = struct
| Error (Parser.ParseError s) -> Error (Exec.ParseError s)
let execute storage db ast =
- match Gate.admit db ast with
- | Error msg -> Error (Exec.ParseError msg)
- | Ok () -> (
- match Exec.execute storage db ast with
- | Ok rel -> Ok (Sublanguage_types.Query rel)
- | Error e -> Error e)
+ match Exec.execute storage db ast with
+ | Ok rel -> Ok (Sublanguage_types.Query (rel :> Relation.relation))
+ | Error e -> Error e
let sexp_of_error = Exec.sexp_of_error
end
diff --git a/lib/drl_verified/drl_verified.ml b/lib/drl_verified/drl_verified.ml
deleted file mode 100644
index 868af2a..0000000
--- a/lib/drl_verified/drl_verified.ml
+++ /dev/null
@@ -1,67 +0,0 @@
-(** val eqb : char list -> char list -> bool **)
-
-let rec eqb s1 s2 =
- match s1 with
- | [] -> ( match s2 with [] -> true | _ :: _ -> false)
- | c1 :: s1' -> (
- match s2 with
- | [] -> false
- | c2 :: s2' -> if c1 = c2 then eqb s1' s2' else false)
-
-type attr_name = char list
-type relation = { rel_name : char list; rel_finite : bool }
-type database = (char list * relation) list
-
-(** val db_lookup : char list -> database -> relation option **)
-
-let rec db_lookup name = function
- | [] -> None
- | p :: rest ->
- let n, r = p in
- if eqb name n then Some r else db_lookup name rest
-
-type literal = LitInt of int | LitStr of char list | LitBool of bool
-
-type query =
- | Base of char list
- | Const of (attr_name * literal) list
- | Select of query * query
- | Join of attr_name list * query * query
- | Cartesian of query * query
- | Project of attr_name list * query
- | Rename of (attr_name * attr_name) list * query
- | Union of query * query
- | Diff of query * query
- | Take of int * query
-
-(** val predicted_finite : database -> query -> bool option **)
-
-let rec predicted_finite db = function
- | Base name -> (
- match db_lookup name db with Some r -> Some r.rel_finite | None -> None)
- | Select (_, source) -> predicted_finite db source
- | Join (_, q1, q2) -> (
- match predicted_finite db q1 with
- | Some f1 -> (
- match predicted_finite db q2 with
- | Some f2 -> Some (f1 && f2)
- | None -> None)
- | None -> None)
- | Cartesian (q1, q2) -> (
- match predicted_finite db q1 with
- | Some f1 -> (
- match predicted_finite db q2 with
- | Some f2 -> Some (f1 && f2)
- | None -> None)
- | None -> None)
- | Project (_, q0) -> predicted_finite db q0
- | Rename (_, q0) -> predicted_finite db q0
- | Union (q1, q2) -> (
- match predicted_finite db q1 with
- | Some f1 -> (
- match predicted_finite db q2 with
- | Some f2 -> Some (f1 && f2)
- | None -> None)
- | None -> None)
- | Diff (q1, _) -> predicted_finite db q1
- | _ -> Some true
diff --git a/lib/drl_verified/drl_verified.mli b/lib/drl_verified/drl_verified.mli
deleted file mode 100644
index dac930e..0000000
--- a/lib/drl_verified/drl_verified.mli
+++ /dev/null
@@ -1,23 +0,0 @@
-val eqb : char list -> char list -> bool
-
-type attr_name = char list
-type relation = { rel_name : char list; rel_finite : bool }
-type database = (char list * relation) list
-
-val db_lookup : char list -> database -> relation option
-
-type literal = LitInt of int | LitStr of char list | LitBool of bool
-
-type query =
- | Base of char list
- | Const of (attr_name * literal) list
- | Select of query * query
- | Join of attr_name list * query * query
- | Cartesian of query * query
- | Project of attr_name list * query
- | Rename of (attr_name * attr_name) list * query
- | Union of query * query
- | Diff of query * query
- | Take of int * query
-
-val predicted_finite : database -> query -> bool option
diff --git a/lib/dune b/lib/dune
index 9a7cd0b..a48798f 100644
--- a/lib/dune
+++ b/lib/dune
@@ -13,6 +13,8 @@
lwt-exit
batteries
ppx_protocol_conv_xml_light
- sexplib)
+ sexplib
+ ctypes
+ ctypes.foreign)
(preprocess
(pps ppx_deriving.show ppx_sexp_conv ppx_protocol_conv)))
diff --git a/lib/error.ml b/lib/error.ml
index cf02845..6215320 100644
--- a/lib/error.ml
+++ b/lib/error.ml
@@ -11,8 +11,8 @@ type t =
(* TODO: think of a better way to manage and serialize sublanguage errors *)
| SublanguageError of Sexplib.Sexp.t
| Conflict of {
- old_db : Management.Database.t;
- new_db : Management.Database.t;
+ old_db : Management.Multigroup.multigroup;
+ new_db : Management.Multigroup.multigroup;
}
| SyntaxError of string
| MultigroupNotFound of string
@@ -39,4 +39,4 @@ let sexp_of_error e =
| MultigroupNotFound s -> error "multigroup-not-found" [ "name" <+> Atom s ]
| Conflict { old_db; new_db } ->
error "conflict"
- [ "old-hash" <+> Atom old_db.hash; "new-hash" <+> Atom new_db.hash ]
+ [ "old-hash" <+> Atom old_db#hash; "new-hash" <+> Atom new_db#hash ]
diff --git a/lib/hashing.ml b/lib/hashing.ml
index 9475e46..ff8436b 100644
--- a/lib/hashing.ml
+++ b/lib/hashing.ml
@@ -48,9 +48,9 @@ let hash_tuple (tuple : Tuple.materialized) : Conventions.Hash.t =
- The relation name
- The schema (attribute names and types)
- The merkle tree root hash (representing all tuples) *)
-let hash_relation ~name ~(schema : Schema.t) ~tree : Conventions.Hash.t =
+(* let hash_relation ~name ~(schema : Schema.t) ~tree : Conventions.Hash.t =
let schema_str = Schema.to_string schema in
let tree_hash =
match Merkle.root_hash tree with Some h -> h | None -> "empty"
in
- Conventions.Hash.hash_text (name ^ "|" ^ schema_str ^ "|" ^ tree_hash)
+ Conventions.Hash.hash_text (name ^ "|" ^ schema_str ^ "|" ^ tree_hash) *)
diff --git a/lib/icl/executor.ml b/lib/icl/executor.ml
index 6f85b60..8de60e0 100644
--- a/lib/icl/executor.ml
+++ b/lib/icl/executor.ml
@@ -39,8 +39,8 @@ module Make (Storage : Management.Physical.S) = struct
| Ast.Forall { variable; quantifier; body } ->
Constraint.forall ~variable ~quantifier (convert_body body)
- let execute (storage : Storage.t) (db : Management.Database.t)
- (stmt : Ast.statement) : (Management.Database.t * string, error) result =
+ let execute (storage : Storage.t) (db : Management.Multigroup.multigroup)
+ (stmt : Ast.statement) : (Management.Multigroup.multigroup * string, error) result =
match stmt with
| Ast.RegisterConstraint { constraint_name; relation_name; body } -> (
let runtime_body = convert_body body in
diff --git a/lib/listener.ml b/lib/listener.ml
index e873b3f..5e8f55d 100644
--- a/lib/listener.ml
+++ b/lib/listener.ml
@@ -2,11 +2,9 @@ module type LISTENER = functor
(T : Transport.TRANSPORT)
(S : Management.Physical.S with type error = string)
-> sig
- val run : T.t -> Catalog.t -> S.t -> unit
+ val run : T.t -> S.t -> unit
end
-type connection_context = { mutable current_multigroup : string }
-
module Make : LISTENER =
functor
(T : Transport.TRANSPORT)
@@ -15,9 +13,13 @@ functor
struct
module type SubS = Sublanguage.S with type storage = S.t
- module BranchOps = Management.Branch.Make (S)
module AlgebraOps = Algebra.Make (S)
- module CatalogOps = Catalog.Make (S)
+
+ (* Per-connection state: the client must issue (use "name") before
+ any sublanguage command is accepted. *)
+ type conn_state =
+ | NoMultigroup
+ | Active of Nt.handle * Management.Multigroup.multigroup
let read_command input =
try Ok (Sexplib.Sexp.input_sexp input)
@@ -33,7 +35,7 @@ functor
(module Ddl.Sublanguage.Make (S) : SubS);
(module Dml.Sublanguage.Make (S) : SubS);
(module Icl.Sublanguage.Make (S) : SubS);
- (module Dcl.Sublanguage.Make (S) : SubS);
+ (* (module Dcl.Sublanguage.Make (S) : SubS); *)
(module Prl.Sublanguage.Make (S) : SubS);
(module Scl.Sublanguage.Make (S) : SubS);
]
@@ -45,7 +47,7 @@ functor
Utilities.StringMap.find_opt tag sublanguages
|> Option.to_result ~none:(Error.UnrecognizedSublanguage tag)
- let execute storage db expr (module Language : SubS) =
+ let execute_sublanguage storage db expr (module Language : SubS) =
Language.parse_sexp expr
|> fmap (Language.execute storage db)
|> Result.map_error (fun e ->
@@ -53,41 +55,20 @@ functor
let execute_command storage db = function
| Sexplib.Sexp.(List [ Atom tag; expr ]) ->
- find_language tag |> fmap (execute storage db expr)
+ find_language tag |> fmap (execute_sublanguage storage db expr)
| s -> Error (Error.MalformedExpression s)
- let advance_head_branch storage new_hash =
- match BranchOps.get_head storage with
- | Ok (Some branch_name) ->
- ignore (BranchOps.update_tip storage ~name:branch_name ~tip:new_hash)
- | _ -> ()
-
- let perform storage catalog ctx db_head old_db result =
+ (* Thread handle and db through the connection after a sublanguage result. *)
+ let perform handle db result =
match result with
- | Sublanguage.Transition new_db ->
- if Atomic.compare_and_set db_head old_db new_db then (
- advance_head_branch storage new_db.hash;
- Ok result)
- else Error (Error.Conflict { old_db; new_db })
- | Sublanguage.SessionSwitch multigroup -> (
- match CatalogOps.get catalog multigroup with
- | None -> Error (Error.MultigroupNotFound multigroup)
- | Some _ ->
- ctx.current_multigroup <- multigroup;
- Ok result)
- | Sublanguage.CreateMultigroup name -> (
- match
- CatalogOps.add catalog storage
- ~prelude_relations:Prelude.Standard.prelude_relations name
- with
- | Error e -> Error (Error.SyntaxError e)
- | Ok _ -> Ok result)
- | _ -> Ok result
+ | Sublanguage_types.Transition new_db -> Ok (handle, new_db, result)
+ | Sublanguage_types.SessionSwitch _ ->
+ Error (Error.SyntaxError "SessionSwitch not supported")
+ | Sublanguage_types.CreateMultigroup _ ->
+ Error (Error.SyntaxError "CreateMultigroup not supported")
+ | _ -> Ok (handle, db, result)
- let get_branch storage =
- match BranchOps.get_head storage with Ok (Some name) -> name | _ -> "--"
-
- let current_limit = 16 (* TODO: make the limit per-connection? *)
+ let current_limit = 16
let materialize_generator gen limit =
let rec go gen pos acc count =
@@ -108,7 +89,7 @@ functor
in
go gen 0 [] 0
- let materialize_relation storage (rel : Relation.t) limit =
+ let materialize_relation storage (rel : Relation.relation) limit =
let gen = AlgebraOps.to_generator storage rel in
materialize_generator gen limit
@@ -122,13 +103,40 @@ functor
Atom k; Conventions.AbstractValue.sexp_of_t attr.Attribute.value;
]))
- (* TODO: does our network protocol make sense? *)
- let serialize storage (db : Management.Database.t) =
+ let print_with_time str =
+ (* TODO: a proper logger *)
+ let now = Unix.gettimeofday () in
+ let tm = Unix.localtime now in
+ let orange = "\027[38;5;208m" in
+ let reset = "\027[0m" in
+ let formatted_time =
+ Printf.sprintf "%04d-%02d-%02d %02d:%02d:%02d" (tm.Unix.tm_year + 1900)
+ (tm.Unix.tm_mon + 1) tm.Unix.tm_mday tm.Unix.tm_hour tm.Unix.tm_min
+ tm.Unix.tm_sec
+ in
+ print_endline
+ @@ Printf.sprintf "%s[%s]%s %s" orange formatted_time reset str
+
+ let output_response out_ch sexp =
+ let response = Sexplib.Sexp.to_string sexp in
+ output_string out_ch response;
+ output_string out_ch "\n";
+ flush out_ch;
+ print_with_time response
+
+ let send_error out_ch e =
+ output_response out_ch
+ Sexplib.Sexp.(List [ Atom "error"; Error.sexp_of_error e ])
+
+ let send_ok_message out_ch msg =
+ output_response out_ch
+ Sexplib.Sexp.(List [ Atom "ok"; List [ Atom "message"; Atom msg ] ])
+
+ let serialize storage (db : Management.Multigroup.multigroup) =
let open Sexplib.Sexp in
function
| Error e -> List [ Atom "error"; Error.sexp_of_error e ]
- (* TODO: forsake the global cursor register in favour of per-connection bookkeeping *)
- | Ok (Sublanguage.Cursor { cursor_id; rows; has_more }) ->
+ | Ok (Sublanguage_types.Cursor { cursor_id; rows; has_more }) ->
let row_sexps = List.map tuple_to_sexp rows in
let rows_sexp = List row_sexps in
List
@@ -141,11 +149,11 @@ functor
Atom "row_count"; Atom (string_of_int (List.length row_sexps));
];
List [ Atom "has_more"; Atom (string_of_bool has_more) ];
- List [ Atom "db_hash"; Atom db.hash ];
- List [ Atom "db_name"; Atom db.name ];
- List [ Atom "branch"; Atom (get_branch storage) ];
+ List [ Atom "db_hash"; Atom db#hash ];
+ List [ Atom "db_name"; Atom db#name ];
+ (* TODO: forsake the global cursor register in favour of per-connection bookkeeping *)
]
- | Ok (Sublanguage.Query rel) ->
+ | Ok (Sublanguage_types.Query rel) ->
let tuples, truncated =
materialize_relation storage rel current_limit
in
@@ -153,32 +161,29 @@ functor
List
(List.map
(fun (a, d) -> List [ Atom a; Atom d ])
- rel.Relation.schema)
+ rel#schema)
in
let rows_sexp = List (List.map tuple_to_sexp tuples) in
List
[
Atom "relation";
- List [ Atom "name"; Atom rel.Relation.name ];
+ List [ Atom "name"; Atom rel#name ];
List [ Atom "schema"; schema_sexp ];
List [ Atom "rows"; rows_sexp ];
List
[ Atom "row_count"; Atom (string_of_int (List.length tuples)) ];
List [ Atom "truncated"; Atom (string_of_bool truncated) ];
- List [ Atom "db_hash"; Atom db.hash ];
- List [ Atom "db_name"; Atom db.name ];
- List [ Atom "branch"; Atom (get_branch storage) ];
+ List [ Atom "db_hash"; Atom db#hash ];
+ List [ Atom "db_name"; Atom db#name ];
]
- | Ok (Sublanguage.Transition new_db) ->
+ | Ok (Sublanguage_types.Transition new_db) ->
List
[
Atom "ok";
- List [ Atom "db_hash"; Atom new_db.hash ];
- List [ Atom "db_name"; Atom new_db.name ];
- (* TODO: `serialize' shouldn't need access to the storage layer *)
- List [ Atom "branch"; Atom (get_branch storage) ];
+ List [ Atom "db_hash"; Atom new_db#hash ];
+ List [ Atom "db_name"; Atom new_db#name ];
]
- | Ok (Sublanguage.SessionSwitch multigroup) ->
+ | Ok (Sublanguage_types.SessionSwitch multigroup) ->
List
[
Atom "ok";
@@ -187,76 +192,84 @@ functor
Atom "message"; Atom ("Switched to multigroup " ^ multigroup);
];
]
- | Ok (Sublanguage.CreateMultigroup name) ->
+ | Ok (Sublanguage_types.CreateMultigroup name) ->
List
[
Atom "ok";
List [ Atom "message"; Atom ("Multigroup " ^ name ^ " created") ];
]
- let print_with_time str =
- (* TODO: a proper logger *)
- let now = Unix.gettimeofday () in
- let tm = Unix.localtime now in
- let orange = "\027[38;5;208m" in
- let reset = "\027[0m" in
- let formatted_time =
- Printf.sprintf "%04d-%02d-%02d %02d:%02d:%02d" (tm.Unix.tm_year + 1900)
- (tm.Unix.tm_mon + 1) tm.Unix.tm_mday tm.Unix.tm_hour tm.Unix.tm_min
- tm.Unix.tm_sec
- in
- print_endline
- @@ Printf.sprintf "%s[%s]%s %s" orange formatted_time reset str
-
- let output_response out_ch sexp =
- let response = Sexplib.Sexp.to_string sexp in
- output_string out_ch response;
- output_string out_ch "\n";
- flush out_ch;
- print_with_time response
-
- let resolve_db_ref catalog ctx =
- match CatalogOps.get catalog ctx.current_multigroup with
- | Some db_ref -> Ok db_ref
- | None -> Error (Error.MultigroupNotFound ctx.current_multigroup)
+ (* Open a handle to a multigroup by name via the NT object layer. The claims
+ from Firewall become the connection_context for access checks. *)
+ let open_multigroup (_storage : S.t) claims name =
+ match
+ Nt.open_handle () () ~path:[ "multigroups"; name ]
+ ~connection_context:claims
+ with
+ | Error e -> Error (Error.SyntaxError e)
+ | Ok handle -> (
+ match Nt.deserialize () () Nt.Multigroup handle.Nt.obj with
+ | Error e -> Error (Error.SyntaxError e)
+ | Ok (Nt.Multigroup mg) -> Ok (handle, mg)
+ | Ok _ -> Error (Error.SyntaxError "unexpected object type at path"))
- let fallback_db ctx = Management.Database.empty ~name:ctx.current_multigroup
+ let handle_use storage claims output state name =
+ match open_multigroup storage claims name with
+ | Error e -> send_error output e
+ | Ok (handle, mg) ->
+ state := Active (handle, mg);
+ send_ok_message output ("using multigroup: " ^ name)
- let send_serialized storage out_ch db result =
- serialize storage db result |> output_response out_ch
+ let handle_sublanguage storage output state sexp handle db =
+ match
+ Ok sexp
+ |> fmap (execute_command storage db)
+ |> fmap (perform handle db)
+ with
+ | Error e -> send_error output e
+ | Ok (new_handle, new_db, r) ->
+ state := Active (new_handle, new_db);
+ serialize storage new_db (Ok r) |> output_response output
- let handle_sublanguage storage catalog ctx out_ch sexp =
- match resolve_db_ref catalog ctx with
- | Error e -> send_serialized storage out_ch (fallback_db ctx) (Error e)
- | Ok db_ref ->
- let db = Atomic.get db_ref in
- Ok sexp
- |> fmap (execute_command storage db)
- |> fmap (perform storage catalog ctx db_ref db)
- |> send_serialized storage out_ch db
+ let dispatch_command storage claims output state sexp =
+ match sexp with
+ | Sexplib.Sexp.(List [ Atom "use"; Atom name ]) ->
+ handle_use storage claims output state name
+ | _ -> (
+ match !state with
+ | NoMultigroup ->
+ send_error output
+ (Error.SyntaxError "no multigroup selected; send (use \"name\")")
+ | Active (handle, db) ->
+ handle_sublanguage storage output state sexp handle db)
- let handle_client connection catalog (storage : S.t) =
+ let handle_client connection (storage : S.t) =
let input = T.input connection in
let output = T.output connection in
- let ctx = { current_multigroup = catalog.Catalog.default_multigroup } in
- try
+ (* Authenticate via NT PermissionsManager::Firewall before anything else. *)
+ let claims =
+ match Nt.firewall () with
+ | Ok c -> c
+ | Error e -> Printf.eprintf "Auth failed: %s\n%!" e; ""
+ in
+ let state = ref NoMultigroup in
+ (try
while true do
match read_command input with
- | Error e ->
- send_serialized storage output (fallback_db ctx) (Error e)
- | Ok sexp -> handle_sublanguage storage catalog ctx output sexp
+ | Error e -> send_error output e
+ | Ok sexp -> dispatch_command storage claims output state sexp
done
with
| End_of_file -> ()
| e ->
- Printf.eprintf "Error handling connection: %s" (Printexc.to_string e)
+ Printf.eprintf "Error handling connection: %s" (Printexc.to_string e))
- let spawn_handler catalog storage connection =
- Stdlib.Domain.spawn (fun () -> handle_client connection catalog storage)
+ let spawn_handler storage connection =
+ Stdlib.Domain.spawn (fun () -> handle_client connection storage)
- let run transport catalog storage =
+ let run transport storage =
T.listen transport;
while true do
- T.accept transport |> spawn_handler catalog storage |> ignore
+ T.accept transport |> spawn_handler storage |> ignore
done
end
diff --git a/lib/management/branch.ml b/lib/management/branch.ml
index 81da225..801c43d 100644
--- a/lib/management/branch.ml
+++ b/lib/management/branch.ml
@@ -70,7 +70,7 @@ module Make (Storage : Physical.S with type error = string) = struct
names
in
Ok branches
-
+(*
let branch_relation storage : Relation.t =
let schema =
Schema.empty |> Schema.add "name" "string" |> Schema.add "hash" "string"
@@ -102,9 +102,9 @@ module Make (Storage : Physical.S with type error = string) = struct
~generator:(Some generator)
~membership_criteria:(fun _ _ -> true)
~provenance:(Relation.Provenance.Base Prelude.Catalog.branch_rel_name)
- ~lineage:(Relation.Lineage.Base Prelude.Catalog.branch_rel_name) ()
+ ~lineage:(Relation.Lineage.Base Prelude.Catalog.branch_rel_name) () *)
- let head_relation storage : Relation.t =
+ (* let head_relation storage : Relation.t =
let schema = Schema.empty |> Schema.add "branch" "string" in
let mk v = { Attribute.value = Obj.repr v } in
let generator position =
@@ -129,5 +129,5 @@ module Make (Storage : Physical.S with type error = string) = struct
~generator:(Some generator)
~membership_criteria:(fun _ _ -> true)
~provenance:(Relation.Provenance.Base Prelude.Catalog.head_rel_name)
- ~lineage:(Relation.Lineage.Base Prelude.Catalog.head_rel_name) ()
+ ~lineage:(Relation.Lineage.Base Prelude.Catalog.head_rel_name) () *)
end
diff --git a/lib/management/database.ml b/lib/management/database.ml
deleted file mode 100644
index b8a9829..0000000
--- a/lib/management/database.ml
+++ /dev/null
@@ -1,136 +0,0 @@
-(** Database state: a named collection of relations with a Merkle tree over
- their hashes, a domain registry, and a history chain of prior hashes. All
- mutations produce a new value; no in-place update. *)
-
-(* TODO: history is an unbounded list of hashes; there is no way to
- reconstruct a past state from a hash alone without a separate snapshot
- store. Either cap the history or make it actually useful. *)
-
-(* TODO: refactor RelationMap keying from composite "schema:relation" strings
- to nested maps (schema -> relation -> Relation.t) for cleaner semantics.
- Currently, callers are responsible for passing composite keys. *)
-module RelationMap = Map.Make (String)
-
-type deferred_entry = {
- relation_name : string;
- constraint_name : string;
- body : Constraint.t;
-}
-
-type t = {
- hash : Conventions.Hash.t;
- name : Conventions.Name.t;
- tree : Merkle.t;
- relations : Relation.t RelationMap.t;
- domains : Domain.t RelationMap.t;
- history : Conventions.Hash.t list;
- timestamp : float;
- deferred : deferred_entry list;
-}
-
-let empty ~name =
- {
- hash = "";
- name;
- tree = Merkle.empty;
- relations = RelationMap.empty;
- domains = RelationMap.empty;
- history = [];
- timestamp = Unix.gettimeofday ();
- deferred = [];
- }
-
-let compute_hash db =
- match Merkle.root_hash db.tree with
- | Some root -> root
- | None -> Conventions.Hash.hash_text db.name
-
-let max_history = 128
-
-let rec take_at_most n = function
- | [] -> []
- | _ when n = 0 -> []
- | x :: xs -> x :: take_at_most (n - 1) xs
-
-let update_state db ~relations ~tree =
- let new_hash =
- match Merkle.root_hash tree with
- | Some root -> root
- | None -> Conventions.Hash.hash_text db.name
- in
- let history =
- if db.hash = "" then db.history
- else take_at_most max_history (db.hash :: db.history)
- in
- {
- hash = new_hash;
- name = db.name;
- tree;
- relations;
- domains = db.domains;
- history;
- timestamp = Unix.gettimeofday ();
- deferred = db.deferred;
- }
-
-let get_relation db name = RelationMap.find_opt name db.relations
-
-let get_relation_hash db name =
- match RelationMap.find_opt name db.relations with
- | None -> None
- | Some rel -> rel.Relation.hash
-
-let get_relation_names db =
- RelationMap.fold (fun name _ acc -> name :: acc) db.relations []
-
-let has_relation db name = RelationMap.mem name db.relations
-
-let relation_hash_or_compute (relation : Relation.t) =
- match relation.hash with
- | Some h -> h
- | None ->
- let tree = Option.value relation.tree ~default:Merkle.empty in
- Hashing.hash_relation ~name:relation.name ~schema:relation.schema ~tree
-
-(* TODO: computing the hash here for hash:None relations (ephemeral/prelude)
- is a layering violation — callers should assign the hash before calling
- add_relation, not rely on this fallback. *)
-let add_relation db ~(relation : Relation.t) =
- let relation_hash = relation_hash_or_compute relation in
- let relation = { relation with hash = Some relation_hash } in
- let tree = Merkle.insert relation_hash db.tree in
- let relations = RelationMap.add relation.name relation db.relations in
- update_state db ~relations ~tree
-
-let remove_relation db ~name =
- match RelationMap.find_opt name db.relations with
- | None -> db
- | Some relation ->
- let relation_hash = relation_hash_or_compute relation in
- let tree = Merkle.delete relation_hash db.tree in
- let relations = RelationMap.remove name db.relations in
- update_state db ~relations ~tree
-
-let update_relation db ~(relation : Relation.t) =
- let name = relation.name in
- match RelationMap.find_opt name db.relations with
- | None -> db
- | Some old_relation ->
- let old_hash = relation_hash_or_compute old_relation in
- let new_hash = relation_hash_or_compute relation in
- let tree = db.tree |> Merkle.delete old_hash |> Merkle.insert new_hash in
- let relations = RelationMap.add name relation db.relations in
- update_state db ~relations ~tree
-
-let add_domain db (domain : Domain.t) =
- { db with domains = RelationMap.add domain.name domain db.domains }
-
-let get_domain db name = RelationMap.find_opt name db.domains
-
-let get_domain_names db =
- RelationMap.fold (fun name _ acc -> name :: acc) db.domains []
-
-let has_domain db name = RelationMap.mem name db.domains
-
-let remove_domain db name =
- { db with domains = RelationMap.remove name db.domains }
diff --git a/lib/management/diff.ml b/lib/management/diff.ml
deleted file mode 100644
index 8fca0af..0000000
--- a/lib/management/diff.ml
+++ /dev/null
@@ -1,70 +0,0 @@
-(** Structural delta between two Database.t states. Computes what changed from
- ancestor -> target at the relation level. *)
-
-type relation_diff =
- | RelationAdded of Relation.t
- | RelationRemoved of string
- | RelationModified of {
- name : string;
- added_tuples : Conventions.Hash.t list;
- removed_tuples : Conventions.Hash.t list;
- schema_changed : bool;
- }
-
-type t = {
- ancestor : Conventions.Hash.t;
- left : Conventions.Hash.t;
- right : Conventions.Hash.t;
- relation_diffs : relation_diff list;
-}
-
-module StringSet = Set.Make (String)
-
-let relation_keys rel =
- match rel.Relation.tree with
- | None -> StringSet.empty
- | Some tree -> StringSet.of_list (Merkle.keys tree)
-
-(** Compute relation-level diffs from ancestor → target. *)
-let diff ~ancestor ~(target : Database.t) =
- let ancestor_names =
- Database.get_relation_names ancestor |> StringSet.of_list
- in
- let target_names = Database.get_relation_names target |> StringSet.of_list in
- let all_names = StringSet.union ancestor_names target_names in
- StringSet.fold
- (fun name acc ->
- let in_ancestor = StringSet.mem name ancestor_names in
- let in_target = StringSet.mem name target_names in
- match (in_ancestor, in_target) with
- | false, true -> (
- match Database.get_relation target name with
- | Some rel -> RelationAdded rel :: acc
- | None -> acc)
- | true, false -> RelationRemoved name :: acc
- | true, true -> (
- match
- ( Database.get_relation ancestor name,
- Database.get_relation target name )
- with
- | Some anc_rel, Some tgt_rel ->
- (* Compare hashes — if identical, no diff *)
- if anc_rel.Relation.hash = tgt_rel.Relation.hash then acc
- else
- let anc_keys = relation_keys anc_rel in
- let tgt_keys = relation_keys tgt_rel in
- let added_tuples =
- StringSet.diff tgt_keys anc_keys |> StringSet.elements
- in
- let removed_tuples =
- StringSet.diff anc_keys tgt_keys |> StringSet.elements
- in
- let schema_changed =
- anc_rel.Relation.schema <> tgt_rel.Relation.schema
- in
- RelationModified
- { name; added_tuples; removed_tuples; schema_changed }
- :: acc
- | _ -> acc)
- | false, false -> acc (* impossible *))
- all_names []
diff --git a/lib/management/merge.ml b/lib/management/merge.ml
deleted file mode 100644
index dff4808..0000000
--- a/lib/management/merge.ml
+++ /dev/null
@@ -1,288 +0,0 @@
-(** 3-way merge of two branch tips using their Lowest Common Ancestor. Walks the
- history chain to find it, diffs both sides against it, applies merge rules,
- validates constraints, and persists the result. *)
-
-type conflict =
- | TupleConflict of { relation : string; hash : Conventions.Hash.t }
- | SchemaConflict of string
- | ConstraintConflict of string
-
-type strategy = PreferLeft | PreferRight | RevertToAncestor
-type merge_result = Clean of Database.t | Failed of conflict list
-
-(* TODO: Remove this later. We already should have the interface on the manipulation *)
-
-(** Module type for the subset of Manipulation.Make we need. *)
-module type MANIPULATION = sig
- type storage
- type error
-
- val of_string_error : string -> error
-
- val load_database :
- storage -> Conventions.Hash.t -> (Database.t option, error) result
-
- val store_database : storage -> Database.t -> (unit, error) result
-end
-
-module StringSet = Set.Make (String)
-
-(** Walk history to find LCA. First hash in right's ancestry that also appears
- in left's ancestry set. *)
-let find_lca left_db right_db =
- let left_ancestors =
- StringSet.of_list (left_db.Database.hash :: left_db.Database.history)
- in
- let right_chain = right_db.Database.hash :: right_db.Database.history in
- List.find_opt (fun h -> StringSet.mem h left_ancestors) right_chain
-
-(** Apply a single relation diff to a database, using strategy on conflicts. *)
-let apply_diff db ~strategy ~left_db ~right_db ~(left_diff : Diff.relation_diff)
- ~(right_diff : Diff.relation_diff option) : Database.t * conflict list =
- match left_diff with
- | Diff.RelationAdded rel ->
- (* Only left added it; right_diff must be None or same *)
- (Database.add_relation db ~relation:rel, [])
- | Diff.RelationRemoved name -> (Database.remove_relation db ~name, [])
- | Diff.RelationModified { name; added_tuples; removed_tuples; schema_changed }
- -> (
- let conflicts = ref [] in
- (* Determine the merged relation's Merkle tree *)
- let base_rel_opt = Database.get_relation db name in
- match base_rel_opt with
- | None -> (db, [])
- | Some base_rel ->
- let base_tree =
- Option.value base_rel.Relation.tree ~default:Merkle.empty
- in
- (* Handle schema conflict *)
- let resolved_rel, schema_conflict =
- if schema_changed then
- match right_diff with
- | Some (Diff.RelationModified { schema_changed = true; _ }) ->
- (* Both changed schema — apply strategy *)
- let winner =
- match strategy with
- | PreferLeft -> Database.get_relation left_db name
- | PreferRight -> Database.get_relation right_db name
- | RevertToAncestor -> Some base_rel
- in
- ( Option.value winner ~default:base_rel,
- [ SchemaConflict name ] )
- | _ ->
- (* Only left changed schema — take left's relation *)
- let left_rel =
- Option.value
- (Database.get_relation left_db name)
- ~default:base_rel
- in
- (left_rel, [])
- else (base_rel, [])
- in
- conflicts := schema_conflict @ !conflicts;
- (* Apply tuple adds/removes from left *)
- let merged_tree =
- List.fold_left (fun t h -> Merkle.insert h t) base_tree added_tuples
- in
- let merged_tree =
- List.fold_left
- (fun t h -> Merkle.delete h t)
- merged_tree removed_tuples
- in
- (* Apply tuple adds/removes from right if disjoint *)
- let merged_tree =
- match right_diff with
- | Some
- (Diff.RelationModified
- { added_tuples = r_add; removed_tuples = r_rem; _ }) ->
- (* Detect tuple conflicts: same hash both added and removed *)
- let left_add = StringSet.of_list added_tuples in
- let left_rem = StringSet.of_list removed_tuples in
- let right_add = StringSet.of_list r_add in
- let right_rem = StringSet.of_list r_rem in
- let conflict_hashes =
- StringSet.inter left_add right_rem
- |> StringSet.union (StringSet.inter left_rem right_add)
- in
- if not (StringSet.is_empty conflict_hashes) then begin
- StringSet.iter
- (fun h ->
- conflicts :=
- TupleConflict { relation = name; hash = h }
- :: !conflicts)
- conflict_hashes;
- (* Resolve conflicting tuples per strategy *)
- match strategy with
- | PreferLeft ->
- (* keep left's merged_tree as-is, ignore conflicting right ops *)
- let safe_add = StringSet.diff right_add conflict_hashes in
- let safe_rem = StringSet.diff right_rem conflict_hashes in
- let t =
- StringSet.fold
- (fun h acc -> Merkle.insert h acc)
- safe_add merged_tree
- in
- StringSet.fold
- (fun h acc -> Merkle.delete h acc)
- safe_rem t
- | PreferRight ->
- (* revert left's conflicting ops, apply right's *)
- let t =
- StringSet.fold
- (fun h acc -> Merkle.delete h acc)
- conflict_hashes merged_tree
- in
- let t =
- StringSet.fold
- (fun h acc -> Merkle.insert h acc)
- right_add t
- in
- StringSet.fold
- (fun h acc -> Merkle.delete h acc)
- right_rem t
- | RevertToAncestor ->
- (* drop conflicting hashes from merged tree *)
- StringSet.fold
- (fun h acc -> Merkle.delete h acc)
- conflict_hashes merged_tree
- end
- else begin
- (* Disjoint — union both sides *)
- let t =
- List.fold_left
- (fun acc h -> Merkle.insert h acc)
- merged_tree r_add
- in
- List.fold_left (fun acc h -> Merkle.delete h acc) t r_rem
- end
- | _ -> merged_tree
- in
- let new_hash =
- Hashing.hash_relation ~name:resolved_rel.Relation.name
- ~schema:resolved_rel.Relation.schema ~tree:merged_tree
- in
- let updated_rel =
- {
- resolved_rel with
- Relation.tree = Some merged_tree;
- hash = Some new_hash;
- }
- in
- let new_db = Database.update_relation db ~relation:updated_rel in
- (new_db, !conflicts))
-
-module Make
- (Storage : Physical.S)
- (Manip : MANIPULATION with type storage = Storage.t) =
-struct
- let err s = Error (Manip.of_string_error s)
-
- (* Load both tips, find the lowest common ancestor, compute the diffs,
- lookup for right diffs by relation name, start from ancestor and
- apply all the diffs, apply first the left diffs, then right-only diffs
- (relations only right touched). If there are no conflicts, persist the
- merged database, otherwise return Failed, unless a strategy resolved them. *)
- let merge ~storage ~strategy ~left_tip ~right_tip =
- match Manip.load_database storage left_tip with
- | Error e -> Error e
- | Ok None -> err ("Left tip not found: " ^ left_tip)
- | Ok (Some left_db) -> (
- match Manip.load_database storage right_tip with
- | Error e -> Error e
- | Ok None -> err ("Right tip not found: " ^ right_tip)
- | Ok (Some right_db) -> (
- match find_lca left_db right_db with
- | None -> err "No common ancestor found between branches"
- | Some ancestor_hash -> (
- match Manip.load_database storage ancestor_hash with
- | Error e -> Error e
- | Ok None -> err ("Ancestor not found: " ^ ancestor_hash)
- | Ok (Some ancestor_db) ->
- let left_diffs =
- Diff.diff ~ancestor:ancestor_db ~target:left_db
- in
- let right_diffs =
- Diff.diff ~ancestor:ancestor_db ~target:right_db
- in
- let right_diff_map =
- List.fold_left
- (fun m d ->
- let key =
- match d with
- | Diff.RelationAdded r -> r.Relation.name
- | Diff.RelationRemoved n -> n
- | Diff.RelationModified { name; _ } -> name
- in
- Database.RelationMap.add key d m)
- Database.RelationMap.empty right_diffs
- in
- let merged_db, all_conflicts =
- let db_after_left, left_conflicts =
- List.fold_left
- (fun (db, conflicts) left_d ->
- let rel_name =
- match left_d with
- | Diff.RelationAdded r -> r.Relation.name
- | Diff.RelationRemoved n -> n
- | Diff.RelationModified { name; _ } -> name
- in
- let right_d =
- Database.RelationMap.find_opt rel_name
- right_diff_map
- in
- let new_db, cs =
- apply_diff db ~strategy ~left_db ~right_db
- ~left_diff:left_d ~right_diff:right_d
- in
- (new_db, cs @ conflicts))
- (ancestor_db, []) left_diffs
- in
- let left_names =
- List.fold_left
- (fun s d ->
- let n =
- match d with
- | Diff.RelationAdded r -> r.Relation.name
- | Diff.RelationRemoved n -> n
- | Diff.RelationModified { name; _ } -> name
- in
- StringSet.add n s)
- StringSet.empty left_diffs
- in
- let right_only =
- List.filter
- (fun d ->
- let n =
- match d with
- | Diff.RelationAdded r -> r.Relation.name
- | Diff.RelationRemoved n -> n
- | Diff.RelationModified { name; _ } -> name
- in
- not (StringSet.mem n left_names))
- right_diffs
- in
- let db_final, right_conflicts =
- List.fold_left
- (fun (db, conflicts) right_d ->
- let new_db, cs =
- apply_diff db ~strategy ~left_db ~right_db
- ~left_diff:right_d ~right_diff:None
- in
- (new_db, cs @ conflicts))
- (db_after_left, left_conflicts)
- right_only
- in
- (db_final, right_conflicts)
- in
- let unresolvable =
- List.filter
- (function ConstraintConflict _ -> true | _ -> false)
- all_conflicts
- in
- if unresolvable <> [] then Ok (Failed unresolvable)
- else
- begin match Manip.store_database storage merged_db with
- | Error e -> Error e
- | Ok () -> Ok (Clean merged_db)
- end)))
-end
diff --git a/lib/management/multigroup.ml b/lib/management/multigroup.ml
new file mode 100644
index 0000000..cfde4c1
--- /dev/null
+++ b/lib/management/multigroup.ml
@@ -0,0 +1,84 @@
+(** Multigroup root: a lightweight versioned descriptor that maps relation names
+ to content-addressed relation values. The multigroup object owns the B+ tree
+ pointer and advances it when relations change. *)
+
+
+class multigroup ~name:(init_name : Conventions.Name.t) =
+ let init_hash = Conventions.Hash.hash_text init_name in
+ object (self)
+ val name : Conventions.Name.t = init_name
+ val hash : Conventions.Hash.t = init_hash
+ val previous_version : Conventions.Hash.t option = None
+ val tree_pointer : Conventions.Hash.t option = None
+ val relations : Relation.relation BatMap.String.t = BatMap.String.empty
+ val timestamp : float = Unix.gettimeofday ()
+
+ method name = name
+ method hash = hash
+ method previous_version = previous_version
+ method tree_pointer = tree_pointer
+ method relations = relations
+ method timestamp = timestamp
+
+ method get_relation rel_name = BatMap.String.find_opt rel_name relations
+ method get_relation_names = BatMap.String.fold (fun n _ acc -> n :: acc) relations []
+ method has_relation rel_name = BatMap.String.mem rel_name relations
+
+ (* Derive the B+ tree root hash from sorted relation hashes. *)
+ method private compute_tree_pointer rels =
+ BatMap.String.fold
+ (fun _n (r : Relation.relation) acc -> acc ^ r#hash)
+ rels ""
+ |> Conventions.Hash.hash_text
+
+ method private compute_hash tp =
+ Conventions.Hash.hash_text (name ^ tp)
+
+ method private advance rels =
+ let tp = self#compute_tree_pointer rels in
+ {< hash = self#compute_hash tp;
+ previous_version = (if hash = "" then None else Some hash);
+ tree_pointer = Some tp;
+ relations = rels;
+ timestamp = Unix.gettimeofday () >}
+
+ method add_relation (rel : Relation.relation) =
+ let rels = BatMap.String.add rel#name rel relations in
+ self#advance rels
+
+ method remove_relation rel_name =
+ if not (BatMap.String.mem rel_name relations) then self
+ else self#advance (BatMap.String.remove rel_name relations)
+
+ method update_relation (rel : Relation.relation) =
+ if not (BatMap.String.mem rel#name relations) then self
+ else self#advance (BatMap.String.add rel#name rel relations)
+
+ method serialize () : Storable.Multigroup.t =
+ {
+ Storable.Multigroup.name = name;
+ relations = BatMap.String.bindings relations |> List.map snd |> List.map (fun r -> r#serialize ());
+ }
+end
+
+let deserialize (_bytes : bytes) : (multigroup, string) result =
+ try
+ let stored = Storable.Multigroup.of_bytes _bytes in
+ let db = new multigroup ~name:stored.name in
+ let db =
+ List.fold_left
+ (fun db rel ->
+ let membership_criteria =
+ Constraint.build_membership_criteria ~_name:rel.Storable.Relation.name
+ ~schema:rel.schema
+ in
+ let relation =
+ new Relation.stored ~name:rel.name ~schema:rel.schema ~constraints:None
+ ~cardinality:Conventions.Cardinality.ConstrainedFinite
+ ~membership_criteria ~lineage:None ~provenance:None
+ in
+ db#add_relation relation)
+ db stored.relations
+ in
+ Ok db
+ with Invalid_argument message -> Error message
diff --git a/lib/manipulation.ml b/lib/manipulation.ml
index 7ae2753..dd09378 100644
--- a/lib/manipulation.ml
+++ b/lib/manipulation.ml
@@ -1,350 +1,85 @@
-(** Database manipulation operations.
+(** Multigroup manipulation operations.
This module implements the core operations for the relational engine:
- - Database creation
+ - Multigroup creation
- Relation creation and deletion
- Tuple insertion and deletion
- Query operations
- All operations are immutable: they return new database/relation states
+ All operations are immutable: they return new multigroup/relation states
rather than modifying existing ones. The storage layer handles persistence.
This is a functor that takes a storage backend, ensuring all tuple data is
properly persisted to the content-addressed store. *)
-module RelationMap = Management.Database.RelationMap
-
-(** Build membership criteria from schema (validates type membership). Returns a
- function that takes a tree-lookup function and a tuple, checking schema
- conformance and tree membership at call time. *)
-let build_membership_criteria ~name schema :
- (string -> Merkle.t option) -> Tuple.t -> bool =
- let value_conforms_to_domain domain_name (value : Conventions.AbstractValue.t)
- =
- match domain_name with
- | "integer" -> Obj.is_int value
- | "natural" -> Obj.is_int value && (Obj.obj value : int) >= 0
- | "string" -> Obj.tag value = Obj.string_tag
- | _ ->
- (* Unknown domain: could be a relation-typed attribute (nested tuple)
- or a user-defined domain. Accept for now; full validation would
- require looking up the target relation's schema. *)
- true
- in
- let n_expected = List.length schema in
- fun tree_of tuple ->
- match tuple with
- | Tuple.NonMaterialized nm -> (
- match tree_of name with
- | None -> false
- | Some t ->
- Merkle.member nm.hash t
- && Tuple.AttributeMap.cardinal nm.attributes = n_expected
- && List.for_all
- (fun (attr_name, _) ->
- Tuple.AttributeMap.mem attr_name nm.attributes)
- schema)
- | Tuple.Materialized m ->
- Tuple.AttributeMap.cardinal m.attributes = n_expected
- && List.for_all
- (fun (attr_name, domain_name) ->
- match Tuple.AttributeMap.find_opt attr_name m.attributes with
- | None -> false
- | Some attr ->
- value_conforms_to_domain domain_name attr.Attribute.value)
- schema
-
-let tree_of_db (db : Management.Database.t) name =
- Option.bind (Management.Database.get_relation db name) (fun r ->
- r.Relation.tree)
-
-module Constraint = struct
- include Constraint
-
- (** Mutation direction for cascade constraint checking *)
- type mutation = Insert | Delete
-
- type mutation_context = {
- target_relation : string;
- transition : (string * Conventions.AbstractValue.t) list;
- kind : mutation;
- }
- (** Context for a single tuple mutation, used by cascade checking *)
-end
-
(** Functor to create manipulation operations with a storage backend *)
module Make (Storage : Management.Physical.S) = struct
+ include Nt
+
type storage = Storage.t
type error = Error.t
-
- let of_string_error s = Error.StorageError s
- let ( let* ) = Result.bind
- let normalize_name n = Qualified_name.(parse n |> to_key)
-
- let rec normalize_constraint_body c =
- match c with
- | Constraint.MemberOf { target; binding } ->
- Constraint.MemberOf { target = normalize_name target; binding }
- | Constraint.Not { body; universe } ->
- Constraint.Not
- {
- body = normalize_constraint_body body;
- universe = normalize_name universe;
- }
- | Constraint.And cs ->
- Constraint.And (List.map normalize_constraint_body cs)
- | Constraint.Or cs -> Constraint.Or (List.map normalize_constraint_body cs)
- | Constraint.Exists { variable; quantifier; body } ->
- Constraint.Exists
- {
- variable;
- quantifier = normalize_name quantifier;
- body = normalize_constraint_body body;
- }
- | Constraint.Forall { variable; quantifier; body } ->
- Constraint.Forall
- {
- variable;
- quantifier = normalize_name quantifier;
- body = normalize_constraint_body body;
- }
-
- let fold_result (f : 'a -> 'b -> ('a, error) Result.t) (init : 'a)
- (xs : 'b list) : ('a, error) Result.t =
- List.fold_left
- (fun acc x ->
- let* a = acc in
- f a x)
- (Ok init) xs
-
- (** Build an eval_context closed over a specific (storage, db) snapshot. All
- relation lookups resolve against this exact database version. *)
- let build_eval_context (storage : storage) (db : Management.Database.t) :
- Constraint.eval_context =
- let load_value attr_hash =
- match Storage.load_raw storage attr_hash with
- | Error _ | Ok None -> None
- | Ok (Some vbytes) ->
- Some (Marshal.from_bytes vbytes 0 : Conventions.AbstractValue.t)
- in
- let rec load_attrs acc = function
- | [] -> Some (List.rev acc)
- | (name, attr_hash) :: rest -> (
- match load_value attr_hash with
- | None -> None
- | Some value -> load_attrs ((name, value) :: acc) rest)
- in
- let load_tuple hash =
- match Storage.load_raw storage hash with
- | Error _ | Ok None -> None
- | Ok (Some bytes) ->
- load_attrs []
- (Storable.Tuple.of_bytes bytes).Storable.Tuple.attributes
- in
- let rec load_all acc = function
- | [] -> Some (List.rev acc)
- | h :: rest -> (
- match load_tuple h with
- | None -> None
- | Some pairs -> load_all (pairs :: acc) rest)
- in
- let check_membership rel_name bound_pairs =
- match Management.Database.get_relation db rel_name with
- | None -> false
- | Some rel ->
- let attributes =
- List.fold_left
- (fun acc (k, v) ->
- Tuple.AttributeMap.add k { Attribute.value = v } acc)
- Tuple.AttributeMap.empty bound_pairs
- in
- let tuple =
- Tuple.Materialized { Tuple.relation = rel_name; attributes }
- in
- rel.membership_criteria (tree_of_db db) tuple
- in
- let iterate_finite rel_name =
- match Management.Database.get_relation db rel_name with
- | None -> None
- | Some rel -> (
- match rel.cardinality with
- | Conventions.Cardinality.Finite _
- | Conventions.Cardinality.ConstrainedFinite ->
- let hashes =
- match rel.tree with None -> [] | Some tree -> Merkle.keys tree
- in
- load_all [] hashes
- | _ -> None)
- in
- { Constraint.check_membership; iterate_finite }
-
+
(* State Persistence - Store relation and database states *)
(** Store a relation state to storage *)
- let store_relation (storage : storage) (relation : Relation.t) :
+ let store_relation (storage : storage) (relation : Relation.relation) :
(unit, error) Result.t =
- match relation.hash with
- | None -> Error (Error.StorageError "Relation has no hash")
- | Some rel_hash -> (
- let tree_keys =
- match relation.tree with None -> [] | Some tree -> Merkle.keys tree
- in
- let stored : Storable.Relation.t =
- {
- name = relation.name;
- schema = relation.schema;
- tree_keys;
- cardinality = relation.cardinality;
- }
- in
- match
- Storage.store_raw storage rel_hash (Storable.Relation.to_bytes stored)
- with
- | Error _ -> Error (Error.StorageError "Failed to store relation")
- | Ok () -> Ok ())
+ match
+ Storage.store_raw storage relation#hash (Storable.Relation.to_bytes @@ relation#serialize ())
+ with
+ | Error _ -> Error (Error.StorageError "Failed to store relation")
+ | Ok () -> Ok ()
(** Store a database state to storage *)
- let store_database (storage : storage) (db : Management.Database.t) :
+ let store_multigroup (storage : storage) (db : Management.Multigroup.multigroup) :
(unit, error) Result.t =
- if db.hash = "" then Ok () (* Don't store empty/initial database *)
- else
- (* Extract relation hashes from the actual relations *)
- let relation_hashes =
- Management.Database.RelationMap.fold
- (fun name rel acc ->
- match rel.Relation.hash with
- | Some h -> (name, h) :: acc
- | None -> acc)
- db.relations []
- in
- let stored : Storable.Database.t =
- {
- name = db.name;
- relations = relation_hashes;
- tree_keys = Merkle.keys db.tree;
- history = db.history;
- timestamp = db.timestamp;
- }
- in
match
- Storage.store_raw storage db.hash (Storable.Database.to_bytes stored)
+ Storage.store_raw storage db#hash (Storable.Multigroup.to_bytes @@ db#serialize ())
with
- | Error _ -> Error (Error.StorageError "Failed to store database")
+ | Error _ -> Error (Error.StorageError "Failed to store multigroup")
| Ok () -> Ok ()
(** Load a relation state from storage by hash *)
- let load_relation (storage : storage) (rel_hash : Conventions.Hash.t) :
- (Relation.t option, error) Result.t =
+ let load_relation (storage : storage) (rel_hash : Conventions.Hash.t) : (Relation.stored option, error) Result.t =
match Storage.load_raw storage rel_hash with
| Error _ -> Error (Error.StorageError "Failed to load relation")
| Ok None -> Ok None
| Ok (Some bytes) ->
- let stored = Storable.Relation.of_bytes bytes in
- let tree =
- List.fold_left
- (fun t h -> Merkle.insert h t)
- Merkle.empty stored.tree_keys
- in
+ let _stored = Storable.Relation.of_bytes bytes in
+ let name = failwith "NOT IMPLEMENTED" in
+ let schema = failwith "NOT IMPLEMENTED" in
+ let constraints = failwith "NOT IMPLEMENTED" in
+ let cardinality = failwith "NOT IMPLEMENTED" in
+ let membership_criteria = Constraint.build_membership_criteria ~_name:name ~schema in
let relation =
- Relation.make ~hash:(Some rel_hash) ~name:stored.name
- ~schema:stored.schema ~tree:(Some tree) ~constraints:None
- ~cardinality:stored.cardinality ~generator:None
- ~membership_criteria:
- (build_membership_criteria ~name:stored.name stored.schema)
- ~provenance:(Relation.Provenance.Base stored.name)
- ~lineage:(Relation.Lineage.Base stored.name) ()
+ new Relation.stored
+ ~name
+ ~schema
+ ~constraints
+ ~cardinality
+ ~membership_criteria
+ ~provenance:None
+ ~lineage:None
in
Ok (Some relation)
- (** Load a database state from storage by hash. Note: This loads the database
- structure with relation hashes, but the relations themselves need to be
- loaded separately. *)
- let load_database (storage : storage) (db_hash : Conventions.Hash.t) :
- (Management.Database.t option, error) Result.t =
- match Storage.load_raw storage db_hash with
- | Error _ -> Error (Error.StorageError "Failed to load database")
+ let load_multigroup (storage : storage) (mg_hash : Conventions.Hash.t) :
+ (Management.Multigroup.multigroup option, error) Result.t =
+ match Storage.load_raw storage mg_hash with
+ | Error _ -> Error (Error.StorageError "Failed to load multigroup")
| Ok None -> Ok None
| Ok (Some bytes) ->
- let stored = Storable.Database.of_bytes bytes in
- let tree =
- List.fold_left
- (fun t h -> Merkle.insert h t)
- Merkle.empty stored.tree_keys
- in
- let rec load_relations acc = function
- | [] -> Ok (List.rev acc)
- | (name, rel_hash) :: rest -> (
- let* rel_opt = load_relation storage rel_hash in
- match rel_opt with
- | None ->
- Error (Error.StorageError ("Relation not found: " ^ name))
- | Some rel -> load_relations ((name, rel) :: acc) rest)
- in
- let* relation_list = load_relations [] stored.relations in
- let relations =
- List.fold_left
- (fun m (name, rel) ->
- Management.Database.RelationMap.add name rel m)
- Management.Database.RelationMap.empty relation_list
- in
- Ok
- (Some
- {
- Management.Database.hash = db_hash;
- name = stored.name;
- tree;
- relations;
- domains = Management.Database.RelationMap.empty;
- history = stored.history;
- timestamp = stored.timestamp;
- deferred = [];
- })
-
- (* Relation Operations - forward declarations needed by catalog helpers
- *)
-
- (** Create a new empty relation with the given schema *)
- let create_relation_raw (storage : storage) (db : Management.Database.t)
- ~(name : string) ~(schema : Schema.t) :
- (Management.Database.t * Relation.t, Error.t) Result.t =
- if Management.Database.has_relation db name then
- Error (Error.RelationAlreadyExists name)
- else
- let tree = Merkle.empty in
- let relation_hash = Hashing.hash_relation ~name ~schema ~tree in
- let relation =
- Relation.make ~hash:(Some relation_hash) ~name ~schema ~tree:(Some tree)
- ~constraints:None ~cardinality:(Conventions.Cardinality.Finite 0)
- ~generator:None
- ~membership_criteria:(build_membership_criteria ~name schema)
- ~provenance:(Relation.Provenance.Base name)
- ~lineage:(Relation.Lineage.Base name) ()
- in
- let new_db = Management.Database.add_relation db ~relation in
- let* () = store_relation storage relation in
- Ok (new_db, relation)
+ (* TODO: Properly deserialize multigroup state *)
+ let _stored = Storable.Multigroup.of_bytes bytes in
+ let name = failwith "NOT IMPLEMENTED" in
+ let mg = new Management.Multigroup.multigroup ~name in
+ Ok (Some mg)
(* Tuple Operations - Storage Integrated *)
(** Store each attribute value and return map of attr_name -> attr_hash *)
- let store_attributes (storage : storage) (tuple : Tuple.materialized) :
- ((string * Conventions.Hash.t) list, error) Result.t =
- let attrs = Tuple.AttributeMap.bindings tuple.attributes in
- let rec store_all acc = function
- | [] -> Ok (List.rev acc)
- | (name, attr) :: rest -> (
- let value_bytes =
- Marshal.to_bytes attr.Attribute.value [ Marshal.Closures ]
- in
- let value_hash =
- Conventions.Hash.hash_text (Hashing.bytes_to_hex value_bytes)
- in
- match Storage.store_raw storage value_hash value_bytes with
- | Error _ ->
- Error (Error.StorageError ("Failed to store attribute: " ^ name))
- | Ok () -> store_all ((name, value_hash) :: acc) rest)
- in
- store_all [] attrs
+ let store_attributes (_storage : storage) (_tuple : Tuple.materialized) :
+ ((string * Conventions.Hash.t) list, error) Result.t = failwith "NOT IMPLEMENTED"
(** Load a tuple from storage by its hash *)
let load_tuple (storage : storage) (tuple_hash : Conventions.Hash.t) :
@@ -353,7 +88,9 @@ module Make (Storage : Management.Physical.S) = struct
| Error _ -> Error (Error.StorageError "Failed to load tuple")
| Ok None -> Ok None
| Ok (Some tuple_bytes) ->
- let stored = Storable.Tuple.of_bytes tuple_bytes in
+ let _stored = Storable.Tuple.of_bytes tuple_bytes in
+ let attributes = failwith "NOT IMPLEMENTED" in
+ let relation = failwith "NOT IMPLEMENTED" in
let rec load_attrs acc = function
| [] -> Ok (List.rev acc)
| (name, attr_hash) :: rest -> (
@@ -370,708 +107,9 @@ module Make (Storage : Management.Physical.S) = struct
let attr : Attribute.materialized = { value } in
load_attrs ((name, attr) :: acc) rest)
in
- let* attrs = load_attrs [] stored.attributes in
- let attributes =
- List.fold_left
- (fun m (k, v) -> Tuple.AttributeMap.add k v m)
- Tuple.AttributeMap.empty attrs
- in
- Ok (Some { Tuple.relation = stored.relation; attributes })
-
- (** Load multiple tuples from storage *)
- let load_tuples (storage : storage) (hashes : Conventions.Hash.t list) :
- (Tuple.materialized list, error) Result.t =
- let rec load_all acc = function
- | [] -> Ok (List.rev acc)
- | hash :: rest -> (
- let* tup_opt = load_tuple storage hash in
- match tup_opt with
- | None -> Error (Error.TupleNotFound hash)
- | Some tuple -> load_all (tuple :: acc) rest)
- in
- load_all [] hashes
-
- let with_loaded_tuple storage tuple_hash ~on_some =
- let* tup_opt = load_tuple storage tuple_hash in
- match tup_opt with
- | Some tup -> on_some tup
- | None ->
- Error
- (Error.StorageError
- ("Tuple missing for referenced hash: " ^ tuple_hash))
-
- let transition_attrs (tuple : Tuple.materialized) =
- Tuple.AttributeMap.bindings tuple.attributes
- |> List.map (fun (k, attr) -> (k, attr.Attribute.value))
-
- let ensure_relation_exists (db : Management.Database.t) name =
- if Management.Database.has_relation db name then Ok ()
- else Error (Error.RelationNotFound name)
-
- let bump_cardinality delta = function
- | Conventions.Cardinality.Finite n ->
- Conventions.Cardinality.Finite (max 0 (n + delta))
- | other -> other
-
- let rehashed_relation_with_tree ~name ~schema (relation : Relation.t) tree
- cardinality =
- let hash = Hashing.hash_relation ~name ~schema ~tree in
- {
- relation with
- hash = Some hash;
- tree = Some tree;
- cardinality;
- membership_criteria = build_membership_criteria ~name schema;
- }
-
- let validate_tuple_constraints (storage : storage)
- (db : Management.Database.t) (relation : Relation.t)
- (tuple : Tuple.materialized) =
- let eval_result =
- match relation.constraints with
- | None | Some [] -> Ok true
- | Some named_constraints ->
- let ctx = build_eval_context storage db in
- Constraint.evaluate_named ctx tuple named_constraints
- in
- match eval_result with
- | Ok true -> Ok ()
- | Ok false -> Error (Error.ConstraintViolation "Constraint not satisfied")
- | Error (Constraint.ConstraintFailures failures) ->
- let msg =
- String.concat "; "
- (List.map (fun (n, _) -> "constraint " ^ n ^ " violated") failures)
- in
- Error (Error.ConstraintViolation msg)
- | Error _ ->
- Error (Error.ConstraintViolation "Constraint evaluation failed")
-
- let store_tuple_payload storage tuple_hash (tuple : Tuple.materialized) =
- let* attr_hashes = store_attributes storage tuple in
- let stored_tuple : Storable.Tuple.t =
- { relation = tuple.relation; attributes = attr_hashes }
- in
- let tuple_bytes = Storable.Tuple.to_bytes stored_tuple in
- match Storage.store_raw storage tuple_hash tuple_bytes with
- | Error _ -> Error (Error.StorageError "Failed to store tuple")
- | Ok () -> Ok ()
-
- (* Cascade constraint helpers *)
-
- let polarity_triggered_by kind pol =
- match (kind, pol) with
- | Constraint.Insert, (Constraint.Negative | Constraint.Both) -> true
- | Constraint.Delete, (Constraint.Positive | Constraint.Both) -> true
- | _ -> false
-
- let cascade_violation_msg kind target_relation cname constrained_name =
- let verb =
- match kind with
- | Constraint.Insert -> "inserting into"
- | Constraint.Delete -> "deleting from"
- in
- Printf.sprintf "cascade: %s %s violates constraint %s on %s" verb
- target_relation cname constrained_name
-
- let is_deferred (db : Management.Database.t) rel_name cname =
- List.exists
- (fun (d : Management.Database.deferred_entry) ->
- d.constraint_name = cname && d.relation_name = rel_name)
- db.deferred
-
- let needs_recheck filter (tup : Tuple.materialized) =
- filter = []
- || List.for_all
- (fun (attr, fval) ->
- match Tuple.AttributeMap.find_opt attr tup.attributes with
- | Some a -> Stdlib.( = ) a.Attribute.value fval
- | None -> false)
- filter
-
- let recheck_one storage ctx (mctx : Constraint.mutation_context) cname cbody
- constrained_name filter (h : Conventions.Hash.t) : (unit, error) Result.t
- =
- with_loaded_tuple storage h ~on_some:(fun tup ->
- if not (needs_recheck filter tup) then Ok ()
- else
- let cbody' =
- Constraint.substitute_transition cbody mctx.target_relation
- mctx.transition
- in
- match
- Constraint.evaluate_first_failure ctx tup [ (cname, cbody') ]
- with
- | Ok true -> Ok ()
- | Ok false | Error _ ->
- Error
- (Error.ConstraintViolation
- (cascade_violation_msg mctx.kind mctx.target_relation cname
- constrained_name)))
-
- let check_one_constraint storage ctx db (mctx : Constraint.mutation_context)
- constrained_name constrained_rel (cname, cbody) : (unit, error) Result.t =
- if is_deferred db constrained_name cname then Ok ()
- else
- let pols = Constraint.polarity_of cbody in
- match Constraint.polarity_find mctx.target_relation pols with
- | None -> Ok ()
- | Some pol when not (polarity_triggered_by mctx.kind pol) -> Ok ()
- | Some _ ->
- let filter =
- Constraint.focused_filter cbody mctx.target_relation mctx.transition
- in
- let hashes =
- match constrained_rel.Relation.tree with
- | None -> []
- | Some t -> Merkle.keys t
- in
- fold_result
- (fun () h ->
- recheck_one storage ctx mctx cname cbody constrained_name filter h)
- () hashes
-
- (** Scan every relation in [db] for constraints that reference
- [mctx.target_relation] with a polarity matched by the mutation kind, then
- re-evaluate those constraints against the affected tuples in each
- constrained relation.
-
- Returns [Ok ()] when all cascade checks pass. *)
- let check_cascade_constraints (storage : storage) (db : Management.Database.t)
- (mctx : Constraint.mutation_context) =
- let ctx = build_eval_context storage db in
- Management.Database.RelationMap.fold
- (fun constrained_name constrained_rel acc ->
- let* () = acc in
- match constrained_rel.Relation.constraints with
- | None | Some [] -> Ok ()
- | Some named ->
- fold_result
- (fun () nc ->
- check_one_constraint storage ctx db mctx constrained_name
- constrained_rel nc)
- () named)
- db.relations (Ok ())
-
- (** Insert a tuple into a relation, storing it in the backend *)
- let create_tuple (storage : storage) (db : Management.Database.t)
- (relation : Relation.t) (tuple : Tuple.materialized) :
- (Management.Database.t * Relation.t * Conventions.Hash.t, error) Result.t
- =
- let name = relation.name in
- let* () = ensure_relation_exists db name in
- if
- not
- (relation.membership_criteria (tree_of_db db) (Tuple.Materialized tuple))
- then
- Error
- (Error.ConstraintViolation "Tuple does not satisfy membership criteria")
- else
- let* () = validate_tuple_constraints storage db relation tuple in
- let tuple_hash = Hashing.hash_tuple tuple in
- let current_tree =
- match relation.tree with Some t -> t | None -> Merkle.empty
- in
- if Merkle.member tuple_hash current_tree then
- Error (Error.DuplicateTuple tuple_hash)
- else
- let* () = store_tuple_payload storage tuple_hash tuple in
- let new_tree = Merkle.insert tuple_hash current_tree in
- let new_relation =
- rehashed_relation_with_tree ~name ~schema:relation.schema relation
- new_tree
- (bump_cardinality 1 relation.cardinality)
- in
- let new_db =
- Management.Database.update_relation db ~relation:new_relation
- in
- let* () =
- check_cascade_constraints storage new_db
- {
- target_relation = name;
- transition = transition_attrs tuple;
- kind = Constraint.Insert;
- }
- in
- let* () = store_relation storage new_relation in
- let* () = store_database storage new_db in
- Ok (new_db, new_relation, tuple_hash)
-
- (** Insert multiple tuples into a relation *)
- let create_tuples (storage : storage) (db : Management.Database.t)
- (relation : Relation.t) (tuples : Tuple.materialized list) :
- ( Management.Database.t * Relation.t * Conventions.Hash.t list,
- error )
- Result.t =
- let rec insert_all db rel hashes = function
- | [] -> Ok (db, rel, List.rev hashes)
- | tuple :: rest ->
- let* new_db, new_rel, hash = create_tuple storage db rel tuple in
- insert_all new_db new_rel (hash :: hashes) rest
- in
- insert_all db relation [] tuples
-
- (** Remove a tuple from a relation by its hash *)
- let retract_tuple (storage : storage) (db : Management.Database.t)
- (relation : Relation.t) ~(tuple_hash : Conventions.Hash.t) :
- (Management.Database.t * Relation.t, error) Result.t =
- let name = relation.name in
- let* () = ensure_relation_exists db name in
- let* current_tree =
- match relation.tree with
- | None -> Error (Error.TupleNotFound tuple_hash)
- | Some tree -> Ok tree
- in
- if not (Merkle.member tuple_hash current_tree) then
- Error (Error.TupleNotFound tuple_hash)
- else
- (* Note: We don't delete from storage - content-addressed storage is append-only.
- The tuple data remains for historical queries / garbage collection later. *)
- let new_tree = Merkle.delete tuple_hash current_tree in
- let new_relation =
- rehashed_relation_with_tree ~name ~schema:relation.schema relation
- new_tree
- (bump_cardinality (-1) relation.cardinality)
- in
- let new_db =
- Management.Database.update_relation db ~relation:new_relation
- in
- let* () =
- with_loaded_tuple storage tuple_hash ~on_some:(fun deleted_tuple ->
- check_cascade_constraints storage new_db
- {
- target_relation = name;
- transition = transition_attrs deleted_tuple;
- kind = Constraint.Delete;
- })
- in
- let* () = store_relation storage new_relation in
- let* () = store_database storage new_db in
- Ok (new_db, new_relation)
-
- (*
- System Catalog Maintenance
- *)
-
- (** Update catalog when a new user relation is created. Skipped if the
- relation being created is itself a catalog relation. *)
- let update_catalog_on_create (storage : storage) (db : Management.Database.t)
- (relation : Relation.t) : (Management.Database.t, error) Result.t =
- if Prelude.Catalog.is_catalog_relation relation.name then Ok db
- else
- (* Insert into public:relation *)
- match
- Management.Database.get_relation db Prelude.Catalog.relation_rel_name
- with
- | None -> Ok db (* catalog not yet initialized *)
- | Some rel_cat -> (
- let rel_tuple = Prelude.Catalog.build_relation_tuple relation.name in
- let* db, _, _ = create_tuple storage db rel_cat rel_tuple in
- (* Insert into public:attribute for each schema entry *)
- match
- Management.Database.get_relation db
- Prelude.Catalog.attribute_rel_name
- with
- | None -> Ok db
- | Some attr_cat ->
- let attr_tuples =
- Prelude.Catalog.build_attribute_tuples
- ~relation_name:relation.name relation.schema
- in
- let* db, _, _ = create_tuples storage db attr_cat attr_tuples in
- Ok db)
-
- (** Update catalog when a user relation is retracted. Skipped if the relation
- being retracted is itself a catalog relation. *)
- let update_catalog_on_retract (storage : storage) (db : Management.Database.t)
- (relation : Relation.t) : (Management.Database.t, error) Result.t =
- if Prelude.Catalog.is_catalog_relation relation.name then Ok db
- else
- let* db =
- match
- Management.Database.get_relation db Prelude.Catalog.relation_rel_name
- with
- | None -> Ok db
- | Some rel_cat ->
- let rel_tuple_hash =
- Hashing.hash_tuple
- (Prelude.Catalog.build_relation_tuple relation.name)
- in
- let tree =
- match rel_cat.tree with Some t -> t | None -> Merkle.empty
- in
- if Merkle.member rel_tuple_hash tree then
- let* new_db, _ =
- retract_tuple storage db rel_cat ~tuple_hash:rel_tuple_hash
- in
- Ok new_db
- else Ok db
- in
- (* Remove attribute tuples for this relation from public:attribute *)
- let attr_tuples =
- Prelude.Catalog.build_attribute_tuples ~relation_name:relation.name
- relation.schema
- in
- fold_result
- (fun db tup ->
- let tup_hash = Hashing.hash_tuple tup in
- match
- Management.Database.get_relation db
- Prelude.Catalog.attribute_rel_name
- with
- | None -> Ok db
- | Some attr_cat ->
- let tree =
- match attr_cat.tree with Some t -> t | None -> Merkle.empty
- in
- if Merkle.member tup_hash tree then
- let* new_db, _ =
- retract_tuple storage db attr_cat ~tuple_hash:tup_hash
- in
- Ok new_db
- else Ok db)
- db attr_tuples
-
- (** Bootstrap the 6 system catalog relations into a fresh database. Called
- only from [create_database]; suppresses recursive catalog updates. *)
- let init_catalog_relations (storage : storage) (db : Management.Database.t) :
- (Management.Database.t, error) Result.t =
- let* db =
- fold_result
- (fun db (name, schema) ->
- let* new_db, _ = create_relation_raw storage db ~name ~schema in
- Ok new_db)
- db Prelude.Catalog.catalog_definitions
- in
- let get_required (db : Management.Database.t) rel_name =
- match Management.Database.get_relation db rel_name with
- | Some rel -> Ok rel
- | None ->
- Error (Error.StorageError ("Catalog relation missing: " ^ rel_name))
- in
- let* relation_rel = get_required db Prelude.Catalog.relation_rel_name in
- let* db, _, _ =
- create_tuples storage db relation_rel
- (List.map Prelude.Catalog.build_relation_tuple
- Prelude.Catalog.catalog_relation_names)
- in
- let* attribute_rel = get_required db Prelude.Catalog.attribute_rel_name in
- let* db, _, _ =
- create_tuples storage db attribute_rel
- (List.concat_map
- (fun (name, schema) ->
- Prelude.Catalog.build_attribute_tuples ~relation_name:name schema)
- Prelude.Catalog.catalog_definitions)
- in
- let* on_rel = get_required db Prelude.Catalog.on_rel_name in
- let* db, _, _ =
- create_tuples storage db on_rel
- (List.map Prelude.Catalog.build_on_tuple
- [ "insert"; "update"; "delete" ])
- in
- let* timing_rel = get_required db Prelude.Catalog.timing_rel_name in
- let* db, _, _ =
- create_tuples storage db timing_rel
- (List.map Prelude.Catalog.build_timing_tuple
- [ "immediate"; "deferred" ])
- in
- let* domain_rel = get_required db Prelude.Catalog.domain_rel_name in
- let* db, _, _ =
- create_tuples storage db domain_rel
- (List.map Prelude.Catalog.build_domain_tuple
- [ "integer"; "natural"; "rational"; "string" ])
- in
- let* schema_rel = get_required db Prelude.Catalog.schema_rel_name in
- let* db, _, _ =
- create_tuples storage db schema_rel
- [ Prelude.Catalog.build_schema_tuple Qualified_name.default_schema ]
- in
- Ok db
-
- (*
- Database Operations
- *)
-
- (** Register a domain in the database. Can be called after [create_database]
- to add user-defined domains (e.g. [money], [email], [uuid]). Also inserts
- a tuple into [public:domain] if the catalog is live. *)
- let register_domain (storage : storage) (db : Management.Database.t)
- (domain : Domain.t) : (Management.Database.t, error) Result.t =
- let db = Management.Database.add_domain db domain in
- match
- Management.Database.get_relation db Prelude.Catalog.domain_rel_name
- with
- | None -> Ok db (* catalog not yet initialized *)
- | Some dom_cat ->
- let dom_tuple = Prelude.Catalog.build_domain_tuple domain.name in
- let* new_db, _, _ = create_tuple storage db dom_cat dom_tuple in
- Ok new_db
-
- (** Create a new database pre-seeded with the standard prelude domains and the
- system catalog relations. *)
- let create_database (storage : storage) ~name :
- (Management.Database.t, error) Result.t =
- (* Register prelude domains first (catalog does not exist yet, so no catalog update) *)
- let db =
- List.fold_left Management.Database.add_domain
- (Management.Database.empty ~name)
- Prelude.Domains.[ integer; natural; rational; string ]
- in
- (* Bootstrap catalog relations and seed them *)
- init_catalog_relations storage db
-
- (** Get database history *)
- let database_history (db : Management.Database.t) : Conventions.Hash.t list =
- db.history
-
- (*
- Relation Operations
- *)
-
- (** Create a new empty relation with the given schema. Also updates
- [public:relation] and [public:attribute] in the system catalog. *)
- let create_relation (storage : storage) (db : Management.Database.t)
- ~(name : string) ~(schema : Schema.t) :
- (Management.Database.t * Relation.t, error) Result.t =
- let name = normalize_name name in
- if Management.Database.has_relation db name then
- Error (Error.RelationAlreadyExists name)
- else
- let tree = Merkle.empty in
- let relation_hash = Hashing.hash_relation ~name ~schema ~tree in
- let relation =
- Relation.make ~hash:(Some relation_hash) ~name ~schema ~tree:(Some tree)
- ~constraints:None ~cardinality:(Conventions.Cardinality.Finite 0)
- ~generator:None
- ~membership_criteria:(build_membership_criteria ~name schema)
- ~provenance:(Relation.Provenance.Base name)
- ~lineage:(Relation.Lineage.Base name) ()
- in
- let new_db = Management.Database.add_relation db ~relation in
- let* () = store_relation storage relation in
- let* final_db = update_catalog_on_create storage new_db relation in
- let* () = store_database storage final_db in
- Ok (final_db, relation)
-
- (** Create an immutable/generator-based relation *)
- let create_immutable_relation (storage : storage) (db : Management.Database.t)
- ~(name : string) ~(schema : Schema.t) ~(generator : Generator.t)
- ~(membership_criteria : (string -> Merkle.t option) -> Tuple.t -> bool)
- ~(cardinality : Conventions.Cardinality.t)
- ~(producer : Relation.producer option) :
- (Management.Database.t * Relation.t, error) Result.t =
- let name = normalize_name name in
- if Management.Database.has_relation db name then
- Error (Error.RelationAlreadyExists name)
- else
- let relation_hash =
- Hashing.hash_relation ~name ~schema ~tree:Merkle.empty
- in
- let relation =
- Relation.make ~hash:(Some relation_hash) ~name ~schema
- ~tree:None (* No tree for generator-based relations *)
- ~constraints:None ~cardinality ~generator:(Some generator) ~producer
- ~membership_criteria ~provenance:(Relation.Provenance.Base name)
- ~lineage:(Relation.Lineage.Base name) ()
- in
- let new_db = Management.Database.add_relation db ~relation in
- let* () = store_relation storage relation in
- let* final_db = update_catalog_on_create storage new_db relation in
- let* () = store_database storage final_db in
- Ok (final_db, relation)
-
- (** Remove a relation from the database. Also removes its entries from
- [public:relation] and [public:attribute]. *)
- let retract_relation (storage : storage) (db : Management.Database.t)
- ~(name : string) : (Management.Database.t, error) Result.t =
- let name = normalize_name name in
- match Management.Database.get_relation db name with
- | None -> Error (Error.RelationNotFound name)
- | Some relation ->
- let new_db = Management.Database.remove_relation db ~name in
- (* Update catalog on the db state that no longer contains the retracted relation *)
- let* final_db = update_catalog_on_retract storage new_db relation in
- let* () = store_database storage final_db in
- Ok final_db
-
- (** Clear all tuples from a relation (truncate) *)
- let clear_relation (storage : storage) (db : Management.Database.t)
- (relation : Relation.t) :
- (Management.Database.t * Relation.t, error) Result.t =
- let name = relation.name in
- match Management.Database.get_relation db name with
- | None -> Error (Error.RelationNotFound name)
- | Some _ ->
- let new_tree = Merkle.empty in
- let new_hash =
- Hashing.hash_relation ~name ~schema:relation.schema ~tree:new_tree
- in
- let new_relation =
- {
- relation with
- hash = Some new_hash;
- tree = Some new_tree;
- cardinality = Conventions.Cardinality.Finite 0;
- membership_criteria =
- build_membership_criteria ~name relation.schema;
- }
- in
- let new_db =
- Management.Database.update_relation db ~relation:new_relation
- in
- let* () = store_relation storage new_relation in
- let* () = store_database storage new_db in
- Ok (new_db, new_relation)
-
- (** Attach constraints to an existing relation. Rebuilds membership_criteria
- to include constraint checking, re-hashes, and persists. *)
- let update_relation_constraints (storage : storage)
- (db : Management.Database.t) ~(relation_name : string)
- ~(constraints : Relation.RelationConstraint.t) :
- (Management.Database.t * Relation.t, error) Result.t =
- let relation_name = normalize_name relation_name in
- match Management.Database.get_relation db relation_name with
- | None -> Error (Error.RelationNotFound relation_name)
- | Some relation ->
- let merged_constraints =
- match relation.constraints with
- | None -> constraints
- | Some existing -> Constraint.merge existing constraints
- in
- (* Do not bake constraint evaluation into membership_criteria.
- create_tuple evaluates constraints with the current db snapshot.
- membership_criteria stays for schema/domain validation only. *)
- let new_relation =
- { relation with constraints = Some merged_constraints }
- in
- (* Re-hash *)
- let new_relation =
- match new_relation.tree with
- | Some tree ->
- let h =
- Hashing.hash_relation ~name:relation_name
- ~schema:relation.schema ~tree
- in
- { new_relation with hash = Some h }
- | None -> new_relation
- in
- let new_db =
- Management.Database.update_relation db ~relation:new_relation
- in
- let* () = store_relation storage new_relation in
- let* () = store_database storage new_db in
- Ok (new_db, new_relation)
-
- (** Register a named constraint on a relation. Attaches the constraint body to
- the relation AND records it in [public:constraint]. *)
- let register_constraint (storage : storage) (db : Management.Database.t)
- ~(constraint_name : string) ~(relation_name : string)
- ~(body : Constraint.t) : (Management.Database.t, error) Result.t =
- let relation_name = normalize_name relation_name in
- let body = normalize_constraint_body body in
- let* db, _ =
- update_relation_constraints storage db ~relation_name
- ~constraints:[ (constraint_name, body) ]
- in
- match
- Management.Database.get_relation db Prelude.Catalog.constraint_rel_name
- with
- | None -> Ok db
- | Some con_cat ->
- let con_tuple =
- Prelude.Catalog.build_constraint_tuple constraint_name relation_name
- in
- let* new_db, _, _ = create_tuple storage db con_cat con_tuple in
- Ok new_db
-
- (*Query Operations *)
-
- (** Get all tuple hashes from a relation *)
- let tuple_hashes (relation : Relation.t) : Conventions.Hash.t list =
- match relation.tree with None -> [] | Some tree -> Merkle.keys tree
-
- (** Get relation by name from database *)
- let get_relation (db : Management.Database.t) ~(name : string) :
- Relation.t option =
- Management.Database.get_relation db (normalize_name name)
-
- (** Count tuples in a relation *)
- let tuple_count (relation : Relation.t) : int =
- match relation.tree with None -> 0 | Some tree -> Merkle.size tree
-
- (** Check if a tuple exists in a relation *)
- let tuple_exists (relation : Relation.t) (tuple_hash : Conventions.Hash.t) :
- bool =
- match relation.tree with
- | None -> false
- | Some tree -> Merkle.member tuple_hash tree
-
- (** Attach a named constraint with timing metadata. Immediate constraints are
- added to the relation's constraint list. Deferred constraints are recorded
- in the database's deferred list and also attached to the relation (for
- schema visibility). *)
- let attach_constraint (storage : storage) (db : Management.Database.t)
- ~(constraint_name : string) ~(relation_name : string)
- ~(body : Constraint.t) ~(timing : Constraint.timing) :
- (Management.Database.t, error) Result.t =
- let relation_name = normalize_name relation_name in
- let body = normalize_constraint_body body in
- let* db, _ =
- update_relation_constraints storage db ~relation_name
- ~constraints:[ (constraint_name, body) ]
- in
- match timing with
- | Constraint.Immediate -> Ok db
- | Constraint.Deferred ->
- let entry : Management.Database.deferred_entry =
- { relation_name; constraint_name; body }
- in
- Ok { db with deferred = entry :: db.deferred }
-
- (** Check all deferred constraints against the current database state. Returns
- [Ok ()] if all pass, or an error on the first violation. *)
- let check_deferred_constraints (storage : storage)
- (db : Management.Database.t) : (unit, error) Result.t =
- let ctx = build_eval_context storage db in
- fold_result
- (fun () (entry : Management.Database.deferred_entry) ->
- match Management.Database.get_relation db entry.relation_name with
- | None -> Ok ()
- | Some rel ->
- let hashes =
- match rel.tree with None -> [] | Some t -> Merkle.keys t
- in
- fold_result
- (fun () h ->
- with_loaded_tuple storage h ~on_some:(fun tup ->
- match
- Constraint.evaluate_first_failure ctx tup
- [ (entry.constraint_name, entry.body) ]
- with
- | Ok true -> Ok ()
- | Ok false | Error _ ->
- Error
- (Error.ConstraintViolation
- (Printf.sprintf
- "deferred constraint %s on %s violated"
- entry.constraint_name entry.relation_name))))
- () hashes)
- () db.deferred
-
- (** Complete a mutation sequence by evaluating all deferred constraints
- against the current database state.
-
- On success, returns the database with the deferred list cleared.
- Subsequent mutations start a fresh deferral window. On failure, returns
- the constraint violation error and leaves the database unchanged so the
- caller can inspect or roll back.
-
- Typical usage: let db = create_tuple storage db rel t1 in let db =
- retract_tuple storage db rel t2 in let db = commit storage db in (*
- deferred checks run here *) ... *)
- let commit (storage : storage) (db : Management.Database.t) :
- (Management.Database.t, error) Result.t =
- let* () = check_deferred_constraints storage db in
- let db' = { db with deferred = [] } in
- let* () = store_database storage db' in
- Ok db'
+ load_attrs [] attributes
+ |> Result.map (List.fold_left
+ (fun m (k, v) -> Tuple.AttributeMap.add k v m)
+ Tuple.AttributeMap.empty)
+ |> Result.map (fun attributes -> Some { Tuple.relation = relation; attributes })
end
diff --git a/lib/merkle.ml b/lib/merkle.ml
deleted file mode 100644
index 6c4be52..0000000
--- a/lib/merkle.ml
+++ /dev/null
@@ -1,70 +0,0 @@
-(** Merkle tree module signature for content-addressed hash sets.
-
- This is an opaque interface that can be backed by different implementations:
- - A simple hash set (current placeholder)
- - A proper radix/patricia merkle tree (e.g., plebeia when OCaml 5 support
- arrives)
-
- The tree stores hashes as keys (like a set) and computes a root hash from
- all contained elements. *)
-
-module type S = sig
- type t
-
- val empty : t
- (** The empty tree *)
-
- val is_empty : t -> bool
- (** Check if tree is empty *)
-
- val insert : Conventions.Hash.t -> t -> t
- (** Insert a hash into the tree. Returns a new tree. *)
-
- val delete : Conventions.Hash.t -> t -> t
- (** Delete a hash from the tree. Returns a new tree. *)
-
- val member : Conventions.Hash.t -> t -> bool
- (** Check if a hash is in the tree *)
-
- val keys : t -> Conventions.Hash.t list
- (** Get all hashes in the tree *)
-
- val root_hash : t -> Conventions.Hash.t option
- (** Compute the root hash of the tree. None if empty. *)
-
- val size : t -> int
- (** Number of elements in the tree *)
-end
-
-(** Simple hash set implementation. This is a placeholder until a proper
- radix-merkle library with OCaml 5 support becomes available. *)
-module HashSet : S = struct
- module StringSet = Set.Make (String)
-
- type t = StringSet.t
-
- let empty = StringSet.empty
- let is_empty = StringSet.is_empty
- let insert hash tree = StringSet.add hash tree
- let delete hash tree = StringSet.remove hash tree
- let member hash tree = StringSet.mem hash tree
- let keys tree = StringSet.elements tree
- (* TODO: Streaming/pagination for large tuple sets. Currently materializes
- entire keyset into memory, which fails for relations with billions of tuples.
- Replace with paginated access (keys_paginated offset limit) or lazy generator
- to avoid loading all hashes upfront. Consider replacing HashSet with proper
- radix-merkle tree (plebeia) for native lazy traversal. *)
-
- let root_hash tree =
- if StringSet.is_empty tree then None
- else
- (* Compute root hash by hashing sorted concatenation of all hashes *)
- let sorted_hashes = StringSet.elements tree in
- let concatenated = String.concat "" sorted_hashes in
- Some (Conventions.Hash.hash_text concatenated)
-
- let size = StringSet.cardinal
-end
-
-include HashSet
-(** Default implementation using HashSet *)
diff --git a/lib/nt.ml b/lib/nt.ml
new file mode 100644
index 0000000..c980093
--- /dev/null
+++ b/lib/nt.ml
@@ -0,0 +1,41 @@
+(* PermissionsManager::Firewall — validates a connection during login and
+ returns the set of claims granted to the authenticated connection. *)
+let firewall _method = failwith "NOT IMPLEMENTED"
+
+let get_relation _db _name = failwith "NOT IMPLEMENTED"
+let create_multigroup _storage _name = failwith "NOT IMPLEMENTED"
+let create_relation _storage _db _name _schema = failwith "NOT IMPLEMENTED"
+let create_tuple _storage _db _ll_rel _tuple = failwith "NOT IMPLEMENTED"
+let [@warning "-27"] register_constraint storage db ~constraint_name ~relation_name ~body = failwith "NOT IMPLEMENTED"
+let [@warning "-27"] create_tuples storage db rel tuples = failwith "NOT IMPLEMENTED"
+let [@warning "-27"] create_immutable_relation storage db ~name ~schema ~generator
+ ~membership_criteria
+ ~cardinality
+ ~producer = failwith "NOT IMPLEMENTED"
+let retract_relation _storage _db _name = failwith "NOT IMPLEMENTED"
+let retract_tuple _storage _db _mg_rel _tuple_hash = failwith "NOT IMPLEMENTED"
+let clear_relation _storage _db _rel = failwith "NOT IMPLEMENTED"
+let register_domain _storage _db _domain = failwith "NOT IMPLEMENTED"
+(* let tuple_hashes _rel = failwith "NOT IMPLEMENTED" *)
+(* let load_tuples _storage _hashes = failwith "NOT IMPLEMENTED" *)
+let tuple_hashes = failwith "NOT IMPLEMENTED"
+let load_tuples _storage _rel_hash = failwith "NOT IMPLEMENTED"
+
+
+type catalog_object =
+ | Multigroup of Management.Multigroup.multigroup
+ | Relation of Relation.relation
+
+type object_type =
+ | Multigroup
+ | Relation
+
+type handle =
+ { path : string list
+ ; obj : bytes }
+
+(* Each class should have their own *)
+let deserialize _ _ : object_type -> bytes -> (catalog_object, string) result = failwith "NOT IMPLEMENTED"
+
+let open_handle _ _ : path:string list -> connection_context:string -> (handle, string) result = failwith "NOT IMPLEMENTED"
+let close _ : handle -> (unit, string) result = failwith "NOT IMPLEMENTED"
diff --git a/lib/prelude/domains.ml b/lib/prelude/domains.ml
index d892696..022cc6b 100644
--- a/lib/prelude/domains.ml
+++ b/lib/prelude/domains.ml
@@ -1,9 +1,9 @@
-(** Predefined fundamental domains, ported from the Erlang implementation. Each
- domain carries a generator (for enumeration) and membership criteria (for
- validation). Values are stored as {!Conventions.AbstractValue.t} via
- [Obj.magic], following the same convention as {!Standard}. *)
+(** Predefined fundamental domains. Each domain carries a generator
+ (for enumeration) and membership criteria (for validation). Values
+ are stored as {!Conventions.AbstractValue.t} via [Obj.magic],
+ following the same convention as {!Standard}. *)
-(** Bijection from natural number to integer: 0→0, 1→1, 2→-1, 3→2, 4→-2, … *)
+(** Bijection from natural number to integer: 0->0, 1->1, 2->-1, 3->2, 4->-2, ... *)
let nat_to_int n =
if n = 0 then 0 else if n mod 2 = 1 then (n + 1) / 2 else -(n / 2)
@@ -20,7 +20,7 @@ let cantor_unpair n =
(** Integer domain: all integers, enumerated via a bijection from the naturals.
Schema: [value: integer]. *)
-let integer : Domain.t =
+let integer : Relation.domain =
let rec generator (position : int option) : Generator.result =
match position with
| Some n ->
@@ -38,13 +38,23 @@ let integer : Domain.t =
| Tuple.Materialized _ -> true
| Tuple.NonMaterialized _ -> false
in
- Domain.make ~name:"integer" ~generator ~membership_criteria
- ~cardinality:Conventions.Cardinality.AlephZero ~compare:(fun a b ->
- Stdlib.compare (Obj.magic a : int) (Obj.magic b : int))
+ let schema =
+ Schema.empty
+ |> Schema.add "value" "integer"
+ in
+ new Relation.domain
+ ~name:"integer"
+ ~generator
+ ~membership_criteria
+ ~schema
+ ~constraints:None
+ ~cardinality:Conventions.Cardinality.AlephZero
+ ~lineage:None
+ ~provenance:None
(** Natural number domain: non-negative integers (0, 1, 2, …). Schema:
[value: natural]. *)
-let natural : Domain.t =
+let natural : Relation.domain =
let rec generator (position : int option) : Generator.result =
match position with
| Some n ->
@@ -64,15 +74,25 @@ let natural : Domain.t =
| None -> false)
| Tuple.NonMaterialized _ -> false
in
- Domain.make ~name:"natural" ~generator ~membership_criteria
- ~cardinality:Conventions.Cardinality.AlephZero ~compare:(fun a b ->
- Stdlib.compare (Obj.magic a : int) (Obj.magic b : int))
+ let schema =
+ Schema.empty
+ |> Schema.add "value" "natural"
+ in
+ new Relation.domain
+ ~name:"natural"
+ ~generator
+ ~membership_criteria
+ ~schema
+ ~constraints:None
+ ~cardinality:Conventions.Cardinality.AlephZero
+ ~lineage:None
+ ~provenance:None
(** Rational number domain: pairs [(numerator, denominator)] where the
denominator is never zero. The generator enumerates all such pairs via
Cantor pairing on the integers. Schema:
[numerator: integer, denominator: integer]. *)
-let rational : Domain.t =
+let rational : Relation.domain =
let rec generator (position : int option) : Generator.result =
match position with
| Some n ->
@@ -97,12 +117,37 @@ let rational : Domain.t =
| None -> false)
| Tuple.NonMaterialized _ -> false
in
- Domain.make ~name:"rational" ~generator ~membership_criteria
- ~cardinality:Conventions.Cardinality.AlephZero ~compare:(fun a b ->
- Stdlib.compare (Obj.magic a : float) (Obj.magic b : float))
+ (* Note: Additionally to the membership criteria, we add the constraint here as this relation
+ can be further dismembered, rendering the denominator into a lone integer, that should
+ propagate the constraint `integer <> 0`. If we declared a domain `integer_without_zero`,
+ then this constraint would not be needed as the domain would not be dissociated from the value. *)
+ let constraints: Relation.RelationConstraint.t option =
+ let denominator_not_zero =
+ let open Constraint in
+ Not
+ { body = Eq {left = Var "denominator"; right = Const (Obj.magic 0)}
+ ; universe = "integer" }
+ in
+ Some (("DENOMINATOR_DIFFERENT_FROM_ZERO", denominator_not_zero)
+ |> List.singleton)
+ in
+ let schema =
+ Schema.empty
+ |> Schema.add "numerator" "integer"
+ |> Schema.add "denominator" "integer"
+ in
+ new Relation.domain
+ ~name:"rational"
+ ~generator
+ ~membership_criteria
+ ~schema
+ ~constraints
+ ~cardinality:Conventions.Cardinality.AlephZero
+ ~lineage:None
+ ~provenance:None
(** String domain: any string value. Not enumerable. Schema: [value: string]. *)
-let string : Domain.t =
+let string : Relation.domain =
let generator (_ : int option) : Generator.result =
Generator.Error "Strings are not enumerable."
in
@@ -110,6 +155,17 @@ let string : Domain.t =
| Tuple.Materialized _ -> true
| Tuple.NonMaterialized _ -> false
in
- Domain.make ~name:"string" ~generator ~membership_criteria
- ~cardinality:Conventions.Cardinality.AlephZero ~compare:(fun a b ->
- String.compare (Obj.magic a : string) (Obj.magic b : string))
+ let schema =
+ Schema.empty
+ |> Schema.add "value" "string"
+ in
+ new Relation.domain
+ ~name:"string"
+ ~generator
+ ~membership_criteria
+ ~schema
+ ~constraints:None
+ (* TODO: Implement some form of enumeration for strings with a bijection on naturals. *)
+ ~cardinality:Conventions.Cardinality.Continuum
+ ~lineage:None
+ ~provenance:None
diff --git a/lib/prelude/standard.ml b/lib/prelude/standard.ml
index 8b0db9f..f38ee40 100644
--- a/lib/prelude/standard.ml
+++ b/lib/prelude/standard.ml
@@ -15,8 +15,9 @@ let make_comparison ~name ~domain_name ~pred ~cardinality ~generator =
|> Schema.add "left" domain_name
|> Schema.add "right" domain_name
in
- let membership_criteria : (string -> Merkle.t option) -> Tuple.t -> bool =
- fun _tree_of -> function
+ let membership_criteria : (*(string -> Merkle.t option) ->*) Tuple.t -> bool =
+ (* fun _tree_of -> function *)
+ function
| Tuple.Materialized m -> (
match
( Tuple.AttributeMap.find_opt "left" m.attributes,
@@ -27,10 +28,15 @@ let make_comparison ~name ~domain_name ~pred ~cardinality ~generator =
| _ -> false)
| Tuple.NonMaterialized _ -> false
in
- Relation.make ~hash:None ~name ~schema ~tree:None ~constraints:None
- ~cardinality ~generator:(Some generator) ~membership_criteria
- ~provenance:(Relation.Provenance.Base name)
- ~lineage:(Relation.Lineage.Base name) ()
+ new Relation.ephemeral
+ ~name
+ ~schema
+ ~constraints:None
+ ~cardinality
+ ~generator
+ ~membership_criteria
+ ~provenance:None
+ ~lineage:None
(** Enumerate pairs (a, b) where a < b using triangular indexing. *)
let pair_of_nat_lt n =
@@ -50,7 +56,7 @@ let cantor_pair_of_nat n =
let a = w - b in
(a, b)
-let less_than_natural : Relation.t =
+let less_than_natural : Relation.ephemeral =
let rec generator (position : int option) : Generator.result =
match position with
| Some position ->
@@ -69,7 +75,7 @@ let less_than_natural : Relation.t =
~pred:(fun c -> c < 0)
~cardinality:Conventions.Cardinality.AlephZero ~generator
-let less_than_or_equal_natural : Relation.t =
+let less_than_or_equal_natural : Relation.ephemeral =
let rec generator (position : int option) : Generator.result =
match position with
| Some n ->
@@ -90,7 +96,7 @@ let less_than_or_equal_natural : Relation.t =
~pred:(fun c -> c <= 0)
~cardinality:Conventions.Cardinality.AlephZero ~generator
-let greater_than_natural : Relation.t =
+let greater_than_natural : Relation.ephemeral =
let rec generator (position : int option) : Generator.result =
match position with
| Some n ->
@@ -108,7 +114,7 @@ let greater_than_natural : Relation.t =
~pred:(fun c -> c > 0)
~cardinality:Conventions.Cardinality.AlephZero ~generator
-let greater_than_or_equal_natural : Relation.t =
+let greater_than_or_equal_natural : Relation.ephemeral =
let rec generator (position : int option) : Generator.result =
match position with
| Some n ->
@@ -128,7 +134,7 @@ let greater_than_or_equal_natural : Relation.t =
~pred:(fun c -> c >= 0)
~cardinality:Conventions.Cardinality.AlephZero ~generator
-let equal_natural : Relation.t =
+let equal_natural : Relation.ephemeral =
let rec generator (position : int option) : Generator.result =
match position with
| Some n ->
@@ -143,7 +149,7 @@ let equal_natural : Relation.t =
~pred:(fun c -> c = 0)
~cardinality:Conventions.Cardinality.AlephZero ~generator
-let not_equal_natural : Relation.t =
+let not_equal_natural : Relation.ephemeral =
let rec generator (position : int option) : Generator.result =
match position with
| Some n ->
@@ -160,7 +166,7 @@ let not_equal_natural : Relation.t =
~pred:(fun c -> c <> 0)
~cardinality:Conventions.Cardinality.AlephZero ~generator
-let plus_natural : Relation.t =
+let plus_natural : Relation.ephemeral =
let schema =
Schema.empty |> Schema.add "a" "natural" |> Schema.add "b" "natural"
|> Schema.add "sum" "natural"
@@ -177,8 +183,9 @@ let plus_natural : Relation.t =
(Tuple.make_materialized ~relation:"plus" ~attributes, generator)
| None -> Error "Cannot enumerate plus randomly."
in
- let membership_criteria : (string -> Merkle.t option) -> Tuple.t -> bool =
- fun _tree_of -> function
+ let membership_criteria : Tuple.t -> bool =
+ (* fun _tree_of -> *)
+ function
| Tuple.Materialized m -> (
match
( Tuple.AttributeMap.find_opt "a" m.attributes,
@@ -192,13 +199,17 @@ let plus_natural : Relation.t =
| _ -> false)
| Tuple.NonMaterialized _ -> false
in
- Relation.make ~hash:None ~name:"natural_plus" ~schema ~tree:None
- ~constraints:None ~cardinality:Conventions.Cardinality.AlephZero
- ~generator:(Some generator) ~membership_criteria
- ~provenance:(Relation.Provenance.Base "plus")
- ~lineage:(Relation.Lineage.Base "plus") ()
+ new Relation.ephemeral
+ ~name:"natural_plus"
+ ~schema
+ ~constraints:None
+ ~cardinality:Conventions.Cardinality.AlephZero
+ ~generator
+ ~membership_criteria
+ ~provenance:None
+ ~lineage:None
-let times_natural : Relation.t =
+let times_natural : Relation.ephemeral =
let schema =
Schema.empty |> Schema.add "a" "natural" |> Schema.add "b" "natural"
|> Schema.add "product" "natural"
@@ -216,8 +227,9 @@ let times_natural : Relation.t =
(Tuple.make_materialized ~relation:"times" ~attributes, generator)
| None -> Error "Cannot enumerate times randomly."
in
- let membership_criteria : (string -> Merkle.t option) -> Tuple.t -> bool =
- fun _tree_of -> function
+ let membership_criteria : Tuple.t -> bool =
+ (* fun _tree_of -> *)
+ function
| Tuple.Materialized m -> (
match
( Tuple.AttributeMap.find_opt "a" m.attributes,
@@ -231,13 +243,17 @@ let times_natural : Relation.t =
| _ -> false)
| Tuple.NonMaterialized _ -> false
in
- Relation.make ~hash:None ~name:"natural_times" ~schema ~tree:None
- ~constraints:None ~cardinality:Conventions.Cardinality.AlephZero
- ~generator:(Some generator) ~membership_criteria
- ~provenance:(Relation.Provenance.Base "times")
- ~lineage:(Relation.Lineage.Base "times") ()
+ new Relation.ephemeral
+ ~name:"natural_times"
+ ~schema
+ ~constraints:None
+ ~cardinality:Conventions.Cardinality.AlephZero
+ ~generator
+ ~membership_criteria
+ ~provenance:None
+ ~lineage:None
-let minus_natural : Relation.t =
+let minus_natural : Relation.ephemeral =
let schema =
Schema.empty |> Schema.add "a" "natural" |> Schema.add "b" "natural"
|> Schema.add "difference" "natural"
@@ -256,10 +272,11 @@ let minus_natural : Relation.t =
(Tuple.make_materialized ~relation:"minus" ~attributes, generator)
| None -> Error "Cannot enumerate minus randomly."
in
- let membership_criteria : (string -> Merkle.t option) -> Tuple.t -> bool =
- fun _tree_of -> function
- | Tuple.Materialized m -> (
- match
+ let membership_criteria : Tuple.t -> bool =
+ (* fun _tree_of -> *)
+ function
+ | Tuple.Materialized m ->
+ begin match
( Tuple.AttributeMap.find_opt "a" m.attributes,
Tuple.AttributeMap.find_opt "b" m.attributes,
Tuple.AttributeMap.find_opt "difference" m.attributes )
@@ -269,16 +286,21 @@ let minus_natural : Relation.t =
let bv = (Obj.magic b.Attribute.value : int) in
let dv = (Obj.magic d.Attribute.value : int) in
av - bv = dv && dv >= 0
- | _ -> false)
+ | _ -> false
+ end
| Tuple.NonMaterialized _ -> false
in
- Relation.make ~hash:None ~name:"natural_minus" ~schema ~tree:None
- ~constraints:None ~cardinality:Conventions.Cardinality.AlephZero
- ~generator:(Some generator) ~membership_criteria
- ~provenance:(Relation.Provenance.Base "minus")
- ~lineage:(Relation.Lineage.Base "minus") ()
+ new Relation.ephemeral
+ ~name:"natural_minus"
+ ~schema
+ ~constraints:None
+ ~cardinality:Conventions.Cardinality.AlephZero
+ ~generator
+ ~membership_criteria
+ ~provenance:None
+ ~lineage:None
-let divide_natural : Relation.t =
+let divide_natural : Relation.ephemeral =
let schema =
Schema.empty |> Schema.add "a" "natural" |> Schema.add "b" "natural"
|> Schema.add "quotient" "natural"
@@ -305,8 +327,9 @@ let divide_natural : Relation.t =
(Tuple.make_materialized ~relation:"divide" ~attributes, generator)
| None -> Error "Cannot enumerate divide randomly."
in
- let membership_criteria : (string -> Merkle.t option) -> Tuple.t -> bool =
- fun _tree_of -> function
+ let membership_criteria : Tuple.t -> bool =
+ (* fun _tree_of -> *)
+ function
| Tuple.Materialized m -> (
match
( Tuple.AttributeMap.find_opt "a" m.attributes,
@@ -323,11 +346,15 @@ let divide_natural : Relation.t =
| _ -> false)
| Tuple.NonMaterialized _ -> false
in
- Relation.make ~hash:None ~name:"natural_divide" ~schema ~tree:None
- ~constraints:None ~cardinality:Conventions.Cardinality.AlephZero
- ~generator:(Some generator) ~membership_criteria
- ~provenance:(Relation.Provenance.Base "divide")
- ~lineage:(Relation.Lineage.Base "divide") ()
+ new Relation.ephemeral
+ ~name:"natural_divide"
+ ~schema
+ ~constraints:None
+ ~cardinality:Conventions.Cardinality.AlephZero
+ ~generator
+ ~membership_criteria
+ ~provenance:None
+ ~lineage:None
let prelude_relations =
[
diff --git a/lib/prl/executor.ml b/lib/prl/executor.ml
index 6a53656..10b5142 100644
--- a/lib/prl/executor.ml
+++ b/lib/prl/executor.ml
@@ -20,8 +20,8 @@ module Make (Storage : Management.Physical.S) = struct
let ( let* ) = Result.bind
let map_rel_error r = Result.map_error (fun e -> RelationError e) r
- let require_relation (db : Management.Database.t) rel_name =
- match Management.Database.get_relation db rel_name with
+ let require_relation (db : Management.Multigroup.multigroup) rel_name =
+ match Ops.get_relation db#hash rel_name with
| Some rel -> Ok rel
| None -> Error (RelationNotFound rel_name)
diff --git a/lib/prl/runtime.ml b/lib/prl/runtime.ml
index 4b746d4..9ebef84 100644
--- a/lib/prl/runtime.ml
+++ b/lib/prl/runtime.ml
@@ -69,11 +69,12 @@ let make_producer relation_name schema (impl : Sakura_prl_api.implementation) :
fun bindings -> make_generator relation_name schema impl bindings
let make_membership_criteria schema (impl : Sakura_prl_api.implementation) :
- (string -> Merkle.t option) -> Tuple.t -> bool =
+ Tuple.t -> bool =
match impl.membership_criteria with
- | None -> fun _ _ -> false
+ | None -> fun _ -> false
| Some check -> (
- fun _tree_of -> function
+ (* fun _tree_of -> *)
+ function
| Tuple.NonMaterialized _ -> false
| Tuple.Materialized m -> (
match to_plugin_row schema m with
diff --git a/lib/relation.ml b/lib/relation.ml
index db7f453..670c227 100644
--- a/lib/relation.ml
+++ b/lib/relation.ml
@@ -1,61 +1,212 @@
-module Tree = Merkle
-(** Use the Merkle module for tuple hash storage *)
+(** Relation: a lightweight versioned root describing a named collection of
+ tuples. Physical storage owns the tuple B+ tree; this object holds only
+ metadata and a tree pointer.
+
+ Class hierarchy:
+ - [relation] — base, storable, has membership_criteria/provenance/lineage
+ - [ephemeral_relation] — adds a generator (query-time computed, not stored)
+ - [pseudo_relation] — adds a producer (system-defined, not stored)
+ - [domain] — adds a generator (system or user defined, not necessarily
+ stored) *)
module RelationConstraint = struct
type name = string
type t = (name * Constraint.t) list
end
-module Provenance = struct
+module Lineage = struct
+ (** Tracks which relational algebra operations produced the tuples. Lives in
+ the relation, but refers to the tuple. *)
type t =
- | Undefined
| Base of Conventions.Name.t
+ | Select of t
+ | Project of Conventions.Name.t list * t
| Join of t * t
- | Select of t * (Tuple.t -> bool)
- | Project of t * string list
- | Take of t * int
+ | ThetaJoin of t * t
+ | Sort of t
+ | Take of t
end
-module Lineage = struct
+module Provenance = struct
+ type source = { relation : Conventions.Name.t; attribute : string }
+ (** Tracks which base relation each attribute originates from. Lives on the
+ relation and refers to the `entity group`. *)
+
type t =
+ | Undefined
| Base of Conventions.Name.t
- | Select of (string -> bool) * t
- | Project of string list * t
- | Join of string * t * t
- | ThetaJoin of (string -> string -> bool) * t * t
- | Sort of (string -> string -> int) * t
- | Take of int * t
- | Aggregate of string * string * t
+ | Sources of source list BatMap.String.t
+ (** Maps attribute name -> list of sources (multiple after joins) *)
+
+ let base ~relation ~attributes : t =
+ Sources
+ (List.fold_left
+ (fun acc attr ->
+ BatMap.String.add attr [ { relation; attribute = attr } ] acc)
+ BatMap.String.empty attributes)
+
+ let empty : t = Sources BatMap.String.empty
+
+ let undefined : t = Undefined
end
type producer = (string * Conventions.AbstractValue.t) list -> Generator.t
-type t = {
- hash : Conventions.Hash.t option;
- name : Conventions.Name.t;
- schema : Schema.t;
- tree : Tree.t option;
- constraints : RelationConstraint.t option;
- cardinality : Conventions.Cardinality.t;
- generator : Generator.t option;
- producer : producer option;
- membership_criteria : (string -> Tree.t option) -> Tuple.t -> bool;
- provenance : Provenance.t;
- lineage : Lineage.t;
-}
-
-let make ?(producer = None) ~hash ~name ~schema ~tree ~constraints ~cardinality
- ~generator ~membership_criteria ~provenance ~lineage () =
- {
- hash;
- name;
- schema;
- tree;
- constraints;
- cardinality;
- generator;
- producer;
- membership_criteria;
- provenance;
- lineage;
- }
+type kind = [ `Stored | `Ephemeral | `Pseudo | `Domain ]
+
+class virtual relation = object (_self)
+ method virtual kind : kind
+ method virtual name : Conventions.Name.t
+ method virtual schema : Schema.t
+ method virtual hash : Conventions.Hash.t
+ method virtual constraints : RelationConstraint.t option
+ method virtual cardinality : Conventions.Cardinality.t
+ method virtual lineage : Lineage.t
+ method virtual provenance : Provenance.t
+ method virtual membership_criteria : Tuple.t -> bool
+ method virtual timestamp : float
+ method virtual serialize : unit -> Storable.Relation.t
+end
+
+class stored
+ ~name:(init_name : Conventions.Name.t)
+ ~schema:(init_schema : Schema.t)
+ ~constraints:(init_constraints : RelationConstraint.t option)
+ ~cardinality:(init_cardinality : Conventions.Cardinality.t)
+ ~membership_criteria:(init_membership : Tuple.t -> bool)
+ ~lineage:(init_lineage : Lineage.t option)
+ ~provenance:(init_provenance : Provenance.t option) =
+ let init_hash =
+ Conventions.Hash.hash_text (init_name ^ Schema.to_string init_schema)
+ in
+ object (self)
+ inherit relation
+
+ val name = init_name
+ val hash = init_hash
+ val schema = init_schema
+ val tree_pointer : Conventions.Hash.t option = None
+ val constraints = init_constraints
+ val cardinality = init_cardinality
+ val membership_criteria = init_membership
+ val timestamp = Unix.gettimeofday ()
+ val lineage = Option.value init_lineage ~default:(Lineage.Base init_name)
+ val provenance = Option.value init_provenance
+ ~default:(Provenance.base ~relation:init_name ~attributes:(Schema.attributes init_schema))
+
+ method name = name
+ method kind = `Stored
+ method hash = hash
+ method schema = schema
+ method tree_pointer = tree_pointer
+ method constraints = constraints
+ method cardinality = cardinality
+ method membership_criteria = membership_criteria
+ method timestamp = timestamp
+ method lineage = lineage
+ method provenance = provenance
+
+ method private compute_hash tp =
+ let tree_hash = match tp with Some h -> h | None -> "" in
+ Conventions.Hash.hash_text (name ^ Schema.to_string schema ^ tree_hash)
+
+ method private advance tp =
+ {< hash = self#compute_hash tp;
+ tree_pointer = tp;
+ timestamp = Unix.gettimeofday () >}
+
+ method set_tree_pointer tp = self#advance tp
+ method set_cardinality c = {< cardinality = c >}
+ method set_constraints c = {< constraints = c >}
+ method serialize () = { Storable.Relation.name = name; schema }
+end
+
+class ephemeral
+ ~name:(init_name : Conventions.Name.t)
+ ~schema
+ ~constraints
+ ~cardinality ~membership_criteria
+ ~lineage
+ ~provenance
+ ~generator:(init_generator : Generator.t) =
+ object
+ inherit relation
+ val name : Conventions.Name.t = init_name
+ val schema : Schema.t = schema
+ val generator : Generator.t = init_generator
+ val constraints = constraints
+ val cardinality = cardinality
+ val membership_criteria = membership_criteria
+ val lineage = Option.value lineage ~default:(Lineage.Base init_name)
+ val provenance = Option.value provenance ~default:(Provenance.Base init_name)
+ val timestamp = Unix.gettimeofday ()
+
+ method name = name
+ method kind = `Ephemeral
+ method schema = schema
+ method generator = generator
+ method hash = Conventions.Hash.hash_text (name ^ "ephemeral")
+ method constraints = constraints
+ method cardinality = cardinality
+ method membership_criteria = membership_criteria
+ method lineage = lineage
+ method provenance = provenance
+ method timestamp = timestamp
+
+ method serialize () = failwith "Ephemeral relations cannot be serialized directly"
+end
+
+class pseudo
+ ~name:(init_name : Conventions.Name.t) ~schema ~constraints ~cardinality ~membership_criteria ~lineage ~provenance
+ ~producer:(init_producer : producer) =
+ object
+ inherit relation
+ val name = init_name
+ val schema = schema
+ val producer = init_producer
+ val constraints = constraints
+ val cardinality = cardinality
+ val membership_criteria = membership_criteria
+ val lineage = Option.value lineage ~default:(Lineage.Base init_name)
+ val provenance = provenance
+ val timestamp = Unix.gettimeofday ()
+
+ method name = name
+ method kind = `Pseudo
+ method schema = schema
+ method producer = producer
+ method as_generator (bindings : (string * Conventions.AbstractValue.t) list) : Generator.t = producer bindings
+ method hash = Conventions.Hash.hash_text (name ^ "pseudo")
+ method constraints = constraints
+ method cardinality = cardinality
+ method membership_criteria = membership_criteria
+ method lineage = lineage
+ method provenance = provenance
+ method timestamp = timestamp
+
+ (* TODO: Remove this from the virtual definition *)
+ method serialize () = failwith "Pseudo relations are procedural"
+end
+
+let deserialize_stored (_bytes : bytes) : (stored, string) result =
+ try
+ let stored = Storable.Relation.of_bytes _bytes in
+ let membership_criteria =
+ Constraint.build_membership_criteria ~_name:stored.name ~schema:stored.schema
+ in
+ Ok
+ (new stored ~name:stored.name ~schema:stored.schema ~constraints:None
+ ~cardinality:Conventions.Cardinality.ConstrainedFinite
+ ~membership_criteria ~lineage:None ~provenance:None)
+ with Invalid_argument message -> Error message
+
+class domain ~name ~schema ~constraints ~cardinality ~membership_criteria
+ ~lineage ~provenance ~generator =
+ object
+ inherit ephemeral
+ ~name ~schema ~constraints ~cardinality
+ ~membership_criteria ~lineage
+ ~provenance ~generator
+
+ method! kind = `Domain
+ end
diff --git a/lib/scl/executor.ml b/lib/scl/executor.ml
index d48d852..7532eaa 100644
--- a/lib/scl/executor.ml
+++ b/lib/scl/executor.ml
@@ -6,10 +6,7 @@ type cursor_batch = {
has_more : bool;
}
-type exec_result = Batch of cursor_batch | Closed of Management.Database.t
-
-let sessions : Session.t option ref = ref None
-let set_sessions s = sessions := Some s
+type exec_result = Batch of cursor_batch | Closed of Management.Multigroup.multigroup
module Make (Storage : Management.Physical.S) = struct
module DrlExec = Drl.Executor.Make (Storage)
@@ -27,46 +24,18 @@ module Make (Storage : Management.Physical.S) = struct
| QueryError e -> DrlExec.sexp_of_error e
| CursorError s -> List [ Atom "cursor-error"; Atom s ]
- let get_sessions () =
- match !sessions with
- | Some s -> Ok s
- | None ->
- Error
- (CursorError
- "The session registry has not been initialised; ensure \
- `set_sessions` is called at startup.")
-
let ( let* ) = Result.bind
- let execute (storage : Storage.t) (db : Management.Database.t)
+ let execute (_storage : Storage.t) (db : Management.Multigroup.multigroup)
(stmt : Ast.statement) : (exec_result, error) result =
+ ignore default_batch;
match stmt with
- | Ast.Begin { query; limit } ->
- let* reg = get_sessions () in
- let* rel =
- DrlExec.execute storage db query
- |> Result.map_error (fun e -> QueryError e)
- in
- let gen = Alg.to_generator storage rel in
- let query_str = Drl.Parser.to_string query in
- let cur = Session.register reg ~db ~query:query_str ~generator:gen in
- let batch = Option.value ~default:default_batch limit in
- let* rows, has_more =
- Session.fetch reg ~id:cur.Session.id ~limit:batch
- |> Result.map_error (fun s -> CursorError s)
- in
- Ok (Batch { cursor_id = cur.Session.id; rows; has_more })
- | Ast.Fetch { cursor; limit } ->
- let* reg = get_sessions () in
- let batch = Option.value ~default:default_batch limit in
- let* rows, has_more =
- Session.fetch reg ~id:cursor ~limit:batch
- |> Result.map_error (fun s -> CursorError s)
- in
- Ok (Batch { cursor_id = cursor; rows; has_more })
- | Ast.Close { cursor } ->
- let* reg = get_sessions () in
- Session.close reg ~id:cursor;
+ | Ast.Begin _ ->
+ Error (CursorError "cursors not yet implemented")
+ | Ast.Fetch _ ->
+ Error (CursorError "cursors not yet implemented")
+ | Ast.Close _ ->
+ let* () = Ok () in
Ok (Closed db)
end
diff --git a/lib/session.ml b/lib/session.ml
deleted file mode 100644
index a4aef9d..0000000
--- a/lib/session.ml
+++ /dev/null
@@ -1,79 +0,0 @@
-(** Cursor registry for streaming tuple consumption.
-
- Each cursor wraps a [Generator.t] produced by a DRL query and tracks the
- current position so that successive [fetch] calls return the next batch of
- rows without replaying the query. *)
-
-type cursor = {
- id : string;
- mutable generator : Generator.t;
- mutable position : int;
- db_snapshot : Management.Database.t;
- query_sexp : string;
- created_at : float;
-}
-
-type t = { tbl : (string, cursor) Hashtbl.t; mutable counter : int }
-
-let create () : t = { tbl = Hashtbl.create 16; counter = 0 }
-
-let register (reg : t) ~(db : Management.Database.t) ~(query : string)
- ~(generator : Generator.t) : cursor =
- let raw = string_of_int reg.counter ^ query ^ db.Management.Database.hash in
- let id = Conventions.Hash.hash_text raw in
- reg.counter <- reg.counter + 1;
- let cur =
- {
- id;
- generator;
- position = 0;
- db_snapshot = db;
- query_sexp = query;
- created_at = Unix.gettimeofday ();
- }
- in
- Hashtbl.replace reg.tbl id cur;
- cur
-
-let fetch (reg : t) ~(id : string) ~(limit : int) :
- (Tuple.materialized list * bool, string) result =
- match Hashtbl.find_opt reg.tbl id with
- | None ->
- Error
- ("The cursor with identifier `" ^ id
- ^ "` was not found in the session registry.")
- | Some cur ->
- let rec go gen pos acc count =
- if count >= limit then (List.rev acc, gen, pos, true)
- else
- match gen (Some pos) with
- | Generator.Done -> (List.rev acc, gen, pos, false)
- (* Generator errors are treated as exhaustion: the partial batch is
- returned with has_more = false and the cursor is auto-removed.
- The caller receives no indication that the stream terminated
- abnormally. When fetch gains a richer return type this arm
- should surface the error message instead. *)
- | Generator.Error _ -> (List.rev acc, gen, pos, false)
- | Generator.Value (t, next) ->
- begin match t with
- | Tuple.Materialized m -> go next (pos + 1) (m :: acc) (count + 1)
- | Tuple.NonMaterialized _ -> go next (pos + 1) acc count
- end
- in
- let rows, gen', pos', has_more = go cur.generator cur.position [] 0 in
- cur.generator <- gen';
- cur.position <- pos';
- if not has_more then Hashtbl.remove reg.tbl id;
- Ok (rows, has_more)
-
-let close (reg : t) ~(id : string) : unit = Hashtbl.remove reg.tbl id
-
-let gc (reg : t) ~(max_age : float) : unit =
- let now = Unix.gettimeofday () in
- let to_remove =
- Hashtbl.fold
- (fun k cur acc ->
- if now -. cur.created_at >= max_age then k :: acc else acc)
- reg.tbl []
- in
- List.iter (Hashtbl.remove reg.tbl) to_remove
diff --git a/lib/storable.ml b/lib/storable.ml
index ec0bce2..5d87846 100644
--- a/lib/storable.ml
+++ b/lib/storable.ml
@@ -1,51 +1,119 @@
-(** Serialization formats for content-addressed storage.
+module Wire = struct
+ let split_once ch value =
+ match String.index_opt value ch with
+ | None -> None
+ | Some index ->
+ Some
+ ( String.sub value 0 index,
+ String.sub value (index + 1) (String.length value - index - 1) )
- These modules define the wire format for persisting relational engine
- objects to storage. Each type has to_bytes/of_bytes for serialization.
+ let lines bytes =
+ bytes |> Bytes.to_string |> String.split_on_char '\n'
+ |> List.filter (fun line -> String.trim line <> "")
- The stored formats capture only the essential data needed for
- reconstruction:
- - Tuple: relation name and attribute hashes
- - Relation: name, schema, tuple hashes, cardinality
- - Database: name, relation hashes, merkle tree keys, history *)
+ let fields bytes =
+ lines bytes
+ |> List.filter_map (fun line -> split_once '=' line)
+ |> List.map (fun (key, value) -> (String.trim key, String.trim value))
+
+ let require_type expected fields =
+ match List.assoc_opt "type" fields with
+ | Some actual when actual = expected -> ()
+ | Some actual ->
+ invalid_arg
+ (Printf.sprintf "expected storable type %S, got %S" expected actual)
+ | None -> invalid_arg "missing storable type"
+
+ let values key fields =
+ List.filter_map (fun (k, v) -> if k = key then Some v else None) fields
+
+ let required key fields =
+ match List.assoc_opt key fields with
+ | Some value -> value
+ | None -> invalid_arg ("missing storable field: " ^ key)
+
+ let attribute value =
+ match split_once ':' value with
+ | Some pair -> pair
+ | None -> invalid_arg ("invalid attribute field: " ^ value)
+
+ let encode fields =
+ fields
+ |> List.map (fun (key, value) -> key ^ "=" ^ value)
+ |> String.concat "\n" |> fun value -> Bytes.of_string (value ^ "\n")
+end
-(** Stored tuple format for serialization *)
module Tuple = struct
- type t = {
- relation : string;
- attributes : (string * Conventions.Hash.t) list;
- (* attr_name -> attr_value_hash *)
- }
-
- let to_bytes (st : t) : bytes = Marshal.to_bytes st [ Marshal.Closures ]
- let of_bytes (b : bytes) : t = Marshal.from_bytes b 0
+ type t = { relation : string; attributes : (string * string) list }
+
+ let to_bytes tuple =
+ Wire.encode
+ ([ ("type", "tuple"); ("relation", tuple.relation) ]
+ @ List.map
+ (fun (name, value) -> ("attribute", name ^ ":" ^ value))
+ tuple.attributes)
+
+ let of_bytes bytes =
+ let fields = Wire.fields bytes in
+ Wire.require_type "tuple" fields;
+ {
+ relation = Wire.required "relation" fields;
+ attributes = List.map Wire.attribute (Wire.values "attribute" fields);
+ }
end
-(** Stored relation format for serialization *)
module Relation = struct
- type t = {
- name : string;
- schema : Schema.t;
- tree_keys : Conventions.Hash.t list;
- (* Merkle tree contents - tuple hashes *)
- cardinality : Conventions.Cardinality.t;
- }
-
- let to_bytes (sr : t) : bytes = Marshal.to_bytes sr [ Marshal.Closures ]
- let of_bytes (b : bytes) : t = Marshal.from_bytes b 0
+ type t = { name : string; schema : (string * string) list }
+
+ let to_bytes relation =
+ Wire.encode
+ ([ ("type", "relation"); ("name", relation.name); ("kind", "stored") ]
+ @ List.map
+ (fun (name, domain) -> ("attribute", name ^ ":" ^ domain))
+ relation.schema)
+
+ let of_bytes bytes =
+ let fields = Wire.fields bytes in
+ Wire.require_type "relation" fields;
+ {
+ name = Wire.required "name" fields;
+ schema = List.map Wire.attribute (Wire.values "attribute" fields);
+ }
end
-(** Stored database format for serialization *)
-module Database = struct
- type t = {
- name : string;
- relations : (string * Conventions.Hash.t) list; (* name -> relation_hash *)
- tree_keys : Conventions.Hash.t list;
- (* Merkle tree contents - relation hashes *)
- history : Conventions.Hash.t list;
- timestamp : float;
- }
-
- let to_bytes (sd : t) : bytes = Marshal.to_bytes sd [ Marshal.Closures ]
- let of_bytes (b : bytes) : t = Marshal.from_bytes b 0
+module Multigroup = struct
+ type t = { name : string; relations : Relation.t list }
+
+ let relation_value relation =
+ let attrs =
+ relation.Relation.schema
+ |> List.map (fun (name, domain) -> name ^ ":" ^ domain)
+ |> String.concat ","
+ in
+ relation.name ^ "|" ^ attrs
+
+ let parse_relation value =
+ match Wire.split_once '|' value with
+ | None -> { Relation.name = value; schema = [] }
+ | Some (name, attrs) ->
+ let schema =
+ if attrs = "" then []
+ else attrs |> String.split_on_char ',' |> List.map Wire.attribute
+ in
+ { Relation.name; schema }
+
+ let to_bytes multigroup =
+ Wire.encode
+ ([ ("type", "multigroup"); ("name", multigroup.name) ]
+ @ List.map
+ (fun relation -> ("relation", relation_value relation))
+ multigroup.relations)
+
+ let of_bytes bytes =
+ let fields = Wire.fields bytes in
+ Wire.require_type "multigroup" fields;
+ {
+ name = Wire.required "name" fields;
+ relations = List.map parse_relation (Wire.values "relation" fields);
+ }
end
diff --git a/lib/sublanguage.ml b/lib/sublanguage.ml
index 25474af..cf3d501 100644
--- a/lib/sublanguage.ml
+++ b/lib/sublanguage.ml
@@ -27,7 +27,7 @@ module type S = sig
val parse_sexp : Sexplib.Sexp.t -> (ast, error) Result.t
val execute :
- storage -> Management.Database.t -> ast -> (result, error) Result.t
+ storage -> Management.Multigroup.multigroup -> ast -> (result, error) Result.t
val sexp_of_error : error -> Sexplib.Sexp.t
end
diff --git a/lib/sublanguage_types.ml b/lib/sublanguage_types.ml
index 14ee20f..743cb7f 100644
--- a/lib/sublanguage_types.ml
+++ b/lib/sublanguage_types.ml
@@ -5,8 +5,8 @@ type cursor_result = {
}
type result =
- | Query of Relation.t
- | Transition of Management.Database.t
+ | Query of Relation.relation
+ | Transition of Management.Multigroup.multigroup
| Cursor of cursor_result
| SessionSwitch of string
| CreateMultigroup of string
diff --git a/lib/system.ml b/lib/system.ml
index 40adf82..4c4e4b5 100644
--- a/lib/system.ml
+++ b/lib/system.ml
@@ -67,15 +67,8 @@ let assemble (config : Configuration.t) : (unit -> unit, string) result =
let* packed_transport = transport_provider transport_body in
let (StorageParcel ((module S), storage)) = packed_storage in
let (TransportParcel ((module T), transport)) = packed_transport in
- let module C = Catalog.Make (S) in
- let* catalog =
- C.create storage ~prelude_relations:Prelude.Standard.prelude_relations
- in
let module L = Listener.Make (T) (S) in
- Ok
- (fun () ->
- Scl.Executor.set_sessions (Session.create ());
- L.run transport catalog storage)
+ Ok (fun () -> L.run transport storage)
let run_from_config (path : string) : (unit -> unit, string) result =
let ( let* ) = Result.bind in
diff --git a/lib/tuple.ml b/lib/tuple.ml
index 1ce73b0..24eecab 100644
--- a/lib/tuple.ml
+++ b/lib/tuple.ml
@@ -1,5 +1,5 @@
module AttributeMap = struct
- include Map.Make (String)
+ include BatMap.String
let sexp_of_t sexp_of_v m =
Sexplib.Sexp.List
@@ -12,12 +12,14 @@ type non_materialized = {
hash : Conventions.Hash.t;
relation : Conventions.Name.t;
attributes : Attribute.referenced AttributeMap.t;
+ (* lineage : Relation.Lineage.t option; *)
}
[@@deriving sexp_of]
type materialized = {
relation : Conventions.Name.t;
attributes : Attribute.materialized AttributeMap.t;
+ (* lineage : Relation.Lineage.t option; *)
}
[@@deriving sexp_of]
@@ -25,4 +27,8 @@ type t = Materialized of materialized | NonMaterialized of non_materialized
[@@deriving sexp_of]
let make_materialized ~relation ~attributes =
- Materialized { relation; attributes }
+ Materialized {
+ relation;
+ attributes;
+ (* lineage = None *)
+ }
diff --git a/proof/.gitignore b/proof/.gitignore
deleted file mode 100644
index 5ff7fe7..0000000
--- a/proof/.gitignore
+++ /dev/null
@@ -1,11 +0,0 @@
-# Coq build artifacts
-*.vo
-*.vos
-*.vok
-*.glob
-*.aux
-.*.aux
-Makefile.coq
-Makefile.coq.conf
-.Makefile.coq.d
-.coqdeps.d
diff --git a/proof/Drl.v b/proof/Drl.v
deleted file mode 100644
index fd179a1..0000000
--- a/proof/Drl.v
+++ /dev/null
@@ -1,67 +0,0 @@
-(** * DRL: Data Retrieval Language — Finiteness Gate
-
- This file defines:
- - The DRL query AST (mirroring [lib/drl/ast.ml])
- - [predicted_finite]: statically decides whether a query can
- produce an infinite result based on the cardinality flags of
- the relations it references.
-
- [predicted_finite] is extracted to OCaml and called by
- [lib/drl/gate.ml] before every query execution. Queries whose
- result cannot be statically proven finite are rejected unless
- wrapped in a [Take]. *)
-
-From Stdlib Require Import List.
-From Stdlib Require Import String.
-From Stdlib Require Import Bool.
-Require Import Schema.
-Require Import Relation.
-Import ListNotations.
-
-(* ================================================================== *)
-(** ** AST *)
-(* ================================================================== *)
-
-Inductive literal :=
- | LitInt : nat -> literal
- | LitStr : string -> literal
- | LitBool : bool -> literal.
-
-Inductive query : Type :=
- | Base : string -> query
- | Const : list (attr_name * literal) -> query
- | Select : query -> query -> query
- | Join : list attr_name -> query -> query -> query
- | Cartesian : query -> query -> query
- | Project : list attr_name -> query -> query
- | Rename : list (attr_name * attr_name) -> query -> query
- | Union : query -> query -> query
- | Diff : query -> query -> query
- | Take : nat -> query -> query.
-
-(* ================================================================== *)
-(** ** Finiteness Prediction *)
-(* ================================================================== *)
-
-(** Conservatively predict whether a query produces a finite result.
- Returns [Some true] if guaranteed finite, [Some false] if not,
- [None] if a referenced relation is not found in the database. *)
-Fixpoint predicted_finite (db : database) (q : query) : option bool :=
- match q with
- | Base name =>
- match db_lookup name db with
- | Some r => Some (rel_finite r)
- | None => None
- end
- | Const _ => Some true
- | Take _ _ => Some true
- | Select _ source =>
- predicted_finite db source
- | Join _ q1 q2 | Cartesian q1 q2 | Union q1 q2 =>
- match predicted_finite db q1, predicted_finite db q2 with
- | Some f1, Some f2 => Some (f1 && f2)
- | _, _ => None
- end
- | Diff q1 _ => predicted_finite db q1
- | Project _ q' | Rename _ q' => predicted_finite db q'
- end.
diff --git a/proof/Extraction.v b/proof/Extraction.v
deleted file mode 100644
index dc93c21..0000000
--- a/proof/Extraction.v
+++ /dev/null
@@ -1,17 +0,0 @@
-(** * Extraction to OCaml — finiteness gate only
-
- Extracts [predicted_finite] to [lib/drl_verified/drl_verified.ml].
- To regenerate: cd proof && make *)
-
-From Stdlib Require Import Extraction.
-From Stdlib Require Import ExtrOcamlBasic.
-From Stdlib Require Import ExtrOcamlString.
-From Stdlib Require Import ExtrOcamlNatInt.
-
-Require Import Schema.
-Require Import Relation.
-Require Import Drl.
-
-Set Extraction Output Directory "../lib/drl_verified".
-
-Extraction "drl_verified" predicted_finite.
diff --git a/proof/Makefile b/proof/Makefile
deleted file mode 100644
index a9e1f72..0000000
--- a/proof/Makefile
+++ /dev/null
@@ -1,14 +0,0 @@
-COQMAKEFILE ?= Makefile.coq
-
-all: $(COQMAKEFILE)
- mkdir -p ../lib/drl_verified
- $(MAKE) -f $(COQMAKEFILE)
-
-$(COQMAKEFILE): _CoqProject
- coq_makefile -f _CoqProject -o $(COQMAKEFILE)
-
-clean: $(COQMAKEFILE)
- $(MAKE) -f $(COQMAKEFILE) clean
- rm -f $(COQMAKEFILE) $(COQMAKEFILE).conf
-
-.PHONY: all clean
diff --git a/proof/Relation.v b/proof/Relation.v
deleted file mode 100644
index f7c087d..0000000
--- a/proof/Relation.v
+++ /dev/null
@@ -1,26 +0,0 @@
-(** * Relation: minimal model for finiteness checking
-
- A relation is reduced to the two fields that [predicted_finite]
- actually inspects: its name (for database lookup) and its
- finiteness flag (for the gate decision). *)
-
-From Stdlib Require Import List.
-From Stdlib Require Import String.
-Require Import Schema.
-Import ListNotations.
-
-Record relation := mkRelation {
- rel_name : string;
- rel_finite : bool;
-}.
-
-(** A database is a named collection of relations. *)
-Definition database := list (string * relation).
-
-(** Look up a relation by name. *)
-Fixpoint db_lookup (name : string) (db : database) : option relation :=
- match db with
- | [] => None
- | (n, r) :: rest =>
- if String.eqb name n then Some r else db_lookup name rest
- end.
diff --git a/proof/Schema.v b/proof/Schema.v
deleted file mode 100644
index eb8f4c5..0000000
--- a/proof/Schema.v
+++ /dev/null
@@ -1,5 +0,0 @@
-(** * Schema: attribute name type *)
-
-From Stdlib Require Import String.
-
-Definition attr_name := string.
diff --git a/proof/_CoqProject b/proof/_CoqProject
deleted file mode 100644
index 0e6123e..0000000
--- a/proof/_CoqProject
+++ /dev/null
@@ -1,6 +0,0 @@
--R . Sakura
-
-Schema.v
-Relation.v
-Drl.v
-Extraction.v
diff --git a/proof/drl_verified.ml b/proof/drl_verified.ml
deleted file mode 100644
index 137ad86..0000000
--- a/proof/drl_verified.ml
+++ /dev/null
@@ -1,411 +0,0 @@
-(** val negb : bool -> bool **)
-
-let negb = function true -> false | false -> true
-
-(** val fst : ('a1 * 'a2) -> 'a1 **)
-
-let fst = function x, _ -> x
-
-(** val snd : ('a1 * 'a2) -> 'a2 **)
-
-let snd = function _, y -> y
-
-(** val app : 'a1 list -> 'a1 list -> 'a1 list **)
-
-let rec app l m = match l with [] -> m | a :: l1 -> a :: app l1 m
-
-(** val map : ('a1 -> 'a2) -> 'a1 list -> 'a2 list **)
-
-let rec map f = function [] -> [] | a :: l0 -> f a :: map f l0
-
-(** val firstn : int -> 'a1 list -> 'a1 list **)
-
-let rec firstn n l =
- (fun fO fS n -> if n = 0 then fO () else fS (n - 1))
- (fun _ -> [])
- (fun n0 -> match l with [] -> [] | a :: l0 -> a :: firstn n0 l0)
- n
-
-(** val flat_map : ('a1 -> 'a2 list) -> 'a1 list -> 'a2 list **)
-
-let rec flat_map f = function [] -> [] | x :: l0 -> app (f x) (flat_map f l0)
-
-(** val existsb : ('a1 -> bool) -> 'a1 list -> bool **)
-
-let rec existsb f = function [] -> false | a :: l0 -> f a || existsb f l0
-
-(** val forallb : ('a1 -> bool) -> 'a1 list -> bool **)
-
-let rec forallb f = function [] -> true | a :: l0 -> f a && forallb f l0
-
-(** val filter : ('a1 -> bool) -> 'a1 list -> 'a1 list **)
-
-let rec filter f = function
- | [] -> []
- | x :: l0 -> if f x then x :: filter f l0 else filter f l0
-
-(** val find : ('a1 -> bool) -> 'a1 list -> 'a1 option **)
-
-let rec find f = function
- | [] -> None
- | x :: tl -> if f x then Some x else find f tl
-
-(** val eqb : char list -> char list -> bool **)
-
-let rec eqb s1 s2 =
- match s1 with
- | [] -> ( match s2 with [] -> true | _ :: _ -> false)
- | c1 :: s1' -> (
- match s2 with
- | [] -> false
- | c2 :: s2' -> if c1 = c2 then eqb s1' s2' else false)
-
-(** val append : char list -> char list -> char list **)
-
-let rec append s1 s2 = match s1 with [] -> s2 | c :: s1' -> c :: append s1' s2
-
-type attr_name = char list
-type domain_name = char list
-type schema = (attr_name * domain_name) list
-
-(** val has_attr : attr_name -> schema -> bool **)
-
-let has_attr a s = existsb (fun p -> eqb a (fst p)) s
-
-(** val attr_names : schema -> attr_name list **)
-
-let attr_names s = map fst s
-
-(** val filter_schema : attr_name list -> schema -> schema **)
-
-let filter_schema attrs s = filter (fun p -> existsb (eqb (fst p)) attrs) s
-
-(** val merge_schema : schema -> schema -> schema **)
-
-let merge_schema s1 s2 =
- app s1 (filter (fun p -> negb (has_attr (fst p) s1)) s2)
-
-(** val remove_attrs : attr_name list -> schema -> schema **)
-
-let remove_attrs attrs s =
- filter (fun p -> negb (existsb (eqb (fst p)) attrs)) s
-
-(** val rename_in_schema : (attr_name * attr_name) list -> schema -> schema **)
-
-let rename_in_schema renames s =
- map
- (fun p ->
- let a = fst p in
- let d = snd p in
- match find (fun r -> eqb a (fst r)) renames with
- | Some p0 ->
- let _, a' = p0 in
- (a', d)
- | None -> (a, d))
- s
-
-type value (* AXIOM TO BE REALIZED *)
-
-(** val value_eqb : value -> value -> bool **)
-
-let value_eqb = failwith "AXIOM TO BE REALIZED (Sakura.Relation.value_eqb)"
-
-type tuple = (attr_name * value) list
-
-(** val tuple_lookup : attr_name -> tuple -> value option **)
-
-let rec tuple_lookup a = function
- | [] -> None
- | p :: rest ->
- let a', v = p in
- if eqb a a' then Some v else tuple_lookup a rest
-
-(** val project_tuple : attr_name list -> tuple -> tuple **)
-
-let project_tuple attrs t = filter (fun p -> existsb (eqb (fst p)) attrs) t
-
-(** val rename_tuple : (attr_name * attr_name) list -> tuple -> tuple **)
-
-let rename_tuple renames t =
- map
- (fun p ->
- let a = fst p in
- let v = snd p in
- match find (fun r -> eqb a (fst r)) renames with
- | Some p0 ->
- let _, a' = p0 in
- (a', v)
- | None -> (a, v))
- t
-
-(** val merge_tuples : tuple -> tuple -> tuple **)
-
-let merge_tuples t1 t2 =
- app t1 (filter (fun p -> negb (existsb (eqb (fst p)) (map fst t1))) t2)
-
-(** val tuples_agree_on : attr_name list -> tuple -> tuple -> bool **)
-
-let tuples_agree_on attrs t1 t2 =
- forallb
- (fun a ->
- match tuple_lookup a t1 with
- | Some v1 -> (
- match tuple_lookup a t2 with
- | Some v2 -> value_eqb v1 v2
- | None -> false)
- | None -> ( match tuple_lookup a t2 with Some _ -> false | None -> true))
- attrs
-
-type relation = {
- rel_name : char list;
- rel_schema : schema;
- rel_tuples : tuple list;
-}
-
-type database = (char list * relation) list
-
-(** val db_lookup : char list -> database -> relation option **)
-
-let rec db_lookup name = function
- | [] -> None
- | p :: rest ->
- let n, r = p in
- if eqb name n then Some r else db_lookup name rest
-
-type literal = LitInt of int | LitStr of char list | LitBool of bool
-
-type query =
- | Base of char list
- | Const of (attr_name * literal) list
- | Select of query * query
- | Join of attr_name list * query * query
- | Cartesian of query * query
- | Project of attr_name list * query
- | Rename of (attr_name * attr_name) list * query
- | Union of query * query
- | Diff of query * query
- | Take of int * query
-
-(** val predicted_schema : database -> query -> schema option **)
-
-let rec predicted_schema db = function
- | Base name -> (
- match db_lookup name db with Some r -> Some r.rel_schema | None -> None)
- | Const pairs ->
- Some
- (map
- (fun p -> (fst p, [ 'a'; 'b'; 's'; 't'; 'r'; 'a'; 'c'; 't' ]))
- pairs)
- | Select (_, source) -> predicted_schema db source
- | Join (attrs, q1, q2) -> (
- match predicted_schema db q1 with
- | Some s1 -> (
- match predicted_schema db q2 with
- | Some s2 ->
- Some
- (merge_schema s1
- (remove_attrs (attr_names s1) (remove_attrs attrs s2)))
- | None -> None)
- | None -> None)
- | Cartesian (q1, q2) -> (
- match predicted_schema db q1 with
- | Some s1 -> (
- match predicted_schema db q2 with
- | Some s2 -> Some (merge_schema s1 s2)
- | None -> None)
- | None -> None)
- | Project (attrs, q') -> (
- match predicted_schema db q' with
- | Some s -> Some (filter_schema attrs s)
- | None -> None)
- | Rename (renames, q') -> (
- match predicted_schema db q' with
- | Some s -> Some (rename_in_schema renames s)
- | None -> None)
- | Union (q1, _) -> predicted_schema db q1
- | Diff (q1, _) -> predicted_schema db q1
- | Take (_, q') -> predicted_schema db q'
-
-(** val literal_to_value : literal -> value **)
-
-let literal_to_value =
- failwith "AXIOM TO BE REALIZED (Sakura.Drl.literal_to_value)"
-
-(** val eval_const : (attr_name * literal) list -> relation **)
-
-let eval_const pairs =
- let tuple0 = map (fun p -> (fst p, literal_to_value (snd p))) pairs in
- let sch =
- map (fun p -> (fst p, [ 'a'; 'b'; 's'; 't'; 'r'; 'a'; 'c'; 't' ])) pairs
- in
- {
- rel_name = [ 'c'; 'o'; 'n'; 's'; 't' ];
- rel_schema = sch;
- rel_tuples = tuple0 :: [];
- }
-
-(** val semijoin : relation -> relation -> relation **)
-
-let semijoin filter_rel source =
- let common =
- filter
- (fun a -> has_attr a filter_rel.rel_schema)
- (attr_names source.rel_schema)
- in
- let matches =
- fun t ->
- existsb (fun ft -> tuples_agree_on common t ft) filter_rel.rel_tuples
- in
- {
- rel_name = source.rel_name;
- rel_schema = source.rel_schema;
- rel_tuples = filter matches source.rel_tuples;
- }
-
-(** val equijoin : attr_name list -> relation -> relation -> relation **)
-
-let equijoin attrs left right =
- let joined =
- flat_map
- (fun lt ->
- flat_map
- (fun rt ->
- if tuples_agree_on attrs lt rt then merge_tuples lt rt :: [] else [])
- right.rel_tuples)
- left.rel_tuples
- in
- let new_schema =
- merge_schema left.rel_schema
- (remove_attrs
- (attr_names left.rel_schema)
- (remove_attrs attrs right.rel_schema))
- in
- {
- rel_name =
- append
- [ 'j'; 'o'; 'i'; 'n'; '_' ]
- (append left.rel_name (append ('_' :: []) right.rel_name));
- rel_schema = new_schema;
- rel_tuples = joined;
- }
-
-(** val cartesian : relation -> relation -> relation **)
-
-let cartesian left right =
- let joined =
- flat_map
- (fun lt -> map (fun rt -> merge_tuples lt rt) right.rel_tuples)
- left.rel_tuples
- in
- {
- rel_name =
- append
- [ 'c'; 'a'; 'r'; 't'; '_' ]
- (append left.rel_name (append ('_' :: []) right.rel_name));
- rel_schema = merge_schema left.rel_schema right.rel_schema;
- rel_tuples = joined;
- }
-
-(** val project : attr_name list -> relation -> relation **)
-
-let project attrs r =
- {
- rel_name = append [ 'p'; 'r'; 'o'; 'j'; '_' ] r.rel_name;
- rel_schema = filter_schema attrs r.rel_schema;
- rel_tuples = map (project_tuple attrs) r.rel_tuples;
- }
-
-(** val rename : (attr_name * attr_name) list -> relation -> relation **)
-
-let rename renames r =
- {
- rel_name = append [ 'r'; 'e'; 'n'; 'a'; 'm'; 'e'; '_' ] r.rel_name;
- rel_schema = rename_in_schema renames r.rel_schema;
- rel_tuples = map (rename_tuple renames) r.rel_tuples;
- }
-
-(** val rel_union : relation -> relation -> relation **)
-
-let rel_union r1 r2 =
- {
- rel_name =
- append
- [ 'u'; 'n'; 'i'; 'o'; 'n'; '_' ]
- (append r1.rel_name (append ('_' :: []) r2.rel_name));
- rel_schema = r1.rel_schema;
- rel_tuples = app r1.rel_tuples r2.rel_tuples;
- }
-
-(** val rel_diff : relation -> relation -> relation **)
-
-let rel_diff r1 r2 =
- let in_r2 =
- fun t ->
- existsb
- (fun t2 -> tuples_agree_on (attr_names r1.rel_schema) t t2)
- r2.rel_tuples
- in
- {
- rel_name =
- append
- [ 'd'; 'i'; 'f'; 'f'; '_' ]
- (append r1.rel_name (append ('_' :: []) r2.rel_name));
- rel_schema = r1.rel_schema;
- rel_tuples = filter (fun t -> negb (in_r2 t)) r1.rel_tuples;
- }
-
-(** val take : int -> relation -> relation **)
-
-let take n r =
- {
- rel_name = append [ 't'; 'a'; 'k'; 'e'; '_' ] r.rel_name;
- rel_schema = r.rel_schema;
- rel_tuples = firstn n r.rel_tuples;
- }
-
-(** val eval : database -> query -> relation option **)
-
-let rec eval db = function
- | Base name -> db_lookup name db
- | Const pairs -> Some (eval_const pairs)
- | Select (filter_q, source_q) -> (
- match eval db filter_q with
- | Some filter_rel -> (
- match eval db source_q with
- | Some source_rel -> Some (semijoin filter_rel source_rel)
- | None -> None)
- | None -> None)
- | Join (attrs, q1, q2) -> (
- match eval db q1 with
- | Some r1 -> (
- match eval db q2 with
- | Some r2 -> Some (equijoin attrs r1 r2)
- | None -> None)
- | None -> None)
- | Cartesian (q1, q2) -> (
- match eval db q1 with
- | Some r1 -> (
- match eval db q2 with
- | Some r2 -> Some (cartesian r1 r2)
- | None -> None)
- | None -> None)
- | Project (attrs, q') -> (
- match eval db q' with Some r -> Some (project attrs r) | None -> None)
- | Rename (renames, q') -> (
- match eval db q' with Some r -> Some (rename renames r) | None -> None)
- | Union (q1, q2) -> (
- match eval db q1 with
- | Some r1 -> (
- match eval db q2 with
- | Some r2 -> Some (rel_union r1 r2)
- | None -> None)
- | None -> None)
- | Diff (q1, q2) -> (
- match eval db q1 with
- | Some r1 -> (
- match eval db q2 with
- | Some r2 -> Some (rel_diff r1 r2)
- | None -> None)
- | None -> None)
- | Take (n, q') -> (
- match eval db q' with Some r -> Some (take n r) | None -> None)
diff --git a/run_tree.ps1 b/run_tree.ps1
new file mode 100644
index 0000000..7f74bac
--- /dev/null
+++ b/run_tree.ps1
@@ -0,0 +1,38 @@
+param(
+ [switch]$NoRun
+)
+
+$ErrorActionPreference = "Stop"
+
+$repoRoot = $PSScriptRoot
+$projectName = Split-Path -Leaf $repoRoot
+
+Push-Location $repoRoot
+try {
+ (& opam env) -split '\r?\n' | ForEach-Object {
+ if ($_ -ne "") {
+ Invoke-Expression $_
+ }
+ }
+
+ dune build shared/shabptree/sakura_shabptree.dll bin/tree.exe
+
+ $dll = @(
+ Get-ChildItem -Path $repoRoot -Filter sakura_shabptree.dll -Recurse -ErrorAction SilentlyContinue
+ Get-ChildItem -Path (Join-Path $repoRoot "..") -Filter sakura_shabptree.dll -Recurse -ErrorAction SilentlyContinue |
+ Where-Object { $_.FullName -like "*\_build\*\$projectName\shared\shabptree\sakura_shabptree.dll" }
+ ) | Select-Object -First 1
+
+ if ($null -eq $dll) {
+ throw "Could not find built sakura_shabptree.dll"
+ }
+
+ $env:SAKURA_BPLUSTREE_DLL = $dll.FullName
+
+ if (-not $NoRun) {
+ dune exec bin/tree.exe
+ }
+}
+finally {
+ Pop-Location
+}
diff --git a/sakura.opam b/sakura.opam
index 51fca63..0a1145b 100644
--- a/sakura.opam
+++ b/sakura.opam
@@ -15,6 +15,8 @@ depends: [
"ppx_protocol_conv"
"ppx_protocol_conv_xml_light"
"sha"
+ "ctypes"
+ "ctypes-foreign"
"data-encoding"
"ppx_inline_test" {with-test}
"ppx_deriving"
diff --git a/shared/shabptree/dune b/shared/shabptree/dune
new file mode 100644
index 0000000..43cba80
--- /dev/null
+++ b/shared/shabptree/dune
@@ -0,0 +1,5 @@
+(rule
+ (target sakura_shabptree.dll)
+ (deps shabptree.c)
+ (action
+ (run %{cc} -std=c99 -Wall -Wextra -DSAKURA_BPTREE_BUILDING_DLL -shared -o %{target} %{deps})))
diff --git a/shared/shabptree/shabptree.c b/shared/shabptree/shabptree.c
new file mode 100644
index 0000000..0337345
--- /dev/null
+++ b/shared/shabptree/shabptree.c
@@ -0,0 +1,1031 @@
+#include <stddef.h>
+#include <stdint.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+
+#if defined(_WIN32) && defined(SAKURA_BPTREE_BUILDING_DLL)
+#define SAKURA_BPTREE_API __declspec(dllexport)
+#elif defined(_WIN32)
+#define SAKURA_BPTREE_API __declspec(dllimport)
+#else
+#define SAKURA_BPTREE_API
+#endif
+
+#define SAKURA_SHA32_KEY_SIZE 32u
+
+typedef struct sakura_bptree sakura_bptree;
+
+typedef enum sakura_bptree_status {
+ SAKURA_BPTREE_OK = 0,
+ SAKURA_BPTREE_NOT_FOUND = 1,
+ SAKURA_BPTREE_INVALID_ARGUMENT = 2,
+ SAKURA_BPTREE_OUT_OF_MEMORY = 3,
+ SAKURA_BPTREE_IO_ERROR = 4,
+ SAKURA_BPTREE_CORRUPT_FILE = 5
+} sakura_bptree_status;
+
+typedef void (*sakura_bptree_iter_cb)(const uint8_t key[SAKURA_SHA32_KEY_SIZE],
+ const void *value,
+ uint64_t value_len,
+ void *user_data);
+
+#define BPTREE_ORDER 32
+#define BPTREE_MAX_KEYS (BPTREE_ORDER - 1)
+#define BPTREE_MAGIC "SKBPT1\0\0"
+#define BPTREE_MAGIC_SIZE 8u
+#define BPTREE_VERSION 1u
+
+typedef struct bptree_value {
+ uint8_t *data;
+ uint64_t len;
+} bptree_value;
+
+typedef struct bptree_node {
+ int is_leaf;
+ int key_count;
+ uint8_t keys[BPTREE_ORDER][SAKURA_SHA32_KEY_SIZE];
+ struct bptree_node *parent;
+ struct bptree_node *next;
+ union {
+ struct bptree_node *children[BPTREE_ORDER + 1];
+ bptree_value values[BPTREE_ORDER];
+ } slots;
+} bptree_node;
+
+struct sakura_bptree {
+ bptree_node *root;
+ bptree_node *first_leaf;
+ uint64_t len;
+};
+
+static int key_cmp(const uint8_t a[SAKURA_SHA32_KEY_SIZE],
+ const uint8_t b[SAKURA_SHA32_KEY_SIZE])
+{
+ return memcmp(a, b, SAKURA_SHA32_KEY_SIZE);
+}
+
+static void key_copy(uint8_t dst[SAKURA_SHA32_KEY_SIZE],
+ const uint8_t src[SAKURA_SHA32_KEY_SIZE])
+{
+ memcpy(dst, src, SAKURA_SHA32_KEY_SIZE);
+}
+
+static bptree_node *node_create(int is_leaf)
+{
+ bptree_node *node = (bptree_node *)calloc(1, sizeof(bptree_node));
+ if (node == NULL) {
+ return NULL;
+ }
+ node->is_leaf = is_leaf;
+ return node;
+}
+
+static void node_free(bptree_node *node)
+{
+ int i;
+
+ if (node == NULL) {
+ return;
+ }
+
+ if (node->is_leaf) {
+ for (i = 0; i < node->key_count; i++) {
+ free(node->slots.values[i].data);
+ }
+ } else {
+ for (i = 0; i <= node->key_count; i++) {
+ node_free(node->slots.children[i]);
+ }
+ }
+
+ free(node);
+}
+
+static int lower_bound_keys(const uint8_t keys[][SAKURA_SHA32_KEY_SIZE],
+ int count,
+ const uint8_t key[SAKURA_SHA32_KEY_SIZE])
+{
+ int lo = 0;
+ int hi = count;
+
+ while (lo < hi) {
+ int mid = lo + (hi - lo) / 2;
+ if (key_cmp(keys[mid], key) < 0) {
+ lo = mid + 1;
+ } else {
+ hi = mid;
+ }
+ }
+
+ return lo;
+}
+
+static int upper_bound_keys(const uint8_t keys[][SAKURA_SHA32_KEY_SIZE],
+ int count,
+ const uint8_t key[SAKURA_SHA32_KEY_SIZE])
+{
+ int lo = 0;
+ int hi = count;
+
+ while (lo < hi) {
+ int mid = lo + (hi - lo) / 2;
+ if (key_cmp(keys[mid], key) <= 0) {
+ lo = mid + 1;
+ } else {
+ hi = mid;
+ }
+ }
+
+ return lo;
+}
+
+static bptree_node *find_leaf(const sakura_bptree *tree,
+ const uint8_t key[SAKURA_SHA32_KEY_SIZE])
+{
+ bptree_node *node;
+
+ if (tree == NULL || tree->root == NULL) {
+ return NULL;
+ }
+
+ node = tree->root;
+ while (!node->is_leaf) {
+ int idx = upper_bound_keys(node->keys, node->key_count, key);
+ node = node->slots.children[idx];
+ }
+
+ return node;
+}
+
+static void refresh_first_leaf(sakura_bptree *tree)
+{
+ bptree_node *node;
+
+ if (tree == NULL || tree->root == NULL) {
+ return;
+ }
+
+ node = tree->root;
+ while (!node->is_leaf) {
+ node = node->slots.children[0];
+ }
+ tree->first_leaf = node;
+}
+
+static int subtree_first_key(const bptree_node *node,
+ uint8_t out[SAKURA_SHA32_KEY_SIZE])
+{
+ while (node != NULL && !node->is_leaf) {
+ node = node->slots.children[0];
+ }
+ if (node == NULL || node->key_count == 0) {
+ return 0;
+ }
+ key_copy(out, node->keys[0]);
+ return 1;
+}
+
+static void update_parent_separator(bptree_node *node)
+{
+ bptree_node *parent;
+ uint8_t first_key[SAKURA_SHA32_KEY_SIZE];
+
+ while (node != NULL && node->parent != NULL) {
+ int i;
+ parent = node->parent;
+ for (i = 1; i <= parent->key_count; i++) {
+ if (parent->slots.children[i] == node) {
+ if (subtree_first_key(node, first_key)) {
+ key_copy(parent->keys[i - 1], first_key);
+ }
+ return;
+ }
+ }
+ node = parent;
+ }
+}
+
+static sakura_bptree_status value_make(bptree_value *slot,
+ const void *value,
+ uint64_t value_len)
+{
+ uint8_t *copy = NULL;
+
+ if (value_len > 0 && value == NULL) {
+ return SAKURA_BPTREE_INVALID_ARGUMENT;
+ }
+
+ if (value_len > 0) {
+ if ((uint64_t)((size_t)value_len) != value_len) {
+ return SAKURA_BPTREE_INVALID_ARGUMENT;
+ }
+ copy = (uint8_t *)malloc((size_t)value_len);
+ if (copy == NULL) {
+ return SAKURA_BPTREE_OUT_OF_MEMORY;
+ }
+ memcpy(copy, value, (size_t)value_len);
+ }
+
+ slot->data = copy;
+ slot->len = value_len;
+ return SAKURA_BPTREE_OK;
+}
+
+static sakura_bptree_status value_replace(bptree_value *slot,
+ const void *value,
+ uint64_t value_len)
+{
+ bptree_value next;
+ sakura_bptree_status status;
+
+ next.data = NULL;
+ next.len = 0;
+ status = value_make(&next, value, value_len);
+ if (status != SAKURA_BPTREE_OK) {
+ return status;
+ }
+
+ free(slot->data);
+ *slot = next;
+ return SAKURA_BPTREE_OK;
+}
+
+static sakura_bptree_status insert_into_parent(sakura_bptree *tree,
+ bptree_node *left,
+ const uint8_t key[SAKURA_SHA32_KEY_SIZE],
+ bptree_node *right);
+
+static sakura_bptree_status split_internal(sakura_bptree *tree, bptree_node *node)
+{
+ bptree_node *right;
+ int split;
+ int right_keys;
+ int i;
+ uint8_t promote[SAKURA_SHA32_KEY_SIZE];
+
+ right = node_create(0);
+ if (right == NULL) {
+ return SAKURA_BPTREE_OUT_OF_MEMORY;
+ }
+
+ split = BPTREE_ORDER / 2;
+ right_keys = node->key_count - split - 1;
+ key_copy(promote, node->keys[split]);
+
+ for (i = 0; i < right_keys; i++) {
+ key_copy(right->keys[i], node->keys[split + 1 + i]);
+ }
+ for (i = 0; i <= right_keys; i++) {
+ right->slots.children[i] = node->slots.children[split + 1 + i];
+ if (right->slots.children[i] != NULL) {
+ right->slots.children[i]->parent = right;
+ }
+ node->slots.children[split + 1 + i] = NULL;
+ }
+
+ right->key_count = right_keys;
+ node->key_count = split;
+ right->parent = node->parent;
+
+ return insert_into_parent(tree, node, promote, right);
+}
+
+static sakura_bptree_status insert_into_parent(sakura_bptree *tree,
+ bptree_node *left,
+ const uint8_t key[SAKURA_SHA32_KEY_SIZE],
+ bptree_node *right)
+{
+ bptree_node *parent;
+ int left_index;
+ int i;
+
+ if (left->parent == NULL) {
+ bptree_node *root = node_create(0);
+ if (root == NULL) {
+ return SAKURA_BPTREE_OUT_OF_MEMORY;
+ }
+ key_copy(root->keys[0], key);
+ root->slots.children[0] = left;
+ root->slots.children[1] = right;
+ root->key_count = 1;
+ left->parent = root;
+ right->parent = root;
+ tree->root = root;
+ return SAKURA_BPTREE_OK;
+ }
+
+ parent = left->parent;
+ left_index = 0;
+ while (left_index <= parent->key_count && parent->slots.children[left_index] != left) {
+ left_index++;
+ }
+ if (left_index > parent->key_count) {
+ return SAKURA_BPTREE_CORRUPT_FILE;
+ }
+
+ for (i = parent->key_count; i > left_index; i--) {
+ key_copy(parent->keys[i], parent->keys[i - 1]);
+ }
+ for (i = parent->key_count + 1; i > left_index + 1; i--) {
+ parent->slots.children[i] = parent->slots.children[i - 1];
+ }
+
+ key_copy(parent->keys[left_index], key);
+ parent->slots.children[left_index + 1] = right;
+ right->parent = parent;
+ parent->key_count++;
+
+ if (parent->key_count <= BPTREE_MAX_KEYS) {
+ return SAKURA_BPTREE_OK;
+ }
+
+ return split_internal(tree, parent);
+}
+
+static sakura_bptree_status split_leaf_and_insert(sakura_bptree *tree,
+ bptree_node *leaf,
+ const uint8_t key[SAKURA_SHA32_KEY_SIZE],
+ const void *value,
+ uint64_t value_len)
+{
+ uint8_t temp_keys[BPTREE_ORDER][SAKURA_SHA32_KEY_SIZE];
+ bptree_value temp_values[BPTREE_ORDER];
+ bptree_value new_value;
+ bptree_node *right;
+ int insert_at;
+ int split;
+ int right_count;
+ int i;
+ sakura_bptree_status status;
+
+ memset(temp_values, 0, sizeof(temp_values));
+ new_value.data = NULL;
+ new_value.len = 0;
+ status = value_make(&new_value, value, value_len);
+ if (status != SAKURA_BPTREE_OK) {
+ return status;
+ }
+
+ right = node_create(1);
+ if (right == NULL) {
+ free(new_value.data);
+ return SAKURA_BPTREE_OUT_OF_MEMORY;
+ }
+
+ insert_at = lower_bound_keys(leaf->keys, leaf->key_count, key);
+
+ for (i = 0; i < insert_at; i++) {
+ key_copy(temp_keys[i], leaf->keys[i]);
+ temp_values[i] = leaf->slots.values[i];
+ leaf->slots.values[i].data = NULL;
+ leaf->slots.values[i].len = 0;
+ }
+ key_copy(temp_keys[insert_at], key);
+ temp_values[insert_at] = new_value;
+ for (i = insert_at; i < leaf->key_count; i++) {
+ key_copy(temp_keys[i + 1], leaf->keys[i]);
+ temp_values[i + 1] = leaf->slots.values[i];
+ leaf->slots.values[i].data = NULL;
+ leaf->slots.values[i].len = 0;
+ }
+
+ split = BPTREE_ORDER / 2;
+ leaf->key_count = split;
+ right_count = BPTREE_ORDER - split;
+ right->key_count = right_count;
+ right->parent = leaf->parent;
+ right->next = leaf->next;
+ leaf->next = right;
+
+ for (i = 0; i < split; i++) {
+ key_copy(leaf->keys[i], temp_keys[i]);
+ leaf->slots.values[i] = temp_values[i];
+ }
+ for (i = 0; i < right_count; i++) {
+ key_copy(right->keys[i], temp_keys[split + i]);
+ right->slots.values[i] = temp_values[split + i];
+ }
+
+ tree->len++;
+ return insert_into_parent(tree, leaf, right->keys[0], right);
+}
+
+SAKURA_BPTREE_API sakura_bptree *sakura_bptree_create(void)
+{
+ sakura_bptree *tree = (sakura_bptree *)calloc(1, sizeof(sakura_bptree));
+ if (tree == NULL) {
+ return NULL;
+ }
+
+ tree->root = node_create(1);
+ if (tree->root == NULL) {
+ free(tree);
+ return NULL;
+ }
+ tree->first_leaf = tree->root;
+ return tree;
+}
+
+SAKURA_BPTREE_API void sakura_bptree_free(sakura_bptree *tree)
+{
+ if (tree == NULL) {
+ return;
+ }
+ node_free(tree->root);
+ free(tree);
+}
+
+SAKURA_BPTREE_API uint64_t sakura_bptree_len(const sakura_bptree *tree)
+{
+ return tree == NULL ? 0 : tree->len;
+}
+
+SAKURA_BPTREE_API sakura_bptree_status sakura_bptree_put(sakura_bptree *tree,
+ const uint8_t key[SAKURA_SHA32_KEY_SIZE],
+ const void *value,
+ uint64_t value_len)
+{
+ bptree_node *leaf;
+ int pos;
+ int i;
+ sakura_bptree_status status;
+
+ if (tree == NULL || key == NULL || (value == NULL && value_len > 0)) {
+ return SAKURA_BPTREE_INVALID_ARGUMENT;
+ }
+
+ leaf = find_leaf(tree, key);
+ if (leaf == NULL) {
+ return SAKURA_BPTREE_CORRUPT_FILE;
+ }
+
+ pos = lower_bound_keys(leaf->keys, leaf->key_count, key);
+ if (pos < leaf->key_count && key_cmp(leaf->keys[pos], key) == 0) {
+ return value_replace(&leaf->slots.values[pos], value, value_len);
+ }
+
+ if (leaf->key_count == BPTREE_MAX_KEYS) {
+ return split_leaf_and_insert(tree, leaf, key, value, value_len);
+ }
+
+ for (i = leaf->key_count; i > pos; i--) {
+ key_copy(leaf->keys[i], leaf->keys[i - 1]);
+ leaf->slots.values[i] = leaf->slots.values[i - 1];
+ }
+
+ key_copy(leaf->keys[pos], key);
+ leaf->slots.values[pos].data = NULL;
+ leaf->slots.values[pos].len = 0;
+ status = value_make(&leaf->slots.values[pos], value, value_len);
+ if (status != SAKURA_BPTREE_OK) {
+ return status;
+ }
+
+ leaf->key_count++;
+ tree->len++;
+ if (pos == 0) {
+ update_parent_separator(leaf);
+ }
+
+ return SAKURA_BPTREE_OK;
+}
+
+SAKURA_BPTREE_API sakura_bptree_status sakura_bptree_get(const sakura_bptree *tree,
+ const uint8_t key[SAKURA_SHA32_KEY_SIZE],
+ const void **value,
+ uint64_t *value_len)
+{
+ bptree_node *leaf;
+ int pos;
+
+ if (tree == NULL || key == NULL || value == NULL || value_len == NULL) {
+ return SAKURA_BPTREE_INVALID_ARGUMENT;
+ }
+
+ leaf = find_leaf(tree, key);
+ if (leaf == NULL) {
+ return SAKURA_BPTREE_NOT_FOUND;
+ }
+
+ pos = lower_bound_keys(leaf->keys, leaf->key_count, key);
+ if (pos >= leaf->key_count || key_cmp(leaf->keys[pos], key) != 0) {
+ return SAKURA_BPTREE_NOT_FOUND;
+ }
+
+ *value = leaf->slots.values[pos].data;
+ *value_len = leaf->slots.values[pos].len;
+ return SAKURA_BPTREE_OK;
+}
+
+SAKURA_BPTREE_API sakura_bptree_status sakura_bptree_copy_value(const sakura_bptree *tree,
+ const uint8_t key[SAKURA_SHA32_KEY_SIZE],
+ void *buffer,
+ uint64_t buffer_len,
+ uint64_t *value_len)
+{
+ const void *value;
+ uint64_t len;
+ sakura_bptree_status status;
+
+ if (value_len == NULL || (buffer == NULL && buffer_len > 0)) {
+ return SAKURA_BPTREE_INVALID_ARGUMENT;
+ }
+
+ status = sakura_bptree_get(tree, key, &value, &len);
+ if (status != SAKURA_BPTREE_OK) {
+ return status;
+ }
+
+ *value_len = len;
+ if (buffer_len < len) {
+ return SAKURA_BPTREE_INVALID_ARGUMENT;
+ }
+ if (len > 0) {
+ memcpy(buffer, value, (size_t)len);
+ }
+ return SAKURA_BPTREE_OK;
+}
+
+SAKURA_BPTREE_API sakura_bptree_status sakura_bptree_remove(sakura_bptree *tree,
+ const uint8_t key[SAKURA_SHA32_KEY_SIZE])
+{
+ bptree_node *leaf;
+ int pos;
+ int i;
+
+ if (tree == NULL || key == NULL) {
+ return SAKURA_BPTREE_INVALID_ARGUMENT;
+ }
+
+ leaf = find_leaf(tree, key);
+ if (leaf == NULL) {
+ return SAKURA_BPTREE_NOT_FOUND;
+ }
+ pos = lower_bound_keys(leaf->keys, leaf->key_count, key);
+ if (pos >= leaf->key_count || key_cmp(leaf->keys[pos], key) != 0) {
+ return SAKURA_BPTREE_NOT_FOUND;
+ }
+
+ free(leaf->slots.values[pos].data);
+ for (i = pos; i < leaf->key_count - 1; i++) {
+ key_copy(leaf->keys[i], leaf->keys[i + 1]);
+ leaf->slots.values[i] = leaf->slots.values[i + 1];
+ }
+ leaf->slots.values[leaf->key_count - 1].data = NULL;
+ leaf->slots.values[leaf->key_count - 1].len = 0;
+ leaf->key_count--;
+ tree->len--;
+
+ if (leaf->key_count > 0 && pos == 0) {
+ update_parent_separator(leaf);
+ }
+
+ return SAKURA_BPTREE_OK;
+}
+
+SAKURA_BPTREE_API void sakura_bptree_iterate(const sakura_bptree *tree,
+ sakura_bptree_iter_cb callback,
+ void *user_data)
+{
+ bptree_node *node;
+
+ if (tree == NULL || callback == NULL) {
+ return;
+ }
+
+ node = tree->first_leaf;
+ while (node != NULL) {
+ int i;
+ for (i = 0; i < node->key_count; i++) {
+ callback(node->keys[i], node->slots.values[i].data,
+ node->slots.values[i].len, user_data);
+ }
+ node = node->next;
+ }
+}
+
+typedef struct buf_writer {
+ uint8_t *data;
+ uint64_t len;
+ uint64_t cap;
+} buf_writer;
+
+static int buf_writer_init(buf_writer *w)
+{
+ w->data = (uint8_t *)malloc(256);
+ if (w->data == NULL) {
+ return 0;
+ }
+ w->len = 0;
+ w->cap = 256;
+ return 1;
+}
+
+static int buf_writer_write(buf_writer *w, const void *src, uint64_t n)
+{
+ uint64_t needed = w->len + n;
+ if (needed > w->cap) {
+ uint64_t new_cap = w->cap * 2;
+ uint8_t *p;
+ while (new_cap < needed) {
+ new_cap *= 2;
+ }
+ p = (uint8_t *)realloc(w->data, (size_t)new_cap);
+ if (p == NULL) {
+ return 0;
+ }
+ w->data = p;
+ w->cap = new_cap;
+ }
+ memcpy(w->data + w->len, src, (size_t)n);
+ w->len += n;
+ return 1;
+}
+
+typedef struct buf_reader {
+ const uint8_t *data;
+ uint64_t len;
+ uint64_t pos;
+} buf_reader;
+
+static int buf_reader_read(buf_reader *r, void *dst, uint64_t n)
+{
+ if (r->pos + n > r->len) {
+ return 0;
+ }
+ memcpy(dst, r->data + r->pos, (size_t)n);
+ r->pos += n;
+ return 1;
+}
+
+static int buf_write_u32(buf_writer *w, uint32_t value)
+{
+ uint8_t b[4];
+ b[0] = (uint8_t)(value & 0xffu);
+ b[1] = (uint8_t)((value >> 8) & 0xffu);
+ b[2] = (uint8_t)((value >> 16) & 0xffu);
+ b[3] = (uint8_t)((value >> 24) & 0xffu);
+ return buf_writer_write(w, b, sizeof(b));
+}
+
+static int buf_write_u64(buf_writer *w, uint64_t value)
+{
+ uint8_t b[8];
+ int i;
+ for (i = 0; i < 8; i++) {
+ b[i] = (uint8_t)((value >> (8 * i)) & 0xffu);
+ }
+ return buf_writer_write(w, b, sizeof(b));
+}
+
+static int buf_read_u32(buf_reader *r, uint32_t *value)
+{
+ uint8_t b[4];
+ if (!buf_reader_read(r, b, sizeof(b))) {
+ return 0;
+ }
+ *value = ((uint32_t)b[0]) | ((uint32_t)b[1] << 8) |
+ ((uint32_t)b[2] << 16) | ((uint32_t)b[3] << 24);
+ return 1;
+}
+
+static int buf_read_u64(buf_reader *r, uint64_t *value)
+{
+ uint8_t b[8];
+ int i;
+ if (!buf_reader_read(r, b, sizeof(b))) {
+ return 0;
+ }
+ *value = 0;
+ for (i = 0; i < 8; i++) {
+ *value |= ((uint64_t)b[i]) << (8 * i);
+ }
+ return 1;
+}
+
+static int write_u32(FILE *file, uint32_t value)
+{
+ uint8_t b[4];
+ b[0] = (uint8_t)(value & 0xffu);
+ b[1] = (uint8_t)((value >> 8) & 0xffu);
+ b[2] = (uint8_t)((value >> 16) & 0xffu);
+ b[3] = (uint8_t)((value >> 24) & 0xffu);
+ return fwrite(b, 1, sizeof(b), file) == sizeof(b);
+}
+
+static int write_u64(FILE *file, uint64_t value)
+{
+ uint8_t b[8];
+ int i;
+ for (i = 0; i < 8; i++) {
+ b[i] = (uint8_t)((value >> (8 * i)) & 0xffu);
+ }
+ return fwrite(b, 1, sizeof(b), file) == sizeof(b);
+}
+
+static int read_u32(FILE *file, uint32_t *value)
+{
+ uint8_t b[4];
+ if (fread(b, 1, sizeof(b), file) != sizeof(b)) {
+ return 0;
+ }
+ *value = ((uint32_t)b[0]) | ((uint32_t)b[1] << 8) |
+ ((uint32_t)b[2] << 16) | ((uint32_t)b[3] << 24);
+ return 1;
+}
+
+static int read_u64(FILE *file, uint64_t *value)
+{
+ uint8_t b[8];
+ int i;
+
+ if (fread(b, 1, sizeof(b), file) != sizeof(b)) {
+ return 0;
+ }
+
+ *value = 0;
+ for (i = 0; i < 8; i++) {
+ *value |= ((uint64_t)b[i]) << (8 * i);
+ }
+ return 1;
+}
+
+SAKURA_BPTREE_API sakura_bptree_status sakura_bptree_save(const sakura_bptree *tree,
+ const char *path)
+{
+ FILE *file;
+ bptree_node *node;
+
+ if (tree == NULL || path == NULL) {
+ return SAKURA_BPTREE_INVALID_ARGUMENT;
+ }
+
+ file = fopen(path, "wb");
+ if (file == NULL) {
+ return SAKURA_BPTREE_IO_ERROR;
+ }
+
+ if (fwrite(BPTREE_MAGIC, 1, BPTREE_MAGIC_SIZE, file) != BPTREE_MAGIC_SIZE ||
+ !write_u32(file, BPTREE_VERSION) ||
+ !write_u32(file, SAKURA_SHA32_KEY_SIZE) ||
+ !write_u64(file, tree->len)) {
+ fclose(file);
+ return SAKURA_BPTREE_IO_ERROR;
+ }
+
+ node = tree->first_leaf;
+ while (node != NULL) {
+ int i;
+ for (i = 0; i < node->key_count; i++) {
+ if (node->slots.values[i].len > 0 &&
+ (uint64_t)((size_t)node->slots.values[i].len) != node->slots.values[i].len) {
+ fclose(file);
+ return SAKURA_BPTREE_INVALID_ARGUMENT;
+ }
+ if (fwrite(node->keys[i], 1, SAKURA_SHA32_KEY_SIZE, file) != SAKURA_SHA32_KEY_SIZE ||
+ !write_u64(file, node->slots.values[i].len) ||
+ (node->slots.values[i].len > 0 &&
+ fwrite(node->slots.values[i].data, 1, (size_t)node->slots.values[i].len, file) !=
+ (size_t)node->slots.values[i].len)) {
+ fclose(file);
+ return SAKURA_BPTREE_IO_ERROR;
+ }
+ }
+ node = node->next;
+ }
+
+ if (fclose(file) != 0) {
+ return SAKURA_BPTREE_IO_ERROR;
+ }
+ return SAKURA_BPTREE_OK;
+}
+
+SAKURA_BPTREE_API sakura_bptree_status sakura_bptree_load(const char *path,
+ sakura_bptree **tree_out)
+{
+ FILE *file;
+ uint8_t magic[BPTREE_MAGIC_SIZE];
+ uint32_t version;
+ uint32_t key_size;
+ uint64_t count;
+ uint64_t i;
+ sakura_bptree *tree;
+
+ if (path == NULL || tree_out == NULL) {
+ return SAKURA_BPTREE_INVALID_ARGUMENT;
+ }
+ *tree_out = NULL;
+
+ file = fopen(path, "rb");
+ if (file == NULL) {
+ return SAKURA_BPTREE_IO_ERROR;
+ }
+
+ if (fread(magic, 1, sizeof(magic), file) != sizeof(magic) ||
+ memcmp(magic, BPTREE_MAGIC, BPTREE_MAGIC_SIZE) != 0 ||
+ !read_u32(file, &version) ||
+ !read_u32(file, &key_size) ||
+ !read_u64(file, &count) ||
+ version != BPTREE_VERSION ||
+ key_size != SAKURA_SHA32_KEY_SIZE) {
+ fclose(file);
+ return SAKURA_BPTREE_CORRUPT_FILE;
+ }
+
+ tree = sakura_bptree_create();
+ if (tree == NULL) {
+ fclose(file);
+ return SAKURA_BPTREE_OUT_OF_MEMORY;
+ }
+
+ for (i = 0; i < count; i++) {
+ uint8_t key[SAKURA_SHA32_KEY_SIZE];
+ uint64_t value_len;
+ uint8_t *value = NULL;
+ sakura_bptree_status status;
+
+ if (fread(key, 1, SAKURA_SHA32_KEY_SIZE, file) != SAKURA_SHA32_KEY_SIZE ||
+ !read_u64(file, &value_len) ||
+ (value_len > 0 && (uint64_t)((size_t)value_len) != value_len)) {
+ sakura_bptree_free(tree);
+ fclose(file);
+ return SAKURA_BPTREE_CORRUPT_FILE;
+ }
+ if (value_len > 0) {
+ value = (uint8_t *)malloc((size_t)value_len);
+ if (value == NULL) {
+ sakura_bptree_free(tree);
+ fclose(file);
+ return SAKURA_BPTREE_OUT_OF_MEMORY;
+ }
+ if (fread(value, 1, (size_t)value_len, file) != (size_t)value_len) {
+ free(value);
+ sakura_bptree_free(tree);
+ fclose(file);
+ return SAKURA_BPTREE_CORRUPT_FILE;
+ }
+ }
+
+ status = sakura_bptree_put(tree, key, value, value_len);
+ free(value);
+ if (status != SAKURA_BPTREE_OK) {
+ sakura_bptree_free(tree);
+ fclose(file);
+ return status;
+ }
+ }
+
+ if (fgetc(file) != EOF) {
+ sakura_bptree_free(tree);
+ fclose(file);
+ return SAKURA_BPTREE_CORRUPT_FILE;
+ }
+
+ fclose(file);
+ refresh_first_leaf(tree);
+ *tree_out = tree;
+ return SAKURA_BPTREE_OK;
+}
+
+SAKURA_BPTREE_API sakura_bptree_status sakura_bptree_serialize(const sakura_bptree *tree,
+ uint8_t **out,
+ uint64_t *out_len)
+{
+ buf_writer w;
+ bptree_node *node;
+
+ if (tree == NULL || out == NULL || out_len == NULL) {
+ return SAKURA_BPTREE_INVALID_ARGUMENT;
+ }
+
+ if (!buf_writer_init(&w)) {
+ return SAKURA_BPTREE_OUT_OF_MEMORY;
+ }
+
+ if (!buf_writer_write(&w, BPTREE_MAGIC, BPTREE_MAGIC_SIZE) ||
+ !buf_write_u32(&w, BPTREE_VERSION) ||
+ !buf_write_u32(&w, SAKURA_SHA32_KEY_SIZE) ||
+ !buf_write_u64(&w, tree->len)) {
+ free(w.data);
+ return SAKURA_BPTREE_OUT_OF_MEMORY;
+ }
+
+ node = tree->first_leaf;
+ while (node != NULL) {
+ int i;
+ for (i = 0; i < node->key_count; i++) {
+ uint64_t vlen = node->slots.values[i].len;
+ if (!buf_writer_write(&w, node->keys[i], SAKURA_SHA32_KEY_SIZE) ||
+ !buf_write_u64(&w, vlen) ||
+ (vlen > 0 && !buf_writer_write(&w, node->slots.values[i].data, vlen))) {
+ free(w.data);
+ return SAKURA_BPTREE_OUT_OF_MEMORY;
+ }
+ }
+ node = node->next;
+ }
+
+ *out = w.data;
+ *out_len = w.len;
+ return SAKURA_BPTREE_OK;
+}
+
+SAKURA_BPTREE_API sakura_bptree_status sakura_bptree_deserialize(const uint8_t *data,
+ uint64_t data_len,
+ sakura_bptree **tree_out)
+{
+ buf_reader r;
+ uint8_t magic[BPTREE_MAGIC_SIZE];
+ uint32_t version;
+ uint32_t key_size;
+ uint64_t count;
+ uint64_t i;
+ sakura_bptree *tree;
+
+ if (data == NULL || tree_out == NULL) {
+ return SAKURA_BPTREE_INVALID_ARGUMENT;
+ }
+ *tree_out = NULL;
+
+ r.data = data;
+ r.len = data_len;
+ r.pos = 0;
+
+ if (!buf_reader_read(&r, magic, BPTREE_MAGIC_SIZE) ||
+ memcmp(magic, BPTREE_MAGIC, BPTREE_MAGIC_SIZE) != 0 ||
+ !buf_read_u32(&r, &version) ||
+ !buf_read_u32(&r, &key_size) ||
+ !buf_read_u64(&r, &count) ||
+ version != BPTREE_VERSION ||
+ key_size != SAKURA_SHA32_KEY_SIZE) {
+ return SAKURA_BPTREE_CORRUPT_FILE;
+ }
+
+ tree = sakura_bptree_create();
+ if (tree == NULL) {
+ return SAKURA_BPTREE_OUT_OF_MEMORY;
+ }
+
+ for (i = 0; i < count; i++) {
+ uint8_t key[SAKURA_SHA32_KEY_SIZE];
+ uint64_t value_len;
+ uint8_t *value = NULL;
+ sakura_bptree_status status;
+
+ if (!buf_reader_read(&r, key, SAKURA_SHA32_KEY_SIZE) ||
+ !buf_read_u64(&r, &value_len) ||
+ (value_len > 0 && (uint64_t)((size_t)value_len) != value_len)) {
+ sakura_bptree_free(tree);
+ return SAKURA_BPTREE_CORRUPT_FILE;
+ }
+ if (value_len > 0) {
+ value = (uint8_t *)malloc((size_t)value_len);
+ if (value == NULL) {
+ sakura_bptree_free(tree);
+ return SAKURA_BPTREE_OUT_OF_MEMORY;
+ }
+ if (!buf_reader_read(&r, value, value_len)) {
+ free(value);
+ sakura_bptree_free(tree);
+ return SAKURA_BPTREE_CORRUPT_FILE;
+ }
+ }
+
+ status = sakura_bptree_put(tree, key, value, value_len);
+ free(value);
+ if (status != SAKURA_BPTREE_OK) {
+ sakura_bptree_free(tree);
+ return status;
+ }
+ }
+
+ if (r.pos != r.len) {
+ sakura_bptree_free(tree);
+ return SAKURA_BPTREE_CORRUPT_FILE;
+ }
+
+ refresh_first_leaf(tree);
+ *tree_out = tree;
+ return SAKURA_BPTREE_OK;
+}
+
+SAKURA_BPTREE_API const char *sakura_bptree_status_string(sakura_bptree_status status)
+{
+ switch (status) {
+ case SAKURA_BPTREE_OK:
+ return "ok";
+ case SAKURA_BPTREE_NOT_FOUND:
+ return "not found";
+ case SAKURA_BPTREE_INVALID_ARGUMENT:
+ return "invalid argument";
+ case SAKURA_BPTREE_OUT_OF_MEMORY:
+ return "out of memory";
+ case SAKURA_BPTREE_IO_ERROR:
+ return "io error";
+ case SAKURA_BPTREE_CORRUPT_FILE:
+ return "corrupt file";
+ default:
+ return "unknown";
+ }
+}
diff --git a/test/dune b/test/dune
index 2f3e5eb..0f0374b 100644
--- a/test/dune
+++ b/test/dune
@@ -1,6 +1,6 @@
-(library
- (name test_relational_engine)
- (libraries relational_engine)
- (inline_tests)
- (preprocess
- (pps ppx_inline_test)))
+; (library
+; (name test_relational_engine)
+; (libraries relational_engine)
+; (inline_tests)
+; (preprocess
+; (pps ppx_inline_test)))
diff --git a/test/test_relational_engine.ml b/test/test_relational_engine.ml
index 932089f..215007f 100644
--- a/test/test_relational_engine.ml
+++ b/test/test_relational_engine.ml
@@ -133,14 +133,14 @@ let%test_unit "storage: transaction commit" =
Management.Physical.Memory.close storage
let%test_unit "database: create empty" =
- let db = Management.Database.empty ~name:"test_db" in
+ let db = Management.Multigroup.empty ~name:"test_db" in
assert (db.name = "test_db");
assert (Merkle.is_empty db.tree);
- assert (Management.Database.RelationMap.is_empty db.relations);
+ assert (Management.Multigroup.RelationMap.is_empty db.relations);
assert (db.history = [])
let%test_unit "database: add relation" =
- let db = Management.Database.empty ~name:"test_db" in
+ let db = Management.Multigroup.empty ~name:"test_db" in
(* Create a minimal relation for testing *)
let relation =
Relation.make ~hash:(Some "rel_hash_1") ~name:"users" ~schema:Schema.empty
@@ -150,13 +150,13 @@ let%test_unit "database: add relation" =
~provenance:Relation.Provenance.Undefined
~lineage:(Relation.Lineage.Base "users") ()
in
- let db = Management.Database.add_relation db ~relation in
- assert (Management.Database.has_relation db "users");
- assert (Management.Database.get_relation_hash db "users" = Some "rel_hash_1");
- assert (not (Management.Database.has_relation db "orders"))
+ let db = Management.Multigroup.add_relation db ~relation in
+ assert (Management.Multigroup.has_relation db "users");
+ assert (Management.Multigroup.get_relation_hash db "users" = Some "rel_hash_1");
+ assert (not (Management.Multigroup.has_relation db "orders"))
let%test_unit "database: remove relation" =
- let db = Management.Database.empty ~name:"test_db" in
+ let db = Management.Multigroup.empty ~name:"test_db" in
let relation =
Relation.make ~hash:(Some "hash1") ~name:"users" ~schema:Schema.empty
~tree:(Some Merkle.empty) ~constraints:None
@@ -165,13 +165,13 @@ let%test_unit "database: remove relation" =
~provenance:Relation.Provenance.Undefined
~lineage:(Relation.Lineage.Base "users") ()
in
- let db = Management.Database.add_relation db ~relation in
- assert (Management.Database.has_relation db "users");
- let db = Management.Database.remove_relation db ~name:"users" in
- assert (not (Management.Database.has_relation db "users"))
+ let db = Management.Multigroup.add_relation db ~relation in
+ assert (Management.Multigroup.has_relation db "users");
+ let db = Management.Multigroup.remove_relation db ~name:"users" in
+ assert (not (Management.Multigroup.has_relation db "users"))
let%test_unit "database: update relation" =
- let db = Management.Database.empty ~name:"test_db" in
+ let db = Management.Multigroup.empty ~name:"test_db" in
let relation =
Relation.make ~hash:(Some "hash1") ~name:"users" ~schema:Schema.empty
~tree:(Some Merkle.empty) ~constraints:None
@@ -180,16 +180,16 @@ let%test_unit "database: update relation" =
~provenance:Relation.Provenance.Undefined
~lineage:(Relation.Lineage.Base "users") ()
in
- let db = Management.Database.add_relation db ~relation in
+ let db = Management.Multigroup.add_relation db ~relation in
let old_db_hash = db.hash in
let updated_relation = { relation with hash = Some "hash2" } in
- let db = Management.Database.update_relation db ~relation:updated_relation in
- assert (Management.Database.get_relation_hash db "users" = Some "hash2");
+ let db = Management.Multigroup.update_relation db ~relation:updated_relation in
+ assert (Management.Multigroup.get_relation_hash db "users" = Some "hash2");
assert (db.hash <> old_db_hash);
assert (List.mem old_db_hash db.history)
let%test_unit "database: get relation names" =
- let db = Management.Database.empty ~name:"test_db" in
+ let db = Management.Multigroup.empty ~name:"test_db" in
let rel1 =
Relation.make ~hash:(Some "h1") ~name:"users" ~schema:Schema.empty
~tree:(Some Merkle.empty) ~constraints:None
@@ -206,9 +206,9 @@ let%test_unit "database: get relation names" =
~provenance:Relation.Provenance.Undefined
~lineage:(Relation.Lineage.Base "orders") ()
in
- let db = Management.Database.add_relation db ~relation:rel1 in
- let db = Management.Database.add_relation db ~relation:rel2 in
- let names = Management.Database.get_relation_names db in
+ let db = Management.Multigroup.add_relation db ~relation:rel1 in
+ let db = Management.Multigroup.add_relation db ~relation:rel2 in
+ let names = Management.Multigroup.get_relation_names db in
assert (List.length names = 2);
assert (List.mem "users" names);
assert (List.mem "orders" names)
@@ -224,14 +224,14 @@ let with_storage f =
let%test_unit "manipulation: create database" =
with_storage (fun storage ->
- match Memory.create_database storage ~name:"my_db" with
+ match Memory.create_multigroup storage ~name:"my_db" with
| Error _ -> assert false
| Ok db -> assert (db.name = "my_db"))
let%test_unit "manipulation: create relation" =
with_storage (fun storage ->
let db =
- match Memory.create_database storage ~name:"test_db" with
+ match Memory.create_multigroup storage ~name:"test_db" with
| Error _ -> assert false
| Ok db -> db
in
@@ -243,12 +243,12 @@ let%test_unit "manipulation: create relation" =
| Ok (db, relation) ->
assert (relation.name = "users");
assert (relation.schema = schema);
- assert (Management.Database.has_relation db "users"))
+ assert (Management.Multigroup.has_relation db "users"))
let%test_unit "manipulation: create relation already exists" =
with_storage (fun storage ->
let db =
- match Memory.create_database storage ~name:"test_db" with
+ match Memory.create_multigroup storage ~name:"test_db" with
| Error _ -> assert false
| Ok db -> db
in
@@ -263,7 +263,7 @@ let%test_unit "manipulation: create relation already exists" =
let%test_unit "manipulation: retract relation" =
with_storage (fun storage ->
let db =
- match Memory.create_database storage ~name:"test_db" with
+ match Memory.create_multigroup storage ~name:"test_db" with
| Error _ -> assert false
| Ok db -> db
in
@@ -271,15 +271,15 @@ let%test_unit "manipulation: retract relation" =
match Memory.create_relation storage db ~name:"users" ~schema with
| Error _ -> assert false
| Ok (db, _) -> (
- assert (Management.Database.has_relation db "users");
+ assert (Management.Multigroup.has_relation db "users");
match Memory.retract_relation storage db ~name:"users" with
| Error _ -> assert false
- | Ok db -> assert (not (Management.Database.has_relation db "users"))))
+ | Ok db -> assert (not (Management.Multigroup.has_relation db "users"))))
let%test_unit "manipulation: create tuple with storage" =
with_storage (fun storage ->
let db =
- match Memory.create_database storage ~name:"test_db" with
+ match Memory.create_multigroup storage ~name:"test_db" with
| Error _ -> assert false
| Ok db -> db
in
@@ -303,7 +303,7 @@ let%test_unit "manipulation: create tuple with storage" =
let%test_unit "manipulation: create and load tuple" =
with_storage (fun storage ->
let db =
- match Memory.create_database storage ~name:"test_db" with
+ match Memory.create_multigroup storage ~name:"test_db" with
| Error _ -> assert false
| Ok db -> db
in
@@ -335,7 +335,7 @@ let%test_unit "manipulation: create and load tuple" =
let%test_unit "manipulation: create multiple tuples with storage" =
with_storage (fun storage ->
let db =
- match Memory.create_database storage ~name:"test_db" with
+ match Memory.create_multigroup storage ~name:"test_db" with
| Error _ -> assert false
| Ok db -> db
in
@@ -361,7 +361,7 @@ let%test_unit "manipulation: create multiple tuples with storage" =
let%test_unit "manipulation: load multiple tuples" =
with_storage (fun storage ->
let db =
- match Memory.create_database storage ~name:"test_db" with
+ match Memory.create_multigroup storage ~name:"test_db" with
| Error _ -> assert false
| Ok db -> db
in
@@ -402,7 +402,7 @@ let%test_unit "manipulation: load multiple tuples" =
let%test_unit "manipulation: retract tuple" =
with_storage (fun storage ->
let db =
- match Memory.create_database storage ~name:"test_db" with
+ match Memory.create_multigroup storage ~name:"test_db" with
| Error _ -> assert false
| Ok db -> db
in
@@ -434,7 +434,7 @@ let%test_unit "manipulation: retract tuple" =
let%test_unit "manipulation: tuple hashes" =
with_storage (fun storage ->
let db =
- match Memory.create_database storage ~name:"test_db" with
+ match Memory.create_multigroup storage ~name:"test_db" with
| Error _ -> assert false
| Ok db -> db
in
@@ -462,7 +462,7 @@ let%test_unit "manipulation: tuple hashes" =
let%test_unit "manipulation: clear relation" =
with_storage (fun storage ->
let db =
- match Memory.create_database storage ~name:"test_db" with
+ match Memory.create_multigroup storage ~name:"test_db" with
| Error _ -> assert false
| Ok db -> db
in
@@ -492,7 +492,7 @@ let%test_unit "manipulation: clear relation" =
let%test_unit "manipulation: duplicate tuple rejected" =
with_storage (fun storage ->
let db =
- match Memory.create_database storage ~name:"test_db" with
+ match Memory.create_multigroup storage ~name:"test_db" with
| Error _ -> assert false
| Ok db -> db
in
@@ -518,7 +518,7 @@ let%test_unit "manipulation: duplicate tuple rejected" =
let%test_unit "manipulation: tuple_exists check" =
with_storage (fun storage ->
let db =
- match Memory.create_database storage ~name:"test_db" with
+ match Memory.create_multigroup storage ~name:"test_db" with
| Error _ -> assert false
| Ok db -> db
in
@@ -574,7 +574,7 @@ let%test_unit "manipulation: different tuples different hashes" =
let%test_unit "manipulation: get_relation from database" =
with_storage (fun storage ->
let db =
- match Memory.create_database storage ~name:"test_db" with
+ match Memory.create_multigroup storage ~name:"test_db" with
| Error _ -> assert false
| Ok db -> db
in
@@ -592,7 +592,7 @@ let%test_unit "manipulation: get_relation from database" =
let%test_unit "schema: persisted and loaded correctly" =
with_storage (fun storage ->
let db =
- match Memory.create_database storage ~name:"test_db" with
+ match Memory.create_multigroup storage ~name:"test_db" with
| Error _ -> assert false
| Ok db -> db
in
@@ -605,7 +605,7 @@ let%test_unit "schema: persisted and loaded correctly" =
| Ok (db, _relation) -> (
(* Get the relation hash *)
let rel_hash =
- Option.get (Management.Database.get_relation_hash db "users")
+ Option.get (Management.Multigroup.get_relation_hash db "users")
in
(* Load the relation from storage *)
match Memory.load_relation storage rel_hash with
@@ -618,19 +618,19 @@ let%test_unit "schema: persisted and loaded correctly" =
assert (List.mem ("name", "string") loaded_rel.schema);
assert (List.mem ("email", "string") loaded_rel.schema)))
-let%test_unit "catalog: create_database seeds 6 catalog relations" =
+let%test_unit "catalog: create_multigroup seeds 6 catalog relations" =
with_storage (fun storage ->
- match Memory.create_database storage ~name:"test" with
+ match Memory.create_multigroup storage ~name:"test" with
| Error _ -> assert false
| Ok db ->
let catalog_names = Prelude.Catalog.catalog_relation_names in
List.iter
- (fun name -> assert (Management.Database.has_relation db name))
+ (fun name -> assert (Management.Multigroup.has_relation db name))
catalog_names)
let%test_unit "catalog: sakura:relation contains all 6 catalog names" =
with_storage (fun storage ->
- match Memory.create_database storage ~name:"test" with
+ match Memory.create_multigroup storage ~name:"test" with
| Error _ -> assert false
| Ok db ->
let rel =
@@ -642,7 +642,7 @@ let%test_unit "catalog: sakura:relation contains all 6 catalog names" =
let%test_unit "catalog: sakura:on contains insert, update, delete" =
with_storage (fun storage ->
- match Memory.create_database storage ~name:"test" with
+ match Memory.create_multigroup storage ~name:"test" with
| Error _ -> assert false
| Ok db ->
let on_rel =
@@ -654,7 +654,7 @@ let%test_unit "catalog: sakura:on contains insert, update, delete" =
let%test_unit "catalog: sakura:timing contains immediate, deferred" =
with_storage (fun storage ->
- match Memory.create_database storage ~name:"test" with
+ match Memory.create_multigroup storage ~name:"test" with
| Error _ -> assert false
| Ok db ->
let timing_rel =
@@ -666,7 +666,7 @@ let%test_unit "catalog: sakura:timing contains immediate, deferred" =
let%test_unit "catalog: sakura:domain seeded with 4 prelude domains" =
with_storage (fun storage ->
- match Memory.create_database storage ~name:"test" with
+ match Memory.create_multigroup storage ~name:"test" with
| Error _ -> assert false
| Ok db ->
let dom_rel =
@@ -678,7 +678,7 @@ let%test_unit "catalog: sakura:domain seeded with 4 prelude domains" =
let%test_unit "catalog: create_relation updates sakura:relation" =
with_storage (fun storage ->
- match Memory.create_database storage ~name:"test" with
+ match Memory.create_multigroup storage ~name:"test" with
| Error _ -> assert false
| Ok db ->
let schema = Schema.empty |> Schema.add "id" "natural" in
@@ -699,7 +699,7 @@ let%test_unit "catalog: create_relation updates sakura:relation" =
let%test_unit "catalog: create_relation updates sakura:attribute" =
with_storage (fun storage ->
- match Memory.create_database storage ~name:"test" with
+ match Memory.create_multigroup storage ~name:"test" with
| Error _ -> assert false
| Ok db ->
let schema = Schema.empty |> Schema.add "id" "natural" in
@@ -723,7 +723,7 @@ let%test_unit "catalog: create_relation updates sakura:attribute" =
let%test_unit "catalog: retract_relation removes from sakura:relation" =
with_storage (fun storage ->
- match Memory.create_database storage ~name:"test" with
+ match Memory.create_multigroup storage ~name:"test" with
| Error _ -> assert false
| Ok db ->
let schema = Schema.empty |> Schema.add "id" "natural" in
@@ -749,7 +749,7 @@ let%test_unit "catalog: retract_relation removes from sakura:relation" =
let%test_unit "catalog: register_constraint inserts into sakura:constraint" =
with_storage (fun storage ->
- match Memory.create_database storage ~name:"test" with
+ match Memory.create_multigroup storage ~name:"test" with
| Error _ -> assert false
| Ok db ->
let schema = Schema.empty |> Schema.add "id" "natural" in
@@ -778,7 +778,7 @@ let%test_unit "integration: full workflow with storage" =
with_storage (fun storage ->
(* Create database *)
let db =
- match Memory.create_database storage ~name:"shop" with
+ match Memory.create_multigroup storage ~name:"shop" with
| Error _ -> assert false
| Ok db -> db
in
@@ -858,7 +858,7 @@ let%test_unit "integration: full workflow with storage" =
let%test_unit "integration: database history tracking" =
with_storage (fun storage ->
let db =
- match Memory.create_database storage ~name:"versioned" with
+ match Memory.create_multigroup storage ~name:"versioned" with
| Error _ -> assert false
| Ok db -> db
in
@@ -889,7 +889,7 @@ let%test_unit "integration: database history tracking" =
let%test_unit "integration: hash bubbles up correctly" =
with_storage (fun storage ->
let db =
- match Memory.create_database storage ~name:"test" with
+ match Memory.create_multigroup storage ~name:"test" with
| Error _ -> assert false
| Ok db -> db
in
@@ -936,7 +936,7 @@ let%test_unit "integration: hash bubbles up correctly" =
let%test_unit "branching: load database from historical hash" =
with_storage (fun storage ->
let db =
- match Memory.create_database storage ~name:"test" with
+ match Memory.create_multigroup storage ~name:"test" with
| Error _ -> assert false
| Ok db -> db
in
@@ -1008,7 +1008,7 @@ let%test_unit "branching: load database from historical hash" =
let%test_unit "branching: branch from historical state" =
with_storage (fun storage ->
let db =
- match Memory.create_database storage ~name:"test" with
+ match Memory.create_multigroup storage ~name:"test" with
| Error _ -> assert false
| Ok db -> db
in
@@ -1101,7 +1101,7 @@ let%test_unit "branching: branch from historical state" =
let%test_unit "branching: full reconstruction from hash" =
with_storage (fun storage ->
let db =
- match Memory.create_database storage ~name:"shop" with
+ match Memory.create_multigroup storage ~name:"shop" with
| Error _ -> assert false
| Ok db -> db
in
@@ -1221,7 +1221,7 @@ let%test_unit "algebra: const_relation single tuple" =
let%test_unit "algebra: select_fn with predicate" =
with_storage (fun storage ->
let db =
- match Memory.create_database storage ~name:"test_db" with
+ match Memory.create_multigroup storage ~name:"test_db" with
| Error _ -> assert false
| Ok db -> db
in
@@ -1258,7 +1258,7 @@ let%test_unit "algebra: select_fn with predicate" =
let%test_unit "algebra: project restricts schema" =
with_storage (fun storage ->
let db =
- match Memory.create_database storage ~name:"test_db" with
+ match Memory.create_multigroup storage ~name:"test_db" with
| Error _ -> assert false
| Ok db -> db
in
@@ -1296,7 +1296,7 @@ let%test_unit "algebra: project restricts schema" =
let%test_unit "algebra: rename changes attr names" =
with_storage (fun storage ->
let db =
- match Memory.create_database storage ~name:"test_db" with
+ match Memory.create_multigroup storage ~name:"test_db" with
| Error _ -> assert false
| Ok db -> db
in
@@ -1322,7 +1322,7 @@ let%test_unit "algebra: rename changes attr names" =
let%test_unit "algebra: equijoin merges matching tuples" =
with_storage (fun storage ->
let db =
- match Memory.create_database storage ~name:"test_db" with
+ match Memory.create_multigroup storage ~name:"test_db" with
| Error _ -> assert false
| Ok db -> db
in
@@ -1400,7 +1400,7 @@ let%test_unit "algebra: equijoin merges matching tuples" =
let%test_unit "algebra: equijoin empty match" =
with_storage (fun storage ->
let db =
- match Memory.create_database storage ~name:"test_db" with
+ match Memory.create_multigroup storage ~name:"test_db" with
| Error _ -> assert false
| Ok db -> db
in
@@ -1420,7 +1420,7 @@ let%test_unit "algebra: equijoin empty match" =
let%test_unit "algebra: union concatenates streams" =
with_storage (fun storage ->
let db =
- match Memory.create_database storage ~name:"test_db" with
+ match Memory.create_multigroup storage ~name:"test_db" with
| Error _ -> assert false
| Ok db -> db
in
@@ -1453,7 +1453,7 @@ let%test_unit "algebra: union concatenates streams" =
let%test_unit "algebra: diff removes right from left" =
with_storage (fun storage ->
let db =
- match Memory.create_database storage ~name:"test_db" with
+ match Memory.create_multigroup storage ~name:"test_db" with
| Error _ -> assert false
| Ok db -> db
in
@@ -1480,7 +1480,7 @@ let%test_unit "algebra: diff removes right from left" =
let%test_unit "algebra: take limits output" =
with_storage (fun storage ->
let db =
- match Memory.create_database storage ~name:"test_db" with
+ match Memory.create_multigroup storage ~name:"test_db" with
| Error _ -> assert false
| Ok db -> db
in
@@ -1523,7 +1523,7 @@ let%test_unit "drl: parse Select" =
let%test_unit "drl: execute Base" =
with_storage (fun storage ->
let db =
- match Memory.create_database storage ~name:"test_db" with
+ match Memory.create_multigroup storage ~name:"test_db" with
| Error _ -> assert false
| Ok db -> db
in
@@ -1543,7 +1543,7 @@ let%test_unit "drl: execute Base" =
let%test_unit "drl: execute Select+Const" =
with_storage (fun storage ->
let db =
- match Memory.create_database storage ~name:"test_db" with
+ match Memory.create_multigroup storage ~name:"test_db" with
| Error _ -> assert false
| Ok db -> db
in
@@ -1926,7 +1926,7 @@ let%test_unit "constraint: Forall unbounded quantifier errors" =
let%test_unit "constraint: create_tuple with passing constraint" =
with_storage (fun storage ->
let db =
- match Memory.create_database storage ~name:"test" with
+ match Memory.create_multigroup storage ~name:"test" with
| Error _ -> assert false
| Ok db -> db
in
@@ -1965,7 +1965,7 @@ let%test_unit "constraint: create_tuple with passing constraint" =
let%test_unit "constraint: create_tuple with failing constraint" =
with_storage (fun storage ->
let db =
- match Memory.create_database storage ~name:"test" with
+ match Memory.create_multigroup storage ~name:"test" with
| Error _ -> assert false
| Ok db -> db
in
@@ -2015,7 +2015,7 @@ let%test_unit "constraint: create_tuple with failing constraint" =
let%test_unit "constraint scenario: mutual exclusion subtypes" =
with_storage (fun storage ->
let db =
- match Memory.create_database storage ~name:"test" with
+ match Memory.create_multigroup storage ~name:"test" with
| Error _ -> assert false
| Ok db -> db
in
@@ -2091,7 +2091,7 @@ let%test_unit "constraint scenario: mutual exclusion subtypes" =
let%test_unit "constraint scenario: foreign key" =
with_storage (fun storage ->
let db =
- match Memory.create_database storage ~name:"test" with
+ match Memory.create_multigroup storage ~name:"test" with
| Error _ -> assert false
| Ok db -> db
in
@@ -2195,7 +2195,7 @@ let%test_unit "constraint scenario: foreign key" =
let%test_unit "constraint scenario: self-reference neq" =
with_storage (fun storage ->
let db =
- match Memory.create_database storage ~name:"test" with
+ match Memory.create_multigroup storage ~name:"test" with
| Error _ -> assert false
| Ok db -> db
in
@@ -2290,7 +2290,7 @@ let%test_unit "constraint scenario: self-reference neq" =
let%test_unit "constraint scenario: open vs closed ticket" =
with_storage (fun storage ->
let db =
- match Memory.create_database storage ~name:"test" with
+ match Memory.create_multigroup storage ~name:"test" with
| Error _ -> assert false
| Ok db -> db
in
@@ -2370,7 +2370,7 @@ let%test_unit "constraint scenario: open vs closed ticket" =
let%test_unit "constraint scenario: weak entity dependency" =
with_storage (fun storage ->
let db =
- match Memory.create_database storage ~name:"test" with
+ match Memory.create_multigroup storage ~name:"test" with
| Error _ -> assert false
| Ok db -> db
in
@@ -2472,7 +2472,7 @@ let%test_unit "constraint scenario: weak entity dependency" =
let%test_unit "constraint propagation: select preserves constraints" =
with_storage (fun storage ->
let db =
- match Memory.create_database storage ~name:"test" with
+ match Memory.create_multigroup storage ~name:"test" with
| Error _ -> assert false
| Ok db -> db
in
@@ -2503,7 +2503,7 @@ let%test_unit "constraint propagation: select preserves constraints" =
let%test_unit "constraint propagation: project filters constraints" =
with_storage (fun storage ->
let db =
- match Memory.create_database storage ~name:"test" with
+ match Memory.create_multigroup storage ~name:"test" with
| Error _ -> assert false
| Ok db -> db
in
@@ -2626,7 +2626,7 @@ let%test_unit "prl: round-trip DefineFunctionPredicate" =
let%test_unit "prl: define predicate and query via DRL" =
with_storage (fun storage ->
let db =
- match Memory.create_database storage ~name:"prl_db" with
+ match Memory.create_multigroup storage ~name:"prl_db" with
| Error _ -> assert false
| Ok db -> db
in
@@ -2675,7 +2675,7 @@ let%test_unit "prl: define predicate and query via DRL" =
let%test_unit "ddl: execute CreateDatabase" =
with_storage (fun storage ->
- let db = Management.Database.empty ~name:"" in
+ let db = Management.Multigroup.empty ~name:"" in
let stmt = Ddl.Ast.CreateDatabase "shop" in
match Ddl.Executor.Memory.execute storage db stmt with
| Error _ -> assert false
@@ -2684,7 +2684,7 @@ let%test_unit "ddl: execute CreateDatabase" =
let%test_unit "ddl: execute CreateRelation" =
with_storage (fun storage ->
let db =
- match Memory.create_database storage ~name:"shop" with
+ match Memory.create_multigroup storage ~name:"shop" with
| Error _ -> assert false
| Ok db -> db
in
@@ -2697,12 +2697,12 @@ let%test_unit "ddl: execute CreateRelation" =
in
match Ddl.Executor.Memory.execute storage db stmt with
| Error _ -> assert false
- | Ok (db, _msg) -> assert (Management.Database.has_relation db "users"))
+ | Ok (db, _msg) -> assert (Management.Multigroup.has_relation db "users"))
let%test_unit "dml: execute InsertTuple" =
with_storage (fun storage ->
let db =
- match Memory.create_database storage ~name:"shop" with
+ match Memory.create_multigroup storage ~name:"shop" with
| Error _ -> assert false
| Ok db -> db
in
@@ -2720,7 +2720,7 @@ let%test_unit "dml: execute InsertTuple" =
| Error _ -> assert false
| Ok db ->
let rel =
- match Management.Database.get_relation db "users" with
+ match Management.Multigroup.get_relation db "users" with
| None -> assert false
| Some r -> r
in
@@ -2729,7 +2729,7 @@ let%test_unit "dml: execute InsertTuple" =
let%test_unit "dml: execute InsertTuples" =
with_storage (fun storage ->
let db =
- match Memory.create_database storage ~name:"shop" with
+ match Memory.create_multigroup storage ~name:"shop" with
| Error _ -> assert false
| Ok db -> db
in
@@ -2754,7 +2754,7 @@ let%test_unit "dml: execute InsertTuples" =
| Error _ -> assert false
| Ok db ->
let rel =
- match Management.Database.get_relation db "users" with
+ match Management.Multigroup.get_relation db "users" with
| None -> assert false
| Some r -> r
in
@@ -2763,7 +2763,7 @@ let%test_unit "dml: execute InsertTuples" =
let%test_unit "dml: execute DeleteTuple" =
with_storage (fun storage ->
let db =
- match Memory.create_database storage ~name:"shop" with
+ match Memory.create_multigroup storage ~name:"shop" with
| Error _ -> assert false
| Ok db -> db
in
@@ -2793,7 +2793,7 @@ let%test_unit "dml: execute DeleteTuple" =
| Error _ -> assert false
| Ok db ->
let rel =
- match Management.Database.get_relation db "users" with
+ match Management.Multigroup.get_relation db "users" with
| None -> assert false
| Some r -> r
in
@@ -2802,7 +2802,7 @@ let%test_unit "dml: execute DeleteTuple" =
let%test_unit "ddl: execute RetractRelation" =
with_storage (fun storage ->
let db =
- match Memory.create_database storage ~name:"shop" with
+ match Memory.create_multigroup storage ~name:"shop" with
| Error _ -> assert false
| Ok db -> db
in
@@ -2817,12 +2817,12 @@ let%test_unit "ddl: execute RetractRelation" =
with
| Error _ -> assert false
| Ok (db, _msg) ->
- assert (not (Management.Database.has_relation db "users")))
+ assert (not (Management.Multigroup.has_relation db "users")))
let%test_unit "ddl: execute ClearRelation" =
with_storage (fun storage ->
let db =
- match Memory.create_database storage ~name:"shop" with
+ match Memory.create_multigroup storage ~name:"shop" with
| Error _ -> assert false
| Ok db -> db
in
@@ -2854,7 +2854,7 @@ let%test_unit "ddl: execute ClearRelation" =
| Error _ -> assert false
| Ok (db, _msg) ->
let rel =
- match Management.Database.get_relation db "users" with
+ match Management.Multigroup.get_relation db "users" with
| None -> assert false
| Some r -> r
in
@@ -2863,7 +2863,7 @@ let%test_unit "ddl: execute ClearRelation" =
let%test_unit "ddl: execute RegisterDomain" =
with_storage (fun storage ->
let db =
- match Memory.create_database storage ~name:"shop" with
+ match Memory.create_multigroup storage ~name:"shop" with
| Error _ -> assert false
| Ok db -> db
in
@@ -2873,12 +2873,12 @@ let%test_unit "ddl: execute RegisterDomain" =
in
match Ddl.Executor.Memory.execute storage db stmt with
| Error _ -> assert false
- | Ok (db, _msg) -> assert (Management.Database.has_domain db "money"))
+ | Ok (db, _msg) -> assert (Management.Multigroup.has_domain db "money"))
let%test_unit "dml: insert into nonexistent relation returns error" =
with_storage (fun storage ->
let db =
- match Memory.create_database storage ~name:"shop" with
+ match Memory.create_multigroup storage ~name:"shop" with
| Error _ -> assert false
| Ok db -> db
in
@@ -2968,7 +2968,7 @@ let%test_unit "dcl: round-trip Not constraint" =
let%test_unit "dcl: execute RegisterConstraint attaches constraint" =
with_storage (fun storage ->
let db =
- match Memory.create_database storage ~name:"shop" with
+ match Memory.create_multigroup storage ~name:"shop" with
| Error _ -> assert false
| Ok db -> db
in
@@ -2995,7 +2995,7 @@ let%test_unit "dcl: execute RegisterConstraint attaches constraint" =
| Error _ -> assert false
| Ok (db, _) ->
let rel =
- match Management.Database.get_relation db "order_items" with
+ match Management.Multigroup.get_relation db "order_items" with
| None -> assert false
| Some r -> r
in
@@ -3004,7 +3004,7 @@ let%test_unit "dcl: execute RegisterConstraint attaches constraint" =
let%test_unit "dcl: FK constraint enforced on insert" =
with_storage (fun storage ->
let db =
- match Memory.create_database storage ~name:"shop" with
+ match Memory.create_multigroup storage ~name:"shop" with
| Error _ -> assert false
| Ok db -> db
in
@@ -3067,7 +3067,7 @@ let%test_unit "dcl: FK constraint enforced on insert" =
| Ok db -> db
in
let rel =
- match Management.Database.get_relation db "order_items" with
+ match Management.Multigroup.get_relation db "order_items" with
| None -> assert false
| Some r -> r
in
@@ -3173,7 +3173,7 @@ let%test_unit "branch: multiple branches are independent" =
let%test_unit "diff: identical databases produce empty diff" =
with_storage (fun storage ->
let db =
- match Memory.create_database storage ~name:"db" with
+ match Memory.create_multigroup storage ~name:"db" with
| Error _ -> assert false
| Ok db -> db
in
@@ -3183,7 +3183,7 @@ let%test_unit "diff: identical databases produce empty diff" =
let%test_unit "diff: added relation detected" =
with_storage (fun storage ->
let ancestor =
- match Memory.create_database storage ~name:"db" with
+ match Memory.create_multigroup storage ~name:"db" with
| Error _ -> assert false
| Ok db -> db
in
@@ -3207,7 +3207,7 @@ let%test_unit "diff: removed relation detected" =
with_storage (fun storage ->
let schema = Schema.empty |> Schema.add "x" "natural" in
let ancestor =
- match Memory.create_database storage ~name:"db" with
+ match Memory.create_multigroup storage ~name:"db" with
| Error _ -> assert false
| Ok db -> db
in
@@ -3233,7 +3233,7 @@ let%test_unit "diff: modified relation detected with added tuple" =
with_storage (fun storage ->
let schema = Schema.empty |> Schema.add "val" "natural" in
let ancestor =
- match Memory.create_database storage ~name:"db" with
+ match Memory.create_multigroup storage ~name:"db" with
| Error _ -> assert false
| Ok db -> db
in
@@ -3242,7 +3242,7 @@ let%test_unit "diff: modified relation detected with added tuple" =
| Error _ -> assert false
| Ok p -> p
in
- let rel = Option.get (Management.Database.get_relation ancestor "r") in
+ let rel = Option.get (Management.Multigroup.get_relation ancestor "r") in
let t : Tuple.materialized =
{
Tuple.relation = "r";
@@ -3273,7 +3273,7 @@ let%test_unit "merge: fast-forward when only one side changed" =
with_storage (fun storage ->
let schema = Schema.empty |> Schema.add "val" "natural" in
let base_db =
- match Memory.create_database storage ~name:"db" with
+ match Memory.create_multigroup storage ~name:"db" with
| Error _ -> assert false
| Ok db -> db
in
@@ -3285,7 +3285,7 @@ let%test_unit "merge: fast-forward when only one side changed" =
(match Memory.store_database storage base_db with
| Error _ -> assert false
| Ok () -> ());
- let rel = Option.get (Management.Database.get_relation base_db "r") in
+ let rel = Option.get (Management.Multigroup.get_relation base_db "r") in
let t1 : Tuple.materialized =
{
Tuple.relation = "r";
@@ -3303,14 +3303,14 @@ let%test_unit "merge: fast-forward when only one side changed" =
| Ok () -> ());
match
MergeMemory.merge ~storage ~strategy:Management.Merge.PreferLeft
- ~left_tip:left_db.Management.Database.hash
- ~right_tip:base_db.Management.Database.hash
+ ~left_tip:left_db.Management.Multigroup.hash
+ ~right_tip:base_db.Management.Multigroup.hash
with
| Error _ -> assert false
| Ok (Management.Merge.Failed _) -> assert false
| Ok (Management.Merge.Clean merged) ->
let merged_rel =
- Option.get (Management.Database.get_relation merged "r")
+ Option.get (Management.Multigroup.get_relation merged "r")
in
assert (Memory.tuple_count merged_rel = 1))
@@ -3318,7 +3318,7 @@ let%test_unit "merge: independent tuple additions produce union" =
with_storage (fun storage ->
let schema = Schema.empty |> Schema.add "val" "natural" in
let base_db =
- match Memory.create_database storage ~name:"db" with
+ match Memory.create_multigroup storage ~name:"db" with
| Error _ -> assert false
| Ok db -> db
in
@@ -3330,7 +3330,7 @@ let%test_unit "merge: independent tuple additions produce union" =
(match Memory.store_database storage base_db with
| Error _ -> assert false
| Ok () -> ());
- let rel = Option.get (Management.Database.get_relation base_db "r") in
+ let rel = Option.get (Management.Multigroup.get_relation base_db "r") in
let t_left : Tuple.materialized =
{
Tuple.relation = "r";
@@ -3363,21 +3363,21 @@ let%test_unit "merge: independent tuple additions produce union" =
| Ok () -> ());
match
MergeMemory.merge ~storage ~strategy:Management.Merge.PreferLeft
- ~left_tip:left_db.Management.Database.hash
- ~right_tip:right_db.Management.Database.hash
+ ~left_tip:left_db.Management.Multigroup.hash
+ ~right_tip:right_db.Management.Multigroup.hash
with
| Error _ -> assert false
| Ok (Management.Merge.Failed _) -> assert false
| Ok (Management.Merge.Clean merged) ->
let merged_rel =
- Option.get (Management.Database.get_relation merged "r")
+ Option.get (Management.Multigroup.get_relation merged "r")
in
assert (Memory.tuple_count merged_rel = 2))
let%test_unit "merge: no-op when both sides are identical" =
with_storage (fun storage ->
let base_db =
- match Memory.create_database storage ~name:"db" with
+ match Memory.create_multigroup storage ~name:"db" with
| Error _ -> assert false
| Ok db -> db
in
@@ -3386,15 +3386,15 @@ let%test_unit "merge: no-op when both sides are identical" =
| Ok () -> ());
match
MergeMemory.merge ~storage ~strategy:Management.Merge.PreferLeft
- ~left_tip:base_db.Management.Database.hash
- ~right_tip:base_db.Management.Database.hash
+ ~left_tip:base_db.Management.Multigroup.hash
+ ~right_tip:base_db.Management.Multigroup.hash
with
| Error _ -> assert false
| Ok (Management.Merge.Failed _) -> assert false
| Ok (Management.Merge.Clean merged) ->
assert (
- Management.Database.get_relation_names merged
- = Management.Database.get_relation_names base_db))
+ Management.Multigroup.get_relation_names merged
+ = Management.Multigroup.get_relation_names base_db))
(* Helper: look up polarity for a relation name in the result map *)
let find_polarity name pols = Constraint.polarity_find name pols
@@ -3808,7 +3808,7 @@ let%test_unit "substitute_transition: substitution applies through And and Not"
Constraint on Employee: Exists d in Department, MemberOf Department (dept_id = Var "dept_id") *)
let setup_fk_db storage =
let db =
- match Memory.create_database storage ~name:"hr" with
+ match Memory.create_multigroup storage ~name:"hr" with
| Error _ -> assert false
| Ok db -> db
in
@@ -4009,7 +4009,7 @@ let%test_unit "cascade: Negative-polarity relation deletion is not checked" =
DELETE from Blacklist should never trigger a cascade check. *)
with_storage (fun storage ->
let db =
- match Memory.create_database storage ~name:"hr" with
+ match Memory.create_multigroup storage ~name:"hr" with
| Error _ -> assert false
| Ok db -> db
in
@@ -4095,7 +4095,7 @@ let%test_unit "cascade: Negative-polarity relation deletion is not checked" =
let%test_unit "cascade: deferred constraint not checked during retract_tuple" =
with_storage (fun storage ->
let db =
- match Memory.create_database storage ~name:"hr" with
+ match Memory.create_multigroup storage ~name:"hr" with
| Error _ -> assert false
| Ok db -> db
in
@@ -4201,7 +4201,7 @@ let%test_unit "cascade: deferred constraint not checked during retract_tuple" =
must trigger a re-check of Employee tuples. *)
let setup_blacklist_db storage =
let db =
- match Memory.create_database storage ~name:"hr" with
+ match Memory.create_multigroup storage ~name:"hr" with
| Error _ -> assert false
| Ok db -> db
in
@@ -4310,7 +4310,7 @@ let%test_unit
commit is the boundary where deferred violations are caught. *)
let setup_deferred_fk_db storage =
let db =
- match Memory.create_database storage ~name:"hr" with
+ match Memory.create_multigroup storage ~name:"hr" with
| Error _ -> assert false
| Ok db -> db
in