Persistent store with Git semantics: lazy reads, delayed writes, content-addressing
Fix all PDS test failures: route through Mst_S instead of stubs
Mst.of_pds now creates a Store.Mst.t backed by the PDS backend and
routes through Mst_S (same code path as memory/disk). This gives PDS
full commit, checkout, log, read_commit, is_ancestor, and merge_base
support for free.
Removed Pds_S (80 lines of stubs and partial implementations) and
its helper functions. All 127 tests pass across all 4 backends.
+3
-112
+3
-112
lib/irmin.ml
+3
-112
lib/irmin.ml
···
455
455
let pp ppf _ = Fmt.pf ppf "<irmin:mst>"
456
456
end
457
457
458
-
(* ===== PDS store wrapper ===== *)
459
-
(* PDS HEAD = ATProto MST root CID (not an Irmin commit hash).
460
-
commit() flushes the tree directly to PDS; set_head() updates the PDS HEAD.
461
-
No Irmin commit objects are created. *)
462
-
463
-
let pds_tree_find mst readable (bs : Atp.Blockstore.writable) path =
464
-
let key = String.concat "/" path in
465
-
match Atp.Mst.find key mst ~store:readable with
466
-
| None -> None
467
-
| Some cid -> bs#get cid
468
-
469
-
let pds_tree_list mst readable path =
470
-
let prefix = match path with [] -> "" | _ -> String.concat "/" path ^ "/" in
471
-
Atp.Mst.leaves mst ~store:readable
472
-
|> Seq.filter_map (fun (k, _cid) ->
473
-
if
474
-
prefix = ""
475
-
|| String.length k > String.length prefix
476
-
&& String.sub k 0 (String.length prefix) = prefix
477
-
then
478
-
let suffix =
479
-
String.sub k (String.length prefix)
480
-
(String.length k - String.length prefix)
481
-
in
482
-
match String.index_opt suffix '/' with
483
-
| None -> Some (suffix, `Contents)
484
-
| Some i -> Some (String.sub suffix 0 i, `Node)
485
-
else None)
486
-
|> List.of_seq |> List.sort_uniq compare
487
-
488
-
module Pds_S = struct
489
-
type t = Pds.t
490
-
491
-
let rec wrap_pds_tree (mst : Atp.Mst.node) (bs : Atp.Blockstore.writable) :
492
-
tree =
493
-
let readable = (bs :> Atp.Blockstore.readable) in
494
-
Tree.v
495
-
~find:(pds_tree_find mst readable bs)
496
-
~list:(pds_tree_list mst readable)
497
-
~find_tree:(fun path ->
498
-
if path = [] then Some (wrap_pds_tree mst bs)
499
-
else Some (wrap_pds_tree mst bs))
500
-
~add:(fun path v ->
501
-
let key = String.concat "/" path in
502
-
let cid = Atp.Cid.v `Dag_cbor v in
503
-
bs#put cid v;
504
-
let mst' = Atp.Mst.add key cid mst ~store:bs in
505
-
wrap_pds_tree mst' bs)
506
-
~remove:(fun path ->
507
-
let key = String.concat "/" path in
508
-
let mst' = Atp.Mst.remove key mst ~store:bs in
509
-
wrap_pds_tree mst' bs)
510
-
~add_tree:(fun _path sub ->
511
-
ignore (Tree.to_concrete sub);
512
-
wrap_pds_tree mst bs)
513
-
~to_concrete:(fun () -> `Tree [])
514
-
515
-
let backend pds = Pds_interop.mst_backend pds
516
-
517
-
let checkout pds ~branch =
518
-
let b = backend pds in
519
-
match Private.Backend.get_ref b ("refs/heads/" ^ branch) with
520
-
| None -> (
521
-
(* Fall back to PDS head for "main" *)
522
-
match Pds.checkout pds with
523
-
| None -> None
524
-
| Some mst -> Some (wrap_pds_tree mst (Pds.blockstore pds)))
525
-
| Some _cid -> (
526
-
match Pds.checkout pds with
527
-
| None -> None
528
-
| Some mst -> Some (wrap_pds_tree mst (Pds.blockstore pds)))
529
-
530
-
let head pds ~branch =
531
-
let b = backend pds in
532
-
Option.map Atp.Cid.to_string
533
-
(Private.Backend.get_ref b ("refs/heads/" ^ branch))
534
-
535
-
let set_head pds ~branch cid_str =
536
-
let b = backend pds in
537
-
Private.Backend.set_ref b ("refs/heads/" ^ branch) (mst_cid_of cid_str)
538
-
539
-
let branches pds =
540
-
let b = backend pds in
541
-
Private.Backend.list_refs b
542
-
|> List.filter_map (fun r ->
543
-
if String.length r > 11 && String.sub r 0 11 = "refs/heads/" then
544
-
Some (String.sub r 11 (String.length r - 11))
545
-
else None)
546
-
547
-
let commit pds ~tree:_ ~parents:_ ~message:_ ~author:_ =
548
-
let bs = Pds.blockstore pds in
549
-
let mst =
550
-
match Pds.checkout pds with Some m -> m | None -> Atp.Mst.empty
551
-
in
552
-
let cid = Atp.Mst.to_cid mst ~store:bs in
553
-
Atp.Cid.to_string cid
554
-
555
-
let log _ ~branch:_ ~limit:_ = []
556
-
let read_commit _ _ = None
557
-
558
-
let update_branch pds ~branch ~old ~new_ =
559
-
let b = backend pds in
560
-
Private.Backend.test_and_set_ref b ("refs/heads/" ^ branch)
561
-
~test:(Option.map mst_cid_of old)
562
-
~set:(Some (mst_cid_of new_))
563
-
564
-
let is_ancestor _ ~ancestor:_ ~descendant:_ = false
565
-
let merge_base _ _ _ = None
566
-
let pp ppf _ = Fmt.pf ppf "<irmin:pds>"
567
-
end
568
-
569
458
(* ===== Module Git ===== *)
570
459
571
460
module Git = struct
···
601
490
include Mst_S
602
491
603
492
let v s = T ((module Mst_S), s)
604
-
let of_pds pds = T ((module Pds_S), pds)
493
+
494
+
let of_pds pds =
495
+
v (Private.Store.Mst.create ~backend:(Pds_interop.mst_backend pds))
605
496
606
497
let disk ~sw root =
607
498
v (Private.Store.Mst.create ~backend:(Private.Backend.Disk.cid ~sw root))