Persistent store with Git semantics: lazy reads, delayed writes, content-addressing
Refactor Backend to module type S + Make functor + functor combinators
Backend.t is now abstract, backed by an internal record hidden by
the .mli. The public API exposes:
- module type S: the backend interface (read, write, exists, ...)
- Make(B : S): functor to pack a module + state into 'hash t
- Flat functions: Backend.read t h, Backend.write t h data, etc.
- Functor combinators: Cached(B), Readonly(B), Layered(U)(L)
Each backend (git_interop.Git_backend, pds_interop.Pds_backend,
Memory.Impl, Disk.Impl) is a named top-level module matching S.
Combinators compose at the module level before packing with Make.
+574
-487
+335
-286
lib/backend.ml
+335
-286
lib/backend.ml
···
1
-
type 'hash t = {
2
-
read : 'hash -> string option;
3
-
write : 'hash -> string -> unit;
4
-
exists : 'hash -> bool;
5
-
get_ref : string -> 'hash option;
6
-
set_ref : string -> 'hash -> unit;
7
-
test_and_set_ref : string -> test:'hash option -> set:'hash option -> bool;
8
-
list_refs : unit -> string list;
9
-
write_batch : ('hash * string) list -> unit;
10
-
flush : unit -> unit;
11
-
close : unit -> unit;
12
-
}
1
+
module type S = sig
2
+
type t
3
+
type hash
13
4
14
-
type stats = { reads : int; writes : int; cache_hits : int; cache_misses : int }
5
+
val read : t -> hash -> string option
6
+
val write : t -> hash -> string -> unit
7
+
val exists : t -> hash -> bool
8
+
val get_ref : t -> string -> hash option
9
+
val set_ref : t -> string -> hash -> unit
15
10
16
-
module Memory = struct
17
-
module String_map = Map.Make (String)
11
+
val test_and_set_ref :
12
+
t -> string -> test:hash option -> set:hash option -> bool
18
13
19
-
type 'hash state = {
20
-
mutable objects : string String_map.t;
21
-
mutable refs : 'hash String_map.t;
22
-
to_hex : 'hash -> string;
23
-
equal : 'hash -> 'hash -> bool;
24
-
}
14
+
val list_refs : t -> string list
15
+
val write_batch : t -> (hash * string) list -> unit
16
+
val flush : t -> unit
17
+
val close : t -> unit
18
+
end
25
19
26
-
let create_with_hash (type h) (to_hex : h -> string) (equal : h -> h -> bool)
27
-
: h t =
28
-
let state =
29
-
{ objects = String_map.empty; refs = String_map.empty; to_hex; equal }
30
-
in
20
+
(* Internal record — abstract in .mli *)
21
+
type 'hash t = {
22
+
i_read : 'hash -> string option;
23
+
i_write : 'hash -> string -> unit;
24
+
i_exists : 'hash -> bool;
25
+
i_get_ref : string -> 'hash option;
26
+
i_set_ref : string -> 'hash -> unit;
27
+
i_test_and_set_ref : string -> test:'hash option -> set:'hash option -> bool;
28
+
i_list_refs : unit -> string list;
29
+
i_write_batch : ('hash * string) list -> unit;
30
+
i_flush : unit -> unit;
31
+
i_close : unit -> unit;
32
+
}
33
+
34
+
module Make (B : S) = struct
35
+
let v (s : B.t) : B.hash t =
31
36
{
32
-
read =
33
-
(fun h ->
34
-
let key = state.to_hex h in
35
-
String_map.find_opt key state.objects);
36
-
write =
37
-
(fun h data ->
38
-
let key = state.to_hex h in
39
-
state.objects <- String_map.add key data state.objects);
40
-
exists =
41
-
(fun h ->
42
-
let key = state.to_hex h in
43
-
String_map.mem key state.objects);
44
-
get_ref = (fun name -> String_map.find_opt name state.refs);
45
-
set_ref =
46
-
(fun name hash -> state.refs <- String_map.add name hash state.refs);
47
-
test_and_set_ref =
48
-
(fun name ~test ~set ->
49
-
let current = String_map.find_opt name state.refs in
50
-
let matches =
51
-
match (test, current) with
52
-
| None, None -> true
53
-
| Some t, Some c -> state.equal t c
54
-
| _ -> false
55
-
in
56
-
if matches then (
57
-
(match set with
58
-
| None -> state.refs <- String_map.remove name state.refs
59
-
| Some h -> state.refs <- String_map.add name h state.refs);
60
-
true)
61
-
else false);
62
-
list_refs = (fun () -> String_map.bindings state.refs |> List.map fst);
63
-
write_batch =
64
-
(fun objects ->
65
-
List.iter
66
-
(fun (h, data) ->
67
-
let key = state.to_hex h in
68
-
state.objects <- String_map.add key data state.objects)
69
-
objects);
70
-
flush = (fun () -> ());
71
-
close = (fun () -> ());
37
+
i_read = B.read s;
38
+
i_write = B.write s;
39
+
i_exists = B.exists s;
40
+
i_get_ref = B.get_ref s;
41
+
i_set_ref = B.set_ref s;
42
+
i_test_and_set_ref = B.test_and_set_ref s;
43
+
i_list_refs = (fun () -> B.list_refs s);
44
+
i_write_batch = B.write_batch s;
45
+
i_flush = (fun () -> B.flush s);
46
+
i_close = (fun () -> B.close s);
72
47
}
73
-
74
-
let create_sha1 () = create_with_hash Hash.to_hex Hash.equal
75
-
let create_sha256 () = create_with_hash Hash.to_hex Hash.equal
76
-
let create_cid () = create_with_hash Atp.Cid.to_string Atp.Cid.equal
77
48
end
78
49
79
-
(* Simple LRU cache *)
50
+
let read t h = t.i_read h
51
+
let write t h data = t.i_write h data
52
+
let exists t h = t.i_exists h
53
+
let get_ref t name = t.i_get_ref name
54
+
let set_ref t name h = t.i_set_ref name h
55
+
let test_and_set_ref t name ~test ~set = t.i_test_and_set_ref name ~test ~set
56
+
let list_refs t = t.i_list_refs ()
57
+
let write_batch t objects = t.i_write_batch objects
58
+
let flush t = t.i_flush ()
59
+
let close t = t.i_close ()
60
+
61
+
type stats = { reads : int; writes : int; cache_hits : int; cache_misses : int }
62
+
63
+
(* ===== Combinator functors ===== *)
64
+
80
65
module Lru = struct
81
66
type ('k, 'v) t = { capacity : int; mutable items : ('k * 'v) list }
82
67
···
85
70
let find t key =
86
71
match List.assoc_opt key t.items with
87
72
| Some v ->
88
-
(* Move to front *)
89
73
t.items <- (key, v) :: List.remove_assoc key t.items;
90
74
Some v
91
75
| None -> None
···
96
80
t.items <- List.rev (List.tl (List.rev t.items))
97
81
end
98
82
99
-
let cached (type h) (backend : h t) : h t =
100
-
let cache : (h, string) Lru.t = Lru.create 1000 in
101
-
{
102
-
backend with
103
-
read =
104
-
(fun h ->
105
-
match Lru.find cache h with
106
-
| Some v -> Some v
107
-
| None ->
108
-
let result = backend.read h in
109
-
Option.iter (fun v -> Lru.add cache h v) result;
110
-
result);
83
+
module Cached (B : S) :
84
+
S with type t = B.t * (B.hash, string) Lru.t and type hash = B.hash = struct
85
+
type t = B.t * (B.hash, string) Lru.t
86
+
type hash = B.hash
87
+
88
+
let read (s, cache) h =
89
+
match Lru.find cache h with
90
+
| Some v -> Some v
91
+
| None ->
92
+
let r = B.read s h in
93
+
Option.iter (fun v -> Lru.add cache h v) r;
94
+
r
95
+
96
+
let write (s, _) = B.write s
97
+
let exists (s, _) = B.exists s
98
+
let get_ref (s, _) = B.get_ref s
99
+
let set_ref (s, _) = B.set_ref s
100
+
let test_and_set_ref (s, _) = B.test_and_set_ref s
101
+
let list_refs (s, _) = B.list_refs s
102
+
let write_batch (s, _) = B.write_batch s
103
+
let flush (s, _) = B.flush s
104
+
let close (s, _) = B.close s
105
+
end
106
+
107
+
module Readonly (B : S) : S with type t = B.t and type hash = B.hash = struct
108
+
type t = B.t
109
+
type hash = B.hash
110
+
111
+
let fail () = invalid_arg "Backend is read-only"
112
+
let read = B.read
113
+
let write _ _ _ = fail ()
114
+
let exists = B.exists
115
+
let get_ref = B.get_ref
116
+
let set_ref _ _ _ = fail ()
117
+
let test_and_set_ref _ _ ~test:_ ~set:_ = fail ()
118
+
let list_refs = B.list_refs
119
+
let write_batch _ _ = fail ()
120
+
let flush = B.flush
121
+
let close = B.close
122
+
end
123
+
124
+
module Layered (U : S) (L : S with type hash = U.hash) :
125
+
S with type t = U.t * L.t and type hash = U.hash = struct
126
+
type t = U.t * L.t
127
+
type hash = U.hash
128
+
129
+
let read (u, l) h =
130
+
match U.read u h with Some v -> Some v | None -> L.read l h
131
+
132
+
let write (u, _) = U.write u
133
+
let exists (u, l) h = U.exists u h || L.exists l h
134
+
135
+
let get_ref (u, l) name =
136
+
match U.get_ref u name with Some v -> Some v | None -> L.get_ref l name
137
+
138
+
let set_ref (u, _) = U.set_ref u
139
+
let test_and_set_ref (u, _) = U.test_and_set_ref u
140
+
141
+
let list_refs (u, l) =
142
+
List.sort_uniq String.compare (U.list_refs u @ L.list_refs l)
143
+
144
+
let write_batch (u, _) = U.write_batch u
145
+
146
+
let flush (u, l) =
147
+
U.flush u;
148
+
L.flush l
149
+
150
+
let close (u, l) =
151
+
U.close u;
152
+
L.close l
153
+
end
154
+
155
+
let stats _ = None
156
+
157
+
(* ===== Memory backend ===== *)
158
+
159
+
module Memory = struct
160
+
module String_map = Map.Make (String)
161
+
162
+
type 'hash mem_state = {
163
+
mutable objects : string String_map.t;
164
+
mutable refs : 'hash String_map.t;
111
165
}
112
166
113
-
let readonly (backend : 'h t) : 'h t =
114
-
let fail () = invalid_arg "Backend is read-only" in
115
-
{
116
-
backend with
117
-
write = (fun _ _ -> fail ());
118
-
set_ref = (fun _ _ -> fail ());
119
-
test_and_set_ref = (fun _ ~test:_ ~set:_ -> fail ());
120
-
write_batch = (fun _ -> fail ());
121
-
}
167
+
module Impl (H : sig
168
+
type t
169
+
170
+
val to_hex : t -> string
171
+
val equal : t -> t -> bool
172
+
end) : S with type hash = H.t and type t = H.t mem_state = struct
173
+
type hash = H.t
174
+
type t = hash mem_state
175
+
176
+
let read s h = String_map.find_opt (H.to_hex h) s.objects
177
+
let write s h data = s.objects <- String_map.add (H.to_hex h) data s.objects
178
+
let exists s h = String_map.mem (H.to_hex h) s.objects
179
+
let get_ref s name = String_map.find_opt name s.refs
180
+
let set_ref s name h = s.refs <- String_map.add name h s.refs
181
+
182
+
let test_and_set_ref s name ~test ~set =
183
+
let current = String_map.find_opt name s.refs in
184
+
let matches =
185
+
match (test, current) with
186
+
| None, None -> true
187
+
| Some t, Some c -> H.equal t c
188
+
| _ -> false
189
+
in
190
+
if matches then (
191
+
(match set with
192
+
| None -> s.refs <- String_map.remove name s.refs
193
+
| Some h -> s.refs <- String_map.add name h s.refs);
194
+
true)
195
+
else false
196
+
197
+
let list_refs s = String_map.bindings s.refs |> List.map fst
122
198
123
-
let layered ~(upper : 'h t) ~(lower : 'h t) : 'h t =
124
-
{
125
-
read =
126
-
(fun h ->
127
-
match upper.read h with Some v -> Some v | None -> lower.read h);
128
-
write = upper.write;
129
-
exists = (fun h -> upper.exists h || lower.exists h);
130
-
get_ref =
131
-
(fun name ->
132
-
match upper.get_ref name with
133
-
| Some v -> Some v
134
-
| None -> lower.get_ref name);
135
-
set_ref = upper.set_ref;
136
-
test_and_set_ref = upper.test_and_set_ref;
137
-
list_refs =
138
-
(fun () ->
139
-
let upper_refs = upper.list_refs () in
140
-
let lower_refs = lower.list_refs () in
141
-
List.sort_uniq String.compare (upper_refs @ lower_refs));
142
-
write_batch = upper.write_batch;
143
-
flush =
144
-
(fun () ->
145
-
upper.flush ();
146
-
lower.flush ());
147
-
close =
148
-
(fun () ->
149
-
upper.close ();
150
-
lower.close ());
151
-
}
199
+
let write_batch s objects =
200
+
List.iter
201
+
(fun (h, data) ->
202
+
s.objects <- String_map.add (H.to_hex h) data s.objects)
203
+
objects
152
204
153
-
let stats _ = None
205
+
let flush _ = ()
206
+
let close _ = ()
207
+
end
154
208
155
-
(** Disk-based backend using append-only storage with WAL and bloom filter.
209
+
let create_with_hash (type h) (to_hex : h -> string) (equal : h -> h -> bool)
210
+
: h t =
211
+
let module H = struct
212
+
type t = h
156
213
157
-
Storage layout:
158
-
- objects.wal: write-ahead log for crash recovery (uses ocaml-wal)
159
-
- objects.data: append-only file containing all objects
160
-
- objects.idx: index file mapping hex hash -> (offset, length)
161
-
- objects.bloom: serialized bloom filter for fast negative lookups
162
-
- refs/: directory with one file per ref containing hex hash
214
+
let to_hex = to_hex
215
+
let equal = equal
216
+
end in
217
+
let module B = Impl (H) in
218
+
let module P = Make (B) in
219
+
P.v { objects = String_map.empty; refs = String_map.empty }
163
220
164
-
Write path: 1. Write to WAL (crash-safe with CRC) 2. Write to data file 3.
165
-
Update in-memory index and bloom filter 4. On flush: save index and bloom,
166
-
then clear WAL
221
+
let create_sha1 () = create_with_hash Hash.to_hex Hash.equal
222
+
let create_sha256 () = create_with_hash Hash.to_hex Hash.equal
223
+
let create_cid () = create_with_hash Atp.Cid.to_string Atp.Cid.equal
224
+
end
167
225
168
-
Recovery: 1. Load index and bloom from disk 2. Replay any entries in WAL not
169
-
yet in index
226
+
(* ===== Disk backend ===== *)
170
227
171
-
Inspired by lavyek's append-only design and LevelDB's WAL pattern. *)
172
228
module Disk = struct
173
229
module String_map = Map.Make (String)
174
230
···
192
248
let bloom_path root = Eio.Path.(root / "objects.bloom")
193
249
let wal_path root = Eio.Path.(root / "objects.wal")
194
250
let refs_path root = Eio.Path.(root / "refs")
195
-
196
-
(* Expected number of objects for bloom filter sizing *)
197
251
let bloom_expected_size = 100_000
198
252
199
-
(* Index file format: one line per entry "hex_hash offset length\n" *)
200
253
let load_index root =
201
254
let path = index_path root in
202
255
if Eio.Path.is_file path then
···
271
324
let path = refs_path root in
272
325
if not (Eio.Path.is_directory path) then Eio.Path.mkdir ~perm:0o755 path;
273
326
let ref_path = Eio.Path.(path / name) in
274
-
(* Handle nested paths like refs/heads/main *)
275
327
let dir = Filename.dirname name in
276
328
if dir <> "." && dir <> "" then begin
277
329
let dir_path = Eio.Path.(path / dir) in
···
297
349
in
298
350
(file, offset)
299
351
300
-
(* WAL record format: "hex_hash\x00data" *)
301
352
let encode_wal_record hex data = hex ^ "\x00" ^ data
302
353
303
354
let decode_wal_record record =
···
308
359
let data = String.sub record (i + 1) (String.length record - i - 1) in
309
360
Some (hex, data)
310
361
311
-
(* Replay WAL entries that aren't in the index yet *)
312
362
let replay_wal root index bloom data_file data_offset =
313
363
let wal_p = wal_path root in
314
364
if not (Eio.Path.is_file wal_p) then (index, bloom, data_offset)
···
321
371
| Some (hex, data) ->
322
372
if String_map.mem hex idx then (idx, blm, offset)
323
373
else begin
324
-
(* Write to data file *)
325
374
let len = String.length data in
326
375
Eio.File.pwrite_all data_file
327
376
~file_offset:(Optint.Int63.of_int offset)
···
332
381
end)
333
382
(index, bloom, data_offset)
334
383
records
384
+
385
+
module Impl (H : sig
386
+
type t
387
+
388
+
val to_hex : t -> string
389
+
val equal : t -> t -> bool
390
+
end) : S with type t = H.t state and type hash = H.t = struct
391
+
type t = H.t state
392
+
type hash = H.t
393
+
394
+
let read s h =
395
+
let key = s.to_hex h in
396
+
match String_map.find_opt key s.index with
397
+
| None -> None
398
+
| Some entry -> (
399
+
match s.data_file with
400
+
| None -> None
401
+
| Some file ->
402
+
let buf = Cstruct.create entry.length in
403
+
Eio.File.pread_exact file
404
+
~file_offset:(Optint.Int63.of_int entry.offset)
405
+
[ buf ];
406
+
Some (Cstruct.to_string buf))
407
+
408
+
let write s h data =
409
+
Eio.Mutex.use_rw ~protect:true s.mutex (fun () ->
410
+
let key = s.to_hex h in
411
+
if Bloom.mem s.bloom key && String_map.mem key s.index then ()
412
+
else
413
+
match (s.wal, s.data_file) with
414
+
| Some wal, Some file ->
415
+
Wal.append wal (encode_wal_record key data);
416
+
Wal.sync wal;
417
+
let len = String.length data in
418
+
let offset = s.data_offset in
419
+
Eio.File.pwrite_all file
420
+
~file_offset:(Optint.Int63.of_int offset)
421
+
[ Cstruct.of_string data ];
422
+
s.data_offset <- offset + len;
423
+
s.index <- String_map.add key { offset; length = len } s.index;
424
+
Bloom.add s.bloom key
425
+
| _ -> ())
426
+
427
+
let exists s h =
428
+
let key = s.to_hex h in
429
+
Bloom.mem s.bloom key && String_map.mem key s.index
430
+
431
+
let get_ref s name = String_map.find_opt name s.refs
432
+
433
+
let set_ref s name hash =
434
+
Eio.Mutex.use_rw ~protect:true s.mutex (fun () ->
435
+
s.refs <- String_map.add name hash s.refs;
436
+
save_ref s.root name hash s.to_hex)
437
+
438
+
let test_and_set_ref s name ~test ~set =
439
+
Eio.Mutex.use_rw ~protect:true s.mutex (fun () ->
440
+
let current = String_map.find_opt name s.refs in
441
+
let matches =
442
+
match (test, current) with
443
+
| None, None -> true
444
+
| Some t, Some c -> s.equal t c
445
+
| _ -> false
446
+
in
447
+
if matches then begin
448
+
(match set with
449
+
| None ->
450
+
s.refs <- String_map.remove name s.refs;
451
+
delete_ref s.root name
452
+
| Some h ->
453
+
s.refs <- String_map.add name h s.refs;
454
+
save_ref s.root name h s.to_hex);
455
+
true
456
+
end
457
+
else false)
458
+
459
+
let list_refs s = String_map.bindings s.refs |> List.map fst
460
+
461
+
let write_batch s objects =
462
+
Eio.Mutex.use_rw ~protect:true s.mutex (fun () ->
463
+
match (s.wal, s.data_file) with
464
+
| Some wal, Some file ->
465
+
List.iter
466
+
(fun (h, data) ->
467
+
let key = s.to_hex h in
468
+
if not (String_map.mem key s.index) then
469
+
Wal.append wal (encode_wal_record key data))
470
+
objects;
471
+
Wal.sync wal;
472
+
List.iter
473
+
(fun (h, data) ->
474
+
let key = s.to_hex h in
475
+
if String_map.mem key s.index then ()
476
+
else begin
477
+
let len = String.length data in
478
+
let offset = s.data_offset in
479
+
Eio.File.pwrite_all file
480
+
~file_offset:(Optint.Int63.of_int offset)
481
+
[ Cstruct.of_string data ];
482
+
s.data_offset <- offset + len;
483
+
s.index <-
484
+
String_map.add key { offset; length = len } s.index;
485
+
Bloom.add s.bloom key
486
+
end)
487
+
objects
488
+
| _ -> ())
489
+
490
+
let flush s =
491
+
Eio.Mutex.use_rw ~protect:true s.mutex (fun () ->
492
+
(match s.data_file with
493
+
| Some file -> Eio.File.sync file
494
+
| None -> ());
495
+
save_index s.root s.index;
496
+
save_bloom s.root s.bloom;
497
+
let wal_p = wal_path s.root in
498
+
if Eio.Path.is_file wal_p then Eio.Path.unlink wal_p)
499
+
500
+
let close s =
501
+
Eio.Mutex.use_rw ~protect:true s.mutex (fun () ->
502
+
(match s.wal with Some wal -> Wal.close wal | None -> ());
503
+
(match s.data_file with
504
+
| Some file ->
505
+
Eio.File.sync file;
506
+
Eio.Resource.close file
507
+
| None -> ());
508
+
save_index s.root s.index;
509
+
save_bloom s.root s.bloom;
510
+
let wal_p = wal_path s.root in
511
+
if Eio.Path.is_file wal_p then Eio.Path.unlink wal_p;
512
+
s.wal <- None;
513
+
s.data_file <- None)
514
+
end
335
515
336
516
let create_with_hash (type h) ~sw (root : Eio.Fs.dir_ty Eio.Path.t)
337
517
(to_hex : h -> string) (of_hex : string -> (h, [ `Msg of string ]) result)
338
518
(equal : h -> h -> bool) : h t =
339
-
(* Create root directory if needed *)
340
519
if not (Eio.Path.is_directory root) then
341
520
Eio.Path.mkdirs ~exists_ok:true ~perm:0o755 root;
342
521
let index = load_index root in
343
522
let bloom = load_bloom root in
344
-
(* Populate bloom from index if empty (first load after upgrade) *)
345
523
if Bloom.size_estimate bloom = 0 then
346
524
String_map.iter (fun hex _ -> Bloom.add bloom hex) index;
347
525
let refs = load_refs root of_hex in
348
526
let file, offset = open_data_file ~sw root in
349
527
let data_file = (file :> Eio.File.rw_ty Eio.Resource.t) in
350
-
(* Replay any uncommitted WAL entries *)
351
528
let index, bloom, offset = replay_wal root index bloom data_file offset in
352
-
(* Open WAL for new writes *)
353
529
let wal = Wal.v ~sw (wal_path root) in
354
-
let state =
530
+
let module H = struct
531
+
type t = h
532
+
533
+
let to_hex = to_hex
534
+
let equal = equal
535
+
end in
536
+
let module B = Impl (H) in
537
+
let module P = Make (B) in
538
+
P.v
355
539
{
356
540
root;
357
541
wal = Some wal;
···
364
548
equal;
365
549
mutex = Eio.Mutex.create ();
366
550
}
367
-
in
368
-
{
369
-
read =
370
-
(fun h ->
371
-
let key = state.to_hex h in
372
-
match String_map.find_opt key state.index with
373
-
| None -> None
374
-
| Some entry -> (
375
-
match state.data_file with
376
-
| None -> None
377
-
| Some file ->
378
-
let buf = Cstruct.create entry.length in
379
-
Eio.File.pread_exact file
380
-
~file_offset:(Optint.Int63.of_int entry.offset)
381
-
[ buf ];
382
-
Some (Cstruct.to_string buf)));
383
-
write =
384
-
(fun h data ->
385
-
Eio.Mutex.use_rw ~protect:true state.mutex (fun () ->
386
-
let key = state.to_hex h in
387
-
(* Fast path: bloom filter says "definitely not present" *)
388
-
if Bloom.mem state.bloom key && String_map.mem key state.index
389
-
then ()
390
-
else
391
-
match (state.wal, state.data_file) with
392
-
| Some wal, Some file ->
393
-
(* Write to WAL first for crash safety *)
394
-
Wal.append wal (encode_wal_record key data);
395
-
Wal.sync wal;
396
-
(* Then write to data file *)
397
-
let len = String.length data in
398
-
let offset = state.data_offset in
399
-
Eio.File.pwrite_all file
400
-
~file_offset:(Optint.Int63.of_int offset)
401
-
[ Cstruct.of_string data ];
402
-
state.data_offset <- offset + len;
403
-
state.index <-
404
-
String_map.add key { offset; length = len } state.index;
405
-
Bloom.add state.bloom key
406
-
| _ -> ()));
407
-
exists =
408
-
(fun h ->
409
-
let key = state.to_hex h in
410
-
(* Fast path: bloom filter for negative lookups *)
411
-
Bloom.mem state.bloom key && String_map.mem key state.index);
412
-
get_ref = (fun name -> String_map.find_opt name state.refs);
413
-
set_ref =
414
-
(fun name hash ->
415
-
Eio.Mutex.use_rw ~protect:true state.mutex (fun () ->
416
-
state.refs <- String_map.add name hash state.refs;
417
-
save_ref state.root name hash state.to_hex));
418
-
test_and_set_ref =
419
-
(fun name ~test ~set ->
420
-
Eio.Mutex.use_rw ~protect:true state.mutex (fun () ->
421
-
let current = String_map.find_opt name state.refs in
422
-
let matches =
423
-
match (test, current) with
424
-
| None, None -> true
425
-
| Some t, Some c -> state.equal t c
426
-
| _ -> false
427
-
in
428
-
if matches then begin
429
-
(match set with
430
-
| None ->
431
-
state.refs <- String_map.remove name state.refs;
432
-
delete_ref state.root name
433
-
| Some h ->
434
-
state.refs <- String_map.add name h state.refs;
435
-
save_ref state.root name h state.to_hex);
436
-
true
437
-
end
438
-
else false));
439
-
list_refs = (fun () -> String_map.bindings state.refs |> List.map fst);
440
-
write_batch =
441
-
(fun objects ->
442
-
Eio.Mutex.use_rw ~protect:true state.mutex (fun () ->
443
-
match (state.wal, state.data_file) with
444
-
| Some wal, Some file ->
445
-
(* Write all to WAL first *)
446
-
List.iter
447
-
(fun (h, data) ->
448
-
let key = state.to_hex h in
449
-
if not (String_map.mem key state.index) then
450
-
Wal.append wal (encode_wal_record key data))
451
-
objects;
452
-
Wal.sync wal;
453
-
(* Then write to data file *)
454
-
List.iter
455
-
(fun (h, data) ->
456
-
let key = state.to_hex h in
457
-
if String_map.mem key state.index then ()
458
-
else begin
459
-
let len = String.length data in
460
-
let offset = state.data_offset in
461
-
Eio.File.pwrite_all file
462
-
~file_offset:(Optint.Int63.of_int offset)
463
-
[ Cstruct.of_string data ];
464
-
state.data_offset <- offset + len;
465
-
state.index <-
466
-
String_map.add key { offset; length = len }
467
-
state.index;
468
-
Bloom.add state.bloom key
469
-
end)
470
-
objects
471
-
| _ -> ()));
472
-
flush =
473
-
(fun () ->
474
-
Eio.Mutex.use_rw ~protect:true state.mutex (fun () ->
475
-
(match state.data_file with
476
-
| Some file -> Eio.File.sync file
477
-
| None -> ());
478
-
save_index state.root state.index;
479
-
save_bloom state.root state.bloom;
480
-
(* Clear WAL after persisting index - entries are now recoverable
481
-
from index + data file *)
482
-
let wal_p = wal_path state.root in
483
-
if Eio.Path.is_file wal_p then Eio.Path.unlink wal_p));
484
-
close =
485
-
(fun () ->
486
-
Eio.Mutex.use_rw ~protect:true state.mutex (fun () ->
487
-
(match state.wal with Some wal -> Wal.close wal | None -> ());
488
-
(match state.data_file with
489
-
| Some file ->
490
-
Eio.File.sync file;
491
-
Eio.Resource.close file
492
-
| None -> ());
493
-
save_index state.root state.index;
494
-
save_bloom state.root state.bloom;
495
-
(* Clear WAL *)
496
-
let wal_p = wal_path state.root in
497
-
if Eio.Path.is_file wal_p then Eio.Path.unlink wal_p;
498
-
state.wal <- None;
499
-
state.data_file <- None));
500
-
}
501
551
502
552
let create_sha1 ~sw root =
503
553
create_with_hash ~sw root Hash.to_hex Hash.sha1_of_hex Hash.equal
504
554
505
555
let create_sha256 ~sw root =
506
556
create_with_hash ~sw root Hash.to_hex Hash.sha256_of_hex Hash.equal
507
-
508
-
let err_invalid_cid s exn =
509
-
Error (`Msg (Fmt.str "invalid CID %S: %s" s (Printexc.to_string exn)))
510
557
511
558
let create_cid ~sw root =
512
559
create_with_hash ~sw root Atp.Cid.to_string
513
560
(fun s ->
514
-
try Ok (Atp.Cid.of_string s) with exn -> err_invalid_cid s exn)
561
+
try Ok (Atp.Cid.of_string s)
562
+
with exn ->
563
+
Error (`Msg (Fmt.str "invalid CID %S: %s" s (Printexc.to_string exn))))
515
564
Atp.Cid.equal
516
565
end
+51
-59
lib/backend.mli
+51
-59
lib/backend.mli
···
1
-
(** Storage backends for Irmin.
2
-
3
-
Backends are records of functions, NOT functors. This makes them composable
4
-
and easy to create without functor application. *)
1
+
(** Storage backends for Irmin. *)
5
2
6
3
(** {1 Backend Interface} *)
7
4
8
-
type 'hash t = {
9
-
read : 'hash -> string option;
10
-
(** [read hash] retrieves the object with the given hash. *)
11
-
write : 'hash -> string -> unit;
12
-
(** [write hash data] stores [data] at [hash]. Caller computes the hash.
13
-
*)
14
-
exists : 'hash -> bool; (** [exists hash] checks if an object exists. *)
15
-
get_ref : string -> 'hash option;
16
-
(** [get_ref name] reads a reference (branch/tag). *)
17
-
set_ref : string -> 'hash -> unit;
18
-
(** [set_ref name hash] sets a reference. *)
19
-
test_and_set_ref : string -> test:'hash option -> set:'hash option -> bool;
20
-
(** [test_and_set_ref name ~test ~set] atomically updates a reference if
21
-
its current value matches [test]. *)
22
-
list_refs : unit -> string list;
23
-
(** [list_refs ()] returns all reference names. *)
24
-
write_batch : ('hash * string) list -> unit;
25
-
(** [write_batch [(h1, d1); ...]] writes multiple objects efficiently. *)
26
-
flush : unit -> unit; (** [flush ()] ensures all writes are persisted. *)
27
-
close : unit -> unit; (** [close ()] releases resources. *)
28
-
}
5
+
module type S = sig
6
+
type t
7
+
type hash
29
8
30
-
(** {1 Memory Backend} *)
9
+
val read : t -> hash -> string option
10
+
val write : t -> hash -> string -> unit
11
+
val exists : t -> hash -> bool
12
+
val get_ref : t -> string -> hash option
13
+
val set_ref : t -> string -> hash -> unit
31
14
32
-
module Memory : sig
33
-
val create_with_hash : ('h -> string) -> ('h -> 'h -> bool) -> 'h t
34
-
(** [create_with_hash to_hex equal] creates an in-memory backend. Caller
35
-
computes hashes; backend just stores (hash, data) pairs. *)
15
+
val test_and_set_ref :
16
+
t -> string -> test:hash option -> set:hash option -> bool
36
17
37
-
val create_sha1 : unit -> Hash.sha1 t
38
-
(** Create an in-memory SHA-1 backend. *)
18
+
val list_refs : t -> string list
19
+
val write_batch : t -> (hash * string) list -> unit
20
+
val flush : t -> unit
21
+
val close : t -> unit
22
+
end
39
23
40
-
val create_sha256 : unit -> Hash.sha256 t
41
-
(** Create an in-memory SHA-256 backend. *)
24
+
type 'hash t
25
+
(** A packed storage backend. *)
42
26
43
-
val create_cid : unit -> Atp.Cid.t t
44
-
(** Create an in-memory CID-keyed backend (ATProto compatible). *)
27
+
module Make (B : S) : sig
28
+
val v : B.t -> B.hash t
45
29
end
46
30
47
-
(** {1 Backend Combinators} *)
31
+
val read : 'h t -> 'h -> string option
32
+
val write : 'h t -> 'h -> string -> unit
33
+
val exists : 'h t -> 'h -> bool
34
+
val get_ref : 'h t -> string -> 'h option
35
+
val set_ref : 'h t -> string -> 'h -> unit
36
+
val test_and_set_ref : 'h t -> string -> test:'h option -> set:'h option -> bool
37
+
val list_refs : 'h t -> string list
38
+
val write_batch : 'h t -> ('h * string) list -> unit
39
+
val flush : 'h t -> unit
40
+
val close : 'h t -> unit
48
41
49
-
val cached : 'h t -> 'h t
50
-
(** [cached backend] wraps a backend with an LRU cache. Reads are served from
51
-
cache when possible. *)
42
+
(** {1 Combinator Functors}
43
+
44
+
Compose at the module level, then pack with {!Make}:
45
+
{[
46
+
module My_backend = Backend.Cached (Backend.Disk.Impl (...))
47
+
module P = Backend.Make (My_backend)
48
+
let backend = P.v state
49
+
]} *)
50
+
51
+
module Cached (B : S) : S with type hash = B.hash
52
+
module Readonly (B : S) : S with type t = B.t and type hash = B.hash
53
+
54
+
module Layered (U : S) (L : S with type hash = U.hash) :
55
+
S with type t = U.t * L.t and type hash = U.hash
52
56
53
-
val readonly : 'h t -> 'h t
54
-
(** [readonly backend] makes a backend read-only. Write operations raise
55
-
[Invalid_argument]. *)
57
+
(** {1 Memory Backend} *)
56
58
57
-
val layered : upper:'h t -> lower:'h t -> 'h t
58
-
(** [layered ~upper ~lower] creates a layered backend. Reads check upper first,
59
-
then lower. Writes go to upper only. Used for garbage collection
60
-
(upper=live, lower=frozen). *)
59
+
module Memory : sig
60
+
val create_with_hash : ('h -> string) -> ('h -> 'h -> bool) -> 'h t
61
+
val create_sha1 : unit -> Hash.sha1 t
62
+
val create_sha256 : unit -> Hash.sha256 t
63
+
val create_cid : unit -> Atp.Cid.t t
64
+
end
61
65
62
66
(** {1 Disk Backend} *)
63
67
···
69
73
(string -> ('h, [ `Msg of string ]) result) ->
70
74
('h -> 'h -> bool) ->
71
75
'h t
72
-
(** [create_with_hash ~sw root to_hex of_hex equal] creates a disk-based
73
-
backend at [root]. Uses append-only storage for objects with an index file
74
-
for lookups.
75
-
76
-
Storage layout:
77
-
- objects.data: append-only file containing all objects
78
-
- objects.idx: index mapping hex hash to (offset, length)
79
-
- refs/: directory with one file per ref *)
80
76
81
77
val create_sha1 : sw:Eio.Switch.t -> Eio.Fs.dir_ty Eio.Path.t -> Hash.sha1 t
82
-
(** Create a disk-based SHA-1 backend. *)
83
78
84
79
val create_sha256 :
85
80
sw:Eio.Switch.t -> Eio.Fs.dir_ty Eio.Path.t -> Hash.sha256 t
86
-
(** Create a disk-based SHA-256 backend. *)
87
81
88
82
val create_cid : sw:Eio.Switch.t -> Eio.Fs.dir_ty Eio.Path.t -> Atp.Cid.t t
89
-
(** Create a disk-based CID-keyed backend (ATProto compatible). *)
90
83
end
91
84
92
85
(** {1 Statistics} *)
···
94
87
type stats = { reads : int; writes : int; cache_hits : int; cache_misses : int }
95
88
96
89
val stats : _ t -> stats option
97
-
(** [stats backend] returns statistics if the backend tracks them. *)
+39
-35
lib/git_interop.ml
+39
-35
lib/git_interop.ml
···
39
39
true)
40
40
else false
41
41
42
-
(* Create Git backend from a Git.Repository.t *)
43
-
let git_backend (repo : Git.Repository.t) : Hash.sha1 Backend.t =
44
-
{
45
-
read =
46
-
(fun hash ->
47
-
let git_hash = git_hash_of_sha1 hash in
48
-
match Git.Repository.read repo git_hash with
49
-
| Ok value -> Some (Git.Value.to_string_without_header value)
50
-
| Error _ -> None);
51
-
write =
52
-
(fun expected_hash data ->
42
+
module Git_backend :
43
+
Backend.S with type t = Git.Repository.t and type hash = Hash.sha1 = struct
44
+
type t = Git.Repository.t
45
+
type hash = Hash.sha1
46
+
47
+
let read repo hash =
48
+
match Git.Repository.read repo (git_hash_of_sha1 hash) with
49
+
| Ok value -> Some (Git.Value.to_string_without_header value)
50
+
| Error _ -> None
51
+
52
+
let write repo expected_hash data =
53
+
let git_hash = git_hash_of_sha1 expected_hash in
54
+
if not (Git.Repository.exists repo git_hash) then
55
+
ignore (Git.Repository.write repo (git_value_of_data data))
56
+
57
+
let exists repo hash = Git.Repository.exists repo (git_hash_of_sha1 hash)
58
+
59
+
let get_ref repo name =
60
+
Option.map sha1_of_git_hash (Git.Repository.read_ref repo name)
61
+
62
+
let set_ref repo name hash =
63
+
Git.Repository.write_ref repo name (git_hash_of_sha1 hash)
64
+
65
+
let test_and_set_ref = test_and_set_ref
66
+
let list_refs repo = Git.Repository.list_refs repo
67
+
68
+
let write_batch repo objects =
69
+
List.iter
70
+
(fun (expected_hash, data) ->
53
71
let git_hash = git_hash_of_sha1 expected_hash in
54
72
if not (Git.Repository.exists repo git_hash) then
55
-
ignore (Git.Repository.write repo (git_value_of_data data)));
56
-
exists =
57
-
(fun hash ->
58
-
let git_hash = git_hash_of_sha1 hash in
59
-
Git.Repository.exists repo git_hash);
60
-
get_ref =
61
-
(fun name ->
62
-
Option.map sha1_of_git_hash (Git.Repository.read_ref repo name));
63
-
set_ref =
64
-
(fun name hash ->
65
-
Git.Repository.write_ref repo name (git_hash_of_sha1 hash));
66
-
test_and_set_ref = test_and_set_ref repo;
67
-
list_refs = (fun () -> Git.Repository.list_refs repo);
68
-
write_batch =
69
-
(fun objects ->
70
-
List.iter
71
-
(fun (expected_hash, data) ->
72
-
let git_hash = git_hash_of_sha1 expected_hash in
73
-
if not (Git.Repository.exists repo git_hash) then
74
-
ignore (Git.Repository.write repo (git_value_of_data data)))
75
-
objects);
76
-
flush = (fun () -> ());
77
-
close = (fun () -> ());
78
-
}
73
+
ignore (Git.Repository.write repo (git_value_of_data data)))
74
+
objects
75
+
76
+
let flush _ = ()
77
+
let close _ = ()
78
+
end
79
+
80
+
module Git_B = Backend.Make (Git_backend)
81
+
82
+
let git_backend repo = Git_B.v repo
79
83
80
84
let import ~sw ~fs ~git_dir =
81
85
let repo = Git.Repository.open_bare ~sw ~fs git_dir in
+2
-2
lib/link.ml
+2
-2
lib/link.ml
···
101
101
fetch =
102
102
(fun addr ->
103
103
match F.hash_of_hex addr with
104
-
| Ok h -> backend.read h
104
+
| Ok h -> Backend.read backend h
105
105
| Error _ -> None);
106
106
persist =
107
107
(fun data ->
108
108
let h = F.hash_contents data in
109
-
backend.write h data;
109
+
Backend.write backend h data;
110
110
F.hash_to_hex h);
111
111
}
112
112
in
+46
-40
lib/pds_interop.ml
+46
-40
lib/pds_interop.ml
···
4
4
(Merkle Search Tree) and blockstore, enabling interoperability between the
5
5
PDS record API and the MST key-value layer. *)
6
6
7
-
let mst_backend (pds : Pds.t) : Atp.Cid.t Backend.t =
8
-
let bs = Pds.blockstore pds in
9
-
{
10
-
Backend.read = (fun cid -> bs#get cid);
11
-
write = (fun cid data -> bs#put cid data);
12
-
exists = (fun cid -> bs#has cid);
13
-
get_ref =
14
-
(fun name ->
15
-
if name = "HEAD" || name = "refs/heads/main" then Pds.head pds else None);
16
-
set_ref =
17
-
(fun name cid ->
18
-
if name = "HEAD" || name = "refs/heads/main" then Pds.set_head pds cid);
19
-
test_and_set_ref =
20
-
(fun name ~test ~set ->
21
-
let current =
22
-
if name = "HEAD" || name = "refs/heads/main" then Pds.head pds
23
-
else None
24
-
in
25
-
let matches =
26
-
match (test, current) with
27
-
| None, None -> true
28
-
| Some t, Some c -> Atp.Cid.equal t c
29
-
| _ -> false
30
-
in
31
-
if matches then (
32
-
(match set with
33
-
| None -> ()
34
-
| Some cid ->
35
-
if name = "HEAD" || name = "refs/heads/main" then
36
-
Pds.set_head pds cid);
37
-
true)
38
-
else false);
39
-
list_refs =
40
-
(fun () ->
41
-
match Pds.head pds with None -> [] | Some _ -> [ "refs/heads/main" ]);
42
-
write_batch =
43
-
(fun objects -> List.iter (fun (cid, data) -> bs#put cid data) objects);
44
-
flush = (fun () -> bs#sync);
45
-
close = (fun () -> Pds.close pds);
46
-
}
7
+
module Pds_backend : Backend.S with type t = Pds.t and type hash = Atp.Cid.t =
8
+
struct
9
+
type t = Pds.t
10
+
type hash = Atp.Cid.t
11
+
12
+
let read pds cid = (Pds.blockstore pds)#get cid
13
+
let write pds cid data = (Pds.blockstore pds)#put cid data
14
+
let exists pds cid = (Pds.blockstore pds)#has cid
15
+
16
+
let get_ref pds name =
17
+
if name = "HEAD" || name = "refs/heads/main" then Pds.head pds else None
18
+
19
+
let set_ref pds name cid =
20
+
if name = "HEAD" || name = "refs/heads/main" then Pds.set_head pds cid
21
+
22
+
let test_and_set_ref pds name ~test ~set =
23
+
let current =
24
+
if name = "HEAD" || name = "refs/heads/main" then Pds.head pds else None
25
+
in
26
+
let matches =
27
+
match (test, current) with
28
+
| None, None -> true
29
+
| Some t, Some c -> Atp.Cid.equal t c
30
+
| _ -> false
31
+
in
32
+
if matches then (
33
+
(match set with
34
+
| None -> ()
35
+
| Some cid ->
36
+
if name = "HEAD" || name = "refs/heads/main" then Pds.set_head pds cid);
37
+
true)
38
+
else false
39
+
40
+
let list_refs pds =
41
+
match Pds.head pds with None -> [] | Some _ -> [ "refs/heads/main" ]
42
+
43
+
let write_batch pds objects =
44
+
List.iter (fun (cid, data) -> (Pds.blockstore pds)#put cid data) objects
45
+
46
+
let flush pds = (Pds.blockstore pds)#sync
47
+
let close pds = Pds.close pds
48
+
end
49
+
50
+
module Pds_B = Backend.Make (Pds_backend)
51
+
52
+
let mst_backend pds = Pds_B.v pds
47
53
48
54
let mst_find pds key =
49
55
match Pds.checkout pds with
+37
-18
lib/proof.ml
+37
-18
lib/proof.ml
···
198
198
let empty_env () = { nodes = Htbl.create 16; contents = Htbl.create 16 }
199
199
200
200
(* A recording backend wraps a real backend and records every read. *)
201
-
let recording_backend (backend : hash Backend.t) env : hash Backend.t =
202
-
let read h =
203
-
match backend.read h with
201
+
module Recording = struct
202
+
type t = { backend : hash Backend.t; env : env }
203
+
type nonrec hash = hash
204
+
205
+
let read t h =
206
+
match Backend.read t.backend h with
204
207
| Some data as r ->
205
208
(match C.node_of_bytes data with
206
-
| Ok _ -> Htbl.replace env.nodes h data
207
-
| Error _ -> Htbl.replace env.contents h data);
209
+
| Ok _ -> Htbl.replace t.env.nodes h data
210
+
| Error _ -> Htbl.replace t.env.contents h data);
208
211
r
209
212
| None -> None
210
-
in
211
-
{ backend with read }
213
+
214
+
let write t h data = Backend.write t.backend h data
215
+
let exists t h = Backend.exists t.backend h
216
+
let get_ref t name = Backend.get_ref t.backend name
217
+
let set_ref t name h = Backend.set_ref t.backend name h
218
+
219
+
let test_and_set_ref t name ~test ~set =
220
+
Backend.test_and_set_ref t.backend name ~test ~set
221
+
222
+
let list_refs t = Backend.list_refs t.backend
223
+
let write_batch t objs = Backend.write_batch t.backend objs
224
+
let flush t = Backend.flush t.backend
225
+
let close t = Backend.close t.backend
226
+
end
227
+
228
+
module Recording_B = Backend.Make (Recording)
229
+
230
+
let recording_backend backend env = Recording_B.v { backend; env }
212
231
213
232
(* A replay backend is a Memory backend pre-populated from the env. *)
214
233
let replay_backend env =
215
234
let b = Backend.Memory.create_with_hash C.hash_to_hex C.hash_equal in
216
-
Htbl.iter (fun h data -> b.write h data) env.nodes;
217
-
Htbl.iter (fun h data -> b.write h data) env.contents;
235
+
Htbl.iter (fun h data -> Backend.write b h data) env.nodes;
236
+
Htbl.iter (fun h data -> Backend.write b h data) env.contents;
218
237
b
219
238
220
239
(* --- Tree ------------------------------------------------------------ *)
···
230
249
let of_proof_tree tree = { state = From_proof { tree } }
231
250
232
251
let read_node backend h =
233
-
match backend.Backend.read h with
252
+
match Backend.read backend h with
234
253
| None -> None
235
254
| Some data -> (
236
255
match C.node_of_bytes data with Ok n -> Some n | Error _ -> None)
237
256
238
-
let read_contents backend h = backend.Backend.read h
257
+
let read_contents backend h = Backend.read backend h
239
258
240
259
(* --- Navigate backend tree ---------------------------------------- *)
241
260
···
382
401
| [] -> failwith "Proof.Tree.add: empty path"
383
402
| [ key ] ->
384
403
let h = C.hash_contents contents in
385
-
backend.write h contents;
404
+
Backend.write backend h contents;
386
405
C.add node key (`Contents h)
387
406
| key :: rest ->
388
407
let child_node =
···
396
415
let updated = add_to_node child_node rest in
397
416
let data = C.bytes_of_node updated in
398
417
let h = C.hash_node updated in
399
-
backend.write h data;
418
+
Backend.write backend h data;
400
419
C.add node key (`Node h)
401
420
in
402
421
let node =
···
407
426
let updated = add_to_node node path in
408
427
let data = C.bytes_of_node updated in
409
428
let new_hash = C.hash_node updated in
410
-
backend.write new_hash data;
429
+
Backend.write backend new_hash data;
411
430
{ state = Live { backend; node_hash = new_hash } }
412
431
| From_proof _ -> failwith "Proof.Tree.add: cannot modify proof tree"
413
432
···
429
448
let updated = add_tree_to_node sub_node rest in
430
449
let data = C.bytes_of_node updated in
431
450
let h = C.hash_node updated in
432
-
backend.write h data;
451
+
Backend.write backend h data;
433
452
C.add node key (`Node h)
434
453
in
435
454
let node =
···
440
459
let updated = add_tree_to_node node path in
441
460
let data = C.bytes_of_node updated in
442
461
let new_hash = C.hash_node updated in
443
-
backend.write new_hash data;
462
+
Backend.write backend new_hash data;
444
463
{ state = Live { backend; node_hash = new_hash } }
445
464
| _ -> failwith "Proof.Tree.add_tree: incompatible trees"
446
465
···
460
479
else
461
480
let data = C.bytes_of_node updated in
462
481
let h = C.hash_node updated in
463
-
backend.write h data;
482
+
Backend.write backend h data;
464
483
C.add node key (`Node h)
465
484
| None -> node)
466
485
| _ -> node)
···
473
492
let updated = remove_from_node node path in
474
493
let data = C.bytes_of_node updated in
475
494
let new_hash = C.hash_node updated in
476
-
backend.write new_hash data;
495
+
Backend.write backend new_hash data;
477
496
{ state = Live { backend; node_hash = new_hash } }
478
497
| From_proof _ -> failwith "Proof.Tree.remove: cannot modify proof tree"
479
498
+10
-7
lib/store.ml
+10
-7
lib/store.ml
···
15
15
| Some h -> Tree.of_hash ~backend:t.backend h
16
16
17
17
let read_commit t h =
18
-
match t.backend.read h with
18
+
match Backend.read t.backend h with
19
19
| None -> None
20
20
| Some data -> (
21
21
match Commit.of_bytes data with Ok c -> Some c | Error _ -> None)
···
23
23
let read_tree t h = Tree.of_hash ~backend:t.backend h
24
24
25
25
let checkout t ~branch =
26
-
match t.backend.get_ref ("refs/heads/" ^ branch) with
26
+
match Backend.get_ref t.backend ("refs/heads/" ^ branch) with
27
27
| None -> None
28
28
| Some commit_hash -> (
29
29
match read_commit t commit_hash with
···
36
36
let c = Commit.v ~tree:tree_hash ~parents ~author ~message () in
37
37
let data = Commit.to_bytes c in
38
38
let h = Commit.hash c in
39
-
t.backend.write h data;
39
+
Backend.write t.backend h data;
40
40
h
41
41
42
-
let head t ~branch = t.backend.get_ref ("refs/heads/" ^ branch)
43
-
let set_head t ~branch h = t.backend.set_ref ("refs/heads/" ^ branch) h
42
+
let head t ~branch = Backend.get_ref t.backend ("refs/heads/" ^ branch)
43
+
44
+
let set_head t ~branch h =
45
+
Backend.set_ref t.backend ("refs/heads/" ^ branch) h
46
+
44
47
let hash_to_hex h = F.hash_to_hex h
45
48
let hash_equal h1 h2 = F.hash_equal h1 h2
46
49
47
50
let branches t =
48
-
t.backend.list_refs ()
51
+
Backend.list_refs t.backend
49
52
|> List.filter_map (fun r ->
50
53
if String.length r > 11 && String.sub r 0 11 = "refs/heads/" then
51
54
Some (String.sub r 11 (String.length r - 11))
52
55
else None)
53
56
54
57
let update_branch t ~branch ~old ~new_ =
55
-
t.backend.test_and_set_ref ("refs/heads/" ^ branch) ~test:old
58
+
Backend.test_and_set_ref t.backend ("refs/heads/" ^ branch) ~test:old
56
59
~set:(Some new_)
57
60
58
61
(* Simple ancestry check - walks parent chain *)
+4
-4
lib/tree.ml
+4
-4
lib/tree.ml
···
42
42
match state with
43
43
| Loaded n -> Some n
44
44
| Lazy { backend; hash } -> (
45
-
match backend.read hash with
45
+
match Backend.read backend hash with
46
46
| Some data -> (
47
47
match F.node_of_bytes data with Ok n -> Some n | Error _ -> None)
48
48
| None -> None)
···
71
71
(* Load the content blob *)
72
72
match node.state with
73
73
| Lazy { backend; _ } -> (
74
-
match backend.read hash with
74
+
match Backend.read backend hash with
75
75
| Some data -> navigate (Contents data) rest
76
76
| None -> None)
77
77
| _ -> None)
···
234
234
match t with
235
235
| Contents s ->
236
236
let h = F.hash_contents s in
237
-
backend.write h s;
237
+
Backend.write backend h s;
238
238
h
239
239
| Node node -> (
240
240
(* Shallow node with no pending changes: already in backend. *)
···
266
266
in
267
267
let data = F.bytes_of_node final in
268
268
let h = F.hash_node final in
269
-
backend.write h data;
269
+
Backend.write backend h data;
270
270
h)
271
271
272
272
let hash t ~backend = write_tree t ~backend
+49
-35
test/test_backend.ml
+49
-35
test/test_backend.ml
···
23
23
let backend = Backend.Memory.create_sha1 () in
24
24
let data = "test content" in
25
25
let hash = Hash.sha1 data in
26
-
backend.write hash data;
27
-
Alcotest.(check (option string)) "read back" (Some data) (backend.read hash)
26
+
Backend.write backend hash data;
27
+
Alcotest.(check (option string))
28
+
"read back" (Some data)
29
+
(Backend.read backend hash)
28
30
29
31
let test_backend_refs () =
30
32
let backend = Backend.Memory.create_sha1 () in
31
33
let data = "content" in
32
34
let hash = Hash.sha1 data in
33
-
backend.write hash data;
34
-
backend.set_ref "refs/heads/main" hash;
35
+
Backend.write backend hash data;
36
+
Backend.set_ref backend "refs/heads/main" hash;
35
37
Alcotest.(check bool)
36
38
"ref exists" true
37
-
(Option.is_some (backend.get_ref "refs/heads/main"));
38
-
match backend.get_ref "refs/heads/main" with
39
+
(Option.is_some (Backend.get_ref backend "refs/heads/main"));
40
+
match Backend.get_ref backend "refs/heads/main" with
39
41
| Some h -> Alcotest.(check bool) "ref matches" true (Hash.equal hash h)
40
42
| None -> Alcotest.fail "ref not found"
41
43
···
43
45
let backend = Backend.Memory.create_sha1 () in
44
46
let h1 = Hash.sha1 "content1" in
45
47
let h2 = Hash.sha1 "content2" in
46
-
backend.write h1 "content1";
47
-
backend.write h2 "content2";
48
-
backend.set_ref "ref" h1;
49
-
let result = backend.test_and_set_ref "ref" ~test:(Some h2) ~set:(Some h2) in
48
+
Backend.write backend h1 "content1";
49
+
Backend.write backend h2 "content2";
50
+
Backend.set_ref backend "ref" h1;
51
+
let result =
52
+
Backend.test_and_set_ref backend "ref" ~test:(Some h2) ~set:(Some h2)
53
+
in
50
54
Alcotest.(check bool) "wrong test fails" false result;
51
-
let result = backend.test_and_set_ref "ref" ~test:(Some h1) ~set:(Some h2) in
55
+
let result =
56
+
Backend.test_and_set_ref backend "ref" ~test:(Some h1) ~set:(Some h2)
57
+
in
52
58
Alcotest.(check bool) "correct test succeeds" true result
53
59
54
60
let test_disk_backend () =
···
56
62
let backend = Backend.Disk.create_sha1 ~sw tmp_path in
57
63
let data = "test content" in
58
64
let hash = Hash.sha1 data in
59
-
backend.write hash data;
60
-
Alcotest.(check (option string)) "read back" (Some data) (backend.read hash);
61
-
backend.close ()
65
+
Backend.write backend hash data;
66
+
Alcotest.(check (option string))
67
+
"read back" (Some data)
68
+
(Backend.read backend hash);
69
+
Backend.close backend
62
70
63
71
let test_disk_backend_persistence () =
64
72
Eio_main.run @@ fun env ->
···
69
77
let hash = Hash.sha1 data in
70
78
Eio.Switch.run (fun sw ->
71
79
let backend = Backend.Disk.create_sha1 ~sw tmp_path in
72
-
backend.write hash data;
73
-
backend.set_ref "refs/heads/main" hash;
74
-
backend.flush ();
75
-
backend.close ());
80
+
Backend.write backend hash data;
81
+
Backend.set_ref backend "refs/heads/main" hash;
82
+
Backend.flush backend;
83
+
Backend.close backend);
76
84
Eio.Switch.run (fun sw ->
77
85
let backend = Backend.Disk.create_sha1 ~sw tmp_path in
78
86
Alcotest.(check (option string))
79
-
"read after reopen" (Some data) (backend.read hash);
87
+
"read after reopen" (Some data)
88
+
(Backend.read backend hash);
80
89
Alcotest.(check bool)
81
90
"ref persisted" true
82
-
(Option.is_some (backend.get_ref "refs/heads/main"));
83
-
backend.close ());
91
+
(Option.is_some (Backend.get_ref backend "refs/heads/main"));
92
+
Backend.close backend);
84
93
rm_rf tmp_path
85
94
86
95
let test_disk_backend_refs () =
···
88
97
let backend = Backend.Disk.create_sha1 ~sw tmp_path in
89
98
let data = "content" in
90
99
let hash = Hash.sha1 data in
91
-
backend.write hash data;
92
-
backend.set_ref "refs/heads/main" hash;
100
+
Backend.write backend hash data;
101
+
Backend.set_ref backend "refs/heads/main" hash;
93
102
Alcotest.(check bool)
94
103
"ref exists" true
95
-
(Option.is_some (backend.get_ref "refs/heads/main"));
96
-
(match backend.get_ref "refs/heads/main" with
104
+
(Option.is_some (Backend.get_ref backend "refs/heads/main"));
105
+
(match Backend.get_ref backend "refs/heads/main" with
97
106
| Some h -> Alcotest.(check bool) "ref matches" true (Hash.equal hash h)
98
107
| None -> Alcotest.fail "ref not found");
99
-
backend.close ()
108
+
Backend.close backend
100
109
101
110
let test_disk_backend_write_batch () =
102
111
with_temp_dir @@ fun ~sw tmp_path ->
···
108
117
(Hash.sha1 "data3", "data3");
109
118
]
110
119
in
111
-
backend.write_batch objects;
120
+
Backend.write_batch backend objects;
112
121
List.iter
113
122
(fun (hash, data) ->
114
123
Alcotest.(check (option string))
115
-
"batch item" (Some data) (backend.read hash))
124
+
"batch item" (Some data)
125
+
(Backend.read backend hash))
116
126
objects;
117
-
backend.close ()
127
+
Backend.close backend
118
128
119
129
let test_disk_backend_wal_recovery () =
120
130
Eio_main.run @@ fun env ->
···
125
135
let hash = Hash.sha1 data in
126
136
Eio.Switch.run (fun sw ->
127
137
let backend = Backend.Disk.create_sha1 ~sw tmp_path in
128
-
backend.write hash data;
138
+
Backend.write backend hash data;
129
139
Alcotest.(check (option string))
130
-
"readable before crash" (Some data) (backend.read hash);
131
-
backend.close ());
140
+
"readable before crash" (Some data)
141
+
(Backend.read backend hash);
142
+
Backend.close backend);
132
143
Eio.Switch.run (fun sw ->
133
144
let backend = Backend.Disk.create_sha1 ~sw tmp_path in
134
145
Alcotest.(check (option string))
135
-
"recovered from WAL" (Some data) (backend.read hash);
136
-
Alcotest.(check bool) "exists after recovery" true (backend.exists hash);
137
-
backend.close ());
146
+
"recovered from WAL" (Some data)
147
+
(Backend.read backend hash);
148
+
Alcotest.(check bool)
149
+
"exists after recovery" true
150
+
(Backend.exists backend hash);
151
+
Backend.close backend);
138
152
rm_rf tmp_path
139
153
140
154
let suite =
+1
-1
test/test_store.ml
+1
-1
test/test_store.ml
···
15
15
Store.Git.commit store ~tree ~parents:[] ~message:"Initial commit"
16
16
~author:"test"
17
17
in
18
-
Alcotest.(check bool) "commit hash exists" true (backend.exists hash)
18
+
Alcotest.(check bool) "commit hash exists" true (Backend.exists backend hash)
19
19
20
20
let test_store_branches () =
21
21
let backend = Backend.Memory.create_sha1 () in