Multigroup unified reference for hierarchical access

1 files changed, 0 insertions, 194 deletions

diff --git a/lib/catalog.ml b/lib/catalog.ml
deleted file mode 100644
index 605c40a..0000000
--- a/lib/catalog.ml
+++ /dev/null
@@ -1,194 +0,0 @@
-(** Multi-multigroup catalog.
-
-    Each multigroup gets its own [Atomic.t], so mutations to independent
-    multigroups never contend. The [sakura] multigroup is auto-bootstrapped,
-    undeletable, and self-referential: it carries a [public:multigroup] relation
-    listing every registered multigroup. *)
-
-type t = {
-  multigroups : Management.Database.t Atomic.t Utilities.StringMap.t Atomic.t;
-  default_multigroup : string;
-  mutex : Mutex.t;
-}
-
-let sakura_name = "sakura"
-
-module Make (S : Management.Physical.S with type error = string) = struct
-  open Utilities.Result
-  module Manip = Manipulation.Make (S)
-
-  type nonrec t = t
-
-  let map_error r =
-    Result.map_error (fun e -> Sexplib.Sexp.to_string (Error.sexp_of_error e)) r
-
-  let get catalog name =
-    Utilities.StringMap.find_opt name (Atomic.get catalog.multigroups)
-
-  let list catalog =
-    Utilities.StringMap.bindings (Atomic.get catalog.multigroups)
-    |> List.map fst
-
-  let publish_multigroups catalog ~expected ~updated =
-    if Atomic.compare_and_set catalog.multigroups expected updated then Ok ()
-    else Error "Concurrent multigroup map update detected"
-
-  let get_string_attr attr (t : Tuple.materialized) =
-    Option.map
-      (fun a -> (Obj.magic a.Attribute.value : string))
-      (Tuple.AttributeMap.find_opt attr t.attributes)
-
-  (** Dynlink every library recorded in public:loaded_library. No-op on a fresh
-      DB; effective when loading a previously persisted multigroup. *)
-  let hydrate_prl_libraries storage (db : Management.Database.t) =
-    match
-      Management.Database.get_relation db
-        Prelude.Catalog.loaded_library_rel_name
-    with
-    | None -> ()
-    | Some rel -> (
-        let hashes =
-          match rel.Relation.tree with None -> [] | Some t -> Merkle.keys t
-        in
-        match Manip.load_tuples storage hashes with
-        | Error _ -> ()
-        | Ok tuples ->
-            List.iter
-              (fun t ->
-                match get_string_attr "path" t with
-                | None -> ()
-                | Some path -> ignore (Prl.Runtime.load_library path))
-              tuples)
-
-  (** Swallow errors: a missing prelude relation is non-fatal. *)
-  let register_prelude_relation storage db (rel : Relation.t) =
-    match
-      Manip.create_immutable_relation storage db ~name:rel.name
-        ~schema:rel.schema ~generator:(Option.get rel.generator)
-        ~membership_criteria:rel.membership_criteria
-        ~cardinality:rel.cardinality ~producer:None
-    with
-    | Ok (new_db, _) -> new_db
-    | Error e ->
-        Printf.eprintf "Warning: prelude relation %s: %s\n%!" rel.name
-          (Sexplib.Sexp.to_string (Error.sexp_of_error e));
-        db
-
-  (** Create DB + seed catalog + fold in [prelude_relations] + hydrate PRL. *)
-  let bootstrap_multigroup storage ~prelude_relations ~name =
-    let* db = Manip.create_database storage ~name |> map_error in
-    let db =
-      List.fold_left (register_prelude_relation storage) db prelude_relations
-    in
-    hydrate_prl_libraries storage db;
-    Ok db
-
-  (** Create additional catalog relations beyond the base six. Used to seed
-      [public:multigroup] into the sakura multigroup only. *)
-  let seed_extra_catalog storage ~definitions db =
-    List.fold_left
-      (fun acc (name, schema) ->
-        let* db = acc in
-        let* new_db, _ =
-          Manip.create_relation storage db ~name ~schema |> map_error
-        in
-        Ok new_db)
-      (Ok db) definitions
-
-  (** Write a tuple into sakura's [public:multigroup] and update the ref. No-op
-      if the relation doesn't exist yet (bootstrap ordering). *)
-  let register_in_sakura storage sakura_ref mg_name =
-    let rec go () =
-      let sakura = Atomic.get sakura_ref in
-      match
-        Management.Database.get_relation sakura
-          Prelude.Catalog.multigroup_rel_name
-      with
-      | None -> Ok ()
-      | Some mg_rel ->
-          let tuple = Prelude.Catalog.build_multigroup_tuple mg_name in
-          let* new_sakura, _, _ =
-            Manip.create_tuple storage sakura mg_rel tuple |> map_error
-          in
-          if Atomic.compare_and_set sakura_ref sakura new_sakura then Ok ()
-          else go ()
-    in
-    go ()
-
-  let create storage ~prelude_relations =
-    let* sakura_db =
-      bootstrap_multigroup storage ~prelude_relations ~name:sakura_name
-    in
-    let* sakura_db =
-      seed_extra_catalog storage
-        ~definitions:Prelude.Catalog.sakura_only_definitions sakura_db
-    in
-    let sakura_ref = Atomic.make sakura_db in
-    let* () = register_in_sakura storage sakura_ref sakura_name in
-    let map = Utilities.StringMap.singleton sakura_name sakura_ref in
-    Ok
-      {
-        multigroups = Atomic.make map;
-        default_multigroup = sakura_name;
-        mutex = Mutex.create ();
-      }
-
-  let add catalog storage ~prelude_relations name =
-    Mutex.protect catalog.mutex (fun () ->
-        let map = Atomic.get catalog.multigroups in
-        if Utilities.StringMap.mem name map then
-          Error (Printf.sprintf "Multigroup %s already exists" name)
-        else
-          let* db = bootstrap_multigroup storage ~prelude_relations ~name in
-          let db_ref = Atomic.make db in
-          let* () =
-            match Utilities.StringMap.find_opt sakura_name map with
-            | Some sakura_ref -> register_in_sakura storage sakura_ref name
-            | None -> Ok ()
-          in
-          let new_map = Utilities.StringMap.add name db_ref map in
-          let* () =
-            publish_multigroups catalog ~expected:map ~updated:new_map
-          in
-          Ok db_ref)
-
-  let unregister_from_sakura storage sakura_ref mg_name =
-    let rec go () =
-      let sakura = Atomic.get sakura_ref in
-      match
-        Management.Database.get_relation sakura
-          Prelude.Catalog.multigroup_rel_name
-      with
-      | None -> Ok ()
-      | Some mg_rel ->
-          let tuple_hash =
-            Hashing.hash_tuple (Prelude.Catalog.build_multigroup_tuple mg_name)
-          in
-          let* new_sakura, _ =
-            Manip.retract_tuple storage sakura mg_rel ~tuple_hash |> map_error
-          in
-          if Atomic.compare_and_set sakura_ref sakura new_sakura then Ok ()
-          else go ()
-    in
-    go ()
-
-  let remove catalog storage name =
-    if name = sakura_name then Error "Cannot remove the sakura system catalog"
-    else
-      Mutex.protect catalog.mutex (fun () ->
-          let map = Atomic.get catalog.multigroups in
-          if not (Utilities.StringMap.mem name map) then
-            Error (Printf.sprintf "Multigroup %s does not exist" name)
-          else
-            let* () =
-              match Utilities.StringMap.find_opt sakura_name map with
-              | None -> Ok ()
-              | Some sakura_ref ->
-                  unregister_from_sakura storage sakura_ref name
-            in
-            let new_map = Utilities.StringMap.remove name map in
-            let* () =
-              publish_multigroups catalog ~expected:map ~updated:new_map
-            in
-            Ok ())
-end