Something went wrong. Try again.
A local Git merge queue with content-bound gate verdicts
Something went wrong. Try again.
14 kB · 343 lines
OCaml
at main
123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344(** Interop: the repository mq resolves from a directory is the one git resolves there, and the hook a check runs is the one git would. doc/commands.md, [mq -C PATH]: "mq finds its repository as Git does: it walks up from the current directory to the enclosing [.git] and honours GIT_DIR, with [git rev-parse --git-common-dir] as the oracle." The hooks are below, with their own traces.
Traces generated by: the git named in [traces/git-version]. Regenerate: [REGEN=1 dune build @traces].
[scripts/generate.sh] builds a fixture with git (a checkout, a linked worktree of it, a second repository, a directory in no repository, a symbolic link to the checkout and a bare repository) and records, for each case, the directory, the GIT_DIR it sets, the common directory, the top of the work tree and whether the repository is bare as git printed them, and the main worktree git worktree list names first, paths relative to the fixture's root, in [traces/discover.csv]. This test builds the same fixture with nox-git-eio and runs {!Merge_queue_eio.Repo.discover} on each case, in an environment that holds the case's GIT_DIR and nothing of the process's. The common directory, the top and the main checkout, relative to the root, must be the ones git printed, character for character; where git refused, or found a bare repository, which has no checkout to land in, discover must refuse.
The process starts in its build directory, not in the case's, so a relative GIT_DIR resolved against the process's directory names nothing. *)
type case = { name : string; dir : string; (** Relative to the fixture's root, or [@F] for the Git directory the gitfile [F], relative to the root, names. *) git_dir : string; (** Empty for none; [@F] for the Git directory the gitfile [F], relative to the root, names; otherwise set as written. *) common_dir : string; (** Relative to the root; empty for a refusal. *) top : string; (** Relative to the root; empty outside a work tree. *) bare : string; (** [true], [false], or empty for a refusal. *) checkout : string; (** Relative to the root; empty for a refusal or a bare repository. *)}
let codec = Csv.( Row.( obj (fun name dir git_dir common_dir top bare checkout -> { name; dir; git_dir; common_dir; top; bare; checkout }) |> col "name" Field.string ~enc:(fun c -> c.name) |> col "dir" Field.string ~enc:(fun c -> c.dir) |> col "git_dir" Field.string ~enc:(fun c -> c.git_dir) |> col "common_dir" Field.string ~enc:(fun c -> c.common_dir) |> col "top" Field.string ~enc:(fun c -> c.top) |> col "bare" Field.string ~enc:(fun c -> c.bare) |> col "checkout" Field.string ~enc:(fun c -> c.checkout) |> finish))
let cases () = let file = Fpath.(v "traces" / "discover.csv") in match Csv.of_file codec (Fpath.to_string file) with | Ok [] -> Fmt.failwith "%a: no case" Fpath.pp file | Ok cases -> cases | Error e -> Fmt.failwith "%a: %a" Fpath.pp file Csv.Error.pp e
(* The fixture of scripts/generate.sh, written through nox-git-eio. *)let fixture ~sw ~fs root = let path rel = Fpath.(root // v rel) in let eio p = Eio.Path.(fs / Fpath.to_string p) in let mkdir rel = Eio.Path.mkdir ~perm:0o755 (eio (path rel)) in (* git init writes the core section of a repository with a work tree, which says it is not bare; nox-git-eio's init writes no configuration. *) let init rel = let r = Git_eio.Repository.init ~sw ~fs (path rel) in Git_eio.Repository.write_config r (Git.Config.of_core Git.Config.core_defaults); r in let main = init "main" in let file name contents = Git.Tree.entry ~perm:`Normal ~name (Git_eio.Repository.write_blob main contents) in let lib = Git_eio.Repository.write_tree main (Git.Tree.v [ file "ttl.ml" "let of_string = int_of_string\n" ]) in let tree = Git_eio.Repository.write_tree main (Git.Tree.v [ file "README" "ttl: the time to live of a DNS record\n"; Git.Tree.entry ~perm:`Dir ~name:"lib" lib; ]) in let alice = Git.User.v ~name:"Alice" ~email:"alice@example.org" ~date:1767268800L () in let head = Git_eio.Repository.write_commit main (Git.Commit.v ~tree ~author:alice ~committer:alice ~parents:[] (Some "ttl: read a TTL\n")) in Git_eio.Repository.write_ref main "refs/heads/main" head; mkdir "main/lib"; let worktrees = Git_eio.Repository.worktree main in (match Git_eio.Worktree.add worktrees ~head ~path:(path "wt") ~branch:"topic" with | Ok () -> () | Error (`Msg m) -> Fmt.failwith "git worktree add: %s" m); mkdir "wt/lib"; ignore (init "other" : Git_eio.Repository.t); mkdir "outside"; Eio.Path.symlink ~link_to:"main" (eio (path "link")); (* nox-git-eio initialises no bare repository: the three entries git init --bare --template= writes that make a directory one (gitrepository-layout(5)). *) mkdir "bare.git"; mkdir "bare.git/objects"; mkdir "bare.git/refs"; Eio.Path.save ~create:(`Exclusive 0o644) (eio (path "bare.git/HEAD")) "ref: refs/heads/main\n"; Eio.Path.save ~create:(`Exclusive 0o644) (eio (path "bare.git/config")) "[core]\n\trepositoryformatversion = 0\n\tbare = true\n"
(* The Git directory the gitfile [rel], relative to [root], names. nox-git-eio names a linked worktree's Git directory otherwise than git does, so a case reaches it through its gitfile. *)let gitfile ~fs ~root rel = let gitfile = Fpath.(root // v rel) in let contents = Eio.Path.load Eio.Path.(fs / Fpath.to_string gitfile) in match String.split_on_char ' ' (String.trim contents) with | [ "gitdir:"; dir ] -> dir | _ -> Fmt.failwith "%a: %S is not a gitfile" Fpath.pp gitfile contents
let at ~fs ~root value = if value.[0] = '@' then Some (gitfile ~fs ~root (String.sub value 1 (String.length value - 1))) else None
(* The value of the case's GIT_DIR, if it sets one. *)let git_dir ~fs ~root case = match case.git_dir with | "" -> None | value -> Some (Option.value ~default:value (at ~fs ~root value))
(* The case's directory. *)let dir ~fs ~root case = match at ~fs ~root case.dir with | Some d -> Fpath.v d | None -> Fpath.(root // v case.dir)
let relative ~root answer = match Fpath.rem_prefix root answer with | Some path -> Fpath.to_string path | None -> Alcotest.failf "discover answered %a, outside the fixture" Fpath.pp answer
(* The environment a case reads Git in: no configuration but the repository's, no repository above the root, and [git_dir] as GIT_DIR. *)let environment ~fs ~root ?git_dir () = let lookup = function | "GIT_DIR" -> git_dir | "GIT_CONFIG_GLOBAL" -> Some "/dev/null" | "GIT_CONFIG_NOSYSTEM" -> Some "1" | "GIT_CEILING_DIRECTORIES" -> Some (Fpath.to_string (Fpath.rem_empty_seg (Fpath.parent root))) | _ -> None in match Merge_queue_eio.Repo.environment ~fs ~lookup ~uid:(Unix.geteuid ()) with | Ok e -> e | Error m -> Alcotest.failf "the environment: %s" m
let pp_error ppf : Merge_queue_eio.Repo.discovery_error -> unit = function | No_such_directory -> Fmt.string ppf "no such directory" | Not_a_directory -> Fmt.string ppf "not a directory" | No_repository -> Fmt.string ppf "no repository" | No_checkout c -> Fmt.pf ppf "no checkout of %a" Fpath.pp c | Refused m -> Fmt.pf ppf "refused: %s" m
let check ~fs ~root case () = let dir = dir ~fs ~root case in match ( Merge_queue_eio.Repo.discover (environment ~fs ~root ?git_dir:(git_dir ~fs ~root case) ()) dir, case.common_dir ) with | Error No_repository, "" -> () | Error (No_checkout common), expected when case.bare = "true" -> Alcotest.(check string) "common directory" expected (relative ~root common) | Ok location, "" -> Alcotest.failf "git refused, discover answered %a" Fpath.pp location.common_dir | Ok location, _ when case.bare = "true" -> Alcotest.failf "git found a bare repository, discover answered %a" Fpath.pp location.common_dir | Ok location, expected -> Alcotest.(check string) "common directory" expected (relative ~root location.common_dir); Alcotest.(check string) "top" case.top (Option.fold ~none:"" ~some:(relative ~root) location.top); Alcotest.(check string) "checkout" case.checkout (relative ~root location.checkout) | Error e, expected -> Alcotest.failf "git answered %S (bare %s), discover refused: %a" expected case.bare pp_error e
(* doc/configuration.md: "mq finds the script as Git does, in the directory core.hooksPath names or else in hooks/ of the Git directory, and resolves that with ocaml-git, never by running git. An interop test holds the two equal, with git rev-parse --git-path hooks/pre-commit as the oracle. A core.hooksPath inside the work tree (.githooks) resolves against the check worktree, so the hook comes from the tree being checked."
[traces/hooks.csv] has, for each core.hooksPath of main, git's answer from the linked worktree wt, where a check of main runs, and from main. mq's answer is the script {!Merge_queue.Check.program} places from main and {!Merge_queue.Check.locate} names for a check run in wt. It is git's answer from wt for every row but one: an absolute core.hooksPath inside main's work tree, which git takes from main and mq from the tree under check in wt, the departure doc/design.md records. *)
type hook_case = { hook : string; hooks_path : string; (** Empty for none, [@P] for the absolute path [ROOT/P], otherwise as written. *) from_worktree : string; (** git's answer from wt, relative to the root. *) from_checkout : string; (** git's answer from main, relative to the root. *)}
let hook_codec = Csv.( Row.( obj (fun hook hooks_path from_worktree from_checkout -> { hook; hooks_path; from_worktree; from_checkout }) |> col "name" Field.string ~enc:(fun c -> c.hook) |> col "hooks_path" Field.string ~enc:(fun c -> c.hooks_path) |> col "from_worktree" Field.string ~enc:(fun c -> c.from_worktree) |> col "from_checkout" Field.string ~enc:(fun c -> c.from_checkout) |> finish))
let hook_cases () = let file = Fpath.(v "traces" / "hooks.csv") in match Csv.of_file hook_codec (Fpath.to_string file) with | Ok [] -> Fmt.failwith "%a: no case" Fpath.pp file | Ok cases -> cases | Error e -> Fmt.failwith "%a: %a" Fpath.pp file Csv.Error.pp e
(* What mq expects for a check run in wt: git's answer from wt, unless git's answer from main lies in main's tree, outside its Git directory, in which case the same path in wt. *)let expected case = match Fpath.(rem_prefix (v "main/") (v case.from_checkout)) with | Some rel when not (Fpath.is_prefix (Fpath.v ".git/") rel) -> Fpath.(to_string (v "wt" // rel)) | _ -> case.from_worktree
let check_hook ~fs ~process ~clock ~root case () = let path rel = Fpath.(root // v rel) in let config = Eio.Path.(fs / Fpath.to_string (path "main/.git/config")) in let base = Eio.Path.load config in Fun.protect ~finally:(fun () -> Eio.Path.save ~create:(`Or_truncate 0o644) config base) (fun () -> (match case.hooks_path with | "" -> () | value -> let value = if value.[0] = '@' then Fpath.to_string (path (String.sub value 1 (String.length value - 1))) else value in Eio.Path.save ~create:(`Or_truncate 0o644) config (Fmt.str "%s[core]\n\thooksPath = %s\n" base value)); Eio.Switch.run @@ fun sw -> let hooks = Merge_queue_eio.Repo.hooks ~process ~clock ~wall:(Merge_queue.Duration.of_seconds 30) () in let repo = Merge_queue_eio.Repo.v ~sw ~environment:(environment ~fs ~root ()) ~hooks (path "main") in let pre_commit = Merge_queue.Check.(v (name "pre-commit") (Hook Commit)) in match Merge_queue.Check.program ~hooks:(Merge_queue_eio.Repo.hooks_dir repo) pre_commit with | None -> Alcotest.fail "pre-commit has no script" | Some place -> let script = Merge_queue.Check.locate ~worktree:(path "wt") place in Alcotest.(check string) "the script of a check run in wt" (expected case) (relative ~root script); if not (String.equal (expected case) case.from_worktree) then Alcotest.(check bool) "git takes it from the checkout" true (String.equal case.from_worktree case.from_checkout))
let () = Eio_main.run @@ fun env -> Eio.Switch.run @@ fun sw -> (* eio#946: a child's exit wakes the scheduler (Eio_signal.wake), as in mq's own loop. *) Eio_signal.wake ~sw [ Sys.sigchld ]; let fs = Eio.Stdenv.fs env and process = Eio.Stdenv.process_mgr env in let clock = (Eio.Stdenv.clock env :> float Eio.Time.clock_ty Eio.Resource.t) in (* A fresh directory outside any repository, by its physical path, the one git prints; git looks for no repository above it. *) let root = Fpath.v (Unix.realpath (Filename.temp_dir "mq-discover-" "")) in Fun.protect ~finally:(fun () -> Eio.Path.rmtree ~missing_ok:true Eio.Path.(fs / Fpath.to_string root)) (fun () -> Eio.Switch.run (fun sw -> fixture ~sw ~fs root); Alcotest.run ~and_exit:false "merge-queue-eio-interop" [ ( "hooks", List.map (fun case -> Alcotest.test_case case.hook `Quick (check_hook ~fs ~process ~clock ~root case)) (hook_cases ()) ); ( "discover", List.map (fun case -> Alcotest.test_case case.name `Quick (check ~fs ~root case)) (cases ()) ); ])