ocaml-precommit / lib / precommit.ml

(** 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:"<none>" 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