blob: 1d9267e4d11bfa853bd1e68922cca5697aad6fa2 (
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
|
type program = {evaluator: string; code: Concepts.Hash.hash}
type t =
{ name: string option;
schematics:
[ `Persisted of Concepts.Hash.hash
| `Temporary of Protocols.Schematics.attribute_description BatMap.String.t ];
program: program option }
type Protocols.Handle.protocol += Stored of {evaluator: string; code: Concepts.Blob.t}
module Error = struct
open Concepts.Condition
let malformed_relation () =
condition "malformed-ephemeral-relation"
"The on-disk representation of an ephemeral relation did not conform to what was expected. \
Is your database corrupted?"
empty
let unbound_program name =
condition "unbound-program"
"A stored relation has to be instantiated by its evaluator before it can be enumerated"
("relation" |=| Concepts.Value.String name)
end
module Persisted = struct
type nonrec t = {name: string; schematics: Concepts.Hash.hash; program: program}
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 = 'E'
let malformed = Error.malformed_relation
let fields {name; schematics; program= {evaluator; code}} =
let open Concepts.Encoding in
[ "name", Field.string name;
"schema", Value.bencode_of_hash schematics;
"evaluator", Field.string evaluator;
"program", Value.bencode_of_hash code ]
let of_fields fields =
let open Utilities.Result in
let open Concepts.Encoding in
let* name = Field.require_string "name" fields in
let* schematics = Bencode.field "schema" fields |> fmap Value.hash_of_bencode in
let* evaluator = Field.require_string "evaluator" fields in
let* code = Bencode.field "program" fields |> fmap Value.hash_of_bencode in
Ok {name; schematics; program= {evaluator; code}}
end
end
(* FIXME: Bring the Persisted/Temporary out to avoid using the
wildcard and optionals *)
let persisted = function
| {name= Some name; schematics= `Persisted schematics; program= Some program} ->
Some {Persisted.name; schematics; program}
| _ -> None
class ephemeral_relation ?code description value enumerate inputs =
object (self)
inherit Lifecycle.counted
inherit Identity.of_id
method to_string = "ephemeral-relation"
val relation : t = value
method destroy = List.iter Protocols.Handle.release inputs
method enumerate : (Protocols.Handle.t, Concepts.Condition.condition) result = enumerate ()
method describe () = Ok (Protocols.Schematics.Relation description)
(* TODO: We do not need to scan, but simply apply a membership
criteria (set of constraints. For now this works, but it's
inneficient and hurts data independence, as there is an
assymetry between ephemeral and substantial relations. *)
method contains (tuple : Concepts.Tuple.t) =
let open Utilities.Result in
let* cursor = self#enumerate in
Fun.protect
~finally:(fun () -> Protocols.Handle.release cursor)
(fun () ->
let* scan = Protocols.Cursor.require cursor in
Protocols.Cursor.exists scan (fun member ->
Concepts.Hash.hash_equals (Concepts.Tuple.hash member) (Concepts.Tuple.hash tuple) ) )
method protocols : Protocols.Handle.protocol list =
let protocols = Protocols.[Relation.make self; Enumerable.make self; Schematics.make self] in
match persisted relation with
| None -> protocols
| Some record ->
let stored =
Option.fold ~none:protocols
~some:(fun code -> Stored {evaluator= record.program.evaluator; code} :: protocols)
code
in
Protocols.Addressable.make
object
method address = Persisted.Representation.to_blob record |> Concepts.Hash.hash_of_blob
end
:: stored
end
let instantiate ?(inputs = []) ?code description value enumerate =
new ephemeral_relation ?code description value enumerate inputs |> Protocols.Handle.make
module Make (S : Abstract.Storage.STORAGE) = struct
module SI = Storage.Make (S)
module R = SubstantialRelation.Make (S)
let restore ~code ({Persisted.name; schematics; program} : Persisted.t) description =
instantiate ~code description
{name= Some name; schematics= `Persisted schematics; program= Some program}
(fun () -> Error (Error.unbound_program name))
let load connection (record : Persisted.t) =
SI.with_read connection (fun tx ->
let open Utilities.Result in
let* description = R.schema_of tx record.schematics in
let* code = SI.get_req tx (S.Hash record.program.code) in
Ok (restore ~code record description) )
let persist connection ~name ~evaluator ~code description =
SI.with_transaction connection (fun tx ->
let open Utilities.Result in
let* schematics = R.store_schema tx description in
let* address = SI.store_blob tx code in
let record = {Persisted.name; schematics; program= {evaluator; code= address}} in
let* _ = SI.store_blob tx (Persisted.Representation.to_blob record) in
Ok (restore ~code record description) )
end
|
