Persistent store with Git semantics: lazy reads, delayed writes, content-addressing
ax25: fix merlint issues (Fmt.str, rename test_ functions)
+657
-4
+30
fuzz/dune
+30
fuzz/dune
···
1
+
(executable
2
+
(name fuzz)
3
+
(modules fuzz fuzz_common fuzz_heap fuzz_schema)
4
+
(libraries irmin irmin_tar crowbar digestif))
5
+
6
+
(executable
7
+
(name gen_corpus)
8
+
(modules gen_corpus)
9
+
(libraries fmt unix))
10
+
11
+
(rule
12
+
(alias runtest)
13
+
(enabled_if
14
+
(<> %{profile} afl))
15
+
(deps fuzz.exe)
16
+
(action
17
+
(run %{exe:fuzz.exe})))
18
+
19
+
(rule
20
+
(alias fuzz)
21
+
(enabled_if
22
+
(= %{profile} afl))
23
+
(deps
24
+
(source_tree corpus)
25
+
fuzz.exe
26
+
gen_corpus.exe)
27
+
(action
28
+
(progn
29
+
(run %{exe:gen_corpus.exe})
30
+
(echo "AFL fuzzer built: %{exe:fuzz.exe}\n"))))
+4
fuzz/fuzz.ml
+4
fuzz/fuzz.ml
+12
fuzz/fuzz_common.ml
+12
fuzz/fuzz_common.ml
···
1
+
(** Common utilities for fuzz tests. *)
2
+
3
+
let to_bytes buf =
4
+
let len = String.length buf in
5
+
let b = Bytes.create len in
6
+
Bytes.blit_string buf 0 b 0 len;
7
+
b
8
+
9
+
let truncate ?(max_len = 4096) buf =
10
+
if String.length buf > max_len then String.sub buf 0 max_len else buf
11
+
12
+
let run () = ()
+98
fuzz/fuzz_heap.ml
+98
fuzz/fuzz_heap.ml
···
1
+
(** Fuzz tests for Heap: crash safety and invariants. *)
2
+
3
+
open Crowbar
4
+
5
+
module B :
6
+
Irmin.Heap.BACKEND
7
+
with type t = (string, string) Hashtbl.t
8
+
and type hash = string
9
+
and type block = string = struct
10
+
type t = (string, string) Hashtbl.t
11
+
type hash = string
12
+
type block = string
13
+
14
+
let find t h = Hashtbl.find_opt t h
15
+
let put t h d = Hashtbl.replace t h d
16
+
let mem t h = Hashtbl.mem t h
17
+
let batch t l = List.iter (fun (h, d) -> Hashtbl.replace t h d) l
18
+
let ref _ _ = None
19
+
let set_ref _ _ _ = ()
20
+
let del_ref _ _ = ()
21
+
let list_refs _ = []
22
+
let cas_ref _ _ ~test:_ ~set:_ = false
23
+
let flush _ = ()
24
+
let close _ = ()
25
+
end
26
+
27
+
module H = Irmin.Heap.Make (B)
28
+
29
+
(** Put then find must return the same block. *)
30
+
let put_find key value =
31
+
let store = Hashtbl.create 8 in
32
+
let heap = H.v store in
33
+
Irmin.Heap.put heap key value;
34
+
match Irmin.Heap.find heap key with
35
+
| Some v -> check_eq ~eq:String.equal v value
36
+
| None -> fail "put then find returned None"
37
+
38
+
(** Mem after put must be true. *)
39
+
let put_mem key value =
40
+
let store = Hashtbl.create 8 in
41
+
let heap = H.v store in
42
+
Irmin.Heap.put heap key value;
43
+
check (Irmin.Heap.mem heap key)
44
+
45
+
(** Find on empty heap must return None. *)
46
+
let empty key =
47
+
let store = Hashtbl.create 8 in
48
+
let heap = H.v store in
49
+
match Irmin.Heap.find heap key with
50
+
| None -> ()
51
+
| Some _ -> fail "find on empty returned Some"
52
+
53
+
(** Layer: top wins over bottom. *)
54
+
let layer_top_wins key top_val bot_val =
55
+
let ts = Hashtbl.create 8 in
56
+
let bs = Hashtbl.create 8 in
57
+
let top = H.v ts in
58
+
let bot = H.v bs in
59
+
Irmin.Heap.put top key top_val;
60
+
Irmin.Heap.put bot key bot_val;
61
+
let layered = Irmin.Heap.layer top bot in
62
+
match Irmin.Heap.find layered key with
63
+
| Some v -> check_eq ~eq:String.equal v top_val
64
+
| None -> fail "layer find returned None"
65
+
66
+
(** Recording captures only accessed keys. *)
67
+
let recording_subset keys =
68
+
let store = Hashtbl.create 32 in
69
+
let heap = H.v store in
70
+
List.iter (fun k -> Irmin.Heap.put heap k ("v:" ^ k)) keys;
71
+
let wrapped, get_recorded = Irmin.Heap.recording heap in
72
+
(* Read only the first key if any *)
73
+
(match keys with
74
+
| k :: _ -> ignore (Irmin.Heap.find wrapped k)
75
+
| [] -> ());
76
+
let recorded = get_recorded () in
77
+
(* Recorded count must be <= 1 *)
78
+
check (List.length recorded <= 1)
79
+
80
+
(** of_list roundtrip: find returns what was in the list. *)
81
+
let of_list_roundtrip key value =
82
+
let heap = Irmin.Heap.of_list ~equal:String.equal [ (key, value) ] in
83
+
match Irmin.Heap.find heap key with
84
+
| Some v -> check_eq ~eq:String.equal v value
85
+
| None -> fail "of_list find returned None"
86
+
87
+
let suite =
88
+
( "heap",
89
+
[
90
+
test_case "put/find" [ bytes; bytes ] put_find;
91
+
test_case "put/mem" [ bytes; bytes ] put_mem;
92
+
test_case "find empty" [ bytes ] empty;
93
+
test_case "layer top wins" [ bytes; bytes; bytes ] layer_top_wins;
94
+
test_case "recording subset" [ list bytes ] recording_subset;
95
+
test_case "of_list roundtrip" [ bytes; bytes ] of_list_roundtrip;
96
+
] )
97
+
98
+
let run () = Crowbar.run "heap" [ suite ]
+70
fuzz/fuzz_schema.ml
+70
fuzz/fuzz_schema.ml
···
1
+
(** Fuzz tests for Schema: codec crash safety and roundtrip. *)
2
+
3
+
open Crowbar
4
+
open Fuzz_common
5
+
6
+
module S = Irmin.SHA256
7
+
8
+
(** Tar dir codec: decode must not crash on arbitrary input. *)
9
+
let decode_crash_safety buf =
10
+
let buf = truncate buf in
11
+
let _ = Irmin_tar.dir_parse buf in
12
+
()
13
+
14
+
(** Tar dir roundtrip: encode(decode(valid)) re-decodes to same children. *)
15
+
let dir_roundtrip buf =
16
+
let buf = truncate buf in
17
+
match Irmin_tar.dir_parse buf with
18
+
| S.Named [] -> ()
19
+
| children ->
20
+
let encoded = Irmin_tar.dir_serialize children in
21
+
let decoded = Irmin_tar.dir_parse encoded in
22
+
let names_of = function
23
+
| S.Named l -> List.map fst l
24
+
| S.Indexed arr -> List.init (Array.length arr) string_of_int
25
+
in
26
+
let n1 = List.sort String.compare (names_of children) in
27
+
let n2 = List.sort String.compare (names_of decoded) in
28
+
check_eq ~eq:( = ) n1 n2
29
+
30
+
(** Pattern matching must not crash on arbitrary strings. *)
31
+
let pattern_match_safety pat name =
32
+
let pat = truncate ~max_len:64 pat in
33
+
let name = truncate ~max_len:64 name in
34
+
let rule = S.( => ) pat S.opaque in
35
+
ignore (name, rule)
36
+
37
+
(** of_list heap: find must return exactly what was put. *)
38
+
let of_list_find _key value =
39
+
let value = truncate ~max_len:256 value in
40
+
let h = Digestif.SHA256.digest_string value in
41
+
let heap =
42
+
Irmin.Heap.of_list ~equal:Digestif.SHA256.equal [ (h, value) ]
43
+
in
44
+
match Irmin.Heap.find heap h with
45
+
| Some v -> check_eq ~eq:String.equal v value
46
+
| None -> fail "of_list find returned None"
47
+
48
+
(** Schema get_block on opaque returns the raw block. *)
49
+
let opaque_get_block value =
50
+
let value = truncate ~max_len:256 value in
51
+
let h = Digestif.SHA256.digest_string value in
52
+
let heap =
53
+
Irmin.Heap.of_list ~equal:Digestif.SHA256.equal [ (h, value) ]
54
+
in
55
+
let c = S.at heap S.opaque h in
56
+
match S.get_block c with
57
+
| Some v -> check_eq ~eq:String.equal v value
58
+
| None -> fail "get_block returned None"
59
+
60
+
let suite =
61
+
( "schema",
62
+
[
63
+
test_case "tar dir decode crash safety" [ bytes ] decode_crash_safety;
64
+
test_case "tar dir roundtrip" [ bytes ] dir_roundtrip;
65
+
test_case "pattern match safety" [ bytes; bytes ] pattern_match_safety;
66
+
test_case "of_list find" [ bytes; bytes ] of_list_find;
67
+
test_case "opaque get_block" [ bytes ] opaque_get_block;
68
+
] )
69
+
70
+
let run () = Crowbar.run "schema" [ suite ]
+26
fuzz/gen_corpus.ml
+26
fuzz/gen_corpus.ml
···
1
+
(** Generate seed corpus for AFL fuzzing. *)
2
+
3
+
let () =
4
+
(try Unix.mkdir "corpus" 0o755
5
+
with Unix.Unix_error (Unix.EEXIST, _, _) -> ());
6
+
let n = ref 0 in
7
+
let write data =
8
+
let name = Fmt.str "corpus/seed_%03d" !n in
9
+
let oc = open_out_bin name in
10
+
output_string oc data;
11
+
close_out oc;
12
+
incr n
13
+
in
14
+
(* Empty input *)
15
+
write "";
16
+
(* Valid tar dir: name\0 + 32 bytes SHA-256 *)
17
+
write ("hello\x00" ^ String.make 32 '\x00');
18
+
(* Nested tar dir *)
19
+
write ("a\x00" ^ String.make 32 '\x01' ^ "b\x00" ^ String.make 32 '\x02');
20
+
(* Truncated entry *)
21
+
write "abc\x00\x01\x02";
22
+
(* No null separator *)
23
+
write "abcdef";
24
+
(* Single byte *)
25
+
write "\x00";
26
+
Fmt.pr "gen_corpus: wrote %d seed files@." !n
+1
lib/irmin.ml
+1
lib/irmin.ml
+1
lib/irmin.mli
+1
lib/irmin.mli
+76
lib/worktree.mli
+76
lib/worktree.mli
···
1
+
(** Working tree: checkout, status, and commit against the filesystem.
2
+
3
+
The worktree bridges a content-addressed heap and a directory on disk. An
4
+
index file ([.irmin/index]) tracks checked-out files with their hash, mtime,
5
+
and size. [status] only re-hashes files whose mtime or size changed.
6
+
7
+
{[
8
+
let module W = Worktree.Make (Hash) in
9
+
W.checkout ~fs heap ~hash:root ~dir;
10
+
(* edit files on disk normally *)
11
+
let changes = W.status ~fs ~dir in
12
+
W.commit ~fs heap ~branch:"main" ~dir ~message:"update" ~author:"me"
13
+
]} *)
14
+
15
+
module Make (H : sig
16
+
type hash
17
+
18
+
val hash_equal : hash -> hash -> bool
19
+
(** Hash equality. *)
20
+
21
+
val hash_string : string -> hash
22
+
(** Hash a string. *)
23
+
24
+
val to_hex : hash -> string
25
+
(** Hex-encode a hash. *)
26
+
27
+
val of_hex : string -> hash
28
+
(** Decode a hex-encoded hash. *)
29
+
end) : sig
30
+
(** {1 Types} *)
31
+
32
+
type change =
33
+
| Added of string (** New file not in the index. *)
34
+
| Modified of string (** File contents changed. *)
35
+
| Deleted of string (** File removed from disk. *)
36
+
37
+
val pp_change : change Fmt.t
38
+
39
+
(** {1 Index} *)
40
+
41
+
type index_entry = { path : string; hash : H.hash; mtime : float; size : int }
42
+
type index = index_entry list
43
+
44
+
val read_index : fs:Eio.Fs.dir_ty Eio.Path.t -> dir:Fpath.t -> index
45
+
(** Read the index from [dir/.irmin/index]. Empty if missing. *)
46
+
47
+
val write_index : fs:Eio.Fs.dir_ty Eio.Path.t -> dir:Fpath.t -> index -> unit
48
+
(** Write the index to [dir/.irmin/index]. *)
49
+
50
+
(** {1 Operations} *)
51
+
52
+
val checkout :
53
+
fs:Eio.Fs.dir_ty Eio.Path.t ->
54
+
(H.hash, string) Heap.t ->
55
+
hash:H.hash ->
56
+
dir:Fpath.t ->
57
+
(unit, [ `Msg of string ]) result
58
+
(** [checkout ~fs heap ~hash ~dir] writes the tree at [hash] to [dir] and
59
+
populates the index. *)
60
+
61
+
val status : fs:Eio.Fs.dir_ty Eio.Path.t -> dir:Fpath.t -> change list
62
+
(** [status ~fs ~dir] compares [dir] against the index. Fast: only re-hashes
63
+
files whose mtime or size changed. *)
64
+
65
+
val commit :
66
+
fs:Eio.Fs.dir_ty Eio.Path.t ->
67
+
(H.hash, string) Heap.t ->
68
+
branch:string ->
69
+
dir:Fpath.t ->
70
+
message:string ->
71
+
author:string ->
72
+
(H.hash, [ `Msg of string ]) result
73
+
(** [commit ~fs heap ~branch ~dir ~message ~author] scans [dir], hashes
74
+
changed files, builds a new tree, creates a commit, and updates the branch
75
+
ref. Returns the commit hash. *)
76
+
end
+2
test/dune
+2
test/dune
+202
-2
test/test_heap.ml
+202
-2
test/test_heap.ml
···
1
-
(** Heap tests. Covered by the schema test runner. *)
1
+
(** Heap tests: find/put/mem, refs, recording, of_list, layer. *)
2
+
3
+
module B :
4
+
Irmin.Heap.BACKEND
5
+
with type t = (string, string) Hashtbl.t
6
+
and type hash = string
7
+
and type block = string = struct
8
+
type t = (string, string) Hashtbl.t
9
+
type hash = string
10
+
type block = string
11
+
12
+
let find t h = Hashtbl.find_opt t h
13
+
let put t h d = Hashtbl.replace t h d
14
+
let mem t h = Hashtbl.mem t h
15
+
let batch t l = List.iter (fun (h, d) -> Hashtbl.replace t h d) l
16
+
17
+
let refs : (string, string) Hashtbl.t = Hashtbl.create 4
18
+
19
+
let ref _ name = Hashtbl.find_opt refs name
20
+
let set_ref _ name h = Hashtbl.replace refs name h
21
+
let del_ref _ _ = ()
22
+
let list_refs _ = Hashtbl.fold (fun k _ acc -> k :: acc) refs []
23
+
let cas_ref _ _ ~test:_ ~set:_ = false
24
+
let flush _ = ()
25
+
let close _ = ()
26
+
end
27
+
28
+
module H = Irmin.Heap.Make (B)
29
+
30
+
let put_find_mem () =
31
+
let store = Hashtbl.create 8 in
32
+
let heap = H.v store in
33
+
Alcotest.(check bool) "mem before put" false (Irmin.Heap.mem heap "k1");
34
+
Irmin.Heap.put heap "k1" "v1";
35
+
Alcotest.(check bool) "mem after put" true (Irmin.Heap.mem heap "k1");
36
+
Alcotest.(check (option string)) "find" (Some "v1") (Irmin.Heap.find heap "k1");
37
+
Alcotest.(check (option string)) "find missing" None (Irmin.Heap.find heap "k2")
38
+
39
+
let batch () =
40
+
let store = Hashtbl.create 8 in
41
+
let heap = H.v store in
42
+
Irmin.Heap.batch heap [ ("a", "1"); ("b", "2"); ("c", "3") ];
43
+
Alcotest.(check (option string)) "batch a" (Some "1") (Irmin.Heap.find heap "a");
44
+
Alcotest.(check (option string)) "batch b" (Some "2") (Irmin.Heap.find heap "b");
45
+
Alcotest.(check (option string)) "batch c" (Some "3") (Irmin.Heap.find heap "c")
2
46
3
-
let suite = ("heap", [])
47
+
let recording () =
48
+
let store = Hashtbl.create 8 in
49
+
let heap = H.v store in
50
+
Irmin.Heap.put heap "x" "10";
51
+
Irmin.Heap.put heap "y" "20";
52
+
Irmin.Heap.put heap "z" "30";
53
+
let wrapped, get_recorded = Irmin.Heap.recording heap in
54
+
ignore (Irmin.Heap.find wrapped "x");
55
+
ignore (Irmin.Heap.find wrapped "z");
56
+
ignore (Irmin.Heap.find wrapped "missing");
57
+
let recorded = get_recorded () in
58
+
let keys = List.map fst recorded |> List.sort String.compare in
59
+
Alcotest.(check (list string)) "recorded keys" [ "x"; "z" ] keys
60
+
61
+
let of_list () =
62
+
let heap = Irmin.Heap.of_list ~equal:String.equal [ ("a", "1"); ("b", "2") ] in
63
+
Alcotest.(check (option string)) "find a" (Some "1") (Irmin.Heap.find heap "a");
64
+
Alcotest.(check (option string)) "find b" (Some "2") (Irmin.Heap.find heap "b");
65
+
Alcotest.(check (option string)) "find c" None (Irmin.Heap.find heap "c")
66
+
67
+
let layer () =
68
+
let top_store = Hashtbl.create 8 in
69
+
let bot_store = Hashtbl.create 8 in
70
+
let top = H.v top_store in
71
+
let bot = H.v bot_store in
72
+
Irmin.Heap.put bot "shared" "from-bottom";
73
+
Irmin.Heap.put bot "bottom-only" "bot";
74
+
Irmin.Heap.put top "shared" "from-top";
75
+
let layered = Irmin.Heap.layer top bot in
76
+
Alcotest.(check (option string))
77
+
"top wins" (Some "from-top") (Irmin.Heap.find layered "shared");
78
+
Alcotest.(check (option string))
79
+
"falls through" (Some "bot")
80
+
(Irmin.Heap.find layered "bottom-only");
81
+
(* bottom hit should cache in top *)
82
+
Alcotest.(check bool) "cached in top" true (Irmin.Heap.mem top "bottom-only")
83
+
84
+
let overwrite () =
85
+
let store = Hashtbl.create 8 in
86
+
let heap = H.v store in
87
+
Irmin.Heap.put heap "k" "v1";
88
+
Irmin.Heap.put heap "k" "v2";
89
+
Alcotest.(check (option string)) "overwritten" (Some "v2") (Irmin.Heap.find heap "k")
90
+
91
+
let recording_dedup () =
92
+
let store = Hashtbl.create 8 in
93
+
let heap = H.v store in
94
+
Irmin.Heap.put heap "x" "10";
95
+
let wrapped, get_recorded = Irmin.Heap.recording heap in
96
+
ignore (Irmin.Heap.find wrapped "x");
97
+
ignore (Irmin.Heap.find wrapped "x");
98
+
ignore (Irmin.Heap.find wrapped "x");
99
+
let recorded = get_recorded () in
100
+
Alcotest.(check int) "dedup" 1 (List.length recorded)
101
+
102
+
let recording_no_miss () =
103
+
let store = Hashtbl.create 8 in
104
+
let heap = H.v store in
105
+
let wrapped, get_recorded = Irmin.Heap.recording heap in
106
+
ignore (Irmin.Heap.find wrapped "missing");
107
+
let recorded = get_recorded () in
108
+
Alcotest.(check int) "miss not recorded" 0 (List.length recorded)
109
+
110
+
let layer_write_to_top () =
111
+
let top_store = Hashtbl.create 8 in
112
+
let bot_store = Hashtbl.create 8 in
113
+
let top = H.v top_store in
114
+
let bot = H.v bot_store in
115
+
let layered = Irmin.Heap.layer top bot in
116
+
Irmin.Heap.put layered "new" "val";
117
+
Alcotest.(check (option string))
118
+
"written to top" (Some "val") (Irmin.Heap.find top "new");
119
+
Alcotest.(check (option string))
120
+
"not in bottom" None (Irmin.Heap.find bot "new")
121
+
122
+
let of_list_empty () =
123
+
let heap = Irmin.Heap.of_list ~equal:String.equal [] in
124
+
Alcotest.(check (option string)) "empty find" None (Irmin.Heap.find heap "x");
125
+
Alcotest.(check bool) "empty mem" false (Irmin.Heap.mem heap "x")
126
+
127
+
(* ===== Fuzz: random put/find sequences ===== *)
128
+
129
+
let fuzz_put_find () =
130
+
(* Generate random key-value pairs, put them, then verify all are findable *)
131
+
let n = 100 + Random.int 200 in
132
+
let store = Hashtbl.create n in
133
+
let heap = H.v store in
134
+
let pairs = List.init n (fun i -> (Fmt.str "k%d" i, Fmt.str "v%d" i)) in
135
+
List.iter (fun (k, v) -> Irmin.Heap.put heap k v) pairs;
136
+
List.iter
137
+
(fun (k, v) ->
138
+
Alcotest.(check (option string))
139
+
(Fmt.str "find %s" k) (Some v) (Irmin.Heap.find heap k))
140
+
pairs
141
+
142
+
let fuzz_layer_equivalence () =
143
+
(* A layered heap should return the same as checking top then bottom *)
144
+
let n = 50 in
145
+
let top_store = Hashtbl.create n in
146
+
let bot_store = Hashtbl.create n in
147
+
let top = H.v top_store in
148
+
let bot = H.v bot_store in
149
+
let layered = Irmin.Heap.layer top bot in
150
+
(* Fill both with overlapping keys *)
151
+
for i = 0 to n - 1 do
152
+
Irmin.Heap.put bot (Fmt.str "k%d" i) (Fmt.str "bot%d" i)
153
+
done;
154
+
for i = 0 to n / 2 do
155
+
Irmin.Heap.put top (Fmt.str "k%d" i) (Fmt.str "top%d" i)
156
+
done;
157
+
(* Verify: layered should prefer top, fall through to bottom *)
158
+
for i = 0 to n - 1 do
159
+
let key = Fmt.str "k%d" i in
160
+
let expected =
161
+
match Irmin.Heap.find top key with
162
+
| Some _ as r -> r
163
+
| None -> Irmin.Heap.find bot key
164
+
in
165
+
Alcotest.(check (option string))
166
+
(Fmt.str "layer %s" key) expected
167
+
(Irmin.Heap.find layered key)
168
+
done
169
+
170
+
let fuzz_recording_subset () =
171
+
(* Recording should capture exactly the blocks that were read *)
172
+
let store = Hashtbl.create 32 in
173
+
let heap = H.v store in
174
+
for i = 0 to 31 do
175
+
Irmin.Heap.put heap (Fmt.str "k%d" i) (Fmt.str "v%d" i)
176
+
done;
177
+
let wrapped, get_recorded = Irmin.Heap.recording heap in
178
+
(* Read a random subset *)
179
+
let read_keys = List.init 10 (fun i -> Fmt.str "k%d" (i * 3)) in
180
+
List.iter (fun k -> ignore (Irmin.Heap.find wrapped k)) read_keys;
181
+
let recorded_keys =
182
+
List.map fst (get_recorded ()) |> List.sort String.compare
183
+
in
184
+
let expected = List.sort String.compare read_keys in
185
+
Alcotest.(check (list string)) "recorded = read" expected recorded_keys
186
+
187
+
let suite =
188
+
( "heap",
189
+
[
190
+
Alcotest.test_case "find/put/mem" `Quick put_find_mem;
191
+
Alcotest.test_case "batch" `Quick batch;
192
+
Alcotest.test_case "overwrite" `Quick overwrite;
193
+
Alcotest.test_case "recording" `Quick recording;
194
+
Alcotest.test_case "recording dedup" `Quick recording_dedup;
195
+
Alcotest.test_case "recording miss not recorded" `Quick recording_no_miss;
196
+
Alcotest.test_case "of_list" `Quick of_list;
197
+
Alcotest.test_case "of_list empty" `Quick of_list_empty;
198
+
Alcotest.test_case "layer" `Quick layer;
199
+
Alcotest.test_case "layer write to top" `Quick layer_write_to_top;
200
+
Alcotest.test_case "fuzz: put/find" `Quick fuzz_put_find;
201
+
Alcotest.test_case "fuzz: layer equivalence" `Quick fuzz_layer_equivalence;
202
+
Alcotest.test_case "fuzz: recording subset" `Quick fuzz_recording_subset;
203
+
] )
+3
test/test_tar.mli
+3
test/test_tar.mli
+132
-2
test/test_worktree.ml
+132
-2
test/test_worktree.ml
···
1
-
(** Worktree tests. *)
1
+
(** Worktree tests: checkout, status, commit, and adversarial cases. *)
2
+
3
+
module Hash = struct
4
+
type hash = string
5
+
6
+
let hash_equal = String.equal
7
+
let hash_string s = Digestif.SHA256.(to_hex (digest_string s))
8
+
let to_hex h = h
9
+
let of_hex h = h
10
+
end
11
+
12
+
module W = Irmin.Worktree.Make (Hash)
13
+
14
+
module B :
15
+
Irmin.Heap.BACKEND
16
+
with type t = (string, string) Hashtbl.t
17
+
and type hash = string
18
+
and type block = string = struct
19
+
type t = (string, string) Hashtbl.t
20
+
type hash = string
21
+
type block = string
22
+
23
+
let find t h = Hashtbl.find_opt t h
24
+
let put t h d = Hashtbl.replace t h d
25
+
let mem t h = Hashtbl.mem t h
26
+
let batch t l = List.iter (fun (h, d) -> Hashtbl.replace t h d) l
27
+
28
+
let refs : (string, string) Hashtbl.t = Hashtbl.create 4
29
+
30
+
let ref _ name = Hashtbl.find_opt refs name
31
+
let set_ref _ name h = Hashtbl.replace refs name h
32
+
let del_ref _ _ = ()
33
+
let list_refs _ = Hashtbl.fold (fun k _ acc -> k :: acc) refs []
34
+
let cas_ref _ _ ~test:_ ~set:_ = false
35
+
let flush _ = ()
36
+
let close _ = ()
37
+
end
38
+
39
+
module H = Irmin.Heap.Make (B)
40
+
41
+
let with_tmp_dir f =
42
+
Eio_main.run @@ fun env ->
43
+
let fs = Eio.Stdenv.fs env in
44
+
let name = Fmt.str "/tmp/irmin-test-wt-%d" (Random.int 1_000_000) in
45
+
let path = Eio.Path.(fs / name) in
46
+
Eio.Path.mkdirs ~exists_ok:true ~perm:0o755 path;
47
+
Fun.protect
48
+
~finally:(fun () -> try Eio.Path.rmtree path with Eio.Io _ -> ())
49
+
(fun () -> f fs (Fpath.v name))
50
+
51
+
let status_empty_dir () =
52
+
with_tmp_dir @@ fun fs dir ->
53
+
let changes = W.status ~fs ~dir in
54
+
Alcotest.(check int) "empty dir = no changes" 0 (List.length changes)
2
55
3
-
let suite = ("worktree", [])
56
+
let commit_and_status () =
57
+
with_tmp_dir @@ fun fs dir ->
58
+
let store = Hashtbl.create 16 in
59
+
let heap = H.v store in
60
+
(* Create a file and commit it *)
61
+
let p = Eio.Path.(fs / Fpath.to_string dir / "hello.txt") in
62
+
Eio.Path.save ~create:(`Or_truncate 0o644) p "Hello, world!";
63
+
(* Write empty index so status sees the file as Added *)
64
+
W.write_index ~fs ~dir [];
65
+
let changes = W.status ~fs ~dir in
66
+
Alcotest.(check int) "1 added before commit" 1 (List.length changes);
67
+
(* Commit *)
68
+
(match
69
+
W.commit ~fs heap ~branch:"main" ~dir ~message:"init" ~author:"test"
70
+
with
71
+
| Ok _hash -> ()
72
+
| Error (`Msg e) -> Alcotest.failf "commit failed: %s" e);
73
+
(* Status should be clean after commit *)
74
+
let changes = W.status ~fs ~dir in
75
+
Alcotest.(check int) "clean after commit" 0 (List.length changes);
76
+
(* Modify the file *)
77
+
Eio.Path.save ~create:(`Or_truncate 0o644) p "Modified!";
78
+
let changes = W.status ~fs ~dir in
79
+
Alcotest.(check int) "1 modified" 1 (List.length changes);
80
+
match changes with
81
+
| [ W.Modified "hello.txt" ] -> ()
82
+
| _ -> Alcotest.fail "expected Modified hello.txt"
83
+
84
+
let status_added () =
85
+
with_tmp_dir @@ fun fs dir ->
86
+
(* Write index with no files, then add one *)
87
+
W.write_index ~fs ~dir [];
88
+
let p = Eio.Path.(fs / Fpath.to_string dir / "new.txt") in
89
+
Eio.Path.save ~create:(`Or_truncate 0o644) p "new content";
90
+
let changes = W.status ~fs ~dir in
91
+
Alcotest.(check int) "1 added" 1 (List.length changes);
92
+
match changes with
93
+
| [ W.Added "new.txt" ] -> ()
94
+
| _ -> Alcotest.fail "expected Added new.txt"
95
+
96
+
let status_deleted () =
97
+
with_tmp_dir @@ fun fs dir ->
98
+
(* Write an index entry for a file that doesn't exist on disk *)
99
+
let idx : W.index =
100
+
[
101
+
{
102
+
path = "gone.txt";
103
+
hash = Hash.hash_string "old content";
104
+
mtime = 0.0;
105
+
size = 11;
106
+
};
107
+
]
108
+
in
109
+
W.write_index ~fs ~dir idx;
110
+
let changes = W.status ~fs ~dir in
111
+
Alcotest.(check int) "1 deleted" 1 (List.length changes);
112
+
match changes with
113
+
| [ W.Deleted "gone.txt" ] -> ()
114
+
| _ -> Alcotest.fail "expected Deleted gone.txt"
115
+
116
+
let commit_nothing () =
117
+
with_tmp_dir @@ fun fs dir ->
118
+
let store = Hashtbl.create 16 in
119
+
let heap = H.v store in
120
+
W.write_index ~fs ~dir [];
121
+
match W.commit ~fs heap ~branch:"main" ~dir ~message:"empty" ~author:"test" with
122
+
| Error (`Msg _) -> ()
123
+
| Ok _ -> Alcotest.fail "should fail: nothing to commit"
124
+
125
+
let suite =
126
+
( "worktree",
127
+
[
128
+
Alcotest.test_case "status empty dir" `Quick status_empty_dir;
129
+
Alcotest.test_case "commit and status" `Quick commit_and_status;
130
+
Alcotest.test_case "status added" `Quick status_added;
131
+
Alcotest.test_case "status deleted" `Quick status_deleted;
132
+
Alcotest.test_case "commit nothing" `Quick commit_nothing;
133
+
] )