aboutsummaryrefslogtreecommitdiffstats
path: root/test/unit/kernel
diff options
context:
space:
mode:
Diffstat (limited to 'test/unit/kernel')
-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
4 files changed, 234 insertions, 10 deletions
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-06 16:36:32 +0000