diff --git a/Changelog.md b/Changelog.md new file mode 100644 --- /dev/null +++ b/Changelog.md @@ -0,0 +1,1 @@ +# claude-gate changelog diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2025 Jappie Klooster + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,59 @@ +-- | The claude-gate executable: one binary, four subcommands. +-- +-- Claude Code wires each hook to a subcommand in settings.json: +-- record PostToolUse(Write|Edit|MultiEdit|NotebookEdit) +-- reset UserPromptSubmit +-- stop-gate Stop +-- +-- The fourth, @critique@, is not wired to a hook: it runs ONLY the adversarial +-- critique phase against the same hook event on stdin, so the nested reviewer +-- call can be exercised and debugged in isolation (e.g. to see whether the +-- nested @claude@ authenticates and answers, rather than hanging) without the +-- dumbify and rule-review phases around it. +module Main (main) where + +import Control.Monad (join) +import Claude.Gate.Critique (runCritique) +import Claude.Gate.HookProtocol (HookEvent (sessionId, transcriptPath), readHookEvent) +import Claude.Gate.RecordEdit (recordEdit) +import Claude.Gate.StopGate (runStopGate) +import Claude.Gate.TurnState (ensureStateDir, resetState, turnPaths) +import Options.Applicative + +main :: IO () +-- Each subcommand parses to the IO action for its hook, so execParser yields an +-- IO (IO ()); join runs the chosen action. +main = join (execParser (info (subcommands <**> helper) description)) + +description :: InfoMod a +description = fullDesc <> progDesc "Claude Code end-of-turn gate hooks (record, reset, stop-gate)" + +-- | Each subcommand parses no options and yields the IO action for its hook. +subcommands :: Parser (IO ()) +subcommands = + subparser + ( command "record" (info (pure recordEdit) (progDesc "PostToolUse: record an edit onto the review stack")) + <> command "reset" (info (pure resetTurnState) (progDesc "UserPromptSubmit: wipe the previous turn's state")) + <> command "stop-gate" (info (pure runStopGate) (progDesc "Stop: rule review, then verification")) + <> command "critique" (info (pure runCritiqueOnly) (progDesc "Run only the adversarial critique phase (for debugging the nested reviewer)")) + ) + +-- | Run the critique phase standalone against the hook event on stdin. This is +-- the same call 'runStopGate' makes for phase 1, lifted out of the phase chain +-- so the nested reviewer can be reproduced on its own. It reads the hook event, +-- prepares the turn state dir, and runs the critique against the live transcript +-- and the edits already recorded this turn. +runCritiqueOnly :: IO () +runCritiqueOnly = do + event <- readHookEvent + paths <- turnPaths (sessionId event) + ensureStateDir paths + runCritique (sessionId event) (transcriptPath event) paths + +-- | UserPromptSubmit: wipe the previous turn's review stack and verify-done +-- flag so they do not leak into the new turn. +resetTurnState :: IO () +resetTurnState = do + event <- readHookEvent + paths <- turnPaths (sessionId event) + resetState paths diff --git a/claude-gate.cabal b/claude-gate.cabal new file mode 100644 --- /dev/null +++ b/claude-gate.cabal @@ -0,0 +1,142 @@ +cabal-version: 3.0 + +name: claude-gate +version: 1.0.0 +synopsis: Hook gate that reviews and records edits from nested Claude Code sessions +description: + A Claude Code hook-protocol gate. It intercepts edits made by nested Claude + sessions, renders their diffs, tracks per-turn state, and drives the + review, critique and dumbify passes that decide whether an edit is allowed + through. +category: Development +homepage: https://github.com/jappeace/vibes#readme +bug-reports: https://github.com/jappeace/vibes/issues +author: Jappie Klooster +maintainer: hi@jappie.me +copyright: 2026 Jappie Klooster +license: MIT +license-file: LICENSE +build-type: Simple +extra-doc-files: + Changelog.md + +source-repository head + type: git + location: https://github.com/jappeace/vibes + +-- Decision: -Werror lives behind a manual flag, default False. cabal check +-- rejects an unconditional -Werror (future GHCs add warnings that would break +-- the package), so the flag keeps `cabal check` green while CI and the nix +-- build still compile warning-clean by turning it on (see nix/hpkgs.nix and +-- cabal.project). Alternative considered: dropping -Werror entirely, rejected +-- because it would let warnings rot in. +flag werror + description: Turn warnings into errors. Off by default; CI and the nix build enable it. + default: False + manual: True + +common common-options + default-extensions: + EmptyCase + FlexibleContexts + FlexibleInstances + InstanceSigs + MultiParamTypeClasses + LambdaCase + MultiWayIf + NamedFieldPuns + TupleSections + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveLift + DeriveTraversable + DerivingStrategies + GeneralizedNewtypeDeriving + StandaloneDeriving + OverloadedStrings + ScopedTypeVariables + TypeApplications + NumericUnderscores + ImportQualifiedPost + + ghc-options: + -O2 -Wall -Wincomplete-uni-patterns + -Wincomplete-record-updates -Widentities -Wredundant-constraints + -Wcpp-undef -fwarn-tabs -Wpartial-fields + -fdefer-diagnostics -Wunused-packages + -fno-omit-yields + + if flag(werror) + ghc-options: -Werror + + build-depends: + base >=4.9.1.0 && <4.22 + + default-language: Haskell2010 + +library + import: common-options + exposed-modules: + Claude.Gate.HookProtocol + Claude.Gate.Edit + Claude.Gate.TurnState + Claude.Gate.RecordEdit + Claude.Gate.DiffRender + Claude.Gate.Corpus + Claude.Gate.FileContext + Claude.Gate.Repo + Claude.Gate.SpawnAnnotation + Claude.Gate.GateConfig + Claude.Gate.EditStack + Claude.Gate.NestedClaude + Claude.Gate.Transcript + Claude.Gate.ReviewPrompt + Claude.Gate.Dumbify + Claude.Gate.Critique + Claude.Gate.RuleReview + Claude.Gate.StopGate + other-modules: + Paths_claude_gate + autogen-modules: + Paths_claude_gate + hs-source-dirs: + src + build-depends: + aeson < 2.3, + annotated-exception < 0.4, + bytestring < 0.13, + text < 2.2, + directory < 1.4, + filepath < 1.6, + typed-process < 0.3, + safe-exceptions < 0.2 + +executable claude-gate + import: common-options + main-is: Main.hs + hs-source-dirs: + app + build-depends: + claude-gate, + optparse-applicative < 0.19 + ghc-options: -Wno-unused-packages -threaded -rtsopts "-with-rtsopts=-N" + +test-suite unit + import: common-options + type: exitcode-stdio-1.0 + main-is: Test.hs + ghc-options: -Wno-unused-packages -threaded -rtsopts "-with-rtsopts=-N" + hs-source-dirs: + test + build-depends: + tasty < 1.6, + tasty-hunit < 0.11, + tasty-hedgehog < 1.5, + hedgehog < 1.6, + claude-gate, + aeson < 2.3, + bytestring < 0.13, + text < 2.2, + directory < 1.4, + filepath < 1.6 diff --git a/src/Claude/Gate/Corpus.hs b/src/Claude/Gate/Corpus.hs new file mode 100644 --- /dev/null +++ b/src/Claude/Gate/Corpus.hs @@ -0,0 +1,85 @@ +-- | Assemble the rules corpus the reviewer is checked against. +-- +-- The corpus is the global CLAUDE.md, the project CLAUDE.md (if it is a +-- different file), and the SKILL.md of each skill whose rules could apply to +-- the file types touched this turn. Attaching every skill was almost all of the +-- old prompt and pure latency, so only language skills matching the touched +-- extensions are selected; the two CLAUDE.md files are always included. +module Claude.Gate.Corpus + ( selectSkills + , buildCorpus + ) where + +import Data.List (isSuffixOf, nub, sort) +import Data.Text (Text) +import Data.Text qualified as Text +import Data.Text.IO qualified as TextIO +import Claude.Gate.Repo (gitRoot) +import System.Directory (doesFileExist, getHomeDirectory) +import System.FilePath (takeDirectory, ()) + +-- | Skill names whose rules are relevant to the touched file types, sorted and +-- deduplicated. Pure so the mapping can be tested directly. +selectSkills :: [FilePath] -> [Text] +selectSkills = sort . nub . concatMap skillsForPath + +skillsForPath :: FilePath -> [Text] +skillsForPath path + | any (`isSuffixOf` path) haskellExtensions = haskellSkills + | ".nix" `isSuffixOf` path = nixSkills + | otherwise = [] + +haskellExtensions :: [FilePath] +haskellExtensions = [".hs", ".lhs", ".hsig", ".cabal"] + +haskellSkills :: [Text] +haskellSkills = + ["haskell-project", "haskell-backpack", "unwitch-conversions", "verify-test-fails", "error-messages"] + +nixSkills :: [Text] +nixSkills = ["nix", "ci-nix"] + +-- | Build the corpus text for the files touched this turn. Reads the two +-- CLAUDE.md files and the selected skills from disk. +buildCorpus :: [FilePath] -> IO Text +buildCorpus touchedPaths = do + home <- getHomeDirectory + let globalClaude = home ".claude" "CLAUDE.md" + globalSection <- fileSection ("=== " <> Text.pack globalClaude <> " ===") globalClaude + projectSection <- projectClaudeSection globalClaude touchedPaths + skillSections <- mapM (skillSection home) (selectSkills touchedPaths) + pure (Text.concat (globalSection <> projectSection <> concat skillSections)) + +-- | The project CLAUDE.md, resolved from the git root of the first touched +-- file, included only if it exists and is a different file from the global one. +projectClaudeSection :: FilePath -> [FilePath] -> IO [Text] +projectClaudeSection globalClaude touchedPaths = case touchedPaths of + [] -> pure [] + (firstFile : _) -> do + maybeRoot <- gitRoot (takeDirectory firstFile) + case maybeRoot of + Nothing -> pure [] + Just root -> + let projectClaude = root "CLAUDE.md" + in if projectClaude == globalClaude + then pure [] + else fileSection ("=== " <> Text.pack projectClaude <> " ===") projectClaude + +skillSection :: FilePath -> Text -> IO [Text] +skillSection home skillName = + fileSection + ("=== skill: " <> skillName <> " ===") + (home ".claude" "skills" Text.unpack skillName "SKILL.md") + +-- | A labelled section for a file, or nothing if the file is absent. Absence is +-- expected (not every skill or project has the file), so it is a legitimate +-- empty result rather than a swallowed error. +fileSection :: Text -> FilePath -> IO [Text] +fileSection heading path = do + present <- doesFileExist path + if present + then do + body <- TextIO.readFile path + pure ["\n" <> heading <> "\n" <> body] + else pure [] + diff --git a/src/Claude/Gate/Critique.hs b/src/Claude/Gate/Critique.hs new file mode 100644 --- /dev/null +++ b/src/Claude/Gate/Critique.hs @@ -0,0 +1,389 @@ +-- | Phase 1: adversarial critique. +-- +-- A fresh independent critic (default Opus, full tools and MCP) tries to PROVE +-- THE WORKER WRONG about both the code it changed and the claims it made this +-- turn, by running tests and commands and searching authoritative sources. It +-- also flags any factual claim it can find no supporting source for, since an +-- assertion the worker cannot back is itself evidence. The prompt is anchored to +-- ground truth (the round number and the repo's real commit history) so the +-- critic judges the current state and maps CI runs to commits by sha rather than +-- reconstructing the order from run timestamps. A substantiated +-- CHALLENGE blocks the turn. The critic is an advisor, not a wall: +-- exactly like dumbify, convergence is observed via the edit stack, so a turn +-- with no new edits (the worker stood by its work) is a shrug that ends the +-- debate. Runs after dumbify (so it verifies the canary's refactor too) and +-- before rule review (so its fixes land on the stack and get rule-checked). +-- +-- The claims are read from the transcript by POLLING ('readTurnClaims'): +-- Claude Code can fire the Stop hook before the turn's final assistant message +-- is flushed to the transcript file, and a single immediate read loses that +-- race. A turn that still offers neither claims nor edits after polling is an +-- EMPTY DOSSIER and fails loudly ('classifyDossier'): a critic spawned with +-- nothing to refute can only answer OK, and recording that OK as approval +-- would be a false green stamp. +module Claude.Gate.Critique + ( runCritique + , critiqueDiffBlock + , recentClaims + , critiqueAnchor + , retryWhileEmpty + , classifyDossier + , CritiqueDossier(..) + , EditPresence(..) + , RoundBudget(..) + ) where + +import Control.Concurrent (threadDelay) +import Control.Monad (when) +import Data.Maybe (fromMaybe, isJust) +import Data.Text (Text) +import Data.Text qualified as Text +import Data.Text.IO qualified as TextIO +import Claude.Gate.DiffRender (renderDiffs) +import Claude.Gate.EditStack (readEdits, stackFilePaths) +import Claude.Gate.GateConfig (envInt, envStr, phaseDisabled) +import Claude.Gate.HookProtocol (BlockReason (BlockReason), blockAndExit) +import Claude.Gate.NestedClaude + ( GateFailure (GateFailure, failureBlockReason, failureHeadline, failureLogBody, failureUserNotice) + , NestedResult (NestedBroken, NestedOutput) + , Reviewer (Reviewer) + , runNested + , surfaceGateFailure + , surfaceNestedFailure + ) +import Claude.Gate.Repo (commitHistory, repoForFilesOrCwd) +import Claude.Gate.ReviewPrompt (maxDiffPromptChars) +import Claude.Gate.Transcript (turnAssistantText) +import Claude.Gate.TurnState + ( TurnPaths (critiqueApproved, critiqueBroke, critiqueDone, critiqueEditmark, critiquePrev, critiqueRound, reviewStack) + , fileNonEmpty + , flagExists + , readCounter + , readMark + , stackLineCount + , writeCounter + , writeFlag + ) +import System.Directory (doesFileExist, findExecutable) + +-- | The critic refutes both the code and the claims, so it runs on EVERY turn, +-- including conversational ones with no edits. A shrug (no new edits since the +-- last challenge) ends the debate within the turn. +maxCritiqueClaimChars :: Int +maxCritiqueClaimChars = 16_000 + +-- | Keep the most recent claims within the character budget. The worker's prose +-- accumulates across a turn's critique rounds (a block is not a turn boundary, +-- so 'turnAssistantText' keeps growing), and it is chronological. Trimming from +-- the FRONT would hand the critic the OLDEST claims (round 1, the first CI runs) +-- and drop the newest (the current HEAD's claims), so the critic judges stale +-- claims and misattributes runs. Trim from the end so the current round survives. +recentClaims :: Int -> Text -> Text +recentClaims = Text.takeEnd + +-- | Which critique round this is, and the cap it counts against. The two travel +-- together through the anchor, the block reason, and 'handleChallenge'; bundling +-- them keeps the round and its cap from being swapped at a call site (both are +-- 'Int'), and threading one value keeps the number the critic is told identical +-- to the number the worker is told. +data RoundBudget = RoundBudget + { thisRound :: Int + , maxRounds :: Int + } + +-- | Whether this turn recorded file edits onto the review stack. The fact +-- travels through the whole phase (mark computation, dossier classification, +-- diff rendering), so it gets named constructors rather than a bare Bool. +data EditPresence = EditsRecorded | NoEditsRecorded + deriving stock (Eq, Show) + +editPresence :: TurnPaths -> IO EditPresence +editPresence paths = do + stackNonEmpty <- fileNonEmpty (reviewStack paths) + pure (if stackNonEmpty then EditsRecorded else NoEditsRecorded) + +runCritique :: Text -> Maybe FilePath -> TurnPaths -> IO () +runCritique session transcript paths = do + disabled <- phaseDisabled "CLAUDE_SKIP_CRITIQUE" + done <- flagExists (critiqueDone paths) + claudeAvailable <- isJust <$> findExecutable "claude" + when (not disabled && not done && claudeAvailable) $ do + edits <- editPresence paths + currentMark <- case edits of + EditsRecorded -> stackLineCount (reviewStack paths) + NoEditsRecorded -> pure 0 + previousMark <- readMark (critiqueEditmark paths) + if previousMark == Just currentMark + then + -- The critic already challenged this turn and the worker made no new + -- edits since: it stood by its work. A shrug ends the debate. + writeFlag (critiqueDone paths) + else runCritiqueRound session transcript paths edits currentMark + +runCritiqueRound :: Text -> Maybe FilePath -> TurnPaths -> EditPresence -> Int -> IO () +runCritiqueRound session transcript paths edits currentMark = do + claims <- recentClaims maxCritiqueClaimChars <$> readTurnClaims transcript + case classifyDossier claims edits of + EmptyDossier -> surfaceEmptyDossier session transcript paths + DossierReady -> runCriticOnDossier session paths edits currentMark claims + +-- Decision: poll the transcript for the turn's claims instead of reading it +-- once. Claude Code fires the Stop hook before it has flushed the turn's final +-- assistant message to the transcript file (observed lag ~0.7s), so a single +-- immediate read handed the critic an empty dossier it could only wave OK at. +-- Alternatives considered: one fixed sleep before reading (pays the full delay +-- on every turn, even when the flush already happened) and filesystem watching +-- (a new dependency for a bounded, sub-second race). Polling costs nothing on +-- the common path because the first non-blank read returns immediately. +claimsFlushAttempts :: Int +claimsFlushAttempts = 5 + +-- | The pause between transcript polls. The observed flush lag is well under a +-- second, so the second attempt normally wins the race. +claimsFlushDelayMicroseconds :: Int +claimsFlushDelayMicroseconds = 1_000_000 + +-- | The worker's prose for this turn, polled per the Decision above. A Stop +-- event without a transcript path yields empty claims immediately; whether an +-- empty result is fatal is decided by 'classifyDossier', not here. +readTurnClaims :: Maybe FilePath -> IO Text +readTurnClaims Nothing = pure "" +readTurnClaims (Just path) = + retryWhileEmpty claimsFlushAttempts claimsFlushDelayMicroseconds (turnAssistantText path) + +-- | Run the read until it yields non-blank text, up to the attempt budget, +-- sleeping the given microseconds between attempts. The final attempt's result +-- is returned as-is (possibly still blank); the caller decides what that means. +retryWhileEmpty :: Int -> Int -> IO Text -> IO Text +retryWhileEmpty attempts delayMicroseconds readAction = do + result <- readAction + if not (Text.null (Text.strip result)) || attempts <= 1 + then pure result + else do + threadDelay delayMicroseconds + retryWhileEmpty (attempts - 1) delayMicroseconds readAction + +-- | Whether the turn gives the critic anything to refute. Claims that are all +-- whitespace count as absent, exactly like a missing transcript. +data CritiqueDossier = EmptyDossier | DossierReady + deriving stock (Eq, Show) + +classifyDossier :: Text -> EditPresence -> CritiqueDossier +classifyDossier claims edits = case edits of + EditsRecorded -> DossierReady + NoEditsRecorded -> + if Text.null (Text.strip claims) + then EmptyDossier + else DossierReady + +-- | Fail loudly on an empty dossier, mirroring 'surfaceNestedFailure': log it +-- durably and block the Stop once per turn with a user-visible notice. On a +-- repeat occurrence within the turn the phase gives up WITHOUT writing the +-- approved flag, so the missing critique is never recorded as a clean pass. +surfaceEmptyDossier :: Text -> Maybe FilePath -> TurnPaths -> IO () +surfaceEmptyDossier session transcript paths = do + surfaceGateFailure session (emptyDossierFailure transcript) (critiqueBroke paths) + writeFlag (critiqueDone paths) + +-- | The empty dossier described for 'surfaceGateFailure'. The log records the +-- transcript path the hook event carried (or its absence), which is the first +-- thing to check when debugging why the claims came up empty. +emptyDossierFailure :: Maybe FilePath -> GateFailure +emptyDossierFailure transcript = + GateFailure + { failureHeadline = "critique got an empty dossier (no claims, no edits)" + , failureLogBody = "transcript_path=" <> maybe "(absent from Stop event)" Text.pack transcript + , failureBlockReason = emptyDossierReason + , failureUserNotice = emptyDossierNotice + } + +emptyDossierReason :: Text +emptyDossierReason = + "GATE INPUT FAILURE in the critique phase: even after polling the transcript, \ + \this turn shows no assistant text and has no recorded edits, so there was \ + \nothing to hand the critic and this turn was NOT critiqued. An empty dossier \ + \is never a clean pass. Likely causes: the Stop event carried no \ + \transcript_path, or the transcript flush lagged past the polling window. \ + \This warning fires once per turn; you may continue after acknowledging it." + +emptyDossierNotice :: Text +emptyDossierNotice = + "claude-gate: the critique phase found no claims in the transcript and no \ + \edits even after polling, so this turn was NOT critiqued. Details in the \ + \gate failure log ($CLAUDE_GATE_FAILURE_LOG, default ~/.claude/gate-failures.log)." + +-- | Spawn the nested critic on a non-empty dossier and act on its verdict. +runCriticOnDossier :: Text -> TurnPaths -> EditPresence -> Int -> Text -> IO () +runCriticOnDossier session paths edits currentMark claims = do + files <- stackFilePaths (reviewStack paths) + diffs <- critiqueDiffBlock edits (reviewStack paths) + repo <- repoForFilesOrCwd files + history <- maybe (pure Nothing) commitHistory repo + previous <- readPreviousChallenges (critiquePrev paths) + previousRound <- readCounter (critiqueRound paths) + roundCap <- envInt "CLAUDE_CRITIQUE_MAX_ROUNDS" 2 + timeoutSecs <- envInt "CLAUDE_CRITIQUE_TIMEOUT" 1200 + model <- envStr "CLAUDE_CRITIQUE_MODEL" "claude-opus-4-8" + -- The round is computed once and threaded to both the prompt and the block, so + -- the critic is told the same round the worker is (the nested critic runs with + -- the critique phase disabled, so it never bumps this counter mid-round). + let budget = RoundBudget { thisRound = previousRound + 1, maxRounds = roundCap } + reviewer = Reviewer model False timeoutSecs repo + prompt = critiquePrompt (critiqueAnchor budget history) previous claims diffs + result <- runNested reviewer prompt + case result of + NestedBroken exitCode emptyOut stderrText -> do + surfaceNestedFailure session "critique" model exitCode emptyOut stderrText (critiqueBroke paths) + writeFlag (critiqueDone paths) + NestedOutput output -> + if hasChallenge output + then handleChallenge paths model output currentMark budget + else do + -- Clean OK: critique is done and this turn cleared. + writeFlag (critiqueDone paths) + writeFlag (critiqueApproved paths) + +handleChallenge :: TurnPaths -> Text -> Text -> Int -> RoundBudget -> IO () +handleChallenge paths model output currentMark budget = do + writeCounter (critiqueRound paths) (thisRound budget) + if thisRound budget <= maxRounds budget + then do + -- Record this challenge and the stack size it was based on. No new edits + -- before the next Stop reads as a shrug; new edits earn a fresh critique. + TextIO.writeFile (critiquePrev paths) output + writeCounter (critiqueEditmark paths) currentMark + blockAndExit (BlockReason (critiqueBlockReason model budget output)) + else + -- Round cap reached: stop debating without marking approved (the concern + -- is unresolved), and let rule review proceed. + writeFlag (critiqueDone paths) + +-- | The diff block shown to the critic. Only a turn that recorded edits has a +-- review stack on disk; a conversational turn has none, and reading the absent +-- stack would crash this phase before the critic runs (the critic is meant to +-- run on every turn, edits or not). So read the stack only when there are edits, +-- and otherwise hand the critic the explicit no-edits placeholder. +critiqueDiffBlock :: EditPresence -> FilePath -> IO Text +critiqueDiffBlock edits stackPath = case edits of + EditsRecorded -> renderDiffs <$> readEdits stackPath + NoEditsRecorded -> pure "(no file edits this turn)" + +readPreviousChallenges :: FilePath -> IO (Maybe Text) +readPreviousChallenges path = do + present <- doesFileExist path + if present then Just <$> TextIO.readFile path else pure Nothing + +hasChallenge :: Text -> Bool +hasChallenge output = any ("CHALLENGE:" `Text.isPrefixOf`) (Text.lines output) + +critiquePrompt :: Text -> Maybe Text -> Text -> Text -> Text +critiquePrompt anchor previous claims diffs = + Text.concat + [ critiqueHeader + , "\n=== GROUND TRUTH (authoritative; use this, do not reconstruct it from timestamps) ===\n" + , anchor + , maybe "" ("\n=== YOUR PREVIOUS CHALLENGES (the worker has since responded and may have changed code or claims; only re-raise what still holds and you can still substantiate) ===\n" <>) previous + , "\n=== WHAT THE WORKER CLAIMS THIS TURN ===\n" + , if Text.null claims then "(no transcript claims available)\n" else claims <> "\n" + , "\n=== CODE CHANGES THIS TURN (may be empty) ===\n" + , Text.take maxDiffPromptChars diffs + ] + +-- | The ground-truth anchor: which round this critique is, and the repo's real +-- commit history. A critic with full tools cross-checks external CI runs; stating +-- the round stops it renumbering the debate from the worker's prose, and the +-- commit history (HEAD first, with each commit's timestamp) lets it map a run to +-- a commit by sha instead of inferring the order from run start times. A missing +-- history is rendered as an explicit placeholder, never dropped silently. +critiqueAnchor :: RoundBudget -> Maybe Text -> Text +critiqueAnchor RoundBudget { thisRound, maxRounds } history = + Text.concat + [ "This is critique round ", Text.pack (show thisRound), " of at most " + , Text.pack (show maxRounds), " this turn. The worker's prose this turn may recount" + , " earlier rounds; judge the CURRENT state and keep this round numbering, do not" + , " renumber the debate.\n" + , "Repo commit history, newest first, one commit per line as" + , " \" \"; the FIRST line is HEAD." + , " Map any CI run to a commit by its sha (a run can start on an older HEAD and" + , " finish after a newer commit exists, so run start time is not commit order):\n" + , fromMaybe "(git commit history unavailable)" history + , "\n" + ] + +critiqueHeader :: Text +critiqueHeader = + "You are an adversarial correctness critic. A different, larger Claude Code agent\n\ + \just finished a turn. Below are the code changes it made (possibly none) and the\n\ + \claims it made about what it did or found. Your single job is to PROVE THE WORKER\n\ + \WRONG, by any means necessary. Assume both the code and the claims are wrong until\n\ + \you have evidence otherwise. A factual claim you can neither reproduce nor find any\n\ + \authoritative source for does not earn the benefit of the doubt: an assertion the\n\ + \worker cannot back is a weakness to surface, not something to wave through.\n\ + \\n\ + \Use every tool you have to gather counter-evidence:\n\ + \\n\ + \- For code: write and run tests, run the type-checker/build, run a one-off\n\ + \ command. Look for logic errors that still typecheck (wrong boundaries, inverted\n\ + \ conditions, unhandled cases, off-by-one, broken invariants, missing coverage)\n\ + \ and ways the change breaks the rest of the codebase.\n\ + \- For prose/claims: check them against reality. Run the command the worker says\n\ + \ it ran. Search the web and read authoritative sources, both to contradict a\n\ + \ factual claim and to look for the support the worker never cited. A claim of\n\ + \ \"I verified X\" that was never actually demonstrated is itself suspect. When\n\ + \ the worker states a checkable fact as established (attributing a view to\n\ + \ someone, quoting a spec, describing what a tool or library does), actively try\n\ + \ to find the authoritative source that backs it.\n\ + \\n\ + \Rank your counter-evidence by authority, and gather as much as you can:\n\ + \\n\ + \- Strongest: a failing test, a non-zero exit code, a command you ran and its\n\ + \ output. A machine cannot misreport these.\n\ + \- Good: an authoritative external source (documentation, a standard, a primary\n\ + \ source) that contradicts the claim. Cite the URL and quote the line.\n\ + \- Also evidence: the ABSENCE of a source. If the worker asserts a checkable fact\n\ + \ as established and you genuinely search for it (authoritative docs, the primary\n\ + \ source, the web) and find nothing that supports it, report that. Your evidence\n\ + \ is the search itself: name the queries you ran and the sources you checked, show\n\ + \ they turned up nothing backing the claim, and ask why the worker is asserting it.\n\ + \ Absence only counts once you have actually looked, so \"I did not look\" is not\n\ + \ \"no source exists\". This is for facts presented as established, not for the\n\ + \ worker's own clearly-labelled opinions, recommendations, or plans.\n\ + \- More independent counter-evidence is stronger than one: a test AND a source\n\ + \ beats either alone.\n\ + \- Not evidence: your own opinion or doubt with no search behind it. If you have\n\ + \ neither a test, a command, a cited source, nor a documented failed search, DROP\n\ + \ it.\n\ + \\n\ + \Do not add files to the repository under review; use /tmp for scratch\n\ + \reproducers. Do not flag style, naming, or \"could be cleaner\".\n\ + \\n\ + \Response format, no markdown:\n\ + \\n\ + \- If you cannot prove anything wrong: respond with the single line OK.\n\ + \- Otherwise, one block per item you are challenging:\n\ + \\n\ + \ CHALLENGE: \n\ + \ CLAIM: \n\ + \ EVIDENCE: \n\ + \ SEVERITY: blocker | major | minor\n\ + \\n\ + \Separate blocks with a blank line." + +critiqueBlockReason :: Text -> RoundBudget -> Text -> Text +critiqueBlockReason model RoundBudget { thisRound, maxRounds } output = + Text.concat + [ "A fresh adversarial ", model, " critic tried to prove your work wrong this turn, " + , "using tests and sources, and produced the counter-evidence below (round " + , Text.pack (show thisRound), " of ", Text.pack (show maxRounds) + , "). This critic is an advisor, not a wall: you are the final judge. For each challenge, either:\n" + , " 1. Agree: fix the code, correct the claim, or (for an unsourced factual claim) cite a source or retract it. Code fixes are re-critiqued and rule-checked automatically.\n" + , " 2. Disagree: rebut it with STRONGER evidence than the critic brought (run the test yourself, cite a better source), or simply stand by your work. Do not just assert.\n" + , "Engage every challenge, then decide. If you make no further edits, the gate takes that as your considered judgement and moves on (a shrug is allowed); it does not re-litigate. Set CLAUDE_SKIP_CRITIQUE=1 to disable this gate.\n" + , "\n--- critic challenges ---\n" + , output + , "\n--- end critic challenges ---" + ] diff --git a/src/Claude/Gate/DiffRender.hs b/src/Claude/Gate/DiffRender.hs new file mode 100644 --- /dev/null +++ b/src/Claude/Gate/DiffRender.hs @@ -0,0 +1,49 @@ +-- | Render recorded edits as labelled diff blocks for the reviewer prompt. +-- +-- Showing the diff (the old and new text) rather than the whole file keeps the +-- prompt small and points the reviewer at exactly the text the agent wrote. +-- The reviewer is told to only flag text in a "with"/"new content" section. +module Claude.Gate.DiffRender + ( renderDiffs + ) where + +import Data.Text (Text) +import Data.Text qualified as Text +import Claude.Gate.Edit (Edit (..), Replacement (..)) + +-- | Render a turn's edits as one labelled block per edit, in order. +renderDiffs :: [Edit] -> Text +renderDiffs = Text.concat . map renderOne + +renderOne :: Edit -> Text +renderOne edit = + Text.concat + [ "=== FILE: ", Text.pack (editPath edit), " (via ", toolLabel edit, ") ===\n" + , editBody edit + , "\n" + ] + +editPath :: Edit -> FilePath +editPath = \case + SingleEdit path _ -> path + MultiEditFile path _ -> path + WriteFileContent path _ -> path + NotebookCellSource path _ -> path + +toolLabel :: Edit -> Text +toolLabel = \case + SingleEdit _ _ -> "Edit" + MultiEditFile _ _ -> "MultiEdit" + WriteFileContent _ _ -> "Write" + NotebookCellSource _ _ -> "NotebookEdit" + +editBody :: Edit -> Text +editBody = \case + SingleEdit _ replacement -> renderReplacement replacement + MultiEditFile _ replacements -> Text.intercalate "\n" (map renderReplacement replacements) + WriteFileContent _ content -> "--- new content ---\n" <> content + NotebookCellSource _ source -> "--- new source ---\n" <> source + +renderReplacement :: Replacement -> Text +renderReplacement (Replacement old new) = + Text.concat ["--- replaced ---\n", old, "\n--- with ---\n", new] diff --git a/src/Claude/Gate/Dumbify.hs b/src/Claude/Gate/Dumbify.hs new file mode 100644 --- /dev/null +++ b/src/Claude/Gate/Dumbify.hs @@ -0,0 +1,140 @@ +-- | Phase 0: the dumbify complexity canary. +-- +-- For code-touching turns, a small model (Haiku) reads the changed code with the +-- full files as context and explains it; the larger main-loop model judges that +-- explanation. If the canary could not work out what the code DOES, the code is +-- too complex and the larger model simplifies it (behaviour-preserving), which +-- re-triggers the canary. Convergence is OBSERVED via the edit stack: no new +-- edits since the last explanation means the larger model accepted it. Bounded +-- by CLAUDE_DUMBIFY_MAX_ROUNDS. Runs first so the cheap canary shapes the code +-- before the expensive critic verifies the result. +module Claude.Gate.Dumbify + ( runDumbify + ) where + +import Control.Monad (when) +import Data.Maybe (isJust) +import Data.Text (Text) +import Data.Text qualified as Text +import Claude.Gate.DiffRender (renderDiffs) +import Claude.Gate.EditStack (readEdits, stackFilePaths, stackHasCode) +import Claude.Gate.FileContext (renderFullFiles) +import Claude.Gate.GateConfig (envInt, envStr, phaseDisabled) +import Claude.Gate.HookProtocol (BlockReason (BlockReason), blockAndExit) +import Claude.Gate.NestedClaude (NestedResult (NestedBroken, NestedOutput), Reviewer (Reviewer), runNested, surfaceNestedFailure) +import Claude.Gate.Repo (repoForFiles) +import Claude.Gate.ReviewPrompt (maxDiffPromptChars) +import Claude.Gate.TurnState + ( TurnPaths (dumbifyApproved, dumbifyBroke, dumbifyDone, dumbifyEditmark, dumbifyRound, reviewStack) + , fileNonEmpty + , flagExists + , readCounter + , readMark + , stackLineCount + , writeCounter + , writeFlag + ) +import System.Directory (findExecutable) + +-- | Run Phase 0. Fires only for a code-touching turn whose stack has not yet +-- converged, and only when claude is available. +runDumbify :: Text -> TurnPaths -> IO () +runDumbify session paths = do + disabled <- phaseDisabled "CLAUDE_SKIP_DUMBIFY" + done <- flagExists (dumbifyDone paths) + stackReady <- fileNonEmpty (reviewStack paths) + hasCode <- stackHasCode (reviewStack paths) + claudeAvailable <- isJust <$> findExecutable "claude" + when (not disabled && not done && stackReady && hasCode && claudeAvailable) $ do + currentMark <- stackLineCount (reviewStack paths) + previousMark <- readMark (dumbifyEditmark paths) + if previousMark == Just currentMark + then do + -- No new edits since the last explanation: the larger model judged the + -- explanation correct and chose not to simplify. Accept and move on. + writeFlag (dumbifyDone paths) + writeFlag (dumbifyApproved paths) + else do + previousRound <- readCounter (dumbifyRound paths) + maxRounds <- envInt "CLAUDE_DUMBIFY_MAX_ROUNDS" 2 + let thisRound = previousRound + 1 + if thisRound > maxRounds + then writeFlag (dumbifyDone paths) + else runDumbifyRound session paths currentMark thisRound maxRounds + +runDumbifyRound :: Text -> TurnPaths -> Int -> Int -> Int -> IO () +runDumbifyRound session paths currentMark thisRound maxRounds = do + files <- stackFilePaths (reviewStack paths) + edits <- readEdits (reviewStack paths) + fullFiles <- renderFullFiles files + repo <- repoForFiles files + timeoutSecs <- envInt "CLAUDE_DUMBIFY_TIMEOUT" 300 + model <- envStr "CLAUDE_DUMBIFY_MODEL" "claude-haiku-4-5" + let reviewer = Reviewer model True timeoutSecs repo + prompt = dumbifyPrompt (renderDiffs edits) fullFiles + result <- runNested reviewer prompt + case result of + NestedBroken exitCode emptyOut stderrText -> do + surfaceNestedFailure session "dumbify canary" model exitCode emptyOut stderrText (dumbifyBroke paths) + writeFlag (dumbifyDone paths) + NestedOutput output -> do + -- Record the round and the stack size this explanation was based on, so the + -- next Stop can tell whether the larger model simplified. + writeCounter (dumbifyRound paths) thisRound + writeCounter (dumbifyEditmark paths) currentMark + blockAndExit (BlockReason (dumbifyBlockReason model thisRound maxRounds output)) + +dumbifyPrompt :: Text -> Text -> Text +dumbifyPrompt renderedDiffs fullFiles = + Text.concat + [ dumbifyHeader + , "\n=== DIFFS JUST APPLIED THIS TURN ===\n" + , Text.take maxDiffPromptChars renderedDiffs + , "\n=== FULL CURRENT CONTENTS OF THE TOUCHED FILES (context: definitions the diffs reference live here) ===\n" + , fullFiles + ] + +dumbifyHeader :: Text +dumbifyHeader = + "You are a complexity canary. You are a small model reading code a larger agent\n\ + \just wrote, with no explanation from its author. Your job is to test whether the\n\ + \CHANGED code is understandable.\n\ + \\n\ + \You are given two things below: the diffs applied this turn, and the FULL current\n\ + \contents of each file they touched. Use the full file as context. A definition,\n\ + \variable, or helper that the diff references but that lives elsewhere in the file\n\ + \is available to you, so \"I can't see where X is defined\" is NOT a valid confusion\n\ + \unless X is genuinely absent from the file.\n\ + \\n\ + \For each function or section in the diffs, explain in your own words:\n\ + \- what it does,\n\ + \- what its inputs mean and what it returns,\n\ + \- and any concern that makes it hard to follow. Label each concern:\n\ + \ BLOCKS - you could not work out what the changed code actually does.\n\ + \ NICE-TO-HAVE - you understood it, but a comment or clearer name would help.\n\ + \\n\ + \Rules:\n\ + \- Judge from the diffs plus the full files shown and anything else you can read in\n\ + \ the repository. Nobody will explain it to you; that is the point.\n\ + \- Be honest. If something genuinely stops you understanding the behaviour, say so\n\ + \ plainly and label it BLOCKS. Hedging (\"I think\", \"probably\", \"I'm not sure\")\n\ + \ about what the code DOES is itself a BLOCKS signal worth stating outright.\n\ + \- Do NOT report code outside this turn's change (untouched surrounding functions,\n\ + \ the harness/hook protocol that consumes this script's output, the build system)\n\ + \ as confusion. That is context, not the work under review.\n\ + \- Do not suggest fixes. Just explain, and label each concern BLOCKS or NICE-TO-HAVE." + +dumbifyBlockReason :: Text -> Int -> Int -> Text -> Text +dumbifyBlockReason model thisRound maxRounds output = + Text.concat + [ "A ", model, " model (a small 'complexity canary') read the code you changed this turn, " + , "with the full files as context, and explained it as follows (round " + , Text.pack (show thisRound), " of ", Text.pack (show maxRounds) + , "). You are the larger model and the final judge. Weigh its explanation:\n" + , " 1. If it could NOT work out what the changed code DOES (a BLOCKS concern, a misread, or hedging about behaviour), the code is too complex. Apply a behaviour-preserving simplification (split a large dispatch into named functions, bundle threaded parameters into a record, add a domain-bridging comment, extract a capturing where-block). Your edits trigger a re-explanation. Do NOT change behaviour.\n" + , " 2. If it understood the behaviour correctly, make no change and say so; the gate moves on. A NICE-TO-HAVE request for more comments when it already understood is advisory: weigh it, but you may decline and proceed rather than pile on prose.\n" + , "Set CLAUDE_SKIP_DUMBIFY=1 to disable this gate.\n" + , "\n--- canary explanation ---\n" + , output + , "\n--- end canary explanation ---" + ] diff --git a/src/Claude/Gate/Edit.hs b/src/Claude/Gate/Edit.hs new file mode 100644 --- /dev/null +++ b/src/Claude/Gate/Edit.hs @@ -0,0 +1,91 @@ +-- | A single file mutation recorded during a turn. +-- +-- The PostToolUse hook only fires for the four edit tools (the matcher in +-- settings.json is @Write|Edit|MultiEdit|NotebookEdit@), so those four +-- constructors are the complete set: there is no "unknown tool" case to fall +-- back on. Each edit is persisted as one JSON line on the review stack and read +-- back at Stop time to reconstruct the diff for the reviewer. +module Claude.Gate.Edit + ( Edit(..) + , Replacement(..) + , editFilePath + , parseEditFromTool + ) where + +import Data.Aeson (FromJSON (parseJSON), ToJSON (toJSON), Value, object, withObject, (.:), (.=)) +import Data.Aeson.Types qualified as Aeson (Parser, parseEither) +import Data.Text (Text) + +-- | One old/new text pair, as carried by Edit and each element of MultiEdit. +data Replacement = Replacement + { replacedText :: Text + , replacementText :: Text + } + deriving stock (Eq, Show) + +instance FromJSON Replacement where + parseJSON :: Value -> Aeson.Parser Replacement + parseJSON = withObject "Replacement" $ \object' -> + Replacement + <$> object' .: "old_string" + <*> object' .: "new_string" + +-- | A recorded edit, one constructor per edit tool the hook fires for. +data Edit + = SingleEdit FilePath Replacement + | MultiEditFile FilePath [Replacement] + | WriteFileContent FilePath Text + | NotebookCellSource FilePath Text + deriving stock (Eq, Show) + +editFilePath :: Edit -> FilePath +editFilePath = \case + SingleEdit path _ -> path + MultiEditFile path _ -> path + WriteFileContent path _ -> path + NotebookCellSource path _ -> path + +-- | Parse an edit from a PostToolUse payload's tool name and tool_input. The +-- tool name selects the shape; an unexpected name means the settings.json +-- matcher and this code disagree, which is a bug we surface loudly rather than +-- silently drop. +parseEditFromTool :: Text -> Value -> Either String Edit +parseEditFromTool tool = Aeson.parseEither (editParser tool) + +editParser :: Text -> Value -> Aeson.Parser Edit +editParser tool = withObject "tool_input" $ \object' -> case tool of + "Edit" -> + SingleEdit <$> object' .: "file_path" <*> (Replacement <$> object' .: "old_string" <*> object' .: "new_string") + "MultiEdit" -> + MultiEditFile <$> object' .: "file_path" <*> object' .: "edits" + "Write" -> + WriteFileContent <$> object' .: "file_path" <*> object' .: "content" + "NotebookEdit" -> + NotebookCellSource <$> object' .: "file_path" <*> object' .: "new_source" + other -> + fail ("unexpected edit tool: " <> show other) + +-- Persisted form: tag with the tool name and keep exactly the fields needed to +-- reconstruct the diff. Round-trips through parseEditFromTool's shape so the +-- record and review halves of the gate stay in sync. +instance ToJSON Edit where + toJSON :: Edit -> Value + toJSON = \case + SingleEdit path (Replacement old new) -> + object ["tool" .= ("Edit" :: Text), "file_path" .= path, "old_string" .= old, "new_string" .= new] + MultiEditFile path edits -> + object ["tool" .= ("MultiEdit" :: Text), "file_path" .= path, "edits" .= map replacementToJSON edits] + WriteFileContent path content -> + object ["tool" .= ("Write" :: Text), "file_path" .= path, "content" .= content] + NotebookCellSource path source -> + object ["tool" .= ("NotebookEdit" :: Text), "file_path" .= path, "new_source" .= source] + +replacementToJSON :: Replacement -> Value +replacementToJSON (Replacement old new) = + object ["old_string" .= old, "new_string" .= new] + +instance FromJSON Edit where + parseJSON :: Value -> Aeson.Parser Edit + parseJSON value = flip (withObject "Edit") value $ \object' -> do + tool <- object' .: "tool" + editParser tool value diff --git a/src/Claude/Gate/EditStack.hs b/src/Claude/Gate/EditStack.hs new file mode 100644 --- /dev/null +++ b/src/Claude/Gate/EditStack.hs @@ -0,0 +1,70 @@ +-- | Reading the per-turn edit stack the phases review. +-- +-- record-edit appends one JSON-encoded edit per line. The phases read it back to +-- render diffs and to list the touched files; Phase A also returns a claimed +-- stack to the live stack when its reviewer fails, so the next Stop retries. +module Claude.Gate.EditStack + ( readEdits + , stackFilePaths + , stackHasCode + , returnClaimedToStack + ) where + +import Data.Aeson qualified as Aeson +import Data.ByteString qualified as StrictByteString +import Data.ByteString.Char8 qualified as ByteString +import Data.List (isSuffixOf, nub, sort) +import Claude.Gate.Edit (Edit, editFilePath) +import Claude.Gate.TurnState (TurnPaths (claimedStack, reviewStack), removeIfExists) +import System.Directory (doesFileExist) + +-- | Read a stack file back into edits. We wrote these lines ourselves, so a line +-- that fails to decode is a bug in this program, surfaced loudly. +readEdits :: FilePath -> IO [Edit] +readEdits path = do + contents <- ByteString.readFile path + pure (map decodeEdit (filter (not . ByteString.null) (ByteString.lines contents))) + +decodeEdit :: ByteString.ByteString -> Edit +decodeEdit raw = case Aeson.eitherDecodeStrict raw of + Right edit -> edit + Left err -> error ("claude-gate: corrupt edit on the review stack: " <> err) + +-- | The sorted, deduplicated file paths recorded on a stack file. +stackFilePaths :: FilePath -> IO [FilePath] +stackFilePaths path = do + present <- doesFileExist path + if not present + then pure [] + else do + edits <- readEdits path + pure (sort (nub (map editFilePath edits))) + +-- | Whether any file on the stack is source code. Dumbify is about code +-- comprehension, so prose and config edits do not trigger it. +stackHasCode :: FilePath -> IO Bool +stackHasCode path = do + paths <- stackFilePaths path + pure (any isCode paths) + +isCode :: FilePath -> Bool +isCode path = any (`isSuffixOf` path) codeExtensions + +codeExtensions :: [FilePath] +codeExtensions = + [ ".hs", ".lhs", ".hsig", ".cabal", ".nix", ".sh", ".bash", ".py", ".rs" + , ".js", ".ts", ".tsx", ".go", ".c", ".h", ".cpp", ".hpp", ".java" + ] + +-- | Return the claimed diffs to the live stack so the next Stop re-reviews them, +-- then drop the claimed copy. Used when the rule reviewer fails: the diffs must +-- not be lost to an infrastructure hiccup. +returnClaimedToStack :: TurnPaths -> IO () +returnClaimedToStack paths = do + present <- doesFileExist (claimedStack paths) + if not present + then pure () + else do + claimed <- StrictByteString.readFile (claimedStack paths) + StrictByteString.appendFile (reviewStack paths) claimed + removeIfExists (claimedStack paths) diff --git a/src/Claude/Gate/FileContext.hs b/src/Claude/Gate/FileContext.hs new file mode 100644 --- /dev/null +++ b/src/Claude/Gate/FileContext.hs @@ -0,0 +1,37 @@ +-- | Render the current contents of the touched files for a reviewer prompt. +-- +-- The dumbify canary and the rule reviewer both get the diffs AND the full +-- current file, so a reference the diff makes to code defined elsewhere in the +-- same file is not a false "I can't see it" confusion, and the reviewer can +-- judge the ABSENCE of required elements (e.g. a missing type signature) that a +-- diff fragment alone cannot show. Each file is capped to keep the prompt bounded. +module Claude.Gate.FileContext + ( renderFullFiles + , maxFileContextChars + ) where + +import Data.Text (Text) +import Data.Text qualified as Text +import Data.Text.Encoding (decodeUtf8Lenient) +import Data.ByteString qualified as ByteString +import System.Directory (doesFileExist) + +-- | Each file's contents are truncated to this many bytes, matching the shell +-- gate's @head -c 40000@ per file. +maxFileContextChars :: Int +maxFileContextChars = 40_000 + +-- | A labelled block per existing file, in the given order. Missing files are +-- skipped (a path may have been deleted this turn). +renderFullFiles :: [FilePath] -> IO Text +renderFullFiles paths = Text.concat <$> mapM renderOne paths + +renderOne :: FilePath -> IO Text +renderOne path = do + present <- doesFileExist path + if not present + then pure "" + else do + raw <- ByteString.readFile path + let body = decodeUtf8Lenient (ByteString.take maxFileContextChars raw) + pure (Text.concat ["\n--- ", Text.pack path, " ---\n", body, "\n"]) diff --git a/src/Claude/Gate/GateConfig.hs b/src/Claude/Gate/GateConfig.hs new file mode 100644 --- /dev/null +++ b/src/Claude/Gate/GateConfig.hs @@ -0,0 +1,28 @@ +-- | Environment-tunable gate configuration: the skip flags and the integer +-- knobs (round caps, timeouts) each phase reads. +module Claude.Gate.GateConfig + ( phaseDisabled + , envInt + , envStr + ) where + +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import Data.Text qualified as Text +import System.Environment (lookupEnv) +import Text.Read (readMaybe) + +-- | A @CLAUDE_SKIP_*@ flag is set when it equals exactly "1". +phaseDisabled :: String -> IO Bool +phaseDisabled name = (== Just "1") <$> lookupEnv name + +-- | Read an integer environment knob, falling back to the default when it is +-- unset or not a number. +envInt :: String -> Int -> IO Int +envInt name fallback = do + value <- lookupEnv name + pure (fromMaybe fallback (value >>= readMaybe)) + +-- | Read a string environment knob (e.g. a model override), with a default. +envStr :: String -> Text -> IO Text +envStr name fallback = maybe fallback Text.pack <$> lookupEnv name diff --git a/src/Claude/Gate/HookProtocol.hs b/src/Claude/Gate/HookProtocol.hs new file mode 100644 --- /dev/null +++ b/src/Claude/Gate/HookProtocol.hs @@ -0,0 +1,91 @@ +-- | The JSON protocol Claude Code uses to talk to hook commands. +-- +-- A hook reads one JSON object from stdin describing the event, and a Stop hook +-- may write one JSON object to stdout to influence the turn. This module models +-- the fields the gate reads from the input, and the two output shapes it emits: +-- a @decision: block@ (with a reason fed back to the main-loop model) and a +-- @systemMessage@ (shown to the user, not added to model context). +module Claude.Gate.HookProtocol + ( HookEvent(..) + , BlockReason(..) + , readHookEvent + , emitBlock + , blockAndExit + , blockAndExitWithNotice + , emitSystemMessage + ) where + +import Data.Aeson (FromJSON (parseJSON), Value, object, withObject, (.!=), (.:?), (.=)) +import Data.Aeson qualified as Aeson +-- Data.Aeson does not re-export Parser; it lives in Data.Aeson.Types. Both are +-- qualified as Aeson so the FromJSON method signature reads Aeson.Parser. +import Data.Aeson.Types qualified as Aeson (Parser) +import Data.ByteString.Lazy qualified as LazyByteString +import Data.Text (Text) +import System.Exit (exitSuccess) + +-- | The subset of a hook's stdin payload the gate reads. Every field except +-- the session id is optional because which fields are present depends on the +-- event (PostToolUse carries a tool, Stop carries a transcript path). +data HookEvent = HookEvent + { sessionId :: Text + , transcriptPath :: Maybe FilePath + , toolName :: Maybe Text + , toolInput :: Maybe Value + } + +instance FromJSON HookEvent where + parseJSON :: Value -> Aeson.Parser HookEvent + parseJSON = withObject "HookEvent" $ \object' -> + HookEvent + <$> object' .:? "session_id" .!= "default" + <*> object' .:? "transcript_path" + <*> object' .:? "tool_name" + <*> object' .:? "tool_input" + +-- | The text shown back to the main-loop model when the gate blocks the Stop. +newtype BlockReason = BlockReason Text + +-- | Read and decode the hook event from stdin. A malformed payload is a bug in +-- the harness contract, not something to paper over, so we crash loudly. +readHookEvent :: IO HookEvent +readHookEvent = do + raw <- LazyByteString.getContents + case Aeson.eitherDecode raw of + Left err -> error ("claude-gate: could not decode hook event from stdin: " <> err) + Right event -> pure event + +-- | Block the Stop and feed the reason back to the model. Printing this JSON and +-- exiting 0 is how a Stop hook asks the turn to continue. +emitBlock :: BlockReason -> IO () +emitBlock (BlockReason reason) = + LazyByteString.putStr (Aeson.encode (object ["decision" .= ("block" :: Text), "reason" .= reason])) + +-- | A blocking phase emits its reason and ends the gate immediately: later +-- phases do not run on a Stop that one phase already blocked. +blockAndExit :: BlockReason -> IO a +blockAndExit reason = emitBlock reason >> exitSuccess + +-- | Block the Stop and, in the SAME hook response, show the user a notice. A +-- Stop hook may emit only one JSON object, so the model-facing block reason and +-- the user-facing systemMessage are combined into one object: the model gets the +-- reason it must act on, and the human watching sees the notice rather than being +-- left to guess at a phase that broke silently. Used for infrastructure failures +-- (a nested reviewer that timed out or returned a weird exit status). +-- +-- Decision: emit one JSON object carrying both "reason" and "systemMessage", +-- rather than reusing emitBlock then emitSystemMessage as two writes. Alternative +-- considered: two separate emits. Rejected because a hook may write only one JSON +-- object to stdout, so the second write is ignored or breaks parsing; a single +-- merged object is the only way to deliver both signals from one hook response. +blockAndExitWithNotice :: BlockReason -> Text -> IO a +blockAndExitWithNotice (BlockReason reason) notice = do + LazyByteString.putStr + (Aeson.encode (object ["decision" .= ("block" :: Text), "reason" .= reason, "systemMessage" .= notice])) + exitSuccess + +-- | Emit a user-visible, non-blocking message (the end-of-gate "gate clear" +-- notice). systemMessage is shown to the user and is not added to model context. +emitSystemMessage :: Text -> IO () +emitSystemMessage message = + LazyByteString.putStr (Aeson.encode (object ["systemMessage" .= message])) diff --git a/src/Claude/Gate/NestedClaude.hs b/src/Claude/Gate/NestedClaude.hs new file mode 100644 --- /dev/null +++ b/src/Claude/Gate/NestedClaude.hs @@ -0,0 +1,224 @@ +-- | Running a nested @claude -p@ reviewer and surfacing its failures loudly. +-- +-- Each Stop-gate phase shells out to a fresh @claude@ to review the turn. Two +-- rules from the shell gate are preserved here. First, the nested call is launched +-- with every gate phase disabled in its environment, so its own hooks cannot +-- re-enter this gate. Second, the gate FAILS LOUD: a reviewer that timed out, +-- crashed, or returned nothing is not read as a clean pass. It is logged and, on +-- its first occurrence this turn, blocks the Stop with a descriptive reason for +-- the model AND a user-visible systemMessage naming the weird exit status, so a +-- silently broken reviewer is never mistaken for a clean pass by either of them. +module Claude.Gate.NestedClaude + ( Reviewer(..) + , NestedResult(..) + , GateFailure(..) + , runNested + , surfaceNestedFailure + , surfaceGateFailure + ) where + +import Control.Exception.Safe (displayException, tryAny) +import Control.Monad (unless) +import Data.ByteString.Lazy qualified as LazyByteString +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import Data.Text qualified as Text +import Data.Text.Encoding (decodeUtf8Lenient, encodeUtf8) +import Claude.Gate.HookProtocol (BlockReason (BlockReason), blockAndExitWithNotice) +import Claude.Gate.SpawnAnnotation (annotateSpawn) +import Claude.Gate.TurnState (flagExists, writeFlag) +import System.Directory (createDirectoryIfMissing) +import System.Environment (getEnvironment, lookupEnv) +import System.Exit (ExitCode (ExitFailure, ExitSuccess)) +import System.FilePath (takeDirectory) +import System.Process.Typed (byteStringInput, proc, readProcess, setEnv, setStdin, setWorkingDir) + +-- | How to launch one nested reviewer. A read-only reviewer (the dumbify canary +-- and the rule reviewer) gets MCP disabled and only Read/Grep/Glob, skipping the +-- MCP cold-start cost; the critic is deliberately given neither, so it has full +-- tools to gather counter-evidence. +data Reviewer = Reviewer + { reviewerModel :: Text + , reviewerReadOnly :: Bool + , reviewerTimeoutSecs :: Int + , reviewerWorkdir :: Maybe FilePath + } + +-- | The outcome of a nested call. NestedBroken carries the exit code, whether +-- stdout was empty, and the captured stderr, so a failure can be described. +data NestedResult + = NestedBroken Int Bool Text + | NestedOutput Text + +-- | Run @timeout N claude -p ... --model M@ feeding the prompt on stdin. The +-- timeout binary kills a hung reviewer (exit 124). A non-zero exit, an empty +-- stdout, or a spawn exception all count as broken. +runNested :: Reviewer -> Text -> IO NestedResult +runNested reviewer prompt = do + baseEnv <- getEnvironment + let configure = + setStdin (byteStringInput (LazyByteString.fromStrict (encodeUtf8 prompt))) + . setEnv (guardEnv baseEnv) + . maybe id setWorkingDir (reviewerWorkdir reviewer) + reviewerProcess = configure (proc "timeout" (timeoutArgs reviewer)) + outcome <- tryAny (annotateSpawn (nestedSpawnLabel reviewer) (readProcess reviewerProcess)) + pure $ case outcome of + Left err -> NestedBroken 1 True (Text.pack (displayException err)) + Right (exitCode, out, errOut) -> interpret exitCode (decodeLazy out) (decodeLazy errOut) + +interpret :: ExitCode -> Text -> Text -> NestedResult +interpret exitCode out err + | nestedBroken exitCode out = NestedBroken (exitNumber exitCode) (emptyOutput out) err + | otherwise = NestedOutput out + +-- | Mirrors the shell @nested_call_broken@: a non-zero exit, or exit 0 with no +-- usable stdout, is broken; a reviewer that answered (even "OK") is not. +nestedBroken :: ExitCode -> Text -> Bool +nestedBroken ExitSuccess out = emptyOutput out +nestedBroken (ExitFailure _) _ = True + +emptyOutput :: Text -> Bool +emptyOutput = Text.null . Text.strip + +exitNumber :: ExitCode -> Int +exitNumber ExitSuccess = 0 +exitNumber (ExitFailure n) = n + +timeoutArgs :: Reviewer -> [String] +timeoutArgs reviewer = + [show (reviewerTimeoutSecs reviewer), "claude", "-p"] + <> (if reviewerReadOnly reviewer then readOnlyArgs else []) + <> ["--model", Text.unpack (reviewerModel reviewer)] + +readOnlyArgs :: [String] +readOnlyArgs = ["--strict-mcp-config", "--mcp-config", "{\"mcpServers\":{}}", "--tools", "Read", "Grep", "Glob"] + +-- | A label for the nested reviewer spawn, attached to any spawn failure so a +-- broken 'NestedResult' names which reviewer's process could not start (rather +-- than a bare @timeout: posix_spawnp@). Keyed by model, which distinguishes the +-- canary, rule reviewer and critic. +nestedSpawnLabel :: Reviewer -> String +nestedSpawnLabel reviewer = + "timeout claude (nested " <> Text.unpack (reviewerModel reviewer) <> " reviewer)" + +-- | Disable every gate phase in the nested reviewer's environment so its own +-- Stop hook cannot recurse into this gate. +guardEnv :: [(String, String)] -> [(String, String)] +guardEnv base = + upsert "CLAUDE_SKIP_DUMBIFY" "1" + (upsert "CLAUDE_SKIP_CRITIQUE" "1" (upsert "CLAUDE_SKIP_RULE_CHECK" "1" base)) + +upsert :: String -> String -> [(String, String)] -> [(String, String)] +upsert key value environment = (key, value) : filter ((/= key) . fst) environment + +decodeLazy :: LazyByteString.ByteString -> Text +decodeLazy = decodeUtf8Lenient . LazyByteString.toStrict + +-- | One gate failure described for its three audiences: the durable log, the +-- main-loop model, and the human watching. A record rather than positional +-- Text arguments so the reason and the notice cannot be swapped at a call site. +data GateFailure = GateFailure + { failureHeadline :: Text + -- ^ One line naming the failure in the durable log header. + , failureLogBody :: Text + -- ^ Detail recorded under the headline (stderr tail, paths). + , failureBlockReason :: Text + -- ^ Model-facing reason fed back when the Stop is blocked. + , failureUserNotice :: Text + -- ^ User-visible systemMessage shown alongside the block. + } + +-- | The shared fail-loud path: append the failure to the durable log and, on +-- its first occurrence this turn (tracked via the warn flag), block the Stop +-- with a reason for the model AND a user-visible notice (then exit). Later +-- occurrences only log and return, so a persistent failure surfaces once but +-- does not wedge the turn. Used for broken nested calls and for the critique's +-- empty dossier; anything the gate must never silently wave through. +surfaceGateFailure :: Text -> GateFailure -> FilePath -> IO () +surfaceGateFailure session failure warnFlag = do + appendFailureLog session (failureHeadline failure) (failureLogBody failure) + alreadyWarned <- flagExists warnFlag + unless alreadyWarned $ do + writeFlag warnFlag + blockAndExitWithNotice + (BlockReason (failureBlockReason failure)) + (failureUserNotice failure) + +-- | Log a broken nested call, and on its first occurrence this turn block the +-- Stop with a loud reason for the model and a user-visible notice (then exit). +-- On later occurrences it only logs and returns, so a permanently broken CLI +-- surfaces once but does not wedge the turn. +surfaceNestedFailure :: Text -> Text -> Text -> Int -> Bool -> Text -> FilePath -> IO () +surfaceNestedFailure session phase model exitCode emptyOut stderrText = + surfaceGateFailure session (nestedCallFailure phase model detail stderrText) + where + detail = failureDetail exitCode emptyOut + +-- | Describe a broken nested call for 'surfaceGateFailure'. +nestedCallFailure :: Text -> Text -> Text -> Text -> GateFailure +nestedCallFailure phase model detail stderrText = + GateFailure + { failureHeadline = Text.concat ["nested call broke: phase=", phase, " model=", model, " ", detail] + , failureLogBody = "--- stderr (last 20 lines) ---\n" <> stderrTail stderrText + , failureBlockReason = failureReason phase model detail stderrText + , failureUserNotice = failureNotice phase model detail + } + +-- | The short, user-visible companion to 'failureReason'. It names the phase, +-- the model, and the weird exit status so a watching human sees at once that a +-- reviewer broke and where to look, instead of mistaking the silence for a +-- clean pass. The default failure log path is named because it holds the detail. +failureNotice :: Text -> Text -> Text -> Text +failureNotice phase model detail = + Text.concat + [ "claude-gate: the ", phase, " reviewer (", model, ") returned a bad exit status (" + , detail, "), so this turn was NOT checked by it. Details in the gate failure log " + , "($CLAUDE_GATE_FAILURE_LOG, default ~/.claude/gate-failures.log)." + ] + +failureDetail :: Int -> Bool -> Text +failureDetail exitCode emptyOut = + "exit=" <> Text.pack (show exitCode) + <> (if exitCode == 124 then " (timed out)" else "") + <> (if emptyOut then ", empty output" else "") + +failureReason :: Text -> Text -> Text -> Text -> Text +failureReason phase model detail stderrText = + Text.concat + [ "GATE INFRASTRUCTURE FAILURE in the ", phase, " phase: the nested ", model + , " call returned no usable result (", detail, "), so this turn was NOT checked " + , "by that phase. Find out why the reviewer could not run (timeout, auth, MCP, " + , "model error) before trusting this turn. This loud warning fires once per turn; " + , "you may continue after acknowledging it.\nLast stderr lines:\n" + , stderrTail stderrText + ] + +stderrTail :: Text -> Text +stderrTail = Text.unlines . lastN 20 . Text.lines + +lastN :: Int -> [a] -> [a] +lastN n xs = drop (length xs - n) xs + +-- | Append a failure record to the durable log outside the per-turn state dir +-- (so it survives the per-prompt reset), overridable via CLAUDE_GATE_FAILURE_LOG. +appendFailureLog :: Text -> Text -> Text -> IO () +appendFailureLog session headline body = do + path <- failureLogPath + createDirectoryIfMissing True (takeDirectory path) + appendFile path $ + Text.unpack $ + Text.concat + [ "=== gate failure: ", headline, " ===\n" + , "session=", session, "\n" + , body + , "\n" + ] + +failureLogPath :: IO FilePath +failureLogPath = do + override <- lookupEnv "CLAUDE_GATE_FAILURE_LOG" + case override of + Just path -> pure path + Nothing -> do + home <- lookupEnv "HOME" + pure (fromMaybe "/tmp" home <> "/.claude/gate-failures.log") diff --git a/src/Claude/Gate/RecordEdit.hs b/src/Claude/Gate/RecordEdit.hs new file mode 100644 --- /dev/null +++ b/src/Claude/Gate/RecordEdit.hs @@ -0,0 +1,118 @@ +-- | The PostToolUse half of the gate: record an edit onto the per-turn review +-- stack, near-instantly, so the Stop gate can review the whole turn's diffs in +-- one pass. This never blocks the agent and never reviews anything itself. +module Claude.Gate.RecordEdit + ( recordEdit + , editTools + , pathSkipReason + , SkipReason(..) + , maxRecordedFileBytes + ) where + +import Control.Monad (unless, when) +import Data.Aeson qualified as Aeson +import Data.ByteString qualified as ByteString +import Data.ByteString.Lazy qualified as LazyByteString +import Data.List (isInfixOf, isSuffixOf) +import Data.Text (Text) +import Claude.Gate.Edit (Edit, editFilePath, parseEditFromTool) +import Claude.Gate.HookProtocol (HookEvent (sessionId, toolInput, toolName), readHookEvent) +import Claude.Gate.TurnState (TurnPaths (reviewStack), ensureStateDir, turnPaths) +import System.Directory (doesFileExist, getFileSize) +import System.Environment (lookupEnv) + +-- | The tools whose edits we record. Matches the PostToolUse matcher in +-- settings.json; any other tool name is simply not an edit event. +editTools :: [Text] +editTools = ["Edit", "MultiEdit", "Write", "NotebookEdit"] + +-- | Files larger than this are skipped so a huge generated write does not burn +-- review tokens. Matches the 50 KB cutoff the shell hook used. +maxRecordedFileBytes :: Integer +maxRecordedFileBytes = 50_000 + +-- | Why an edit was not recorded. Kept as data (rather than a bare Bool) so the +-- reason is greppable and testable, even though the hook acts the same for all +-- of them: it skips silently, because a skipped file is an intended no-op, not +-- a failure. +data SkipReason + = SkipBinaryExtension + | SkipArchive + | SkipBuildArtifact + deriving stock (Eq, Show) + +-- | Decide, from the path alone, whether prose/style rules could apply. Returns +-- the reason to skip, or Nothing to consider the file. Pure so it can be tested +-- without touching the filesystem. +pathSkipReason :: FilePath -> Maybe SkipReason +pathSkipReason path + | any (`isSuffixOf` path) binaryExtensions = Just SkipBinaryExtension + | any (`isSuffixOf` path) archiveExtensions = Just SkipArchive + | any (`isInfixOf` path) buildArtifactInfixes = Just SkipBuildArtifact + | "/result" `isSuffixOf` path = Just SkipBuildArtifact + | "/result-" `isInfixOf` path = Just SkipBuildArtifact + | otherwise = Nothing + +binaryExtensions :: [FilePath] +binaryExtensions = + [ ".lock", ".json", ".csv", ".tsv", ".png", ".jpg", ".jpeg", ".gif" + , ".pdf", ".ico", ".svg", ".sqlite", ".db", ".so", ".dylib", ".exe", ".bin" + ] + +archiveExtensions :: [FilePath] +archiveExtensions = [".zip", ".tar", ".tar.gz", ".tgz", ".bz2", ".xz", ".7z", ".rar"] + +buildArtifactInfixes :: [FilePath] +buildArtifactInfixes = ["/node_modules/", "/.git/", "/dist-newstyle/"] + +-- | Entry point for the @record@ subcommand. Reads the PostToolUse event, +-- applies the same filters the shell hook did, and appends the edit as one JSON +-- line to the review stack. +recordEdit :: IO () +recordEdit = do + -- Recording respects the rule-review skip flag because the only consumer of + -- the review stack is the Stop gate's Phase A rule review. With review off + -- nothing ever reads the stack, so recording would be pure overhead. + disabled <- ruleCheckDisabled + unless disabled $ do + event <- readHookEvent + case (toolName event, toolInput event) of + (Just tool, Just input) + | tool `elem` editTools -> + case parseEditFromTool tool input of + Left err -> error ("claude-gate record: malformed " <> show tool <> " input: " <> err) + Right edit -> recordIfRelevant (sessionId event) edit + _notAnEditEvent -> pure () + +ruleCheckDisabled :: IO Bool +ruleCheckDisabled = (== Just "1") <$> lookupEnv "CLAUDE_SKIP_RULE_CHECK" + +recordIfRelevant :: Text -> Edit -> IO () +recordIfRelevant session edit = case pathSkipReason path of + Just SkipBinaryExtension -> pure () + Just SkipArchive -> pure () + Just SkipBuildArtifact -> pure () + Nothing -> do + isRegularFile <- doesFileExist path + when isRegularFile $ do + tooBig <- aboveSizeLimit path + binary <- looksBinary path + when (not tooBig && not binary) (appendEdit session edit) + where + path = editFilePath edit + +aboveSizeLimit :: FilePath -> IO Bool +aboveSizeLimit path = (> maxRecordedFileBytes) <$> getFileSize path + +-- | Cheap binary heuristic matching the shell hook: a NUL byte in the first +-- 8 KB means binary. +looksBinary :: FilePath -> IO Bool +looksBinary path = do + prefix <- ByteString.take 8192 <$> ByteString.readFile path + pure (ByteString.elem 0 prefix) + +appendEdit :: Text -> Edit -> IO () +appendEdit session edit = do + paths <- turnPaths session + ensureStateDir paths + LazyByteString.appendFile (reviewStack paths) (Aeson.encode edit <> "\n") diff --git a/src/Claude/Gate/Repo.hs b/src/Claude/Gate/Repo.hs new file mode 100644 --- /dev/null +++ b/src/Claude/Gate/Repo.hs @@ -0,0 +1,109 @@ +-- | Resolving the git work-tree root a reviewer should run in. +-- +-- The dumbify canary and the critic run in the repository so they can read code +-- and (the critic) run tests. The root is taken from the first edited file; +-- the critic falls back to the gate's own working directory on a turn with no +-- file edits. +module Claude.Gate.Repo + ( gitRoot + , repoForFiles + , repoForFilesOrCwd + , commitHistory + ) where + +import Data.ByteString.Lazy.Char8 qualified as LazyChar8 +import Data.Text (Text) +import Data.Text qualified as Text +import Data.Text.Encoding (decodeUtf8Lenient) +import System.Directory (findExecutable) +import System.Exit (ExitCode (ExitFailure, ExitSuccess)) +import System.FilePath (takeDirectory) +import System.Process.Typed (proc, readProcess) + +import Claude.Gate.SpawnAnnotation (annotateSpawn) + +-- | The git work-tree root containing a directory. 'Nothing' when the directory +-- is not in a repository, or when @git@ is not on @PATH@ at all. +-- +-- Decision: guard the spawn with 'findExecutable' rather than spawning blind. +-- A missing @git@, or a @\/bin\/git@ symlink left dangling by a nix +-- garbage-collection, otherwise crashes the whole Stop hook on @posix_spawnp@; +-- declining to resolve a root lets the caller skip that reviewer instead. This +-- mirrors the @findExecutable "claude"@ guard the reviewers already use. +-- Alternative considered: catch the spawn exception; rejected because the +-- pre-flight check keeps the not-installed path explicit and never swallows a +-- genuine spawn failure of a @git@ that IS present. +gitRoot :: FilePath -> IO (Maybe FilePath) +gitRoot dir = do + gitOnPath <- findExecutable "git" + case gitOnPath of + Nothing -> pure Nothing + Just _ -> do + (exitCode, out, _err) <- + annotateSpawn ("git -C " <> dir <> " rev-parse --show-toplevel") $ + readProcess (proc "git" ["-C", dir, "rev-parse", "--show-toplevel"]) + pure (parseTopLevel exitCode out) + +-- | The first line of @git rev-parse --show-toplevel@ output is the work-tree +-- root on success; a failing exit or empty output means not-a-repository. +parseTopLevel :: ExitCode -> LazyChar8.ByteString -> Maybe FilePath +parseTopLevel exitCode out = + case LazyChar8.lines out of + (root : _) -> + if isSuccess exitCode && not (LazyChar8.null root) + then Just (LazyChar8.unpack root) + else Nothing + [] -> Nothing + +isSuccess :: ExitCode -> Bool +isSuccess = \case + ExitSuccess -> True + ExitFailure _ -> False + +-- | The repo's recent commit history, newest first, one commit per line as +-- @\ \ \@. The first line is HEAD. +-- The critic runs with full tools and cross-checks external CI runs; handed the +-- real commit order and each commit's timestamp it can pin a run to a commit by +-- its sha instead of reconstructing the order from run start times (which are not +-- commit order: a run can start on an older HEAD and finish after a newer commit +-- exists) and pinning runs to the wrong commits. 'Nothing' when the directory is +-- not a work tree, or when @git@ is not on @PATH@ (same guard as 'gitRoot'). +commitHistory :: FilePath -> IO (Maybe Text) +commitHistory dir = do + gitOnPath <- findExecutable "git" + case gitOnPath of + Nothing -> pure Nothing + -- The resolved path is unused; we invoke @git@ through PATH, the presence + -- check is all we need from findExecutable. + Just _gitExecutable -> do + -- 15 commits: enough to cover a turn's worth of recent work (so the critic + -- can place the runs it checks) without bloating the prompt with ancient + -- history the critique will never reference. + (exitCode, out, _err) <- + annotateSpawn ("git -C " <> dir <> " log -n 15 --format=%H %cI %s") $ + readProcess (proc "git" ["-C", dir, "log", "-n", "15", "--format=%H %cI %s"]) + pure (parseHistory exitCode out) + +-- | The git log output as trimmed 'Text' on success with non-empty output; a +-- failing exit (not a repository, an empty repo with no commits) is 'Nothing' so +-- the caller renders an explicit placeholder rather than a blank anchor. +parseHistory :: ExitCode -> LazyChar8.ByteString -> Maybe Text +parseHistory exitCode out = + let decoded = Text.stripEnd (decodeUtf8Lenient (LazyChar8.toStrict out)) + in if isSuccess exitCode && not (Text.null decoded) + then Just decoded + else Nothing + +-- | The repo root of the first edited file, or Nothing when there are no files. +repoForFiles :: [FilePath] -> IO (Maybe FilePath) +repoForFiles [] = pure Nothing +repoForFiles (firstFile : _) = gitRoot (takeDirectory firstFile) + +-- | The repo root of the first edited file, falling back to the current +-- directory's repo when the turn made no file edits. +repoForFilesOrCwd :: [FilePath] -> IO (Maybe FilePath) +repoForFilesOrCwd files = do + fromFiles <- repoForFiles files + case fromFiles of + Just root -> pure (Just root) + Nothing -> gitRoot "." diff --git a/src/Claude/Gate/ReviewPrompt.hs b/src/Claude/Gate/ReviewPrompt.hs new file mode 100644 --- /dev/null +++ b/src/Claude/Gate/ReviewPrompt.hs @@ -0,0 +1,105 @@ +-- | The Phase A rule-review prompt and the parsing of the reviewer's reply. +-- +-- Keeping the prompt text here, separate from the orchestration in +-- "Claude.Gate.RuleReview", makes the wording easy to find and edit without wading +-- through control flow. +module Claude.Gate.ReviewPrompt + ( buildReviewPrompt + , maxDiffPromptChars + , hasViolations + , reviewBlockReason + ) where + +import Data.Text (Text) +import Data.Text qualified as Text + +-- | The rendered diffs are truncated to this many characters so a giant turn +-- cannot blow up the reviewer prompt. Matches the shell hook's @head -c 40000@. +maxDiffPromptChars :: Int +maxDiffPromptChars = 40_000 + +-- | Assemble the reviewer prompt from the rules corpus, the rendered diffs, and +-- the full current contents of the touched files (so the reviewer can judge the +-- absence of required elements that a diff fragment cannot show). +buildReviewPrompt :: Text -> Text -> Text -> Text +buildReviewPrompt corpus renderedDiffs fullFiles = + Text.concat + [ reviewPromptHeader + , corpus + , "\n=== DIFFS JUST APPLIED ===\n" + , Text.take maxDiffPromptChars renderedDiffs + , "\n=== FULL FILE CONTENTS (context; judge presence/absence of required elements only for definitions that appear in the diffs above) ===\n" + , fullFiles + ] + +reviewPromptHeader :: Text +reviewPromptHeader = + "You are a rule-compliance reviewer. Another Claude Code agent (a larger model\n\ + \than you) just finished a turn in which it made the edits shown below. You are\n\ + \reviewing the DIFFS of those edits, not whole files. Your output is fed back to\n\ + \that larger model, which then decides whether to fix the file or rebut your\n\ + \finding. Give it enough evidence to judge, not just a label.\n\ + \\n\ + \Below is a corpus of rules from CLAUDE.md and the relevant skills, followed by\n\ + \the diffs that were just applied.\n\ + \\n\ + \Be strict about what counts as a violation:\n\ + \\n\ + \- Only flag clear, objective violations of a rule stated in the rules corpus.\n\ + \ Quote the rule you are applying.\n\ + \- Only flag text that appears in a \"--- with ---\", \"--- new content ---\" or\n\ + \ \"--- new source ---\" section: that is what the agent actually wrote. Do not\n\ + \ flag text in a \"--- replaced ---\" section; that is the old text being removed.\n\ + \- A violation can also be the ABSENCE of required text. For rules of the form\n\ + \ \"always do X\" / \"every Y must have Z\" (e.g. \"always add a top-level type\n\ + \ signature to every top-level binding\"), a diff fragment cannot show a missing\n\ + \ line. So for any top-level definition that appears in the diffs (added or\n\ + \ modified this turn), consult the FULL FILE CONTENTS section below to check\n\ + \ whether the required element is present; if it is missing, flag it. Apply this\n\ + \ ONLY to definitions that appear in the diffs, never to untouched code.\n\ + \- Do NOT flag stylistic preferences that are not stated in the rules.\n\ + \- Do NOT flag judgement calls or things that \"might be better\".\n\ + \- If you are unsure, do not flag it.\n\ + \- Skill rules only apply when the skill's trigger conditions match the file\n\ + \ being reviewed.\n\ + \\n\ + \Response format:\n\ + \\n\ + \- If there are no violations: respond with the single line `OK`.\n\ + \- Otherwise: one block per violation, no markdown, with these labelled lines:\n\ + \\n\ + \ VIOLATION: \n\ + \ RULE: \"\"\n\ + \ EVIDENCE: : \n\ + \ REASONING: \n\ + \\n\ + \Separate blocks with a blank line.\n\ + \\n\ + \=== RULES ===\n" + +-- | A reviewer reply reports violations when it contains at least one line +-- beginning with @VIOLATION:@. +hasViolations :: Text -> Bool +hasViolations reviewOutput = + any ("VIOLATION:" `Text.isPrefixOf`) (Text.lines reviewOutput) + +-- | The block reason shown to the main-loop model when the reviewer flags +-- something. It frames the model as the final judge: fix or rebut, never +-- silently ignore. +reviewBlockReason :: Text -> Text -> Text +reviewBlockReason model reviewOutput = + Text.concat + [ "A ", model, " reviewer flagged possible rule violations in the diffs you just applied.\n" + , "You are the larger model and the final judge. For each finding, either:\n" + , " 1. Agree: edit the file to fix it (the fix is re-reviewed automatically), or\n" + , " 2. Disagree: explain to the user why the finding is wrong (the reviewer misread\n" + , " the rule, the rule does not apply to this file type, evidence out of context)\n" + , " and proceed without fixing.\n" + , "Do not silently ignore findings. Set CLAUDE_SKIP_RULE_CHECK=1 to disable.\n" + , "\n--- reviewer findings ---\n" + , reviewOutput + , "\n--- end reviewer findings ---" + ] diff --git a/src/Claude/Gate/RuleReview.hs b/src/Claude/Gate/RuleReview.hs new file mode 100644 --- /dev/null +++ b/src/Claude/Gate/RuleReview.hs @@ -0,0 +1,73 @@ +-- | Phase A: rule review. +-- +-- Claims the edit stack and reviews every diff in a single reviewer call against +-- the rules corpus (global and project CLAUDE.md plus the skills matching the +-- touched file types), with the full file contents for context. Violations block +-- the Stop with the findings; the model's fixes are themselves edits, recorded on +-- a fresh stack and re-reviewed next Stop, so review loops until clean. A reviewer +-- that fails returns the diffs to the stack and is surfaced loudly. +module Claude.Gate.RuleReview + ( runRuleReview + ) where + +import Control.Monad (when) +import Data.Maybe (isJust) +import Data.Text (Text) +import Claude.Gate.Corpus (buildCorpus) +import Claude.Gate.DiffRender (renderDiffs) +import Claude.Gate.EditStack (readEdits, returnClaimedToStack, stackFilePaths) +import Claude.Gate.FileContext (renderFullFiles) +import Claude.Gate.GateConfig (envInt, envStr, phaseDisabled) +import Claude.Gate.HookProtocol (BlockReason (BlockReason), blockAndExit) +import Claude.Gate.NestedClaude (NestedResult (NestedBroken, NestedOutput), Reviewer (Reviewer), runNested, surfaceNestedFailure) +import Claude.Gate.ReviewPrompt (buildReviewPrompt, hasViolations, reviewBlockReason) +import Claude.Gate.TurnState + ( TurnPaths (claimedStack, reviewApproved, reviewBroke, reviewStack) + , claimReviewStack + , fileNonEmpty + , removeIfExists + , writeFlag + ) +import System.Directory (findExecutable) + +runRuleReview :: Text -> TurnPaths -> IO () +runRuleReview session paths = do + disabled <- phaseDisabled "CLAUDE_SKIP_RULE_CHECK" + claudeAvailable <- isJust <$> findExecutable "claude" + stackReady <- fileNonEmpty (reviewStack paths) + when (not disabled && claudeAvailable && stackReady) $ do + -- Claim the stack atomically so any edit recorded after this point lands on a + -- fresh stack and is reviewed on the next Stop rather than lost. + claimed <- claimReviewStack paths + claimedReady <- if claimed then fileNonEmpty (claimedStack paths) else pure False + when claimedReady (reviewClaimed session paths) + +reviewClaimed :: Text -> TurnPaths -> IO () +reviewClaimed session paths = do + files <- stackFilePaths (claimedStack paths) + edits <- readEdits (claimedStack paths) + corpus <- buildCorpus files + fullFiles <- renderFullFiles files + timeoutSecs <- envInt "CLAUDE_RULE_REVIEW_TIMEOUT" 300 + -- Phase A reviewer model. Decision: Sonnet rather than Haiku. The review only + -- fires on turns that edited files and batches that turn's diffs into one call, + -- so cost is per-edit-turn, not per-Stop, and the extra reasoning catches + -- semantic violations (silent failures, tests asserting static content) a + -- smaller model misses. The main-loop model is still the final judge. Read via + -- the env, defaulting to the current Sonnet, so bumping the model to the next + -- generation needs no rebuild, matching CLAUDE_CRITIQUE_MODEL / CLAUDE_DUMBIFY_MODEL. + model <- envStr "CLAUDE_REVIEWER_MODEL" "claude-sonnet-5" + let reviewer = Reviewer model True timeoutSecs Nothing + prompt = buildReviewPrompt corpus (renderDiffs edits) fullFiles + result <- runNested reviewer prompt + case result of + NestedBroken exitCode emptyOut stderrText -> do + -- Do not lose the diffs: return them to the stack so the next Stop + -- re-reviews once the reviewer works again, then surface the failure. + returnClaimedToStack paths + surfaceNestedFailure session "rule review" model exitCode emptyOut stderrText (reviewBroke paths) + NestedOutput output -> do + removeIfExists (claimedStack paths) + if hasViolations output + then blockAndExit (BlockReason (reviewBlockReason model output)) + else writeFlag (reviewApproved paths) diff --git a/src/Claude/Gate/SpawnAnnotation.hs b/src/Claude/Gate/SpawnAnnotation.hs new file mode 100644 --- /dev/null +++ b/src/Claude/Gate/SpawnAnnotation.hs @@ -0,0 +1,30 @@ +-- | Naming external-process spawns in the exception context. +-- +-- 'System.Process.Typed.readProcess' spawns through @posix_spawnp@. When that +-- fails, for a missing binary or a @\/bin@ symlink left dangling by a nix +-- garbage-collection, the exception is a bare +-- @git: startProcess: posix_spawnp: does not exist@ that says nothing about +-- which of the gate's spawns raised it. Wrapping every spawn in 'annotateSpawn' +-- attaches its command, and (via 'checkpoint'\'s 'HasCallStack') the call site, +-- to the exception with @annotated-exception@, so an uncaught crash, or a +-- 'Control.Exception.displayException' of a caught one, names the spawn. +module Claude.Gate.SpawnAnnotation + ( ProcessCallSite(..) + , annotateSpawn + ) where + +import Control.Exception.Annotated (Annotation (Annotation), checkpoint) +import GHC.Stack (HasCallStack) + +-- | The command a process spawn was for. Its 'Show' is the message the +-- annotation renders, so a crash reads as a sentence rather than a constructor. +newtype ProcessCallSite = ProcessCallSite String + +instance Show ProcessCallSite where + show (ProcessCallSite command) = "while spawning: " <> command + +-- | Run a process spawn with its command, and the caller's source location, +-- attached to any exception it raises. The action is otherwise unchanged; this +-- only decorates failures. +annotateSpawn :: HasCallStack => String -> IO a -> IO a +annotateSpawn command = checkpoint (Annotation (ProcessCallSite command)) diff --git a/src/Claude/Gate/StopGate.hs b/src/Claude/Gate/StopGate.hs new file mode 100644 --- /dev/null +++ b/src/Claude/Gate/StopGate.hs @@ -0,0 +1,67 @@ +-- | The Stop hook: the end-of-turn gate. +-- +-- Three phases run in order over the per-turn state, mirroring the shell gate: +-- +-- Phase 0 (dumbify). A cheap canary checks the changed code is understandable, +-- and the larger model simplifies it if not. See "Claude.Gate.Dumbify". +-- Phase 1 (critique). An adversarial critic tries to prove the work wrong with +-- tests and sources. See "Claude.Gate.Critique". (This replaced the old verification +-- nudge.) +-- Phase A (rule review). The diffs are checked against the rules corpus. See +-- "Claude.Gate.RuleReview". +-- +-- Each phase may block the Stop (emit a reason and exit); later phases only run +-- on a Stop that no earlier phase blocked. The phases converge across the turn's +-- repeated Stops via per-phase flags on tmpfs. When every phase that ran cleared +-- without blocking, a non-blocking "gate clear" notice names them. +module Claude.Gate.StopGate + ( runStopGate + ) where + +import Control.Monad (unless) +import Data.Maybe (catMaybes) +import Data.Text (Text) +import Data.Text qualified as Text +import Claude.Gate.Critique (runCritique) +import Claude.Gate.Dumbify (runDumbify) +import Claude.Gate.HookProtocol (HookEvent (sessionId, transcriptPath), emitSystemMessage, readHookEvent) +import Claude.Gate.RuleReview (runRuleReview) +import Claude.Gate.TurnState + ( TurnPaths (critiqueApproved, dumbifyApproved, reviewApproved) + , ensureStateDir + , flagExists + , turnPaths + ) + +-- | Entry point for the @stop-gate@ subcommand. +runStopGate :: IO () +runStopGate = do + event <- readHookEvent + paths <- turnPaths (sessionId event) + ensureStateDir paths + runDumbify (sessionId event) paths + runCritique (sessionId event) (transcriptPath event) paths + runRuleReview (sessionId event) paths + emitGateClear paths + +-- | Every phase that ran this turn concluded without blocking (a block would +-- have exited above). Emit one user-visible, non-blocking confirmation naming +-- the phases that ran and cleared, from their per-turn approved markers. +emitGateClear :: TurnPaths -> IO () +emitGateClear paths = do + cleared <- clearedPhases paths + unless (null cleared) (emitSystemMessage ("gate clear:" <> Text.concat (map (" " <>) cleared))) + +clearedPhases :: TurnPaths -> IO [Text] +clearedPhases paths = + catMaybes + <$> sequence + [ namedIfPresent (dumbifyApproved paths) "dumbify" + , namedIfPresent (critiqueApproved paths) "critique" + , namedIfPresent (reviewApproved paths) "rules" + ] + +namedIfPresent :: FilePath -> Text -> IO (Maybe Text) +namedIfPresent path name = do + present <- flagExists path + pure (if present then Just name else Nothing) diff --git a/src/Claude/Gate/Transcript.hs b/src/Claude/Gate/Transcript.hs new file mode 100644 --- /dev/null +++ b/src/Claude/Gate/Transcript.hs @@ -0,0 +1,135 @@ +-- | Extract the assistant's claims this turn from the session transcript. +-- +-- The transcript is JSON Lines. A real user message is @type == "user"@ with a +-- /string/ content; a tool reply is also @type == "user"@ but with an /array/ +-- content, which is how the two are told apart. The critique phase refutes the +-- prose the assistant produced since the most recent real user message, so we +-- collect the text blocks of every assistant entry after that point. +module Claude.Gate.Transcript + ( TranscriptLine(..) + , classifyLine + , turnAssistantText + ) where + +import Data.Aeson (Value (Array, Object, String)) +import Data.Aeson qualified as Aeson +import Data.Aeson.Key qualified as Key +import Data.Aeson.KeyMap qualified as KeyMap +import Data.ByteString.Char8 qualified as ByteString +import Data.Foldable (toList) +import Data.Text (Text) +import Data.Text qualified as Text +import System.Directory (doesFileExist) + +-- | One transcript entry, reduced to what the critique cares about: a real user +-- prompt (the boundary), an assistant turn with its text blocks, or neither. +data TranscriptLine + = RealUserPrompt + | AssistantText [Text] + | OtherLine + deriving stock (Eq, Show) + +-- | Classify a decoded transcript entry. Anything that is not a string-content +-- user message or an assistant message is OtherLine; that is the genuine meaning +-- of "an entry we do not care about", not a swallowed parse error (malformed +-- JSON never reaches here, see 'readLines'). +classifyLine :: Value -> TranscriptLine +classifyLine value = case lookupKey "type" value of + Just (String "user") -> userLine (messageContent value) + Just (String "assistant") -> assistantLine (messageContent value) + -- Any other "type" string is an entry we ignore. String values cannot be + -- enumerated, so this is the one unavoidable catch-all. + Just (String _otherType) -> OtherLine + Just (Object _) -> OtherLine + Just (Array _) -> OtherLine + Just (Aeson.Number _) -> OtherLine + Just (Aeson.Bool _) -> OtherLine + Just Aeson.Null -> OtherLine + Nothing -> OtherLine + +-- | A user entry is a real prompt only when its content is a string; an array +-- content is a tool result, which does not count as a turn boundary. +userLine :: Maybe Value -> TranscriptLine +userLine = \case + Just (String _userText) -> RealUserPrompt + Just (Object _) -> OtherLine + Just (Array _) -> OtherLine + Just (Aeson.Number _) -> OtherLine + Just (Aeson.Bool _) -> OtherLine + Just Aeson.Null -> OtherLine + Nothing -> OtherLine + +-- | An assistant entry contributes its text blocks. Array content is the list of +-- content blocks (we keep the @text@ ones); a bare string content is itself the +-- text. +assistantLine :: Maybe Value -> TranscriptLine +assistantLine = \case + Just (Array items) -> AssistantText (collectTextBlocks (toList items)) + Just (String text) -> AssistantText [text] + Just (Object _) -> OtherLine + Just (Aeson.Number _) -> OtherLine + Just (Aeson.Bool _) -> OtherLine + Just Aeson.Null -> OtherLine + Nothing -> OtherLine + +messageContent :: Value -> Maybe Value +messageContent value = lookupKey "message" value >>= lookupKey "content" + +collectTextBlocks :: [Value] -> [Text] +collectTextBlocks items = + [ text + | item <- items + , lookupKey "type" item == Just (String "text") + , Just (String text) <- [lookupKey "text" item] + ] + +lookupKey :: Text -> Value -> Maybe Value +lookupKey key value = case value of + Object fields -> KeyMap.lookup (Key.fromText key) fields + Array _ -> Nothing + String _ -> Nothing + Aeson.Number _ -> Nothing + Aeson.Bool _ -> Nothing + Aeson.Null -> Nothing + +-- | The assistant's text since the most recent real user message, joined with +-- newlines. This is the prose the critic refutes. A missing transcript is empty. +turnAssistantText :: FilePath -> IO Text +turnAssistantText path = do + present <- doesFileExist path + if not present + then pure "" + else do + transcriptLines <- readLines path + pure (Text.intercalate "\n" (concatMap assistantTextsOf (linesAfterLastUserPrompt transcriptLines))) + +assistantTextsOf :: TranscriptLine -> [Text] +assistantTextsOf = \case + RealUserPrompt -> [] + AssistantText texts -> texts + OtherLine -> [] + +-- | The suffix of lines following the last real user prompt. Implemented by +-- reversing, taking lines up to the first prompt from the end, then reversing +-- back: 'takeWhile' from the end stops at the most recent prompt, so what +-- survives is exactly the lines after it (or all lines if there is no prompt). +linesAfterLastUserPrompt :: [TranscriptLine] -> [TranscriptLine] +linesAfterLastUserPrompt = reverse . takeWhile (not . isRealUserPrompt) . reverse + +isRealUserPrompt :: TranscriptLine -> Bool +isRealUserPrompt = \case + RealUserPrompt -> True + AssistantText _ -> False + OtherLine -> False + +-- | Parse the transcript file into classified lines. Blank lines and lines that +-- are not valid JSON classify as OtherLine; the transcript is appended to live +-- and the tail can be a partial write, so a single unparseable line is expected +-- noise, not a failure of the whole turn. +readLines :: FilePath -> IO [TranscriptLine] +readLines path = do + contents <- ByteString.readFile path + pure (map classifyRaw (ByteString.lines contents)) + +classifyRaw :: ByteString.ByteString -> TranscriptLine +classifyRaw raw = maybe OtherLine classifyLine (Aeson.decodeStrict raw) diff --git a/src/Claude/Gate/TurnState.hs b/src/Claude/Gate/TurnState.hs new file mode 100644 --- /dev/null +++ b/src/Claude/Gate/TurnState.hs @@ -0,0 +1,184 @@ +-- | Per-turn state kept on tmpfs, shared by the hooks and the three Stop-gate +-- phases (dumbify, critique, rule review). +-- +-- A "turn" is one user prompt and everything the agent does to satisfy it. +-- record-edit appends to the review stack during the turn; each Stop-gate phase +-- keeps its own done/round/editmark/approved flags here so it converges across +-- the turn's repeated Stops; reset wipes the whole directory when the next user +-- prompt arrives. All of it lives under @$TMPDIR/claude-turn-state/@. +module Claude.Gate.TurnState + ( TurnPaths(..) + , turnPaths + , sanitiseSession + , ensureStateDir + , resetState + , claimReviewStack + , flagExists + , writeFlag + , readCounter + , writeCounter + , readMark + , stackLineCount + , fileNonEmpty + , removeIfExists + ) where + +import Control.Monad (when) + +import Data.ByteString.Char8 qualified as ByteString +import Data.Char (isAsciiLower, isAsciiUpper, isDigit, isSpace) +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import Data.Text qualified as Text +import System.Directory (createDirectoryIfMissing, doesFileExist, getFileSize, removeFile, removePathForcibly, renameFile) +import System.Environment (lookupEnv) +import System.FilePath (()) +import Text.Read (readMaybe) + +-- | Every state file for one session. Grouping them keeps the on-disk layout in +-- one place rather than recomputed in each phase. The @*Done@ flags stop a phase +-- re-running once it has converged this turn; @*Round@ counts rounds against the +-- per-phase cap; @*Editmark@ records the edit-stack size a block was based on so +-- the next Stop can tell a fix (stack grew) from a shrug (unchanged); @*Approved@ +-- records a clean pass for the end-of-gate notice; @*Broke@ is the once-per-turn +-- guard for surfacing an infrastructure failure. +data TurnPaths = TurnPaths + { stateDir :: FilePath + , reviewStack :: FilePath + , claimedStack :: FilePath + , dumbifyDone :: FilePath + , dumbifyRound :: FilePath + , dumbifyEditmark :: FilePath + , dumbifyApproved :: FilePath + , dumbifyBroke :: FilePath + , critiqueDone :: FilePath + , critiqueRound :: FilePath + , critiquePrev :: FilePath + , critiqueEditmark :: FilePath + , critiqueApproved :: FilePath + , critiqueBroke :: FilePath + , reviewApproved :: FilePath + , reviewBroke :: FilePath + } + +-- | Resolve the state paths for a session id, reading TMPDIR the same way the +-- shell hooks did (defaulting to /tmp). +turnPaths :: Text -> IO TurnPaths +turnPaths session = do + tmp <- fromMaybe "/tmp" <$> lookupEnv "TMPDIR" + let dir = tmp "claude-turn-state" Text.unpack (sanitiseSession session) + pure + TurnPaths + { stateDir = dir + , reviewStack = dir "edits.jsonl" + , claimedStack = dir "edits.processing" + , dumbifyDone = dir "dumbify-done" + , dumbifyRound = dir "dumbify-round" + , dumbifyEditmark = dir "dumbify-editmark" + , dumbifyApproved = dir "dumbify-approved" + , dumbifyBroke = dir "dumbify-broke" + , critiqueDone = dir "critique-done" + , critiqueRound = dir "critique-round" + , critiquePrev = dir "critique-prev" + , critiqueEditmark = dir "critique-editmark" + , critiqueApproved = dir "critique-approved" + , critiqueBroke = dir "critique-broke" + , reviewApproved = dir "review-approved" + , reviewBroke = dir "review-broke" + } + +-- | Make the session id safe to use as a single path component by replacing any +-- character outside @[A-Za-z0-9_.-]@ with an underscore, matching the shell +-- @tr -c@ the hooks used. +sanitiseSession :: Text -> Text +sanitiseSession = Text.map keepOrUnderscore + +keepOrUnderscore :: Char -> Char +keepOrUnderscore character + | isSafe character = character + | otherwise = '_' + +isSafe :: Char -> Bool +isSafe character = + isAsciiUpper character + || isAsciiLower character + || isDigit character + || character == '_' + || character == '.' + || character == '-' + +ensureStateDir :: TurnPaths -> IO () +ensureStateDir paths = createDirectoryIfMissing True (stateDir paths) + +-- | Wipe a session's state directory. Used by the UserPromptSubmit reset so the +-- previous turn's review stack and per-phase flags do not leak into the next. +resetState :: TurnPaths -> IO () +resetState paths = removePathForcibly (stateDir paths) + +-- | Atomically claim the review stack: rename edits.jsonl to edits.processing +-- so any edit recorded after this point lands on a fresh stack and is reviewed +-- on the next Stop rather than lost. Returns whether there was a stack to claim. +claimReviewStack :: TurnPaths -> IO Bool +claimReviewStack paths = do + hasStack <- doesFileExist (reviewStack paths) + if hasStack + then renameFile (reviewStack paths) (claimedStack paths) >> pure True + else pure False + +-- | Whether a marker/flag file is present. +flagExists :: FilePath -> IO Bool +flagExists = doesFileExist + +-- | Create an empty marker file (the shell @: > flag@). +writeFlag :: FilePath -> IO () +writeFlag path = writeFile path "" + +-- | Read an integer counter file, defaulting to 0 when absent or unparseable. +readCounter :: FilePath -> IO Int +readCounter path = do + present <- doesFileExist path + if not present + then pure 0 + else do + -- Strict read. A lazy 'Prelude.readFile' leaves the handle open until the + -- contents thunk is forced, and the very next 'writeCounter' (which is + -- 'withFile' in WriteMode) on the same path then dies with "resource busy + -- (file is locked)" under GHC's single-writer file locking. Reading + -- strictly closes the handle before we return. See handleChallenge, which + -- reads then immediately rewrites critique-round. + contents <- ByteString.readFile path + pure (fromMaybe 0 (readMaybe (filter (not . isSpace) (ByteString.unpack contents)))) + +writeCounter :: FilePath -> Int -> IO () +writeCounter path n = writeFile path (show n) + +-- | Read an editmark, distinguishing "no mark written yet" (Nothing) from a +-- recorded count: a phase only treats an unchanged stack as a shrug when it +-- actually wrote a mark on a previous Stop this turn. +readMark :: FilePath -> IO (Maybe Int) +readMark path = do + present <- doesFileExist path + if present then Just <$> readCounter path else pure Nothing + +-- | The number of recorded edits, i.e. non-empty lines on a stack file. Used as +-- the convergence signal: it grows when the worker makes new edits. +stackLineCount :: FilePath -> IO Int +stackLineCount path = do + present <- doesFileExist path + if not present + then pure 0 + else do + contents <- ByteString.readFile path + pure (length (filter (not . ByteString.null) (ByteString.lines contents))) + +-- | Whether a file exists and has non-zero size. +fileNonEmpty :: FilePath -> IO Bool +fileNonEmpty path = do + present <- doesFileExist path + if present then (> 0) <$> getFileSize path else pure False + +-- | Remove a file if it is there; absence is fine. +removeIfExists :: FilePath -> IO () +removeIfExists path = do + present <- doesFileExist path + when present (removeFile path) diff --git a/test/Test.hs b/test/Test.hs new file mode 100644 --- /dev/null +++ b/test/Test.hs @@ -0,0 +1,386 @@ +module Main (main) where + +import Control.Exception (ErrorCall (ErrorCall), SomeException, displayException, throwIO, try) +import Data.Aeson (Result (Success), Value, eitherDecode, eitherDecodeStrict, encode, fromJSON, toJSON) +import Data.ByteString.Lazy qualified as LazyByteString +import Data.ByteString.Char8 qualified as ByteString +import Data.List (isInfixOf) +import Data.Text (Text) +import Data.Text qualified as Text +import Claude.Gate.Corpus (selectSkills) +import Data.IORef (IORef, newIORef, readIORef, writeIORef) +import Claude.Gate.Critique + ( CritiqueDossier (DossierReady, EmptyDossier) + , EditPresence (EditsRecorded, NoEditsRecorded) + , RoundBudget (RoundBudget) + , classifyDossier + , critiqueAnchor + , critiqueDiffBlock + , recentClaims + , retryWhileEmpty + ) +import Claude.Gate.DiffRender (renderDiffs) +import Claude.Gate.Edit (Edit (..), Replacement (..), editFilePath, parseEditFromTool) +import Claude.Gate.RecordEdit (SkipReason (..), pathSkipReason) +import Claude.Gate.ReviewPrompt (hasViolations) +import Claude.Gate.SpawnAnnotation (annotateSpawn) +import Claude.Gate.Transcript (turnAssistantText) +import Claude.Gate.TurnState (readCounter, writeCounter) +import Hedgehog (Gen, Property, forAll, property, (===)) +import Hedgehog.Gen qualified as Gen +import Hedgehog.Range qualified as Range +import System.Directory (getTemporaryDirectory) +import System.FilePath (()) +import Test.Tasty (TestTree, defaultMain, testGroup) +import Test.Tasty.Hedgehog (testProperty) +import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=)) + +main :: IO () +main = defaultMain tests + +tests :: TestTree +tests = + testGroup + "claude-gate" + [ transcriptTests + , skillSelectionTests + , skipReasonTests + , violationTests + , editRoundTripTests + , editPropertyTests + , critiqueDiffTests + , recentClaimsTests + , critiqueAnchorTests + , claimsRetryTests + , dossierTests + , counterTests + , spawnAnnotationTests + ] + +-- The claims blob accumulates across a turn's critique rounds and is +-- chronological, so when it exceeds the budget the critic must keep the NEWEST +-- claims (the current round) and drop the oldest. A front trim (the old +-- Text.take) kept the oldest and dropped the newest, which is what fed the critic +-- stale claims. These assert the tail survives and the head is dropped. + +recentClaimsTests :: TestTree +recentClaimsTests = + testGroup + "recentClaims" + [ testCase "keeps the newest claims and drops the oldest over budget" $ do + let oldest = "OLDEST-round-1-run-A" + newest = "NEWEST-round-3-run-C" + blob = oldest <> Text.replicate 200 "x" <> newest + trimmed = recentClaims (Text.length newest + 20) blob + assertBool "the current round's claim survives" (Text.isInfixOf newest trimmed) + assertBool "the stale first round's claim is dropped" (not (Text.isInfixOf oldest trimmed)) + , testCase "claims within budget pass through unchanged" $ + recentClaims 1000 "short claim" @?= "short claim" + ] + +-- The anchor threads the round and the commit history into the prompt. The one +-- piece of logic (not static text) is that a missing history is turned into an +-- explicit placeholder rather than dropped, and a present history is carried +-- through verbatim so the critic actually sees the real commit order. + +critiqueAnchorTests :: TestTree +critiqueAnchorTests = + testGroup + "critiqueAnchor" + [ testCase "a present commit history is carried through verbatim" $ + assertBool + "the supplied history appears in the anchor" + (Text.isInfixOf "deadbeef 2026-07-10T12:00:00Z fix the thing" (critiqueAnchor (RoundBudget 2 3) (Just "deadbeef 2026-07-10T12:00:00Z fix the thing"))) + , testCase "a missing history becomes an explicit placeholder, not a blank" $ + assertBool + "the placeholder names the missing history" + (Text.isInfixOf "unavailable" (critiqueAnchor (RoundBudget 1 2) Nothing)) + ] + +-- The transcript can lag the Stop hook (the final assistant message flushes +-- after the hook fires), so the claims read polls via 'retryWhileEmpty'. These +-- drive the real retry loop with a scripted sequence of reads: it must return +-- at the first non-blank read, keep polling past blank ones, and hand back the +-- final blank result when the budget runs out so the caller can fail loud. + +claimsRetryTests :: TestTree +claimsRetryTests = + testGroup + "retryWhileEmpty" + [ testCase "returns at the first non-blank read without extra attempts" $ do + (result, reads') <- scriptedRetry 5 ["claims right away"] + result @?= "claims right away" + reads' @?= 1 + , testCase "polls past blank reads until text appears" $ do + (result, reads') <- scriptedRetry 5 ["", " \n ", "late claims"] + result @?= "late claims" + reads' @?= 3 + , testCase "gives up blank after the attempt budget so the caller can fail loud" $ do + (result, reads') <- scriptedRetry 3 ["", "", "", "", ""] + result @?= "" + reads' @?= 3 + ] + +-- | Drive 'retryWhileEmpty' (with no pause between attempts) through a +-- scripted sequence of reads, returning the final result and the number of +-- reads it consumed. +scriptedRetry :: Int -> [Text] -> IO (Text, Int) +scriptedRetry attempts script = do + counter <- newIORef (0 :: Int) + result <- retryWhileEmpty attempts 0 (nextScriptedRead counter script) + reads' <- readIORef counter + pure (result, reads') + +nextScriptedRead :: IORef Int -> [Text] -> IO Text +nextScriptedRead counter script = do + index <- readIORef counter + writeIORef counter (index + 1) + case drop index script of + [] -> throwIO (ErrorCall "scripted retry consumed more reads than the test provided") + next : _ -> pure next + +-- The empty-dossier rule: a critic spawned with neither claims nor edits can +-- only answer OK, and that OK must never be recorded as approval. The +-- classification decides between failing loud and spawning the critic, so a +-- wrong verdict here either wedges healthy turns or silently green-stamps +-- unchecked ones. + +dossierTests :: TestTree +dossierTests = + testGroup + "classifyDossier" + [ testCase "no claims and no edits is an empty dossier" $ + classifyDossier "" NoEditsRecorded @?= EmptyDossier + , testCase "whitespace-only claims count as no claims" $ + classifyDossier " \n \t " NoEditsRecorded @?= EmptyDossier + , testCase "claims alone are enough to critique" $ + classifyDossier "I fixed the bug" NoEditsRecorded @?= DossierReady + , testCase "edits alone are enough to critique" $ + classifyDossier "" EditsRecorded @?= DossierReady + ] + +-- A spawn that fails (a missing binary, or a /bin symlink left dangling by a +-- nix GC) must not vanish into a bare posix_spawnp error: 'annotateSpawn' tags +-- the exception with its command so an uncaught crash, or a displayException of +-- a caught one, names the call site. The assertion drives a real exception +-- through 'annotateSpawn' and checks the label survives into displayException. + +spawnAnnotationTests :: TestTree +spawnAnnotationTests = + testGroup + "annotateSpawn" + [ testCase "a failing spawn carries its call site into displayException" $ do + let spawnLabel = "git -C /x rev-parse --show-toplevel" + outcome <- try (annotateSpawn spawnLabel (throwIO (ErrorCall "spawn blew up"))) + case (outcome :: Either SomeException ()) of + Right () -> assertFailure "expected the wrapped action to throw" + Left err -> + assertBool + "displayException names the spawn call site" + (spawnLabel `isInfixOf` displayException err) + ] + +-- A read-then-write on the same counter file, the exact sequence handleChallenge +-- runs on critique-round. With a lazy 'readFile' inside 'readCounter' the read +-- handle is still open when 'writeCounter' opens the path in WriteMode, and GHC's +-- single-writer file lock aborts with "resource busy (file is locked)". The +-- assertion is that the cycle completes and round-trips the value. +counterTests :: TestTree +counterTests = + testGroup + "TurnState counters" + [ testCase "readCounter then writeCounter on the same path does not lock" $ do + dir <- getTemporaryDirectory + let path = dir "claude-gate-counter-roundtrip" + writeCounter path 1 + previous <- readCounter path + writeCounter path (previous + 1) + final <- readCounter path + final @?= 2 + ] + +-- The critique claims-extraction end to end: write a transcript file and ask the +-- real 'turnAssistantText' for the assistant prose since the last real user +-- prompt. This exercises line parsing, "since the last real user prompt", and +-- text-block extraction together, which is where the gnarly logic lives. + +transcriptTests :: TestTree +transcriptTests = + testGroup + "turnAssistantText" + [ testCase "collects assistant text after the last user prompt" $ do + claims <- claimsFor "after" [userPrompt, assistantSays "I fixed the bug"] + claims @?= "I fixed the bug" + , testCase "ignores assistant text before the last user prompt" $ do + -- The first claim is from a previous turn; only the latest turn counts. + claims <- claimsFor "before" [assistantSays "old claim", userPrompt, assistantSays "new claim"] + claims @?= "new claim" + , testCase "joins multiple assistant turns with newlines" $ do + claims <- claimsFor "multi" [userPrompt, assistantSays "first", assistantSays "second"] + claims @?= "first\nsecond" + , testCase "a tool-reply user entry is not a turn boundary" $ do + -- The array-content user entry is a tool result, not a real prompt, so + -- the earlier claim is still in this turn. + claims <- claimsFor "toolreply" [userPrompt, assistantSays "before tool", toolResult, assistantSays "after tool"] + claims @?= "before tool\nafter tool" + ] + +claimsFor :: String -> [Text] -> IO Text +claimsFor name transcriptLines = do + tmp <- getTemporaryDirectory + let path = tmp ("claude-gate-test-" <> name <> ".jsonl") + writeFile path (Text.unpack (Text.unlines transcriptLines)) + turnAssistantText path + +userPrompt :: Text +userPrompt = "{\"type\":\"user\",\"message\":{\"content\":\"do the thing\"}}" + +toolResult :: Text +toolResult = "{\"type\":\"user\",\"message\":{\"content\":[{\"type\":\"tool_result\",\"content\":\"ok\"}]}}" + +assistantSays :: Text -> Text +assistantSays text = + "{\"type\":\"assistant\",\"message\":{\"content\":[{\"type\":\"text\",\"text\":\"" + <> text + <> "\"}]}}" + +-- Skill selection maps touched extensions to the relevant language skills. + +skillSelectionTests :: TestTree +skillSelectionTests = + testGroup + "selectSkills" + [ testCase "haskell sources pull in the haskell skills" $ + selectSkills ["src/Foo.hs"] + @?= ["error-messages", "haskell-backpack", "haskell-project", "unwitch-conversions", "verify-test-fails"] + , testCase "nix files pull in the nix skills" $ + selectSkills ["default.nix"] @?= ["ci-nix", "nix"] + , testCase "unrelated files select nothing" $ + selectSkills ["notes.md"] @?= [] + , testCase "results are deduplicated across many files" $ + selectSkills ["A.hs", "B.hs", "x.cabal"] + @?= ["error-messages", "haskell-backpack", "haskell-project", "unwitch-conversions", "verify-test-fails"] + ] + +-- The record filter: which paths are skipped and why. + +skipReasonTests :: TestTree +skipReasonTests = + testGroup + "pathSkipReason" + [ testCase "haskell source is reviewed" $ pathSkipReason "src/Foo.hs" @?= Nothing + , testCase "json is skipped as binary-ish" $ pathSkipReason "package.json" @?= Just SkipBinaryExtension + , testCase "archives are skipped" $ pathSkipReason "bundle.tar.gz" @?= Just SkipArchive + , testCase "build artifacts under dist-newstyle are skipped" $ + pathSkipReason "/home/x/dist-newstyle/build/Foo.hs" @?= Just SkipBuildArtifact + , testCase "the result symlink is skipped" $ pathSkipReason "/home/x/result" @?= Just SkipBuildArtifact + ] + +-- Reviewer-reply parsing: only a VIOLATION line means findings. + +violationTests :: TestTree +violationTests = + testGroup + "hasViolations" + [ testCase "the clean reply OK is not a violation" $ hasViolations "OK\n" @?= False + , testCase "empty output is not a violation" $ hasViolations "" @?= False + , testCase "a VIOLATION block is a violation" $ + hasViolations "VIOLATION: used a wildcard\nRULE: \"...\"\n" @?= True + , testCase "the word violation mid-line is not a violation" $ + hasViolations "no violation here\n" @?= False + ] + +-- Edits survive the persist/reload round trip the two hooks rely on, and the +-- reconstructed diff shows the new text under the right label. + +editRoundTripTests :: TestTree +editRoundTripTests = + testGroup + "edit persistence" + [ testCase "an Edit round-trips and renders its new text" $ do + edit <- parsedEdit "Edit" "{\"file_path\":\"src/Foo.hs\",\"old_string\":\"old line\",\"new_string\":\"new line\"}" + reloaded <- reencode edit + editFilePath reloaded @?= "src/Foo.hs" + let rendered = renderDiffs [reloaded] + assertBool "new text under --- with ---" (Text.isInfixOf "--- with ---\nnew line" rendered) + assertBool "old text under --- replaced ---" (Text.isInfixOf "--- replaced ---\nold line" rendered) + , testCase "a Write round-trips and renders its content" $ do + edit <- parsedEdit "Write" "{\"file_path\":\"a.txt\",\"content\":\"hello body\"}" + reloaded <- reencode edit + assertBool "content under --- new content ---" (Text.isInfixOf "--- new content ---\nhello body" (renderDiffs [reloaded])) + ] + +-- The critic runs on every turn, including conversational ones with no edits. On +-- such a turn there is no review stack on disk, so the diff block must come back +-- as the placeholder WITHOUT reading (and crashing on) the absent stack file. +-- This is the regression: the old code read the stack unconditionally and died on +-- a missing edits.jsonl, which silently killed the whole critique phase. + +critiqueDiffTests :: TestTree +critiqueDiffTests = + testGroup + "critiqueDiffBlock" + [ testCase "a no-edit turn yields the placeholder without touching the stack" $ do + block <- critiqueDiffBlock NoEditsRecorded "/no/such/edits.jsonl" + block @?= "(no file edits this turn)" + , testCase "an edited turn renders the recorded diff" $ do + edit <- parsedEdit "Edit" "{\"file_path\":\"src/Foo.hs\",\"old_string\":\"old line\",\"new_string\":\"new line\"}" + stackPath <- writeStack "critique-edits" [edit] + block <- critiqueDiffBlock EditsRecorded stackPath + assertBool "new text appears in the diff block" (Text.isInfixOf "new line" block) + ] + +-- | Write edits to a stack file in the one-JSON-per-line form record-edit uses, +-- so the reader under test sees exactly what production writes. +writeStack :: String -> [Edit] -> IO FilePath +writeStack name edits = do + tmp <- getTemporaryDirectory + let path = tmp ("claude-gate-test-" <> name <> ".jsonl") + LazyByteString.writeFile path (LazyByteString.intercalate "\n" (map encode edits)) + pure path + +parsedEdit :: Text -> ByteString.ByteString -> IO Edit +parsedEdit tool inputJson = case eitherDecodeStrict inputJson of + Left err -> fail ("test fixture is not valid JSON: " <> err) + Right (value :: Value) -> case parseEditFromTool tool value of + Left err -> fail ("parseEditFromTool failed: " <> err) + Right edit -> pure edit + +reencode :: Edit -> IO Edit +reencode edit = case eitherDecode (encode edit) of + Left err -> fail ("edit did not round-trip: " <> err) + Right reloaded -> pure reloaded + +-- The JSON instances the two hooks rely on must satisfy +-- fromJSON (toJSON e) == Success e for every edit shape, checked over +-- generated inputs rather than the few hand-written fixtures above. + +editPropertyTests :: TestTree +editPropertyTests = + testGroup + "edit JSON property" + [ testProperty "fromJSON . toJSON == Success" editJsonRoundTrip + ] + +editJsonRoundTrip :: Property +editJsonRoundTrip = property $ do + edit <- forAll genEdit + fromJSON (toJSON edit) === Success edit + +genEdit :: Gen Edit +genEdit = + Gen.choice + [ SingleEdit <$> genPath <*> genReplacement + , MultiEditFile <$> genPath <*> Gen.list (Range.linear 0 4) genReplacement + , WriteFileContent <$> genPath <*> genText + , NotebookCellSource <$> genPath <*> genText + ] + +genReplacement :: Gen Replacement +genReplacement = Replacement <$> genText <*> genText + +genText :: Gen Text +genText = Gen.text (Range.linear 0 40) Gen.unicode + +genPath :: Gen FilePath +genPath = Gen.string (Range.linear 1 30) Gen.alphaNum