Persistent store with Git semantics: lazy reads, delayed writes, content-addressing
irmin: address merlint issues
- heap: document public values; drop `val v : (module BACKEND) -> _`
first-class-module constructor, keep only the `Make(B:BACKEND)` functor
- hash: extract err_unknown_algo helper (E340)
- cmd_serve: extract err_unsafe_filename; narrow catch-all to Eio.Io
- tests: add docs to test_helpers.mli / test_store.mli; add irmin_ui.mli;
inline check_bool to avoid double-bool param flag (E350); narrow
catch-all in test_atproto_ext / test_stores to Eio.Io | Sys_error;
extract persist_session_{read,write}, with_pds_path, run_git to flatten
nesting (E010); rename test_sync get/get_ancestors -> find/ancestors
(E325/E331); shorten long identifiers in test_atproto / test_hash /
test_pds_interop (E320); rename atproto-extensions suite to snake_case
+182
-118
+4
-2
bin/cmd_serve.ml
+4
-2
bin/cmd_serve.ml
···
14
14
15
15
(* ── HTML helpers (tw.html DSL) ─────────────────────────────────────── *)
16
16
17
+
let err_unsafe_filename name = Error (Fmt.str "unsafe upload filename: %S" name)
18
+
17
19
let url_escape s =
18
20
let b = Buffer.create (String.length s) in
19
21
String.iter
···
229
231
let db_path = Eio.Path.(fs / ".irmin" / "auth.db") in
230
232
(* Ensure the containing directory exists. *)
231
233
(try Eio.Path.mkdirs ~perm:0o755 ~exists_ok:true Eio.Path.(fs / ".irmin")
232
-
with _ -> ());
234
+
with Eio.Io _ -> ());
233
235
let store = Auth.Store.v ~sw db_path in
234
236
let full_cfg =
235
237
Auth.config ~oauth_provider:Oauth.Github ~client_id ~client_secret
···
546
548
name = "" || name = "." || name = ".." || String.contains name '/'
547
549
|| String.contains name '\x00'
548
550
in
549
-
if bad then Error (Fmt.str "unsafe upload filename: %S" name) else Ok name
551
+
if bad then err_unsafe_filename name else Ok name
550
552
551
553
let upload ?auth heap (req : Respond.post_request) =
552
554
let authorized =
+3
-1
lib/hash.ml
+3
-1
lib/hash.ml
···
1
1
let err_invalid_hex pos =
2
2
Error (`Msg (Fmt.str "invalid hex character at position %d" pos))
3
3
4
+
let err_unknown_algo s = Error (`Msg (Fmt.str "unknown hash algorithm: %s" s))
5
+
4
6
type algorithm = Sha1 | Sha256
5
7
6
8
type _ t =
···
154
156
let algorithm_of_name = function
155
157
| "sha1" -> Ok Sha1
156
158
| "sha256" -> Ok Sha256
157
-
| s -> Error (`Msg (Fmt.str "unknown hash algorithm: %s" s))
159
+
| s -> err_unknown_algo s
158
160
159
161
let any_to_algo_hex a =
160
162
Fmt.str "%s:%s" (algorithm_name (any_algorithm a)) (any_to_hex a)
+17
-27
lib/heap.ml
+17
-27
lib/heap.ml
···
48
48
let to_seq t = t.to_seq ()
49
49
let pp ppf _ = Fmt.pf ppf "<heap>"
50
50
51
-
(* Construct a heap from a first-class module + state *)
52
-
let v (type h v s)
53
-
(b : (module BACKEND with type hash = h and type block = v and type t = s))
54
-
(s : s) : (h, v) t =
55
-
let module B = (val b) in
56
-
{
57
-
find = B.find s;
58
-
put = B.put s;
59
-
mem = B.mem s;
60
-
batch = B.batch s;
61
-
ref = B.ref s;
62
-
set_ref = B.set_ref s;
63
-
del_ref = B.del_ref s;
64
-
list_refs = (fun () -> B.list_refs s);
65
-
cas_ref = B.cas_ref s;
66
-
flush = (fun () -> B.flush s);
67
-
close = (fun () -> B.close s);
68
-
to_seq = (fun () -> Seq.empty);
69
-
}
70
-
71
51
module Make (B : BACKEND) = struct
72
52
let v (s : B.t) : (B.hash, B.block) t =
73
-
v
74
-
(module B : BACKEND
75
-
with type hash = B.hash
76
-
and type block = B.block
77
-
and type t = B.t)
78
-
s
53
+
{
54
+
find = B.find s;
55
+
put = B.put s;
56
+
mem = B.mem s;
57
+
batch = B.batch s;
58
+
ref = B.ref s;
59
+
set_ref = B.set_ref s;
60
+
del_ref = B.del_ref s;
61
+
list_refs = (fun () -> B.list_refs s);
62
+
cas_ref = B.cas_ref s;
63
+
flush = (fun () -> B.flush s);
64
+
close = (fun () -> B.close s);
65
+
to_seq = (fun () -> Seq.empty);
66
+
}
79
67
end
80
68
81
69
(* --- Combinators --- *)
···
202
190
Hashtbl.clear s.refs
203
191
end
204
192
193
+
module Heap = Make (B)
194
+
205
195
let v () : (H.hash, H.block) t =
206
196
let s = { blocks = Hashtbl.create 256; refs = Hashtbl.create 16 } in
207
-
let heap = v (module B) s in
197
+
let heap = Heap.v s in
208
198
{
209
199
heap with
210
200
to_seq =
+47
-8
lib/heap.mli
+47
-8
lib/heap.mli
···
14
14
(** A heap parameterized by hash type ['h] and block type ['v]. *)
15
15
16
16
val pp : Format.formatter -> (_, _) t -> unit
17
+
(** [pp ppf h] prints a short identifier for [h]. *)
17
18
18
19
(** {1:blocks Blocks} *)
19
20
20
21
val find : ('h, 'v) t -> 'h -> 'v option
22
+
(** [find h k] is the block bound to [k] in [h], or [None] if absent. *)
23
+
21
24
val put : ('h, 'v) t -> 'h -> 'v -> unit
25
+
(** [put h k v] stores [v] under [k] in [h]. *)
26
+
22
27
val mem : ('h, _) t -> 'h -> bool
28
+
(** [mem h k] is [true] iff [h] has a block under [k]. *)
29
+
23
30
val batch : ('h, 'v) t -> ('h * 'v) list -> unit
31
+
(** [batch h pairs] stores all [(k, v)] pairs in [h]. *)
24
32
25
33
(** {1:refs Named References} *)
26
34
27
35
val ref : ('h, _) t -> string -> 'h option
36
+
(** [ref h name] is the hash bound to [name], or [None] if unset. *)
37
+
28
38
val set_ref : ('h, _) t -> string -> 'h -> unit
39
+
(** [set_ref h name k] binds [name] to [k] in [h]. *)
40
+
29
41
val del_ref : ('h, _) t -> string -> unit
42
+
(** [del_ref h name] removes the binding for [name] in [h]. *)
43
+
30
44
val list_refs : (_, _) t -> string list
45
+
(** [list_refs h] is the list of ref names currently bound in [h]. *)
46
+
31
47
val cas_ref : ('h, _) t -> string -> test:'h option -> set:'h option -> bool
48
+
(** [cas_ref h name ~test ~set] atomically sets [name] to [set] iff its current
49
+
value equals [test]. Returns [true] on success. *)
32
50
33
51
(** {1:lifecycle Lifecycle} *)
34
52
35
53
val flush : (_, _) t -> unit
54
+
(** [flush h] forces pending writes to durable storage. *)
55
+
36
56
val close : (_, _) t -> unit
57
+
(** [close h] releases resources held by [h]. *)
37
58
38
59
(** {1:backend Backend binding} *)
39
60
···
43
64
type block
44
65
45
66
val find : t -> hash -> block option
67
+
(** [find s k] is the block bound to [k] in [s], or [None] if absent. *)
68
+
46
69
val put : t -> hash -> block -> unit
70
+
(** [put s k v] stores [v] under [k] in [s]. *)
71
+
47
72
val mem : t -> hash -> bool
73
+
(** [mem s k] is [true] iff [s] has a block under [k]. *)
74
+
48
75
val batch : t -> (hash * block) list -> unit
76
+
(** [batch s pairs] stores all [(k, v)] pairs in [s]. *)
77
+
49
78
val ref : t -> string -> hash option
79
+
(** [ref s name] is the hash bound to [name], or [None] if unset. *)
80
+
50
81
val set_ref : t -> string -> hash -> unit
82
+
(** [set_ref s name k] binds [name] to [k] in [s]. *)
83
+
51
84
val del_ref : t -> string -> unit
85
+
(** [del_ref s name] removes the binding for [name]. *)
86
+
52
87
val list_refs : t -> string list
88
+
(** [list_refs s] is the list of ref names bound in [s]. *)
89
+
53
90
val cas_ref : t -> string -> test:hash option -> set:hash option -> bool
91
+
(** [cas_ref s name ~test ~set] atomically sets [name] to [set] iff its
92
+
current value equals [test]. Returns [true] on success. *)
93
+
54
94
val flush : t -> unit
95
+
(** [flush s] forces pending writes to durable storage. *)
96
+
55
97
val close : t -> unit
98
+
(** [close s] releases resources held by [s]. *)
56
99
end
57
100
58
101
module Make (B : BACKEND) : sig
59
102
val v : B.t -> (B.hash, B.block) t
103
+
(** [v state] packs [state] into a typed heap using backend [B]. *)
60
104
end
61
105
62
-
val v :
63
-
(module BACKEND with type hash = 'h and type block = 'v and type t = 's) ->
64
-
's ->
65
-
('h, 'v) t
66
-
(** [v (module B) state] packs a backend module and its state into a heap.
67
-
Equivalent to [let module H = Make(B) in H.v state]. *)
68
-
69
106
(** {1:combinators Heap Combinators} *)
70
107
71
108
val recording : ('h, 'v) t -> ('h, 'v) t * (unit -> ('h * 'v) list)
···
81
118
to [top]. Blocks found in [bottom] are cached in [top]. *)
82
119
83
120
val to_seq : ('h, 'v) t -> ('h * 'v) Seq.t
121
+
(** [to_seq h] is a sequence of all [(hash, block)] pairs in [h]. *)
84
122
85
123
(** {1:mem In-Memory Heap} *)
86
124
···
89
127
type block
90
128
91
129
val equal : hash -> hash -> bool
130
+
(** [equal h1 h2] is [true] iff [h1] and [h2] are the same hash. *)
92
131
end) : sig
93
132
val v : unit -> (H.hash, H.block) t
94
-
(** Fresh in-memory heap backed by hashtables. *)
133
+
(** [v ()] is a fresh in-memory heap backed by hashtables. *)
95
134
end
+12
lib/ui/irmin_ui.mli
+12
lib/ui/irmin_ui.mli
···
1
+
(** UI component library for Irmin's HTTP pages.
2
+
3
+
Each module covers one visual concept; pages compose them via
4
+
{!Layout.page}. *)
5
+
6
+
module Brand = Brand
7
+
module Breadcrumb = Breadcrumb
8
+
module Button = Button
9
+
module Drop_zone = Drop_zone
10
+
module Layout = Layout
11
+
module Table = Table
12
+
module Tag = Tag
+10
-6
test/test_admin.ml
+10
-6
test/test_admin.ml
···
1
1
(** Tests for [Irmin_admin.parse]. *)
2
2
3
3
let check_string_list = Alcotest.(check (list string))
4
-
let check_bool = Alcotest.(check bool)
5
4
6
5
let parse_valid () =
7
6
let toml =
···
78
77
let cfg = Irmin_admin.parse {|[[allow]]
79
78
email = "me@example.com"
80
79
|} in
81
-
check_bool "listed email allowed" true
80
+
Alcotest.(check bool)
81
+
"listed email allowed" true
82
82
(Irmin_admin.is_allowed cfg ~email:"me@example.com");
83
-
check_bool "other email denied" false
83
+
Alcotest.(check bool)
84
+
"other email denied" false
84
85
(Irmin_admin.is_allowed cfg ~email:"nope@example.com")
85
86
86
87
let is_allowed_empty () =
87
-
check_bool "empty list denies everyone" false
88
+
Alcotest.(check bool)
89
+
"empty list denies everyone" false
88
90
(Irmin_admin.is_allowed Irmin_admin.empty ~email:"any@example.com")
89
91
90
92
let is_allowed_case_sensitive () =
···
93
95
let cfg = Irmin_admin.parse {|[[allow]]
94
96
email = "Alice@example.com"
95
97
|} in
96
-
check_bool "lowercase mismatch" false
98
+
Alcotest.(check bool)
99
+
"lowercase mismatch" false
97
100
(Irmin_admin.is_allowed cfg ~email:"alice@example.com");
98
-
check_bool "exact match" true
101
+
Alcotest.(check bool)
102
+
"exact match" true
99
103
(Irmin_admin.is_allowed cfg ~email:"Alice@example.com")
100
104
101
105
let suite =
+8
-8
test/test_atproto.ml
+8
-8
test/test_atproto.ml
···
180
180
Alcotest.(check (list string)) "feed.post list only" [ "p" ] post_keys;
181
181
Alcotest.(check (list string)) "feed.like list only" [ "p" ] like_keys
182
182
183
-
let test_collection_prefix_does_not_leak () =
183
+
let test_collection_prefix_isolated () =
184
184
(* "app.bsky.feed.posts" (plural) must not match "app.bsky.feed.post/". *)
185
185
with_memory_store @@ fun store ->
186
186
let _ =
···
255
255
let store = Atproto.of_pds pds in
256
256
f pds store)
257
257
258
-
let test_atproto_writes_readable_by_pds () =
258
+
let test_atproto_writes_readable_pds () =
259
259
with_pds_backed_store @@ fun pds store ->
260
260
let _ =
261
261
Atproto.put_record store ~author:pub_author ~collection:"app.bsky.feed.post"
···
276
276
Alcotest.(check (list string))
277
277
"Pds.list sees all records" [ "p1"; "p2" ] rkeys
278
278
279
-
let test_pds_writes_readable_by_atproto () =
279
+
let test_pds_writes_readable_atproto () =
280
280
with_pds_backed_store @@ fun pds store ->
281
281
let data =
282
282
Atp.Dagcbor.encode_string ~cid_format:`Atproto (`String "from-pds")
···
323
323
"pds sees c" (Some "via-atproto-2")
324
324
(Pds.find pds ~collection:"col" ~rkey:"c")
325
325
326
-
let test_atproto_delete_visible_to_pds () =
326
+
let test_atproto_delete_visible_pds () =
327
327
with_pds_backed_store @@ fun pds store ->
328
328
let _ =
329
329
Atproto.put_record store ~author:pub_author ~collection:"c" ~rkey:"k" "v"
···
355
355
test_list_records_empty_collection;
356
356
Alcotest.test_case "collections isolated" `Quick test_collections_isolated;
357
357
Alcotest.test_case "collection prefix does not leak" `Quick
358
-
test_collection_prefix_does_not_leak;
358
+
test_collection_prefix_isolated;
359
359
Alcotest.test_case "list collections" `Quick test_list_collections;
360
360
Alcotest.test_case "describe repo shape" `Quick test_describe_repo_shape;
361
361
Alcotest.test_case "describe repo empty" `Quick test_describe_repo_empty;
362
362
Alcotest.test_case "atproto writes readable by pds" `Quick
363
-
test_atproto_writes_readable_by_pds;
363
+
test_atproto_writes_readable_pds;
364
364
Alcotest.test_case "pds writes readable by atproto" `Quick
365
-
test_pds_writes_readable_by_atproto;
365
+
test_pds_writes_readable_atproto;
366
366
Alcotest.test_case "interleaved atproto + pds writes" `Quick
367
367
test_interleaved_atproto_pds_writes;
368
368
Alcotest.test_case "atproto delete visible to pds" `Quick
369
-
test_atproto_delete_visible_to_pds;
369
+
test_atproto_delete_visible_pds;
370
370
] )
+11
-5
test/test_atproto_ext.ml
+11
-5
test/test_atproto_ext.ml
···
7
7
let author = "tester"
8
8
let with_memory f = f (Irmin_atproto.memory ())
9
9
10
+
let cleanup_path path =
11
+
try Test_helpers.rm_rf path with Eio.Io _ | Sys_error _ -> ()
12
+
13
+
let with_pds_path ~sw path f =
14
+
Fun.protect
15
+
~finally:(fun () -> cleanup_path path)
16
+
(fun () -> f (Irmin_atproto.disk ~sw path))
17
+
10
18
let with_pds f =
11
19
Eio_main.run @@ fun env ->
12
20
Eio.Switch.run @@ fun sw ->
13
21
let cwd = Eio.Stdenv.cwd env in
14
22
let name = Fmt.str "irmin-test-atp-ext-%d" (Random.int 1_000_000) in
15
23
let path = Eio.Path.(cwd / "_build" / name) in
16
-
(try Eio.Path.mkdirs ~exists_ok:true ~perm:0o755 path with _ -> ());
17
-
Fun.protect
18
-
~finally:(fun () -> try Test_helpers.rm_rf path with _ -> ())
19
-
(fun () -> f (Irmin_atproto.disk ~sw path))
24
+
(try Eio.Path.mkdirs ~exists_ok:true ~perm:0o755 path with Eio.Io _ -> ());
25
+
with_pds_path ~sw path f
20
26
21
27
(* Run on both memory and PDS backends. *)
22
28
let with_each f =
···
136
142
(* {1 Suite} *)
137
143
138
144
let suite =
139
-
( "atproto-extensions",
145
+
( "atproto_ext",
140
146
[
141
147
Alcotest.test_case "put/get record" `Quick test_put_get_record;
142
148
Alcotest.test_case "delete record" `Quick test_delete_record;
+24
-22
test/test_atproto_tree.ml
+24
-22
test/test_atproto_tree.ml
···
298
298
299
299
(* ---------- PDS persistence across sessions ---------- *)
300
300
301
+
let persist_session_write path =
302
+
Eio.Switch.run @@ fun sw ->
303
+
let pds = Pds.v ~sw path ~did:test_did in
304
+
let store = Atproto.of_pds pds in
305
+
let t = Atproto.empty () in
306
+
let t = Atproto.add t (post "persist") "value" in
307
+
let h = Atproto.commit store ~tree:t ~parents:[] ~message:"w" ~author:"a" in
308
+
Atproto.set_head store ~branch:"main" h;
309
+
Pds.close pds
310
+
311
+
let persist_session_read path =
312
+
Eio.Switch.run @@ fun sw ->
313
+
let pds = Pds.open_ ~sw path in
314
+
let store = Atproto.of_pds pds in
315
+
match Atproto.checkout store ~branch:"main" with
316
+
| None -> Alcotest.fail "session 2 checkout None"
317
+
| Some t ->
318
+
Alcotest.(check (option string))
319
+
"read after reopen" (Some "value")
320
+
(Atproto.find t (post "persist"));
321
+
Pds.close pds
322
+
301
323
let test_commit_survives_reopen_pds () =
302
324
Eio_main.run @@ fun env ->
303
325
let cwd = Eio.Stdenv.cwd env in
···
308
330
Fun.protect
309
331
~finally:(fun () -> try Test_helpers.rm_rf path with Eio.Io _ -> ())
310
332
(fun () ->
311
-
(* Session 1: write *)
312
-
Eio.Switch.run (fun sw ->
313
-
let pds = Pds.v ~sw path ~did:test_did in
314
-
let store = Atproto.of_pds pds in
315
-
let t = Atproto.empty () in
316
-
let t = Atproto.add t (post "persist") "value" in
317
-
let h =
318
-
Atproto.commit store ~tree:t ~parents:[] ~message:"w" ~author:"a"
319
-
in
320
-
Atproto.set_head store ~branch:"main" h;
321
-
Pds.close pds);
322
-
(* Session 2: read *)
323
-
Eio.Switch.run (fun sw ->
324
-
let pds = Pds.open_ ~sw path in
325
-
let store = Atproto.of_pds pds in
326
-
match Atproto.checkout store ~branch:"main" with
327
-
| None -> Alcotest.fail "session 2 checkout None"
328
-
| Some t ->
329
-
Alcotest.(check (option string))
330
-
"read after reopen" (Some "value")
331
-
(Atproto.find t (post "persist"));
332
-
Pds.close pds))
333
+
persist_session_write path;
334
+
persist_session_read path)
333
335
334
336
(* ---------- Wire compatibility with the raw Atp.Mst + Pds layer ----- *)
335
337
+2
-2
test/test_gzip.ml
+2
-2
test/test_gzip.ml
···
1
1
(** Tests for [Irmin_gzip]. *)
2
2
3
3
let check_string = Alcotest.(check string)
4
-
let check_bool = Alcotest.(check bool)
5
4
6
5
let roundtrip_empty () =
7
6
let out = Irmin_gzip.uncompress (Irmin_gzip.compress "") in
···
25
24
check_string "deterministic" a b
26
25
27
26
let malformed_rejected () =
28
-
check_bool "Gzip_error raised" true
27
+
Alcotest.(check bool)
28
+
"Gzip_error raised" true
29
29
(try
30
30
let _ = Irmin_gzip.uncompress "this is not a gzip stream" in
31
31
false
+6
-6
test/test_hash.ml
+6
-6
test/test_hash.ml
···
65
65
| Ok a' -> Alcotest.(check bool) "roundtrip" true (Irmin.Hash.equal_any a a')
66
66
| Error (`Msg m) -> Alcotest.fail m
67
67
68
-
let any_of_algo_hex_rejects_unknown_algo () =
68
+
let algo_hex_unknown_algo () =
69
69
match Irmin.Hash.any_of_algo_hex "md5:abcdef" with
70
70
| Ok _ -> Alcotest.fail "expected error for unknown algo"
71
71
| Error (`Msg _) -> ()
72
72
73
-
let any_of_algo_hex_rejects_missing_separator () =
73
+
let algo_hex_missing_sep () =
74
74
match Irmin.Hash.any_of_algo_hex "sha256abcdef" with
75
75
| Ok _ -> Alcotest.fail "expected error for missing separator"
76
76
| Error (`Msg _) -> ()
77
77
78
-
let any_of_algo_hex_rejects_wrong_length () =
78
+
let algo_hex_wrong_length () =
79
79
match Irmin.Hash.any_of_algo_hex "sha256:deadbeef" with
80
80
| Ok _ -> Alcotest.fail "expected length error"
81
81
| Error (`Msg _) -> ()
···
102
102
any_compare_orders_by_algo;
103
103
Alcotest.test_case "any algo:hex roundtrip" `Quick any_algo_hex_roundtrip;
104
104
Alcotest.test_case "any_of_algo_hex rejects unknown algo" `Quick
105
-
any_of_algo_hex_rejects_unknown_algo;
105
+
algo_hex_unknown_algo;
106
106
Alcotest.test_case "any_of_algo_hex rejects missing :" `Quick
107
-
any_of_algo_hex_rejects_missing_separator;
107
+
algo_hex_missing_sep;
108
108
Alcotest.test_case "any_of_algo_hex rejects wrong length" `Quick
109
-
any_of_algo_hex_rejects_wrong_length;
109
+
algo_hex_wrong_length;
110
110
Alcotest.test_case "any_of_bytes wrong length" `Quick
111
111
any_of_bytes_wrong_length;
112
112
] )
+1
test/test_helpers.mli
+1
test/test_helpers.mli
+2
-2
test/test_pds_interop.ml
+2
-2
test/test_pds_interop.ml
···
448
448
| Some h -> Alcotest.(check bool) "dev head" true (Irmin.Hash.equal h h2)
449
449
| None -> Alcotest.fail "dev head missing"
450
450
451
-
let test_pds_store_branches_survive_reopen () =
451
+
let test_pds_branches_survive_reopen () =
452
452
with_temp_dir @@ fun path ->
453
453
(* Session 1: create branches *)
454
454
Eio.Switch.run (fun sw ->
···
497
497
Alcotest.test_case "multiple branches" `Quick
498
498
test_pds_store_multiple_branches;
499
499
Alcotest.test_case "branches survive reopen" `Quick
500
-
test_pds_store_branches_survive_reopen;
500
+
test_pds_branches_survive_reopen;
501
501
] )
+1
test/test_store.mli
+1
test/test_store.mli
+14
-9
test/test_stores.ml
+14
-9
test/test_stores.ml
···
1
1
(** Backend configs for the generic store test suite. *)
2
2
3
+
let cleanup_path path =
4
+
try Test_helpers.rm_rf path with Eio.Io _ | Sys_error _ -> ()
5
+
6
+
let run_git f =
7
+
Eio_main.run @@ fun env ->
8
+
Eio.Switch.run @@ fun sw ->
9
+
let fs = Eio.Stdenv.fs env in
10
+
let name = Fmt.str "/tmp/irmin-test-git-%d" (Random.int 1_000_000) in
11
+
let path = Eio.Path.(fs / name) in
12
+
Fun.protect
13
+
~finally:(fun () -> cleanup_path path)
14
+
(fun () -> f (Irmin_git.init ~sw ~fs ~path:(Fpath.v name)))
15
+
3
16
let git : Irmin_git.t Generic_store.config =
4
-
Generic_store.make ~name:"git" ~run:(fun f ->
5
-
Eio_main.run @@ fun env ->
6
-
Eio.Switch.run @@ fun sw ->
7
-
let fs = Eio.Stdenv.fs env in
8
-
let name = Fmt.str "/tmp/irmin-test-git-%d" (Random.int 1_000_000) in
9
-
let path = Eio.Path.(fs / name) in
10
-
Fun.protect
11
-
~finally:(fun () -> try Test_helpers.rm_rf path with _ -> ())
12
-
(fun () -> f (Irmin_git.init ~sw ~fs ~path:(Fpath.v name))))
17
+
Generic_store.make ~name:"git" ~run:run_git
13
18
14
19
let suites = [ Generic_store.suite git ]
+20
-20
test/test_sync.ml
+20
-20
test/test_sync.ml
···
18
18
19
19
let set_head d branch hash = d.heads <- (branch, hash) :: d.heads
20
20
let has d h = Hashtbl.mem d.blocks h
21
-
let get d h = Hashtbl.find_opt d.blocks h
21
+
let find d h = Hashtbl.find_opt d.blocks h
22
22
23
23
let kids d h =
24
24
match Hashtbl.find_opt d.children h with Some l -> l | None -> []
25
25
26
-
let get_ancestors d roots n =
26
+
let ancestors d roots n =
27
27
let visited = Hashtbl.create 16 in
28
28
let result = ref [] in
29
29
let queue = Queue.create () in
···
88
88
Irmin.Sync.merkle_diff
89
89
~local_has:(fun _ -> false)
90
90
~remote_get:(fun h ->
91
-
match get server h with
91
+
match find server h with
92
92
| Some data -> Some (kids server h, data)
93
93
| None -> None)
94
94
"c"
···
110
110
Irmin.Sync.merkle_diff
111
111
~local_has:(fun h -> h = "a" || h = "b")
112
112
~remote_get:(fun h ->
113
-
match get server h with
113
+
match find server h with
114
114
| Some data -> Some (kids server h, data)
115
115
| None -> None)
116
116
"c"
···
134
134
let send msg =
135
135
incr round;
136
136
let resp =
137
-
Irmin.Sync.Slice_sync.handle ~heads:[ "c" ] ~get_block:(get server)
137
+
Irmin.Sync.Slice_sync.handle ~heads:[ "c" ] ~get_block:(find server)
138
138
~get_children:(kids server) ~to_string:Fun.id msg
139
139
in
140
140
Queue.push resp responses
141
141
in
142
142
Irmin.Sync.Slice_sync.pull ~heads:[] ~to_string:Fun.id
143
-
~get_ancestors:(get_ancestors client) ~apply_block:(apply client) ~send
143
+
~get_ancestors:(ancestors client) ~apply_block:(apply client) ~send
144
144
~receive:(fun () -> Queue.pop responses);
145
145
Alcotest.(check bool) "has a" true (has client "a");
146
146
Alcotest.(check bool) "has b" true (has client "b");
147
147
Alcotest.(check bool) "has c" true (has client "c");
148
-
Alcotest.(check string) "data-a" "data-a" (Option.get (get client "a"));
148
+
Alcotest.(check string) "data-a" "data-a" (Option.get (find client "a"));
149
149
Alcotest.(check bool) "converges" true (!round <= 3)
150
150
151
151
let slice_partial_overlap () =
···
166
166
let responses = Queue.create () in
167
167
let send msg =
168
168
let resp =
169
-
Irmin.Sync.Slice_sync.handle ~heads:[ "d" ] ~get_block:(get server)
169
+
Irmin.Sync.Slice_sync.handle ~heads:[ "d" ] ~get_block:(find server)
170
170
~get_children:(kids server) ~to_string:Fun.id msg
171
171
in
172
172
Queue.push resp responses
173
173
in
174
174
Irmin.Sync.Slice_sync.pull ~heads:[ "b" ] ~to_string:Fun.id
175
-
~get_ancestors:(get_ancestors client) ~apply_block:(apply client) ~send
175
+
~get_ancestors:(ancestors client) ~apply_block:(apply client) ~send
176
176
~receive:(fun () -> Queue.pop responses);
177
177
Alcotest.(check bool) "has c" true (has client "c");
178
178
Alcotest.(check bool) "has d" true (has client "d");
179
-
Alcotest.(check string) "data-d" "data-d" (Option.get (get client "d"))
179
+
Alcotest.(check string) "data-d" "data-d" (Option.get (find client "d"))
180
180
181
181
let slice_already_synced () =
182
182
let d = dag () in
···
190
190
let send msg =
191
191
incr rounds;
192
192
let resp =
193
-
Irmin.Sync.Slice_sync.handle ~heads:[ "b" ] ~get_block:(get d)
193
+
Irmin.Sync.Slice_sync.handle ~heads:[ "b" ] ~get_block:(find d)
194
194
~get_children:(kids d) ~to_string:Fun.id msg
195
195
in
196
196
Queue.push resp responses
197
197
in
198
198
Irmin.Sync.Slice_sync.pull ~heads:[ "b" ] ~to_string:Fun.id
199
-
~get_ancestors:(get_ancestors d) ~apply_block:(apply d) ~send
199
+
~get_ancestors:(ancestors d) ~apply_block:(apply d) ~send
200
200
~receive:(fun () -> Queue.pop responses);
201
201
(* Should complete in 1 round — the Bloom catches everything *)
202
202
Alcotest.(check bool) "at most 2 rounds" true (!rounds <= 2)
···
216
216
let responses = Queue.create () in
217
217
let send msg =
218
218
let resp =
219
-
Irmin.Sync.Slice_sync.handle ~heads:[ "merge" ] ~get_block:(get server)
219
+
Irmin.Sync.Slice_sync.handle ~heads:[ "merge" ] ~get_block:(find server)
220
220
~get_children:(kids server) ~to_string:Fun.id msg
221
221
in
222
222
Queue.push resp responses
223
223
in
224
224
Irmin.Sync.Slice_sync.pull ~heads:[ "root" ] ~to_string:Fun.id
225
-
~get_ancestors:(get_ancestors client) ~apply_block:(apply client) ~send
225
+
~get_ancestors:(ancestors client) ~apply_block:(apply client) ~send
226
226
~receive:(fun () -> Queue.pop responses);
227
227
Alcotest.(check bool) "has merge" true (has client "merge");
228
228
Alcotest.(check bool) "has left" true (has client "left");
···
245
245
let send msg =
246
246
st.rounds <- st.rounds + 1;
247
247
let resp =
248
-
Irmin.Sync.Slice_sync.handle ~heads:server_heads ~get_block:(get server)
248
+
Irmin.Sync.Slice_sync.handle ~heads:server_heads ~get_block:(find server)
249
249
~get_children:(kids server) ~to_string:Fun.id msg
250
250
in
251
251
List.iter
···
256
256
Queue.push resp responses
257
257
in
258
258
Irmin.Sync.Slice_sync.pull ~heads:(List.map snd client.heads)
259
-
~to_string:Fun.id ~get_ancestors:(get_ancestors client)
259
+
~to_string:Fun.id ~get_ancestors:(ancestors client)
260
260
~apply_block:(apply client) ~send ~receive:(fun () -> Queue.pop responses);
261
261
st
262
262
···
414
414
in
415
415
let client = dag () in
416
416
let _ = sync_with_stats ~client ~server ~server_heads:[ "y" ] in
417
-
Alcotest.(check string) "x data" "payload-x" (Option.get (get client "x"));
418
-
Alcotest.(check string) "y data" "payload-y" (Option.get (get client "y"))
417
+
Alcotest.(check string) "x data" "payload-x" (Option.get (find client "x"));
418
+
Alcotest.(check string) "y data" "payload-y" (Option.get (find client "y"))
419
419
420
420
(** Server returns blocks for hash the client didn't ask about — ignored. *)
421
421
let server_extra_blocks_harmless () =
···
430
430
client.heads <- [ ("main", "a") ];
431
431
let _ = sync_with_stats ~client ~server ~server_heads:[ "b" ] in
432
432
(* Client has both, data is correct *)
433
-
Alcotest.(check string) "a intact" "data-a" (Option.get (get client "a"));
434
-
Alcotest.(check string) "b received" "data-b" (Option.get (get client "b"))
433
+
Alcotest.(check string) "a intact" "data-a" (Option.get (find client "a"));
434
+
Alcotest.(check string) "b received" "data-b" (Option.get (find client "b"))
435
435
436
436
(* ===== Bloom tests ===== *)
437
437