blob: 605c40ad621769b03e0cbd9ce441f6543c369495 (
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
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
|
(** Multi-multigroup catalog.
Each multigroup gets its own [Atomic.t], so mutations to independent
multigroups never contend. The [sakura] multigroup is auto-bootstrapped,
undeletable, and self-referential: it carries a [public:multigroup] relation
listing every registered multigroup. *)
type t = {
multigroups : Management.Database.t Atomic.t Utilities.StringMap.t Atomic.t;
default_multigroup : string;
mutex : Mutex.t;
}
let sakura_name = "sakura"
module Make (S : Management.Physical.S with type error = string) = struct
open Utilities.Result
module Manip = Manipulation.Make (S)
type nonrec t = t
let map_error r =
Result.map_error (fun e -> Sexplib.Sexp.to_string (Error.sexp_of_error e)) r
let get catalog name =
Utilities.StringMap.find_opt name (Atomic.get catalog.multigroups)
let list catalog =
Utilities.StringMap.bindings (Atomic.get catalog.multigroups)
|> List.map fst
let publish_multigroups catalog ~expected ~updated =
if Atomic.compare_and_set catalog.multigroups expected updated then Ok ()
else Error "Concurrent multigroup map update detected"
let get_string_attr attr (t : Tuple.materialized) =
Option.map
(fun a -> (Obj.magic a.Attribute.value : string))
(Tuple.AttributeMap.find_opt attr t.attributes)
(** Dynlink every library recorded in public:loaded_library. No-op on a fresh
DB; effective when loading a previously persisted multigroup. *)
let hydrate_prl_libraries storage (db : Management.Database.t) =
match
Management.Database.get_relation db
Prelude.Catalog.loaded_library_rel_name
with
| None -> ()
| Some rel -> (
let hashes =
match rel.Relation.tree with None -> [] | Some t -> Merkle.keys t
in
match Manip.load_tuples storage hashes with
| Error _ -> ()
| Ok tuples ->
List.iter
(fun t ->
match get_string_attr "path" t with
| None -> ()
| Some path -> ignore (Prl.Runtime.load_library path))
tuples)
(** Swallow errors: a missing prelude relation is non-fatal. *)
let register_prelude_relation storage db (rel : Relation.t) =
match
Manip.create_immutable_relation storage db ~name:rel.name
~schema:rel.schema ~generator:(Option.get rel.generator)
~membership_criteria:rel.membership_criteria
~cardinality:rel.cardinality ~producer:None
with
| Ok (new_db, _) -> new_db
| Error e ->
Printf.eprintf "Warning: prelude relation %s: %s\n%!" rel.name
(Sexplib.Sexp.to_string (Error.sexp_of_error e));
db
(** Create DB + seed catalog + fold in [prelude_relations] + hydrate PRL. *)
let bootstrap_multigroup storage ~prelude_relations ~name =
let* db = Manip.create_database storage ~name |> map_error in
let db =
List.fold_left (register_prelude_relation storage) db prelude_relations
in
hydrate_prl_libraries storage db;
Ok db
(** Create additional catalog relations beyond the base six. Used to seed
[public:multigroup] into the sakura multigroup only. *)
let seed_extra_catalog storage ~definitions db =
List.fold_left
(fun acc (name, schema) ->
let* db = acc in
let* new_db, _ =
Manip.create_relation storage db ~name ~schema |> map_error
in
Ok new_db)
(Ok db) definitions
(** Write a tuple into sakura's [public:multigroup] and update the ref. No-op
if the relation doesn't exist yet (bootstrap ordering). *)
let register_in_sakura storage sakura_ref mg_name =
let rec go () =
let sakura = Atomic.get sakura_ref in
match
Management.Database.get_relation sakura
Prelude.Catalog.multigroup_rel_name
with
| None -> Ok ()
| Some mg_rel ->
let tuple = Prelude.Catalog.build_multigroup_tuple mg_name in
let* new_sakura, _, _ =
Manip.create_tuple storage sakura mg_rel tuple |> map_error
in
if Atomic.compare_and_set sakura_ref sakura new_sakura then Ok ()
else go ()
in
go ()
let create storage ~prelude_relations =
let* sakura_db =
bootstrap_multigroup storage ~prelude_relations ~name:sakura_name
in
let* sakura_db =
seed_extra_catalog storage
~definitions:Prelude.Catalog.sakura_only_definitions sakura_db
in
let sakura_ref = Atomic.make sakura_db in
let* () = register_in_sakura storage sakura_ref sakura_name in
let map = Utilities.StringMap.singleton sakura_name sakura_ref in
Ok
{
multigroups = Atomic.make map;
default_multigroup = sakura_name;
mutex = Mutex.create ();
}
let add catalog storage ~prelude_relations name =
Mutex.protect catalog.mutex (fun () ->
let map = Atomic.get catalog.multigroups in
if Utilities.StringMap.mem name map then
Error (Printf.sprintf "Multigroup %s already exists" name)
else
let* db = bootstrap_multigroup storage ~prelude_relations ~name in
let db_ref = Atomic.make db in
let* () =
match Utilities.StringMap.find_opt sakura_name map with
| Some sakura_ref -> register_in_sakura storage sakura_ref name
| None -> Ok ()
in
let new_map = Utilities.StringMap.add name db_ref map in
let* () =
publish_multigroups catalog ~expected:map ~updated:new_map
in
Ok db_ref)
let unregister_from_sakura storage sakura_ref mg_name =
let rec go () =
let sakura = Atomic.get sakura_ref in
match
Management.Database.get_relation sakura
Prelude.Catalog.multigroup_rel_name
with
| None -> Ok ()
| Some mg_rel ->
let tuple_hash =
Hashing.hash_tuple (Prelude.Catalog.build_multigroup_tuple mg_name)
in
let* new_sakura, _ =
Manip.retract_tuple storage sakura mg_rel ~tuple_hash |> map_error
in
if Atomic.compare_and_set sakura_ref sakura new_sakura then Ok ()
else go ()
in
go ()
let remove catalog storage name =
if name = sakura_name then Error "Cannot remove the sakura system catalog"
else
Mutex.protect catalog.mutex (fun () ->
let map = Atomic.get catalog.multigroups in
if not (Utilities.StringMap.mem name map) then
Error (Printf.sprintf "Multigroup %s does not exist" name)
else
let* () =
match Utilities.StringMap.find_opt sakura_name map with
| None -> Ok ()
| Some sakura_ref ->
unregister_from_sakura storage sakura_ref name
in
let new_map = Utilities.StringMap.remove name map in
let* () =
publish_multigroups catalog ~expected:map ~updated:new_map
in
Ok ())
end
|
