seihou-cli 0.6.0.0 → 0.7.0.0
raw patch · 29 files changed
+3938/−411 lines, 29 filesdep ~seihou-core
Dependency ranges changed: seihou-core
Files
- data/blueprint-migration-prompt.md +35/−4
- help/agent.md +14/−5
- seihou-cli.cabal +8/−4
- src-exe/Seihou/CLI/AgentMigrate.hs +463/−90
- src-exe/Seihou/CLI/AgentRun.hs +89/−27
- src-exe/Seihou/CLI/Commands.hs +51/−11
- src-exe/Seihou/CLI/Install.hs +52/−20
- src-exe/Seihou/CLI/Run.hs +8/−24
- src-exe/Seihou/CLI/Status.hs +10/−2
- src-exe/Seihou/CLI/Upgrade.hs +20/−4
- src/Seihou/CLI/AgentGuard.hs +101/−0
- src/Seihou/CLI/BlueprintMigration.hs +500/−44
- src/Seihou/CLI/InstallShared.hs +201/−19
- src/Seihou/CLI/ManifestGuard.hs +164/−44
- src/Seihou/CLI/Migrate.hs +29/−9
- src/Seihou/CLI/MigrationCohort.hs +178/−0
- src/Seihou/CLI/SchemaVersion.hs +2/−2
- src/Seihou/CLI/StatusRender.hs +21/−1
- src/Seihou/CLI/Update.hs +37/−11
- test/Main.hs +4/−0
- test/Seihou/CLI/AgentGuardE2ESpec.hs +435/−0
- test/Seihou/CLI/AgentLaunchSpec.hs +2/−1
- test/Seihou/CLI/AgentMigrateE2ESpec.hs +506/−6
- test/Seihou/CLI/AppliedBlueprintMigrationSpec.hs +167/−37
- test/Seihou/CLI/AppliedBlueprintSpec.hs +64/−0
- test/Seihou/CLI/BlueprintMigrationSpec.hs +546/−43
- test/Seihou/CLI/InstallCollisionSpec.hs +188/−0
- test/Seihou/CLI/StatusSpec.hs +42/−2
- test/Seihou/CLI/UpdateSpec.hs +1/−1
data/blueprint-migration-prompt.md view
@@ -1,7 +1,9 @@ You are running one ordered Seihou blueprint migration for a library upgrade. The blueprint author supplied shared library guidance plus instructions for this exact version edge. Work only on the current edge; later edges run in separate-agent sessions after this one succeeds.+agent sessions after this one succeeds. A chain may span several blueprints,+because one library's upgrade can require another's; the identity below is the+blueprint that owns *this* edge, and it may not be the one the user named. You may be running in an interactive local CLI with repository tools, or as a one-shot API completion without tools. When tools are available, inspect the@@ -33,7 +35,9 @@ From library version: {{migration_from}} To library version: {{migration_to}} +{{migration_entailed_by}} + ## Reference Files The blueprint declares these shared library-upgrade references:@@ -69,8 +73,35 @@ that remains for the user or later migration steps. +## If This Edge Does Not Apply++An edge states its own precondition. If this project does not meet it — the+library is not used here, the feature this edge upgrades was never adopted, the+change is already present — the correct action is to change nothing and report+that. This is the ordinary case for an edge the project reached indirectly:+a project that depends on one library only through another may never use the+upgraded library's API itself.++Do not make speculative edits to justify the step, and do not exit with an+error: an error means the provider failed, halts the remaining edges, and asks+the user to retry.++To report it, write one line explaining why to:++{{not_applicable_signal_path}}++If you cannot write files, end your reply with a line of exactly this form:++ SEIHOU: not-applicable <one-line reason>++Seihou records the attempt with that outcome, prints your reason, and continues+to the next edge. The edge is not marked done, so it runs again once the+precondition is met.++ ## Completion Boundary -Seihou records this exact edge after your provider interaction returns-successfully. That receipt is not package-manager verification. Do not report-the target version as installed unless you actually verified it in the project.+Seihou records this exact edge after your provider interaction returns, with+what it produced: applied, or not applicable. An applied receipt is not+package-manager verification. Do not report the target version as installed+unless you actually verified it in the project.
help/agent.md view
@@ -118,16 +118,24 @@ provider. A successful non-debug run records applied-blueprint provenance in `.seihou/manifest.json`. - seihou agent migrate BLUEPRINT --from VERSION --to VERSION [PROMPT]+ seihou agent migrate BLUEPRINT [--from VERSION] [--to VERSION] [PROMPT] Run one agent session per in-window migration declared by the blueprint.- Versions are explicit dotted numbers; gaps are allowed. Successful edges- are recorded immediately so a later invocation resumes at the first+ Versions are dotted numbers; gaps are allowed. Successful edges are+ recorded immediately so a later invocation resumes at the first unrecorded edge. `--rerun` ignores matching receipts. Migration mode does not apply baseModules and exposes neither --no-baseline nor --force. + Either end of the window may be omitted. --to then comes from the+ blueprint's declared versionProbe, a command it supplies that reads the+ version this project depends on; --from comes from the highest version+ already recorded in this project's receipts. An explicit flag always+ wins, and an inferred end is reported with the source it came from.+ Parent --debug prints every pending migration prompt in order without- contacting a provider or writing receipts. A receipt records provider- completion, not package-manager verification.+ 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+ verification. seihou prompt run PROMPT [USER-PROMPT] [--var KEY=VALUE] [--debug] Resolve a reusable prompt, run command-derived variables, render@@ -141,6 +149,7 @@ seihou agent --debug --provider openai setup "inspect this prompt" seihou agent --debug run my-blueprint --var project.name=demo seihou agent --debug migrate my-library --from 1.0.0 --to 3.0.0+ seihou agent --debug migrate my-library SEE ALSO
seihou-cli.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.0 name: seihou-cli-version: 0.6.0.0+version: 0.7.0.0 synopsis: CLI for Seihou project scaffolding description: Command-line interface for Seihou, a composable project scaffolding@@ -57,6 +57,7 @@ Seihou.CLI.AgentCompletion Seihou.CLI.AgentConfig Seihou.CLI.AgentConfigShow+ Seihou.CLI.AgentGuard Seihou.CLI.AgentLaunch Seihou.CLI.AgentModels Seihou.CLI.AgentTrace@@ -81,6 +82,7 @@ Seihou.CLI.ManifestGuard Seihou.CLI.ManifestUpgrade Seihou.CLI.Migrate+ Seihou.CLI.MigrationCohort Seihou.CLI.PendingMigrations Seihou.CLI.PromptRender Seihou.CLI.Registry@@ -124,7 +126,7 @@ generic-lens >=2.2 && <3, lens >=5.2 && <6, process >=1.6 && <2,- seihou-core ^>=0.6.0.0,+ seihou-core ^>=0.7.0.0, streamly-core >=0.3 && <0.5, temporary >=1.3 && <2, text >=2.0 && <3,@@ -209,7 +211,7 @@ optparse-applicative >=0.18 && <1, process >=1.6 && <2, seihou-cli-internal,- seihou-core ^>=0.6.0.0,+ seihou-core ^>=0.7.0.0, temporary >=1.3 && <2, text >=2.0 && <3, time >=1.12 && <2,@@ -231,6 +233,7 @@ Seihou.CLI.AgentCompletionSpec Seihou.CLI.AgentConfigShowSpec Seihou.CLI.AgentConfigSpec+ Seihou.CLI.AgentGuardE2ESpec Seihou.CLI.AgentLaunchSpec Seihou.CLI.AgentMigrateE2ESpec Seihou.CLI.AgentModelsSpec@@ -246,6 +249,7 @@ Seihou.CLI.ExtensionSpec Seihou.CLI.GitSpec Seihou.CLI.InitSpec+ Seihou.CLI.InstallCollisionSpec Seihou.CLI.InstallHistorySpec Seihou.CLI.ListSpec Seihou.CLI.ManifestGuardSpec@@ -287,7 +291,7 @@ lens >=5.2 && <6, process >=1.6 && <2, seihou-cli-internal,- seihou-core ^>=0.6.0.0,+ seihou-core ^>=0.7.0.0, streamly-core >=0.3 && <0.5, tasty >=1.4 && <2, tasty-hspec >=1.2 && <2,
src-exe/Seihou/CLI/AgentMigrate.hs view
@@ -6,9 +6,13 @@ where import Baikai.Trace.Sink (TraceSink)+import Control.Applicative ((<|>))+import Control.Monad (unless, when) import Data.FileEmbed (embedFile) import Data.Generics.Labels ()-import Data.Maybe (maybeToList)+import Data.List (nub)+import Data.Map.Strict qualified as Map+import Data.Maybe (fromMaybe, listToMaybe, maybeToList) import Data.Text qualified as T import Data.Text.Encoding qualified as TE import Data.Text.IO qualified as TIO@@ -24,6 +28,7 @@ agentLaunchDeclaration, resolveDeclaredAgentConfig, )+import Seihou.CLI.AgentGuard (enforceAgentArtifactGuard) import Seihou.CLI.AgentLaunch (gatherAgentContext) import Seihou.CLI.AgentLaunchExec (launchConfiguredAgentAddingDirs) import Seihou.CLI.AgentTrace (traceSinkForConfig)@@ -35,30 +40,61 @@ ) import Seihou.CLI.BlueprintMigration ( BlueprintMigrationLaunchFailure (..),+ BlueprintMigrationLaunchResult (..), BlueprintMigrationRunResult (..),+ ResolvedWindow (..),+ VersionProbeResult (..), formatBlueprintMigrationDebugOutput,+ formatMigrationStepLabel,+ formatProbeFailure,+ formatResolvedWindow,+ formatWindowResolutionError,+ highestMigratedVersion,+ parseNotApplicableSignal, pendingBlueprintMigrations, renderBlueprintMigrationSystemPrompt,+ resolveMigrationWindow, runBlueprintMigrationsWith,+ runVersionProbe,+ unstatedNotApplicableReason, ) import Seihou.CLI.Commands (BlueprintMigrationOpts (..))+import Seihou.CLI.MigrationCohort+ ( CohortBlueprint (..),+ CohortResolutionError (..),+ resolveCohortBlueprint,+ resolveMigrationCohort,+ ) import Seihou.CLI.Shared (formatVarError, logIO)-import Seihou.Core.Blueprint (validateBlueprint) import Seihou.Core.Migration ( BlueprintMigration (..), BlueprintMigrationPlan (..),+ BlueprintMigrationStep (..),+ EntailedEdge (..),+ EntailmentError (..),+ EntailmentSite (..), MigrationPlanError (..),+ expandEntailedEdges, planBlueprintMigrationChain, ) import Seihou.Core.Module (defaultSearchPaths, discoverRunnable) import Seihou.Core.Types import Seihou.Core.Version (Version, parseVersion, renderVersion) import Seihou.Effect.FilesystemInterp (runFilesystem)-import Seihou.Effect.Logger (logError)+import Seihou.Effect.Logger (logError, logWarn) import Seihou.Effect.ManifestStore (readManifest) import Seihou.Effect.ManifestStoreInterp (runManifestStore)+import Seihou.Effect.ProcessInterp (runProcessIO) import Seihou.Prelude+import System.Directory+ ( createDirectoryIfMissing,+ doesFileExist,+ getCurrentDirectory,+ removeFile,+ ) import System.Exit (ExitCode (..), exitFailure, exitWith)+import System.FilePath (takeDirectory)+import System.Timeout (timeout) migrationPromptTemplate :: Text migrationPromptTemplate = TE.decodeUtf8 $(embedFile "data/blueprint-migration-prompt.md")@@ -68,12 +104,43 @@ let level = if opts ^. #verbose then LogVerbose else LogNormal manifestPath = ".seihou" </> "manifest.json" - (blueprint, blueprintDir) <- discoverMigrationBlueprint level (opts ^. #name)- validationResult <- validateBlueprint blueprintDir blueprint- case validationResult of- Left err -> exitErr level (renderModuleLoadError err)- Right _ -> pure ()+ -- 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+ -- its own receipts.+ projectRoot <- getCurrentDirectory+ searchPaths <- defaultSearchPaths+ invoked <- discoverMigrationBlueprint level projectRoot searchPaths (opts ^. #name)+ let blueprint = invoked ^. #blueprint + -- Pre-flight downgrade and origin guard, before a single edge is planned.+ -- Placing it before planning is the point rather than an implementation+ -- detail: a substituted blueprint's edges do not match this project's+ -- receipts, so without the check the command would report that every edge in+ -- the window already has a receipt and exit successfully, having silently+ -- skipped work that never ran. The refusal happens before any receipt is+ -- written, so the manifest is left byte-identical.+ --+ -- No baseline modules are in scope: migration mode applies no baseModules+ -- (see docs/user/blueprint-migrations.md), and refusing for artifacts this+ -- command will not touch would violate the scoping rule in+ -- docs/adr/0003-a-stale-or-substituted-artifact-is-a-hard-error.md.+ --+ -- --debug performs no check at all: it contacts no provider and writes+ -- nothing, so a prompt can still be inspected on any machine.+ --+ -- Only the invoked blueprint is in scope here. Blueprints reached by+ -- entailment are not known until the window has been planned, and they are+ -- checked separately once they are; the guard is not moved later to+ -- accommodate them, because the invoked blueprint being substituted is+ -- exactly the case that would make the planned window meaningless.+ unless debug $+ enforceAgentArtifactGuard+ (opts ^. #allowDowngrade)+ manifestPath+ [blueprint ^. #name]+ mempty+ -- Finish provider/model/effort resolution now that the blueprint is loaded: -- `agent migrate` reads the same Blueprint record as `agent run`, so it -- honors the same launch declaration.@@ -84,8 +151,19 @@ pendingConfig (agentLaunchDeclaration (blueprint ^. #launch)) - current <- parseRequestedVersion level "--from" (opts ^. #from)- target <- parseRequestedVersion level "--to" (opts ^. #to)+ -- The receipts are read before the window is planned, not after, because+ -- the window itself now depends on them: an omitted --from is the highest+ -- version this project has already migrated this blueprint to. The same+ -- list is reused for per-step filtering further down, so the manifest is+ -- read once.+ receipts <- readMigrationReceipts level manifestPath++ window <- resolveWindow level projectRoot invoked receipts opts+ let current = window ^. #fromVersion+ target = window ^. #toVersion+ windowReport = formatResolvedWindow (opts ^. #verbose) window+ unless (null windowReport) $ mapM_ TIO.putStrLn (windowReport <> [""])+ planned <- case planBlueprintMigrationChain (blueprint ^. #name . #unModuleName) (blueprint ^. #migrations) current target of Left err -> exitErr level (renderPlanError err)@@ -97,29 +175,71 @@ case planned of Nothing -> pure () Just migrationPlan -> do- receipts <- readMigrationReceipts level manifestPath+ -- Load every blueprint this window reaches by entailment, then flatten+ -- the window into an ordered list of steps, each labelled with the+ -- blueprint that declares it. Both happen before receipts are consulted,+ -- because an entailed step is filtered against its own owner's receipts+ -- rather than the invoked blueprint's.+ let invokedName = blueprint ^. #name . #unModuleName+ cohortResult <-+ resolveMigrationCohort+ projectRoot+ searchPaths+ (Map.singleton invokedName invoked)+ (migrationPlan ^. #steps)+ cohort <- case cohortResult of+ Left err -> exitErr level (renderCohortError err)+ Right resolved -> pure resolved++ -- Every entailed blueprint is an artifact this command is about to+ -- generate from, so ADR 0003's scoping rule reaches it too. The invoked+ -- blueprint was already checked before planning; this covers the rest,+ -- and still lands before any launch.+ let entailedNames =+ [ModuleName name | name <- Map.keys cohort, name /= invokedName]+ unless (debug || null entailedNames) $+ enforceAgentArtifactGuard+ (opts ^. #allowDowngrade)+ manifestPath+ entailedNames+ mempty++ expandedPlan <- case expandEntailedEdges (lookupCohortMigrations cohort) (migrationPlan ^. #steps) of+ Left err -> exitErr level (renderEntailmentError cohort err)+ Right expandedSteps -> pure (migrationPlan & #steps .~ expandedSteps)+ let pending = pendingBlueprintMigrations (opts ^. #rerun)- (blueprint ^. #name)+ (lookupCohortIdentity cohort) receipts- migrationPlan+ expandedPlan if null pending- then reportNoPending migrationPlan+ then reportNoPending expandedPlan else do- prepared <- prepare level modelConfig opts blueprint blueprintDir+ -- 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 renderStep position total migration =- renderBlueprintMigrationSystemPrompt- migrationPromptTemplate- context- prepared- position- total- migration- renderDebugStep position total migration =- renderStep position total migration+ 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" <>)@@ -129,35 +249,207 @@ then TIO.putStrLn $ "Blueprint migrations for "- <> blueprint ^. #name . #unModuleName+ <> invokedName <> ": "- <> renderVersion (migrationPlan ^. #from)+ <> renderVersion (expandedPlan ^. #from) <> " -> "- <> renderVersion (migrationPlan ^. #to)+ <> 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 prepared renderStep)- (recordMigration manifestPath blueprint)+ (launchMigration traceSink modelConfig opts preparedByOwner signalPath renderStep)+ (recordMigration manifestPath cohort) pending handleRunResult level (blueprint ^. #name) result -discoverMigrationBlueprint :: LogLevel -> ModuleName -> IO (Blueprint, FilePath)-discoverMigrationBlueprint level requestedName = do- searchPaths <- defaultSearchPaths- runnableResult <- discoverRunnable searchPaths requestedName- case runnableResult of- Right (RunnableBlueprint blueprint dir) -> pure (blueprint, dir)- Right (RunnableModule _ _) ->- exitErr level $ "'" <> requestedName ^. #unModuleName <> "' is a module, not a blueprint."- Right (RunnableRecipe _ _) ->- exitErr level $ "'" <> requestedName ^. #unModuleName <> "' is a recipe, not a blueprint."- Right (RunnableAgentPrompt _ _) ->- exitErr level $ "'" <> requestedName ^. #unModuleName <> "' is a prompt, not a blueprint."- Left err -> exitErr level (renderModuleLoadError err)+-- | 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+-- the edge that named it.+lookupCohortMigrations :: Map Text CohortBlueprint -> Text -> Maybe [BlueprintMigration]+lookupCohortMigrations cohort name =+ (^. #blueprint . #migrations) <$> Map.lookup name cohort +-- | A step's owning blueprint's recorded identity, for receipt matching. This+-- is the whole cross-entry-point property in one function: a step owned by+-- @kiroku-upgrade@ is filtered against kiroku's receipts no matter which+-- blueprint the user named.+lookupCohortIdentity :: Map Text CohortBlueprint -> Text -> Maybe (ModuleName, ArtifactOrigin)+lookupCohortIdentity cohort name = do+ resolved <- Map.lookup name cohort+ pure (resolved ^. #blueprint . #name, resolved ^. #origin)++-- | Prepare one execution context per blueprint that owns a pending step.+--+-- Blueprints in the cohort that own no pending step are deliberately skipped:+-- preparing one resolves its variables, which can prompt, and asking a user to+-- answer questions for a blueprint whose every edge already has a receipt is+-- pure friction.+prepareCohort ::+ LogLevel ->+ AgentModelConfig ->+ BlueprintMigrationOpts ->+ Map Text CohortBlueprint ->+ [BlueprintMigrationStep] ->+ IO (Map Text PreparedBlueprintExecution)+prepareCohort level modelConfig opts cohort pending =+ Map.fromList <$> traverse prepareOne owners+ where+ owners = nub [step ^. #owner | step <- pending]++ prepareOne name = case Map.lookup name cohort of+ -- Unreachable: every owner came out of a plan the cohort resolved.+ Nothing -> exitErr level ("Internal error: no blueprint loaded for migration step owner '" <> name <> "'.")+ Just resolved -> do+ prepared <-+ prepare level modelConfig opts (resolved ^. #blueprint) (resolved ^. #blueprintDir)+ pure (name, prepared)++-- | Unreachable in production — 'prepareCohort' covers every pending step's+-- owner — but a rendered message beats a partial-function crash if the two+-- ever drift apart.+missingOwnerMessage :: BlueprintMigrationStep -> Text+missingOwnerMessage step =+ "Internal error: no execution context prepared for '" <> step ^. #owner <> "'."++discoverMigrationBlueprint :: LogLevel -> FilePath -> [FilePath] -> ModuleName -> IO CohortBlueprint+discoverMigrationBlueprint level projectRoot searchPaths requestedName = do+ result <- resolveCohortBlueprint projectRoot searchPaths requestedName+ case result of+ Right resolved -> pure resolved+ Left err -> exitErr level (renderCohortError err)++renderCohortError :: CohortResolutionError -> Text+renderCohortError = \case+ CohortArtifactWrongKind name kind ->+ "'" <> name ^. #unModuleName <> "' is a " <> kind <> ", not a blueprint."+ CohortArtifactMissing name searched ->+ renderModuleLoadError (ModuleNotFound name searched)+ CohortArtifactUnusable err -> renderModuleLoadError err++-- | Turn an expansion failure into the message a blueprint author has to act+-- on. These are the only feedback an author gets about an @entails@ list, so+-- each says which blueprint is at fault and what to do next.+renderEntailmentError :: Map Text CohortBlueprint -> EntailmentError -> Text+renderEntailmentError cohort = \case+ EntailedBlueprintNotFound site name ->+ renderSite site+ <> " entails blueprint '"+ <> name+ <> "', which is not installed on this machine.\n\n"+ <> " Install it, then re-run:\n"+ <> " seihou install <url> --module "+ <> name+ EntailedEdgeNotDeclared site name fromVersion toVersion ->+ renderSite site+ <> " entails edge "+ <> fromVersion+ <> " -> "+ <> toVersion+ <> " of '"+ <> name+ <> "', which declares no such edge.\n\n"+ <> " This is an authoring error in '"+ <> site ^. #blueprint+ <> "'. Report it upstream.\n"+ <> " Declared edges of '"+ <> name+ <> "': "+ <> declaredEdges name+ EntailmentCycle chain ->+ "blueprint migration entailment forms a cycle:\n"+ <> T.intercalate "\n" [" " <> link | link <- chain]+ <> "\n\n Each of these edges declares that the next must run first, so"+ <> " there is no order that satisfies them all.\n"+ <> " This is an authoring error in the blueprints listed. Report it upstream."+ where+ renderSite site =+ "'" <> site ^. #blueprint <> "' edge " <> site ^. #from <> " -> " <> site ^. #to++ -- The likeliest cause of a missing edge is an off-by-one in a version+ -- string, so showing the real list usually makes the mistake obvious.+ declaredEdges name = case Map.lookup name cohort of+ Nothing -> "(none: the blueprint could not be read)"+ Just resolved ->+ case [edge ^. #from <> " -> " <> edge ^. #to | edge <- resolved ^. #blueprint . #migrations] of+ [] -> "(it declares no migrations at all)"+ rendered -> T.intercalate ", " rendered++-- | Decide both ends of the version window, running the blueprint's declared+-- probe only if it is needed.+--+-- The probe is skipped entirely when @--to@ was supplied: an explicit+-- invocation must never execute a subprocess whose answer it would discard.+-- It /is/ run under @--debug@, though nothing else there is: it is a+-- read-only command the blueprint supplies, and refusing to run it would make+-- debug output diverge from a real run in exactly the way that matters — the+-- window, and therefore which edges are shown.+--+-- Receipts are matched against the invoked blueprint's own identity. That is+-- the same "by owner" rule the per-step filtering uses: the window is+-- expressed in the invoked library's version space, so the receipts that+-- bound it are the ones the invoked blueprint owns.+resolveWindow ::+ LogLevel ->+ FilePath ->+ CohortBlueprint ->+ [AppliedBlueprintMigration] ->+ BlueprintMigrationOpts ->+ IO ResolvedWindow+resolveWindow level projectRoot invoked receipts opts = do+ fromFlag <- traverse (parseRequestedVersion level "--from") (opts ^. #from)+ toFlag <- traverse (parseRequestedVersion level "--to") (opts ^. #to)+ probed <- case (toFlag, invoked ^. #blueprint . #versionProbe) of+ (Just _, _) -> pure Nothing+ (Nothing, Nothing) -> pure Nothing+ (Nothing, Just command) -> do+ result <- executeVersionProbe level projectRoot command+ pure $ case result of+ ProbeVersion version -> Just (version, command)+ _ -> Nothing+ let recorded =+ highestMigratedVersion+ (invoked ^. #origin)+ (invoked ^. #blueprint . #name)+ receipts+ case resolveMigrationWindow fromFlag toFlag probed recorded of+ Right window -> pure window+ Left err ->+ exitErr level (formatWindowResolutionError (invoked ^. #blueprint . #name) err)++-- | Run one version probe under a wall-clock bound, reporting anything that+-- is not a version and returning it for the caller to discard.+--+-- Every failure here is a warning rather than an error. The user did not+-- write the probe, and still has @--to@; turning an author's broken command+-- into a hard failure would take a working escape hatch away from the person+-- who cannot fix it.+executeVersionProbe :: LogLevel -> FilePath -> Text -> IO VersionProbeResult+executeVersionProbe level projectRoot command = do+ bounded <- timeout probeTimeoutMicroseconds run+ let result = fromMaybe (ProbeExitedNonZero 124 timedOut) bounded+ mapM_ (logIO level . logWarn) (formatProbeFailure command result)+ pure result+ where+ run = runEff $ runProcessIO $ runVersionProbe command projectRoot++ -- 124 is what `timeout(1)` reports, which is the closest thing to a+ -- convention for "the command did not finish".+ timedOut =+ "timed out after "+ <> T.pack (show (probeTimeoutMicroseconds `div` 1_000_000))+ <> " seconds"++-- | How long a version probe may take before the command stops waiting for+-- it. Generous enough for a cold @nix eval@, short enough that a probe that+-- hangs forever does not hang @seihou agent migrate@ forever with it.+probeTimeoutMicroseconds :: Int+probeTimeoutMicroseconds = 60 * 1_000_000+ parseRequestedVersion :: LogLevel -> Text -> Text -> IO Version parseRequestedVersion level flag raw = case parseVersion raw of@@ -201,35 +493,75 @@ exitFailure Right prepared -> pure prepared +-- | Where an edge reports that it does not apply.+--+-- It lives under @.seihou\/@ rather than in the working tree so a signal a+-- crashed run left behind never shows up in @git status@, and the leading dot+-- keeps it out of the way of @.seihou@'s own contents.+notApplicableSignalPath :: FilePath -> FilePath+notApplicableSignalPath projectRoot = projectRoot </> ".seihou" </> ".migrate-signal"++-- | Delete a signal left behind by an earlier edge or a crashed run, so it+-- cannot be misread as this edge's answer.+clearNotApplicableSignal :: FilePath -> IO ()+clearNotApplicableSignal signalPath = do+ exists <- doesFileExist signalPath+ when exists (removeFile signalPath)++-- | Read and consume the signal an edge may have written.+--+-- The file's existence is the signal: an agent creates it deliberately, with+-- its own tools, at a path only this command names. An empty one therefore+-- still means "not applicable", it just fails to say why.+readNotApplicableSignal :: FilePath -> IO (Maybe Text)+readNotApplicableSignal signalPath = do+ exists <- doesFileExist signalPath+ if not exists+ then pure Nothing+ else do+ contents <- TIO.readFile signalPath+ removeFile signalPath+ let firstLine = listToMaybe (filter (not . T.null) (map T.strip (T.lines contents)))+ pure (Just (fromMaybe unstatedNotApplicableReason firstLine))+ launchMigration :: -- | built once per command, so every migration edge appends to one destination TraceSink -> AgentModelConfig -> BlueprintMigrationOpts ->- PreparedBlueprintExecution ->- (Int -> Int -> BlueprintMigration -> Text) ->+ -- | one execution context per owning blueprint, keyed by name+ Map Text PreparedBlueprintExecution ->+ -- | where this edge reports that it does not apply+ FilePath ->+ (Int -> Int -> BlueprintMigrationStep -> Text) -> Int -> Int ->- BlueprintMigration ->- IO (Either BlueprintMigrationLaunchFailure ())-launchMigration traceSink modelConfig opts prepared renderStep position total migration = do+ BlueprintMigrationStep ->+ IO (Either BlueprintMigrationLaunchFailure BlueprintMigrationLaunchResult)+launchMigration traceSink modelConfig opts preparedByOwner signalPath renderStep position total step = do TIO.putStrLn $ "Running blueprint migration "- <> T.pack (show position)- <> "/"- <> T.pack (show total)+ <> stepLabel <> ": "- <> migration ^. #from- <> " -> "- <> (migration ^. #to)- let systemPrompt = renderStep position total migration- case modelConfig ^. #provider of- AgentProviderClaudeCli -> launchInteractive systemPrompt- AgentProviderCodexCli -> launchInteractive systemPrompt- AgentProviderAnthropic -> launchCompletion systemPrompt- AgentProviderOpenAI -> launchCompletion systemPrompt+ <> formatMigrationStepLabel step+ clearNotApplicableSignal signalPath+ let systemPrompt = renderStep position total step+ case Map.lookup (step ^. #owner) preparedByOwner of+ Nothing -> pure (Left (BlueprintMigrationProviderFailure (missingOwnerMessage step)))+ Just prepared -> case modelConfig ^. #provider of+ AgentProviderClaudeCli -> launchInteractive prepared systemPrompt+ AgentProviderCodexCli -> launchInteractive prepared systemPrompt+ AgentProviderAnthropic -> launchCompletion systemPrompt+ AgentProviderOpenAI -> launchCompletion systemPrompt where- launchInteractive systemPrompt = do+ stepLabel = T.pack (show position) <> "/" <> T.pack (show total)++ -- An interactive session communicates only through its exit code, so the+ -- signal file is the one channel an agent has to report inapplicability.+ -- Only the owning blueprint's files/ directory is mounted: handing this+ -- step another cohort member's reference material invites the agent to+ -- pre-apply work the framing prompt tells it to leave for a later step.+ launchInteractive prepared systemPrompt = do exitCode <- launchConfiguredAgentAddingDirs (maybeToList (prepared ^. #mountedFilesDir))@@ -238,55 +570,98 @@ False systemPrompt (opts ^. #prompt)- pure $ case exitCode of- ExitSuccess -> Right ()- failure -> Left (BlueprintMigrationProcessFailure failure)+ case exitCode of+ ExitSuccess -> Right <$> sessionResultFromSignal Nothing+ failure -> do+ -- A failed session's signal is not this edge's answer.+ clearNotApplicableSignal signalPath+ pure (Left (BlueprintMigrationProcessFailure failure)) + -- An API provider hands us its reply directly, so the marker line works.+ -- The signal file is still checked, because a provider given tool access+ -- may take the prompt's first instruction rather than its fallback. launchCompletion systemPrompt = do result <- runAgentCompletion (buildAgentCompletionRequestWith traceSink modelConfig systemPrompt (opts ^. #prompt)) case result of- Left err -> pure (Left (BlueprintMigrationProviderFailure err))+ Left err -> do+ clearNotApplicableSignal signalPath+ pure (Left (BlueprintMigrationProviderFailure err)) Right assistantText -> do TIO.putStrLn assistantText- pure (Right ())+ Right <$> sessionResultFromSignal (parseNotApplicableSignal assistantText) + sessionResultFromSignal parsedReason = do+ fileReason <- readNotApplicableSignal signalPath+ case fileReason <|> parsedReason of+ Nothing -> pure BlueprintMigrationSessionReturned+ Just reason -> do+ TIO.putStrLn $+ "Blueprint migration "+ <> stepLabel+ <> ": "+ <> formatMigrationStepLabel step+ <> " — not applicable: "+ <> reason+ pure (BlueprintMigrationSessionNotApplicable reason)++-- | Write one edge's receipt under the identity of the blueprint that /owns/+-- the edge, not the one the user named on the command line.+--+-- This looks like a mistake to a reader who does not know the design, and it+-- is the single line that makes fan-out correct. A project that crossed+-- kiroku's edge by running @keiro-upgrade@ has a receipt saying so under+-- @kiroku-upgrade@'s name and origin, so running @kiroku-upgrade@ directly+-- afterwards finds it and crosses nothing twice. Recording under the invoking+-- blueprint would make the same work look like two different edges. recordMigration :: FilePath ->- Blueprint ->- BlueprintMigration ->+ -- | every blueprint this run loaded, keyed by name+ Map Text CohortBlueprint ->+ BlueprintMigrationStep ->+ MigrationOutcome -> IO (Either Text ())-recordMigration manifestPath blueprint migration = do- now <- getCurrentTime- recordAppliedBlueprintMigration- manifestPath- AppliedBlueprintMigration- { name = blueprint ^. #name,- blueprintVersion = blueprint ^. #version,- fromVersion = migration ^. #from,- toVersion = migration ^. #to,- appliedAt = now,- agentSessionId = Nothing- }+recordMigration manifestPath cohort step migrationOutcome =+ case Map.lookup (step ^. #owner) cohort of+ -- Unreachable: the step came out of a plan this cohort resolved.+ Nothing -> pure (Left (missingOwnerMessage step))+ Just owner -> do+ now <- getCurrentTime+ recordAppliedBlueprintMigration+ manifestPath+ AppliedBlueprintMigration+ { name = owner ^. #blueprint . #name,+ origin = owner ^. #origin,+ blueprintVersion = owner ^. #blueprint . #version,+ fromVersion = step ^. #edge . #from,+ toVersion = step ^. #edge . #to,+ outcome = migrationOutcome,+ appliedAt = now,+ agentSessionId = Nothing+ } handleRunResult :: LogLevel -> ModuleName -> BlueprintMigrationRunResult -> IO () handleRunResult level blueprintName = \case BlueprintMigrationNoWork -> TIO.putStrLn "No pending blueprint migrations."- BlueprintMigrationComplete completed ->+ BlueprintMigrationComplete completed -> do+ let notApplicable = length [() | (_, MigrationNotApplicable _) <- completed] TIO.putStrLn $ "Completed " <> T.pack (show (length completed)) <> " blueprint migration(s) for '" <> blueprintName ^. #unModuleName- <> "'."- BlueprintMigrationLaunchFailed migration failure -> do+ <> "'"+ <> ( if notApplicable > 0+ then " (" <> T.pack (show notApplicable) <> " not applicable)"+ else ""+ )+ <> "."+ BlueprintMigrationLaunchFailed step failure -> do let prefix = "Blueprint migration "- <> migration ^. #from- <> " -> "- <> migration ^. #to+ <> formatMigrationStepLabel step <> " failed; completed earlier edges remain recorded. " retry = "Fix the provider error, then rerun the same command to resume." case failure of@@ -296,13 +671,11 @@ BlueprintMigrationProviderFailure err -> do logIO level $ logError $ prefix <> err <> " " <> retry exitFailure- BlueprintMigrationRecordFailed migration err -> do+ BlueprintMigrationRecordFailed step err -> do logIO level $ logError $ "Agent completed blueprint migration "- <> migration ^. #from- <> " -> "- <> migration ^. #to+ <> formatMigrationStepLabel step <> ", but its receipt could not be recorded: " <> err <> ". The next edge was not started; repair manifest access, then rerun the same command."
src-exe/Seihou/CLI/AgentRun.hs view
@@ -35,6 +35,7 @@ agentLaunchDeclaration, resolveDeclaredAgentConfig, )+import Seihou.CLI.AgentGuard (enforceAgentArtifactGuard) import Seihou.CLI.AgentLaunch ( AgentContext (..), BaselineStatus (..),@@ -130,6 +131,40 @@ <> "'?" Left err -> exitErr level (renderModuleLoadError err) + -- (a2) Resolve the baseline composition — every declared base module plus+ -- its transitive dependencies — before anything is written. 'seihou run'+ -- guards every module in the composition it is about to generate from, not+ -- just the ones named at the top level, so the guard below needs the+ -- resolved composition rather than the blueprint's declared baseModules+ -- list. Resolving it here rather than inside 'applyBaseline' also means the+ -- Dhall evaluation happens exactly once.+ baselineComposition <-+ if opts ^. #noBaseline || null (bp ^. #baseModules)+ then pure Nothing+ else Just <$> loadBaselineComposition level (bp ^. #baseModules)++ -- (a3) Pre-flight downgrade and origin guard. This runs before the baseline+ -- is applied, before any variable is prompted for, and before the manifest+ -- is touched, so a refusal leaves the working tree and+ -- .seihou/manifest.json byte-identical — the property+ -- docs/adr/0003-a-stale-or-substituted-artifact-is-a-hard-error.md relies+ -- on. It covers the blueprint itself and every module the baseline would+ -- generate from, and nothing else: an artifact this run will not touch must+ -- not block it.+ --+ -- The check runs in --debug too, unlike on the migrate path. --debug is a+ -- true dry run for @agent migrate@ but not here: it skips only the provider+ -- call, still applies the baseline at (c), and still records+ -- applied-blueprint provenance below. Rewriting the manifest to name a+ -- blueprint older than the one this project records is ADR 0003's opening+ -- scenario exactly, so exempting debug would leave the hole this guard+ -- exists to close.+ enforceAgentArtifactGuard+ (opts ^. #allowDowngrade)+ (".seihou" </> "manifest.json")+ [bp ^. #name]+ (baselineComposedNames baselineComposition)+ -- Finish provider/model/effort resolution now that the blueprint is loaded -- and its launch declaration is known. This must precede the -- providerCanMountFiles computation below, which depends on the final@@ -169,10 +204,9 @@ baseline <- if opts ^. #noBaseline then pure BaselineSkipped- else- if null (bp ^. #baseModules)- then pure BaselineEmpty- else applyBaseline level opts (bp ^. #baseModules) cliOverrides resolved+ else case baselineComposition of+ Nothing -> pure BaselineEmpty+ Just composition -> applyBaseline level opts composition cliOverrides resolved -- (d) Render the system prompt around the prepared shared body. ctx <- gatherAgentContext@@ -195,7 +229,12 @@ -- after the rendered prompt is printed successfully. when launchSucceeded $ do now <- getCurrentTime- let entry = appliedBlueprintFromOutcome bp baseline opts now+ -- Classify the blueprint's discovery directory into a portable origin, so+ -- the recorded entry names the artifact rather than a directory that means+ -- nothing on another developer's machine.+ projectRoot <- getCurrentDirectory+ blueprintOrigin <- detectArtifactOrigin projectRoot blueprintDir+ let entry = appliedBlueprintFromOutcome bp blueprintOrigin baseline opts now manifestPath = ".seihou" </> "manifest.json" writeRes <- recordAppliedBlueprint manifestPath entry case writeRes of@@ -246,10 +285,11 @@ -- one-liner at the call site and so cross-plan tests can drive it -- with synthetic inputs. appliedBlueprintFromOutcome ::- Blueprint -> BaselineStatus -> BlueprintRunOpts -> UTCTime -> AppliedBlueprint-appliedBlueprintFromOutcome bp baseline opts now =+ Blueprint -> ArtifactOrigin -> BaselineStatus -> BlueprintRunOpts -> UTCTime -> AppliedBlueprint+appliedBlueprintFromOutcome bp blueprintOrigin baseline opts now = AppliedBlueprint { name = bp ^. #name,+ origin = blueprintOrigin, blueprintVersion = bp ^. #version, appliedAt = now, baselineModules = case baseline of@@ -263,34 +303,56 @@ agentSessionId = Nothing } --- | Apply the blueprint's @baseModules@ to the cwd. Mirrors the--- composition pipeline in @Seihou.CLI.Run.handleRun@: load every--- declared base module (plus transitive deps), resolve their variables--- through the same precedence chain (with the blueprint's own resolved--- vars folded into the CLI override map so the agent's prompt and the--- base modules see the same values), compile the composed plan,--- compute the diff, resolve conflicts, execute the plan, and write the--- resulting manifest. Returns 'BaselineApplied' listing each module's--- (name, version) for the prompt's "Baseline" section.-applyBaseline ::- LogLevel ->- BlueprintRunOpts ->- [Dependency] ->- Map VarName Text ->- Map VarName ResolvedVar ->- IO BaselineStatus-applyBaseline level opts baseModules cliOverridesIn resolvedBlueprintVars = do+-- | One resolved baseline composition: the primary base module, and every+-- module the baseline would generate from — the declared base modules plus+-- their transitive dependencies — in dependency order, each paired with the+-- directory it was discovered in.+type BaselineComposition = (ModuleName, [(ModuleInstance, Module, FilePath)])++-- | Load the blueprint's baseline composition without applying it.+--+-- Split out of 'applyBaseline' so the pre-flight artifact guard can see+-- exactly the module set the baseline would generate from before anything is+-- written, and so the composition's Dhall evaluation happens once per run+-- rather than once for the guard and once for the application.+loadBaselineComposition :: LogLevel -> [Dependency] -> IO BaselineComposition+loadBaselineComposition level baseModules = do searchPaths <- defaultSearchPaths (primary, additionals) <- case baseModules of d : rs -> pure (d ^. #module_, map (^. #module_) rs)- [] -> exitErr level "internal error: applyBaseline called with empty baseModules"+ [] -> exitErr level "internal error: loadBaselineComposition called with empty baseModules" compositionResult <- loadComposition searchPaths primary additionals- modulesInOrder <- case compositionResult of+ case compositionResult of Left err -> do logIO level $ logError $ "Baseline error: " <> renderModuleLoadError err exitFailure- Right ms -> pure ms+ Right modulesInOrder -> pure (primary, modulesInOrder) +-- | The module names a baseline application would generate from, as the+-- artifact guard's filter wants them. Mirrors @composedModuleNames@ in+-- "Seihou.CLI.Run". Empty when no baseline will be applied, which the guard+-- reads as "no modules are in scope for this run".+baselineComposedNames :: Maybe BaselineComposition -> Set ModuleName+baselineComposedNames =+ maybe mempty (\(_, modulesInOrder) -> Set.fromList [m ^. #name | (_, m, _) <- modulesInOrder])++-- | Apply the blueprint's @baseModules@ to the cwd. Mirrors the+-- composition pipeline in @Seihou.CLI.Run.handleRun@: take the composition+-- resolved by 'loadBaselineComposition', resolve its variables through the+-- same precedence chain (with the blueprint's own resolved vars folded into+-- the CLI override map so the agent's prompt and the base modules see the+-- same values), compile the composed plan, compute the diff, resolve+-- conflicts, execute the plan, and write the resulting manifest. Returns+-- 'BaselineApplied' listing each module's (name, version) for the prompt's+-- "Baseline" section.+applyBaseline ::+ LogLevel ->+ BlueprintRunOpts ->+ BaselineComposition ->+ Map VarName Text ->+ Map VarName ResolvedVar ->+ IO BaselineStatus+applyBaseline level opts (primary, modulesInOrder) cliOverridesIn resolvedBlueprintVars = do -- Classify every baseline module's discovery directory into a portable -- origin before anything is recorded, so the manifest stays meaningful on -- another developer's machine.
src-exe/Seihou/CLI/Commands.hs view
@@ -209,7 +209,8 @@ { source :: !(Maybe Text), name :: !(Maybe Text), modules :: ![Text],- all :: !Bool+ all :: !Bool,+ force :: !Bool } deriving stock (Eq, Show, Generic) @@ -368,14 +369,21 @@ provider :: !(Maybe Text), model :: !(Maybe Text), effort :: !(Maybe Text),- trace :: !(Maybe Text)+ trace :: !(Maybe Text),+ allowDowngrade :: !Bool } deriving stock (Eq, Show, Generic) data BlueprintMigrationOpts = BlueprintMigrationOpts { name :: !ModuleName,- from :: !Text,- to :: !Text,+ -- | Where to start migrating from. 'Nothing' means "infer it": the+ -- highest version this project's receipts say the blueprint has+ -- already been migrated to.+ from :: !(Maybe Text),+ -- | Where to migrate to. 'Nothing' means "infer it": the output of+ -- the blueprint's declared @versionProbe@, which reads the version+ -- this project depends on.+ to :: !(Maybe Text), prompt :: !(Maybe Text), vars :: ![(Text, Text)], namespace :: !(Maybe Text),@@ -385,7 +393,8 @@ provider :: !(Maybe Text), model :: !(Maybe Text), effort :: !(Maybe Text),- trace :: !(Maybe Text)+ trace :: !(Maybe Text),+ allowDowngrade :: !Bool } deriving stock (Eq, Show, Generic) @@ -931,6 +940,7 @@ <*> optional (option (T.pack <$> str) (long "name" <> metavar "NAME" <> help "Override installed module name")) <*> many (option (T.pack <$> str) (long "module" <> metavar "MODULE" <> help "Module, recipe, blueprint, or prompt name from the registry to install (repeatable)")) <*> switch (long "all" <> help "Install every module, recipe, blueprint, and prompt listed in the registry")+ <*> switch (long "force" <> help "Replace an installation that came from a different source") newModuleParser :: Parser Command newModuleParser =@@ -1827,6 +1837,10 @@ <*> modelOption <*> effortOption <*> traceOption+ <*> switch+ ( long "allow-downgrade"+ <> help "Proceed even when the blueprint or a baseline module installed locally is older than, or from a different source than, .seihou/manifest.json records"+ ) agentMigrateInfo :: ParserInfo AgentCommand agentMigrateInfo =@@ -1837,20 +1851,28 @@ <> footerDoc ( Just $ vsep- [ pretty ("Selects the blueprint migrations inside the explicit version window," :: String),+ [ pretty ("Selects the blueprint migrations inside the version window," :: String), pretty ("runs one provider interaction per edge, and records each successful" :: String), pretty ("edge so an interrupted chain resumes without repeating completed work." :: String), line,+ pretty ("Either end of the window may be omitted. --to then comes from the" :: String),+ pretty ("blueprint's declared version probe, which reads the version this" :: String),+ pretty ("project depends on; --from comes from the highest version already" :: String),+ pretty ("recorded in this project's migration receipts. An explicit flag" :: String),+ pretty ("always wins, and an inferred end is reported with its source." :: String),+ line, pretty ("Versions must be dotted numeric values. Gaps are allowed. Pass --rerun" :: String), pretty ("to ignore matching receipts. Parent --debug prints every pending prompt" :: String),- pretty ("without contacting a provider or changing the manifest." :: String),+ pretty ("without contacting a provider or changing the manifest; it does run" :: String),+ pretty ("the version probe, which is read-only." :: String), line, pretty ("Examples:" :: String), indent 2 $ vsep- [ pretty ("seihou agent migrate my-library --from 1.0.0 --to 3.0.0" :: String),+ [ pretty ("seihou agent migrate my-library" :: String),+ pretty ("seihou agent migrate my-library --from 1.0.0 --to 3.0.0" :: String), pretty ("seihou agent migrate my-library --from 1 --to 3 --rerun" :: String),- pretty ("seihou agent --debug migrate my-library --from 1.0.0 --to 3.0.0" :: String)+ pretty ("seihou agent --debug migrate my-library --to 3.0.0" :: String) ] ] )@@ -1861,8 +1883,22 @@ fmap AgentMigrate $ BlueprintMigrationOpts <$> argument moduleNameReader (metavar "BLUEPRINT" <> help "Name of the blueprint containing migrations")- <*> option (T.pack <$> str) (long "from" <> metavar "VERSION" <> help "Currently used library version (dotted numeric)")- <*> option (T.pack <$> str) (long "to" <> metavar "VERSION" <> help "Desired library version (dotted numeric)")+ <*> optional+ ( option+ (T.pack <$> str)+ ( long "from"+ <> metavar "VERSION"+ <> help "Currently used library version (dotted numeric; default: the highest version this project has already migrated to)"+ )+ )+ <*> optional+ ( option+ (T.pack <$> str)+ ( long "to"+ <> metavar "VERSION"+ <> help "Desired library version (dotted numeric; default: the blueprint's declared version probe)"+ )+ ) <*> optional (argument (T.pack <$> str) (metavar "PROMPT" <> help "Optional initial user instruction for each migration session")) <*> many ( option@@ -1877,6 +1913,10 @@ <*> modelOption <*> effortOption <*> traceOption+ <*> switch+ ( long "allow-downgrade"+ <> help "Proceed even when the blueprint installed locally is older than, or from a different source than, .seihou/manifest.json records"+ ) agentModelsInfo :: ParserInfo AgentCommand agentModelsInfo =
src-exe/Seihou/CLI/Install.hs view
@@ -14,7 +14,13 @@ import Seihou.CLI.BrowseFormat (kindLabel) import Seihou.CLI.Commands (InstallOpts (..)) import Seihou.CLI.InstallHistory (HistoryEntry (..), InstallHistory (..), readHistory, recordUrl)-import Seihou.CLI.InstallShared (cloneRepo, copyDirectoryRecursive, installModuleDir)+import Seihou.CLI.InstallShared+ ( InstallOutcome (..),+ cloneRepo,+ copyDirectoryRecursive,+ formatInstallRefusal,+ installModuleDir,+ ) import Seihou.CLI.Registry.Sync (checkRegistryVersionDrift) import Seihou.CLI.Shared (logIO) import Seihou.Core.AgentPrompt (validateAgentPrompt)@@ -182,7 +188,8 @@ Right _ -> pure () TIO.putStrLn " Validated module definition" - installModuleDir rootDir name source registryName (modul ^. #version) []+ outcome <- installModuleDir (iopts ^. #force) rootDir name source registryName (modul ^. #version) []+ reportSingleInstall name source outcome TIO.putStrLn "" TIO.putStrLn $ "Module available as: " <> T.pack name @@ -196,7 +203,8 @@ -- Validate recipe.dhall exists (discoverRepoContents already confirmed it) TIO.putStrLn " Validated recipe definition" - installModuleDir rootDir name source Nothing Nothing []+ outcome <- installModuleDir (iopts ^. #force) rootDir name source Nothing Nothing []+ reportSingleInstall name source outcome TIO.putStrLn "" TIO.putStrLn $ "Recipe available as: " <> T.pack name @@ -231,7 +239,8 @@ TIO.putStrLn " Validated blueprint definition" let bpVersion = (bp ^. #version)- installModuleDir rootDir name source Nothing bpVersion []+ outcome <- installModuleDir (iopts ^. #force) rootDir name source Nothing bpVersion []+ reportSingleInstall name source outcome TIO.putStrLn "" TIO.putStrLn $ "Blueprint available as: " <> T.pack name @@ -265,7 +274,8 @@ Right _ -> pure () TIO.putStrLn " Validated prompt definition" - installModuleDir rootDir name source Nothing (prompt ^. #version) []+ outcome <- installModuleDir (iopts ^. #force) rootDir name source Nothing (prompt ^. #version) []+ reportSingleInstall name source outcome TIO.putStrLn "" TIO.putStrLn $ "Prompt available as: " <> T.pack name @@ -276,7 +286,7 @@ if null selected then TIO.putStrLn "No entries selected." else do- results <- mapM (installRegistryEntry cloneDir source (registry ^. #repoName)) selected+ results <- mapM (installRegistryEntry (iopts ^. #force) cloneDir source (registry ^. #repoName)) selected let succeeded = length (filter id results) failed = length results - succeeded TIO.putStrLn ""@@ -287,7 +297,33 @@ <> " installed" <> (if failed > 0 then ", " <> T.pack (show failed) <> " failed" else "") <> "."+ -- A batch runs to completion before it reports, so a user installing+ -- twenty entries sees every refusal and every load failure at once+ -- rather than stopping at the first. But a batch that did not fully+ -- succeed must not exit zero: a caller in a script would otherwise+ -- treat a half-applied install as done.+ when (failed > 0) exitFailure +-- | Report one single-artifact install. A refusal is fatal here: the command+-- was asked to install exactly one thing and did not.+reportSingleInstall :: String -> Text -> InstallOutcome -> IO ()+reportSingleInstall _ _ InstallPerformed = pure ()+reportSingleInstall name source (InstallRefused collision) = do+ TIO.putStrLn ""+ TIO.putStrLn (formatInstallRefusal name source collision)+ exitFailure++-- | Report one registry-batch install, returning whether it succeeded. A+-- refusal is not fatal here: the remaining entries are still attempted, and+-- 'installFromRegistry' exits nonzero once it has reported them all.+reportRegistryInstall :: String -> Text -> InstallOutcome -> Text -> IO Bool+reportRegistryInstall _ _ InstallPerformed successLine = do+ TIO.putStrLn successLine+ pure True+reportRegistryInstall name source (InstallRefused collision) _ = do+ TIO.putStrLn (formatInstallRefusal name source collision)+ pure False+ -- | All registry entries (modules, recipes, blueprints, prompts) in display order. -- Used wherever installation must treat all four kinds uniformly. allEntries :: Registry -> [RegistryEntry]@@ -406,8 +442,8 @@ else pure [entryList !! (n - 1) | n <- indices] -- | Install a single registry entry (module, recipe, blueprint, or prompt).-installRegistryEntry :: FilePath -> Text -> Text -> RegistryEntry -> IO Bool-installRegistryEntry cloneDir source repoName entry = do+installRegistryEntry :: Bool -> FilePath -> Text -> Text -> RegistryEntry -> IO Bool+installRegistryEntry force cloneDir source repoName entry = do let entryDir = cloneDir </> (entry ^. #path) name = T.unpack (entry ^. #name . #unModuleName) moduleDhall = entryDir </> "module.dhall"@@ -438,16 +474,14 @@ pure False Right _ -> do let ver = entry ^. #version <|> (modul ^. #version)- installModuleDir entryDir name source (Just repoName) ver (entry ^. #tags)- TIO.putStrLn $ " Installed as: " <> T.pack name- pure True+ outcome <- installModuleDir force entryDir name source (Just repoName) ver (entry ^. #tags)+ reportRegistryInstall name source outcome (" Installed as: " <> T.pack name) else do hasRecipe <- doesFileExist recipeDhall if hasRecipe then do- installModuleDir entryDir name source (Just repoName) (entry ^. #version) (entry ^. #tags)- TIO.putStrLn $ " Installed recipe as: " <> T.pack name- pure True+ outcome <- installModuleDir force entryDir name source (Just repoName) (entry ^. #version) (entry ^. #tags)+ reportRegistryInstall name source outcome (" Installed recipe as: " <> T.pack name) else do hasBlueprint <- doesFileExist blueprintDhall if hasBlueprint@@ -461,9 +495,8 @@ Right bp -> do let bpVersion = (bp ^. #version) ver = entry ^. #version <|> bpVersion- installModuleDir entryDir name source (Just repoName) ver (entry ^. #tags)- TIO.putStrLn $ " Installed blueprint as: " <> T.pack name- pure True+ outcome <- installModuleDir force entryDir name source (Just repoName) ver (entry ^. #tags)+ reportRegistryInstall name source outcome (" Installed blueprint as: " <> T.pack name) else do hasPrompt <- doesFileExist promptDhall if hasPrompt@@ -487,9 +520,8 @@ pure False Right _ -> do let ver = entry ^. #version <|> (prompt ^. #version)- installModuleDir entryDir name source (Just repoName) ver (entry ^. #tags)- TIO.putStrLn $ " Installed prompt as: " <> T.pack name- pure True+ outcome <- installModuleDir force entryDir name source (Just repoName) ver (entry ^. #tags)+ reportRegistryInstall name source outcome (" Installed prompt as: " <> T.pack name) else do logIO LogNormal $ do logError $ " entry '" <> entry ^. #name . #unModuleName <> "' has no supported runnable Dhall file at " <> T.pack (entry ^. #path)
src-exe/Seihou/CLI/Run.hs view
@@ -27,11 +27,9 @@ import Seihou.CLI.CommitMessage (generateCommitMessage) import Seihou.CLI.Git (gitAdd, gitCheckIgnore, gitCommit, gitDiffCached, isGitRepo) import Seihou.CLI.ManifestGuard- ( ArtifactCheck,- blockingChecks,+ ( blockingChecks, checkAppliedArtifactsFor,- formatGuardOverride,- formatGuardRefusal,+ enforceArtifactGuard, ) import Seihou.CLI.Migrate ( MigrateError (..),@@ -289,7 +287,7 @@ searchPaths <- defaultSearchPaths guardChecks <- checkAppliedArtifactsFor projectRoot searchPaths (Just composedModuleNames) initialManifest- enforceArtifactGuard runOpts (blockingChecks guardChecks)+ enforceArtifactGuard (runOpts ^. #allowDowngrade) (blockingChecks guardChecks) -- 6c. Pre-flight pending-migration check. We only consider modules in -- the current composition: a pending chain on an unrelated module@@ -429,7 +427,11 @@ [Map.map (^. #value) vs | vs <- Map.elems resolved] appliedRecipe = case recipeInfo of Just (rName, rVersion) ->- Just AppliedRecipe {name = rName, recipeVersion = rVersion, appliedAt = now}+ -- targetOrigin is the recipe's own origin+ -- here: recipeInfo is Just only on the+ -- branch where targetInfo was built from+ -- the discovered recipe directory.+ Just AppliedRecipe {name = rName, origin = targetOrigin, recipeVersion = rVersion, appliedAt = now} Nothing -> (manifest ^. #recipe) appliedCompositionWithoutReceipts = buildAppliedComposition@@ -689,24 +691,6 @@ | application ^. #applicationId == applicationId = application & #commandReceipts .~ receipts | otherwise = application---- | Apply the downgrade / origin-mismatch policy.------ Without @--allow-downgrade@: the run refuses before a single file is--- written, so the project and its manifest are left byte-identical.------ With @--allow-downgrade@: the same blocks are printed under a--- "proceeding anyway" lead-in and the run continues. They are printed--- rather than suppressed on purpose — a deliberate downgrade is still a--- downgrade, and the diff it produces should not be the first time anyone--- hears about it.-enforceArtifactGuard :: RunOpts -> [ArtifactCheck] -> IO ()-enforceArtifactGuard _ [] = pure ()-enforceArtifactGuard runOpts blocking- | runOpts ^. #allowDowngrade = TIO.putStr (formatGuardOverride blocking)- | otherwise = do- TIO.putStr (formatGuardRefusal blocking)- exitFailure -- | Apply the pending-migration policy. --
src-exe/Seihou/CLI/Status.hs view
@@ -5,9 +5,10 @@ import Control.Exception (SomeException, try) import Data.Generics.Labels ()+import Data.Maybe (maybeToList) import Data.Text.IO qualified as TIO import Seihou.CLI.Commands (StatusOpts (..))-import Seihou.CLI.ManifestGuard (ArtifactCheck, checkAppliedArtifacts)+import Seihou.CLI.ManifestGuard (ArtifactCheck, checkAppliedArtifacts, checkAppliedBlueprint) import Seihou.CLI.Outdated (checkInstalledModulesForUpdates) import Seihou.CLI.PendingMigrations (detectPendingMigrations) import Seihou.CLI.Shared (logIO)@@ -65,12 +66,19 @@ -- failure so status still renders. An empty list means "nothing to report", -- which is also what a failed check yields — @seihou status@ must not turn a -- reporting problem into an exit code.+--+-- The recorded blueprint is checked alongside the recorded modules. A stale+-- or substituted blueprint makes @seihou agent run@ and @seihou agent+-- migrate@ refuse, so this is where a developer finds out before that+-- happens — the same reason the module checks are here. fetchArtifactChecks :: Manifest -> IO [ArtifactCheck] fetchArtifactChecks manifest = do outcome <- try $ do projectRoot <- getCurrentDirectory searchPaths <- defaultSearchPaths- checkAppliedArtifacts projectRoot searchPaths manifest+ moduleChecks <- checkAppliedArtifacts projectRoot searchPaths manifest+ blueprintCheck <- checkAppliedBlueprint projectRoot searchPaths manifest+ pure (moduleChecks <> maybeToList blueprintCheck) case outcome of Left (e :: SomeException) -> do hPutStrLn stderr ("warning: artifact check failed: " <> show e)
src-exe/Seihou/CLI/Upgrade.hs view
@@ -15,7 +15,7 @@ import Data.Text.IO qualified as TIO import Seihou.CLI.Commands (UpgradeOpts (..)) import Seihou.CLI.Install (installModuleDir)-import Seihou.CLI.InstallShared (OriginInfo (..))+import Seihou.CLI.InstallShared (InstallOutcome (..), OriginInfo (..), summarizeInstallRefusal) import Seihou.CLI.Migrate ( MigrateError (..), MigrateOpts (..),@@ -214,9 +214,25 @@ (entry : _) -> (modul ^. #version <|> entry ^. #version, entry ^. #tags) [] -> (modul ^. #version, []) _ -> (modul ^. #version, [])- installModuleDir moduleDir (T.unpack name) sourceUrl registryName ver tags- TIO.putStrLn $ " Upgraded " <> name- pure UpgradeEntry {moduleName = name, oldVersion = installedVer, newVersion = availableVer, upgradeStatus = Upgraded}+ -- Pass force = False deliberately. This reinstalls from the URL+ -- the installed copy already records, so it is structurally the+ -- same-source case and must never refuse. If it ever does, the+ -- cache and its own provenance file disagree — real news, and+ -- reported as an upgrade failure rather than overridden. Do not+ -- "fix" a refusal here by passing True.+ outcome <- installModuleDir False moduleDir (T.unpack name) sourceUrl registryName ver tags+ case outcome of+ InstallRefused collision ->+ pure+ UpgradeEntry+ { moduleName = name,+ oldVersion = installedVer,+ newVersion = availableVer,+ upgradeStatus = UpgradeFailed (summarizeInstallRefusal sourceUrl collision)+ }+ InstallPerformed -> do+ TIO.putStrLn $ " Upgraded " <> name+ pure UpgradeEntry {moduleName = name, oldVersion = installedVer, newVersion = availableVer, upgradeStatus = Upgraded} renderUpgradeTable :: [UpgradeEntry] -> IO () renderUpgradeTable entries = do
+ src/Seihou/CLI/AgentGuard.hs view
@@ -0,0 +1,101 @@+-- | The pre-flight artifact guard for the agent path.+--+-- @seihou agent run@ and @seihou agent migrate@ both act on artifacts the+-- project records in @.seihou\/manifest.json@: the first applies a+-- blueprint's baseline modules to the working directory and rewrites the+-- manifest, the second writes a receipt per migration edge that suppresses+-- future runs of that edge. Both are therefore subject to+-- docs\/adr\/0003-a-stale-or-substituted-artifact-is-a-hard-error.md, which+-- decides that a command about to generate from an artifact refuses when the+-- local copy is older than, or came from somewhere other than, what the+-- manifest records.+--+-- This module is the glue between that decision and those two commands. The+-- comparison itself is 'Seihou.CLI.ManifestGuard'; all this adds is reading+-- the manifest, choosing what is in scope, and handing the result to+-- 'enforceArtifactGuard'.+module Seihou.CLI.AgentGuard+ ( enforceAgentArtifactGuard,+ )+where++import Data.Generics.Labels ()+import Data.Maybe (maybeToList)+import Data.Set qualified as Set+import Seihou.CLI.ManifestGuard+ ( blockingChecks,+ checkAppliedArtifactsFor,+ checkRecordedBlueprint,+ enforceArtifactGuard,+ )+import Seihou.Core.Module (defaultSearchPaths)+import Seihou.Core.Types (ModuleName)+import Seihou.Effect.FilesystemInterp (runFilesystem)+import Seihou.Effect.ManifestStore (readManifest)+import Seihou.Effect.ManifestStoreInterp (runManifestStore)+import Seihou.Prelude+import System.Directory (getCurrentDirectory)++-- | Refuse to proceed when an artifact this agent command is about to use+-- disagrees with what the project records, unless @--allow-downgrade@ says+-- otherwise.+--+-- @manifestPath@ is the project's @.seihou\/manifest.json@.+-- @blueprintNames@ are the blueprints the command is about to use: the one it+-- was invoked on, and — for @agent migrate@ crossing a cohort — every further+-- blueprint reached by entailment, each of which owns edges this run will+-- launch and write receipts for. @baselineModuleNames@ are the modules the+-- command is about to generate files from — every module in the resolved+-- baseline composition for @agent run@, and empty for @agent migrate@, which+-- applies no baseline.+--+-- Two situations pass without a check because there is genuinely nothing to+-- compare against: a project with no manifest at all, and a manifest that+-- cannot be read. The second is deliberate rather than lax — an unreadable+-- manifest is a problem the command's own manifest handling reports far+-- better than a guard could, and turning it into a downgrade refusal would+-- name the wrong cause.+--+-- Scope is the whole point. A blueprint recorded under a different name, or a+-- stale module the command will not touch, must not block work that has+-- nothing to do with it; that is the line ADR 0003 draws for @seihou run@ and+-- this holds it for the agent path.+--+-- Whether @--debug@ exempts a command from this check is the caller's+-- decision, and the two agent commands answer differently because @--debug@+-- means different things to them. It is a true dry run for @seihou agent+-- migrate@, which prints its pending prompts and writes nothing, so that+-- command skips the check and stays usable for inspecting a prompt on a+-- machine that has never installed the artifact. It is not a dry run for+-- @seihou agent run@, which still applies the blueprint's baseline and still+-- records applied-blueprint provenance under debug, so that command checks+-- unconditionally.+enforceAgentArtifactGuard ::+ -- | @--allow-downgrade@+ Bool ->+ -- | path to @.seihou\/manifest.json@+ FilePath ->+ -- | the blueprints this command is about to use+ [ModuleName] ->+ -- | modules this command is about to generate files from+ Set ModuleName ->+ IO ()+enforceAgentArtifactGuard allowDowngrade manifestPath blueprintNames baselineModuleNames = do+ readResult <- runEff $ runFilesystem $ runManifestStore manifestPath readManifest+ case readResult of+ Left _ -> pure ()+ Right Nothing -> pure ()+ Right (Just manifest) -> do+ projectRoot <- getCurrentDirectory+ searchPaths <- defaultSearchPaths+ blueprintChecks <-+ traverse+ (\blueprintName -> checkRecordedBlueprint projectRoot searchPaths blueprintName manifest)+ blueprintNames+ moduleChecks <-+ if Set.null baselineModuleNames+ then pure []+ else checkAppliedArtifactsFor projectRoot searchPaths (Just baselineModuleNames) manifest+ enforceArtifactGuard+ allowDowngrade+ (blockingChecks (concatMap maybeToList blueprintChecks <> moduleChecks))
src/Seihou/CLI/BlueprintMigration.hs view
@@ -2,18 +2,39 @@ -- agent-guided blueprint migrations. module Seihou.CLI.BlueprintMigration ( BlueprintMigrationLaunchFailure (..),+ BlueprintMigrationLaunchResult (..), BlueprintMigrationRunResult (..), renderBlueprintMigrationInstruction, renderBlueprintMigrationSystemPrompt, formatBlueprintMigrationDebugOutput,+ formatMigrationStepLabel, pendingBlueprintMigrations,+ parseNotApplicableSignal,+ unstatedNotApplicableReason, runBlueprintMigrationsWith,++ -- * Inferring the version window+ VersionSource (..),+ ResolvedWindow (..),+ WindowResolutionError (..),+ VersionProbeResult (..),+ highestMigratedVersion,+ resolveMigrationWindow,+ readVersionProbeOutput,+ runVersionProbe,+ formatResolvedWindow,+ formatProbeFailure,+ formatWindowResolutionError, ) where +import Data.Char (isAlphaNum, isSpace) import Data.Generics.Labels ()-import Data.Maybe (fromMaybe)+import Data.List (sortOn)+import Data.Maybe (fromMaybe, listToMaybe, mapMaybe)+import Data.Ord (Down (..)) import Data.Text qualified as T+import Data.Time.Format (defaultTimeLocale, formatTime) import Seihou.CLI.AgentLaunch ( AgentContext (..), formatAvailableModules,@@ -27,19 +48,26 @@ ( PreparedBlueprintExecution (..), renderBlueprintText, )+import Seihou.Core.ArtifactIdentity (sameArtifactIdentity) import Seihou.Core.Migration ( BlueprintMigration (..), BlueprintMigrationPlan (..),+ BlueprintMigrationStep (..),+ EntailmentSite (..), ) import Seihou.Core.Types ( AppliedBlueprintMigration (..),+ ArtifactOrigin (..), Blueprint (..),+ MigrationOutcome (..), ModuleName (..), ResolvedVar, VarName, )+import Seihou.Core.Version (Version, parseVersion, renderVersion)+import Seihou.Effect.Process (Process, runProcess) import Seihou.Prelude-import System.Exit (ExitCode)+import System.Exit (ExitCode (..)) -- | Provider failures retain either a real interactive process exit or API -- error text rather than collapsing both paths into an artificial exit code.@@ -48,12 +76,25 @@ | BlueprintMigrationProviderFailure Text deriving stock (Eq, Show) +-- | What one edge's provider interaction produced, when it produced anything+-- at all. A launch that never returned is a 'BlueprintMigrationLaunchFailure'+-- instead; these two constructors are both non-failures, and the chain+-- continues past either of them.+data BlueprintMigrationLaunchResult+ = BlueprintMigrationSessionReturned+ | BlueprintMigrationSessionNotApplicable !Text+ deriving stock (Eq, Show)+ -- | Terminal outcome for one pending migration chain.+--+-- 'BlueprintMigrationComplete' carries each edge together with what it+-- produced, so the caller can report how many edges did real work and how many+-- reported themselves inapplicable without re-reading the manifest. data BlueprintMigrationRunResult = BlueprintMigrationNoWork- | BlueprintMigrationComplete [BlueprintMigration]- | BlueprintMigrationLaunchFailed BlueprintMigration BlueprintMigrationLaunchFailure- | BlueprintMigrationRecordFailed BlueprintMigration Text+ | BlueprintMigrationComplete [(BlueprintMigrationStep, MigrationOutcome)]+ | BlueprintMigrationLaunchFailed BlueprintMigrationStep BlueprintMigrationLaunchFailure+ | BlueprintMigrationRecordFailed BlueprintMigrationStep Text deriving stock (Eq, Show) -- | Render the edge-specific instruction with the same resolved variables as@@ -68,16 +109,27 @@ -- | Fill the migration-specific embedded template. The template itself stays -- in the executable target because @Data.FileEmbed@ traps it there; accepting -- it as an argument keeps all rendering policy pure and unit-testable here.+-- The not-applicable signal path is passed in for the same reason: the caller+-- knows the project root, and this stays a function of its arguments.+--+-- @prepared@ must be the execution context of the step's /owning/ blueprint,+-- not of the blueprint named on the command line. Under entailment those+-- differ, and the agent is told the owner's identity and handed the owner's+-- reference files, because it is doing the owner's migration. renderBlueprintMigrationSystemPrompt :: Text ->+ -- | absolute path the agent writes to when this edge does not apply+ FilePath -> AgentContext ->+ -- | the /owning/ blueprint's prepared execution PreparedBlueprintExecution -> Int -> Int ->- BlueprintMigration ->+ BlueprintMigrationStep -> Text-renderBlueprintMigrationSystemPrompt template ctx prepared position total migration =+renderBlueprintMigrationSystemPrompt template signalPath ctx prepared position total step = let blueprint = (prepared ^. #blueprint)+ migration = (step ^. #edge) renderedInstruction = renderBlueprintMigrationInstruction (prepared ^. #resolvedVariables) migration in substitute@@ -94,21 +146,27 @@ ("migration_to", migration ^. #to), ("migration_position", T.pack (show position)), ("migration_total", T.pack (show total)),+ ("migration_entailed_by", formatEntailedBy step), ("reference_files", prepared ^. #referenceFiles), ("reference_files_dir", prepared ^. #referenceFilesAccess), ("shared_prompt", prepared ^. #sharedPrompt),- ("migration_prompt", renderedInstruction)+ ("migration_prompt", renderedInstruction),+ ("not_applicable_signal_path", T.pack signalPath) ] template -- | Clearly delimit every pending prompt for parent debug mode. This pure -- function cannot launch a provider or receive a recorder, which makes the -- migration debug path structurally read-only.+--+-- Each header names the step's owning blueprint, because a chain may span+-- several: a reader inspecting a cohort migration has no other way to tell+-- which blueprint's prompt they are looking at. formatBlueprintMigrationDebugOutput ::- (Int -> Int -> BlueprintMigration -> Text) ->- [BlueprintMigration] ->+ (Int -> Int -> BlueprintMigrationStep -> Text) ->+ [BlueprintMigrationStep] -> Text-formatBlueprintMigrationDebugOutput render migrations =+formatBlueprintMigrationDebugOutput render steps = T.intercalate "\n\n" [ T.unlines@@ -117,59 +175,457 @@ <> "/" <> T.pack (show total) <> "] "- <> migration ^. #from- <> " -> "- <> migration ^. #to+ <> formatMigrationStepLabel step <> " =====",- render position total migration+ render position total step ]- | (position, migration) <- zip [1 ..] migrations+ | (position, step) <- zip [1 ..] steps ] where- total = length migrations+ total = length steps --- | Remove exact-edge receipts while retaining planner order. Artifact--- versions and timestamps are intentionally not part of the completion key.+-- | Name one step the way every user-facing surface names it: the owning+-- blueprint, its edge window, and — when the step was reached through+-- entailment rather than named on the command line — what pulled it in.+--+-- One definition rather than three, because the launch announcement, the+-- debug headers, and the failure messages must agree; a chain that spans+-- blueprints is confusing enough without three spellings of the same step.+formatMigrationStepLabel :: BlueprintMigrationStep -> Text+formatMigrationStepLabel step =+ step ^. #owner+ <> " "+ <> step ^. #edge . #from+ <> " -> "+ <> step ^. #edge . #to+ <> maybe "" (\site -> " (entailed by " <> renderSite site <> ")") (step ^. #entailedBy)++-- | The sentence the framing prompt uses to explain to an agent why it is+-- migrating a library the user did not name. Empty for a directly selected+-- edge, which needs no explanation.+formatEntailedBy :: BlueprintMigrationStep -> Text+formatEntailedBy step = case step ^. #entailedBy of+ Nothing -> ""+ Just site ->+ "This edge was not requested directly. It is required by "+ <> renderSite site+ <> ", which the user is migrating."++renderSite :: EntailmentSite -> Text+renderSite site =+ site ^. #blueprint <> " " <> site ^. #from <> " -> " <> site ^. #to++-- | Remove applied exact-edge receipts while retaining planner order.+--+-- Exact-edge identity is the origin and name of the blueprint that owns the+-- edge together with its @from@ and @to@ versions. Artifact versions and+-- timestamps are intentionally not part of the completion key: an edge is the+-- same edge regardless of which release of the blueprint declared it. Origin+-- is part of it, because two blueprints published by different repositories+-- that share a name and an edge window are not the same edge, and dropping a+-- second repository's edge because the first one's is recorded would be a+-- silent skip of work that never ran.+--+-- The identity used for a step is the /owning/ blueprint's, resolved through+-- @lookupOwner@, not the identity of the blueprint the user invoked. Under+-- entailment a single plan contains steps owned by several blueprints, and+-- this is the mechanism that makes a shared cohort edge the same edge from+-- either entry point: a project that crossed kiroku's edge by running+-- @keiro-upgrade@ has a receipt under @kiroku-upgrade@'s identity, so running+-- @kiroku-upgrade@ directly finds that receipt and crosses nothing twice.+--+-- @lookupOwner@ returning 'Nothing' cannot happen in production: cohort+-- discovery resolves every owner before a plan reaches this function. It is+-- treated as "not previously applied" rather than as a crash, because the+-- honest failure for an unresolvable owner is the discovery error the caller+-- already raises, not a receipt lookup that silently claims completion.+--+-- The receipt's outcome is also part of the decision, though not of the+-- edge's identity. Only a 'MigrationApplied' receipt suppresses its edge. A+-- 'MigrationNotApplicable' one records that the edge was evaluated and found+-- inapplicable to this project, which says nothing about whether it applies+-- now — the precondition it reported unmet may since have been met, and that+-- is the ordinary case, because satisfying it is usually what the edge told+-- the user to do.+--+-- Receipts written before origins were recorded decode as+-- @'LocalOrigin' name@, which matches other such receipts and matches nothing+-- installed from a git URL. A project upgrading across that change therefore+-- sees its previously-recorded edges become pending once; that is honest,+-- because seihou cannot prove the recorded edge and the planned one came from+-- the same repository. pendingBlueprintMigrations :: Bool ->- ModuleName ->+ -- | the recorded identity of a step's owning blueprint, by name+ (Text -> Maybe (ModuleName, ArtifactOrigin)) -> [AppliedBlueprintMigration] -> BlueprintMigrationPlan ->- [BlueprintMigration]-pendingBlueprintMigrations rerun blueprintName receipts plan+ [BlueprintMigrationStep]+pendingBlueprintMigrations rerun lookupOwner receipts plan | rerun = plan ^. #steps | otherwise = filter (not . alreadyApplied) (plan ^. #steps) where- alreadyApplied migration =- any- ( \receipt ->- receipt ^. #name == blueprintName- && receipt ^. #fromVersion == migration ^. #from- && receipt ^. #toVersion == migration ^. #to- )- receipts+ alreadyApplied step = case lookupOwner (step ^. #owner) of+ Nothing -> False+ Just (ownerName, ownerOrigin) ->+ any+ ( \receipt ->+ receipt ^. #outcome == MigrationApplied+ && sameArtifactIdentity (receipt ^. #origin) ownerOrigin+ && receipt ^. #name == ownerName+ && receipt ^. #fromVersion == step ^. #edge . #from+ && receipt ^. #toVersion == step ^. #edge . #to+ )+ receipts -- | Launch and record one pending edge at a time. A receipt is requested only--- after its launch succeeds, and either callback failure stops the chain before+-- after its launch returns, and either callback failure stops the chain before -- the next launch.+--+-- An edge that reports itself not applicable is not a failure and does not+-- stop the chain: its receipt is written with that outcome and the next edge+-- launches, exactly as after an applied one. runBlueprintMigrationsWith ::- (Int -> Int -> BlueprintMigration -> IO (Either BlueprintMigrationLaunchFailure ())) ->- (BlueprintMigration -> IO (Either Text ())) ->- [BlueprintMigration] ->+ (Int -> Int -> BlueprintMigrationStep -> IO (Either BlueprintMigrationLaunchFailure BlueprintMigrationLaunchResult)) ->+ (BlueprintMigrationStep -> MigrationOutcome -> IO (Either Text ())) ->+ [BlueprintMigrationStep] -> IO BlueprintMigrationRunResult runBlueprintMigrationsWith _launch _record [] = pure BlueprintMigrationNoWork-runBlueprintMigrationsWith launch record migrations =- go [] (zip [1 ..] migrations)+runBlueprintMigrationsWith launch record steps =+ go [] (zip [1 ..] steps) where- total = length migrations+ total = length steps go completed [] = pure (BlueprintMigrationComplete (reverse completed))- go completed ((position, migration) : rest) = do- launchResult <- launch position total migration+ go completed ((position, step) : rest) = do+ launchResult <- launch position total step case launchResult of- Left failure -> pure (BlueprintMigrationLaunchFailed migration failure)- Right () -> do- recordResult <- record migration+ Left failure -> pure (BlueprintMigrationLaunchFailed step failure)+ Right sessionResult -> do+ let outcome = case sessionResult of+ BlueprintMigrationSessionReturned -> MigrationApplied+ BlueprintMigrationSessionNotApplicable reason -> MigrationNotApplicable reason+ recordResult <- record step outcome case recordResult of- Left err -> pure (BlueprintMigrationRecordFailed migration err)- Right () -> go (migration : completed) rest+ Left err -> pure (BlueprintMigrationRecordFailed step err)+ Right () -> go ((step, outcome) : completed) rest++-- | Extract a not-applicable signal from an API provider's assistant text.+--+-- Recognises a line of the form @SEIHOU: not-applicable \<reason\>@ among the+-- last few non-empty lines, tolerating the surrounding whitespace, backticks+-- and emphasis a model is liable to add. The marker itself is matched+-- strictly: the line must begin with it, so prose that merely discusses+-- applicability is not a signal. A false positive here silently skips real+-- work, which is worse than missing a signal an agent could have written to+-- the signal file instead.+parseNotApplicableSignal :: Text -> Maybe Text+parseNotApplicableSignal assistantText =+ listToMaybe (mapMaybe signalOnLine candidateLines)+ where+ candidateLines =+ take signalScanDepth $+ reverse $+ filter (not . T.null) $+ map T.strip (T.lines assistantText)++ signalOnLine line = do+ afterMarker <- T.stripPrefix "SEIHOU:" (stripDecoration line)+ afterToken <- T.stripPrefix "not-applicable" (stripDecoration afterMarker)+ -- The token must end a word: 'not-applicable-ish' is not the marker.+ if maybe False continuesTheToken (fst <$> T.uncons afterToken)+ then Nothing+ else Just (readReason afterToken)++ continuesTheToken c = isAlphaNum c || c == '-'++ readReason =+ orPlaceholder+ . stripDecoration+ . T.dropWhile (\c -> isSpace c || c `elem` (":-–—" :: String))+ . stripDecoration++ orPlaceholder reason+ | T.null reason = unstatedNotApplicableReason+ | otherwise = reason++ stripDecoration = T.dropAround (\c -> isSpace c || c `elem` ("*_`" :: String))++-- | How many trailing non-empty lines of an assistant reply to search for the+-- marker. A model that signals usually does so last, but often follows with a+-- closing sentence or two.+signalScanDepth :: Int+signalScanDepth = 5++-- | What to record when an edge signals inapplicability without saying why.+-- The signal is a deliberate act either way, so it is honoured; the reason is+-- what suffers.+unstatedNotApplicableReason :: Text+unstatedNotApplicableReason = "(no reason given)"++-- ---------------------------------------------------------------------------+-- Inferring the version window+-- ---------------------------------------------------------------------------++-- | Where one end of the migration version window came from. Carried so the+-- command can tell the user what it inferred and why, which matters more here+-- than usual: an inferred window silently off by one release would run the+-- wrong edges against their source.+data VersionSource+ = VersionFromFlag+ | -- | The blueprint's declared probe command, which printed this version.+ VersionFromProbe !Text+ | -- | The receipt this end was read from. The whole record is carried+ -- rather than only its edge window, because the reported line names the+ -- blueprint and the date the edge was applied, and a user checking an+ -- inferred start needs to recognise the run it came from.+ VersionFromReceipt !AppliedBlueprintMigration+ deriving stock (Eq, Show, Generic)++-- | Both ends of the window, each with the reason it holds that value.+data ResolvedWindow = ResolvedWindow+ { fromVersion :: !Version,+ fromSource :: !VersionSource,+ toVersion :: !Version,+ toSource :: !VersionSource+ }+ deriving stock (Eq, Show, Generic)++-- | Why a window could not be resolved. Both cases are recoverable by passing+-- the flag the message names, so neither is reported as a defect.+data WindowResolutionError+ = -- | No @--to@ was given, and no probe supplied one.+ NoTargetVersion+ | -- | No @--from@ was given, and this project has no applied receipt for+ -- this blueprint to start from.+ NoStartVersion+ deriving stock (Eq, Show, Generic)++-- | What running a blueprint's declared version probe produced.+--+-- Only 'ProbeVersion' contributes to the window. The other two are reported to+-- the user and then treated as "no probe result": a probe is the blueprint+-- author's convenience, and a broken one must degrade to requiring @--to@+-- rather than failing a command the user can still complete by hand.+data VersionProbeResult+ = ProbeVersion !Version+ | -- | Exit code and captured stderr.+ ProbeExitedNonZero !Int !Text+ | -- | The probe succeeded but printed something that is not a dotted+ -- numeric version. Carries the raw stdout.+ ProbeOutputUnparseable !Text+ deriving stock (Eq, Show, Generic)++-- | The highest version this project has already migrated this blueprint to,+-- with the receipt that says so.+--+-- Only receipts belonging to this blueprint identity are considered — name and+-- origin both, per docs\/adr\/0002-artifact-identity-is-origin-url-plus-name.md+-- and compared with 'sameArtifactIdentity' rather than structural equality,+-- because a same-named blueprint from another repository records a different+-- project history and two spellings of one git URL record the same one.+--+-- The identity to pass is that of the blueprint whose /own/ edges are being+-- windowed. For @seihou agent migrate@ that is the invoked blueprint, because+-- the window is expressed in the invoked library's version space; an entailed+-- blueprint's steps are windowed by the edge that entails them, not by a+-- window of their own.+--+-- Two exclusions are deliberate:+--+-- * A receipt whose @toVersion@ does not parse is skipped rather than+-- failing the command. Receipts are data written by earlier runs, and one+-- malformed entry must not make the command unusable.+--+-- * A 'MigrationNotApplicable' receipt does not count. It records that+-- seihou considered an edge and this project did not need it, which says+-- nothing about how far the source has been carried. Counting it would+-- start the window above edges that were never applied and skip them+-- permanently.+highestMigratedVersion ::+ ArtifactOrigin ->+ ModuleName ->+ [AppliedBlueprintMigration] ->+ Maybe (Version, AppliedBlueprintMigration)+highestMigratedVersion origin name receipts =+ listToMaybe (sortOn (Down . fst) (mapMaybe reached receipts))+ where+ reached receipt+ | receipt ^. #outcome /= MigrationApplied = Nothing+ | not (sameArtifactIdentity (receipt ^. #origin) origin) = Nothing+ | receipt ^. #name /= name = Nothing+ | otherwise = (,receipt) <$> parseVersion (receipt ^. #toVersion)++-- | Decide each end of the window from what the user supplied and what seihou+-- could infer.+--+-- Precedence is per end and independent: an explicit flag always wins, and+-- either end may be inferred while the other is typed.+--+-- The two ends deliberately draw on different sources. @--to@ takes the probe,+-- which reads how far the /dependency/ has been bumped in this project;+-- @--from@ takes the receipt ledger, which records how far the /source/ has+-- been migrated. Swapping them would break the workflow this exists for: the+-- normal sequence is to bump the dependency and then migrate the source up to+-- it, so at the moment the command runs the lockfile already names the target.+--+-- Running the probe is the caller's job, and its result arrives here already+-- parsed. That keeps this pure, and lets the caller skip the subprocess+-- entirely when @--to@ was given.+resolveMigrationWindow ::+ -- | @--from@, already parsed+ Maybe Version ->+ -- | @--to@, already parsed+ Maybe Version ->+ -- | the probe's version and the command that produced it+ Maybe (Version, Text) ->+ -- | the highest applied receipt, from 'highestMigratedVersion'+ Maybe (Version, AppliedBlueprintMigration) ->+ Either WindowResolutionError ResolvedWindow+resolveMigrationWindow fromFlag toFlag probed recorded = do+ (target, targetSource) <- case (toFlag, probed) of+ (Just version, _) -> Right (version, VersionFromFlag)+ (Nothing, Just (version, command)) -> Right (version, VersionFromProbe command)+ (Nothing, Nothing) -> Left NoTargetVersion+ (start, startSource) <- case (fromFlag, recorded) of+ (Just version, _) -> Right (version, VersionFromFlag)+ (Nothing, Just (version, receipt)) -> Right (version, VersionFromReceipt receipt)+ (Nothing, Nothing) -> Left NoStartVersion+ pure+ ResolvedWindow+ { fromVersion = start,+ fromSource = startSource,+ toVersion = target,+ toSource = targetSource+ }++-- | Read a probe's captured stdout as a version.+--+-- The rule is the /last non-empty line/, trimmed, rather than the whole of+-- stdout: a probe like @nix eval@ prints progress before its answer, and+-- requiring authors to silence every tool's chatter would make probes+-- fragile. Authors need to know this rule, so it is documented in+-- docs\/user\/blueprints.md as well as here.+readVersionProbeOutput :: Text -> VersionProbeResult+readVersionProbeOutput raw =+ case lastNonEmptyLine of+ Just line | Just version <- parseVersion line -> ProbeVersion version+ _ -> ProbeOutputUnparseable raw+ where+ lastNonEmptyLine =+ listToMaybe (reverse (filter (not . T.null) (map T.strip (T.lines raw))))++-- | Run a blueprint's declared version probe in the project directory.+--+-- Executed through @sh -c@, exactly as a module's @RunCommand@ operation and a+-- command-derived variable are, so an author writes the same kind of shell+-- string everywhere. This function has no timeout of its own; the caller+-- bounds it, because a bound belongs where the real clock is.+runVersionProbe ::+ (Process :> es) =>+ -- | the declared command+ Text ->+ -- | the project directory to run it in+ FilePath ->+ Eff es VersionProbeResult+runVersionProbe command projectRoot = do+ (exitCode, stdoutText, stderrText) <- runProcess "sh" ["-c", command] (Just projectRoot)+ pure $ case exitCode of+ ExitSuccess -> readVersionProbeOutput stdoutText+ ExitFailure code -> ProbeExitedNonZero code stderrText++-- | Report the resolved window and where each end came from.+--+-- Returns no lines at all when the user typed both flags and did not ask for+-- verbose output: they already know what they typed, and existing invocations+-- should keep printing exactly what they printed before. An /inferred/ end is+-- always reported, verbose or not — a window silently off by one release runs+-- the wrong agent sessions against the user's source, which is worth two lines.+formatResolvedWindow :: Bool -> ResolvedWindow -> [Text]+formatResolvedWindow verbose window+ | null provenance = []+ | otherwise = header : provenance+ where+ header =+ "Version window: "+ <> renderVersion (window ^. #fromVersion)+ <> " -> "+ <> renderVersion (window ^. #toVersion)++ provenance =+ end "--from" (window ^. #fromVersion) (window ^. #fromSource)+ <> end "--to " (window ^. #toVersion) (window ^. #toSource)++ end flag version source =+ [ " " <> flag <> " " <> renderVersion version <> " " <> renderSource source+ | verbose || source /= VersionFromFlag+ ]++ renderSource = \case+ VersionFromFlag -> "[flag]"+ VersionFromProbe command -> "[probe: " <> command <> "]"+ VersionFromReceipt receipt ->+ "[receipt: "+ <> receipt ^. #name . #unModuleName+ <> " "+ <> receipt ^. #fromVersion+ <> " -> "+ <> receipt ^. #toVersion+ <> ", applied "+ <> T.pack (formatTime defaultTimeLocale "%Y-%m-%d" (receipt ^. #appliedAt))+ <> "]"++-- | Explain a probe that did not produce a version.+--+-- The blueprint's author wrote the command and the consumer is the one holding+-- the failure, so the message shows enough to forward upstream — and says+-- plainly that the run can continue with an explicit flag.+formatProbeFailure :: Text -> VersionProbeResult -> Maybe Text+formatProbeFailure command = \case+ ProbeVersion _ -> Nothing+ ProbeExitedNonZero code stderrText ->+ Just $+ "The blueprint's version probe failed, so --to could not be inferred.\n"+ <> " probe: "+ <> command+ <> "\n exit: "+ <> T.pack (show code)+ <> diagnostic "stderr" stderrText+ ProbeOutputUnparseable raw ->+ Just $+ "The blueprint's version probe printed no dotted numeric version, so --to could not be inferred.\n"+ <> " probe: "+ <> command+ <> diagnostic "output" raw+ where+ -- Both labels are six characters, so one space after the colon lines+ -- their values up under `probe:` and `exit:` above them.+ diagnostic label text+ | T.null trimmed = ""+ | otherwise = "\n " <> label <> ": " <> T.replace "\n" "\n " trimmed+ where+ trimmed = T.strip text++-- | Turn an unresolvable window into the sentence the user has to act on.+--+-- The missing-start case is the first-run case and will be much the commoner+-- of the two, so it explains rather than complains: seihou has no record of+-- this project's migration history, which is a fact about the project and not+-- a mistake by the person typing.+formatWindowResolutionError :: ModuleName -> WindowResolutionError -> Text+formatWindowResolutionError blueprintName = \case+ NoTargetVersion ->+ "Cannot determine the target version for '"+ <> name+ <> "'.\n\n"+ <> " Pass --to VERSION, or ask the blueprint's author to declare a versionProbe\n"+ <> " so seihou can read the version this project depends on."+ NoStartVersion ->+ "Cannot determine the starting version for '"+ <> name+ <> "'.\n\n"+ <> " This project has no recorded migration for that blueprint, so seihou does\n"+ <> " not know how far its source has already been migrated.\n\n"+ <> " Pass --from VERSION."+ where+ name = blueprintName ^. #unModuleName
@@ -4,8 +4,18 @@ OriginMeta (..), readOriginInfo, + -- * Install collisions+ InstallCollision (..),+ InstallOutcome (..),+ classifyInstallCollision,+ formatInstallRefusal,+ formatInstallOverride,+ summarizeInstallRefusal,+ -- * Install primitives installModuleDir,+ installModuleDirInto,+ installedRoot, cloneRepo, copyDirectoryRecursive, )@@ -17,12 +27,11 @@ import Data.ByteString.Lazy qualified as LBS import Data.Generics.Labels () import Data.Text qualified as T+import Data.Text.IO qualified as TIO import Data.Time (getCurrentTime) import Data.Time.Format.ISO8601 (iso8601Show)-import Seihou.CLI.Shared (logIO)+import Seihou.Core.ArtifactIdentity (normalizeOriginUrl) import Seihou.Core.ArtifactOriginDetect (OriginInfo (..), readOriginInfo)-import Seihou.Core.Types (LogLevel (..))-import Seihou.Effect.Logger (logWarn) import Seihou.Prelude import System.Directory ( XdgDirectory (..),@@ -70,29 +79,202 @@ ] -- ----------------------------------------------------------------------------+-- Install collisions+-- ----------------------------------------------------------------------------++-- | What the install cache already holds at the name being installed into.+--+-- The cache at @~\/.config\/seihou\/installed\/@ is keyed by the artifact's+-- bare name across every repository the user has ever installed from, and it+-- is machine-global: every project on the machine resolves artifact names+-- through it. Replacing an entry is therefore either the most routine thing+-- seihou does — reinstalling the same artifact to pick up a new version — or+-- one of the most destructive, and the two are told apart only by the+-- provenance recorded in @.seihou-origin.json@ beside the installed copy.+data InstallCollision+ = -- | Nothing is installed under this name.+ NoExistingInstall+ | -- | An artifact from the same source URL is installed. This is the+ -- ordinary upgrade path. Carries the recorded version, if any.+ SameSource !(Maybe Text)+ | -- | An artifact from a different source URL is installed. Carries the+ -- recorded source URL.+ DifferentSource !Text+ | -- | Something is installed but carries no readable provenance, so seihou+ -- cannot tell whether replacing it is safe.+ UnknownSource+ deriving stock (Eq, Show, Generic)++-- | Whether an install ran or was refused.+--+-- 'installModuleDir' returns this rather than throwing because it has ten+-- call sites across four commands and each wants to react differently: a+-- single-artifact install exits, a registry batch collects and reports at the+-- end, and the three commands that reinstall from an artifact's own recorded+-- origin treat a refusal as evidence that the cache and that record disagree.+data InstallOutcome+ = InstallPerformed+ | InstallRefused !InstallCollision+ deriving stock (Eq, Show, Generic)++-- | Classify what is already installed at @installDir@ against the source URL+-- an install is about to write there.+--+-- URLs are compared through 'normalizeOriginUrl', so a user who typed+-- @https:\/\/host\/repo.git@ last week and @https:\/\/host\/repo@ today is not+-- told they have a different artifact. That is the same normalisation the+-- manifest guard and the migration receipt ledger use; sharing it is what+-- keeps a refusal here consistent with a mismatch reported there.+classifyInstallCollision :: FilePath -> Text -> IO InstallCollision+classifyInstallCollision installDir incomingUrl = do+ exists <- doesDirectoryExist installDir+ if not exists+ then pure NoExistingInstall+ else do+ recorded <- readOriginInfo installDir+ pure $ case recorded of+ Nothing -> UnknownSource+ Just info+ | normalizeOriginUrl (info ^. #sourceUrl) == normalizeOriginUrl incomingUrl ->+ SameSource (info ^. #version)+ | otherwise -> DifferentSource (info ^. #sourceUrl)++-- | The refusal message, in the shape+-- 'Seihou.CLI.ManifestGuard.formatGuardRefusal' established, so one class of+-- problem reads with one vocabulary. Pure, so it can be tested without a+-- filesystem.+formatInstallRefusal :: String -> Text -> InstallCollision -> Text+formatInstallRefusal name incomingUrl = \case+ DifferentSource recordedUrl ->+ T.intercalate+ "\n"+ [ "✗ Refusing to install '" <> T.pack name <> "': a different artifact",+ " is already installed under that name.",+ "",+ " Installed on this machine: " <> recordedUrl,+ " Incoming: " <> incomingUrl,+ "",+ " These are different artifacts that happen to share a name. Installing",+ " would replace the first for every project on this machine.",+ "",+ " To replace it anyway, re-run with --force."+ ]+ UnknownSource ->+ T.intercalate+ "\n"+ [ "✗ Refusing to install '" <> T.pack name <> "': something is already",+ " installed under that name and records no provenance.",+ "",+ " Installed on this machine: (no .seihou-origin.json)",+ " Incoming: " <> incomingUrl,+ "",+ " Seihou cannot tell whether these are the same artifact, and replacing",+ " it would affect every project on this machine that resolved the name.",+ "",+ " To replace it anyway, re-run with --force."+ ]+ NoExistingInstall -> ""+ SameSource _ -> ""++-- | A one-line reason, for callers that report inside a table or a per-entry+-- status rather than as a standalone block — the shape+-- 'Seihou.CLI.ManifestGuard.summarizeCheck' uses for the same reason.+summarizeInstallRefusal :: Text -> InstallCollision -> Text+summarizeInstallRefusal incomingUrl = \case+ DifferentSource recordedUrl ->+ "refused: the installed copy records " <> recordedUrl <> ", not " <> incomingUrl+ UnknownSource ->+ "refused: the installed copy records no provenance, so it cannot be matched against "+ <> incomingUrl+ NoExistingInstall -> ""+ SameSource _ -> ""++-- | The same news printed when @--force@ was passed. A deliberate override+-- should still be visible in the terminal, exactly as+-- 'Seihou.CLI.ManifestGuard.formatGuardOverride' keeps @--allow-downgrade@+-- visible; silently honouring the flag would hide the change this refusal+-- exists to make legible.+formatInstallOverride :: String -> Text -> InstallCollision -> Text+formatInstallOverride name incomingUrl = \case+ DifferentSource recordedUrl ->+ T.intercalate+ "\n"+ [ "! Replacing '" <> T.pack name <> "' with an artifact from a different",+ " source (--force).",+ "",+ " Was installed from: " <> recordedUrl,+ " Now installed from: " <> incomingUrl+ ]+ UnknownSource ->+ T.intercalate+ "\n"+ [ "! Replacing '" <> T.pack name <> "', which records no provenance, with",+ " " <> incomingUrl <> " (--force)."+ ]+ NoExistingInstall -> ""+ SameSource _ -> ""++-- ---------------------------------------------------------------------------- -- Install primitives -- ---------------------------------------------------------------------------- --- | Copy a module directory to @~/.config/seihou/installed/<name>@,--- replacing any existing installation, and write origin metadata. The--- source directory must already contain the module's files; this--- function does not clone or fetch.-installModuleDir :: FilePath -> String -> Text -> Maybe Text -> Maybe Text -> [Text] -> IO ()-installModuleDir moduleDir name source registryName moduleVersion moduleTags = do+-- | The machine-global install cache, @~\/.config\/seihou\/installed@.+installedRoot :: IO FilePath+installedRoot = do xdgConfig <- getXdgDirectory XdgConfig "seihou"- let installDir = xdgConfig </> "installed" </> name+ pure (xdgConfig </> "installed") - exists <- doesDirectoryExist installDir- when exists $ do- logIO LogNormal (logWarn $ "overwriting existing installation of '" <> T.pack name <> "'")- removeDirectoryRecursive installDir+-- | Copy an artifact directory to @~\/.config\/seihou\/installed\/<name>@ and+-- write its origin metadata. The source directory must already contain the+-- artifact's files; this function does not clone or fetch.+--+-- An existing installation from the same source URL is replaced without+-- comment — that is the ordinary upgrade path, and the calling command+-- already reports what it installed. One from a different source, or one with+-- no readable provenance, is refused with 'InstallRefused' and the cache is+-- left byte-identical, unless @force@ is 'True', in which case the override is+-- printed and the install proceeds.+installModuleDir :: Bool -> FilePath -> String -> Text -> Maybe Text -> Maybe Text -> [Text] -> IO InstallOutcome+installModuleDir force moduleDir name source registryName moduleVersion moduleTags = do+ root <- installedRoot+ installModuleDirInto root force moduleDir name source registryName moduleVersion moduleTags - createDirectoryIfMissing True installDir- copyDirectoryRecursive moduleDir installDir+-- | 'installModuleDir' against an explicit cache root.+--+-- Every command wants the XDG-derived root, so they call 'installModuleDir'.+-- This variant exists so tests can install into a temporary directory without+-- redirecting @XDG_CONFIG_HOME@, which is process-global and therefore unsafe+-- to mutate in a test suite that runs specs concurrently.+installModuleDirInto ::+ FilePath -> Bool -> FilePath -> String -> Text -> Maybe Text -> Maybe Text -> [Text] -> IO InstallOutcome+installModuleDirInto root force moduleDir name source registryName moduleVersion moduleTags = do+ let installDir = root </> name - now <- getCurrentTime- let origin = OriginMeta source registryName (T.pack (iso8601Show now)) moduleVersion moduleTags- LBS.writeFile (installDir </> ".seihou-origin.json") (encodePretty origin)+ collision <- classifyInstallCollision installDir source+ let blocked = case collision of+ DifferentSource _ -> True+ UnknownSource -> True+ NoExistingInstall -> False+ SameSource _ -> False++ if blocked && not force+ then pure (InstallRefused collision)+ else do+ -- Nothing is removed until the collision has been accepted, so a+ -- refusal leaves the cache exactly as it was.+ when blocked $+ TIO.putStrLn (formatInstallOverride name source collision)++ exists <- doesDirectoryExist installDir+ when exists $ removeDirectoryRecursive installDir++ createDirectoryIfMissing True installDir+ copyDirectoryRecursive moduleDir installDir++ now <- getCurrentTime+ let origin = OriginMeta source registryName (T.pack (iso8601Show now)) moduleVersion moduleTags+ LBS.writeFile (installDir </> ".seihou-origin.json") (encodePretty origin)+ pure InstallPerformed -- | Recursively copy a directory tree, excluding the @.git@ directory. copyDirectoryRecursive :: FilePath -> FilePath -> IO ()
src/Seihou/CLI/ManifestGuard.hs view
@@ -24,8 +24,13 @@ -- * Checking a manifest against this machine checkAppliedArtifacts, checkAppliedArtifactsFor,+ checkAppliedBlueprint,+ checkRecordedBlueprint, blockingChecks, + -- * Enforcing+ enforceArtifactGuard,+ -- * Rendering formatGuardRefusal, formatGuardOverride,@@ -34,10 +39,13 @@ where import Data.Generics.Labels ()-import Data.List (nubBy)+import Data.List (maximumBy, nubBy) import Data.Maybe (fromMaybe)+import Data.Ord (comparing) import Data.Set qualified as Set import Data.Text qualified as T+import Data.Text.IO qualified as TIO+import Seihou.Core.ArtifactIdentity (normalizeOriginUrl, normalizeProjectPath) import Seihou.Core.ArtifactOriginDetect (detectArtifactOrigin) import Seihou.Core.ArtifactRef ( ArtifactRefError,@@ -45,15 +53,19 @@ resolveArtifactOrigin, ) import Seihou.Core.Types- ( AppliedModule (..),+ ( AppliedBlueprint (..),+ AppliedBlueprintMigration (..),+ AppliedModule (..), ArtifactOrigin (..),+ Blueprint (..), Manifest (..), Module (..), ModuleName (..), ) import Seihou.Core.Version (parseVersion)-import Seihou.Dhall.Eval (evalModuleFromFile)+import Seihou.Dhall.Eval (evalBlueprintFromFile, evalModuleFromFile) import Seihou.Prelude+import System.Exit (exitFailure) -- ---------------------------------------------------------------------------- -- Verdicts@@ -163,32 +175,6 @@ (ProjectOrigin {}, _) -> OriginDiffers (LocalOrigin {}, _) -> OriginUnverifiable --- | Reduce a git URL to a form two spellings of the same repository share.------ @https:\/\/host\/repo@, @https:\/\/host\/repo.git@ and--- @https:\/\/host\/repo\/@ all name the same repository, and a manifest--- written by a developer who typed one of them must not read as a different--- module to a developer who typed another.-normalizeOriginUrl :: Text -> Text-normalizeOriginUrl =- dropTrailingSlashes . dropGitSuffix . dropTrailingSlashes . T.strip- where- dropTrailingSlashes = T.dropWhileEnd (== '/')- dropGitSuffix url = fromMaybe url (T.stripSuffix ".git" url)---- | Reduce a project-relative path to a comparable form. The manifest stores--- these with forward slashes; @.\/@ prefixes and trailing slashes are noise.-normalizeProjectPath :: FilePath -> FilePath-normalizeProjectPath =- dropWhileEnd' (== '/') . dropDotPrefix . dropWhileEnd' (== '/')- where- dropDotPrefix path = fromMaybe path (stripPrefix' "./" path)- stripPrefix' prefix path =- if take (length prefix) path == prefix- then Just (drop (length prefix) path)- else Nothing- dropWhileEnd' p = reverse . dropWhile p . reverse- -- ---------------------------------------------------------------------------- -- Checking a manifest against this machine -- ----------------------------------------------------------------------------@@ -232,22 +218,120 @@ dedupeByName = nubBy (\a b -> a ^. #name == b ^. #name) - checkOne applied = do- let recordedOrigin = applied ^. #origin- resolved <- resolveArtifactOrigin projectRoot searchPaths "module.dhall" recordedOrigin- verdict <- case resolved of- Left refErr -> pure (ArtifactUnresolvable refErr)- Right directory -> do- localOrigin <- detectArtifactOrigin projectRoot directory- localVersion <- localModuleVersion directory- pure (judgeArtifact recordedOrigin (applied ^. #moduleVersion) localOrigin localVersion)- pure- ArtifactCheck- { name = applied ^. #name,- origin = recordedOrigin,- verdict = verdict- }+ checkOne applied =+ checkRecordedArtifact+ projectRoot+ searchPaths+ "module.dhall"+ localModuleVersion+ (applied ^. #name)+ (applied ^. #origin)+ (applied ^. #moduleVersion) +-- | Check the blueprint the manifest records, if any, against this machine.+--+-- 'Nothing' means no @seihou agent run@ has been recorded in this project.+--+-- This is the reporting form: it checks whatever blueprint the manifest+-- happens to record, which is what @seihou status@ wants. A command about to+-- *use* a blueprint wants 'checkRecordedBlueprint', which is scoped to that+-- one blueprint.+checkAppliedBlueprint :: FilePath -> [FilePath] -> Manifest -> IO (Maybe ArtifactCheck)+checkAppliedBlueprint projectRoot searchPaths manifest =+ traverse checkOne (manifest ^. #blueprint)+ where+ checkOne applied =+ checkBlueprintIdentity+ projectRoot+ searchPaths+ (applied ^. #name)+ (applied ^. #origin)+ (applied ^. #blueprintVersion)++-- | Check one named blueprint — the one a command is about to use — against+-- what this project already records about it.+--+-- A project records a blueprint's identity in two independent places, and+-- either is enough. @seihou agent run@ writes the applied-blueprint entry;+-- @seihou agent migrate@ writes one receipt per completed edge and never+-- touches that entry, so a project may well have migrated a blueprint it+-- never ran. The applied-blueprint entry wins when both exist, because it is+-- rewritten on every run and is therefore the more recent statement; among+-- receipts the most recently applied one wins for the same reason.+--+-- 'Nothing' means this project records nothing about this blueprint, so there+-- is nothing to compare and the caller proceeds. A record naming a+-- *different* blueprint is deliberately ignored: docs\/adr\/0003 scopes each+-- refusal to the artifacts the command is actually about to use, so an+-- unrelated stale artifact must not block unrelated work.+checkRecordedBlueprint ::+ FilePath ->+ [FilePath] ->+ ModuleName ->+ Manifest ->+ IO (Maybe ArtifactCheck)+checkRecordedBlueprint projectRoot searchPaths blueprintName manifest =+ traverse checkOne recorded+ where+ checkOne (recordedOrigin, recordedVersion) =+ checkBlueprintIdentity projectRoot searchPaths blueprintName recordedOrigin recordedVersion++ recorded = case appliedEntry of+ Just entry -> Just (entry ^. #origin, entry ^. #blueprintVersion)+ Nothing -> latestReceipt++ appliedEntry = case manifest ^. #blueprint of+ Just entry | entry ^. #name == blueprintName -> Just entry+ _ -> Nothing++ latestReceipt =+ case filter (\receipt -> receipt ^. #name == blueprintName) (manifest ^. #blueprintMigrations) of+ [] -> Nothing+ receipts ->+ let newest = maximumBy (comparing (^. #appliedAt)) receipts+ in Just (newest ^. #origin, newest ^. #blueprintVersion)++-- | One recorded blueprint identity, checked against the copy installed here.+checkBlueprintIdentity ::+ FilePath ->+ [FilePath] ->+ ModuleName ->+ ArtifactOrigin ->+ Maybe Text ->+ IO ArtifactCheck+checkBlueprintIdentity projectRoot searchPaths =+ checkRecordedArtifact projectRoot searchPaths "blueprint.dhall" localBlueprintVersion++-- | Locate one recorded artifact on this machine and judge it.+--+-- Shared by every caller so there is one verdict vocabulary regardless of+-- what kind of artifact is being checked. Only two things vary: the file that+-- makes a directory count as this kind of artifact (@module.dhall@ versus+-- @blueprint.dhall@), and how the local copy's version is read out of it.+checkRecordedArtifact ::+ FilePath ->+ [FilePath] ->+ FilePath ->+ (FilePath -> IO (Maybe Text)) ->+ ModuleName ->+ ArtifactOrigin ->+ Maybe Text ->+ IO ArtifactCheck+checkRecordedArtifact projectRoot searchPaths definitionFile readLocalVersion name recordedOrigin recordedVersion = do+ resolved <- resolveArtifactOrigin projectRoot searchPaths definitionFile recordedOrigin+ verdict <- case resolved of+ Left refErr -> pure (ArtifactUnresolvable refErr)+ Right directory -> do+ localOrigin <- detectArtifactOrigin projectRoot directory+ localVersion <- readLocalVersion directory+ pure (judgeArtifact recordedOrigin recordedVersion localOrigin localVersion)+ pure+ ArtifactCheck+ { name = name,+ origin = recordedOrigin,+ verdict = verdict+ }+ -- | The version the locally installed @module.dhall@ declares. -- -- A module that does not evaluate yields 'Nothing', which becomes@@ -261,6 +345,15 @@ Left _ -> Nothing Right modul -> modul ^. #version +-- | The version the locally installed @blueprint.dhall@ declares, on the same+-- terms as 'localModuleVersion'.+localBlueprintVersion :: FilePath -> IO (Maybe Text)+localBlueprintVersion directory = do+ result <- evalBlueprintFromFile (directory </> "blueprint.dhall")+ pure $ case result of+ Left _ -> Nothing+ Right blueprint -> blueprint ^. #version+ -- | Whether any verdict is severe enough to stop the command. -- -- 'ArtifactStale', 'ArtifactOriginMismatch' and 'ArtifactUnresolvable' block:@@ -279,6 +372,33 @@ ArtifactOk -> False ArtifactVersionIncomparable {} -> False ArtifactUnverifiableOrigin -> False++-- ----------------------------------------------------------------------------+-- Enforcing+-- ----------------------------------------------------------------------------++-- | Apply the downgrade / origin-mismatch policy to whatever 'blockingChecks'+-- kept.+--+-- The 'Bool' is the command's @--allow-downgrade@ flag. Every command that+-- generates from an artifact spells that flag the same way and behaves the+-- same way once it is set, so the policy lives here rather than being+-- reimplemented per command.+--+-- Without @--allow-downgrade@: the command refuses before a single file is+-- written, so the project and its manifest are left byte-identical.+--+-- With @--allow-downgrade@: the same blocks are printed under a "proceeding+-- anyway" lead-in and the command continues. They are printed rather than+-- suppressed on purpose — a deliberate downgrade is still a downgrade, and+-- the diff it produces should not be the first time anyone hears about it.+enforceArtifactGuard :: Bool -> [ArtifactCheck] -> IO ()+enforceArtifactGuard _ [] = pure ()+enforceArtifactGuard allowDowngrade blocking+ | allowDowngrade = TIO.putStr (formatGuardOverride blocking)+ | otherwise = do+ TIO.putStr (formatGuardRefusal blocking)+ exitFailure -- ---------------------------------------------------------------------------- -- Rendering
src/Seihou/CLI/Migrate.hs view
@@ -31,10 +31,12 @@ import Seihou.CLI.CommitMessage (generateCommitMessage) import Seihou.CLI.Git (gitAdd, gitCheckIgnore, gitCommit, gitDiffCached, isGitRepo) import Seihou.CLI.InstallShared- ( OriginInfo (..),+ ( InstallOutcome (..),+ OriginInfo (..), cloneRepo, installModuleDir, readOriginInfo,+ summarizeInstallRefusal, ) import Seihou.CLI.ManifestGuard ( ArtifactCheck,@@ -43,7 +45,7 @@ formatGuardOverride, formatGuardRefusal, )-import Seihou.CLI.Shared (resolveAppliedArtifactDir)+import Seihou.CLI.Shared (logIO, resolveAppliedArtifactDir) import Seihou.CLI.Style (bold, dim, green, red, useColor, yellow) import Seihou.Core.ArtifactRef (ArtifactRefError, renderArtifactRefError) import Seihou.Core.Migration@@ -62,6 +64,7 @@ ) import Seihou.Core.Types ( AppliedModule (..),+ LogLevel (..), Manifest (..), Module (..), ModuleName (..),@@ -69,6 +72,7 @@ import Seihou.Core.Version (Version, parseVersion, renderVersion) import Seihou.Dhall.Eval (evalModuleFromFile, evalRegistryFromFile) import Seihou.Effect.FilesystemInterp (runFilesystem)+import Seihou.Effect.Logger (logWarn) import Seihou.Effect.ManifestStore (readManifest, writeManifest) import Seihou.Effect.ManifestStoreInterp (runManifestStore) import Seihou.Effect.ProcessInterp (runProcessIO)@@ -497,13 +501,29 @@ Left _ -> pure () Right modul -> do let installedName = takeFileName installedDir- installModuleDir- moduleDir- installedName- (origin ^. #sourceUrl)- (origin ^. #repoName)- (modul ^. #version)- tags+ -- Pass force = False deliberately. The URL passed here was read out of+ -- the installed copy's own @.seihou-origin.json@ a moment ago, so this+ -- is structurally the same-source case and must never refuse. If it+ -- does, the cache disagrees with its own provenance file — real news,+ -- and reported rather than overridden. Do not "fix" it by passing True.+ outcome <-+ installModuleDir+ False+ moduleDir+ installedName+ (origin ^. #sourceUrl)+ (origin ^. #repoName)+ (modul ^. #version)+ tags+ case outcome of+ InstallPerformed -> pure ()+ InstallRefused collision ->+ logIO LogNormal . logWarn $+ "could not refresh the installed copy of '"+ <> T.pack installedName+ <> "': "+ <> summarizeInstallRefusal (origin ^. #sourceUrl) collision+ <> ". The migration was applied to this project; the shared cache still holds the older copy." -- ---------------------------------------------------------------------------- -- Pending-migration detection (used by status / upgrade)
+ src/Seihou/CLI/MigrationCohort.hs view
@@ -0,0 +1,178 @@+-- | Resolving the set of blueprints one @seihou agent migrate@ run needs.+--+-- A blueprint migration edge may declare that crossing it entails crossing an+-- exact edge of another blueprint — that is how a breaking change reaches+-- consumers who depend on the library that absorbed it rather than on the+-- library that shipped it. The set of blueprints reached that way is a+-- /cohort/. It is not an artifact and is recorded nowhere: it is recomputed+-- from declarations on every run, per+-- docs\/adr\/0004-the-manifest-is-the-only-record-of-applied-state.md.+--+-- This module is the filesystem half of that. It resolves blueprints by name+-- through the same search paths the command uses for the blueprint the user+-- typed, validates each one, and classifies each into a portable+-- 'ArtifactOrigin' so its receipts can be keyed by identity rather than by+-- name. The pure half — turning declarations into an ordered list of steps —+-- is 'Seihou.Core.Migration.expandEntailedEdges', which takes what this module+-- found as a lookup function.+module Seihou.CLI.MigrationCohort+ ( CohortBlueprint (..),+ CohortResolutionError (..),+ resolveCohortBlueprint,+ resolveMigrationCohort,+ )+where++import Data.Generics.Labels ()+import Data.Map.Strict qualified as Map+import Data.Set qualified as Set+import Seihou.Core.ArtifactOriginDetect (detectArtifactOrigin)+import Seihou.Core.Blueprint (validateBlueprint)+import Seihou.Core.Migration+ ( BlueprintMigration (..),+ BlueprintMigrationStep (..),+ EntailedEdge (..),+ )+import Seihou.Core.Module (discoverRunnable)+import Seihou.Core.Types+ ( ArtifactOrigin,+ Blueprint (..),+ ModuleLoadError (..),+ ModuleName (..),+ Runnable (..),+ )+import Seihou.Prelude++-- | One blueprint this run needs, with everything the run needs to know about+-- it: its declarations, where it lives on disk (so its @files\/@ directory can+-- be mounted for its own steps), and the portable identity its receipts are+-- keyed by.+data CohortBlueprint = CohortBlueprint+ { blueprint :: !Blueprint,+ blueprintDir :: !FilePath,+ origin :: !ArtifactOrigin+ }+ deriving stock (Generic)++-- | Why a named blueprint could not be turned into a 'CohortBlueprint'.+--+-- 'CohortArtifactMissing' is deliberately separate from the other two. A+-- blueprint that is simply not installed is reported by the /expander/, which+-- knows which edge named it and can therefore say what to install and why;+-- resolution just hands the absence back. The other two are genuine problems+-- with an artifact that /is/ present, and stop the command wherever they are+-- found.+data CohortResolutionError+ = -- | The name resolved to something other than a blueprint. Carries the+ -- name and the kind word for the message ("module", "recipe", "prompt").+ CohortArtifactWrongKind !ModuleName !Text+ | -- | Nothing of that name is installed. Carries the name and the+ -- directories searched.+ CohortArtifactMissing !ModuleName ![FilePath]+ | -- | Found, but it could not be evaluated, decoded, or validated.+ CohortArtifactUnusable !ModuleLoadError+ deriving stock (Eq, Show, Generic)++-- | Resolve one blueprint by name: discover it, refuse a same-named artifact+-- of another kind, validate it, and classify its directory into an origin.+--+-- @projectRoot@ is the working directory the command was invoked in; it is+-- what makes a local origin's recorded path relative to the project rather+-- than to the machine, per+-- docs\/adr\/0001-manifest-is-a-checked-in-machine-independent-artifact.md.+resolveCohortBlueprint ::+ -- | project root, for classifying a local blueprint's path+ FilePath ->+ -- | module search paths+ [FilePath] ->+ ModuleName ->+ IO (Either CohortResolutionError CohortBlueprint)+resolveCohortBlueprint projectRoot searchPaths requestedName = do+ runnableResult <- discoverRunnable searchPaths requestedName+ case runnableResult of+ Left (ModuleNotFound name searched) -> pure (Left (CohortArtifactMissing name searched))+ Left err -> pure (Left (CohortArtifactUnusable err))+ Right (RunnableModule _ _) -> pure (Left (CohortArtifactWrongKind requestedName "module"))+ Right (RunnableRecipe _ _) -> pure (Left (CohortArtifactWrongKind requestedName "recipe"))+ Right (RunnableAgentPrompt _ _) -> pure (Left (CohortArtifactWrongKind requestedName "prompt"))+ Right (RunnableBlueprint discovered dir) -> do+ validationResult <- validateBlueprint dir discovered+ case validationResult of+ Left err -> pure (Left (CohortArtifactUnusable err))+ Right validated -> do+ detected <- detectArtifactOrigin projectRoot dir+ pure $+ Right+ CohortBlueprint+ { blueprint = validated,+ blueprintDir = dir,+ origin = detected+ }++-- | Load every blueprint reachable by entailment from a planned window, on top+-- of the blueprints already loaded.+--+-- The walk follows /exact edges/ rather than whole blueprints: a reference+-- names one edge, so only that edge's own @entails@ list is followed onward.+-- Loading everything a newly discovered blueprint mentions anywhere would make+-- an unrelated, uninstalled member of some other chain fail a run that never+-- needed it.+--+-- Termination does not depend on the declarations being acyclic. Every+-- reference is expanded at most once, tracked by its @(blueprint, from, to)@+-- triple, so a cycle here simply stops; /reporting/ the cycle is+-- 'Seihou.Core.Migration.expandEntailedEdges''s job, which has the ordering+-- context to name it.+--+-- A blueprint that is not installed is left out of the returned map rather+-- than raised here, so the expander can report it against the edge that named+-- it.+resolveMigrationCohort ::+ -- | project root, for classifying a local blueprint's path+ FilePath ->+ -- | module search paths+ [FilePath] ->+ -- | blueprints already loaded, keyed by name (at least the invoked one)+ Map Text CohortBlueprint ->+ -- | the window-selected steps whose entailments to follow+ [BlueprintMigrationStep] ->+ IO (Either CohortResolutionError (Map Text CohortBlueprint))+resolveMigrationCohort projectRoot searchPaths initial steps =+ walk initial Set.empty (concatMap (\step -> step ^. #edge . #entails) steps)+ where+ walk loaded _seen [] = pure (Right loaded)+ walk loaded seen (reference : rest)+ | referenceKey reference `Set.member` seen = walk loaded seen rest+ | otherwise =+ case Map.lookup (reference ^. #blueprint) loaded of+ Just already -> walk loaded seen' (rest <> onward already reference)+ Nothing -> do+ result <-+ resolveCohortBlueprint+ projectRoot+ searchPaths+ (ModuleName (reference ^. #blueprint))+ case result of+ Left (CohortArtifactMissing _ _) -> walk loaded seen' rest+ Left err -> pure (Left err)+ Right resolved ->+ walk+ (Map.insert (reference ^. #blueprint) resolved loaded)+ seen'+ (rest <> onward resolved reference)+ where+ seen' = Set.insert (referenceKey reference) seen++ -- What the named edge itself entails. An empty result also covers the+ -- case where the blueprint declares no such edge at all, which the+ -- expander reports against the edge that named it.+ onward resolved reference =+ concat+ [ declared ^. #entails+ | declared <- resolved ^. #blueprint . #migrations,+ declared ^. #from == reference ^. #from,+ declared ^. #to == reference ^. #to+ ]++ referenceKey reference =+ (reference ^. #blueprint, reference ^. #from, reference ^. #to)
src/Seihou/CLI/SchemaVersion.hs view
@@ -9,11 +9,11 @@ -- | Raw URL for the seihou-schema package.dhall at a pinned commit schemaUrl :: Text-schemaUrl = "https://raw.githubusercontent.com/shinzui/seihou-schema/0e1b875efcf2b4e4b98d93595ea627290459e3ad/package.dhall"+schemaUrl = "https://raw.githubusercontent.com/shinzui/seihou-schema/49ff1e5b353b171b1b52946f478623ee4423ea93/package.dhall" -- | SHA256 integrity hash for the schema import schemaHash :: Text-schemaHash = "sha256:356829d4e2b333ce157615dd7eccd0cd4765f3ef0d94ef637fa8c97398d3b92c"+schemaHash = "sha256:cadacb688dd31ec39feb7f2fe599973a1ad58ef8fcc8ed1100bf3da22a1222cb" -- | Complete Dhall import line for use in generated modules schemaImportLine :: Text
src/Seihou/CLI/StatusRender.hs view
@@ -32,6 +32,7 @@ AppliedRecipe (..), AppliedTarget (..), Manifest (..),+ MigrationOutcome (..), ModuleName (..), ParentVars (..), RecipeName (..),@@ -135,9 +136,28 @@ <> receipt ^. #fromVersion <> " -> " <> receipt ^. #toVersion- <> " (applied "+ <> " ("+ <> renderOutcome (receipt ^. #outcome)+ <> " " <> T.pack (formatTime defaultTimeLocale "%Y-%m-%d %H:%M UTC" (receipt ^. #appliedAt))+ <> renderReason (receipt ^. #outcome) <> ")"++ renderOutcome MigrationApplied = "applied"+ renderOutcome (MigrationNotApplicable _) = "not applicable"++ -- `seihou status` is a scannable summary, so a long reason is truncated+ -- rather than wrapped; the manifest keeps the whole of it.+ renderReason MigrationApplied = ""+ renderReason (MigrationNotApplicable reason) = " -- " <> truncateReason reason++ truncateReason reason+ | T.length oneLine <= reasonWidth = oneLine+ | otherwise = T.take (reasonWidth - 1) oneLine <> "…"+ where+ oneLine = T.unwords (T.words reason)++ reasonWidth = 60 -- | Render the baseline body for the blueprint section. Three cases: -- @--no-baseline@ was passed, the blueprint declared no baseline at
src/Seihou/CLI/Update.hs view
@@ -19,7 +19,7 @@ ) where -import Control.Exception (SomeException, displayException, toException, try)+import Control.Exception (SomeException, displayException, throwIO, toException, try) import Control.Monad (foldM, forM, forM_, when) import Data.Foldable (traverse_) import Data.Generics.Labels ()@@ -32,7 +32,7 @@ import Data.Time (UTCTime, getCurrentTime) import Effectful (runEff) import Seihou.CLI.CommandExecution-import Seihou.CLI.InstallShared (installModuleDir)+import Seihou.CLI.InstallShared (InstallOutcome (..), installModuleDir, summarizeInstallRefusal) import Seihou.CLI.Shared (deriveNamespace, toVarNameMap) import Seihou.CLI.Update.Migrations import Seihou.CLI.Update.Recovery@@ -845,8 +845,17 @@ ] updatedRecipe = foldl' updateRecipe (filesManifest ^. #recipe) finalApplications+ -- The composition's targetOrigin is the recipe's own portable identity on+ -- this branch, because the target is the recipe. updateRecipe current application = case application ^. #target of- AppliedRecipeTarget name -> Just AppliedRecipe {name, recipeVersion = application ^. #targetVersion, appliedAt = now}+ AppliedRecipeTarget name ->+ Just+ AppliedRecipe+ { name,+ origin = application ^. #targetOrigin,+ recipeVersion = application ^. #targetVersion,+ appliedAt = now+ } AppliedModuleTarget _ -> current updateAppliedModules :: [AppliedModule] -> [AppliedComposition] -> [PlannedApplication] -> UTCTime -> [AppliedModule]@@ -950,14 +959,31 @@ result <- try @SomeException $ forM_ artifacts $ \artifact -> case artifact ^. #sourceUrl of Nothing -> pure ()- Just sourceUrl ->- installModuleDir- (artifact ^. #originalDirectory)- (T.unpack (artifact ^. #name))- sourceUrl- (artifact ^. #repoName)- (artifact ^. #version)- (artifact ^. #tags)+ Just sourceUrl -> do+ -- Pass force = False deliberately. Every candidate was fetched from+ -- the URL the manifest itself records for that artifact, so this is+ -- structurally the same-source case and must never refuse. A refusal+ -- means the shared cache holds a different artifact under this name,+ -- which would make the update publish over somebody else's+ -- installation — reported as a publication failure rather than+ -- overridden. Do not "fix" it by passing True.+ outcome <-+ installModuleDir+ False+ (artifact ^. #originalDirectory)+ (T.unpack (artifact ^. #name))+ sourceUrl+ (artifact ^. #repoName)+ (artifact ^. #version)+ (artifact ^. #tags)+ case outcome of+ InstallPerformed -> pure ()+ InstallRefused collision ->+ throwIO . userError . T.unpack $+ "publishing '"+ <> (artifact ^. #name)+ <> "' to the shared install cache was "+ <> summarizeInstallRefusal sourceUrl collision pure $ first (UpdateCachePublicationFailed . T.pack . displayException) result setCommitMarkers :: UpdateTransaction -> Manifest -> IO (Either UpdateError ())
test/Main.hs view
@@ -3,6 +3,7 @@ import Seihou.CLI.AgentCompletionSpec qualified as AgentCompletionSpec import Seihou.CLI.AgentConfigShowSpec qualified as AgentConfigShowSpec import Seihou.CLI.AgentConfigSpec qualified as AgentConfigSpec+import Seihou.CLI.AgentGuardE2ESpec qualified as AgentGuardE2ESpec import Seihou.CLI.AgentLaunchSpec qualified as AgentLaunchSpec import Seihou.CLI.AgentMigrateE2ESpec qualified as AgentMigrateE2ESpec import Seihou.CLI.AgentModelsSpec qualified as AgentModelsSpec@@ -18,6 +19,7 @@ import Seihou.CLI.ExtensionSpec qualified as ExtensionSpec import Seihou.CLI.GitSpec qualified as GitSpec import Seihou.CLI.InitSpec qualified as InitSpec+import Seihou.CLI.InstallCollisionSpec qualified as InstallCollisionSpec import Seihou.CLI.InstallHistorySpec qualified as InstallHistorySpec import Seihou.CLI.ListSpec qualified as ListSpec import Seihou.CLI.ManifestGuardSpec qualified as ManifestGuardSpec@@ -46,6 +48,7 @@ sequence [ AgentLaunchSpec.tests, AgentMigrateE2ESpec.tests,+ AgentGuardE2ESpec.tests, AgentCompletionSpec.tests, AgentConfigSpec.tests, AgentConfigShowSpec.tests,@@ -62,6 +65,7 @@ ExtensionSpec.tests, GitSpec.tests, InitSpec.tests,+ InstallCollisionSpec.tests, InstallHistorySpec.tests, ListSpec.tests, ManifestGuardSpec.tests,
+ test/Seihou/CLI/AgentGuardE2ESpec.hs view
@@ -0,0 +1,435 @@+-- | The agent path refuses a stale or substituted artifact, driven end to end+-- through the real binary.+--+-- @seihou run@ has refused since+-- docs\/adr\/0003-a-stale-or-substituted-artifact-is-a-hard-error.md was+-- accepted; @seihou agent run@ and @seihou agent migrate@ did not, even though+-- the first applies a blueprint's baseline modules to the working directory+-- and rewrites the manifest, and the second writes receipts that suppress+-- future runs of the edges they name. This spec is what stops that gap from+-- reopening.+--+-- Every case asserts the decisive property rather than the exit code alone:+-- an exit code proves the command reported failure, only an unchanged working+-- tree proves it did not write first.+module Seihou.CLI.AgentGuardE2ESpec (tests) where++import Control.Lens ((^.))+import Data.ByteString.Lazy qualified as LBS+import Data.Generics.Labels ()+import Data.Maybe (fromMaybe)+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.IO qualified as TIO+import GHC.Generics (Generic)+import Seihou.CLI.SeihouBinary (seihouBinary)+import Seihou.CLI.TwoDeveloperFixture (installModuleVersion, moduleSourceUrl)+import System.Directory+ ( createDirectoryIfMissing,+ doesFileExist,+ executable,+ getPermissions,+ setPermissions,+ )+import System.Environment (getEnvironment)+import System.Exit (ExitCode (..))+import System.FilePath (searchPathSeparator, (</>))+import System.IO.Temp (withSystemTempDirectory)+import System.Process (CreateProcess (..), callProcess, proc, readCreateProcessWithExitCode, readProcess)+import Test.Hspec+import Test.Tasty (TestTree)+import Test.Tasty.Hspec (testSpec)++tests :: IO TestTree+tests = testSpec "agent path artifact guard" spec++spec :: Spec+spec = do+ it "offers --allow-downgrade on both agent subcommands" $ do+ binary <- seihouBinary+ (runCode, runOut, _) <- runProcessText binary ["agent", "run", "--help"] Nothing Nothing+ runCode `shouldBe` ExitSuccess+ runOut `shouldSatisfy` T.isInfixOf "--allow-downgrade"+ (migrateCode, migrateOut, _) <- runProcessText binary ["agent", "migrate", "--help"] Nothing Nothing+ migrateCode `shouldBe` ExitSuccess+ migrateOut `shouldSatisfy` T.isInfixOf "--allow-downgrade"++ it "refuses agent run when the installed blueprint is older than the manifest records" $+ withStaleBlueprint $ \fixture -> do+ before <- LBS.readFile (fixture ^. #manifestPath)+ (code, out, err) <- runSeihou fixture ["agent", "run", "upgrade-helper"]+ code `shouldSatisfy` (/= ExitSuccess)+ let reported = out <> err+ reported `shouldSatisfy` T.isInfixOf "2.0.0"+ reported `shouldSatisfy` T.isInfixOf "1.0.0"+ reported `shouldSatisfy` T.isInfixOf "seihou upgrade upgrade-helper"++ -- The decisive assertions: nothing was generated, no provenance was+ -- recorded, and the provider was never contacted.+ gitStatus fixture `shouldReturn` ""+ LBS.readFile (fixture ^. #manifestPath) `shouldReturn` before+ doesFileExist (fixture ^. #launchLog) `shouldReturn` False++ it "proceeds under --allow-downgrade and prints what it overrode" $+ withStaleBlueprint $ \fixture -> do+ (code, out, err) <- runSeihou fixture ["agent", "run", "upgrade-helper", "--allow-downgrade"]+ expectSuccess "the deliberate downgrade" code out err++ -- A deliberate downgrade must still be visible; silently honouring the+ -- flag would hide exactly the change the guard exists to make legible.+ let reported = out <> err+ reported `shouldSatisfy` T.isInfixOf "Proceeding anyway (--allow-downgrade)"+ reported `shouldSatisfy` T.isInfixOf "2.0.0"+ reported `shouldSatisfy` T.isInfixOf "1.0.0"+ reported `shouldSatisfy` T.isInfixOf "agent complete"++ -- Having proceeded, it pins the project to what is installed here.+ manifest <- TIO.readFile (fixture ^. #manifestPath)+ manifest `shouldSatisfy` T.isInfixOf "\"version\":\"1.0.0\""++ it "refuses agent run when a baseline module is stale though the blueprint is current" $+ withStaleBaselineModule $ \fixture -> do+ before <- LBS.readFile (fixture ^. #manifestPath)+ (code, out, err) <- runSeihou fixture ["agent", "run", "upgrade-helper"]+ code `shouldSatisfy` (/= ExitSuccess)+ let reported = out <> err+ -- The blueprint itself is current, so the refusal must name the module.+ reported `shouldSatisfy` T.isInfixOf "'demo'"+ reported `shouldSatisfy` T.isInfixOf "2.0.0"+ reported `shouldSatisfy` T.isInfixOf "1.4.0"++ gitStatus fixture `shouldReturn` ""+ LBS.readFile (fixture ^. #manifestPath) `shouldReturn` before++ it "refuses agent migrate when the installed blueprint came from another repository" $+ withSubstitutedBlueprint $ \fixture -> do+ before <- LBS.readFile (fixture ^. #manifestPath)+ (code, out, err) <-+ runSeihou fixture ["agent", "migrate", "payments", "--from", "1.0.0", "--to", "2.0.0"]+ code `shouldSatisfy` (/= ExitSuccess)+ let reported = out <> err+ reported `shouldSatisfy` T.isInfixOf "different source"+ reported `shouldSatisfy` T.isInfixOf recordedBlueprintUrl+ reported `shouldSatisfy` T.isInfixOf substitutedBlueprintUrl++ -- The point of checking before planning: without the guard this command+ -- would have launched a provider session carrying the wrong+ -- repository's migration prompt and written a receipt for it.+ doesFileExist (fixture ^. #launchLog) `shouldReturn` False+ LBS.readFile (fixture ^. #manifestPath) `shouldReturn` before+ gitStatus fixture `shouldReturn` ""++ it "checks nothing under agent --debug migrate, which writes nothing" $+ withSubstitutedBlueprint $ \fixture -> do+ before <- LBS.readFile (fixture ^. #manifestPath)+ (code, out, err) <-+ runSeihou+ fixture+ ["agent", "--debug", "migrate", "payments", "--from", "1.0.0", "--to", "2.0.0"]+ expectSuccess "the debug migration" code out err+ out `shouldSatisfy` T.isInfixOf "Blueprint migrations for payments: 1.0.0 -> 2.0.0"++ LBS.readFile (fixture ^. #manifestPath) `shouldReturn` before+ doesFileExist (fixture ^. #launchLog) `shouldReturn` False+ gitStatus fixture `shouldReturn` ""++ it "still checks under agent --debug run, which is not a dry run" $+ withStaleBlueprint $ \fixture -> do+ before <- LBS.readFile (fixture ^. #manifestPath)+ (code, out, err) <- runSeihou fixture ["agent", "--debug", "run", "upgrade-helper"]+ code `shouldSatisfy` (/= ExitSuccess)+ (out <> err) `shouldSatisfy` T.isInfixOf "seihou upgrade upgrade-helper"++ -- Without the check this run would still have applied the baseline and+ -- rewritten the manifest to name the older blueprint: --debug skips the+ -- provider call on this path, not the writes.+ LBS.readFile (fixture ^. #manifestPath) `shouldReturn` before+ gitStatus fixture `shouldReturn` ""++-- ----------------------------------------------------------------------------+-- Scenarios+-- ----------------------------------------------------------------------------++-- | The manifest records @upgrade-helper@ at 2.0.0; 1.0.0 is installed here.+-- This is the downgrade ADR 0003 opens with, on the blueprint path.+withStaleBlueprint :: (GuardFixture -> IO ()) -> IO ()+withStaleBlueprint = withGuardFixture "seihou-agent-guard-stale" $ \fixture -> do+ installBlueprint+ fixture+ "upgrade-helper"+ recordedBlueprintUrl+ (blueprintDhall "upgrade-helper" "1.0.0" noBaseModules oneMigration)+ TIO.writeFile+ (fixture ^. #manifestPath)+ (manifestJson [] (Just (appliedBlueprintJson "upgrade-helper" recordedBlueprintUrl "2.0.0")) [])++-- | The blueprint matches what the manifest records, but a module it applies+-- as its baseline does not. Those modules generate ordinary files, and a+-- blueprint run is the one path on which they are applied without the+-- @seihou run@ guard.+withStaleBaselineModule :: (GuardFixture -> IO ()) -> IO ()+withStaleBaselineModule = withGuardFixture "seihou-agent-guard-baseline" $ \fixture -> do+ installBlueprint+ fixture+ "upgrade-helper"+ recordedBlueprintUrl+ (blueprintDhall "upgrade-helper" "2.0.0" demoBaseModule oneMigration)+ installModuleVersion (fixture ^. #home) "demo" "1.4.0"+ TIO.writeFile+ (fixture ^. #manifestPath)+ ( manifestJson+ [appliedModuleJson "demo" moduleSourceUrl "2.0.0"]+ (Just (appliedBlueprintJson "upgrade-helper" recordedBlueprintUrl "2.0.0"))+ []+ )++-- | A blueprint of the recorded name is installed, from a different+-- repository. Its edges are not this project's edges.+withSubstitutedBlueprint :: (GuardFixture -> IO ()) -> IO ()+withSubstitutedBlueprint = withGuardFixture "seihou-agent-guard-substituted" $ \fixture -> do+ installBlueprint+ fixture+ "payments"+ substitutedBlueprintUrl+ (blueprintDhall "payments" "4.2.0" noBaseModules oneMigration)+ -- Receipts only, and no applied-blueprint entry: this project has migrated+ -- the blueprint but never run it, which is the shape 'agent migrate' alone+ -- produces.+ TIO.writeFile+ (fixture ^. #manifestPath)+ (manifestJson [] Nothing [migrationReceiptJson "payments" recordedBlueprintUrl "4.2.0"])++-- ----------------------------------------------------------------------------+-- Fixture+-- ----------------------------------------------------------------------------++-- | A scratch project with its own configuration root and a fake provider.+--+-- @home@ becomes @XDG_CONFIG_HOME@, so @\<home\>\/seihou\/installed\/@ is the+-- only place artifacts are found and a test can never reach the developer's+-- own @~\/.config\/seihou\/@. @launchLog@ exists only once the fake provider+-- has actually been called, which is how a test proves nothing was launched.+data GuardFixture = GuardFixture+ { projectRoot :: !FilePath,+ manifestPath :: !FilePath,+ home :: !FilePath,+ launchLog :: !FilePath,+ binary :: !FilePath,+ environment :: ![(String, String)]+ }+ deriving stock (Eq, Show, Generic)++-- | Build the fixture, run @setup@ against it, commit everything, then run the+-- scenario. Committing after setup is what makes @git status --porcelain@ a+-- meaningful assertion: anything it reports afterwards was written by the+-- command under test.+withGuardFixture :: String -> (GuardFixture -> IO ()) -> (GuardFixture -> IO ()) -> IO ()+withGuardFixture label setup action =+ withSystemTempDirectory label $ \root -> do+ binary <- seihouBinary+ let projectRoot = root </> "project"+ home = root </> "home"+ fakeBin = root </> "bin"+ fakeClaude = fakeBin </> "claude"+ launchLog = root </> "agent-launch.args"+ createDirectoryIfMissing True (projectRoot </> ".seihou")+ createDirectoryIfMissing True home+ createDirectoryIfMissing True fakeBin++ -- The batch path parses one JSON line out of the provider's stdout, so the+ -- fake has to print one. Touching the log is what records that it ran.+ TIO.writeFile+ fakeClaude+ "#!/bin/sh\nprintf '%s\\n' \"$@\" > \"$SEIHOU_FAKE_AGENT_LOG\"\nprintf '%s\\n' '{\"result\":\"agent complete\",\"is_error\":false,\"session_id\":\"fake\"}'\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.+ setPermissions fakeClaude (permissions {executable = True})++ inherited <- getEnvironment+ let inheritedPath = fromMaybe "" (lookup "PATH" inherited)+ overriddenNames =+ [ "PATH",+ "XDG_CONFIG_HOME",+ "SEIHOU_AGENT_PROVIDER",+ "SEIHOU_AGENT_MODEL",+ "SEIHOU_AGENT_EFFORT",+ "SEIHOU_CONTEXT",+ "SEIHOU_FAKE_AGENT_LOG"+ ]+ environment =+ ("PATH", fakeBin <> [searchPathSeparator] <> inheritedPath)+ : ("XDG_CONFIG_HOME", home)+ : ("SEIHOU_AGENT_PROVIDER", "claude-cli")+ : ("SEIHOU_FAKE_AGENT_LOG", launchLog)+ : filter (\(key, _) -> key `notElem` overriddenNames) inherited+ fixture =+ GuardFixture+ { projectRoot = projectRoot,+ manifestPath = projectRoot </> ".seihou" </> "manifest.json",+ home = home,+ launchLog = launchLog,+ binary = binary,+ environment = environment+ }++ setup fixture++ callProcess "git" ["-C", projectRoot, "init", "-q"]+ callProcess "git" ["-C", projectRoot, "config", "user.name", "Seihou Test"]+ callProcess "git" ["-C", projectRoot, "config", "user.email", "test@example.com"]+ callProcess "git" ["-C", projectRoot, "add", "-A"]+ callProcess "git" ["-C", projectRoot, "commit", "-qm", "test: seed the guarded project"]++ action fixture++-- | Run the real binary inside the fixture's project.+runSeihou :: GuardFixture -> [String] -> IO (ExitCode, Text, Text)+runSeihou fixture args =+ runProcessText+ (fixture ^. #binary)+ args+ (Just (fixture ^. #projectRoot))+ (Just (fixture ^. #environment))++runProcessText ::+ FilePath ->+ [String] ->+ Maybe FilePath ->+ Maybe [(String, String)] ->+ IO (ExitCode, Text, Text)+runProcessText binary args workingDirectory environment = do+ let command = (proc binary args) {cwd = workingDirectory, env = environment}+ (exitCode, stdoutText, stderrText) <- readCreateProcessWithExitCode command ""+ pure (exitCode, T.pack stdoutText, T.pack stderrText)++-- | @git status --porcelain@ in the project. Empty means nothing was written.+gitStatus :: GuardFixture -> IO Text+gitStatus fixture =+ T.strip . T.pack <$> readProcess "git" ["-C", fixture ^. #projectRoot, "status", "--porcelain"] ""++expectSuccess :: String -> ExitCode -> Text -> Text -> Expectation+expectSuccess label code out err = case code of+ ExitSuccess -> pure ()+ ExitFailure status ->+ expectationFailure+ ( label+ <> " exited "+ <> show status+ <> "\nstdout:\n"+ <> T.unpack out+ <> "\nstderr:\n"+ <> T.unpack err+ )++-- ----------------------------------------------------------------------------+-- Artifacts and manifests+-- ----------------------------------------------------------------------------++-- | The repository the project's manifest says its blueprint came from.+recordedBlueprintUrl :: Text+recordedBlueprintUrl = "https://example.com/cohort-blueprints.git"++-- | A different repository publishing a blueprint of the same name. Nothing is+-- ever fetched from either; the URLs exist so the two copies are recognisably+-- different artifacts.+substitutedBlueprintUrl :: Text+substitutedBlueprintUrl = "https://example.com/somebody-elses-blueprints.git"++-- | Install a blueprint into the fixture's configuration root, as+-- @seihou install@ would: the directory, its @blueprint.dhall@, and the+-- @.seihou-origin.json@ recording where it came from.+installBlueprint :: GuardFixture -> Text -> Text -> Text -> IO ()+installBlueprint fixture name sourceUrl dhall = do+ let installed = (fixture ^. #home) </> "seihou" </> "installed" </> T.unpack name+ createDirectoryIfMissing True installed+ TIO.writeFile (installed </> "blueprint.dhall") dhall+ TIO.writeFile+ (installed </> ".seihou-origin.json")+ ( "{\"sourceUrl\":\""+ <> sourceUrl+ <> "\",\"repoName\":\"cohort\",\"installedAt\":\"2026-07-01T00:00:00Z\",\"tags\":[]}"+ )++blueprintDhall :: Text -> Text -> Text -> Text -> Text+blueprintDhall name version baseModules migrations =+ T.unlines+ [ "{ name = \"" <> name <> "\"",+ ", version = Some \"" <> version <> "\"",+ ", description = Some \"Guarded blueprint fixture\"",+ ", prompt = \"Upgrade this project.\"",+ ", vars = [] : List { name : Text, type : Text, default : Optional Text, description : Optional Text, required : Bool, validation : Optional Text }",+ ", prompts = [] : List { var : Text, text : Text, when : Optional Text, choices : Optional (List Text) }",+ ", baseModules = " <> baseModules,+ ", files = [] : List { src : Text, description : Optional Text }",+ ", allowedTools = None (List Text)",+ ", tags = [] : List Text",+ ", migrations = " <> migrations,+ "}"+ ]++noBaseModules :: Text+noBaseModules = "[] : List { module : Text, vars : List { name : Text, value : Text } }"++demoBaseModule :: Text+demoBaseModule = "[ { module = \"demo\", vars = [] : List { name : Text, value : Text } } ]"++oneMigration :: Text+oneMigration = "[ { from = \"1.0.0\", to = \"2.0.0\", prompt = \"Cross the cohort edge.\" } ]"++-- | A schema-6 manifest carrying exactly the records a scenario needs.+manifestJson :: [Text] -> Maybe Text -> [Text] -> Text+manifestJson modules blueprint receipts =+ T.concat+ [ "{\"version\":6",+ ",\"generatedAt\":\"2026-07-01T12:00:00Z\"",+ ",\"modules\":[",+ T.intercalate "," modules,+ "],\"variables\":{},\"files\":{},\"applications\":[]",+ maybe "" (\entry -> ",\"blueprint\":" <> entry) blueprint,+ ",\"blueprintMigrations\":[",+ T.intercalate "," receipts,+ "]}"+ ]++appliedBlueprintJson :: Text -> Text -> Text -> Text+appliedBlueprintJson name url version =+ T.concat+ [ "{\"name\":\"",+ name,+ "\",\"origin\":",+ remoteOriginJson url name,+ ",\"version\":\"",+ version,+ "\",\"appliedAt\":\"2026-07-01T12:00:00Z\"",+ ",\"baselineModules\":[],\"noBaseline\":false}"+ ]++appliedModuleJson :: Text -> Text -> Text -> Text+appliedModuleJson name url version =+ T.concat+ [ "{\"name\":\"",+ name,+ "\",\"origin\":",+ remoteOriginJson url name,+ ",\"version\":\"",+ version,+ "\",\"appliedAt\":\"2026-07-01T12:00:00Z\"}"+ ]++migrationReceiptJson :: Text -> Text -> Text -> Text+migrationReceiptJson name url version =+ T.concat+ [ "{\"name\":\"",+ name,+ "\",\"origin\":",+ remoteOriginJson url name,+ ",\"version\":\"",+ version,+ "\",\"from\":\"0.9.0\",\"to\":\"1.0.0\"",+ ",\"appliedAt\":\"2026-07-01T12:00:00Z\"}"+ ]++remoteOriginJson :: Text -> Text -> Text+remoteOriginJson url artifact =+ "{\"kind\":\"remote\",\"url\":\"" <> url <> "\",\"artifact\":\"" <> artifact <> "\"}"
test/Seihou/CLI/AgentLaunchSpec.hs view
@@ -153,7 +153,8 @@ allowedTools = Nothing, tags = [], migrations = [],- launch = Nothing+ launch = Nothing,+ versionProbe = Nothing } it "renders name, version, description as a three-line block" $ formatBlueprintIdentity (mk (Just "0.1") (Just "a thing"))
test/Seihou/CLI/AgentMigrateE2ESpec.hs view
@@ -1,19 +1,25 @@ module Seihou.CLI.AgentMigrateE2ESpec (tests) where -import Control.Lens ((^.))+import Control.Lens (to, (^.)) import Data.ByteString.Lazy qualified as LBS import Data.Generics.Labels () import Data.Maybe (fromMaybe) import Data.Text qualified as T import Data.Text.IO qualified as TIO import Seihou.CLI.SeihouBinary (seihouBinary)-import Seihou.Core.Types (AppliedBlueprintMigration (..), Manifest (..))+import Seihou.Core.Types+ ( AppliedBlueprintMigration (..),+ Manifest (..),+ MigrationOutcome (..),+ ModuleName (..),+ ) import Seihou.Manifest.Types (manifestFromJSON) import System.Directory ( createDirectoryIfMissing, doesFileExist, executable, getPermissions,+ removeDirectoryRecursive, setPermissions, ) import System.Environment (getEnvironment)@@ -129,11 +135,11 @@ launchArgs `shouldSatisfy` elem "--effort" launchArgs `shouldSatisfy` elem "max" - it "exposes the required version window and rerun option in help" $ do+ it "exposes an optional version window and the rerun option 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 "Usage: seihou agent migrate BLUEPRINT [--from VERSION] [--to VERSION] [PROMPT]" output `shouldSatisfy` T.isInfixOf "--rerun" output `shouldNotSatisfy` T.isInfixOf "--no-baseline" output `shouldNotSatisfy` T.isInfixOf "--force"@@ -181,8 +187,8 @@ <> "\nstderr:\n" <> T.unpack errorOutput output `shouldSatisfy` T.isInfixOf "Blueprint migrations for payments: 1.0.0 -> 3.0.0"- output `shouldSatisfy` T.isInfixOf "===== [1/2] 1.0.0 -> 2.0.0 ====="- output `shouldSatisfy` T.isInfixOf "===== [2/2] 2.5.0 -> 3.0.0 ====="+ output `shouldSatisfy` T.isInfixOf "===== [1/2] payments 1.0.0 -> 2.0.0 ====="+ output `shouldSatisfy` T.isInfixOf "===== [2/2] payments 2.5.0 -> 3.0.0 =====" output `shouldSatisfy` T.isInfixOf "Shared upgrade guidance for baikai." output `shouldSatisfy` T.isInfixOf "Replace baikai legacy calls." let (_, afterFirst) = T.breakOn "1.0.0 -> 2.0.0" output@@ -252,6 +258,500 @@ resumeOutput `shouldSatisfy` T.isInfixOf "already have receipts" T.lines <$> TIO.readFile launchLog `shouldReturn` ["called", "called"] LBS.readFile manifestPath `shouldReturn` beforeResume++ -- The IR-1 scenario end to end: an edge whose precondition is unmet writes+ -- the signal file, the chain continues past it, and the edge runs again once+ -- the signal is no longer written -- without --rerun, which is the whole+ -- point. Before this outcome existed the first edge was skipped forever.+ it "continues past a not-applicable edge and replans it on the next invocation" $+ withSystemTempDirectory "seihou-agent-migrate-not-applicable" $ \root -> do+ binary <- seihouBinary+ let blueprintDir = root </> ".seihou" </> "modules" </> "payments"+ blueprintPath = blueprintDir </> "blueprint.dhall"+ manifestPath = root </> ".seihou" </> "manifest.json"+ signalPath = root </> ".seihou" </> ".migrate-signal"+ xdgHome = root </> "xdg"+ fakeBin = root </> "bin"+ fakeClaude = fakeBin </> "claude"+ launchLog = root </> "agent-launches.log"+ reason = "no docs/adr directory in this project"+ createDirectoryIfMissing True blueprintDir+ createDirectoryIfMissing True xdgHome+ createDirectoryIfMissing True fakeBin+ TIO.writeFile blueprintPath migrationBlueprintDhall+ -- Signals inapplicability on its very first launch only, so the same+ -- edge applies for real when it is replanned.+ TIO.writeFile+ fakeClaude+ "#!/bin/sh\nprintf 'called\\n' >> \"$SEIHOU_FAKE_AGENT_LOG\"\nif [ \"$(wc -l < \"$SEIHOU_FAKE_AGENT_LOG\" | tr -d ' ')\" = \"1\" ]; then\n printf '%s\\n' \"$SEIHOU_FAKE_SIGNAL_REASON\" > \"$SEIHOU_FAKE_SIGNAL_FILE\"\nfi\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.+ setPermissions fakeClaude (permissions {executable = True})++ inherited <- getEnvironment+ let inheritedPath = fromMaybe "" (lookup "PATH" inherited)+ overriddenNames =+ [ "PATH",+ "XDG_CONFIG_HOME",+ "SEIHOU_AGENT_PROVIDER",+ "SEIHOU_AGENT_MODEL",+ "SEIHOU_CONTEXT",+ "SEIHOU_FAKE_AGENT_LOG",+ "SEIHOU_FAKE_SIGNAL_FILE",+ "SEIHOU_FAKE_SIGNAL_REASON"+ ]+ environment =+ ("PATH", fakeBin <> [searchPathSeparator] <> inheritedPath)+ : ("XDG_CONFIG_HOME", xdgHome)+ : ("SEIHOU_AGENT_PROVIDER", "claude-cli")+ : ("SEIHOU_FAKE_AGENT_LOG", launchLog)+ : ("SEIHOU_FAKE_SIGNAL_FILE", signalPath)+ : ("SEIHOU_FAKE_SIGNAL_REASON", T.unpack reason)+ : filter (\(key, _) -> key `notElem` overriddenNames) inherited+ args =+ [ "agent",+ "migrate",+ "payments",+ "--from",+ "1.0.0",+ "--to",+ "3.0.0",+ "--var",+ "library.name=baikai"+ ]++ (firstExit, firstOutput, firstError) <- runProcessText binary args (Just root) (Just environment)+ expectSuccess "not-applicable migration" firstExit firstOutput firstError+ firstOutput `shouldSatisfy` T.isInfixOf ("not applicable: " <> reason)+ firstOutput `shouldSatisfy` T.isInfixOf "Completed 2 blueprint migration(s) for 'payments' (1 not applicable)."+ -- Both edges launched: an inapplicable edge does not halt the chain.+ T.lines <$> TIO.readFile launchLog `shouldReturn` ["called", "called"]+ -- The signal is transient state, consumed by the run that read it.+ doesFileExist signalPath `shouldReturn` False++ afterFirst <- readReceipts manifestPath+ afterFirst+ `shouldBe` [ ("1.0.0", "2.0.0", MigrationNotApplicable reason),+ ("2.5.0", "3.0.0", MigrationApplied)+ ]++ -- No --rerun. The not-applicable edge is pending again; the applied one+ -- is not.+ (resumeExit, resumeOutput, resumeError) <- runProcessText binary args (Just root) (Just environment)+ expectSuccess "replanned migration" resumeExit resumeOutput resumeError+ resumeOutput `shouldSatisfy` T.isInfixOf "Running blueprint migration 1/1: payments 1.0.0 -> 2.0.0"+ resumeOutput `shouldNotSatisfy` T.isInfixOf "2.5.0 -> 3.0.0"+ resumeOutput `shouldNotSatisfy` T.isInfixOf "not applicable"+ T.lines <$> TIO.readFile launchLog `shouldReturn` ["called", "called", "called"]++ -- The replanned edge replaces its own receipt rather than adding one.+ afterResume <- readReceipts manifestPath+ afterResume+ `shouldBe` [ ("1.0.0", "2.0.0", MigrationApplied),+ ("2.5.0", "3.0.0", MigrationApplied)+ ]++ (settledExit, settledOutput, settledError) <- runProcessText binary args (Just root) (Just environment)+ expectSuccess "settled migration" settledExit settledOutput settledError+ settledOutput `shouldSatisfy` T.isInfixOf "already have receipts"+ T.lines <$> TIO.readFile launchLog `shouldReturn` ["called", "called", "called"]++ -- The cohort story end to end. A keiro edge entails a kiroku edge; one+ -- command plans both, in order, each carrying its own blueprint's reference+ -- files. --debug is the ideal surface: it exercises discovery, expansion, and+ -- per-blueprint preparation while contacting no provider and writing nothing.+ it "expands an entailed edge into the chain with its own blueprint's context" $+ withCohortProject $ \root run -> do+ (exitCode, output, errorOutput) <-+ run ["agent", "--debug", "migrate", "keiro-upgrade", "--from", "2.4.0", "--to", "3.0.0"]+ expectSuccess "cohort debug migration" exitCode output errorOutput+ output `shouldSatisfy` T.isInfixOf "Blueprint migrations for keiro-upgrade: 2.4.0 -> 3.0.0"+ output+ `shouldSatisfy` T.isInfixOf+ "===== [1/2] kiroku-upgrade 1.9.0 -> 2.0.0 (entailed by keiro-upgrade 2.4.0 -> 3.0.0) ====="+ output `shouldSatisfy` T.isInfixOf "===== [2/2] keiro-upgrade 2.4.0 -> 3.0.0 ====="++ -- The entailed edge comes first, which is the ordering rule.+ let (beforeKiroku, fromKiroku) = T.breakOn "kiroku-upgrade 1.9.0 -> 2.0.0" output+ (_, fromKeiro) = T.breakOn "===== [2/2]" fromKiroku+ beforeKiroku `shouldSatisfy` (not . T.isInfixOf "===== [2/2]")+ fromKeiro `shouldNotBe` ""++ -- Each step got its own blueprint's shared prompt, edge prompt, and+ -- reference-file listing. The marker files are the proof that `files/`+ -- was read from the owning blueprint's directory, not the invoked one's.+ let kirokuStep = T.take (T.length fromKiroku - T.length fromKeiro) fromKiroku+ kirokuStep `shouldSatisfy` T.isInfixOf "Shared kiroku guidance."+ kirokuStep `shouldSatisfy` T.isInfixOf "Drop the removed kiroku API."+ kirokuStep `shouldSatisfy` T.isInfixOf "kiroku-marker.md"+ kirokuStep `shouldNotSatisfy` T.isInfixOf "keiro-marker.md"+ kirokuStep+ `shouldSatisfy` T.isInfixOf "It is required by keiro-upgrade 2.4.0 -> 3.0.0"+ fromKeiro `shouldSatisfy` T.isInfixOf "Shared keiro guidance."+ fromKeiro `shouldSatisfy` T.isInfixOf "keiro-marker.md"+ fromKeiro `shouldNotSatisfy` T.isInfixOf "kiroku-marker.md"++ doesFileExist (root </> ".seihou" </> "manifest.json") `shouldReturn` False++ -- The decisive property. A project that crossed the shared kiroku edge by+ -- running keiro-upgrade does not cross it again by running kiroku-upgrade,+ -- because the receipt was written under kiroku-upgrade's own identity.+ it "crosses a shared cohort edge once regardless of entry point" $+ withCohortProject $ \root run -> do+ (exitCode, output, errorOutput) <-+ run ["agent", "migrate", "keiro-upgrade", "--from", "2.4.0", "--to", "3.0.0"]+ expectSuccess "cohort migration" exitCode output errorOutput+ output `shouldSatisfy` T.isInfixOf "Running blueprint migration 1/2: kiroku-upgrade 1.9.0 -> 2.0.0"+ output `shouldSatisfy` T.isInfixOf "Running blueprint migration 2/2: keiro-upgrade 2.4.0 -> 3.0.0"++ -- The kiroku receipt is filed under kiroku-upgrade, not keiro-upgrade.+ bytes <- LBS.readFile (root </> ".seihou" </> "manifest.json")+ manifest <- case manifestFromJSON bytes of+ Left err -> expectationFailure err >> fail "unreachable"+ Right decoded -> pure decoded+ [ (receipt ^. #name . #unModuleName, receipt ^. #fromVersion, receipt ^. #toVersion)+ | receipt <- manifest ^. #blueprintMigrations+ ]+ `shouldBe` [ ("kiroku-upgrade", "1.9.0", "2.0.0"),+ ("keiro-upgrade", "2.4.0", "3.0.0")+ ]++ -- Running the entailed blueprint directly finds that receipt.+ (kirokuExit, kirokuOutput, kirokuError) <-+ run ["agent", "migrate", "kiroku-upgrade", "--from", "1.9.0", "--to", "2.0.0"]+ expectSuccess "direct kiroku migration" kirokuExit kirokuOutput kirokuError+ kirokuOutput `shouldSatisfy` T.isInfixOf "already have receipts"++ -- Skipping an uninstalled cohort member would leave a half-migrated project+ -- with no signal, because the consumer never named that library.+ it "refuses when an entailed blueprint is not installed" $+ withCohortProject $ \root run -> do+ removeDirectoryRecursive (root </> ".seihou" </> "modules" </> "kiroku-upgrade")+ (exitCode, output, errorOutput) <-+ run ["agent", "--debug", "migrate", "keiro-upgrade", "--from", "2.4.0", "--to", "3.0.0"]+ exitCode `shouldSatisfy` (/= ExitSuccess)+ let streams = output <> errorOutput+ streams+ `shouldSatisfy` T.isInfixOf+ "'keiro-upgrade' edge 2.4.0 -> 3.0.0 entails blueprint 'kiroku-upgrade', which is not installed"+ streams `shouldSatisfy` T.isInfixOf "seihou install <url> --module kiroku-upgrade"++ -- Entailment names one exact edge; the likeliest authoring mistake is an+ -- off-by-one in a version string, so the real list is printed.+ it "refuses when the entailed blueprint declares no such edge, listing what it does" $+ withCohortProject $ \root run -> do+ TIO.writeFile+ (root </> ".seihou" </> "modules" </> "kiroku-upgrade" </> "blueprint.dhall")+ (kirokuBlueprintDhall "1.8.0")+ (exitCode, output, errorOutput) <-+ run ["agent", "--debug", "migrate", "keiro-upgrade", "--from", "2.4.0", "--to", "3.0.0"]+ exitCode `shouldSatisfy` (/= ExitSuccess)+ let streams = output <> errorOutput+ streams+ `shouldSatisfy` T.isInfixOf+ "'keiro-upgrade' edge 2.4.0 -> 3.0.0 entails edge 1.9.0 -> 2.0.0 of 'kiroku-upgrade', which declares no such edge"+ streams `shouldSatisfy` T.isInfixOf "Declared edges of 'kiroku-upgrade': 1.8.0 -> 2.0.0"++ -- A consumer of the entailed library alone is untouched by the existence of+ -- the blueprint that entails it.+ it "leaves a direct consumer of the entailed blueprint alone" $+ withCohortProject $ \_ run -> do+ (exitCode, output, errorOutput) <-+ run ["agent", "--debug", "migrate", "kiroku-upgrade", "--from", "1.9.0", "--to", "2.0.0"]+ expectSuccess "direct kiroku debug migration" exitCode output errorOutput+ output `shouldSatisfy` T.isInfixOf "===== [1/1] kiroku-upgrade 1.9.0 -> 2.0.0 ====="+ output `shouldNotSatisfy` T.isInfixOf "keiro"++ -- The point of the whole plan: the command a user types is `seihou agent+ -- migrate my-library`, and it does the right thing. The probe reads a file+ -- so the test can move the "installed version" around, exactly as bumping a+ -- lockfile would.+ it "infers --to from the probe and --from from the receipt ledger" $+ withProbeProject $ \root run -> do+ TIO.writeFile (root </> ".library-version") "2.0.0\n"++ -- First run: --from is typed because nothing has been recorded yet, and+ -- --to comes from the probe. Only the inferred end is reported.+ (firstExit, firstOutput, firstError) <-+ run ["agent", "migrate", "probe-upgrade", "--from", "1.0.0"]+ expectSuccess "probe-inferred target" firstExit firstOutput firstError+ firstOutput `shouldSatisfy` T.isInfixOf "Version window: 1.0.0 -> 2.0.0"+ firstOutput `shouldSatisfy` T.isInfixOf "--to 2.0.0 [probe: cat .library-version]"+ firstOutput `shouldNotSatisfy` T.isInfixOf "--from 1.0.0"+ firstOutput `shouldSatisfy` T.isInfixOf "Running blueprint migration 1/1: probe-upgrade 1.0.0 -> 2.0.0"++ -- Bump the dependency and run with no flags at all. The window starts+ -- where the last run finished and ends where the project now points.+ TIO.writeFile (root </> ".library-version") "3.0.0\n"+ (secondExit, secondOutput, secondError) <-+ run ["agent", "--debug", "migrate", "probe-upgrade"]+ expectSuccess "fully inferred window" secondExit secondOutput secondError+ secondOutput `shouldSatisfy` T.isInfixOf "Version window: 2.0.0 -> 3.0.0"+ secondOutput+ `shouldSatisfy` T.isInfixOf "--from 2.0.0 [receipt: probe-upgrade 1.0.0 -> 2.0.0, applied "+ secondOutput `shouldSatisfy` T.isInfixOf "--to 3.0.0 [probe: cat .library-version]"+ secondOutput `shouldSatisfy` T.isInfixOf "===== [1/1] probe-upgrade 2.0.0 -> 3.0.0 ====="++ -- Explicit flags win over both sources, and a run that names them keeps+ -- printing exactly what it printed before this feature existed.+ it "lets explicit flags override the probe and the ledger silently" $+ withProbeProject $ \root run -> do+ TIO.writeFile (root </> ".library-version") "2.0.0\n"+ (exitCode, output, errorOutput) <-+ run ["agent", "--debug", "migrate", "probe-upgrade", "--from", "1.0.0", "--to", "3.0.0"]+ expectSuccess "explicit window" exitCode output errorOutput+ output `shouldNotSatisfy` T.isInfixOf "Version window:"+ output `shouldSatisfy` T.isInfixOf "===== [1/2] probe-upgrade 1.0.0 -> 2.0.0 ====="+ output `shouldSatisfy` T.isInfixOf "===== [2/2] probe-upgrade 2.0.0 -> 3.0.0 ====="++ -- --verbose is where a user who typed both flags can still see them+ -- accounted for.+ (verboseExit, verboseOutput, verboseError) <-+ run ["agent", "--debug", "migrate", "probe-upgrade", "--from", "1.0.0", "--to", "3.0.0", "--verbose"]+ expectSuccess "explicit window, verbose" verboseExit verboseOutput verboseError+ verboseOutput `shouldSatisfy` T.isInfixOf "--from 1.0.0 [flag]"+ verboseOutput `shouldSatisfy` T.isInfixOf "--to 3.0.0 [flag]"++ -- A broken probe is the author's mistake and the consumer's problem, so it+ -- degrades to requiring --to rather than failing a command the user can+ -- still complete by hand.+ it "degrades to requiring --to when the probe fails" $+ withProbeProject $ \_ run -> do+ (exitCode, output, errorOutput) <-+ run ["agent", "--debug", "migrate", "probe-upgrade", "--from", "1.0.0"]+ exitCode `shouldSatisfy` (/= ExitSuccess)+ let streams = output <> errorOutput+ streams `shouldSatisfy` T.isInfixOf "version probe failed"+ streams `shouldSatisfy` T.isInfixOf "probe: cat .library-version"+ streams `shouldSatisfy` T.isInfixOf "No such file"+ streams `shouldSatisfy` T.isInfixOf "Cannot determine the target version for 'probe-upgrade'."+ streams `shouldSatisfy` T.isInfixOf "Pass --to VERSION"++ -- The escape hatch works despite the broken probe.+ (withFlag, flagOutput, flagError) <-+ run ["agent", "--debug", "migrate", "probe-upgrade", "--from", "1.0.0", "--to", "2.0.0"]+ expectSuccess "explicit target despite broken probe" withFlag flagOutput flagError+ flagOutput `shouldSatisfy` T.isInfixOf "===== [1/1] probe-upgrade 1.0.0 -> 2.0.0 ====="++ -- The first-run case, which will be the commonest failure by far. It has to+ -- read as an explanation of what seihou cannot know.+ it "explains a missing start version when nothing has been recorded" $+ withProbeProject $ \root run -> do+ TIO.writeFile (root </> ".library-version") "3.0.0\n"+ (exitCode, output, errorOutput) <- run ["agent", "--debug", "migrate", "probe-upgrade"]+ exitCode `shouldSatisfy` (/= ExitSuccess)+ let streams = output <> errorOutput+ streams `shouldSatisfy` T.isInfixOf "Cannot determine the starting version for 'probe-upgrade'."+ streams `shouldSatisfy` T.isInfixOf "no recorded migration for that blueprint"+ streams `shouldSatisfy` T.isInfixOf "Pass --from VERSION."++ -- Blueprints published before versionProbe existed must be unaffected: both+ -- flags still work, and omitting --to gives the actionable refusal rather+ -- than a decoding failure.+ it "leaves a blueprint without a probe working exactly as before" $+ withSystemTempDirectory "seihou-agent-migrate-noprobe" $ \root -> do+ binary <- seihouBinary+ let blueprintDir = root </> ".seihou" </> "modules" </> "payments"+ xdgHome = root </> "xdg"+ createDirectoryIfMissing True blueprintDir+ createDirectoryIfMissing True xdgHome+ TIO.writeFile (blueprintDir </> "blueprint.dhall") migrationBlueprintDhall+ inherited <- getEnvironment+ let overriddenNames = ["XDG_CONFIG_HOME", "SEIHOU_AGENT_PROVIDER", "SEIHOU_AGENT_MODEL", "SEIHOU_CONTEXT"]+ environment =+ ("XDG_CONFIG_HOME", xdgHome)+ : ("SEIHOU_AGENT_PROVIDER", "claude-cli")+ : filter (\(key, _) -> key `notElem` overriddenNames) inherited+ run args = runProcessText binary args (Just root) (Just environment)++ (exitCode, output, errorOutput) <-+ run ["agent", "--debug", "migrate", "payments", "--from", "1.0.0", "--to", "3.0.0", "--var", "library.name=baikai"]+ expectSuccess "probe-less blueprint" exitCode output errorOutput+ output `shouldSatisfy` T.isInfixOf "Blueprint migrations for payments: 1.0.0 -> 3.0.0"+ output `shouldNotSatisfy` T.isInfixOf "Version window:"++ (bareExit, bareOutput, bareError) <-+ run ["agent", "--debug", "migrate", "payments", "--from", "1.0.0", "--var", "library.name=baikai"]+ bareExit `shouldSatisfy` (/= ExitSuccess)+ (bareOutput <> bareError) `shouldSatisfy` T.isInfixOf "Cannot determine the target version for 'payments'."++-- | 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+-- the broken-probe case needs no extra setup.+withProbeProject ::+ (FilePath -> ([String] -> IO (ExitCode, T.Text, T.Text)) -> IO a) ->+ IO a+withProbeProject action =+ withSystemTempDirectory "seihou-agent-migrate-probe" $ \root -> do+ binary <- seihouBinary+ let blueprintDir = root </> ".seihou" </> "modules" </> "probe-upgrade"+ xdgHome = root </> "xdg"+ fakeBin = root </> "bin"+ fakeClaude = fakeBin </> "claude"+ createDirectoryIfMissing True blueprintDir+ createDirectoryIfMissing True xdgHome+ createDirectoryIfMissing True fakeBin+ TIO.writeFile (blueprintDir </> "blueprint.dhall") probeBlueprintDhall+ TIO.writeFile fakeClaude "#!/bin/sh\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.+ setPermissions fakeClaude (permissions {executable = True})++ inherited <- getEnvironment+ let inheritedPath = fromMaybe "" (lookup "PATH" inherited)+ overriddenNames =+ [ "PATH",+ "XDG_CONFIG_HOME",+ "SEIHOU_AGENT_PROVIDER",+ "SEIHOU_AGENT_MODEL",+ "SEIHOU_AGENT_EFFORT",+ "SEIHOU_CONTEXT"+ ]+ environment =+ ("PATH", fakeBin <> [searchPathSeparator] <> inheritedPath)+ : ("XDG_CONFIG_HOME", xdgHome)+ : ("SEIHOU_AGENT_PROVIDER", "claude-cli")+ : filter (\(key, _) -> key `notElem` overriddenNames) inherited+ run args = runProcessText binary args (Just root) (Just environment)+ action root run++-- | A blueprint declaring two consecutive edges and a file-backed version+-- probe, so a test can move the "installed version" the way bumping a+-- lockfile would.+probeBlueprintDhall :: T.Text+probeBlueprintDhall =+ T.unlines+ [ "{ name = \"probe-upgrade\"",+ ", version = Some \"3.0.0\"",+ ", description = Some \"probe fixture\"",+ ", prompt = \"Shared probe guidance.\"",+ ", vars = [] : List { name : Text, type : Text, default : Optional Text, description : Optional Text, required : Bool, validation : Optional Text }",+ ", prompts = [] : List { var : Text, text : Text, when : Optional Text, choices : Optional (List Text) }",+ ", baseModules = [] : List { module : Text, vars : List { name : Text, value : Text } }",+ ", files = [] : List { src : Text, description : Optional Text }",+ ", allowedTools = None (List Text)",+ ", tags = [] : List Text",+ ", migrations =",+ " [ { from = \"1.0.0\", to = \"2.0.0\", prompt = \"First probe edge.\" }",+ " , { from = \"2.0.0\", to = \"3.0.0\", prompt = \"Second probe edge.\" }",+ " ]",+ ", versionProbe = Some \"cat .library-version\"",+ "}"+ ]++-- | A scratch project with both cohort blueprints installed, a fake @claude@+-- first on @PATH@ that always succeeds, and a scrubbed environment. The+-- callback receives the project root and a runner for @seihou@ arguments.+withCohortProject ::+ (FilePath -> ([String] -> IO (ExitCode, T.Text, T.Text)) -> IO a) ->+ IO a+withCohortProject action =+ withSystemTempDirectory "seihou-agent-migrate-cohort" $ \root -> do+ binary <- seihouBinary+ let modulesDir = root </> ".seihou" </> "modules"+ kirokuDir = modulesDir </> "kiroku-upgrade"+ keiroDir = modulesDir </> "keiro-upgrade"+ xdgHome = root </> "xdg"+ fakeBin = root </> "bin"+ fakeClaude = fakeBin </> "claude"+ createDirectoryIfMissing True (kirokuDir </> "files")+ createDirectoryIfMissing True (keiroDir </> "files")+ createDirectoryIfMissing True xdgHome+ createDirectoryIfMissing True fakeBin+ TIO.writeFile (kirokuDir </> "blueprint.dhall") (kirokuBlueprintDhall "1.9.0")+ TIO.writeFile (keiroDir </> "blueprint.dhall") keiroBlueprintDhall+ -- Distinctive markers, so each rendered step's reference-file listing+ -- 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"+ 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.+ setPermissions fakeClaude (permissions {executable = True})++ inherited <- getEnvironment+ let inheritedPath = fromMaybe "" (lookup "PATH" inherited)+ overriddenNames =+ [ "PATH",+ "XDG_CONFIG_HOME",+ "SEIHOU_AGENT_PROVIDER",+ "SEIHOU_AGENT_MODEL",+ "SEIHOU_AGENT_EFFORT",+ "SEIHOU_CONTEXT"+ ]+ environment =+ ("PATH", fakeBin <> [searchPathSeparator] <> inheritedPath)+ : ("XDG_CONFIG_HOME", xdgHome)+ : ("SEIHOU_AGENT_PROVIDER", "claude-cli")+ : filter (\(key, _) -> key `notElem` overriddenNames) inherited+ run args = runProcessText binary args (Just root) (Just environment)+ action root run++-- | The entailed blueprint. Its edge's start version is a parameter so a test+-- can move it and make the declaring blueprint's reference dangle.+kirokuBlueprintDhall :: T.Text -> T.Text+kirokuBlueprintDhall edgeFrom =+ T.unlines+ [ "{ name = \"kiroku-upgrade\"",+ ", version = Some \"2.0.0\"",+ ", description = Some \"kiroku upgrade\"",+ ", prompt = \"Shared kiroku guidance.\"",+ ", vars = [] : List { name : Text, type : Text, default : Optional Text, description : Optional Text, required : Bool, validation : Optional Text }",+ ", prompts = [] : List { var : Text, text : Text, when : Optional Text, choices : Optional (List Text) }",+ ", baseModules = [] : List { module : Text, vars : List { name : Text, value : Text } }",+ ", files = [ { src = \"kiroku-marker.md\", description = Some \"kiroku reference\" } ]",+ ", allowedTools = None (List Text)",+ ", tags = [] : List Text",+ ", migrations =",+ " [ { from = \"" <> edgeFrom <> "\"",+ " , to = \"2.0.0\"",+ " , prompt = \"Drop the removed kiroku API.\"",+ " , entails = [] : List { blueprint : Text, from : Text, to : Text }",+ " }",+ " ]",+ "}"+ ]++-- | The declaring blueprint, whose only edge entails kiroku's.+keiroBlueprintDhall :: T.Text+keiroBlueprintDhall =+ T.unlines+ [ "{ name = \"keiro-upgrade\"",+ ", version = Some \"3.0.0\"",+ ", description = Some \"keiro upgrade\"",+ ", prompt = \"Shared keiro guidance.\"",+ ", vars = [] : List { name : Text, type : Text, default : Optional Text, description : Optional Text, required : Bool, validation : Optional Text }",+ ", prompts = [] : List { var : Text, text : Text, when : Optional Text, choices : Optional (List Text) }",+ ", baseModules = [] : List { module : Text, vars : List { name : Text, value : Text } }",+ ", files = [ { src = \"keiro-marker.md\", description = Some \"keiro reference\" } ]",+ ", allowedTools = None (List Text)",+ ", tags = [] : List Text",+ ", migrations =",+ " [ { from = \"2.4.0\"",+ " , to = \"3.0.0\"",+ " , prompt = \"Adopt the new keiro wrapper.\"",+ " , entails =",+ " [ { blueprint = \"kiroku-upgrade\", from = \"1.9.0\", to = \"2.0.0\" } ]",+ " }",+ " ]",+ "}"+ ]++-- | The recorded edge windows and outcomes, in ledger order.+readReceipts :: FilePath -> IO [(T.Text, T.Text, MigrationOutcome)]+readReceipts manifestPath = do+ bytes <- LBS.readFile manifestPath+ case manifestFromJSON bytes of+ Left err -> expectationFailure err >> fail "unreachable"+ Right manifest ->+ pure+ [ (receipt ^. #fromVersion, receipt ^. #toVersion, receipt ^. #outcome)+ | receipt <- manifest ^. #blueprintMigrations+ ] runProcessText :: FilePath ->
test/Seihou/CLI/AppliedBlueprintMigrationSpec.hs view
@@ -1,12 +1,20 @@ module Seihou.CLI.AppliedBlueprintMigrationSpec (tests) where import Control.Lens ((&), (.~), (^.))+import Data.ByteString qualified as BS import Data.ByteString.Lazy qualified as LBS import Data.Generics.Labels () import Data.Text qualified as T+import Data.Text.Encoding qualified as TE import Data.Time (UTCTime, defaultTimeLocale, parseTimeOrError) import Seihou.CLI.AppliedBlueprintMigration (recordAppliedBlueprintMigration)-import Seihou.Core.Types (AppliedBlueprintMigration (..), Manifest (..), ModuleName (..))+import Seihou.Core.Types+ ( AppliedBlueprintMigration (..),+ ArtifactOrigin (..),+ Manifest (..),+ MigrationOutcome (..),+ ModuleName (..),+ ) import Seihou.Manifest.Types (currentManifestVersion, manifestFromJSON) import System.FilePath ((</>)) import System.IO.Temp (withSystemTempDirectory)@@ -25,13 +33,34 @@ fixedTime2 = parseTimeOrError True defaultTimeLocale "%Y-%m-%dT%H:%M:%SZ" "2026-07-20T13:00:00Z" -mkReceipt :: T.Text -> T.Text -> T.Text -> UTCTime -> AppliedBlueprintMigration-mkReceipt blueprintName fromVersion toVersion appliedAt =+-- | The identity of the blueprint most cases here record receipts for.+repoOne :: ArtifactOrigin+repoOne = RemoteOrigin "https://github.com/acme/one" "payments" Nothing++-- | A different repository publishing a blueprint of the same name.+repoTwo :: ArtifactOrigin+repoTwo = RemoteOrigin "https://github.com/acme/two" "payments" Nothing++mkReceipt :: ArtifactOrigin -> T.Text -> T.Text -> T.Text -> UTCTime -> AppliedBlueprintMigration+mkReceipt origin blueprintName fromVersion toVersion appliedAt =+ mkReceiptWithOutcome origin blueprintName fromVersion toVersion appliedAt MigrationApplied++mkReceiptWithOutcome ::+ ArtifactOrigin ->+ T.Text ->+ T.Text ->+ T.Text ->+ UTCTime ->+ MigrationOutcome -> AppliedBlueprintMigration+mkReceiptWithOutcome origin blueprintName fromVersion toVersion appliedAt outcome =+ AppliedBlueprintMigration { name = ModuleName blueprintName,+ origin = origin, blueprintVersion = Just "0.4.0", fromVersion = fromVersion, toVersion = toVersion,+ outcome = outcome, appliedAt = appliedAt, agentSessionId = Nothing }@@ -44,39 +73,140 @@ Left err -> error ("test fixture: malformed manifest: " <> err) spec :: Spec-spec = describe "recordAppliedBlueprintMigration" $ do- it "creates a version-5 manifest for the first receipt" $- withSystemTempDirectory "seihou-blueprint-migration" $ \dir -> do- let manifestPath = dir </> ".seihou" </> "manifest.json"- receipt = mkReceipt "payments" "1.0.0" "2.0.0" fixedTime- result <- recordAppliedBlueprintMigration manifestPath receipt- result `shouldBe` Right ()- manifest <- readManifestFile manifestPath- (manifest ^. #version) `shouldBe` currentManifestVersion- (manifest ^. #blueprintMigrations) `shouldBe` [receipt]+spec = do+ describe "recordAppliedBlueprintMigration" $ do+ it "creates a version-5 manifest for the first receipt" $+ withSystemTempDirectory "seihou-blueprint-migration" $ \dir -> do+ let manifestPath = dir </> ".seihou" </> "manifest.json"+ receipt = mkReceipt repoOne "payments" "1.0.0" "2.0.0" fixedTime+ result <- recordAppliedBlueprintMigration manifestPath receipt+ result `shouldBe` Right ()+ manifest <- readManifestFile manifestPath+ (manifest ^. #version) `shouldBe` currentManifestVersion+ (manifest ^. #blueprintMigrations) `shouldBe` [receipt] - it "upserts the same exact edge and retains unrelated edges" $- withSystemTempDirectory "seihou-blueprint-migration" $ \dir -> do- let manifestPath = dir </> "manifest.json"- first = mkReceipt "payments" "1.0.0" "2.0.0" fixedTime- second = mkReceipt "payments" "2.5.0" "3.0.0" fixedTime- replacement =- ( (mkReceipt "payments" "1.0.0" "2.0.0" fixedTime2)- & #blueprintVersion .~ Just "0.5.0"- )- recordAppliedBlueprintMigration manifestPath first `shouldReturn` Right ()- recordAppliedBlueprintMigration manifestPath second `shouldReturn` Right ()- recordAppliedBlueprintMigration manifestPath replacement `shouldReturn` Right ()- manifest <- readManifestFile manifestPath- (manifest ^. #blueprintMigrations) `shouldBe` [replacement, second]+ it "upserts the same exact edge and retains unrelated edges" $+ withSystemTempDirectory "seihou-blueprint-migration" $ \dir -> do+ let manifestPath = dir </> "manifest.json"+ first = mkReceipt repoOne "payments" "1.0.0" "2.0.0" fixedTime+ second = mkReceipt repoOne "payments" "2.5.0" "3.0.0" fixedTime+ replacement =+ ( (mkReceipt repoOne "payments" "1.0.0" "2.0.0" fixedTime2)+ & #blueprintVersion .~ Just "0.5.0"+ )+ recordAppliedBlueprintMigration manifestPath first `shouldReturn` Right ()+ recordAppliedBlueprintMigration manifestPath second `shouldReturn` Right ()+ recordAppliedBlueprintMigration manifestPath replacement `shouldReturn` Right ()+ manifest <- readManifestFile manifestPath+ (manifest ^. #blueprintMigrations) `shouldBe` [replacement, second] - it "returns Left and preserves a corrupt existing manifest" $- withSystemTempDirectory "seihou-blueprint-migration" $ \dir -> do- let manifestPath = dir </> "manifest.json"- corrupt = "{ this is not valid json"- writeFile manifestPath corrupt- result <- recordAppliedBlueprintMigration manifestPath (mkReceipt "payments" "1.0.0" "2.0.0" fixedTime)- case result of- Left err -> err `shouldSatisfy` not . T.null- Right () -> expectationFailure "expected corrupt manifest failure"- readFile manifestPath `shouldReturn` corrupt+ -- The ledger keys receipts by the origin of the blueprint that owns the+ -- edge, so two repositories publishing the same name and the same edge+ -- window each keep their own receipt rather than overwriting each other.+ it "appends rather than replaces when only the origin differs" $+ withSystemTempDirectory "seihou-blueprint-migration" $ \dir -> do+ let manifestPath = dir </> "manifest.json"+ fromRepoOne = mkReceipt repoOne "payments" "1.0.0" "2.0.0" fixedTime+ fromRepoTwo = mkReceipt repoTwo "payments" "1.0.0" "2.0.0" fixedTime2+ recordAppliedBlueprintMigration manifestPath fromRepoOne `shouldReturn` Right ()+ recordAppliedBlueprintMigration manifestPath fromRepoTwo `shouldReturn` Right ()+ manifest <- readManifestFile manifestPath+ (manifest ^. #blueprintMigrations) `shouldBe` [fromRepoOne, fromRepoTwo]++ it "replaces in place when the origin spelling differs only by a .git suffix" $+ withSystemTempDirectory "seihou-blueprint-migration" $ \dir -> do+ let manifestPath = dir </> "manifest.json"+ plainUrl = mkReceipt repoOne "payments" "1.0.0" "2.0.0" fixedTime+ dotGitUrl =+ mkReceipt+ (RemoteOrigin "https://github.com/acme/one.git" "payments" Nothing)+ "payments"+ "1.0.0"+ "2.0.0"+ fixedTime2+ recordAppliedBlueprintMigration manifestPath plainUrl `shouldReturn` Right ()+ recordAppliedBlueprintMigration manifestPath dotGitUrl `shouldReturn` Right ()+ manifest <- readManifestFile manifestPath+ (manifest ^. #blueprintMigrations) `shouldBe` [dotGitUrl]++ it "returns Left and preserves a corrupt existing manifest" $+ withSystemTempDirectory "seihou-blueprint-migration" $ \dir -> do+ let manifestPath = dir </> "manifest.json"+ corrupt = "{ this is not valid json"+ writeFile manifestPath corrupt+ result <- recordAppliedBlueprintMigration manifestPath (mkReceipt repoOne "payments" "1.0.0" "2.0.0" fixedTime)+ case result of+ Left err -> err `shouldSatisfy` not . T.null+ Right () -> expectationFailure "expected corrupt manifest failure"+ readFile manifestPath `shouldReturn` corrupt++ describe "receipt JSON" $ do+ it "round-trips a receipt's origin through the manifest encoding" $+ withSystemTempDirectory "seihou-blueprint-migration" $ \dir -> do+ let manifestPath = dir </> "manifest.json"+ receipt = mkReceipt repoOne "payments" "1.0.0" "2.0.0" fixedTime+ recordAppliedBlueprintMigration manifestPath receipt `shouldReturn` Right ()+ encoded <- LBS.readFile manifestPath+ LBS.toStrict encoded+ `shouldSatisfy` BS.isInfixOf (TE.encodeUtf8 "https://github.com/acme/one")+ manifest <- readManifestFile manifestPath+ map (^. #origin) (manifest ^. #blueprintMigrations) `shouldBe` [repoOne]++ it "round-trips a not-applicable outcome with its reason intact" $+ withSystemTempDirectory "seihou-blueprint-migration" $ \dir -> do+ let manifestPath = dir </> "manifest.json"+ reason = "the project has not adopted the bundle"+ skipped =+ mkReceiptWithOutcome repoOne "payments" "1.0.0" "2.0.0" fixedTime (MigrationNotApplicable reason)+ recordAppliedBlueprintMigration manifestPath skipped `shouldReturn` Right ()+ encoded <- LBS.readFile manifestPath+ LBS.toStrict encoded `shouldSatisfy` BS.isInfixOf (TE.encodeUtf8 "not-applicable")+ manifest <- readManifestFile manifestPath+ (manifest ^. #blueprintMigrations) `shouldBe` [skipped]++ -- Outcome is audit metadata, not identity. An edge that reported itself+ -- inapplicable and later ran for real must leave one receipt behind, not+ -- two records of the same edge disagreeing about what happened.+ it "replaces a not-applicable receipt when the same edge later applies" $+ withSystemTempDirectory "seihou-blueprint-migration" $ \dir -> do+ let manifestPath = dir </> "manifest.json"+ skipped =+ mkReceiptWithOutcome repoOne "payments" "1.0.0" "2.0.0" fixedTime (MigrationNotApplicable "no adr bundle")+ applied = mkReceipt repoOne "payments" "1.0.0" "2.0.0" fixedTime2+ recordAppliedBlueprintMigration manifestPath skipped `shouldReturn` Right ()+ recordAppliedBlueprintMigration manifestPath applied `shouldReturn` Right ()+ manifest <- readManifestFile manifestPath+ (manifest ^. #blueprintMigrations) `shouldBe` [applied]++ -- A manifest written before the origin field existed must keep parsing.+ -- Nothing on disk can say where such a receipt came from, so it decodes+ -- to the constructor that means "provenance seihou cannot verify".+ it "decodes a receipt with no origin key as unverifiable provenance" $ do+ let legacy =+ LBS.fromStrict $+ TE.encodeUtf8 $+ T.unlines+ [ "{ \"version\": 6",+ ", \"generatedAt\": \"2026-07-20T12:00:00Z\"",+ ", \"modules\": []",+ ", \"variables\": {}",+ ", \"files\": {}",+ ", \"blueprintMigrations\":",+ " [ { \"name\": \"payments\"",+ " , \"from\": \"1.0.0\"",+ " , \"to\": \"2.0.0\"",+ " , \"appliedAt\": \"2026-07-20T12:00:00Z\"",+ " } ]",+ "}"+ ]+ case manifestFromJSON legacy of+ Left err -> expectationFailure ("legacy manifest must still parse: " <> err)+ Right manifest -> do+ map (^. #origin) (manifest ^. #blueprintMigrations)+ `shouldBe` [LocalOrigin "payments"]+ -- Every receipt written before the outcome field existed recorded an+ -- edge whose session returned, which is what MigrationApplied means.+ -- Reading it that way preserves its meaning; a receipt that was+ -- really a deliberate no-op stays wrong, and --rerun is its remedy.+ map (^. #outcome) (manifest ^. #blueprintMigrations)+ `shouldBe` [MigrationApplied]
test/Seihou/CLI/AppliedBlueprintSpec.hs view
@@ -6,11 +6,13 @@ import Data.Map.Strict qualified as Map import Data.Text (Text) import Data.Text qualified as T+import Data.Text.Encoding qualified as TE import Data.Time (UTCTime, defaultTimeLocale, parseTimeOrError) import Seihou.CLI.AppliedBlueprint (recordAppliedBlueprint) import Seihou.Core.Types ( AppliedBlueprint (..), AppliedRecipe (..),+ ArtifactOrigin (..), Manifest (..), ModuleName (..), RecipeName (..),@@ -33,10 +35,15 @@ "%Y-%m-%dT%H:%M:%SZ" "2026-05-12T14:23:00Z" +-- | The identity a blueprint installed from a git URL carries.+blueprintOrigin :: Text -> ArtifactOrigin+blueprintOrigin name = RemoteOrigin ("https://github.com/acme/" <> name) name Nothing+ mkEntry :: Text -> Maybe Text -> [Text] -> Bool -> Maybe Text -> AppliedBlueprint mkEntry name mver baseline noBL prompt = AppliedBlueprint { name = ModuleName name,+ origin = blueprintOrigin name, blueprintVersion = mver, appliedAt = fixedTime, baselineModules = map ModuleName baseline,@@ -71,6 +78,7 @@ seedRecipe = AppliedRecipe { name = RecipeName "haskell-library",+ origin = RemoteOrigin "https://github.com/acme/haskell-library" "haskell-library" Nothing, recipeVersion = Just "1.2.0", appliedAt = fixedTime }@@ -106,3 +114,59 @@ case res of Left err -> err `shouldSatisfy` not . T.null Right () -> expectationFailure "expected Left for corrupt manifest"++ describe "blueprint and recipe origins in the manifest encoding" $ do+ it "round-trips the blueprint's origin" $ do+ let entry = mkEntry "payments-service" (Just "0.3.1") [] False Nothing+ seed = (emptyManifest fixedTime) & #blueprint .~ Just entry+ case manifestFromJSON (manifestToJSON seed) of+ Left err -> expectationFailure ("manifest must round-trip: " <> err)+ Right decoded ->+ (decoded ^. #blueprint) `shouldBe` Just entry++ it "round-trips the recipe's origin" $ do+ let seedRecipe =+ AppliedRecipe+ { name = RecipeName "haskell-library",+ origin = RemoteOrigin "https://github.com/acme/haskell-library" "haskell-library" Nothing,+ recipeVersion = Just "1.2.0",+ appliedAt = fixedTime+ }+ seed = (emptyManifest fixedTime) & #recipe .~ Just seedRecipe+ case manifestFromJSON (manifestToJSON seed) of+ Left err -> expectationFailure ("manifest must round-trip: " <> err)+ Right decoded ->+ (decoded ^. #recipe) `shouldBe` Just seedRecipe++ -- Manifests written before the origin field existed must keep parsing;+ -- both records decode to the constructor that means "provenance seihou+ -- cannot verify".+ it "decodes a blueprint and recipe with no origin key as unverifiable" $ do+ let legacy =+ LBS.fromStrict $+ TE.encodeUtf8 $+ T.unlines+ [ "{ \"version\": 6",+ ", \"generatedAt\": \"2026-05-12T14:23:00Z\"",+ ", \"modules\": []",+ ", \"variables\": {}",+ ", \"files\": {}",+ ", \"blueprint\":",+ " { \"name\": \"payments-service\"",+ " , \"appliedAt\": \"2026-05-12T14:23:00Z\"",+ " , \"baselineModules\": []",+ " , \"noBaseline\": false",+ " }",+ ", \"recipe\":",+ " { \"name\": \"haskell-library\"",+ " , \"appliedAt\": \"2026-05-12T14:23:00Z\"",+ " }",+ "}"+ ]+ case manifestFromJSON legacy of+ Left err -> expectationFailure ("legacy manifest must still parse: " <> err)+ Right decoded -> do+ fmap (^. #origin) (decoded ^. #blueprint)+ `shouldBe` Just (LocalOrigin "payments-service")+ fmap (^. #origin) (decoded ^. #recipe)+ `shouldBe` Just (LocalOrigin "haskell-library")
test/Seihou/CLI/BlueprintMigrationSpec.hs view
@@ -7,12 +7,14 @@ import Data.Text (Text) import Data.Text qualified as T import Data.Time (UTCTime)+import Effectful (runPureEff) import Seihou.CLI.AgentLaunch (AgentContext (..)) import Seihou.CLI.BlueprintExecution (PreparedBlueprintExecution (..)) import Seihou.CLI.BlueprintMigration import Seihou.Core.Migration import Seihou.Core.Types import Seihou.Core.Version (Version, parseVersion)+import Seihou.Effect.ProcessPure (ProcessMock (..), runProcessPure) import System.Exit (ExitCode (..)) import Test.Hspec import Test.Tasty (TestTree)@@ -30,24 +32,125 @@ [late, early] (version "1.0.0") (version "3.0.0")- pendingBlueprintMigrations False blueprintName [] migrationPlan- `shouldBe` [early, late]+ pendingBlueprintMigrations False owners [] migrationPlan+ `shouldBe` [ownedStep "payments" early, ownedStep "payments" late] it "resumes by filtering only an already-recorded exact edge" $ do let migrationPlan = plan [first, second] receipts =- [ receipt blueprintName "1.0.0" "2.0.0",- receipt "another-blueprint" "2.0.0" "3.0.0"+ [ receipt blueprintOrigin blueprintName "1.0.0" "2.0.0",+ receipt blueprintOrigin "another-blueprint" "2.0.0" "3.0.0" ]- pendingBlueprintMigrations False blueprintName receipts migrationPlan+ pendingBlueprintMigrations False owners receipts migrationPlan `shouldBe` [second] it "keeps recorded edges when rerun is requested" $ do let migrationPlan = plan [first, second]- receipts = [receipt blueprintName "1.0.0" "2.0.0"]- pendingBlueprintMigrations True blueprintName receipts migrationPlan+ receipts = [receipt blueprintOrigin blueprintName "1.0.0" "2.0.0"]+ pendingBlueprintMigrations True owners receipts migrationPlan `shouldBe` [first, second] + -- The behaviour the origin field exists for. Two repositories can publish+ -- a blueprint under the same name; their identically-numbered edges are+ -- different work, and the first one's receipt must not silently suppress+ -- the second one's edge.+ it "does not let another repository's receipt suppress an identical edge" $ do+ let migrationPlan = plan [first, second]+ receipts = [receipt otherRepoOrigin blueprintName "1.0.0" "2.0.0"]+ pendingBlueprintMigrations False owners receipts migrationPlan+ `shouldBe` [first, second]++ it "does drop the edge when the receipt is from the same repository" $ do+ let migrationPlan = plan [first, second]+ receipts = [receipt blueprintOrigin blueprintName "1.0.0" "2.0.0"]+ pendingBlueprintMigrations False owners receipts migrationPlan+ `shouldBe` [second]++ -- Two spellings of one git URL are one repository. A developer who+ -- installed with the '.git' suffix must not see their recorded edges+ -- reappear because someone else typed it without.+ it "treats a trailing .git as the same origin" $ do+ let migrationPlan = plan [first, second]+ receipts =+ [receipt (RemoteOrigin "https://github.com/acme/one.git" "payments" Nothing) blueprintName "1.0.0" "2.0.0"]+ pendingBlueprintMigrations False owners receipts migrationPlan+ `shouldBe` [second]++ -- Receipts written before origins were recorded decode as LocalOrigin.+ -- They match each other, and they match nothing installed from a URL.+ it "matches a legacy receipt only against an equally unprovenanced blueprint" $ do+ let migrationPlan = plan [first, second]+ receipts = [receipt (LocalOrigin "payments") blueprintName "1.0.0" "2.0.0"]+ unprovenancedOwners =+ ownersFrom [("payments", (blueprintName, LocalOrigin "payments"))]+ pendingBlueprintMigrations False unprovenancedOwners receipts migrationPlan+ `shouldBe` [second]+ pendingBlueprintMigrations False owners receipts migrationPlan+ `shouldBe` [first, second]++ -- The defect IR-1 filed. An edge that reported its precondition unmet+ -- recorded a receipt indistinguishable from a real upgrade, so the run+ -- that should have happened once the precondition was met never did.+ it "does not let a not-applicable receipt suppress its own edge" $ do+ let migrationPlan = plan [first, second]+ receipts =+ [ notApplicableReceipt+ blueprintOrigin+ blueprintName+ "1.0.0"+ "2.0.0"+ "the project has not adopted the bundle"+ ]+ pendingBlueprintMigrations False owners receipts migrationPlan+ `shouldBe` [first, second]++ -- The same edge, the same origin, the same window: only the outcome+ -- differs, and only the applied one suppresses.+ it "suppresses the edge once the same edge is recorded as applied" $ do+ let migrationPlan = plan [first, second]+ skipped = notApplicableReceipt blueprintOrigin blueprintName "1.0.0" "2.0.0" "no adr bundle"+ applied = receipt blueprintOrigin blueprintName "1.0.0" "2.0.0"+ pendingBlueprintMigrations False owners [skipped] migrationPlan+ `shouldBe` [first, second]+ pendingBlueprintMigrations False owners [applied] migrationPlan+ `shouldBe` [second]++ -- The regression fence around fan-out's central claim. A plan whose steps+ -- belong to two blueprints is filtered per step against the receipts of+ -- that step's own owner.+ it "drops an entailed step when the entailed blueprint recorded that edge" $ do+ let migrationPlan = plan [entailedStep, first]+ receipts = [receipt entailedOrigin entailedName "1.9.0" "2.0.0"]+ pendingBlueprintMigrations False cohortOwners receipts migrationPlan+ `shouldBe` [first]++ -- The mirror, and the whole reason the receipt is written under the owner:+ -- a receipt filed under the invoking blueprint for the same window says+ -- nothing about the entailed blueprint's edge, and must not drop it.+ it "does not drop an entailed step because the invoking blueprint recorded that window" $ do+ let migrationPlan = plan [entailedStep, first]+ receipts = [receipt blueprintOrigin blueprintName "1.9.0" "2.0.0"]+ pendingBlueprintMigrations False cohortOwners receipts migrationPlan+ `shouldBe` [entailedStep, first]++ -- Discovery resolves every owner before a plan reaches this function, so+ -- an unresolvable owner is an internal inconsistency. Claiming the step+ -- was already applied would silently skip real work; the honest answer is+ -- that nothing is known about it.+ it "treats a step whose owner cannot be resolved as not previously applied" $ do+ let migrationPlan = plan [entailedStep]+ receipts = [receipt entailedOrigin entailedName "1.9.0" "2.0.0"]+ pendingBlueprintMigrations False owners receipts migrationPlan+ `shouldBe` [entailedStep]++ describe "formatMigrationStepLabel" $ do+ it "names the owning blueprint and the edge" $+ formatMigrationStepLabel first `shouldBe` "payments 1.0.0 -> 2.0.0"++ it "names what pulled in an entailed step" $+ formatMigrationStepLabel entailedStep+ `shouldBe` "kiroku-upgrade 1.9.0 -> 2.0.0 (entailed by keiro-upgrade 2.4.0 -> 3.0.0)"+ describe "renderBlueprintMigrationInstruction" $ do it "substitutes the variables resolved for the shared blueprint" $ do let declaration = VarDecl "library.name" VTText Nothing Nothing False Nothing@@ -60,10 +163,11 @@ describe "renderBlueprintMigrationSystemPrompt" $ do it "renders identity, position, shared guidance, edge instructions, and reference access" $ do- let edge = migrationWithPrompt "1.0.0" "2.0.0" "Upgrade {{library.name}} now."+ let edge = ownedStep "payments" (migrationWithPrompt "1.0.0" "2.0.0" "Upgrade {{library.name}} now.") rendered = renderBlueprintMigrationSystemPrompt "{{blueprint_name}} {{blueprint_version}} | {{migration_position}}/{{migration_total}} | {{migration_from}} -> {{migration_to}} | {{shared_prompt}} | {{migration_prompt}} | {{reference_files_dir}} | {{cwd}}"+ "/tmp/project/.seihou/.migrate-signal" sampleContext samplePrepared 1@@ -72,36 +176,78 @@ rendered `shouldBe` "payments 4.2.0 | 1/2 | 1.0.0 -> 2.0.0 | Shared guidance for baikai. | Upgrade baikai now. | mounted at /tmp/payments/files | /tmp/project" + -- The agent cannot signal inapplicability without being told where; the+ -- path is a template variable so the caller owns it, exactly as it owns+ -- the template text.+ it "substitutes the not-applicable signal path" $ do+ renderBlueprintMigrationSystemPrompt+ "write to {{not_applicable_signal_path}}"+ "/tmp/project/.seihou/.migrate-signal"+ sampleContext+ samplePrepared+ 1+ 1+ first+ `shouldBe` "write to /tmp/project/.seihou/.migrate-signal"++ -- An entailed step is being run on a library the user never named, so the+ -- framing has to say why it is happening at all.+ it "explains an entailed step, and says nothing for a directly selected one" $ do+ let render step =+ renderBlueprintMigrationSystemPrompt+ "{{migration_entailed_by}}"+ "/tmp/project/.seihou/.migrate-signal"+ sampleContext+ samplePrepared+ 1+ 1+ step+ render entailedStep+ `shouldBe` "This edge was not requested directly. It is required by keiro-upgrade 2.4.0 -> 3.0.0, which the user is migrating."+ render first `shouldBe` ""+ it "delimits debug prompts in pending order without any execution callback" $ do let output = formatBlueprintMigrationDebugOutput- (\position total edge -> "prompt " <> tshow position <> "/" <> tshow total <> " " <> edge ^. #from)+ (\position total step -> "prompt " <> tshow position <> "/" <> tshow total <> " " <> step ^. #edge . #from) [first, second]- output `shouldSatisfy` T.isInfixOf "===== [1/2] 1.0.0 -> 2.0.0 ====="- output `shouldSatisfy` T.isInfixOf "===== [2/2] 2.0.0 -> 3.0.0 ====="+ output `shouldSatisfy` T.isInfixOf "===== [1/2] payments 1.0.0 -> 2.0.0 ====="+ output `shouldSatisfy` T.isInfixOf "===== [2/2] payments 2.0.0 -> 3.0.0 =====" T.breakOn "2.0.0 -> 3.0.0" output `shouldSatisfy` (not . T.null . snd) + -- A chain that spans blueprints is unreadable if every header looks the+ -- same; the owner is the only way to tell whose prompt follows.+ it "labels a debug header with the owning blueprint and what entailed it" $ do+ let output =+ formatBlueprintMigrationDebugOutput+ (\_ _ _ -> "prompt body")+ [entailedStep, first]+ output+ `shouldSatisfy` T.isInfixOf+ "===== [1/2] kiroku-upgrade 1.9.0 -> 2.0.0 (entailed by keiro-upgrade 2.4.0 -> 3.0.0) ====="+ output `shouldSatisfy` T.isInfixOf "===== [2/2] payments 1.0.0 -> 2.0.0 ====="+ describe "runBlueprintMigrationsWith" $ do it "reports no work without invoking either callback" $ do calls <- newIORef ([] :: [Text]) result <- runBlueprintMigrationsWith- (\_ _ _ -> modifyIORef' calls (<> ["launch"]) >> pure (Right ()))- (\_ -> modifyIORef' calls (<> ["record"]) >> pure (Right ()))+ (\_ _ _ -> modifyIORef' calls (<> ["launch"]) >> pure (Right BlueprintMigrationSessionReturned))+ (\_ _ -> modifyIORef' calls (<> ["record"]) >> pure (Right ())) [] result `shouldBe` BlueprintMigrationNoWork readIORef calls `shouldReturn` [] it "launches and records every edge sequentially" $ do calls <- newIORef ([] :: [Text])- let launch position total edge = do- modifyIORef' calls (<> ["launch " <> tshow position <> "/" <> tshow total <> " " <> edge ^. #from])- pure (Right ())- record edge = do- modifyIORef' calls (<> ["record " <> edge ^. #from])+ let launch position total step = do+ modifyIORef' calls (<> ["launch " <> tshow position <> "/" <> tshow total <> " " <> step ^. #edge . #from])+ pure (Right BlueprintMigrationSessionReturned)+ record step _ = do+ modifyIORef' calls (<> ["record " <> step ^. #edge . #from]) pure (Right ()) result <- runBlueprintMigrationsWith launch record [first, second]- result `shouldBe` BlueprintMigrationComplete [first, second]+ result `shouldBe` BlueprintMigrationComplete [(first, MigrationApplied), (second, MigrationApplied)] readIORef calls `shouldReturn` [ "launch 1/2 1.0.0", "record 1.0.0",@@ -109,10 +255,39 @@ "record 2.0.0" ] + -- IR-1 rejects exiting nonzero for an inapplicable edge precisely because+ -- it "halts a multi-edge chain that should have continued past an+ -- inapplicable step". This is that requirement.+ it "records the outcome and continues past a not-applicable edge" $ do+ calls <- newIORef ([] :: [Text])+ outcomes <- newIORef ([] :: [(Text, MigrationOutcome)])+ let launch _ _ step = do+ modifyIORef' calls (<> ["launch " <> step ^. #edge . #from])+ pure . Right $+ if step == first+ then BlueprintMigrationSessionNotApplicable "no docs/adr directory"+ else BlueprintMigrationSessionReturned+ record step outcome = do+ modifyIORef' calls (<> ["record " <> step ^. #edge . #from])+ modifyIORef' outcomes (<> [(step ^. #edge . #from, outcome)])+ pure (Right ())+ result <- runBlueprintMigrationsWith launch record [first, second]+ result+ `shouldBe` BlueprintMigrationComplete+ [ (first, MigrationNotApplicable "no docs/adr directory"),+ (second, MigrationApplied)+ ]+ readIORef calls+ `shouldReturn` ["launch 1.0.0", "record 1.0.0", "launch 2.0.0", "record 2.0.0"]+ readIORef outcomes+ `shouldReturn` [ ("1.0.0", MigrationNotApplicable "no docs/adr directory"),+ ("2.0.0", MigrationApplied)+ ]+ it "records only completed edges after failure and resumes at the failed edge" $ do calls <- newIORef ([] :: [Text]) recorded <- newIORef ([] :: [AppliedBlueprintMigration])- let third = migration "3.0.0" "4.0.0"+ let third = ownedStep "payments" (migration "3.0.0" "4.0.0") migrationPlan = BlueprintMigrationPlan { name = "payments",@@ -120,15 +295,15 @@ to = version "4.0.0", steps = [first, second, third] }- launch _ _ edge = do- modifyIORef' calls (<> ["launch " <> edge ^. #from])+ launch _ _ step = do+ modifyIORef' calls (<> ["launch " <> step ^. #edge . #from]) pure $- if edge == second+ if step == second then Left (BlueprintMigrationProcessFailure (ExitFailure 17))- else Right ()- record edge = do- modifyIORef' calls (<> ["record " <> edge ^. #from])- modifyIORef' recorded (<> [receipt blueprintName (edge ^. #from) (edge ^. #to)])+ else Right BlueprintMigrationSessionReturned+ record step _ = do+ modifyIORef' calls (<> ["record " <> step ^. #edge . #from])+ modifyIORef' recorded (<> [receipt blueprintOrigin blueprintName (step ^. #edge . #from) (step ^. #edge . #to)]) pure (Right ()) result <- runBlueprintMigrationsWith launch record [first, second, third] result@@ -137,34 +312,316 @@ `shouldReturn` ["launch 1.0.0", "record 1.0.0", "launch 2.0.0"] savedReceipts <- readIORef recorded- let resumed = pendingBlueprintMigrations False blueprintName savedReceipts migrationPlan+ let resumed = pendingBlueprintMigrations False owners savedReceipts migrationPlan resumed `shouldBe` [second, third] resumedResult <- runBlueprintMigrationsWith- (\_ _ edge -> modifyIORef' calls (<> ["resume " <> edge ^. #from]) >> pure (Right ()))+ (\_ _ step -> modifyIORef' calls (<> ["resume " <> step ^. #edge . #from]) >> pure (Right BlueprintMigrationSessionReturned)) record resumed- resumedResult `shouldBe` BlueprintMigrationComplete [second, third]- readIORef recorded `shouldReturn` map (\edge -> receipt blueprintName (edge ^. #from) (edge ^. #to)) [first, second, third]+ resumedResult `shouldBe` BlueprintMigrationComplete [(second, MigrationApplied), (third, MigrationApplied)]+ readIORef recorded+ `shouldReturn` map+ (\step -> receipt blueprintOrigin blueprintName (step ^. #edge . #from) (step ^. #edge . #to))+ [first, second, third] it "stops before the next launch when receipt recording fails" $ do calls <- newIORef ([] :: [Text])- let launch _ _ edge = modifyIORef' calls (<> ["launch " <> edge ^. #from]) >> pure (Right ())- record edge = modifyIORef' calls (<> ["record " <> edge ^. #from]) >> pure (Left "disk full")+ let launch _ _ step = modifyIORef' calls (<> ["launch " <> step ^. #edge . #from]) >> pure (Right BlueprintMigrationSessionReturned)+ record step _ = modifyIORef' calls (<> ["record " <> step ^. #edge . #from]) >> pure (Left "disk full") result <- runBlueprintMigrationsWith launch record [first, second] result `shouldBe` BlueprintMigrationRecordFailed first "disk full" readIORef calls `shouldReturn` ["launch 1.0.0", "record 1.0.0"] + describe "highestMigratedVersion" $ do+ it "returns Nothing when nothing has been recorded" $+ highestMigratedVersion blueprintOrigin blueprintName [] `shouldBe` Nothing++ it "returns the highest recorded target with the receipt that says so" $ do+ let earlier = receipt blueprintOrigin blueprintName "1.0.0" "2.0.0"+ later = receipt blueprintOrigin blueprintName "2.0.0" "2.5.0"+ highestMigratedVersion blueprintOrigin blueprintName [later, earlier]+ `shouldBe` Just (version "2.5.0", later)++ it "ignores receipts belonging to another blueprint name" $+ highestMigratedVersion+ blueprintOrigin+ blueprintName+ [receipt blueprintOrigin "another-blueprint" "1.0.0" "9.0.0"]+ `shouldBe` Nothing++ -- The reason origin is part of the identity: another repository's+ -- same-named blueprint records a different project history, and starting+ -- this project's window from it would skip every edge below its target.+ it "ignores a same-named receipt from another repository" $+ highestMigratedVersion+ blueprintOrigin+ blueprintName+ [receipt otherRepoOrigin blueprintName "1.0.0" "9.0.0"]+ `shouldBe` Nothing++ it "treats two spellings of one git URL as the same repository" $ do+ let dotGit = receipt (RemoteOrigin "https://github.com/acme/one.git" "payments" Nothing) blueprintName "1.0.0" "2.0.0"+ highestMigratedVersion blueprintOrigin blueprintName [dotGit]+ `shouldBe` Just (version "2.0.0", dotGit)++ -- One malformed entry written by an earlier run must not make the+ -- command unusable.+ it "skips an unparseable recorded version rather than failing" $ do+ let usable = receipt blueprintOrigin blueprintName "1.0.0" "2.0.0"+ broken = receipt blueprintOrigin blueprintName "2.0.0" "not-a-version"+ highestMigratedVersion blueprintOrigin blueprintName [broken, usable]+ `shouldBe` Just (version "2.0.0", usable)++ -- The subtlest correctness point in the feature. A not-applicable receipt+ -- says seihou considered an edge and this project did not need it, which+ -- is not progress. Its target is deliberately the highest here, so an+ -- implementation that counted it would visibly pick it and then skip the+ -- 2.0.0 -> 3.0.0 edge forever.+ it "does not count a not-applicable receipt as progress" $ do+ let applied = receipt blueprintOrigin blueprintName "1.0.0" "2.0.0"+ skipped = notApplicableReceipt blueprintOrigin blueprintName "2.0.0" "3.0.0" "no bundle adopted"+ highestMigratedVersion blueprintOrigin blueprintName [applied, skipped]+ `shouldBe` Just (version "2.0.0", applied)++ describe "resolveMigrationWindow" $ do+ it "takes an explicit flag over the probe and the receipts, at each end" $ do+ resolveMigrationWindow (Just (version "1.0.0")) (Just (version "4.0.0")) probeResult recordedResult+ `shouldBe` Right+ ResolvedWindow+ { fromVersion = version "1.0.0",+ fromSource = VersionFromFlag,+ toVersion = version "4.0.0",+ toSource = VersionFromFlag+ }++ -- The two ends resolve independently: either may be typed while the+ -- other is inferred.+ it "infers only the end that was not given" $ do+ resolveMigrationWindow (Just (version "1.0.0")) Nothing probeResult recordedResult+ `shouldBe` Right+ ResolvedWindow+ { fromVersion = version "1.0.0",+ fromSource = VersionFromFlag,+ toVersion = version "3.0.0",+ toSource = VersionFromProbe "cat .library-version"+ }+ resolveMigrationWindow Nothing (Just (version "4.0.0")) probeResult recordedResult+ `shouldBe` Right+ ResolvedWindow+ { fromVersion = version "2.0.0",+ fromSource = VersionFromReceipt recordedReceipt,+ toVersion = version "4.0.0",+ toSource = VersionFromFlag+ }++ -- The probe reads how far the dependency was bumped, so it is the+ -- target; the ledger records how far the source was carried, so it is the+ -- start. Reversing them would report nothing to do for every project that+ -- bumped its lockfile first, which is the workflow this exists for.+ it "takes --to from the probe and --from from the receipt" $+ resolveMigrationWindow Nothing Nothing probeResult recordedResult+ `shouldBe` Right+ ResolvedWindow+ { fromVersion = version "2.0.0",+ fromSource = VersionFromReceipt recordedReceipt,+ toVersion = version "3.0.0",+ toSource = VersionFromProbe "cat .library-version"+ }++ it "reports a missing target when there is no --to and no probe" $+ resolveMigrationWindow Nothing Nothing Nothing recordedResult+ `shouldBe` Left NoTargetVersion++ it "reports a missing start when there is no --from and no receipt" $+ resolveMigrationWindow Nothing Nothing probeResult Nothing+ `shouldBe` Left NoStartVersion++ describe "readVersionProbeOutput" $ do+ it "reads a version printed on its own" $+ readVersionProbeOutput "3.0.0\n" `shouldBe` ProbeVersion (version "3.0.0")++ -- A probe like `nix eval` prints progress before its answer, and+ -- requiring authors to silence every tool's chatter would make probes+ -- fragile.+ it "reads the last non-empty line, past progress output" $+ readVersionProbeOutput "evaluating derivation\nbuilding...\n\n3.0.0\n\n"+ `shouldBe` ProbeVersion (version "3.0.0")++ it "reports unparseable output with the raw text" $ do+ readVersionProbeOutput "v3.0.0\n" `shouldBe` ProbeOutputUnparseable "v3.0.0\n"+ readVersionProbeOutput "" `shouldBe` ProbeOutputUnparseable ""++ describe "runVersionProbe" $ do+ it "returns the version a successful probe printed" $+ runProbe (ExitSuccess, "3.0.0\n", "") `shouldBe` ProbeVersion (version "3.0.0")++ it "returns the version after progress lines" $+ runProbe (ExitSuccess, "evaluating\n3.0.0\n", "warning: ignoring config\n")+ `shouldBe` ProbeVersion (version "3.0.0")++ -- Neither failure aborts the command: the caller reports them and falls+ -- through to requiring --to, because the user did not write the probe and+ -- still has an explicit flag.+ it "carries a nonzero exit and its stderr back to the caller" $+ runProbe (ExitFailure 1, "", "cat: .library-version: No such file\n")+ `shouldBe` ProbeExitedNonZero 1 "cat: .library-version: No such file\n"++ it "reports output that is not a version" $+ runProbe (ExitSuccess, "nothing useful\n", "")+ `shouldBe` ProbeOutputUnparseable "nothing useful\n"++ it "falls through when the probe command does not exist at all" $+ runPureEff (runProcessPure [] (runVersionProbe "no-such-tool" "/tmp/project"))+ `shouldBe` ProbeExitedNonZero 127 "command not found: sh"++ describe "formatResolvedWindow" $ do+ -- Existing invocations that name both versions keep printing exactly what+ -- they printed before; the user does not need to be told what they typed.+ it "says nothing when both ends were typed and verbose was not asked for" $+ formatResolvedWindow False (windowWith VersionFromFlag VersionFromFlag) `shouldBe` []++ it "names both sources under verbose" $+ formatResolvedWindow True (windowWith VersionFromFlag VersionFromFlag)+ `shouldBe` [ "Version window: 2.0.0 -> 3.0.0",+ " --from 2.0.0 [flag]",+ " --to 3.0.0 [flag]"+ ]++ -- An inferred window that is silently wrong runs the wrong agent sessions+ -- against the user's source, so an inferred end always reports itself.+ it "reports an inferred end at normal verbosity, and only that end" $+ formatResolvedWindow False (windowWith VersionFromFlag (VersionFromProbe "cat .library-version"))+ `shouldBe` [ "Version window: 2.0.0 -> 3.0.0",+ " --to 3.0.0 [probe: cat .library-version]"+ ]++ it "names the blueprint, the edge, and the date a receipt-derived start came from" $+ formatResolvedWindow False (windowWith (VersionFromReceipt recordedReceipt) (VersionFromProbe "cat .library-version"))+ `shouldBe` [ "Version window: 2.0.0 -> 3.0.0",+ " --from 2.0.0 [receipt: payments 1.0.0 -> 2.0.0, applied 2026-07-20]",+ " --to 3.0.0 [probe: cat .library-version]"+ ]++ describe "formatProbeFailure" $ do+ it "says nothing about a probe that produced a version" $+ formatProbeFailure "cat .library-version" (ProbeVersion (version "3.0.0")) `shouldBe` Nothing++ it "shows the command, the exit code, and the stderr" $ do+ let rendered = formatProbeFailure "cat .library-version" (ProbeExitedNonZero 1 "No such file\n")+ rendered `shouldSatisfy` maybe False (T.isInfixOf "probe: cat .library-version")+ rendered `shouldSatisfy` maybe False (T.isInfixOf "exit: 1")+ rendered `shouldSatisfy` maybe False (T.isInfixOf "stderr: No such file")++ it "shows what an unparseable probe printed" $+ formatProbeFailure "cat .library-version" (ProbeOutputUnparseable "v3.0.0\n")+ `shouldSatisfy` maybe False (T.isInfixOf "output: v3.0.0")++ describe "formatWindowResolutionError" $ do+ it "names --to and the author's remedy for a missing target" $ do+ let rendered = formatWindowResolutionError blueprintName NoTargetVersion+ rendered `shouldSatisfy` T.isInfixOf "Cannot determine the target version for 'payments'."+ rendered `shouldSatisfy` T.isInfixOf "Pass --to VERSION"+ rendered `shouldSatisfy` T.isInfixOf "versionProbe"++ -- The first-run case, which will be much the commoner of the two. It+ -- should read as an explanation of what seihou does not know, not as a+ -- complaint about what the user failed to type.+ it "explains rather than complains about a missing start" $ do+ let rendered = formatWindowResolutionError blueprintName NoStartVersion+ rendered `shouldSatisfy` T.isInfixOf "no recorded migration for that blueprint"+ rendered `shouldSatisfy` T.isInfixOf "Pass --from VERSION."++ describe "parseNotApplicableSignal" $ do+ it "reads the plain marker line" $+ parseNotApplicableSignal "Checked the pins.\nSEIHOU: not-applicable the bundle was never adopted"+ `shouldBe` Just "the bundle was never adopted"++ it "tolerates backticks, bold, and trailing whitespace" $ do+ parseNotApplicableSignal "`SEIHOU: not-applicable no kiroku imports`"+ `shouldBe` Just "no kiroku imports"+ parseNotApplicableSignal "**SEIHOU: not-applicable no kiroku imports**"+ `shouldBe` Just "no kiroku imports"+ parseNotApplicableSignal "**SEIHOU:** not-applicable no kiroku imports"+ `shouldBe` Just "no kiroku imports"+ parseNotApplicableSignal " SEIHOU: not-applicable no kiroku imports \n\n"+ `shouldBe` Just "no kiroku imports"++ it "finds the marker above a closing sentence" $+ parseNotApplicableSignal+ (T.unlines ["Summary of what I checked.", "SEIHOU: not-applicable nothing to upgrade", "", "No files were changed."])+ `shouldBe` Just "nothing to upgrade"++ it "records a placeholder when the marker carries no reason" $+ parseNotApplicableSignal "SEIHOU: not-applicable" `shouldBe` Just unstatedNotApplicableReason++ -- A parser that reads a refusal out of prose silently skips real work,+ -- which is strictly worse than missing a signal the agent could also have+ -- written to the signal file.+ it "rejects prose that merely mentions the words" $ do+ parseNotApplicableSignal "This edge is not applicable to projects without an ADR bundle."+ `shouldBe` Nothing+ parseNotApplicableSignal "I considered writing SEIHOU: not-applicable but the edge does apply."+ `shouldBe` Nothing+ parseNotApplicableSignal "not-applicable" `shouldBe` Nothing+ parseNotApplicableSignal "SEIHOU: not-applicable-ish" `shouldBe` Nothing+ parseNotApplicableSignal "" `shouldBe` Nothing+ parseNotApplicableSignal "Upgraded three call sites and ran the tests." `shouldBe` Nothing+ blueprintName :: ModuleName blueprintName = "payments" -first :: BlueprintMigration-first = migration "1.0.0" "2.0.0"+-- | The identity of the blueprint under test: installed from one repository.+blueprintOrigin :: ArtifactOrigin+blueprintOrigin = RemoteOrigin "https://github.com/acme/one" "payments" Nothing -second :: BlueprintMigration-second = migration "2.0.0" "3.0.0"+-- | A different repository publishing a blueprint of the same name.+otherRepoOrigin :: ArtifactOrigin+otherRepoOrigin = RemoteOrigin "https://github.com/acme/two" "payments" Nothing +-- | A second cohort member, published by a third repository, whose edge is+-- reached only through entailment.+entailedName :: ModuleName+entailedName = "kiroku-upgrade"++entailedOrigin :: ArtifactOrigin+entailedOrigin = RemoteOrigin "https://github.com/acme/kiroku" "kiroku-upgrade" Nothing++-- | Owner identities for a run that loaded only the invoked blueprint.+owners :: Text -> Maybe (ModuleName, ArtifactOrigin)+owners = ownersFrom [("payments", (blueprintName, blueprintOrigin))]++-- | Owner identities for a run that also loaded the entailed blueprint.+cohortOwners :: Text -> Maybe (ModuleName, ArtifactOrigin)+cohortOwners =+ ownersFrom+ [ ("payments", (blueprintName, blueprintOrigin)),+ ("kiroku-upgrade", (entailedName, entailedOrigin))+ ]++ownersFrom :: [(Text, (ModuleName, ArtifactOrigin))] -> Text -> Maybe (ModuleName, ArtifactOrigin)+ownersFrom table name = lookup name table++first :: BlueprintMigrationStep+first = ownedStep "payments" (migration "1.0.0" "2.0.0")++second :: BlueprintMigrationStep+second = ownedStep "payments" (migration "2.0.0" "3.0.0")++-- | An edge of another blueprint, pulled in by an edge of the invoked one.+entailedStep :: BlueprintMigrationStep+entailedStep =+ BlueprintMigrationStep+ { owner = "kiroku-upgrade",+ edge = migration "1.9.0" "2.0.0",+ entailedBy = Just (EntailmentSite "keiro-upgrade" "2.4.0" "3.0.0")+ }++ownedStep :: Text -> BlueprintMigration -> BlueprintMigrationStep+ownedStep owner edge =+ BlueprintMigrationStep {owner = owner, edge = edge, entailedBy = Nothing}+ migration :: Text -> Text -> BlueprintMigration migration fromVersion toVersion = migrationWithPrompt fromVersion toVersion ("Migrate from " <> fromVersion <> " to " <> toVersion)@@ -174,10 +631,11 @@ BlueprintMigration { from = fromVersion, to = toVersion,- prompt = instructions+ prompt = instructions,+ entails = [] } -plan :: [BlueprintMigration] -> BlueprintMigrationPlan+plan :: [BlueprintMigrationStep] -> BlueprintMigrationPlan plan steps = BlueprintMigrationPlan { name = "payments",@@ -186,13 +644,24 @@ steps = steps } -receipt :: ModuleName -> Text -> Text -> AppliedBlueprintMigration-receipt name fromVersion toVersion =+receipt :: ArtifactOrigin -> ModuleName -> Text -> Text -> AppliedBlueprintMigration+receipt origin name fromVersion toVersion =+ receiptWithOutcome origin name fromVersion toVersion MigrationApplied++-- | A receipt for an edge that reported its precondition unmet.+notApplicableReceipt :: ArtifactOrigin -> ModuleName -> Text -> Text -> Text -> AppliedBlueprintMigration+notApplicableReceipt origin name fromVersion toVersion reason =+ receiptWithOutcome origin name fromVersion toVersion (MigrationNotApplicable reason)++receiptWithOutcome :: ArtifactOrigin -> ModuleName -> Text -> Text -> MigrationOutcome -> AppliedBlueprintMigration+receiptWithOutcome origin name fromVersion toVersion outcome = AppliedBlueprintMigration { name,+ origin, blueprintVersion = Just "4.2.0", fromVersion, toVersion,+ outcome, appliedAt = read "2026-07-20 12:00:00 UTC" :: UTCTime, agentSessionId = Nothing }@@ -203,6 +672,39 @@ Just parsed -> parsed Nothing -> error "test version should parse" +-- | The receipt an inferred @--from@ is read out of.+recordedReceipt :: AppliedBlueprintMigration+recordedReceipt = receipt blueprintOrigin blueprintName "1.0.0" "2.0.0"++-- | What 'highestMigratedVersion' would hand the resolver for that receipt.+recordedResult :: Maybe (Version, AppliedBlueprintMigration)+recordedResult = Just (version "2.0.0", recordedReceipt)++-- | What a successful probe would hand the resolver.+probeResult :: Maybe (Version, Text)+probeResult = Just (version "3.0.0", "cat .library-version")++-- | A resolved window whose values are fixed so a test can vary only where+-- each end came from.+windowWith :: VersionSource -> VersionSource -> ResolvedWindow+windowWith startSource targetSource =+ ResolvedWindow+ { fromVersion = version "2.0.0",+ fromSource = startSource,+ toVersion = version "3.0.0",+ toSource = targetSource+ }++-- | Run one probe against a mocked @sh -c@ result.+runProbe :: (ExitCode, Text, Text) -> VersionProbeResult+runProbe result =+ runPureEff $+ runProcessPure+ [ProcessMock {command = "sh", args = ["-c", probeCommand], result = result}]+ (runVersionProbe probeCommand "/tmp/project")+ where+ probeCommand = "cat .library-version"+ tshow :: (Show a) => a -> Text tshow = T.pack . show @@ -236,8 +738,9 @@ files = [], allowedTools = Nothing, tags = [],- migrations = [first, second],- launch = Nothing+ migrations = [first ^. #edge, second ^. #edge],+ launch = Nothing,+ versionProbe = Nothing } in PreparedBlueprintExecution { blueprint = blueprint,
+ test/Seihou/CLI/InstallCollisionSpec.hs view
@@ -0,0 +1,188 @@+module Seihou.CLI.InstallCollisionSpec (tests) where++import Control.Lens ((^.))+import Data.Generics.Labels ()+import Data.Text qualified as T+import Seihou.CLI.InstallShared+ ( InstallCollision (..),+ InstallOutcome (..),+ OriginInfo (..),+ classifyInstallCollision,+ formatInstallRefusal,+ installModuleDirInto,+ readOriginInfo,+ )+import System.Directory (createDirectoryIfMissing, doesFileExist)+import System.FilePath ((</>))+import System.IO.Temp (withSystemTempDirectory)+import Test.Hspec+import Test.Tasty+import Test.Tasty.Hspec (testSpec)++tests :: IO TestTree+tests = testSpec "Seihou.CLI.InstallCollision" spec++repoOne :: T.Text+repoOne = "https://github.com/acme/one"++repoTwo :: T.Text+repoTwo = "https://github.com/acme/two"++-- | Lay out a directory that looks like an installed artifact: one content+-- file plus the provenance file @seihou install@ writes beside it. A+-- 'Nothing' source means "installed by hand, no provenance", which is a real+-- state a user's cache can be in.+seedInstalled :: FilePath -> Maybe T.Text -> Maybe T.Text -> IO ()+seedInstalled dir mSource mVersion = do+ createDirectoryIfMissing True dir+ writeFile (dir </> "marker.txt") "the copy that was already here"+ case mSource of+ Nothing -> pure ()+ Just source ->+ writeFile (dir </> ".seihou-origin.json") $+ "{\"sourceUrl\":"+ <> show (T.unpack source)+ <> ",\"repoName\":null,\"installedAt\":\"2026-08-16T00:00:00Z\",\"version\":"+ <> maybe "null" (show . T.unpack) mVersion+ <> ",\"tags\":[]}"++-- | The directory an install copies *from*.+seedIncoming :: FilePath -> IO ()+seedIncoming dir = do+ createDirectoryIfMissing True dir+ writeFile (dir </> "incoming.txt") "the copy being installed"++spec :: Spec+spec = do+ describe "classifyInstallCollision" $ do+ it "classifies an absent directory as NoExistingInstall" $+ withSystemTempDirectory "seihou-collision" $ \dir -> do+ collision <- classifyInstallCollision (dir </> "nothing-here") repoOne+ collision `shouldBe` NoExistingInstall++ it "classifies a matching source URL as SameSource, carrying the recorded version" $+ withSystemTempDirectory "seihou-collision" $ \dir -> do+ let installed = dir </> "shared-thing"+ seedInstalled installed (Just repoOne) (Just "0.4.0")+ collision <- classifyInstallCollision installed repoOne+ collision `shouldBe` SameSource (Just "0.4.0")++ -- Two spellings of one git URL are one repository. A user who typed the+ -- .git suffix last week and omitted it today must not be told they have a+ -- different artifact.+ it "treats a trailing .git as the same source" $+ withSystemTempDirectory "seihou-collision" $ \dir -> do+ let installed = dir </> "shared-thing"+ seedInstalled installed (Just (repoOne <> ".git")) Nothing+ collision <- classifyInstallCollision installed repoOne+ collision `shouldBe` SameSource Nothing++ it "treats a trailing slash as the same source" $+ withSystemTempDirectory "seihou-collision" $ \dir -> do+ let installed = dir </> "shared-thing"+ seedInstalled installed (Just (repoOne <> "/")) Nothing+ collision <- classifyInstallCollision installed repoOne+ collision `shouldBe` SameSource Nothing++ it "classifies a different source URL as DifferentSource, carrying the recorded URL" $+ withSystemTempDirectory "seihou-collision" $ \dir -> do+ let installed = dir </> "shared-thing"+ seedInstalled installed (Just repoOne) Nothing+ collision <- classifyInstallCollision installed repoTwo+ collision `shouldBe` DifferentSource repoOne++ it "classifies a directory with no provenance file as UnknownSource" $+ withSystemTempDirectory "seihou-collision" $ \dir -> do+ let installed = dir </> "handmade"+ seedInstalled installed Nothing Nothing+ collision <- classifyInstallCollision installed repoOne+ collision `shouldBe` UnknownSource++ it "classifies an unparseable provenance file as UnknownSource" $+ withSystemTempDirectory "seihou-collision" $ \dir -> do+ let installed = dir </> "corrupt"+ seedInstalled installed Nothing Nothing+ writeFile (installed </> ".seihou-origin.json") "{ this is not valid json"+ collision <- classifyInstallCollision installed repoOne+ collision `shouldBe` UnknownSource++ describe "installModuleDirInto" $ do+ it "installs into an empty cache without comment" $+ withSystemTempDirectory "seihou-collision" $ \dir -> do+ let root = dir </> "installed"+ incoming = dir </> "incoming"+ seedIncoming incoming+ outcome <- installModuleDirInto root False incoming "shared-thing" repoOne Nothing (Just "1.0.0") []+ outcome `shouldBe` InstallPerformed+ doesFileExist (root </> "shared-thing" </> "incoming.txt") `shouldReturn` True+ recorded <- readOriginInfo (root </> "shared-thing")+ fmap (^. #sourceUrl) recorded `shouldBe` Just repoOne++ it "replaces an installation from the same source" $+ withSystemTempDirectory "seihou-collision" $ \dir -> do+ let root = dir </> "installed"+ incoming = dir </> "incoming"+ seedInstalled (root </> "shared-thing") (Just repoOne) (Just "0.4.0")+ seedIncoming incoming+ outcome <- installModuleDirInto root False incoming "shared-thing" repoOne Nothing (Just "0.5.0") []+ outcome `shouldBe` InstallPerformed+ doesFileExist (root </> "shared-thing" </> "incoming.txt") `shouldReturn` True+ doesFileExist (root </> "shared-thing" </> "marker.txt") `shouldReturn` False++ -- The property that matters: the refusal happens before anything is+ -- removed, so a refused install leaves the cache exactly as it was. The+ -- marker file is the evidence.+ it "refuses a different source and leaves the existing installation untouched" $+ withSystemTempDirectory "seihou-collision" $ \dir -> do+ let root = dir </> "installed"+ incoming = dir </> "incoming"+ seedInstalled (root </> "shared-thing") (Just repoOne) Nothing+ seedIncoming incoming+ outcome <- installModuleDirInto root False incoming "shared-thing" repoTwo Nothing Nothing []+ outcome `shouldBe` InstallRefused (DifferentSource repoOne)+ readFile (root </> "shared-thing" </> "marker.txt")+ `shouldReturn` "the copy that was already here"+ doesFileExist (root </> "shared-thing" </> "incoming.txt") `shouldReturn` False+ recorded <- readOriginInfo (root </> "shared-thing")+ fmap (^. #sourceUrl) recorded `shouldBe` Just repoOne++ it "refuses an installation with no provenance and leaves it untouched" $+ withSystemTempDirectory "seihou-collision" $ \dir -> do+ let root = dir </> "installed"+ incoming = dir </> "incoming"+ seedInstalled (root </> "handmade") Nothing Nothing+ seedIncoming incoming+ outcome <- installModuleDirInto root False incoming "handmade" repoOne Nothing Nothing []+ outcome `shouldBe` InstallRefused UnknownSource+ readFile (root </> "handmade" </> "marker.txt")+ `shouldReturn` "the copy that was already here"++ it "replaces a different source when force is passed" $+ withSystemTempDirectory "seihou-collision" $ \dir -> do+ let root = dir </> "installed"+ incoming = dir </> "incoming"+ seedInstalled (root </> "shared-thing") (Just repoOne) Nothing+ seedIncoming incoming+ outcome <- installModuleDirInto root True incoming "shared-thing" repoTwo Nothing Nothing []+ outcome `shouldBe` InstallPerformed+ doesFileExist (root </> "shared-thing" </> "incoming.txt") `shouldReturn` True+ doesFileExist (root </> "shared-thing" </> "marker.txt") `shouldReturn` False+ recorded <- readOriginInfo (root </> "shared-thing")+ fmap (^. #sourceUrl) recorded `shouldBe` Just repoTwo++ describe "formatInstallRefusal" $ do+ it "names both sources and the override flag" $ do+ let rendered = formatInstallRefusal "shared-thing" repoTwo (DifferentSource repoOne)+ rendered `shouldSatisfy` T.isInfixOf repoOne+ rendered `shouldSatisfy` T.isInfixOf repoTwo+ rendered `shouldSatisfy` T.isInfixOf "--force"+ rendered `shouldSatisfy` T.isInfixOf "shared-thing"++ it "says provenance is missing rather than naming a recorded URL" $ do+ let rendered = formatInstallRefusal "handmade" repoOne UnknownSource+ rendered `shouldSatisfy` T.isInfixOf "no .seihou-origin.json"+ rendered `shouldSatisfy` T.isInfixOf "--force"++ it "has nothing to say about a case that is not refused" $ do+ formatInstallRefusal "shared-thing" repoOne NoExistingInstall `shouldBe` ""+ formatInstallRefusal "shared-thing" repoOne (SameSource (Just "1.0.0")) `shouldBe` ""
test/Seihou/CLI/StatusSpec.hs view
@@ -29,6 +29,7 @@ AppliedTarget (..), ArtifactOrigin (..), Manifest (..),+ MigrationOutcome (..), ModuleName (..), RecipeName (..), emptyParentVars,@@ -125,6 +126,7 @@ mkBlueprint name mver baselines noBL prompt = AppliedBlueprint { name = ModuleName name,+ origin = RemoteOrigin ("https://github.com/acme/" <> name) name Nothing, blueprintVersion = mver, appliedAt = fixedTime, baselineModules = map ModuleName baselines,@@ -138,11 +140,18 @@ mkBlueprintMigrationReceipt :: Text -> Maybe Text -> Text -> Text -> AppliedBlueprintMigration mkBlueprintMigrationReceipt blueprintName artifactVersion fromVersion toVersion =+ mkBlueprintMigrationReceiptWith blueprintName artifactVersion fromVersion toVersion MigrationApplied++mkBlueprintMigrationReceiptWith ::+ Text -> Maybe Text -> Text -> Text -> MigrationOutcome -> AppliedBlueprintMigration+mkBlueprintMigrationReceiptWith blueprintName artifactVersion fromVersion toVersion outcome = AppliedBlueprintMigration { name = ModuleName blueprintName,+ origin = RemoteOrigin ("https://github.com/acme/" <> blueprintName) blueprintName Nothing, blueprintVersion = artifactVersion, fromVersion = fromVersion, toVersion = toVersion,+ outcome = outcome, appliedAt = fixedTime, agentSessionId = Nothing }@@ -221,8 +230,39 @@ manifest = ((mkManifest []) & #blueprintMigrations .~ [receipt]) out = formatStatus False manifest [] Nothing [] out `shouldSatisfy` T.isInfixOf "Blueprint migrations:"- out `shouldSatisfy` T.isInfixOf "payments v0.4.0: 1.0.0 -> 2.0.0"- out `shouldSatisfy` T.isInfixOf "2026-04-15 10:00 UTC"+ out `shouldSatisfy` T.isInfixOf "payments v0.4.0: 1.0.0 -> 2.0.0 (applied 2026-04-15 10:00 UTC)"++ -- What IR-1 means by "keeps seihou status honest": an edge that was+ -- evaluated and found inapplicable must not look like an upgrade.+ it "distinguishes a not-applicable receipt and shows its reason" $ do+ let applied = mkBlueprintMigrationReceipt "payments" (Just "0.4.0") "1.0.0" "2.0.0"+ skipped =+ mkBlueprintMigrationReceiptWith+ "payments"+ (Just "0.4.0")+ "2.5.0"+ "3.0.0"+ (MigrationNotApplicable "no direct kiroku imports")+ manifest = ((mkManifest []) & #blueprintMigrations .~ [applied, skipped])+ out = formatStatus False manifest [] Nothing []+ out `shouldSatisfy` T.isInfixOf "payments v0.4.0: 1.0.0 -> 2.0.0 (applied 2026-04-15 10:00 UTC)"+ out+ `shouldSatisfy` T.isInfixOf+ "payments v0.4.0: 2.5.0 -> 3.0.0 (not applicable 2026-04-15 10:00 UTC -- no direct kiroku imports)"++ it "truncates a long reason rather than wrapping it" $ do+ let skipped =+ mkBlueprintMigrationReceiptWith+ "payments"+ Nothing+ "1.0.0"+ "2.0.0"+ (MigrationNotApplicable (T.replicate 200 "x"))+ manifest = ((mkManifest []) & #blueprintMigrations .~ [skipped])+ out = formatStatus False manifest [] Nothing []+ migrationLine = head [line | line <- T.lines out, "1.0.0 -> 2.0.0" `T.isInfixOf` line]+ migrationLine `shouldSatisfy` T.isInfixOf (T.replicate 59 "x" <> "…")+ migrationLine `shouldNotSatisfy` T.isInfixOf (T.replicate 61 "x") it "all modules clean: no remediation, no Recommended actions block" $ do let am = mkApplied "demo" (Just "1.0.0")
test/Seihou/CLI/UpdateSpec.hs view
@@ -526,7 +526,7 @@ vars = Map.empty, files = Map.empty, applications = [app],- recipe = Just (AppliedRecipe "stack" (Just "1.0.0") testTime),+ recipe = Just (AppliedRecipe "stack" (remoteOrigin "stack") (Just "1.0.0") testTime), blueprint = Nothing, blueprintMigrations = [] }