rework evaluators and add schema scope

1 files changed, 196 insertions, 0 deletions

diff --git a/lib/kernel/Schema.ml b/lib/kernel/Schema.ml
new file mode 100644
index 0000000..e121e7a
--- /dev/null
+++ b/lib/kernel/Schema.ml
@@ -0,0 +1,196 @@
+module Make (S : Abstract.Storage.STORAGE) = struct
+  module SI = Storage.Make (S)
+  module R = SubstantialRelation.Make (S)
+  module E = EphemeralRelation.Make (S)
+
+  (* A relation as a schema holds it. *)
+  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 ?bind storage = function
+      | Substantial relation -> R.load storage relation
+      | Ephemeral relation -> E.load ?bind storage relation
+
+    (* A program is stored as itself, to run whenever it is read; any
+       other relation is stored as the tuples it holds now. *)
+    let admit name h =
+      let open Utilities.Result in
+      let address entry = Concepts.Hash.hash_of_blob (encode entry) in
+      match EphemeralRelation.stored h with
+      | Some (evaluator, code, _) ->
+          let* description = Protocols.Relation.heading h in
+          Ok
+            (fun tx ->
+              let* record = E.store tx ~name ~evaluator ~code description in
+              Ok (address (Ephemeral record)) )
+      | None ->
+          let* description, tuples = Protocols.Relation.read h in
+          Ok
+            (fun tx ->
+              let* relation = R.store tx description tuples in
+              Ok (address (Substantial 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}
+
+  module Error = struct
+    open Concepts.Condition
+
+    let malformed_schema () =
+      condition "malformed-schema"
+        "The on-disk representation of a schema did not conform to what was expected. Is your \
+         database corrupted?"
+        empty
+
+    let incomplete_schema addr =
+      condition "incomplete-schema"
+        "A stored schema is missing part of its expected structure. Is your storage corrupted?"
+        ("address" |=| Concepts.Value.String (Concepts.Hash.to_hum_string addr))
+  end
+
+  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 = 'S'
+    let malformed = Error.malformed_schema
+
+    let fields {relations} =
+      let open Concepts.Encoding in
+      ["relations", Value.bencode_of_hash relations]
+
+    let of_fields fields =
+      let open Utilities.Result in
+      let open Concepts.Encoding in
+      let* relations = Bencode.field "relations" fields |> fmap Value.hash_of_bencode in
+      Ok {relations}
+  end
+
+  let encode = Representation.to_blob
+  let decode = Representation.of_blob
+
+  let node_of tx schema =
+    let open Utilities.Result in
+    RelationM.find tx schema.relations
+    |> fmap (Option.to_result ~none:(Error.incomplete_schema schema.relations))
+
+  class schema ?bind conn value node =
+    object (self)
+      inherit Lifecycle.null
+      method to_string = "schema"
+      val schema = value
+      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 schema' =
+        let open Utilities.Result in
+        let* node' =
+          SI.with_transaction storage (fun tx ->
+              let* _ = SI.store_blob tx (Representation.to_blob schema') in
+              node_of tx schema' )
+        in
+        new schema ?bind storage schema' 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_of node (fun make node ->
+                      [ RMAddressable.make ~node:(RelationM.into node);
+                        RMDirectory.make ~storage ~node ~constructor:(Entry.load ?bind storage);
+                        RMAssociative.make ~admit:Entry.admit ~storage ~node:(RelationM.into node)
+                          ~constructor:(fun node' -> RelationM.from node' |> make |> Result.ok)
+                          () ] ) ) ] ]
+
+      method hash = Representation.to_blob schema |> Concepts.Hash.hash_of_blob
+      method address = self#hash
+    end
+
+  let load ?bind conn value =
+    let open Utilities.Result in
+    let* node = SI.with_read conn (fun tx -> node_of tx value) in
+    new schema ?bind conn value node |> Protocols.Handle.make |> Result.ok
+
+  let make conn =
+    let open Utilities.Result in
+    SI.with_transaction conn (fun tx ->
+        let* empty = RelationM.empty_under tx in
+        let schema = {relations= empty} in
+        let* _ = SI.store_blob tx (Representation.to_blob schema) in
+        new schema conn schema RelationM.empty |> Protocols.Handle.make |> Result.ok )
+
+  (* Handed over as the tree shows one, a directory holding its relations
+     under \relation, a schema not stored yet is stored with them. *)
+  let admit _ h =
+    let open Utilities.Result in
+    let* listing = Protocols.Handle.require Protocols.Directory.from h in
+    let* relations = Protocols.Directory.find listing "relation" in
+    let* relations =
+      match relations with
+      | None -> Ok []
+      | Some relations ->
+          let* listing = Protocols.Handle.require Protocols.Directory.from relations in
+          let* names = Protocols.Directory.list listing in
+          BatFingerTree.to_list names
+          |> List.filter_map (fun name ->
+              match Protocols.Directory.find listing name with
+              | Ok None -> None
+              | Error c -> Some (Error c)
+              | Ok (Some relation) -> (
+                match Protocols.Addressable.from relation with
+                | Some a ->
+                    let addr = Protocols.Addressable.address a in
+                    Some (Ok (name, fun _ -> Ok addr))
+                | None -> Some (Entry.admit name relation |> Result.map (fun p -> name, p)) ) )
+          |> Utilities.List.sequence
+    in
+    Ok
+      (fun tx ->
+        let* _ = RelationM.empty_under tx in
+        let* node =
+          RelationM.with_batch tx (fun () ->
+              List.fold_left
+                (fun node (name, store) ->
+                  let* node = node in
+                  let* addr = store tx in
+                  RelationM.Tree.insert tx name addr (RelationM.into node)
+                  |> Result.map RelationM.from )
+                (Ok RelationM.empty) relations )
+        in
+        SI.store_blob tx (Representation.to_blob {relations= RelationM.hash_of node}) )
+end