Hooks.hs

{-# LANGUAGE MultiWayIf #-}

-- | Git pre-commit integration for judgements.
--
-- Seihou owns at most one hook file, recognised by 'hookMarker'. It never
-- overwrites a hook it does not own:
--
-- * No @pre-commit@ hook: Seihou writes its own.
-- * A hook generated by the pre-commit framework: Seihou writes
--   @pre-commit.legacy@, which that framework runs before its own hooks and
--   keeps when it regenerates @pre-commit@. Its formatters fail a commit
--   rather than restage files, so the reviewed index is the committed one.
-- * Any other hook: Seihou renames it, byte for byte (a symlink stays the
--   same literal link), to @pre-commit.seihou-original@ and writes a hook
--   that runs it first and stops the commit if it fails.
--
-- A @core.hooksPath@ inside this repository (git-hooks.nix sets it to
-- @.git/hooks@) is used as is. One that points outside the repository's Git
-- directory and worktree may be shared beyond this checkout, so Seihou
-- refuses and names the line to add instead.
-- Linked worktrees resolve the common hook directory through Git itself.
module Seihou.CLI.Judgement.Hooks
  ( HookPlan (..),
    hookMarker,
    ownedHookScript,
    planHook,
    applyHook,
    renderHookPlan,
    retireOwnedHook,
  )
where

import Control.Exception (IOException, try)
import Data.ByteString qualified as BS
import Data.Generics.Labels ()
import Data.List (isPrefixOf)
import Data.Text qualified as T
import Data.Text.Encoding qualified as TE
import Seihou.CLI.Judgement.Evidence (GitRunner)
import Seihou.Prelude
import System.Directory (canonicalizePath, doesPathExist, getPermissions, pathIsSymbolicLink, removeFile, renamePath, setOwnerExecutable, setPermissions)
import System.FilePath (isAbsolute, normalise, splitDirectories)

-- | The first comment line of every hook file Seihou owns.
hookMarker :: Text
hookMarker = "# seihou-judgement-hook v1"

-- | What adoption will do to the hook directory.
data HookPlan
  = -- | Seihou's hook is already in place at this path.
    HookAlreadyInstalled !FilePath
  | -- | Write Seihou's hook at this path; nothing is there.
    HookInstall !FilePath
  | -- | Write @pre-commit.legacy@ beside a pre-commit framework hook.
    HookBesideFramework !FilePath
  | -- | Preserve the existing hook at the second path and write Seihou's
    -- hook, which runs it first, at the first.
    HookChain !FilePath !FilePath
  deriving stock (Eq, Show, Generic)

renderHookPlan :: HookPlan -> Text
renderHookPlan = \case
  HookAlreadyInstalled p -> "pre-commit hook: already runs seihou check (" <> T.pack p <> ")"
  HookInstall p -> "pre-commit hook: install " <> T.pack p <> " to run seihou check"
  HookBesideFramework p -> "pre-commit hook: install " <> T.pack p <> ", which the pre-commit framework runs before its own hooks"
  HookChain p orig -> "pre-commit hook: keep the existing hook as " <> T.pack orig <> " and install " <> T.pack p <> ", which runs it first and then seihou check"

-- | The hook script. It runs a preserved original hook first, refuses to
-- let a commit through when @seihou@ cannot be found, and then runs every
-- active judgement on the staged changes.
ownedHookScript :: Text
ownedHookScript =
  T.unlines
    [ "#!/bin/sh",
      hookMarker,
      "# Managed by seihou: runs the project's active judgements on the staged",
      "# changes. A nonzero status stops the commit. Remove the judgement with",
      "# seihou to retire this hook; do not edit it in place.",
      "here=$(dirname \"$0\")",
      "if [ -e \"$here/pre-commit.seihou-original\" ]; then",
      "  \"$here/pre-commit.seihou-original\" \"$@\" || exit $?",
      "fi",
      "if ! command -v seihou >/dev/null 2>&1; then",
      "  echo \"seihou check: the seihou executable is not on PATH, so the staged changes were not checked; the commit is stopped.\" >&2",
      "  exit 1",
      "fi",
      "exec seihou check --staged"
    ]

-- | Decide the hook change for the repository at @root@ without writing.
planHook :: FilePath -> GitRunner -> IO (Either Text HookPlan)
planHook root git = do
  hooksPathSetting <- git ["config", "--get", "core.hooksPath"]
  let hooksPathSet = either (const False) (not . T.null . T.strip . TE.decodeUtf8) hooksPathSetting
  located <- traverse (fmap (fmap resolve)) [git ["rev-parse", "--git-path", "hooks"], git ["rev-parse", "--git-common-dir"], git ["rev-parse", "--show-toplevel"]]
  case sequence located of
    Left err -> pure (Left ("cannot locate the Git hook directory: " <> err))
    Right [rawDir, commonDir, top] -> do
      dir <- canonicalizePath rawDir
      owned <- mapM canonicalizePath [commonDir, top]
      if hooksPathSet && not (any (\base -> splitDirectories base `isPrefixOf` splitDirectories dir) owned)
        then pure (Left ("core.hooksPath points at " <> T.pack dir <> ", outside this repository, so its hooks may be shared beyond this checkout; add 'seihou check --staged' to that pre-commit hook yourself"))
        else planIn rawDir
    Right _ -> pure (Left "cannot locate the Git hook directory")
  where
    resolve raw =
      let rel = T.unpack (T.strip (TE.decodeUtf8 raw))
       in normalise (if isAbsolute rel then rel else root </> rel)
    planIn dir = do
      let hook = dir </> "pre-commit"
          legacy = dir </> "pre-commit.legacy"
          original = dir </> "pre-commit.seihou-original"
      present <- doesPathExist hook
      if not present
        then pure (Right (HookInstall hook))
        else do
          link <- pathIsSymbolicLink hook
          body <- if link then pure Nothing else readMaybe hook
          case body of
            Just b
              | hookMarker `T.isInfixOf` b -> pure (Right (HookAlreadyInstalled hook))
              | "File generated by pre-commit" `T.isInfixOf` b -> do
                  legacyPresent <- doesPathExist legacy
                  legacyBody <- if legacyPresent then readMaybe legacy else pure Nothing
                  pure $ case legacyBody of
                    _ | not legacyPresent -> Right (HookBesideFramework legacy)
                    Just lb | hookMarker `T.isInfixOf` lb -> Right (HookAlreadyInstalled legacy)
                    _ -> Left ("the pre-commit framework already runs " <> T.pack legacy <> "; add 'seihou check --staged' to it yourself")
            _ -> do
              taken <- doesPathExist original
              pure $
                if taken
                  then Left (T.pack original <> " already exists; add 'seihou check --staged' to the existing pre-commit hook yourself")
                  else Right (HookChain hook original)
    readMaybe p =
      (try (BS.readFile p) :: IO (Either IOException BS.ByteString)) <&> \case
        Right bs -> Just (TE.decodeUtf8With (\_ _ -> Just '?') bs)
        Left _ -> Nothing

-- | Carry out a plan. Writing happens only after the plan was re-derived
-- from the same directory state, so a changed hook is never clobbered.
applyHook :: HookPlan -> IO (Either Text ())
applyHook plan =
  try act <&> \case
    Left (e :: IOException) -> Left ("could not install the pre-commit hook: " <> T.pack (show e))
    Right () -> Right ()
  where
    act = case plan of
      HookAlreadyInstalled _ -> pure ()
      HookInstall p -> writeHook p
      HookBesideFramework p -> writeHook p
      HookChain p orig -> renamePath p orig >> writeHook p
    writeHook p = do
      BS.writeFile p (TE.encodeUtf8 ownedHookScript)
      perms <- getPermissions p
      setPermissions p (setOwnerExecutable True perms)

-- | Remove Seihou's hook once no judgement is active. Only a byte-identical
-- owned hook is removed; a preserved original is restored in its place. An
-- edited hook is left alone and reported.
retireOwnedHook :: FilePath -> GitRunner -> IO (Either Text [Text])
retireOwnedHook root git =
  git ["rev-parse", "--git-path", "hooks"] >>= \case
    Left err -> pure (Left ("cannot locate the Git hook directory: " <> err))
    Right raw -> do
      let rel = T.unpack (T.strip (TE.decodeUtf8 raw))
          dir = normalise (if isAbsolute rel then rel else root </> rel)
          hook = dir </> "pre-commit"
          legacy = dir </> "pre-commit.legacy"
          original = dir </> "pre-commit.seihou-original"
      outcome <-
        try $ do
          legacyMsg <- retireFile legacy Nothing
          hookMsg <- retireFile hook (Just original)
          pure (legacyMsg <> hookMsg)
      pure $ case outcome of
        Left (e :: IOException) -> Left ("could not retire the pre-commit hook: " <> T.pack (show e))
        Right msgs -> Right msgs
  where
    retireFile path restore = do
      present <- doesPathExist path
      link <- if present then pathIsSymbolicLink path else pure False
      if not present || link
        then pure []
        else do
          body <- TE.decodeUtf8With (\_ _ -> Just '?') <$> BS.readFile path
          if
            | body == ownedHookScript -> do
                restored <- maybe (pure False) doesPathExist restore
                case restore of
                  Just orig | restored -> renamePath orig path >> pure ["restored the original pre-commit hook"]
                  _ -> removeFile path >> pure ["removed " <> T.pack path]
            | hookMarker `T.isInfixOf` body -> pure ["left " <> T.pack path <> " in place because it was edited; remove its seihou check line yourself"]
            | otherwise -> pure []