Something went wrong. Try again.
My own corner of monopam
Something went wrong. Try again.
34 kB · 949 lines
OCaml
at main
123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950(** Pre-commit hook initialization for OCaml projects.
Installs git hooks directly without requiring the pre-commit tool. *)
let log_src = Logs.Src.create "precommit"
module Log = (val Logs.src_log log_src : Logs.LOG)
let err fmt = Fmt.kstr (fun s -> Error s) fmt
let err_no_dune_project dir = err "%s: No dune-project found (use --force to override)" dir
let err_no_git_dir dir = err "%s: No .git directory found" dir
type ctx = { cwd : Eio.Fs.dir_ty Eio.Path.t; fs : Eio.Fs.dir_ty Eio.Path.t }
let ctx ~cwd ~fs = { cwd :> Eio.Fs.dir_ty Eio.Path.t; fs :> Eio.Fs.dir_ty Eio.Path.t }
type hooks = { fmt : bool; ai : bool; merlint : bool }
let all_hooks = { fmt = true; ai = true; merlint = true }
let pre_commit_header = {|#!/bin/sh# Pre-commit: auto-format and lint the whole tree
# OCaml files already staged (used for re-staging after auto-formatting)STAGED_ML=$(git diff --cached --name-only --diff-filter=ACM | grep -E '\.(ml|mli|mll|mly)$' || true)
# Git exports GIT_DIR, GIT_INDEX_FILE and friends to every hook child, naming# the repository being committed to. A build below can run a test suite whose# fixtures then commit into THIS repository instead of their own sandbox. The# variables have to go, and GIT_CEILING_DIRECTORIES is not a fix: git handed an# explicit GIT_DIR never walks up.## They go per command, not in one "unset" at the top, because the git commands# in this hook need GIT_INDEX_FILE: during "git commit -- <paths>" it names a# temporary index, and a "git diff --cached" that cannot read it reports nothing# staged.no_git_env="env -u GIT_DIR -u GIT_WORK_TREE -u GIT_INDEX_FILE \ -u GIT_OBJECT_DIRECTORY -u GIT_COMMON_DIR \ -u GIT_ALTERNATE_OBJECT_DIRECTORIES -u GIT_PREFIX -u GIT_QUARANTINE_PATH"|}
let fmt_section = {|# Auto-format the whole tree. dune fmt promotes the formatted files and exits# non-zero when it changed any; that is the fix succeeding, so never abort on it.# Re-stage any already-staged files so a plain "git commit" includes the fix;# "git-x commit" reads the work tree directly and needs no re-staging.$no_git_env dune fmt >/dev/null 2>&1 || trueif [ -n "$STAGED_ML" ]; then git add -- $STAGED_ML 2>/dev/null || truefi|}
let merlint_section = {|# Lint the whole workspace with the merlint the workspace itself carries. Real# issues abort the commit; bypass with --no-verify.## merlint is found by path, never through PATH, and is never skipped: resolving# through PATH reaches whatever version is installed, and skipping prints# exactly what a clean run prints. A gate that cannot find its instrument# refuses and names the paths it looked for.## merlint is never wrapped in timeout, whose kill code 124 is also a code# merlint returns through cmdliner.## The workspace may build merlint at its root or vendor it, so both layouts are# searched by path and the first that exists is the one that must build.merlint_dirs="merlint/bin vendor/mono/merlint/bin"
merlint_bin=""for merlint_dir in $merlint_dirs; do [ -d "$merlint_dir" ] || continue if ! $no_git_env dune build "$merlint_dir/main.exe"; then echo "Error: this workspace carries merlint at $merlint_dir and it does not build" >&2 exit 1 fi if [ ! -x "_build/default/$merlint_dir/main.exe" ]; then echo "Error: dune reported $merlint_dir/main.exe built, but _build/default/$merlint_dir/main.exe is not there" >&2 exit 1 fi merlint_bin="_build/default/$merlint_dir/main.exe" breakdone
if [ -z "$merlint_bin" ]; then echo "Error: no merlint in this workspace; looked for:" >&2 for merlint_dir in $merlint_dirs; do echo " $merlint_dir/main.exe" >&2 done echo "Linting through PATH would reach some other merlint, so this refuses instead." >&2 exit 1fi
if ! $no_git_env "$merlint_bin" --build . ; then # merlint's own last line says which outcome this was; the words belong to # the tool that computed it. echo "Error: the commit is refused. merlint's output above says why." >&2 exit 1fi|}
let pre_commit_hook hooks = String.concat "" [ pre_commit_header; (if hooks.fmt then fmt_section else ""); (if hooks.merlint then merlint_section else ""); "\nexit 0\n"; ]
let commit_msg_hook = {|#!/bin/sh# Reject a commit message carrying an emoji and remove the lines that mention# claude: precommit commit-msg holds the rule.exec precommit commit-msg "$1"|}
(* The code points the commit-msg hook refuses, as inclusive ranges. *)let emoji_ranges = [ (0x1F600, 0x1F64F); (0x1F300, 0x1F5FF); (0x1F680, 0x1F6FF); (0x1F1E0, 0x1F1FF); (0x2702, 0x27B0); (0x24C2, 0x1F251); ]
let is_emoji u = let c = Uchar.to_int u in List.exists (fun (lo, hi) -> lo <= c && c <= hi) emoji_ranges
(* [Ok true] when [s] carries an emoji, [Error ()] when it is not UTF-8. *)let has_emoji s = let rec go i = if i >= String.length s then Ok false else let d = String.get_utf_8_uchar s i in if not (Uchar.utf_decode_is_valid d) then Error () else if is_emoji (Uchar.utf_decode_uchar d) then Ok true else go (i + Uchar.utf_decode_length d) in go 0
let claude = Re.compile (Re.no_case (Re.str "claude"))
let commit_message msg = match has_emoji msg with | Error () -> Error "Error: Commit message is not UTF-8." | Ok true -> Error "Error: Commit message contains emojis, which are not allowed." | Ok false -> (* Each line keeps its terminator, as the message's last may have none. *) let lines = String.split_on_char '\n' msg in let last = List.length lines - 1 in List.mapi (fun i l -> if i < last then l ^ "\n" else l) lines |> List.filter (fun l -> not (Re.execp claude l)) |> String.concat "" |> Result.ok
let default_ocamlformat = {|version = 0.28.1|}
(* Regular expression for detecting "(formatting disabled)" in dune-project *)let formatting_disabled_re = Re.compile (Re.Pcre.re {|\(formatting\s+disabled\)|})
let file_exists ~fs path = match Eio.Path.kind ~follow:true Eio.Path.(fs / path) with | `Not_found -> false | _ -> true
let is_directory ~fs path = match Eio.Path.kind ~follow:true Eio.Path.(fs / path) with | `Directory -> true | _ -> false
let is_symlink ~fs path = match Eio.Path.kind ~follow:false Eio.Path.(fs / path) with | `Symbolic_link -> true | _ -> false
let read_file ~fs path = Eio.Path.load Eio.Path.(fs / path)
let write_file ~fs ~dry_run path content = if dry_run then Fmt.pr "Would create %s@." path else Eio.Path.save ~create:(`Or_truncate 0o644) Eio.Path.(fs / path) content
let chmod_exec ~dry_run path = if dry_run then Fmt.pr "Would chmod +x %s@." path else Unix.chmod path 0o755
let mkdir_p ~fs ~dry_run path = if dry_run then Fmt.pr "Would create %s/@." path else Eio.Path.mkdirs ~exists_ok:true ~perm:0o755 Eio.Path.(fs / path)
let check_formatting_disabled ~fs path = if not (file_exists ~fs path) then false else let content = read_file ~fs path in Re.execp formatting_disabled_re content
let resolve_git_dir ~fs git_dir_path = if is_directory ~fs git_dir_path then git_dir_path else (* .git is a file pointing to the real git dir (worktree) *) let content = read_file ~fs git_dir_path in let line = String.trim (List.hd (String.split_on_char '\n' content)) in match String.split_on_char ' ' line with | "gitdir:" :: rest -> String.concat " " rest | _ -> git_dir_path
(* Find git root by walking up from dir. [cwd] is the working directory path, [fs] is the full filesystem. *)let git_root ~cwd ~fs dir = let _, cwd_path = cwd in let base_path = if cwd_path = "" || cwd_path = "." then Sys.getcwd () else cwd_path in let abs_dir = if Filename.is_relative dir then Filename.concat base_path dir else dir in let abs_dir = if String.length abs_dir >= 2 && String.sub abs_dir (String.length abs_dir - 2) 2 = "/." then String.sub abs_dir 0 (String.length abs_dir - 2) else abs_dir in Log.debug (fun m -> m "git_root: dir=%s abs_dir=%s" dir abs_dir); let rec walk path = let git_dir = Filename.concat path ".git" in Log.debug (fun m -> m "git_root: checking %s" git_dir); match Eio.Path.kind ~follow:true Eio.Path.(fs / git_dir) with | `Not_found -> let parent = Filename.dirname path in if parent = path then None else walk parent | _ -> Some path in walk abs_dir
let init_in_dir ctx ~dry_run ~force ~hooks dir = let dune_project = Filename.concat dir "dune-project" in let ocamlformat_path = Filename.concat dir ".ocamlformat" in if (not force) && not (file_exists ~fs:ctx.cwd dune_project) then err_no_dune_project dir else match git_root ~cwd:ctx.cwd ~fs:ctx.fs dir with | None -> err_no_git_dir dir | Some git_root -> let git_dir_path = Filename.concat git_root ".git" in let git_dir = resolve_git_dir ~fs:ctx.fs git_dir_path in let hooks_dir = Filename.concat git_dir "hooks" in
(* Create hooks directory if needed *) mkdir_p ~fs:ctx.fs ~dry_run hooks_dir;
(* Install pre-commit hook if requested *) if hooks.fmt || hooks.merlint then begin let pre_commit_path = Filename.concat hooks_dir "pre-commit" in write_file ~fs:ctx.fs ~dry_run pre_commit_path (pre_commit_hook hooks); chmod_exec ~dry_run pre_commit_path end;
(* Install commit-msg hook if requested *) if hooks.ai then begin let commit_msg_path = Filename.concat hooks_dir "commit-msg" in write_file ~fs:ctx.fs ~dry_run commit_msg_path commit_msg_hook; chmod_exec ~dry_run commit_msg_path end;
(* Create .ocamlformat if missing and fmt hooks requested *) if hooks.fmt && not (file_exists ~fs:ctx.cwd ocamlformat_path) then write_file ~fs:ctx.cwd ~dry_run ocamlformat_path default_ocamlformat;
Ok ()
let init ctx ~dry_run ~force ~hooks () = init_in_dir ctx ~dry_run ~force ~hooks "."
type hook_status = { has_pre_commit : bool; has_merlint : bool; has_commit_msg : bool; has_ocamlformat : bool; formatting_disabled : bool; is_ocaml_project : bool; is_git_repo : bool;}
let merlint_re = Re.compile (Re.str "merlint")
(* The pre-commit and commit-msg hooks git actually runs, which is the pair the repository points at through [core.hooksPath] and only otherwise the pair lying in the common dir's [hooks/]. Reading that directory directly would call a repository wired to a tracked hooks directory unhooked, and one whose hooks git ignores gated. Both hooks come from one open, so they cannot disagree about which repository they describe. *)let repo_hooks ctx git_root = Eio.Switch.run @@ fun sw -> let repo = Git_eio.Repository.open_repo ~sw ~fs:ctx.fs (Fpath.v git_root) in ( Git_eio.Repository.hook repo "pre-commit", Git_eio.Repository.hook repo "commit-msg" )
let status_in_dir ctx dir = let dune_project = Filename.concat dir "dune-project" in let ocamlformat_path = Filename.concat dir ".ocamlformat" in let is_ocaml_project = file_exists ~fs:ctx.cwd dune_project in let has_ocamlformat = file_exists ~fs:ctx.cwd ocamlformat_path in let formatting_disabled = check_formatting_disabled ~fs:ctx.cwd dune_project in match git_root ~cwd:ctx.cwd ~fs:ctx.fs dir with | None -> { has_pre_commit = false; has_merlint = false; has_commit_msg = false; has_ocamlformat; formatting_disabled; is_ocaml_project; is_git_repo = false; } | Some git_root -> let pre_commit, commit_msg = repo_hooks ctx git_root in let has_merlint = match pre_commit with | None -> false | Some path -> Re.execp merlint_re (read_file ~fs:ctx.fs (Fpath.to_string path)) in { has_pre_commit = Option.is_some pre_commit; has_merlint; has_commit_msg = Option.is_some commit_msg; has_ocamlformat; formatting_disabled; is_ocaml_project; is_git_repo = true; }
let status ctx () = status_in_dir ctx "."
(* {1 Tracked hooks directory} *)
type receive_link = { path : string; target : string }
type link_status = { root : string; tracked_dir : string; hooks_dir : string; wired : bool; by_mq : bool; per_worktree : bool; receive : receive_link option; receives : bool; tracked_hooks : (string * bool) list; shadowed : string list;}
(* Ask git rather than reimplement it. core.hooksPath is resolved from several config scopes and a second implementation of that precedence is a second answer to the same question, free to disagree with the one git acts on. *)let git ~proc ~root args = let argv = "git" :: "-C" :: root :: args in match Eio.Process.parse_out proc Eio.Buf_read.take_all argv with | out -> Ok (String.trim out) | exception Eio.Io _ -> err "git %s: failed in %s" (String.concat " " args) root
(* [dir] resolved against [root] and normalised, so that two spellings of one directory compare equal. *)let absolute ~root dir = let p = Fpath.v dir in let p = if Fpath.is_abs p then p else Fpath.(v root // p) in Fpath.to_string (Fpath.rem_empty_seg (Fpath.normalize p))
let is_hook_name name = (not (String.starts_with ~prefix:"." name)) && not (String.ends_with ~suffix:".sample" name)
(* [Some executable] for a regular file, [None] for anything else. *)let executable ~fs path = match Eio.Path.stat ~follow:true Eio.Path.(fs / path) with | { Eio.File.Stat.kind = `Regular_file; perm; _ } -> Some (perm land 0o111 <> 0) | _ -> None | exception Eio.Io _ -> None
(* The hook files of [dir], sorted, each with whether it is executable. *)let dir_hooks ~fs dir = let entry name = if not (is_hook_name name) then None else let path = Fpath.to_string Fpath.(v dir / name) in Option.map (fun x -> (name, x)) (executable ~fs path) in match Eio.Path.read_dir Eio.Path.(fs / dir) with | entries -> List.filter_map entry (List.sort String.compare entries) | exception Eio.Io _ -> []
(* The executable hooks of the directory git uses when core.hooksPath is unset, that [tracked] does not carry. Setting core.hooksPath makes git ignore exactly these, so naming them is the difference between a deliberate move and a silent loss. *)let shadowed_hooks ~proc ~fs ~root ~tracked = match git ~proc ~root [ "rev-parse"; "--git-common-dir" ] with | Error _ -> [] | Ok common -> let dir = absolute ~root (Fpath.to_string Fpath.(v common / "hooks")) in dir_hooks ~fs dir |> List.filter (fun (name, exec) -> exec && not (List.exists (String.equal name) tracked)) |> List.map fst
let realpath path = try Unix.realpath path with Unix.Unix_error _ -> path
(* mq serves a primary the hooks its queue's tip tracks: it records the tracked directory as [mq.hooks] and points core.hooksPath at its copy of that directory under the git common dir. That copy is the hook git must run, whatever the checkout holds. *)let by_mq ~proc ~root ~want ~hooks_dir = match ( git ~proc ~root [ "config"; "--get"; "mq.hooks" ], git ~proc ~root [ "config"; "--get"; "core.hooksPath" ], git ~proc ~root [ "rev-parse"; "--git-common-dir" ] ) with | Ok mq_hooks, Ok _, Ok common -> let common = realpath (absolute ~root common) in String.equal (absolute ~root mq_hooks) want && String.starts_with ~prefix:(common ^ "/") (realpath hooks_dir) | _ -> false
(* Git runs a push's hooks from the git directory (githooks(5)), where a relative core.hooksPath resolves under the git directory itself. In a repository whose git directory is its main worktree's [.git], a link there to the tracked directory gives a push the hooks that worktree carries. A bare repository has no worktree to link to. *)let receive_link ~proc ~root tracked_dir = if not (Filename.is_relative tracked_dir) then None else match git ~proc ~root [ "rev-parse"; "--git-common-dir" ] with | Error _ -> None | Ok common -> let common = Fpath.v (absolute ~root common) in if not (String.equal (Fpath.basename common) ".git") then None else let tracked = Fpath.v tracked_dir in let path = Fpath.(normalize (common // tracked)) in let to_ = Fpath.(normalize (parent common // tracked)) in Option.map (fun rel -> let path = Fpath.(to_string (rem_empty_seg path)) in { path; target = Fpath.(to_string (rem_empty_seg rel)) }) (Fpath.relativize ~root:(Fpath.parent path) to_)
let receives = function | None -> true | Some { path; target } -> let at = Filename.concat (Filename.dirname path) target in Sys.file_exists path && String.equal (realpath path) (realpath at)
let link_status ctx ~proc ~tracked_dir dir = match git_root ~cwd:ctx.cwd ~fs:ctx.fs dir with | None -> err_no_git_dir dir | Some root -> ( match git ~proc ~root [ "rev-parse"; "--git-path"; "hooks" ] with | Error _ as e -> e | Ok hooks_dir -> let want = absolute ~root tracked_dir in let have = absolute ~root hooks_dir in let by_mq = by_mq ~proc ~root ~want ~hooks_dir:have in let per_worktree = Filename.is_relative hooks_dir in let receive = receive_link ~proc ~root tracked_dir in let receives = receives receive in let tracked_hooks = dir_hooks ~fs:ctx.fs want in let tracked = List.map fst tracked_hooks in Ok { root; tracked_dir; hooks_dir = have; wired = by_mq || (String.equal want have && per_worktree && receives); by_mq; per_worktree; receive; receives; tracked_hooks = (if by_mq then dir_hooks ~fs:ctx.fs have else tracked_hooks); shadowed = shadowed_hooks ~proc ~fs:ctx.fs ~root ~tracked; })
let err_shadowed s = err "%s: hooks git runs today that %s does not carry: %s.@\n\ Setting core.hooksPath makes git ignore them. Move them into %s first, or \ pass --force to wire anyway." s.root s.tracked_dir (String.concat ", " s.shadowed) s.tracked_dir
let unwired s = if s.wired then None else if not (String.equal (absolute ~root:s.root s.tracked_dir) s.hooks_dir) then Fmt.kstr Option.some "git runs hooks from %s, not %s" s.hooks_dir s.tracked_dir else if not s.per_worktree then Fmt.kstr Option.some "core.hooksPath names %s by absolute path, so every worktree runs this \ checkout's hooks, not its own %s" s.hooks_dir s.tracked_dir else match s.receive with | Some { path; _ } -> Fmt.kstr Option.some "a push into this repository runs no hook: %s does not lead to %s" path s.tracked_dir | None -> None
(* The link is written where nothing stands and left where it already holds [target]; anything else at its path is the operator's to move. *)let wire_receive ~fs ~dry_run { path; target } = let at = Eio.Path.(fs / path) in match Eio.Path.kind ~follow:false at with | `Not_found when dry_run -> Fmt.pr "Would link %s to %s@." path target; Ok () | `Not_found -> mkdir_p ~fs ~dry_run (Filename.dirname path); Eio.Path.symlink ~link_to:target at; Ok () | `Symbolic_link when String.equal (Eio.Path.read_link at) target -> Ok () | _ -> err "%s is not a symbolic link to %s; move it aside, then wire again" path target
let wire ~proc ~fs ~dry_run ~tracked_dir s = let want = absolute ~root:s.root tracked_dir in List.iter (fun (name, exec) -> if not exec then chmod_exec ~dry_run (Fpath.to_string Fpath.(v want / name))) s.tracked_hooks; let ( let* ) = Result.bind in let* () = if dry_run then begin Fmt.pr "Would set core.hooksPath to %s in %s@." tracked_dir s.root; Ok () end else Result.map ignore (git ~proc ~root:s.root [ "config"; "core.hooksPath"; tracked_dir ]) in match s.receive with | None -> Ok () | Some receive -> wire_receive ~fs ~dry_run receive
let link ctx ~proc ~dry_run ~force ~tracked_dir dir = match link_status ctx ~proc ~tracked_dir dir with | Error _ as e -> e | Ok { by_mq = true; _ } -> Ok () | Ok s -> ( match (s.tracked_hooks, s.shadowed) with | [], _ -> err "%s: %s carries no hook to wire" s.root s.tracked_dir | _, _ :: _ when not force -> err_shadowed s | _ -> wire ~proc ~fs:ctx.fs ~dry_run ~tracked_dir s)
let list_subdirs ~fs dir = Eio.Path.read_dir Eio.Path.(fs / dir) |> List.filter_map (fun name -> if name.[0] = '.' then None else let path = Filename.concat dir name in if is_directory ~fs path then Some path else None) |> List.sort String.compare
(* Check if dir is inside a git repo (ancestor has .git, not dir itself) *)let is_inside_git_repo ~cwd ~fs dir = (* First check if dir itself has .git *) let has_git_here = file_exists ~fs (Filename.concat dir ".git") in if has_git_here then false else (* Check if an ancestor has .git *) match git_root ~cwd ~fs dir with | Some _ -> true | None -> false
(* Convert absolute path to relative path from cwd_path *)let relative ~cwd_path abs_path = if String.length abs_path >= String.length cwd_path && String.sub abs_path 0 (String.length cwd_path) = cwd_path then let rest = String.sub abs_path (String.length cwd_path) (String.length abs_path - String.length cwd_path) in if rest = "" then "." else if rest.[0] = '/' then String.sub rest 1 (String.length rest - 1) else rest else abs_path
let self ctx dir entries = if List.mem ".git" entries then [ dir ] else if is_inside_git_repo ~cwd:ctx.cwd ~fs:ctx.fs dir then match git_root ~cwd:ctx.cwd ~fs:ctx.fs dir with | Some root -> let _, cwd_path = ctx.cwd in let cwd_path = if String.equal cwd_path "" || String.equal cwd_path "." then Sys.getcwd () else cwd_path in [ relative ~cwd_path root ] | None -> [] else []
(* Return the relative path to a child directory worth recursing into, or [None] if [name] is hidden, a symlink, or not a directory. *)let child_subdir ctx ~child_path name = if String.length name > 0 && (name.[0] = '.' || name.[0] = '_') then None else let path = child_path name in (* Skip symlinks to avoid traversing outside the sandbox *) if is_symlink ~fs:ctx.cwd path then None else if is_directory ~fs:ctx.cwd path then Some path else None
let rec git_projects ctx dir = let entries = try Eio.Path.read_dir Eio.Path.(ctx.cwd / dir) with Eio.Io _ -> [] in let child_path name = if dir = "." then name else Filename.concat dir name in let self = self ctx dir entries in (* Only descend into children if we haven't found a git root yet *) let children = if self <> [] then [] else entries |> List.filter_map (child_subdir ctx ~child_path) |> List.sort String.compare |> List.concat_map (fun sub -> if file_exists ~fs:ctx.cwd (Filename.concat sub ".git") then [ sub ] else git_projects ctx sub) in self @ children
type ai_commit = { hash : string; subject : string }
(* AI attribution pattern for filtering commit messages *)let ai_pattern = Re.compile (Re.Pcre.re {|[Cc]o-[Aa]uthored-[Bb]y:.*[Cc]laude.*\n?|})
let filter_message msg = Re.replace_string ai_pattern ~by:"" msglet message_has_ai_attribution msg = Re.execp ai_pattern msg
(* Get current user's email from git config (local or global) *)let user_email ~fs repo = (* First check local repo config *) let local_email = match Git_eio.Repository.read_config repo with | Ok (Some config) -> (Git.Config.user config).email | Ok None -> None | Error (`Msg reason) -> failwith reason in match local_email with | Some _ -> local_email | None -> ( (* Fall back to global config ~/.gitconfig *) let home = try Sys.getenv "HOME" with Not_found -> ( try Sys.getenv "USERPROFILE" with Not_found -> "") in if home = "" then None else let global_config_path = Filename.concat home ".gitconfig" in match Eio.Path.load Eio.Path.(fs / global_config_path) with | content -> ( let source = { Git.Config.scope = Global; origin = File (Fpath.v global_config_path); } in match Git.Config.of_string ~source content with | Ok config -> (Git.Config.user config).email | Error (`Msg reason) -> failwith reason) | exception Eio.Io (Eio.Fs.E (Eio.Fs.Not_found _), _) -> None | exception (Eio.Io _ as exn) -> Fmt.failwith "%a" Eio.Exn.pp exn)
(* Check if commit was made by the current user *)let is_my_commit ~user_email commit = match user_email with | None -> true (* If no user configured, include all commits *) | Some email -> let committer_email = Git.User.email (Git.Commit.committer commit) in String.equal email committer_email
let subject_of_message = function | None -> "" | Some m -> ( match String.split_on_char '\n' m with | subj :: _ -> String.trim subj | [] -> "")
let message_ai_attribution_summary info msg = if message_has_ai_attribution msg then let hash = String.sub (Git.Hash.to_hex info.Git_eio.Rev_list.hash) 0 7 in Some { hash; subject = subject_of_message (Some msg) } else None
let scan_commit_for_ai_attribution ~repo ~user_email ~found ~skipped_email ~skipped_no_ai (info : Git_eio.Rev_list.commit_info) = match Git_eio.Repository.read repo info.hash with | Ok (Git.Value.Commit c) when not (is_my_commit ~user_email c) -> incr skipped_email; None | Ok (Git.Value.Commit c) -> ( match Git.Commit.message c with | None -> incr skipped_no_ai; None | Some msg -> ( match message_ai_attribution_summary info msg with | Some _ as s -> incr found; s | None -> incr skipped_no_ai; None)) | _ -> None
let scan_commits_for_ai_attribution repo commits user_email = let found = ref 0 in let skipped_email = ref 0 in let skipped_no_ai = ref 0 in let result = List.filter_map (scan_commit_for_ai_attribution ~repo ~user_email ~found ~skipped_email ~skipped_no_ai) commits in Log.debug (fun m -> m "check_ai_attribution: found=%d skipped_email=%d skipped_no_ai=%d" !found !skipped_email !skipped_no_ai); result
let load_commits_from_head repo head_hash = Log.debug (fun m -> m "check_ai_attribution: HEAD=%s" (Git.Hash.to_hex head_hash)); match Git_eio.Rev_list.topo_sort_reverse repo head_hash ~stop:(fun _ -> false) with | Ok cs -> Log.debug (fun m -> m "check_ai_attribution: %d commits" (List.length cs)); cs | Error (`Msg e) -> Log.debug (fun m -> m "check_ai_attribution: error %s" e); []
let check_ai_attribution_at_root ctx git_root = Log.debug (fun m -> m "check_ai_attribution: git_root=%s" git_root); Eio.Switch.run @@ fun sw -> let repo = Git_eio.Repository.open_repo ~sw ~fs:ctx.fs (Fpath.v git_root) in let user_email = user_email ~fs:ctx.fs repo in Log.debug (fun m -> m "check_ai_attribution: git_root=%s user_email=%s" git_root (Option.value ~default:"<none>" user_email)); match Git_eio.Repository.head repo with | None -> Log.debug (fun m -> m "check_ai_attribution: no HEAD"); [] | Some head_hash -> let commits = load_commits_from_head repo head_hash in scan_commits_for_ai_attribution repo commits user_email
let check_ai_attribution ctx dir = Log.debug (fun m -> m "check_ai_attribution: dir=%s" dir); match git_root ~cwd:ctx.cwd ~fs:ctx.fs dir with | None -> Log.debug (fun m -> m "check_ai_attribution: no git root found for %s" dir); [] | Some git_root -> check_ai_attribution_at_root ctx git_root
let current_branch ctx dir = match git_root ~cwd:ctx.cwd ~fs:ctx.fs dir with | None -> None | Some git_root -> Eio.Switch.run @@ fun sw -> let repo = Git_eio.Repository.open_repo ~sw ~fs:ctx.fs (Fpath.v git_root) in Git_eio.Repository.current_branch repo
let backup_branch ctx dir = match git_root ~cwd:ctx.cwd ~fs:ctx.fs dir with | None -> Fmt.failwith "%s: No .git directory found" dir | Some git_root -> Eio.Switch.run @@ fun sw -> let repo = Git_eio.Repository.open_repo ~sw ~fs:ctx.fs (Fpath.v git_root) in let branch = match Git_eio.Repository.current_branch repo with | Some b -> b | None -> "HEAD" in let now = Unix.gettimeofday () in let tm = Unix.localtime now in let timestamp = Fmt.str "%04d%02d%02d-%02d%02d%02d" (1900 + tm.tm_year) (tm.tm_mon + 1) tm.tm_mday tm.tm_hour tm.tm_min tm.tm_sec in let backup_name = Fmt.str "backup/%s-before-fix-%s" branch timestamp in (match Git_eio.Repository.head repo with | Some hash -> Git_eio.Repository.write_ref repo ("refs/heads/" ^ backup_name) hash | None -> ()); backup_name
let mark_commits_needing_rewrite repo commits user_email = let needs_rewrite = Hashtbl.create 64 in List.iter (fun (info : Git_eio.Rev_list.commit_info) -> match Git_eio.Repository.read repo info.hash with | Ok (Git.Value.Commit c) when is_my_commit ~user_email c -> ( match Git.Commit.message c with | Some msg when message_has_ai_attribution msg -> Hashtbl.add needs_rewrite info.hash true | _ -> ()) | _ -> ()) commits; needs_rewrite
let rewrite_resolved_parents hash_map c = let new_parents = List.map (fun p -> match Hashtbl.find_opt hash_map p with Some np -> np | None -> p) (Git.Commit.parents c) in let parents_changed = not (List.equal Git.Hash.equal new_parents (Git.Commit.parents c)) in (new_parents, parents_changed)
let needs_msg_rewrite_for c = match Git.Commit.message c with | Some m -> message_has_ai_attribution m | None -> false
let write_rewritten_commit repo hash_map info c new_parents = let new_msg = match Git.Commit.message c with | Some m -> Some (filter_message m) | None -> None in let new_commit = Git.Commit.v ~tree:(Git.Commit.tree c) ~author:(Git.Commit.author c) ~committer:(Git.Commit.committer c) ~parents:new_parents ~extra:(Git.Commit.extra c) new_msg in let new_hash = Git_eio.Repository.write_commit repo new_commit in Hashtbl.add hash_map info.Git_eio.Rev_list.hash new_hash
let rewrite_commit_step repo hash_map (info : Git_eio.Rev_list.commit_info) = match Git_eio.Repository.read repo info.hash with | Ok (Git.Value.Commit c) -> let new_parents, parents_changed = rewrite_resolved_parents hash_map c in if parents_changed || needs_msg_rewrite_for c then write_rewritten_commit repo hash_map info c new_parents | _ -> ()
let rewrite_commit_history repo commits hash_map = List.iter (fun (info : Git_eio.Rev_list.commit_info) -> rewrite_commit_step repo hash_map info) commits
let rewrite_at_head repo head_hash user_email = let commits = match Git_eio.Rev_list.topo_sort_reverse repo head_hash ~stop:(fun _ -> false) with | Ok cs -> cs | Error _ -> [] in let needs_rewrite = mark_commits_needing_rewrite repo commits user_email in if Hashtbl.length needs_rewrite = 0 then Ok 0 else let hash_map = Hashtbl.create 64 in rewrite_commit_history repo commits hash_map; (match Hashtbl.find_opt hash_map head_hash with | Some new_head -> Git_eio.Repository.advance_head repo new_head | None -> ()); Ok (Hashtbl.length needs_rewrite)
let rewrite_at_root ctx git_root = try Eio.Switch.run @@ fun sw -> let repo = Git_eio.Repository.open_repo ~sw ~fs:ctx.fs (Fpath.v git_root) in let user_email = user_email ~fs:ctx.fs repo in match Git_eio.Repository.head repo with | None -> Ok 0 | Some head_hash -> rewrite_at_head repo head_hash user_email with | Failure reason -> Error reason | Eio.Io _ as exn -> err "%a" Eio.Exn.pp exn
let rewrite_ai_attribution ctx dir = match git_root ~cwd:ctx.cwd ~fs:ctx.fs dir with | None -> err_no_git_dir dir | Some git_root -> rewrite_at_root ctx git_root
(* Tabular output helpers *)
let status_icon ok = if ok then "+" else "-"
let format_status_row dir status = let name = Filename.basename dir in Fmt.str "%-20s %s pre-commit %s commit-msg %s ocamlformat %s fmt-enabled" name (status_icon status.has_pre_commit) (status_icon status.has_commit_msg) (status_icon status.has_ocamlformat) (status_icon (not status.formatting_disabled))
let format_status_header () = Fmt.str "%-20s %-11s %-11s %-12s %-11s" "Directory" "pre-commit" "commit-msg" "ocamlformat" "formatting"
let format_status_separator () = String.make 80 '-'
let pp_status_table ppf statuses = Fmt.pf ppf "%s@." (format_status_header ()); Fmt.pf ppf "%s@." (format_status_separator ()); List.iter (fun (dir, status) -> Fmt.pf ppf "%s@." (format_status_row dir status)) statuses
let check_all ctx dirs = List.map (fun dir -> (dir, status_in_dir ctx dir)) dirs