seihou-cli 0.13.0.0 → 0.14.0.0
raw patch · 37 files changed
+1550/−383 lines, 37 filesdep +transformersdep ~seihou-corePVP ok
version bump matches the API change (PVP)
Dependencies added: transformers
Dependency ranges changed: seihou-core
API changes (from Hackage documentation)
+ Seihou.CLI.InstallClosure: ClosureArtifact :: !Text -> !Text -> !Maybe Text -> !Maybe Text -> ![Text] -> !Maybe Text -> !FilePath -> ClosureArtifact
+ Seihou.CLI.InstallClosure: [directory] :: ClosureArtifact -> !FilePath
+ Seihou.CLI.InstallClosure: [name] :: ClosureArtifact -> !Text
+ Seihou.CLI.InstallClosure: [repoName] :: ClosureArtifact -> !Maybe Text
+ Seihou.CLI.InstallClosure: [sourceRevision] :: ClosureArtifact -> !Maybe Text
+ Seihou.CLI.InstallClosure: [sourceUrl] :: ClosureArtifact -> !Text
+ Seihou.CLI.InstallClosure: [tags] :: ClosureArtifact -> ![Text]
+ Seihou.CLI.InstallClosure: [version] :: ClosureArtifact -> !Maybe Text
+ Seihou.CLI.InstallClosure: data ClosureArtifact
+ Seihou.CLI.InstallClosure: instance GHC.Classes.Eq Seihou.CLI.InstallClosure.ClosureArtifact
+ Seihou.CLI.InstallClosure: instance GHC.Internal.Generics.Generic Seihou.CLI.InstallClosure.ClosureArtifact
+ Seihou.CLI.InstallClosure: instance GHC.Internal.Show.Show Seihou.CLI.InstallClosure.ClosureArtifact
+ Seihou.CLI.InstallClosure: normalizePayload :: FilePath -> FilePath -> FilePath -> IO ()
+ Seihou.CLI.InstallClosure: publishStagedClosure :: FilePath -> [ClosureArtifact] -> IO (Either Text ())
+ Seihou.CLI.InstallClosure: stageClosuresInto :: Bool -> FilePath -> Bool -> [(FilePath, Text, [(Text, FilePath)])] -> IO (Either Text [ClosureArtifact])
+ Seihou.CLI.InstallClosure: writeStagedText :: FilePath -> Text -> IO ()
+ Seihou.CLI.ManifestCapabilityUpgrade: prepareRecipeInheritance :: Manifest -> Either Text Manifest
+ Seihou.CLI.ManifestGuard: checkRecipeChain :: ApplicationId -> [AppliedRecipeNode] -> Manifest -> ([ArtifactCheck], [Text])
+ Seihou.CLI.Update: [cacheChanges] :: UpdatePlan -> ![Text]
+ Seihou.CLI.Update: instance GHC.Internal.Generics.Generic Seihou.CLI.Update.CandidateRoot
+ Seihou.CLI.Update.Types: [cacheChanges] :: UpdatePlan -> ![Text]
- Seihou.CLI.Update: UpdatePlan :: ![AppliedComposition] -> ![VersionChange] -> !InputChangeSummary -> ![PlannedUpdateMigration] -> !ReconciliationPlan -> !CheckoutPlan -> !Map FilePath CheckoutOutputRecord -> !Map FilePath Text -> !CommandPlan -> ![CandidateArtifact] -> ![UpdateWarning] -> !UpdateRequest -> !UpdateSnapshot -> ![PlannedApplication] -> !Maybe ManifestPreparation -> UpdatePlan
+ Seihou.CLI.Update: UpdatePlan :: ![AppliedComposition] -> ![VersionChange] -> !InputChangeSummary -> ![PlannedUpdateMigration] -> !ReconciliationPlan -> !CheckoutPlan -> !Map FilePath CheckoutOutputRecord -> !Map FilePath Text -> !CommandPlan -> ![CandidateArtifact] -> ![Text] -> ![UpdateWarning] -> !UpdateRequest -> !UpdateSnapshot -> ![PlannedApplication] -> !Maybe ManifestPreparation -> UpdatePlan
- Seihou.CLI.Update.Types: UpdatePlan :: ![AppliedComposition] -> ![VersionChange] -> !InputChangeSummary -> ![PlannedUpdateMigration] -> !ReconciliationPlan -> !CheckoutPlan -> !Map FilePath CheckoutOutputRecord -> !Map FilePath Text -> !CommandPlan -> ![CandidateArtifact] -> ![UpdateWarning] -> !UpdateRequest -> !UpdateSnapshot -> ![PlannedApplication] -> !Maybe ManifestPreparation -> UpdatePlan
+ Seihou.CLI.Update.Types: UpdatePlan :: ![AppliedComposition] -> ![VersionChange] -> !InputChangeSummary -> ![PlannedUpdateMigration] -> !ReconciliationPlan -> !CheckoutPlan -> !Map FilePath CheckoutOutputRecord -> !Map FilePath Text -> !CommandPlan -> ![CandidateArtifact] -> ![Text] -> ![UpdateWarning] -> !UpdateRequest -> !UpdateSnapshot -> ![PlannedApplication] -> !Maybe ManifestPreparation -> UpdatePlan
Files
- data/module-reference.md +27/−0
- data/setup-prompt.md +2/−2
- data/upgrade-prompt.md +9/−1
- help/blueprints.md +4/−3
- help/manifest.md +12/−1
- help/recipes.md +43/−1
- help/registry.md +7/−1
- help/update.md +16/−1
- help/variables.md +6/−0
- seihou-cli.cabal +6/−4
- src-exe/Seihou/CLI/Commands.hs +6/−6
- src-exe/Seihou/CLI/NewRecipe.hs +3/−1
- src-exe/Seihou/CLI/Run.hs +85/−57
- src-exe/Seihou/CLI/Upgrade.hs +89/−48
- src-exe/Seihou/CLI/ValidateRecipe.hs +5/−1
- src-exe/Seihou/CLI/Vars.hs +40/−23
- src/Seihou/CLI/InstallClosure.hs +171/−51
- src/Seihou/CLI/ManifestCapabilityUpgrade.hs +9/−0
- src/Seihou/CLI/ManifestGuard.hs +43/−3
- src/Seihou/CLI/SchemaVersion.hs +2/−2
- src/Seihou/CLI/Update.hs +206/−143
- src/Seihou/CLI/Update/Render.hs +33/−1
- src/Seihou/CLI/Update/Source.hs +101/−4
- src/Seihou/CLI/Update/Types.hs +3/−0
- test/Main.hs +3/−1
- test/Seihou/CLI/InstallClosureSpec.hs +115/−1
- test/Seihou/CLI/ManifestCapabilityUpgradeSpec.hs +3/−2
- test/Seihou/CLI/ManifestGuardSpec.hs +29/−4
- test/Seihou/CLI/ManifestRepairOriginsSpec.hs +2/−1
- test/Seihou/CLI/ManifestUpgradeSpec.hs +8/−8
- test/Seihou/CLI/RecipeExtensionE2ESpec.hs +429/−0
- test/Seihou/CLI/StatusSpec.hs +2/−1
- test/Seihou/CLI/UpdateE2ESpec.hs +4/−4
- test/Seihou/CLI/UpdateFixture.hs +1/−0
- test/Seihou/CLI/UpdateSpec.hs +7/−4
- test/Seihou/CLI/UpgradeDiagnosisSpec.hs +3/−3
- test/Seihou/CLI/ValidateRecipeE2ESpec.hs +16/−0
data/module-reference.md view
@@ -193,3 +193,30 @@ Recipe and blueprint producers using camelCase bindings or relying on POSIX pattern enforcement require Seihou 0.13.0.0 or newer. Older runtimes can reject those binding names or silently accept patterns they do not recognize.++### Single-base recipe inheritance++A recipe may declare `extends = Some { recipe = "base-recipe", source = Some+"GIT-URL", versionRange = Some { minimum = "1", before = "2" } }`. Source and+range are optional; absent source means the declaring registry on install. Follow+the base chain oldest first, retaining its first member as primary; children+append members or keep modules empty for settings-only specialization.+Use moduleOverrides for inherited literal keys, promptOverrides for replacing+inherited questions in place. Identical member repeats deduplicate; conflicts+fail. Bindings remain global by variable name: child literals outrank ancestors+and saved inputs, CLI still wins, defaults remain fallbacks. Inherited declaration+type, requiredness and validation must agree. Errors preserve recipe/origin.++Install/update acquire the full candidate closure and validate source/range+requirements before publication; run remains offline. Ordinary update handles+base-only metadata, fresh-clone cache restoration and unknown-history adoption,+reuses saved answers and optional omissions, and skips unchanged commands.+Schema 13 records ordered chain names/origins/versions/descriptor hashes; null+means unknown prior history. Neither a historical base nor dropped member is a+mandatory fetch unless independently needed by migration/baseline work. Cache-only+`seihou upgrade RECIPE` includes bases and recommends `seihou update RECIPE`.+Never repair routine adoption by hand-editing the manifest or installing members+individually. See `seihou help recipes` for the complete shape and recovery.++Recipe inheritance producers require Seihou 0.14.0.0 or newer. Update the runtime+before adopting descriptors that use `extends` or inherited overrides.
data/setup-prompt.md view
@@ -38,7 +38,7 @@ 2. **Discover**: Check available runnables (`seihou list`). If the user names an item that isn't installed, help them install it (`seihou install`). Browse remote repositories if needed (`seihou browse`). Installing a selected recipe acquires- its required module closure, including declared external registry sources; no+ its inherited-base and required module closure, including declared external registry sources; no transitive module list is needed. Reinstall repairs incomplete old installations. 3. **Understand**: Show the module's variables (`seihou vars MODULE`) so the user@@ -143,7 +143,7 @@ - `seihou manifest upgrade [--dry-run]` — explicitly convert older manifest schemas - `seihou manifest repair-origins [--dry-run] [--set NAME=URL]` — repair machine-local recorded origins - `seihou outdated` — inspect installed copies against their sources-- `seihou upgrade [MODULE] [--dry-run]` — deliberate installed-cache maintenance+- `seihou upgrade [MODULE_OR_RECIPE] [--dry-run]` — deliberate installed-cache maintenance - `seihou migrate MODULE [--dry-run] [--to VERSION]` — lower-level migration control - See `seihou help update`, `seihou help sync`, and `seihou help manifest`.
data/upgrade-prompt.md view
@@ -254,7 +254,7 @@ - Never lower a recorded version. - Never pass `--force` or `--allow-downgrade` without the user's agreement. - Never change anything under `~/.config/seihou/installed/` except through- `seihou install` and `seihou upgrade`.+ `seihou install`, `seihou upgrade`, and accepted `seihou update`. - After any manual edit, run `seihou status`, `seihou manifest upgrade --dry-run`, and `seihou agent upgrade {{module}} --check`. - Blueprint migrations (`seihou agent migrate`) are a different mechanism,@@ -273,3 +273,11 @@ command could not express the fix, so the maintainers know what to automate next; - the final `Upgrade readiness` line.++For derived recipes, diagnose the selected root and its full candidate base/member+closure. Recipe-chain provenance is application-scoped in schema 13; null older+history is adopted through ordinary update. Base-only changes can be actionable+with no file or command change. Never prescribe fetching a removed historical+base merely to preserve old chain evidence, enumerate transitive selectors, or+waive producer source/version intervals with --allow-downgrade. Normal update+restores a fresh clone cache and reuses saved inputs and optional omissions.
help/blueprints.md view
@@ -36,7 +36,7 @@ prompt Required prompt body. Usually `./prompt.md as Text`. vars Variables resolved before the prompt is rendered. prompts Interactive questions for missing required variables.- baseModules Modules or recipes to apply before the agent runs.+ baseModules Modules to apply before the agent runs. files Reference files under the blueprint's files/ directory. allowedTools Extra tools to pre-approve in addition to the base set. tags Optional discovery tags.@@ -74,7 +74,8 @@ , vars = [ { name = "project.name", value = "demo" } ] } - Base modules must resolve to modules or recipes, not other blueprints. The+ Use actual modules in baseModules. Named recipes run separately through+ `seihou run`; they are not executable blueprint baselines. The agent runner records the applied blueprint in `.seihou/manifest.json` after a successful run, including baseline provenance. @@ -175,7 +176,7 @@ - the prompt body is non-empty - variables are unique - prompts reference declared variables- - baseModules resolve to modules or recipes+ - baseModules targets are discoverable; executable baselines use modules - declared reference files exist under files/ - migrations have dotted forward versions, unique starts, and non-empty prompts
help/manifest.md view
@@ -64,8 +64,9 @@ 9 -> 10 repeatable checkout commands 10 -> 11 precise seed ownership claims 11 -> 12 recipe inputs+ 12 -> 13 unknown recipe-chain history - ✓ Upgraded .seihou/manifest.json to schema version 12.+ ✓ Upgraded .seihou/manifest.json to schema version 13. Review the diff and commit it: git diff .seihou/manifest.json Running it on a manifest that is already current reports that there is@@ -153,3 +154,13 @@ seihou help migrations moving a project between module versions seihou manifest upgrade -h the full flag reference seihou manifest repair-origins -h++RECIPE INHERITANCE++ Schema 13 adds recipeChain to each application: ordered oldest-first nodes with+ recipe name, portable origin, declared version and normalized descriptor hash.+ Null means unknown older history; module applications record an empty array.+ Accepted run/update records the resolved chain. Preview and decline preserve+ the old manifest. Metadata-only base changes need acceptance, and unchanged+ application command receipts remain valid. Use the normal recipe update to+ adopt unknown history; no manual manifest editing is required.
help/recipes.md view
@@ -63,7 +63,7 @@ ## Installing required modules `seihou install SOURCE --module RECIPE` installs the selected recipe and its complete-module dependency closure, including external registries declared with+recipe-base and module dependency closure, including external registries declared with `source = Some "GIT-URL"`. Then use `seihou run RECIPE` with ordinary recipe inputs. A missing source means the declaring registry during install. Reinstalling repairs older incomplete installs. Run and dry-run use local modules and never fetch.@@ -116,3 +116,45 @@ even on absent optional inputs. Recipe and consumer constraints apply independently to every selected source; errors name the original source and a supported correction before generation or commands. Ordinary update revalidates saved inputs.++## Extending a recipe++Declare one `extends = Some { recipe = "base-recipe", source = Some "GIT-URL",+versionRange = Some { minimum = "1.0.0", before = "2.0.0" } }`. Source and range+are optional. A missing source means the declaring registry during install.+Acquisition validates the version at default-branch HEAD, without searching tags.+The lower interval bound is inclusive; the upper bound is exclusive.++Expand oldest base first; append child members. The oldest first member stays+primary. A root needs members; a derived recipe may have `modules = [] : List Text`+for settings-only specialization. Identical repeated members from the same origin+are deduplicated. Conflicting origins or repeated bindings fail.++Use `moduleOverrides = [{ module = "git-init", vars =+[{ name = "git.githubOwner", value = "shinzui" }] }]` to change literal keys on+exactly one inherited member. Unmentioned keys survive; no extra instance runs.+Literals use global variable names: nearest child wins across layers. Unequal+values within one layer of an extended chain fail. CLI still wins; constraints+still apply. A child default cannot defeat an inherited literal.++Inherited variable type, requiredness and validation must agree. A child's supplied+default/description wins; None retains the inherited value. Questions keep their+order: identical repeats deduplicate; `promptOverrides` explicitly replaces an+inherited question in place; new questions append. Merged validation proves+inherited references. Descriptor-only validation needs no installed base.++Install the derived root once, then run it offline. Retry that same install to+repair missing cached entries. Ordinary `seihou update RECIPE` fetches the current+closure, includes base-only changes, restores an empty cache in fresh clones and+reuses saved choices, including omitted optional answers. `--reconfigure` revisits+them. Producer source/range requirements cannot be bypassed with --allow-downgrade.++Schema 13 records the ordered recipe chain with portable origins, versions and+normalized descriptor hashes. Unknown older history is adopted visibly through+ordinary accepted run/update. Base substitution/downgrade is guarded; compatible+base or descriptor-only changes appear in preview. A metadata-only update keeps+unchanged commands skipped. `seihou upgrade RECIPE` refreshes only the cache and+recommends the corresponding project update; --dry-run never publishes.++Recipe inheritance producers require Seihou 0.14.0.0 or newer. Update the runtime+before adopting descriptors that use `extends` or inherited overrides.
help/registry.md view
@@ -41,7 +41,7 @@ ## Installing required modules `seihou install SOURCE --module RECIPE` installs the selected recipe and its complete-module dependency closure, including external registries declared with+inherited-base and module dependency closure, including external registries declared with `source = Some "GIT-URL"`. Then use `seihou run RECIPE` with ordinary recipe inputs. A missing source means the declaring registry during install. Reinstalling repairs older incomplete installs. Run and dry-run use local modules and never fetch.@@ -50,3 +50,9 @@ entry and retry the same command. Existing foreign cache entries require an informed `--force`; contradictory sources within one closure always fail. A local shadow must have verifiable matching provenance for an explicit source requirement.++Recipes can declare one base with `extends`, including an explicit Git source and+optional numeric version interval. Install validates the whole candidate closure+before publication. Use `seihou help recipes` for overrides and authoring rules.+`seihou upgrade RECIPE` refreshes its full cache closure, including unchanged+children with changed bases; project reconciliation uses `seihou update RECIPE`.
help/update.md view
@@ -93,7 +93,7 @@ Recipe applications also reuse recorded recipe inputs before member variables. Inputs used only by conditions survive fresh clones. Ordinary preview prepares- schema 12 as needed and adopts agreeing historical values; conflicting or newly+ schema 13 as needed and adopts agreeing historical values; conflicting or newly required choices need --var KEY=VALUE or --reconfigure. Recipe-only changes are recorded even when no generated file changes. @@ -189,3 +189,18 @@ Last-claim retirement keeps disk contents. Reverse seed-to-managed adoption requires an explicit interactive keep/accept choice; --force/JSON cannot consent. Declarative migrations cannot touch seeds. Arbitrary shell is unsandboxed.++RECIPE BASES++ Update fetches the candidate recipe, inherited bases and transitive members,+ including new source registries. Removed bases are not required fetches solely+ because they occur in history. Fresh clones restore missing cache entries in+ the ordinary preview/confirmation flow. Saved optional omissions are preserved;+ --reconfigure revisits them.++ Base version, source, chain and descriptor changes appear in preview even when+ target version and generated bytes agree. Metadata-only acceptance preserves+ unchanged command receipts. JSON schemaVersion 1 adds recipeChains (previous+ and candidate node arrays, applicationId, adopted) and cacheChanges (names).+ The arrays are empty when unchanged. Producer source/range checks cannot be+ waived by --allow-downgrade.
help/variables.md view
@@ -84,3 +84,9 @@ even on absent optional inputs. Recipe and consumer constraints apply independently to every selected source; errors name the original source and a supported correction before generation or commands. Ordinary update revalidates saved inputs.++Inherited recipe inputs merge before resolution. Nearest child literals override+ancestor literals globally; defaults remain fallbacks. Explicit moduleOverrides+change inherited keys without adding instances. Declarations retain inherited+type, requiredness and validation. Literal errors name their recipe and origin.+See `seihou help recipes` for the complete extension rules.
seihou-cli.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.0 name: seihou-cli-version: 0.13.0.0+version: 0.14.0.0 synopsis: CLI for Seihou project scaffolding description: Command-line interface for Seihou, a composable project scaffolding@@ -144,11 +144,12 @@ generic-lens >=2.2 && <3, lens >=5.2 && <6, process >=1.6 && <2,- seihou-core ^>=0.13.0.0,+ seihou-core ^>=0.14.0.0, streamly-core >=0.3 && <0.5, temporary >=1.3 && <2, text >=2.0 && <3, time >=1.12 && <2,+ transformers >=0.6 && <0.7, vector ^>=0.13.2.0, executable seihou@@ -232,7 +233,7 @@ optparse-applicative >=0.18 && <1, process >=1.6 && <2, seihou-cli-internal,- seihou-core ^>=0.13.0.0,+ seihou-core ^>=0.14.0.0, temporary >=1.3 && <2, text >=2.0 && <3, time >=1.12 && <2,@@ -286,6 +287,7 @@ Seihou.CLI.MigrateSpec Seihou.CLI.PendingMigrationSpec Seihou.CLI.PromptRenderSpec+ Seihou.CLI.RecipeExtensionE2ESpec Seihou.CLI.RecipeInputsE2ESpec Seihou.CLI.RecordedReleaseSpec Seihou.CLI.Registry.SyncSpec@@ -328,7 +330,7 @@ lens >=5.2 && <6, process >=1.6 && <2, seihou-cli-internal,- seihou-core ^>=0.13.0.0,+ seihou-core ^>=0.14.0.0, streamly-core >=0.3 && <0.5, tasty >=1.4 && <2, tasty-hspec >=1.2 && <2,
src-exe/Seihou/CLI/Commands.hs view
@@ -1344,10 +1344,10 @@ upgradeParser = fmap Upgrade $ UpgradeOpts- <$> many (argument (T.pack <$> str) (metavar "MODULE" <> help "Module(s) to upgrade (default: all)"))+ <$> many (argument (T.pack <$> str) (metavar "MODULE_OR_RECIPE" <> help "Modules or recipes to upgrade (default: all)")) <*> switch (long "dry-run" <> help "Show what would be upgraded without making changes") <*> switch (long "json" <> help "Output as JSON")- <*> switch (long "skip-unversioned" <> help "Skip modules without version information")+ <*> switch (long "skip-unversioned" <> help "Skip unversioned changes (keeps recipe closures together)") <*> switch ( long "with-migrations" <> help "After each upgrade, also run 'seihou migrate' against the current project for that module"@@ -1356,14 +1356,14 @@ upgradeFooter :: Doc upgradeFooter = vsep- [ pretty ("Refreshes installed-cache modules to the latest version available from their" :: String),- pretty ("source repository. Only modules installed via 'seihou install' are checked." :: String),+ [ pretty ("Refreshes installed modules and recipe closures from their" :: String),+ pretty ("source repositories. Only artifacts installed via 'seihou install' are checked." :: String), pretty ("It does not reconcile the current project; use 'seihou update' for that." :: String), pretty ("Modules without version information are upgraded by default." :: String), pretty ("Use --skip-unversioned to skip them." :: String), line,- pretty ("With no arguments, checks all installed modules. Pass module names to" :: String),- pretty ("upgrade specific modules only." :: String),+ pretty ("With no arguments, checks all installed modules and recipes. Pass names to" :: String),+ pretty ("upgrade selected artifacts and their recipe closures." :: String), line, pretty ("Examples:" :: String), indent 2 $
src-exe/Seihou/CLI/NewRecipe.hs view
@@ -51,7 +51,7 @@ TIO.putStrLn $ "Recipe '" <> name <> "' created at " <> T.pack outputDir <> "/" TIO.putStrLn $ "Next: seihou validate-recipe " <> "'" <> T.replace "'" "'\"'\"'" (T.pack outputDir) <> "'" if null (ropts ^. #modules)- then TIO.putStrLn "Add at least one member to modules before validating."+ then TIO.putStrLn "Add a member for a root recipe, or set extends for a derived recipe; see seihou help recipes." else pure () -- | Check if a recipe name matches [a-z][a-z0-9-]*@@ -70,6 +70,8 @@ <> "\"\n" <> ", version = Some \"0.1.0\"\n" <> ", description = Some \"\"\n"+ <> "-- Derived recipes may keep modules empty and add extends = Some { recipe = \"base-recipe\" }.\n"+ <> "-- Use moduleOverrides for inherited bindings; see seihou help recipes for source and range fields.\n" <> ", modules =\n" <> modulesSection mods <> ", vars = [] : List { name : Text, type : Text, default : Optional Text, description : Optional Text, required : Bool, validation : Optional Text }\n"
src-exe/Seihou/CLI/Run.hs view
@@ -31,11 +31,13 @@ import Seihou.CLI.Commands (RunOpts (..)) import Seihou.CLI.CommitMessage (generateCommitMessage) import Seihou.CLI.Git (gitAdd, gitCheckIgnore, gitCommit, gitDiffCached, isGitRepo)-import Seihou.CLI.ManifestCapabilityUpgrade (prepareRecordedSeedOwnership)+import Seihou.CLI.ManifestCapabilityUpgrade (prepareRecipeInheritance, prepareRecordedSeedOwnership) import Seihou.CLI.ManifestGuard ( blockingChecks, checkAppliedArtifactsFor,+ checkRecipeChain, enforceArtifactGuard,+ summarizeCheck, ) import Seihou.CLI.Migrate ( MigrateError (..),@@ -50,12 +52,14 @@ import Seihou.CLI.SavePrompted (collectRecipePromptedValues, offerSavePrompted) import Seihou.CLI.Shared (deriveNamespace, formatBlueprintRefusal, formatVarError, logIO, resolveAppliedArtifactDir, toVarNameMap, unwrapConfig) import Seihou.CLI.Style (bold, dim, formatPlanViewColor, green, magenta, red, useColor, yellow)+import Seihou.CLI.ValidateRecipeReport (recipeLoadErrorText) import Seihou.Composition.Instance (ModuleInstance (..), qualifiedName) import Seihou.Composition.Plan (ComposedPlan (..), compileComposedPlan)-import Seihou.Composition.Recipe (expandRecipe)-import Seihou.Composition.Resolve (PromptPermission (..), RecipeInputSpec (..), loadComposition, resolveRecipeWithPrompts, verifyDependencySources)+import Seihou.Composition.Recipe (recipeLiteralSources)+import Seihou.Composition.RecipeChain (loadRecipeChain, recordRecipeChain)+import Seihou.Composition.Resolve (PromptPermission (..), RecipeInputSpec (..), loadComposition, resolveRecipeWithSources) import Seihou.Core.Application (attachApplication, buildAppliedComposition, mkApplicationId, replaceAppliedComposition)-import Seihou.Core.ArtifactOriginDetect (detectArtifactOrigin)+import Seihou.Core.ArtifactOriginDetect (detectArtifactOrigin, readOriginInfo) import Seihou.Core.ArtifactRef (renderArtifactRefError) import Seihou.Core.Checkout import Seihou.Core.CommandFingerprint (checkoutCommandsFromOperations, isCheckoutCommand)@@ -124,37 +128,39 @@ exitFailure -- 0b. Recipe detection: check if the name resolves to a recipe or a module+ projectRoot <- getCurrentDirectory searchPaths <- defaultSearchPaths- (primaryName, allAdditional, recipeOverrides, recipeDecls, recipePrompts, recipeInfo, targetInfo) <- do+ (primaryName, allAdditional, recipeOverrides, recipeDecls, recipePrompts, recipeInfo, targetInfo, recipeChain) <- do runnableResult <- discoverRunnable searchPaths modName case runnableResult of Right (RunnableRecipe recipe recipeDir) -> do- case expandRecipe recipe of- Left errs -> do- logIO level $- logError $- "Invalid recipe '"- <> recipe ^. #name . #unRecipeName- <> "': "- <> T.intercalate "; " errs- exitFailure- Right (primary, recipeAdditional, overrides, recipeVars, recipePrompts, requirements) -> do- sourceCheck <- verifyDependencySources searchPaths recipeDir requirements- case sourceCheck of- Left err -> TIO.putStrLn (T.pack (show err)) >> exitFailure- Right () -> pure ()- logIO level $- logInfo $- "Recipe '" <> recipe ^. #name . #unRecipeName <> "' expanding to " <> T.pack (show (length (recipe ^. #modules))) <> " modules"- pure- ( primary,- recipeAdditional ++ additional,- overrides,- recipeVars,- recipePrompts,- Just (recipe ^. #name, recipe ^. #version),- (AppliedRecipeTarget (recipe ^. #name), recipeDir, recipe ^. #version)- )+ when (recipe ^. #name . #unRecipeName /= modName ^. #unModuleName) $+ exitError level "Recipe descriptor name does not match the requested artifact; correct its name before generating."+ expanded <- loadRecipeChain projectRoot searchPaths recipe recipeDir >>= either (exitError level . recipeLoadErrorText) pure+ let members = map (^. #dependency . #module_) (expanded ^. #members)+ sources = case recipe ^. #extends of+ Nothing -> Map.map (\literal -> (literal ^. #value, FromRecipeBinding)) (expanded ^. #literals)+ Just _ -> recipeLiteralSources expanded+ originText (RemoteOrigin url _ _) = url+ originText (ProjectOrigin path) = "project:" <> T.pack path+ originText (LocalOrigin name) = name <> " (unverified local origin)"+ TIO.putStrLn $ "Recipe '" <> recipe ^. #name . #unRecipeName <> "' expanding to " <> T.pack (show (length members)) <> " members"+ TIO.putStrLn $ "Base chain: " <> T.intercalate " -> " [node ^. #definition . #name . #unRecipeName | node <- expanded ^. #chain]+ forM_ (expanded ^. #chain) $ \node ->+ TIO.putStrLn $+ " " <> node ^. #definition . #name . #unRecipeName <> " " <> fromMaybe "<unversioned>" (node ^. #definition . #version) <> " from " <> originText (node ^. #origin)+ TIO.putStrLn $ "Primary module: " <> expanded ^. #primary . #unModuleName+ chain <- recordRecipeChain expanded+ pure+ ( expanded ^. #primary,+ drop 1 members <> additional,+ sources,+ expanded ^. #declarations,+ expanded ^. #prompts,+ Just (recipe ^. #name, recipe ^. #version),+ (AppliedRecipeTarget (recipe ^. #name), recipeDir, recipe ^. #version),+ chain+ ) Right (RunnableModule modul moduleDir) -> pure ( modName,@@ -163,7 +169,8 @@ [], [], Nothing,- (AppliedModuleTarget modName, moduleDir, modul ^. #version)+ (AppliedModuleTarget modName, moduleDir, modul ^. #version),+ [] ) Right (RunnableBlueprint _b _blueprintDir) -> do -- Use the user-typed name (modName) rather than the blueprint's@@ -172,6 +179,13 @@ -- can re-type to find the same artifact. logIO level $ logError (formatBlueprintRefusal modName) exitFailure+ Left err+ | case err of ModuleNotFound _ _ -> False; _ -> True ->+ exitError level $+ "Cannot load '" <> modName ^. #unModuleName <> "': " <> case err of+ DhallEvalError _ reason -> reason+ DhallDecodeError _ reason -> reason+ _ -> recipeLoadErrorText err Left _ -> -- Discovery failed — let loadComposition handle the error with its detailed message pure@@ -181,9 +195,19 @@ [], [], Nothing,- (AppliedModuleTarget modName, "", Nothing)+ (AppliedModuleTarget modName, "", Nothing),+ [] ) + let explainRecipeRepair = case recipeInfo of+ Nothing -> pure ()+ Just (name, _) -> do+ let (_, dir, _) = targetInfo+ origin <- readOriginInfo dir+ TIO.putStrLn $ case origin of+ Just info -> "Retry: seihou install " <> info ^. #sourceUrl <> " --module " <> name ^. #unRecipeName+ Nothing -> "Restore the local composition for recipe '" <> name ^. #unRecipeName <> "', or install it from its declaring registry."+ -- 1. Load all modules in the composition (primary + additional + transitive deps) compositionResult <- loadComposition searchPaths primaryName allAdditional modulesInOrder <- case compositionResult of@@ -192,21 +216,37 @@ logError $ "Module '" <> name ^. #unModuleName <> "' not found." logError "Searched in:" mapM_ (\p -> logError $ " " <> T.pack p) searched+ explainRecipeRepair exitFailure Left (CircularDependency names) -> do logIO level $ do logError "Circular dependency detected:" logError $ " " <> T.intercalate " -> " (map (^. #unModuleName) names)+ explainRecipeRepair exitFailure- Left err -> exitError level (T.pack (show err))+ Left err -> do+ TIO.putStrLn (recipeLoadErrorText err)+ explainRecipeRepair+ exitFailure Right ms -> pure ms -- Report composition when multiple modules are involved- when (length modulesInOrder > 1) $- logIO level $ do- logInfo $ "Composing " <> T.pack (show (length modulesInOrder)) <> " modules:"- mapM_ (\(_, m, _) -> logInfo $ " " <> m ^. #name . #unModuleName) modulesInOrder+ when (length modulesInOrder > 1) $ do+ TIO.putStrLn $ "Composing " <> T.pack (show (length modulesInOrder)) <> " modules:"+ mapM_ (\(_, m, _) -> TIO.putStrLn $ " " <> m ^. #name . #unModuleName) modulesInOrder + now <- getCurrentTime+ let manifestPath = ".seihou" </> "manifest.json"+ existingRes <- runEff $ runFilesystem $ runManifestStore manifestPath readManifest+ initialManifest <- case existingRes of+ Left err -> exitError level ("Error reading manifest: " <> err)+ Right m -> pure (fromMaybe (emptyManifest now) m)+ let (appliedTargetForGuard, _, _) = targetInfo+ (recipeChecks, recipeChanges) = checkRecipeChain (mkApplicationId appliedTargetForGuard additional) recipeChain initialManifest+ mapM_ TIO.putStrLn recipeChanges+ enforceArtifactGuard (runOpts ^. #allowDowngrade) (blockingChecks recipeChecks)+ mapM_ TIO.putStrLn [message | check <- recipeChecks, null (blockingChecks [check]), Just message <- [summarizeCheck check]]+ -- 2. Resolve variables with export visibility and interactive prompts envPairs <- getEnvironment -- Merge recipe overrides with CLI overrides (CLI wins on conflict)@@ -223,7 +263,7 @@ nm = toVarNameMap namespaceCfg cm = toVarNameMap contextCfg gm = toVarNameMap globalCfg- r <- resolveRecipeWithPrompts PromptsAllowed (runOpts ^. #confirmDefaults) (RecipeInputSpec recipeDecls recipePrompts Nothing) modulesInOrder Map.empty (Map.fromList [(VarName k, v) | (k, v) <- runOpts ^. #vars]) recipeOverrides envVars namespace contextName lm nm cm gm+ r <- resolveRecipeWithSources PromptsAllowed (runOpts ^. #confirmDefaults) (RecipeInputSpec recipeDecls recipePrompts Nothing) modulesInOrder Map.empty (Map.fromList [(VarName k, v) | (k, v) <- runOpts ^. #vars]) recipeOverrides envVars namespace contextName lm nm cm gm pure (r, lm, nm, cm, gm) (recipeResolved, resolvedInitial) <- case resolveResult of Left errs -> do@@ -273,25 +313,11 @@ mapM_ (printWarning level) warnings -- 6. Compute diff (shared by dry-run, --diff, and execution paths)- now <- getCurrentTime- let manifestPath = ".seihou" </> "manifest.json"- baselineDir = ".seihou" </> "baselines"+ let baselineDir = ".seihou" </> "baselines" planned = [(dest, content, modName, Nothing) | WriteFileOp dest content _ <- opsFiltered] ++ [(dest, content, mName, Just pOp) | PatchFileOp dest content pOp _ mName <- opsFiltered] - -- 6a. Read the manifest before computing the diff so the pre-flight- -- migration check can run against it (and, with --with-migrations, so- -- 'runMigrate' can rewrite it before the diff is taken).- existingRes <- runEff $ runFilesystem $ runManifestStore manifestPath $ do- createDirectoryIfMissing True (takeDirectory manifestPath)- readManifest- initialManifest <- case existingRes of- Left err -> do- logIO level (logError $ "Error reading manifest: " <> err)- exitFailure- Right m -> pure (fromMaybe (emptyManifest now) m)- case validateSeedRun initialManifest opsFiltered of Left errors -> mapM_ (TIO.putStrLn . (^. #message)) errors >> exitFailure Right () -> pure ()@@ -307,7 +333,6 @@ -- would point the wrong way. Like the migration check, it considers only -- modules in the current composition; a stale module this run does not -- touch must not block it.- projectRoot <- getCurrentDirectory searchPaths <- defaultSearchPaths earlySeedResult <- runEff $ runFilesystem $ planSeeds projectRoot initialManifest seedOwnerMap opsFiltered case earlySeedResult of@@ -363,9 +388,10 @@ let recordedRecipe = fmap (const (Map.map (varValueToText . (^. #value)) recipeResolved)) recipeInfo let declarationApplication =- buildAppliedComposition appliedTarget targetOrigin targetVersion additional (Just namespace) context originedModules resolved now & #recipeInputs .~ recordedRecipe+ buildAppliedComposition appliedTarget targetOrigin targetVersion additional (Just namespace) context originedModules resolved now & #recipeInputs .~ recordedRecipe & #recipeChain .~ Just recipeChain let selectedSeedPaths = Set.fromList [path | (path, receipt) <- Map.toAscList (manifest ^. #seeds), case receipt ^. #ownership of LegacySeedOwners apps -> Set.member currentApplicationId apps || Map.member path seedOwnerMap; _ -> False]- seedPrepared <- prepareRecordedSeedOwnership projectRoot searchPaths selectedSeedPaths manifest+ inheritancePrepared <- either (exitError level) pure (prepareRecipeInheritance manifest)+ seedPrepared <- prepareRecordedSeedOwnership projectRoot searchPaths selectedSeedPaths inheritancePrepared seedBase <- case seedPrepared of Left err -> TIO.putStrLn err >> exitFailure Right candidate -> pure candidate@@ -514,6 +540,8 @@ ( appliedCompositionWithoutReceipts & #recipeInputs .~ recordedRecipe+ & #recipeChain+ .~ Just recipeChain & #commandReceipts .~ expectedCommandReceiptMap & #checkoutCommands
src-exe/Seihou/CLI/Upgrade.hs view
@@ -5,17 +5,20 @@ import Control.Applicative ((<|>)) import Control.Exception (SomeException, try)-import Control.Monad (when)+import Control.Monad (forM, forM_, when) import Data.Aeson (ToJSON (..), object, (.=)) import Data.Aeson.Encode.Pretty (encodePretty) import Data.ByteString.Lazy qualified as LBS import Data.Generics.Labels () import Data.Map.Strict qualified as Map+import Data.Maybe (fromMaybe) import Data.Text qualified as T import Data.Text.IO qualified as TIO+import Data.Time (getCurrentTime) import Seihou.CLI.Commands (UpgradeOpts (..)) import Seihou.CLI.Install (installModuleDir)-import Seihou.CLI.InstallShared (InstallOutcome (..), OriginInfo (..), summarizeInstallRefusal)+import Seihou.CLI.InstallClosure (ClosureArtifact (..), publishStagedClosure)+import Seihou.CLI.InstallShared (InstallOutcome (..), OriginInfo (..), installedRoot, readOriginInfo, summarizeInstallRefusal) import Seihou.CLI.Migrate ( MigrateError (..), MigrateOpts (..),@@ -27,18 +30,23 @@ import Seihou.CLI.RemoteVersion (fetchTrueModuleVersion) import Seihou.CLI.Shared (resolveAppliedArtifactDir) import Seihou.CLI.Style (dim, green, red, useColor, yellow)+import Seihou.CLI.Update.Render (errorOutput, renderUpdateHuman)+import Seihou.CLI.Update.Source (hashArtifactDirectory, stageCandidateSources)+import Seihou.CLI.Update.Types (CandidateArtifact (..), CandidateCatalog (..)) import Seihou.CLI.VersionCompare (OutdatedStatus (..), compareVersions)+import Seihou.Core.Application (buildAppliedComposition) import Seihou.Core.Install (parseModuleName) import Seihou.Core.Migration (MigrationPlan (..))-import Seihou.Core.Module (DiscoveredModule (..), ModuleSource (..), defaultSearchPaths, discoverAllModules, validateModule)+import Seihou.Core.Module (DiscoveredModule (..), DiscoveredRunnable (..), ModuleSource (..), RunnableKind (..), defaultSearchPaths, discoverAllModules, discoverAllRunnables, validateModule) import Seihou.Core.Registry (Registry (..), RegistryEntry (..), RepoContents (..), discoverRepoContents)-import Seihou.Core.Types (AppliedModule (..), Manifest (..), Module (..), ModuleName (..))+import Seihou.Core.Types (AppliedModule (..), AppliedTarget (..), ArtifactOrigin (..), Manifest (..), Module (..), ModuleName (..), RecipeName (..)) import Seihou.Core.Version (renderVersion) import Seihou.Dhall.Eval (evalModuleFromFile, evalRegistryFromFile) import Seihou.Effect.FilesystemInterp (runFilesystem) import Seihou.Effect.ManifestStore (readManifest) import Seihou.Effect.ManifestStoreInterp (runManifestStore) import Seihou.Prelude+import System.Directory qualified as Directory import System.Exit (ExitCode (..), exitFailure) import System.IO.Temp (withSystemTempDirectory) import System.Process (readProcessWithExitCode)@@ -79,47 +87,78 @@ handleUpgrade uopts = do searchPaths <- defaultSearchPaths modules <- discoverAllModules searchPaths+ runnables <- discoverAllRunnables searchPaths let installed = filter (\dm -> dm ^. #source == SourceInstalled) modules-- if null installed- then TIO.putStrLn "No installed modules found."- else do- originsWithModules <- mapM readOriginWithModule installed- let withOrigins = [(dm, origin) | (dm, Just origin) <- originsWithModules]-- filtered <- case uopts ^. #modules of- [] -> pure withOrigins- names -> do- let result = [(dm, origin) | (dm, origin) <- withOrigins, moduleNameFromDm dm `elem` names]- found = map (moduleNameFromDm . fst) result- missing = filter (`notElem` found) names- when (not (null missing)) $ do- TIO.putStrLn $ "Module(s) not found: " <> T.intercalate ", " missing- exitFailure- pure result-- if null filtered- then TIO.putStrLn "No installed modules with origin metadata found."+ recipes = [recipe | recipe <- runnables, recipe ^. #source == SourceInstalled, recipe ^. #kind == KindRecipe]+ requested = uopts ^. #modules+ selectedRecipes = [recipe | recipe <- recipes, null requested || recipe ^. #name `elem` requested]+ originsWithModules <- mapM readOriginWithModule installed+ let withOrigins = [(dm, origin) | (dm, Just origin) <- originsWithModules]+ found = map (moduleNameFromDm . fst) withOrigins <> map (^. #name) recipes+ missing = filter (`notElem` found) requested+ when (not (null missing)) $ TIO.putStrLn ("Module(s) or recipe(s) not found: " <> T.intercalate ", " missing) >> exitFailure+ recipeResult <- upgradeRecipes uopts selectedRecipes+ case recipeResult of+ Left message -> do+ if uopts ^. #json+ then LBS.putStr (encodePretty [UpgradeEntry (recipe ^. #name) Nothing Nothing (UpgradeFailed message) | recipe <- selectedRecipes])+ else TIO.putStrLn ("Recipe upgrade failed: " <> message)+ exitFailure+ Right (recipeEntries, covered) -> do+ let filtered = [(dm, origin) | (dm, origin) <- withOrigins, null requested || moduleNameFromDm dm `elem` requested, moduleNameFromDm dm `notElem` covered]+ grouped = Map.toList $ Map.fromListWith (++) [(origin ^. #sourceUrl, [(dm, origin)]) | (dm, origin) <- filtered]+ moduleEntries <- concat <$> mapM (upgradeSource uopts) grouped+ let entries = recipeEntries <> moduleEntries+ if null entries+ then TIO.putStrLn "No installed modules or recipes with origin metadata found." else do- let grouped = Map.toList $ Map.fromListWith (++) [(origin ^. #sourceUrl, [(dm, origin)]) | (dm, origin) <- filtered]-- if uopts ^. #dryRun- then TIO.putStrLn "Checking installed modules for updates (dry run)..."- else TIO.putStrLn "Upgrading installed modules..."-- entries <- concat <$> mapM (upgradeSource uopts) grouped-- if uopts ^. #json- then LBS.putStr (encodePretty entries)- else renderUpgradeTable entries-- -- After all upgrades, see whether the *current project* has- -- migrations pending for any module that was upgraded just- -- now. Either run them (--with-migrations) or print a- -- one-line advisory per module.- unless (uopts ^. #dryRun) $+ if uopts ^. #json then LBS.putStr (encodePretty entries) else renderUpgradeTable (uopts ^. #dryRun) entries+ unless (uopts ^. #dryRun) $ do handlePostUpgradeMigrations uopts entries+ when (not (uopts ^. #json)) $ forM_ selectedRecipes $ \recipe -> TIO.putStrLn $ "Run 'seihou update " <> recipe ^. #name <> "' to reconcile the recorded project application." +-- Refresh each selected recipe's complete candidate closure, including an+-- unchanged child whose base has changed. Publication uses staged bytes only.+upgradeRecipes :: UpgradeOpts -> [DiscoveredRunnable] -> IO (Either Text ([UpgradeEntry], [Text]))+upgradeRecipes _ [] = pure (Right ([], []))+upgradeRecipes opts recipes = withSystemTempDirectory "seihou-recipe-upgrade" $ \session -> do+ now <- getCurrentTime+ root <- Directory.getCurrentDirectory+ cache <- installedRoot+ roots <- forM recipes $ \recipe -> do+ origin <- readOriginInfo (recipe ^. #dir)+ pure $ case origin of+ Nothing -> Left ("Recipe '" <> recipe ^. #name <> "' has no origin metadata; reinstall it from its registry.")+ Just info -> Right (buildAppliedComposition (AppliedRecipeTarget (RecipeName (recipe ^. #name))) (RemoteOrigin (info ^. #sourceUrl) (recipe ^. #name) (info ^. #repoName)) (info ^. #version) [] Nothing Nothing [] Map.empty now)+ case sequence roots of+ Left message -> pure (Left message)+ Right applications -> do+ staged <- stageCandidateSources session root cache applications+ case staged of+ Left err -> pure (Left (renderUpdateHuman False (errorOutput err)))+ Right (catalog, _) -> do+ compared <- forM (Map.elems (catalog ^. #artifacts)) $ \artifact -> do+ let path = cache </> T.unpack (artifact ^. #name)+ old <- readOriginInfo path+ present <- Directory.doesDirectoryExist path+ oldHash <- if present then Just <$> hashArtifactDirectory path else pure Nothing+ let changed = oldHash /= Just (artifact ^. #contentHash)+ skipped = opts ^. #skipUnversioned && (artifact ^. #version == Nothing || maybe False ((== Nothing) . (^. #version)) old)+ status+ | changed && skipped = Skipped+ | changed = Upgraded+ | otherwise = AlreadyUpToDate+ entry = UpgradeEntry (artifact ^. #name) (old >>= (^. #version)) (artifact ^. #version) status+ prepared = ClosureArtifact (artifact ^. #name) (fromMaybe "" (artifact ^. #sourceUrl)) (artifact ^. #repoName) (artifact ^. #version) (artifact ^. #tags) (artifact ^. #sourceRevision) (artifact ^. #sourceDirectory)+ pure (entry, prepared)+ let blocked = any ((== Skipped) . (^. #upgradeStatus) . fst) compared+ entries = [if blocked && entry ^. #upgradeStatus == Upgraded then entry & #upgradeStatus .~ Skipped else entry | (entry, _) <- compared]+ changes = [artifact | (entry, artifact) <- compared, entry ^. #upgradeStatus == Upgraded]+ published <- if opts ^. #dryRun || blocked || null changes then pure (Right ()) else publishStagedClosure cache changes+ pure $ do+ published+ Right (entries, map (^. #name) (Map.elems (catalog ^. #artifacts)))+ upgradeSource :: UpgradeOpts -> (Text, [(DiscoveredModule, OriginInfo)]) -> IO [UpgradeEntry] upgradeSource uopts (sourceUrl, modulesWithOrigins) = do let repoName = parseModuleName sourceUrl@@ -234,17 +273,18 @@ TIO.putStrLn $ " Upgraded " <> name pure UpgradeEntry {moduleName = name, oldVersion = installedVer, newVersion = availableVer, upgradeStatus = Upgraded} -renderUpgradeTable :: [UpgradeEntry] -> IO ()-renderUpgradeTable entries = do+renderUpgradeTable :: Bool -> [UpgradeEntry] -> IO ()+renderUpgradeTable dryRun entries = do colorEnabled <- useColor- let maxNameLen = max 6 (maximum (map (T.length . (^. #moduleName)) entries))+ let upgradedLabel = if dryRun then "would upgrade" else "upgraded"+ maxNameLen = max 6 (maximum (map (T.length . (^. #moduleName)) entries)) maxOldLen = max 3 (maximum (map (T.length . maybe "(none)" id . (^. #oldVersion)) entries)) maxNewLen = max 3 (maximum (map (T.length . maybe "(none)" id . (^. #newVersion)) entries)) padR n t = t <> T.replicate (n - T.length t + 2) " " header =- padR maxNameLen "Module"+ padR maxNameLen "Artifact" <> padR maxOldLen "Old" <> padR maxNewLen "New" <> "Status"@@ -253,7 +293,7 @@ let oldText = maybe "(none)" id (e ^. #oldVersion) newText = maybe "(none)" id (e ^. #newVersion) statusTxt = case e ^. #upgradeStatus of- Upgraded -> if colorEnabled then green "upgraded" else "upgraded"+ Upgraded -> if colorEnabled then green upgradedLabel else upgradedLabel AlreadyUpToDate -> if colorEnabled then dim "up to date" else "up to date" Skipped -> if colorEnabled then yellow "skipped (unversioned)" else "skipped (unversioned)" UpgradeFailed reason -> if colorEnabled then red ("failed: " <> reason) else "failed: " <> reason@@ -273,9 +313,10 @@ TIO.putStrLn "" TIO.putStrLn $ T.pack (show (length entries))- <> " module(s) checked, "+ <> " artifact(s) checked, " <> T.pack (show upgraded)- <> " upgraded"+ <> " "+ <> upgradedLabel <> (if failed > 0 then ", " <> T.pack (show failed) <> " failed" else "") <> (if skipped > 0 then ", " <> T.pack (show skipped) <> " skipped" else "") <> "."
src-exe/Seihou/CLI/ValidateRecipe.hs view
@@ -35,4 +35,8 @@ Left err -> invalid [recipeLoadErrorText err] 1 Right recipe -> case validateRecipe recipe of Left errors -> invalid errors 1- Right valid -> TIO.putStrLn $ "Recipe '" <> valid ^. #name . #unRecipeName <> "' is valid."+ Right valid -> do+ TIO.putStrLn $ "Recipe '" <> valid ^. #name . #unRecipeName <> "' is valid."+ case valid ^. #extends of+ Nothing -> pure ()+ Just _ -> TIO.putStrLn "Local descriptor validation passed; the base and composition were not checked."
src-exe/Seihou/CLI/Vars.hs view
@@ -11,8 +11,11 @@ import Data.Text.IO qualified as TIO import Seihou.CLI.Commands (VarsOpts (..)) import Seihou.CLI.Shared (deriveNamespace, formatVarError, logIO, toVarNameMap, unwrapConfig)+import Seihou.CLI.ValidateRecipeReport (recipeLoadErrorText) import Seihou.Composition.Instance (ModuleInstance (..))-import Seihou.Composition.Resolve (loadComposition, resolveWithPrompts)+import Seihou.Composition.Recipe (ExpandedRecipe (..), recipeLiteralSources)+import Seihou.Composition.RecipeChain (loadRecipeChain)+import Seihou.Composition.Resolve (PromptPermission (..), RecipeInputSpec (..), loadComposition, resolveRecipeWithSources, resolveWithPrompts) import Seihou.Core.Context (resolveContext) import Seihou.Core.Module (defaultSearchPaths, discoverRunnable) import Seihou.Core.Types@@ -25,6 +28,7 @@ import Seihou.Fzf (FzfResult (..), detectFzfConfig, isFzfUsable) import Seihou.Fzf.Selector (selectModule) import Seihou.Prelude+import System.Directory (getCurrentDirectory) import System.Environment (getEnvironment) import System.Exit (ExitCode (..), exitFailure, exitWith) @@ -71,12 +75,20 @@ exitFailure Right (RunnableModule m _) -> if vopts ^. #explain- then explainMode modName vopts+ then explainMode modName vopts Nothing else declarationModeModule m- Right (RunnableRecipe r _) ->- if vopts ^. #explain- then explainMode modName vopts- else declarationModeRecipe r+ Right (RunnableRecipe r dir) ->+ if not (vopts ^. #explain) && r ^. #extends == Nothing+ then declarationModeRecipe r+ else do+ root <- getCurrentDirectory+ expanded <- loadRecipeChain root searchPaths r dir+ case expanded of+ Left err -> logIO LogNormal (logError (recipeLoadErrorText err)) >> exitFailure+ Right recipe ->+ if vopts ^. #explain+ then explainMode modName vopts (Just recipe)+ else declarationModeRecipe (r & #vars .~ (recipe ^. #declarations)) Right (RunnableBlueprint b _) -> if vopts ^. #explain then do@@ -101,7 +113,7 @@ -- | Declaration mode for a recipe: list its declared variables. Recipes -- carry their own @vars@ list (separately from the modules they--- compose); this prints those without expanding the recipe.+-- compose); derived callers supply their merged declaration list. declarationModeRecipe :: Recipe -> IO () declarationModeRecipe r = do let vs = (r ^. #vars)@@ -126,11 +138,13 @@ TIO.putStr (formatDeclarations vs) -- | Explain mode: load full composition, resolve variables with exports, show provenance-explainMode :: ModuleName -> VarsOpts -> IO ()-explainMode modName vopts = do+explainMode :: ModuleName -> VarsOpts -> Maybe ExpandedRecipe -> IO ()+explainMode modName vopts expansion = do -- Load the full composition (target module + transitive dependencies) searchPaths <- defaultSearchPaths- compositionResult <- loadComposition searchPaths modName []+ let primary = maybe modName (^. #primary) expansion+ additional = maybe [] (drop 1 . map (^. #dependency . #module_) . (^. #members)) expansion+ compositionResult <- loadComposition searchPaths primary additional modulesInOrder <- case compositionResult of Left (ModuleNotFound name searched) -> do logIO LogNormal $ do@@ -160,7 +174,7 @@ envPairs <- getEnvironment let cliOverrides = Map.fromList [(VarName k, v) | (k, v) <- vopts ^. #vars] envVars = Map.fromList [(T.pack k, T.pack v) | (k, v) <- envPairs]- namespace = fromMaybe (deriveNamespace modName) (vopts ^. #namespace)+ namespace = fromMaybe (deriveNamespace primary) (vopts ^. #namespace) context <- resolveContext (vopts ^. #context) envVars let contextName = fromMaybe "" context (resolveResult, localMap, nsMap, ctxMap, globalMap) <- runEff $ runConfigReader $ runConsole $ do@@ -172,7 +186,9 @@ nm = toVarNameMap namespaceCfg cm = toVarNameMap contextCfg gm = toVarNameMap globalCfg- r <- resolveWithPrompts modulesInOrder cliOverrides envVars namespace contextName lm nm cm gm+ r <- case expansion of+ Nothing -> fmap (fmap (\values -> (Map.empty, values))) (resolveWithPrompts modulesInOrder cliOverrides envVars namespace contextName lm nm cm gm)+ Just recipe -> resolveRecipeWithSources PromptsAllowed False (RecipeInputSpec (recipe ^. #declarations) (recipe ^. #prompts) Nothing) modulesInOrder Map.empty cliOverrides (recipeLiteralSources recipe) envVars namespace contextName lm nm cm gm pure (r, lm, nm, cm, gm) case resolveResult of Left errs -> do@@ -180,17 +196,18 @@ logError "Error resolving variables:" mapM_ (logError . (" " <>) . formatVarError) errs exitFailure- Right resolved -> do- -- Show only the target module's resolved variables. `seihou vars` is- -- scoped to a module name, so if multiple instances exist we merge- -- their resolved maps (last wins on overlap — matches how a user+ Right (recipeValues, resolved) -> do+ -- Modules show their target values; recipes show accepted recipe inputs+ -- and the complete consumer composition. Multiple instances merge+ -- their maps in the existing order — matching how a user -- reads "the variables of module X" before any disambiguation UI). let targetResolved =- Map.unions- [ vs- | (inst, vs) <- Map.toList resolved,- inst ^. #module_ == modName- ]+ Map.union recipeValues $+ Map.unions+ [ vs+ | (inst, vs) <- Map.toList resolved,+ maybe (inst ^. #module_ == modName) (const True) expansion+ ] TIO.putStrLn $ "Variables for " <> modName ^. #unModuleName <> ":" TIO.putStrLn "" if Map.null targetResolved@@ -198,8 +215,8 @@ else TIO.putStr (formatExplain targetResolved) -- Show diagnostics- let allDecls = concatMap (\(_, m, _) -> m ^. #vars) modulesInOrder- allResolved = Map.unions [vs | vs <- Map.elems resolved]+ let allDecls = maybe [] (^. #declarations) expansion <> concatMap (\(_, m, _) -> m ^. #vars) modulesInOrder+ allResolved = Map.union recipeValues (Map.unions [vs | vs <- Map.elems resolved]) (unusedKeys, unresolvedOpt) = diagnoseResolution allResolved allDecls localMap nsMap ctxMap globalMap when (not (null unusedKeys)) $ do TIO.putStrLn ""
src/Seihou/CLI/InstallClosure.hs view
@@ -1,5 +1,5 @@ -- | Acquisition is completed and validated before any installed entry changes.-module Seihou.CLI.InstallClosure (installClosure, installClosureInto) where+module Seihou.CLI.InstallClosure (installClosure, installClosureInto, stageClosuresInto, ClosureArtifact (..), normalizePayload, writeStagedText, publishStagedClosure) where import Control.Exception (IOException, displayException, mask, onException, throwIO, try) import Control.Monad (forM, forM_, unless, when)@@ -7,21 +7,26 @@ import Data.IORef import Data.List (find) import Data.Map.Strict qualified as Map+import Data.Maybe (maybeToList) import Data.Text qualified as T import Data.Text.IO qualified as TIO import Seihou.CLI.InstallShared+import Seihou.CLI.ValidateRecipeReport (recipeLoadErrorText)+import Seihou.Composition.RecipeChain (loadRecipeChain) import Seihou.Core.AgentPrompt (validateAgentPrompt) import Seihou.Core.ArtifactIdentity (normalizeOriginUrl) import Seihou.Core.Blueprint (validateBlueprintForInstall) import Seihou.Core.Module (validateModule)-import Seihou.Core.Recipe (validateRecipe)+import Seihou.Core.Recipe (validateRecipe, validateRecipeVersion) import Seihou.Core.Registry import Seihou.Core.Types import Seihou.Dhall.Eval import Seihou.Prelude import System.Directory+import System.Exit (ExitCode (..)) import System.FilePath (isAbsolute, makeRelative, splitDirectories) import System.IO.Temp (createTempDirectory, withSystemTempDirectory)+import System.Process (readProcessWithExitCode) -- Paths refer to temporary checkouts until every selected root passes preflight. data Entry = Entry@@ -36,8 +41,28 @@ } deriving stock (Generic) +-- | Normalized artifacts in the caller-owned staging directory. No temporary+-- checkout paths escape; revision and provenance are captured before cleanup.+data ClosureArtifact = ClosureArtifact+ { name :: !Text,+ sourceUrl :: !Text,+ repoName :: !(Maybe Text),+ version :: !(Maybe Text),+ tags :: ![Text],+ sourceRevision :: !(Maybe Text),+ directory :: !FilePath+ }+ deriving stock (Eq, Show, Generic)+ data Repo = Repo FilePath Text RepoContents +data ExpectedArtifact = AnyArtifact | ModuleArtifact | RecipeArtifact RecipeReference++data Requirement = Requirement Text (Maybe Text) ExpectedArtifact++moduleRequirements :: [Dependency] -> [Requirement]+moduleRequirements = map (\dep -> Requirement (dep ^. #module_ . #unModuleName) (dep ^. #source) ModuleArtifact)+ -- | Roots are registry entries, or a name and directory for a single artifact. -- All failures discovered across selected roots are reported before staging. installClosure :: Bool -> FilePath -> Text -> [(Text, FilePath)] -> IO (Either Text ())@@ -47,10 +72,19 @@ -- | Explicit cache root for isolated callers and concurrent tests. installClosureInto :: FilePath -> Bool -> FilePath -> Text -> [(Text, FilePath)] -> IO (Either Text ())-installClosureInto cache force rootDir recorded roots = withSystemTempDirectory "seihou-closure" $ \tmp -> do- repos <- newIORef Map.empty- contents <- readContents rootDir- modifyIORef' repos (Map.insert (normalizeOriginUrl recorded) (Repo rootDir recorded contents))+installClosureInto cache force rootDir recorded roots =+ fmap (fmap (const ())) $+ stageClosuresInto True cache force [(rootDir, recorded, roots)]++-- | The acquisition planner is shared by install and read-only candidate work.+-- The caller chooses an isolated directory for previews; publication into the+-- real cache remains the accepting command's transaction.+stageClosuresInto :: Bool -> FilePath -> Bool -> [(FilePath, Text, [(Text, FilePath)])] -> IO (Either Text [ClosureArtifact])+stageClosuresInto report cache force groups = withSystemTempDirectory "seihou-closure" $ \tmp -> do+ rootRepos <- forM groups $ \(rootDir, recorded, roots) -> do+ contents <- readContents rootDir+ pure (Repo rootDir recorded contents, roots)+ repos <- newIORef (Map.fromList [(normalizeOriginUrl recorded, repo) | (repo@(Repo _ recorded _), _) <- rootRepos]) nodes <- newIORef Map.empty ordered <- newIORef [] let failWith = throwIO . userError . T.unpack@@ -66,7 +100,7 @@ let repo = Repo dir origin discovered modifyIORef' repos (Map.insert (normalizeOriginUrl source) repo . Map.insert (normalizeOriginUrl origin) repo) pure repo- visit active chain repo@(Repo repoDir origin _) name dir mustBeModule = do+ visit active chain repo@(Repo repoDir origin _) name dir expectedArtifact = do let key = (normalizeOriginUrl origin, name) context = chain <> name <> " [" <> origin <> "]" unless (safeName name) $ failWith (context <> ": unsafe install name")@@ -76,21 +110,20 @@ Just (other, _) | other /= fst key -> failWith (context <> ": conflicting sources for " <> name <> "; also required from " <> other) _ -> pure () checkTree repoDir dir- (file, deps, version) <- inspect dir mustBeModule `withContext` context+ (file, deps, version) <- inspect dir expectedArtifact `withContext` context case Map.lookup name known of Just _ -> pure () Nothing -> do modifyIORef' nodes (Map.insert name (fst key, context)) -- Evaluate every declaration independently of generation bindings.- forM_ deps $ \dep -> do- let depName = dep ^. #module_ . #unModuleName- depRepo <- case dep ^. #source of+ forM_ deps $ \(Requirement depName source expected) -> do+ depRepo <- case source of Nothing -> pure repo Just src -> do when (T.null (T.strip src) || "${" `T.isInfixOf` src) $ failWith (context <> ": invalid dependency source") getRepo src `withContext` context- depDir <- locate depRepo depName `withContext` context- visit (key : active) (context <> " -> ") depRepo depName depDir True+ depDir <- locate depRepo depName expected `withContext` context+ visit (key : active) (context <> " -> ") depRepo depName depDir expected let tags = case repo of Repo _ _ (MultiModule reg) -> maybe [] (^. #tags) (find ((== name) . (^. #name . #unModuleName)) (entries reg)) _ -> []@@ -99,11 +132,12 @@ _ -> Nothing checkTree repoDir dir modifyIORef' ordered (++ [Entry name origin dir file version registry tags context])- rootRepo = Repo rootDir recorded contents- outcomes <- forM roots $ \(name, dir) -> try @IOException (visit [] "" rootRepo name dir False)+ outcomes <- fmap concat $ forM rootRepos $ \(repo, roots) ->+ forM roots $ \(name, dir) -> try @IOException (visit [] "" repo name dir AnyArtifact)+ let repairs = T.concat ["\nRetry: seihou install " <> recorded <> T.concat [" --module " <> name | (name, _) <- roots] | (_, recorded, roots) <- groups] let errors = [T.pack (displayException e) | Left e <- outcomes] if not (null errors)- then pure (Left (T.intercalate "\n" errors))+ then pure (Left (T.intercalate "\n" errors <> repairs)) else do planned <- readIORef ordered collisions <- forM planned $ \e -> classifyInstallCollision (cache </> T.unpack (e ^. #entryName)) (e ^. #entrySource)@@ -119,12 +153,22 @@ copyDirectoryRecursive (e ^. #entryDir) stage normalizePayload (e ^. #entryDir) stage (e ^. #entryFile) definition <- normalizeInstalledDefinition (e ^. #entrySource) ((e ^. #entryDir) </> (e ^. #entryFile))- TIO.writeFile (stage </> (e ^. #entryFile)) definition+ writeStagedText (stage </> (e ^. #entryFile)) definition -- Build metadata with the existing writer, entirely outside the cache. forM_ planned $ \e -> do let name = T.unpack (e ^. #entryName) _ <- installModuleDirInto (tmp </> "ready") False (tmp </> "stage" </> name) name (e ^. #entrySource) (e ^. #entryRegistry) (e ^. #entryVersion) (e ^. #entryTags) pure ()+ -- Validate every merged recipe against only this staged closure.+ -- No ambient cache entry can hide a missing or contradictory edge.+ forM_ planned $ \e -> when (e ^. #entryFile == "recipe.dhall") $ do+ let ready = tmp </> "ready"+ dir = ready </> T.unpack (e ^. #entryName)+ recipe <- evalRecipeFromFile (dir </> "recipe.dhall") >>= decoded+ unless (recipe ^. #name . #unRecipeName == e ^. #entryName) $+ failWith ("Recipe descriptor name must match registry entry '" <> e ^. #entryName <> "'")+ _ <- loadRecipeChain tmp [ready] recipe dir >>= either (failWith . recipeLoadErrorText) pure+ pure () current <- forM planned $ \e -> classifyInstallCollision (cache </> T.unpack (e ^. #entryName)) (e ^. #entrySource) unless (current == collisions) $ failWith "Install cache changed during preparation; retry the same install command." createDirectoryIfMissing True cache@@ -160,9 +204,22 @@ case result of Left e -> pure (Left (T.pack (displayException e))) Right () -> do- forM_ planned $ \e -> TIO.putStrLn $ " Installed " <> (e ^. #entryName) <> " from " <> (e ^. #entrySource) <> if (e ^. #entryName) `elem` map fst roots then " (selected)" else " (required)"- TIO.putStrLn $ T.pack (show (length planned)) <> " entries installed; selected artifacts are ready."- pure (Right ())+ when report $ do+ forM_ planned $ \e -> TIO.putStrLn $ " Installed " <> (e ^. #entryName) <> " from " <> (e ^. #entrySource) <> if (e ^. #entryName) `elem` [name | (_, _, roots) <- groups, (name, _) <- roots] then " (selected)" else " (required)"+ TIO.putStrLn $ T.pack (show (length planned)) <> " entries installed; selected artifacts are ready."+ artifacts <- forM planned $ \e -> do+ revision <- try @IOException (readProcessWithExitCode "git" ["-C", e ^. #entryDir, "rev-parse", "HEAD"] "")+ pure+ ( ClosureArtifact+ (e ^. #entryName)+ (e ^. #entrySource)+ (e ^. #entryRegistry)+ (e ^. #entryVersion)+ (e ^. #entryTags)+ (case revision of Right (ExitSuccess, out, _) -> Just (T.strip (T.pack out)); _ -> Nothing)+ (cache </> T.unpack (e ^. #entryName))+ )+ pure (Right artifacts) withContext :: IO a -> Text -> IO a withContext action context = do@@ -180,9 +237,9 @@ entries :: Registry -> [RegistryEntry] entries reg = reg ^. #modules ++ reg ^. #recipes ++ reg ^. #blueprints ++ reg ^. #prompts -locate :: Repo -> Text -> IO FilePath-locate (Repo dir origin contents) name = case contents of- MultiModule reg -> case find ((== name) . (^. #name . #unModuleName)) (entries reg) of+locate :: Repo -> Text -> ExpectedArtifact -> IO FilePath+locate (Repo dir origin contents) name expected = case contents of+ MultiModule reg -> case find ((== name) . (^. #name . #unModuleName)) (allowedEntries reg) of Just entry -> do let candidate = dir </> (entry ^. #path) checkTree dir candidate@@ -190,10 +247,20 @@ Nothing -> missing SingleModule _ -> do m <- evalModuleFromFile (dir </> "module.dhall") >>= decoded- if m ^. #name . #unModuleName == name then pure dir else missing+ if m ^. #name . #unModuleName == name && isModule then pure dir else missing+ SingleRecipe _ -> do+ r <- evalRecipeFromFile (dir </> "recipe.dhall") >>= decoded+ if r ^. #name . #unRecipeName == name && isRecipe then pure dir else missing _ -> missing where- missing = throwIO (userError (T.unpack (name <> " not found as a module in " <> origin)))+ allowedEntries reg = case expected of+ AnyArtifact -> entries reg+ ModuleArtifact -> reg ^. #modules+ RecipeArtifact _ -> reg ^. #recipes+ isModule = case expected of RecipeArtifact _ -> False; _ -> True+ isRecipe = case expected of ModuleArtifact -> False; _ -> True+ kind = case expected of RecipeArtifact _ -> "recipe"; ModuleArtifact -> "module"; AnyArtifact -> "artifact"+ missing = throwIO (userError (T.unpack (name <> " not found as a " <> kind <> " in " <> origin))) -- Reject escapes and symlinks rather than copying files from outside the clone. checkTree :: FilePath -> FilePath -> IO ()@@ -213,35 +280,40 @@ decoded :: (Show e) => Either e a -> IO a decoded = either (throwIO . userError . show) pure -inspect :: FilePath -> Bool -> IO (FilePath, [Dependency], Maybe Text)-inspect dir mustBeModule = do+inspect :: FilePath -> ExpectedArtifact -> IO (FilePath, [Requirement], Maybe Text)+inspect dir expected = do hasModule <- doesFileExist (dir </> "module.dhall")- if hasModule- then do+ hasRecipe <- doesFileExist (dir </> "recipe.dhall")+ case expected of+ ModuleArtifact | not hasModule -> wrong "module"+ RecipeArtifact _ | not hasRecipe -> wrong "recipe"+ _ -> pure ()+ case expected of+ RecipeArtifact ref -> recipe (Just ref)+ _ | hasModule -> do m <- evalModuleFromFile (dir </> "module.dhall") >>= decoded _ <- validateModule dir m >>= decoded- pure ("module.dhall", m ^. #dependencies, m ^. #version)- else- if mustBeModule- then throwIO (userError ("Expected module at " <> dir))+ pure ("module.dhall", moduleRequirements (m ^. #dependencies), m ^. #version)+ _ | hasRecipe -> recipe Nothing+ _ -> do+ blueprint <- doesFileExist (dir </> "blueprint.dhall")+ if blueprint+ then do+ b <- evalBlueprintFromFile (dir </> "blueprint.dhall") >>= decoded+ _ <- validateBlueprintForInstall dir b >>= decoded+ pure ("blueprint.dhall", moduleRequirements (b ^. #baseModules), b ^. #version) else do- recipe <- doesFileExist (dir </> "recipe.dhall")- blueprint <- doesFileExist (dir </> "blueprint.dhall")- if recipe- then do- r <- evalRecipeFromFile (dir </> "recipe.dhall") >>= decoded- _ <- decoded (validateRecipe r)- pure ("recipe.dhall", r ^. #modules, r ^. #version)- else- if blueprint- then do- b <- evalBlueprintFromFile (dir </> "blueprint.dhall") >>= decoded- _ <- validateBlueprintForInstall dir b >>= decoded- pure ("blueprint.dhall", b ^. #baseModules, b ^. #version)- else do- p <- evalAgentPromptFromFile (dir </> "prompt.dhall") >>= decoded- _ <- validateAgentPrompt dir p >>= decoded- pure ("prompt.dhall", [], p ^. #version)+ p <- evalAgentPromptFromFile (dir </> "prompt.dhall") >>= decoded+ _ <- validateAgentPrompt dir p >>= decoded+ pure ("prompt.dhall", [], p ^. #version)+ where+ wrong kind = throwIO (userError ("Expected " <> kind <> " at " <> dir))+ recipe requirement = do+ r <- evalRecipeFromFile (dir </> "recipe.dhall") >>= decoded+ _ <- decoded (validateRecipe r)+ forM_ requirement $ \ref -> decoded (validateRecipeVersion ref r)+ let base = [Requirement (ref ^. #recipe . #unRecipeName) (ref ^. #source) (RecipeArtifact ref) | ref <- maybeToList (r ^. #extends)]+ pure ("recipe.dhall", base <> moduleRequirements (r ^. #modules), r ^. #version) -- A malformed registry must not silently fall back to a stray root module. readContents :: FilePath -> IO RepoContents@@ -261,4 +333,52 @@ directory <- doesDirectoryExist src if directory then normalizePayload src dst ""- else when (".dhall" `T.isSuffixOf` T.pack name) $ normalizeDhallFile src >>= TIO.writeFile dst+ else when (".dhall" `T.isSuffixOf` T.pack name) $ normalizeDhallFile src >>= writeStagedText dst++-- | Normalization replaces only disposable staging bytes. A copied source may+-- be read-only (including immutable schema imports); do not change its original+-- permissions or lose executable bits merely to write the normalized copy.+writeStagedText :: FilePath -> Text -> IO ()+writeStagedText destination content = do+ permissions <- getPermissions destination+ setPermissions destination (setOwnerWritable True permissions)+ TIO.writeFile destination content++-- | Publish already validated staged bytes atomically across cache entries on+-- handled failures. No acquisition or project writes occur here.+publishStagedClosure :: FilePath -> [ClosureArtifact] -> IO (Either Text ())+publishStagedClosure cache artifacts = do+ collisions <- forM artifacts $ \artifact -> classifyInstallCollision (cache </> T.unpack (artifact ^. #name)) (artifact ^. #sourceUrl)+ let refused = [formatInstallRefusal (T.unpack (artifact ^. #name)) (artifact ^. #sourceUrl) collision | (artifact, collision) <- zip artifacts collisions, blocked collision]+ if not (null refused)+ then pure (Left (T.intercalate "\n" refused))+ else do+ result <- try @IOException $ do+ createDirectoryIfMissing True cache+ transaction <- createTempDirectory cache ".seihou-transaction"+ changed <- newIORef []+ let rollback =+ readIORef changed+ >>= mapM_+ ( \(dest, backup, existed) -> do+ present <- doesDirectoryExist dest+ when present (removeDirectoryRecursive dest)+ when existed (renameDirectory backup dest)+ )+ mask $ \restore ->+ ( forM_ (zip artifacts collisions) $ \(artifact, collision) -> do+ let name = T.unpack (artifact ^. #name)+ dest = cache </> name+ backup = transaction </> name+ current <- classifyInstallCollision dest (artifact ^. #sourceUrl)+ unless (current == collision) $ throwIO (userError "Install cache changed during recipe upgrade; retry the same upgrade command.")+ exists <- doesDirectoryExist dest+ when exists (renameDirectory dest backup)+ modifyIORef' changed ((dest, backup, exists) :)+ restore $ do+ createDirectoryIfMissing True dest+ copyDirectoryRecursive (artifact ^. #directory) dest+ )+ `onException` rollback+ removeDirectoryRecursive transaction+ pure (first (T.pack . displayException) result)
src/Seihou/CLI/ManifestCapabilityUpgrade.hs view
@@ -30,6 +30,7 @@ resolveLegacySeedOwnership, prepareSeedOwnership, prepareRecordedSeedOwnership,+ prepareRecipeInheritance, gatherSeedOwnershipEvidence, CertificationScope (..), EvidencePolicy (..),@@ -532,3 +533,11 @@ Left err -> pure (Left err) Right prepared -> withSystemTempDirectory "seihou-seed-evidence" $ \session -> prepareSeedOwnership paths prepared (gatherSeedOwnershipEvidence (FetchRecordedReleases session) root searchPaths prepared seedOperationClaims)++-- | Lossless preparation is in memory. The accepting operation owns publication.+prepareRecipeInheritance :: Manifest -> Either Text Manifest+prepareRecipeInheritance manifest = do+ (_, document) <-+ first renderManifestUpgradeError $+ upgradeDocumentLosslessly (max (manifest ^. #version) (minimumManifestVersion RecipeInheritance)) (Aeson.toJSON manifest)+ first T.pack (manifestFromJSON (Aeson.encode document))
src/Seihou/CLI/ManifestGuard.hs view
@@ -20,6 +20,7 @@ ArtifactVerdict (..), ArtifactCheck (..), judgeArtifact,+ checkRecipeChain, -- * Checking a manifest against this machine checkAppliedArtifacts,@@ -41,13 +42,13 @@ where import Data.Generics.Labels ()-import Data.List (maximumBy, nubBy)+import Data.List (find, 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 (isMachineLocalOriginUrl, normalizeOriginUrl, normalizeProjectPath)+import Seihou.Core.ArtifactIdentity (isMachineLocalOriginUrl, normalizeOriginUrl, normalizeProjectPath, sameArtifactIdentity) import Seihou.Core.ArtifactOriginDetect (detectArtifactOrigin) import Seihou.Core.ArtifactRef ( ArtifactRefError,@@ -55,14 +56,19 @@ resolveArtifactOrigin, ) import Seihou.Core.Types- ( AppliedBlueprint (..),+ ( ApplicationId,+ AppliedBlueprint (..), AppliedBlueprintMigration (..),+ AppliedComposition (..), AppliedModule (..),+ AppliedRecipeNode (..),+ AppliedTarget (..), ArtifactOrigin (..), Blueprint (..), Manifest (..), Module (..), ModuleName (..),+ RecipeName (..), ) import Seihou.Core.Version (parseVersion) import Seihou.Dhall.Eval (evalBlueprintFromFile, evalModuleFromFile)@@ -569,3 +575,37 @@ originDescription (RemoteOrigin url _ _) = url originDescription (ProjectOrigin path) = T.pack path <> " (inside this project)" originDescription (LocalOrigin artifact) = artifact <> " (no recorded provenance)"++-- | Compare against the selected application's own history, rather than the+-- manifest's last-recipe summary. Missing history stays explicitly unknown.+checkRecipeChain :: ApplicationId -> [AppliedRecipeNode] -> Manifest -> ([ArtifactCheck], [Text])+checkRecipeChain selected current manifest =+ let results = map check [app | app <- manifest ^. #applications, app ^. #applicationId == selected]+ in (nubBy (\a b -> a ^. #name == b ^. #name && a ^. #origin == b ^. #origin) (concatMap fst results), concatMap snd results)+ where+ byName name = find (\node -> node ^. #name == name) current+ compareNode old new =+ ArtifactCheck+ (ModuleName (old ^. #name . #unRecipeName))+ (old ^. #origin)+ (judgeArtifact (old ^. #origin) (old ^. #recipeVersion) (new ^. #origin) (new ^. #recipeVersion))+ label node = node ^. #name . #unRecipeName+ version node = fromMaybe "<unversioned>" (node ^. #recipeVersion)+ check app =+ let targetCheck = case app ^. #target of+ AppliedRecipeTarget name -> case byName name of+ Just node -> [compareNode (AppliedRecipeNode name (app ^. #targetOrigin) (app ^. #targetVersion) (node ^. #descriptorHash)) node]+ Nothing -> []+ _ -> []+ in case app ^. #recipeChain of+ Nothing -> (targetCheck, ["Record current recipe-chain provenance; the prior chain is unknown." | not (null current)])+ Just previous ->+ ( targetCheck <> [compareNode old new | old <- previous, Just new <- [byName (old ^. #name)]],+ ["Removed recipe from chain: " <> label old | old <- previous, byName (old ^. #name) == Nothing]+ <> ["Added recipe to chain: " <> label new | new <- current, not (any (\old -> old ^. #name == new ^. #name) previous)]+ <> concat [changes old new | old <- previous, Just new <- [byName (old ^. #name)]]+ )+ changes old new =+ ["Recipe version changed: " <> label new <> " " <> version old <> " -> " <> version new | old ^. #recipeVersion /= new ^. #recipeVersion]+ <> ["Recipe descriptor changed: " <> label new <> " (" <> version new <> ")" | old ^. #descriptorHash /= new ^. #descriptorHash]+ <> ["Recipe origin changed: " <> label new | not (sameArtifactIdentity (old ^. #origin) (new ^. #origin))]
src/Seihou/CLI/SchemaVersion.hs view
@@ -9,11 +9,11 @@ -- | Raw URL for the seihou-schema package.dhall at a pinned commit schemaUrl :: Text-schemaUrl = "https://raw.githubusercontent.com/shinzui/seihou-schema/d3c78cd81d9697ebff3128732ec673a17e65c73f/package.dhall"+schemaUrl = "https://raw.githubusercontent.com/shinzui/seihou-schema/dbeff0dd67c15b7a1c57f90b23103afdc2fa8056/package.dhall" -- | SHA256 integrity hash for the schema import schemaHash :: Text-schemaHash = "sha256:49297b712cb7fd4b38f3d7c7eb41f34685638e306058913e5129a79157e298aa"+schemaHash = "sha256:065c27b4d26059a7641e8ee7ee9d23ed32a698052c6aa8966426e6a678ee0e82" -- | Complete Dhall import line for use in generated modules schemaImportLine :: Text
src/Seihou/CLI/Update.hs view
@@ -21,6 +21,8 @@ import Control.Exception (SomeException, displayException, onException, throwIO, toException, try) import Control.Monad (foldM, forM, forM_, when)+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Trans.Except (ExceptT (..), runExceptT) import Data.Aeson qualified as Aeson import Data.ByteString qualified as BS import Data.ByteString.Lazy qualified as LBS@@ -38,6 +40,7 @@ import Seihou.CLI.CommandExecution import Seihou.CLI.InstallShared (InstallOutcome (..), installModuleDir, summarizeInstallRefusal) import Seihou.CLI.ManifestCapabilityUpgrade (CertificationGap (..), CertificationScope (..), EvidencePolicy (..), EvidenceSource, SharedWriteCertification, certifiedChanges, certifySharedWriteModesIO, prepareRecordedSeedOwnership)+import Seihou.CLI.ManifestGuard (blockingChecks, checkRecipeChain, formatGuardRefusal) import Seihou.CLI.Shared (deriveNamespace, toVarNameMap) import Seihou.CLI.Update.Migrations import Seihou.CLI.Update.Recovery@@ -46,17 +49,18 @@ import Seihou.CLI.Update.Types import Seihou.Composition.Instance (ModuleInstance (..)) import Seihou.Composition.Plan (ComposedPlan (..), compileComposedPlan)-import Seihou.Composition.Recipe (expandRecipe)+import Seihou.Composition.Recipe (ExpandedRecipe (..), ResolvedRecipeMember (..), ResolvedRecipeNode (..), recipeLiteralSources)+import Seihou.Composition.RecipeChain (loadRecipeChain, recordRecipeChain) import Seihou.Composition.Resolve ( PromptPermission (..), RecipeInputSpec (..), SavedInstanceValues, loadComposition,- resolveRecipeWithPrompts,+ resolveRecipeWithSources, verifyDependencySources, ) import Seihou.Core.Application (buildAppliedComposition, mkApplicationId, replaceAppliedComposition)-import Seihou.Core.ArtifactIdentity (sameArtifactIdentity)+import Seihou.Core.ArtifactIdentity (isMachineLocalOriginUrl, sameArtifactIdentity) import Seihou.Core.ArtifactOriginDetect (detectArtifactOrigin) import Seihou.Core.ArtifactRef (renderArtifactRefError, resolveArtifactOrigin) import Seihou.Core.Checkout@@ -86,6 +90,7 @@ import Seihou.Manifest.JSON (decodeManifestValue) import Seihou.Manifest.Types ( currentManifestVersion,+ emptyManifest, manifestFromJSON, manifestSupports, minimumManifestVersion,@@ -159,7 +164,7 @@ selectedIdsForSeeds = Set.fromList (map (^. #candidate . #applicationId) plannedApplications) neededLegacy = Set.fromList [path | (path, receipt) <- Map.toAscList (base ^. #seeds), LegacySeedOwners apps <- [receipt ^. #ownership], Map.member path claims || not (Set.null (apps `Set.intersection` selectedIdsForSeeds))] relevant = not (Map.null claims) || any (\receipt -> not (Set.null (seedApplicationIds receipt `Set.intersection` selectedIdsForSeeds))) (Map.elems (base ^. #seeds))- structurallyPrepared = if relevant then prepareManifestSchema manifestPath SeedOwnerClaims document base else Right base+ structurallyPrepared = prepareManifestSchema manifestPath RecipeInheritance document base >>= \prepared -> if relevant then prepareManifestSchema manifestPath SeedOwnerClaims (Aeson.toJSON prepared) prepared else Right prepared paths <- defaultSearchPaths preparedResult <- case structurallyPrepared of Left err -> pure (Left err)@@ -210,6 +215,7 @@ observePaths projectRoot (Set.insert (".seihou" </> "manifest.json") transactionTargets)+ cacheChanges <- candidateCacheChanges installedDirectory usedArtifacts let snapshot = UpdateSnapshot { sessionDirectory,@@ -235,6 +241,7 @@ checkoutAdoptions, commandPlan, candidateArtifacts = usedArtifacts,+ cacheChanges, warnings, request, snapshot,@@ -578,92 +585,134 @@ IO (Either UpdateError PlannedApplication) planApplication request projectRoot catalog now previous = do fallback <- defaultSearchPaths- case candidateRoot catalog previous of+ rootResult <- candidateRoot projectRoot catalog previous+ case rootResult of Left err -> pure (Left err)- Right (primary, recipeAdditional, recipeOverrides, targetArtifact) -> do- let allAdditional = recipeAdditional <> (previous ^. #additionalModules)- loaded <- loadCandidateComposition (catalog ^. #searchRoot : fallback) targetArtifact primary allAdditional- case loaded of- Left err -> pure (Left (CandidateLoadFailed (primary ^. #unModuleName) err))- Right modulesInOrder -> do- let savedValues- | (request ^. #reconfigure) = Map.empty- | otherwise = savedInstanceValues previous- namespace = fromMaybe (deriveNamespace primary) (previous ^. #namespace)- context = fromMaybe "" (previous ^. #context)- resolved <- resolveApplicationValues request namespace context savedValues (artifactRecipeInputs targetArtifact (if request ^. #reconfigure then Nothing else previous ^. #recipeInputs)) recipeOverrides modulesInOrder- case resolved of- Left err -> pure (Left err)- Right (recipeValues, resolvedValues) -> do- compiled <-- compileComposedPlan- [ (instanceId, modul, directory, Map.map (^. #value) (resolvedValues Map.! instanceId))- | (instanceId, modul, directory) <- modulesInOrder- ]- case compiled of- Left errors -> pure (Left (UpdateCompositionFailed errors))- Right ComposedPlan {operations, warnings = compositionWarnings, managedOwners = rawOwners, seedOwners} -> do- proposedOrigin <- publishedArtifactOrigin projectRoot targetArtifact- let targetOrigin = if sameArtifactIdentity proposedOrigin (previous ^. #targetOrigin) then previous ^. #targetOrigin else proposedOrigin- proposedModules <- traverse (withInstanceOrigin projectRoot catalog) modulesInOrder- let originedModules = [(instanceId, modul, maybe origin (\state -> if sameArtifactIdentity origin (state ^. #origin) then state ^. #origin else origin) (find (\state -> state ^. #name == instanceId ^. #module_ && state ^. #parentVars == instanceId ^. #parentVars) (previous ^. #instances))) | (instanceId, modul, origin) <- proposedModules]- let candidate0 =- buildAppliedComposition- (previous ^. #target)- targetOrigin- (targetArtifact ^. #version)- (previous ^. #additionalModules)- (Just namespace)- (previous ^. #context)- originedModules- resolvedValues- now- & #recipeInputs- .~ recordedRecipeInputs (previous ^. #target) recipeValues- & #checkoutCommands- .~ checkoutCommandsFromOperations operations- & #applicationId- .~ (previous ^. #applicationId)- candidate =- setCompositionState- (candidate0 ^. #instances)- (previous ^. #commandReceipts)- candidate0- desiredOwners =- Map.map- (\owner -> DesiredFileOwner owner (Set.singleton (candidate ^. #applicationId)))- rawOwners- renderedWarnings = map compositionWarning compositionWarnings- pure- ( Right- PlannedApplication- { previous = Just previous,- candidate,- modulesInOrder,- resolvedValues,- operations = expandSeedClaims seedOwners operations,- desiredOwners- }- )+ Right CandidateRoot {primary, additional = recipeAdditional, literals = recipeOverrides, artifact = targetArtifact, expansion} -> do+ chain <- maybe (pure []) recordRecipeChain expansion+ let (checks, _) = checkRecipeChain (previous ^. #applicationId) chain (emptyManifest now & #applications .~ [previous])+ if not (request ^. #allowDowngrade) && not (null (blockingChecks checks))+ then pure (Left (UpdateCompositionFailed [formatGuardRefusal (blockingChecks checks)]))+ else do+ let allAdditional = recipeAdditional <> (previous ^. #additionalModules)+ loaded <- loadCandidateComposition (catalog ^. #searchRoot : fallback) targetArtifact primary allAdditional+ case loaded of+ Left err -> pure (Left (CandidateLoadFailed (primary ^. #unModuleName) err))+ Right modulesInOrder -> do+ let savedValues+ | (request ^. #reconfigure) = Map.empty+ | otherwise = savedInstanceValues previous+ namespace = fromMaybe (deriveNamespace primary) (previous ^. #namespace)+ context = fromMaybe "" (previous ^. #context)+ resolved <- resolveApplicationValues request namespace context savedValues (artifactRecipeInputs expansion (if request ^. #reconfigure then Nothing else previous ^. #recipeInputs)) recipeOverrides modulesInOrder+ case resolved of+ Left err -> pure (Left err)+ Right (recipeValues, resolvedValues) -> do+ compiled <-+ compileComposedPlan+ [ (instanceId, modul, directory, Map.map (^. #value) (resolvedValues Map.! instanceId))+ | (instanceId, modul, directory) <- modulesInOrder+ ]+ case compiled of+ Left errors -> pure (Left (UpdateCompositionFailed errors))+ Right ComposedPlan {operations, warnings = compositionWarnings, managedOwners = rawOwners, seedOwners} -> do+ proposedOrigin <- case reverse chain of+ node : _ -> pure (node ^. #origin)+ [] -> publishedArtifactOrigin projectRoot targetArtifact+ let targetOrigin = if sameArtifactIdentity proposedOrigin (previous ^. #targetOrigin) then previous ^. #targetOrigin else proposedOrigin+ proposedModules <- traverse (withInstanceOrigin projectRoot catalog) modulesInOrder+ let originedModules = [(instanceId, modul, maybe origin (\state -> if sameArtifactIdentity origin (state ^. #origin) then state ^. #origin else origin) (find (\state -> state ^. #name == instanceId ^. #module_ && state ^. #parentVars == instanceId ^. #parentVars) (previous ^. #instances))) | (instanceId, modul, origin) <- proposedModules]+ let candidate0 =+ buildAppliedComposition+ (previous ^. #target)+ targetOrigin+ (targetArtifact ^. #version)+ (previous ^. #additionalModules)+ (Just namespace)+ (previous ^. #context)+ originedModules+ resolvedValues+ now+ & #recipeChain+ .~ Just chain+ & #recipeInputs+ .~ recordedRecipeInputs (previous ^. #target) recipeValues+ & #checkoutCommands+ .~ checkoutCommandsFromOperations operations+ & #applicationId+ .~ (previous ^. #applicationId)+ candidate =+ setCompositionState+ (candidate0 ^. #instances)+ (previous ^. #commandReceipts)+ candidate0+ desiredOwners =+ Map.map+ (\owner -> DesiredFileOwner owner (Set.singleton (candidate ^. #applicationId)))+ rawOwners+ renderedWarnings = map compositionWarning compositionWarnings+ pure+ ( Right+ PlannedApplication+ { previous = Just previous,+ candidate,+ modulesInOrder,+ resolvedValues,+ operations = expandSeedClaims seedOwners operations,+ desiredOwners+ }+ ) where compositionWarning (FileOverwritten path old new) = CrossApplicationLastWriter path old new compositionWarning (ContentMerged path old new) = CrossApplicationLastWriter path old new compositionWarning (SeedContentIgnored path old new) = CrossApplicationLastWriter path old new -candidateRoot ::- CandidateCatalog ->- AppliedComposition ->- Either UpdateError (ModuleName, [ModuleName], Map VarName Text, CandidateArtifact)-candidateRoot catalog previous = case previous ^. #target of+data CandidateRoot = CandidateRoot+ { primary :: !ModuleName,+ additional :: ![ModuleName],+ literals :: !(Map VarName (Text, VarSource)),+ artifact :: !CandidateArtifact,+ expansion :: !(Maybe ExpandedRecipe)+ }+ deriving stock (Generic)++candidateRoot :: FilePath -> CandidateCatalog -> AppliedComposition -> IO (Either UpdateError CandidateRoot)+candidateRoot projectRoot catalog previous = runExceptT $ case previous ^. #target of AppliedModuleTarget name -> do- artifact <- lookupArtifact catalog CandidateModule (name ^. #unModuleName)- Right (name, [], Map.empty, artifact)+ artifact <- ExceptT (pure (lookupArtifact catalog CandidateModule (name ^. #unModuleName)))+ pure (CandidateRoot name [] Map.empty artifact Nothing) AppliedRecipeTarget name -> do- artifact <- lookupArtifact catalog CandidateRecipe (name ^. #unRecipeName)- recipe <- maybe (Left (CandidateArtifactMissing CandidateRecipe (name ^. #unRecipeName))) Right (artifact ^. #recipeDefinition)- (primary, additional, overrides, _, _, _) <- first (CandidateRepositoryInvalid (name ^. #unRecipeName)) (expandRecipe recipe)- Right (primary, additional, overrides, artifact)+ artifact <- ExceptT (pure (lookupArtifact catalog CandidateRecipe (name ^. #unRecipeName)))+ recipe <- ExceptT (pure (maybe (Left (CandidateArtifactMissing CandidateRecipe (name ^. #unRecipeName))) Right (artifact ^. #recipeDefinition)))+ expanded <- ExceptT (fmap (first (CandidateLoadFailed (name ^. #unRecipeName))) (loadRecipeChain projectRoot [catalog ^. #searchRoot] recipe (artifact ^. #sourceDirectory)))+ portable <- liftIO (portableExpansion projectRoot catalog expanded)+ let sources = case recipe ^. #extends of+ Nothing -> Map.map (\literal -> (literal ^. #value, FromRecipeBinding)) (portable ^. #literals)+ Just _ -> recipeLiteralSources portable+ pure (CandidateRoot (portable ^. #primary) (drop 1 (map (^. #dependency . #module_) (portable ^. #members))) sources artifact (Just portable)) +-- Staging directories are machine-local. Recover each recipe's portable+-- identity from its candidate provenance or original project location.+portableExpansion :: FilePath -> CandidateCatalog -> ExpandedRecipe -> IO ExpandedRecipe+portableExpansion root catalog expanded = do+ nodes <- forM (expanded ^. #chain) $ \node -> do+ let name = node ^. #definition . #name . #unRecipeName+ origin <- case Map.lookup (CandidateRecipe, name) (catalog ^. #artifacts) of+ Nothing -> pure (node ^. #origin)+ Just artifact -> case artifact ^. #sourceUrl of+ Just source | isMachineLocalOriginUrl source -> pure (LocalOrigin name)+ _ -> publishedArtifactOrigin root artifact+ pure (node & #origin .~ origin)+ let origins = Map.fromList [(node ^. #definition . #name, node ^. #origin) | node <- nodes]+ let retagMember member = do+ memberOrigin <- case Map.lookup (CandidateModule, member ^. #dependency . #module_ . #unModuleName) (catalog ^. #artifacts) of+ Nothing -> pure (member ^. #memberOrigin)+ Just artifact -> publishedArtifactOrigin root artifact+ pure (member & #declaringOrigin .~ Map.findWithDefault (member ^. #declaringOrigin) (member ^. #declaringRecipe) origins & #memberOrigin .~ memberOrigin)+ members <- traverse retagMember (expanded ^. #members)+ fullNodes <- traverse (\node -> (\nodeMembers -> node & #members .~ nodeMembers) <$> traverse retagMember (node ^. #members)) nodes+ pure (expanded & #chain .~ fullNodes & #members .~ members & #literals %~ Map.map (\literal -> literal & #origin .~ Map.findWithDefault (literal ^. #origin) (literal ^. #recipe) origins))+ lookupArtifact :: CandidateCatalog -> CandidateArtifactKind -> Text -> Either UpdateError CandidateArtifact lookupArtifact catalog kind name = maybe (Left (CandidateArtifactMissing kind name)) Right (Map.lookup (kind, name) (catalog ^. #artifacts))@@ -672,10 +721,9 @@ recordedRecipeInputs (AppliedRecipeTarget _) values = Just (Map.map (varValueToText . (^. #value)) values) recordedRecipeInputs _ _ = Nothing -artifactRecipeInputs :: CandidateArtifact -> Maybe (Map VarName Text) -> RecipeInputSpec-artifactRecipeInputs artifact saved = case artifact ^. #recipeDefinition of- Just recipe -> RecipeInputSpec (recipe ^. #vars) (recipe ^. #prompts) saved- Nothing -> RecipeInputSpec [] [] saved+artifactRecipeInputs :: Maybe ExpandedRecipe -> Maybe (Map VarName Text) -> RecipeInputSpec+artifactRecipeInputs (Just expanded) saved = RecipeInputSpec (expanded ^. #declarations) (expanded ^. #prompts) saved+artifactRecipeInputs Nothing saved = RecipeInputSpec [] [] saved resolveApplicationValues :: UpdateRequest ->@@ -683,7 +731,7 @@ Text -> SavedInstanceValues -> RecipeInputSpec ->- Map VarName Text ->+ Map VarName (Text, VarSource) -> [(ModuleInstance, Module, FilePath)] -> IO (Either UpdateError (Map VarName ResolvedVar, Map ModuleInstance (Map VarName ResolvedVar))) resolveApplicationValues request namespace context saved recipeSpec recipeOverrides modulesInOrder = do@@ -697,14 +745,19 @@ promptPermission = case request ^. #promptPolicy of AllowPrompts -> PromptsAllowed ForbidPrompts -> PromptsForbidden+ -- An omitted optional answer is also a saved choice. Ordinary update+ -- must not ask for it again merely because stdin is a terminal.+ let replayModules+ | request ^. #reconfigure = modulesInOrder+ | otherwise = [(inst, modul & #prompts %~ filter (\prompt -> any (\decl -> decl ^. #name == prompt ^. #var && decl ^. #required) (modul ^. #vars)), dir) | (inst, modul, dir) <- modulesInOrder] result <- runEff $ runConsole $- resolveRecipeWithPrompts+ resolveRecipeWithSources promptPermission False recipeSpec- modulesInOrder+ replayModules saved cli recipeOverrides@@ -737,30 +790,32 @@ seedLegacyApplication request session projectRoot installed manifest now requested = case roots of [] -> fmap (fmap (\(apps, warnings) -> (apps, warnings, Nothing))) (seedInstalledLegacyApplication request projectRoot manifest now requested) (target, origin, version) : _ -> do- let provisional = AppliedComposition (mkApplicationId target []) target origin version [] (Just (deriveNamespace (ModuleName requested))) Nothing [] Map.empty [] Nothing now+ let provisional = AppliedComposition (mkApplicationId target []) target origin version [] (Just (deriveNamespace (ModuleName requested))) Nothing [] Map.empty [] Nothing Nothing now staged <- stageCandidateSources (session </> "legacy-candidate") projectRoot installed [provisional] case staged of Left err -> pure (Left err)- Right (catalog, sourceWarnings) -> case candidateRoot catalog provisional of- Left err -> pure (Left err)- Right (primary, additional, overrides, artifact) -> do- paths <- defaultSearchPaths- loaded <- loadCandidateComposition (catalog ^. #searchRoot : paths) artifact primary additional- case loaded of- Left err -> pure (Left (CandidateLoadFailed requested err))- Right modulesInOrder -> do- let (saved, legacyWarnings) = legacySavedValues manifest modulesInOrder- namespace = deriveNamespace primary- resolved <- resolveApplicationValues request namespace "" saved (artifactRecipeInputs artifact Nothing) overrides modulesInOrder- case resolved of- Left err -> pure (Left err)- Right (recipeValues, values) -> do- origined <- traverse (withInstanceOrigin projectRoot catalog) modulesInOrder- let recorded = buildAppliedComposition target origin version additional (Just namespace) Nothing origined values now & #recipeInputs .~ recordedRecipeInputs target recipeValues & #instances %~ map (restoreLegacyVersion manifest)- planned <- planApplication request projectRoot catalog now recorded- pure $ do- candidate <- planned- Right ([recorded], legacyWarnings, Just (StagedSelection (Set.singleton (recorded ^. #applicationId)) catalog sourceWarnings [candidate]))+ Right (catalog, sourceWarnings) -> do+ rootResult <- candidateRoot projectRoot catalog provisional+ case rootResult of+ Left err -> pure (Left err)+ Right CandidateRoot {primary, additional, literals = overrides, artifact, expansion} -> do+ paths <- defaultSearchPaths+ loaded <- loadCandidateComposition (catalog ^. #searchRoot : paths) artifact primary additional+ case loaded of+ Left err -> pure (Left (CandidateLoadFailed requested err))+ Right modulesInOrder -> do+ let (saved, legacyWarnings) = legacySavedValues manifest modulesInOrder+ namespace = deriveNamespace primary+ resolved <- resolveApplicationValues request namespace "" saved (artifactRecipeInputs expansion Nothing) overrides modulesInOrder+ case resolved of+ Left err -> pure (Left err)+ Right (recipeValues, values) -> do+ origined <- traverse (withInstanceOrigin projectRoot catalog) modulesInOrder+ let recorded = buildAppliedComposition target origin version [] (Just namespace) Nothing origined values now & #recipeInputs .~ recordedRecipeInputs target recipeValues & #instances %~ map (restoreLegacyVersion manifest)+ planned <- planApplication request projectRoot catalog now recorded+ pure $ do+ candidate <- planned+ Right ([recorded], legacyWarnings, Just (StagedSelection (Set.singleton (recorded ^. #applicationId)) catalog sourceWarnings [candidate])) where roots = [(AppliedModuleTarget (applied ^. #name), applied ^. #origin, applied ^. #moduleVersion) | applied <- manifest ^. #modules, applied ^. #name == ModuleName requested, applied ^. #parentVars == emptyParentVars]@@ -774,46 +829,40 @@ case discovered of Left err -> pure (Left (CandidateLoadFailed requested err)) Right runnable -> do- let root = case runnable of- RunnableModule modul directory -> Right (AppliedModuleTarget (modul ^. #name), modul ^. #name, [], Map.empty, directory, modul ^. #version)- RunnableRecipe recipe directory -> do- (primary, additional, overrides, _, _, _) <- first (CandidateRepositoryInvalid requested) (expandRecipe recipe)- Right (AppliedRecipeTarget (recipe ^. #name), primary, additional, overrides, directory, recipe ^. #version)+ let artifactTarget = case runnable of+ RunnableModule modul dir -> Right (AppliedModuleTarget (modul ^. #name), dir, modul ^. #version)+ RunnableRecipe recipe dir -> Right (AppliedRecipeTarget (recipe ^. #name), dir, recipe ^. #version) _ -> Left (CandidateArtifactMissing CandidateModule requested)- case root of- Left err -> pure (Left err)- Right (target, primary, additional, recipeOverrides, targetSource, targetVersion) -> do- checked <- case runnable of- RunnableRecipe recipe directory -> verifyDependencySources searchPaths directory (recipe ^. #modules)- _ -> pure (Right ())- loaded <- case checked of- Left err -> pure (Left err)- Right () -> loadComposition searchPaths primary additional+ expandedResult <- case runnable of+ RunnableRecipe recipe dir -> fmap (fmap Just . first (CandidateLoadFailed requested)) (loadRecipeChain projectRoot searchPaths recipe dir)+ _ -> pure (Right Nothing)+ case (artifactTarget, expandedResult) of+ (Right (target, targetSource, targetVersion), Right expansion) -> do+ let primary = maybe (ModuleName requested) (^. #primary) expansion+ additional = maybe [] (drop 1 . map (^. #dependency . #module_) . (^. #members)) expansion+ overrides = maybe Map.empty recipeLiteralSources expansion+ loaded <- loadComposition searchPaths primary additional case loaded of Left err -> pure (Left (CandidateLoadFailed requested err)) Right modulesInOrder -> do let (saved, warnings) = legacySavedValues manifest modulesInOrder namespace = deriveNamespace primary- let recipeSpec = case runnable of- RunnableRecipe r _ -> RecipeInputSpec (r ^. #vars) (r ^. #prompts) Nothing- _ -> RecipeInputSpec [] [] Nothing- resolved <- resolveApplicationValues request namespace "" saved recipeSpec recipeOverrides modulesInOrder+ resolved <- resolveApplicationValues request namespace "" saved (artifactRecipeInputs expansion Nothing) overrides modulesInOrder case resolved of Left err -> pure (Left err) Right (recipeValues, resolvedValues) -> do targetOrigin <- detectArtifactOrigin projectRoot targetSource- originedModules <-- traverse- (\(instanceId, modul, directory) -> (instanceId,modul,) <$> detectArtifactOrigin projectRoot directory)- modulesInOrder- let provisional0 =- buildAppliedComposition target targetOrigin targetVersion [] (Just namespace) Nothing originedModules resolvedValues now & #recipeInputs .~ recordedRecipeInputs target recipeValues- provisional =- ( provisional0- & #instances- %~ map (restoreLegacyVersion manifest)- )+ originedModules <- traverse (\(instanceId, modul, dir) -> (instanceId,modul,) <$> detectArtifactOrigin projectRoot dir) modulesInOrder+ -- Unknown history remains unknown until the candidate is accepted.+ let provisional =+ buildAppliedComposition target targetOrigin targetVersion [] (Just namespace) Nothing originedModules resolvedValues now+ & #recipeInputs+ .~ recordedRecipeInputs target recipeValues+ & #instances+ %~ map (restoreLegacyVersion manifest) pure (Right ([provisional], warnings))+ (Left err, _) -> pure (Left err)+ (_, Left err) -> pure (Left err) legacySavedValues :: Manifest ->@@ -1005,6 +1054,18 @@ else Right () _ -> Right () +-- Restoring a fresh clone's missing cache is real accepted work even when+-- its recorded project already agrees with the candidate composition.+candidateCacheChanges :: FilePath -> [CandidateArtifact] -> IO [Text]+candidateCacheChanges installed artifacts = fmap catMaybes $ forM artifacts $ \artifact ->+ case artifact ^. #sourceUrl of+ Nothing -> pure Nothing+ Just _ -> do+ let destination = installed </> T.unpack (artifact ^. #name)+ present <- Directory.doesDirectoryExist destination+ current <- if present then Just <$> hashArtifactDirectory destination else pure Nothing+ pure (if current == Just (artifact ^. #contentHash) then Nothing else Just (artifact ^. #name))+ artifactsUsedBy :: CandidateCatalog -> [PlannedApplication] -> [CandidateArtifact] artifactsUsedBy catalog planned = Map.elems (Map.restrictKeys (catalog ^. #artifacts) keys) where@@ -1013,7 +1074,9 @@ concatMap applicationKeys planned applicationKeys application = targetKey (application ^. #candidate . #target)- : [(CandidateModule, modul ^. #name . #unModuleName) | (_, modul, _) <- application ^. #modulesInOrder]+ : ( [(CandidateModule, modul ^. #name . #unModuleName) | (_, modul, _) <- application ^. #modulesInOrder]+ <> [(CandidateRecipe, node ^. #name . #unRecipeName) | node <- fromMaybe [] (application ^. #candidate . #recipeChain)]+ ) targetKey (AppliedModuleTarget name) = (CandidateModule, name ^. #unModuleName) targetKey (AppliedRecipeTarget name) = (CandidateRecipe, name ^. #unRecipeName) @@ -1288,7 +1351,8 @@ commandReceipts = receipts, checkoutCommands = composition ^. #checkoutCommands, recipeInputs = composition ^. #recipeInputs,- appliedAt = composition ^. #appliedAt+ appliedAt = composition ^. #appliedAt,+ recipeChain = composition ^. #recipeChain } -- | The portable manifest identity an artifact will have once this update@@ -1324,9 +1388,8 @@ forM_ artifacts $ \artifact -> case artifact ^. #sourceUrl of Nothing -> pure () 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+ -- Pass force = False deliberately. Candidates follow recorded root URLs and+ -- producer-declared edges. 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
src/Seihou/CLI/Update/Render.hs view
@@ -31,6 +31,7 @@ summarizeCommandPlan, ) import Seihou.CLI.ManifestCapabilityUpgrade (CertificationGap (..), EvidenceSource (..), renderEvidenceSource)+import Seihou.CLI.ManifestGuard (blockingChecks, checkRecipeChain, formatGuardOverride) import Seihou.CLI.Shared (formatVarError) import Seihou.CLI.Update.Types import Seihou.Core.ArtifactRef (renderArtifactRefError)@@ -40,9 +41,11 @@ import Seihou.Core.Types ( ApplicationId (..), AppliedComposition (..),+ AppliedRecipeNode (..), AppliedTarget (..), BaselineRef (..), CommandFingerprint (..),+ Manifest (..), ManifestSchemaVersion (..), ModuleLoadError (..), ModuleName (..),@@ -78,7 +81,7 @@ ) import Seihou.Engine.Reconcile qualified as Reconcile import Seihou.Engine.UpdateTransaction (TransactionError (..))-import Seihou.Manifest.Types (currentManifestVersion, sharedWriteModeToText)+import Seihou.Manifest.Types (currentManifestVersion, emptyManifest, sharedWriteModeToText) import Seihou.Prelude newtype UpdatePlanView = UpdatePlanView UpdatePlan@@ -121,7 +124,9 @@ T.unlines $ seedLines (plan ^. #reconciliation) <> preparationLines (displayedPreparation plan)+ <> ["Cache: refresh " <> T.intercalate ", " (plan ^. #cacheChanges) | not (null (plan ^. #cacheChanges))] <> versionLines plan+ <> concatMap (recipeChainLines (plan ^. #request . #allowDowngrade)) (plan ^. #plannedApplications) <> [ renderInputs (plan ^. #inputChanges), "Migrations: " <> count (length (plan ^. #migrations)) <> migrationCaveat plan, renderFiles (reconciliationSummary (plan ^. #reconciliation)),@@ -162,6 +167,8 @@ "manifestPreparation" .= fmap preparationValue (displayedPreparation plan), "applications" .= map applicationIdText (plan ^. #applications), "versions" .= map versionValue (plan ^. #versionChanges),+ "cacheChanges" .= (plan ^. #cacheChanges),+ "recipeChains" .= [recipeChainValue app | app <- plan ^. #plannedApplications, chainChanged app], "inputs" .= inputValue (plan ^. #inputChanges), "migrations" .= map migrationValue (plan ^. #migrations), "checkout" .= checkoutReportJSON (CheckoutSyncResult (plan ^. #snapshot . #projectRoot) True (plan ^. #checkoutPlan) (CheckoutExecution Map.empty [] Nothing) [] [] []),@@ -788,3 +795,28 @@ showText :: (Show a) => a -> Text showText = T.pack . show++-- Additive schema-version-1 plan evidence: old readers may ignore this field.+-- Arrays retain full ordered portable node records, including descriptor hashes.+chainChanged :: PlannedApplication -> Bool+chainChanged app = case app ^. #candidate . #target of+ AppliedRecipeTarget _ -> (app ^. #previous >>= (^. #recipeChain)) /= app ^. #candidate . #recipeChain+ _ -> False++recipeChainValue :: PlannedApplication -> Value+recipeChainValue app =+ object+ [ "applicationId" .= (app ^. #candidate . #applicationId . #unApplicationId),+ "previous" .= (app ^. #previous >>= (^. #recipeChain)),+ "candidate" .= (app ^. #candidate . #recipeChain),+ "adopted" .= (isNothing (app ^. #previous >>= (^. #recipeChain)))+ ]++recipeChainLines :: Bool -> PlannedApplication -> [Text]+recipeChainLines allow app+ | not (chainChanged app) = []+ | otherwise =+ let current = app ^. #candidate+ manifest = emptyManifest (current ^. #appliedAt) & #applications .~ maybe [] pure (app ^. #previous)+ (checks, changes) = checkRecipeChain (current ^. #applicationId) (fromMaybe [] (current ^. #recipeChain)) manifest+ in changes <> [formatGuardOverride (blockingChecks checks) | allow, not (null (blockingChecks checks))]
src/Seihou/CLI/Update/Source.hs view
@@ -5,13 +5,19 @@ where import Control.Exception (SomeException, displayException, try)-import Control.Monad (foldM, forM, forM_)+import Control.Monad (foldM, forM, forM_, unless)+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Trans.Except (ExceptT (..), runExceptT) import Data.ByteString qualified as BS import Data.Foldable (traverse_) import Data.Generics.Labels ()-import Data.List (sort)+import Data.IORef+import Data.List (find, sort) import Data.Map.Strict qualified as Map+import Data.Maybe (maybeToList) import Data.Text qualified as T+import Data.Text.IO qualified as TIO+import Seihou.CLI.InstallClosure (normalizePayload, stageClosuresInto, writeStagedText) import Seihou.CLI.InstallShared ( OriginInfo (..), cloneRepo,@@ -25,7 +31,7 @@ import Seihou.Core.Recipe (validateRecipe) import Seihou.Core.Registry (Registry (..), RegistryEntry (..), validateRegistry) import Seihou.Core.Types-import Seihou.Dhall.Eval (evalModuleFromFile, evalRecipeFromFile, evalRegistryFromFile)+import Seihou.Dhall.Eval (evalModuleFromFile, evalRecipeFromFile, evalRegistryFromFile, normalizeDhallFile) import Seihou.Manifest.Hash (hashContent) import Seihou.Prelude import System.Directory qualified as Directory@@ -56,7 +62,11 @@ FilePath -> [AppliedComposition] -> IO (Either UpdateError (CandidateCatalog, [UpdateWarning]))-stageCandidateSources sessionRoot projectRoot installedDirectory selected = do+stageCandidateSources sessionRoot projectRoot installedDirectory selected+ | any (\app -> case app ^. #target of AppliedRecipeTarget _ -> True; _ -> False) selected = stageRecipeCandidateSources sessionRoot projectRoot installedDirectory selected+ | otherwise = stageFlatCandidateSources sessionRoot projectRoot installedDirectory selected++stageFlatCandidateSources sessionRoot projectRoot installedDirectory selected = do requirements <- requirementsFor projectRoot installedDirectory selected let remoteOrigins = Map.fromList@@ -400,3 +410,90 @@ then pure [] else collectFiles base childRelative else pure [childRelative]++-- | Recipe roots own their candidate closure. Historical base/member origins+-- remain comparison evidence and never become mandatory acquisition roots.+-- Remote traversal and normalization use the same kind-aware planner as install.+stageRecipeCandidateSources :: FilePath -> FilePath -> FilePath -> [AppliedComposition] -> IO (Either UpdateError (CandidateCatalog, [UpdateWarning]))+stageRecipeCandidateSources session projectRoot installed applications = runExceptT $ do+ let search = session </> "search"+ clones = session </> "clones"+ liftIO (Directory.createDirectoryIfMissing True search >> Directory.createDirectoryIfMissing True clones)+ roots <- liftIO (requirementsFor projectRoot installed (map rootScope applications))+ locals <- liftIO (newIORef Map.empty)+ remotes <- liftIO (newIORef [])+ let visit requirement = case requirement ^. #origin of+ Just _ -> liftIO (modifyIORef' remotes (requirement :))+ Nothing -> do+ known <- liftIO (readIORef locals)+ let key = (requirement ^. #kind, requirement ^. #name)+ unless (Map.member key known) $ do+ dir <- ExceptT (pure (first CandidateArtifactUnresolved (requirement ^. #sourceDirectory)))+ candidate <- ExceptT $ case requirement ^. #kind of+ CandidateModule -> loadModuleArtifact Nothing Nothing [] Nothing dir+ CandidateRecipe -> loadRecipeArtifact Nothing Nothing [] Nothing dir+ inserted <- ExceptT (insertCandidate search (Right known) candidate)+ let staged = inserted Map.! key+ liftIO $ do+ -- Resolve imports while the local declaring tree is available,+ -- without inventing a registry for implicit local edges.+ normalizePayload dir (staged ^. #sourceDirectory) (definitionFileFor (requirement ^. #kind))+ normalized <- normalizeDhallFile (dir </> definitionFileFor (requirement ^. #kind))+ writeStagedText (staged ^. #sourceDirectory </> definitionFileFor (requirement ^. #kind)) normalized+ writeIORef locals inserted+ mapM_ visit =<< liftIO (mapM edgeRequirement (candidateEdges candidate))+ edgeRequirement (kind, name, source) = do+ paths <- defaultSearchPaths+ resolved <- resolveArtifactOrigin projectRoot paths (definitionFileFor kind) (LocalOrigin name)+ pure (ArtifactRequirement kind name resolved (fmap (\url -> OriginInfo url Nothing Nothing) source))+ mapM_ visit roots+ remoteRequirements <- liftIO (readIORef remotes)+ let grouped = Map.elems (Map.fromListWith (\(origin, xs) (_, ys) -> (origin, xs <> ys)) [(normalizeOriginUrl (origin ^. #sourceUrl), (origin, [requirement])) | requirement <- remoteRequirements, Just origin <- [requirement ^. #origin]])+ groups <- forM (zip [0 :: Int ..] grouped) $ \(index, (origin, requirements)) -> do+ let url = origin ^. #sourceUrl+ clone = clones </> show index+ ExceptT (fmap (first (CandidateCloneFailed url)) (cloneRepo url clone))+ selected <- forM requirements $ \requirement -> do+ dir <- ExceptT (locateCandidateRoot clone requirement)+ pure (requirement ^. #name, dir)+ pure (clone, url, selected)+ remoteArtifacts <-+ if null groups+ then pure []+ else ExceptT $ do+ staged <- stageClosuresInto False search False groups+ pure (first (CandidateRepositoryInvalid "recipe candidate closure" . pure) staged)+ localArtifacts <- liftIO (readIORef locals)+ remoteCandidates <- forM remoteArtifacts $ \artifact -> do+ hasRecipe <- liftIO (Directory.doesFileExist (artifact ^. #directory </> "recipe.dhall"))+ ExceptT $+ if hasRecipe+ then loadRecipeArtifact (Just (artifact ^. #sourceUrl)) (artifact ^. #repoName) (artifact ^. #tags) (artifact ^. #sourceRevision) (artifact ^. #directory)+ else loadModuleArtifact (Just (artifact ^. #sourceUrl)) (artifact ^. #repoName) (artifact ^. #tags) (artifact ^. #sourceRevision) (artifact ^. #directory)+ let artifacts = Map.union localArtifacts (Map.fromList [((artifact ^. #kind, artifact ^. #name), artifact) | artifact <- remoteCandidates])+ pure (CandidateCatalog search artifacts (Map.fromList [(url, clone) | (clone, url, _) <- groups]), [LocalArtifactHasNoRemote name | ((_, name), _) <- Map.toList localArtifacts])+ where+ rootScope app = case app ^. #target of+ AppliedRecipeTarget _ -> app & #instances %~ filter (\state -> state ^. #name `elem` app ^. #additionalModules)+ _ -> app+ candidateEdges artifact =+ [ (CandidateModule, dep ^. #module_ . #unModuleName, dep ^. #source)+ | dep <- maybe [] (^. #dependencies) (artifact ^. #moduleDefinition) <> maybe [] (^. #modules) (artifact ^. #recipeDefinition)+ ]+ <> [(CandidateRecipe, ref ^. #recipe . #unRecipeName, ref ^. #source) | recipe <- maybeToList (artifact ^. #recipeDefinition), ref <- maybeToList (recipe ^. #extends)]++locateCandidateRoot :: FilePath -> ArtifactRequirement -> IO (Either UpdateError FilePath)+locateCandidateRoot repo requirement = do+ hasRegistry <- Directory.doesFileExist (repo </> "seihou-registry.dhall")+ if not hasRegistry+ then do+ present <- Directory.doesFileExist (repo </> definitionFileFor (requirement ^. #kind))+ pure (if present then Right repo else missing)+ else do+ result <- evalRegistryFromFile (repo </> "seihou-registry.dhall")+ pure $ do+ registry <- first (CandidateLoadFailed (requirement ^. #name)) result+ let entries = case requirement ^. #kind of CandidateModule -> registry ^. #modules; CandidateRecipe -> registry ^. #recipes+ maybe missing (Right . (repo </>) . (^. #path)) (find ((== requirement ^. #name) . (^. #name . #unModuleName)) entries)+ where+ missing = Left (CandidateArtifactMissing (requirement ^. #kind) (requirement ^. #name))
src/Seihou/CLI/Update/Types.hs view
@@ -226,6 +226,7 @@ checkoutAdoptions :: !(Map FilePath Text), commandPlan :: !CommandPlan, candidateArtifacts :: ![CandidateArtifact],+ cacheChanges :: ![Text], warnings :: ![UpdateWarning], request :: !UpdateRequest, snapshot :: !UpdateSnapshot,@@ -310,6 +311,7 @@ && Map.null (plan ^. #checkoutAdoptions) && all ((== UnchangedLink) . (^. #action)) (plan ^. #checkoutPlan . #entries) && isNothing (plan ^. #manifestPreparation)+ && null (plan ^. #cacheChanges) && null (plan ^. #versionChanges) && null (plan ^. #migrations) && plan ^. #inputChanges . #overridden == 0@@ -351,6 +353,7 @@ && previous ^. #namespace == candidate ^. #namespace && previous ^. #context == candidate ^. #context && previous ^. #recipeInputs == candidate ^. #recipeInputs+ && previous ^. #recipeChain == candidate ^. #recipeChain && length (previous ^. #instances) == length (candidate ^. #instances) && and (zipWith sameInstance (previous ^. #instances) (candidate ^. #instances)) && previous ^. #commandReceipts == (candidate ^. #commandReceipts)
test/Main.hs view
@@ -35,6 +35,7 @@ import Seihou.CLI.MigrateSpec qualified as MigrateSpec import Seihou.CLI.PendingMigrationSpec qualified as PendingMigrationSpec import Seihou.CLI.PromptRenderSpec qualified as PromptRenderSpec+import Seihou.CLI.RecipeExtensionE2ESpec qualified as RecipeExtensionE2E import Seihou.CLI.RecipeInputsE2ESpec qualified as RecipeInputsE2E import Seihou.CLI.RecordedReleaseSpec qualified as RecordedReleaseSpec import Seihou.CLI.Registry.SyncSpec qualified as RegistrySyncSpec@@ -61,7 +62,8 @@ main = do tests <- sequence- [ AgentLaunchSpec.tests,+ [ RecipeExtensionE2E.tests,+ AgentLaunchSpec.tests, AgentMigrateE2ESpec.tests, AgentGuardE2ESpec.tests, AgentCompletionSpec.tests,
test/Seihou/CLI/InstallClosureSpec.hs view
@@ -1,7 +1,8 @@ module Seihou.CLI.InstallClosureSpec (tests) where import Data.Either (isLeft)-import Seihou.CLI.InstallClosure (installClosureInto)+import Data.Text qualified as T+import Seihou.CLI.InstallClosure (installClosureInto, publishStagedClosure, stageClosuresInto) import Seihou.CLI.InstallShared (installModuleDirInto) import System.Directory import System.FilePath ((</>))@@ -12,6 +13,78 @@ tests :: IO TestTree tests = testSpec "Seihou.CLI.InstallClosure" $ do+ it "acquires same-registry recipe bases, materializes their source, and repairs a missing base" $+ withSystemTempDirectory "closure-recipes" $ \tmp -> do+ let repo = tmp </> "repo"+ cache = tmp </> "cache"+ source = "https://example.com/registry.git"+ moduleDir repo "member"+ recipeDir repo "base" "[\"member\"]" ""+ recipeDir repo "child" "[] : List Text" ", extends = Some {recipe = \"base\"}"+ registry repo ["member"] ["base", "child"]+ installClosureInto cache False repo source [("child", repo </> "child")] `shouldReturn` Right ()+ doesFileExist (cache </> "base/recipe.dhall") `shouldReturn` True+ normalized <- readFile (cache </> "child/recipe.dhall")+ T.pack normalized `shouldSatisfy` T.isInfixOf source+ removeDirectoryRecursive (cache </> "base")+ installClosureInto cache False repo source [("child", repo </> "child")] `shouldReturn` Right ()+ doesFileExist (cache </> "base/recipe.dhall") `shouldReturn` True++ it "normalizes read-only descriptors and payload imports without changing source permissions" $+ withSystemTempDirectory "closure-read-only" $ \tmp -> do+ let repo = tmp </> "repo"+ cache = tmp </> "cache"+ descriptor = repo </> "member/module.dhall"+ payload = repo </> "member/files/value.dhall"+ moduleDir repo "member"+ createDirectoryIfMissing True (repo </> "member/files")+ writeFile payload "let value = \"hello\" in value"+ mapM_ (\file -> getPermissions file >>= setPermissions file . setOwnerWritable False) [descriptor, payload]+ before <- mapM getPermissions [descriptor, payload]+ installClosureInto cache False repo "https://example.com/registry.git" [("member", repo </> "member")] `shouldReturn` Right ()+ mapM getPermissions [descriptor, payload] `shouldReturn` before+ normalized <- readFile (cache </> "member/files/value.dhall")+ T.strip (T.pack normalized) `shouldBe` "\"hello\""++ it "rejects wrong-kind bases, range violations, cycles and invalid merged overrides before publishing" $+ withSystemTempDirectory "closure-recipe-refusals" $ \tmp -> do+ let repo = tmp </> "repo"+ cache = tmp </> "cache"+ source = "https://example.com/registry.git"+ moduleDir repo "member"+ recipeDir repo "base" "[\"member\"]" ""+ registry repo ["member"] ["base", "child"]+ mapM_+ ( \extension -> do+ recipeDir repo "child" "[] : List Text" extension+ result <- installClosureInto cache False repo source [("child", repo </> "child")]+ result `shouldSatisfy` isLeft+ doesDirectoryExist cache `shouldReturn` False+ )+ [ ", extends = Some {recipe = \"member\"}",+ ", extends = Some {recipe = \"base\", versionRange = Some {minimum = \"2\", before = \"3\"}}",+ ", extends = Some {recipe = \"child\"}",+ ", extends = Some {recipe = \"base\"}, moduleOverrides = [{module = \"missing\", vars = [{name = \"x\", value = \"new\"}]}]"+ ]++ it "rejects indirect recipe cycles and recipe names used as module edges" $+ withSystemTempDirectory "closure-recipe-kinds" $ \tmp -> do+ let repo = tmp </> "repo"+ cache = tmp </> "cache"+ source = "https://example.com/registry.git"+ moduleDir repo "member"+ recipeDir repo "base" "[] : List Text" ", extends = Some {recipe = \"child\"}"+ recipeDir repo "child" "[] : List Text" ", extends = Some {recipe = \"base\"}"+ registry repo ["member"] ["base", "child"]+ cycleResult <- installClosureInto cache False repo source [("child", repo </> "child")]+ cycleResult `shouldSatisfy` isLeft+ doesDirectoryExist cache `shouldReturn` False+ recipeDir repo "base" "[\"member\"]" ""+ recipeDir repo "child" "[\"base\"]" ""+ wrongKind <- installClosureInto cache False repo source [("child", repo </> "child")]+ wrongKind `shouldSatisfy` isLeft+ doesDirectoryExist cache `shouldReturn` False+ it "refuses an escaping selected path without creating a cache" $ withSystemTempDirectory "closure" $ \tmp -> do let repo = tmp </> "repo"@@ -49,9 +122,50 @@ readFile (cache </> "good" </> "marker") `shouldReturn` "original" readFile (cache </> "blocked") `shouldReturn` "occupied file" + it "restores every cache entry if publishing a staged recipe refresh fails" $+ withSystemTempDirectory "closure-upgrade-rollback" $ \tmp -> do+ let repo = tmp </> "repo"+ staged = tmp </> "staged"+ cache = tmp </> "cache"+ source = "https://example.com/registry.git"+ moduleDir repo "first"+ moduleDir repo "second"+ installClosureInto cache False repo source [("first", repo </> "first"), ("second", repo </> "second")] `shouldReturn` Right ()+ writeFile (cache </> "first/marker") "original"+ result <- stageClosuresInto False staged False [(repo, source, [("first", repo </> "first"), ("second", repo </> "second")])]+ case result of+ Left err -> expectationFailure (T.unpack err)+ Right artifacts -> do+ removeDirectoryRecursive (staged </> "second")+ published <- publishStagedClosure cache artifacts+ published `shouldSatisfy` isLeft+ readFile (cache </> "first/marker") `shouldReturn` "original"+ doesFileExist (cache </> "second/module.dhall") `shouldReturn` True+ moduleDir :: FilePath -> String -> IO () moduleDir root name = do schema <- canonicalizePath "../schema/Module.dhall" let dir = root </> name createDirectoryIfMissing True dir writeFile (dir </> "module.dhall") ("let Module = " <> schema <> " in Module::{ name = \"" <> name <> "\", version = Some \"1.0.0\" }")++recipeDir :: FilePath -> String -> String -> String -> IO ()+recipeDir root name members extension = do+ let dir = root </> name+ createDirectoryIfMissing True dir+ writeFile (dir </> "recipe.dhall") $+ "{ name = "+ <> show name+ <> ", version = Some \"1.0.0\", description = None Text, modules = "+ <> members+ <> ", 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)}"+ <> extension+ <> "}"++registry :: FilePath -> [String] -> [String] -> IO ()+registry root modules recipes =+ writeFile (root </> "seihou-registry.dhall") $+ "{repoName = \"fixture\", repoDescription = None Text, modules = " <> entries modules <> ", recipes = " <> entries recipes <> "}"+ where+ entries names = "[" <> concat (zipWith (\i name -> (if i == (0 :: Int) then "" else ",") <> "{name = " <> show name <> ", path = " <> show name <> ", version = None Text, description = None Text, tags = [] : List Text}") [0 ..] names) <> "]"
test/Seihou/CLI/ManifestCapabilityUpgradeSpec.hs view
@@ -54,7 +54,8 @@ commandReceipts = Map.empty, checkoutCommands = [], recipeInputs = Nothing,- appliedAt = testTime+ appliedAt = testTime,+ recipeChain = Nothing } record :: [ApplicationId] -> SharedWriteMode -> FileRecord@@ -293,7 +294,7 @@ case manifestFromJSON written of Left err -> expectationFailure err Right upgraded -> do- (upgraded ^. #version) `shouldBe` ManifestSchemaVersion 12+ (upgraded ^. #version) `shouldBe` ManifestSchemaVersion 13 (^. #sharedWriteMode) <$> Map.lookup ".gitignore" (upgraded ^. #files) `shouldBe` Just SharedWriteAdditiveOnly TIO.readFile (fixture ^. #gitignorePath) `shouldReturn` gitignoreBefore
test/Seihou/CLI/ManifestGuardSpec.hs view
@@ -1,22 +1,23 @@ module Seihou.CLI.ManifestGuardSpec (tests) where -import Control.Lens ((^.))+import Control.Lens ((&), (.~), (^.)) import Data.Generics.Labels ()+import Data.Map.Strict qualified as Map import Data.Text (Text) import Data.Text qualified as T import Seihou.CLI.ManifestGuard ( ArtifactCheck (..), ArtifactVerdict (..), blockingChecks,+ checkRecipeChain, formatGuardRefusal, judgeArtifact, summarizeCheck, ) import Seihou.Core.ArtifactRef (ArtifactRefError (..)) import Seihou.Core.Types- ( ArtifactOrigin (..),- ModuleName (..),- )+import Seihou.Manifest.Hash (hashContent)+import Seihou.Manifest.Types (emptyManifest) import Test.Hspec import Test.Tasty import Test.Tasty.Hspec (testSpec)@@ -39,6 +40,30 @@ spec :: Spec spec = do+ describe "application recipe-chain guard" $ do+ let origin name = RemoteOrigin demoUrl name Nothing+ base = AppliedRecipeNode "base" (origin "base") (Just "2") (hashContent "base")+ child = AppliedRecipeNode "child" (origin "child") (Just "1") (hashContent "child")+ selected = ApplicationId "selected"+ app = AppliedComposition selected (AppliedRecipeTarget "child") (origin "child") (Just "1") [] Nothing Nothing [] Map.empty [] Nothing (Just [base, child]) (read "2026-11-01 00:00:00 UTC")+ manifest = emptyManifest (read "2026-11-01 00:00:00 UTC") & #applications .~ [app]+ it "blocks a base-only downgrade while the derived version stays unchanged" $ do+ let (checks, _) = checkRecipeChain selected [base & #recipeVersion .~ Just "1", child] manifest+ map (^. #name) (blockingChecks checks) `shouldBe` [ModuleName "base"]+ it "blocks same-name substitution and reports metadata-only changes" $ do+ let (checks, changes) = checkRecipeChain selected [base & #origin .~ RemoteOrigin otherUrl "base" Nothing & #descriptorHash .~ hashContent "changed", child] manifest+ length (blockingChecks checks) `shouldBe` 1+ T.unlines changes `shouldSatisfy` T.isInfixOf "Recipe descriptor changed: base"+ it "keeps unknown history unknown and scopes guards to the selected application" $ do+ let unknown = manifest & #applications .~ [app & #recipeChain .~ Nothing]+ (_, changes) = checkRecipeChain selected [base, child] unknown+ T.unlines changes `shouldSatisfy` T.isInfixOf "prior chain is unknown"+ checkRecipeChain (ApplicationId "another") [base & #recipeVersion .~ Just "0", child] manifest `shouldBe` ([], [])+ it "reports chain removal without requiring the removed base to remain installed" $ do+ let (checks, changes) = checkRecipeChain selected [child] manifest+ blockingChecks checks `shouldBe` []+ T.unlines changes `shouldSatisfy` T.isInfixOf "Removed recipe from chain: base"+ describe "judgeArtifact version comparison" $ do it "reports a strictly older local copy as stale" $ judgeArtifact (remote demoUrl) (Just "2.0.0") (remote demoUrl) (Just "1.4.0")
test/Seihou/CLI/ManifestRepairOriginsSpec.hs view
@@ -60,7 +60,8 @@ commandReceipts = Map.empty, checkoutCommands = [], recipeInputs = Nothing,- appliedAt = testTime+ appliedAt = testTime,+ recipeChain = Nothing } receipt = AppliedBlueprintMigration "service" (origin localPath "service") (Just "2.0.0") "1.0.0" "2.0.0" MigrationApplied testTime Nothing
test/Seihou/CLI/ManifestUpgradeSpec.hs view
@@ -264,12 +264,12 @@ outcome <- runManifestUpgrade (opts False False Nothing) case outcome of UpgradeWritten result -> do- map stepVersions (result ^. #steps) `shouldBe` [(6, 7), (7, 8), (8, 9), (9, 10), (10, 11), (11, 12)]+ map stepVersions (result ^. #steps) `shouldBe` [(6, 7), (7, 8), (8, 9), (9, 10), (10, 11), (11, 12), (12, 13)] (result ^. #entries) `shouldBe` []- (result ^. #toVersion) `shouldBe` ManifestSchemaVersion 12+ (result ^. #toVersion) `shouldBe` ManifestSchemaVersion 13 other -> expectationFailure ("expected a write, got " <> show other) document <- readDocument manifestPath- lookupPath ["version"] document `shouldBe` Just (Aeson.Number 12)+ lookupPath ["version"] document `shouldBe` Just (Aeson.Number 13) lookupPath ["files", ".gitignore", "sharedWriteMode"] document `shouldBe` Just (Aeson.String "additive-only") lookupPath ["files", "README.md", "sharedWriteMode"] document `shouldBe` Just (Aeson.String "unknown") lookupPath ["files", ".gitignore", "additiveOnly"] document `shouldBe` Nothing@@ -281,7 +281,7 @@ before <- LBS.readFile manifestPath outcome <- runManifestUpgrade (opts False False Nothing) case outcome of- UpgradeNotNeeded version _ -> version `shouldBe` ManifestSchemaVersion 12+ UpgradeNotNeeded version _ -> version `shouldBe` ManifestSchemaVersion 13 other -> expectationFailure ("expected nothing to do, got " <> show other) LBS.readFile manifestPath `shouldReturn` before @@ -310,7 +310,7 @@ outcome <- runManifestUpgrade (opts True True Nothing) case outcome of UpgradeWouldWrite result [] -> do- map stepVersions (result ^. #steps) `shouldBe` [(5, 6), (6, 7), (7, 8), (8, 9), (9, 10), (10, 11), (11, 12)]+ map stepVersions (result ^. #steps) `shouldBe` [(5, 6), (6, 7), (7, 8), (8, 9), (9, 10), (10, 11), (11, 12), (12, 13)] map (^. #artifactName) (result ^. #entries) `shouldBe` ["haskell-base", "project-lint", "haskell-service", "scratch-helper"] let report = formatUpgradeReport result@@ -335,10 +335,10 @@ outcome <- runManifestUpgrade (opts False True Nothing) case outcome of UpgradeWritten result ->- map stepVersions (result ^. #steps) `shouldBe` [(2, 3), (3, 4), (4, 5), (5, 6), (6, 7), (7, 8), (8, 9), (9, 10), (10, 11), (11, 12)]+ map stepVersions (result ^. #steps) `shouldBe` [(2, 3), (3, 4), (4, 5), (5, 6), (6, 7), (7, 8), (8, 9), (9, 10), (10, 11), (11, 12), (12, 13)] other -> expectationFailure ("expected a write, got " <> show other) document <- readDocument manifestPath- lookupPath ["version"] document `shouldBe` Just (Aeson.Number 12)+ lookupPath ["version"] document `shouldBe` Just (Aeson.Number 13) it "rejects a target newer than this build or older than the document" $ do withUpgradeProject schema6Manifest $ \_ ->@@ -366,7 +366,7 @@ output `shouldSatisfy` T.isInfixOf "5 -> 6" output `shouldSatisfy` T.isInfixOf "6 -> 7" document <- readDocument manifestPath- lookupPath ["version"] document `shouldBe` Just (Aeson.Number 12)+ lookupPath ["version"] document `shouldBe` Just (Aeson.Number 13) lookupPath ["modules", "0", "origin"] document `shouldBe` Just (Aeson.toJSON (RemoteOrigin "https://example.com/demo-modules.git" "demo" (Just "demo-modules"))) filter absoluteLooking (documentStrings document) `shouldBe` []
+ test/Seihou/CLI/RecipeExtensionE2ESpec.hs view
@@ -0,0 +1,429 @@+module Seihou.CLI.RecipeExtensionE2ESpec (tests) where++import Control.Exception (bracket)+import Control.Lens ((^.))+import Control.Monad (forM_)+import Data.Aeson qualified as Aeson+import Data.Aeson.KeyMap qualified as KM+import Data.ByteString qualified as BS+import Data.ByteString.Lazy qualified as LBS+import Data.Generics.Labels ()+import Data.List (find)+import Data.Text qualified as T+import Data.Text.Encoding qualified as TE+import Data.Text.IO qualified as TIO+import Seihou.CLI.CommandExecution (CommandPolicy (..))+import Seihou.CLI.SeedRunE2ESpec (prepare)+import Seihou.CLI.Update qualified as U+import Seihou.CLI.Update.Types (UpdateError (..))+import System.Directory qualified as D+import System.Environment (getEnvironment, lookupEnv, setEnv, unsetEnv)+import System.Exit (ExitCode (..))+import System.FilePath ((</>))+import System.IO.Temp (withSystemTempDirectory)+import System.Process (CreateProcess (..), callProcess, proc, readCreateProcessWithExitCode)+import Test.Hspec+import Test.Tasty+import Test.Tasty.Hspec (testSpec)++invoke binary root flags = invokeCommand binary root ("run" : "child" : flags)++invokeCommand binary root args = do+ inherited <- getEnvironment+ configured <- D.doesFileExist (root </> "fixture-gitconfig")+ let overrides = zip ["HOME", "XDG_CONFIG_HOME", "XDG_CACHE_HOME"] [root </> "home", root </> "config", root </> "cache"] <> [("GIT_CONFIG_GLOBAL", root </> "fixture-gitconfig") | configured]+ keys = map fst overrides+ environment = overrides <> filter (\(key, _) -> key `notElem` keys && not ("SEIHOU_VAR_" `T.isPrefixOf` T.pack key)) inherited+ (code, out, err) <- readCreateProcessWithExitCode (proc binary args) {cwd = Just (if configured then root </> "project" else root), env = Just environment} ""+ pure (code, T.pack (out <> err))++fixture root = do+ (binary, member) <- prepare root+ TIO.writeFile (member </> "module.dhall") "let S = ./schema/package.dhall in S.Module::{name=\"demo\",version=Some \"1\",steps=[S.Step::{strategy=\"copy\",src=\"starter\",dest=\"value.txt\"}],commands=[S.Command::{action=S.Command.Action.Apply \"printf once >> command-marker\"}]}"+ writeRecipe root "base" "1" "[\"demo\"]" ""+ writeRecipe root "child" "1" "[] : List Text" ", extends = Some {recipe = \"base\"}"+ pure binary++writeRecipe root name version members extra = do+ let dir = root </> ".seihou/modules" </> name+ D.createDirectoryIfMissing True dir+ writeFile (dir </> "recipe.dhall") $ "{name=" <> show name <> ",version=Some " <> show version <> ",description=None Text,modules=" <> members <> ",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)}" <> extra <> "}"++readManifest root = LBS.fromStrict <$> BS.readFile (root </> ".seihou/manifest.json")++tests :: IO TestTree+tests = testSpec "RecipeExtension" $ do+ it "inspects inherited declarations and literal sources through vars without generation" $+ withSystemTempDirectory "recipe-chain-vars" $ \root -> do+ binary <- fixture root+ let base = root </> ".seihou/modules/base/recipe.dhall"+ body <- TIO.readFile base+ TIO.writeFile base (T.replace "vars=[] : List {name : Text,type : Text,default : Optional Text,description : Optional Text,required : Bool,validation : Optional Text}" "vars=[{name=\"project.owner\",type=\"text\",default=Some \"base\",description=None Text,required=False,validation=None Text}]" body)+ writeRecipe root "child" "1" "[] : List Text" ", extends=Some {recipe=\"base\"},moduleOverrides=[{module=\"demo\",vars=[{name=\"project.owner\",value=\"child\"}]}]"+ declarations <- successful binary root ["vars", "child"]+ declarations `shouldSatisfy` T.isInfixOf "project.owner"+ explained <- successful binary root ["vars", "child", "--explain"]+ explained `shouldSatisfy` T.isInfixOf "literal recipe binding from 'child'"+ explained `shouldSatisfy` T.isInfixOf "project.owner"+ explained `shouldNotSatisfy` T.isInfixOf "Unresolved optional variables:"+ D.doesFileExist (root </> ".seihou/manifest.json") `shouldReturn` False+ D.doesFileExist (root </> "command-marker") `shouldReturn` False++ it "records the chain and refuses base-only downgrades before files, commands or manifest writes" $+ withSystemTempDirectory "recipe-chain-guard" $ \root -> do+ binary <- fixture root+ (code, output) <- invoke binary root []+ if code == ExitSuccess then pure () else expectationFailure (T.unpack output)+ before <- readManifest root+ case Aeson.eitherDecode before :: Either String Aeson.Value of+ Right (Aeson.Object fields) -> do+ KM.lookup "version" fields `shouldBe` Just (Aeson.toJSON (13 :: Int))+ T.pack (show fields) `shouldSatisfy` T.isInfixOf "recipeChain"+ T.pack (show fields) `shouldSatisfy` T.isInfixOf "descriptorHash"+ other -> expectationFailure (show other)+ writeRecipe root "base" "0.9" "[\"demo\"]" ""+ (refused, diagnostic) <- invoke binary root []+ refused `shouldBe` ExitFailure 1+ diagnostic `shouldSatisfy` T.isInfixOf "base"+ readManifest root `shouldReturn` before+ readFile (root </> "command-marker") `shouldReturn` "once"+ (allowed, visible) <- invoke binary root ["--allow-downgrade"]+ allowed `shouldBe` ExitSuccess+ visible `shouldSatisfy` T.isInfixOf "allow-downgrade"+ readFile (root </> "command-marker") `shouldReturn` "onceonce"++ it "previews same-version descriptor changes without writing provenance" $+ withSystemTempDirectory "recipe-chain-digest" $ \root -> do+ binary <- fixture root+ (code, _) <- invoke binary root []+ code `shouldBe` ExitSuccess+ before <- readManifest root+ let descriptor = root </> ".seihou/modules/base/recipe.dhall"+ original <- TIO.readFile descriptor+ TIO.writeFile descriptor (T.replace "description=None Text" "description=Some \"New base description\"" original)+ (previewed, output) <- invoke binary root ["--dry-run"]+ previewed `shouldBe` ExitSuccess+ output `shouldSatisfy` T.isInfixOf "Recipe descriptor changed: base"+ readManifest root `shouldReturn` before+ readFile (root </> "command-marker") `shouldReturn` "once"++ it "prepares old unknown history in memory and adopts it only on an accepted run" $+ withSystemTempDirectory "recipe-chain-adoption" $ \root -> do+ binary <- fixture root+ (code, _) <- invoke binary root []+ code `shouldBe` ExitSuccess+ bytes <- readManifest root+ let Right (Aeson.Object fields) = Aeson.eitherDecode bytes+ withoutChain (Aeson.Object app) = Aeson.Object (KM.delete "recipeChain" app)+ withoutChain other = other+ Just (Aeson.Array apps) = KM.lookup "applications" fields+ legacy = Aeson.Object (KM.insert "version" (Aeson.toJSON (12 :: Int)) (KM.insert "applications" (Aeson.Array (fmap withoutChain apps)) fields))+ LBS.writeFile (root </> ".seihou/manifest.json") (Aeson.encode legacy)+ old <- readManifest root+ (previewed, output) <- invoke binary root ["--dry-run"]+ previewed `shouldBe` ExitSuccess+ output `shouldSatisfy` T.isInfixOf "prior chain is unknown"+ readManifest root `shouldReturn` old+ (accepted, _) <- invoke binary root []+ accepted `shouldBe` ExitSuccess+ adopted <- readManifest root+ adopted `shouldSatisfy` (/= old)++ it "retains generated provenance but no command receipt when a run command fails" $+ withSystemTempDirectory "recipe-chain-command-failure" $ \root -> do+ binary <- fixture root+ let descriptor = root </> ".seihou/modules/demo/module.dhall"+ source <- TIO.readFile descriptor+ TIO.writeFile descriptor (T.replace "printf once >> command-marker" "printf once >> command-marker; exit 1" source)+ (code, _) <- invoke binary root []+ code `shouldBe` ExitFailure 1+ D.doesFileExist (root </> "value.txt") `shouldReturn` True+ readFile (root </> "command-marker") `shouldReturn` "once"+ bytes <- readManifest root+ case Aeson.eitherDecode bytes :: Either String Aeson.Value of+ Right (Aeson.Object fields) -> case KM.lookup "applications" fields of+ Just (Aeson.Array apps) -> forM_ apps $ \case+ Aeson.Object app -> do+ KM.lookup "recipeChain" app `shouldSatisfy` (\value -> value /= Nothing && value /= Just Aeson.Null)+ KM.lookup "commandReceipts" app `shouldSatisfy` (\value -> value == Nothing || value == Just (Aeson.object []))+ other -> expectationFailure (show other)+ other -> expectationFailure (show other)+ other -> expectationFailure (show other)++ it "does not create a manifest directory during preview of a cache-only recipe" $+ withSystemTempDirectory "recipe-chain-no-write" $ \root -> do+ binary <- fixture root+ let cache = root </> "config/seihou/installed"+ D.createDirectoryIfMissing True cache+ forM_ ["base", "child", "demo"] $ \name -> D.renameDirectory (root </> ".seihou/modules" </> name) (cache </> name)+ D.removeDirectory (root </> ".seihou/modules")+ D.removeDirectory (root </> ".seihou")+ (code, output) <- invoke binary root ["--dry-run"]+ if code == ExitSuccess then pure () else expectationFailure (T.unpack output)+ D.doesDirectoryExist (root </> ".seihou") `shouldReturn` False++ it "accepts base-only metadata through ordinary update without rerunning commands, then becomes a no-op" $+ withSystemTempDirectory "recipe-chain-update" $ \root -> do+ binary <- fixture root+ (ran, _) <- invoke binary root []+ ran `shouldBe` ExitSuccess+ before <- readManifest root+ writeRecipe root "base" "1.1" "[\"demo\"]" ""+ (previewed, preview) <- invokeCommand binary root ["update", "child", "--dry-run", "--json"]+ previewed `shouldBe` ExitSuccess+ case Aeson.eitherDecode (LBS.fromStrict (TE.encodeUtf8 preview)) :: Either String Aeson.Value of+ Right (Aeson.Object fields) -> do+ KM.lookup "schemaVersion" fields `shouldBe` Just (Aeson.toJSON (1 :: Int))+ KM.lookup "alreadyUpToDate" fields `shouldBe` Just (Aeson.Bool False)+ KM.lookup "recipeChains" fields `shouldSatisfy` (\case Just (Aeson.Array xs) -> length xs == 1; _ -> False)+ KM.lookup "versions" fields `shouldBe` Just (Aeson.toJSON ([] :: [Aeson.Value]))+ other -> expectationFailure (show other)+ readManifest root `shouldReturn` before+ readFile (root </> "command-marker") `shouldReturn` "once"+ (eof, _) <- invokeCommand binary root ["update", "child"]+ eof `shouldBe` ExitSuccess+ readManifest root `shouldReturn` before+ (accepted, output) <- invokeCommand binary root ["update", "child", "--json"]+ if accepted == ExitSuccess then pure () else expectationFailure (T.unpack output)+ readManifest root >>= (`shouldSatisfy` (/= before))+ readFile (root </> "command-marker") `shouldReturn` "once"+ (repeated, unchanged) <- invokeCommand binary root ["update", "child", "--dry-run"]+ repeated `shouldBe` ExitSuccess+ unchanged `shouldSatisfy` T.isInfixOf "Already up to date"++ it "updates a local recipe with read-only definitions and schema payloads without changing the originals" $+ withSystemTempDirectory "recipe-chain-read-only" $ \root -> do+ binary <- fixture root+ let files = [root </> ".seihou/modules/demo/module.dhall", root </> ".seihou/modules/demo/schema/Migration.dhall"]+ forM_ files $ \file -> D.getPermissions file >>= D.setPermissions file . D.setOwnerWritable False+ permissions <- mapM D.getPermissions files+ before <- mapM BS.readFile files+ _ <- successful binary root ["run", "child"]+ writeRecipe root "base" "1.1" "[\"demo\"]" ""+ _ <- successful binary root ["update", "child", "--json"]+ mapM D.getPermissions files `shouldReturn` permissions+ mapM BS.readFile files `shouldReturn` before+ readFile (root </> "command-marker") `shouldReturn` "once"++ it "adopts unknown recipe history through update only on acceptance" $+ withSystemTempDirectory "recipe-chain-update-adopt" $ \root -> do+ binary <- fixture root+ (ran, _) <- invoke binary root []+ ran `shouldBe` ExitSuccess+ bytes <- readManifest root+ let Right (Aeson.Object fields) = Aeson.eitherDecode bytes+ withoutChain (Aeson.Object app) = Aeson.Object (KM.delete "recipeChain" app)+ withoutChain other = other+ Just (Aeson.Array apps) = KM.lookup "applications" fields+ legacy = Aeson.Object (KM.insert "version" (Aeson.toJSON (12 :: Int)) (KM.insert "applications" (Aeson.Array (fmap withoutChain apps)) fields))+ LBS.writeFile (root </> ".seihou/manifest.json") (Aeson.encode legacy)+ old <- readManifest root+ (previewed, output) <- invokeCommand binary root ["update", "child", "--dry-run"]+ previewed `shouldBe` ExitSuccess+ output `shouldSatisfy` T.isInfixOf "prior chain is unknown"+ readManifest root `shouldReturn` old+ (accepted, applied) <- invokeCommand binary root ["update", "child", "--json"]+ if accepted == ExitSuccess then pure () else expectationFailure (T.unpack applied)+ readManifest root >>= (`shouldSatisfy` (/= old))+ readFile (root </> "command-marker") `shouldReturn` "once"++ it "guards a downgraded base during update before commands or publication" $+ withSystemTempDirectory "recipe-chain-update-guard" $ \root -> do+ binary <- fixture root+ (ran, _) <- invoke binary root []+ ran `shouldBe` ExitSuccess+ before <- readManifest root+ writeRecipe root "base" "0.9" "[\"demo\"]" ""+ (refused, output) <- invokeCommand binary root ["update", "child", "--json"]+ refused `shouldBe` ExitFailure 1+ output `shouldSatisfy` T.isInfixOf "base"+ readManifest root `shouldReturn` before+ readFile (root </> "command-marker") `shouldReturn` "once"+ (allowed, preview) <- invokeCommand binary root ["update", "child", "--allow-downgrade", "--dry-run"]+ allowed `shouldBe` ExitSuccess+ preview `shouldSatisfy` T.isInfixOf "allow-downgrade"++ it "rolls recipe-chain evidence and generated files back after a changed command fails" $+ withSystemTempDirectory "recipe-chain-update-failure" $ \root -> do+ binary <- fixture root+ (ran, _) <- invoke binary root []+ ran `shouldBe` ExitSuccess+ before <- readManifest root+ fileBefore <- readFile (root </> "value.txt")+ writeRecipe root "base" "1.1" "[\"demo\"]" ""+ let path = root </> ".seihou/modules/demo/module.dhall"+ body <- TIO.readFile path+ TIO.writeFile path (T.replace "printf once >> command-marker" "exit 7" body)+ (failed, output) <- invokeCommand binary root ["update", "child", "--json"]+ failed `shouldBe` ExitFailure 1+ output `shouldSatisfy` T.isInfixOf "command_failed"+ readManifest root `shouldReturn` before+ readFile (root </> "value.txt") `shouldReturn` fileBefore+ readFile (root </> "command-marker") `shouldReturn` "once"++ it "refreshes an unchanged recipe's base closure once, preserves previews, and replays from an empty cache" $+ withSystemTempDirectory "recipe-chain-remote" $ \root -> do+ binary <- remoteFixture root+ _ <- successful binary root ["install", remoteUrl "child", "--module", "child"]+ _ <- successful binary root ["run", "child"]+ before <- readManifest (root </> "project")+ let installed = root </> "config/seihou/installed"+ oldBase <- BS.readFile (installed </> "base/recipe.dhall")+ writeRemoteRecipe root "base" "1.1" ("[ {module=\"demo\",source=Some \"" <> remoteUrl "demo" <> "\",vars=[] : List {name : Text,value : Text}} ]") ""+ commitRemote root "base"+ preview <- successful binary root ["upgrade", "child", "demo", "--dry-run", "--json"]+ case Aeson.eitherDecode (LBS.fromStrict (TE.encodeUtf8 preview)) :: Either String Aeson.Value of+ Right (Aeson.Array entries) -> length entries `shouldBe` 3+ other -> expectationFailure (show other)+ readManifest (root </> "project") `shouldReturn` before+ BS.readFile (installed </> "base/recipe.dhall") `shouldReturn` oldBase+ allRoots <- successful binary root ["upgrade", "--dry-run", "--json"]+ case Aeson.eitherDecode (LBS.fromStrict (TE.encodeUtf8 allRoots)) :: Either String Aeson.Value of+ Right (Aeson.Array entries) -> length entries `shouldBe` 3+ other -> expectationFailure (show other)+ _ <- successful binary root ["upgrade", "child", "--json"]+ readManifest (root </> "project") `shouldReturn` before+ BS.readFile (installed </> "base/recipe.dhall") >>= (`shouldSatisfy` (/= oldBase))+ updated <- successful binary root ["update", "child", "--json"]+ updated `shouldSatisfy` T.isInfixOf "skippedUnchanged"+ readFile (root </> "project/command-marker") `shouldReturn` "once"+ unchanged <- successful binary root ["update", "child", "--dry-run"]+ unchanged `shouldSatisfy` T.isInfixOf "Already up to date"+ D.removePathForcibly installed+ _ <- successful binary root ["update", "child", "--json"]+ -- Cache reconstruction is published as part of the accepted update.+ D.doesFileExist (installed </> "base/recipe.dhall") `shouldReturn` True+ readFile (root </> "project/command-marker") `shouldReturn` "once"++ it "acquires new external bases and members without fetching a removed base" $+ withSystemTempDirectory "recipe-chain-reparent" $ \root -> do+ binary <- remoteFixture root+ _ <- successful binary root ["install", remoteUrl "child", "--module", "child"]+ _ <- successful binary root ["run", "child"]+ let producers = root </> "producers"+ D.renameDirectory (producers </> "base") (producers </> "unavailable-base")+ D.renameDirectory (producers </> "demo") (producers </> "fresh")+ let path = producers </> "fresh/module.dhall"+ body <- TIO.readFile path+ TIO.writeFile path (T.replace "name=\"demo\"" "name=\"fresh\"" (T.replace "dest=\"value.txt\"" "dest=\"fresh.txt\"" body))+ commitRemote root "fresh"+ writeRemoteRecipe root "next-base" "1" ("[ {module=\"fresh\",source=Some \"" <> remoteUrl "fresh" <> "\",vars=[] : List {name : Text,value : Text}} ]") ""+ initRemote root "next-base"+ writeRemoteRecipe root "child" "1" "[] : List Text" (", extends=Some {recipe=\"next-base\",source=Some \"" <> remoteUrl "next-base" <> "\"}")+ commitRemote root "child"+ preview <- successful binary root ["update", "child", "--dry-run"]+ preview `shouldSatisfy` T.isInfixOf "next-base"+ _ <- successful binary root ["update", "child", "--json"]+ D.doesFileExist (root </> "project/fresh.txt") `shouldReturn` True+ D.doesFileExist (root </> "project/value.txt") `shouldReturn` False+ unchanged <- successful binary root ["update", "child", "--dry-run"]+ unchanged `shouldSatisfy` T.isInfixOf "Already up to date"++ it "refuses an out-of-range base during update and upgrade even with the application downgrade override" $+ withSystemTempDirectory "recipe-chain-range-update" $ \root -> do+ binary <- remoteFixture root+ _ <- successful binary root ["install", remoteUrl "child", "--module", "child"]+ _ <- successful binary root ["run", "child"]+ before <- readManifest (root </> "project")+ let installed = root </> "config/seihou/installed/base/recipe.dhall"+ cached <- BS.readFile installed+ writeRemoteRecipe root "base" "2" ("[ {module=\"demo\",source=Some \"" <> remoteUrl "demo" <> "\",vars=[] : List {name : Text,value : Text}} ]") ""+ commitRemote root "base"+ forM_ [["update", "child", "--allow-downgrade", "--json"], ["upgrade", "child", "--json"]] $ \args -> do+ (code, output) <- invokeCommand binary root args+ code `shouldBe` ExitFailure 1+ output `shouldSatisfy` T.isInfixOf "base"+ readManifest (root </> "project") `shouldReturn` before+ BS.readFile installed `shouldReturn` cached+ readFile (root </> "project/command-marker") `shouldReturn` "once"++ it "keeps a recipe refresh together when skip-unversioned excludes a changed recipe" $+ withSystemTempDirectory "recipe-chain-upgrade-skip" $ \root -> do+ binary <- remoteFixture root+ _ <- successful binary root ["install", remoteUrl "child", "--module", "child"]+ let cached = root </> "config/seihou/installed/child/recipe.dhall"+ before <- BS.readFile cached+ let descriptor = root </> "producers/child/recipe.dhall"+ body <- TIO.readFile descriptor+ TIO.writeFile descriptor (T.replace "version=Some \"1\"" "version=None Text" body)+ commitRemote root "child"+ output <- successful binary root ["upgrade", "child", "--skip-unversioned", "--json"]+ output `shouldSatisfy` T.isInfixOf "skipped"+ BS.readFile cached `shouldReturn` before+ D.doesFileExist (root </> "project/.seihou/manifest.json") `shouldReturn` False++ it "refuses a same-name base substitution before cache or project publication" $+ withSystemTempDirectory "recipe-chain-update-substitution" $ \root -> do+ binary <- remoteFixture root+ _ <- successful binary root ["install", remoteUrl "child", "--module", "child"]+ _ <- successful binary root ["run", "child"]+ before <- readManifest (root </> "project")+ cached <- BS.readFile (root </> "config/seihou/installed/base/recipe.dhall")+ let replacement = root </> "producers/replacement"+ callProcess "git" ["clone", "-q", root </> "producers/base", replacement]+ appendFile (root </> "fixture-gitconfig") ("[url \"file://" <> replacement <> "\"]\n insteadOf = " <> remoteUrl "replacement" <> "\n")+ writeRemoteRecipe root "child" "1" "[] : List Text" (", extends=Some {recipe=\"base\",source=Some \"" <> remoteUrl "replacement" <> "\"}")+ commitRemote root "child"+ (code, output) <- invokeCommand binary root ["update", "child", "--json"]+ code `shouldBe` ExitFailure 1+ output `shouldSatisfy` T.isInfixOf "different source"+ readManifest (root </> "project") `shouldReturn` before+ BS.readFile (root </> "config/seihou/installed/base/recipe.dhall") `shouldReturn` cached++ it "rejects a base descriptor edited after the update preview without publishing" $+ withSystemTempDirectory "recipe-chain-stale-update" $ \root -> do+ binary <- fixture root+ _ <- successful binary root ["run", "child"]+ before <- readManifest root+ writeRecipe root "base" "1.1" "[\"demo\"]" ""+ let request = U.UpdateRequest (U.NamedUpdateTargets ["child"]) [] False U.ForbidPrompts RunChangedCommands False False False+ let environmentKeys = ["XDG_CONFIG_HOME", "XDG_CACHE_HOME"]+ result <- bracket (mapM lookupEnv environmentKeys) (\previous -> forM_ (zip environmentKeys previous) $ \(key, value) -> maybe (unsetEnv key) (setEnv key) value) $ \_ -> do+ setEnv "XDG_CONFIG_HOME" (root </> "config")+ setEnv "XDG_CACHE_HOME" (root </> "cache")+ D.withCurrentDirectory root $ U.withProjectUpdate request $ \case+ Left err -> pure (Left err)+ Right plan -> do+ let Just base = find ((== "base") . (^. #name)) (plan ^. #candidateArtifacts)+ TIO.appendFile (base ^. #originalDirectory </> "recipe.dhall") "\n-- changed after preview\n"+ U.applyProjectUpdate plan+ result `shouldSatisfy` (\case Left UpdatePlanStale {} -> True; _ -> False)+ readManifest root `shouldReturn` before+ readFile (root </> "command-marker") `shouldReturn` "once"++successful binary root args = do+ (code, output) <- invokeCommand binary root args+ if code == ExitSuccess then pure () else expectationFailure (T.unpack output)+ pure output++remoteUrl name = "https://example.invalid/" <> name <> ".git"++writeRemoteRecipe root name version members extra = do+ writeRecipe root name version members extra+ let target = root </> "producers" </> name+ D.createDirectoryIfMissing True target+ D.renameFile (root </> ".seihou/modules" </> name </> "recipe.dhall") (target </> "recipe.dhall")++commitRemote root name = do+ let repo = root </> "producers" </> name+ callProcess "git" ["-C", repo, "add", "."]+ callProcess "git" ["-C", repo, "-c", "user.name=Seihou Test", "-c", "user.email=test@example.invalid", "commit", "--allow-empty", "-qm", "test: recipe candidate"]++initRemote root name = do+ callProcess "git" ["-C", root </> "producers" </> name, "init", "-q"]+ commitRemote root name++remoteFixture root = do+ binary <- fixture root+ let producers = root </> "producers"+ D.createDirectory producers+ D.createDirectory (root </> "project")+ D.renameDirectory (root </> ".seihou/modules/demo") (producers </> "demo")+ writeRemoteRecipe root "base" "1" ("[ {module=\"demo\",source=Some \"" <> remoteUrl "demo" <> "\",vars=[] : List {name : Text,value : Text}} ]") ""+ writeRemoteRecipe root "child" "1" "[] : List Text" (", extends=Some {recipe=\"base\",source=Some \"" <> remoteUrl "base" <> "\",versionRange=Some {minimum=\"1\",before=\"2\"}}")+ forM_ ["demo", "base", "child"] (initRemote root)+ -- Every URL remains portable in descriptors and manifest; only this test+ -- process's transport routes to committed fixture producers.+ -- Directory names have no .git suffix, so use one explicit rewrite per URL.+ writeFile (root </> "fixture-gitconfig") $ concat ["[url \"file://" <> producers </> name <> "\"]\n insteadOf = " <> remoteUrl name <> "\n" | name <- ["demo", "base", "child", "fresh", "next-base"]]+ pure binary
test/Seihou/CLI/StatusSpec.hs view
@@ -91,7 +91,8 @@ commandReceipts = Map.empty, checkoutCommands = [], recipeInputs = Nothing,- appliedAt = fixedTime+ appliedAt = fixedTime,+ recipeChain = Nothing } where mkInstance name =
test/Seihou/CLI/UpdateE2ESpec.hs view
@@ -237,7 +237,7 @@ expectSuccess "targeted update" exitCode stdoutText stderrText stdoutText `shouldSatisfy` T.isInfixOf "\"outcome\":\"applied\"" manifestText <- TIO.readFile (fixture ^. #manifestPath)- manifestText `shouldSatisfy` T.isInfixOf "\"version\":12"+ manifestText `shouldSatisfy` T.isInfixOf "\"version\":13" manifestText `shouldSatisfy` T.isInfixOf "\"sharedWriteMode\":\"additive-only\"" -- Recording an answer must not touch a single byte of the project. TIO.readFile (fixture ^. #gitignorePath) `shouldReturn` beforeGitignore@@ -276,7 +276,7 @@ dryOut `shouldSatisfy` T.isInfixOf "\"outcome\":\"plan\"" dryOut `shouldSatisfy` T.isInfixOf "\"alreadyUpToDate\":false" dryOut `shouldSatisfy` T.isInfixOf "\"fromSchema\":6"- dryOut `shouldSatisfy` T.isInfixOf "\"toSchema\":7"+ dryOut `shouldSatisfy` T.isInfixOf "\"toSchema\":13" dryOut `shouldSatisfy` T.isInfixOf "{\"from\":\"unknown\",\"path\":\".gitignore\",\"to\":\"additive-only\"}" dryOut `shouldNotSatisfy` T.isInfixOf "shared_path_requires_applications" LBS.readFile (fixture ^. #manifestPath) `shouldReturn` beforeManifest@@ -297,7 +297,7 @@ case decoded of Left err -> expectationFailure err Right manifest -> do- (manifest ^. #version) `shouldBe` ManifestSchemaVersion 12+ (manifest ^. #version) `shouldBe` ManifestSchemaVersion 13 case Map.lookup ".gitignore" (manifest ^. #files) of Nothing -> expectationFailure "the manifest lost .gitignore" Just record -> do@@ -317,7 +317,7 @@ binary <- seihouBinary (dryExit, dryOut, dryErr) <- runSeihouShared binary bug1 ["update", "alpha", "--dry-run"] expectSuccess "human dry run" dryExit dryOut dryErr- dryOut `shouldSatisfy` T.isInfixOf "Manifest: schema 6 -> 7"+ dryOut `shouldSatisfy` T.isInfixOf "Manifest: schema 6 -> 13" dryOut `shouldSatisfy` T.isInfixOf ".gitignore evidence unknown -> additive-only" (dryOut <> dryErr) `shouldNotSatisfy` leaksInternals
test/Seihou/CLI/UpdateFixture.hs view
@@ -57,6 +57,7 @@ checkoutAdoptions = Map.empty, commandPlan = CommandPlan [], candidateArtifacts = [],+ cacheChanges = [], warnings = [], request = UpdateRequest
test/Seihou/CLI/UpdateSpec.hs view
@@ -560,7 +560,7 @@ Nothing -> expectationFailure "expected a manifest preparation" Just preparation -> do (preparation ^. #fromVersion) `shouldBe` ManifestSchemaVersion 6- (preparation ^. #toVersion) `shouldBe` ManifestSchemaVersion 7+ (preparation ^. #toVersion) `shouldBe` currentManifestVersion (preparation ^. #modeChanges) `shouldBe` Map.singleton ".gitignore" (SharedWriteUnknown, SharedWriteAdditiveOnly) map (^. #applicationId) (plan ^. #applications) `shouldBe` [fixture ^. #alphaApplicationId]@@ -584,7 +584,7 @@ withSystemTempDirectory "seihou-update-schema-5" $ \root -> do fixture <- prepareSharedPathFixture CoOwnerAppends root manifestText <- TIO.readFile (fixture ^. #manifestPath)- TIO.writeFile (fixture ^. #manifestPath) (T.replace "\"version\":12" "\"version\":5" manifestText)+ TIO.writeFile (fixture ^. #manifestPath) (T.replace "\"version\":13" "\"version\":5" manifestText) withSavedEnv "XDG_CONFIG_HOME" (Just (fixture ^. #xdgHome)) $ withCurrentDirectory (fixture ^. #projectRoot) $ do forM_ [NamedUpdateTargets ["alpha"], AllRecordedApplications] $ \selection -> do@@ -1072,7 +1072,8 @@ commandReceipts = Map.empty, checkoutCommands = [], recipeInputs = Nothing,- appliedAt = testTime+ appliedAt = testTime,+ recipeChain = Nothing } base = emptyManifest testTime manifest =@@ -1176,7 +1177,8 @@ commandReceipts = Map.empty, checkoutCommands = [], recipeInputs = Nothing,- appliedAt = testTime+ appliedAt = testTime,+ recipeChain = Nothing } where targetName = case target of@@ -1293,6 +1295,7 @@ reconciliation = plan ^. #reconciliation, commandPlan = plan ^. #commandPlan, candidateArtifacts = map breakArtifact (plan ^. #candidateArtifacts),+ cacheChanges = plan ^. #cacheChanges, warnings = plan ^. #warnings, request = plan ^. #request, snapshot = plan ^. #snapshot,
test/Seihou/CLI/UpgradeDiagnosisSpec.hs view
@@ -43,7 +43,7 @@ withFixture CoOwnerAppendsPredatingEvidence noDamage $ \_ _ diagnose -> do checks <- readiness <$> diagnose "alpha" statusOf "manifest-schema-current" checks `shouldBe` NeedsAttention- detailOf "manifest-schema-current" checks `shouldSatisfy` T.isInfixOf "schema 6 is older than 12"+ detailOf "manifest-schema-current" checks `shouldSatisfy` T.isInfixOf "schema 6 is older than 13" statusOf "shared-evidence-known" checks `shouldBe` NeedsAttention detailOf "shared-evidence-known" checks `shouldBe` ".gitignore is shared with beta and its write mode is unknown" statusOf "update-plans-cleanly" checks `shouldBe` Ready@@ -59,7 +59,7 @@ ((^. #errorCode) <$> diagnosis ^. #updateDryRun) `shouldBe` ProbeOk (Just "shared_write_evidence_unavailable") it "reports a schema-5 manifest as needing seihou manifest upgrade" $- withFixture CoOwnerAppends (withManifestText (T.replace "\"version\":12" "\"version\":5")) $ \_ _ diagnose -> do+ withFixture CoOwnerAppends (withManifestText (T.replace "\"version\":13" "\"version\":5")) $ \_ _ diagnose -> do diagnosis <- diagnose "alpha" let checks = readiness diagnosis statusOf "manifest-readable" checks `shouldBe` NeedsAttention@@ -154,7 +154,7 @@ [ ("healthy" :: Text, CoOwnerAppends, const (pure ())), ("schema 6", CoOwnerAppendsPredatingEvidence, const (pure ())), ("evidence unavailable", CoOwnerAppendsPredatingEvidence, evidenceUnavailable),- ("schema 5", CoOwnerAppends, withManifestText (T.replace "\"version\":12" "\"version\":5")),+ ("schema 5", CoOwnerAppends, withManifestText (T.replace "\"version\":13" "\"version\":5")), ("not json", CoOwnerAppends, withManifestText (const "{not json")), ("local origin", CoOwnerAppends, localBetaOrigin), ("pending transaction", CoOwnerAppends, pendingTransaction)
test/Seihou/CLI/ValidateRecipeE2ESpec.hs view
@@ -92,6 +92,22 @@ (code, output) `shouldBe` (ExitSuccess, "Recipe 'my-stack' is valid.\n") snapshot root `shouldReturn` before + it "validates a settings-only child with inherited prompts without acquiring its base" $+ withSystemTempDirectory "validate-derived-recipe" $ \root -> do+ binary <- seihouBinary+ prepareState root+ let descriptor =+ T.replace+ "modules = [{module = \"demo\", vars = [{name = \"member.only\", value = \"literal\"}]}]"+ "extends = Some {recipe = \"unpublished-base\", source = Some \"https://example.invalid/registry.git\"}, modules = [] : List Text"+ $ T.replace "var = \"github.owner\"" "var = \"inherited.input\"" recipe+ TIO.writeFile (root </> "recipe.dhall") descriptor+ before <- snapshot root+ (code, output) <- invoke binary root root ["validate-recipe"]+ code `shouldBe` ExitSuccess+ output `shouldSatisfy` T.isInfixOf "Local descriptor validation passed; the base and composition were not checked."+ snapshot root `shouldReturn` before+ it "supports the ordinary new-recipe workflow without members or configuration" $ withSystemTempDirectory "validate-recipe-scaffold" $ \root -> do binary <- seihouBinary