Something went wrong. Try again.
My own corner of monopam
Something went wrong. Try again.
5.5 kB · 141 lines
OCaml
at main
123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142(* Copyright (c) 2024-2026 Thomas Gazagnaire <thomas@gazagnaire.org>
Permission to use, copy, modify, and distribute this software for any purpose with or without fee is hereby granted, provided that the above copyright notice and this permission notice appear in all copies.
THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *)
(** Fuzz the smart-protocol negotiation invariant driven by {!Git_eio.Fetch}: the set of objects a fetch sends is EXACTLY the closure reachable from the wanted tip minus what the client already has -- no shared history re-sent (minimality), no needed object omitted (completeness). This is the "the diff sent is exactly the diff" property.
A random commit DAG is built from a seed; {!Git_eio.Fetch.reachable_from} (which drives the server's [objects_to_send]) is cross-checked against an INDEPENDENT reference reachability walk written here, so a bug in the production walk cannot hide behind itself. *)
open Alcobarmodule Hash = Git.Hashmodule Value = Git.Valuemodule SS = Set.Make (String)
let key = Hash.to_hexlet author = Git.User.v ~name:"t" ~email:"t@e" ~date:0L ()
(* Build a random acyclic commit DAG from [seed]: blobs, a tree of a random subset of blobs per commit, and parents drawn only from earlier commits (so the graph is acyclic by construction). Returns the object store and the commit hashes in creation order. *)let build seed = let pos = ref 0 in let byte () = let b = if !pos < String.length seed then Char.code seed.[!pos] else 0 in incr pos; b in let rng k = if k <= 0 then 0 else byte () mod k in let store : (Hash.t, Value.t) Hashtbl.t = Hashtbl.create 64 in let put v = let h = Value.digest v in Hashtbl.replace store h v; h in let n_blobs = 1 + rng 6 in let blob_h = Array.init n_blobs (fun i -> put (Value.blob (Git.Blob.of_string ("blob-" ^ string_of_int i)))) in let n_commits = 1 + rng 8 in let commit_h = Array.make n_commits (Hash.of_hex (String.make 40 '0')) in for i = 0 to n_commits - 1 do let entries = Array.to_list blob_h |> List.mapi (fun j h -> (j, h)) |> List.filter (fun _ -> rng 2 = 0) |> List.map (fun (j, h) -> Git.Tree.entry ~perm:`Normal ~name:("f" ^ string_of_int j) h) in let th = put (Value.tree (Git.Tree.v entries)) in let parents = List.init i (fun k -> commit_h.(k)) |> List.filter (fun _ -> rng 2 = 0) in let ch = put (Value.commit (Git.Commit.v ~tree:th ~author ~committer:author ~parents (Some ("c" ^ string_of_int i ^ "\n")))) in commit_h.(i) <- ch done; (store, commit_h)
(* Independent reference: every object hash reachable from [root] (commit -> tree + parents, tree -> entries, tag -> target). *)let rec reach store seen h = if SS.mem (key h) seen then seen else let seen = SS.add (key h) seen in match Hashtbl.find_opt store h with | None -> seen | Some (Value.Blob _) -> seen | Some (Value.Tree t) -> let acc = ref seen in Git.Tree.iter (fun (e : Git.Tree.entry) -> acc := reach store !acc e.hash) t; !acc | Some (Value.Commit c) -> let seen = reach store seen (Git.Commit.tree c) in List.fold_left (reach store) seen (Git.Commit.parents c) | Some (Value.Tag tg) -> reach store seen (Git.Tag.obj tg)
let reachable store root = reach store SS.empty root
let test_minimality seed i_have i_want = let store, commits = build seed in let n = Array.length commits in let have = commits.(i_have mod n) and want = commits.(i_want mod n) in let r_have = reachable store have and r_want = reachable store want in let read h = match Hashtbl.find_opt store h with | Some v -> Ok v | None -> Error (`Msg "absent") in let exists h = SS.mem (key h) r_have in let sent = Git_eio.Fetch.reachable_from ~read ~exists want in let sent_set = SS.of_list (List.map key sent) in (* The headline invariant: sent == reachable(want) \ reachable(have). *) check (SS.equal sent_set (SS.diff r_want r_have)); (* No object is sent twice. *) check (List.length sent = SS.cardinal sent_set); (* Bottom-up order: a child that is also sent appears before its referrer, so the receiver can write each object without a dangling reference. *) let pos = Hashtbl.create 64 in List.iteri (fun i h -> Hashtbl.replace pos (key h) i) sent; let before parent child = match (Hashtbl.find_opt pos (key parent), Hashtbl.find_opt pos (key child)) with | Some p, Some c -> c < p | _ -> true (* child not sent (already had it): no ordering constraint *) in List.iter (fun h -> match Hashtbl.find_opt store h with | Some (Value.Commit c) -> check (before h (Git.Commit.tree c)) | Some (Value.Tree t) -> Git.Tree.iter (fun (e : Git.Tree.entry) -> check (before h e.hash)) t | _ -> ()) sent
let suite = ("fetch", [ test_case "minimality" [ bytes; uint8; uint8 ] test_minimality ])