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
215
216
217
218
219
|
(* Branch: the effectful session layer.
Owns the RNT branch handle and the in-memory mirror of every multigroup
bound to that branch. Each mutation names its target mg explicitly. *)
module Make (NT : Nt.S) = struct
module Error = struct
open Condition
(* TODO: more structure *)
let not_supported msg = condition "not-supported" msg empty
let handle_error msg = condition "handle-error" msg empty
end
let ( let* ) = Result.bind
type mode =
| Live (* tracking branch tip; mutations allowed *)
| Detached of string (* pinned to snapshot hash; read-only *)
class branch ~(init_bh : Nt.branch_handle) ~(init_name : string) ~(init_tip : string)
~(init_mgs : (string * Management.Multigroup.multigroup) list) ~(init_mode : mode) =
object (self)
val mutable bh : Nt.branch_handle = init_bh
val name : string = init_name
val mutable tip : string = init_tip
val mutable mode : mode = init_mode
val mgs : (string, Management.Multigroup.multigroup) Hashtbl.t =
let t = Hashtbl.create 8 in
List.iter (fun (n, mg) -> Hashtbl.replace t n mg) init_mgs;
t
method name = name
method tip = tip
method snapshot = tip
method mode = mode
method branch_handle = bh
method mg_of (n : string) : Management.Multigroup.multigroup option = Hashtbl.find_opt mgs n
method multigroups : (string * Management.Multigroup.multigroup) list =
Hashtbl.to_seq mgs |> List.of_seq
(* Register a fresh mg under this branch. Idempotent. *)
method add_multigroup ~(name : string) : unit =
if not (Hashtbl.mem mgs name) then
Hashtbl.add mgs name (new Management.Multigroup.multigroup ~name)
(* Replace the cached mg value (e.g. after an NT mutation returned a
new mg). Idempotent insert if the mg was not present. *)
method set_mg ~(name : string) (mg : Management.Multigroup.multigroup) : unit =
Hashtbl.replace mgs name mg
(* Path for a relation in this branch (Live) or its pinned snapshot
(Detached). Pass [~branch] to reference a relation on a different
live branch (cross-multigroup reads). *)
method path ?(branch : string option) (fqn : Qualified_name.t) : string =
match branch with
| Some b -> "/system/branches/" ^ b ^ "/multigroups/" ^ fqn.mg ^ "/relations/" ^ fqn.name
| None -> (
match mode with
| Live -> "/system/branches/" ^ name ^ "/multigroups/" ^ fqn.mg ^ "/relations/" ^ fqn.name
| Detached hash -> "/system/snapshots/" ^ hash ^ "/relations/" ^ fqn.name )
method private assert_live op =
match mode with
| Live -> Ok ()
| Detached _ -> Error (Error.not_supported (op ^ ": detached snapshot is read-only"))
method private sync_tip () =
match mode with
| Detached _ -> ()
| Live -> ( match NT.branch_target_of_handle bh with Error _ -> () | Ok h -> tip <- h )
method private get_mg op (mg_name : string) :
(Management.Multigroup.multigroup, Condition.t) result =
match Hashtbl.find_opt mgs mg_name with
| Some mg -> Ok mg
| None -> Error (Error.handle_error (op ^ ": multigroup not found: " ^ mg_name))
method create_relation ~(mg : string) ~(rel_name : string) ~schema =
let* () = self#assert_live "create_relation" in
let* mg_val = self#get_mg "create_relation" mg in
let* bh', mg' = NT.create_relation bh mg_val ~branch_name:name ~name:rel_name ~schema in
bh <- bh';
Hashtbl.replace mgs mg mg';
self#sync_tip ();
Ok ()
method retract_relation ~(mg : string) ~(rel_name : string) =
let* () = self#assert_live "retract_relation" in
let* mg_val = self#get_mg "retract_relation" mg in
let* bh', mg' = NT.retract_relation bh mg_val ~name:rel_name in
bh <- bh';
Hashtbl.replace mgs mg mg';
self#sync_tip ();
Ok ()
method clear_relation ~(mg : string) ~(rel_name : string) =
let* () = self#assert_live "clear_relation" in
let* mg_val = self#get_mg "clear_relation" mg in
match mg_val#get_relation rel_name with
| None -> Error (Error.handle_error ("relation not found: " ^ rel_name))
| Some rel ->
let* bh', mg' = NT.clear_relation bh mg_val ~branch_name:name ~mg_name:mg rel in
bh <- bh';
Hashtbl.replace mgs mg mg';
self#sync_tip ();
Ok ()
method register_domain ~(mg : string) domain =
let* () = self#assert_live "register_domain" in
let* mg_val = self#get_mg "register_domain" mg in
let* bh', mg' = NT.register_domain bh mg_val domain in
bh <- bh';
Hashtbl.replace mgs mg mg';
Ok ()
method create_immutable_relation ~(mg : string) ~name:rel_name ~schema ~generator
~membership_criteria ~cardinality ~producer =
let* () = self#assert_live "create_immutable_relation" in
let* mg_val = self#get_mg "create_immutable_relation" mg in
let* bh', mg', rel =
NT.create_immutable_relation bh mg_val ~name:rel_name ~schema ~generator
~membership_criteria ~cardinality ~producer
in
bh <- bh';
Hashtbl.replace mgs mg mg';
Ok rel
method register_constraint ~(mg : string) ~constraint_name ~relation_name ~body =
let* () = self#assert_live "register_constraint" in
let* mg_val = self#get_mg "register_constraint" mg in
let* bh', mg' = NT.register_constraint bh mg_val ~constraint_name ~relation_name ~body in
bh <- bh';
Hashtbl.replace mgs mg mg';
Ok ()
method insert_tuple ~(mg : string) ~(rel_name : string) attrs =
let* () = self#assert_live "insert_tuple" in
let* hash = NT.insert_tuple ~branch_name:name ~mg_name:mg ~rel_name attrs in
self#sync_tip (); Ok hash
method create_tuple ~(mg : string) ~(rel_name : string) tuple =
let* () = self#assert_live "create_tuple" in
let* hash = NT.create_tuple ~branch_name:name ~mg_name:mg ~rel_name tuple in
self#sync_tip (); Ok hash
method create_tuples ~(mg : string) ~(rel_name : string) tuples =
let* () = self#assert_live "create_tuples" in
let* hash = NT.create_tuples ~branch_name:name ~mg_name:mg ~rel_name tuples in
self#sync_tip (); Ok hash
method retract_tuple ~(mg : string) ~(rel_name : string) ~tuple_hash =
let* () = self#assert_live "retract_tuple" in
let* () = NT.retract_tuple ~branch_name:name ~mg_name:mg ~rel_name tuple_hash in
self#sync_tip (); Ok ()
(* Applies a Transition delta from a sublanguage executor. Each entry
replaces the named mg in the cache, then the tip is re-read. *)
method apply_delta (delta : (string * Management.Multigroup.multigroup) list) =
List.iter (fun (mg_name, mg_val) -> Hashtbl.replace mgs mg_name mg_val) delta;
self#sync_tip ()
method close () = NT.close_branch bh
end
(* Default mg name seeded into an unborn branch so the session can write
into something. Real catalog seeding (under "sakura") is the prelude's
responsibility. *)
let default_mg_name = "public"
let open_branch claims branch_name =
let* bh, _legacy_mg = NT.open_branch claims branch_name in
let tip = match NT.branch_target_of_handle bh with Ok h -> h | Error _ -> "" in
let* mg_entries = NT.list_branch_multigroups branch_name in
let mgs =
List.map
(fun (mg_name, _mg_hash) ->
(* For each bound mg, enumerate its relations from the kernel and
rebuild the OCaml mirror. Schemas are not persisted in the
snapshot codec — they are repopulated by DDL replay / catalog
reads later. *)
let rels =
match NT.list_relations ~branch_name ~mg_name with Ok pairs -> pairs | Error _ -> []
in
let mg =
List.fold_left
(fun mg (rel_name, root) ->
let rel =
(new Relation.stored
~name:rel_name ~schema:[] ~constraints:None
~cardinality:Conventions.Cardinality.AlephZero
~lineage:(Some (Relation.Lineage.Base rel_name))
~provenance:(Some (Relation.Provenance.base ~relation:rel_name ~attributes:[]))
~membership_criteria:(fun _ -> true) )
#set_tree_pointer
(Some root)
in
mg#add_relation (rel :> Relation.relation) )
(new Management.Multigroup.multigroup ~name:mg_name)
rels
in
mg_name, mg )
mg_entries
in
let mgs =
if mgs = [] then [default_mg_name, new Management.Multigroup.multigroup ~name:default_mg_name]
else mgs
in
Ok (new branch ~init_bh:bh ~init_name:branch_name ~init_tip:tip ~init_mgs:mgs ~init_mode:Live)
let open_snapshot claims ~branch_name ~snapshot_hash =
let* bh, mg = NT.open_snapshot claims branch_name snapshot_hash in
Ok
(new branch
~init_bh:bh ~init_name:branch_name ~init_tip:snapshot_hash
~init_mgs:[mg#name, mg]
~init_mode:(Detached snapshot_hash) )
end
|
