aboutsummaryrefslogtreecommitdiffstats
path: root/lib
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--lib/catalog.ml152
-rw-r--r--lib/dcl/ast.ml2
-rw-r--r--lib/dcl/executor.ml161
-rw-r--r--lib/dcl/sublanguage.ml4
-rw-r--r--lib/dml/executor.ml16
-rw-r--r--lib/error.ml2
-rw-r--r--lib/listener.ml267
-rw-r--r--lib/management/branch.ml4
-rw-r--r--lib/management/database.ml3
-rw-r--r--lib/manipulation.ml78
-rw-r--r--lib/prelude/catalog.ml44
-rw-r--r--lib/prelude/standard.ml12
-rw-r--r--lib/qualified_name.ml31
-rw-r--r--lib/qualified_name.mli24
-rw-r--r--lib/sublanguage_types.ml2
-rw-r--r--lib/system.ml37
16 files changed, 603 insertions, 236 deletions
diff --git a/lib/catalog.ml b/lib/catalog.ml
new file mode 100644
index 0000000..be54375
--- /dev/null
+++ b/lib/catalog.ml
@@ -0,0 +1,152 @@
+(** Multi-multigroup catalog.
+
+ Each multigroup gets its own [Atomic.t], so mutations to independent
+ multigroups never contend. The [sakura] multigroup is auto-bootstrapped,
+ undeletable, and self-referential: it carries a [public:multigroup]
+ relation listing every registered multigroup. *)
+
+type t = {
+ multigroups : Management.Database.t Atomic.t Utilities.StringMap.t Atomic.t;
+ default_multigroup : string;
+ mutex : Mutex.t;
+}
+
+let sakura_name = "sakura"
+
+module Make (S : Management.Physical.S with type error = string) = struct
+ open Utilities.Result
+ module Manip = Manipulation.Make (S)
+
+ type nonrec t = t
+
+ let map_error r = Result.map_error
+ (fun e -> Sexplib.Sexp.to_string (Error.sexp_of_error e)) r
+
+ let get catalog name =
+ Utilities.StringMap.find_opt name (Atomic.get catalog.multigroups)
+
+ let list catalog =
+ Utilities.StringMap.bindings (Atomic.get catalog.multigroups)
+ |> List.map fst
+
+ let publish_multigroups catalog ~expected ~updated =
+ if Atomic.compare_and_set catalog.multigroups expected updated then Ok ()
+ else Error "Concurrent multigroup map update detected"
+
+ (** Swallow errors: a missing prelude relation is non-fatal. *)
+ let register_prelude_relation storage db (rel : Relation.t) =
+ match
+ Manip.create_immutable_relation storage db ~name:rel.name
+ ~schema:rel.schema ~generator:(Option.get rel.generator)
+ ~membership_criteria:rel.membership_criteria
+ ~cardinality:rel.cardinality
+ with
+ | Ok (new_db, _) -> new_db
+ | Error e ->
+ Printf.eprintf "Warning: prelude relation %s: %s\n%!"
+ rel.name (Sexplib.Sexp.to_string (Error.sexp_of_error e));
+ db
+
+ (** Create DB + seed catalog + fold in [prelude_relations]. *)
+ let bootstrap_multigroup storage ~prelude_relations ~name =
+ let* db = Manip.create_database storage ~name |> map_error in
+ Ok (List.fold_left (register_prelude_relation storage) db prelude_relations)
+
+ (** Create additional catalog relations beyond the base six.
+ Used to seed [public:multigroup] into the sakura multigroup only. *)
+ let seed_extra_catalog storage ~definitions db =
+ List.fold_left
+ (fun acc (name, schema) ->
+ let* db = acc in
+ let* new_db, _ =
+ Manip.create_relation storage db ~name ~schema |> map_error
+ in
+ Ok new_db)
+ (Ok db) definitions
+
+ (** Write a tuple into sakura's [public:multigroup] and update the ref.
+ No-op if the relation doesn't exist yet (bootstrap ordering). *)
+ let register_in_sakura storage sakura_ref mg_name =
+ let rec go () =
+ let sakura = Atomic.get sakura_ref in
+ match
+ Management.Database.get_relation sakura Prelude.Catalog.multigroup_rel_name
+ with
+ | None -> Ok ()
+ | Some mg_rel ->
+ let tuple = Prelude.Catalog.build_multigroup_tuple mg_name in
+ let* new_sakura, _, _ =
+ Manip.create_tuple storage sakura mg_rel tuple |> map_error
+ in
+ if Atomic.compare_and_set sakura_ref sakura new_sakura then Ok ()
+ else go ()
+ in
+ go ()
+
+ let create storage ~prelude_relations =
+ let* sakura_db =
+ bootstrap_multigroup storage ~prelude_relations ~name:sakura_name
+ in
+ let* sakura_db =
+ seed_extra_catalog storage
+ ~definitions:Prelude.Catalog.sakura_only_definitions sakura_db
+ in
+ let sakura_ref = Atomic.make sakura_db in
+ let* () = register_in_sakura storage sakura_ref sakura_name in
+ let map = Utilities.StringMap.singleton sakura_name sakura_ref in
+ Ok { multigroups = Atomic.make map; default_multigroup = sakura_name; mutex = Mutex.create () }
+
+ let add catalog storage ~prelude_relations name =
+ Mutex.protect catalog.mutex (fun () ->
+ let map = Atomic.get catalog.multigroups in
+ if Utilities.StringMap.mem name map then
+ Error (Printf.sprintf "Multigroup %s already exists" name)
+ else
+ let* db = bootstrap_multigroup storage ~prelude_relations ~name in
+ let db_ref = Atomic.make db in
+ let* () =
+ match Utilities.StringMap.find_opt sakura_name map with
+ | Some sakura_ref -> register_in_sakura storage sakura_ref name
+ | None -> Ok ()
+ in
+ let new_map = Utilities.StringMap.add name db_ref map in
+ let* () = publish_multigroups catalog ~expected:map ~updated:new_map in
+ Ok db_ref)
+
+ let unregister_from_sakura storage sakura_ref mg_name =
+ let rec go () =
+ let sakura = Atomic.get sakura_ref in
+ match Management.Database.get_relation sakura Prelude.Catalog.multigroup_rel_name with
+ | None -> Ok ()
+ | Some mg_rel ->
+ let tuple_hash =
+ Hashing.hash_tuple (Prelude.Catalog.build_multigroup_tuple mg_name)
+ in
+ let* new_sakura, _ =
+ Manip.retract_tuple storage sakura mg_rel ~tuple_hash |> map_error
+ in
+ if Atomic.compare_and_set sakura_ref sakura new_sakura then Ok ()
+ else go ()
+ in
+ go ()
+
+ let remove catalog storage name =
+ if name = sakura_name then
+ Error "Cannot remove the sakura system catalog"
+ else
+ Mutex.protect catalog.mutex (fun () ->
+ let map = Atomic.get catalog.multigroups in
+ if not (Utilities.StringMap.mem name map) then
+ Error (Printf.sprintf "Multigroup %s does not exist" name)
+ else
+ let* () =
+ match Utilities.StringMap.find_opt sakura_name map with
+ | None -> Ok ()
+ | Some sakura_ref -> unregister_from_sakura storage sakura_ref name
+ in
+ let new_map = Utilities.StringMap.remove name map in
+ let* () =
+ publish_multigroups catalog ~expected:map ~updated:new_map
+ in
+ Ok ())
+end
diff --git a/lib/dcl/ast.ml b/lib/dcl/ast.ml
index 0b6107f..a55ec19 100644
--- a/lib/dcl/ast.ml
+++ b/lib/dcl/ast.ml
@@ -10,4 +10,6 @@ type statement =
| GetBranchTip of string
| UpdateBranchTip of { name : string; hash : string }
| Merge of { left : string; right : string; strategy : merge_strategy }
+ | Use of string
+ | CreateMultigroup of string
[@@deriving sexp]
diff --git a/lib/dcl/executor.ml b/lib/dcl/executor.ml
index a651067..b83f629 100644
--- a/lib/dcl/executor.ml
+++ b/lib/dcl/executor.ml
@@ -4,24 +4,24 @@ module Make (Storage : Management.Physical.S with type error = string) = struct
module MergeOps = Management.Merge.Make (Storage) (Ops)
type error =
- | ParseError of string
- | BranchError of Error.t
- | BranchNotFound of string
+ | ParseError of string
+ | BranchError of Error.t
+ | BranchNotFound of string
| NoDatabaseAtHash of Conventions.Hash.t
- | StorageError of string
- | MergeError of Error.t
- | Conflict of string
+ | StorageError of string
+ | MergeError of Error.t
+ | Conflict of string
let sexp_of_error e =
let open Sexplib.Sexp in
match e with
- | ParseError s -> List [Atom "parse-error"; Atom s]
- | BranchError s -> List [Atom "branch-error"; Error.sexp_of_error s]
- | BranchNotFound s -> List [Atom "branch-not-found"; Atom s]
- | NoDatabaseAtHash s -> List [Atom "no-database-at-hash"; Atom s]
- | StorageError s -> List [Atom "storage-error"; Atom s]
- | MergeError s -> List [Atom "merge-error"; Error.sexp_of_error s]
- | Conflict s -> List [Atom "conflict"; Atom s]
+ | ParseError s -> List [ Atom "parse-error"; Atom s ]
+ | BranchError s -> List [ Atom "branch-error"; Error.sexp_of_error s ]
+ | BranchNotFound s -> List [ Atom "branch-not-found"; Atom s ]
+ | NoDatabaseAtHash s -> List [ Atom "no-database-at-hash"; Atom s ]
+ | StorageError s -> List [ Atom "storage-error"; Atom s ]
+ | MergeError s -> List [ Atom "merge-error"; Error.sexp_of_error s ]
+ | Conflict s -> List [ Atom "conflict"; Atom s ]
let convert_strategy : Ast.merge_strategy -> Management.Merge.strategy =
function
@@ -29,71 +29,80 @@ module Make (Storage : Management.Physical.S with type error = string) = struct
| Ast.PreferRight -> Management.Merge.PreferRight
| Ast.RevertToAncestor -> Management.Merge.RevertToAncestor
+ type exec_result =
+ | DbResult of Management.Database.t * string
+ | Switch of string
+ | NewMultigroup of string
+
let execute (storage : Storage.t) (db : Management.Database.t)
- (stmt : Ast.statement) : (Management.Database.t * string, error) result =
+ (stmt : Ast.statement) : (exec_result, error) result =
match stmt with
- | Ast.CreateBranch { name; hash } ->
- let tip = match hash with
- | Some h -> h
- | None -> db.Management.Database.hash
- in
- (match Branch.create storage ~name ~tip with
- | Error e -> Error (StorageError e)
- | Ok () -> Ok (db, "Branch " ^ name ^ " created"))
-
- | Ast.Checkout branch_name ->
- (match Branch.get_tip storage branch_name with
- | Error e -> Error (StorageError e)
- | Ok None -> Error (BranchNotFound branch_name)
- | Ok (Some tip) ->
- (match Branch.checkout storage branch_name with
- | Error e -> Error (StorageError e)
- | Ok () ->
- (match Ops.load_database storage tip with
- | Error e -> Error (BranchError e)
- | Ok None -> Error (NoDatabaseAtHash tip)
- | Ok (Some loaded_db) ->
- Ok (loaded_db, "HEAD:" ^ branch_name))))
-
- | Ast.GetHead ->
- (match Branch.get_head storage with
- | Error e -> Error (StorageError e)
- | Ok None -> Ok (db, "HEAD is unset")
- | Ok (Some name) -> Ok (db, "HEAD:" ^ name))
-
- | Ast.GetBranchTip name ->
- (match Branch.get_tip storage name with
- | Error e -> Error (StorageError e)
- | Ok None -> Error (BranchNotFound name)
- | Ok (Some hash) -> Ok (db, "branch:" ^ name ^ "=" ^ hash))
-
- | Ast.UpdateBranchTip { name; hash } ->
- (match Branch.update_tip storage ~name ~tip:hash with
- | Error e -> Error (StorageError e)
- | Ok () -> Ok (db, "Branch " ^ name ^ " updated"))
-
- | Ast.Merge { left; right; strategy } ->
- (match Branch.get_tip storage left, Branch.get_tip storage right with
- | Error e, _ | _, Error e -> Error (StorageError e)
- | Ok None, _ -> Error (BranchNotFound left)
- | _, Ok None -> Error (BranchNotFound right)
- | Ok (Some left_tip), Ok (Some right_tip) ->
- let strat = convert_strategy strategy in
- (match MergeOps.merge ~storage ~strategy:strat ~left_tip ~right_tip with
- | Error e -> Error (MergeError e)
- | Ok (Management.Merge.Failed conflicts) ->
- let msgs = List.map (function
- | Management.Merge.TupleConflict { relation; hash } ->
- "tuple conflict in " ^ relation ^ " (" ^ hash ^ ")"
- | Management.Merge.SchemaConflict r -> "schema conflict in " ^ r
- | Management.Merge.ConstraintConflict r -> "constraint conflict in " ^ r
- ) conflicts in
- Error (Conflict ("Merge failed: " ^ String.concat "; " msgs))
- | Ok (Management.Merge.Clean merged_db) ->
- let _ = Branch.update_tip storage ~name:left
- ~tip:merged_db.Management.Database.hash in
- Ok (merged_db,
- "Merged:" ^ right ^ "→" ^ left)))
+ | Ast.CreateBranch { name; hash } -> (
+ let tip =
+ match hash with Some h -> h | None -> db.Management.Database.hash
+ in
+ match Branch.create storage ~name ~tip with
+ | Error e -> Error (StorageError e)
+ | Ok () -> Ok (DbResult (db, "Branch " ^ name ^ " created")))
+ | Ast.Checkout branch_name -> (
+ match Branch.get_tip storage branch_name with
+ | Error e -> Error (StorageError e)
+ | Ok None -> Error (BranchNotFound branch_name)
+ | Ok (Some tip) -> (
+ match Branch.checkout storage branch_name with
+ | Error e -> Error (StorageError e)
+ | Ok () -> (
+ match Ops.load_database storage tip with
+ | Error e -> Error (BranchError e)
+ | Ok None -> Error (NoDatabaseAtHash tip)
+ | Ok (Some loaded_db) ->
+ Ok (DbResult (loaded_db, "HEAD:" ^ branch_name)))))
+ | Ast.GetHead -> (
+ match Branch.get_head storage with
+ | Error e -> Error (StorageError e)
+ | Ok None -> Ok (DbResult (db, "HEAD is unset"))
+ | Ok (Some name) -> Ok (DbResult (db, "HEAD:" ^ name)))
+ | Ast.GetBranchTip name -> (
+ match Branch.get_tip storage name with
+ | Error e -> Error (StorageError e)
+ | Ok None -> Error (BranchNotFound name)
+ | Ok (Some hash) -> Ok (DbResult (db, "branch:" ^ name ^ "=" ^ hash)))
+ | Ast.UpdateBranchTip { name; hash } -> (
+ match Branch.update_tip storage ~name ~tip:hash with
+ | Error e -> Error (StorageError e)
+ | Ok () -> Ok (DbResult (db, "Branch " ^ name ^ " updated")))
+ | Ast.Merge { left; right; strategy } -> (
+ match (Branch.get_tip storage left, Branch.get_tip storage right) with
+ | Error e, _ | _, Error e -> Error (StorageError e)
+ | Ok None, _ -> Error (BranchNotFound left)
+ | _, Ok None -> Error (BranchNotFound right)
+ | Ok (Some left_tip), Ok (Some right_tip) -> (
+ let strat = convert_strategy strategy in
+ match
+ MergeOps.merge ~storage ~strategy:strat ~left_tip ~right_tip
+ with
+ | Error e -> Error (MergeError e)
+ | Ok (Management.Merge.Failed conflicts) ->
+ let msgs =
+ List.map
+ (function
+ | Management.Merge.TupleConflict { relation; hash } ->
+ "tuple conflict in " ^ relation ^ " (" ^ hash ^ ")"
+ | Management.Merge.SchemaConflict r ->
+ "schema conflict in " ^ r
+ | Management.Merge.ConstraintConflict r ->
+ "constraint conflict in " ^ r)
+ conflicts
+ in
+ Error (Conflict ("Merge failed: " ^ String.concat "; " msgs))
+ | Ok (Management.Merge.Clean merged_db) ->
+ let _ =
+ Branch.update_tip storage ~name:left
+ ~tip:merged_db.Management.Database.hash
+ in
+ Ok (DbResult (merged_db, "Merged:" ^ right ^ "→" ^ left))))
+ | Ast.Use multigroup -> Ok (Switch multigroup)
+ | Ast.CreateMultigroup name -> Ok (NewMultigroup name)
end
module Memory = Make (Management.Physical.Memory)
diff --git a/lib/dcl/sublanguage.ml b/lib/dcl/sublanguage.ml
index eab5ecb..7af0703 100644
--- a/lib/dcl/sublanguage.ml
+++ b/lib/dcl/sublanguage.ml
@@ -16,7 +16,9 @@ module Make (Storage : Management.Physical.S with type error = string) = struct
let execute storage db ast =
match Exec.execute storage db ast with
- | Ok (db, msg) -> Ok (Sublanguage_types.Transition (db, msg))
+ | Ok (Exec.DbResult (db, msg)) -> Ok (Sublanguage_types.Transition (db, msg))
+ | Ok (Exec.Switch multigroup) -> Ok (Sublanguage_types.SessionSwitch multigroup)
+ | Ok (Exec.NewMultigroup name) -> Ok (Sublanguage_types.CreateMultigroup name)
| Error e -> Error e
let sexp_of_error = Exec.sexp_of_error
diff --git a/lib/dml/executor.ml b/lib/dml/executor.ml
index 85f9791..e92b0f5 100644
--- a/lib/dml/executor.ml
+++ b/lib/dml/executor.ml
@@ -58,19 +58,21 @@ module Make (Storage : Management.Physical.S) = struct
match stmt with
| Ast.InsertTuple { relation; attributes } ->
let* rel = get_rel db relation in
- let tuple = build_tuple ~relation attributes in
+ let tuple = build_tuple ~relation:rel.Relation.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) tuples in
+ let tuple_list =
+ List.map (build_tuple ~relation:rel.Relation.name) tuples
+ in
let* db, _, _ =
Ops.create_tuples storage db rel tuple_list |> wrap_manip
in
Ok db
| Ast.DeleteTuple { relation; attributes } ->
let* rel = get_rel db relation in
- let tuple = build_tuple ~relation attributes in
+ let tuple = build_tuple ~relation:rel.Relation.name attributes in
let tuple_hash = Hashing.hash_tuple tuple in
let* db, _ =
Ops.retract_tuple storage db rel ~tuple_hash |> wrap_manip
@@ -82,7 +84,8 @@ module Make (Storage : Management.Physical.S) = struct
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 (List.map (retarget target) tuples)
+ Ops.create_tuples storage db rel
+ (List.map (retarget rel.Relation.name) tuples)
|> wrap_manip
in
Ok db
@@ -91,7 +94,8 @@ module Make (Storage : Management.Physical.S) = struct
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 (List.map (retarget target) tuples)
+ Ops.create_tuples storage db rel
+ (List.map (retarget rel.Relation.name) tuples)
|> wrap_manip
in
Ok db
@@ -118,7 +122,7 @@ module Make (Storage : Management.Physical.S) = struct
(fun acc t ->
let* db = acc in
let* rel = get_rel db target in
- let tuple_hash = Hashing.hash_tuple (retarget target t) in
+ let tuple_hash = Hashing.hash_tuple (retarget rel.Relation.name t) in
let* db, _ =
Ops.retract_tuple storage db rel ~tuple_hash |> wrap_manip
in
diff --git a/lib/error.ml b/lib/error.ml
index edaa85b..09b2e53 100644
--- a/lib/error.ml
+++ b/lib/error.ml
@@ -13,6 +13,7 @@ type t =
| SublanguageError of Sexplib.Sexp.t
| Conflict of { old_db : Management.Database.t; new_db : Management.Database.t}
| SyntaxError of string
+ | MultigroupNotFound of string
let sexp_of_error e =
let open Sexplib.Sexp in
@@ -30,5 +31,6 @@ let sexp_of_error e =
| MalformedExpression s -> error "malformed-expression" ["expression" <+> s]
| SublanguageError s -> error "sublanguage-error" ["error" <+> s]
| SyntaxError s -> error "syntax-error" ["message" <+> (Atom s)]
+ | 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)]
diff --git a/lib/listener.ml b/lib/listener.ml
index d7951aa..c706180 100644
--- a/lib/listener.ml
+++ b/lib/listener.ml
@@ -1,29 +1,40 @@
-module type LISTENER = functor (T : Transport.TRANSPORT)(S : Management.Physical.S with type error = string) -> sig
- val run : T.t -> Management.Database.t -> S.t -> unit
+module type LISTENER = functor
+ (T : Transport.TRANSPORT)
+ (S : Management.Physical.S with type error = string)
+ -> sig
+ val run : T.t -> Catalog.t -> S.t -> unit
end
+type connection_context = { mutable current_multigroup : string }
+
module Make : LISTENER =
- functor (T : Transport.TRANSPORT)(S : Management.Physical.S with type error = string) -> struct
+functor
+ (T : Transport.TRANSPORT)
+ (S : Management.Physical.S with type error = string)
+ ->
+ struct
module type SubS = Sublanguage.S with type storage = S.t
+
module BranchOps = Management.Branch.Make (S)
module AlgebraOps = Algebra.Make (S)
+ module CatalogOps = Catalog.Make (S)
let read_command input =
- try
- Ok (Sexplib.Sexp.input_sexp input)
- with Sexplib.Sexp.Parse_error { err_msg ; _} ->
+ try Ok (Sexplib.Sexp.input_sexp input)
+ with Sexplib.Sexp.Parse_error { err_msg; _ } ->
Error (Error.SyntaxError err_msg)
- let sublanguages = (* should this go here? *)
+ let sublanguages =
List.fold_right
- (fun (module Language : SubS) -> Utilities.StringMap.add Language.name (module Language : SubS))
+ (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 Scl.Sublanguage.Make(S) : 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 Scl.Sublanguage.Make (S) : SubS);
]
Utilities.StringMap.empty
@@ -36,32 +47,46 @@ module Make : LISTENER =
let execute storage db expr (module Language : SubS) =
Language.parse_sexp expr
|> fmap (Language.execute storage db)
- |> Result.map_error (fun e -> Error.SublanguageError (Language.sexp_of_error e))
+ |> Result.map_error (fun e ->
+ Error.SublanguageError (Language.sexp_of_error e))
let execute_command storage db = function
- | Sexplib.Sexp.(List [Atom tag; expr]) ->
- find_language tag
- |> fmap (execute storage db expr)
+ | Sexplib.Sexp.(List [ Atom tag; expr ]) ->
+ find_language tag |> fmap (execute storage db expr)
| s -> Error (Error.MalformedExpression s)
let advance_head_branch storage new_hash =
match BranchOps.get_head storage with
| Ok (Some branch_name) ->
- ignore (BranchOps.update_tip storage ~name:branch_name ~tip:new_hash)
+ ignore (BranchOps.update_tip storage ~name:branch_name ~tip:new_hash)
| _ -> ()
- let perform storage db_head old_db result =
+ let perform storage catalog ctx db_head old_db result =
match result with
| Sublanguage.Transition (new_db, _) ->
- if Atomic.compare_and_set db_head old_db new_db
- then (advance_head_branch storage new_db.hash; Ok result)
- else Error (Error.Conflict { old_db; new_db })
+ if Atomic.compare_and_set db_head old_db new_db then (
+ advance_head_branch storage new_db.hash;
+ Ok result)
+ else Error (Error.Conflict { old_db; new_db })
+ | Sublanguage.SessionSwitch multigroup -> (
+ match CatalogOps.get catalog multigroup with
+ | None -> Error (Error.MultigroupNotFound multigroup)
+ | Some _ ->
+ ctx.current_multigroup <- multigroup;
+ Ok result)
+ | Sublanguage.CreateMultigroup name -> (
+ match
+ CatalogOps.add catalog storage
+ ~prelude_relations:Prelude.Standard.prelude_relations name
+ with
+ | Error e -> Error (Error.SyntaxError e)
+ | Ok _ -> Ok result)
| _ -> Ok result
let get_branch storage =
match BranchOps.get_head storage with Ok (Some name) -> name | _ -> "--"
- let current_limit = 16 (* TODO: make the limit per-connection? *)
+ let current_limit = 16 (* TODO: make the limit per-connection? *)
let materialize_generator gen limit =
let rec go gen pos acc count =
@@ -71,14 +96,14 @@ module Make : LISTENER =
| 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))
+ 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
@@ -88,48 +113,86 @@ module Make : LISTENER =
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 ]))
+ List
+ (Tuple.AttributeMap.bindings t.Tuple.attributes
+ |> List.map (fun (k, attr) ->
+ List
+ [
+ Atom k; Conventions.AbstractValue.sexp_of_t attr.Attribute.value;
+ ]))
(* TODO: does our network protocol make sense? *)
let serialize storage (db : Management.Database.t) =
let open Sexplib.Sexp in
function
- | Error e -> List [ Atom "error"; (Error.sexp_of_error e) ]
+ | Error e -> List [ Atom "error"; Error.sexp_of_error e ]
(* TODO: forsake the global cursor register in favour of per-connection bookkeeping *)
| Ok (Sublanguage.Cursor { cursor_id; rows; has_more }) ->
- 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 ];
- List [ Atom "branch"; Atom (get_branch storage) ] ]
+ 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 ];
+ List [ Atom "branch"; Atom (get_branch storage) ];
+ ]
| Ok (Sublanguage.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.Relation.schema) in
- let rows_sexp = List (List.map tuple_to_sexp tuples) in
- List [ Atom "relation";
- List [ Atom "name"; Atom rel.Relation.name ];
- List [ Atom "schema"; schema_sexp ];
- List [ Atom "rows"; rows_sexp ];
- List [ Atom "row_count"; Atom (string_of_int (List.length tuples)) ];
- List [ Atom "truncated"; Atom (string_of_bool truncated) ];
- List [ Atom "db_hash"; Atom db.hash ];
- List [ Atom "db_name"; Atom db.name ];
- List [ Atom "branch"; Atom (get_branch storage) ] ]
+ 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.Relation.schema)
+ in
+ let rows_sexp = List (List.map tuple_to_sexp tuples) in
+ List
+ [
+ Atom "relation";
+ List [ Atom "name"; Atom rel.Relation.name ];
+ List [ Atom "schema"; schema_sexp ];
+ List [ Atom "rows"; rows_sexp ];
+ List
+ [ Atom "row_count"; Atom (string_of_int (List.length tuples)) ];
+ List [ Atom "truncated"; Atom (string_of_bool truncated) ];
+ List [ Atom "db_hash"; Atom db.hash ];
+ List [ Atom "db_name"; Atom db.name ];
+ List [ Atom "branch"; Atom (get_branch storage) ];
+ ]
| Ok (Sublanguage.Transition (new_db, message)) ->
- List [ Atom "ok";
- List [ Atom "message"; Atom message ];
- List [ Atom "db_hash"; Atom new_db.hash ];
- List [ Atom "db_name"; Atom new_db.name ];
- (* TODO: `serialize' shouldn't need access to the storage layer *)
- List [ Atom "branch"; Atom (get_branch storage) ] ]
-
- let print_with_time str = (* TODO: a proper logger *)
+ List
+ [
+ Atom "ok";
+ List [ Atom "message"; Atom message ];
+ List [ Atom "db_hash"; Atom new_db.hash ];
+ List [ Atom "db_name"; Atom new_db.name ];
+ (* TODO: `serialize' shouldn't need access to the storage layer *)
+ List [ Atom "branch"; Atom (get_branch storage) ];
+ ]
+ | Ok (Sublanguage.SessionSwitch multigroup) ->
+ List
+ [
+ Atom "ok";
+ List [ Atom "message"; Atom ("Switched to multigroup " ^ multigroup) ];
+ ]
+ | Ok (Sublanguage.CreateMultigroup name) ->
+ List
+ [
+ Atom "ok";
+ List [ Atom "message"; Atom ("Multigroup " ^ name ^ " created") ];
+ ]
+
+ let print_with_time str =
+ (* TODO: a proper logger *)
let now = Unix.gettimeofday () in
let tm = Unix.localtime now in
let orange = "\027[38;5;208m" in
@@ -139,50 +202,58 @@ module Make : LISTENER =
(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
+ print_endline
+ @@ Printf.sprintf "%s[%s]%s %s" orange formatted_time reset str
- let output_response output sexp =
+ let output_response out_ch sexp =
let response = Sexplib.Sexp.to_string sexp in
- output_string output response;
- (* Some programs, like our current iteration of
- * relational-explorer, expect server responses to always end
- * with a newline. Although that is technically incorrect,
- * acommodating for it doesn't bring us much harm; thus:
- *)
- output_string output "\n";
- flush output;
+ output_string out_ch response;
+ output_string out_ch "\n";
+ flush out_ch;
print_with_time response
- let handle_client connection db_head (storage : S.t) =
+ let resolve_db_ref catalog ctx =
+ match CatalogOps.get catalog ctx.current_multigroup with
+ | Some db_ref -> Ok db_ref
+ | None -> Error (Error.MultigroupNotFound ctx.current_multigroup)
+
+ let fallback_db ctx = Management.Database.empty ~name:ctx.current_multigroup
+
+ let send_serialized storage out_ch db result =
+ serialize storage db result |> output_response out_ch
+
+ let handle_sublanguage storage catalog ctx out_ch sexp =
+ match resolve_db_ref catalog ctx with
+ | Error e -> send_serialized storage out_ch (fallback_db ctx) (Error e)
+ | Ok db_ref ->
+ let db = Atomic.get db_ref in
+ Ok sexp
+ |> fmap (execute_command storage db)
+ |> fmap (perform storage catalog ctx db_ref db)
+ |> send_serialized storage out_ch db
+
+ let handle_client connection catalog (storage : S.t) =
let input = T.input connection in
let output = T.output connection in
+ let ctx = { current_multigroup = catalog.Catalog.default_multigroup } in
try
while true do
- let db = Atomic.get db_head in
- read_command input
- |> fmap (execute_command storage db)
- |> fmap (perform storage db_head db)
- |> serialize storage db
- |> output_response output
- |> ignore
+ match read_command input with
+ | Error e ->
+ send_serialized storage output (fallback_db ctx) (Error e)
+ | Ok sexp -> handle_sublanguage storage catalog ctx output sexp
done
with
- End_of_file -> ()
- (* TODO: use the logger instead *)
- | e -> Printf.eprintf "Error handling connection: %s" (Printexc.to_string e)
-
- let spawn_handler db_head storage connection =
- Stdlib.Domain.spawn (fun () -> handle_client connection db_head storage)
-
- let run transport db storage =
- (* TODO: consider how to handle multiple databases within a
- * single server (a catalog perhaps?)
- *)
- let db_head = Atomic.make db in
+ | End_of_file -> ()
+ | e ->
+ Printf.eprintf "Error handling connection: %s" (Printexc.to_string e)
+
+ let spawn_handler catalog storage connection =
+ Stdlib.Domain.spawn (fun () -> handle_client connection catalog storage)
+
+ let run transport catalog storage =
T.listen transport;
while true do
- T.accept transport
- |> spawn_handler db_head storage
- |> ignore
+ T.accept transport |> spawn_handler catalog storage |> ignore
done
end
diff --git a/lib/management/branch.ml b/lib/management/branch.ml
index 1d218b1..81dcdff 100644
--- a/lib/management/branch.ml
+++ b/lib/management/branch.ml
@@ -78,7 +78,7 @@ module Make (Storage : Physical.S with type error = string) = struct
let mk v = { Attribute.value = Obj.repr v } in
let rec generator position =
match position with
- | None -> Generator.Error "random access not supported for sakura:branch"
+ | None -> Generator.Error "random access not supported for public:branch"
| Some pos -> (
match list storage with
| Error _ -> Generator.Done
@@ -109,7 +109,7 @@ module Make (Storage : Physical.S with type error = string) = struct
let mk v = { Attribute.value = Obj.repr v } in
let generator position =
match position with
- | None -> Generator.Error "random access not supported for sakura:head"
+ | None -> Generator.Error "random access not supported for public:head"
| Some 0 -> (
match get_head storage with
| Ok None | Error _ -> Generator.Done
diff --git a/lib/management/database.ml b/lib/management/database.ml
index f4d18e8..b8a9829 100644
--- a/lib/management/database.ml
+++ b/lib/management/database.ml
@@ -6,6 +6,9 @@
reconstruct a past state from a hash alone without a separate snapshot
store. Either cap the history or make it actually useful. *)
+(* TODO: refactor RelationMap keying from composite "schema:relation" strings
+ to nested maps (schema -> relation -> Relation.t) for cleaner semantics.
+ Currently, callers are responsible for passing composite keys. *)
module RelationMap = Map.Make (String)
type deferred_entry = {
diff --git a/lib/manipulation.ml b/lib/manipulation.ml
index 91cd35d..acf6068 100644
--- a/lib/manipulation.ml
+++ b/lib/manipulation.ml
@@ -14,9 +14,9 @@
module RelationMap = Management.Database.RelationMap
-(** Build membership criteria from schema (validates type membership).
- Returns a function that takes a tree-lookup function and a tuple, checking
- schema conformance and tree membership at call time. *)
+(** Build membership criteria from schema (validates type membership). Returns a
+ function that takes a tree-lookup function and a tuple, checking schema
+ conformance and tree membership at call time. *)
let build_membership_criteria ~name schema :
(string -> Merkle.t option) -> Tuple.t -> bool =
let value_conforms_to_domain domain_name (value : Conventions.AbstractValue.t)
@@ -55,7 +55,8 @@ let build_membership_criteria ~name schema :
schema
let tree_of_db (db : Management.Database.t) name =
- Option.bind (Management.Database.get_relation db name) (fun r -> r.Relation.tree)
+ Option.bind (Management.Database.get_relation db name) (fun r ->
+ r.Relation.tree)
module Constraint = struct
include Constraint
@@ -79,6 +80,35 @@ module Make (Storage : Management.Physical.S) = struct
let of_string_error s = Error.StorageError s
let ( let* ) = Result.bind
+ let normalize_name n = Qualified_name.(parse n |> to_key)
+
+ let rec normalize_constraint_body c =
+ match c with
+ | Constraint.MemberOf { target; binding } ->
+ Constraint.MemberOf { target = normalize_name target; binding }
+ | Constraint.Not { body; universe } ->
+ Constraint.Not
+ {
+ body = normalize_constraint_body body;
+ universe = normalize_name universe;
+ }
+ | Constraint.And cs -> Constraint.And (List.map normalize_constraint_body cs)
+ | Constraint.Or cs -> Constraint.Or (List.map normalize_constraint_body cs)
+ | Constraint.Exists { variable; quantifier; body } ->
+ Constraint.Exists
+ {
+ variable;
+ quantifier = normalize_name quantifier;
+ body = normalize_constraint_body body;
+ }
+ | Constraint.Forall { variable; quantifier; body } ->
+ Constraint.Forall
+ {
+ variable;
+ quantifier = normalize_name quantifier;
+ body = normalize_constraint_body body;
+ }
+
let fold_result (f : 'a -> 'b -> ('a, error) Result.t) (init : 'a)
(xs : 'b list) : ('a, error) Result.t =
List.fold_left
@@ -108,7 +138,8 @@ module Make (Storage : Management.Physical.S) = struct
match Storage.load_raw storage hash with
| Error _ | Ok None -> None
| Ok (Some bytes) ->
- load_attrs [] (Storable.Tuple.of_bytes bytes).Storable.Tuple.attributes
+ load_attrs []
+ (Storable.Tuple.of_bytes bytes).Storable.Tuple.attributes
in
let rec load_all acc = function
| [] -> Some (List.rev acc)
@@ -218,7 +249,8 @@ module Make (Storage : Management.Physical.S) = struct
Relation.make ~hash:(Some rel_hash) ~name:stored.name
~schema:stored.schema ~tree:(Some tree) ~constraints:None
~cardinality:stored.cardinality ~generator:None
- ~membership_criteria:(build_membership_criteria ~name:stored.name stored.schema)
+ ~membership_criteria:
+ (build_membership_criteria ~name:stored.name stored.schema)
~provenance:(Relation.Provenance.Base stored.name)
~lineage:(Relation.Lineage.Base stored.name)
in
@@ -527,7 +559,10 @@ module Make (Storage : Management.Physical.S) = struct
=
let name = relation.name in
let* () = ensure_relation_exists db name in
- if not (relation.membership_criteria (tree_of_db db) (Tuple.Materialized tuple)) then
+ if
+ not
+ (relation.membership_criteria (tree_of_db db) (Tuple.Materialized tuple))
+ then
Error
(Error.ConstraintViolation "Tuple does not satisfy membership criteria")
else
@@ -623,7 +658,7 @@ module Make (Storage : Management.Physical.S) = struct
(relation : Relation.t) : (Management.Database.t, error) Result.t =
if Prelude.Catalog.is_catalog_relation relation.name then Ok db
else
- (* Insert into sakura:relation *)
+ (* Insert into public:relation *)
match
Management.Database.get_relation db Prelude.Catalog.relation_rel_name
with
@@ -631,7 +666,7 @@ module Make (Storage : Management.Physical.S) = struct
| Some rel_cat -> (
let rel_tuple = Prelude.Catalog.build_relation_tuple relation.name in
let* db, _, _ = create_tuple storage db rel_cat rel_tuple in
- (* Insert into sakura:attribute for each schema entry *)
+ (* Insert into public:attribute for each schema entry *)
match
Management.Database.get_relation db
Prelude.Catalog.attribute_rel_name
@@ -671,7 +706,7 @@ module Make (Storage : Management.Physical.S) = struct
Ok new_db
else Ok db
in
- (* Remove attribute tuples for this relation from sakura:attribute *)
+ (* Remove attribute tuples for this relation from public:attribute *)
let attr_tuples =
Prelude.Catalog.build_attribute_tuples ~relation_name:relation.name
relation.schema
@@ -745,6 +780,11 @@ module Make (Storage : Management.Physical.S) = struct
(List.map Prelude.Catalog.build_domain_tuple
[ "integer"; "natural"; "rational"; "string" ])
in
+ let* schema_rel = get_required db Prelude.Catalog.schema_rel_name in
+ let* db, _, _ =
+ create_tuples storage db schema_rel
+ [ Prelude.Catalog.build_schema_tuple Qualified_name.default_schema ]
+ in
Ok db
(*
@@ -753,7 +793,7 @@ module Make (Storage : Management.Physical.S) = struct
(** Register a domain in the database. Can be called after [create_database]
to add user-defined domains (e.g. [money], [email], [uuid]). Also inserts
- a tuple into [sakura:domain] if the catalog is live. *)
+ a tuple into [public:domain] if the catalog is live. *)
let register_domain (storage : storage) (db : Management.Database.t)
(domain : Domain.t) : (Management.Database.t, error) Result.t =
let db = Management.Database.add_domain db domain in
@@ -788,10 +828,11 @@ module Make (Storage : Management.Physical.S) = struct
*)
(** Create a new empty relation with the given schema. Also updates
- [sakura:relation] and [sakura:attribute] in the system catalog. *)
+ [public:relation] and [public:attribute] in the system catalog. *)
let create_relation (storage : storage) (db : Management.Database.t)
~(name : string) ~(schema : Schema.t) :
(Management.Database.t * Relation.t, error) Result.t =
+ let name = normalize_name name in
if Management.Database.has_relation db name then
Error (Error.RelationAlreadyExists name)
else
@@ -817,6 +858,7 @@ module Make (Storage : Management.Physical.S) = struct
~(membership_criteria : (string -> Merkle.t option) -> Tuple.t -> bool)
~(cardinality : Conventions.Cardinality.t) :
(Management.Database.t * Relation.t, error) Result.t =
+ let name = normalize_name name in
if Management.Database.has_relation db name then
Error (Error.RelationAlreadyExists name)
else
@@ -837,9 +879,10 @@ module Make (Storage : Management.Physical.S) = struct
Ok (final_db, relation)
(** Remove a relation from the database. Also removes its entries from
- [sakura:relation] and [sakura:attribute]. *)
+ [public:relation] and [public:attribute]. *)
let retract_relation (storage : storage) (db : Management.Database.t)
~(name : string) : (Management.Database.t, error) Result.t =
+ let name = normalize_name name in
match Management.Database.get_relation db name with
| None -> Error (Error.RelationNotFound name)
| Some relation ->
@@ -884,6 +927,7 @@ module Make (Storage : Management.Physical.S) = struct
(db : Management.Database.t) ~(relation_name : string)
~(constraints : Relation.RelationConstraint.t) :
(Management.Database.t * Relation.t, error) Result.t =
+ let relation_name = normalize_name relation_name in
match Management.Database.get_relation db relation_name with
| None -> Error (Error.RelationNotFound relation_name)
| Some relation ->
@@ -917,10 +961,12 @@ module Make (Storage : Management.Physical.S) = struct
Ok (new_db, new_relation)
(** Register a named constraint on a relation. Attaches the constraint body to
- the relation AND records it in [sakura:constraint]. *)
+ the relation AND records it in [public:constraint]. *)
let register_constraint (storage : storage) (db : Management.Database.t)
~(constraint_name : string) ~(relation_name : string)
~(body : Constraint.t) : (Management.Database.t, error) Result.t =
+ let relation_name = normalize_name relation_name in
+ let body = normalize_constraint_body body in
let* db, _ =
update_relation_constraints storage db ~relation_name
~constraints:[ (constraint_name, body) ]
@@ -945,7 +991,7 @@ module Make (Storage : Management.Physical.S) = struct
(** Get relation by name from database *)
let get_relation (db : Management.Database.t) ~(name : string) :
Relation.t option =
- Management.Database.get_relation db name
+ Management.Database.get_relation db (normalize_name name)
(** Count tuples in a relation *)
let tuple_count (relation : Relation.t) : int =
@@ -966,6 +1012,8 @@ module Make (Storage : Management.Physical.S) = struct
~(constraint_name : string) ~(relation_name : string)
~(body : Constraint.t) ~(timing : Constraint.timing) :
(Management.Database.t, error) Result.t =
+ let relation_name = normalize_name relation_name in
+ let body = normalize_constraint_body body in
let* db, _ =
update_relation_constraints storage db ~relation_name
~constraints:[ (constraint_name, body) ]
diff --git a/lib/prelude/catalog.ml b/lib/prelude/catalog.ml
index ce36f1e..743d397 100644
--- a/lib/prelude/catalog.ml
+++ b/lib/prelude/catalog.ml
@@ -1,13 +1,13 @@
(** System catalog helpers. Pure definitions — no storage access, no
- manipulation dependency. Consumed by {!Manipulation.Make} to bootstrap and
- maintain the six catalog relations that make the database self-describing.
-*)
+ manipulation dependency. Consumed by {!Manipulation.Make} and
+ {!Catalog.Make} to bootstrap the catalog relations that make each multigroup
+ self-describing. *)
(* TODO: on_rel_name and timing_rel_name are defined and seeded but never
written to by any executor. They appear to be stubs for trigger/timing
metadata that was never implemented. *)
-let catalog_prefix = "sakura:"
+let catalog_prefix = "public:"
let relation_rel_name = catalog_prefix ^ "relation"
let domain_rel_name = catalog_prefix ^ "domain"
let attribute_rel_name = catalog_prefix ^ "attribute"
@@ -16,7 +16,10 @@ let on_rel_name = catalog_prefix ^ "on"
let timing_rel_name = catalog_prefix ^ "timing"
let branch_rel_name = catalog_prefix ^ "branch"
let head_rel_name = catalog_prefix ^ "head"
+let multigroup_rel_name = catalog_prefix ^ "multigroup"
+let schema_rel_name = catalog_prefix ^ "schema"
+(** Relations present in every multigroup's catalog. *)
let catalog_relation_names =
[
relation_rel_name;
@@ -25,9 +28,16 @@ let catalog_relation_names =
constraint_rel_name;
on_rel_name;
timing_rel_name;
+ schema_rel_name;
]
-let is_catalog_relation name = List.mem name catalog_relation_names
+(** Relations exclusive to the sakura meta-multigroup. *)
+let sakura_only_relation_names = [ multigroup_rel_name ]
+
+let all_catalog_relation_names =
+ catalog_relation_names @ sakura_only_relation_names
+
+let is_catalog_relation name = List.mem name all_catalog_relation_names
let relation_schema : Schema.t = Schema.empty |> Schema.add "name" "string"
let domain_schema : Schema.t = Schema.empty |> Schema.add "name" "string"
@@ -43,7 +53,10 @@ let constraint_schema : Schema.t =
let on_schema : Schema.t = Schema.empty |> Schema.add "event" "string"
let timing_schema : Schema.t = Schema.empty |> Schema.add "timing" "string"
+let multigroup_schema : Schema.t = Schema.empty |> Schema.add "name" "string"
+let schema_schema : Schema.t = Schema.empty |> Schema.add "name" "string"
+(** Definitions seeded into every multigroup. *)
let catalog_definitions =
[
(relation_rel_name, relation_schema);
@@ -52,8 +65,12 @@ let catalog_definitions =
(constraint_rel_name, constraint_schema);
(on_rel_name, on_schema);
(timing_rel_name, timing_schema);
+ (schema_rel_name, schema_schema);
]
+(** Extra definitions seeded only into the sakura meta-multigroup. *)
+let sakura_only_definitions = [ (multigroup_rel_name, multigroup_schema) ]
+
(* TODO: all tuple builders use Obj.magic to coerce string values into
Attribute.value (Obj.t). This is the same UB pattern fixed in standard.ml;
should use Obj.repr instead. *)
@@ -115,3 +132,20 @@ let build_timing_tuple timing : Tuple.materialized =
Tuple.AttributeMap.singleton "timing"
{ Attribute.value = Obj.magic timing };
}
+
+let build_multigroup_tuple mg_name : Tuple.materialized =
+ {
+ Tuple.relation = multigroup_rel_name;
+ attributes =
+ Tuple.AttributeMap.singleton "name"
+ { Attribute.value = Obj.magic mg_name };
+ }
+
+let build_schema_tuple schema_name : Tuple.materialized =
+ {
+ Tuple.relation = schema_rel_name;
+ attributes =
+ Tuple.AttributeMap.singleton "name"
+ { Attribute.value = Obj.magic schema_name };
+ }
+
diff --git a/lib/prelude/standard.ml b/lib/prelude/standard.ml
index 6822f19..2a507e5 100644
--- a/lib/prelude/standard.ml
+++ b/lib/prelude/standard.ml
@@ -328,3 +328,15 @@ let divide_natural : Relation.t =
~generator:(Some generator) ~membership_criteria
~provenance:(Relation.Provenance.Base "divide")
~lineage:(Relation.Lineage.Base "divide")
+
+let prelude_relations =
+ [ less_than_natural
+ ; less_than_or_equal_natural
+ ; greater_than_natural
+ ; greater_than_or_equal_natural
+ ; equal_natural
+ ; not_equal_natural
+ ; plus_natural
+ ; times_natural
+ ; minus_natural
+ ; divide_natural ]
diff --git a/lib/qualified_name.ml b/lib/qualified_name.ml
new file mode 100644
index 0000000..b6d01bb
--- /dev/null
+++ b/lib/qualified_name.ml
@@ -0,0 +1,31 @@
+(** Fully qualified relation name: [multigroup:schema:relation].
+
+ Splits on [:], fills defaults for missing parts.
+ - ["relation"] -> { multigroup=""; schema="public"; relation }
+ - ["schema:relation"] -> { multigroup=""; schema; relation }
+ - ["mg:schema:relation"] -> { multigroup=mg; schema; relation }
+*)
+
+type t = {
+ multigroup : string;
+ schema : string;
+ relation : string;
+}
+
+let default_schema = "public"
+
+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 }
+
+let make ?(multigroup = "") ?(schema = default_schema) relation =
+ { multigroup; schema; relation }
+
+let to_string { multigroup; schema; relation } =
+ if multigroup = "" then schema ^ ":" ^ relation
+ else multigroup ^ ":" ^ schema ^ ":" ^ relation
+
+let to_key { schema; relation; _ } = schema ^ ":" ^ relation
diff --git a/lib/qualified_name.mli b/lib/qualified_name.mli
new file mode 100644
index 0000000..9bee0c9
--- /dev/null
+++ b/lib/qualified_name.mli
@@ -0,0 +1,24 @@
+(** Fully qualified relation name: [multigroup:schema:relation].
+
+ Unqualified names fill in defaults: empty multigroup, ["public"] schema. *)
+
+type t = {
+ multigroup : string;
+ schema : string;
+ relation : string;
+}
+
+val default_schema : string
+
+(** 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" *)
+val parse : string -> t
+
+val make : ?multigroup:string -> ?schema:string -> string -> t
+val to_string : t -> string
+
+(** Composite key for [RelationMap] lookup within a single database:
+ ["schema:relation"]. *)
+val to_key : t -> string
diff --git a/lib/sublanguage_types.ml b/lib/sublanguage_types.ml
index b4b6b29..d82d6aa 100644
--- a/lib/sublanguage_types.ml
+++ b/lib/sublanguage_types.ml
@@ -8,3 +8,5 @@ type result =
| Query of Relation.t
| Transition of Management.Database.t * string
| Cursor of cursor_result
+ | SessionSwitch of string
+ | CreateMultigroup of string \ No newline at end of file
diff --git a/lib/system.ml b/lib/system.ml
index 4280dda..14ef089 100644
--- a/lib/system.ml
+++ b/lib/system.ml
@@ -38,33 +38,6 @@ let registry : registry =
let transport = Transport.TCP.create config in
Ok (TransportParcel ((module Transport.TCP), transport))) }
-let initialize_multigroup create_immutable_relation storage multigroup =
- let open Prelude.Standard in
- List.fold_left
- (fun multigroup (rel : Relation.t) ->
- match
- create_immutable_relation storage multigroup ~name:rel.name
- ~schema:rel.schema ~generator:(Option.get rel.generator)
- ~membership_criteria:rel.membership_criteria
- ~cardinality:rel.cardinality
- with
- | Ok (new_multigroup, _) -> new_multigroup
- | Error e ->
- Printf.eprintf
- "Warning: failed to register prelude relation %s: %s\n%!" rel.name
- (Sexplib.Sexp.to_string (Error.sexp_of_error e));
- multigroup)
- multigroup
- [ less_than_natural;
- less_than_or_equal_natural;
- greater_than_natural;
- greater_than_or_equal_natural;
- equal_natural;
- not_equal_natural;
- plus_natural;
- times_natural;
- minus_natural;
- divide_natural ]
let assemble (config : Configuration.t) : (unit -> unit, string) result =
let open Utilities.Result in
@@ -93,15 +66,13 @@ let assemble (config : Configuration.t) : (unit -> unit, string) result =
let* packed_transport = transport_provider transport_body in
let (StorageParcel ((module S), storage)) = packed_storage in
let (TransportParcel ((module T), transport)) = packed_transport in
- let module Manip = Manipulation.Make (S) in
- let* multigroup =
- Manip.create_database storage ~name:"sakura"
- |> Result.map (initialize_multigroup Manip.create_immutable_relation storage)
- |> Result.map_error (fun _ -> "Failed to create initial database")
+ let module C = Catalog.Make (S) in
+ let* catalog =
+ C.create storage ~prelude_relations:Prelude.Standard.prelude_relations
in
let module L = Listener.Make (T) (S) in
Ok (fun () -> Scl.Executor.set_sessions (Session.create ());
- L.run transport multigroup storage)
+ L.run transport catalog storage)
let run_from_config (path : string) : (unit -> unit, string) result =
let ( let* ) = Result.bind in
generated by cgit v1.2.3 (git 2.25.1) at 2026-11-04 07:15:05 +0000