seihou-cli 0.7.0.0 → 0.8.0.0
raw patch · 9 files changed
+406/−63 lines, 9 filesdep ~seihou-core
Dependency ranges changed: seihou-core
Files
- help/agent.md +13/−1
- help/blueprints.md +6/−2
- help/migrations.md +5/−2
- seihou-cli.cabal +4/−4
- src-exe/Seihou/CLI/AgentMigrate.hs +143/−49
- src-exe/Seihou/CLI/Commands.hs +9/−0
- src/Seihou/CLI/BlueprintMigration.hs +32/−0
- test/Seihou/CLI/AgentMigrateE2ESpec.hs +165/−5
- test/Seihou/CLI/BlueprintMigrationSpec.hs +29/−0
help/agent.md view
@@ -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]
help/blueprints.md view
@@ -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
help/migrations.md view
@@ -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
seihou-cli.cabal view
@@ -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,
src-exe/Seihou/CLI/AgentMigrate.hs view
@@ -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
src-exe/Seihou/CLI/Commands.hs view
@@ -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
src/Seihou/CLI/BlueprintMigration.hs view
@@ -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
test/Seihou/CLI/AgentMigrateE2ESpec.hs view
@@ -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)]
test/Seihou/CLI/BlueprintMigrationSpec.hs view
@@ -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