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
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
|
module Make (S : Abstract.Storage.STORAGE) = struct
module SI = Storage.Make (S)
module Error = struct
open Concepts.Condition
let malformed_relation () =
condition "malformed-substantial-relation"
"The on-disk representation of a substantial relation did not conform to what was \
expected. Is your database corrupted?"
empty
let malformed_tuple_key length =
condition "malformed-tuple-key" "A tuple key did not have the expected hash size"
("length" |=| Concepts.Value.Integer length)
let invalid_tuple_root root =
condition "invalid-tuple-root"
"The tuple-set root for a substantial relation is missing from the backend. Either your \
storage is corrupted, or this is a bug in RNT!"
("hash" |=| Concepts.Value.String (Concepts.Hash.to_hum_string root))
end
module TupleKey = struct
type t = Concepts.Hash.hash
let encode = Concepts.Hash.blob_of_hash
let decode blob =
let raw = Concepts.Blob.bytes_of_blob blob |> Bytes.to_string in
if String.length raw = Concepts.Hash.size then Ok (Concepts.Hash.of_raw_string raw)
else Error (Error.malformed_tuple_key (String.length raw))
let compare = Concepts.Hash.compare
end
module TupleValue = struct
type t = Concepts.Tuple.t
let encode = Concepts.Tuple.Representation.to_blob
let decode = Concepts.Tuple.Representation.of_blob
end
module TupleSet = Merkle.Interface (S) (TupleKey) (TupleValue)
type t =
{ schematics: Concepts.Hash.hash;
predicate: Concepts.Hash.hash option;
local_constraints: Concepts.Hash.hash option;
tuples: TupleSet.address;
indexes: Concepts.Hash.hash option }
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 = 'R'
let malformed = Error.malformed_relation
let fields {schematics; predicate; local_constraints; tuples; indexes} =
let open Concepts.Encoding in
[ "schema", Value.bencode_of_hash schematics;
"predicate", Value.bencode_of_option Value.bencode_of_hash predicate;
"local-constraints", Value.bencode_of_option Value.bencode_of_hash local_constraints;
"tuples", Value.bencode_of_hash tuples;
"indexes", Value.bencode_of_option Value.bencode_of_hash indexes ]
let of_fields fields =
let open Utilities.Result in
let open Concepts.Encoding in
let* schematics = Bencode.field "schema" fields |> fmap Value.hash_of_bencode in
let* predicate =
Bencode.field "predicate" fields |> fmap (Value.option_of_bencode Value.hash_of_bencode)
in
let* local_constraints =
Bencode.field "local-constraints" fields
|> fmap (Value.option_of_bencode Value.hash_of_bencode)
in
let* tuples = Bencode.field "tuples" fields |> fmap Value.hash_of_bencode in
let* indexes =
Bencode.field "indexes" fields |> fmap (Value.option_of_bencode Value.hash_of_bencode)
in
Ok {schematics; predicate; local_constraints; tuples; indexes}
end
let encode = Representation.to_blob
let decode = Representation.of_blob
let schematics {schematics; _} = schematics
let predicate {predicate; _} = predicate
let local_constraints {local_constraints; _} = local_constraints
let tuples {tuples; _} = tuples
let indexes {indexes; _} = indexes
let hash relation = Representation.to_blob relation |> Concepts.Hash.hash_of_blob
let tuple_node tx relation =
let open Utilities.Result in
let* tuples = TupleSet.find tx relation.tuples in
Option.to_result ~none:(Error.invalid_tuple_root relation.tuples) tuples
let empty tx ~schematics ?predicate ?local_constraints ?indexes () =
let open Utilities.Result in
let* tuples = TupleSet.empty_under tx in
Ok {schematics; predicate; local_constraints; tuples; indexes}
let store tx relation = SI.store_blob tx (Representation.to_blob relation)
let contains_tuple tx relation tuple =
let open Utilities.Result in
let* node = tuple_node tx relation in
TupleSet.mem tx (Concepts.Tuple.hash tuple) node
let schema_of tx relation =
let open Utilities.Result in
let* data = SI.get_req tx (S.Hash relation.schematics) in
let* fields = Concepts.Encoding.Bencode.of_blob data in
let* kvs = Concepts.Encoding.Bencode.as_dict fields in
kvs
|> List.map (fun (name, domain) ->
Concepts.Encoding.Bencode.as_string domain
|> Result.map (fun domain ->
(name, {Protocols.Schematics.domain; provenance= []}) ) )
|> Utilities.List.sequence
|> Result.map BatMap.String.of_list
let generate storage relation binding =
let open Utilities.Result in
let* tx = S.start_read storage in
let close () = ignore (S.abort tx) in
let* node = tuple_node tx relation |> Result.map_error (fun c -> close (); c) in
(* The fold is suspended by [yield], so the tree is walked one node
and one tuple at a time rather than materialized before the
first tuple is produced. *)
let produce ~yield =
TupleSet.iter tx
(fun _ tuple -> if Protocols.Generative.satisfies binding tuple then yield tuple)
node
in
Ok (Generator.cursor_of ~finally:close produce)
let enumerate storage relation = generate storage relation Protocols.Generative.nothing
let modes_of description =
Concepts.Mode.of_list
[ Concepts.Mode.enumerable Concepts.Cardinality.Finite;
{Concepts.Mode.bound= Concepts.Mode.attributes_of_map description; affords= Decides} ]
let modes tx relation = schema_of tx relation |> Result.map modes_of
class relation storage value description =
object (self)
inherit Lifecycle.null
val storage : S.connection = storage
val relation : t = value
val declaration = modes_of description
method predicate = Ok relation.predicate
method local_constraints = Ok relation.local_constraints
(* The protocol takes a tuple, not bytes: encoding is this object's business, and a caller
that had to produce the exact stored bytes would have to know this encoding to do it. *)
method contains (tuple : Concepts.Tuple.t) =
SI.with_read storage (fun tx -> contains_tuple tx relation tuple)
method describe () = Ok (Protocols.Schematics.Relation description)
(* A substantial relation is finitely enumerable, so it carries [Enumerable] as well as
[Relation]. A procedural relation would carry only the latter, which is how an evaluator
discovers it cannot iterate one -- see [Protocols.Enumerable]. The context is accepted and
unused here: this enumeration reads through its own cursor-lifetime transaction and needs
no name resolution, but cancellation should eventually be checked between tuples. *)
method enumerate = enumerate storage relation
method modes : (Concepts.Mode.t, Concepts.Condition.condition) result = Ok declaration
method generate binding = generate storage relation binding
method protocols : Protocols.Handle.protocol list =
[ Protocols.Relation.make self
; Protocols.Enumerable.make self
; Protocols.Generative.make self
; Protocols.Schematics.make self ]
method hash = hash relation
end
(* A relation never changes its schema, so it is read once here and
the description and modes are served from it on every request. *)
let instantiate tx conn relation =
schema_of tx relation
|> Result.map (fun description -> new relation conn relation description |> Protocols.Handle.make)
let make conn ~schematics ?predicate ?local_constraints ?indexes () =
let open Utilities.Result in
SI.with_transaction conn (fun tx ->
let* relation = empty tx ~schematics ?predicate ?local_constraints ?indexes () in
let* _ = store tx relation in
instantiate tx conn relation )
let load_value tx addr =
let open Utilities.Result in
let* data = SI.get_req tx (S.Hash addr) in
Representation.of_blob data
let wrap conn relation = SI.with_read conn (fun tx -> instantiate tx conn relation)
let load tx conn addr =
load_value tx addr |> Utilities.Result.fmap (instantiate tx conn)
let assert_tuple tx relation tuple =
let open Utilities.Result in
let* node = tuple_node tx relation in
let* node = TupleSet.insert tx (Concepts.Tuple.hash tuple) tuple node in
Ok {relation with tuples= TupleSet.hash_of node}
end
|
