From e3d3e20dfea253de291d5b31059cd55c0eaabf02 Mon Sep 17 00:00:00 2001 From: Marcos Magueta Date: Mon, 11 May 2026 23:10:27 -0300 Subject: Multigroup unified reference for hierarchical access --- lib/algebra.ml | 190 +++---- lib/bplustree.ml | 245 +++++++++ lib/catalog.ml | 194 ------- lib/constraint.ml | 103 +++- lib/constraint.mli | 91 ---- lib/dcl/ast.ml | 15 - lib/dcl/executor.ml | 108 ---- lib/dcl/parser.ml | 14 - lib/dcl/sublanguage.ml | 29 - lib/ddl/ast.ml | 2 +- lib/ddl/executor.ml | 26 +- lib/dml/executor.ml | 28 +- lib/domain.ml | 10 - lib/drl/executor.ml | 12 +- lib/drl/gate.ml | 79 --- lib/drl/sublanguage.ml | 9 +- lib/drl_verified/drl_verified.ml | 67 --- lib/drl_verified/drl_verified.mli | 23 - lib/dune | 4 +- lib/error.ml | 6 +- lib/hashing.ml | 4 +- lib/icl/executor.ml | 4 +- lib/listener.ml | 227 ++++---- lib/management/branch.ml | 8 +- lib/management/database.ml | 136 ----- lib/management/diff.ml | 70 --- lib/management/merge.ml | 288 ---------- lib/management/multigroup.ml | 84 +++ lib/manipulation.ml | 1060 ++----------------------------------- lib/merkle.ml | 70 --- lib/nt.ml | 41 ++ lib/prelude/domains.ml | 98 +++- lib/prelude/standard.ml | 121 +++-- lib/prl/executor.ml | 4 +- lib/prl/runtime.ml | 7 +- lib/relation.ml | 239 +++++++-- lib/scl/executor.ml | 49 +- lib/session.ml | 79 --- lib/storable.ml | 150 ++++-- lib/sublanguage.ml | 2 +- lib/sublanguage_types.ml | 4 +- lib/system.ml | 9 +- lib/tuple.ml | 10 +- 43 files changed, 1240 insertions(+), 2779 deletions(-) create mode 100644 lib/bplustree.ml delete mode 100644 lib/catalog.ml delete mode 100644 lib/constraint.mli delete mode 100644 lib/dcl/ast.ml delete mode 100644 lib/dcl/executor.ml delete mode 100644 lib/dcl/parser.ml delete mode 100644 lib/dcl/sublanguage.ml delete mode 100644 lib/domain.ml delete mode 100644 lib/drl/gate.ml delete mode 100644 lib/drl_verified/drl_verified.ml delete mode 100644 lib/drl_verified/drl_verified.mli delete mode 100644 lib/management/database.ml delete mode 100644 lib/management/diff.ml delete mode 100644 lib/management/merge.ml create mode 100644 lib/management/multigroup.ml delete mode 100644 lib/merkle.ml create mode 100644 lib/nt.ml delete mode 100644 lib/session.ml (limited to 'lib') 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 *) + } -- cgit v1.2.3