path: root/lib/backend/managers/Object.ml

(* @uses Path -- snoc, to_string when building registry paths *)
(* @uses Condition -- builds registry-object/path errors *)
(* @needs Value *)

type multigroup = {merkle_root: string}
type relation = {merkle_root: string}

(* 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}
type branch_tree = {merkle_root: string}

type rnt_object_kind =
  | Multigroup of multigroup
  | Relation of relation
  | EphemeralRelation of ephemeral_relation
  | 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; 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 rnt_object_tree = {data: registry; subsequent: rnt_object_tree BatMap.String.t}

module Error = struct
  open Concepts.Condition

  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 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 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 =
  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)