aboutsummaryrefslogtreecommitdiffstats
path: root/lib
diff options
context:
space:
mode:
Diffstat (limited to '')
-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
7 files changed, 261 insertions, 16 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 )
generated by cgit v1.2.3 (git 2.25.1) at 2026-11-04 10:06:42 +0000