diff --git a/data/blueprint-migration-prompt.md b/data/blueprint-migration-prompt.md --- a/data/blueprint-migration-prompt.md +++ b/data/blueprint-migration-prompt.md @@ -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 + +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. diff --git a/help/agent.md b/help/agent.md --- a/help/agent.md +++ b/help/agent.md @@ -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 diff --git a/seihou-cli.cabal b/seihou-cli.cabal --- a/seihou-cli.cabal +++ b/seihou-cli.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: seihou-cli -version: 0.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, diff --git a/src-exe/Seihou/CLI/AgentMigrate.hs b/src-exe/Seihou/CLI/AgentMigrate.hs --- a/src-exe/Seihou/CLI/AgentMigrate.hs +++ b/src-exe/Seihou/CLI/AgentMigrate.hs @@ -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 --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." diff --git a/src-exe/Seihou/CLI/AgentRun.hs b/src-exe/Seihou/CLI/AgentRun.hs --- a/src-exe/Seihou/CLI/AgentRun.hs +++ b/src-exe/Seihou/CLI/AgentRun.hs @@ -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. diff --git a/src-exe/Seihou/CLI/Commands.hs b/src-exe/Seihou/CLI/Commands.hs --- a/src-exe/Seihou/CLI/Commands.hs +++ b/src-exe/Seihou/CLI/Commands.hs @@ -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 = diff --git a/src-exe/Seihou/CLI/Install.hs b/src-exe/Seihou/CLI/Install.hs --- a/src-exe/Seihou/CLI/Install.hs +++ b/src-exe/Seihou/CLI/Install.hs @@ -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) diff --git a/src-exe/Seihou/CLI/Run.hs b/src-exe/Seihou/CLI/Run.hs --- a/src-exe/Seihou/CLI/Run.hs +++ b/src-exe/Seihou/CLI/Run.hs @@ -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. -- diff --git a/src-exe/Seihou/CLI/Status.hs b/src-exe/Seihou/CLI/Status.hs --- a/src-exe/Seihou/CLI/Status.hs +++ b/src-exe/Seihou/CLI/Status.hs @@ -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) diff --git a/src-exe/Seihou/CLI/Upgrade.hs b/src-exe/Seihou/CLI/Upgrade.hs --- a/src-exe/Seihou/CLI/Upgrade.hs +++ b/src-exe/Seihou/CLI/Upgrade.hs @@ -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 diff --git a/src/Seihou/CLI/AgentGuard.hs b/src/Seihou/CLI/AgentGuard.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/CLI/AgentGuard.hs @@ -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)) diff --git a/src/Seihou/CLI/BlueprintMigration.hs b/src/Seihou/CLI/BlueprintMigration.hs --- a/src/Seihou/CLI/BlueprintMigration.hs +++ b/src/Seihou/CLI/BlueprintMigration.hs @@ -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 \@ 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 diff --git a/src/Seihou/CLI/InstallShared.hs b/src/Seihou/CLI/InstallShared.hs --- a/src/Seihou/CLI/InstallShared.hs +++ b/src/Seihou/CLI/InstallShared.hs @@ -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/@, --- 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\/@ 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 () diff --git a/src/Seihou/CLI/ManifestGuard.hs b/src/Seihou/CLI/ManifestGuard.hs --- a/src/Seihou/CLI/ManifestGuard.hs +++ b/src/Seihou/CLI/ManifestGuard.hs @@ -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 diff --git a/src/Seihou/CLI/Migrate.hs b/src/Seihou/CLI/Migrate.hs --- a/src/Seihou/CLI/Migrate.hs +++ b/src/Seihou/CLI/Migrate.hs @@ -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) diff --git a/src/Seihou/CLI/MigrationCohort.hs b/src/Seihou/CLI/MigrationCohort.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/CLI/MigrationCohort.hs @@ -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) diff --git a/src/Seihou/CLI/SchemaVersion.hs b/src/Seihou/CLI/SchemaVersion.hs --- a/src/Seihou/CLI/SchemaVersion.hs +++ b/src/Seihou/CLI/SchemaVersion.hs @@ -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 diff --git a/src/Seihou/CLI/StatusRender.hs b/src/Seihou/CLI/StatusRender.hs --- a/src/Seihou/CLI/StatusRender.hs +++ b/src/Seihou/CLI/StatusRender.hs @@ -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 diff --git a/src/Seihou/CLI/Update.hs b/src/Seihou/CLI/Update.hs --- a/src/Seihou/CLI/Update.hs +++ b/src/Seihou/CLI/Update.hs @@ -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 ()) diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -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, diff --git a/test/Seihou/CLI/AgentGuardE2ESpec.hs b/test/Seihou/CLI/AgentGuardE2ESpec.hs new file mode 100644 --- /dev/null +++ b/test/Seihou/CLI/AgentGuardE2ESpec.hs @@ -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 @\\/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 <> "\"}" diff --git a/test/Seihou/CLI/AgentLaunchSpec.hs b/test/Seihou/CLI/AgentLaunchSpec.hs --- a/test/Seihou/CLI/AgentLaunchSpec.hs +++ b/test/Seihou/CLI/AgentLaunchSpec.hs @@ -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")) diff --git a/test/Seihou/CLI/AgentMigrateE2ESpec.hs b/test/Seihou/CLI/AgentMigrateE2ESpec.hs --- a/test/Seihou/CLI/AgentMigrateE2ESpec.hs +++ b/test/Seihou/CLI/AgentMigrateE2ESpec.hs @@ -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 --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 -> diff --git a/test/Seihou/CLI/AppliedBlueprintMigrationSpec.hs b/test/Seihou/CLI/AppliedBlueprintMigrationSpec.hs --- a/test/Seihou/CLI/AppliedBlueprintMigrationSpec.hs +++ b/test/Seihou/CLI/AppliedBlueprintMigrationSpec.hs @@ -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] diff --git a/test/Seihou/CLI/AppliedBlueprintSpec.hs b/test/Seihou/CLI/AppliedBlueprintSpec.hs --- a/test/Seihou/CLI/AppliedBlueprintSpec.hs +++ b/test/Seihou/CLI/AppliedBlueprintSpec.hs @@ -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") diff --git a/test/Seihou/CLI/BlueprintMigrationSpec.hs b/test/Seihou/CLI/BlueprintMigrationSpec.hs --- a/test/Seihou/CLI/BlueprintMigrationSpec.hs +++ b/test/Seihou/CLI/BlueprintMigrationSpec.hs @@ -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, diff --git a/test/Seihou/CLI/InstallCollisionSpec.hs b/test/Seihou/CLI/InstallCollisionSpec.hs new file mode 100644 --- /dev/null +++ b/test/Seihou/CLI/InstallCollisionSpec.hs @@ -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` "" diff --git a/test/Seihou/CLI/StatusSpec.hs b/test/Seihou/CLI/StatusSpec.hs --- a/test/Seihou/CLI/StatusSpec.hs +++ b/test/Seihou/CLI/StatusSpec.hs @@ -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") diff --git a/test/Seihou/CLI/UpdateSpec.hs b/test/Seihou/CLI/UpdateSpec.hs --- a/test/Seihou/CLI/UpdateSpec.hs +++ b/test/Seihou/CLI/UpdateSpec.hs @@ -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 = [] }