blob: 50ce5b534b8870bed2d7bdf5a8fb7842f105e9aa (
plain) (
blame)
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
|
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)
(* 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.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
|
