session exclusive lifetime

4 files changed, 24 insertions, 8 deletions

diff --git a/lib/kernel/Lifecycle.ml b/lib/kernel/Lifecycle.ml
index bf0b544..ac6bb20 100644
--- a/lib/kernel/Lifecycle.ml
+++ b/lib/kernel/Lifecycle.ml
@@ -14,6 +14,13 @@ class null =
     method release = ()
   end
 
+class exclusive =
+  object
+    val taken = Atomic.make false
+    method reference = Atomic.compare_and_set taken false true
+    method release = Atomic.set taken false
+  end
+
 class virtual counted =
   object (self)
     val references = Atomic.make 1
diff --git a/lib/kernel/Lifecycle.mli b/lib/kernel/Lifecycle.mli
index fa3abee..d4ef178 100644
--- a/lib/kernel/Lifecycle.mli
+++ b/lib/kernel/Lifecycle.mli
@@ -9,6 +9,7 @@ class type virtual controlled_lifecycle = object
 end
 
 class null : lifecycle
+class exclusive : lifecycle
 class virtual counted : controlled_lifecycle
 
 (** stands for [inner], carrying what it carries, while holding a
diff --git a/lib/kernel/Path.ml b/lib/kernel/Path.ml
index 9e3c52f..77a6b54 100644
--- a/lib/kernel/Path.ml
+++ b/lib/kernel/Path.ml
@@ -37,14 +37,22 @@ let walking f g handle path =
   |> Result.map_error
        Concepts.Condition.(complement ("path" |=| Concepts.Value.String (to_string path)))
 
-let lookup = walking (fun _ _ f -> f ()) Result.ok
+(* Handles we find in the middle of a walk get released once we're
+   done with them, but never the caller's root.  If you leak one and
+   its refcount never drops, nothing under that path gets collected,
+   and an exclusive object, like a session, stays locked forever. *)
+let releasing root handle f =
+  Fun.protect ~finally:(fun () -> if handle != root then Protocols.Handle.release handle) f
+
+let lookup handle path = walking (fun _ parent -> releasing handle parent) Result.ok handle path
 
 let update handle path key reference value =
   let open Utilities.Result in
   let open Protocols in
-  let* handle = lookup handle path in
-  let* registry = Handle.require Registry.from handle in
-  Registry.update registry key reference value
+  let* target = lookup handle path in
+  releasing handle target (fun () ->
+      let* registry = Handle.require Registry.from target in
+      Registry.update registry key reference value )
 
 let assoc handle path key value =
   let open Utilities.Result in
@@ -56,6 +64,7 @@ let assoc handle path key value =
     Ok (Handle.from a')
   in
   walking
-    (fun key dir f -> f () |> fmap (assoc_on dir key |.| Option.some))
-    (fun h -> assoc_on h key value)
+    (fun key dir f ->
+      releasing handle dir (fun () -> f () |> fmap (assoc_on dir key |.| Option.some)) )
+    (fun h -> releasing handle h (fun () -> assoc_on h key value))
     handle path
diff --git a/lib/kernel/Session.ml b/lib/kernel/Session.ml
index 75bf8c9..322d0e0 100644
--- a/lib/kernel/Session.ml
+++ b/lib/kernel/Session.ml
@@ -4,7 +4,7 @@ module Make (S : Abstract.Storage.STORAGE) = struct
 
   class session storage state =
     object (self)
-      inherit Lifecycle.null
+      inherit Lifecycle.exclusive
       inherit Identity.of_id
       method to_string = "session"
       val storage : S.connection = storage
@@ -13,7 +13,6 @@ module Make (S : Abstract.Storage.STORAGE) = struct
       method pin state' = Atomic.set state state'
       method protocols = Protocols.[Directory.make self; Session.make self]
       method list = Ok (BatFingerTree.singleton "branch")
-
       method find =
         function
         | "branch" ->