diff --git a/help/agent.md b/help/agent.md --- a/help/agent.md +++ b/help/agent.md @@ -134,7 +134,19 @@ Parent --debug prints every pending migration prompt in order without contacting a provider or writing receipts. It does run the version probe, which is required to be read-only, so debug planning matches a - real run. A receipt records provider completion, not package-manager + real run. + + --mark-applied records every pending edge in the window as already + applied, without running them, on your assertion that you performed the + upgrade by hand. No provider is contacted and no file in the working + tree is changed. Each receipt is filed under the blueprint that owns its + edge, so a marked entailed edge suppresses a later direct run of that + blueprint too; edges that already have receipts are left alone rather + than restamped. --rerun clears a mistaken marking. The flag is refused + alongside --rerun or parent --debug, both of which it contradicts. + + A receipt records that an edge has been dealt with -- a provider + interaction returned, or you marked it -- not package-manager verification. seihou prompt run PROMPT [USER-PROMPT] [--var KEY=VALUE] [--debug] diff --git a/help/blueprints.md b/help/blueprints.md --- a/help/blueprints.md +++ b/help/blueprints.md @@ -132,9 +132,13 @@ receipt before the next session. Rerunning resumes; --rerun repeats matching receipts. Parent --debug prints pending prompts without launching or writing. + --mark-applied records the pending edges in a window as already applied + without running them, for a consumer who performed the upgrade by hand. + Migration mode reuses variables, shared prompt, references, and allowed tools, - but never applies baseModules. A receipt records agent completion, not proof - that a package manager now reports the target version. + but never applies baseModules. A receipt records that an edge has been dealt + with -- an agent session returned, or the consumer marked it -- not proof that + a package manager now reports the target version. COMMON COMMANDS diff --git a/help/migrations.md b/help/migrations.md --- a/help/migrations.md +++ b/help/migrations.md @@ -17,8 +17,11 @@ Parent --debug renders pending prompts in order without launching a provider or changing the manifest. Migration mode never applies blueprint baseModules. - A receipt means the agent interaction completed successfully. It does not - verify that Cabal, npm, Cargo, or another package manager reports the target. + A receipt means the edge has been dealt with and need not run again: either + the agent interaction completed, or the consumer upgraded by hand and said so + with --mark-applied, which records the pending edges in a window without + starting a session. It does not verify that Cabal, npm, Cargo, or another + package manager reports the target. DETERMINISTIC MODULE MIGRATIONS diff --git a/seihou-cli.cabal b/seihou-cli.cabal --- a/seihou-cli.cabal +++ b/seihou-cli.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: seihou-cli -version: 0.7.0.0 +version: 0.8.0.0 synopsis: CLI for Seihou project scaffolding description: Command-line interface for Seihou, a composable project scaffolding @@ -126,7 +126,7 @@ generic-lens >=2.2 && <3, lens >=5.2 && <6, process >=1.6 && <2, - seihou-core ^>=0.7.0.0, + seihou-core ^>=0.8.0.0, streamly-core >=0.3 && <0.5, temporary >=1.3 && <2, text >=2.0 && <3, @@ -211,7 +211,7 @@ optparse-applicative >=0.18 && <1, process >=1.6 && <2, seihou-cli-internal, - seihou-core ^>=0.7.0.0, + seihou-core ^>=0.8.0.0, temporary >=1.3 && <2, text >=2.0 && <3, time >=1.12 && <2, @@ -291,7 +291,7 @@ lens >=5.2 && <6, process >=1.6 && <2, seihou-cli-internal, - seihou-core ^>=0.7.0.0, + seihou-core ^>=0.8.0.0, streamly-core >=0.3 && <0.5, tasty >=1.4 && <2, tasty-hspec >=1.2 && <2, diff --git a/src-exe/Seihou/CLI/AgentMigrate.hs b/src-exe/Seihou/CLI/AgentMigrate.hs --- a/src-exe/Seihou/CLI/AgentMigrate.hs +++ b/src-exe/Seihou/CLI/AgentMigrate.hs @@ -45,6 +45,8 @@ ResolvedWindow (..), VersionProbeResult (..), formatBlueprintMigrationDebugOutput, + formatMarkAppliedNotice, + formatMarkAppliedSummary, formatMigrationStepLabel, formatProbeFailure, formatResolvedWindow, @@ -104,6 +106,13 @@ let level = if opts ^. #verbose then LogVerbose else LogNormal manifestPath = ".seihou" "manifest.json" + -- Two --mark-applied combinations cannot mean anything, and both are + -- refused here rather than resolved by precedence. This is the first thing + -- the command does: the refusal must land before the blueprint is + -- discovered, before the version probe runs, and above all before a receipt + -- is written, so an invalid invocation leaves the filesystem untouched. + rejectConflictingMarkApplied debug opts + -- The blueprint's discovery directory is classified into a portable origin -- as it is loaded. Receipts are keyed by that origin, not by the name the -- user typed, so a blueprint of the same name from another repository has @@ -216,56 +225,141 @@ expandedPlan if null pending then reportNoPending expandedPlan - else do - -- One execution context per blueprint that owns a pending step, so - -- each step gets its own reference files, allowed tools, and - -- variables. All of them are resolved now rather than lazily per - -- step: a user should answer every prompt up front rather than - -- being interrupted between agent sessions. - preparedByOwner <- prepareCohort level modelConfig opts cohort pending - traceSink <- traceSinkForConfig level modelConfig - context <- gatherAgentContext - let signalPath = notApplicableSignalPath projectRoot - renderStep position total step = - case Map.lookup (step ^. #owner) preparedByOwner of - Nothing -> missingOwnerMessage step - Just prepared -> - renderBlueprintMigrationSystemPrompt - migrationPromptTemplate - signalPath - context - prepared - position - total - step - renderDebugStep position total step = - renderStep position total step - <> maybe - "" - ("\n\n===== Initial user instruction =====\n" <>) - (opts ^. #prompt) - - if debug - then - TIO.putStrLn $ - "Blueprint migrations for " - <> invokedName - <> ": " - <> renderVersion (expandedPlan ^. #from) - <> " -> " - <> renderVersion (expandedPlan ^. #to) - <> "\n" - <> formatBlueprintMigrationDebugOutput renderDebugStep pending + else + if opts ^. #markApplied + then markPendingAsApplied level manifestPath cohort pending else do - -- The agent needs somewhere to put the signal file, and the - -- directory is created by the first receipt anyway. - createDirectoryIfMissing True (takeDirectory signalPath) - result <- - runBlueprintMigrationsWith - (launchMigration traceSink modelConfig opts preparedByOwner signalPath renderStep) - (recordMigration manifestPath cohort) - pending - handleRunResult level (blueprint ^. #name) result + -- One execution context per blueprint that owns a pending step, so + -- each step gets its own reference files, allowed tools, and + -- variables. All of them are resolved now rather than lazily per + -- step: a user should answer every prompt up front rather than + -- being interrupted between agent sessions. + preparedByOwner <- prepareCohort level modelConfig opts cohort pending + traceSink <- traceSinkForConfig level modelConfig + context <- gatherAgentContext + let signalPath = notApplicableSignalPath projectRoot + renderStep position total step = + case Map.lookup (step ^. #owner) preparedByOwner of + Nothing -> missingOwnerMessage step + Just prepared -> + renderBlueprintMigrationSystemPrompt + migrationPromptTemplate + signalPath + context + prepared + position + total + step + renderDebugStep position total step = + renderStep position total step + <> maybe + "" + ("\n\n===== Initial user instruction =====\n" <>) + (opts ^. #prompt) + + if debug + then + TIO.putStrLn $ + "Blueprint migrations for " + <> invokedName + <> ": " + <> renderVersion (expandedPlan ^. #from) + <> " -> " + <> renderVersion (expandedPlan ^. #to) + <> "\n" + <> formatBlueprintMigrationDebugOutput renderDebugStep pending + else do + -- The agent needs somewhere to put the signal file, and the + -- directory is created by the first receipt anyway. + createDirectoryIfMissing True (takeDirectory signalPath) + result <- + runBlueprintMigrationsWith + (launchMigration traceSink modelConfig opts preparedByOwner signalPath renderStep) + (recordMigration manifestPath cohort) + pending + handleRunResult level (blueprint ^. #name) result + +-- | Record every pending step as applied without running it. +-- +-- Each receipt goes through 'recordMigration', the same function the real run +-- uses, so a marked receipt is indistinguishable from a run one and is written +-- under the identity of the blueprint that /owns/ the edge rather than the one +-- the user named. Reusing it is the point: a second receipt-construction site +-- could drift from the ownership rule in +-- docs\/adr\/0008-an-entailed-migration-edge-is-owned-by-the-blueprint-that-declares-it.md, +-- and a receipt written under the wrong identity matches nothing. +-- +-- The outcome is 'MigrationApplied' rather than a third \"applied by hand\" +-- value. A receipt already means \"this edge has been attended to and need not +-- run again\" rather than proof an agent did it, and a hand migration satisfies +-- that meaning exactly; see +-- docs\/adr\/0011-a-migration-receipt-asserts-a-claim-about-the-project.md. +-- +-- Recording stops at the first failure and reports it, leaving earlier +-- receipts in place, which is the same contract the real run has: re-running +-- the same command then records only what is still pending. +markPendingAsApplied :: + LogLevel -> + FilePath -> + Map Text CohortBlueprint -> + [BlueprintMigrationStep] -> + IO () +markPendingAsApplied level manifestPath cohort pending = do + TIO.putStr (formatMarkAppliedNotice pending) + TIO.putStrLn "" + go 0 pending + where + go recorded [] = TIO.putStrLn (formatMarkAppliedSummary recorded) + go recorded (step : rest) = + recordMigration manifestPath cohort step MigrationApplied >>= \case + Right () -> go (recorded + 1) rest + Left err -> + exitErr level $ + "Blueprint migration " + <> formatMigrationStepLabel step + <> " could not be marked as applied: " + <> err + <> ". " + <> markedSoFar recorded + <> " Repair manifest access, then rerun the same command; " + <> "already-recorded edges are no longer pending." + markedSoFar 0 = "No receipts were recorded." + markedSoFar n = + "The first " <> T.pack (show (n :: Int)) <> " edge(s) remain recorded." + +-- | Refuse the two @--mark-applied@ combinations that contradict themselves. +-- +-- Neither has a defensible winner, so neither gets one. @--rerun@ means "run +-- these edges again even though receipts exist" and @--mark-applied@ means +-- "run nothing"; @--debug@ is a true dry run that writes nothing and +-- @--mark-applied@ exists to write receipts. Letting either silently win +-- would leave a user believing something happened that did not. +-- +-- The refusal block follows the shape 'Seihou.CLI.ManifestGuard' established +-- for this command's other refusal — a @✗@ line naming what was refused, then +-- an indented paragraph explaining the conflict and what to do instead. +rejectConflictingMarkApplied :: Bool -> BlueprintMigrationOpts -> IO () +rejectConflictingMarkApplied debug opts + | not (opts ^. #markApplied) = pure () + | opts ^. #rerun = + refuse + [ "✗ --mark-applied and --rerun cannot be combined.", + "", + " --rerun runs edges that already have receipts; --mark-applied records", + " receipts without running anything. Pick one." + ] + | debug = + refuse + [ "✗ --mark-applied cannot be combined with --debug.", + "", + " --debug renders prompts without changing anything; --mark-applied writes", + " migration receipts. Run it without --debug when you are ready to record." + ] + | otherwise = pure () + where + refuse ls = do + TIO.putStrLn (T.intercalate "\n" ls) + exitFailure -- | What a step's owning blueprint declares, for the pure expander. A name -- absent from the cohort was not installed, which the expander reports against diff --git a/src-exe/Seihou/CLI/Commands.hs b/src-exe/Seihou/CLI/Commands.hs --- a/src-exe/Seihou/CLI/Commands.hs +++ b/src-exe/Seihou/CLI/Commands.hs @@ -390,6 +390,11 @@ context :: !(Maybe Text), verbose :: !Bool, rerun :: !Bool, + -- | When 'True', record a receipt for every pending step in the window + -- without starting an agent session, on the user's assertion that the + -- upgrade has already been performed by hand. No provider is contacted + -- and no file in the working tree is touched. + markApplied :: !Bool, provider :: !(Maybe Text), model :: !(Maybe Text), effort :: !(Maybe Text), @@ -1909,6 +1914,10 @@ <*> optional (option (T.pack <$> str) (long "context" <> short 'c' <> metavar "CTX" <> help "Override context for config lookup")) <*> switch (long "verbose" <> short 'v' <> help "Show detailed progress messages") <*> switch (long "rerun" <> help "Run matching migrations even when a receipt already exists") + <*> switch + ( long "mark-applied" + <> help "Record the pending migrations in the window as already applied, without running them" + ) <*> providerOption <*> modelOption <*> effortOption diff --git a/src/Seihou/CLI/BlueprintMigration.hs b/src/Seihou/CLI/BlueprintMigration.hs --- a/src/Seihou/CLI/BlueprintMigration.hs +++ b/src/Seihou/CLI/BlueprintMigration.hs @@ -8,6 +8,8 @@ renderBlueprintMigrationSystemPrompt, formatBlueprintMigrationDebugOutput, formatMigrationStepLabel, + formatMarkAppliedNotice, + formatMarkAppliedSummary, pendingBlueprintMigrations, parseNotApplicableSignal, unstatedNotApplicableReason, @@ -183,6 +185,36 @@ ] where total = length steps + +-- | Announce the steps a @--mark-applied@ run is about to record. +-- +-- Every step is named with 'formatMigrationStepLabel', the one function every +-- user-facing step label goes through, so a marked chain reads the same as a +-- run one and an entailed step still says what pulled it in. +-- +-- \"without running them\" is in the first line rather than only in the +-- summary because this is the sentence a user sees before the receipts are +-- written. Marking asserts something rather than observing it, and someone +-- who reached for the flag by mistake needs the mistake visible here. +formatMarkAppliedNotice :: [BlueprintMigrationStep] -> Text +formatMarkAppliedNotice steps = + T.unlines $ + "Marking " + <> T.pack (show (length steps)) + <> " blueprint migration(s) as already applied, without running them:" + : [" " <> formatMigrationStepLabel step | step <- steps] + +-- | Confirm what a @--mark-applied@ run recorded, once the receipts are in. +-- +-- The second sentence is doing real work. A receipt written this way is an +-- ordinary applied receipt, indistinguishable from one an agent earned, so a +-- user who marked a migration they have not actually performed has to notice +-- immediately — and @--rerun@ is the remedy. +formatMarkAppliedSummary :: Int -> Text +formatMarkAppliedSummary recorded = + "Recorded " + <> T.pack (show recorded) + <> " receipt(s). No agent session was started and no file was changed." -- | Name one step the way every user-facing surface names it: the owning -- blueprint, its edge window, and — when the step was reached through diff --git a/test/Seihou/CLI/AgentMigrateE2ESpec.hs b/test/Seihou/CLI/AgentMigrateE2ESpec.hs --- a/test/Seihou/CLI/AgentMigrateE2ESpec.hs +++ b/test/Seihou/CLI/AgentMigrateE2ESpec.hs @@ -3,9 +3,11 @@ import Control.Lens (to, (^.)) import Data.ByteString.Lazy qualified as LBS import Data.Generics.Labels () +import Data.List (sort) import Data.Maybe (fromMaybe) import Data.Text qualified as T import Data.Text.IO qualified as TIO +import Data.Time (UTCTime) import Seihou.CLI.SeihouBinary (seihouBinary) import Seihou.Core.Types ( AppliedBlueprintMigration (..), @@ -19,6 +21,7 @@ doesFileExist, executable, getPermissions, + listDirectory, removeDirectoryRecursive, setPermissions, ) @@ -135,12 +138,15 @@ launchArgs `shouldSatisfy` elem "--effort" launchArgs `shouldSatisfy` elem "max" - it "exposes an optional version window and the rerun option in help" $ do + it "exposes an optional version window, rerun, and mark-applied in help" $ do binary <- seihouBinary (exitCode, output, _) <- runProcessText binary ["agent", "migrate", "--help"] Nothing Nothing exitCode `shouldBe` ExitSuccess output `shouldSatisfy` T.isInfixOf "Usage: seihou agent migrate BLUEPRINT [--from VERSION] [--to VERSION] [PROMPT]" output `shouldSatisfy` T.isInfixOf "--rerun" + output `shouldSatisfy` T.isInfixOf "--mark-applied" + output + `shouldSatisfy` T.isInfixOf "Record the pending migrations in the window as" output `shouldNotSatisfy` T.isInfixOf "--no-baseline" output `shouldNotSatisfy` T.isInfixOf "--force" @@ -576,6 +582,138 @@ bareExit `shouldSatisfy` (/= ExitSuccess) (bareOutput <> bareError) `shouldSatisfy` T.isInfixOf "Cannot determine the target version for 'payments'." + -- === --mark-applied ===================================================== + -- + -- Someone who upgraded a library by hand needs to say so, and be believed. + -- Every case below turns on the same pair of facts: a receipt appears, and + -- the provider was never called. + + it "records the window as applied without starting a session" $ + withProbeProject $ \root run -> do + let launchLog = root "agent-launch.log" + manifestPath = root ".seihou" "manifest.json" + (exitCode, output, errorOutput) <- + run ["agent", "migrate", "probe-upgrade", "--from", "1.0.0", "--to", "2.0.0", "--mark-applied"] + expectSuccess "mark applied" exitCode output errorOutput + output `shouldSatisfy` T.isInfixOf "Marking 1 blueprint migration(s) as already applied, without running them:" + output `shouldSatisfy` T.isInfixOf " probe-upgrade 1.0.0 -> 2.0.0" + output `shouldSatisfy` T.isInfixOf "Recorded 1 receipt(s). No agent session was started and no file was changed." + + -- The fake provider appends to this log whenever it is invoked, so its + -- absence is the proof that no session started. + doesFileExist launchLog `shouldReturn` False + + -- A marked receipt is an ordinary applied receipt. + readReceipts manifestPath `shouldReturn` [("1.0.0", "2.0.0", MigrationApplied)] + + -- And it suppresses a real run of the same window, still without a + -- session. + (againExit, againOutput, againError) <- + run ["agent", "migrate", "probe-upgrade", "--from", "1.0.0", "--to", "2.0.0"] + expectSuccess "run after marking" againExit againOutput againError + againOutput `shouldSatisfy` T.isInfixOf "already have receipts" + doesFileExist launchLog `shouldReturn` False + + -- The decisive cohort property, reached without running anything: an + -- entailed edge is marked under the blueprint that declares it, so the + -- direct entry point finds the receipt too. + it "marks an entailed edge under the blueprint that owns it" $ + withCohortProject $ \root run -> do + let launchLog = root "agent-launch.log" + (exitCode, output, errorOutput) <- + run ["agent", "migrate", "keiro-upgrade", "--from", "2.4.0", "--to", "3.0.0", "--mark-applied"] + expectSuccess "mark cohort window" exitCode output errorOutput + output + `shouldSatisfy` T.isInfixOf " kiroku-upgrade 1.9.0 -> 2.0.0 (entailed by keiro-upgrade 2.4.0 -> 3.0.0)" + output `shouldSatisfy` T.isInfixOf " keiro-upgrade 2.4.0 -> 3.0.0" + output `shouldSatisfy` T.isInfixOf "Recorded 2 receipt(s)." + doesFileExist launchLog `shouldReturn` False + + bytes <- LBS.readFile (root ".seihou" "manifest.json") + manifest <- case manifestFromJSON bytes of + Left err -> expectationFailure err >> fail "unreachable" + Right decoded -> pure decoded + [ (migrationReceipt ^. #name . #unModuleName, migrationReceipt ^. #fromVersion, migrationReceipt ^. #toVersion) + | migrationReceipt <- manifest ^. #blueprintMigrations + ] + `shouldBe` [ ("kiroku-upgrade", "1.9.0", "2.0.0"), + ("keiro-upgrade", "2.4.0", "3.0.0") + ] + + (kirokuExit, kirokuOutput, kirokuError) <- + run ["agent", "migrate", "kiroku-upgrade", "--from", "1.9.0", "--to", "2.0.0"] + expectSuccess "direct kiroku run after marking" kirokuExit kirokuOutput kirokuError + kirokuOutput `shouldSatisfy` T.isInfixOf "already have receipts" + doesFileExist launchLog `shouldReturn` False + + -- Marking asserts that the working tree is already correct, so it must not + -- touch it. Only .seihou/manifest.json may appear. + it "changes nothing in the working tree but the manifest" $ + withProbeProject $ \root run -> do + let listing = fmap sort . listDirectory + before <- listing root + modulesBefore <- listing (root ".seihou") + (exitCode, output, errorOutput) <- + run ["agent", "migrate", "probe-upgrade", "--from", "1.0.0", "--to", "3.0.0", "--mark-applied"] + expectSuccess "mark whole window" exitCode output errorOutput + listing root `shouldReturn` before + listing (root ".seihou") `shouldReturn` sort ("manifest.json" : modulesBefore) + + -- Marking a window twice is a no-op the second time, and widening it later + -- adds only what is newly pending: an honestly recorded appliedAt is never + -- moved for work that was recorded at a different time. + it "is idempotent and never rewrites an existing receipt" $ + withProbeProject $ \root run -> do + let manifestPath = root ".seihou" "manifest.json" + (firstExit, firstOutput, firstError) <- + run ["agent", "migrate", "probe-upgrade", "--from", "1.0.0", "--to", "2.0.0", "--mark-applied"] + expectSuccess "first marking" firstExit firstOutput firstError + originalTimestamps <- readReceiptTimestamps manifestPath + + (repeatExit, repeatOutput, repeatError) <- + run ["agent", "migrate", "probe-upgrade", "--from", "1.0.0", "--to", "2.0.0", "--mark-applied"] + expectSuccess "repeated marking" repeatExit repeatOutput repeatError + repeatOutput `shouldSatisfy` T.isInfixOf "already have receipts" + repeatOutput `shouldNotSatisfy` T.isInfixOf "Marking " + + (widerExit, widerOutput, widerError) <- + run ["agent", "migrate", "probe-upgrade", "--from", "1.0.0", "--to", "3.0.0", "--mark-applied"] + expectSuccess "wider marking" widerExit widerOutput widerError + widerOutput `shouldSatisfy` T.isInfixOf "Marking 1 blueprint migration(s) " + widerOutput `shouldSatisfy` T.isInfixOf " probe-upgrade 2.0.0 -> 3.0.0" + + readReceipts manifestPath + `shouldReturn` [ ("1.0.0", "2.0.0", MigrationApplied), + ("2.0.0", "3.0.0", MigrationApplied) + ] + widened <- readReceiptTimestamps manifestPath + take 1 widened `shouldBe` originalTimestamps + + -- Both refusals must land before the blueprint is even discovered, so an + -- invalid invocation cannot leave a receipt behind. + it "refuses --mark-applied with --rerun before writing anything" $ + withProbeProject $ \root run -> do + (exitCode, output, errorOutput) <- + run ["agent", "migrate", "probe-upgrade", "--from", "1.0.0", "--to", "2.0.0", "--mark-applied", "--rerun"] + exitCode `shouldSatisfy` (/= ExitSuccess) + let streams = output <> errorOutput + streams `shouldSatisfy` T.isInfixOf "--mark-applied" + streams `shouldSatisfy` T.isInfixOf "--rerun" + streams `shouldSatisfy` T.isInfixOf "cannot be combined" + doesFileExist (root ".seihou" "manifest.json") `shouldReturn` False + doesFileExist (root "agent-launch.log") `shouldReturn` False + + it "refuses --mark-applied with --debug before writing anything" $ + withProbeProject $ \root run -> do + (exitCode, output, errorOutput) <- + run ["agent", "--debug", "migrate", "probe-upgrade", "--from", "1.0.0", "--to", "2.0.0", "--mark-applied"] + exitCode `shouldSatisfy` (/= ExitSuccess) + let streams = output <> errorOutput + streams `shouldSatisfy` T.isInfixOf "--mark-applied" + streams `shouldSatisfy` T.isInfixOf "--debug" + streams `shouldSatisfy` T.isInfixOf "cannot be combined" + doesFileExist (root ".seihou" "manifest.json") `shouldReturn` False + -- | A scratch project holding one blueprint whose version probe reads -- @.library-version@ from the project root, plus a fake @claude@ that always -- succeeds. The probe file is deliberately absent until a test writes it, so @@ -590,11 +728,15 @@ xdgHome = root "xdg" fakeBin = root "bin" fakeClaude = fakeBin "claude" + launchLog = root "agent-launch.log" createDirectoryIfMissing True blueprintDir createDirectoryIfMissing True xdgHome createDirectoryIfMissing True fakeBin TIO.writeFile (blueprintDir "blueprint.dhall") probeBlueprintDhall - TIO.writeFile fakeClaude "#!/bin/sh\nexit 0\n" + -- The fake logs every invocation so a test can prove a session did NOT + -- start. An assertion that the log is absent is only evidence when the + -- fake would have written it; a silently succeeding fake proves nothing. + TIO.writeFile fakeClaude "#!/bin/sh\nprintf 'called\\n' >> \"$SEIHOU_FAKE_AGENT_LOG\"\nexit 0\n" permissions <- getPermissions fakeClaude -- Permissions comes from `directory` and has no Generic instance, so it -- has no #executable label. Record update syntax is the only option. @@ -608,12 +750,14 @@ "SEIHOU_AGENT_PROVIDER", "SEIHOU_AGENT_MODEL", "SEIHOU_AGENT_EFFORT", - "SEIHOU_CONTEXT" + "SEIHOU_CONTEXT", + "SEIHOU_FAKE_AGENT_LOG" ] environment = ("PATH", fakeBin <> [searchPathSeparator] <> inheritedPath) : ("XDG_CONFIG_HOME", xdgHome) : ("SEIHOU_AGENT_PROVIDER", "claude-cli") + : ("SEIHOU_FAKE_AGENT_LOG", launchLog) : filter (\(key, _) -> key `notElem` overriddenNames) inherited run args = runProcessText binary args (Just root) (Just environment) action root run @@ -657,6 +801,7 @@ xdgHome = root "xdg" fakeBin = root "bin" fakeClaude = fakeBin "claude" + launchLog = root "agent-launch.log" createDirectoryIfMissing True (kirokuDir "files") createDirectoryIfMissing True (keiroDir "files") createDirectoryIfMissing True xdgHome @@ -667,7 +812,10 @@ -- proves which blueprint's files/ directory it was built from. TIO.writeFile (kirokuDir "files" "kiroku-marker.md") "kiroku reference" TIO.writeFile (keiroDir "files" "keiro-marker.md") "keiro reference" - TIO.writeFile fakeClaude "#!/bin/sh\nexit 0\n" + -- The fake logs every invocation so a test can prove a session did NOT + -- start. An assertion that the log is absent is only evidence when the + -- fake would have written it; a silently succeeding fake proves nothing. + TIO.writeFile fakeClaude "#!/bin/sh\nprintf 'called\\n' >> \"$SEIHOU_FAKE_AGENT_LOG\"\nexit 0\n" permissions <- getPermissions fakeClaude -- Permissions comes from `directory` and has no Generic instance, so it -- has no #executable label. Record update syntax is the only option. @@ -681,12 +829,14 @@ "SEIHOU_AGENT_PROVIDER", "SEIHOU_AGENT_MODEL", "SEIHOU_AGENT_EFFORT", - "SEIHOU_CONTEXT" + "SEIHOU_CONTEXT", + "SEIHOU_FAKE_AGENT_LOG" ] environment = ("PATH", fakeBin <> [searchPathSeparator] <> inheritedPath) : ("XDG_CONFIG_HOME", xdgHome) : ("SEIHOU_AGENT_PROVIDER", "claude-cli") + : ("SEIHOU_FAKE_AGENT_LOG", launchLog) : filter (\(key, _) -> key `notElem` overriddenNames) inherited run args = runProcessText binary args (Just root) (Just environment) action root run @@ -740,6 +890,16 @@ " ]", "}" ] + +-- | The recorded @appliedAt@ stamps, in ledger order. A marking that rewrote +-- an existing receipt would move one of these. +readReceiptTimestamps :: FilePath -> IO [UTCTime] +readReceiptTimestamps manifestPath = do + bytes <- LBS.readFile manifestPath + case manifestFromJSON bytes of + Left err -> expectationFailure err >> fail "unreachable" + Right manifest -> + pure [migrationReceipt ^. #appliedAt | migrationReceipt <- manifest ^. #blueprintMigrations] -- | The recorded edge windows and outcomes, in ledger order. readReceipts :: FilePath -> IO [(T.Text, T.Text, MigrationOutcome)] diff --git a/test/Seihou/CLI/BlueprintMigrationSpec.hs b/test/Seihou/CLI/BlueprintMigrationSpec.hs --- a/test/Seihou/CLI/BlueprintMigrationSpec.hs +++ b/test/Seihou/CLI/BlueprintMigrationSpec.hs @@ -151,6 +151,35 @@ formatMigrationStepLabel entailedStep `shouldBe` "kiroku-upgrade 1.9.0 -> 2.0.0 (entailed by keiro-upgrade 2.4.0 -> 3.0.0)" + describe "formatMarkAppliedNotice" $ do + it "names every step it is about to record, with the owning blueprint" $ + formatMarkAppliedNotice [first, second] + `shouldBe` T.unlines + [ "Marking 2 blueprint migration(s) as already applied, without running them:", + " payments 1.0.0 -> 2.0.0", + " payments 2.0.0 -> 3.0.0" + ] + + -- Proves the notice goes through 'formatMigrationStepLabel' rather than a + -- second label derivation: someone marking a cohort window must see that + -- an edge of a blueprint they never named is about to get a receipt, and + -- what pulled it in. + it "labels an entailed step with what entailed it" $ + formatMarkAppliedNotice [entailedStep] + `shouldSatisfy` T.isInfixOf + " kiroku-upgrade 1.9.0 -> 2.0.0 (entailed by keiro-upgrade 2.4.0 -> 3.0.0)\n" + + it "counts the steps it lists" $ + formatMarkAppliedNotice [first, second, entailedStep] + `shouldSatisfy` T.isPrefixOf "Marking 3 blueprint migration(s) " + + describe "formatMarkAppliedSummary" $ do + -- The second sentence is the whole point of the line: it is what makes a + -- mistaken marking obvious the moment it happens. + it "says plainly that nothing ran and nothing changed" $ + formatMarkAppliedSummary 2 + `shouldBe` "Recorded 2 receipt(s). No agent session was started and no file was changed." + describe "renderBlueprintMigrationInstruction" $ do it "substitutes the variables resolved for the shared blueprint" $ do let declaration = VarDecl "library.name" VTText Nothing Nothing False Nothing