aboutsummaryrefslogtreecommitdiffstats
path: root/test
diff options
context:
space:
mode:
Diffstat (limited to 'test')
-rw-r--r--test/Helpers.ml29
-rw-r--r--test/integration/Registration.ml46
-rw-r--r--test/test_rnt.ml1
-rw-r--r--test/unit/evaluators/FOL.ml43
-rw-r--r--test/unit/kernel/Branch.ml167
-rw-r--r--test/unit/kernel/EphemeralRelation.ml6
-rw-r--r--test/unit/kernel/Merkle.ml32
-rw-r--r--test/unit/kernel/Session.ml39
8 files changed, 318 insertions, 45 deletions
diff --git a/test/Helpers.ml b/test/Helpers.ml
index f812a3a..ecd3985 100644
--- a/test/Helpers.ml
+++ b/test/Helpers.ml
@@ -18,6 +18,15 @@ let condition_as_failure = function
let pp_value ppf v = Format.pp_print_string ppf (Concepts.Value.to_string v)
let value = Alcotest.testable pp_value Concepts.Value.equal
+(* the titles a relation of books holds, in order *)
+let titles relation =
+ let open Utilities.Result in
+ let* _, tuples = Protocols.Relation.read relation in
+ Ok
+ ( tuples
+ |> List.map (fun tuple -> BatMap.String.find "title" tuple.Concepts.Tuple.attributes)
+ |> List.sort compare )
+
module Storage = struct
module type CONFIGURATOR = sig
val configure : string -> Rnt.Concepts.Configuration.term
@@ -40,21 +49,13 @@ module Storage = struct
let relation conn attributes tuples =
let open Utilities.Result in
- let* value =
- SI.with_transaction conn (fun tx ->
- let* schematics = store_schema tx attributes in
- let* _ = SR.TupleSet.empty_under tx in
- let* node =
- List.fold_left
- (fun node tuple ->
- let* node = node in
- SR.TupleSet.insert tx (Concepts.Tuple.hash tuple) tuple node )
- (Ok SR.TupleSet.empty) tuples
- in
- let relation = {SR.schematics; tuples= SR.TupleSet.hash_of node} in
- let* _ = SI.store_blob tx (SR.encode relation) in
- Ok relation )
+ let description =
+ BatMap.String.of_list
+ (List.map
+ (fun a -> a, {Protocols.Schematics.domain= "string"; provenance= []})
+ attributes )
in
+ let* value = SI.with_transaction conn (fun tx -> SR.store tx description tuples) in
SR.load conn value
let with_connection f dir () =
diff --git a/test/integration/Registration.ml b/test/integration/Registration.ml
index 693435b..2060ae6 100644
--- a/test/integration/Registration.ml
+++ b/test/integration/Registration.ml
@@ -6,49 +6,63 @@ module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) =
module I = Kernel.Initialization.Make (S)
module B = Kernel.Branch.Make (S)
module M = Kernel.Multigroup.Make (S)
- module R = Kernel.SubstantialRelation.Make (S)
module E = Kernel.EphemeralRelation.Make (S)
- let book = Kernel.Path.("multigroup" @/ "library" @/ "relation" @/ "book" @/ this)
- let shelf = Kernel.Path.("multigroup" @/ "library" @/ "relation" @/ "shelf" @/ this)
+ let book =
+ Kernel.Path.("multigroup" @/ "library" @/ "schema" @/ "default" @/ "relation" @/ "book" @/ this)
+
+ let shelf =
+ Kernel.Path.("multigroup" @/ "library" @/ "schema" @/ "default" @/ "relation" @/ "shelf" @/ this)
+
+ let stacks = Kernel.Path.("system" @/ "branch" @/ "stacks" @/ this)
+
+ let titled title =
+ { Concepts.Tuple.type_= "book";
+ attributes=
+ BatMap.String.of_list
+ ["title", Concepts.Value.String title; "author", Concepts.Value.String "Date"] }
let run conn =
let open Utilities.Result in
begin
let* root = I.initialize ~evaluators:["fol", Evaluators.FOL.make ()] conn in
- let* multigroup = M.make conn in
- let* schematics = H.SI.with_transaction conn (fun tx -> H.store_schema tx ["title"]) in
- let* relation = R.instantiate conn ~schematics in
- let* multigroup =
- Kernel.Path.(assoc multigroup ("relation" @/ this) "book" (Some relation))
- in
+ let* relation = H.relation conn ["title"; "author"] [titled "SQL and Relational Theory"] in
let* view =
E.persist conn ~name:"shelf" ~evaluator:Evaluators.FOL.name
~code:Evaluators.FOL.(encode (Project (Base book, BatFingerTree.singleton "title")))
(BatMap.String.singleton "title" {Protocols.Schematics.domain= "string"; provenance= []})
in
- let* multigroup = Kernel.Path.(assoc multigroup ("relation" @/ this) "shelf" (Some view)) in
+ let* multigroup = M.make conn in
+ let relations = Kernel.Path.("schema" @/ "default" @/ "relation" @/ this) in
+ let* multigroup =
+ Kernel.Path.assoc_all multigroup
+ [relations, "book", Some relation; relations, "shelf", Some view]
+ in
let* branch = B.make conn in
let* branch' =
Kernel.Path.(assoc branch ("multigroup" @/ this) "library" (Some multigroup))
in
- Kernel.Path.(update root ("branch" @/ this) "master" None (Some branch'))
+ Kernel.Path.(update root ("system" @/ "branch" @/ this) "stacks" None (Some branch'))
end
|> Helpers.condition_as_failure
|> ignore;
- let attributes =
+ let attributes, shelved =
begin
let* root = I.initialize ~evaluators:["fol", Evaluators.FOL.make ()] conn in
- let* branch = Kernel.Path.(lookup root ("branch" @/ "master" @/ this)) in
+ let* branch = Kernel.Path.lookup root stacks in
let* _ = Kernel.Path.lookup branch book in
- let* _ = Kernel.Path.(lookup root ("evaluator" @/ "fol" @/ this)) in
let* plan = Evaluators.FOL.(instantiate (Kernel.Path.lookup branch) (Base shelf)) in
let* description = Evaluators.FOL.describe plan in
- Ok (BatMap.String.keys description |> BatList.of_enum)
+ let* view = Kernel.Path.lookup branch shelf in
+ let* shelved = Helpers.titles view in
+ Ok (BatMap.String.keys description |> BatList.of_enum, shelved)
end
|> Helpers.condition_as_failure
in
- check (list string) "the stored view reads the book it was defined over" ["title"] attributes
+ check (list string) "the stored view reads the book it was defined over" ["title"] attributes;
+ check (list Helpers.value) "read through the branch, the stored view runs"
+ [Concepts.Value.String "SQL and Relational Theory"]
+ shelved
let suite =
( "registration",
diff --git a/test/test_rnt.ml b/test/test_rnt.ml
index da8c008..c6fcfd5 100644
--- a/test/test_rnt.ml
+++ b/test/test_rnt.ml
@@ -5,6 +5,7 @@ let all_suites =
@ Unit.Kernel.Merkle.suites ()
@ Unit.Kernel.SubstantialRelation.suites ()
@ Unit.Kernel.Session.suites ()
+ @ Unit.Kernel.Branch.suites ()
@ Unit.Evaluators.FOL.suites ()
@ Integration.Registration.suites ()
diff --git a/test/unit/evaluators/FOL.ml b/test/unit/evaluators/FOL.ml
index 0a3dabc..a0789aa 100644
--- a/test/unit/evaluators/FOL.ml
+++ b/test/unit/evaluators/FOL.ml
@@ -23,6 +23,9 @@ module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) =
BatMap.String.of_list ["name", Concepts.Value.String name; "age", Concepts.Value.Integer age]
}
+ (* a plan comes resolved, so it reads nothing through [within] *)
+ let nowhere = Kernel.Prototype.mixture []
+
let drain result =
let open Utilities.Result in
let* enumerable = Protocols.Enumerable.require result in
@@ -50,7 +53,8 @@ module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) =
let* evaluator = Option.to_result ~none:(missing "fol") found in
let* evaluator = Protocols.Evaluator.require evaluator in
let* result =
- Rnt.Evaluators.FOL.(program (Base employee)) |> Protocols.Evaluator.invoke evaluator
+ Rnt.Evaluators.FOL.(program (Base employee))
+ |> Protocols.Evaluator.invoke evaluator ~within:nowhere
in
drain result
end
@@ -74,7 +78,7 @@ module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) =
let* evaluator = Protocols.Evaluator.require (Rnt.Evaluators.FOL.make ()) in
let* result =
Rnt.Evaluators.FOL.(program (Project (Base employees, BatFingerTree.singleton "name")))
- |> Protocols.Evaluator.invoke evaluator
+ |> Protocols.Evaluator.invoke evaluator ~within:nowhere
in
drain result
end
@@ -100,7 +104,9 @@ module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) =
(Project (Base Kernel.Path.("employee" @/ this), BatFingerTree.singleton "name")) )
in
let* evaluator = Protocols.Evaluator.require (Rnt.Evaluators.FOL.make ()) in
- let* result = Rnt.Evaluators.FOL.program plan |> Protocols.Evaluator.invoke evaluator in
+ let* result =
+ Rnt.Evaluators.FOL.program plan |> Protocols.Evaluator.invoke evaluator ~within:nowhere
+ in
drain result
end
|> Helpers.condition_as_failure
@@ -147,7 +153,9 @@ module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) =
instantiate (Kernel.Path.lookup root) (Base Kernel.Path.("view" @/ this)) )
in
let* evaluator = Protocols.Evaluator.require (Rnt.Evaluators.FOL.make ()) in
- let* result = Rnt.Evaluators.FOL.program plan |> Protocols.Evaluator.invoke evaluator in
+ let* result =
+ Rnt.Evaluators.FOL.program plan |> Protocols.Evaluator.invoke evaluator ~within:nowhere
+ in
drain result
end
|> Helpers.condition_as_failure
@@ -158,6 +166,29 @@ module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) =
[["name", Concepts.Value.String "Alaric"]]
(projected |> List.map (fun tuple -> BatMap.String.bindings tuple.Concepts.Tuple.attributes))
+ let run_a_stored_program_within conn =
+ let projected =
+ begin
+ let open Utilities.Result in
+ let* employees = H.relation conn ["name"; "age"] [employee "Alaric" 42] in
+ let* view =
+ store conn
+ Rnt.Evaluators.FOL.(
+ Project (Base Kernel.Path.("employee" @/ this), BatFingerTree.singleton "name") )
+ in
+ let* root = namespace ["employee", employees] in
+ let* evaluator = Protocols.Evaluator.require (Rnt.Evaluators.FOL.make ()) in
+ let* result = Protocols.Evaluator.invoke evaluator view ~within:root in
+ drain result
+ end
+ |> Helpers.condition_as_failure
+ in
+ check
+ (list (list (pair string Helpers.value)))
+ "the stored source read its relations where it was told to"
+ [["name", Concepts.Value.String "Alaric"]]
+ (projected |> List.map (fun tuple -> BatMap.String.bindings tuple.Concepts.Tuple.attributes))
+
let refuse_a_program_that_reads_itself conn =
let expanded =
begin
@@ -197,7 +228,7 @@ module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) =
let* evaluator = Protocols.Evaluator.require (Rnt.Evaluators.FOL.make ()) in
let* result =
Rnt.Evaluators.FOL.(program (Project (Base source, BatFingerTree.singleton "value")))
- |> Protocols.Evaluator.invoke evaluator
+ |> Protocols.Evaluator.invoke evaluator ~within:nowhere
in
let* enumerable = Protocols.Enumerable.require result in
let* cursor = Protocols.Enumerable.enumerate enumerable in
@@ -220,6 +251,8 @@ module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) =
(H.with_connection instantiate_a_program "fol-test");
test_case "expand-a-stored-program" `Quick
(H.with_connection expand_a_stored_program "fol-test");
+ test_case "run-a-stored-program-within" `Quick
+ (H.with_connection run_a_stored_program_within "fol-test");
test_case "refuse-a-program-that-reads-itself" `Quick
(H.with_connection refuse_a_program_that_reads_itself "fol-test");
test_case "pull-one-tuple-at-a-time" `Quick pull_one_tuple_at_a_time ] )
diff --git a/test/unit/kernel/Branch.ml b/test/unit/kernel/Branch.ml
new file mode 100644
index 0000000..ebce298
--- /dev/null
+++ b/test/unit/kernel/Branch.ml
@@ -0,0 +1,167 @@
+open Alcotest
+module K = Rnt.Kernel
+module P = Rnt.Protocols
+module C = Rnt.Concepts
+
+let ok = Helpers.condition_as_failure
+let library = {K.Scope.multigroup= "library"; schema= "default"}
+let master = K.Path.("system" @/ "branch" @/ "master" @/ this)
+let under a b = K.Path.(of_list (to_list a @ to_list b))
+let shelf = K.Scope.path library "shelf"
+let s v = C.Value.String v
+let title = BatMap.String.singleton "title" {P.Schematics.domain= "string"; provenance= []}
+
+let books titles =
+ K.EphemeralRelation.literal title
+ (List.map
+ (fun t -> {C.Tuple.type_= "book"; attributes= BatMap.String.singleton "title" (s t)})
+ titles )
+
+let titles relation = ok (Helpers.titles relation)
+let read root path = titles (ok (K.Path.lookup root path))
+
+(* shelf is a stored FOL program reading book where it is stored *)
+let shelved =
+ K.Source.view ~language:"fol" ~heading:title
+ ( Rnt.Evaluators.FOL.(encode (Base (K.Scope.path library "book")))
+ |> C.Blob.bytes_of_blob
+ |> Bytes.to_string )
+
+let publish root changes = ok (K.Scope.publish root ~branch:"master" ~home:library changes)
+
+let fresh books' =
+ let root = ok (Rnt.Scratch.root ()) in
+ publish root ["book", Some (books books'); "shelf", Some shelved];
+ root
+
+let address handle = P.Addressable.address (Option.get (P.Addressable.from handle))
+
+let reads_as_of_each_state () =
+ let root = fresh ["Codd"] in
+ publish root ["book", Some (books ["Codd"; "Date"])];
+ check (list Helpers.value) "the head's view reads the books as they are"
+ [s "Codd"; s "Date"]
+ (read root (under master shelf));
+ check (list Helpers.value) "the previous state's view reads them as they were"
+ [s "Codd"]
+ (read root (under master K.Path.("previous" @/ shelf)))
+
+let a_batch_is_one_successor () =
+ let root = fresh ["Codd"] in
+ let head = ok (K.Path.lookup root master) in
+ publish root ["book", Some (books ["Date"]); "loan", Some (books ["Codd"])];
+ let next = ok (K.Path.lookup root master) in
+ let previous = ok (K.Path.lookup next K.Path.("previous" @/ this)) in
+ check bool "two changes, one state after the head" true
+ (C.Hash.hash_equals (address previous) (address head));
+ let changed =
+ ok
+ (K.Path.diff
+ (ok (K.Path.lookup head K.Path.("multigroup" @/ this)))
+ (ok (K.Path.lookup next K.Path.("multigroup" @/ this))) )
+ in
+ check
+ (list (list string))
+ "the diff names what changed and nothing else"
+ [ ["library"; "schema"; "default"; "relation"; "book"];
+ ["library"; "schema"; "default"; "relation"; "loan"] ]
+ (List.map K.Path.to_list changed)
+
+let unbinding_removes_a_relation () =
+ let root = fresh ["Codd"] in
+ publish root ["shelf", None];
+ check bool "shelf is gone" true (Result.is_error (K.Path.lookup root (under master shelf)));
+ check (list Helpers.value) "book stays"
+ [s "Codd"]
+ (read root (under master (K.Scope.path library "book")))
+
+let a_scope_reads_names_from_its_home () =
+ let root = fresh ["Codd"] in
+ K.Scope.publish root ~branch:"master"
+ ~home:{K.Scope.multigroup= "store"; schema= "default"}
+ ["stock", Some (books ["Date"]); "archive:old", Some (books ["Codd"])]
+ |> ok;
+ let scope = ok (K.Scope.of_root root ~branch:"master" library) in
+ let directory = Option.get (P.Directory.from scope) in
+ let found name = ok (P.Directory.find directory name) |> Option.map titles in
+ check
+ (option (list Helpers.value))
+ "a bare name is the home schema's"
+ (Some [s "Codd"])
+ (found "book");
+ check
+ (option (list Helpers.value))
+ "schema:name stays in the home multigroup"
+ (Some [s "Codd"])
+ (found "default:book");
+ check
+ (option (list Helpers.value))
+ "multigroup:schema:name leaves it"
+ (Some [s "Date"])
+ (found "store:default:stock");
+ check (option (list Helpers.value)) "what is not there is not found" None (found "stock");
+ check
+ (option (list Helpers.value))
+ "four parts name an attribute, not a relation" None
+ (found "library:default:book:title");
+ let catalog = ok (K.Scope.catalog (ok (K.Scope.require scope))) in
+ check (list string) "the catalog is every relation of the state"
+ ["library:default:book"; "library:default:shelf"; "store:archive:old"; "store:default:stock"]
+ (List.sort compare catalog);
+ check (option string) "a qualified attribute names the relation's own" (Some "title")
+ (K.Scope.attribute library "book" "library:default:book:title");
+ check (option string) "but not another relation's" None
+ (K.Scope.attribute library "book" "shelf:title")
+
+(* A toy language answers a stored relation with its own name, and a run
+ with the source it was given. *)
+let a_stored_relation_is_viewed_and_a_program_run () =
+ let root = fresh ["Codd"] in
+ let answer text = Ok (books [text]) in
+ let toy =
+ K.Source.evaluator ~language:"toy"
+ ~view:(fun ~within:_ ~name source -> answer (name ^ " of " ^ source))
+ (fun ~within:_ source -> answer source)
+ in
+ let _ = ok (K.Initialization.mount root "toys") in
+ ok (K.Source.register root ~scope:"toys" ~language:"toy" toy);
+ publish root ["named", Some (K.Source.view ~language:"toys:toy" ~heading:title "this")];
+ check (list Helpers.value) "read from the branch, the view is asked for it by name"
+ [s "named of this"]
+ (read root (under master (K.Scope.path library "named")));
+ check (list Helpers.value) "run, the program is just run"
+ [s "that"]
+ (titles (ok (K.Source.run root ~language:"toys:toy" ~within:root "that")));
+ check bool "an unqualified name is the system's" true
+ (Result.is_error (K.Source.run root ~language:"toy" ~within:root "that"))
+
+(* shelf, stored as a denial, says no book may be shelved *)
+let a_head_moves_only_to_a_valid_state () =
+ let root = fresh [] in
+ publish root ["denial:no-books", Some shelved];
+ let head = ok (K.Path.lookup root master) in
+ let proposed =
+ ok
+ (K.Path.assoc_all head
+ [ ( K.Path.("multigroup" @/ "library" @/ "schema" @/ "default" @/ "relation" @/ this),
+ "book",
+ Some (books ["Codd"]) ) ] )
+ in
+ check bool "a state with a book is judged invalid without landing" true
+ (Result.is_error (K.Denial.check proposed));
+ check bool "publishing it is refused" true
+ (Result.is_error
+ (K.Scope.publish root ~branch:"master" ~home:library ["book", Some (books ["Codd"])]) );
+ check bool "and the head stays" true
+ (C.Hash.hash_equals (address head) (address (ok (K.Path.lookup root master))))
+
+let suites () =
+ [ ( "kernel/branch",
+ [ test_case "reads-as-of-each-state" `Quick reads_as_of_each_state;
+ test_case "a-batch-is-one-successor" `Quick a_batch_is_one_successor;
+ test_case "unbinding-removes-a-relation" `Quick unbinding_removes_a_relation;
+ test_case "a-scope-reads-names-from-its-home" `Quick a_scope_reads_names_from_its_home;
+ test_case "a-stored-relation-is-viewed-and-a-program-run" `Quick
+ a_stored_relation_is_viewed_and_a_program_run;
+ test_case "a-head-moves-only-to-a-valid-state" `Quick a_head_moves_only_to_a_valid_state ] )
+ ]
diff --git a/test/unit/kernel/EphemeralRelation.ml b/test/unit/kernel/EphemeralRelation.ml
index d7ffa92..7f113ef 100644
--- a/test/unit/kernel/EphemeralRelation.ml
+++ b/test/unit/kernel/EphemeralRelation.ml
@@ -97,9 +97,9 @@ let releasing_releases_its_inputs () =
let released = ref false in
let input =
object
- inherit Rnt.Kernel.Lifecycle.null
- inherit Rnt.Kernel.Identity.of_id
- method! release = released := true
+ method reference = true
+ method release = released := true
+ method hash = Concepts.Hash.hash_of_int 0
method to_string = "input"
method protocols : Protocols.Handle.protocol list = []
end
diff --git a/test/unit/kernel/Merkle.ml b/test/unit/kernel/Merkle.ml
index 9d0dc6e..5c8d761 100644
--- a/test/unit/kernel/Merkle.ml
+++ b/test/unit/kernel/Merkle.ml
@@ -126,12 +126,42 @@ module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) =
(* let determinism _conn = *)
(* () *)
+ (* Enough keys for the tree to grow trunks, so removal reaches through
+ them and empties whole leaves. *)
+ let removal conn =
+ let kept, gone, keys, emptied =
+ begin
+ let open Utilities.Result in
+ let* tx = S.start conn in
+ let key i = Printf.sprintf "k%03d" i in
+ let all = List.init 300 key in
+ let* full = List.fold_left (fun node k -> fmap (T.insert tx k k) node) (Ok T.empty) all in
+ let evens = List.filteri (fun i _ -> i mod 2 = 0) all in
+ let* half = List.fold_left (fun node k -> fmap (T.remove tx k) node) (Ok full) evens in
+ let* kept = T.lookup tx (key 1) half in
+ let* gone = T.lookup tx (key 2) half in
+ let* keys = T.keys tx half in
+ let* none = List.fold_left (fun node k -> fmap (T.remove tx k) node) (Ok half) all in
+ let* () = S.abort tx in
+ Ok (kept, gone, BatFingerTree.to_list keys, T.hash_of none)
+ end
+ |> Helpers.condition_as_failure
+ in
+ check (option string) "a key not removed stays" (Some "k001") kept;
+ check (option string) "a removed key is gone" None gone;
+ check (list string) "exactly the odd keys remain"
+ (List.init 150 (fun i -> Printf.sprintf "k%03d" ((2 * i) + 1)))
+ keys;
+ check bool "removing every key leaves the empty tree" true
+ (Concepts.Hash.hash_equals emptied (T.hash_of T.empty))
+
let suite =
( "kernel/merkle",
[ test_case "insert-and-lookup" `Quick (H.with_connection insert_and_lookup "merkle-test");
test_case "batching" `Quick (H.with_connection batching "merkle-test");
test_case "persistence" `Quick (H.with_connection persistence "merkle-test");
- test_case "iteration" `Quick (H.with_connection iteration "merkle-test") ] )
+ test_case "iteration" `Quick (H.with_connection iteration "merkle-test");
+ test_case "removal" `Quick (H.with_connection removal "merkle-test") ] )
end
module LMDB = Make (Rnt.Backend.Storage.LMDB) (Helpers.Storage.LMDB_Configurator)
diff --git a/test/unit/kernel/Session.ml b/test/unit/kernel/Session.ml
index 3ae549f..79ad5a2 100644
--- a/test/unit/kernel/Session.ml
+++ b/test/unit/kernel/Session.ml
@@ -22,21 +22,25 @@ module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) =
let open Rnt.Kernel.Path in
let* root = I.initialize conn in
let* branch = B.make conn in
- let* _ = update root ("branch" @/ this) "master" None (Some branch) in
+ let* _ = update root ("system" @/ "branch" @/ this) "client" None (Some branch) in
let* tip = address branch in
let session = Session.make conn {Protocols.Session.snapshot= tip} in
- let* _ = update root ("session" @/ this) "client" None (Protocols.Handle.copy session) in
- let library = "session" @/ "client" @/ "branch" @/ "multigroup" @/ "library" @/ this in
+ let* _ = update root ("system" @/ "session" @/ this) "client" None (Some session) in
+ let library =
+ "system" @/ "session" @/ "client" @/ "branch" @/ "multigroup" @/ "library" @/ this
+ in
let before = finds root library in
let* multigroup = M.make conn in
let* branch' = assoc branch ("multigroup" @/ this) "library" (Some multigroup) in
- let* _ = update root ("branch" @/ this) "master" (Some branch) (Some branch') in
+ let* _ = update root ("system" @/ "branch" @/ this) "client" (Some branch) (Some branch') in
let unchanged = finds root library in
let* tip' = address branch' in
let* interface = Protocols.Handle.require Protocols.Session.from session in
Protocols.Session.pin interface {Protocols.Session.snapshot= tip'};
let after = finds root library in
- let* pinned = lookup root ("session" @/ "client" @/ "branch" @/ this) |> fmap address in
+ let* pinned =
+ lookup root ("system" @/ "session" @/ "client" @/ "branch" @/ this) |> fmap address
+ in
let refused =
assoc session ("branch" @/ "multigroup" @/ this) "other" (Some multigroup)
|> Result.is_error
@@ -51,9 +55,32 @@ module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) =
check bool "the session reconstructs the pinned branch" true pinned;
check bool "the session refuses derivation through it" true refused
+ let single_handle conn =
+ let refused, reacquired =
+ begin
+ let open Utilities.Result in
+ let open Rnt.Kernel.Path in
+ let* root = I.initialize conn in
+ let* branch = B.make conn in
+ let* tip = address branch in
+ let session = Session.make conn {Protocols.Session.snapshot= tip} in
+ let* _ = update root ("system" @/ "session" @/ this) "client" None (Some session) in
+ let client = "system" @/ "session" @/ "client" @/ this in
+ let* _ = lookup root ("system" @/ "session" @/ "client" @/ "branch" @/ this) in
+ let* held = lookup root client in
+ let refused = finds root client in
+ Protocols.Handle.release held;
+ Ok (refused, finds root client)
+ end
+ |> Helpers.condition_as_failure
+ in
+ check bool "a second handle to the session is refused" false refused;
+ check bool "releasing the handle frees the session" true reacquired
+
let suite =
( "kernel/session",
- [test_case "pin-and-follow" `Quick (H.with_connection pin_and_follow "session-test")] )
+ [ test_case "pin-and-follow" `Quick (H.with_connection pin_and_follow "session-test");
+ test_case "single-handle" `Quick (H.with_connection single_handle "session-single-test") ] )
end
module LMDB = Make (Rnt.Backend.Storage.LMDB) (Helpers.Storage.LMDB_Configurator)
generated by cgit v1.2.3 (git 2.25.1) at 2026-11-11 18:49:28 +0000