(** 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_no_dune_project dir = Error (Fmt.str "%s: No dune-project found (use --force to override)" dir) let err_no_git_dir dir = Error (Fmt.str "%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 } let pre_commit_hook = {|#!/bin/sh # Auto-format OCaml files with dune before commit # Check if any OCaml files are staged STAGED_ML=$(git diff --cached --name-only --diff-filter=ACM | grep -E '\.(ml|mli|mll|mly)$' || true) if [ -n "$STAGED_ML" ]; then # Run dune fmt if ! dune fmt 2>/dev/null; then echo "Error: dune fmt failed" >&2 exit 1 fi # Check if formatting changed any staged files CHANGED=$(git diff --name-only $STAGED_ML 2>/dev/null || true) if [ -n "$CHANGED" ]; then echo "Files were reformatted by dune fmt:" echo "$CHANGED" echo "" echo "Please review and stage the changes, then commit again." exit 1 fi fi exit 0 |} let commit_msg_hook = {|#!/bin/sh # Check commit message for emojis and remove AI attribution lines COMMIT_MSG_FILE="$1" # Check for emojis using grep with Unicode ranges if grep -qP '[\x{1F600}-\x{1F64F}\x{1F300}-\x{1F5FF}\x{1F680}-\x{1F6FF}\x{1F1E0}-\x{1F1FF}\x{2702}-\x{27B0}\x{24C2}-\x{1F251}]' "$COMMIT_MSG_FILE" 2>/dev/null; then echo "Error: Commit message contains emojis, which are not allowed." >&2 exit 1 fi # Remove AI attribution lines (Co-Authored-By: Claude or similar patterns) if grep -qiE 'Co-Authored-By:.*[Cc]laude' "$COMMIT_MSG_FILE"; then # Use sed to filter out AI attribution lines in-place if [ "$(uname)" = "Darwin" ]; then sed -i '' '/[Cc]o-[Aa]uthored-[Bb]y:.*[Cc]laude/d' "$COMMIT_MSG_FILE" else sed -i '/[Cc]o-[Aa]uthored-[Bb]y:.*[Cc]laude/d' "$COMMIT_MSG_FILE" fi fi exit 0 |} 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 type hooks = { fmt : bool; ai : bool } let all_hooks = { fmt = true; ai = true } 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 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; 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_commit_msg : bool; has_ocamlformat : bool; formatting_disabled : bool; is_ocaml_project : bool; is_git_repo : bool; } 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_commit_msg = false; has_ocamlformat; formatting_disabled; is_ocaml_project; is_git_repo = false; } | 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 let pre_commit_path = Filename.concat hooks_dir "pre-commit" in let commit_msg_path = Filename.concat hooks_dir "commit-msg" in { has_pre_commit = file_exists ~fs:ctx.fs pre_commit_path; has_commit_msg = file_exists ~fs:ctx.fs commit_msg_path; has_ocamlformat; formatting_disabled; is_ocaml_project; is_git_repo = true; } let status ctx () = status_in_dir ctx "." 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 cwd_path = "" || cwd_path = "." then Sys.getcwd () else cwd_path in [ relative ~cwd_path root ] | None -> [] else [] 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 (fun 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) |> 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:"" msg let 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.Repository.read_config repo with | Some config -> (Git.Config.user config).email | None -> None 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 try let content = Eio.Path.load Eio.Path.(fs / global_config_path) in let config = Git.Config.of_string content in (Git.Config.user config).email with Eio.Io _ | Failure _ -> None) (* 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 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 (fun (info : Git.Rev_list.commit_info) -> match Git.Repository.read repo info.hash with | Ok (Git.Value.Commit c) -> if not (is_my_commit ~user_email c) then begin incr skipped_email; None end else let msg = Git.Commit.message c in let has_ai = match msg with | Some m -> message_has_ai_attribution m | None -> false in if has_ai then begin incr found; let hash = String.sub (Git.Hash.to_hex info.hash) 0 7 in let subject = match msg with | Some m -> ( match String.split_on_char '\n' m with | subj :: _ -> String.trim subj | [] -> "") | None -> "" in Some { hash; subject } end else begin incr skipped_no_ai; None end | _ -> None) 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 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 -> ( Log.debug (fun m -> m "check_ai_attribution: git_root=%s" git_root); let repo = Git.Repository.open_repo ~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:"" user_email)); match Git.Repository.head repo with | None -> Log.debug (fun m -> m "check_ai_attribution: no HEAD"); [] | Some head_hash -> Log.debug (fun m -> m "check_ai_attribution: HEAD=%s" (Git.Hash.to_hex head_hash)); let commits = match Git.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); [] in scan_commits_for_ai_attribution repo commits user_email) let current_branch ctx dir = match git_root ~cwd:ctx.cwd ~fs:ctx.fs dir with | None -> None | Some git_root -> let repo = Git.Repository.open_repo ~fs:ctx.fs (Fpath.v git_root) in Git.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 -> let repo = Git.Repository.open_repo ~fs:ctx.fs (Fpath.v git_root) in let branch = match Git.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.Repository.head repo with | Some hash -> Git.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.Rev_list.commit_info) -> match Git.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_commit_history repo commits hash_map = List.iter (fun (info : Git.Rev_list.commit_info) -> match Git.Repository.read repo info.hash with | Ok (Git.Value.Commit c) -> let new_parents = List.map (fun p -> match Hashtbl.find_opt hash_map p with | Some new_p -> new_p | None -> p) (Git.Commit.parents c) in let parents_changed = not (List.equal Git.Hash.equal new_parents (Git.Commit.parents c)) in let msg = Git.Commit.message c in let needs_msg_rewrite = match msg with | Some m -> message_has_ai_attribution m | None -> false in if parents_changed || needs_msg_rewrite then begin let new_msg = match msg 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.Repository.write_commit repo new_commit in Hashtbl.add hash_map info.hash new_hash end | _ -> ()) commits 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 -> ( let repo = Git.Repository.open_repo ~fs:ctx.fs (Fpath.v git_root) in let user_email = user_email ~fs:ctx.fs repo in match Git.Repository.head repo with | None -> Ok 0 | Some head_hash -> let commits = match Git.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.Repository.advance_head repo new_head | None -> ()); Ok (Hashtbl.length needs_rewrite)) (* 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