Lifecycle Manager

1 files changed, 213 insertions, 13 deletions

diff --git a/lib/backend/managers/Object.ml b/lib/backend/managers/Object.ml
index b107b4e..981420b 100644
--- a/lib/backend/managers/Object.ml
+++ b/lib/backend/managers/Object.ml
@@ -1,6 +1,13 @@
 type multigroup = {merkle_root: string}
 type relation = {merkle_root: string}
-type ephemeral_relation = {merkle_root: string; dependencies: string BatFingerTree.t}
+
+(* An ephemeral relation is a stored plan that reads other relations. Its
+   dependencies are the inputs that plan replays over. They are branch-local
+   symlink paths, not version-pinned paths: as the branch head advances the
+   inputs move with it, and Namespace.resolve turns the symlink into whatever
+   object is current on this branch hash. Keeping them as paths (not hashes)
+   is what lets an ephemeral relation behave like a view. *)
+type ephemeral_relation = {merkle_root: string; dependencies: Concepts.Path.t BatFingerTree.t}
 type transaction = unit
 type session = {connection_context: unit; branch_overrides: string BatMap.String.t}
 type branch = {name: string; target_hash: string}
@@ -13,25 +20,218 @@ type rnt_object_kind =
   | Session of session
   | Branch of branch
   | BranchTree of branch_tree
+  | Namespace of namespace
+
+and namespace = {label: string; predicate: rnt_object_kind -> bool}
 
 type rnt_method = OPEN | CLOSE
 
 type rnt_object =
-  {kind: rnt_object_kind; disposable: bool; methods: rnt_method BatSet.t; exclsive: bool}
+  {kind: rnt_object_kind; disposable: bool; methods: rnt_method BatSet.t; exclusive: bool}
+
+(* Three independent facts about a registered object, kept apart on purpose:
+
+   - handle_count: how many handles are open on it right now (open/close).
+   - reference_count: how many other objects depend on it staying resident.
+     This is bookkeeping of real edges, nothing more. It goes up because a
+     dependency exists, not because someone asked to keep the object alive.
+   - pinned: an explicit override that bypasses collection regardless of the
+     counts. Used when something must not be evicted even though nothing
+     currently points at it or holds it open. This is deliberately separate
+     from reference_count so the two reasons never get confused. *)
+type registry = {reference_count: int; handle_count: int; pinned: bool; entry: rnt_object}
+
+(*
+  /system/branch/branch1/multigrop/multigroup1/relation/relation1
+  /system/branch1/multigrop/multigroup1/relation/relation2
+  /system/branch1/multigrop/multigroup1/ephemeral_relation/ephemeral_relation1
+  /system/transaction/xyz_txn
+ *)
 
-type registry = {reference_count: int; handle_count: int; entry: rnt_object}
+type rnt_object_tree = {data: registry; subsequent: rnt_object_tree BatMap.String.t}
 
-type rnt_object_tree =
-  | Intermediary of {label: string; data: registry; subsequent: rnt_object_tree BatFingerTree.t}
-  | Final of {label: string; data: registry}
+module Error = struct
+  open Concepts.Condition
 
-let register (_object_path : string BatFingerTree.t) (_registry : rnt_object_tree)
-    (_rnt_object : rnt_object) : rnt_object_tree =
-  failwith "NOT IMPLEMENTED"
+  let registry_object_already_registered path =
+    let msg = "An object is already registered in the path" in
+    condition "registry-object-already-registered" msg
+      ("path" |=| Concepts.Value.String (Concepts.Path.to_string path))
 
-let find (_object_path : string BatFingerTree.t) (_registry : rnt_object_tree) : registry =
-  failwith "NOT IMPLEMENTED"
+  let registry_path_not_found path =
+    let msg = "The provided path was not found" in
+    condition "registry-path-not-found" msg
+      ("path" |=| Concepts.Value.String (Concepts.Path.to_string path))
+end
 
