diff options
Diffstat (limited to 'test/unit')
| -rw-r--r-- | test/unit/evaluators/FOL.ml | 43 | ||||
| -rw-r--r-- | test/unit/kernel/Branch.ml | 144 | ||||
| -rw-r--r-- | test/unit/kernel/Journal.ml | 133 | ||||
| -rw-r--r-- | test/unit/kernel/Merkle.ml | 32 | ||||
| -rw-r--r-- | test/unit/kernel/Session.ml | 20 |
5 files changed, 225 insertions, 147 deletions
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..ee42463 --- /dev/null +++ b/test/unit/kernel/Branch.ml @@ -0,0 +1,144 @@ +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")) + +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 ] ) ] diff --git a/test/unit/kernel/Journal.ml b/test/unit/kernel/Journal.ml deleted file mode 100644 index d0ab9f6..0000000 --- a/test/unit/kernel/Journal.ml +++ /dev/null @@ -1,133 +0,0 @@ -open Rnt -open Alcotest -module J = Protocols.Journal - -let ok = Helpers.condition_as_failure -let thing () = Rnt.Kernel.Prototype.mixture [] - -let journal () = - let handle = Rnt.Kernel.Journal.make ~bindings:["A", thing ()] () in - handle, ok (J.require handle) - -let bound directory name = - let listing = ok (Protocols.Handle.require Protocols.Directory.from directory) in - ok (Protocols.Directory.find listing name) |> Option.is_some - -let a_registry_update_is_a_commit () = - let handle, journal = journal () in - let registry = Protocols.Registry.from handle |> Option.get in - check bool "bound" true (ok (Protocols.Registry.update registry "B" None (Some (thing ())))); - let history = J.history journal in - check (list int) "numbered" [0; 1] (List.map (fun (c : J.commit) -> c.number) history); - check bool "the first snapshot keeps its past" false (bound (List.hd history).snapshot "B"); - check bool "the head sees it" true (bound (J.head journal).snapshot "B") - -let a_commit_binds_together_or_not_at_all () = - let _, journal = journal () in - let changes stale = - J. - [ {name= "B"; expected= None; replacement= Some (thing ())}; - { name= "C"; - expected= (if stale then Some (thing ()) else None); - replacement= Some (thing ()) } ] - in - check bool "a stale expectation" true (ok (J.commit journal (changes true)) = None); - check int "nothing landed" 0 (J.head journal).number; - let commit = ok (J.commit journal (changes false)) |> Option.get in - check (list string) "both" ["B"; "C"] commit.changed; - check bool "B" true (bound commit.snapshot "B"); - check bool "C" true (bound commit.snapshot "C") - -let a_guard_refuses_and_an_observer_hears () = - let _, journal = journal () in - let heard = ref [] in - J.observe journal "ear" (Some (fun c -> heard := c.number :: !heard)); - J.guard journal "no-B" - (Some - (fun {proposed; _} -> - if List.mem "B" proposed.changed then - Error Concepts.Condition.(condition "no-B" "B stays unbound" empty) - else Ok () ) ); - let change name = [J.{name; expected= None; replacement= Some (thing ())}] in - check bool "refused" true (Result.is_error (J.commit journal (change "B"))); - check bool "allowed" true (Result.is_ok (J.commit journal (change "C"))); - check (list int) "heard only what landed" [1] !heard - -let a_snapshot_hands_out_derived_relations_against_itself () = - let derived = - Rnt.Kernel.Prototype.mixture - [ Protocols.Derived.make - object - method within directory = - Ok - (Rnt.Kernel.Prototype.mixture - [Rnt.Kernel.Prototype.Directory.of_properties ["seen", directory]] ) - end ] - in - let snapshot = Rnt.Kernel.Journal.snapshot ["D", derived] in - let read = ok (Rnt.Kernel.Path.lookup snapshot Rnt.Kernel.Path.("D" @/ "seen" @/ this)) in - check bool "read against the snapshot" true (Protocols.Handle.equal read snapshot) - -let suites () = - [ ( "kernel/journal", - [ test_case "a registry update is a commit" `Quick a_registry_update_is_a_commit; - test_case "a commit binds together or not at all" `Quick - a_commit_binds_together_or_not_at_all; - test_case "a guard refuses and an observer hears" `Quick - a_guard_refuses_and_an_observer_hears; - test_case "a snapshot hands out derived relations against itself" `Quick - a_snapshot_hands_out_derived_relations_against_itself ] ) ] - -let schema = BatMap.String.singleton "N" {Protocols.Schematics.domain= "integer"; provenance= []} - -let row n = - {Concepts.Tuple.type_= "R"; attributes= BatMap.String.singleton "N" (Concepts.Value.Integer n)} - -let count relation = - let _, tuples = ok (Rnt.Kernel.View.read relation) in - List.length tuples - -let rebinding_lands_as_one_commit_or_one_name_at_a_time () = - let handle, journal = journal () in - let fixed n = Rnt.Kernel.View.fixed schema (List.init n row) in - ok (Rnt.Kernel.Journal.rebind handle ["A", Some (fixed 1); "B", Some (fixed 2)]); - ok (Rnt.Kernel.Journal.rebind handle ["A", Some (fixed 3)]); - check (list int) "two commits after the first" [0; 1; 2] - (List.map (fun (c : J.commit) -> c.number) (J.history journal)); - let plain = Rnt.Kernel.Namespace.make () in - ok (Rnt.Kernel.Journal.rebind plain ["A", Some (fixed 1)]); - ok (Rnt.Kernel.Journal.rebind plain ["A", Some (fixed 4)]); - check int "a plain namespace too" 4 - (count (ok (Rnt.Kernel.Path.lookup plain Rnt.Kernel.Path.("A" @/ this)))) - -(* A computed relation counts the tuples of A in whatever it is read - against, so the first snapshot still sees one and the head three. *) -let a_computed_relation_reads_as_of_its_snapshot () = - let ( let* ) = Result.bind in - let handle, journal = journal () in - let fixed n = Rnt.Kernel.View.fixed schema (List.init n row) in - let counting = - Rnt.Kernel.View.computed schema - ~current:(fun () -> Ok handle) - (fun directory -> - let* a = Rnt.Kernel.Path.lookup directory Rnt.Kernel.Path.("A" @/ this) in - Ok [row (count a)] ) - in - ok (Rnt.Kernel.Journal.rebind handle ["A", Some (fixed 1); "C", Some counting]); - ok (Rnt.Kernel.Journal.rebind handle ["A", Some (fixed 3)]); - let read snapshot = - let c = ok (Rnt.Kernel.Path.lookup snapshot Rnt.Kernel.Path.("C" @/ this)) in - let _, tuples = ok (Rnt.Kernel.View.read c) in - BatMap.String.find "N" (List.hd tuples).Concepts.Tuple.attributes - in - let history = J.history journal in - check Helpers.value "as it was" (Concepts.Value.Integer 1) (read (List.nth history 1).snapshot); - check Helpers.value "as it is" (Concepts.Value.Integer 3) (read (J.head journal).snapshot) - -let suites () = - suites () - @ [ ( "kernel/view", - [ test_case "rebinding lands as one commit, or one name at a time" `Quick - rebinding_lands_as_one_commit_or_one_name_at_a_time; - test_case "a computed relation reads as of its snapshot" `Quick - a_computed_relation_reads_as_of_its_snapshot ] ) ] 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 2548629..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 (Some 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 @@ -60,9 +64,9 @@ module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) = 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* _ = 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; |
