diff options
Diffstat (limited to 'lib')
| -rw-r--r-- | lib/concepts/Tuple.ml | 45 | ||||
| -rw-r--r-- | lib/kernel/EphemeralRelation.ml | 87 | ||||
| -rw-r--r-- | lib/kernel/EphemeralRelation.mli | 26 | ||||
| -rw-r--r-- | lib/kernel/SubstantialRelation.ml | 51 | ||||
| -rw-r--r-- | lib/kernel/SubstantialRelation.mli | 20 | ||||
| -rw-r--r-- | lib/kernel/Tuple.ml | 15 | ||||
| -rw-r--r-- | lib/protocols/Context.ml | 4 | ||||
| -rw-r--r-- | lib/protocols/Relation.ml | 2 | ||||
| -rw-r--r-- | lib/protocols/Relation.mli | 2 | ||||
| -rw-r--r-- | lib/runtime/Context.ml | 68 | ||||
| -rw-r--r-- | lib/runtime/Context.mli | 9 |
11 files changed, 124 insertions, 205 deletions
diff --git a/lib/concepts/Tuple.ml b/lib/concepts/Tuple.ml new file mode 100644 index 0000000..296bf26 --- /dev/null +++ b/lib/concepts/Tuple.ml @@ -0,0 +1,45 @@ +type t = { type_ : string; attributes : Value.value BatMap.String.t } + +let malformed_value () = + Condition.condition "malformed-tuple-value" + "A tuple field did not conform to what was expected" Condition.empty + +let bencode_of_value = function + | Value.String s -> Encoding.Bencode.Tagged ('s', Encoding.Bencode.String s) + | Value.Integer n -> Encoding.Bencode.Tagged ('i', Encoding.Bencode.Int n) + +let value_of_bencode = function + | Encoding.Bencode.Tagged ('s', Encoding.Bencode.String s) -> Ok (Value.String s) + | Encoding.Bencode.Tagged ('i', Encoding.Bencode.Int n) -> Ok (Value.Integer n) + | _ -> Error (malformed_value ()) + +module rec Representation : (Encoding.Record.S with type t = t) = + Encoding.Record.Make (Body) + +and Body : Encoding.Record.BODY = struct + type nonrec t = t + + let tag = 'T' + let malformed = malformed_value + + let fields { type_; attributes } = + [ "type", Encoding.Bencode.String type_; + "attributes", + Encoding.Bencode.Dict + (BatMap.String.enum attributes + |> BatEnum.fold + (fun acc (name, value) -> (name, bencode_of_value value) :: acc) + []) ] + + let of_fields data = + let open Utilities.Result in + let* type_ = Encoding.Bencode.field "type" data |> fmap Encoding.Bencode.as_string in + let* kvs = Encoding.Bencode.field "attributes" data |> fmap Encoding.Bencode.as_dict in + kvs + |> List.map (fun (name, v) -> value_of_bencode v |> Result.map (fun v -> (name, v))) + |> Utilities.List.sequence + |> Result.map (fun kvs -> + { type_; attributes = BatMap.String.of_list kvs }) +end + +let hash tuple = Representation.to_blob tuple |> Hash.hash_of_blob diff --git a/lib/kernel/EphemeralRelation.ml b/lib/kernel/EphemeralRelation.ml deleted file mode 100644 index 7682c80..0000000 --- a/lib/kernel/EphemeralRelation.ml +++ /dev/null @@ -1,87 +0,0 @@ -module Make (S : Abstract.Storage.STORAGE) = struct - module SI = Storage.Make (S) - - type t = { - heading: Concepts.Hash.hash; - evaluator: string; - source: string; - entry: string; - bindings: Concepts.Hash.hash; - inputs: string BatFingerTree.t - } - - module Error = struct - open Concepts.Condition - - let malformed () = - condition "malformed-ephemeral-relation" - "The on-disk representation of an ephemeral relation did not conform to what was expected" - empty - - let replay_not_implemented () = - condition "ephemeral-relation-replay-not-implemented" - "Replaying an ephemeral relation's stored plan is not implemented in this slice -- \ - see lib/kernel/EphemeralRelation.mli" - empty - end - - let heading {heading; _} = heading - let evaluator {evaluator; _} = evaluator - let inputs {inputs; _} = inputs - - let make ~heading ~evaluator ~source ~entry ~bindings ~inputs () = - Ok {heading; evaluator; source; entry; bindings; inputs} - - 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 - - let fields {heading; evaluator; source; entry; bindings; inputs} = - let open Concepts.Encoding in - [ "heading", Value.bencode_of_hash heading; - "evaluator", Field.string evaluator; - "source", Field.string source; - "entry", Field.string entry; - "bindings", Value.bencode_of_hash bindings; - "inputs", Bencode.List (BatFingerTree.to_list inputs |> List.map Field.string) ] - - (* TODO: symmetric to `fields` above -- decode each field back with - Concepts.Encoding.Bencode.{field,as_string,as_list} and - Concepts.Encoding.Value.hash_of_bencode, then rebuild the - BatFingerTree for `inputs` with BatFingerTree.of_list. Left - unimplemented because nothing in this slice ever calls `load` - on a real address (see `load` below); the algorithm is exactly - SubstantialRelation.Body.of_fields's shape, one field wider. *) - let of_fields _fields = Error (malformed ()) [@@warning "-27"] - end - - let store tx relation = SI.store_blob tx (Representation.to_blob relation) - - (* TODO: `enumerate`/`contains` on the Relation object this should - return must, on every call: - 1. resolve `evaluator` via the *current* Runtime.Context's root, - not the one live when `make` ran (lifecycle.org: "not - version-pinned paths" -- the whole point of storing a path - instead of a hash for `evaluator` and `inputs`); - 2. `Protocols.Evaluator.admit source` against it; - 3. `Protocols.Program.invoke ~entry ~bindings:(decode bindings)`; - 4. drain the resulting Cursor into this call's answer. - None of that belongs in this module (see the module comment on - layering) -- it belongs in whatever session/host module builds - Runtime.Context.t values, since only that code is already - S-aware AND Protocols-aware. `load` therefore returns a handle - whose Relation methods all fail with `Error.replay_not_implemented` - rather than wiring a half-generic version of that four-step - replay here. *) - let load tx conn addr = - let open Utilities.Result in - let* data = SI.get_req tx (S.Hash addr) in - let* (_relation : t) = Representation.of_blob data in - let _ = conn in - Error (Error.replay_not_implemented ()) -end diff --git a/lib/kernel/EphemeralRelation.mli b/lib/kernel/EphemeralRelation.mli deleted file mode 100644 index e579abd..0000000 --- a/lib/kernel/EphemeralRelation.mli +++ /dev/null @@ -1,26 +0,0 @@ -module Make (S : Abstract.Storage.STORAGE) : sig - type t - - val make : - heading:Concepts.Hash.hash -> - evaluator:string -> - source:string -> - entry:string -> - bindings:Concepts.Hash.hash -> - inputs:string BatFingerTree.t -> - unit -> - (t, Concepts.Condition.condition) result - - val store : S.transaction -> t -> (Concepts.Hash.hash, Concepts.Condition.condition) result - val load : S.transaction -> S.connection -> Concepts.Hash.hash -> (Protocols.Handle.t, Concepts.Condition.condition) result - val heading : t -> Concepts.Hash.hash - val evaluator : t -> string - val inputs : t -> string BatFingerTree.t - - module Error : sig - val malformed : unit -> Concepts.Condition.condition - val replay_not_implemented : unit -> Concepts.Condition.condition - end - - module Representation : Concepts.Encoding.Record.S with type t = t -end diff --git a/lib/kernel/SubstantialRelation.ml b/lib/kernel/SubstantialRelation.ml index b0c8a51..3094eb8 100644 --- a/lib/kernel/SubstantialRelation.ml +++ b/lib/kernel/SubstantialRelation.ml @@ -1,7 +1,4 @@ -module Make (S : Abstract.Storage.STORAGE) (Schematics : sig - include Protocols.Schematics.S - val of_blob : Concepts.Blob.t -> (Schema.t, Concepts.Condition.condition) result -end) = struct +module Make (S : Abstract.Storage.STORAGE) = struct module SI = Storage.Make (S) module Error = struct @@ -40,7 +37,7 @@ end) = 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; @@ -55,9 +52,9 @@ end) = 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; @@ -66,7 +63,7 @@ end) = 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 @@ -78,13 +75,13 @@ end) = 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 @@ -96,10 +93,10 @@ end) = 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) @@ -110,10 +107,20 @@ end) = struct let* present = TupleSet.lookup tx tuple node in Ok (Option.is_some present) - let heading_value tx relation = + let schema_of tx relation = let open Utilities.Result in - let* data = SI.get_req tx (S.Hash relation.heading) in - Schematics.of_blob data + 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 @@ -154,7 +161,6 @@ end) = struct 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 @@ -164,7 +170,10 @@ end) = struct SI.with_transaction storage (fun tx -> contains_tuple tx relation (Concepts.Tuple.Representation.to_blob tuple) ) - method schema = SI.with_transaction storage (fun tx -> heading_value tx relation) + 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 @@ -174,14 +183,16 @@ end) = struct method enumerate (_ : Protocols.Context.t) = enumerate storage relation method protocols : Protocols.Handle.protocol list = - [Protocols.Relation.make self; Protocols.Enumerable.make self; Schematics.make self] + [ 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 866c3a0..be2ad28 100644 --- a/lib/kernel/SubstantialRelation.mli +++ b/lib/kernel/SubstantialRelation.mli @@ -1,7 +1,4 @@ -module Make (S : Abstract.Storage.STORAGE) (Schematics : sig - include Protocols.Schematics.S - val of_blob : Concepts.Blob.t -> (Schema.t, Concepts.Condition.condition) result -end) : sig +module Make (S : Abstract.Storage.STORAGE) : sig type t val encode : t -> Concepts.Blob.t @@ -9,7 +6,7 @@ end) : 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 -> @@ -20,7 +17,7 @@ end) : 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 -> @@ -37,7 +34,7 @@ end) : 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 @@ -50,9 +47,12 @@ end) : sig val contains_tuple : S.transaction -> t -> Concepts.Blob.t -> (bool, Concepts.Condition.condition) result - (** decodes the heading at [heading relation] -- the body of - [Schematics.schema] for this kind of relation. *) - val heading_value : S.transaction -> t -> (Schematics.Schema.t, 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] -- diff --git a/lib/kernel/Tuple.ml b/lib/kernel/Tuple.ml index 50ce5b5..ef591ae 100644 --- a/lib/kernel/Tuple.ml +++ b/lib/kernel/Tuple.ml @@ -19,6 +19,8 @@ module Make (S : Abstract.Storage.STORAGE) = struct 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 @@ -33,7 +35,7 @@ module Make (S : Abstract.Storage.STORAGE) = struct 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 (Error.malformed_value ()) + | _ -> Error (malformed_value ()) let domain = function | Concepts.Value.String _ -> "string" @@ -90,11 +92,12 @@ module Make (S : Abstract.Storage.STORAGE) = struct let open Utilities.Result in let* node = AttributeM.with_batch tx (fun () -> - BatMap.String.foldi - (fun name value node -> - let* node = node in - AttributeM.insert tx name value node) - attributes (Ok AttributeM.empty)) + 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 } diff --git a/lib/protocols/Context.ml b/lib/protocols/Context.ml new file mode 100644 index 0000000..b7c8a37 --- /dev/null +++ b/lib/protocols/Context.ml @@ -0,0 +1,4 @@ +type t = + { snapshot : Concepts.Hash.hash + ; root : Handle.t + ; status : unit -> [`Live | `Cancelled | `Exhausted] } diff --git a/lib/protocols/Relation.ml b/lib/protocols/Relation.ml index 54454cf..c05337f 100644 --- a/lib/protocols/Relation.ml +++ b/lib/protocols/Relation.ml @@ -7,7 +7,6 @@ module Error = struct end class type implementation = object - method heading : (Concepts.Hash.hash, Concepts.Condition.condition) result method predicate : (Concepts.Hash.hash option, Concepts.Condition.condition) result method local_constraints : (Concepts.Hash.hash option, Concepts.Condition.condition) result method contains : Concepts.Tuple.t -> (bool, Concepts.Condition.condition) result @@ -19,7 +18,6 @@ type t = implementation let make impl = Relation (impl :> implementation) let from handle = Handle.into handle (function Relation impl -> Some impl | _ -> None) let require handle = from handle |> Option.to_result ~none:(Error.not_a_relation ()) -let heading i = Handle.invoke i (fun o -> o#heading) let predicate i = Handle.invoke i (fun o -> o#predicate) let local_constraints i = Handle.invoke i (fun o -> o#local_constraints) let contains i tuple = Handle.invoke i (fun o -> o#contains tuple) diff --git a/lib/protocols/Relation.mli b/lib/protocols/Relation.mli index 7e64a3b..384877e 100644 --- a/lib/protocols/Relation.mli +++ b/lib/protocols/Relation.mli @@ -1,7 +1,6 @@ type t class type implementation = object - method heading : (Concepts.Hash.hash, Concepts.Condition.condition) result method predicate : (Concepts.Hash.hash option, Concepts.Condition.condition) result method local_constraints : (Concepts.Hash.hash option, Concepts.Condition.condition) result method contains : Concepts.Tuple.t -> (bool, Concepts.Condition.condition) result @@ -10,7 +9,6 @@ end val make : #implementation -> Handle.protocol val from : Handle.t -> t Handle.interface option val require : Handle.t -> (t Handle.interface, Concepts.Condition.condition) result -val heading : t Handle.interface -> (Concepts.Hash.hash, Concepts.Condition.condition) result val predicate : t Handle.interface -> (Concepts.Hash.hash option, Concepts.Condition.condition) result diff --git a/lib/runtime/Context.ml b/lib/runtime/Context.ml index 10422e4..000f5d6 100644 --- a/lib/runtime/Context.ml +++ b/lib/runtime/Context.ml @@ -1,60 +1,30 @@ module Error = struct open Concepts.Condition - let budget_exhausted ~requested ~remaining = - condition "budget-exhausted" "An evaluation asked for more budget than it had left" - ("requested" |=| Concepts.Value.Integer requested - & "remaining" |=| Concepts.Value.Integer remaining) - let not_a_directory segment = condition "not-a-directory" "A path segment named an object with no Directory protocol" ("segment" |=| Concepts.Value.String segment) end -type budget = int Atomic.t - -let charge_budget budget n = +let resolve { Protocols.Context.root; _ } name = let open Utilities.Result in - let* _ = - Utilities.Atomic.mswap budget (fun remaining -> - if remaining >= n then Ok (remaining - n) - else Error (Error.budget_exhausted ~requested:n ~remaining) ) + let rec walk handle = function + | [] -> Ok (Protocols.Handle.copy handle) + | segment :: rest -> + let* directory = + Protocols.Directory.from handle + |> Option.to_result ~none:(Error.not_a_directory segment) + in + let* found = Protocols.Directory.find directory segment in + match found with + | None -> Ok None + | Some child -> + Fun.protect ~finally:(fun () -> Protocols.Handle.release child) + (fun () -> walk child rest) in - Ok () - -class context ~root ~budget ~cancelled = - object (self) - val root : Protocols.Handle.t = root - val budget : budget = budget - val cancelled : unit -> bool = cancelled - - method resolve (name : string) : - (Protocols.Handle.t option, Concepts.Condition.condition) result = - let open Utilities.Result in - let rec walk handle = function - | [] -> Ok (Protocols.Handle.copy handle) - | segment :: rest -> - let* directory = Protocols.Directory.from handle - |> Option.to_result ~none:(Error.not_a_directory segment) - in - let* found = Protocols.Directory.find directory segment in - match found with - | None -> Ok None - | Some child -> - Fun.protect ~finally:(fun () -> Protocols.Handle.release child) - (fun () -> walk child rest) - in - String.split_on_char '/' name |> List.filter (fun segment -> segment <> "") |> walk root - - method cancelled = cancelled () - method charge n = charge_budget budget n - method nest ?authority:(_ : string BatSet.t option) () = - (new context ~root ~budget ~cancelled :> Protocols.Context.implementation) - - initializer ignore self - end - -let over ~root ?(budget = max_int) ?(cancelled = fun () -> false) () = - Protocols.Context.make (new context ~root ~budget:(Atomic.make budget) ~cancelled) + String.split_on_char '/' name |> List.filter (fun segment -> segment <> "") |> walk root -let remaining (_ : Protocols.Context.t) : int option = failwith "not implemented" +let over ~snapshot ~root ?(cancelled = fun () -> false) () = + { Protocols.Context.snapshot + ; root + ; status = (fun () -> if cancelled () then `Cancelled else `Live) } diff --git a/lib/runtime/Context.mli b/lib/runtime/Context.mli index 31ef194..6e7ab2f 100644 --- a/lib/runtime/Context.mli +++ b/lib/runtime/Context.mli @@ -1,8 +1,11 @@ +val resolve : + Protocols.Context.t -> + string -> + (Protocols.Handle.t option, Concepts.Condition.condition) result + val over : + snapshot:Concepts.Hash.hash -> root:Protocols.Handle.t -> - ?budget:int -> ?cancelled:(unit -> bool) -> unit -> Protocols.Context.t - -val remaining : Protocols.Context.t -> int option |