blob: be5437582fb98e4a3b661841cb2dee4a7d6938e3 (
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
|
(** 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"
(** 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
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]. *)
let bootstrap_multigroup storage ~prelude_relations ~name =
let* db = Manip.create_database storage ~name |> map_error in
Ok (List.fold_left (register_prelude_relation storage) db prelude_relations)
(** 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
|
