aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--lib/concepts/Encoding.ml2
-rw-r--r--lib/evaluators/FOL.ml83
-rw-r--r--lib/kernel/EphemeralRelation.ml111
-rw-r--r--lib/kernel/Multigroup.ml59
-rw-r--r--lib/kernel/Path.ml2
-rw-r--r--lib/kernel/Path.mli2
-rw-r--r--lib/kernel/SubstantialRelation.ml18
-rw-r--r--test/Helpers.ml4
-rw-r--r--test/integration/Registration.ml38
-rw-r--r--test/unit/evaluators/FOL.ml94
-rw-r--r--test/unit/kernel/EphemeralRelation.ml24
11 files changed, 406 insertions, 31 deletions
diff --git a/lib/concepts/Encoding.ml b/lib/concepts/Encoding.ml
index 733ff67..d78eb28 100644
--- a/lib/concepts/Encoding.ml
+++ b/lib/concepts/Encoding.ml
@@ -235,6 +235,7 @@ module Record = struct
module type S = sig
type t
+ val tag : char
val to_bencode : t -> Bencode.t
val of_bencode : Bencode.t -> (t, Condition.condition) result
val to_blob : t -> Blob.t
@@ -255,6 +256,7 @@ module Record = struct
module Make (B : BODY) : S with type t = B.t = struct
type t = B.t
+ let tag = B.tag
let to_bencode object_ = Bencode.Tagged (B.tag, Bencode.Dict (B.fields object_))
let of_bencode = function
diff --git a/lib/evaluators/FOL.ml b/lib/evaluators/FOL.ml
index 016e3a0..e436eeb 100644
--- a/lib/evaluators/FOL.ml
+++ b/lib/evaluators/FOL.ml
@@ -23,11 +23,90 @@ module Error = struct
let released_relation name =
condition "released-relation" "A plan named a relation that was already released"
("object" |=| Concepts.Value.String name)
+
+ let malformed_program () =
+ condition "malformed-fol-program"
+ "A stored FOL program did not conform to what was expected. Is your database corrupted?" empty
+
+ let foreign_program evaluator =
+ condition "foreign-program" "A plan named a relation stored by another evaluator"
+ ("evaluator" |=| Concepts.Value.String evaluator)
+
+ let cyclic_program code =
+ condition "cyclic-program" "A stored program reads itself"
+ ("program" |=| Concepts.Value.String (Concepts.Hash.to_hum_string code))
end
-type plan = Base of Protocols.Handle.t | Project of plan * string BatFingerTree.t
+let name = "fol"
+
+type 'r term = Base of 'r | Project of 'r term * string BatFingerTree.t
+type plan = Protocols.Handle.t term
type Protocols.Handle.protocol += Plan of plan
+module Bencode = Concepts.Encoding.Bencode
+
+let rec bencode_of_term =
+ let strings values = Bencode.List (List.map (fun value -> Bencode.String value) values) in
+ function
+ | Base path -> Bencode.Tagged ('b', strings (Kernel.Path.to_list path))
+ | Project (term, attributes) ->
+ Bencode.Tagged
+ ( 'p',
+ Bencode.Dict
+ ["term", bencode_of_term term; "attributes", strings (BatFingerTree.to_list attributes)]
+ )
+
+let rec term_of_bencode =
+ let open Utilities.Result in
+ let strings values =
+ let* values = Bencode.as_list values in
+ List.map Bencode.as_string values |> Utilities.List.sequence
+ in
+ function
+ | Bencode.Tagged ('b', segments) ->
+ strings segments |> Result.map (fun segments -> Base (Kernel.Path.of_list segments))
+ | Bencode.Tagged ('p', data) ->
+ let* term = Bencode.field "term" data |> fmap term_of_bencode in
+ let* attributes = Bencode.field "attributes" data |> fmap strings in
+ Ok (Project (term, BatFingerTree.of_list attributes))
+ | _ -> Error (Error.malformed_program ())
+
+let encode term = bencode_of_term term |> Bencode.to_blob
+let decode code = Bencode.of_blob code |> Utilities.Result.fmap term_of_bencode
+
+let stored relation =
+ Protocols.Handle.into relation (function
+ | Kernel.EphemeralRelation.Stored {evaluator; code} -> Some (evaluator, code)
+ | _ -> None )
+ |> Option.map (fun stored -> Protocols.Handle.invoke stored Fun.id)
+
+(* TODO: To strenghten our checks for self references, we need to
+ construct a graph and see raise a condition if there are self
+ references. We partially do that here with the program calling
+ self, but if the flow is alternated, say between program A and B,
+ where B calls A and A calls B, we also must check. *)
+let instantiate resolve =
+ let open Utilities.Result in
+ let rec bind expanding = function
+ | Base reference -> (
+ let* relation = resolve reference in
+ match stored relation with
+ | None -> Ok (Base relation)
+ | Some (evaluator, code) ->
+ Protocols.Handle.release relation;
+ let identity = Concepts.Hash.hash_of_blob code in
+ if not (String.equal evaluator name) then Error (Error.foreign_program evaluator)
+ else if List.exists (Concepts.Hash.hash_equals identity) expanding then
+ Error (Error.cyclic_program identity)
+ else
+ let* term = decode code in
+ bind (identity :: expanding) term )
+ | Project (term, attributes) ->
+ let* plan = bind expanding term in
+ Ok (Project (plan, attributes))
+ in
+ bind []
+
class program plan =
object
inherit Kernel.Lifecycle.null
@@ -96,7 +175,7 @@ let project description relation =
let derive relation description enumerate =
Kernel.EphemeralRelation.instantiate ~inputs:[relation] description
- {Kernel.EphemeralRelation.schematics= `Temporary description}
+ {Kernel.EphemeralRelation.name= None; schematics= `Temporary description; program= None}
(fun () -> enumerate relation)
let rec execute plan =
diff --git a/lib/kernel/EphemeralRelation.ml b/lib/kernel/EphemeralRelation.ml
index e1e450d..1d9267e 100644
--- a/lib/kernel/EphemeralRelation.ml
+++ b/lib/kernel/EphemeralRelation.ml
@@ -1,13 +1,67 @@
+type program = {evaluator: string; code: Concepts.Hash.hash}
+
type t =
- { schematics:
+ { name: string option;
+ schematics:
[ `Persisted of Concepts.Hash.hash
- | `Temporary of Protocols.Schematics.attribute_description BatMap.String.t ] }
+ | `Temporary of Protocols.Schematics.attribute_description BatMap.String.t ];
+ program: program option }
+
+type Protocols.Handle.protocol += Stored of {evaluator: string; code: Concepts.Blob.t}
module Error = struct
- (* open Concepts.Condition *)
+ open Concepts.Condition
+
+ let malformed_relation () =
+ condition "malformed-ephemeral-relation"
+ "The on-disk representation of an ephemeral relation did not conform to what was expected. \
+ Is your database corrupted?"
+ empty
+
+ let unbound_program name =
+ condition "unbound-program"
+ "A stored relation has to be instantiated by its evaluator before it can be enumerated"
+ ("relation" |=| Concepts.Value.String name)
end
-class ephemeral_relation description value enumerate inputs =
+module Persisted = struct
+ type nonrec t = {name: string; schematics: Concepts.Hash.hash; program: program}
+
+ module rec Representation : (Concepts.Encoding.Record.S with type t = t) =
+ Concepts.Encoding.Record.Make (Body)
+
+ and Body : Concepts.Encoding.Record.BODY = struct
+ type nonrec t = t
+
+ let tag = 'E'
+ let malformed = Error.malformed_relation
+
+ let fields {name; schematics; program= {evaluator; code}} =
+ let open Concepts.Encoding in
+ [ "name", Field.string name;
+ "schema", Value.bencode_of_hash schematics;
+ "evaluator", Field.string evaluator;
+ "program", Value.bencode_of_hash code ]
+
+ let of_fields fields =
+ let open Utilities.Result in
+ let open Concepts.Encoding in
+ let* name = Field.require_string "name" fields in
+ let* schematics = Bencode.field "schema" fields |> fmap Value.hash_of_bencode in
+ let* evaluator = Field.require_string "evaluator" fields in
+ let* code = Bencode.field "program" fields |> fmap Value.hash_of_bencode in
+ Ok {name; schematics; program= {evaluator; code}}
+ end
+end
+
+(* FIXME: Bring the Persisted/Temporary out to avoid using the
+ wildcard and optionals *)
+let persisted = function
+ | {name= Some name; schematics= `Persisted schematics; program= Some program} ->
+ Some {Persisted.name; schematics; program}
+ | _ -> None
+
+class ephemeral_relation ?code description value enumerate inputs =
object (self)
inherit Lifecycle.counted
inherit Identity.of_id
@@ -17,6 +71,10 @@ class ephemeral_relation description value enumerate inputs =
method enumerate : (Protocols.Handle.t, Concepts.Condition.condition) result = enumerate ()
method describe () = Ok (Protocols.Schematics.Relation description)
+ (* TODO: We do not need to scan, but simply apply a membership
+ criteria (set of constraints. For now this works, but it's
+ inneficient and hurts data independence, as there is an
+ assymetry between ephemeral and substantial relations. *)
method contains (tuple : Concepts.Tuple.t) =
let open Utilities.Result in
let* cursor = self#enumerate in
@@ -28,8 +86,47 @@ class ephemeral_relation description value enumerate inputs =
Concepts.Hash.hash_equals (Concepts.Tuple.hash member) (Concepts.Tuple.hash tuple) ) )
method protocols : Protocols.Handle.protocol list =
- Protocols.[Relation.make self; Enumerable.make self; Schematics.make self]
+ let protocols = Protocols.[Relation.make self; Enumerable.make self; Schematics.make self] in
+ match persisted relation with
+ | None -> protocols
+ | Some record ->
+ let stored =
+ Option.fold ~none:protocols
+ ~some:(fun code -> Stored {evaluator= record.program.evaluator; code} :: protocols)
+ code
+ in
+ Protocols.Addressable.make
+ object
+ method address = Persisted.Representation.to_blob record |> Concepts.Hash.hash_of_blob
+ end
+ :: stored
end
-let instantiate ?(inputs = []) description value enumerate =
- new ephemeral_relation description value enumerate inputs |> Protocols.Handle.make
+let instantiate ?(inputs = []) ?code description value enumerate =
+ new ephemeral_relation ?code description value enumerate inputs |> Protocols.Handle.make
+
+module Make (S : Abstract.Storage.STORAGE) = struct
+ module SI = Storage.Make (S)
+ module R = SubstantialRelation.Make (S)
+
+ let restore ~code ({Persisted.name; schematics; program} : Persisted.t) description =
+ instantiate ~code description
+ {name= Some name; schematics= `Persisted schematics; program= Some program}
+ (fun () -> Error (Error.unbound_program name))
+
+ let load connection (record : Persisted.t) =
+ SI.with_read connection (fun tx ->
+ let open Utilities.Result in
+ let* description = R.schema_of tx record.schematics in
+ let* code = SI.get_req tx (S.Hash record.program.code) in
+ Ok (restore ~code record description) )
+
+ let persist connection ~name ~evaluator ~code description =
+ SI.with_transaction connection (fun tx ->
+ let open Utilities.Result in
+ let* schematics = R.store_schema tx description in
+ let* address = SI.store_blob tx code in
+ let record = {Persisted.name; schematics; program= {evaluator; code= address}} in
+ let* _ = SI.store_blob tx (Persisted.Representation.to_blob record) in
+ Ok (restore ~code record description) )
+end
diff --git a/lib/kernel/Multigroup.ml b/lib/kernel/Multigroup.ml
index 88f5948..1417a65 100644
--- a/lib/kernel/Multigroup.ml
+++ b/lib/kernel/Multigroup.ml
@@ -1,8 +1,35 @@
module Make (S : Abstract.Storage.STORAGE) = struct
module SI = Storage.Make (S)
module R = SubstantialRelation.Make (S)
- module RelationM = Merkle.Interface (S) (Merkle.StringKey) (R)
- module RMDirectory = Prototype.Directory.OfTree (S) (Merkle.StringKey) (R)
+ module E = EphemeralRelation.Make (S)
+
+ module Entry = struct
+ module Stored = EphemeralRelation.Persisted.Representation
+
+ type t = Substantial of R.t | Ephemeral of EphemeralRelation.Persisted.t
+
+ let encode = function
+ | Substantial relation -> R.encode relation
+ | Ephemeral relation -> Stored.to_blob relation
+
+ let decode blob =
+ let open Utilities.Result in
+ let open Concepts.Encoding in
+ let* data = Bencode.of_blob blob in
+ match data with
+ | Bencode.Tagged (tag, _) when Char.equal tag Stored.tag ->
+ Stored.of_bencode data |> Result.map (fun relation -> Ephemeral relation)
+ | _ -> R.Representation.of_bencode data |> Result.map (fun relation -> Substantial relation)
+
+ let load storage = function
+ | Substantial relation -> R.load storage relation
+ | Ephemeral relation -> E.load storage relation
+ end
+
+ module RelationM = Merkle.Interface (S) (Merkle.StringKey) (Entry)
+ module RMAddressable = Prototype.Addressable.OfTree (S) (Merkle.StringKey)
+ module RMDirectory = Prototype.Directory.OfTree (S) (Merkle.StringKey) (Entry)
+ module RMAssociative = Prototype.Associative.OfTree (S) (Merkle.StringKey)
type t = {relations: RelationM.address}
@@ -52,12 +79,38 @@ module Make (S : Abstract.Storage.STORAGE) = struct
val storage = conn
val node = node (* FIXME: see the comment on Branch.ml *)
+ (* TODO: Add later to the lifecycle management, accounting for
+ derived instances. Callers must release the previous handle
+ when done with it so its instance can be cleaned up after the
+ last reference is released. *)
+ method deriving multigroup' =
+ let open Utilities.Result in
+ let* node' =
+ SI.with_transaction storage (fun tx ->
+ let* _ = SI.store_blob tx (Representation.to_blob multigroup') in
+ RelationM.find tx multigroup'.relations
+ |> fmap (Option.to_result ~none:(Error.incomplete_multigroup multigroup'.relations)) )
+ in
+ new multigroup storage multigroup' node' |> Protocols.Handle.make |> Result.ok
+
method protocols : Protocols.Handle.protocol list =
+ let open Utilities.Result in
Protocols.
[ Addressable.make self;
+ Prototype.Associative.(
+ of_properties
+ [ ( "relation",
+ update_only (fun node' ->
+ Handle.require Addressable.from node'
+ |> Result.map Addressable.address
+ |> fmap (fun addr -> self#deriving {relations= addr}) ) ) ] );
Prototype.Directory.of_properties
[ ( "relation",
- Prototype.mixture [RMDirectory.make ~storage ~node ~constructor:(R.load storage)]
+ Prototype.mixture_of node (fun make node ->
+ [ RMAddressable.make ~node:(RelationM.into node);
+ RMDirectory.make ~storage ~node ~constructor:(Entry.load storage);
+ RMAssociative.make ~storage ~node:(RelationM.into node)
+ ~constructor:(fun node' -> RelationM.from node' |> make |> Result.ok ) ] )
) ] ]
method hash = Representation.to_blob multigroup |> Concepts.Hash.hash_of_blob
diff --git a/lib/kernel/Path.ml b/lib/kernel/Path.ml
index 77a6b54..eeef396 100644
--- a/lib/kernel/Path.ml
+++ b/lib/kernel/Path.ml
@@ -2,6 +2,8 @@ type t = string list
let this = []
let ( @/ ) x y = x :: y
+let of_list segments = segments
+let to_list path = path
let to_string path =
path
diff --git a/lib/kernel/Path.mli b/lib/kernel/Path.mli
index 198ef83..571e59c 100644
--- a/lib/kernel/Path.mli
+++ b/lib/kernel/Path.mli
@@ -2,6 +2,8 @@ type t
val this : t
val ( @/ ) : string -> t -> t
+val of_list : string list -> t
+val to_list : t -> string list
val lookup : Protocols.Handle.t -> t -> (Protocols.Handle.t, Concepts.Condition.condition) result
val update :
diff --git a/lib/kernel/SubstantialRelation.ml b/lib/kernel/SubstantialRelation.ml
index 844b186..57bb79e 100644
--- a/lib/kernel/SubstantialRelation.ml
+++ b/lib/kernel/SubstantialRelation.ml
@@ -74,9 +74,17 @@ module Make (S : Abstract.Storage.STORAGE) = struct
let* tuples = TupleSet.find tx relation.tuples in
Option.to_result ~none:(Error.invalid_tuple_root relation.tuples) tuples
- let schema_of tx relation =
+ let store_schema tx description =
+ Concepts.Encoding.Bencode.(
+ Dict
+ ( BatMap.String.bindings description
+ |> List.map (fun (name, {Protocols.Schematics.domain; _}) -> name, String domain) )
+ |> to_blob )
+ |> SI.store_blob tx
+
+ let schema_of tx schematics =
let open Utilities.Result in
- let* data = SI.get_req tx (S.Hash relation.schematics) in
+ let* data = SI.get_req tx (S.Hash schematics) in
let* fields = Concepts.Encoding.Bencode.of_blob data in
let* kvs = Concepts.Encoding.Bencode.as_dict fields in
kvs
@@ -112,15 +120,17 @@ module Make (S : Abstract.Storage.STORAGE) = struct
method enumerate = enumerate connection relation
method protocols : Protocols.Handle.protocol list =
- [ Protocols.Relation.make self;
+ [ Protocols.Addressable.make self;
+ Protocols.Relation.make self;
Protocols.Enumerable.make self;
Protocols.Schematics.make self ]
method hash = encode relation |> Concepts.Hash.hash_of_blob
+ method address = self#hash
end
let load connection relation =
- SI.with_read connection (fun tx -> schema_of tx relation)
+ SI.with_read connection (fun tx -> schema_of tx relation.schematics)
|> Result.map (fun description ->
new substantial_relation connection relation description |> Protocols.Handle.make )
diff --git a/test/Helpers.ml b/test/Helpers.ml
index 7f65007..f812a3a 100644
--- a/test/Helpers.ml
+++ b/test/Helpers.ml
@@ -51,7 +51,9 @@ module Storage = struct
SR.TupleSet.insert tx (Concepts.Tuple.hash tuple) tuple node )
(Ok SR.TupleSet.empty) tuples
in
- Ok {SR.schematics; tuples= SR.TupleSet.hash_of node} )
+ let relation = {SR.schematics; tuples= SR.TupleSet.hash_of node} in
+ let* _ = SI.store_blob tx (SR.encode relation) in
+ Ok relation )
in
SR.load conn value
diff --git a/test/integration/Registration.ml b/test/integration/Registration.ml
index 60f1690..693435b 100644
--- a/test/integration/Registration.ml
+++ b/test/integration/Registration.ml
@@ -6,12 +6,28 @@ 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 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* 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* branch = B.make conn in
let* branch' =
Kernel.Path.(assoc branch ("multigroup" @/ this) "library" (Some multigroup))
@@ -20,15 +36,19 @@ module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) =
end
|> Helpers.condition_as_failure
|> ignore;
- begin
- let* root = I.initialize ~evaluators:["fol", Evaluators.FOL.make ()] conn in
- let* _ =
- Kernel.Path.(lookup root ("branch" @/ "master" @/ "multigroup" @/ "library" @/ this))
- in
- let* _ = Kernel.Path.(lookup root ("evaluator" @/ "fol" @/ this)) in
- Ok ()
- end
- |> Helpers.condition_as_failure
+ let attributes =
+ begin
+ let* root = I.initialize ~evaluators:["fol", Evaluators.FOL.make ()] conn in
+ let* branch = Kernel.Path.(lookup root ("branch" @/ "master" @/ this)) 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)
+ end
+ |> Helpers.condition_as_failure
+ in
+ check (list string) "the stored view reads the book it was defined over" ["title"] attributes
let suite =
( "registration",
diff --git a/test/unit/evaluators/FOL.ml b/test/unit/evaluators/FOL.ml
index 046fa3f..0a3dabc 100644
--- a/test/unit/evaluators/FOL.ml
+++ b/test/unit/evaluators/FOL.ml
@@ -88,6 +88,92 @@ module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) =
|> List.map (fun tuple -> BatMap.String.bindings tuple.Concepts.Tuple.attributes)
|> List.sort compare )
+ let instantiate_a_program conn =
+ let projected =
+ begin
+ let open Utilities.Result in
+ let* employees = H.relation conn ["name"; "age"] [employee "Alaric" 42] in
+ let root = Kernel.Prototype.(mixture [Directory.of_properties ["employee", employees]]) in
+ let* plan =
+ Rnt.Evaluators.FOL.(
+ instantiate (Kernel.Path.lookup root)
+ (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
+ drain result
+ end
+ |> Helpers.condition_as_failure
+ in
+ check
+ (list (list (pair string Helpers.value)))
+ "the program ran over the relation its path resolved to"
+ [["name", Concepts.Value.String "Alaric"]]
+ (projected |> List.map (fun tuple -> BatMap.String.bindings tuple.Concepts.Tuple.attributes))
+
+ module E = Kernel.EphemeralRelation.Make (S)
+
+ let store conn term =
+ E.persist conn ~name:"view" ~evaluator:Rnt.Evaluators.FOL.name
+ ~code:(Rnt.Evaluators.FOL.encode term)
+ (BatMap.String.singleton "name" {Protocols.Schematics.domain= "string"; provenance= []})
+
+ let namespace entries =
+ let open Utilities.Result in
+ let root = Kernel.Namespace.make () in
+ let* registry = Protocols.Handle.require Protocols.Registry.from root in
+ let* _ =
+ List.fold_left
+ (fun registered (name, handle) ->
+ let* _ = registered in
+ Protocols.Registry.update registry name None (Some handle) )
+ (Ok true) entries
+ in
+ Ok root
+
+ let expand_a_stored_program 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; "view", view] in
+ let* plan =
+ Rnt.Evaluators.FOL.(
+ 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
+ drain result
+ end
+ |> Helpers.condition_as_failure
+ in
+ check
+ (list (list (pair string Helpers.value)))
+ "the stored program ran in place of its name"
+ [["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
+ let open Utilities.Result in
+ let* view = store conn Rnt.Evaluators.FOL.(Base Kernel.Path.("view" @/ this)) in
+ let* root = namespace ["view", view] in
+ Rnt.Evaluators.FOL.(
+ instantiate (Kernel.Path.lookup root) (Base Kernel.Path.("view" @/ this)) )
+ end
+ in
+ check bool "the expansion stopped at the cycle" true
+ ( match expanded with
+ | Error condition ->
+ BatString.starts_with (Concepts.Condition.to_string_hum condition) "cyclic-program"
+ | Ok _ -> false )
+
let pull_one_tuple_at_a_time () =
let produced = ref 0 and closed = ref false in
let description =
@@ -102,7 +188,7 @@ module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) =
in
let source =
Kernel.EphemeralRelation.instantiate description
- {Kernel.EphemeralRelation.schematics= `Temporary description}
+ {Kernel.EphemeralRelation.name= None; schematics= `Temporary description; program= None}
(fun () -> Ok (Kernel.Generator.cursor_of ~finally:(fun () -> closed := true) (count 0)))
in
let first =
@@ -130,6 +216,12 @@ module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) =
[ test_case "scan-a-base-relation" `Quick (H.with_connection scan_a_base_relation "fol-test");
test_case "project-away-an-attribute" `Quick
(H.with_connection project_away_an_attribute "fol-test");
+ test_case "instantiate-a-program" `Quick
+ (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 "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 ] )
end
diff --git a/test/unit/kernel/EphemeralRelation.ml b/test/unit/kernel/EphemeralRelation.ml
index 95ce56d..7f113ef 100644
--- a/test/unit/kernel/EphemeralRelation.ml
+++ b/test/unit/kernel/EphemeralRelation.ml
@@ -12,10 +12,11 @@ let description =
{ Protocols.Schematics.domain= "integer";
provenance= [{Protocols.Schematics.source= ["example"]; attribute= "value"}] }
-let over ?inputs members =
- Ephemeral.instantiate ?inputs description
- {Ephemeral.schematics= `Temporary description}
- (fun () -> Ok (Rnt.Kernel.Generator.cursor_of (fun ~yield -> List.iter yield members; Ok ())))
+let temporary = {Ephemeral.name= None; schematics= `Temporary description; program= None}
+
+let over ?inputs ?(value = temporary) members =
+ Ephemeral.instantiate ?inputs description value (fun () ->
+ Ok (Rnt.Kernel.Generator.cursor_of (fun ~yield -> List.iter yield members; Ok ())) )
let values tuples =
BatFingerTree.to_list tuples
@@ -78,6 +79,20 @@ let describes_itself () =
^ origin.Protocols.Schematics.attribute ) ) )
| _ -> fail "an ephemeral relation describes itself as a relation"
+let addressed_once_persisted () =
+ let persisted code =
+ { Ephemeral.name= Some "example";
+ schematics= `Persisted (Concepts.Hash.hash_of_int 1);
+ program= Some {Ephemeral.evaluator= "fol"; code= Concepts.Hash.hash_of_int code} }
+ in
+ let address value =
+ Protocols.Addressable.from (over ~value []) |> Option.map Protocols.Addressable.address
+ in
+ check bool "a temporary relation has no address" true (Option.is_none (address temporary));
+ check bool "a persisted one has" true (Option.is_some (address (persisted 2)));
+ check bool "and its program is part of it" false
+ (Option.equal Concepts.Hash.hash_equals (address (persisted 2)) (address (persisted 3)))
+
let releasing_releases_its_inputs () =
let released = ref false in
let input =
@@ -99,4 +114,5 @@ let suites () =
[ test_case "enumerates-every-member" `Quick enumerates_every_member;
test_case "decides-membership" `Quick decides_membership;
test_case "describes-itself" `Quick describes_itself;
+ test_case "addressed-once-persisted" `Quick addressed_once_persisted;
test_case "releasing-releases-its-inputs" `Quick releasing_releases_its_inputs ] ) ]
generated by cgit v1.2.3 (git 2.25.1) at 2026-11-04 20:06:50 +0000