From cf0fffed43d0ca7618cd0013411151e057b7a32a Mon Sep 17 00:00:00 2001 From: Marcos Magueta Date: Mon, 18 May 2026 12:35:26 -0300 Subject: RNT interface Co-authored-by: Estevan Castilho --- bin/dune | 8 - bin/tree.ml | 165 ---------- config.sexp | 5 +- docs/icl-quantification.org | 4 +- docs/n-way-binding.org | 4 +- flake.lock | 45 ++- flake.nix | 106 ++----- lib/algebra.ml | 378 ++-------------------- lib/bplustree.ml | 245 -------------- lib/branch.ml | 242 ++++++++++++++ lib/ddl/executor.ml | 92 ++++-- lib/ddl/sublanguage.ml | 13 +- lib/dml/executor.ml | 224 +++++++------ lib/dml/sublanguage.ml | 13 +- lib/drl/executor.ml | 113 +++---- lib/drl/sublanguage.ml | 12 +- lib/error.ml | 2 +- lib/icl/executor.ml | 48 ++- lib/icl/sublanguage.ml | 13 +- lib/listener.ml | 325 +++++++------------ lib/management/branch.ml | 6 +- lib/management/multigroup.ml | 64 ++-- lib/manipulation.ml | 12 +- lib/nt.ml | 737 ++++++++++++++++++++++++++++++++++++++++--- lib/nt_ffi.ml | 155 +++++++++ lib/prelude/catalog.ml | 5 + lib/prelude/domains.ml | 2 +- lib/prl/executor.ml | 89 ++---- lib/prl/sublanguage.ml | 7 +- lib/qualified_name.ml | 45 +-- lib/qualified_name.mli | 24 +- lib/relation.ml | 24 +- lib/scl/executor.ml | 17 +- lib/scl/sublanguage.ml | 17 +- lib/session.ml | 49 +++ lib/storable.ml | 38 ++- lib/sublanguage.ml | 4 +- lib/sublanguage_context.ml | 39 +++ lib/sublanguage_types.ml | 7 +- lib/system.ml | 59 ++-- lib/utilities.ml | 14 + lib/vcl/ast.ml | 1 + lib/vcl/executor.ml | 21 ++ lib/vcl/sublanguage.ml | 19 ++ 44 files changed, 1933 insertions(+), 1579 deletions(-) delete mode 100644 bin/tree.ml delete mode 100644 lib/bplustree.ml create mode 100644 lib/branch.ml create mode 100644 lib/nt_ffi.ml create mode 100644 lib/session.ml create mode 100644 lib/sublanguage_context.ml create mode 100644 lib/vcl/ast.ml create mode 100644 lib/vcl/executor.ml create mode 100644 lib/vcl/sublanguage.ml diff --git a/bin/dune b/bin/dune index 7ce0e91..2a0d1c0 100644 --- a/bin/dune +++ b/bin/dune @@ -5,11 +5,3 @@ (libraries relational_engine unix) (link_deps ../shared/shabptree/sakura_shabptree.dll) (modes byte exe)) - -(executable - (name tree) - (public_name sakura-tree) - (modules tree) - (libraries relational_engine unix) - (link_deps ../shared/shabptree/sakura_shabptree.dll) - (modes byte exe)) diff --git a/bin/tree.ml b/bin/tree.ml deleted file mode 100644 index 66f5e1c..0000000 --- a/bin/tree.ml +++ /dev/null @@ -1,165 +0,0 @@ -open Relational_engine - -(* Content-addressed store: hash -> bytes. In production this is NT storage. *) -let store : (string, bytes) Hashtbl.t = Hashtbl.create 64 - -(* --- Object construction helpers --- *) - -let make_tuple ~relation attributes = - let attr_map = - List.fold_left - (fun acc (name, value) -> - Tuple.AttributeMap.add name - { Attribute.value = Obj.repr (value : string) } - acc) - Tuple.AttributeMap.empty attributes - in - { Tuple.relation; attributes = attr_map } - -(* Simulate B+ tree root: hash of sorted tuple hashes. *) -let tuple_tree_pointer tuples = - List.map Hashing.hash_tuple tuples - |> List.sort String.compare - |> List.fold_left ( ^ ) "" - |> Conventions.Hash.hash_text - -let make_relation ~name ~schema ~cardinality tuples = - (new Relation.stored - ~name ~schema ~constraints:None - ~cardinality:(Conventions.Cardinality.Finite cardinality) - ~membership_criteria:(fun _ -> true) - ~lineage:None ~provenance:None) - #set_tree_pointer (Some (tuple_tree_pointer tuples)) - -(* --- Persistence layer (writing into the store) --- *) - -let persist_tuple tuple = - let hash = Hashing.hash_tuple tuple in - Hashtbl.add store hash (Marshal.to_bytes tuple [ Marshal.Closures ]); - hash - -(* Store an ordered list of child hashes at a tree node address. *) -let persist_tree_node node_hash (child_hashes : string list) = - Hashtbl.add store node_hash (Marshal.to_bytes child_hashes []) - -(* Store a relation's metadata (name, schema, tree_pointer) at its hash. *) -let persist_relation (rel : Relation.stored) = - Hashtbl.add store rel#hash - (Marshal.to_bytes (rel#name, rel#schema, rel#tree_pointer) []) - -(* --- Reconstruction layer (reading from the store) --- *) - -let load : 'a. string -> 'a = fun hash -> - Marshal.from_bytes (Hashtbl.find store hash) 0 - -let reconstruct_from_tree_pointer mg_tp = - let rel_hashes : string list = load mg_tp in - List.map (fun rel_hash -> - let (name, schema, tp_opt) : string * Schema.t * string option = - load rel_hash - in - let tuples : Tuple.materialized list = - match tp_opt with - | None -> [] - | Some tp -> - let tuple_hashes : string list = load tp in - List.map load tuple_hashes - in - (name, schema, tuples) - ) rel_hashes - -(* --- Printing --- *) - -let print_tuple (t : Tuple.materialized) = - let fields = - Tuple.AttributeMap.bindings t.attributes - |> List.map (fun (k, attr) -> - k ^ " = " ^ (Obj.magic attr.Attribute.value : string)) - |> String.concat ", " - in - Printf.printf " { %s }\n" fields - -let print_reconstructed relations = - List.iter (fun (name, schema, tuples) -> - Printf.printf " relation: %s [%s]\n" - name - (String.concat ", " (List.map (fun (a, d) -> a ^ ":" ^ d) schema)); - List.iter print_tuple tuples - ) relations - -(* --- Main --- *) - -let boot () = - (* Tuples *) - let dept_engineering = - make_tuple ~relation:"departments" [ ("id", "1"); ("name", "Engineering") ] - in - let dept_sales = - make_tuple ~relation:"departments" [ ("id", "2"); ("name", "Sales") ] - in - let emp_alice = - make_tuple ~relation:"employees" - [ ("dept_id", "1"); ("id", "1"); ("name", "Alice") ] - in - let emp_bob = - make_tuple ~relation:"employees" - [ ("dept_id", "2"); ("id", "2"); ("name", "Bob") ] - in - - (* Persist tuples and capture their hashes *) - let dept_eng_hash = persist_tuple dept_engineering in - let dept_sales_hash = persist_tuple dept_sales in - let emp_alice_hash = persist_tuple emp_alice in - let emp_bob_hash = persist_tuple emp_bob in - - (* Build relations with tree_pointers derived from tuple hashes *) - let departments = - make_relation - ~name:"departments" - ~schema:[ ("id", "int"); ("name", "string") ] - ~cardinality:2 - [ dept_engineering; dept_sales ] - in - let employees = - make_relation - ~name:"employees" - ~schema:[ ("id", "int"); ("name", "string"); ("dept_id", "int") ] - ~cardinality:2 - [ emp_alice; emp_bob ] - in - - (* Persist each relation's B+ tree node (tuple hashes) at its tree_pointer *) - let dept_tp = Option.get departments#tree_pointer in - let emp_tp = Option.get employees#tree_pointer in - persist_tree_node dept_tp - (List.sort String.compare [ dept_eng_hash; dept_sales_hash ]); - persist_tree_node emp_tp - (List.sort String.compare [ emp_alice_hash; emp_bob_hash ]); - - (* Persist relation metadata at each relation hash *) - persist_relation departments; - persist_relation employees; - - (* Build multigroup *) - let company = - List.fold_left - (fun mg rel -> mg#add_relation rel) - (new Management.Multigroup.multigroup ~name:"company") - [ (departments :> Relation.relation); (employees :> Relation.relation) ] - in - - (* Persist multigroup's B+ tree node (relation hashes) at its tree_pointer *) - let mg_tp = Option.get company#tree_pointer in - persist_tree_node mg_tp - (List.sort String.compare [ departments#hash; employees#hash ]); - - Printf.printf "=== Built state ===\n"; - Printf.printf " multigroup hash: %s\n" company#hash; - Printf.printf " tree_pointer: %s\n\n" mg_tp; - - (* Drop everything except the tree_pointer and reconstruct *) - Printf.printf "=== Reconstructing from tree_pointer only ===\n"; - let relations = reconstruct_from_tree_pointer mg_tp in - print_reconstructed relations - -let () = boot () diff --git a/config.sexp b/config.sexp index c1371a8..67a48a5 100644 --- a/config.sexp +++ b/config.sexp @@ -1,8 +1,5 @@ -;; Sakura server configuration -;; storage: memory -;; transport: tcp (address, port) (server -(storage (memory)) + (nt (sqlite "/tmp/sakura.db")) (transport (tcp (address "127.0.0.1") (port 7777)))) diff --git a/docs/icl-quantification.org b/docs/icl-quantification.org index 7a81551..0a3ba90 100644 --- a/docs/icl-quantification.org +++ b/docs/icl-quantification.org @@ -101,8 +101,8 @@ Generator-based relations with no tree return ~Some []~. The materialisation path: 1. ~Merkle.keys tree~ — loads all tuple hashes. -2. For each hash: ~Storage.load_raw~ → ~Storable.Tuple.of_bytes~ → attribute hash list. -3. For each attribute hash: ~Storage.load_raw~ → ~Marshal.from_bytes~. +2. For each hash: ~Storage.load_raw~ -> ~Storable.Tuple.of_bytes~ -> attribute hash list. +3. For each attribute hash: ~Storage.load_raw~ -> ~Marshal.from_bytes~. This eagerly materialises the *entire* quantifier relation into memory before evaluation begins. For a relation of cardinality /n/ with /k/ attributes each, diff --git a/docs/n-way-binding.org b/docs/n-way-binding.org index 85dc0e3..c49d2a1 100644 --- a/docs/n-way-binding.org +++ b/docs/n-way-binding.org @@ -75,7 +75,7 @@ to fire when suites referencing its rooms are inserted. * ICL — Constraints Binary FK constraints compose to enforce referential integrity along the chain -~Suite → Room → Building~. Each link is declared independently. +~Suite -> Room -> Building~. Each link is declared independently. #+begin_src lisp ;; FK: every Room must belong to an existing Building @@ -140,7 +140,7 @@ However, some constraints require joining through intermediate variables before membership check can be made. These cannot be decomposed. Example: /a suite is only valid if its room belongs to a building with more than 3 floors/. -The chain ~suite.room_id → room.building_id → building.floors~ requires two intermediate +The chain ~suite.room_id -> room.building_id -> building.floors~ requires two intermediate variables — it is inherently a 3-wise constraint. Each ~Exists~ record field must be wrapped by name when written in s-expression form, as diff --git a/flake.lock b/flake.lock index e43eb45..59837c9 100644 --- a/flake.lock +++ b/flake.lock @@ -1,5 +1,27 @@ { "nodes": { + "RNT": { + "inputs": { + "nixpkgs": [ + "nixpkgs" + ], + "picosha2": "picosha2" + }, + "locked": { + "lastModified": 1779079590, + "narHash": "sha256-AYny1AQxSudDaqq2XrHyuDJgyHAd58vW5i+GsEfdcpU=", + "owner": "mmagueta", + "repo": "RNT", + "rev": "fdcc42675289ae69068dd02421ba6282c59301df", + "type": "github" + }, + "original": { + "owner": "mmagueta", + "ref": "branching", + "repo": "RNT", + "type": "github" + } + }, "flake-utils": { "inputs": { "systems": "systems" @@ -35,11 +57,11 @@ }, "nixpkgs": { "locked": { - "lastModified": 1772624091, - "narHash": "sha256-QKyJ0QGWBn6r0invrMAK8dmJoBYWoOWy7lN+UHzW1jc=", + "lastModified": 1778869304, + "narHash": "sha256-30sZNZoA1cqF5JNO9fVX+wgiQYjB7HJqqJ4ztCDeBZE=", "owner": "NixOS", "repo": "nixpkgs", - "rev": "80bdc1e5ce51f56b19791b52b2901187931f5353", + "rev": "d233902339c02a9c334e7e593de68855ad26c4cb", "type": "github" }, "original": { @@ -49,8 +71,25 @@ "type": "github" } }, + "picosha2": { + "flake": false, + "locked": { + "lastModified": 1746328024, + "narHash": "sha256-3psCzbrwR+vO9TyTKOx+gEaWuHDx6pSgLOQ3DqrJsnI=", + "owner": "okdshin", + "repo": "PicoSHA2", + "rev": "161cb3fc4170fa7a3eca9e582cebd27cc4d1fe29", + "type": "github" + }, + "original": { + "owner": "okdshin", + "repo": "PicoSHA2", + "type": "github" + } + }, "root": { "inputs": { + "RNT": "RNT", "flake-utils": "flake-utils", "nix-filter": "nix-filter", "nixpkgs": "nixpkgs" diff --git a/flake.nix b/flake.nix index 127102c..67b905c 100644 --- a/flake.nix +++ b/flake.nix @@ -1,32 +1,22 @@ { description = "Sakura Relational Engine"; - - # Flake dependency specification - # - # To update all flake inputs: - # - # $ nix flake update --commit-lockfile - # - # To update individual flake inputs: - # - # $ nix flake lock --update-input ... --commit-lockfile - # inputs = { nixpkgs.url = "github:NixOS/nixpkgs/nixos-unstable"; - # Convenience functions for writing flakes flake-utils.url = "github:numtide/flake-utils"; - # Precisely filter files copied to the nix store nix-filter.url = "github:numtide/nix-filter"; + RNT = { + type = "github"; + owner = "mmagueta"; + repo = "RNT"; + ref = "branching"; + inputs.nixpkgs.follows = "nixpkgs"; + }; }; - outputs = { self, nixpkgs, flake-utils, nix-filter }: - # Construct an output set that supports a number of default systems + outputs = { self, nixpkgs, flake-utils, nix-filter, RNT }: flake-utils.lib.eachDefaultSystem (system: let - # Legacy packages that have not been converted to flakes legacyPackages = nixpkgs.legacyPackages.${system}; - # OCaml packages available on nixpkgs - # Library functions from nixpkgs lib = legacyPackages.lib; ocamlPackages = legacyPackages.ocamlPackages; ppx_protocol_conv = @@ -40,7 +30,7 @@ ppx_protocol_conv = ppx_protocol_conv; fetchFromGitHub = legacyPackages.fetchFromGitHub; ocamlPackages = ocamlPackages; }; - # Filtered sources (prevents unecessary rebuilds) + rnt = RNT.packages.${system}.default; sources = { ocaml = nix-filter.lib { root = ./.; @@ -61,18 +51,7 @@ }; }; in { - # Exposed packages that can be built or run with `nix build` or - # `nix run` respectively: - # - # $ nix build .# - # $ nix run .# -- - # packages = { - # The package that will be built or run by default. For example: - # - # $ nix build - # $ nix run -- - # default = self.packages.${system}.relational_engine; relational_engine = ocamlPackages.buildDunePackage { @@ -82,7 +61,8 @@ src = sources.ocaml; buildInputs = [ ppx_protocol_conv_xml_light - ppx_protocol_conv ] + ppx_protocol_conv + rnt ] ++ (with ocamlPackages; [ sha ctypes @@ -101,26 +81,8 @@ }; }; - # Flake checks - # - # $ nix flake check - # checks = { - # Run tests for the `relational_engine` package relational_engine = let - # Patches calls to dune commands to produce log-friendly output - # when using `nix ... --print-build-log`. Ideally there would be - # support for one or more of the following: - # - # In Dune: - # - # - have workspace-specific dune configuration files - # - # In NixPkgs: - # - # - allow dune flags to be set in in `ocamlPackages.buildDunePackage` - # - alter `ocamlPackages.buildDunePackage` to use `--display=short` - # - alter `ocamlPackages.buildDunePackage` to allow `--config-file=FILE` to be set patchDuneCommand = let subcmds = [ "build" "test" "runtest" "install" ]; in lib.replaceStrings @@ -134,11 +96,9 @@ doCheck = true; buildPhase = patchDuneCommand oldAttrs.buildPhase; checkPhase = patchDuneCommand oldAttrs.checkPhase; - # skip installation (this will be tested in the `relational_engine-app` check) installPhase = "touch $out"; }); - # Check Dune and OCaml formatting dune-fmt = legacyPackages.runCommand "check-dune-fmt" { nativeBuildInputs = [ ocamlPackages.dune_3 @@ -168,6 +128,7 @@ ocamlPackages.lwt-exit ocamlPackages.ctypes ocamlPackages.ctypes-foreign + rnt ppx_protocol_conv ppx_protocol_conv_xml_light ]; @@ -197,56 +158,25 @@ @doc touch $out ''; - - # Check Nix formatting - # nixpkgs-fmt = legacyPackages.runCommand "check-nixpkgs-fmt" { - # nativeBuildInputs = [ legacyPackages.nixpkgs-fmt ]; - # } '' - # echo "checking nix formatting" - # nixpkgs-fmt --check ${sources.nix} - # touch $out - # ''; }; - # Development shells - # - # $ nix develop .# - # $ nix develop .# --command dune build @test - # - # [Direnv](https://direnv.net/) is recommended for automatically loading - # development environments in your shell. For example: - # - # $ echo "use flake" > .envrc && direnv allow - # $ dune build @test - # devShells = { default = legacyPackages.mkShell { - - # Development tools packages = [ - # Source file formatting legacyPackages.nixpkgs-fmt legacyPackages.ocamlformat - # For `dune build --watch ...` - # legacyPackages.fswatch - # For `dune build @doc` ocamlPackages.odoc - # OCaml editor support ocamlPackages.ocaml-lsp - # Nicely formatted types on hover ocamlPackages.ocamlformat-rpc-lib - # Fancy REPL thing ocamlPackages.utop - # Libraries - # ocamlPackages.menhir ocamlPackages.sha ocamlPackages.ctypes ocamlPackages.ctypes-foreign + rnt ocamlPackages.data-encoding ocamlPackages.ppx_inline_test ocamlPackages.ppx_deriving ocamlPackages.ppx_sexp_conv - # legacyPackages.nixfmt-classic ocamlPackages.lwt ocamlPackages.lwt-exit ocamlPackages.batteries @@ -254,18 +184,20 @@ ppx_protocol_conv ppx_protocol_conv_xml_light ocamlPackages.earlybird - # Formal verification legacyPackages.coq legacyPackages.coqPackages.stdlib legacyPackages.z3 ]; - - + shellHook = '' export CAML_LD_LIBRARY_PATH="''${CAML_LD_LIBRARY_PATH:+$CAML_LD_LIBRARY_PATH:}$(ocamlfind query num)" + export RNT_ROOT="${rnt}" + export CPATH="${rnt}/include''${CPATH:+:$CPATH}" + export LIBRARY_PATH="${rnt}/lib''${LIBRARY_PATH:+:$LIBRARY_PATH}" + export DYLD_LIBRARY_PATH="${rnt}/lib''${DYLD_LIBRARY_PATH:+:$DYLD_LIBRARY_PATH}" + export LD_LIBRARY_PATH="${rnt}/lib''${LD_LIBRARY_PATH:+:$LD_LIBRARY_PATH}" ''; - # Tools from packages inputsFrom = [ self.packages.${system}.relational_engine ]; }; }; diff --git a/lib/algebra.ml b/lib/algebra.ml index 0ef16df..9c620ee 100644 --- a/lib/algebra.ml +++ b/lib/algebra.ml @@ -1,61 +1,18 @@ -type error = StorageError of string | GeneratorError of string - -module Make (Storage : Management.Physical.S) = struct - module Ops = Manipulation.Make (Storage) - - type storage = Storage.t - - (* Internal generator utilities *) - - let rec list_generator : Tuple.t list -> Generator.t = function - | [] -> fun _pos -> Generator.Done - | t :: rest -> fun _pos -> Generator.Value (t, list_generator rest) - - let drain gen = - let rec go gen pos acc = - match gen (Some pos) with - | Generator.Done -> Ok (List.rev acc) - | Generator.Error e -> Error (GeneratorError e) - | Generator.Value (t, next) -> go next (pos + 1) (t :: acc) - in - go gen 0 [] - - 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. *) - match Ops.load_tuples storage rel#hash with - | Error _ -> - 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 - new Relation.ephemeral - ~name - ~schema - ~constraints - ~cardinality - ~generator - ~membership_criteria - ~provenance:None - ~lineage:None - - let const_relation (pairs : (string * Conventions.AbstractValue.t) list) : - Relation.ephemeral = +(* algebra.ml — plan compilation support. + Generator-based evaluation is removed; all query execution goes through the + Tarski VM via Nt.execute_query. This module retains only what is needed to + construct plan nodes and handle compile-time errors. *) + +type error = UnsupportedOperator of string + +(* const_relation is kept for the Ast.Const case which produces an in-memory + ephemeral relation from literal pairs. It is used only in DRL tests and + REPL exploration; it does not go through the VM. + TODO: materialise const tuples into InMemoryBackend and SCAN them so they + can participate in VM JOINs. *) +let const_relation (pairs : (string * Conventions.AbstractValue.t) list) : + Relation.ephemeral = + let make_gen () = let attrs = List.fold_left (fun acc (k, v) -> Tuple.AttributeMap.add k { Attribute.value = v } acc) @@ -64,296 +21,15 @@ module Make (Storage : Management.Physical.S) = struct let tuple = Tuple.Materialized { Tuple.relation = "const"; attributes = attrs } in - let schema = List.map (fun (k, _) -> (k, "abstract")) pairs in - (* 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 *) - - let select_fn storage predicate rel = - let gen = to_generator storage rel in - let lazy_gen = - let rec go g pos = - match g pos with - | Generator.Done -> Generator.Done - | Generator.Error e -> Generator.Error e - | Generator.Value (t, next) -> - if predicate t then Generator.Value (t, go next) - else go next (Option.map (( + ) 1) pos) - 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#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 - let project_tuple = function - | Tuple.Materialized t -> - let attrs' = - List.fold_left - (fun acc k -> - match Tuple.AttributeMap.find_opt k t.Tuple.attributes with - | None -> acc - | Some v -> Tuple.AttributeMap.add k v acc) - Tuple.AttributeMap.empty attrs - in - Tuple.Materialized { t with attributes = attrs' } - | other -> other - in - let new_schema = - List.filter (fun (n, _) -> List.mem n attrs) rel#schema - in - let lazy_gen = - let rec go g pos = - match g pos with - | Generator.Done -> Generator.Done - | Generator.Error e -> Generator.Error e - | Generator.Value (t, next) -> Generator.Value (project_tuple t, go next) - in - fun pos -> go gen pos - in - let filtered_constraints = - match rel#constraints with - | None | Some [] -> None - | Some cs -> ( - let kept = - List.filter_map - (fun (name, c) -> - match Constraint.filter_by_attrs attrs c with - | Some c' -> Some (name, c') - | None -> None) - cs - 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#name) - ~schema:new_schema ?constraints:filtered_constraints lazy_gen membership_criteria) - - let rename storage (renames : (string * string) list) rel = - let rename_key k = - match List.assoc_opt k renames with Some k' -> k' | None -> k - in - let rename_tuple = function - | Tuple.Materialized t -> - let attrs' = - Tuple.AttributeMap.fold - (fun k v acc -> Tuple.AttributeMap.add (rename_key k) v acc) - t.Tuple.attributes Tuple.AttributeMap.empty - in - Tuple.Materialized { t with attributes = attrs' } - | other -> other - in - let gen = to_generator storage rel in - let new_schema = - List.map (fun (n, d) -> (rename_key n, d)) rel#schema - in - let lazy_gen = - let rec go g pos = - match g pos with - | Generator.Done -> Generator.Done - | Generator.Error e -> Generator.Error e - | Generator.Value (t, next) -> Generator.Value (rename_tuple t, go next) - in - fun pos -> go gen pos - in - let renamed_constraints = - match rel#constraints with - | None | Some [] -> None - | Some cs -> - Some - (List.map - (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#name) - ~schema:new_schema ?constraints:renamed_constraints lazy_gen membership_criteria) - - let equijoin storage (attrs : string list) left right: (Relation.ephemeral, error) result = - let get_vals attr_list = function - | Tuple.Materialized t -> - List.map - (fun a -> Tuple.AttributeMap.find_opt a t.Tuple.attributes) - attr_list - | _ -> List.map (fun _ -> None) attr_list - in - let merge lt rt = - match (lt, rt) with - | Tuple.Materialized l, Tuple.Materialized r -> - Tuple.Materialized - { - l with - attributes = - Tuple.AttributeMap.union - (fun _ a _ -> Some a) - l.Tuple.attributes r.Tuple.attributes; - } - | _ -> lt - in - let merged_schema = - left#schema - @ List.filter - (fun (n, _) -> - (not (List.mem n attrs)) - && not (List.exists (fun (m, _) -> m = n) left#schema)) - right#schema - in - let merged_constraints = - 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#name ^ "_" ^ right#name in - let rec chain_with_cont g cont pos = - match g pos with - | Generator.Done -> cont pos - | Generator.Value (t, next) -> - Generator.Value (t, fun p -> chain_with_cont next cont p) - | Generator.Error e -> Generator.Error e - in - let make_join_gen left_gen right_tuples = - 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 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 left_gen 0 - in - - 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 - (* 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_join_gen left_gen right_tuples) - membership_criteria) - - let union storage rel1 rel2 = - let gen1 = to_generator storage rel1 in - let gen2 = to_generator storage rel2 in - let chain_gen = - let rec go g1 g2 pos = - match g1 pos with - | Generator.Done -> g2 pos - | Generator.Error _ -> g2 pos - | Generator.Value (t, next) -> Generator.Value (t, fun p -> go next g2 p) - in - fun pos -> go gen1 gen2 pos - 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#schema chain_gen membership_criteria) - - let attrs_equal (m1 : Attribute.materialized Tuple.AttributeMap.t) - (m2 : Attribute.materialized Tuple.AttributeMap.t) = - Tuple.AttributeMap.equal - (fun a b -> Stdlib.( = ) a.Attribute.value b.Attribute.value) - m1 m2 - - let diff storage rel1 rel2 = - let right_gen = to_generator storage rel2 in - match drain right_gen with - | Error e -> Error e - | Ok right_tuples -> - let right_mats = - List.filter_map - (function Tuple.Materialized t -> Some t | _ -> None) - right_tuples - in - let left_gen = to_generator storage rel1 in - let not_in_right = function - | Tuple.Materialized t -> - not - (List.exists - (fun r -> attrs_equal t.Tuple.attributes r.Tuple.attributes) - right_mats) - | _ -> true - in - let lazy_gen = - let rec go g pos = - match g pos with - | Generator.Done -> Generator.Done - | Generator.Error e -> Generator.Error e - | Generator.Value (t, next) -> - if not_in_right t then Generator.Value (t, go next) - else go next (Option.map (( + ) 1) pos) - in - fun pos -> go left_gen pos - 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#schema - ?constraints:rel1#constraints lazy_gen membership_criteria) - - let take storage n rel = - let gen = to_generator storage rel in - let lazy_gen = - let rec go g count pos = - if count = 0 then Generator.Done - else - match g pos with - | Generator.Done -> Generator.Done - | Generator.Error e -> Generator.Error e - | Generator.Value (t, next) -> Generator.Value (t, go next (count - 1)) - 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#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 - | Error e -> Error e - | Ok tuples -> - Ok - (List.filter_map - (function Tuple.Materialized t -> Some t | _ -> None) - tuples) -end - -module Memory = Make (Management.Physical.Memory) + let gen = function + | None | Some 0 -> Generator.Value (tuple, fun _ -> Generator.Done) + | _ -> Generator.Done + in + gen + in + let schema = List.map (fun (k, _) -> (k, "abstract")) pairs in + new Relation.ephemeral ~name:"const" ~schema ~constraints:None + ~cardinality:(Conventions.Cardinality.Finite 1) + ~membership_criteria:(fun _ -> true) + ~lineage:None ~provenance:None + ~generator:(make_gen ()) diff --git a/lib/bplustree.ml b/lib/bplustree.ml deleted file mode 100644 index 608ff7e..0000000 --- a/lib/bplustree.ml +++ /dev/null @@ -1,245 +0,0 @@ -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/branch.ml b/lib/branch.ml new file mode 100644 index 0000000..8437d55 --- /dev/null +++ b/lib/branch.ml @@ -0,0 +1,242 @@ +(* Branch: the effectful session layer. + Owns the RNT branch handle and the in-memory mirror of every multigroup + bound to that branch. Each mutation names its target mg explicitly. *) + +module Make (NT : Nt.S) = struct + + let ( let* ) = Result.bind + + type mode = + | Live (* tracking branch tip; mutations allowed *) + | Detached of string (* pinned to snapshot hash; read-only *) + + class branch + ~(init_bh : Nt.branch_handle) + ~(init_name : string) + ~(init_tip : string) + ~(init_mgs : (string * Management.Multigroup.multigroup) list) + ~(init_mode : mode) = + object (self) + val mutable bh : Nt.branch_handle = init_bh + val name : string = init_name + val mutable tip : string = init_tip + val mutable mode : mode = init_mode + val mgs : (string, Management.Multigroup.multigroup) Hashtbl.t = + let t = Hashtbl.create 8 in + List.iter (fun (n, mg) -> Hashtbl.replace t n mg) init_mgs; + t + + method name = name + method tip = tip + method snapshot = tip + method mode = mode + method branch_handle = bh + + method mg_of (n : string) : Management.Multigroup.multigroup option = + Hashtbl.find_opt mgs n + + method multigroups : (string * Management.Multigroup.multigroup) list = + Hashtbl.to_seq mgs |> List.of_seq + + (* Register a fresh mg under this branch. Idempotent. *) + method add_multigroup ~(name : string) : unit = + if not (Hashtbl.mem mgs name) then + Hashtbl.add mgs name (new Management.Multigroup.multigroup ~name) + + (* Replace the cached mg value (e.g. after an NT mutation returned a + new mg). Idempotent insert if the mg was not present. *) + method set_mg ~(name : string) (mg : Management.Multigroup.multigroup) : unit = + Hashtbl.replace mgs name mg + + (* Path for a relation in this branch (Live) or its pinned snapshot + (Detached). Pass [~branch] to reference a relation on a different + live branch (cross-multigroup reads). *) + method path ?(branch : string option) (fqn : Qualified_name.t) : string = + match branch with + | Some b -> + "/system/branches/" ^ b ^ "/multigroups/" ^ fqn.mg + ^ "/relations/" ^ fqn.name + | None -> + match mode with + | Live -> + "/system/branches/" ^ name ^ "/multigroups/" ^ fqn.mg + ^ "/relations/" ^ fqn.name + | Detached hash -> + "/system/snapshots/" ^ hash ^ "/relations/" ^ fqn.name + + method private assert_live op = + match mode with + | Live -> Ok () + | Detached _ -> + Error (Nt.NotSupported (op ^ ": detached snapshot is read-only")) + + method private sync_tip () = + match mode with + | Detached _ -> () + | Live -> + match NT.branch_target_of_handle bh with + | Error _ -> () + | Ok h -> tip <- h + + method private get_mg op (mg_name : string) : + (Management.Multigroup.multigroup, Nt.error) result = + match Hashtbl.find_opt mgs mg_name with + | Some mg -> Ok mg + | None -> Error (Nt.HandleError + (op ^ ": multigroup not found: " ^ mg_name)) + + method create_relation ~(mg : string) ~(rel_name : string) ~schema = + let* () = self#assert_live "create_relation" in + let* mg_val = self#get_mg "create_relation" mg in + let* (bh', mg') = + NT.create_relation bh mg_val + ~branch_name:name ~mg_name:mg ~name:rel_name ~schema + in + bh <- bh'; Hashtbl.replace mgs mg mg'; self#sync_tip (); Ok () + + method retract_relation ~(mg : string) ~(rel_name : string) = + let* () = self#assert_live "retract_relation" in + let* mg_val = self#get_mg "retract_relation" mg in + let* (bh', mg') = NT.retract_relation bh mg_val ~name:rel_name in + bh <- bh'; Hashtbl.replace mgs mg mg'; self#sync_tip (); Ok () + + method clear_relation ~(mg : string) ~(rel_name : string) = + let* () = self#assert_live "clear_relation" in + let* mg_val = self#get_mg "clear_relation" mg in + match mg_val#get_relation rel_name with + | None -> Error (Nt.HandleError ("relation not found: " ^ rel_name)) + | Some rel -> + let* (bh', mg') = + NT.clear_relation bh mg_val + ~branch_name:name ~mg_name:mg rel + in + bh <- bh'; Hashtbl.replace mgs mg mg'; self#sync_tip (); Ok () + + method register_domain ~(mg : string) domain = + let* () = self#assert_live "register_domain" in + let* mg_val = self#get_mg "register_domain" mg in + let* (bh', mg') = NT.register_domain bh mg_val domain in + bh <- bh'; Hashtbl.replace mgs mg mg'; Ok () + + method create_immutable_relation ~(mg : string) ~name:rel_name ~schema + ~generator ~membership_criteria ~cardinality ~producer = + let* () = self#assert_live "create_immutable_relation" in + let* mg_val = self#get_mg "create_immutable_relation" mg in + let* (bh', mg', rel) = + NT.create_immutable_relation bh mg_val ~name:rel_name ~schema ~generator + ~membership_criteria ~cardinality ~producer + in + bh <- bh'; Hashtbl.replace mgs mg mg'; Ok rel + + method register_constraint ~(mg : string) ~constraint_name ~relation_name + ~body = + let* () = self#assert_live "register_constraint" in + let* mg_val = self#get_mg "register_constraint" mg in + let* (bh', mg') = + NT.register_constraint bh mg_val ~constraint_name ~relation_name ~body + in + bh <- bh'; Hashtbl.replace mgs mg mg'; Ok () + + method insert_tuple ~(mg : string) ~(rel_name : string) attrs = + let* () = self#assert_live "insert_tuple" in + let* hash = + NT.insert_tuple ~branch_name:name ~mg_name:mg ~rel_name attrs + in + self#sync_tip (); Ok hash + + method create_tuple ~(mg : string) ~(rel_name : string) tuple = + let* () = self#assert_live "create_tuple" in + let* hash = + NT.create_tuple ~branch_name:name ~mg_name:mg ~rel_name tuple + in + self#sync_tip (); Ok hash + + method create_tuples ~(mg : string) ~(rel_name : string) tuples = + let* () = self#assert_live "create_tuples" in + let* hash = + NT.create_tuples ~branch_name:name ~mg_name:mg ~rel_name tuples + in + self#sync_tip (); Ok hash + + method retract_tuple ~(mg : string) ~(rel_name : string) ~tuple_hash = + let* () = self#assert_live "retract_tuple" in + let* () = + NT.retract_tuple ~branch_name:name ~mg_name:mg ~rel_name tuple_hash + in + self#sync_tip (); Ok () + + (* Applies a Transition delta from a sublanguage executor. Each entry + replaces the named mg in the cache, then the tip is re-read. *) + method apply_delta (delta : (string * Management.Multigroup.multigroup) list) = + List.iter + (fun (mg_name, mg_val) -> Hashtbl.replace mgs mg_name mg_val) + delta; + self#sync_tip () + + method close () = NT.close_branch bh + end + + (* Default mg name seeded into an unborn branch so the session can write + into something. Real catalog seeding (under "sakura") is the prelude's + responsibility. *) + let default_mg_name = "public" + + let open_branch claims branch_name = + let* (bh, _legacy_mg) = NT.open_branch claims branch_name in + let tip = match NT.branch_target_of_handle bh with + | Ok h -> h + | Error _ -> "" + in + let* mg_entries = NT.list_branch_multigroups branch_name in + let mgs = + List.map + (fun (mg_name, _mg_hash) -> + (* For each bound mg, enumerate its relations from the kernel and + rebuild the OCaml mirror. Schemas are not persisted in the + snapshot codec — they are repopulated by DDL replay / catalog + reads later. *) + let rels = + match NT.list_relations ~branch_name ~mg_name with + | Ok pairs -> pairs + | Error _ -> [] + in + let mg = + List.fold_left + (fun mg (rel_name, root) -> + let rel = + (new Relation.stored + ~name:rel_name + ~schema:[] + ~constraints:None + ~cardinality:Conventions.Cardinality.AlephZero + ~lineage:(Some (Relation.Lineage.Base rel_name)) + ~provenance:(Some (Relation.Provenance.base + ~relation:rel_name ~attributes:[])) + ~membership_criteria:(fun _ -> true)) + #set_tree_pointer (Some root) + in + mg#add_relation (rel :> Relation.relation)) + (new Management.Multigroup.multigroup ~name:mg_name) + rels + in + (mg_name, mg)) + mg_entries + in + let mgs = + if mgs = [] then + [ (default_mg_name, + new Management.Multigroup.multigroup ~name:default_mg_name) ] + else mgs + in + Ok (new branch + ~init_bh:bh ~init_name:branch_name ~init_tip:tip ~init_mgs:mgs + ~init_mode:Live) + + let open_snapshot claims ~branch_name ~snapshot_hash = + let* (bh, mg) = NT.open_snapshot claims branch_name snapshot_hash in + Ok (new branch + ~init_bh:bh ~init_name:branch_name ~init_tip:snapshot_hash + ~init_mgs:[ (mg#name, mg) ] + ~init_mode:(Detached snapshot_hash)) + +end diff --git a/lib/ddl/executor.ml b/lib/ddl/executor.ml index 7800466..a052ba2 100644 --- a/lib/ddl/executor.ml +++ b/lib/ddl/executor.ml @@ -1,23 +1,31 @@ -module Make (Storage : Management.Physical.S) = struct - module Ops = Manipulation.Make (Storage) - +module Make (NT : Nt.S) = struct type error = | ParseError of string - | ManipulationError of Error.t + | NtError of Nt.error | RelationNotFound of string + | MultigroupNotFound of string + | UnqualifiedName of string let sexp_of_error e = let open Sexplib.Sexp in match e with | ParseError s -> List [ Atom "parse-error"; Atom s ] - | ManipulationError e -> Error.sexp_of_error e + | NtError e -> List [ Atom "nt-error"; Atom (Nt.string_of_error e) ] | RelationNotFound s -> List [ Atom "relation-not-found"; Atom s ] + | MultigroupNotFound s -> List [ Atom "multigroup-not-found"; Atom s ] + | UnqualifiedName s -> List [ Atom "unqualified-name"; Atom s ] let ( let* ) = Result.bind - let wrap_manip r = Result.map_error (fun e -> ManipulationError e) r + let wrap_nt r = Result.map_error (fun e -> NtError e) r + + let parse_fqn (s : string) : (Qualified_name.t, error) result = + Qualified_name.try_parse s |> Result.map_error (fun s -> UnqualifiedName s) - let get_rel db name = - Ops.get_relation db name |> Option.to_result ~none:(RelationNotFound name) + let lookup_mg (ctx : Sublanguage_context.t) (mg_name : string) : + (Management.Multigroup.multigroup, error) result = + match ctx.branch#mg_of mg_name with + | Some mg -> Ok mg + | None -> Error (MultigroupNotFound mg_name) let convert_cardinality : Ast.cardinality_spec -> Conventions.Cardinality.t = function @@ -26,43 +34,67 @@ module Make (Storage : Management.Physical.S) = struct | Ast.Continuum -> Conventions.Cardinality.Continuum | Ast.ConstrainedFinite -> Conventions.Cardinality.ConstrainedFinite - let execute (storage : Storage.t) (db : Management.Multigroup.multigroup) - (stmt : Ast.statement) : (Management.Multigroup.multigroup * string, error) result = + (* Every relation-touching statement names exactly one mg via its FQN + prefix. The executor parses the FQN, resolves the mg in the branch + cache, advances it through NT, and returns a single-element delta. *) + let execute (ctx : Sublanguage_context.t) (stmt : Ast.statement) : + (Sublanguage_types.transition_delta * string, error) result = + let bh = ctx.write_handle in + let branch_name = ctx.branch#name in match stmt with | Ast.CreateMultigroup name -> - let* db = Ops.create_multigroup storage name |> wrap_manip in - Ok (db, "Multigroup created: " ^ name) + ctx.branch#add_multigroup ~name; + (match ctx.branch#mg_of name with + | Some mg -> Ok ([ (name, mg) ], "Multigroup created: " ^ name) + | None -> Error (MultigroupNotFound name)) | Ast.CreateRelation { name; schema = schema_pairs } -> + let* fqn = parse_fqn name in + let* mg = lookup_mg ctx fqn.mg in let schema = List.fold_left (fun s (attr, dom) -> Schema.add attr dom s) Schema.empty schema_pairs in - let* db, _ = - Ops.create_relation storage db name schema |> wrap_manip + let* _bh, new_mg = + NT.create_relation bh mg + ~branch_name ~mg_name:fqn.mg ~name:fqn.name ~schema + |> wrap_nt in - Ok (db, "Relation created: " ^ name) + ctx.branch#set_mg ~name:fqn.mg new_mg; + Ok ([ (fqn.mg, new_mg) ], "Relation created: " ^ name) | Ast.RetractRelation name -> - let* db = Ops.retract_relation storage db name |> wrap_manip in - Ok (db, "Relation retracted: " ^ name) + let* fqn = parse_fqn name in + let* mg = lookup_mg ctx fqn.mg in + let* _bh, new_mg = + NT.retract_relation bh mg ~name:fqn.name |> wrap_nt + in + ctx.branch#set_mg ~name:fqn.mg new_mg; + Ok ([ (fqn.mg, new_mg) ], "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) + let* fqn = parse_fqn name in + let* mg = lookup_mg ctx fqn.mg in + (match mg#get_relation fqn.name with + | None -> Error (RelationNotFound name) + | Some rel -> + let* _bh, new_mg = + NT.clear_relation bh mg + ~branch_name ~mg_name:fqn.mg + (rel :> Relation.relation) |> wrap_nt + in + ctx.branch#set_mg ~name:fqn.mg new_mg; + Ok ([ (fqn.mg, new_mg) ], "Relation cleared: " ^ name)) | Ast.RegisterDomain { name; cardinality } -> - let domain: Relation.domain = - new Relation.domain - ~name + let* fqn = parse_fqn name in + let* mg = lookup_mg ctx fqn.mg in + let domain : Relation.domain = + new Relation.domain ~name:fqn.name ~generator:(fun _ -> Generator.Error "not enumerable via DDL") ~membership_criteria:(fun _ -> true) ~cardinality:(convert_cardinality cardinality) - ~schema:Schema.empty - ~provenance:None - ~lineage:None + ~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) + let* _bh, new_mg = NT.register_domain bh mg domain |> wrap_nt in + ctx.branch#set_mg ~name:fqn.mg new_mg; + Ok ([ (fqn.mg, new_mg) ], "Domain registered: " ^ name) end - -module Memory = Make (Management.Physical.Memory) diff --git a/lib/ddl/sublanguage.ml b/lib/ddl/sublanguage.ml index b1c87e5..a7910c5 100644 --- a/lib/ddl/sublanguage.ml +++ b/lib/ddl/sublanguage.ml @@ -1,8 +1,7 @@ -module Make (Storage : Management.Physical.S) = struct - module Exec = Executor.Make (Storage) +module Make (NT : Nt.S) = struct + module Exec = Executor.Make (NT) type configuration = unit - type storage = Storage.t type ast = Ast.statement type error = Exec.error @@ -14,12 +13,10 @@ module Make (Storage : Management.Physical.S) = struct | 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 (db, _) -> Ok (Sublanguage_types.Transition db) + let execute ctx ast = + match Exec.execute ctx ast with + | Ok (delta, _msg) -> Ok (Sublanguage_types.Transition delta) | Error e -> Error e let sexp_of_error = Exec.sexp_of_error end - -module Memory = Make (Management.Physical.Memory) diff --git a/lib/dml/executor.ml b/lib/dml/executor.ml index ed50479..3b18f4b 100644 --- a/lib/dml/executor.ml +++ b/lib/dml/executor.ml @@ -1,40 +1,46 @@ -module Make (Storage : Management.Physical.S) = struct - module Ops = Manipulation.Make (Storage) - module Alg = Algebra.Make (Storage) - module DrlExec = Drl.Executor.Make (Storage) +module Make (NT : Nt.S) = struct + module DrlExec = Drl.Executor.Make (NT) type error = | ParseError of string - | ManipulationError of Error.t + | NtError of Nt.error | RelationNotFound of string - | AlgebraError of Algebra.error + | MultigroupNotFound of string + | UnqualifiedName of string + | DrlError of DrlExec.error let sexp_of_error e = let open Sexplib.Sexp in match e with | ParseError s -> List [ Atom "parse-error"; Atom s ] - | ManipulationError e -> Error.sexp_of_error e + | NtError e -> List [ Atom "nt-error"; Atom (Nt.string_of_error e) ] | RelationNotFound s -> List [ Atom "relation-not-found"; Atom s ] - | AlgebraError (Algebra.StorageError s) -> - List [ Atom "storage-error"; Atom s ] - | AlgebraError (Algebra.GeneratorError s) -> - List [ Atom "generator-error"; Atom s ] + | MultigroupNotFound s -> List [ Atom "multigroup-not-found"; Atom s ] + | UnqualifiedName s -> List [ Atom "unqualified-name"; Atom s ] + | DrlError e -> List [ Atom "drl-error"; DrlExec.sexp_of_error e ] let ( let* ) = Result.bind - let wrap_manip r = Result.map_error (fun e -> ManipulationError e) r - let wrap_alg e = AlgebraError e + let wrap_nt r = Result.map_error (fun e -> NtError e) r - let get_rel db name = - match Ops.get_relation db name with + let parse_fqn (s : string) : (Qualified_name.t, error) result = + Qualified_name.try_parse s |> Result.map_error (fun s -> UnqualifiedName s) + + let lookup_mg (ctx : Sublanguage_context.t) (mg_name : string) : + (Management.Multigroup.multigroup, error) result = + match ctx.branch#mg_of mg_name with + | Some mg -> Ok mg + | None -> Error (MultigroupNotFound mg_name) + + let get_rel (ctx : Sublanguage_context.t) (fqn : Qualified_name.t) = + let* mg = lookup_mg ctx fqn.mg in + match NT.get_relation mg fqn.name with | Some r -> Ok r - | None -> Error (RelationNotFound name) + | None -> Error (RelationNotFound (Qualified_name.to_string fqn)) let retarget target (t : Tuple.materialized) = { t with Tuple.relation = target } - (** Build a materialized tuple from a list of (attr_name, ast_value) pairs *) - let build_tuple ~relation (attributes : Ast.attr_value list) : - Tuple.materialized = + let build_tuple ~relation (attributes : Ast.attr_value list) : Tuple.materialized = let attr_map = List.fold_left (fun acc (name, value) -> @@ -45,93 +51,135 @@ module Make (Storage : Management.Physical.S) = struct in { Tuple.relation; attributes = attr_map } - let eval_query storage db query = - match DrlExec.execute storage db query with - | Ok rel -> Ok rel - | Error (DrlExec.ParseError s) -> Error (ParseError s) - | Error (DrlExec.RelationNotFound s) -> Error (RelationNotFound s) - | Error (DrlExec.AlgebraError e) -> Error (AlgebraError e) + (* Drain all tuples from a DRL query using ctx.resolve for path resolution. + Cross-multigroup reads work transparently here. *) + let drain_query (ctx : Sublanguage_context.t) query = + match DrlExec.compile ctx.resolve query with + | Error e -> Error (DrlError e) + | Ok plan -> + let* stream = + NT.execute_query plan ~rel_name:"dml_drain" + |> wrap_nt + in + let rec drain acc = + match NT.stream_next stream with + | Error _ -> List.rev acc + | Ok None -> List.rev acc + | Ok (Some t) -> drain (t :: acc) + in + let tuples = drain [] in + ignore (NT.stream_close stream); + Ok tuples + + let attr_val_eq a b = + Stdlib.( = ) a.Attribute.value b.Attribute.value + + let tuple_matches_pred common (target_t : Tuple.materialized) + (pred_t : Tuple.materialized) = + List.for_all (fun attr -> + match + ( Tuple.AttributeMap.find_opt attr target_t.Tuple.attributes, + Tuple.AttributeMap.find_opt attr pred_t.Tuple.attributes ) + with + | Some a, Some b -> attr_val_eq a b + | _ -> false) + common - let materialize_tuples storage rel = - Result.map_error wrap_alg (Alg.materialize storage rel) + let semijoin common target_tuples pred_tuples = + List.filter + (fun t -> List.exists (tuple_matches_pred common t) pred_tuples) + target_tuples - let execute (storage : Storage.t) (db : Management.Multigroup.multigroup) - (stmt : Ast.statement) : (Management.Multigroup.multigroup, error) result = + (* DML mutates tuples in a single mg per statement. Returns a + single-element transition delta keyed by that mg's name. *) + let execute (ctx : Sublanguage_context.t) (stmt : Ast.statement) : + (Sublanguage_types.transition_delta, error) result = + let bh = ctx.write_handle in + let branch_name = ctx.branch#name in + let after fqn = Result.bind (lookup_mg ctx fqn.Qualified_name.mg) + (fun mg -> Ok [ (fqn.Qualified_name.mg, mg) ]) + in match stmt with | Ast.InsertTuple { relation; attributes } -> - let* rel = get_rel db relation in + let* fqn = parse_fqn relation in + let* rel = get_rel ctx fqn 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#name) tuples + let* _ = + NT.create_tuple ~branch_name ~mg_name:fqn.mg ~rel_name:rel#name tuple + |> wrap_nt in - let* db, _, _ = - Ops.create_tuples storage db rel tuple_list |> wrap_manip + after fqn + | Ast.InsertTuples { relation; tuples } -> + let* fqn = parse_fqn relation in + let* rel = get_rel ctx fqn in + let tuple_list = List.map (build_tuple ~relation:rel#name) tuples in + let* _ = + NT.create_tuples ~branch_name ~mg_name:fqn.mg ~rel_name:rel#name + tuple_list + |> wrap_nt in - Ok db + after fqn | Ast.DeleteTuple { relation; attributes } -> - let* rel = get_rel db relation in + let* fqn = parse_fqn relation in + let* rel = get_rel ctx fqn 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 + let hash = Hashing.hash_tuple tuple in + let* () = + NT.retract_tuple ~branch_name ~mg_name:fqn.mg ~rel_name:rel#name hash + |> wrap_nt in - Ok db + after fqn | Ast.Assign { target; body } -> - let* rel = get_rel db target in - let* result_rel = eval_query storage db body in - let* tuples = materialize_tuples storage result_rel in - let* db, rel = Ops.clear_relation storage db rel |> wrap_manip in - let* db, _, _ = - Ops.create_tuples storage db rel + let* fqn = parse_fqn target in + let* mg = lookup_mg ctx fqn.mg in + let* rel = get_rel ctx fqn in + let* tuples = drain_query ctx body in + let* _bh, new_mg = + NT.clear_relation bh mg ~branch_name ~mg_name:fqn.mg + (rel :> Relation.relation) |> wrap_nt + in + ctx.branch#set_mg ~name:fqn.mg new_mg; + let* _ = + NT.create_tuples ~branch_name ~mg_name:fqn.mg ~rel_name:rel#name (List.map (retarget rel#name) tuples) - |> wrap_manip + |> wrap_nt in - Ok db + Ok [ (fqn.mg, new_mg) ] | Ast.InsertFrom { target; source } -> - let* rel = get_rel db target in - let* result_rel = eval_query storage db source in - let* tuples = materialize_tuples storage result_rel in - let* db, _, _ = - Ops.create_tuples storage db rel + let* fqn = parse_fqn target in + let* rel = get_rel ctx fqn in + let* tuples = drain_query ctx source in + let* _ = + NT.create_tuples ~branch_name ~mg_name:fqn.mg ~rel_name:rel#name (List.map (retarget rel#name) tuples) - |> wrap_manip + |> wrap_nt in - Ok db + after fqn | Ast.DeleteWhere { target; predicate } -> - let* rel = get_rel db target in - let* pred_rel = eval_query storage db predicate in - let common = - List.filter_map - (fun (n, _) -> - if List.exists (fun (m, _) -> m = n) pred_rel#schema then - Some n - else None) - rel#schema - in - let* joined = - Alg.equijoin storage common rel pred_rel |> Result.map_error wrap_alg + let* fqn = parse_fqn target in + let* rel = get_rel ctx fqn in + let* target_tuples = drain_query ctx (Drl.Ast.Base target) in + let* pred_tuples = drain_query ctx predicate in + let attr_names_of = function + | [] -> [] + | t :: _ -> + List.map fst (Tuple.AttributeMap.bindings t.Tuple.attributes) in - let* to_delete = - Alg.project storage (List.map fst rel#schema) joined - |> Result.map_error wrap_alg + let target_attrs = attr_names_of target_tuples in + let pred_attrs = attr_names_of pred_tuples in + let common = List.filter (fun n -> List.mem n pred_attrs) target_attrs in + let to_delete = semijoin common target_tuples pred_tuples in + let* () = + List.fold_left + (fun acc t -> + let* () = acc in + let hash = Hashing.hash_tuple (retarget rel#name t) in + NT.retract_tuple ~branch_name ~mg_name:fqn.mg ~rel_name:rel#name + hash + |> wrap_nt) + (Ok ()) to_delete in - let* tuples = materialize_tuples storage to_delete in - List.fold_left - (fun acc t -> - let* db = acc in - let* rel = get_rel db target in - let tuple_hash = - Hashing.hash_tuple (retarget rel#name t) - in - let* db, _ = - Ops.retract_tuple storage db rel tuple_hash |> wrap_manip - in - Ok db) - (Ok db) tuples + after fqn end -module Memory = Make (Management.Physical.Memory) +module Memory = Make (Nt.Memory) diff --git a/lib/dml/sublanguage.ml b/lib/dml/sublanguage.ml index cc9d200..a67ec66 100644 --- a/lib/dml/sublanguage.ml +++ b/lib/dml/sublanguage.ml @@ -1,8 +1,7 @@ -module Make (Storage : Management.Physical.S) = struct - module Exec = Executor.Make (Storage) +module Make (NT : Nt.S) = struct + module Exec = Executor.Make (NT) type configuration = unit - type storage = Storage.t type ast = Ast.statement type error = Exec.error @@ -14,12 +13,10 @@ module Make (Storage : Management.Physical.S) = struct | 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 db -> Ok (Sublanguage_types.Transition db) + let execute ctx ast = + match Exec.execute ctx ast with + | Ok delta -> Ok (Sublanguage_types.Transition delta) | Error e -> Error e let sexp_of_error = Exec.sexp_of_error end - -module Memory = Make (Management.Physical.Memory) diff --git a/lib/drl/executor.ml b/lib/drl/executor.ml index 41bdde5..20b94b9 100644 --- a/lib/drl/executor.ml +++ b/lib/drl/executor.ml @@ -1,75 +1,66 @@ -module Make (Storage : Management.Physical.S) = struct - module Alg = Algebra.Make (Storage) - module Ops = Manipulation.Make (Storage) - +module Make (NT : Nt.S) = struct type error = | ParseError of string | RelationNotFound of string - | AlgebraError of Algebra.error + | NtError of Nt.error + | UnsupportedOperator of string + | UnqualifiedName of string let sexp_of_error e = let open Sexplib.Sexp in match e with | ParseError s -> List [ Atom "parse-error"; Atom s ] | RelationNotFound s -> List [ Atom "relation-not-found"; Atom s ] - | AlgebraError (Algebra.StorageError s) -> - List [ Atom "storage-error"; Atom s ] - | AlgebraError (Algebra.GeneratorError s) -> - List [ Atom "generator-error"; Atom s ] - - let wrap = Result.map_error (fun e -> AlgebraError e) - let ast_value_to_abstract = Ast.value_to_abstract + | NtError e -> List [ Atom "nt-error"; Atom (Nt.string_of_error e) ] + | UnsupportedOperator s -> List [ Atom "unsupported-operator"; Atom s ] + | UnqualifiedName s -> List [ Atom "unqualified-name"; Atom s ] - let select_semijoin storage source filter = - let common = - List.filter_map - (fun (n, _) -> - if List.exists (fun (m, _) -> m = n) filter#schema then - Some n - else None) - source#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 ( let* ) = Result.bind - let rec execute (storage : Storage.t) (db : Management.Multigroup.multigroup) - (q : Ast.query) : (Relation.ephemeral, error) Result.t = - let ( >>= ) = Result.bind in + (* Compile a DRL AST query to a Tarski VM plan node tree. + Every base relation reference must be fully qualified ([:]); + [resolve] maps an FQN to its absolute RNT path. *) + let rec compile + (resolve : ?branch:string -> Qualified_name.t -> string) + (q : Ast.query) : (Nt.plan_node, error) result = match q with - | Ast.Base name -> ( - match Ops.get_relation db name with - | None -> Error (RelationNotFound name) - | Some rel -> Ok rel) - | Ast.Const pairs -> - Ok - (Alg.const_relation - (List.map (fun (k, v) -> (k, ast_value_to_abstract v)) pairs)) - | Ast.Select (filter_q, source_q) -> - execute storage db filter_q >>= fun filter -> - execute storage db source_q >>= fun source -> - select_semijoin storage source filter - | Ast.Join (attrs, q1, q2) -> - execute storage db q1 >>= fun r1 -> - execute storage db q2 >>= fun r2 -> - wrap (Alg.equijoin storage attrs r1 r2) - | Ast.Project (attrs, q) -> - execute storage db q >>= fun rel -> wrap (Alg.project storage attrs rel) - | Ast.Rename (renames, q) -> - execute storage db q >>= fun rel -> - wrap (Alg.rename storage renames rel) - | Ast.Cartesian (q1, q2) -> - execute storage db q1 >>= fun r1 -> - execute storage db q2 >>= fun r2 -> wrap (Alg.equijoin storage [] r1 r2) - | Ast.Union (q1, q2) -> - execute storage db q1 >>= fun r1 -> - execute storage db q2 >>= fun r2 -> wrap (Alg.union storage r1 r2) - | Ast.Diff (q1, q2) -> - execute storage db q1 >>= fun r1 -> - execute storage db q2 >>= fun r2 -> wrap (Alg.diff storage r1 r2) + | Ast.Base name -> + (match Qualified_name.try_parse name with + | Error s -> Error (UnqualifiedName s) + | Ok fqn -> Ok (Nt.Scan { path = resolve fqn; args = [] })) + | Ast.Join (on_attrs, q1, q2) -> + let* p1 = compile resolve q1 in + let* p2 = compile resolve q2 in + Ok (Nt.Join { left = p1; right = p2; on_attrs }) | Ast.Take (n, q) -> - execute storage db q >>= fun rel -> wrap (Alg.take storage n rel) -end + let* p = compile resolve q in + Ok (Nt.Take { limit = n; source = p }) + | Ast.Const _ -> + Error (UnsupportedOperator + "Const: literal relations not yet reachable by VM; use Base") + | _ -> + Error (UnsupportedOperator + "Select/Project/Rename/Union/Diff/Cartesian require VM operators not yet implemented") -module Memory = Make (Management.Physical.Memory) + let page_limit = 16 + + let execute (ctx : Sublanguage_context.t) (q : Ast.query) : + (Sublanguage_types.result, error) result = + let* plan = compile ctx.resolve q in + let rel_name = "query_result" in + let* stream = + NT.execute_query plan ~rel_name + |> Result.map_error (fun e -> NtError e) + in + let rec drain acc count = + if count >= page_limit then (List.rev acc, true) + else + match NT.stream_next stream with + | Error _ -> (List.rev acc, false) + | Ok None -> (List.rev acc, false) + | Ok (Some t) -> drain (t :: acc) (count + 1) + in + let (rows, has_more) = drain [] 0 in + ignore (NT.stream_close stream); + Ok (Sublanguage_types.Cursor { cursor_id = "0"; rows; has_more }) +end diff --git a/lib/drl/sublanguage.ml b/lib/drl/sublanguage.ml index f47129f..ccc0222 100644 --- a/lib/drl/sublanguage.ml +++ b/lib/drl/sublanguage.ml @@ -1,8 +1,7 @@ -module Make (Storage : Management.Physical.S) = struct - module Exec = Executor.Make (Storage) +module Make (NT : Nt.S) = struct + module Exec = Executor.Make (NT) type configuration = unit - type storage = Storage.t type ast = Ast.query type error = Exec.error @@ -14,12 +13,7 @@ module Make (Storage : Management.Physical.S) = struct | 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 rel -> Ok (Sublanguage_types.Query (rel :> Relation.relation)) - | Error e -> Error e + let execute ctx ast = Exec.execute ctx ast let sexp_of_error = Exec.sexp_of_error end - -module Memory = Make (Management.Physical.Memory) diff --git a/lib/error.ml b/lib/error.ml index 6215320..b19aebb 100644 --- a/lib/error.ml +++ b/lib/error.ml @@ -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" <+> Atom old_db#name; "new" <+> Atom new_db#name ] diff --git a/lib/icl/executor.ml b/lib/icl/executor.ml index 8de60e0..0a77dff 100644 --- a/lib/icl/executor.ml +++ b/lib/icl/executor.ml @@ -1,19 +1,31 @@ -module Make (Storage : Management.Physical.S) = struct - module Ops = Manipulation.Make (Storage) - +module Make (NT : Nt.S) = struct type error = | ParseError of string - | ManipulationError of Error.t + | NtError of Nt.error | ConversionError of string + | MultigroupNotFound of string + | UnqualifiedName of string let sexp_of_error e = let open Sexplib.Sexp in match e with | ParseError s -> List [ Atom "parse-error"; Atom s ] - | ManipulationError e -> Error.sexp_of_error e + | NtError e -> List [ Atom "nt-error"; Atom (Nt.string_of_error e) ] | ConversionError s -> List [ Atom "conversion-error"; Atom s ] + | MultigroupNotFound s -> List [ Atom "multigroup-not-found"; Atom s ] + | UnqualifiedName s -> List [ Atom "unqualified-name"; Atom s ] + + let ( let* ) = Result.bind + let wrap_nt = Result.map_error (fun e -> NtError e) + + let parse_fqn (s : string) : (Qualified_name.t, error) result = + Qualified_name.try_parse s |> Result.map_error (fun s -> UnqualifiedName s) - let wrap_manip = Result.map_error (fun e -> ManipulationError e) + let lookup_mg (ctx : Sublanguage_context.t) (mg_name : string) : + (Management.Multigroup.multigroup, error) result = + match ctx.branch#mg_of mg_name with + | Some mg -> Ok mg + | None -> Error (MultigroupNotFound mg_name) let convert_binding_expr : Ast.binding_expr -> Constraint.binding_expr = function @@ -39,18 +51,20 @@ 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.Multigroup.multigroup) - (stmt : Ast.statement) : (Management.Multigroup.multigroup * string, error) result = + let execute (ctx : Sublanguage_context.t) (stmt : Ast.statement) : + (Sublanguage_types.transition_delta * string, error) result = match stmt with - | Ast.RegisterConstraint { constraint_name; relation_name; body } -> ( + | Ast.RegisterConstraint { constraint_name; relation_name; body } -> + let* fqn = parse_fqn relation_name in + let* mg = lookup_mg ctx fqn.mg in let runtime_body = convert_body body in - match - Ops.register_constraint storage db ~constraint_name ~relation_name - ~body:runtime_body - |> wrap_manip - with - | Ok new_db -> Ok (new_db, "Constraint registered: " ^ constraint_name) - | Error e -> Error e) + let* _bh, new_mg = + NT.register_constraint ctx.write_handle mg + ~constraint_name ~relation_name:fqn.name ~body:runtime_body + |> wrap_nt + in + ctx.branch#set_mg ~name:fqn.mg new_mg; + Ok ([ (fqn.mg, new_mg) ], "Constraint registered: " ^ constraint_name) end -module Memory = Make (Management.Physical.Memory) +module Memory = Make (Nt.Memory) diff --git a/lib/icl/sublanguage.ml b/lib/icl/sublanguage.ml index c415d96..ae2c359 100644 --- a/lib/icl/sublanguage.ml +++ b/lib/icl/sublanguage.ml @@ -1,8 +1,7 @@ -module Make (Storage : Management.Physical.S) = struct - module Exec = Executor.Make (Storage) +module Make (NT : Nt.S) = struct + module Exec = Executor.Make (NT) type configuration = unit - type storage = Storage.t type ast = Ast.statement type error = Exec.error @@ -14,12 +13,10 @@ module Make (Storage : Management.Physical.S) = struct | 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 (db, _) -> Ok (Sublanguage_types.Transition db) + let execute ctx ast = + match Exec.execute ctx ast with + | Ok (delta, _msg) -> Ok (Sublanguage_types.Transition delta) | Error e -> Error e let sexp_of_error = Exec.sexp_of_error end - -module Memory = Make (Management.Physical.Memory) diff --git a/lib/listener.ml b/lib/listener.ml index 5e8f55d..262a2b9 100644 --- a/lib/listener.ml +++ b/lib/listener.ml @@ -1,25 +1,51 @@ -module type LISTENER = functor - (T : Transport.TRANSPORT) - (S : Management.Physical.S with type error = string) - -> sig - val run : T.t -> S.t -> unit -end - -module Make : LISTENER = +module Make = functor (T : Transport.TRANSPORT) - (S : Management.Physical.S with type error = string) + (NT : Nt.S) -> struct - module type SubS = Sublanguage.S with type storage = S.t - - module AlgebraOps = Algebra.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 + module type SubS = Sublanguage.S + + module Sess = Session.Make (NT) + module B = Branch.Make (NT) + + (** Per-connection state: session owns the active branch. The + branch's [relation_path] becomes the context resolver, so all + sublanguages address the full RNT namespace rather than a + single multigroup. **) + type conn_state = { + claims : Nt.claims; + session : Sess.session; + } + + (** Build a fresh execution context from the current session + state. Called at the top of every handle_sublanguage so it + always reflects the live branch after any prior VCL + switch. **) + let make_ctx (state : conn_state) : Sublanguage_context.t = + let br = state.session#branch in + let claims = state.claims in + let session = state.session in + { + Sublanguage_context.write_handle = br#branch_handle; + branch = (br :> Sublanguage_context.branch_view); + resolve = br#path; + switch_branch = fun name -> + match br#close () with + | Error e -> Error e + | Ok () -> + begin match B.open_branch claims name with + | Error e -> + begin match B.open_branch claims "master" with + | Ok mbr -> session#set_branch mbr + | Error _ -> () + end; + Error e + | Ok new_br -> + session#set_branch new_br; + Ok new_br#multigroups + end + } let read_command input = try Ok (Sexplib.Sexp.input_sexp input) @@ -31,245 +57,126 @@ functor (fun (module Language : SubS) -> Utilities.StringMap.add Language.name (module Language : SubS)) [ - (module Drl.Sublanguage.Make (S) : SubS); - (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 Prl.Sublanguage.Make (S) : SubS); - (module Scl.Sublanguage.Make (S) : SubS); + (module Drl.Sublanguage.Make (NT) : SubS); + (module Ddl.Sublanguage.Make (NT) : SubS); + (module Dml.Sublanguage.Make (NT) : SubS); + (module Icl.Sublanguage.Make (NT) : SubS); + (module Prl.Sublanguage.Make (NT) : SubS); + (module Scl.Sublanguage.Make (NT) : SubS); + (module Vcl.Sublanguage.Make (NT) : SubS); ] Utilities.StringMap.empty - let fmap f m = Result.bind m f - let find_language tag = Utilities.StringMap.find_opt tag sublanguages |> Option.to_result ~none:(Error.UnrecognizedSublanguage tag) - let execute_sublanguage storage db expr (module Language : SubS) = + let execute_sublanguage ctx expr (module Language : SubS) = Language.parse_sexp expr - |> fmap (Language.execute storage db) + |> Utilities.Result.fmap (Language.execute ctx) |> Result.map_error (fun e -> Error.SublanguageError (Language.sexp_of_error e)) - let execute_command storage db = function + let execute_command ctx = function | Sexplib.Sexp.(List [ Atom tag; expr ]) -> - find_language tag |> fmap (execute_sublanguage storage db expr) + find_language tag |> Utilities.Result.fmap (execute_sublanguage ctx expr) | s -> Error (Error.MalformedExpression s) - (* Thread handle and db through the connection after a sublanguage result. *) - let perform handle db result = - match result with - | 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 current_limit = 16 - - let materialize_generator gen limit = - let rec go gen pos acc count = - if count >= limit then (List.rev acc, true) - else - match gen (Some pos) with - | Generator.Done -> (List.rev acc, false) - | Generator.Error _ -> (List.rev acc, false) - | Generator.Value (t, next) -> ( - let mat = - match t with - | Tuple.Materialized m -> Some m - | Tuple.NonMaterialized _ -> None - in - match mat with - | None -> go next (pos + 1) acc count - | Some m -> go next (pos + 1) (m :: acc) (count + 1)) - in - go gen 0 [] 0 - - let materialize_relation storage (rel : Relation.relation) limit = - let gen = AlgebraOps.to_generator storage rel in - materialize_generator gen limit - let tuple_to_sexp (t : Tuple.materialized) = let open Sexplib.Sexp in List (Tuple.AttributeMap.bindings t.Tuple.attributes |> List.map (fun (k, attr) -> - List - [ - Atom k; Conventions.AbstractValue.sexp_of_t attr.Attribute.value; - ])) - - 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 + List [ Atom k; Conventions.AbstractValue.sexp_of_t attr.Attribute.value ])) 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 + Utilities.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) = + (* Serializes a sublanguage result. [branch] is the write target whose + tip and name surface in Cursor / Transition responses. *) + let serialize (branch : B.branch) = let open Sexplib.Sexp in function | Error e -> List [ Atom "error"; Error.sexp_of_error e ] | 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 [ Atom "cursor"; - List [ Atom "id"; Atom cursor_id ]; - List [ Atom "rows"; rows_sexp ]; - List - [ - 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 ]; - (* TODO: forsake the global cursor register in favour of per-connection bookkeeping *) - ] - | Ok (Sublanguage_types.Query rel) -> - let tuples, truncated = - materialize_relation storage rel current_limit - in - let schema_sexp = - List - (List.map - (fun (a, d) -> List [ Atom a; Atom d ]) - rel#schema) - in - let rows_sexp = List (List.map tuple_to_sexp tuples) in - List - [ - Atom "relation"; - 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 "id"; Atom cursor_id ]; + List [ Atom "rows"; List row_sexps ]; + List [ Atom "row_count"; Atom (string_of_int (List.length row_sexps)) ]; + List [ Atom "has_more"; Atom (string_of_bool has_more) ]; + List [ Atom "snapshot"; Atom branch#tip ]; + List [ Atom "branch"; Atom branch#name ]; ] - | Ok (Sublanguage_types.Transition new_db) -> + | Ok (Sublanguage_types.Query _rel) -> + List [ Atom "error"; Atom "unexpected Query result: use Cursor path" ] + | Ok (Sublanguage_types.Transition _new_cache) -> List [ Atom "ok"; - List [ Atom "db_hash"; Atom new_db#hash ]; - List [ Atom "db_name"; Atom new_db#name ]; - ] - | Ok (Sublanguage_types.SessionSwitch multigroup) -> - List - [ - Atom "ok"; - List - [ - Atom "message"; Atom ("Switched to multigroup " ^ multigroup); - ]; + List [ Atom "snapshot"; Atom branch#tip ]; + List [ Atom "branch"; Atom branch#name ]; ] + | Ok (Sublanguage_types.SessionSwitch name) -> + List [ Atom "ok"; List [ Atom "message"; Atom ("Switched to branch " ^ name) ] ] | Ok (Sublanguage_types.CreateMultigroup name) -> - List - [ - Atom "ok"; - List [ Atom "message"; Atom ("Multigroup " ^ name ^ " created") ]; - ] + List [ Atom "ok"; List [ Atom "message"; Atom ("Multigroup " ^ name ^ " created") ] ] - (* 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 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 handle_sublanguage storage output state sexp handle db = - match - Ok sexp - |> fmap (execute_command storage db) - |> fmap (perform handle db) - with + let handle_sublanguage output state sexp = + let ctx = make_ctx !state in + match execute_command ctx sexp 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 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 (storage : S.t) = - let input = T.input connection in + | Ok result -> + (* Sync updated schema_cache back into the branch mirror on any + state-advancing result (DDL, ICL, VCL). For VCL the session + already holds the new branch; refresh_mg is a no-op on it but + correct for DDL/ICL which stay on the same branch. *) + (match result with + | Sublanguage_types.Transition delta -> + !state.session#branch#apply_delta delta + | _ -> ()); + serialize !state.session#branch (Ok result) |> output_response output + + let handle_client connection = + let input = T.input connection in let output = T.output connection in - (* 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_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)) - - let spawn_handler storage connection = - Stdlib.Domain.spawn (fun () -> handle_client connection storage) - - let run transport storage = + match NT.authenticate Nt.PlainText with + | Error e -> + send_error output (Error.SyntaxError (Nt.string_of_error e)) + | Ok claims -> + (match Sess.open_session claims ~branch_name:"master" with + | Error e -> + send_error output (Error.SyntaxError (Nt.string_of_error e)) + | Ok sess -> + let state = ref { claims; session = sess } in + (try + while true do + match read_command input with + | Error e -> send_error output e + | Ok sexp -> handle_sublanguage output state sexp + done + with + | End_of_file -> ignore (!state.session#close ()) + | e -> + ignore (!state.session#close ()); + Printf.eprintf "Error handling connection: %s" (Printexc.to_string e))) + + let spawn_handler connection = + Stdlib.Domain.spawn (fun () -> handle_client connection) + + let run transport = T.listen transport; while true do - T.accept transport |> spawn_handler storage |> ignore + T.accept transport |> spawn_handler |> ignore done end diff --git a/lib/management/branch.ml b/lib/management/branch.ml index 801c43d..ea9d525 100644 --- a/lib/management/branch.ml +++ b/lib/management/branch.ml @@ -1,8 +1,8 @@ (** Branch registry: named pointers to database tip hashes, plus HEAD tracking. Stored in the Physical backend under reserved key prefixes: - - "branch:" → serialized { name; tip } - - "branch_names" → serialized string list (index for enumeration) - - "head" → branch name as raw bytes *) + - "branch:" -> serialized { name; tip } + - "branch_names" -> serialized string list (index for enumeration) + - "head" -> branch name as raw bytes *) type t = { name : string; tip : Conventions.Hash.t } type head = string diff --git a/lib/management/multigroup.ml b/lib/management/multigroup.ml index cfde4c1..f115d97 100644 --- a/lib/management/multigroup.ml +++ b/lib/management/multigroup.ml @@ -4,19 +4,12 @@ class multigroup ~name:(init_name : Conventions.Name.t) = - let init_hash = Conventions.Hash.hash_text init_name in - object (self) + 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 @@ -24,35 +17,15 @@ class multigroup ~name:(init_name : Conventions.Name.t) = 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 + {< relations = BatMap.String.add rel#name rel relations >} method remove_relation rel_name = - if not (BatMap.String.mem rel_name relations) then self - else self#advance (BatMap.String.remove rel_name relations) + {< relations = 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) + if not (BatMap.String.mem rel#name relations) then {< >} + else {< relations = BatMap.String.add rel#name rel relations >} method serialize () : Storable.Multigroup.t = { @@ -61,23 +34,32 @@ class multigroup ~name:(init_name : Conventions.Name.t) = } end -let deserialize (_bytes : bytes) : (multigroup, string) result = +let deserialize (bytes : bytes) : (multigroup, string) result = + (* Reconstruct a multigroup from its persisted payload. + Only name, schema, and tree_pointer (Merkle root) are restored per + relation. Constraints are not yet round-tripped — see the TODO in + storable.ml for the constraint serialisation plan. *) try - let stored = Storable.Multigroup.of_bytes _bytes in + 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 + (fun mg rel -> + let relation = + new Relation.stored + ~name:rel.Storable.Relation.name ~schema:rel.schema + ~constraints:None + ~cardinality:Conventions.Cardinality.AlephZero + ~lineage:None + ~provenance:None + ~membership_criteria:(fun _ -> true) in let relation = - new Relation.stored ~name:rel.name ~schema:rel.schema ~constraints:None - ~cardinality:Conventions.Cardinality.ConstrainedFinite - ~membership_criteria ~lineage:None ~provenance:None + if rel.tree_pointer = "" then relation + else relation#set_tree_pointer (Some rel.tree_pointer) in - db#add_relation relation) + mg#add_relation (relation :> Relation.relation)) db stored.relations in Ok db diff --git a/lib/manipulation.ml b/lib/manipulation.ml index dd09378..55b1c32 100644 --- a/lib/manipulation.ml +++ b/lib/manipulation.ml @@ -14,11 +14,11 @@ (** 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 ( let* ) = Result.bind + (* State Persistence - Store relation and database states *) (** Store a relation state to storage *) @@ -30,11 +30,13 @@ module Make (Storage : Management.Physical.S) = struct | Error _ -> Error (Error.StorageError "Failed to store relation") | Ok () -> Ok () - (** Store a database state to storage *) + (** Store a database state to storage. + Keyed by [db#name]; content-hashing of mgs is no longer maintained on the + Sakura side — the kernel owns mg content addressing. *) let store_multigroup (storage : storage) (db : Management.Multigroup.multigroup) : (unit, error) Result.t = match - Storage.store_raw storage db#hash (Storable.Multigroup.to_bytes @@ db#serialize ()) + Storage.store_raw storage db#name (Storable.Multigroup.to_bytes @@ db#serialize ()) with | Error _ -> Error (Error.StorageError "Failed to store multigroup") | Ok () -> Ok () diff --git a/lib/nt.ml b/lib/nt.ml index c980093..1e7077f 100644 --- a/lib/nt.ml +++ b/lib/nt.ml @@ -1,41 +1,696 @@ -(* 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" +(* Interface to the RNT kernel *) + +open Ctypes + +(* Shared types independent of backend, shared across all Make instances *) + +type auth_method = Certificate | PlainText + +(** Opaque claim token returned by [authenticate]. *) +type claims = string + +(** Opaque handle to an open branch (multigroup head) in the NT registry. *) +type branch_handle = nativeint + +(** Opaque handle to an open relation object in the NT registry. *) +type relation_handle = nativeint + +(** Distinguishes a simple single-relation cursor from a full VM plan cursor. *) +type cursor_kind = Simple | Vm + +(** A streaming cursor over tuples produced either by a simple scan or the VM. *) +type tuple_stream = { + ts_cursor : nativeint; + ts_relation : string; + ts_kind : cursor_kind; +} + +type path_arg = Var of string | Const of string + +type plan_node = + | Scan of { path : string; args : (string * path_arg) list } + (* Given this is the query plan, this should probably specify a + concrete join algorithm (e.g. HashJoin, NestedLoop, LeapFrog, &c) *) + | Join of { left : plan_node; right : plan_node; on_attrs : string list } + | Take of { limit : int; source : plan_node } + +type error = + | AuthFailed of string + | HandleError of string + | CursorError of string + | NotSupported of string + | InitializationError + +let string_of_error = function + | AuthFailed s -> "AuthFailed: " ^ s + | HandleError s -> "HandleError: " ^ s + | CursorError s -> "CursorError: " ^ s + | NotSupported s -> "NotSupported: " ^ s + | InitializationError -> "InitializationError" + +(* -------------------------------------------------------------------------- + Backend selector + -------------------------------------------------------------------------- *) + +module type Backend = sig + (** RNT storage driver: "sqlite" or "memory". *) + val driver : string + (** Passed to the driver as its init argument. + For "sqlite": file path or ":memory:". + For "memory": ignored. *) + val init_arg : string +end + +(* -------------------------------------------------------------------------- + Functor — one instance per backend + -------------------------------------------------------------------------- *) + +module Make (B : Backend) = struct + + let ( let* ) = Result.bind + + (* -------------------------------------------------------------------------- + Authentication + -------------------------------------------------------------------------- *) + + let authenticate (method_ : auth_method) : (claims, error) result = + let method_str = match method_ with + | Certificate -> "certificate" + | PlainText -> "plain_text" + in + let (rc, claims_opt) = + Nt_ffi.with_out_string (fun pp -> Nt_ffi.rnt_firewall method_str pp) + in + match (rc, claims_opt) with + | (0, Some s) -> Ok s + | (_, Some s) -> Error (AuthFailed s) + | _ -> Error (AuthFailed "firewall rejected connection") + + (* -------------------------------------------------------------------------- + Path helpers (shared by branch and relation lifecycle) + -------------------------------------------------------------------------- *) + + let branch_path (branch_name : string) : string = + "/system/branches/" ^ branch_name + + let multigroup_path ~(branch_name : string) ~(mg_name : string) : string = + branch_path branch_name ^ "/multigroups/" ^ mg_name + + let relation_path ~(branch_name : string) ~(mg_name : string) + ~(rel_name : string) : string = + multigroup_path ~branch_name ~mg_name ^ "/relations/" ^ rel_name + + (* -------------------------------------------------------------------------- + Branch lifecycle + -------------------------------------------------------------------------- + RNT now owns branch state: each branch is a named hash-pointer to an + immutable snapshot. Sakura's [multigroup] is the OCaml-side mirror of + that snapshot's content (relations, schemas, constraints, lineage). + There is no payload to serialise — every relation/tuple mutation + advances the branch to a new snapshot internally. *) + + let ensure_branch (path : string) : unit = + (* Idempotent: rnt_register_branch with "" creates an unborn branch when + missing, no-ops when present. *) + ignore (Nt_ffi.rnt_register_branch path "") + + let branch_target_of_handle (bh : branch_handle) : (string, error) result = + let (rc, target_opt) = + Nt_ffi.with_out_string + (fun pp -> Nt_ffi.rnt_branch_target (Nt_ffi.nint_to_ptr bh) pp) + in + match (rc, target_opt) with + | (0, Some s) -> Ok s + | (0, None) -> Ok "" + | _ -> Error (HandleError "branch_target read failed") + + let list_relations ~(branch_name : string) ~(mg_name : string) : + ((string * string) list, error) result = + let path = multigroup_path ~branch_name ~mg_name in + let (rc, out_opt) = + Nt_ffi.with_out_string (fun pp -> Nt_ffi.rnt_list_relations path pp) + in + match (rc, out_opt) with + | (0, Some s) -> + let pairs = + String.split_on_char '\n' s + |> List.filter_map (fun line -> + match String.split_on_char '\t' line with + | [n; r] when n <> "" -> Some (n, r) + | _ -> None) + in + Ok pairs + | (0, None) -> Ok [] + | _ -> Error (HandleError + ("list_relations failed: " ^ branch_name + ^ "/" ^ mg_name)) + + let list_branch_multigroups (branch_name : string) : + ((string * string) list, error) result = + let path = branch_path branch_name in + let (rc, out_opt) = + Nt_ffi.with_out_string + (fun pp -> Nt_ffi.rnt_list_branch_multigroups path pp) + in + match (rc, out_opt) with + | (0, Some s) -> + let pairs = + String.split_on_char '\n' s + |> List.filter_map (fun line -> + match String.split_on_char '\t' line with + | [n; h] when n <> "" -> Some (n, h) + | _ -> None) + in + Ok pairs + | (0, None) -> Ok [] + | _ -> Error (HandleError + ("list_branch_multigroups failed: " ^ branch_name)) + + let session_open () : (string, error) result = + let (rc, id_opt) = + Nt_ffi.with_out_string + (fun pp -> Nt_ffi.rnt_session_open (from_voidp void null) pp) + in + match (rc, id_opt) with + | (0, Some id) -> Ok id + | _ -> Error (HandleError "session_open failed") + + let session_close (sid : string) : (unit, error) result = + let rc = Nt_ffi.rnt_session_close sid in + if rc = 0 then Ok () else Error (HandleError "session_close failed") + + let session_set_branch (sid : string) (branch_name : string) + (target_hash : string) : (unit, error) result = + let rc = Nt_ffi.rnt_session_set_branch sid branch_name target_hash in + if rc = 0 then Ok () else Error (HandleError "session_set_branch failed") + + let open_branch (_claims : claims) (name : string) : + (branch_handle * Management.Multigroup.multigroup, error) result = + let path = branch_path name in + ensure_branch path; + let raw = Nt_ffi.rnt_open_handle path (from_voidp void null) in + match Nt_ffi.ptr_to_opt raw with + | None -> Error (HandleError ("branch not found: " ^ name)) + | Some bh -> + let* _tip = branch_target_of_handle bh in + let* rel_entries = list_relations ~branch_name:name ~mg_name:name in + (* Populate mg with stored relations from RNT snapshot. Schema is not + persisted in the snapshot codec so relations start schema-less; the + session rebuilds schema state via DDL or catalog queries. *) + let mg = + List.fold_left + (fun mg (rel_name, root) -> + let rel = + (new Relation.stored + ~name:rel_name + ~schema:[] + ~constraints:None + ~cardinality:Conventions.Cardinality.AlephZero + ~lineage:(Some (Relation.Lineage.Base rel_name)) + ~provenance:(Some (Relation.Provenance.base + ~relation:rel_name ~attributes:[])) + ~membership_criteria:(fun _ -> true)) + #set_tree_pointer (Some root) + in + mg#add_relation (rel :> Relation.relation)) + (new Management.Multigroup.multigroup ~name) + rel_entries + in + Ok (bh, mg) + + let close_branch (bh : branch_handle) : (unit, error) result = + let rc = Nt_ffi.rnt_close_handle (Nt_ffi.nint_to_ptr bh) in + if rc = 0 then Ok () else Error (HandleError "close_branch failed") + + let list_snapshot_relations (snapshot_hash : string) : + ((string * string) list, error) result = + let (rc, out_opt) = + Nt_ffi.with_out_string + (fun pp -> Nt_ffi.rnt_list_snapshot_relations snapshot_hash pp) + in + match (rc, out_opt) with + | (0, Some s) -> + let pairs = + String.split_on_char '\n' s + |> List.filter_map (fun line -> + match String.split_on_char '\t' line with + | [n; r] when n <> "" -> Some (n, r) + | _ -> None) + in + Ok pairs + | (0, None) -> Ok [] + | _ -> Error (HandleError ("list_snapshot_relations failed: " ^ snapshot_hash)) + + (* Opens a read-only view pinned to a specific snapshot hash. + Returns (bh, mg) where bh is a handle on the snapshot object and mg + reflects exactly the relation set at that hash. The caller is + responsible for refusing mutations (see Branch.Detached). *) + let open_snapshot (_claims : claims) (branch_name : string) + (snapshot_hash : string) : + (branch_handle * Management.Multigroup.multigroup, error) result = + let snap_path = "/system/snapshots/" ^ snapshot_hash in + let raw = Nt_ffi.rnt_open_handle snap_path (from_voidp void null) in + match Nt_ffi.ptr_to_opt raw with + | None -> Error (HandleError ("snapshot not found: " ^ snapshot_hash)) + | Some bh -> + let* rel_entries = list_snapshot_relations snapshot_hash in + let mg = + List.fold_left + (fun mg (rel_name, root) -> + let rel = + (new Relation.stored + ~name:rel_name + ~schema:[] + ~constraints:None + ~cardinality:Conventions.Cardinality.AlephZero + ~lineage:(Some (Relation.Lineage.Base rel_name)) + ~provenance:(Some (Relation.Provenance.base + ~relation:rel_name ~attributes:[])) + ~membership_criteria:(fun _ -> true)) + #set_tree_pointer (Some root) + in + mg#add_relation (rel :> Relation.relation)) + (new Management.Multigroup.multigroup ~name:branch_name) + rel_entries + in + Ok (bh, mg) + + (* -------------------------------------------------------------------------- + Relation handles + -------------------------------------------------------------------------- *) + + let open_relation ~(branch_name : string) ~(mg_name : string) + ~(rel_name : string) : (relation_handle, error) result = + let path = relation_path ~branch_name ~mg_name ~rel_name in + ignore (Nt_ffi.rnt_register_relation path); + let raw = Nt_ffi.rnt_open_handle path (from_voidp void null) in + match Nt_ffi.ptr_to_opt raw with + | None -> Error (HandleError ("relation not found: " ^ rel_name)) + | Some rh -> Ok rh + + let close_relation (rh : relation_handle) : (unit, error) result = + let rc = Nt_ffi.rnt_close_handle (Nt_ffi.nint_to_ptr rh) in + if rc = 0 then Ok () else Error (HandleError "close_relation failed") + + (* -------------------------------------------------------------------------- + Query execution via the Tarski VM plan builder + -------------------------------------------------------------------------- *) + + (* Recursively builds a C-side PlanWrapper from an OCaml plan_node tree. + On partial failure the partially-built plan is freed before returning Error. *) + let rec build_plan (plan : plan_node) : (nativeint, error) result = + match plan with + | Scan { path; _ } -> + let raw = Nt_ffi.rnt_plan_scan path in + (match Nt_ffi.ptr_to_opt raw with + | None -> Error (CursorError ("plan_scan failed for path: " ^ path)) + | Some p -> Ok p) + | Join { left; right; _ } -> + let* lp = build_plan left in + (match build_plan right with + | Error e -> + Nt_ffi.rnt_plan_free (Nt_ffi.nint_to_ptr lp); + Error e + | Ok rp -> + let raw = Nt_ffi.rnt_plan_join + (Nt_ffi.nint_to_ptr lp) (Nt_ffi.nint_to_ptr rp) in + (* join takes ownership of both children — no manual free needed *) + (match Nt_ffi.ptr_to_opt raw with + | None -> Error (CursorError "plan_join failed") + | Some p -> Ok p)) + | Take { limit; source } -> + let* sp = build_plan source in + let raw = Nt_ffi.rnt_plan_take + (Nt_ffi.nint_to_ptr sp) + (Unsigned.Size_t.of_int limit) in + (* take takes ownership of source — no manual free needed *) + (match Nt_ffi.ptr_to_opt raw with + | None -> Error (CursorError "plan_take failed") + | Some p -> Ok p) + + let execute_query (plan : plan_node) ~(rel_name : string) : + (tuple_stream, error) result = + let* plan_ptr = build_plan plan in + let raw = Nt_ffi.rnt_vm_execute_plan (Nt_ffi.nint_to_ptr plan_ptr) in + match Nt_ffi.ptr_to_opt raw with + | None -> Error (CursorError "vm_execute_plan failed") + | Some ts_cursor -> Ok { ts_cursor; ts_relation = rel_name; ts_kind = Vm } + + let parse_kv_tuple (relation : string) (kv : string) : Tuple.materialized = + let attributes = + String.split_on_char '\n' kv + |> List.filter_map (fun line -> + match String.split_on_char '=' line with + | k :: rest when k <> "" -> + let v = String.concat "=" rest in + Some (k, Attribute.{ value = Obj.repr v }) + | _ -> None) + |> List.fold_left + (fun m (k, v) -> Tuple.AttributeMap.add k v m) + Tuple.AttributeMap.empty + in + { Tuple.relation; attributes } + + let stream_next (stream : tuple_stream) : + (Tuple.materialized option, error) result = + let next_fn = match stream.ts_kind with + | Simple -> Nt_ffi.rnt_cursor_next + | Vm -> Nt_ffi.rnt_vm_cursor_next + in + let (rc, kv_opt) = + Nt_ffi.with_out_string + (fun pp -> next_fn (Nt_ffi.nint_to_ptr stream.ts_cursor) pp) + in + match rc with + | 0 -> Ok None + | 1 -> (match kv_opt with + | None -> Ok None + | Some kv -> Ok (Some (parse_kv_tuple stream.ts_relation kv))) + | _ -> Error (CursorError "cursor_next error") + + let stream_close (stream : tuple_stream) : (unit, error) result = + let close_fn = match stream.ts_kind with + | Simple -> Nt_ffi.rnt_cursor_close + | Vm -> Nt_ffi.rnt_vm_cursor_close + in + let rc = close_fn (Nt_ffi.nint_to_ptr stream.ts_cursor) in + if rc = 0 then Ok () else Error (CursorError "cursor_close failed") + + (* -------------------------------------------------------------------------- + Tuple storage helpers + -------------------------------------------------------------------------- *) + + let materialized_to_kv (tuple : Tuple.materialized) : (string * string) list = + Tuple.AttributeMap.fold + (fun k v acc -> (k, Obj.obj v.Attribute.value) :: acc) + tuple.Tuple.attributes [] + + (* -------------------------------------------------------------------------- + Multigroup / branch mutations + + Each of these advances the underlying RNT branch to a new snapshot as a + side effect of the [rnt_register_relation] / [rnt_link_tuple] / ... call. + The OCaml multigroup is the pure-value mirror: the caller threads the + returned [mg] through subsequent calls. There is no separate commit step. + -------------------------------------------------------------------------- *) + + let create_multigroup (claims : claims) (name : string) : + (branch_handle * Management.Multigroup.multigroup, error) result = + open_branch claims name + + let create_relation (bh : branch_handle) (mg : Management.Multigroup.multigroup) + ~(branch_name : string) ~(mg_name : string) ~(name : string) + ~(schema : Schema.t) : + (branch_handle * Management.Multigroup.multigroup, error) result = + let path = relation_path ~branch_name ~mg_name ~rel_name:name in + let rc = Nt_ffi.rnt_register_relation path in + if rc <> 0 then Error (HandleError ("register_relation failed: " ^ name)) + else + let rel_root = + let (rc, opt) = + Nt_ffi.with_out_string (fun pp -> Nt_ffi.rnt_relation_root path pp) + in + if rc = 0 then Option.value opt ~default:"" else "" + in + let rel = (new Relation.stored + ~name + ~schema + ~constraints:None + ~cardinality:Conventions.Cardinality.AlephZero + ~lineage:(Some (Relation.Lineage.Base name)) + ~provenance:(Some (Relation.Provenance.base ~relation:name + ~attributes:(List.map fst schema))) + ~membership_criteria:(fun _ -> true))#set_tree_pointer (Some rel_root) + in + let* _tip = branch_target_of_handle bh in + Ok (bh, mg#add_relation (rel :> Relation.relation)) + + let retract_relation (bh : branch_handle) (mg : Management.Multigroup.multigroup) + ~(name : string) : + (branch_handle * Management.Multigroup.multigroup, error) result = + (* TODO: there is no rnt_unregister_relation today; the OCaml mg drops the + relation but RNT continues to carry it in the current snapshot. This + drifts the two views — fine while the in-memory mg is the source of + truth for the connection, but worth revisiting once a removal API + exists on the RNT side. *) + Ok (bh, mg#remove_relation name) + + let clear_relation (bh : branch_handle) (mg : Management.Multigroup.multigroup) + ~(branch_name : string) ~(mg_name : string) + (rel : Relation.relation) : + (branch_handle * Management.Multigroup.multigroup, error) result = + let path = relation_path ~branch_name ~mg_name ~rel_name:rel#name in + let rc = Nt_ffi.rnt_clear_relation path in + if rc <> 0 then Error (HandleError ("clear_relation failed: " ^ rel#name)) + else + let* _tip = branch_target_of_handle bh in + Ok (bh, mg) + + let register_domain (_bh : branch_handle) (mg : Management.Multigroup.multigroup) + (domain : Relation.domain) : + (branch_handle * Management.Multigroup.multigroup, error) result = + Ok (_bh, mg#add_relation (domain :> Relation.relation)) + + let create_immutable_relation (bh : branch_handle) + (mg : Management.Multigroup.multigroup) ~name ~schema ~generator + ~membership_criteria ~cardinality ~(producer : Relation.producer option) : + (branch_handle * Management.Multigroup.multigroup * Relation.relation, error) result = + let rel : Relation.relation = + match producer with + | Some p -> + (new Relation.pseudo ~name ~schema ~constraints:None ~cardinality + ~membership_criteria ~lineage:None + ~provenance:Relation.Provenance.empty ~producer:p + :> Relation.relation) + | None -> + (new Relation.ephemeral ~name ~schema ~constraints:None ~cardinality + ~membership_criteria ~lineage:None ~provenance:None ~generator + :> Relation.relation) + in + Ok (bh, mg#add_relation rel, rel) + + let register_constraint (bh : branch_handle) + (mg : Management.Multigroup.multigroup) ~constraint_name ~relation_name + ~(body : Constraint.t) : + (branch_handle * Management.Multigroup.multigroup, error) result = + match mg#get_relation relation_name with + | None -> Error (HandleError ("relation not found: " ^ relation_name)) + | Some rel -> + let existing = + match rel#constraints with Some cs -> cs | None -> [] + in + let new_constraints = (constraint_name, body) :: existing in + let updated_rel = + (Obj.magic rel + : < set_constraints : + Relation.RelationConstraint.t -> + < constraints : Relation.RelationConstraint.t option + ; .. > >) + #set_constraints new_constraints + in + Ok (bh, mg#update_relation (updated_rel :> Relation.relation)) + + (* -------------------------------------------------------------------------- + Tuple mutations + -------------------------------------------------------------------------- *) + + let insert_tuple ~(branch_name : string) ~(mg_name : string) + ~(rel_name : string) (attrs : (string * string) list) : + (string, error) result = + let path = relation_path ~branch_name ~mg_name ~rel_name in + let kv_str = List.map (fun (k, v) -> k ^ "=" ^ v ^ "\n") attrs + |> String.concat "" in + let (rc, hash_opt) = + Nt_ffi.with_out_string (fun pp -> Nt_ffi.rnt_link_tuple path kv_str pp) + in + match (rc, hash_opt) with + | (0, Some h) -> Ok h + | _ -> Error (HandleError "insert_tuple failed") + + let create_tuple ~branch_name ~mg_name ~rel_name (tuple : Tuple.materialized) : + (string, error) result = + insert_tuple ~branch_name ~mg_name ~rel_name (materialized_to_kv tuple) + + let create_tuples ~branch_name ~mg_name ~rel_name + (tuples : Tuple.materialized list) : (string, error) result = + List.fold_left + (fun acc t -> + let* _ = acc in + let* h = create_tuple ~branch_name ~mg_name ~rel_name t in + Ok h) + (Ok "") tuples + + let retract_tuple ~branch_name ~mg_name ~rel_name (hash : string) : + (unit, error) result = + let path = relation_path ~branch_name ~mg_name ~rel_name in + let rc = Nt_ffi.rnt_unlink_tuple path hash in + if rc = 0 then Ok () else Error (HandleError "retract_tuple failed") + + let relation_root ~(branch_name : string) ~(mg_name : string) + ~(rel_name : string) : (string, error) result = + let path = relation_path ~branch_name ~mg_name ~rel_name in + let (rc, root_opt) = + Nt_ffi.with_out_string (fun pp -> Nt_ffi.rnt_relation_root path pp) + in + match (rc, root_opt) with + | (0, Some r) -> Ok r + | (0, None) -> Ok "" + | _ -> Error (HandleError "relation_root query failed") + + (* -------------------------------------------------------------------------- + Prelude / catalog bootstrap + -------------------------------------------------------------------------- *) + + (* Seed the catalog prelude into a brand-new (empty) multigroup. + Creates all catalog relations as stored relations and inserts the + self-describing tuples into public:relation and public:attribute. Each + mutation auto-advances the branch internally; there is no separate + commit step. *) + let seed_prelude ~(branch_name : string) (branch_handle : branch_handle) + (multigroup : Management.Multigroup.multigroup) : + (branch_handle * Management.Multigroup.multigroup, error) result = + let mg_name = multigroup#name in + let* (branch_handle, multigroup) = + List.fold_left + (fun acc (name, schema) -> + let* (branch_handle, multigroup) = acc in + create_relation branch_handle multigroup + ~branch_name ~mg_name ~name ~schema) + (Ok (branch_handle, multigroup)) + Prelude.Catalog.catalog_definitions + in + let rel_tuples = + List.map + (fun (name, _) -> Prelude.Catalog.build_relation_tuple name) + Prelude.Catalog.catalog_definitions + in + let* _ = + create_tuples ~branch_name ~mg_name + ~rel_name:Prelude.Catalog.relation_rel_name rel_tuples + in + let attr_tuples = + List.concat_map + (fun (rel_name, schema) -> + Prelude.Catalog.build_attribute_tuples ~relation_name:rel_name schema) + Prelude.Catalog.catalog_definitions + in + let* _ = + create_tuples ~branch_name ~mg_name + ~rel_name:Prelude.Catalog.attribute_rel_name attr_tuples + in + Ok (branch_handle, multigroup) + + (* Runtime initialization + Seeds the catalog of the master branch when it doesn't exist yet; otherwise + trusts the registry's existing snapshot. The seeded multigroup is + discarded — each connection's [open_branch] starts from an empty mg + and the caller threads catalog state from there. Persistence of the + OCaml-side metadata across process restarts is a separate concern. *) + let initialize () : (unit, error) result = + let runtime_count = Nt_ffi.rnt_init B.driver B.init_arg in + let* () = if runtime_count <> 0 then Error InitializationError else Ok () in + let path = "/system/branches/master" in + ensure_branch path; + let raw = Nt_ffi.rnt_open_handle path (from_voidp void null) in + match Nt_ffi.ptr_to_opt raw with + | None -> Error (HandleError "init: could not open master branch") + | Some bh -> + let* target = branch_target_of_handle bh in + let result = + if target = "" then + let mg = + new Management.Multigroup.multigroup + ~name:Prelude.Catalog.prelude_mg + in + (match seed_prelude ~branch_name:"master" bh mg with + | Ok _ -> Ok () + | Error e -> Error e) + else Ok () + in + ignore (Nt_ffi.rnt_close_handle (Nt_ffi.nint_to_ptr bh)); + result + + (* -------------------------------------------------------------------------- + Multigroup queries + -------------------------------------------------------------------------- *) + + let get_relation (mg : Management.Multigroup.multigroup) (name : string) : + Relation.ephemeral option = + match mg#get_relation name with + | None -> None + | Some rel -> + let gen : 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 -> + fun _pos -> + Generator.Error + ("stored relation must be accessed via Nt.execute_query: " + ^ rel#name) + in + Some + (new Relation.ephemeral ~name:rel#name ~schema:rel#schema + ~constraints:rel#constraints ~cardinality:rel#cardinality + ~membership_criteria:rel#membership_criteria + ~lineage:(Some rel#lineage) ~provenance:(Some rel#provenance) + ~generator:gen) + +end + +module type S = sig + val initialize : unit -> (unit, error) result + val authenticate : auth_method -> (claims, error) result + + val session_open : unit -> (string, error) result + val session_close : string -> (unit, error) result + val session_set_branch : string -> string -> string -> (unit, error) result + + val open_branch : claims -> string -> (branch_handle * Management.Multigroup.multigroup, error) result + val open_snapshot : claims -> string -> string -> (branch_handle * Management.Multigroup.multigroup, error) result + val close_branch : branch_handle -> (unit, error) result + val branch_target_of_handle : branch_handle -> (string, error) result + + val list_relations : branch_name:string -> mg_name:string -> ((string * string) list, error) result + val list_branch_multigroups : string -> ((string * string) list, error) result + val list_snapshot_relations : string -> ((string * string) list, error) result + + val open_relation : branch_name:string -> mg_name:string -> rel_name:string -> (relation_handle, error) result + val close_relation : relation_handle -> (unit, error) result + + val execute_query : plan_node -> rel_name:string -> (tuple_stream, error) result + val stream_next : tuple_stream -> (Tuple.materialized option, error) result + val stream_close : tuple_stream -> (unit, error) result + + val get_relation : Management.Multigroup.multigroup -> string -> Relation.ephemeral option + + val create_multigroup : claims -> string -> (branch_handle * Management.Multigroup.multigroup, error) result + val create_relation : branch_handle -> Management.Multigroup.multigroup -> branch_name:string -> mg_name:string -> name:string -> schema:Schema.t -> (branch_handle * Management.Multigroup.multigroup, error) result + val retract_relation : branch_handle -> Management.Multigroup.multigroup -> name:string -> (branch_handle * Management.Multigroup.multigroup, error) result + val clear_relation : branch_handle -> Management.Multigroup.multigroup -> branch_name:string -> mg_name:string -> Relation.relation -> (branch_handle * Management.Multigroup.multigroup, error) result + val register_domain : branch_handle -> Management.Multigroup.multigroup -> Relation.domain -> (branch_handle * Management.Multigroup.multigroup, error) result + val create_immutable_relation : branch_handle -> Management.Multigroup.multigroup -> name:string -> schema:Schema.t -> generator:Generator.t -> membership_criteria:(Tuple.t -> bool) -> cardinality:Conventions.Cardinality.t -> producer:Relation.producer option -> (branch_handle * Management.Multigroup.multigroup * Relation.relation, error) result + val register_constraint : branch_handle -> Management.Multigroup.multigroup -> constraint_name:string -> relation_name:string -> body:Constraint.t -> (branch_handle * Management.Multigroup.multigroup, error) result + + val create_tuple : branch_name:string -> mg_name:string -> rel_name:string -> Tuple.materialized -> (string, error) result + val create_tuples : branch_name:string -> mg_name:string -> rel_name:string -> Tuple.materialized list -> (string, error) result + val retract_tuple : branch_name:string -> mg_name:string -> rel_name:string -> string -> (unit, error) result + + val insert_tuple : branch_name:string -> mg_name:string -> rel_name:string -> (string * string) list -> (string, error) result + val relation_root : branch_name:string -> mg_name:string -> rel_name:string -> (string, error) result +end + +module Sqlite = Make (struct + let driver = "sqlite" + let init_arg = ":memory:" +end) + +module Memory = Make (struct + let driver = "memory" + let init_arg = "" +end) diff --git a/lib/nt_ffi.ml b/lib/nt_ffi.ml new file mode 100644 index 0000000..b7e65c4 --- /dev/null +++ b/lib/nt_ffi.ml @@ -0,0 +1,155 @@ +(* Low-level ctypes bindings to RNT_C_API.h. + This module is internal to Nt — never import it anywhere else. *) + +open Ctypes +open Foreign + +(* Load the shared library. Set RNT_LIBRARY_PATH to the full path of + libRNT.dylib / libRNT.so when the library is not on the default search + path. *) +let lib = + let path = + match Sys.getenv_opt "RNT_LIBRARY_PATH" with + | Some p -> p + | None -> "libRNT.dylib" + in + Dl.(dlopen ~filename:path ~flags:[ RTLD_NOW; RTLD_GLOBAL ]) + +let fn name typ = foreign ~from:lib name typ + +(* Runtime ----------------------------------------------------------------- *) +let rnt_init = + fn "rnt_init" (string @-> string @-> returning int) + +(* Auth -------------------------------------------------------------------- *) +let rnt_firewall = + fn "rnt_firewall" (string @-> ptr (ptr char) @-> returning int) + +(* Session lifecycle ------------------------------------------------------- *) +let rnt_session_open = + fn "rnt_session_open" (ptr void @-> ptr (ptr char) @-> returning int) + +let rnt_session_close = + fn "rnt_session_close" (string @-> returning int) + +let rnt_session_set_branch = + fn "rnt_session_set_branch" + (string @-> string @-> string @-> returning int) + +(* Handle lifecycle -------------------------------------------------------- *) +let rnt_open_handle = + fn "rnt_open_handle" (string @-> ptr void @-> returning (ptr void)) + +let rnt_close_handle = + fn "rnt_close_handle" (ptr void @-> returning int) + +(* Branch hash-pointer ----------------------------------------------------- *) +let rnt_branch_target = + fn "rnt_branch_target" + (ptr void @-> ptr (ptr char) @-> returning int) + +let rnt_branch_advance = + fn "rnt_branch_advance" (string @-> string @-> returning int) + +(* Object registration ----------------------------------------------------- *) +let rnt_register_relation = + fn "rnt_register_relation" (string @-> returning int) + +let rnt_register_branch = + fn "rnt_register_branch" (string @-> string @-> returning int) + +(* Branch / snapshot relation enumeration ----------------------------------- *) +let rnt_list_relations = + fn "rnt_list_relations" (string @-> ptr (ptr char) @-> returning int) + +let rnt_list_branch_multigroups = + fn "rnt_list_branch_multigroups" (string @-> ptr (ptr char) @-> returning int) + +let rnt_list_snapshot_relations = + fn "rnt_list_snapshot_relations" (string @-> ptr (ptr char) @-> returning int) + +(* Tuple storage ----------------------------------------------------------- *) +let rnt_link_tuple = + fn "rnt_link_tuple" + (string @-> string @-> ptr (ptr char) @-> returning int) + +let rnt_unlink_tuple = + fn "rnt_unlink_tuple" (string @-> string @-> returning int) + +let rnt_clear_relation = + fn "rnt_clear_relation" (string @-> returning int) + +let rnt_relation_root = + fn "rnt_relation_root" + (string @-> ptr (ptr char) @-> returning int) + +(* Cursor and VM ----------------------------------------------------------- *) +let rnt_cursor_open = + fn "rnt_cursor_open" (ptr void @-> returning (ptr void)) + +let rnt_cursor_next = + fn "rnt_cursor_next" (ptr void @-> ptr (ptr char) @-> returning int) + +let rnt_cursor_close = + fn "rnt_cursor_close" (ptr void @-> returning int) + +(* VM plan builder --------------------------------------------------------- *) +let rnt_plan_scan = + fn "rnt_plan_scan" (string @-> returning (ptr void)) + +let rnt_plan_join = + fn "rnt_plan_join" (ptr void @-> ptr void @-> returning (ptr void)) + +let rnt_plan_take = + fn "rnt_plan_take" (ptr void @-> size_t @-> returning (ptr void)) + +let rnt_plan_free = + fn "rnt_plan_free" (ptr void @-> returning void) + +let rnt_vm_execute_plan = + fn "rnt_vm_execute_plan" (ptr void @-> returning (ptr void)) + +let rnt_vm_cursor_next = + fn "rnt_vm_cursor_next" (ptr void @-> ptr (ptr char) @-> returning int) + +let rnt_vm_cursor_close = + fn "rnt_vm_cursor_close" (ptr void @-> returning int) + +(* Memory management ------------------------------------------------------- *) +let rnt_free_string = + fn "rnt_free_string" (ptr char @-> returning void) + +let rnt_free_bytes = + fn "rnt_free_bytes" (ptr uint8_t @-> returning void) + +(* -------------------------------------------------------------------------- + Helpers shared by Nt (not exported from the library module) + -------------------------------------------------------------------------- *) + +let null_char_ptr : char ptr = from_voidp char null + +(* Reads a null-terminated C string from a char pointer, then frees it. *) +let consume_cstring (p : char ptr) : string = + let n = ref 0 in + while !@(p +@ !n) <> '\000' do incr n done; + let s = string_from_ptr p ~length:!n in + rnt_free_string p; + s + +(* Allocates a char* out-parameter, calls [f], returns the rc and string. *) +let with_out_string (f : char ptr ptr -> int) : int * string option = + let pp = allocate (ptr char) null_char_ptr in + let rc = f pp in + let p = !@ pp in + if is_null p then (rc, None) + else (rc, Some (consume_cstring p)) + +(* Converts a void* (returned from open_handle / cursor_open) to nativeint. + Returns None when the pointer is NULL (failure). *) +let ptr_to_opt (p : unit ptr) : nativeint option = + if is_null p then None + else Some (raw_address_of_ptr p) + +(* Converts a stored nativeint back to a void* for API calls. *) +let nint_to_ptr (n : nativeint) : unit ptr = + ptr_of_raw_address n diff --git a/lib/prelude/catalog.ml b/lib/prelude/catalog.ml index c92a89f..01721b2 100644 --- a/lib/prelude/catalog.ml +++ b/lib/prelude/catalog.ml @@ -7,6 +7,11 @@ written to by any executor. They appear to be stubs for trigger/timing metadata that was never implemented. *) +(** Dedicated multigroup hosting the system catalog. The catalog's relation + names keep the [public:] prefix — that prefix is part of the relation name + inside this mg, not a separate namespace. *) +let prelude_mg = "sakura" + let catalog_prefix = "public:" let relation_rel_name = catalog_prefix ^ "relation" let domain_rel_name = catalog_prefix ^ "domain" diff --git a/lib/prelude/domains.ml b/lib/prelude/domains.ml index 022cc6b..9dc9c86 100644 --- a/lib/prelude/domains.ml +++ b/lib/prelude/domains.ml @@ -98,7 +98,7 @@ let rational : Relation.domain = | Some n -> let a, b = cantor_unpair n in let num = nat_to_int a in - (* Map b → non-zero integer: 0→1, 1→-1, 2→2, 3→-2, … *) + (* Map b -> non-zero integer: 0->1, 1->-1, 2->2, 3->-2, … *) let den = if b mod 2 = 0 then (b / 2) + 1 else -((b + 1) / 2) in let attributes = Tuple.AttributeMap.of_list diff --git a/lib/prl/executor.ml b/lib/prl/executor.ml index 10b5142..0ccaf22 100644 --- a/lib/prl/executor.ml +++ b/lib/prl/executor.ml @@ -1,10 +1,8 @@ -module Make (Storage : Management.Physical.S) = struct - module Ops = Manipulation.Make (Storage) - +module Make (NT : Nt.S) = struct type error = | ParseError of string | RuntimeError of string - | RelationError of Error.t + | NtError of Nt.error | UnknownPluginSymbol of string | RelationNotFound of string @@ -13,77 +11,32 @@ module Make (Storage : Management.Physical.S) = struct match e with | ParseError s -> List [ Atom "parse-error"; Atom s ] | RuntimeError s -> List [ Atom "runtime-error"; Atom s ] - | RelationError err -> Error.sexp_of_error err + | NtError e -> List [ Atom "nt-error"; Atom (Nt.string_of_error e) ] | UnknownPluginSymbol s -> List [ Atom "unknown-plugin-symbol"; Atom s ] | RelationNotFound s -> List [ Atom "relation-not-found"; Atom s ] let ( let* ) = Result.bind - let map_rel_error r = Result.map_error (fun e -> RelationError e) r + let _map_nt r = Result.map_error (fun e -> NtError e) r - 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) + (* TODO: PRL function predicates are OCaml shared-library callbacks that + produce tuples at runtime. To make their output joinable inside the + Tarski VM they need to be materialised into a temporary relation in the + InMemoryBackend and then SCANned like any other stored relation. This + requires a `rnt_register_ephemeral_relation` C API call that does not + yet exist. Disable PRL execution until that bridge is in place. *) - let execute_load_library storage db path = - match Runtime.load_library path with - | Error e -> Error (RuntimeError e) - | Ok () -> ( - let* ll_rel = - require_relation db Prelude.Catalog.loaded_library_rel_name - in - let tuple = Prelude.Catalog.build_loaded_library_tuple path in - match Ops.create_tuple storage db ll_rel tuple with - | Ok (new_db, _, _) -> Ok (Sublanguage_types.Transition new_db) - | Error (Error.DuplicateTuple _) -> Ok (Sublanguage_types.Transition db) - | Error e -> Error (RelationError e)) + let execute (_ctx : Sublanguage_context.t) (_stmt : Ast.statement) : + (Sublanguage_types.result, error) result = + Error (RuntimeError + "PRL execution is temporarily disabled pending VM callback-cursor support") - let execute_define_function_predicate storage db - (spec : Ast.function_predicate) = - match Sakura_prl_api.find spec.symbol with - | None -> Error (UnknownPluginSymbol spec.symbol) - | Some impl -> - let schema = - List.fold_left - (fun s (a, d) -> Schema.add a d s) - Schema.empty spec.schema - in - let name = Qualified_name.(parse spec.name |> to_key) in - let generator = Runtime.make_generator name schema impl [] in - let producer = Runtime.make_producer name schema impl in - let membership_criteria = - Runtime.make_membership_criteria schema impl - in - let* new_db, _ = - Ops.create_immutable_relation storage db ~name ~schema ~generator - ~membership_criteria ~cardinality:spec.cardinality - ~producer:(Some producer) - |> map_rel_error - in - let* fp_rel = - require_relation new_db Prelude.Catalog.function_predicate_rel_name - in - let fp_tuple = - Prelude.Catalog.build_function_predicate_tuple ~name - ~symbol:spec.symbol ~cardinality:spec.cardinality - ~purity:spec.purity - in - let* final_db = - Ops.create_tuple storage new_db fp_rel fp_tuple - |> map_rel_error - |> Result.map (fun (db, _, _) -> db) - in - Ok (Sublanguage_types.Transition final_db) + let _execute_load_library _ctx _path = + Error (RuntimeError "PRL disabled") - let execute_list_function_predicates db = - require_relation db Prelude.Catalog.function_predicate_rel_name - |> Result.map (fun rel -> Sublanguage_types.Query rel) + let _execute_define_function_predicate _ctx (_spec : Ast.function_predicate) = + let* _ = Ok () in + Error (RuntimeError "PRL disabled") - let execute storage db = function - | Ast.LoadLibrary path -> execute_load_library storage db path - | Ast.DefineFunctionPredicate spec -> - execute_define_function_predicate storage db spec - | Ast.ListFunctionPredicates -> execute_list_function_predicates db + let _execute_list_function_predicates _ctx = + Error (RuntimeError "PRL disabled") end - -module Memory = Make (Management.Physical.Memory) diff --git a/lib/prl/sublanguage.ml b/lib/prl/sublanguage.ml index b23f370..96891a9 100644 --- a/lib/prl/sublanguage.ml +++ b/lib/prl/sublanguage.ml @@ -1,8 +1,7 @@ -module Make (Storage : Management.Physical.S) = struct - module Exec = Executor.Make (Storage) +module Make (NT : Nt.S) = struct + module Exec = Executor.Make (NT) type configuration = unit - type storage = Storage.t type ast = Ast.statement type error = Exec.error @@ -17,5 +16,3 @@ module Make (Storage : Management.Physical.S) = struct let execute = Exec.execute let sexp_of_error = Exec.sexp_of_error end - -module Memory = Make (Management.Physical.Memory) diff --git a/lib/qualified_name.ml b/lib/qualified_name.ml index 2155f7d..47134c8 100644 --- a/lib/qualified_name.ml +++ b/lib/qualified_name.ml @@ -1,27 +1,32 @@ -(** Fully qualified relation name: [multigroup:schema:relation]. +(** Fully qualified relation reference: [mg:rel_name]. - Splits on [:], fills defaults for missing parts. - - ["relation"] -> { multigroup=""; schema="public"; relation } - - ["schema:relation"] -> { multigroup=""; schema; relation } - - ["mg:schema:relation"] -> { multigroup=mg; schema; relation } -*) + The first colon separates the multigroup name from the relation name; any + further colons are part of the relation name verbatim. -type t = { multigroup : string; schema : string; relation : string } + Examples: + - ["warehouse:orders"] -> mg=["warehouse"], name=["orders"] + - ["warehouse:public:orders"] -> mg=["warehouse"], name=["public:orders"] + - ["sakura:public:relation"] -> mg=["sakura"], name=["public:relation"] -let default_schema = "public" + A reference with no leading [:] segment is a parse error — callers must + supply the mg explicitly. *) -let parse s = - match String.split_on_char ':' s with - | [ rel ] -> { multigroup = ""; schema = default_schema; relation = rel } - | [ schema; rel ] -> { multigroup = ""; schema; relation = rel } - | [ mg; schema; rel ] -> { multigroup = mg; schema; relation = rel } - | _ -> { multigroup = ""; schema = default_schema; relation = s } +type t = { mg : string; name : string } -let make ?(multigroup = "") ?(schema = default_schema) relation = - { multigroup; schema; relation } +exception Unqualified of string -let to_string { multigroup; schema; relation } = - if multigroup = "" then schema ^ ":" ^ relation - else multigroup ^ ":" ^ schema ^ ":" ^ relation +let parse (s : string) : t = + match String.index_opt s ':' with + | None -> raise (Unqualified s) + | Some i -> + let mg = String.sub s 0 i in + let name = String.sub s (i + 1) (String.length s - i - 1) in + if mg = "" || name = "" then raise (Unqualified s) + else { mg; name } -let to_key { schema; relation; _ } = schema ^ ":" ^ relation +let try_parse (s : string) : (t, string) result = + try Ok (parse s) with Unqualified s -> Error s + +let make ~mg ~name = { mg; name } + +let to_string { mg; name } = mg ^ ":" ^ name diff --git a/lib/qualified_name.mli b/lib/qualified_name.mli index 5da7555..196dfbd 100644 --- a/lib/qualified_name.mli +++ b/lib/qualified_name.mli @@ -1,20 +1,18 @@ -(** Fully qualified relation name: [multigroup:schema:relation]. +(** Fully qualified relation reference: [mg:rel_name]. - Unqualified names fill in defaults: empty multigroup, ["public"] schema. *) + The first colon separates the multigroup name from the relation name; any + further colons are part of the relation name verbatim. *) -type t = { multigroup : string; schema : string; relation : string } +type t = { mg : string; name : string } -val default_schema : string +exception Unqualified of string val parse : string -> t -(** Split on [:] with default filling. - - ["rel"] -> multigroup="", schema="public", relation="rel" - - ["s:rel"] -> multigroup="", schema="s", relation="rel" - - ["mg:s:rel"] -> multigroup="mg", schema="s", relation="rel" *) +(** Splits on the first [:]. Raises [Unqualified] when no mg segment is + present (i.e. no colon, or empty mg / empty name). *) -val make : ?multigroup:string -> ?schema:string -> string -> t -val to_string : t -> string +val try_parse : string -> (t, string) result + +val make : mg:string -> name:string -> t -val to_key : t -> string -(** Composite key for [RelationMap] lookup within a single database: - ["schema:relation"]. *) +val to_string : t -> string diff --git a/lib/relation.ml b/lib/relation.ml index 670c227..bba70b3 100644 --- a/lib/relation.ml +++ b/lib/relation.ml @@ -76,14 +76,10 @@ class stored ~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) + object 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 @@ -96,7 +92,7 @@ class stored method name = name method kind = `Stored - method hash = hash + method hash = Option.value tree_pointer ~default:"" method schema = schema method tree_pointer = tree_pointer method constraints = constraints @@ -106,19 +102,13 @@ class stored 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_tree_pointer tp = {< tree_pointer = tp; timestamp = Unix.gettimeofday () >} method set_cardinality c = {< cardinality = c >} method set_constraints c = {< constraints = c >} - method serialize () = { Storable.Relation.name = name; schema } + method serialize () = + { Storable.Relation.name; + schema; + tree_pointer = Option.value tree_pointer ~default:"" } end class ephemeral diff --git a/lib/scl/executor.ml b/lib/scl/executor.ml index 7532eaa..6848091 100644 --- a/lib/scl/executor.ml +++ b/lib/scl/executor.ml @@ -6,11 +6,12 @@ type cursor_batch = { has_more : bool; } -type exec_result = Batch of cursor_batch | Closed of Management.Multigroup.multigroup +type exec_result = + | Batch of cursor_batch + | Closed of Sublanguage_types.transition_delta -module Make (Storage : Management.Physical.S) = struct - module DrlExec = Drl.Executor.Make (Storage) - module Alg = Algebra.Make (Storage) +module Make (NT : Nt.S) = struct + module DrlExec = Drl.Executor.Make (NT) type error = | ParseError of string @@ -26,8 +27,8 @@ module Make (Storage : Management.Physical.S) = struct let ( let* ) = Result.bind - let execute (_storage : Storage.t) (db : Management.Multigroup.multigroup) - (stmt : Ast.statement) : (exec_result, error) result = + let execute (ctx : Sublanguage_context.t) (stmt : Ast.statement) : + (exec_result, error) result = ignore default_batch; match stmt with | Ast.Begin _ -> @@ -36,7 +37,7 @@ module Make (Storage : Management.Physical.S) = struct Error (CursorError "cursors not yet implemented") | Ast.Close _ -> let* () = Ok () in - Ok (Closed db) + Ok (Closed ctx.branch#multigroups) end -module Memory = Make (Management.Physical.Memory) +module Memory = Make (Nt.Memory) diff --git a/lib/scl/sublanguage.ml b/lib/scl/sublanguage.ml index 722ba08..87e4d42 100644 --- a/lib/scl/sublanguage.ml +++ b/lib/scl/sublanguage.ml @@ -1,8 +1,7 @@ -module Make (Storage : Management.Physical.S) = struct - module Exec = Executor.Make (Storage) +module Make (NT : Nt.S) = struct + module Exec = Executor.Make (NT) type configuration = unit - type storage = Storage.t type ast = Ast.statement type error = Exec.error @@ -14,14 +13,12 @@ module Make (Storage : Management.Physical.S) = struct | Ok r -> Ok r | Error (Parser.ParseError s) -> Error (Exec.ParseError s) - let execute storage db ast = - Exec.execute storage db ast + let execute ctx ast = + Exec.execute ctx ast |> Result.map (function - | Executor.Batch { cursor_id; rows; has_more } -> - Sublanguage_types.Cursor { cursor_id; rows; has_more } - | Executor.Closed db -> Sublanguage_types.Transition db) + | Executor.Batch { cursor_id; rows; has_more } -> + Sublanguage_types.Cursor { cursor_id; rows; has_more } + | Executor.Closed delta -> Sublanguage_types.Transition delta) let sexp_of_error = Exec.sexp_of_error end - -module Memory = Make (Management.Physical.Memory) diff --git a/lib/session.ml b/lib/session.ml new file mode 100644 index 0000000..5505e7e --- /dev/null +++ b/lib/session.ml @@ -0,0 +1,49 @@ +(* Session: outermost connection object. + Each user connection mints a session registered in RNT at + /system/sessions/. The session owns exactly one branch at a time; + DDL / DML / DRL sublanguages operate through that branch. *) + +module Make (NT : Nt.S) = struct + + module B = Branch.Make (NT) + + let ( let* ) = Result.bind + + class session + ~(sid : string) + ~(branch : B.branch) = + object + val mutable br : B.branch = branch + + method id = sid + method branch = br + method snapshot = br#tip + method tip = br#tip + + (* Switch to a different branch within the same session. *) + method set_branch (b : B.branch) = br <- b + + method close () = + let* () = br#close () in + NT.session_close sid + end + + (* Open a session on a live (mutable) branch. + Creates the branch if it does not exist yet. *) + let open_session claims ~branch_name = + let* sid = NT.session_open () in + let* branch = B.open_branch claims branch_name in + Ok (new session ~sid ~branch) + + (* Open a session pinned to a specific snapshot hash (detached / read-only). + Mutations through the returned branch are refused. *) + let open_snapshot_session claims ~branch_name ~snapshot_hash = + let* sid = NT.session_open () in + let* branch = B.open_snapshot claims ~branch_name ~snapshot_hash in + (* Inform RNT of the session's snapshot override so future session-path + resolution (once NamespaceReferenceManager handles /system/sessions/...) + can route queries through the pinned snapshot. *) + let* () = NT.session_set_branch sid branch_name snapshot_hash in + Ok (new session ~sid ~branch) + +end diff --git a/lib/storable.ml b/lib/storable.ml index 5d87846..5527044 100644 --- a/lib/storable.ml +++ b/lib/storable.ml @@ -63,11 +63,17 @@ module Tuple = struct end module Relation = struct - type t = { name : string; schema : (string * string) list } + type t = { + name : string; + schema : (string * string) list; + (** Hex Merkle root of the relation's tuple set. Empty string = empty relation. *) + tree_pointer : string; + } let to_bytes relation = Wire.encode - ([ ("type", "relation"); ("name", relation.name); ("kind", "stored") ] + ([ ("type", "relation"); ("name", relation.name); ("kind", "stored"); + ("tree_pointer", relation.tree_pointer) ] @ List.map (fun (name, domain) -> ("attribute", name ^ ":" ^ domain)) relation.schema) @@ -76,31 +82,43 @@ module Relation = struct 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); + name = Wire.required "name" fields; + schema = List.map Wire.attribute (Wire.values "attribute" fields); + tree_pointer = Option.value (List.assoc_opt "tree_pointer" fields) ~default:""; } end module Multigroup = struct type t = { name : string; relations : Relation.t list } + (* Wire format: "name|attr1:dom1,attr2:dom2|" + The third segment is the Merkle root hex; empty string = empty relation. + A fourth segment for constraints is reserved but not yet implemented. + TODO: add constraints serialisation once a canonical sexp representation + is agreed upon (two syntactically distinct bodies may be semantically + equivalent — the round-trip must account for that). *) let relation_value relation = let attrs = relation.Relation.schema |> List.map (fun (name, domain) -> name ^ ":" ^ domain) |> String.concat "," in - relation.name ^ "|" ^ attrs + relation.name ^ "|" ^ attrs ^ "|" ^ relation.tree_pointer let parse_relation value = match Wire.split_once '|' value with - | None -> { Relation.name = value; schema = [] } - | Some (name, attrs) -> + | None -> { Relation.name = value; schema = []; tree_pointer = "" } + | Some (name, rest) -> + let attrs_str, tree_pointer = + match Wire.split_once '|' rest with + | None -> (rest, "") + | Some (a, tp) -> (a, tp) + in let schema = - if attrs = "" then [] - else attrs |> String.split_on_char ',' |> List.map Wire.attribute + if attrs_str = "" then [] + else attrs_str |> String.split_on_char ',' |> List.map Wire.attribute in - { Relation.name; schema } + { Relation.name; schema; tree_pointer } let to_bytes multigroup = Wire.encode diff --git a/lib/sublanguage.ml b/lib/sublanguage.ml index cf3d501..e8e511c 100644 --- a/lib/sublanguage.ml +++ b/lib/sublanguage.ml @@ -19,15 +19,13 @@ include Sublanguage_types module type S = sig include Configuration.CONFIGURABLE - type storage type ast type error val name : string val parse_sexp : Sexplib.Sexp.t -> (ast, error) Result.t - val execute : - storage -> Management.Multigroup.multigroup -> ast -> (result, error) Result.t + val execute : Sublanguage_context.t -> ast -> (result, error) Result.t val sexp_of_error : error -> Sexplib.Sexp.t end diff --git a/lib/sublanguage_context.ml b/lib/sublanguage_context.ml new file mode 100644 index 0000000..c7598f1 --- /dev/null +++ b/lib/sublanguage_context.ml @@ -0,0 +1,39 @@ +(** Execution context passed to every sublanguage. + + - [write_handle] NT branch handle; sublanguages use it for mutations + (create_relation, link_tuple, etc). Read-only + sublanguages (DRL) ignore it. + + - [branch] Structural view over the active branch — gives every + executor random-access to every multigroup bound to + the branch via [mg_of]. Schema lookups for an FQN + [{mg; name}] use [branch#mg_of mg |> Option.bind + (fun m -> m#get_relation name)]. + + - [resolve] Builds an absolute RNT path for an FQN. Pass + [~branch:b] to address a relation on a different + live branch (cross-multigroup reads). + + - [switch_branch] Closes the current branch and opens the named one, + returning the delta describing the new branch's mg + set. Provided by the listener so VCL does not need + direct access to session state. *) + +type branch_view = < + name : string; + tip : string; + mg_of : string -> Management.Multigroup.multigroup option; + multigroups : (string * Management.Multigroup.multigroup) list; + add_multigroup : name:string -> unit; + set_mg : name:string -> + Management.Multigroup.multigroup -> unit; + path : ?branch:string -> Qualified_name.t -> string; +> + +type t = { + write_handle : Nt.branch_handle; + branch : branch_view; + resolve : ?branch:string -> Qualified_name.t -> string; + switch_branch : string -> + (Sublanguage_types.transition_delta, Nt.error) result; +} diff --git a/lib/sublanguage_types.ml b/lib/sublanguage_types.ml index 743cb7f..3d2b5cc 100644 --- a/lib/sublanguage_types.ml +++ b/lib/sublanguage_types.ml @@ -4,9 +4,14 @@ type cursor_result = { has_more : bool; } +(** A Transition delta names every multigroup that the statement touched and + the updated value for each. Most statements yield a single-element list; + VCL/SCL/ICL statements may touch more than one. *) +type transition_delta = (string * Management.Multigroup.multigroup) list + type result = | Query of Relation.relation - | Transition of Management.Multigroup.multigroup + | Transition of transition_delta | Cursor of cursor_result | SessionSwitch of string | CreateMultigroup of string diff --git a/lib/system.ml b/lib/system.ml index 4c4e4b5..bad6c3b 100644 --- a/lib/system.ml +++ b/lib/system.ml @@ -1,36 +1,40 @@ -(** System assembly: registry-based configuration dispatch. This module is the - composition root. It owns the mapping from configuration tags to concrete - implemenations and assembles a server from a configuration file. *) +(** System assembly: registry-based configuration dispatch. + This module is the composition root. It owns the mapping from configuration + tags to concrete implementations and assembles a server from a config file. *) -type storage_parcel = - | StorageParcel : - (module Management.Physical.S with type t = 't and type error = string) - * 't - -> storage_parcel +type nt_parcel = NtParcel : (module Nt.S) -> nt_parcel type transport_parcel = | TransportParcel : (module Transport.TRANSPORT with type t = 't) * 't -> transport_parcel -type storage_provider = Sexplib.Sexp.t -> (storage_parcel, string) result +type nt_provider = Sexplib.Sexp.t -> (nt_parcel, string) result type transport_provider = Sexplib.Sexp.t -> (transport_parcel, string) result type registry = { - storage : storage_provider Utilities.StringMap.t; + nt : nt_provider Utilities.StringMap.t; transport : transport_provider Utilities.StringMap.t; } let registry : registry = let open Utilities.StringMap in { - storage = + nt = empty - |> add "memory" (fun sexp -> - let ( let* ) = Result.bind in - let* config = Management.Physical.MemoryBackend.parse sexp in - let* storage = Management.Physical.Memory.create config in - Ok (StorageParcel ((module Management.Physical.Memory), storage))); + |> add "memory" (fun _sexp -> + Ok (NtParcel (module Nt.Memory : Nt.S))) + |> add "sqlite" (fun sexp -> + (* Accept (sqlite) for :memory: or (sqlite "/path/to/db") for a file. *) + let path = match sexp with + | Sexplib.Sexp.(List [ Atom p ]) -> p + | _ -> ":memory:" + in + let module M = Nt.Make (struct + let driver = "sqlite" + let init_arg = path + end) in + Ok (NtParcel (module M : Nt.S))); transport = empty |> add "tcp" (fun sexp -> @@ -42,17 +46,17 @@ let registry : registry = let assemble (config : Configuration.t) : (unit -> unit, string) result = let open Utilities.Result in - let* storage_tag, storage_body = - Configuration.require_section ~name:"storage" - ~valid_tags:(Utilities.StringMap.bindings registry.storage |> List.map fst) + let* nt_tag, nt_body = + Configuration.require_section ~name:"nt" + ~valid_tags:(Utilities.StringMap.bindings registry.nt |> List.map fst) config in - let* storage_provider = - Utilities.StringMap.find_opt storage_tag registry.storage + let* nt_provider = + Utilities.StringMap.find_opt nt_tag registry.nt |> Option.to_result - ~none:(Printf.sprintf "Unknown storage backend: %s" storage_tag) + ~none:(Printf.sprintf "Unknown NT backend: %s" nt_tag) in - let* packed_storage = storage_provider storage_body in + let* packed_nt = nt_provider nt_body in let* transport_tag, transport_body = Configuration.require_section ~name:"transport" ~valid_tags: @@ -65,14 +69,15 @@ let assemble (config : Configuration.t) : (unit -> unit, string) result = ~none:(Printf.sprintf "Unknown transport backend: %s" transport_tag) in let* packed_transport = transport_provider transport_body in - let (StorageParcel ((module S), storage)) = packed_storage in + let (NtParcel (module NT)) = packed_nt in let (TransportParcel ((module T), transport)) = packed_transport in - let module L = Listener.Make (T) (S) in - Ok (fun () -> L.run transport storage) + let* () = NT.initialize () |> Result.map_error Nt.string_of_error in + let module L = Listener.Make (T) (NT) in + Ok (fun () -> L.run transport) let run_from_config (path : string) : (unit -> unit, string) result = let ( let* ) = Result.bind in let* config = - Configuration.load ~expected_keys:[ "storage"; "transport" ] path + Configuration.load ~expected_keys:[ "nt"; "transport" ] path in assemble config diff --git a/lib/utilities.ml b/lib/utilities.ml index 34b0eb1..7b77da9 100644 --- a/lib/utilities.ml +++ b/lib/utilities.ml @@ -3,8 +3,22 @@ module StringSet = Set.Make (String) module Result = struct let ( let* ) = Result.bind + let fmap f m = Result.bind m f end module Option = struct let ( let* ) = Option.bind end + +let print_with_time str = + 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 diff --git a/lib/vcl/ast.ml b/lib/vcl/ast.ml new file mode 100644 index 0000000..ef573c0 --- /dev/null +++ b/lib/vcl/ast.ml @@ -0,0 +1 @@ +type statement = Use of string diff --git a/lib/vcl/executor.ml b/lib/vcl/executor.ml new file mode 100644 index 0000000..5f3dd49 --- /dev/null +++ b/lib/vcl/executor.ml @@ -0,0 +1,21 @@ +module Make (NT : Nt.S) = struct + type error = + | ParseError of string + | NtError of Nt.error + + let sexp_of_error e = + let open Sexplib.Sexp in + match e with + | ParseError s -> List [ Atom "parse-error"; Atom s ] + | NtError e -> List [ Atom "nt-error"; Atom (Nt.string_of_error e) ] + + let execute (ctx : Sublanguage_context.t) (stmt : Ast.statement) : + (Sublanguage_types.result, error) result = + match stmt with + | Ast.Use branch_name -> + match ctx.switch_branch branch_name with + | Ok delta -> Ok (Sublanguage_types.Transition delta) + | Error e -> Error (NtError e) + + let _ = (module NT : Nt.S) +end diff --git a/lib/vcl/sublanguage.ml b/lib/vcl/sublanguage.ml new file mode 100644 index 0000000..f9ca629 --- /dev/null +++ b/lib/vcl/sublanguage.ml @@ -0,0 +1,19 @@ +module Make (NT : Nt.S) = struct + module Exec = Executor.Make (NT) + + type configuration = unit + type ast = Ast.statement + type error = Exec.error + + let name = "vcl" + let parse _ = Ok () + + let parse_sexp = function + | Sexplib.Sexp.(List [ Atom "use"; Atom branch ]) -> Ok (Ast.Use branch) + | sexp -> + Error (Exec.ParseError ("unrecognized vcl command: " ^ Sexplib.Sexp.to_string sexp)) + + let execute = Exec.execute + + let sexp_of_error = Exec.sexp_of_error +end -- cgit v1.2.3