rework on tuple non resident object with schematics as protocol

1 files changed, 137 insertions, 0 deletions

diff --git a/lib/kernel/Tuple.ml b/lib/kernel/Tuple.ml
new file mode 100644
index 0000000..e8f2f7f
--- /dev/null
+++ b/lib/kernel/Tuple.ml
@@ -0,0 +1,137 @@
+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 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 (Error.malformed_value ())
+
+    let domain = function
+      | Concepts.Value.String _ -> "string"
+      | Concepts.Value.Integer _ -> "integer"
+  end
+
+  module AttributeM = Merkle.Interface (S) (Merkle.StringKey) (Attribute)
+
+  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.foldi
+            (fun name value node ->
+              let* node = node in
+              AttributeM.insert tx name value node)
+            attributes (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