diff options
Diffstat (limited to 'lib/kernel')
| -rw-r--r-- | lib/kernel/Generator.ml | 56 | ||||
| -rw-r--r-- | lib/kernel/Initialization.ml | 12 | ||||
| -rw-r--r-- | lib/kernel/Initialization.mli | 5 | ||||
| -rw-r--r-- | lib/kernel/SubstantialRelation.ml | 89 | ||||
| -rw-r--r-- | lib/kernel/SubstantialRelation.mli | 21 | ||||
| -rw-r--r-- | lib/kernel/Tuple.ml | 144 |
6 files changed, 306 insertions, 21 deletions
diff --git a/lib/kernel/Generator.ml b/lib/kernel/Generator.ml new file mode 100644 index 0000000..e4a15f8 --- /dev/null +++ b/lib/kernel/Generator.ml @@ -0,0 +1,56 @@ +type _ Effect.t += Yield : Concepts.Tuple.t -> unit Effect.t + +type step = + | Element of Concepts.Tuple.t * (unit, step) Effect.Deep.continuation + | Finished of (unit, Concepts.Condition.condition) result + +let start produce = + try Finished (produce ~yield:(fun tuple -> Effect.perform (Yield tuple))) with + | effect (Yield tuple), k -> Element (tuple, k) + +let resume k = Effect.Deep.continue k () + +class producer_cursor produce on_release = + object (self) + inherit Lifecycle.null + inherit Identity.of_id + + val mutable state : [`Fresh | `Live of (unit, step) Effect.Deep.continuation | `Done] = `Fresh + method protocols : Protocols.Handle.protocol list = Protocols.[Cursor.make self] + method private step : (Concepts.Tuple.t option, Concepts.Condition.condition) result = + let settle = function + | Element (tuple, k) -> + state <- `Live k; + Ok (Some tuple) + | Finished r -> + state <- `Done; + Result.map (fun () -> None) r + in + match state with + | `Done -> Ok None + | `Fresh -> settle (start produce) + | `Live k -> settle (resume k) + + method fetch limit = + let open Utilities.Result in + let rec fill taken tuples = + if taken >= limit then Ok Protocols.Cursor.{tuples; exhausted= false} + else + let* stepped = self#step in + match stepped with + | None -> Ok Protocols.Cursor.{tuples; exhausted= true} + | Some tuple -> fill (taken + 1) (BatFingerTree.snoc tuples tuple) + in + if limit <= 0 then + Ok Protocols.Cursor.{tuples= BatFingerTree.empty; exhausted= (state = `Done)} + else fill 0 BatFingerTree.empty + + method! release = + (match state with + | `Live _ -> Option.iter (fun f -> f ()) on_release + | `Fresh | `Done -> ()); + state <- `Done + end + +let cursor_of ?on_release produce = + new producer_cursor produce on_release |> Protocols.Handle.make diff --git a/lib/kernel/Initialization.ml b/lib/kernel/Initialization.ml index d213b66..ae041fc 100644 --- a/lib/kernel/Initialization.ml +++ b/lib/kernel/Initialization.ml @@ -1,12 +1,22 @@ module Make (S : Abstract.Storage.STORAGE) = struct module BM = BranchManager.Make (S) - let initialize conn = + let initialize ?(evaluators = []) conn = let open Utilities.Result in let open Protocols in let root = Namespace.make () in let registry = Registry.from root |> Option.get in let* branch_manager = BM.make conn "rnt-head" in let* _ = Registry.update registry "branch" None (Some branch_manager) in + let evaluator_namespace = Namespace.make () in + let evaluator_registry = Registry.from evaluator_namespace |> Option.get in + let* _ = + List.fold_left + (fun acc (name, handle) -> + let* _ = acc in + Registry.update evaluator_registry name None (Some handle)) + (Ok true) evaluators + in + let* _ = Registry.update registry "evaluator" None (Some evaluator_namespace) in Ok root end diff --git a/lib/kernel/Initialization.mli b/lib/kernel/Initialization.mli index 104d523..926bbd8 100644 --- a/lib/kernel/Initialization.mli +++ b/lib/kernel/Initialization.mli @@ -1,3 +1,6 @@ module Make (S : Abstract.Storage.STORAGE) : sig - val initialize : S.connection -> (Protocols.Handle.t, Concepts.Condition.condition) result + val initialize : + ?evaluators:(string * Protocols.Handle.t) list -> + S.connection -> + (Protocols.Handle.t, Concepts.Condition.condition) result end diff --git a/lib/kernel/SubstantialRelation.ml b/lib/kernel/SubstantialRelation.ml index eebae3e..6592acb 100644 --- a/lib/kernel/SubstantialRelation.ml +++ b/lib/kernel/SubstantialRelation.ml @@ -37,7 +37,7 @@ module Make (S : Abstract.Storage.STORAGE) = struct module TupleSet = Merkle.Make (S) (TupleKey) type t = - { heading: Concepts.Hash.hash; + { schematics: Concepts.Hash.hash; predicate: Concepts.Hash.hash option; local_constraints: Concepts.Hash.hash option; tuples: TupleSet.address; @@ -52,9 +52,9 @@ module Make (S : Abstract.Storage.STORAGE) = struct let tag = 'R' let malformed = Error.malformed_relation - let fields {heading; predicate; local_constraints; tuples; indexes} = + let fields {schematics; predicate; local_constraints; tuples; indexes} = let open Concepts.Encoding in - [ "heading", Value.bencode_of_hash heading; + [ "schema", Value.bencode_of_hash schematics; "predicate", Value.bencode_of_option Value.bencode_of_hash predicate; "local-constraints", Value.bencode_of_option Value.bencode_of_hash local_constraints; "tuples", Value.bencode_of_hash tuples; @@ -63,7 +63,7 @@ module Make (S : Abstract.Storage.STORAGE) = struct let of_fields fields = let open Utilities.Result in let open Concepts.Encoding in - let* heading = Bencode.field "heading" fields |> fmap Value.hash_of_bencode in + let* schematics = Bencode.field "schema" fields |> fmap Value.hash_of_bencode in let* predicate = Bencode.field "predicate" fields |> fmap (Value.option_of_bencode Value.hash_of_bencode) in @@ -75,13 +75,13 @@ module Make (S : Abstract.Storage.STORAGE) = struct let* indexes = Bencode.field "indexes" fields |> fmap (Value.option_of_bencode Value.hash_of_bencode) in - Ok {heading; predicate; local_constraints; tuples; indexes} + Ok {schematics; predicate; local_constraints; tuples; indexes} end let encode = Representation.to_blob let decode = Representation.of_blob - let heading {heading; _} = heading + let schematics {schematics; _} = schematics let predicate {predicate; _} = predicate let local_constraints {local_constraints; _} = local_constraints let tuples {tuples; _} = tuples @@ -93,10 +93,10 @@ 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 empty tx ~heading ?predicate ?local_constraints ?indexes () = + let empty tx ~schematics ?predicate ?local_constraints ?indexes () = let open Utilities.Result in let* tuples = TupleSet.empty_under tx in - Ok {heading; predicate; local_constraints; tuples; indexes} + Ok {schematics; predicate; local_constraints; tuples; indexes} let store tx relation = SI.store_blob tx (Representation.to_blob relation) @@ -107,27 +107,84 @@ module Make (S : Abstract.Storage.STORAGE) = struct let* present = TupleSet.lookup tx tuple node in Ok (Option.is_some present) + let schema_of tx relation = + let open Utilities.Result in + let* data = SI.get_req tx (S.Hash relation.schematics) in + let* fields = Concepts.Encoding.Bencode.of_blob data in + let* kvs = Concepts.Encoding.Bencode.as_dict fields in + kvs + |> List.map (fun (name, domain) -> + Concepts.Encoding.Bencode.as_string domain + |> Result.map (fun domain -> (name, domain))) + |> Utilities.List.sequence + |> Result.map (fun kvs -> + List.fold_left + (fun acc (name, domain) -> BatMap.String.add name domain acc) + BatMap.String.empty kvs) + + let enumerate storage relation = + let open Utilities.Result in + let* tx = S.start storage in + let* node = tuple_node tx relation in + let closed = ref false in + let close () = if not !closed then begin closed := true; ignore (S.abort tx) end in + (* The fold is suspended by [yield], so the tree is walked one node + and one tuple at a time rather than materialized before the + first tuple is produced. *) + let produce ~yield = + let* walked = + TupleSet.fold_left tx + (fun acc _ addr -> + let* () = acc in + let* tuple = + SI.get_req tx (S.Hash addr) |> fmap Concepts.Tuple.Representation.of_blob + in + yield tuple; + Ok ()) + (Ok ()) node + in + close (); + walked + in + Ok (Generator.cursor_of ~on_release:close produce) + class relation storage value = object (self) inherit Lifecycle.null val storage : S.connection = storage val relation : t = value - method heading = Ok relation.heading method predicate = Ok relation.predicate method local_constraints = Ok relation.local_constraints - method tuples = Ok relation.tuples - - method contains tuple = - SI.with_transaction storage (fun tx -> contains_tuple tx relation tuple) - method protocols : Protocols.Handle.protocol list = Protocols.[Relation.make self] + (* The protocol takes a tuple, not bytes: encoding is this object's business, and a caller + that had to produce the exact stored bytes would have to know this encoding to do it. *) + method contains (tuple : Concepts.Tuple.t) = + SI.with_transaction storage (fun tx -> + contains_tuple tx relation (Concepts.Tuple.Representation.to_blob tuple) ) + + method describe () = + let open Utilities.Result in + let* description = SI.with_transaction storage (fun tx -> schema_of tx relation) in + Ok (Protocols.Schematics.Relation description) + + (* A substantial relation is finitely enumerable, so it carries [Enumerable] as well as + [Relation]. A procedural relation would carry only the latter, which is how an evaluator + discovers it cannot iterate one -- see [Protocols.Enumerable]. The context is accepted and + unused here: this enumeration reads through its own cursor-lifetime transaction and needs + no name resolution, but cancellation should eventually be checked between tuples. *) + method enumerate (_ : Protocols.Context.t) = enumerate storage relation + + method protocols : Protocols.Handle.protocol list = + [ Protocols.Relation.make self + ; Protocols.Enumerable.make self + ; Protocols.Schematics.make self ] method hash = hash relation end - let make conn ~heading ?predicate ?local_constraints ?indexes () = + let make conn ~schematics ?predicate ?local_constraints ?indexes () = let open Utilities.Result in SI.with_transaction conn (fun tx -> - let* relation = empty tx ~heading ?predicate ?local_constraints ?indexes () in + let* relation = empty tx ~schematics ?predicate ?local_constraints ?indexes () in let* _ = store tx relation in Ok (new relation conn relation |> Protocols.Handle.make) ) diff --git a/lib/kernel/SubstantialRelation.mli b/lib/kernel/SubstantialRelation.mli index 9e61411..be2ad28 100644 --- a/lib/kernel/SubstantialRelation.mli +++ b/lib/kernel/SubstantialRelation.mli @@ -6,7 +6,7 @@ module Make (S : Abstract.Storage.STORAGE) : sig val empty : S.transaction -> - heading:Concepts.Hash.hash -> + schematics:Concepts.Hash.hash -> ?predicate:Concepts.Hash.hash -> ?local_constraints:Concepts.Hash.hash -> ?indexes:Concepts.Hash.hash -> @@ -17,7 +17,7 @@ module Make (S : Abstract.Storage.STORAGE) : sig val make : S.connection -> - heading:Concepts.Hash.hash -> + schematics:Concepts.Hash.hash -> ?predicate:Concepts.Hash.hash -> ?local_constraints:Concepts.Hash.hash -> ?indexes:Concepts.Hash.hash -> @@ -34,7 +34,7 @@ module Make (S : Abstract.Storage.STORAGE) : sig Concepts.Hash.hash -> (Protocols.Handle.t, Concepts.Condition.condition) result - val heading : t -> Concepts.Hash.hash + val schematics : t -> Concepts.Hash.hash val predicate : t -> Concepts.Hash.hash option val local_constraints : t -> Concepts.Hash.hash option val tuples : t -> Concepts.Hash.hash @@ -46,4 +46,19 @@ module Make (S : Abstract.Storage.STORAGE) : sig val contains_tuple : S.transaction -> t -> Concepts.Blob.t -> (bool, Concepts.Condition.condition) result + + (** decodes the schematics at [schematics relation] -- the body of + [Protocols.Schematics.describe] for this kind of relation. *) + val schema_of : + S.transaction -> + t -> + (Protocols.Schematics.relation_description, Concepts.Condition.condition) result + + (** a handle carrying [Protocols.Cursor] over every tuple currently + asserted, decoded via [Concepts.Tuple.Representation.of_blob] -- + the body of [Protocols.Relation.enumerate] for this kind of + relation. Opens its own storage transaction, held for the + cursor's whole lifetime rather than just this call -- see + [Kernel.Generator] and docs/design/evaluator.md, "Shape". *) + val enumerate : S.connection -> t -> (Protocols.Handle.t, Concepts.Condition.condition) result end diff --git a/lib/kernel/Tuple.ml b/lib/kernel/Tuple.ml new file mode 100644 index 0000000..ef591ae --- /dev/null +++ b/lib/kernel/Tuple.ml @@ -0,0 +1,144 @@ +module Make (S : Abstract.Storage.STORAGE) = struct + module SI = Storage.Make (S) + + module Error = struct + open Concepts.Condition + + let unknown_attribute name = + condition "unknown-attribute" "No such attribute on this tuple" + ("attribute" |=| Concepts.Value.String name) + let malformed_value () = + condition "malformed-tuple-value" + "A tuple field did not conform to what was expected" empty + let incomplete_tuple addr = + condition "incomplete-tuple" + "A stored tuple is missing part of its expected structure. Is your storage corrupted?" + ("address" |=| Concepts.Value.String (Concepts.Hash.to_hum_string addr)) + end + + module Attribute = struct + type t = Concepts.Value.value + + let malformed_value = Error.malformed_value + + let encode value = + let open Concepts.Encoding in + Bencode.to_blob + (match value with + | Concepts.Value.String s -> Bencode.Tagged ('s', Bencode.String s) + | Concepts.Value.Integer n -> Bencode.Tagged ('i', Bencode.Int n)) + + 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 ('s', Bencode.String s) -> Ok (Concepts.Value.String s) + | Bencode.Tagged ('i', Bencode.Int n) -> Ok (Concepts.Value.Integer n) + | _ -> Error (malformed_value ()) + + let domain = function + | Concepts.Value.String _ -> "string" + | Concepts.Value.Integer _ -> "integer" + end + + module AttributeM = Merkle.Interface (S) (Merkle.StringKey) (Attribute) + + (* TODO: ephemeral tuples are served by instantiating this functor + over an in-memory storage. Consider later splitting [t] into + resident (an address) and ephemeral (an in-memory attribute map) + forms instead. *) + type t = { type_ : string; attributes : AttributeM.address } + + 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 = 'T' + let malformed = Error.malformed_value + + let fields { type_; attributes } = + let open Concepts.Encoding in + [ "type", Bencode.String type_; + "attributes", Value.bencode_of_hash attributes ] + + let of_fields data = + let open Utilities.Result in + let open Concepts.Encoding in + let* type_ = Bencode.field "type" data |> fmap Bencode.as_string in + let* attributes = Bencode.field "attributes" data |> fmap Value.hash_of_bencode in + Ok { type_; attributes } + end + + let encode = Representation.to_blob + let decode = Representation.of_blob + let hash tuple = Representation.to_blob tuple |> Concepts.Hash.hash_of_blob + + let type_of { type_; _ } = type_ + + let node tx { attributes; _ } = + let open Utilities.Result in + AttributeM.find tx attributes + |> fmap (Option.to_result ~none:(Error.incomplete_tuple attributes)) + + let empty tx ~type_ () = + let open Utilities.Result in + let* attributes = AttributeM.empty_under tx in + Ok { type_; attributes } + + let make tx ~type_ attributes = + let open Utilities.Result in + let* node = + AttributeM.with_batch tx (fun () -> + BatMap.String.enum attributes + |> BatEnum.fold + (fun node (name, value) -> + let* node = node in + AttributeM.insert tx name value node) + (Ok AttributeM.empty)) + in + Ok { type_; attributes = AttributeM.hash_of node } + + let attribute tx tuple name = + let open Utilities.Result in + let* node = node tx tuple in + let* value = AttributeM.lookup tx name node in + Option.to_result ~none:(Error.unknown_attribute name) value + + let attributes tx tuple = + let open Utilities.Result in + let* node = node tx tuple in + AttributeM.fold_left tx + (fun acc name value -> BatMap.String.add name value acc) + BatMap.String.empty node + + class tuple ~relation conn value node = object (self) + inherit Lifecycle.null + + val tuple = value + val storage = conn + val node = node + + method describe () = + let open Utilities.Result in + let* attributes = + SI.with_transaction storage (fun tx -> + AttributeM.fold_left tx + (fun acc name value -> BatMap.String.add name (Attribute.domain value) acc) + BatMap.String.empty node) + in + Ok (Protocols.Schematics.Tuple { Protocols.Schematics.relation; attributes }) + + method protocols : Protocols.Handle.protocol list = + [Protocols.Schematics.make self] + + method hash = hash tuple + end + + let wrap ~relation conn value = + let open Utilities.Result in + let* node = SI.with_transaction conn (fun tx -> node tx value) in + new tuple ~relation conn value node |> Protocols.Handle.make |> Result.ok +end |