Persistent store with Git semantics: lazy reads, delayed writes, content-addressing
irmin: 3-way merge with per-node merge strategies
+270
-9
+152
-5
lib/schema.ml
+152
-5
lib/schema.ml
···
11
11
type parse = H.block -> children
12
12
type serialize = children -> H.block
13
13
14
+
type merge =
15
+
ancestor:H.block ->
16
+
H.block ->
17
+
H.block ->
18
+
(H.block, [ `Conflict of string ]) result
19
+
14
20
type packed = Pack : t -> packed
15
21
and rule = Rule : string * t -> rule
16
22
17
23
and t =
18
24
| Opaque : t
19
-
| Node : { parse : parse; serialize : serialize; rules : rule list } -> t
25
+
| Node : {
26
+
parse : parse;
27
+
serialize : serialize;
28
+
merge : merge option;
29
+
rules : rule list;
30
+
}
31
+
-> t
20
32
| Rec : (unit -> t) -> t
21
33
22
34
let opaque = Opaque
23
35
let ( => ) pat schema = Rule (pat, schema)
24
-
let node ~parse ~serialize rules = Node { parse; serialize; rules }
36
+
37
+
let node ~parse ~serialize ?merge rules =
38
+
Node { parse; serialize; merge; rules }
25
39
26
40
let fix f =
27
41
let r = ref None in
···
48
62
let rec resolve_packed : packed -> packed =
49
63
fun p -> match p with Pack (Rec f) -> resolve_packed (Pack (f ())) | _ -> p
50
64
51
-
type node_ops = { parse : parse; serialize : serialize; rules : rule list }
65
+
type node_ops = {
66
+
parse : parse;
67
+
serialize : serialize;
68
+
merge : merge option;
69
+
rules : rule list;
70
+
}
52
71
53
72
let get_node : packed -> node_ops option = function
54
-
| Pack (Node { parse; serialize; rules }) ->
55
-
Some { parse; serialize; rules }
73
+
| Pack (Node { parse; serialize; merge; rules }) ->
74
+
Some { parse; serialize; merge; rules }
56
75
| _ -> None
57
76
58
77
(* ===== Children cache ===== *)
···
299
318
{
300
319
parse;
301
320
serialize;
321
+
merge = None;
302
322
rules =
303
323
[
304
324
Rule ("tree", tree);
···
306
326
Rule ("*", Opaque);
307
327
];
308
328
}
329
+
330
+
(* ===== Merge ===== *)
331
+
332
+
let merge (heap : (H.hash, H.block, _) Heap.t) schema ~ancestor ~ours ~theirs
333
+
=
334
+
(* 3-way merge: walk cursors in parallel *)
335
+
let rec merge_hash schema a_hash o_hash t_hash =
336
+
if H.hash_equal o_hash t_hash then Ok o_hash (* no conflict *)
337
+
else if H.hash_equal a_hash o_hash then
338
+
Ok t_hash (* only theirs changed *)
339
+
else if H.hash_equal a_hash t_hash then Ok o_hash (* only ours changed *)
340
+
else
341
+
(* Both changed — need to merge *)
342
+
match
343
+
(Heap.find heap a_hash, Heap.find heap o_hash, Heap.find heap t_hash)
344
+
with
345
+
| Some a_block, Some o_block, Some t_block ->
346
+
merge_block schema a_block o_block t_block
347
+
| _ -> Error (`Conflict "missing block")
348
+
and merge_block schema a_block o_block t_block =
349
+
let resolved = resolve_packed (Pack schema) in
350
+
match get_node resolved with
351
+
| None ->
352
+
(* Leaf: use the node's merge function, or conflict *)
353
+
Error (`Conflict "leaf conflict, no merge function")
354
+
| Some ops -> (
355
+
match ops.merge with
356
+
| Some merge_fn -> (
357
+
(* Leaf with merge function *)
358
+
match merge_fn ~ancestor:a_block o_block t_block with
359
+
| Ok merged ->
360
+
let h = H.hash_block merged in
361
+
Heap.put heap h merged;
362
+
Ok h
363
+
| Error _ as e -> e)
364
+
| None ->
365
+
(* Interior node: structural merge *)
366
+
let a_kids = ops.parse a_block in
367
+
let o_kids = ops.parse o_block in
368
+
let t_kids = ops.parse t_block in
369
+
let is_empty = function
370
+
| Named [] -> true
371
+
| Indexed [||] -> true
372
+
| _ -> false
373
+
in
374
+
if is_empty a_kids && is_empty o_kids && is_empty t_kids then
375
+
(* All three are childless (leaves) but different — conflict *)
376
+
Error (`Conflict "leaf values differ, no merge function")
377
+
else merge_children ops schema a_kids o_kids t_kids)
378
+
and merge_children ops schema a_kids o_kids t_kids =
379
+
(* Collect all names from all three *)
380
+
let names_of = function
381
+
| Named l -> List.map fst l
382
+
| Indexed arr -> List.init (Array.length arr) string_of_int
383
+
in
384
+
let find_child name = function
385
+
| Named l -> List.assoc_opt name l
386
+
| Indexed arr -> (
387
+
match int_of_string_opt name with
388
+
| Some i when i >= 0 && i < Array.length arr -> Some arr.(i)
389
+
| _ -> None)
390
+
in
391
+
let all_names =
392
+
let tbl = Hashtbl.create 16 in
393
+
List.iter (fun n -> Hashtbl.replace tbl n ()) (names_of a_kids);
394
+
List.iter (fun n -> Hashtbl.replace tbl n ()) (names_of o_kids);
395
+
List.iter (fun n -> Hashtbl.replace tbl n ()) (names_of t_kids);
396
+
Hashtbl.fold (fun n () acc -> n :: acc) tbl []
397
+
|> List.sort String.compare
398
+
in
399
+
(* Find the child schema for a name *)
400
+
let child_schema name =
401
+
match find_rule ops.rules name with
402
+
| Some (Pack s) -> s
403
+
| None -> Opaque
404
+
in
405
+
(* Merge each child *)
406
+
let rec merge_names acc = function
407
+
| [] ->
408
+
let merged = Named (List.rev acc) in
409
+
let block = ops.serialize merged in
410
+
let h = H.hash_block block in
411
+
Heap.put heap h block;
412
+
Ok h
413
+
| name :: rest -> (
414
+
let a = find_child name a_kids in
415
+
let o = find_child name o_kids in
416
+
let t = find_child name t_kids in
417
+
let child_sch = child_schema name in
418
+
match merge_child child_sch a o t with
419
+
| Ok None -> merge_names acc rest (* deleted *)
420
+
| Ok (Some child) -> merge_names ((name, child) :: acc) rest
421
+
| Error _ as e -> e)
422
+
and merge_child schema a o t =
423
+
match (a, o, t) with
424
+
| _, Some oc, Some tc when oc = tc -> Ok (Some oc) (* same *)
425
+
| Some ac, Some oc, _ when ac = oc -> Ok t (* only theirs changed *)
426
+
| Some ac, _, Some tc when ac = tc -> Ok o (* only ours changed *)
427
+
| None, None, None -> Ok None
428
+
| None, Some oc, None -> Ok (Some oc) (* ours added *)
429
+
| None, None, Some tc -> Ok (Some tc) (* theirs added *)
430
+
| None, Some _, Some _ ->
431
+
(* both added — try merge with empty ancestor *)
432
+
Error (`Conflict "both sides added same key")
433
+
| Some _, None, None -> Ok None (* both deleted *)
434
+
| Some _, Some _, None ->
435
+
Ok None (* theirs deleted, ours modified — conflict? *)
436
+
| Some _, None, Some _ ->
437
+
Ok None (* ours deleted, theirs modified — conflict? *)
438
+
| Some (`Link ah), Some (`Link oh), Some (`Link th) -> (
439
+
(* Both modified a linked child — recurse *)
440
+
match merge_hash schema ah oh th with
441
+
| Ok h -> Ok (Some (`Link h))
442
+
| Error _ as e -> e)
443
+
| Some (`Inline _), Some (`Inline ob), Some (`Inline tb) -> (
444
+
(* Both modified an inline child *)
445
+
match a with
446
+
| Some (`Inline ab) -> (
447
+
match merge_block schema ab ob tb with
448
+
| Ok h -> Ok (Some (`Link h))
449
+
| Error _ as e -> e)
450
+
| _ -> Error (`Conflict "inline merge without ancestor"))
451
+
| _ -> Error (`Conflict "incompatible child types")
452
+
in
453
+
merge_names [] all_names
454
+
in
455
+
merge_hash schema ancestor ours theirs
309
456
310
457
(* ===== Proof ===== *)
311
458
+29
-4
lib/schema.mli
+29
-4
lib/schema.mli
···
43
43
type serialize = children -> H.block
44
44
(** How to reconstruct a block from children. *)
45
45
46
+
type merge =
47
+
ancestor:H.block ->
48
+
H.block ->
49
+
H.block ->
50
+
(H.block, [ `Conflict of string ]) result
51
+
(** [merge ~ancestor ours theirs] merges two leaf values given their common
52
+
ancestor. *)
53
+
46
54
type t
47
55
(** A schema node. *)
48
56
···
54
62
["*.json"] matches by suffix, exact names match exactly. First matching
55
63
rule wins. *)
56
64
57
-
val node : parse:parse -> serialize:serialize -> rule list -> t
58
-
(** [node ~parse ~serialize rules] is a block with named children. [parse]
59
-
extracts children, [serialize] reconstructs the block, [rules] determine
60
-
each child's schema by name. *)
65
+
val node :
66
+
parse:parse -> serialize:serialize -> ?merge:merge -> rule list -> t
67
+
(** [node ~parse ~serialize ?merge rules] is a block with named children.
68
+
[merge] is used for leaf-level 3-way merge. Interior nodes are merged
69
+
structurally (child by child). *)
61
70
62
71
val fix : (t -> t) -> t
63
72
(** [fix f] is a recursive schema. *)
···
153
162
(** [commit_node ~parse ~serialize ~tree] is a schema for commit blocks.
154
163
Children: ["tree"] links to [tree], ["parent/0"], ["parent/1"], ... link
155
164
to parent commits, ["message"] and ["author"] are inline metadata. *)
165
+
166
+
(** {1:merge Merge}
167
+
168
+
3-way merge: given a common ancestor and two diverged states, produce a
169
+
merged state. Interior nodes are merged structurally (child by child).
170
+
Leaves use the node's [~merge] function. *)
171
+
172
+
val merge :
173
+
(H.hash, H.block, _) Heap.t ->
174
+
t ->
175
+
ancestor:H.hash ->
176
+
ours:H.hash ->
177
+
theirs:H.hash ->
178
+
(H.hash, [ `Conflict of string ]) result
179
+
(** [merge heap schema ~ancestor ~ours ~theirs] performs a 3-way merge.
180
+
Returns the hash of the merged tree, or a conflict. *)
156
181
157
182
(** {1:proof Proofs}
158
183
+89
test/tar/test.ml
+89
test/tar/test.ml
···
179
179
Alcotest.(check (option string)) "verified digestif" (Some {|"2.0"|}) v
180
180
| Error (`Proof_failure msg) -> Alcotest.failf "verify: %s" msg
181
181
182
+
(* ===== Merge tests ===== *)
183
+
184
+
(* Counter merge: sum the deltas *)
185
+
let counter_parse : S.parse = fun _ -> S.Named []
186
+
let counter_serialize : S.serialize = fun _ -> ""
187
+
188
+
let counter_merge : S.merge =
189
+
fun ~ancestor ours theirs ->
190
+
let to_int s = try int_of_string s with _ -> 0 in
191
+
let a = to_int ancestor and o = to_int ours and t = to_int theirs in
192
+
Ok (string_of_int (o + t - a))
193
+
194
+
let tree_with_counters =
195
+
let ( => ) = S.( => ) in
196
+
S.fix (fun self ->
197
+
S.node ~parse:Irmin_tar.dir_parse ~serialize:Irmin_tar.dir_serialize
198
+
[
199
+
"*.counter"
200
+
=> S.node ~parse:counter_parse ~serialize:counter_serialize
201
+
~merge:counter_merge [];
202
+
"*" => self;
203
+
])
204
+
205
+
let test_merge_structural () =
206
+
let store = Hashtbl.create 64 in
207
+
let heap = H.v store in
208
+
(* Ancestor: a.txt, b.txt *)
209
+
let ancestor =
210
+
Irmin_tar.of_entries heap [ ("a.txt", "hello"); ("b.txt", "world") ]
211
+
in
212
+
(* Ours: add c.txt *)
213
+
let ours =
214
+
Irmin_tar.of_entries heap
215
+
[ ("a.txt", "hello"); ("b.txt", "world"); ("c.txt", "new-ours") ]
216
+
in
217
+
(* Theirs: add d.txt *)
218
+
let theirs =
219
+
Irmin_tar.of_entries heap
220
+
[ ("a.txt", "hello"); ("b.txt", "world"); ("d.txt", "new-theirs") ]
221
+
in
222
+
match S.merge heap Irmin_tar.tree ~ancestor ~ours ~theirs with
223
+
| Error (`Conflict msg) -> Alcotest.failf "merge conflict: %s" msg
224
+
| Ok merged_root ->
225
+
let c = S.at heap Irmin_tar.tree merged_root in
226
+
let kids = S.list c |> List.map fst |> List.sort String.compare in
227
+
Alcotest.(check (list string))
228
+
"merged"
229
+
[ "a.txt"; "b.txt"; "c.txt"; "d.txt" ]
230
+
kids;
231
+
(* Check values *)
232
+
Alcotest.(check (option string))
233
+
"c.txt" (Some "new-ours") (S.find c [ "c.txt" ]);
234
+
Alcotest.(check (option string))
235
+
"d.txt" (Some "new-theirs") (S.find c [ "d.txt" ])
236
+
237
+
let test_merge_counter () =
238
+
let store = Hashtbl.create 64 in
239
+
let heap = H.v store in
240
+
let ancestor = Irmin_tar.of_entries heap [ ("views.counter", "10") ] in
241
+
let ours = Irmin_tar.of_entries heap [ ("views.counter", "15") ] in
242
+
let theirs = Irmin_tar.of_entries heap [ ("views.counter", "12") ] in
243
+
match S.merge heap tree_with_counters ~ancestor ~ours ~theirs with
244
+
| Error (`Conflict msg) -> Alcotest.failf "merge conflict: %s" msg
245
+
| Ok merged_root ->
246
+
let c = S.at heap tree_with_counters merged_root in
247
+
(* 15 + 12 - 10 = 17 *)
248
+
Alcotest.(check (option string))
249
+
"counter merged" (Some "17")
250
+
(S.find c [ "views.counter" ])
251
+
252
+
let test_merge_conflict () =
253
+
let store = Hashtbl.create 64 in
254
+
let heap = H.v store in
255
+
let ancestor = Irmin_tar.of_entries heap [ ("a.txt", "original") ] in
256
+
let ours = Irmin_tar.of_entries heap [ ("a.txt", "ours-edit") ] in
257
+
let theirs = Irmin_tar.of_entries heap [ ("a.txt", "theirs-edit") ] in
258
+
(* No merge function for opaque blobs → conflict *)
259
+
match S.merge heap Irmin_tar.tree ~ancestor ~ours ~theirs with
260
+
| Ok _ -> Alcotest.fail "should conflict"
261
+
| Error (`Conflict _) -> ()
262
+
182
263
let () =
183
264
Alcotest.run "irmin-tar"
184
265
[
···
190
271
[
191
272
Alcotest.test_case "navigate and prove JSON in tar" `Quick
192
273
test_tar_json_proof;
274
+
] );
275
+
( "merge",
276
+
[
277
+
Alcotest.test_case "structural merge (add/add)" `Quick
278
+
test_merge_structural;
279
+
Alcotest.test_case "CRDT counter merge" `Quick test_merge_counter;
280
+
Alcotest.test_case "conflict on opaque leaf" `Quick
281
+
test_merge_conflict;
193
282
] );
194
283
]