diff options
Diffstat (limited to '')
| -rw-r--r-- | docs/lifecycle.org | 82 | ||||
| -rw-r--r-- | dune-project | 2 | ||||
| -rw-r--r-- | flake.nix | 9 | ||||
| -rw-r--r-- | lib/backend/managers/Cursor.ml | 2 | ||||
| -rw-r--r-- | lib/backend/managers/Cursor.mli | 2 | ||||
| -rw-r--r-- | lib/backend/managers/Handle.ml | 9 | ||||
| -rw-r--r-- | lib/backend/managers/Identity.ml | 5 | ||||
| -rw-r--r-- | lib/backend/managers/Identity.mli | 3 | ||||
| -rw-r--r-- | lib/backend/managers/Lifecycle.ml | 106 | ||||
| -rw-r--r-- | lib/backend/managers/Lifecycle.mli | 17 | ||||
| -rw-r--r-- | lib/backend/managers/Namespace.ml | 9 | ||||
| -rw-r--r-- | lib/backend/managers/Namespace.mli | 9 | ||||
| -rw-r--r-- | lib/backend/managers/Object.ml | 226 | ||||
| -rw-r--r-- | rnt.opam | 1 | ||||
| -rw-r--r-- | test/dune | 2 | ||||
| -rw-r--r-- | test/test_rnt.ml | 2 | ||||
| -rw-r--r-- | test/unit/backend/Lifecycle.ml | 147 |
17 files changed, 612 insertions, 21 deletions
diff --git a/docs/lifecycle.org b/docs/lifecycle.org new file mode 100644 index 0000000..80b387d --- /dev/null +++ b/docs/lifecycle.org @@ -0,0 +1,82 @@ +#+TITLE: Lifecycle Manager + +* Purpose + +The lifecycle manager decides when a registered object may leave memory. It +operates purely on the object tree and never touches storage. "Collection" +here means dropping the in-memory registry entry, not deleting anything on +disk. + +* Three independent facts per object + +Each registry entry keeps three separate pieces of state, deliberately not +merged: + +- =handle_count= :: how many handles are open on the object right now. +- =reference_count= :: how many other objects depend on it staying resident. + This is bookkeeping of real dependency edges. It rises because a dependency + exists, never because someone asked to keep the object alive. +- =pinned= :: an explicit override that bypasses collection regardless of the + counts. Pinning is a decision; reference counting is bookkeeping. They are + kept apart so the two reasons are never confused for one another. + +An object is eligible for collection only when =handle_count = 0=, +=reference_count = 0=, =pinned = false=, and its kind is not exempt. + +* Collection is eviction, not deletion + +Durable-backed objects (relations, multigroups, branch trees) carry an encoded +form and can be rebuilt on the next access, so evicting them is safe and keeps +memory bounded. There is no reason to hold every object in memory at all +times. + +Runtime-only objects have no durable form, so collecting them is a real +teardown rather than an eviction. The manager does not act on storage itself; +it returns these to the caller as *disposals* to run (close a session, and +later roll back a transaction). + +* Reference edges + +The objects an object depends on are its reference edges. Registration bumps +the =reference_count= of each edge target; unregistration drops it. The edge +set is a per-kind property and lives next to the registry, because the object +knows its own shape. + +Only ephemeral relations carry edges today. An ephemeral relation is a stored +plan that reads other relations, so those inputs must not be collected while +the plan can still be replayed. The edges 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. This is what lets an ephemeral relation behave like a view. + +* Teardown order + +The order of teardown falls out of the counts rather than any external check. +Collecting an object releases its edges, which drops the =reference_count= of +each input and can make those inputs eligible in turn, so collection cascades +into them. A dependent is always torn down before the inputs it held, because +while it is alive its inputs cannot reach zero. + +A populated namespace is kept, not collected and not an error: it is +scaffolding for the objects still living under it. A childless namespace is +collectable like anything else. + +* Exempt and runtime kinds + +- *Branch* is exempt from collection: everything is reachable through it, so + collecting a branch would orphan its whole subtree. +- *Session* is collectable but runtime-only. A lost connection is the trigger, + and only Sakura can say for certain that a client is gone. The intended + detection is an inactivity timer per session, with each timer modelled as an + object owned by the session so expiry drives collection of the session, + cascading into what it held exclusively (transactions first, temporary + relations perhaps later). This needs a timer facility the project does not + have yet and is left as a boundary. +- *Transaction* is intended to become an object with rollback-on-disposal, but + is not part of =rnt_object_kind= yet. + +* Contention + +Separate from collection. An exclusive object with an open handle, such as a +branch head being read, cannot be modified until the handle closes. +=contention= reports this so writers can be gated. diff --git a/dune-project b/dune-project index e7c3b1e..9c72161 100644 --- a/dune-project +++ b/dune-project @@ -24,4 +24,4 @@ batteries digestif (alcotest :with-test) - (ocaml-lsp-server :with-dev-setup))) ; <-- Linha adicionada aqui + (ocaml-lsp-server :with-dev-setup))) @@ -30,13 +30,18 @@ lmdb ]) ++ (with ocamlPackages; [ batteries + num ctypes ctypes-foreign sexplib digestif ]); - checkInputs = [ ocamlPackages.alcotest ]; + checkInputs = with ocamlPackages; [ + alcotest + qcheck-core + qcheck-alcotest + ]; doCheck = true; @@ -58,6 +63,8 @@ ocaml-lsp ocamlformat utop + qcheck-core + qcheck-alcotest ]); }; }); diff --git a/lib/backend/managers/Cursor.ml b/lib/backend/managers/Cursor.ml index 3295cae..474387a 100644 --- a/lib/backend/managers/Cursor.ml +++ b/lib/backend/managers/Cursor.ml @@ -1,6 +1,6 @@ type descriptor = | Stored of {merkle_root: string} - | Ephemeral of {merkle_root: string; dependencies: string BatFingerTree.t} + | Ephemeral of {merkle_root: string; dependencies: Concepts.Path.t BatFingerTree.t} module Make (Store : Abstract.Storage.STORAGE) = struct type cursor = unit diff --git a/lib/backend/managers/Cursor.mli b/lib/backend/managers/Cursor.mli index 71fb15d..a4dec44 100644 --- a/lib/backend/managers/Cursor.mli +++ b/lib/backend/managers/Cursor.mli @@ -1,6 +1,6 @@ type descriptor = | Stored of {merkle_root: string} - | Ephemeral of {merkle_root: string; dependencies: string BatFingerTree.t} + | Ephemeral of {merkle_root: string; dependencies: Concepts.Path.t BatFingerTree.t} module Make (Store : Abstract.Storage.STORAGE) : sig type cursor diff --git a/lib/backend/managers/Handle.ml b/lib/backend/managers/Handle.ml index ed2f220..872af43 100644 --- a/lib/backend/managers/Handle.ml +++ b/lib/backend/managers/Handle.ml @@ -18,6 +18,10 @@ let not_a_relation () : Concepts.Condition.condition = Concepts.Condition.condition "not-a-relation" "handle does not refer to a stored or ephemeral relation" Concepts.Condition.empty +let no_such_object () : Concepts.Condition.condition = + Concepts.Condition.condition "no-such-object" "no object registered at the given path" + Concepts.Condition.empty + module Make (Store : Abstract.Storage.STORAGE) = struct module Cur = Cursor.Make (Store) @@ -28,8 +32,9 @@ module Make (Store : Abstract.Storage.STORAGE) = struct let create objects txn = {objects; txn} let open_ t ~path = - let object_ = Object.find path t.objects in - Ok {object_; txn= t.txn} + match Object.find path t.objects with + | Some object_ -> Ok {object_; txn= t.txn} + | None -> Error (no_such_object ()) let relation_descriptor (object_ : Object.registry) : (Cursor.descriptor, Concepts.Condition.condition) result = diff --git a/lib/backend/managers/Identity.ml b/lib/backend/managers/Identity.ml new file mode 100644 index 0000000..3510e3a --- /dev/null +++ b/lib/backend/managers/Identity.ml @@ -0,0 +1,5 @@ +let permits (object_ : Object.registry) (method_ : Object.rnt_method) : bool = + BatSet.mem method_ object_.Object.entry.Object.methods + +let can_open (object_ : Object.registry) : bool = permits object_ Object.OPEN +let can_close (object_ : Object.registry) : bool = permits object_ Object.CLOSE diff --git a/lib/backend/managers/Identity.mli b/lib/backend/managers/Identity.mli new file mode 100644 index 0000000..589002e --- /dev/null +++ b/lib/backend/managers/Identity.mli @@ -0,0 +1,3 @@ +val permits : Object.registry -> Object.rnt_method -> bool +val can_open : Object.registry -> bool +val can_close : Object.registry -> bool diff --git a/lib/backend/managers/Lifecycle.ml b/lib/backend/managers/Lifecycle.ml new file mode 100644 index 0000000..7aa3836 --- /dev/null +++ b/lib/backend/managers/Lifecycle.ml @@ -0,0 +1,106 @@ +(* The lifecycle manager decides when a registered object may leave memory. + It works purely on the object tree and never touches storage: collection + here means dropping the in-memory registry entry, not deleting anything on + disk. Durable-backed objects (relations, multigroups, branch trees) can be + rebuilt from their encoded form on the next access, so evicting them is + safe and keeps memory bounded. Runtime-only objects (sessions, and later + transactions) have no durable form, so their collection is a real teardown; + the manager surfaces those to the caller as disposals rather than acting on + storage itself. *) + +type tree = Object.rnt_object_tree + +(* A runtime object that was collected and now needs an external teardown the + lifecycle manager cannot perform on its own: closing a session, and later + rolling back a transaction. The caller drains these after a collect. *) +type disposal = {path: Concepts.Path.t; kind: Object.rnt_object_kind} + +let monitor (tree : tree) (path : Concepts.Path.t) : tree = + Object.update path (fun r -> {r with Object.handle_count= r.Object.handle_count + 1}) tree + +(* Pin is an explicit keep-alive that bypasses collection. It does not touch + reference_count: pinning is a decision, reference counting is bookkeeping of + real edges. Keeping them separate is what stops the two from being mistaken + for each other. *) +let pin (tree : tree) (path : Concepts.Path.t) : tree = + Object.update path (fun r -> {r with Object.pinned= true}) tree + +let unpin (tree : tree) (path : Concepts.Path.t) : tree = + Object.update path (fun r -> {r with Object.pinned= false}) tree + +(* An object may be collected only when nothing holds it open, nothing depends + on it, it has not been pinned, and its kind is not exempt (a branch). This + works on the registry record directly so callers that already hold it (the + cascade) need not walk the tree a second time. *) +let registry_eligible (r : Object.registry) : bool = + r.Object.handle_count = 0 + && r.Object.reference_count = 0 + && (not r.Object.pinned) + && not (Object.is_gc_exempt r.Object.entry.Object.kind) + +let is_eligible_for_gc (tree : tree) (path : Concepts.Path.t) : bool = + match Object.find path tree with Some r -> registry_eligible r | None -> false + +(* Contention reports whether a mutation must wait. An exclusive object with an + open handle, such as a branch head being read, cannot be modified until the + handle closes. This gates writers; it is not part of collection. *) +let contention (tree : tree) (path : Concepts.Path.t) : bool = + match Object.find path tree with + | Some r -> r.Object.entry.Object.exclusive && r.Object.handle_count > 0 + | None -> false + +(* Cascade the collection at path, threading the pruned tree and the disposals + gathered so far. Disposals are appended (snoc) as each object is torn down, + so the finger tree hands them back parent-first, left-to-right without any + reversal pass. + + Order of teardown falls out of the counts. Collecting an object drops the + reference_count of every input it depended on (Object.unregister undoes the + edges), which can make those inputs eligible in turn, so we recurse into + them. A populated namespace is kept, not collected and not an error: it is + scaffolding for the objects still living under it. *) +let rec cascade (tree : tree) (disposals : disposal BatFingerTree.t) (path : Concepts.Path.t) : + (tree * disposal BatFingerTree.t, Concepts.Condition.condition) result = + match Object.find path tree with + | None -> Ok (tree, disposals) + | Some r when not (registry_eligible r) -> Ok (tree, disposals) + | Some r -> + let kind = r.Object.entry.Object.kind in + begin match kind with + | Object.Namespace _ when Object.has_children path tree -> Ok (tree, disposals) + | _ -> + let edges = Object.reference_edges kind in + let disposals = + if Object.is_runtime kind then BatFingerTree.snoc disposals {path; kind} else disposals + in + Result.bind (Object.unregister path tree) (fun tree -> + BatFingerTree.fold_left + (fun acc dep -> Result.bind acc (fun (tree, disposals) -> cascade tree disposals dep)) + (Ok (tree, disposals)) + edges ) + end + +let try_collect (tree : tree) (path : Concepts.Path.t) : + (tree * disposal BatFingerTree.t, Concepts.Condition.condition) result = + cascade tree BatFingerTree.empty path + +(* Close a handle, then see whether the object can now go. *) +let unmonitor (tree : tree) (path : Concepts.Path.t) : + (tree * disposal BatFingerTree.t, Concepts.Condition.condition) result = + let tree = + Object.update path + (fun r -> + if r.Object.handle_count = 0 then r + else {r with Object.handle_count= r.Object.handle_count - 1} ) + tree + in + try_collect tree path + +(* Public entry point for an explicit collection request. *) +let collect (tree : tree) (path : Concepts.Path.t) : + (tree * disposal BatFingerTree.t, Concepts.Condition.condition) result = + try_collect tree path + +(* Session reaping is not built here yet. A lost connection is detected by a + per-session inactivity timer whose expiry drives collect on the session. + Design and tasks are tracked in issue #24. *) diff --git a/lib/backend/managers/Lifecycle.mli b/lib/backend/managers/Lifecycle.mli new file mode 100644 index 0000000..f8cec1a --- /dev/null +++ b/lib/backend/managers/Lifecycle.mli @@ -0,0 +1,17 @@ +type tree = Object.rnt_object_tree + +(* A collected runtime object that still needs an external teardown: a session + to close, and later a transaction to roll back. The caller drains these. *) +type disposal = {path: Concepts.Path.t; kind: Object.rnt_object_kind} + +val monitor : tree -> Concepts.Path.t -> tree +val pin : tree -> Concepts.Path.t -> tree +val unpin : tree -> Concepts.Path.t -> tree +val is_eligible_for_gc : tree -> Concepts.Path.t -> bool +val contention : tree -> Concepts.Path.t -> bool + +val unmonitor : + tree -> Concepts.Path.t -> (tree * disposal BatFingerTree.t, Concepts.Condition.condition) result + +val collect : + tree -> Concepts.Path.t -> (tree * disposal BatFingerTree.t, Concepts.Condition.condition) result diff --git a/lib/backend/managers/Namespace.ml b/lib/backend/managers/Namespace.ml new file mode 100644 index 0000000..61b1eff --- /dev/null +++ b/lib/backend/managers/Namespace.ml @@ -0,0 +1,9 @@ +module Make (Store : Abstract.Storage.STORAGE) = struct + type tree = Object.rnt_object_tree + + let resolve (_txn : Store.transaction) (_tree : tree) (_path : Concepts.Path.t) : + (Concepts.Path.t, Concepts.Condition.condition) result = + failwith + "NOT IMPLEMENTED: reparse loop with cycle guard; /system/branches/<n>/<sub> -> \ + /system/snapshots/<target_hash>/<sub> via Branch.target_hash" +end diff --git a/lib/backend/managers/Namespace.mli b/lib/backend/managers/Namespace.mli new file mode 100644 index 0000000..1ee9651 --- /dev/null +++ b/lib/backend/managers/Namespace.mli @@ -0,0 +1,9 @@ +module Make (Store : Abstract.Storage.STORAGE) : sig + type tree = Object.rnt_object_tree + + val resolve : + Store.transaction -> + tree -> + Concepts.Path.t -> + (Concepts.Path.t, Concepts.Condition.condition) result +end 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) @@ -14,6 +14,7 @@ depends: [ "batteries" "digestif" "alcotest" {with-test} + "qcheck-alcotest" {with-test} "ocaml-lsp-server" {with-dev-setup} "odoc" {with-doc} ] @@ -2,4 +2,4 @@ (test (name test_rnt) - (libraries rnt alcotest)) + (libraries rnt alcotest qcheck-core qcheck-alcotest batteries)) diff --git a/test/test_rnt.ml b/test/test_rnt.ml index 5dd79cf..7173837 100644 --- a/test/test_rnt.ml +++ b/test/test_rnt.ml @@ -1,2 +1,2 @@ -let all_suites = Unit.Backend.Storage.suites () +let all_suites = Unit.Backend.Storage.suites () @ Unit.Backend.Lifecycle.suites () let () = Alcotest.run "RNT" all_suites diff --git a/test/unit/backend/Lifecycle.ml b/test/unit/backend/Lifecycle.ml new file mode 100644 index 0000000..3e5b3e9 --- /dev/null +++ b/test/unit/backend/Lifecycle.ml @@ -0,0 +1,147 @@ +module Object = Rnt.Backend.Managers.Object +module Lifecycle = Rnt.Backend.Managers.Lifecycle +module Path = Rnt.Concepts.Path + +(* Small builders so the tests read like the invariants they check. *) + +let path segments = Path.of_list segments +let relation name = Object.make_object (Object.Relation {merkle_root= name}) + +let session () = + Object.make_object (Object.Session {connection_context= (); branch_overrides= BatMap.String.empty}) + +let branch name = Object.make_object (Object.Branch {name; target_hash= "hash"}) +let namespace label = Object.make_object (Object.Namespace {label; predicate= (fun _ -> true)}) +let dependencies paths = List.fold_left BatFingerTree.snoc BatFingerTree.empty paths + +let ephemeral name deps = + Object.make_object (Object.EphemeralRelation {merkle_root= name; dependencies= dependencies deps}) + +let register_exn tree p object' = Helpers.condition_as_failure (Object.register p object' tree) +let unregister_exn tree p = Helpers.condition_as_failure (Object.unregister p tree) +let collect_exn tree p = Helpers.condition_as_failure (Lifecycle.collect tree p) + +let reference_count tree p = + match Object.find p tree with Some r -> r.Object.reference_count | None -> -1 + +let present tree p = Object.find p tree <> None + +(* An ephemeral relation holds its inputs resident. Registering it raises the + input's reference_count; unregistering it lowers it again. This is the + distinction between reference counting (real edges) and pinning. *) +let test_edges_track_dependents () = + let tree = register_exn Object.root (path ["r1"]) (relation "r1") in + let tree = register_exn tree (path ["er1"]) (ephemeral "er1" [path ["r1"]]) in + Alcotest.(check int) + "dependent raises the input's reference count" 1 + (reference_count tree (path ["r1"])); + let tree = unregister_exn tree (path ["er1"]) in + Alcotest.(check int) + "removing the dependent releases the input" 0 + (reference_count tree (path ["r1"])) + +(* The four gates of eligibility, each shown to block on its own. *) +let test_eligibility_gates () = + let tree = register_exn Object.root (path ["r1"]) (relation "r1") in + Alcotest.(check bool) + "a fresh durable object is collectable" true + (Lifecycle.is_eligible_for_gc tree (path ["r1"])); + Alcotest.(check bool) + "an open handle blocks collection" false + (Lifecycle.is_eligible_for_gc (Lifecycle.monitor tree (path ["r1"])) (path ["r1"])); + Alcotest.(check bool) + "a pin blocks collection" false + (Lifecycle.is_eligible_for_gc (Lifecycle.pin tree (path ["r1"])) (path ["r1"])); + let with_branch = register_exn Object.root (path ["b1"]) (branch "b1") in + Alcotest.(check bool) + "a branch is exempt even with zero counts" false + (Lifecycle.is_eligible_for_gc with_branch (path ["b1"])) + +(* Collecting a dependent cascades into the inputs it releases, and the input + cannot be collected first while the dependent is alive. *) +let test_cascade_follows_edges () = + let tree = register_exn Object.root (path ["r1"]) (relation "r1") in + let tree = register_exn tree (path ["er1"]) (ephemeral "er1" [path ["r1"]]) in + Alcotest.(check bool) + "a live dependent keeps its input" false + (Lifecycle.is_eligible_for_gc tree (path ["r1"])); + let tree, disposals = collect_exn tree (path ["er1"]) in + Alcotest.(check bool) "the dependent is collected" false (present tree (path ["er1"])); + Alcotest.(check bool) "the released input is cascaded out" false (present tree (path ["r1"])); + Alcotest.(check int) "durable collection needs no disposal" 0 (BatFingerTree.size disposals) + +(* A pin overrides the cascade: the input stays even after its dependent goes. *) +let test_pin_survives_cascade () = + let tree = register_exn Object.root (path ["r1"]) (relation "r1") in + let tree = register_exn tree (path ["er1"]) (ephemeral "er1" [path ["r1"]]) in + let tree = Lifecycle.pin tree (path ["r1"]) in + let tree, _ = collect_exn tree (path ["er1"]) in + Alcotest.(check bool) "the dependent is still collected" false (present tree (path ["er1"])); + Alcotest.(check bool) "the pinned input survives" true (present tree (path ["r1"])) + +(* Collecting a runtime object surfaces a disposal for the caller to run, + because there is no durable form to rehydrate from. *) +let test_runtime_collection_surfaces_disposal () = + let tree = register_exn Object.root (path ["s1"]) (session ()) in + let tree, disposals = collect_exn tree (path ["s1"]) in + Alcotest.(check bool) "the session is removed" false (present tree (path ["s1"])); + match BatFingerTree.front disposals with + | Some (rest, {Lifecycle.kind= Object.Session _; _}) when BatFingerTree.is_empty rest -> () + | _ -> Alcotest.fail "expected exactly one session disposal" + +(* A namespace with objects under it is scaffolding, so it is kept rather than + collected, and this is not an error. *) +let test_populated_namespace_is_kept () = + let tree = register_exn Object.root (path ["ns"]) (namespace "ns") in + let tree = register_exn tree (path ["ns"; "r1"]) (relation "r1") in + let tree, _ = collect_exn tree (path ["ns"]) in + Alcotest.(check bool) "a populated namespace is kept" true (present tree (path ["ns"])) + +(* Property: pinning is a decision, reference counting is bookkeeping. No + sequence of pin/unpin may ever move the reference count. *) +let prop_pin_never_moves_reference_count = + QCheck.Test.make ~name:"pin/unpin never changes reference_count" ~count:200 + QCheck.(list bool) + (fun operations -> + let tree = register_exn Object.root (path ["r1"]) (relation "r1") in + let tree = + List.fold_left + (fun tree pin -> + if pin then Lifecycle.pin tree (path ["r1"]) else Lifecycle.unpin tree (path ["r1"]) ) + tree operations + in + reference_count tree (path ["r1"]) = 0 ) + +(* Property: reference edges are balanced. Registering an ephemeral relation + over any selection of inputs and then unregistering it returns every input + to its baseline count, whatever the selection or its duplicates. *) +let prop_edges_are_balanced = + QCheck.Test.make ~name:"register then unregister an ER restores input counts" ~count:200 + QCheck.(pair (int_range 1 5) (list (int_range 0 4))) + (fun (input_count, selection) -> + let inputs = List.init input_count (fun i -> path [Printf.sprintf "r%d" i]) in + let tree = + List.fold_left + (fun tree p -> register_exn tree p (relation (Path.to_string p))) + Object.root inputs + in + let chosen = + List.filter (fun i -> i < input_count) selection + |> List.map (fun i -> path [Printf.sprintf "r%d" i]) + in + let tree = register_exn tree (path ["er"]) (ephemeral "er" chosen) in + let tree = unregister_exn tree (path ["er"]) in + List.for_all (fun p -> reference_count tree p = 0) inputs ) + +let suites () = + [ ( "lifecycle/registry", + [ Alcotest.test_case "edges track dependents" `Quick test_edges_track_dependents; + Alcotest.test_case "eligibility gates" `Quick test_eligibility_gates; + Alcotest.test_case "cascade follows edges" `Quick test_cascade_follows_edges; + Alcotest.test_case "pin survives cascade" `Quick test_pin_survives_cascade; + Alcotest.test_case "runtime collection surfaces disposal" `Quick + test_runtime_collection_surfaces_disposal; + Alcotest.test_case "populated namespace is kept" `Quick test_populated_namespace_is_kept ] ); + ( "lifecycle/properties", + List.map QCheck_alcotest.to_alcotest + [prop_pin_never_moves_reference_count; prop_edges_are_balanced] ) ] |