lib/kernel/Tuple.ml


1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142

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
      method to_string = "tuple"
      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