-let unregister (_object_path : string BatFingerTree.t) (_registry : rnt_object_tree) :
+let make_object ?(disposable = false) ?(exclusive = false) ?(methods = BatSet.empty)
+    (kind : rnt_object_kind) : rnt_object =
+  {kind; disposable; methods; exclusive}
+
+(* The empty registry. The root node is the system namespace itself, and every
+   other object is registered under it. Path separators are only a string
+   rendering concern, so there is no distinct "/" node above system: system is
+   the root. It is exempt from collection for the same reason a branch is, it
+   is the way in to everything else. *)
+let root : rnt_object_tree =
+  { data=
+      { reference_count= 0;
+        handle_count= 0;
+        pinned= false;
+        entry= make_object (Namespace {label= "system"; predicate= (fun _ -> true)}) };
+    subsequent= BatMap.String.empty }
+
+let find (path : Concepts.Path.t) (tree : rnt_object_tree) : registry option =
+  let rec walk components node =
+    match BatFingerTree.front components with
+    | None -> Some node.data
+    | Some (tail, head) -> Option.bind (BatMap.String.find_opt head node.subsequent) (walk tail)
+  in
+  walk path tree
+
+let update (path : Concepts.Path.t) (f : registry -> registry) (tree : rnt_object_tree) :
     rnt_object_tree =
