blob: 2548629e3ae14ab80ed46ca9450b6ee6232b7543 (
plain) (
blame)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
|
open Rnt
module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) = struct
open Alcotest
module H = Helpers.Storage.Make (S) (C)
module I = Rnt.Kernel.Initialization.Make (S)
module B = Rnt.Kernel.Branch.Make (S)
module M = Rnt.Kernel.Multigroup.Make (S)
module Session = Rnt.Kernel.Session.Make (S)
let address handle =
let open Utilities.Result in
let* addressable = Protocols.Handle.require Protocols.Addressable.from handle in
Ok (Protocols.Addressable.address addressable)
let finds root path = Rnt.Kernel.Path.lookup root path |> Result.is_ok
let pin_and_follow conn =
let before, after, unchanged, pinned, refused =
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* _ = update root ("branch" @/ this) "master" 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 (Some session) in
let library = "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 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 refused =
assoc session ("branch" @/ "multigroup" @/ this) "other" (Some multigroup)
|> Result.is_error
in
Ok (before, after, unchanged, Concepts.Hash.hash_equals pinned tip', refused)
end
|> Helpers.condition_as_failure
in
check bool "the pinned state lacks the multigroup" false before;
check bool "advancing the branch leaves the session pinned" false unchanged;
check bool "re-pinning exposes the multigroup" true after;
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 ("session" @/ this) "client" None (Some session) in
let client = "session" @/ "client" @/ this in
let* _ = lookup root ("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 "single-handle" `Quick (H.with_connection single_handle "session-single-test") ] )
end
module LMDB = Make (Rnt.Backend.Storage.LMDB) (Helpers.Storage.LMDB_Configurator)
let suites () = [LMDB.suite]
|
