Persistent store with Git semantics: lazy reads, delayed writes, content-addressing
Use existential GADT for store type: T : (module S with type t = 'a) * 'a -> t
Replace first-class module store with proper existential packing:
each backend provides a named module (Git_S, Mst_S, Pds_S) matching
module type S (with type t = backend state), and the store packs
the module with its state value.
Git and Mst public modules include their S implementation via
include, so Git.checkout/Git.head/etc. are available directly
alongside the constructors (init, open_, memory, disk, of_pds).
+159
-143
+159
-143
lib/irmin.ml
+159
-143
lib/irmin.ml
···
197
197
parents : hash list;
198
198
}
199
199
200
-
(* ===== Unified store (first-class module) ===== *)
200
+
(* ===== Unified store (existential GADT) ===== *)
201
201
202
202
module type S = sig
203
-
val checkout : branch:string -> tree option
204
-
val head : branch:string -> hash option
205
-
val set_head : branch:string -> hash -> unit
206
-
val branches : unit -> string list
203
+
type t
204
+
205
+
val checkout : t -> branch:string -> tree option
206
+
val head : t -> branch:string -> hash option
207
+
val set_head : t -> branch:string -> hash -> unit
208
+
val branches : t -> string list
207
209
208
210
val commit :
209
-
tree:tree -> parents:hash list -> message:string -> author:string -> hash
211
+
t ->
212
+
tree:tree ->
213
+
parents:hash list ->
214
+
message:string ->
215
+
author:string ->
216
+
hash
210
217
211
-
val log : branch:string -> limit:int option -> commit list
212
-
val read_commit : hash -> commit option
213
-
val update_branch : branch:string -> old:hash option -> new_:hash -> bool
214
-
val is_ancestor : ancestor:hash -> descendant:hash -> bool
215
-
val merge_base : hash -> hash -> hash option
216
-
val pp : Format.formatter -> unit
218
+
val log : t -> branch:string -> limit:int option -> commit list
219
+
val read_commit : t -> hash -> commit option
220
+
val update_branch : t -> branch:string -> old:hash option -> new_:hash -> bool
221
+
val is_ancestor : t -> ancestor:hash -> descendant:hash -> bool
222
+
val merge_base : t -> hash -> hash -> hash option
223
+
val pp : t Fmt.t
217
224
end
218
225
219
-
type t = (module S)
226
+
type t = T : (module S with type t = 'a) * 'a -> t
220
227
221
-
let pp ppf (module S : S) = S.pp ppf
228
+
let pp ppf (T ((module S), s)) = S.pp ppf s
222
229
223
230
(* ===== Top-level store operations ===== *)
224
231
225
-
let checkout (module S : S) ~branch = S.checkout ~branch
226
-
let head (module S : S) ~branch = S.head ~branch
227
-
let set_head (module S : S) ~branch h = S.set_head ~branch h
228
-
let branches (module S : S) = S.branches ()
232
+
let checkout (T ((module S), s)) ~branch = S.checkout s ~branch
233
+
let head (T ((module S), s)) ~branch = S.head s ~branch
234
+
let set_head (T ((module S), s)) ~branch h = S.set_head s ~branch h
235
+
let branches (T ((module S), s)) = S.branches s
229
236
230
-
let commit (module S : S) ~tree ~parents ~message ~author =
231
-
S.commit ~tree ~parents ~message ~author
237
+
let commit (T ((module S), s)) ~tree ~parents ~message ~author =
238
+
S.commit s ~tree ~parents ~message ~author
232
239
233
-
let log (module S : S) ~branch ?limit () = S.log ~branch ~limit
234
-
let read_commit (module S : S) h = S.read_commit h
240
+
let log (T ((module S), s)) ~branch ?limit () = S.log s ~branch ~limit
241
+
let read_commit (T ((module S), s)) h = S.read_commit s h
235
242
236
-
let update_branch (module S : S) ~branch ~old ~new_ =
237
-
if S.update_branch ~branch ~old ~new_ then Ok () else Error `Conflict
243
+
let update_branch (T ((module S), s)) ~branch ~old ~new_ =
244
+
if S.update_branch s ~branch ~old ~new_ then Ok () else Error `Conflict
238
245
239
-
let is_ancestor (module S : S) ~ancestor ~descendant =
240
-
S.is_ancestor ~ancestor ~descendant
246
+
let is_ancestor (T ((module S), s)) ~ancestor ~descendant =
247
+
S.is_ancestor s ~ancestor ~descendant
241
248
242
-
let merge_base (module S : S) h1 h2 = S.merge_base h1 h2
249
+
let merge_base (T ((module S), s)) h1 h2 = S.merge_base s h1 h2
243
250
244
251
(* ===== Git tree / store wrapper ===== *)
245
252
···
292
299
(Private.Tree.Git.of_hash ~backend h)))
293
300
~to_concrete:(fun () -> Private.Tree.Git.to_concrete inner)
294
301
295
-
let git_store (s : Private.Store.Git.t) : t =
296
-
let backend = Private.Store.Git.backend s in
297
-
let to_hex h = git_to_hex h in
298
-
let sha1_of = git_sha1_of in
299
-
let wrap_tree = git_wrap_tree ~backend in
300
-
(module struct
301
-
let checkout ~branch =
302
-
Option.map wrap_tree (Private.Store.Git.checkout s ~branch)
302
+
module Git_S = struct
303
+
type t = Private.Store.Git.t
304
+
305
+
let wrap_tree s = git_wrap_tree ~backend:(Private.Store.Git.backend s)
306
+
307
+
let checkout s ~branch =
308
+
Option.map (wrap_tree s) (Private.Store.Git.checkout s ~branch)
303
309
304
-
let head ~branch = Option.map to_hex (Private.Store.Git.head s ~branch)
310
+
let head s ~branch = Option.map git_to_hex (Private.Store.Git.head s ~branch)
305
311
306
-
let set_head ~branch hex =
307
-
Private.Store.Git.set_head s ~branch (sha1_of hex)
312
+
let set_head s ~branch hex =
313
+
Private.Store.Git.set_head s ~branch (git_sha1_of hex)
308
314
309
-
let branches () = Private.Store.Git.branches s
315
+
let branches s = Private.Store.Git.branches s
310
316
311
-
let commit ~tree ~parents ~message ~author =
312
-
let inner = Private.Tree.Git.of_concrete (Tree.to_concrete tree) in
313
-
let tree_sha1 = Private.Tree.Git.hash inner ~backend in
314
-
let parents = List.map sha1_of parents in
315
-
let h =
316
-
Private.Store.Git.commit s
317
-
~tree:(Private.Tree.Git.shallow tree_sha1)
318
-
~parents ~message ~author
319
-
in
320
-
to_hex h
317
+
let commit s ~tree ~parents ~message ~author =
318
+
let backend = Private.Store.Git.backend s in
319
+
let inner = Private.Tree.Git.of_concrete (Tree.to_concrete tree) in
320
+
let tree_sha1 = Private.Tree.Git.hash inner ~backend in
321
+
let parents = List.map git_sha1_of parents in
322
+
let h =
323
+
Private.Store.Git.commit s
324
+
~tree:(Private.Tree.Git.shallow tree_sha1)
325
+
~parents ~message ~author
326
+
in
327
+
git_to_hex h
321
328
322
-
let log ~branch ~limit =
323
-
git_walk_log s to_hex limit (Private.Store.Git.head s ~branch)
329
+
let log s ~branch ~limit =
330
+
git_walk_log s git_to_hex limit (Private.Store.Git.head s ~branch)
324
331
325
-
let read_commit hex =
326
-
let h = sha1_of hex in
327
-
Option.map
328
-
(fun c -> git_commit_entry_of to_hex c h)
329
-
(Private.Store.Git.read_commit s h)
332
+
let read_commit s hex =
333
+
let h = git_sha1_of hex in
334
+
Option.map
335
+
(fun c -> git_commit_entry_of git_to_hex c h)
336
+
(Private.Store.Git.read_commit s h)
330
337
331
-
let update_branch ~branch ~old ~new_ =
332
-
Private.Store.Git.update_branch s ~branch ~old:(Option.map sha1_of old)
333
-
~new_:(sha1_of new_)
338
+
let update_branch s ~branch ~old ~new_ =
339
+
Private.Store.Git.update_branch s ~branch
340
+
~old:(Option.map git_sha1_of old)
341
+
~new_:(git_sha1_of new_)
334
342
335
-
let is_ancestor ~ancestor ~descendant =
336
-
Private.Store.Git.is_ancestor s ~ancestor:(sha1_of ancestor)
337
-
~descendant:(sha1_of descendant)
343
+
let is_ancestor s ~ancestor ~descendant =
344
+
Private.Store.Git.is_ancestor s ~ancestor:(git_sha1_of ancestor)
345
+
~descendant:(git_sha1_of descendant)
338
346
339
-
let merge_base h1 h2 =
340
-
Option.map to_hex
341
-
(Private.Store.Git.merge_base s (sha1_of h1) (sha1_of h2))
347
+
let merge_base s h1 h2 =
348
+
Option.map git_to_hex
349
+
(Private.Store.Git.merge_base s (git_sha1_of h1) (git_sha1_of h2))
342
350
343
-
let pp ppf = Fmt.pf ppf "<irmin:git>"
344
-
end)
351
+
let pp ppf _ = Fmt.pf ppf "<irmin:git>"
352
+
end
345
353
346
354
(* ===== MST tree / store wrapper ===== *)
347
355
···
393
401
(Private.Tree.Mst.of_hash ~backend h)))
394
402
~to_concrete:(fun () -> Private.Tree.Mst.to_concrete inner)
395
403
396
-
let mst_store (s : Private.Store.Mst.t) : t =
397
-
let backend = Private.Store.Mst.backend s in
398
-
let to_hex = mst_to_hex in
399
-
let cid_of = mst_cid_of in
400
-
let wrap_tree = mst_wrap_tree ~backend in
401
-
(module struct
402
-
let checkout ~branch =
403
-
Option.map wrap_tree (Private.Store.Mst.checkout s ~branch)
404
+
module Mst_S = struct
405
+
type t = Private.Store.Mst.t
404
406
405
-
let head ~branch = Option.map to_hex (Private.Store.Mst.head s ~branch)
406
-
let set_head ~branch hex = Private.Store.Mst.set_head s ~branch (cid_of hex)
407
-
let branches () = Private.Store.Mst.branches s
407
+
let wrap_tree s = mst_wrap_tree ~backend:(Private.Store.Mst.backend s)
408
408
409
-
let commit ~tree ~parents ~message ~author =
410
-
let inner = Private.Tree.Mst.of_concrete (Tree.to_concrete tree) in
411
-
let tree_cid = Private.Tree.Mst.hash inner ~backend in
412
-
let parents = List.map cid_of parents in
413
-
let h =
414
-
Private.Store.Mst.commit s
415
-
~tree:(Private.Tree.Mst.shallow tree_cid)
416
-
~parents ~message ~author
417
-
in
418
-
to_hex h
409
+
let checkout s ~branch =
410
+
Option.map (wrap_tree s) (Private.Store.Mst.checkout s ~branch)
419
411
420
-
let log ~branch ~limit =
421
-
mst_walk_log s to_hex limit (Private.Store.Mst.head s ~branch)
412
+
let head s ~branch = Option.map mst_to_hex (Private.Store.Mst.head s ~branch)
422
413
423
-
let read_commit hex =
424
-
let h = cid_of hex in
425
-
Option.map
426
-
(fun c -> mst_commit_entry_of to_hex c h)
427
-
(Private.Store.Mst.read_commit s h)
414
+
let set_head s ~branch hex =
415
+
Private.Store.Mst.set_head s ~branch (mst_cid_of hex)
428
416
429
-
let update_branch ~branch ~old ~new_ =
430
-
try
431
-
Private.Store.Mst.update_branch s ~branch ~old:(Option.map cid_of old)
432
-
~new_:(cid_of new_)
433
-
with Invalid_argument _ -> false
417
+
let branches s = Private.Store.Mst.branches s
434
418
435
-
let is_ancestor ~ancestor ~descendant =
436
-
Private.Store.Mst.is_ancestor s ~ancestor:(cid_of ancestor)
437
-
~descendant:(cid_of descendant)
419
+
let commit s ~tree ~parents ~message ~author =
420
+
let backend = Private.Store.Mst.backend s in
421
+
let inner = Private.Tree.Mst.of_concrete (Tree.to_concrete tree) in
422
+
let tree_cid = Private.Tree.Mst.hash inner ~backend in
423
+
let parents = List.map mst_cid_of parents in
424
+
let h =
425
+
Private.Store.Mst.commit s
426
+
~tree:(Private.Tree.Mst.shallow tree_cid)
427
+
~parents ~message ~author
428
+
in
429
+
mst_to_hex h
438
430
439
-
let merge_base h1 h2 =
440
-
Option.map to_hex (Private.Store.Mst.merge_base s (cid_of h1) (cid_of h2))
431
+
let log s ~branch ~limit =
432
+
mst_walk_log s mst_to_hex limit (Private.Store.Mst.head s ~branch)
441
433
442
-
let pp ppf = Fmt.pf ppf "<irmin:mst>"
443
-
end)
434
+
let read_commit s hex =
435
+
let h = mst_cid_of hex in
436
+
Option.map
437
+
(fun c -> mst_commit_entry_of mst_to_hex c h)
438
+
(Private.Store.Mst.read_commit s h)
439
+
440
+
let update_branch s ~branch ~old ~new_ =
441
+
try
442
+
Private.Store.Mst.update_branch s ~branch
443
+
~old:(Option.map mst_cid_of old)
444
+
~new_:(mst_cid_of new_)
445
+
with Invalid_argument _ -> false
446
+
447
+
let is_ancestor s ~ancestor ~descendant =
448
+
Private.Store.Mst.is_ancestor s ~ancestor:(mst_cid_of ancestor)
449
+
~descendant:(mst_cid_of descendant)
450
+
451
+
let merge_base s h1 h2 =
452
+
Option.map mst_to_hex
453
+
(Private.Store.Mst.merge_base s (mst_cid_of h1) (mst_cid_of h2))
454
+
455
+
let pp ppf _ = Fmt.pf ppf "<irmin:mst>"
456
+
end
444
457
445
458
(* ===== PDS store wrapper ===== *)
446
459
(* PDS HEAD = ATProto MST root CID (not an Irmin commit hash).
···
472
485
else None)
473
486
|> List.of_seq |> List.sort_uniq compare
474
487
475
-
let pds_store (pds : Pds.t) : t =
488
+
module Pds_S = struct
489
+
type t = Pds.t
490
+
476
491
let rec wrap_pds_tree (mst : Atp.Mst.node) (bs : Atp.Blockstore.writable) :
477
492
tree =
478
493
let readable = (bs :> Atp.Blockstore.readable) in
···
496
511
ignore (Tree.to_concrete sub);
497
512
wrap_pds_tree mst bs)
498
513
~to_concrete:(fun () -> `Tree [])
499
-
in
500
-
let pds_flush_tree mst bs =
501
-
Atp.Cid.to_string (Atp.Mst.to_cid mst ~store:bs)
502
-
in
503
-
(module struct
504
-
let checkout ~branch:_ =
505
-
match Pds.checkout pds with
506
-
| None -> None
507
-
| Some mst -> Some (wrap_pds_tree mst (Pds.blockstore pds))
508
514
509
-
let head ~branch:_ = Option.map Atp.Cid.to_string (Pds.head pds)
515
+
let checkout pds ~branch:_ =
516
+
match Pds.checkout pds with
517
+
| None -> None
518
+
| Some mst -> Some (wrap_pds_tree mst (Pds.blockstore pds))
510
519
511
-
let set_head ~branch:_ cid_str =
512
-
Pds.set_head pds (Atp.Cid.of_string cid_str)
520
+
let head pds ~branch:_ = Option.map Atp.Cid.to_string (Pds.head pds)
513
521
514
-
let branches () = [ "main" ]
522
+
let set_head pds ~branch:_ cid_str =
523
+
Pds.set_head pds (Atp.Cid.of_string cid_str)
515
524
516
-
let commit ~tree:_ ~parents:_ ~message:_ ~author:_ =
517
-
let bs = Pds.blockstore pds in
518
-
let mst =
519
-
match Pds.checkout pds with Some m -> m | None -> Atp.Mst.empty
520
-
in
521
-
let cid_str = pds_flush_tree mst bs in
522
-
Pds.set_head pds (Atp.Cid.of_string cid_str);
523
-
cid_str
525
+
let branches _ = [ "main" ]
526
+
527
+
let commit pds ~tree:_ ~parents:_ ~message:_ ~author:_ =
528
+
let bs = Pds.blockstore pds in
529
+
let mst =
530
+
match Pds.checkout pds with Some m -> m | None -> Atp.Mst.empty
531
+
in
532
+
let cid_str = Atp.Cid.to_string (Atp.Mst.to_cid mst ~store:bs) in
533
+
Pds.set_head pds (Atp.Cid.of_string cid_str);
534
+
cid_str
524
535
525
-
let log ~branch:_ ~limit:_ = []
526
-
let read_commit _ = None
527
-
let update_branch ~branch:_ ~old:_ ~new_:_ = false
528
-
let is_ancestor ~ancestor:_ ~descendant:_ = false
529
-
let merge_base _ _ = None
530
-
let pp ppf = Fmt.pf ppf "<irmin:pds>"
531
-
end)
536
+
let log _ ~branch:_ ~limit:_ = []
537
+
let read_commit _ _ = None
538
+
let update_branch _ ~branch:_ ~old:_ ~new_:_ = false
539
+
let is_ancestor _ ~ancestor:_ ~descendant:_ = false
540
+
let merge_base _ _ _ = None
541
+
let pp ppf _ = Fmt.pf ppf "<irmin:pds>"
542
+
end
532
543
533
544
(* ===== Module Git ===== *)
534
545
535
546
module Git = struct
536
-
let init ~sw ~fs ~path = git_store (Git_interop.init ~sw ~fs ~path)
537
-
let open_ ~sw ~fs ~path = git_store (Git_interop.open_ ~sw ~fs ~path)
538
-
let import ~sw ~fs ~git_dir = git_store (Git_interop.import ~sw ~fs ~git_dir)
547
+
include Git_S
548
+
549
+
let v s = T ((module Git_S), s)
550
+
let init ~sw ~fs ~path = v (Git_interop.init ~sw ~fs ~path)
551
+
let open_ ~sw ~fs ~path = v (Git_interop.open_ ~sw ~fs ~path)
552
+
let import ~sw ~fs ~git_dir = v (Git_interop.import ~sw ~fs ~git_dir)
539
553
540
554
let read_object ~sw ~fs ~git_dir (hex : hash) =
541
555
match Private.Hash.sha1_of_hex hex with
···
559
573
(* ===== Module Mst ===== *)
560
574
561
575
module Mst = struct
562
-
let of_pds pds = pds_store pds
576
+
include Mst_S
577
+
578
+
let v s = T ((module Mst_S), s)
579
+
let of_pds pds = T ((module Pds_S), pds)
563
580
564
581
let disk ~sw root =
565
-
mst_store
582
+
v
566
583
(Private.Store.Mst.create
567
584
~backend:(Private.Backend.Disk.create_cid ~sw root))
568
585
569
586
let memory () =
570
-
mst_store
571
-
(Private.Store.Mst.create ~backend:(Private.Backend.Memory.create_cid ()))
587
+
v (Private.Store.Mst.create ~backend:(Private.Backend.Memory.create_cid ()))
572
588
end