-  failwith "NOT IMPLEMENTED"
+  let rec walk components node =
+    match BatFingerTree.front components with
+    | None -> {node with data= f node.data}
+    | Some (tail, head) ->
+      begin match BatMap.String.find_opt head node.subsequent with
+      | None -> node
+      | Some child ->
+          {node with subsequent= BatMap.String.add head (walk tail child) node.subsequent}
+      end
+  in
+  walk path tree
+
+(* The objects that must stay resident for this object to remain replayable.
+   Registering an object bumps the reference_count of each edge target and
+   unregistering drops it, so reference counts stay in step with the real
+   dependency graph. Only ephemeral relations carry edges today. Which kinds
+   grow edges is a per-kind decision, which is why this lives next to the
+   registry and not in the lifecycle manager: the object knows its own shape. *)
+let reference_edges (kind : rnt_object_kind) : Concepts.Path.t BatFingerTree.t =
+  match kind with
+  | EphemeralRelation {dependencies; _} -> dependencies
+  | Multigroup _ | Relation _ | Session _ | Branch _ | BranchTree _ | Namespace _ ->
+      BatFingerTree.empty
+
+(* Adjust the reference_count of every edge target by delta. A target that is
+   not present is skipped: update leaves the tree untouched when the path is
+   missing. That is fine for a skeleton, but it hides a dangling dependency,
+   so registration will eventually want to fail loudly on a missing input. *)
+let adjust_references (delta : int) (paths : Concepts.Path.t BatFingerTree.t)
+    (tree : rnt_object_tree) : rnt_object_tree =
+  BatFingerTree.fold_left
+    (fun tree path ->
+      update path (fun r -> {r with reference_count= r.reference_count + delta}) tree )
+    tree paths
+
+(* A branch is exempt from collection because everything is reachable through
+   it: collecting a branch would orphan its whole subtree. Every other kind is
+   collectable, including sessions. A session is runtime-only state with no
+   durable encoding, so collecting one is a real teardown rather than an
+   eviction, but it still happens (see Lifecycle for how a dead session is
+   detected). *)
+let is_gc_exempt (kind : rnt_object_kind) : bool = match kind with Branch _ -> true | _ -> false
+
+(* Runtime-only kinds have no durable encoding, so collecting them cannot be
+   undone by rehydrating from disk. The lifecycle manager surfaces these to
+   its caller as disposals to run (a session close, and later a transaction
+   rollback once transactions become objects in their own right). *)
+let is_runtime (kind : rnt_object_kind) : bool = match kind with Session _ -> true | _ -> false
+
+let has_children (path : Concepts.Path.t) (tree : rnt_object_tree) : bool =
+  let rec walk components node =
+    match BatFingerTree.front components with
+    | None -> not (BatMap.String.is_empty node.subsequent)
+    | Some (tail, head) ->
+      begin match BatMap.String.find_opt head node.subsequent with
+      | None -> false
+      | Some child -> walk tail child
+      end
+  in
+  walk path tree
+
+(* TODO: This function is not tail call optimized. We ventured with
+   the idea of using CPS, but that's not going to solve anything here,
+   so the probable best course of action is relying on the growing map
+   to carry on the state. This is not a big deal as the structure is
+   expected to be small enough to live in memory and these operations
+   are relatively uncommon. *)
+let register (path : Concepts.Path.t) (object' : rnt_object) (tree : rnt_object_tree) :
+    (rnt_object_tree, Concepts.Condition.condition) result =
+  let rec insert components node =
+    match BatFingerTree.front components with
+    | None -> Error (Error.registry_object_already_registered path)
+    | Some (tail, head) when BatFingerTree.is_empty tail ->
+        if BatMap.String.mem head node.subsequent then
+          Error (Error.registry_object_already_registered path)
+        else
+          let child =
+            { data= {reference_count= 0; handle_count= 0; pinned= false; entry= object'};
+              subsequent= BatMap.String.empty }
+          in
+          Ok {node with subsequent= BatMap.String.add head child node.subsequent}
+    | Some (tail, head) ->
+      begin match BatMap.String.find_opt head node.subsequent with
+      | None -> Error (Error.registry_path_not_found path)
+      | Some child ->
+          Result.map (fun child' ->
+              {node with subsequent= BatMap.String.add head child' node.subsequent} )
+          @@ insert tail child
+      end
+  in
+  (* On success, record the new object's dependency edges by bumping the
+     reference_count of each input it reads. This is the polymorphic part of
+     registration: the edge set comes from the object's own kind. *)
+  Result.map
+    (fun tree -> adjust_references 1 (reference_edges object'.kind) tree)
+    (insert path tree)
+
+let with_namespace (parent : Concepts.Path.t) (namespace_label : string)
+    (predicate : rnt_object_kind -> bool) (name : string) (object' : rnt_object)
+    (tree : rnt_object_tree) : (rnt_object_tree, Concepts.Condition.condition) result =
+  let namespace_path = Concepts.Path.snoc parent namespace_label in
+  let tree_with_namespace =
+    match find namespace_path tree with
+    | None ->
+        register namespace_path (make_object (Namespace {label= namespace_label; predicate})) tree
+    | Some _ -> Ok tree
+  in
+  Result.bind tree_with_namespace (fun tree ->
+      register (Concepts.Path.snoc namespace_path name) object' tree )
+
+let construct_multigroup parent name (mg : multigroup) tree =
+  with_namespace parent "multigroup"
+    (function Multigroup _ -> true | _ -> false)
+    name (make_object (Multigroup mg)) tree
+
+let construct_relation parent name (rel : relation) tree =
+  with_namespace parent "relation"
+    (function Relation _ -> true | _ -> false)
+    name (make_object (Relation rel)) tree
+
+let unregister (path : Concepts.Path.t) (tree : rnt_object_tree) :
+    (rnt_object_tree, Concepts.Condition.condition) result =
+  (* Read the edges before removing the node so we can undo what register did:
+     dropping an object releases its hold on the inputs it depended on. *)
+  let edges =
+    match find path tree with Some r -> reference_edges r.entry.kind | None -> BatFingerTree.empty
+  in
+  let rec remove components node =
+    match BatFingerTree.front components with
+    | None -> Error (Error.registry_path_not_found path)
+    | Some (tail, head) when BatFingerTree.is_empty tail ->
+        if BatMap.String.mem head node.subsequent then
+          Ok {node with subsequent= BatMap.String.remove head node.subsequent}
+        else Error (Error.registry_path_not_found path)
+    | Some (tail, head) ->
+      begin match BatMap.String.find_opt head node.subsequent with
+      | None -> Error (Error.registry_path_not_found path)
+      | Some child ->
+          Result.map (fun child' ->
+              {node with subsequent= BatMap.String.add head child' node.subsequent} )
+          @@ remove tail child
+      end
+  in
+  Result.map (fun tree -> adjust_references (-1) edges tree) (remove path tree)