diff options
| -rw-r--r-- | test/integration/Karuta.ml | 182 | ||||
| -rw-r--r-- | test/integration/beam/library.erl | 19 | ||||
| -rw-r--r-- | test/integration/beam/rnt.erl | 97 | ||||
| -rw-r--r-- | test/integration/beam/shelf.erl | 22 | ||||
| -rw-r--r-- | test/unit/evaluators/FOL.ml | 164 | ||||
| -rw-r--r-- | test/unit/kernel/Branch.ml | 20 | ||||
| -rw-r--r-- | test/unit/kernel/SubstantialRelation.ml | 63 |
7 files changed, 562 insertions, 5 deletions
diff --git a/test/integration/Karuta.ml b/test/integration/Karuta.ml new file mode 100644 index 0000000..2b02e69 --- /dev/null +++ b/test/integration/Karuta.ml @@ -0,0 +1,182 @@ +open Alcotest +open Rnt +module Beam = Subsystem.Karuta.Beam + +let fixtures = "integration/beam" + +(* rnt and shelf boot with the node; library is only ever loaded from + the images that carry it. *) +let booted = ["rnt"; "shelf"] +let carried = ["library"] + +type node = {root: Protocols.Handle.t; image: string -> string} + +let term image module_ function_ heading = + let buffer = Buffer.create 64 in + let binary s = + Buffer.add_uint8 buffer 109; + Buffer.add_int32_be buffer (Int32.of_int (String.length s)); + Buffer.add_string buffer s + in + Buffer.add_uint8 buffer 131; + Buffer.add_uint8 buffer 104; + Buffer.add_uint8 buffer 4; + binary module_; + binary function_; + binary (image module_); + Buffer.add_uint8 buffer 116; + Buffer.add_int32_be buffer (Int32.of_int (List.length heading)); + List.iter (fun name -> binary name; binary "string") heading; + Buffer.contents buffer + +(* \system\evaluator\fol, so the node can define FOL programs. *) +let mount_fol root = + let open Utilities.Result in + let evaluators = Kernel.Namespace.make () in + let system = Kernel.Namespace.make () in + let* _ = + Kernel.Path.update evaluators Kernel.Path.this "fol" None (Some (Evaluators.FOL.make ())) + in + let* _ = Kernel.Path.update system Kernel.Path.this "evaluator" None (Some evaluators) in + let* _ = Kernel.Path.update root Kernel.Path.this "system" None (Some system) in + Ok () + +let with_node test () = + if Sys.command "command -v erl > /dev/null 2>&1 && command -v erlc > /dev/null 2>&1" <> 0 then + skip (); + Sys.set_signal Sys.sigpipe Sys.Signal_ignore; + Helpers.with_temporary_directory "beam" (fun directory -> + let boot = Filename.concat directory "boot" and images = Filename.concat directory "images" in + let compile into modules = + Unix.mkdir into 0o755; + let sources = List.map (fun m -> Filename.concat fixtures (m ^ ".erl")) modules in + if Sys.command (Filename.quote_command "erlc" (["-o"; into] @ sources)) <> 0 then + fail "the fixtures did not compile" + in + compile boot booted; + compile images carried; + let image module_ = + let at = if List.mem module_ booted then boot else images in + In_channel.with_open_bin (Filename.concat at (module_ ^ ".beam")) In_channel.input_all + in + let root = Kernel.Namespace.make () in + Fun.protect + ~finally:(fun () -> Protocols.Handle.release root) + (fun () -> + Helpers.condition_as_failure (mount_fol root); + Helpers.condition_as_failure (Beam.register root [boot]); + test {root; image} ) ) + +let run {root; image} module_ function_ heading = + let open Utilities.Result in + let* program = + Kernel.Program.load root ~evaluator:"karuta:beam" ~source:(term image module_ function_ heading) + in + let* executable = Protocols.Executable.require program in + Protocols.Executable.invoke executable [] ~within:root + +let titles batch = + BatFingerTree.to_list batch.Protocols.Cursor.tuples + |> List.map (fun {Concepts.Tuple.attributes; _} -> + Concepts.Value.to_string (BatMap.String.find "title" attributes) ) + +let fails_with name = function + | Ok _ -> fail ("expected " ^ name) + | Error c -> + check bool name true (BatString.starts_with (Concepts.Condition.to_string_hum c) name) + +let reads_in_batches node = + let batches = + begin + let open Utilities.Result in + let* relation = run node "library" "books" ["title"; "author"] in + Protocols.Handle.releasing relation (fun () -> + let* heading = Protocols.Relation.heading relation in + check (list string) "the heading the term declares" ["author"; "title"] + (BatMap.String.bindings heading |> List.map fst); + Protocols.Enumerable.scan relation (fun scan -> + let rec pull read = + let* batch = Protocols.Cursor.fetch scan 4 in + let read = (titles batch, batch.exhausted) :: read in + if batch.exhausted then Ok (List.rev read) else pull read + in + pull [] ) ) + end + |> Helpers.condition_as_failure + in + check + (list (pair (list string) bool)) + "four, then the rest" + [ ( [ "Structure and Interpretation of Computer Programs"; + "The Art of Computer Programming"; + "An Introduction to Database Systems"; + "Less Than Words Can Say" ], + false ); + ["The Graves of Academe"; "The Leaning Tower of Babel"; "The Gift of Fire"], true ] + batches + +let reads_back_through_the_kernel ({root; image} as node) = + begin + let open Utilities.Result in + let* books = + Kernel.Program.load root ~evaluator:"karuta:beam" + ~source:(term image "library" "books" ["title"; "author"]) + in + let* bound = + Kernel.Path.update root Kernel.Path.("karuta" @/ "program" @/ this) "books" None (Some books) + in + check bool "the books are defined beside what the node defined" true bound; + let* relation = run node "shelf" "titles" ["title"] in + Protocols.Handle.releasing relation (fun () -> Helpers.titles relation) + end + |> Helpers.condition_as_failure + |> check (list Helpers.value) "the node read its FOL program over the books" + (List.map + (fun title -> Concepts.Value.String title) + [ "An Introduction to Database Systems"; + "Less Than Words Can Say"; + "Structure and Interpretation of Computer Programs"; + "The Art of Computer Programming"; + "The Gift of Fire"; + "The Graves of Academe"; + "The Leaning Tower of Babel" ] ) + +let reads_a_program_of_no_path ({root; image} as node) = + begin + let open Utilities.Result in + let* books = + Kernel.Program.load root ~evaluator:"karuta:beam" + ~source:(term image "library" "books" ["title"; "author"]) + in + let* _ = + Kernel.Path.update root Kernel.Path.("karuta" @/ "program" @/ this) "books" None (Some books) + in + let* relation = run node "shelf" "authors" ["author"] in + Protocols.Handle.releasing relation (fun () -> Protocols.Relation.read relation) + end + |> Helpers.condition_as_failure + |> snd + |> List.map (fun {Concepts.Tuple.attributes; _} -> BatMap.String.find "author" attributes) + |> List.sort compare + |> check (list Helpers.value) "each author once" + (List.map + (fun author -> Concepts.Value.String author) + ["C. J. Date"; "Donald Knuth"; "Harold Abelson"; "Richard Mitchell"] ) + +let a_missing_function_fails node = + fails_with "beam-failed" + (Result.bind (run node "library" "nope" ["title"]) (fun relation -> + Protocols.Handle.releasing relation (fun () -> Protocols.Relation.read relation) ) ) + +let a_malformed_term_is_refused {root; _} = + fails_with "malformed-beam-program" + (Kernel.Program.load root ~evaluator:"karuta:beam" ~source:"not a term") + +let suites () = + [ ( "integration/karuta", + [ test_case "reads-in-batches" `Quick (with_node reads_in_batches); + test_case "reads-back-through-the-kernel" `Quick (with_node reads_back_through_the_kernel); + test_case "reads-a-program-of-no-path" `Quick (with_node reads_a_program_of_no_path); + test_case "a-missing-function-fails" `Quick (with_node a_missing_function_fails); + test_case "a-malformed-term-is-refused" `Quick (with_node a_malformed_term_is_refused) ] ) + ] diff --git a/test/integration/beam/library.erl b/test/integration/beam/library.erl new file mode 100644 index 0000000..b9186ab --- /dev/null +++ b/test/integration/beam/library.erl @@ -0,0 +1,19 @@ +-module(library). +-export([books/0]). + +books() -> + from([book(<<"Structure and Interpretation of Computer Programs">>, <<"Harold Abelson">>), + book(<<"The Art of Computer Programming">>, <<"Donald Knuth">>), + book(<<"An Introduction to Database Systems">>, <<"C. J. Date">>), + book(<<"Less Than Words Can Say">>, <<"Richard Mitchell">>), + book(<<"The Graves of Academe">>, <<"Richard Mitchell">>), + book(<<"The Leaning Tower of Babel">>, <<"Richard Mitchell">>), + book(<<"The Gift of Fire">>, <<"Richard Mitchell">>)]). + +book(Title, Author) -> {<<"book">>, #{<<"title">> => Title, <<"author">> => Author}}. + +from(Books) -> + fun(Limit) -> + {Now, Later} = lists:split(min(Limit, length(Books)), Books), + {Now, case Later of [] -> done; _ -> from(Later) end} + end. diff --git a/test/integration/beam/rnt.erl b/test/integration/beam/rnt.erl new file mode 100644 index 0000000..702be2d --- /dev/null +++ b/test/integration/beam/rnt.erl @@ -0,0 +1,97 @@ +-module(rnt). +-export([start/0, define/3, invoke/1, evaluate/2]). + +start() -> + logger:remove_handler(default), + logger:add_handler(default, logger_std_h, #{config => #{type => standard_error}}), + put(port, open_port({fd, 0, 1}, [binary, {packet, 4}, eof])), + loop(). + +loop() -> serve(frame()), loop(). + +frame() -> + Port = get(port), + receive + {Port, {data, Frame}} -> Frame; + {Port, eof} -> halt() + end. + +send(Frame) -> port_command(get(port), Frame). + +answering(F) -> + try F() + catch Class:Reason -> [$e, io_lib:format("~p:~p", [Class, Reason])] + end. + +%% What RNT asks of the node. +serve(<<$h>>) -> + send(answering(fun() -> + [M:rnt_init() || {M, _} <- code:all_loaded(), + erlang:function_exported(M, rnt_init, 0)], + <<$o>> + end)); +serve(<<$i, Id:64, M:16, Module:M/binary, F:16, Function:F/binary, B:32, Beam:B/binary>>) -> + put({poll, Id}, + fun(Limit) -> + Name = load(binary_to_atom(Module), Beam), + (apply(Name, binary_to_existing_atom(Function), []))(Limit) + end); +serve(<<$f, Id:64, Limit:32>>) -> + send(answering(fun() -> fetch(Id, Limit) end)); +serve(<<$c, Id:64>>) -> + erase({poll, Id}). + +load(Name, Beam) -> + {ok, {Name, Md5}} = beam_lib:md5(Beam), + case erlang:module_loaded(Name) andalso Name:module_info(md5) =:= Md5 of + true -> Name; + false -> + code:purge(Name), + {module, Name} = code:load_binary(Name, atom_to_list(Name) ++ ".beam", Beam), + Name + end. + +fetch(Id, Limit) -> + case get({poll, Id}) of + done -> batch([], true); + Relation -> + {Tuples, Rest} = Relation(Limit), + put({poll, Id}, Rest), + batch(Tuples, Rest =:= done) + end. + +batch(Tuples, Exhausted) -> + [$b, case Exhausted of true -> 1; false -> 0 end + | [[<<(byte_size(Term)):32>>, Term] || Tuple <- Tuples, Term <- [term_to_binary(Tuple)]]]. + +%% What the node asks of RNT. +define(Path, Evaluator, Source) -> + request([$D, path(Path), sized(Evaluator), Source]). + +invoke(Path) -> + relation(request([$X, path(Path)])). + +evaluate(Evaluator, Source) -> + relation(request([$E, sized(Evaluator), Source])). + +relation(Id) -> + fun(Limit) -> + {Tuples, Exhausted} = request(<<$N, Id:64, Limit:32>>), + {Tuples, case Exhausted of true -> done; false -> relation(Id) end} + end. + +request(Frame) -> send(Frame), reply(). + +reply() -> + case frame() of + <<$o>> -> ok; + <<$r, Id:64>> -> Id; + <<$b, Exhausted, Tuples/binary>> -> + {[binary_to_term(T) || <<N:32, T:N/binary>> <= Tuples], Exhausted =:= 1}; + <<$e, Message/binary>> -> error({rnt, Message}); + Frame -> serve(Frame), reply() + end. + +path(Segments) -> [<<(length(Segments)):16>> | [sized(S) || S <- Segments]]. + +sized(Bytes) -> <<(byte_size(Bytes)):16, Bytes/binary>>. diff --git a/test/integration/beam/shelf.erl b/test/integration/beam/shelf.erl new file mode 100644 index 0000000..a9b6823 --- /dev/null +++ b/test/integration/beam/shelf.erl @@ -0,0 +1,22 @@ +-module(shelf). +-export([rnt_init/0, titles/0, authors/0]). + +-define(TITLES, [<<"karuta">>, <<"program">>, <<"titles">>]). +-define(BOOKS, {$b, [<<"karuta">>, <<"program">>, <<"books">>]}). + +%% A FOL program over a beam program RNT holds, defined from the node. +rnt_init() -> + rnt:define(?TITLES, <<"fol">>, project(?BOOKS, [<<"title">>])). + +titles() -> rnt:invoke(?TITLES). + +authors() -> rnt:evaluate(<<"fol">>, project(?BOOKS, [<<"author">>])). + +project(Term, Attributes) -> + bencode({$p, #{<<"term">> => Term, <<"attributes">> => Attributes}}). + +bencode(Bytes) when is_binary(Bytes) -> [integer_to_binary(byte_size(Bytes)), $:, Bytes]; +bencode(List) when is_list(List) -> [$l, [bencode(X) || X <- List], $e]; +bencode(Map) when is_map(Map) -> + [$d, [[bencode(K), bencode(V)] || {K, V} <- lists:sort(maps:to_list(Map))], $e]; +bencode({Tag, Value}) -> [$t, Tag, bencode(Value)]. diff --git a/test/unit/evaluators/FOL.ml b/test/unit/evaluators/FOL.ml index 4a6cadd..2049f23 100644 --- a/test/unit/evaluators/FOL.ml +++ b/test/unit/evaluators/FOL.ml @@ -190,18 +190,169 @@ module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) = let holds term tuple = ask term (fun r -> Protocols.Relation.contains r tuple) in check (list (pair (list string) string)) - "a base relation keeps the lookup by hash" - [[], "finite"; ["age"; "name"], "bounded(1)"] + "a base relation keeps the lookup by hash and one lookup per index" + [[], "finite"; ["age"; "name"], "bounded(1)"; ["age"], "finite"; ["name"], "finite"] (modes employees); check (list (pair (list string) string)) "its projection keeps only what a projected tuple can bind" - [[], "finite"] + [[], "finite"; ["name"], "finite"] (modes names); check bool "the base decides by its own test" true (holds employees (employee "Alaric" 42)); check bool "the projection decides by reading" true (holds names (named "Alaric")); check bool "and refuses a stranger" false (holds names (named "Gunther")) + let aged age = BatMap.String.singleton "age" (Concepts.Value.Integer age) + let called name = BatMap.String.singleton "name" (Concepts.Value.String name) + let staff = [employee "Alaric" 42; employee "Brunhild" 30; employee "Gunther" 42] + + module F = Rnt.Evaluators.FOL + + let restrict_through_an_index () = + let scanned = ref false and looked = ref [] in + let cursor tuples = Kernel.Generator.cursor_of (fun ~yield -> List.iter yield tuples; Ok ()) in + let schema domain = {Protocols.Schematics.domain; provenance= []} in + let relation = + Kernel.Prototype.mixture + Protocols. + [ Relation.make + object + method contains _ = Ok false + + method modes = + Ok Concepts.[Mode.mode [] Cardinality.Finite; Mode.mode ["age"] Cardinality.Finite] + end; + Enumerable.make + object + method enumerate = + scanned := true; + Ok (cursor staff) + end; + Indexed.make + object + method indexes = ["age"] + + method lookup attribute value = + looked := attribute :: !looked; + Ok + (cursor + (List.filter + (fun tuple -> + BatMap.String.find_opt attribute tuple.Concepts.Tuple.attributes + |> Option.fold ~none:false ~some:(Concepts.Value.equal value) ) + staff ) ) + end; + Schematics.make + object + method describe () = + Ok + (Schematics.Relation + (BatMap.String.of_list ["name", schema "string"; "age", schema "integer"]) ) + end ] + in + let found = + F.( + execute + (Where + ( Base relation, + BatMap.String.of_list + ["age", Concepts.Value.Integer 42; "name", Concepts.Value.String "Alaric"] ) ) ) + |> Utilities.Result.(fun result -> result |>> drain) + |> Helpers.condition_as_failure + in + check + (list (list (pair string Helpers.value))) + "the one tuple agreeing with every bound attribute" + [["age", Concepts.Value.Integer 42; "name", Concepts.Value.String "Alaric"]] + (bindings found); + check bool "the relation was never scanned" false !scanned; + check (list string) "its index was looked up once" ["age"] !looked + + let restrict_a_stored_relation conn = + let run term f = + begin + let open Utilities.Result in + let* relation = H.relation conn ["name"; "age"] staff in + let* result = eval (directory ["employee", relation]) term in + f result + end + |> Helpers.condition_as_failure + in + let asking term f = + run term (fun result -> + Protocols.Handle.releasing result (fun () -> + Result.bind (Protocols.Relation.require result) f ) ) + in + check + (list (list (pair string Helpers.value))) + "every tuple holding the bound value" + [ ["age", Concepts.Value.Integer 42; "name", Concepts.Value.String "Alaric"]; + ["age", Concepts.Value.Integer 42; "name", Concepts.Value.String "Gunther"] ] + (bindings (run (F.Where (employees, aged 42)) drain)); + check + (list (list (pair string Helpers.value))) + "a restriction reaches through a projection" + [["name", Concepts.Value.String "Alaric"]] + (bindings (run (F.Where (names, called "Alaric")) drain)); + check bool "a tuple agreeing with the binding is held" true + (asking + (F.Where (employees, aged 42)) + (fun r -> Protocols.Relation.contains r (employee "Gunther" 42)) ); + check bool "a tuple disagreeing with it is not" false + (asking + (F.Where (employees, aged 42)) + (fun r -> Protocols.Relation.contains r (employee "Brunhild" 30)) ); + check bool "through the index it ends with nothing bound" true + (asking + (F.Where (employees, aged 42)) + (fun r -> + Protocols.Relation.modes r + |> Result.map (fun modes -> Concepts.Mode.exhaustible modes BatSet.String.empty) ) ) + + let restrict_inside_a_stored_program conn = + let inner = F.Project (F.Where (employees, aged 42), BatFingerTree.singleton "name") in + let pushed, found = + begin + let open Utilities.Result in + let* relation = H.relation conn ["name"; "age"] staff in + let* stored = store conn inner in + let* root = namespace ["employee", relation; "stored", stored] in + let* plan = + F.instantiate root (F.Where (F.Base Kernel.Path.("stored" @/ this), called "Gunther")) + in + let pushed = + match plan with F.Project (F.Where (F.Where (F.Base _, _), _), _) -> true | _ -> false + in + let* result = F.execute plan in + let* found = drain result in + Ok (pushed, found) + end + |> Helpers.condition_as_failure + in + check string "a restriction survives its encoding" (F.encode inner) + (F.encode (Helpers.condition_as_failure (F.decode (F.encode inner)))); + check bool "the restriction moved below the stored projection" true pushed; + check + (list (list (pair string Helpers.value))) + "and both restrictions held" + [["name", Concepts.Value.String "Gunther"]] + (bindings found) + + let refuse_a_restriction_on_a_missing_attribute conn = + let refused term = + match + let open Utilities.Result in + let* relation = H.relation conn ["name"; "age"] staff in + eval (directory ["employee", relation]) term + with + | Error condition -> + BatString.starts_with (Concepts.Condition.to_string_hum condition) "unknown-attribute" + | Ok result -> Protocols.Handle.release result; false + in + check bool "an attribute the relation lacks" true + (refused (F.Where (employees, BatMap.String.singleton "salary" (Concepts.Value.Integer 1)))); + check bool "an attribute projected away" true (refused (F.Where (names, aged 42))) + let counter ?(produced = ref 0) ?(closed = ref false) () = let description = BatMap.String.singleton "value" {Protocols.Schematics.domain= "integer"; provenance= []} @@ -294,6 +445,13 @@ module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) = (H.with_connection refuse_a_program_that_reads_itself "fol-test"); test_case "a-projection-keeps-the-modes-it-can-bind" `Quick (H.with_connection a_projection_keeps_the_modes_it_can_bind "fol-test"); + test_case "restrict-through-an-index" `Quick restrict_through_an_index; + test_case "restrict-a-stored-relation" `Quick + (H.with_connection restrict_a_stored_relation "fol-test"); + test_case "restrict-inside-a-stored-program" `Quick + (H.with_connection restrict_inside_a_stored_program "fol-test"); + test_case "refuse-a-restriction-on-a-missing-attribute" `Quick + (H.with_connection refuse_a_restriction_on_a_missing_attribute "fol-test"); test_case "pull-one-tuple-at-a-time" `Quick pull_one_tuple_at_a_time; test_case "an-endless-projection-cannot-decide" `Quick an_endless_projection_cannot_decide; test_case "a-result-owns-the-relations-of-its-plan" `Quick diff --git a/test/unit/kernel/Branch.ml b/test/unit/kernel/Branch.ml index a0f201d..10789cd 100644 --- a/test/unit/kernel/Branch.ml +++ b/test/unit/kernel/Branch.ml @@ -256,6 +256,23 @@ let a_denial_program_runs_once_per_judgement () = (K.Scope.publish root ~branch:"master" ~home:library ~denials:["dated", Some dated] []) ); check int "and its program ran once to judge it" 1 !evaluations +let a_denial_binds_an_attribute () = + let root = fresh ["Date"] in + let codd = + K.EphemeralRelation.of_program title + Rnt.Evaluators.FOL.( + program + (Where (Base (K.Scope.path library "book"), BatMap.String.singleton "title" (s "Codd"))) ) + in + publish root ~denials:["no-codd", Some codd] []; + check bool "a book the rule binds is refused" true + (Result.is_error + (K.Scope.publish root ~branch:"master" ~home:library ["book", Some (books ["Date"; "Codd"])]) ); + publish root ["book", Some (books ["Date"; "Darwen"])]; + check (list Helpers.value) "any other book lands" + [s "Darwen"; s "Date"] + (read root (under master (K.Scope.path library "book"))) + let suites () = [ ( "kernel/branch", [ test_case "reads-as-of-each-state" `Quick reads_as_of_each_state; @@ -271,4 +288,5 @@ let suites () = test_case "a-denial-without-end-cannot-be-installed" `Quick a_denial_without_end_cannot_be_installed; test_case "a-denial-program-runs-once-per-judgement" `Quick - a_denial_program_runs_once_per_judgement ] ) ] + a_denial_program_runs_once_per_judgement; + test_case "a-denial-binds-an-attribute" `Quick a_denial_binds_an_attribute ] ) ] diff --git a/test/unit/kernel/SubstantialRelation.ml b/test/unit/kernel/SubstantialRelation.ml index 6000e52..b4e90dc 100644 --- a/test/unit/kernel/SubstantialRelation.ml +++ b/test/unit/kernel/SubstantialRelation.ml @@ -49,10 +49,71 @@ module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) = Concepts.Hash.hash_equals (Concepts.Tuple.hash tuple) (Concepts.Tuple.hash alaric) ) enumerated ) + let refuse_a_tuple_without_every_attribute conn = + let nameless = {alaric with attributes= BatMap.String.remove "name" alaric.attributes} in + check bool "storing it fails for the attribute it lacks" true + ( match H.relation conn ["name"; "age"] [nameless] with + | Error condition -> + BatString.starts_with (Concepts.Condition.to_string_hum condition) "missing-attribute" + | Ok _ -> false ) + + let employee name age = + { Concepts.Tuple.type_= "employee"; + attributes= + BatMap.String.empty + |> BatMap.String.add "name" (Concepts.Value.String name) + |> BatMap.String.add "age" (Concepts.Value.Integer age) } + + let look_up_by_one_attribute conn = + let names relation attribute value = + let open Utilities.Result in + let* indexed = Protocols.Indexed.require relation in + let* cursor = Protocols.Indexed.lookup indexed attribute value in + let* found = Protocols.Cursor.consuming cursor (fun scan -> Protocols.Cursor.drain scan ()) in + Ok + ( BatFingerTree.to_list found + |> List.map (fun tuple -> BatMap.String.find "name" tuple.Concepts.Tuple.attributes) + |> List.sort compare ) + in + let indexes, aged, named, unaged, prefixed, unindexed = + begin + let open Utilities.Result in + let* relation = + H.relation conn ["name"; "age"] + [employee "Alaric" 42; employee "Brunhild" 30; employee "Gunther" 42] + in + let* indexed = Protocols.Indexed.require relation in + let* aged = names relation "age" (Concepts.Value.Integer 42) in + let* named = names relation "name" (Concepts.Value.String "Brunhild") in + let* unaged = names relation "age" (Concepts.Value.Integer 4) in + let* prefixed = names relation "name" (Concepts.Value.String "Al") in + let unindexed = names relation "salary" (Concepts.Value.Integer 1) in + Ok (Protocols.Indexed.indexes indexed, aged, named, unaged, prefixed, unindexed) + end + |> Helpers.condition_as_failure + in + let s v = Concepts.Value.String v in + check (list string) "every attribute is indexed" ["age"; "name"] indexes; + check (list Helpers.value) "an integer finds every tuple holding it" + [s "Alaric"; s "Gunther"] + aged; + check (list Helpers.value) "a string finds the tuple holding it" [s "Brunhild"] named; + check (list Helpers.value) "an integer is not a prefix of a longer one" [] unaged; + check (list Helpers.value) "a string is not a prefix of a longer one" [] prefixed; + check bool "an attribute without an index is refused" true + ( match unindexed with + | Error condition -> + BatString.starts_with (Concepts.Condition.to_string_hum condition) "unindexed-attribute" + | Ok _ -> false ) + let suite = ( "kernel/substantial-relation", [ test_case "contain-and-enumerate" `Quick - (H.with_connection contain_and_enumerate "substantial-relation-test") ] ) + (H.with_connection contain_and_enumerate "substantial-relation-test"); + test_case "refuse-a-tuple-without-every-attribute" `Quick + (H.with_connection refuse_a_tuple_without_every_attribute "substantial-relation-test"); + test_case "look-up-by-one-attribute" `Quick + (H.with_connection look_up_by_one_attribute "substantial-relation-test") ] ) end module LMDB = Make (Rnt.Backend.Storage.LMDB) (Helpers.Storage.LMDB_Configurator) |