gazagnaire.org
Git object storage and pack files for Eio
1(** Fuzz tests for Git tree operations.
2
3 Uses a model-based approach: a [Map.Make(String)] acts as the reference
4 implementation. A random sequence of [Add] and [Remove] operations is
5 applied to both the real [Git.Tree.t] and the model; invariants are checked
6 after every step. *)
7
8open Crowbar
9
10(* A small name pool maximises repeated-name collisions, exercising the
11 deduplication path that was missing before the [add] fix. *)
12let small_names = [| "a"; "b"; "c"; "d"; "e"; "ab"; "foo"; "bar" |]
13
14let sanitize_name s =
15 if String.length s = 0 then "x"
16 else
17 let s = String.sub s 0 (min 32 (String.length s)) in
18 String.map (fun c -> if Char.code c = 0 then 'x' else c) s
19
20let gen_name =
21 choose
22 [
23 map [ uint8 ] (fun i -> small_names.(i mod Array.length small_names));
24 map [ bytes ] (fun s -> sanitize_name s);
25 ]
26
27let gen_hash =
28 map [ bytes ] (fun s ->
29 let len = String.length s in
30 let raw =
31 if len >= 20 then String.sub s 0 20
32 else s ^ String.make (20 - len) '\x00'
33 in
34 Git.Hash.of_raw_string raw)
35
36type op = Add of string * Git.Hash.t | Remove of string
37
38let gen_op =
39 choose
40 [
41 map [ gen_name; gen_hash ] (fun name hash -> Add (name, hash));
42 map [ gen_name ] (fun name -> Remove name);
43 ]
44
45(* Reference model *)
46module Ref = Map.Make (String)
47
48let apply_op_ref ref = function
49 | Add (name, hash) -> Ref.add name hash ref
50 | Remove name -> Ref.remove name ref
51
52let apply_op_tree tree = function
53 | Add (name, hash) ->
54 Git.Tree.add (Git.Tree.entry ~perm:`Normal ~name hash) tree
55 | Remove name -> Git.Tree.remove ~name tree
56
57let check_invariants tree ref_map =
58 let entries = Git.Tree.to_list tree in
59 let names = List.map (fun (e : Git.Tree.entry) -> e.name) entries in
60 (* No duplicate names *)
61 let unique = List.sort_uniq String.compare names in
62 if List.length names <> List.length unique then
63 fail "duplicate names in to_list";
64 (* Names are sorted *)
65 if names <> List.sort String.compare names then fail "entries not sorted";
66 (* Size matches model *)
67 if List.length entries <> Ref.cardinal ref_map then
68 fail
69 (Fmt.str "size mismatch: tree=%d model=%d" (List.length entries)
70 (Ref.cardinal ref_map));
71 (* Every tree entry agrees with model *)
72 List.iter
73 (fun (e : Git.Tree.entry) ->
74 match Ref.find_opt e.name ref_map with
75 | None -> fail (Fmt.str "entry %S in tree but absent from model" e.name)
76 | Some h ->
77 if not (Git.Hash.equal e.hash h) then
78 fail (Fmt.str "hash mismatch for entry %S" e.name))
79 entries
80
81(** Apply ops to tree and model simultaneously, checking invariants at each
82 step. *)
83let test_ops_agree ops =
84 ignore
85 (List.fold_left
86 (fun (tree, ref_map) op ->
87 let tree = apply_op_tree tree op in
88 let ref_map = apply_op_ref ref_map op in
89 check_invariants tree ref_map;
90 (tree, ref_map))
91 (Git.Tree.empty, Ref.empty)
92 ops)
93
94(** After any sequence of ops, the tree must round-trip through the git binary
95 format with the same entry count. *)
96let test_roundtrip_after_ops ops =
97 let tree = List.fold_left apply_op_tree Git.Tree.empty ops in
98 let s = Git.Tree.to_string tree in
99 match Git.Tree.of_string s with
100 | Error (`Msg m) -> fail (Fmt.str "roundtrip parse failed: %s" m)
101 | Ok tree' ->
102 let n = List.length (Git.Tree.to_list tree) in
103 let n' = List.length (Git.Tree.to_list tree') in
104 if n <> n' then
105 fail (Fmt.str "roundtrip entry count: before=%d after=%d" n n')
106
107let suite =
108 ( "tree",
109 [
110 test_case "ops agree with model" [ list gen_op ] test_ops_agree;
111 test_case "roundtrip after ops" [ list gen_op ] test_roundtrip_after_ops;
112 ] )