diff --git a/data/blueprint-migration-prompt.md b/data/blueprint-migration-prompt.md new file mode 100644 --- /dev/null +++ b/data/blueprint-migration-prompt.md @@ -0,0 +1,76 @@ +You are running one ordered Seihou blueprint migration for a library upgrade. +The blueprint author supplied shared library guidance plus instructions for this +exact version edge. Work only on the current edge; later edges run in separate +agent sessions after this one succeeds. + +You may be running in an interactive local CLI with repository tools, or as a +one-shot API completion without tools. When tools are available, inspect the +project's actual use of the library, edit the repository directly, and run the +relevant validation. When tools are unavailable, return concrete guidance, +patch-style snippets, and validation commands the user can apply. + + +## Current Environment + +Working directory: {{cwd}} +{{seihou_project_state}} +{{manifest_state}} +{{module_dhall_state}} +{{local_modules}} +{{available_modules}} + + +## Blueprint Identity + +Name: {{blueprint_name}} +Version: {{blueprint_version}} +Description: {{blueprint_description}} + + +## Migration Edge + +Step {{migration_position}} of {{migration_total}} +From library version: {{migration_from}} +To library version: {{migration_to}} + + +## Reference Files + +The blueprint declares these shared library-upgrade references: + +{{reference_files}} + +{{reference_files_dir}} + + +## Shared Blueprint Guidance + +{{shared_prompt}} + + +## Instructions for This Edge + +{{migration_prompt}} + + +## Workflow + +1. Inspect how the project actually uses the library at the source version. + Do not assume every API named in the guidance is present. +2. Read relevant mounted reference files when available. If they are not + mounted, ask the user for anything essential and never claim to have read it. +3. Make only the changes needed for {{migration_from}} -> {{migration_to}}. + Preserve unrelated user changes and do not pre-apply later migration edges. +4. Update source, configuration, and tests that are directly affected by this + edge. Avoid broad cleanup unrelated to the upgrade. +5. Run the most relevant project validation available for this library change. + Report checks you could not run and why. +6. Before exiting, summarize changed files, validation results, and any work + that remains for the user or later migration steps. + + +## Completion Boundary + +Seihou records this exact edge after your provider interaction returns +successfully. That receipt is not package-manager verification. Do not report +the target version as installed unless you actually verified it in the project. diff --git a/help/agent.md b/help/agent.md --- a/help/agent.md +++ b/help/agent.md @@ -2,8 +2,8 @@ `seihou agent` renders Seihou-aware prompts and starts a configured provider. The agent commands are for AI-assisted -module authoring, bootstrapping, project setup, and running -agent-driven blueprints. +module authoring, bootstrapping, project setup, running agent-driven +blueprints, and applying ordered blueprint library migrations. CLI providers open interactive local Claude Code or Codex sessions. API providers send one rendered prompt as a batch completion and print @@ -25,7 +25,7 @@ --model MODEL Select a provider-specific model name or alias for this - invocation. + invocation. Run `seihou agent models` to list known choices. Provider and model options may appear on the parent command or on the subcommand: @@ -81,6 +81,22 @@ SUBCOMMANDS + seihou agent models [--provider PROVIDER] + List the Anthropic and OpenAI models in Seihou's compiled Baikai + catalog. Filtering by `anthropic` or `claude-cli` returns the same + Claude-family models; filtering by `openai` or `codex-cli` returns + the same OpenAI-family models. The filter may appear before or + after `models`: + + seihou agent --provider claude-cli models + seihou agent models --provider openai + + Listing models requires no provider credentials, network access, + or agent configuration. The catalog is a discovery aid, not + validation: provider-native aliases and custom model IDs remain + accepted by `--model`. Do not pass `--model` to this listing + command. + seihou agent assist [PROMPT] Render a prompt for creating or modifying Seihou modules. The prompt includes current project context, available modules, and @@ -102,6 +118,17 @@ provider. A successful non-debug run records applied-blueprint provenance in `.seihou/manifest.json`. + seihou agent migrate BLUEPRINT --from VERSION --to VERSION [PROMPT] + Run one agent session per in-window migration declared by the blueprint. + Versions are explicit dotted numbers; gaps are allowed. Successful edges + are recorded immediately so a later invocation resumes at the first + unrecorded edge. `--rerun` ignores matching receipts. Migration mode does + not apply baseModules and exposes neither --no-baseline nor --force. + + Parent --debug prints every pending migration prompt in order without + contacting a provider or writing receipts. A receipt records provider + completion, not package-manager verification. + seihou prompt run PROMPT [USER-PROMPT] [--var KEY=VALUE] [--debug] Resolve a reusable prompt, run command-derived variables, render the prompt body, and send it to the configured provider. Prompts @@ -113,6 +140,7 @@ seihou agent --debug --provider codex-cli bootstrap --repo "inspect this prompt" seihou agent --debug --provider openai setup "inspect this prompt" seihou agent --debug run my-blueprint --var project.name=demo + seihou agent --debug migrate my-library --from 1.0.0 --to 3.0.0 SEE ALSO diff --git a/help/blueprints.md b/help/blueprints.md --- a/help/blueprints.md +++ b/help/blueprints.md @@ -3,7 +3,8 @@ A blueprint is an agent-driven runnable artifact. Modules and recipes use Seihou's deterministic execution engine to write files from declared steps. Blueprints instead package a prompt, optional baseline modules, variables, -and reference files for `seihou agent run`. +and reference files for `seihou agent run`. They can also package ordered +library-upgrade prompts for `seihou agent migrate`. Use a blueprint when the desired output needs judgement, iteration, or project-specific design decisions that do not fit a fixed module template. @@ -39,6 +40,7 @@ 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. + migrations Agent-guided library version edges (from, to, prompt). Blueprints share the same name lookup namespace as modules and recipes. If a directory contains more than one runnable definition, lookup prefers @@ -103,6 +105,37 @@ its workspace-write sandbox and on-request approval policy because it has no equivalent per-tool allow-list option. +LIBRARY UPGRADE MIGRATIONS + + A blueprint migration describes one forward dotted-numeric version edge: + + migrations = + [ S.BlueprintMigration::{ + , from = "1.0.0" + , to = "2.0.0" + , prompt = ./migrations/1-to-2.md as Text + } + , S.BlueprintMigration::{ + , from = "2.5.0" + , to = "3.0.0" + , prompt = ./migrations/2-5-to-3.md as Text + } + ] + + Run an installed library blueprint with explicit versions: + + seihou agent migrate my-library --from 1.0.0 --to 3.0.0 + + Edges run in ascending `from` order and gaps are allowed. Duplicate starts + are invalid; overlaps already passed by the cursor and edges overshooting the + target are skipped. Each successful provider interaction writes an exact-edge + receipt before the next session. Rerunning resumes; --rerun repeats matching + receipts. Parent --debug prints pending prompts without launching or writing. + + Migration mode reuses variables, shared prompt, references, and allowed tools, + but never applies baseModules. A receipt records agent completion, not proof + that a package manager now reports the target version. + COMMON COMMANDS seihou new-blueprint api-service Scaffold a blueprint @@ -110,6 +143,7 @@ seihou list List modules, recipes, blueprints, and prompts seihou vars api-service Show blueprint variables seihou agent run api-service Run the blueprint with an agent + seihou agent migrate my-library --from 1.0.0 --to 3.0.0 `seihou run api-service` refuses when `api-service` resolves to a blueprint. That command is reserved for deterministic modules and recipes; use @@ -126,6 +160,7 @@ - prompts reference declared variables - baseModules resolve to modules or recipes - declared reference files exist under files/ + - migrations have dotted forward versions, unique starts, and non-empty prompts If validation fails, fix the reported check before publishing or running the blueprint. diff --git a/help/git-repository.md b/help/git-repository.md --- a/help/git-repository.md +++ b/help/git-repository.md @@ -79,10 +79,14 @@ seihou agent bootstrap # single module seihou agent bootstrap --repo # multi-module with registry -UPGRADE WORKFLOW +PROJECT UPDATE AND CACHE UPGRADE - Once installed, modules can be upgraded with `seihou upgrade`. If a newer - module version ships migrations (for renames, - deletions, etc.), the upgrade command surfaces them via an advisory; running - `seihou migrate ` is the post-upgrade step that applies them - to the current project. See `seihou help migrations`. + After a module or recipe has been applied to a project, use `seihou update` + for routine source updates. It stages the newer repository content, reuses + saved inputs, applies migrations, reconciles generated files with user + edits, and publishes the installed cache only after the project succeeds. + + `seihou upgrade` is a lower-level cache-maintenance command. It refreshes + the shared installed copy but does not reconcile templates or user edits in + the current project. Use it when cache-only maintenance is intentional. + See `seihou help update` and `seihou help migrations`. diff --git a/help/migrations.md b/help/migrations.md --- a/help/migrations.md +++ b/help/migrations.md @@ -1,5 +1,27 @@ MIGRATIONS +Seihou has two migration systems. Deterministic module migrations use typed +filesystem operations and `seihou migrate`. Agent-guided blueprint migrations +use one library-upgrade prompt per version edge and `seihou agent migrate`. + +BLUEPRINT MIGRATIONS + + A library blueprint declares entries with `from`, `to`, and a Markdown + `prompt`. Consumers always supply explicit dotted numeric versions: + + seihou agent migrate my-library --from 1.0.0 --to 3.0.0 + + The planner orders in-window entries by `from` and permits gaps. Each entry + runs in its own provider session, then receives an exact-edge receipt before + the next starts. A normal rerun resumes after receipts; --rerun repeats them. + Parent --debug renders pending prompts in order without launching a provider + or changing the manifest. Migration mode never applies blueprint baseModules. + + A receipt means the agent interaction completed successfully. It does not + verify that Cabal, npm, Cargo, or another package manager reports the target. + +DETERMINISTIC MODULE MIGRATIONS + A migration is an author-declared sequence of file-system operations that moves a project's working tree from one module version to another. When a module is upgraded — say, from haskell-base 1.0.0 to 2.0.0 — the project @@ -13,9 +35,9 @@ Add a migration when a new version of your module changes the *layout* of the files it generates: a directory rename, a file removal, a path pattern shift. You do not need a migration for content-only changes; - re-running `seihou run ` already updates file content. Use - migrations specifically for things that `seihou run` cannot infer on - its own. + `seihou update ` already reconciles newly generated content with + the project. Use migrations specifically for layout changes that template + regeneration cannot infer on its own. THE MIGRATION RECORD @@ -135,28 +157,41 @@ For a machine-readable form, pass `--json` (works alongside `--dry-run`). -UPGRADE INTEGRATION +PROJECT UPDATE INTEGRATION + Routine project updates use `seihou update`. It fetches candidate sources + into a staging area, plans applicable migrations automatically, and then + reconciles the newly generated content with user edits. The migration and + template transitions therefore share one preview, confirmation, recovery, + and manifest-publication boundary. + + Use `seihou migrate ` directly for focused recovery or when you + deliberately need its lower-level controls, such as an intermediate + `--to VERSION`. See `seihou help update` for the routine workflow. + +CACHE UPGRADE INTEGRATION + `seihou upgrade` updates the central installed copy under ~/.config/seihou/installed// but does *not* rewrite project - trees by default. After an upgrade that brings new migrations, - `seihou upgrade` prints a one-line advisory: + trees by default. After an upgrade that leaves a recorded project behind, + `seihou upgrade` points the user at `seihou update` so migrations and + generated content advance together: note: haskell-base has 1 migration(s) pending (1.0.0 → 2.0.0); - run 'seihou migrate haskell-base' + run 'seihou update' to reconcile the recorded project application - Pass `--with-migrations` to skip the advisory and run migrations - for each upgraded module against the current project in one shot. + `--with-migrations` remains available for compatibility when only the + lower-level migration should run after refreshing the cache. STATUS INTEGRATION `seihou status` shows a `Pending migration: -> ( - step(s)). Run: seihou migrate ` sub-line under any applied + step(s)). Run: seihou update ` sub-line under any applied module whose installed copy has advanced past the manifest's recorded version. `` is the count of in-window declared migrations that will run; it may be zero (the version range has no applicable migrations and the run will only advance the manifest). - The line is informational — use `seihou migrate ` to apply. + Recommendations are deduplicated by recorded top-level application. MANIFEST GUARANTEE @@ -171,6 +206,8 @@ SEE ALSO + seihou update --help + seihou help update seihou migrate --help seihou upgrade --help docs/user/migrations.md diff --git a/help/modules.md b/help/modules.md --- a/help/modules.md +++ b/help/modules.md @@ -80,6 +80,7 @@ seihou validate-module ./my-module Check a module is well-formed seihou install Install modules, recipes, or blueprints from git seihou run --var k=v Run a module to generate files + seihou update [target] Update a recorded application and preserve user edits seihou remove Remove an applied module and its files seihou schema-upgrade ./my-module Upgrade module.dhall to current schema @@ -88,5 +89,8 @@ Modules carry a `version` field that follows dotted-version semantics (1.0.0, 1.2.3, etc.). When an author bumps a module's version and changes its file layout, they can ship migrations alongside the new - version that move existing project files into the new shape. Run - `seihou help migrations` for the full reference. + version that move existing project files into the new shape. For a + recorded application, `seihou update` fetches the newer source, applies + its migrations, regenerates files, and preserves user edits in one + operation. Run `seihou help update` for the project workflow or + `seihou help migrations` for the authoring reference. diff --git a/help/update.md b/help/update.md new file mode 100644 --- /dev/null +++ b/help/update.md @@ -0,0 +1,117 @@ +UPDATE + +`seihou update` reconciles recorded module and recipe applications with newer +source content while preserving project-local edits. It is the routine way to +advance an existing project. `seihou run` remains the initial-generation and +explicit-reconfiguration command; `seihou upgrade` only refreshes the shared +installed cache. + +BASIC WORKFLOW + + Preview every recorded application: + + seihou update --dry-run + + Update one recorded module or recipe application: + + seihou update master-plan + + Apply every recorded application in manifest order: + + seihou update + + Seihou stages newer source repositories before changing the installed cache, + reuses the saved inputs for each module instance, plans migrations, renders + new generated content, reconciles files, and runs only new or changed commands. + The installed cache and manifest are published only after the managed update + succeeds. + +TARGET SELECTION + + TARGET may name a recorded module or recipe, or a module contained in a + recorded application. Repeat TARGET to select several applications. With no + target, every recorded application is selected. + + A targeted update stops if an unselected application also owns a path the + selected applications would change. Name every required owner or run the + no-target form; Seihou will not guess how to reconstruct an omitted layer. + +SAVED INPUTS + + An ordinary update reuses the exact accepted value recorded for each module + instance. Override a value with a repeatable `--var KEY=VALUE`. A newly added + required variable follows the normal resolution chain and may prompt in an + interactive terminal. + + `--reconfigure` intentionally ignores saved values and resolves every input + again. Use it to change configuration, not for routine source updates. + +MIGRATIONS + + Applicable module migrations are always included. Declarative moves and + deletes are staged so `--dry-run` can show the post-migration file plan. + Migration shell commands are listed but cannot be simulated or rolled back + outside Seihou's managed paths. There is no skip-migrations flag because new + templates against an old project layout would be unsafe. + +THREE-WAY FILE RECONCILIATION + + For each generated text file, Seihou compares: + + baseline Content generated by the previous successful application + current Content now on disk, including user edits + generated Content produced from the candidate source + + If only one side changed, that change wins. Non-overlapping user and module + changes merge automatically. Overlapping edits become a conflict with diff3 + markers labeled current, baseline, and generated. Interactive runs let the + user choose generated content, current content, conflict markers, or abort. + + An obsolete generated file is deleted only when it is unchanged. An edited + orphan can be retained, detached, or explicitly deleted. `--force` accepts + permitted deterministic conflict choices but retains edited orphans; it does + not silently delete user data. Binary content that changed on both sides + remains a conflict. + +COMMANDS + + By default, only new or changed generated commands run. `--run-all-commands` + executes every command and `--no-commands` executes none; those flags are + mutually exclusive. Successful command receipts are published only when the + entire command phase succeeds. + +PREVIEW, AUTOMATION, AND COMMITS + + `--dry-run` prints the complete plan without changing project files, cache, + baselines, or manifest. `--json` emits one machine-readable JSON document and + disables prompts. Supply required values and conflict choices in advance for + non-interactive use. + + `--commit` commits only managed paths from a successful update. + `--commit-message MSG` supplies the message and implies `--commit`. Neither + commit option can be combined with `--dry-run`. + +TRANSACTION SAFETY + + Before mutation, Seihou checks that the manifest, project files, and staged + sources still match the accepted plan. Managed migrations, files, baseline + blobs, installed-cache entries, and the manifest are protected by recovery + journals. The manifest is the final publication marker. + + External effects from module or migration shell commands cannot be undone. + A failure reports that limitation instead of claiming a full rollback. + +LEGACY PROJECTS + + A manifest without recorded applications needs one explicit TARGET for its + first update. That successful run seeds application identity, saved inputs, + ownership, generated baselines, and command receipts. Ambiguous legacy values + are reported rather than guessed. + +SEE ALSO + + seihou update --help + seihou help modules + seihou help migrations + seihou status --help + docs/cli/update.md diff --git a/seihou-cli.cabal b/seihou-cli.cabal --- a/seihou-cli.cabal +++ b/seihou-cli.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: seihou-cli -version: 0.4.0.0 +version: 0.5.0.0 synopsis: CLI for Seihou project scaffolding description: Command-line interface for Seihou, a composable project scaffolding @@ -18,6 +18,7 @@ build-type: Simple extra-source-files: data/assist-prompt.md + data/blueprint-migration-prompt.md data/blueprint-prompt.md data/bootstrap-prompt.md data/prompt-run-prompt.md @@ -32,6 +33,7 @@ help/modules.md help/prompts.md help/templating.md + help/update.md help/variables.md source-repository head @@ -53,9 +55,15 @@ exposed-modules: Seihou.CLI.AgentCompletion Seihou.CLI.AgentConfig + Seihou.CLI.AgentConfigShow Seihou.CLI.AgentLaunch + Seihou.CLI.AgentModels Seihou.CLI.AppliedBlueprint + Seihou.CLI.AppliedBlueprintMigration + Seihou.CLI.BlueprintExecution + Seihou.CLI.BlueprintMigration Seihou.CLI.BrowseFormat + Seihou.CLI.CommandExecution Seihou.CLI.CommitMessage Seihou.CLI.Completions.Bash Seihou.CLI.Completions.Fish @@ -79,6 +87,14 @@ Seihou.CLI.Shared Seihou.CLI.StatusRender Seihou.CLI.Style + Seihou.CLI.Update + Seihou.CLI.Update.Interaction + Seihou.CLI.Update.Migrations + Seihou.CLI.Update.Recovery + Seihou.CLI.Update.Render + Seihou.CLI.Update.Selection + Seihou.CLI.Update.Source + Seihou.CLI.Update.Types Seihou.CLI.VersionCompare Seihou.Effect.Fzf Seihou.Effect.FzfInterp @@ -90,9 +106,9 @@ aeson >=2.1 && <3, aeson-pretty >=0.8 && <1, ansi-terminal >=1.1 && <2, - baikai ^>=0.3.0.0, - baikai-claude ^>=0.3.0.0, - baikai-openai ^>=0.3.0.0, + baikai ^>=0.4.0.0, + baikai-claude ^>=0.3.0.1, + baikai-openai ^>=0.3.0.1, base >=4.18 && <5, bytestring >=0.11 && <1, containers >=0.6 && <1, @@ -101,7 +117,7 @@ file-embed >=0.0.15 && <1, filepath >=1.4 && <2, process >=1.6 && <2, - seihou-core ^>=0.4.0.0, + seihou-core ^>=0.5.0.0, temporary >=1.3 && <2, text >=2.0 && <3, time >=1.12 && <2, @@ -116,6 +132,7 @@ OverloadedLabels OverloadedRecordDot OverloadedStrings + PackageImports TypeFamilies hs-source-dirs: src-exe @@ -132,6 +149,7 @@ other-modules: Paths_seihou_cli Seihou.CLI.AgentLaunchExec + Seihou.CLI.AgentMigrate Seihou.CLI.AgentRun Seihou.CLI.Assist Seihou.CLI.Bootstrap @@ -154,6 +172,7 @@ Seihou.CLI.SchemaUpgrade Seihou.CLI.Setup Seihou.CLI.Status + Seihou.CLI.Update Seihou.CLI.Upgrade Seihou.CLI.Validate Seihou.CLI.ValidateBlueprint @@ -165,10 +184,10 @@ aeson >=2.1 && <3, aeson-pretty >=0.8 && <1, ansi-terminal >=1.1 && <2, - baikai ^>=0.3.0.0, - baikai-claude ^>=0.3.0.0, - baikai-kit ^>=0.1.0.1, - baikai-openai ^>=0.3.0.0, + baikai ^>=0.4.0.0, + baikai-claude ^>=0.3.0.1, + baikai-kit ^>=0.1.0.2, + baikai-openai ^>=0.3.0.1, base >=4.18 && <5, bytestring >=0.11 && <1, containers >=0.6 && <1, @@ -180,7 +199,7 @@ optparse-applicative >=0.18 && <1, process >=1.6 && <2, seihou-cli-internal, - seihou-core ^>=0.4.0.0, + seihou-core ^>=0.5.0.0, temporary >=1.3 && <2, text >=2.0 && <3, time >=1.12 && <2, @@ -202,10 +221,16 @@ other-modules: Seihou.CLI.AgentCompletionSpec + Seihou.CLI.AgentConfigShowSpec Seihou.CLI.AgentConfigSpec Seihou.CLI.AgentLaunchSpec + Seihou.CLI.AgentMigrateE2ESpec + Seihou.CLI.AgentModelsSpec + Seihou.CLI.AppliedBlueprintMigrationSpec Seihou.CLI.AppliedBlueprintSpec + Seihou.CLI.BlueprintMigrationSpec Seihou.CLI.BrowseFormatSpec + Seihou.CLI.CommandExecutionSpec Seihou.CLI.CommitMessageSpec Seihou.CLI.DiffSpec Seihou.CLI.ExtensionSpec @@ -222,12 +247,20 @@ Seihou.CLI.RunBlueprintRefusalSpec Seihou.CLI.SavePromptedSpec Seihou.CLI.StatusSpec + Seihou.CLI.UpdateE2ESpec + Seihou.CLI.UpdateFixture + Seihou.CLI.UpdateInteractionSpec + Seihou.CLI.UpdateRenderSpec + Seihou.CLI.UpdateSpec Seihou.CLI.UpgradeSpec Seihou.FzfSpec + build-tool-depends: + seihou-cli:seihou + build-depends: aeson >=2.1 && <3, - baikai ^>=0.3.0.0, + baikai ^>=0.4.0.0, base >=4.18 && <5, bytestring >=0.11 && <1, containers >=0.6 && <1, @@ -237,7 +270,7 @@ hspec >=2.11 && <3, process >=1.6 && <2, seihou-cli-internal, - seihou-core ^>=0.4.0.0, + seihou-core ^>=0.5.0.0, tasty >=1.4 && <2, tasty-hspec >=1.2 && <2, temporary >=1.3 && <2, diff --git a/src-exe/Main.hs b/src-exe/Main.hs --- a/src-exe/Main.hs +++ b/src-exe/Main.hs @@ -2,12 +2,16 @@ import Control.Applicative ((<|>)) import Data.List (isPrefixOf) +import Data.Maybe (isJust) import Data.String (fromString) import Data.Text (Text) import Data.Text.IO qualified as TIO import Options.Applicative (customExecParser, prefs, showHelpOnEmpty) import Seihou.CLI.AgentCompletion qualified as AgentCompletion -import Seihou.CLI.AgentConfig (loadAgentModelConfig) +import Seihou.CLI.AgentConfig (AgentCommandName (..), loadAgentModelConfigFor) +import Seihou.CLI.AgentConfigShow (handleAgentConfigShow) +import Seihou.CLI.AgentMigrate (handleAgentMigrate) +import Seihou.CLI.AgentModels qualified as AgentModels import Seihou.CLI.AgentRun (handleAgentRun) import Seihou.CLI.Assist (handleAssist) import Seihou.CLI.Bootstrap (handleBootstrap) @@ -36,6 +40,7 @@ import Seihou.CLI.SchemaUpgrade (handleSchemaUpgrade) import Seihou.CLI.Setup (handleSetup) import Seihou.CLI.Status (handleStatus) +import Seihou.CLI.Update (handleUpdate) import Seihou.CLI.Upgrade (handleUpgrade) import Seihou.CLI.Validate (handleValidateModule) import Seihou.CLI.ValidateBlueprint (handleValidateBlueprint) @@ -75,6 +80,8 @@ handleInit Run runOpts -> handleRun runOpts + Update updateOpts -> + handleUpdate updateOpts Remove removeOpts -> handleRemove removeOpts Vars varsOpts -> @@ -127,21 +134,42 @@ Agent agentOpts -> do case agentOpts.agentCommand of AgentAssist assistOpts -> do - modelConfig <- resolveAgentModelConfig agentOpts.agentProvider agentOpts.agentModel assistOpts.assistProvider assistOpts.assistModel + modelConfig <- resolveAgentModelConfigFor AgentCmdAssist agentOpts.agentProvider agentOpts.agentModel agentOpts.agentEffort assistOpts.assistProvider assistOpts.assistModel assistOpts.assistEffort handleAssist agentOpts.agentDebug modelConfig assistOpts AgentBootstrap bootstrapOpts -> do - modelConfig <- resolveAgentModelConfig agentOpts.agentProvider agentOpts.agentModel bootstrapOpts.bootstrapProvider bootstrapOpts.bootstrapModel + modelConfig <- resolveAgentModelConfigFor AgentCmdBootstrap agentOpts.agentProvider agentOpts.agentModel agentOpts.agentEffort bootstrapOpts.bootstrapProvider bootstrapOpts.bootstrapModel bootstrapOpts.bootstrapEffort handleBootstrap agentOpts.agentDebug modelConfig bootstrapOpts AgentSetup setupOpts -> do - modelConfig <- resolveAgentModelConfig agentOpts.agentProvider agentOpts.agentModel setupOpts.setupProvider setupOpts.setupModel + modelConfig <- resolveAgentModelConfigFor AgentCmdSetup agentOpts.agentProvider agentOpts.agentModel agentOpts.agentEffort setupOpts.setupProvider setupOpts.setupModel setupOpts.setupEffort handleSetup agentOpts.agentDebug modelConfig setupOpts AgentRun blueprintRunOpts -> do - modelConfig <- resolveAgentModelConfig agentOpts.agentProvider agentOpts.agentModel blueprintRunOpts.runBlueprintProvider blueprintRunOpts.runBlueprintModel + modelConfig <- resolveAgentModelConfigFor AgentCmdRun agentOpts.agentProvider agentOpts.agentModel agentOpts.agentEffort blueprintRunOpts.runBlueprintProvider blueprintRunOpts.runBlueprintModel blueprintRunOpts.runBlueprintEffort handleAgentRun agentOpts.agentDebug modelConfig blueprintRunOpts + AgentMigrate migrationOpts -> do + modelConfig <- resolveAgentModelConfigFor AgentCmdMigrate agentOpts.agentProvider agentOpts.agentModel agentOpts.agentEffort migrationOpts.migrateBlueprintProvider migrationOpts.migrateBlueprintModel migrationOpts.migrateBlueprintEffort + handleAgentMigrate agentOpts.agentDebug modelConfig migrationOpts + AgentModels modelsOpts -> + case agentOpts.agentModel of + Just _ -> do + TIO.putStrLn "Error: --model does not apply to 'seihou agent models'; omit it to list known choices." + exitFailure + Nothing -> + case modelsOpts.modelsProvider <|> agentOpts.agentProvider of + Nothing -> + TIO.putStr (AgentModels.formatAgentModels Nothing AgentModels.availableAgentModels) + Just providerText -> + case AgentCompletion.providerFromText providerText of + Left err -> do + TIO.putStrLn $ "Error: " <> err + exitFailure + Right provider -> + TIO.putStr (AgentModels.formatAgentModels (Just provider) AgentModels.availableAgentModels) + AgentConfigShow -> + handleAgentConfigShow Prompt promptCmd -> do case promptCmd of PromptRun promptRunOpts -> do - modelConfig <- resolveAgentModelConfig Nothing Nothing promptRunOpts.runPromptProvider promptRunOpts.runPromptModel + modelConfig <- resolveAgentModelConfigFor AgentCmdPromptRun Nothing Nothing Nothing promptRunOpts.runPromptProvider promptRunOpts.runPromptModel promptRunOpts.runPromptEffort handlePromptRun modelConfig promptRunOpts Extension extensionCmd -> do case extensionCmd of @@ -152,9 +180,27 @@ Completions completionsCmd -> handleCompletionsCommand completionsCmd -resolveAgentModelConfig :: Maybe Text -> Maybe Text -> Maybe Text -> Maybe Text -> IO AgentCompletion.AgentModelConfig -resolveAgentModelConfig parentProvider parentModel commandProvider commandModel = do - configResult <- loadAgentModelConfig (commandProvider <|> parentProvider) (commandModel <|> parentModel) +-- | Resolve the effective provider/model/effort for one agent command. The +-- subcommand flag wins over the parent @seihou agent@ flag; that combined flag +-- then feeds the per-command config resolution, which also consults the +-- command's own @agent..*@ keys before the shared @agent.*@ defaults. +resolveAgentModelConfigFor :: + AgentCommandName -> + -- | parent @seihou agent@ provider, model, effort + Maybe Text -> + Maybe Text -> + Maybe Text -> + -- | subcommand provider, model, effort + Maybe Text -> + Maybe Text -> + Maybe Text -> + IO AgentCompletion.AgentModelConfig +resolveAgentModelConfigFor cmd parentProvider parentModel parentEffort commandProvider commandModel commandEffort = do + let provider = commandProvider <|> parentProvider + model = commandModel <|> parentModel + effort = commandEffort <|> parentEffort + configResult <- + loadAgentModelConfigFor cmd provider model effort (isJust commandProvider) (isJust commandModel) (isJust commandEffort) case configResult of Left err -> do TIO.putStrLn $ "Error: " <> err diff --git a/src-exe/Seihou/CLI/AgentLaunchExec.hs b/src-exe/Seihou/CLI/AgentLaunchExec.hs --- a/src-exe/Seihou/CLI/AgentLaunchExec.hs +++ b/src-exe/Seihou/CLI/AgentLaunchExec.hs @@ -10,6 +10,7 @@ CodexSandboxMode (CodexWorkspaceWrite), InteractiveLaunchResult (..), InteractiveSafety (ClaudeAllowedTools, CodexSandbox), + effort, extraDirs, interactiveLaunchRequest, modelId, @@ -26,6 +27,7 @@ ( defaultCodexInteractiveConfig, launchCodexInteractive, ) +import Baikai.ThinkingLevel (ThinkingLevel) import Data.Text qualified as T import Data.Text.IO qualified as TIO import Seihou.CLI.AgentCompletion (AgentModelConfig (..), AgentProvider (..)) @@ -50,16 +52,16 @@ | otherwise = case modelConfig.agentProvider of AgentProviderClaudeCli -> - launchClaude addDirs tools modelConfig.agentModel systemPrompt initialPrompt + launchClaude addDirs tools modelConfig.agentModel modelConfig.agentEffort systemPrompt initialPrompt AgentProviderCodexCli -> - launchCodex addDirs modelConfig.agentModel systemPrompt initialPrompt + launchCodex addDirs modelConfig.agentModel modelConfig.agentEffort systemPrompt initialPrompt AgentProviderAnthropic -> unsupportedInteractiveProvider "anthropic" AgentProviderOpenAI -> unsupportedInteractiveProvider "openai" -launchClaude :: [FilePath] -> [String] -> Maybe Text -> Text -> Maybe Text -> IO ExitCode -launchClaude addDirs tools model systemPrompt initialPrompt = do +launchClaude :: [FilePath] -> [String] -> Maybe Text -> Maybe ThinkingLevel -> Text -> Maybe Text -> IO ExitCode +launchClaude addDirs tools model effortLevel systemPrompt initialPrompt = do claudePath <- findExecutable "claude" case claudePath of Nothing -> do @@ -74,14 +76,15 @@ (interactiveLaunchRequest (promptOrEmpty initialPrompt)) { systemPrompt = Just systemPrompt, modelId = model, + effort = effortLevel, workingDir = Just cwd, extraDirs = addDirs, safety = ClaudeAllowedTools (map T.pack tools) } pure exitCode -launchCodex :: [FilePath] -> Maybe Text -> Text -> Maybe Text -> IO ExitCode -launchCodex addDirs model systemPrompt initialPrompt = do +launchCodex :: [FilePath] -> Maybe Text -> Maybe ThinkingLevel -> Text -> Maybe Text -> IO ExitCode +launchCodex addDirs model effortLevel systemPrompt initialPrompt = do codexPath <- findExecutable "codex" case codexPath of Nothing -> do @@ -96,6 +99,7 @@ (interactiveLaunchRequest (promptOrEmpty initialPrompt)) { systemPrompt = Just systemPrompt, modelId = model, + effort = effortLevel, workingDir = Just cwd, extraDirs = addDirs, safety = CodexSandbox CodexWorkspaceWrite CodexApprovalOnRequest diff --git a/src-exe/Seihou/CLI/AgentMigrate.hs b/src-exe/Seihou/CLI/AgentMigrate.hs new file mode 100644 --- /dev/null +++ b/src-exe/Seihou/CLI/AgentMigrate.hs @@ -0,0 +1,337 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Seihou.CLI.AgentMigrate + ( handleAgentMigrate, + ) +where + +import Data.FileEmbed (embedFile) +import Data.Maybe (maybeToList) +import Data.Text qualified as T +import Data.Text.Encoding qualified as TE +import Data.Text.IO qualified as TIO +import Data.Time.Clock (getCurrentTime) +import Seihou.CLI.AgentCompletion + ( AgentModelConfig (..), + AgentProvider (..), + buildAgentCompletionRequest, + runAgentCompletion, + ) +import Seihou.CLI.AgentLaunch (gatherAgentContext) +import Seihou.CLI.AgentLaunchExec (launchConfiguredAgentAddingDirs) +import Seihou.CLI.AppliedBlueprintMigration (recordAppliedBlueprintMigration) +import Seihou.CLI.BlueprintExecution + ( BlueprintExecutionRequest (..), + PreparedBlueprintExecution (..), + prepareBlueprintExecution, + ) +import Seihou.CLI.BlueprintMigration + ( BlueprintMigrationLaunchFailure (..), + BlueprintMigrationRunResult (..), + formatBlueprintMigrationDebugOutput, + pendingBlueprintMigrations, + renderBlueprintMigrationSystemPrompt, + runBlueprintMigrationsWith, + ) +import Seihou.CLI.Commands (BlueprintMigrationOpts (..)) +import Seihou.CLI.Shared (formatVarError, logIO) +import Seihou.Core.Blueprint (validateBlueprint) +import Seihou.Core.Migration + ( BlueprintMigration (..), + BlueprintMigrationPlan (..), + MigrationPlanError (..), + planBlueprintMigrationChain, + ) +import Seihou.Core.Module (defaultSearchPaths, discoverRunnable) +import Seihou.Core.Types +import Seihou.Core.Version (Version, parseVersion, renderVersion) +import Seihou.Effect.FilesystemInterp (runFilesystem) +import Seihou.Effect.Logger (logError) +import Seihou.Effect.ManifestStore (readManifest) +import Seihou.Effect.ManifestStoreInterp (runManifestStore) +import Seihou.Prelude +import System.Exit (ExitCode (..), exitFailure, exitWith) + +migrationPromptTemplate :: Text +migrationPromptTemplate = TE.decodeUtf8 $(embedFile "data/blueprint-migration-prompt.md") + +handleAgentMigrate :: Bool -> AgentModelConfig -> BlueprintMigrationOpts -> IO () +handleAgentMigrate debug modelConfig opts = do + let level = if opts.migrateBlueprintVerbose then LogVerbose else LogNormal + manifestPath = ".seihou" "manifest.json" + + (blueprint, blueprintDir) <- discoverMigrationBlueprint level opts.migrateBlueprintName + validationResult <- validateBlueprint blueprintDir blueprint + case validationResult of + Left err -> exitErr level (renderModuleLoadError err) + Right _ -> pure () + + current <- parseRequestedVersion level "--from" opts.migrateBlueprintFrom + target <- parseRequestedVersion level "--to" opts.migrateBlueprintTo + planned <- + case planBlueprintMigrationChain blueprint.name.unModuleName blueprint.migrations current target of + Left err -> exitErr level (renderPlanError err) + Right Nothing -> do + TIO.putStrLn "No blueprint migration needed: --from and --to resolve to the same version." + pure Nothing + Right (Just migrationPlan) -> pure (Just migrationPlan) + + case planned of + Nothing -> pure () + Just migrationPlan -> do + receipts <- readMigrationReceipts level manifestPath + let pending = + pendingBlueprintMigrations + opts.migrateBlueprintRerun + blueprint.name + receipts + migrationPlan + if null pending + then reportNoPending migrationPlan + else do + prepared <- prepare level modelConfig opts blueprint blueprintDir + context <- gatherAgentContext + let renderStep position total migration = + renderBlueprintMigrationSystemPrompt + migrationPromptTemplate + context + prepared + position + total + migration + renderDebugStep position total migration = + renderStep position total migration + <> maybe + "" + ("\n\n===== Initial user instruction =====\n" <>) + opts.migrateBlueprintPrompt + + if debug + then + TIO.putStrLn $ + "Blueprint migrations for " + <> blueprint.name.unModuleName + <> ": " + <> renderVersion migrationPlan.blueprintPlanFrom + <> " -> " + <> renderVersion migrationPlan.blueprintPlanTo + <> "\n" + <> formatBlueprintMigrationDebugOutput renderDebugStep pending + else do + result <- + runBlueprintMigrationsWith + (launchMigration modelConfig opts prepared renderStep) + (recordMigration manifestPath blueprint) + pending + handleRunResult level blueprint.name result + +discoverMigrationBlueprint :: LogLevel -> ModuleName -> IO (Blueprint, FilePath) +discoverMigrationBlueprint level requestedName = do + searchPaths <- defaultSearchPaths + runnableResult <- discoverRunnable searchPaths requestedName + case runnableResult of + Right (RunnableBlueprint blueprint dir) -> pure (blueprint, dir) + Right (RunnableModule _ _) -> + exitErr level $ "'" <> requestedName.unModuleName <> "' is a module, not a blueprint." + Right (RunnableRecipe _ _) -> + exitErr level $ "'" <> requestedName.unModuleName <> "' is a recipe, not a blueprint." + Right (RunnableAgentPrompt _ _) -> + exitErr level $ "'" <> requestedName.unModuleName <> "' is a prompt, not a blueprint." + Left err -> exitErr level (renderModuleLoadError err) + +parseRequestedVersion :: LogLevel -> Text -> Text -> IO Version +parseRequestedVersion level flag raw = + case parseVersion raw of + Just version -> pure version + Nothing -> exitErr level (flag <> " value '" <> raw <> "' is not a valid dotted numeric version.") + +readMigrationReceipts :: LogLevel -> FilePath -> IO [AppliedBlueprintMigration] +readMigrationReceipts level manifestPath = do + result <- runEff $ runFilesystem $ runManifestStore manifestPath readManifest + case result of + Left err -> exitErr level ("Error reading migration receipts: " <> err) + Right Nothing -> pure [] + Right (Just manifest) -> pure manifest.blueprintMigrations + +prepare :: + LogLevel -> + AgentModelConfig -> + BlueprintMigrationOpts -> + Blueprint -> + FilePath -> + IO PreparedBlueprintExecution +prepare level modelConfig opts blueprint blueprintDir = do + let providerCanMountFiles = + modelConfig.agentProvider == AgentProviderClaudeCli + || modelConfig.agentProvider == AgentProviderCodexCli + result <- + prepareBlueprintExecution + BlueprintExecutionRequest + { executionBlueprint = blueprint, + executionBlueprintDir = blueprintDir, + executionVariableOverrides = opts.migrateBlueprintVars, + executionNamespaceOverride = opts.migrateBlueprintNamespace, + executionContextOverride = opts.migrateBlueprintContext, + executionCanMountFiles = providerCanMountFiles, + executionLogLevel = level + } + case result of + Left errs -> do + logIO level $ logError "Error resolving blueprint migration variables:" + mapM_ (logIO level . logError . (" " <>) . formatVarError) errs + exitFailure + Right prepared -> pure prepared + +launchMigration :: + AgentModelConfig -> + BlueprintMigrationOpts -> + PreparedBlueprintExecution -> + (Int -> Int -> BlueprintMigration -> Text) -> + Int -> + Int -> + BlueprintMigration -> + IO (Either BlueprintMigrationLaunchFailure ()) +launchMigration modelConfig opts prepared renderStep position total migration = do + TIO.putStrLn $ + "Running blueprint migration " + <> T.pack (show position) + <> "/" + <> T.pack (show total) + <> ": " + <> migration.from + <> " -> " + <> migration.to + let systemPrompt = renderStep position total migration + case modelConfig.agentProvider of + AgentProviderClaudeCli -> launchInteractive systemPrompt + AgentProviderCodexCli -> launchInteractive systemPrompt + AgentProviderAnthropic -> launchCompletion systemPrompt + AgentProviderOpenAI -> launchCompletion systemPrompt + where + launchInteractive systemPrompt = do + exitCode <- + launchConfiguredAgentAddingDirs + (maybeToList prepared.preparedMountedFilesDir) + modelConfig + prepared.preparedAllowedTools + False + systemPrompt + opts.migrateBlueprintPrompt + pure $ case exitCode of + ExitSuccess -> Right () + failure -> Left (BlueprintMigrationProcessFailure failure) + + launchCompletion systemPrompt = do + result <- + runAgentCompletion + (buildAgentCompletionRequest modelConfig systemPrompt opts.migrateBlueprintPrompt) + case result of + Left err -> pure (Left (BlueprintMigrationProviderFailure err)) + Right assistantText -> do + TIO.putStrLn assistantText + pure (Right ()) + +recordMigration :: + FilePath -> + Blueprint -> + BlueprintMigration -> + IO (Either Text ()) +recordMigration manifestPath blueprint migration = do + now <- getCurrentTime + recordAppliedBlueprintMigration + manifestPath + AppliedBlueprintMigration + { name = blueprint.name, + blueprintVersion = blueprint.version, + fromVersion = migration.from, + toVersion = migration.to, + appliedAt = now, + agentSessionId = Nothing + } + +handleRunResult :: LogLevel -> ModuleName -> BlueprintMigrationRunResult -> IO () +handleRunResult level blueprintName = \case + BlueprintMigrationNoWork -> + TIO.putStrLn "No pending blueprint migrations." + BlueprintMigrationComplete completed -> + TIO.putStrLn $ + "Completed " + <> T.pack (show (length completed)) + <> " blueprint migration(s) for '" + <> blueprintName.unModuleName + <> "'." + BlueprintMigrationLaunchFailed migration failure -> do + let prefix = + "Blueprint migration " + <> migration.from + <> " -> " + <> migration.to + <> " failed; completed earlier edges remain recorded. " + retry = "Fix the provider error, then rerun the same command to resume." + case failure of + BlueprintMigrationProcessFailure exitCode -> do + logIO level $ logError $ prefix <> "Provider exited with " <> T.pack (show exitCode) <> ". " <> retry + exitWith exitCode + BlueprintMigrationProviderFailure err -> do + logIO level $ logError $ prefix <> err <> " " <> retry + exitFailure + BlueprintMigrationRecordFailed migration err -> do + logIO level $ + logError $ + "Agent completed blueprint migration " + <> migration.from + <> " -> " + <> migration.to + <> ", but its receipt could not be recorded: " + <> err + <> ". The next edge was not started; repair manifest access, then rerun the same command." + exitFailure + +reportNoPending :: BlueprintMigrationPlan -> IO () +reportNoPending migrationPlan + | null migrationPlan.blueprintPlanSteps = + TIO.putStrLn "No blueprint migrations are declared inside the requested version window." + | otherwise = + TIO.putStrLn "All blueprint migrations in the requested version window already have receipts." + +renderPlanError :: MigrationPlanError -> Text +renderPlanError (MigrationVersionUnparseable raw) = + "the blueprint declares an unparseable migration version: '" <> raw <> "'." +renderPlanError (MigrationDowngradeNotSupported current target) = + "blueprint migration downgrades are not supported: --from " + <> renderVersion current + <> ", --to " + <> renderVersion target + <> "." +renderPlanError (MigrationDuplicateEdge fromVersion _) = + "the blueprint declares more than one migration starting at " + <> renderVersion fromVersion + <> "; the author must merge or remove the duplicate." + +renderModuleLoadError :: ModuleLoadError -> Text +renderModuleLoadError = \case + ModuleNotFound name searched -> + "Blueprint '" + <> name.unModuleName + <> "' not found. Searched in:\n" + <> T.intercalate "\n" (map ((" " <>) . T.pack) searched) + DhallEvalError name msg -> + "Failed to evaluate '" <> name.unModuleName <> "': " <> msg + DhallDecodeError name msg -> + "Failed to decode '" <> name.unModuleName <> "': " <> msg + ValidationError name msgs -> + "Validation failed for '" + <> name.unModuleName + <> "':\n" + <> T.intercalate "\n" (map (" " <>) msgs) + CircularDependency names -> + "Circular dependency detected: " <> T.intercalate " -> " (map (.unModuleName) names) + MissingSourceFile name path -> + "Missing source file in '" <> name.unModuleName <> "': " <> T.pack path + RegistryEvalError path msg -> + "Failed to evaluate registry at '" <> path <> "': " <> msg + +exitErr :: LogLevel -> Text -> IO a +exitErr level msg = do + logIO level (logError msg) + exitFailure diff --git a/src-exe/Seihou/CLI/AgentRun.hs b/src-exe/Seihou/CLI/AgentRun.hs --- a/src-exe/Seihou/CLI/AgentRun.hs +++ b/src-exe/Seihou/CLI/AgentRun.hs @@ -12,6 +12,7 @@ ) where +import Control.Exception (IOException, displayException, try) import Control.Monad (when) import Data.FileEmbed (embedFile) import Data.Map.Strict qualified as Map @@ -36,15 +37,18 @@ formatLocalModules, formatManifestState, formatModuleDhallState, - formatReferenceFiles, - formatReferenceFilesDir, formatSeihouProjectState, gatherAgentContext, - resolveBlueprintTools, substitute, ) import Seihou.CLI.AgentLaunchExec (launchConfiguredAgentAddingDirs) import Seihou.CLI.AppliedBlueprint (recordAppliedBlueprint) +import Seihou.CLI.BlueprintExecution + ( BlueprintExecutionRequest (..), + PreparedBlueprintExecution (..), + prepareBlueprintExecution, + varValueToText, + ) import Seihou.CLI.Commands (BlueprintRunOpts (..)) import Seihou.CLI.Shared ( deriveNamespace, @@ -53,12 +57,14 @@ toVarNameMap, unwrapConfig, ) -import Seihou.Composition.Instance (ModuleInstance (..), primaryInstance, qualifiedName) +import Seihou.Composition.Instance (ModuleInstance (..), qualifiedName) import Seihou.Composition.Plan (compileComposedPlan) import Seihou.Composition.Resolve (loadComposition, resolveWithPrompts) import Seihou.Core.Context (resolveContext) import Seihou.Core.Module (defaultSearchPaths, discoverRunnable) import Seihou.Core.Types +import Seihou.Effect.BaselineStore (pruneBaselines) +import Seihou.Effect.BaselineStoreInterp (runBaselineStore) import Seihou.Effect.ConfigReader ( readContextConfig, readGlobalConfig, @@ -69,15 +75,15 @@ import Seihou.Effect.ConsoleInterp (runConsole) import Seihou.Effect.Filesystem (createDirectoryIfMissing) import Seihou.Effect.FilesystemInterp (runFilesystem) -import Seihou.Effect.Logger (logError, logInfo) +import Seihou.Effect.Logger (logError, logInfo, logWarn) import Seihou.Effect.ManifestStore (readManifest, writeManifest) import Seihou.Effect.ManifestStoreInterp (runManifestStore) +import Seihou.Engine.Baseline (manifestBaselineRefs, recordGeneratedBaselines) import Seihou.Engine.Conflict (resolveConflicts) import Seihou.Engine.Diff (computeDiff) import Seihou.Engine.Execute (executePlan) import Seihou.Manifest.Types (currentManifestVersion, emptyManifest) import Seihou.Prelude -import System.Directory (doesDirectoryExist, makeAbsolute) import System.Environment (getEnvironment) import System.Exit (ExitCode (..), exitFailure, exitWith) import System.FilePath (takeDirectory, ()) @@ -112,66 +118,29 @@ <> "'?" Left err -> exitErr level (renderModuleLoadError err) - let filesDir = blueprintDir "files" - providerCanMountFiles = + let providerCanMountFiles = modelConfig.agentProvider == AgentProviderClaudeCli || modelConfig.agentProvider == AgentProviderCodexCli - filesExist <- doesDirectoryExist filesDir - mFilesDir <- - if filesExist && providerCanMountFiles - then Just <$> makeAbsolute filesDir - else pure Nothing - - -- (b) Resolve blueprint variables. Wrap the blueprint's vars/prompts - -- in a placeholder Module so 'resolveWithPrompts' can run the - -- standard precedence chain (CLI > env > local > namespace > context - -- > global > defaults > interactive prompts). - let placeholderModule = - Module - { name = bp.name, - version = bp.version, - description = bp.description, - vars = bp.vars, - exports = [], - prompts = bp.prompts, - steps = [], - commands = [], - dependencies = [], - removal = Nothing, - migrations = [] - } - placeholderInst = primaryInstance bp.name - placeholderTriple = (placeholderInst, placeholderModule, blueprintDir) - - envPairs <- getEnvironment - let cliOverrides = Map.fromList [(VarName k, v) | (k, v) <- opts.runBlueprintVars] - envVars = Map.fromList [(T.pack k, T.pack v) | (k, v) <- envPairs] - namespace = fromMaybe (deriveNamespace bp.name) opts.runBlueprintNamespace - context <- resolveContext opts.runBlueprintContext envVars - let contextName = fromMaybe "" context - - resolveResult <- runEff $ runConfigReader $ runConsole $ do - localCfg <- readLocalConfig >>= unwrapConfig level - nsCfg <- readNamespaceConfig namespace >>= unwrapConfig level - ctxCfg <- readContextConfig contextName >>= unwrapConfig level - gCfg <- readGlobalConfig >>= unwrapConfig level - resolveWithPrompts - [placeholderTriple] - cliOverrides - envVars - namespace - contextName - (toVarNameMap localCfg) - (toVarNameMap nsCfg) - (toVarNameMap ctxCfg) - (toVarNameMap gCfg) - - resolved <- case resolveResult of + -- (b) Resolve variables and prepare the shared prompt/reference/tool state. + preparedResult <- + prepareBlueprintExecution + BlueprintExecutionRequest + { executionBlueprint = bp, + executionBlueprintDir = blueprintDir, + executionVariableOverrides = opts.runBlueprintVars, + executionNamespaceOverride = opts.runBlueprintNamespace, + executionContextOverride = opts.runBlueprintContext, + executionCanMountFiles = providerCanMountFiles, + executionLogLevel = level + } + prepared <- case preparedResult of Left errs -> do logIO level $ logError "Error resolving blueprint variables:" mapM_ (logIO level . logError . (" " <>) . formatVarError) errs exitFailure - Right r -> pure (Map.findWithDefault Map.empty placeholderInst r) + Right result -> pure result + let resolved = prepared.preparedResolvedVariables + cliOverrides = Map.fromList [(VarName k, v) | (k, v) <- opts.runBlueprintVars] -- (c) Baseline. baseline <- @@ -182,20 +151,17 @@ then pure BaselineEmpty else applyBaseline level opts bp.baseModules cliOverrides resolved - -- (d) Render the user prompt: substitute resolved vars into bp.prompt. - let renderedUser = renderUserPrompt resolved bp.prompt - - -- (e) Render the system prompt around the user body. + -- (d) Render the system prompt around the prepared shared body. ctx <- gatherAgentContext - let systemPrompt = renderSystemPrompt ctx bp baseline mFilesDir renderedUser + let systemPrompt = renderSystemPrompt ctx prepared baseline -- (f) Launch. launchSucceeded <- runRenderedAgentPrompt debug modelConfig - (resolveBlueprintTools bp.allowedTools) - mFilesDir + prepared.preparedAllowedTools + prepared.preparedMountedFilesDir systemPrompt opts.runBlueprintPrompt @@ -347,6 +313,7 @@ -- write the manifest. Mirrors Seihou.CLI.Run.handleRun. now <- getCurrentTime let manifestPath = ".seihou" "manifest.json" + baselineDir = ".seihou" "baselines" planned = [(dest, content, primary, Nothing) | WriteFileOp dest content _ <- ops] ++ [(dest, content, mName, Just pOp) | PatchFileOp dest content pOp _ mName <- ops] @@ -384,7 +351,9 @@ { hash = c.diskHash, moduleName = c.moduleName, strategy = Template, - generatedAt = now + generatedAt = now, + baseline = Nothing, + applicationIds = mempty } ) | (c, KeepCurrent) <- conflictResolved @@ -393,26 +362,57 @@ excludePaths = Set.fromList (Map.keys keepRecords ++ skipPaths) opsForExec = filter (not . opTargetsPath excludePaths) ops - runEff $ runFilesystem $ runManifestStore manifestPath $ do - recs <- executePlan "" opsForExec ownerMap primary now + generationAttempt <- + try @IOException $ + runEff $ + runFilesystem $ + runBaselineStore baselineDir $ + runManifestStore manifestPath $ do + recs <- executePlan "" opsForExec ownerMap primary now + baselineResult <- recordGeneratedBaselines "" recs + case baselineResult of + Left err -> pure (Left err) + Right baselineRecords -> do + let orphanedPaths = map (.path) diff.orphaned + cleanedFiles = foldr Map.delete manifest.files orphanedPaths + allModuleEntries = updateAllModules manifest.modules modulesInOrder now + allResolvedVals = + Map.unions [Map.map (.value) vs | vs <- Map.elems baseResolved] + newManifest = + Manifest + { version = currentManifestVersion, + genAt = now, + modules = allModuleEntries, + vars = Map.union (Map.map varValueToText allResolvedVals) manifest.vars, + files = Map.unions [baselineRecords, keepRecords, cleanedFiles], + applications = manifest.applications, + recipe = manifest.recipe, + blueprint = manifest.blueprint, + blueprintMigrations = manifest.blueprintMigrations + } + writeManifest newManifest + pure (Right newManifest) - let orphanedPaths = map (.path) diff.orphaned - cleanedFiles = foldr Map.delete manifest.files orphanedPaths - allModuleEntries = updateAllModules manifest.modules modulesInOrder now - allResolvedVals = - Map.unions [Map.map (.value) vs | vs <- Map.elems baseResolved] - newManifest = - Manifest - { version = currentManifestVersion, - genAt = now, - modules = allModuleEntries, - vars = Map.union (Map.map varValueToText allResolvedVals) manifest.vars, - files = Map.unions [recs, keepRecords, cleanedFiles], - recipe = manifest.recipe, - blueprint = manifest.blueprint - } - writeManifest newManifest + newManifest <- case generationAttempt of + Left err -> do + logIO level $ logError $ "Error applying baseline files or storing generated baselines: " <> T.pack (displayException err) + exitFailure + Right (Left err) -> do + logIO level $ logError $ "Error storing generated baselines: " <> T.pack (show err) + exitFailure + Right (Right saved) -> pure saved + pruneAttempt <- + try @IOException $ + runEff $ + runFilesystem $ + runBaselineStore baselineDir $ + pruneBaselines (manifestBaselineRefs newManifest) + case pruneAttempt of + Left err -> + logIO level $ logWarn $ "Warning: could not prune generated baselines: " <> T.pack (displayException err) + Right _ -> pure () + let nNew = length diff.new nMod = length diff.modified nUnch = length diff.unchanged @@ -431,40 +431,25 @@ -- | Stitch the system-prompt template together. Each block in -- @blueprint-prompt.md@ has a @{{key}}@ placeholder filled here. -renderSystemPrompt :: AgentContext -> Blueprint -> BaselineStatus -> Maybe FilePath -> Text -> Text -renderSystemPrompt ctx bp baseline mFilesDir userPrompt = - substitute - [ ("cwd", ctx.cwd), - ("seihou_project_state", formatSeihouProjectState ctx), - ("manifest_state", formatManifestState ctx), - ("module_dhall_state", formatModuleDhallState ctx), - ("local_modules", formatLocalModules ctx), - ("available_modules", formatAvailableModules ctx), - ("blueprint_name", bp.name.unModuleName), - ("blueprint_version", fromMaybe "(unspecified)" bp.version), - ("blueprint_description", fromMaybe "(no description)" bp.description), - ("baseline_status", formatBaselineStatus baseline), - ("reference_files", formatReferenceFiles bp.files), - ("reference_files_dir", formatReferenceFilesDir mFilesDir), - ("user_prompt", userPrompt) - ] - promptTemplate - --- | Substitute resolved blueprint variables into the user prompt body. -renderUserPrompt :: Map VarName ResolvedVar -> Text -> Text -renderUserPrompt resolved tpl = - substitute - [(vn.unVarName, varValueToText rv.value) | (vn, rv) <- Map.toList resolved] - tpl - --- | Local copy of @Seihou.CLI.Run.varValueToText@. Kept in sync with the --- original; if a third caller appears, lift it into Seihou.CLI.Shared. -varValueToText :: VarValue -> Text -varValueToText (VText t) = t -varValueToText (VBool True) = "true" -varValueToText (VBool False) = "false" -varValueToText (VInt n) = T.pack (show n) -varValueToText (VList vs) = T.intercalate "," (map varValueToText vs) +renderSystemPrompt :: AgentContext -> PreparedBlueprintExecution -> BaselineStatus -> Text +renderSystemPrompt ctx prepared baseline = + let bp = prepared.preparedBlueprint + in substitute + [ ("cwd", ctx.cwd), + ("seihou_project_state", formatSeihouProjectState ctx), + ("manifest_state", formatManifestState ctx), + ("module_dhall_state", formatModuleDhallState ctx), + ("local_modules", formatLocalModules ctx), + ("available_modules", formatAvailableModules ctx), + ("blueprint_name", bp.name.unModuleName), + ("blueprint_version", fromMaybe "(unspecified)" bp.version), + ("blueprint_description", fromMaybe "(no description)" bp.description), + ("baseline_status", formatBaselineStatus baseline), + ("reference_files", prepared.preparedReferenceFiles), + ("reference_files_dir", prepared.preparedReferenceFilesAccess), + ("user_prompt", prepared.preparedSharedPrompt) + ] + promptTemplate -- | Whether an operation targets a file in the given path set. Local -- copy of @Seihou.CLI.Run.opTargetsPath@. diff --git a/src-exe/Seihou/CLI/Browse.hs b/src-exe/Seihou/CLI/Browse.hs --- a/src-exe/Seihou/CLI/Browse.hs +++ b/src-exe/Seihou/CLI/Browse.hs @@ -68,8 +68,8 @@ logIO LogNormal (logError $ "failed to load blueprint: " <> T.pack (show err)) exitFailure Right b -> do - let bpName = case b of Blueprint nm _ _ _ _ _ _ _ _ _ -> nm - bpDesc = case b of Blueprint _ _ d _ _ _ _ _ _ _ -> d + let bpName = case b of Blueprint nm _ _ _ _ _ _ _ _ _ _ -> nm + bpDesc = case b of Blueprint _ _ d _ _ _ _ _ _ _ _ -> d TIO.putStr $ formatBrowseSingleBlueprint source bpName.unModuleName bpDesc SinglePrompt rootDir -> do let dhallFile = rootDir "prompt.dhall" diff --git a/src-exe/Seihou/CLI/Commands.hs b/src-exe/Seihou/CLI/Commands.hs --- a/src-exe/Seihou/CLI/Commands.hs +++ b/src-exe/Seihou/CLI/Commands.hs @@ -1,6 +1,7 @@ module Seihou.CLI.Commands ( Command (..), RunOpts (..), + UpdateOpts (..), RemoveOpts (..), VarsOpts (..), InstallOpts (..), @@ -22,11 +23,13 @@ MigrateOpts (..), SchemaUpgradeOpts (..), AgentOpts (..), + AgentModelsOpts (..), AgentCommand (..), AssistOpts (..), BootstrapOpts (..), SetupOpts (..), BlueprintRunOpts (..), + BlueprintMigrationOpts (..), PromptCommand (..), PromptRunOpts (..), CompletionsCommand (..), @@ -59,6 +62,7 @@ data Command = Init | Run RunOpts + | Update UpdateOpts | Remove RemoveOpts | Vars VarsOpts | Install InstallOpts @@ -102,15 +106,24 @@ { agentDebug :: Bool, agentProvider :: Maybe Text, agentModel :: Maybe Text, + agentEffort :: Maybe Text, agentCommand :: AgentCommand } deriving stock (Eq, Show, Generic) +data AgentModelsOpts = AgentModelsOpts + { modelsProvider :: Maybe Text + } + deriving stock (Eq, Show, Generic) + data AgentCommand = AgentAssist AssistOpts | AgentBootstrap BootstrapOpts | AgentSetup SetupOpts | AgentRun BlueprintRunOpts + | AgentMigrate BlueprintMigrationOpts + | AgentModels AgentModelsOpts + | AgentConfigShow deriving stock (Eq, Show, Generic) data RunOpts = RunOpts @@ -139,6 +152,20 @@ } deriving stock (Eq, Show, Generic) +data UpdateOpts = UpdateOpts + { updateTargets :: [Text], + updateVars :: [(Text, Text)], + updateDryRun :: Bool, + updateJson :: Bool, + updateReconfigure :: Bool, + updateForce :: Bool, + updateRunAllCommands :: Bool, + updateNoCommands :: Bool, + updateCommit :: Bool, + updateCommitMessage :: Maybe Text + } + deriving stock (Eq, Show, Generic) + data RemoveOpts = RemoveOpts { removeModule :: ModuleName, removeDryRun :: Bool, @@ -266,7 +293,7 @@ -- 'Seihou.CLI.Migrate.runMigrate' against the *current project* -- (cwd), if and only if that module is applied locally. Default -- 'False'; the unset path emits a one-line advisory pointing the - -- user at @seihou migrate@ when migrations would be pending. + -- user at @seihou update@ when migrations would be pending. upgradeWithMigrations :: Bool } deriving stock (Eq, Show, Generic) @@ -281,7 +308,8 @@ data AssistOpts = AssistOpts { assistPrompt :: Maybe Text, assistProvider :: Maybe Text, - assistModel :: Maybe Text + assistModel :: Maybe Text, + assistEffort :: Maybe Text } deriving stock (Eq, Show, Generic) @@ -289,14 +317,16 @@ { bootstrapPrompt :: Maybe Text, bootstrapRepo :: Bool, bootstrapProvider :: Maybe Text, - bootstrapModel :: Maybe Text + bootstrapModel :: Maybe Text, + bootstrapEffort :: Maybe Text } deriving stock (Eq, Show, Generic) data SetupOpts = SetupOpts { setupPrompt :: Maybe Text, setupProvider :: Maybe Text, - setupModel :: Maybe Text + setupModel :: Maybe Text, + setupEffort :: Maybe Text } deriving stock (Eq, Show, Generic) @@ -310,10 +340,27 @@ runBlueprintVerbose :: Bool, runBlueprintForce :: Bool, runBlueprintProvider :: Maybe Text, - runBlueprintModel :: Maybe Text + runBlueprintModel :: Maybe Text, + runBlueprintEffort :: Maybe Text } deriving stock (Eq, Show, Generic) +data BlueprintMigrationOpts = BlueprintMigrationOpts + { migrateBlueprintName :: ModuleName, + migrateBlueprintFrom :: Text, + migrateBlueprintTo :: Text, + migrateBlueprintPrompt :: Maybe Text, + migrateBlueprintVars :: [(Text, Text)], + migrateBlueprintNamespace :: Maybe Text, + migrateBlueprintContext :: Maybe Text, + migrateBlueprintVerbose :: Bool, + migrateBlueprintRerun :: Bool, + migrateBlueprintProvider :: Maybe Text, + migrateBlueprintModel :: Maybe Text, + migrateBlueprintEffort :: Maybe Text + } + deriving stock (Eq, Show, Generic) + data PromptCommand = PromptRun PromptRunOpts deriving stock (Eq, Show, Generic) @@ -327,7 +374,8 @@ runPromptVerbose :: Bool, runPromptDebug :: Bool, runPromptProvider :: Maybe Text, - runPromptModel :: Maybe Text + runPromptModel :: Maybe Text, + runPromptEffort :: Maybe Text } deriving stock (Eq, Show, Generic) @@ -356,6 +404,7 @@ vsep [ pretty ("seihou help # list all help topics" :: String), pretty ("seihou help modules # how modules work" :: String), + pretty ("seihou help update # safely update recorded project applications" :: String), pretty ("seihou help migrations # apply author-declared migrations between versions" :: String) ], mempty, @@ -367,6 +416,7 @@ hsubparser ( command "init" initInfo <> command "run" runInfo + <> command "update" updateInfo <> command "remove" removeInfo <> command "status" statusInfo <> command "diff" diffInfo @@ -440,12 +490,13 @@ info (runParser <**> helper) ( fullDesc - <> progDesc "Run modules to generate a project" + <> progDesc "Apply a module initially or reconfigure it explicitly" <> footerDoc ( Just $ vsep - [ pretty ("Loads the specified module and its dependencies, resolves all variables," :: String), - pretty ("compiles a generation plan, and executes it in the current directory." :: String), + [ pretty ("Applies the specified module for the first time, or deliberately" :: String), + pretty ("reconfigures it. Variables are resolved and a generation plan executes" :: String), + pretty ("in the current directory." :: String), line, pretty ("Compose multiple modules with -m/--module (repeatable). Override" :: String), pretty ("variables with --var KEY=VALUE (repeatable). Use --dry-run to preview" :: String), @@ -458,8 +509,9 @@ pretty ("If an applied module's installed copy has advanced past the manifest's" :: String), pretty ("recorded version and ships migrations that move project files," :: String), pretty ("'seihou run' refuses to proceed (so it never writes new templates into" :: String), - pretty ("paths a migration would have moved). Run 'seihou migrate '" :: String), - pretty ("first, or pass --with-migrations to apply pending chains in-band." :: String), + pretty ("paths a migration would have moved). For routine source updates, run" :: String), + pretty ("'seihou update '. Use migrate or --with-migrations for focused" :: String), + pretty ("recovery and explicit reconfiguration." :: String), line, pretty ("Examples:" :: String), indent 2 $ @@ -474,6 +526,33 @@ ) ) +updateInfo :: ParserInfo Command +updateInfo = + info + (updateParser <**> helper) + ( fullDesc + <> progDesc "Update recorded project applications safely" + <> footerDoc + ( Just $ + vsep + [ pretty ("Reconciles recorded module and recipe applications with newer source" :: String), + pretty ("content. Saved inputs are reused, migrations are included automatically," :: String), + pretty ("user edits are three-way merged, and unchanged commands are skipped." :: String), + line, + pretty ("With no TARGET, updates every recorded application in manifest order." :: String), + pretty ("Use --dry-run to preview or --json for a non-interactive machine result." :: String), + pretty ("--force accepts generated conflict content but retains edited orphans." :: String), + line, + indent 2 $ + vsep + [ pretty ("seihou update" :: String), + pretty ("seihou update master-plan --dry-run" :: String), + pretty ("seihou update master-plan --force --commit" :: String) + ] + ] + ) + ) + removeInfo :: ParserInfo Command removeInfo = info @@ -584,7 +663,8 @@ line, pretty ("When an applied module's installed copy has advanced past the manifest's" :: String), pretty ("recorded version, status reports the pending migration count under that" :: String), - pretty ("module's line; run 'seihou migrate ' to apply them." :: String) + pretty ("module's line. Recorded applications recommend 'seihou update ';" :: String), + pretty ("manual 'seihou migrate ' remains available for focused recovery." :: String) ] ) ) @@ -754,6 +834,42 @@ <> help "Apply any pending module migrations before the run plan; without this, 'seihou run' refuses when migrations are pending" ) +updateParser :: Parser Command +updateParser = + fmap Update $ + makeUpdateOpts + <$> many (argument (T.pack <$> str) (metavar "TARGET" <> help "Recorded application target or contained module (repeatable; default: all)")) + <*> many + ( option + varPair + (long "var" <> metavar "KEY=VALUE" <> help "Variable override (repeatable)") + ) + <*> switch (long "dry-run" <> help "Show the complete update plan without modifying managed state") + <*> switch (long "json" <> help "Emit one JSON document and disable prompts") + <*> switch (long "reconfigure" <> help "Ignore saved inputs and resolve them again") + <*> switch (long "force" <> help "Use generated content for safe conflicts and retain edited orphans") + <*> updateCommandFlags + <*> switch (long "commit" <> help "Commit successfully updated managed paths") + <*> optional (option (T.pack <$> str) (long "commit-message" <> metavar "MSG" <> help "Custom commit message (implies --commit)")) + where + makeUpdateOpts targets vars dryRun json reconfigure force (runAll, noCommands) commit commitMessage = + UpdateOpts + { updateTargets = targets, + updateVars = vars, + updateDryRun = dryRun, + updateJson = json, + updateReconfigure = reconfigure, + updateForce = force, + updateRunAllCommands = runAll, + updateNoCommands = noCommands, + updateCommit = commit, + updateCommitMessage = commitMessage + } + updateCommandFlags = + flag' (True, False) (long "run-all-commands" <> help "Run every generated command, including unchanged ones") + <|> flag' (False, True) (long "no-commands" <> help "Skip every generated command") + <|> pure (False, False) + varsParser :: Parser Command varsParser = fmap Vars $ @@ -1066,10 +1182,9 @@ pretty ("Example:" :: String), indent 2 $ pretty ("seihou outdated" :: String), line, - pretty ("Run 'seihou upgrade' to apply available updates. If a module ships" :: String), - pretty ("migrations, 'seihou upgrade' will surface them via an advisory; run" :: String), - pretty ("'seihou migrate ' (or 'seihou upgrade --with-migrations')" :: String), - pretty ("to apply them to the current project." :: String) + pretty ("Run 'seihou update' in an applied project to fetch and reconcile" :: String), + pretty ("available versions. Use 'seihou upgrade' only to refresh the shared" :: String), + pretty ("installed cache, or 'seihou migrate ' for focused recovery." :: String) ] ) ) @@ -1085,7 +1200,7 @@ info (upgradeParser <**> helper) ( fullDesc - <> progDesc "Upgrade installed modules to latest versions" + <> progDesc "Refresh shared installed-cache sources only" <> footerDoc (Just upgradeFooter) ) @@ -1105,8 +1220,9 @@ upgradeFooter :: Doc upgradeFooter = vsep - [ pretty ("Upgrades installed modules to the latest version available from their" :: String), + [ 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 ("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, @@ -1128,7 +1244,7 @@ vsep [ pretty ("Newer module versions may declare migrations that move project files" :: String), pretty ("when applied. By default 'seihou upgrade' does not run them — it only" :: String), - pretty ("prints an advisory pointing at 'seihou migrate '. Pass" :: String), + pretty ("prints an advisory pointing project users at 'seihou update'. Pass" :: String), pretty ("--with-migrations to run them as part of the upgrade." :: String) ] ] @@ -1372,6 +1488,7 @@ [ pretty ("Agent subcommands provide AI-assisted workflows powered by" :: String), pretty ("configurable CLI or API providers. Use --provider to select claude-cli, codex-cli," :: String), pretty ("anthropic, or openai, and --model for a provider-specific model." :: String), + pretty ("Run 'seihou agent models' to list known model choices." :: String), line, pretty ("Use --debug with any subcommand to print the resolved system" :: String), pretty ("prompt without contacting the configured provider." :: String), @@ -1382,7 +1499,9 @@ [ pretty ("assist AI-assisted template authoring prompt" :: String), pretty ("bootstrap Bootstrap a new module or multi-module repo" :: String), pretty ("setup Guided project setup: configure, run, and commit" :: String), - pretty ("run Run an agent-driven blueprint" :: String) + pretty ("run Run an agent-driven blueprint" :: String), + pretty ("migrate Run ordered library-upgrade blueprint migrations" :: String), + pretty ("models List known agent models" :: String) ] ] ) @@ -1406,9 +1525,10 @@ (T.pack <$> str) ( long "model" <> metavar "MODEL" - <> help "Agent model name or provider-specific model alias" + <> help "Agent model name or provider-specific alias; 'seihou agent models' lists known choices" ) ) + <*> effortOption <*> agentCommandParser agentCommandParser :: Parser AgentCommand @@ -1418,6 +1538,9 @@ <> command "bootstrap" agentBootstrapInfo <> command "setup" agentSetupInfo <> command "run" agentRunInfo + <> command "migrate" agentMigrateInfo + <> command "models" agentModelsInfo + <> command "config" agentConfigInfo ) agentAssistInfo :: ParserInfo AgentCommand @@ -1457,6 +1580,7 @@ <$> optional (argument (T.pack <$> str) (metavar "PROMPT" <> help "Initial prompt describing what you want to do")) <*> providerOption <*> modelOption + <*> effortOption agentBootstrapInfo :: ParserInfo AgentCommand agentBootstrapInfo = @@ -1494,6 +1618,7 @@ <*> switch (long "repo" <> help "Bootstrap a multi-module repository with registry") <*> providerOption <*> modelOption + <*> effortOption agentSetupInfo :: ParserInfo AgentCommand agentSetupInfo = @@ -1530,6 +1655,7 @@ <$> optional (argument (T.pack <$> str) (metavar "PROMPT" <> help "Description of what you want to set up")) <*> providerOption <*> modelOption + <*> effortOption agentRunInfo :: ParserInfo AgentCommand agentRunInfo = @@ -1584,7 +1710,112 @@ <*> switch (long "force" <> help "Auto-resolve baseline conflicts (accept new files)") <*> providerOption <*> modelOption + <*> effortOption +agentMigrateInfo :: ParserInfo AgentCommand +agentMigrateInfo = + info + (agentMigrateParser <**> helper) + ( fullDesc + <> progDesc "Run ordered agent-guided migrations declared by a blueprint" + <> footerDoc + ( Just $ + vsep + [ pretty ("Selects the blueprint migrations inside the explicit version window," :: String), + pretty ("runs one provider interaction per edge, and records each successful" :: String), + pretty ("edge so an interrupted chain resumes without repeating completed work." :: String), + line, + pretty ("Versions must be dotted numeric values. Gaps are allowed. Pass --rerun" :: String), + pretty ("to ignore matching receipts. Parent --debug prints every pending prompt" :: String), + pretty ("without contacting a provider or changing the manifest." :: String), + line, + pretty ("Examples:" :: String), + indent 2 $ + vsep + [ pretty ("seihou agent migrate my-library --from 1.0.0 --to 3.0.0" :: String), + pretty ("seihou agent migrate my-library --from 1 --to 3 --rerun" :: String), + pretty ("seihou agent --debug migrate my-library --from 1.0.0 --to 3.0.0" :: String) + ] + ] + ) + ) + +agentMigrateParser :: Parser AgentCommand +agentMigrateParser = + fmap AgentMigrate $ + BlueprintMigrationOpts + <$> argument moduleNameReader (metavar "BLUEPRINT" <> help "Name of the blueprint containing migrations") + <*> option (T.pack <$> str) (long "from" <> metavar "VERSION" <> help "Currently used library version (dotted numeric)") + <*> option (T.pack <$> str) (long "to" <> metavar "VERSION" <> help "Desired library version (dotted numeric)") + <*> optional (argument (T.pack <$> str) (metavar "PROMPT" <> help "Optional initial user instruction for each migration session")) + <*> many + ( option + varPair + (long "var" <> metavar "KEY=VALUE" <> help "Variable override (repeatable)") + ) + <*> optional (option (T.pack <$> str) (long "namespace" <> metavar "NS" <> help "Override namespace for config lookup")) + <*> optional (option (T.pack <$> str) (long "context" <> short 'c' <> metavar "CTX" <> help "Override context for config lookup")) + <*> switch (long "verbose" <> short 'v' <> help "Show detailed progress messages") + <*> switch (long "rerun" <> help "Run matching migrations even when a receipt already exists") + <*> providerOption + <*> modelOption + <*> effortOption + +agentModelsInfo :: ParserInfo AgentCommand +agentModelsInfo = + info + (agentModelsParser <**> helper) + ( fullDesc + <> progDesc "List known agent models" + <> footerDoc + ( Just $ + vsep + [ pretty ("Lists the Anthropic and OpenAI models in Seihou's compiled Baikai catalog." :: String), + pretty ("Use --provider to filter by an API or compatible local CLI provider." :: String), + line, + pretty ("The catalog is a discovery aid, not validation. Provider-native aliases" :: String), + pretty ("and custom model identifiers remain accepted by --model." :: String), + line, + pretty ("Examples:" :: String), + indent 2 $ + vsep + [ pretty ("seihou agent models" :: String), + pretty ("seihou agent models --provider openai" :: String), + pretty ("seihou agent --provider claude-cli models" :: String) + ] + ] + ) + ) + +agentModelsParser :: Parser AgentCommand +agentModelsParser = + AgentModels . AgentModelsOpts <$> providerOption + +agentConfigInfo :: ParserInfo AgentCommand +agentConfigInfo = + info + (pure AgentConfigShow <**> helper) + ( fullDesc + <> progDesc "Show the resolved provider and model for each agent command" + <> footerDoc + ( Just $ + vsep + [ pretty ("Prints the provider and model that each agent command resolves to," :: String), + pretty ("labelling the source of every value: a config scope and key, an" :: String), + pretty ("environment variable, or the built-in default. Read-only; set values" :: String), + pretty ("with `seihou config set agent..model ...`." :: String), + line, + pretty ("Examples:" :: String), + indent 2 $ + vsep + [ pretty ("seihou agent config" :: String), + pretty ("seihou config set agent.assist.model gpt-5-mini --global" :: String), + pretty ("seihou config set agent.run.model claude-opus-4-8" :: String) + ] + ] + ) + ) + promptInfo :: ParserInfo Command promptInfo = info @@ -1664,6 +1895,7 @@ <*> switch (long "debug" <> help "Print the rendered prompt and exit") <*> providerOption <*> modelOption + <*> effortOption helpCmdInfo :: ParserInfo Command helpCmdInfo = @@ -1778,5 +2010,15 @@ (T.pack <$> str) ( long "model" <> metavar "MODEL" - <> help "Agent model name or provider-specific model alias" + <> help "Agent model name or provider-specific alias; 'seihou agent models' lists known choices" + ) + +effortOption :: Parser (Maybe Text) +effortOption = + optional $ + option + (T.pack <$> str) + ( long "effort" + <> metavar "LEVEL" + <> help "Reasoning effort: minimal, low, medium, high, xhigh, or max" ) diff --git a/src-exe/Seihou/CLI/Help.hs b/src-exe/Seihou/CLI/Help.hs --- a/src-exe/Seihou/CLI/Help.hs +++ b/src-exe/Seihou/CLI/Help.hs @@ -38,7 +38,8 @@ HelpTopic "kit" "Manage Claude Code and Codex skills and subagents" kitContent, HelpTopic "migrations" "Migrating a project between module versions" migrationsContent, HelpTopic "prompts" "Reusable agent-session prompt artifacts" promptsContent, - HelpTopic "templating" "Placeholder substitution, {{#if}} blocks, and patterns" templatingContent + HelpTopic "templating" "Placeholder substitution, {{#if}} blocks, and patterns" templatingContent, + HelpTopic "update" "Safely update recorded project applications" updateContent ] agentContent :: Text @@ -73,6 +74,9 @@ templatingContent :: Text templatingContent = $(embedStringFile "help/templating.md") + +updateContent :: Text +updateContent = $(embedStringFile "help/update.md") helpCommandParser :: Parser HelpCommand helpCommandParser = diff --git a/src-exe/Seihou/CLI/Install.hs b/src-exe/Seihou/CLI/Install.hs --- a/src-exe/Seihou/CLI/Install.hs +++ b/src-exe/Seihou/CLI/Install.hs @@ -229,7 +229,7 @@ Right _ -> pure () TIO.putStrLn " Validated blueprint definition" - let bpVersion = case bp of Blueprint _ v _ _ _ _ _ _ _ _ -> v + let bpVersion = case bp of Blueprint _ v _ _ _ _ _ _ _ _ _ -> v installModuleDir rootDir name source Nothing bpVersion [] TIO.putStrLn "" TIO.putStrLn $ "Blueprint available as: " <> T.pack name @@ -458,7 +458,7 @@ logError $ " failed to load " <> entry.name.unModuleName <> ": " <> T.pack (show err) pure False Right bp -> do - let bpVersion = case bp of Blueprint _ v _ _ _ _ _ _ _ _ -> v + let bpVersion = case bp of Blueprint _ v _ _ _ _ _ _ _ _ _ -> v ver = entry.version <|> bpVersion installModuleDir entryDir name source (Just repoName) ver entry.tags TIO.putStrLn $ " Installed blueprint as: " <> T.pack name diff --git a/src-exe/Seihou/CLI/Run.hs b/src-exe/Seihou/CLI/Run.hs --- a/src-exe/Seihou/CLI/Run.hs +++ b/src-exe/Seihou/CLI/Run.hs @@ -3,7 +3,8 @@ ) where -import Control.Monad (foldM, unless, when) +import Control.Exception (IOException, displayException, try) +import Control.Monad (foldM, forM_, unless, when) import Data.Map.Strict qualified as Map import Data.Maybe (fromMaybe, isJust) import Data.Set qualified as Set @@ -11,6 +12,16 @@ import Data.Text.IO qualified as TIO import Data.Time (UTCTime) import Data.Time.Clock (getCurrentTime) +import Seihou.CLI.CommandExecution + ( CommandDisposition (..), + CommandExecutionError (..), + CommandPlan (..), + CommandPolicy (..), + PlannedCommand (..), + executeCommandPlanWithOutput, + finalizeCommandReceipts, + planCommands, + ) import Seihou.CLI.Commands (RunOpts (..)) import Seihou.CLI.CommitMessage (generateCommitMessage) import Seihou.CLI.Git (gitAdd, gitCheckIgnore, gitCommit, gitDiffCached, isGitRepo) @@ -31,12 +42,15 @@ import Seihou.Composition.Plan (compileComposedPlan) import Seihou.Composition.Recipe (expandRecipe) import Seihou.Composition.Resolve (loadComposition, resolveWithPrompts) +import Seihou.Core.Application (attachApplication, buildAppliedComposition, mkApplicationId, replaceAppliedComposition) import Seihou.Core.Context (resolveContext) import Seihou.Core.Migration (MigrationPlan (..)) import Seihou.Core.Module (defaultSearchPaths, discoverRunnable) import Seihou.Core.Types import Seihou.Core.Variable (diagnoseResolution) import Seihou.Core.Version (renderVersion) +import Seihou.Effect.BaselineStore (pruneBaselines) +import Seihou.Effect.BaselineStoreInterp (runBaselineStore) import Seihou.Effect.ConfigReader (readContextConfig, readGlobalConfig, readLocalConfig, readNamespaceConfig) import Seihou.Effect.ConfigReaderInterp (runConfigReader) import Seihou.Effect.ConfigWriterInterp (runConfigWriter) @@ -47,8 +61,8 @@ import Seihou.Effect.Logger (logDebug, logError, logInfo, logWarn) import Seihou.Effect.ManifestStore (readManifest, writeManifest) import Seihou.Effect.ManifestStoreInterp (runManifestStore) -import Seihou.Effect.Process (runProcess) import Seihou.Effect.ProcessInterp (runProcessIO) +import Seihou.Engine.Baseline (manifestBaselineRefs, recordGeneratedBaselines) import Seihou.Engine.Conflict (resolveConflicts) import Seihou.Engine.Diff (computeDiff) import Seihou.Engine.Execute (executePlan) @@ -91,10 +105,10 @@ -- 0b. Recipe detection: check if the name resolves to a recipe or a module searchPaths <- defaultSearchPaths - (primaryName, allAdditional, recipeOverrides, recipeInfo) <- do + (primaryName, allAdditional, recipeOverrides, recipeInfo, targetInfo) <- do runnableResult <- discoverRunnable searchPaths modName case runnableResult of - Right (RunnableRecipe recipe _recipeDir) -> do + Right (RunnableRecipe recipe recipeDir) -> do case expandRecipe recipe of Left errs -> do logIO level $ @@ -108,9 +122,21 @@ logIO level $ logInfo $ "Recipe '" <> recipe.name.unRecipeName <> "' expanding to " <> T.pack (show (length recipe.modules)) <> " modules" - pure (primary, recipeAdditional ++ additional, overrides, Just (recipe.name, recipe.version)) - Right (RunnableModule _ _) -> - pure (modName, additional, Map.empty, Nothing) + pure + ( primary, + recipeAdditional ++ additional, + overrides, + Just (recipe.name, recipe.version), + (AppliedRecipeTarget recipe.name, recipeDir, recipe.version) + ) + Right (RunnableModule modul moduleDir) -> + pure + ( modName, + additional, + Map.empty, + Nothing, + (AppliedModuleTarget modName, moduleDir, modul.version) + ) Right (RunnableBlueprint _b _blueprintDir) -> do -- Use the user-typed name (modName) rather than the blueprint's -- declared name. Discovery resolves by directory name; the @@ -120,7 +146,13 @@ exitFailure Left _ -> -- Discovery failed — let loadComposition handle the error with its detailed message - pure (modName, additional, Map.empty, Nothing) + pure + ( modName, + additional, + Map.empty, + Nothing, + (AppliedModuleTarget modName, "", Nothing) + ) -- 1. Load all modules in the composition (primary + additional + transitive deps) compositionResult <- loadComposition searchPaths primaryName allAdditional @@ -214,6 +246,7 @@ -- 6. Compute diff (shared by dry-run, --diff, and execution paths) now <- getCurrentTime let manifestPath = ".seihou" "manifest.json" + baselineDir = ".seihou" "baselines" planned = [(dest, content, modName, Nothing) | WriteFileOp dest content _ <- opsFiltered] ++ [(dest, content, mName, Just pOp) | PatchFileOp dest content pOp _ mName <- opsFiltered] @@ -240,6 +273,26 @@ manifest <- handlePendingMigrations level runOpts manifestPath initialManifest pendings + -- Commands are planned against the previously accepted receipts for this + -- exact top-level application. Ordinary run deliberately remains run-all; + -- --no-commands disables execution while retaining matching old receipts. + let (appliedTarget, targetSource, targetVersion) = targetInfo + currentApplicationId = mkApplicationId appliedTarget additional + priorCommandReceipts = + case [ application.commandReceipts + | application <- manifest.applications, + application.applicationId == currentApplicationId + ] of + receipts : _ -> receipts + [] -> Map.empty + commandPolicy = + if runOpts.runNoCommands + then DisableCommands + else RunAllCommands + commandPlan = planCommands commandPolicy priorCommandReceipts ops + candidateCommandReceipts = + finalizeCommandReceipts commandPlan [] priorCommandReceipts + -- 6c. Compute the diff against the (possibly post-migration) manifest. diff <- runEff $ runFilesystem $ runManifestStore manifestPath $ do -- Diff needs every name that could own a manifest file. Each @@ -301,7 +354,9 @@ { hash = c.diskHash, moduleName = c.moduleName, strategy = Template, - generatedAt = now + generatedAt = now, + baseline = Nothing, + applicationIds = mempty } ) | (c, KeepCurrent) <- conflictResolved @@ -310,34 +365,93 @@ excludePaths = Set.fromList (Map.keys keepRecords ++ skipPaths) opsForExec = filter (not . opTargetsPath excludePaths) opsFiltered - -- Execute the plan (excluding kept/skipped files) - runEff $ runFilesystem $ runManifestStore manifestPath $ do - recs <- executePlan "" opsForExec ownerMap modName now + -- Execute the plan (excluding kept/skipped files), capture the + -- exact post-execution baselines, and only then publish the + -- manifest that references those blobs. + generationAttempt <- + try @IOException $ + runEff $ + runFilesystem $ + runBaselineStore baselineDir $ + runManifestStore manifestPath $ do + recs <- executePlan "" opsForExec ownerMap modName now + baselineResult <- recordGeneratedBaselines "" recs + case baselineResult of + Left err -> pure (Left err) + Right baselineRecords -> do + -- Build updated manifest with all composed modules. + let orphanedPaths = map (.path) diff.orphaned + cleanedFiles = foldr Map.delete manifest.files orphanedPaths + allModuleEntries = updateAllModules manifest.modules modulesInOrder now + allResolvedVals = + Map.unions + [Map.map (.value) vs | vs <- Map.elems resolved] + appliedRecipe = case recipeInfo of + Just (rName, rVersion) -> + Just AppliedRecipe {name = rName, recipeVersion = rVersion, appliedAt = now} + Nothing -> manifest.recipe + appliedCompositionWithoutReceipts = + buildAppliedComposition + appliedTarget + targetSource + targetVersion + additional + (Just namespace) + context + modulesInOrder + resolved + now + appliedComposition = + appliedCompositionWithoutReceipts + { commandReceipts = candidateCommandReceipts + } + applicationDestinations = + Set.fromList [path | Just path <- map operationDestination opsFiltered] + combinedFiles = Map.unions [baselineRecords, keepRecords, cleanedFiles] + ownedFiles = + Map.mapWithKey + ( \path record -> + if Set.member path applicationDestinations + then attachApplication appliedComposition.applicationId (Map.lookup path manifest.files) record + else record + ) + combinedFiles + newManifest = + Manifest + { version = currentManifestVersion, + genAt = now, + modules = allModuleEntries, + vars = Map.union (Map.map varValueToText allResolvedVals) manifest.vars, + files = ownedFiles, + applications = replaceAppliedComposition appliedComposition manifest.applications, + recipe = appliedRecipe, + blueprint = manifest.blueprint, + blueprintMigrations = manifest.blueprintMigrations + } + writeManifest newManifest + pure (Right newManifest) - -- Build updated manifest with all composed modules - let orphanedPaths = map (.path) diff.orphaned - cleanedFiles = foldr Map.delete manifest.files orphanedPaths - allModuleEntries = updateAllModules manifest.modules modulesInOrder now - allResolvedVals = - Map.unions - [Map.map (.value) vs | vs <- Map.elems resolved] - appliedRecipe = case recipeInfo of - Just (rName, rVersion) -> - Just AppliedRecipe {name = rName, recipeVersion = rVersion, appliedAt = now} - Nothing -> manifest.recipe - newManifest = - Manifest - { version = currentManifestVersion, - genAt = now, - modules = allModuleEntries, - vars = Map.union (Map.map varValueToText allResolvedVals) manifest.vars, - files = Map.unions [recs, keepRecords, cleanedFiles], - recipe = appliedRecipe, - blueprint = manifest.blueprint - } + newManifest <- case generationAttempt of + Left err -> do + logIO level $ logError $ "Error applying files or storing generated baselines: " <> T.pack (displayException err) + exitFailure + Right (Left err) -> do + logIO level $ logError $ "Error storing generated baselines: " <> T.pack (show err) + exitFailure + Right (Right saved) -> pure saved - -- Save manifest - writeManifest newManifest + -- Pruning is safe only after the new manifest is durable. A + -- pruning failure cannot invalidate the successful generation. + pruneAttempt <- + try @IOException $ + runEff $ + runFilesystem $ + runBaselineStore baselineDir $ + pruneBaselines (manifestBaselineRefs newManifest) + case pruneAttempt of + Left err -> + logIO level $ logWarn $ "Warning: could not prune generated baselines: " <> T.pack (displayException err) + Right _ -> pure () -- Report results let nNew = length diff.new @@ -351,12 +465,60 @@ <> T.pack (show nUnch) <> " unchanged." + -- Execute commands after file generation. The command library + -- returns candidate receipts only when the entire phase + -- succeeds, so a failed run leaves the candidate manifest with + -- no newly-minted success evidence. + forM_ commandPlan.commands $ \planned -> + when (planned.disposition == CommandWillRun) $ + logIO level (logDebug $ " run " <> plannedCommandText planned) + commandResult <- + runEff $ + runProcessIO $ + executeCommandPlanWithOutput + now + ( \_ commandStdout _ -> + when (not (T.null commandStdout)) (liftIO $ TIO.putStr commandStdout) + ) + commandPlan + completedReceipts <- case commandResult of + Right receipts -> pure receipts + Left commandError -> do + when (not (T.null commandError.stdout)) $ TIO.putStr commandError.stdout + when (not (T.null commandError.stderr)) $ TIO.putStr commandError.stderr + logIO level $ + logError $ + "Command failed (exit " + <> T.pack (show commandError.exitCode) + <> "): " + <> plannedCommandText commandError.command + exitFailure + + let finalCommandReceipts = + finalizeCommandReceipts commandPlan completedReceipts priorCommandReceipts + receiptManifest = + setApplicationCommandReceipts + currentApplicationId + finalCommandReceipts + newManifest + receiptWriteAttempt <- + try @IOException $ + runEff $ + runFilesystem $ + runManifestStore manifestPath $ + writeManifest receiptManifest + case receiptWriteAttempt of + Left err -> do + logIO level $ logError $ "Commands succeeded but their receipts could not be recorded: " <> T.pack (displayException err) + exitFailure + Right () -> pure () + -- Commit generated files if --commit or --commit-message when (runOpts.runCommit || isJust runOpts.runCommitMessage) $ do let filesToStage = map (.path) diff.new ++ map (.path) diff.modified - ++ [manifestPath] + ++ [manifestPath, baselineDir] inGit <- runEff $ runProcessIO $ isGitRepo if inGit then do @@ -381,10 +543,6 @@ else logIO level (logDebug "--commit: not inside a git repository, skipping.") - -- Execute commands after file generation - let commandOps = [(cmd, wd) | RunCommandOp cmd wd <- opsForExec] - mapM_ (executeCommand level) commandOps - -- Offer to save prompted values to local config let prompted = collectPromptedValues resolved localMap when (not (null prompted)) $ @@ -454,7 +612,7 @@ -- | Whether an operation is a command (RunCommandOp). isCommandOp :: Operation -> Bool -isCommandOp (RunCommandOp _ _) = True +isCommandOp RunCommandOp {} = True isCommandOp _ = False -- | Check whether an operation targets a file in the given path set. @@ -463,18 +621,32 @@ opTargetsPath paths (PatchFileOp dest _ _ _ _) = Set.member dest paths opTargetsPath _ _ = False --- | Execute a shell command via @sh -c@, printing output and halting on failure. -executeCommand :: LogLevel -> (Text, Maybe FilePath) -> IO () -executeCommand level (cmd, workDir) = do - logIO level (logDebug $ " run " <> cmd) - (exitCode, cmdOut, cmdErr) <- runEff $ runProcessIO $ runProcess "sh" ["-c", cmd] workDir - when (not (T.null cmdOut)) $ TIO.putStr cmdOut - case exitCode of - ExitSuccess -> pure () - ExitFailure code -> do - when (not (T.null cmdErr)) $ TIO.putStr cmdErr - logIO level (logError $ "Command failed (exit " <> T.pack (show code) <> "): " <> cmd) - exitFailure +-- | Return the tracked destination produced by a file operation. +operationDestination :: Operation -> Maybe FilePath +operationDestination (WriteFileOp dest _ _) = Just dest +operationDestination (CopyFileOp _ dest) = Just dest +operationDestination (PatchFileOp dest _ _ _ _) = Just dest +operationDestination _ = Nothing + +plannedCommandText :: PlannedCommand -> Text +plannedCommandText planned = case planned.operation of + RunCommandOp {command} -> command + _ -> "" + +setApplicationCommandReceipts :: + ApplicationId -> + Map CommandFingerprint CommandReceipt -> + Manifest -> + Manifest +setApplicationCommandReceipts applicationId receipts manifest = + manifest + { applications = map updateApplication manifest.applications + } + where + updateApplication application + | application.applicationId == applicationId = + application {commandReceipts = receipts} + | otherwise = application -- | Apply the pending-migration policy. -- diff --git a/src-exe/Seihou/CLI/Update.hs b/src-exe/Seihou/CLI/Update.hs new file mode 100644 --- /dev/null +++ b/src-exe/Seihou/CLI/Update.hs @@ -0,0 +1,203 @@ +module Seihou.CLI.Update + ( handleUpdate, + ) +where + +import Control.Monad (unless, when) +import Data.Aeson (encode, object, (.=)) +import Data.ByteString.Lazy.Char8 qualified as LBS +import Data.Maybe (isJust) +import Data.Set qualified as Set +import Data.Text qualified as T +import Data.Text.IO qualified as TIO +import Seihou.CLI.CommandExecution (CommandPolicy (..)) +import Seihou.CLI.Commands (UpdateOpts (..)) +import Seihou.CLI.CommitMessage (generateCommitMessage) +import Seihou.CLI.Git (gitAdd, gitCheckIgnore, gitCommit, gitDiffCached, isGitRepo) +import Seihou.CLI.Style (useColor) +import Seihou.CLI.Update.Interaction + ( InteractionError (..), + InteractionMode (..), + forceResolveUpdatePlan, + resolveInteractively, + ) +import Seihou.CLI.Update.Render + ( encodeUpdateOutput, + errorOutput, + planOutput, + renderUpdateHuman, + resultOutput, + ) +import Seihou.Core.Types (ModuleName (..)) +import Seihou.Effect.ProcessInterp (runProcessIO) +import Seihou.Prelude +import System.Exit (ExitCode (..), exitFailure) +import System.FilePath (isAbsolute) +import System.IO (hFlush, hIsTerminalDevice, isEOF, stderr, stdin) +import "seihou-cli" Seihou.CLI.Update qualified as Service + +handleUpdate :: UpdateOpts -> IO () +handleUpdate opts = do + validateOptions opts + terminal <- hIsTerminalDevice stdin + let request = requestFromOptions terminal opts + Service.withProjectUpdate request (handlePlanned terminal opts) + +validateOptions :: UpdateOpts -> IO () +validateOptions opts + | opts.updateDryRun && (opts.updateCommit || isJust opts.updateCommitMessage) = + failCli opts "invalid_options" "--commit and --commit-message cannot be used with --dry-run" + | opts.updateRunAllCommands && opts.updateNoCommands = + failCli opts "invalid_options" "--run-all-commands and --no-commands are mutually exclusive" + | otherwise = pure () + +requestFromOptions :: Bool -> UpdateOpts -> Service.UpdateRequest +requestFromOptions terminal opts = + Service.UpdateRequest + { selection = + if null opts.updateTargets + then Service.AllRecordedApplications + else Service.NamedUpdateTargets opts.updateTargets, + varOverrides = opts.updateVars, + reconfigure = opts.updateReconfigure, + promptPolicy = + if terminal && not opts.updateJson + then Service.AllowPrompts + else Service.ForbidPrompts, + commandPolicy = + if opts.updateRunAllCommands + then RunAllCommands + else if opts.updateNoCommands then DisableCommands else RunChangedCommands, + dryRun = opts.updateDryRun + } + +handlePlanned :: Bool -> UpdateOpts -> Either Service.UpdateError Service.UpdatePlan -> IO () +handlePlanned _ opts (Left err) = do + if opts.updateJson + then LBS.putStrLn (encodeUpdateOutput (errorOutput err)) + else TIO.hPutStr stderr (renderUpdateHuman False (errorOutput err)) + exitFailure +handlePlanned terminal opts (Right originalPlan) = do + forced <- + if opts.updateForce + then either (failInteraction opts) pure (forceResolveUpdatePlan originalPlan) + else pure originalPlan + resolved <- + resolveInteractively + (if terminal && not opts.updateJson then Interactive else NonInteractive) + forced + >>= either (failInteraction opts) pure + color <- useColor + if Service.isUpdateNoOp resolved + then + if opts.updateJson + then LBS.putStrLn (encodeUpdateOutput (planOutput resolved)) + else TIO.putStrLn "Already up to date." + else + if opts.updateDryRun + then emitPlan color opts resolved + else do + unless opts.updateJson $ TIO.putStr (renderUpdateHuman color (planOutput resolved)) + accepted <- if opts.updateJson then pure True else confirmApply terminal + if not accepted + then TIO.hPutStrLn stderr "Update cancelled; no managed state was changed." + else do + applied <- Service.applyProjectUpdate resolved + case applied of + Left err -> handlePlanned terminal opts (Left err) + Right result -> do + if opts.updateJson + then LBS.putStrLn (encodeUpdateOutput (resultOutput result)) + else TIO.putStr (renderUpdateHuman color (resultOutput result)) + when (opts.updateCommit || isJust opts.updateCommitMessage) $ do + committed <- commitUpdate opts result + case committed of + Left err -> do + TIO.hPutStrLn stderr ("Update succeeded, but git commit failed: " <> err) + exitFailure + Right () -> pure () + +emitPlan :: Bool -> UpdateOpts -> Service.UpdatePlan -> IO () +emitPlan color opts plan = + if opts.updateJson + then LBS.putStrLn (encodeUpdateOutput (planOutput plan)) + else TIO.putStr (renderUpdateHuman color (planOutput plan)) + +confirmApply :: Bool -> IO Bool +confirmApply False = pure False +confirmApply True = loop + where + loop = do + TIO.hPutStr stderr "Apply? [Y/n] " + hFlush stderr + eof <- isEOF + if eof + then pure False + else do + answer <- T.toLower . T.strip <$> TIO.getLine + case answer of + "" -> pure True + "y" -> pure True + "yes" -> pure True + "n" -> pure False + "no" -> pure False + _ -> do + TIO.hPutStrLn stderr "Please answer yes or no." + loop + +commitUpdate :: UpdateOpts -> Service.UpdateResult -> IO (Either Text ()) +commitUpdate opts result = do + let candidates = filter (not . isAbsolute) (Set.toAscList result.touchedPaths) + inRepo <- runEff $ runProcessIO isGitRepo + if not inRepo + then pure (Right ()) + else do + ignored <- runEff $ runProcessIO $ gitCheckIgnore candidates + let staged = filter (`notElem` ignored) candidates + if null staged + then pure (Right ()) + else do + (addExit, _, addErr) <- runEff $ runProcessIO $ gitAdd staged + case addExit of + ExitFailure _ -> pure (Left (T.strip addErr)) + ExitSuccess -> do + message <- case opts.updateCommitMessage of + Just custom -> pure custom + Nothing -> do + diff <- runEff $ runProcessIO gitDiffCached + let modules = map (ModuleName . (.name)) result.versions + generateCommitMessage modules diff + (commitExit, _, commitErr) <- runEff $ runProcessIO $ gitCommit message + pure $ case commitExit of + ExitSuccess -> Right () + ExitFailure _ -> Left (T.strip commitErr) + +failInteraction :: UpdateOpts -> InteractionError -> IO a +failInteraction opts err = case err of + InteractionRequired paths -> + failCli + opts + "unresolved_conflicts" + ( "Unresolved paths require an interactive terminal or an applicable --force choice: " + <> T.intercalate ", " (map T.pack (Set.toAscList paths)) + ) + InteractionAborted path -> + failCli opts "update_aborted" ("Resolution aborted for " <> T.pack path) + InteractionResolutionFailed inner -> + failCli opts "resolution_failed" (T.pack (show inner)) + InteractionInputFailed message -> + failCli opts "input_failed" message + +failCli :: UpdateOpts -> Text -> Text -> IO a +failCli opts code message = do + if opts.updateJson + then + LBS.putStrLn $ + encode $ + object + [ "schemaVersion" .= (1 :: Int), + "outcome" .= ("error" :: Text), + "error" .= object ["code" .= code, "message" .= message] + ] + else TIO.hPutStrLn stderr ("Update failed [" <> code <> "]: " <> message) + exitFailure diff --git a/src-exe/Seihou/CLI/Upgrade.hs b/src-exe/Seihou/CLI/Upgrade.hs --- a/src-exe/Seihou/CLI/Upgrade.hs +++ b/src-exe/Seihou/CLI/Upgrade.hs @@ -326,9 +326,7 @@ <> renderVersion plan.planFrom <> " → " <> renderVersion plan.planTo - <> "); run 'seihou migrate " - <> name - <> "'" + <> "); run 'seihou update' to reconcile the recorded project application" TIO.putStrLn $ if colorEnabled then yellow msg else msg -- | Run a migration for a single module. Reads the manifest fresh so diff --git a/src/Seihou/CLI/AgentCompletion.hs b/src/Seihou/CLI/AgentCompletion.hs --- a/src/Seihou/CLI/AgentCompletion.hs +++ b/src/Seihou/CLI/AgentCompletion.hs @@ -5,8 +5,11 @@ AgentModelConfig (..), AgentCompletionRequest (..), defaultAgentModelConfig, + defaultModelForProvider, providerFromText, providerToText, + effortFromText, + effortToText, buildAgentCompletionRequest, buildBaikaiModel, runAgentCompletion, @@ -15,10 +18,12 @@ where import Baikai qualified +import Baikai.Options qualified as BaikaiOptions import Baikai.Provider.Claude.Api qualified as ClaudeApi import Baikai.Provider.Claude.Cli qualified as ClaudeCli import Baikai.Provider.OpenAI.Api qualified as OpenAIApi import Baikai.Provider.OpenAI.Cli qualified as CodexCli +import Baikai.ThinkingLevel (ThinkingLevel (..), renderThinkingLevel) import Control.Exception (try) import Data.Text (Text) import Data.Text qualified as Text @@ -33,7 +38,9 @@ data AgentModelConfig = AgentModelConfig { agentProvider :: AgentProvider, - agentModel :: Maybe Text + agentModel :: Maybe Text, + -- | Reasoning effort. 'Nothing' leaves the provider/CLI default alone. + agentEffort :: Maybe ThinkingLevel } deriving stock (Eq, Show) @@ -56,9 +63,44 @@ defaultAgentModelConfig = AgentModelConfig { agentProvider = AgentProviderClaudeCli, - agentModel = Nothing + agentModel = Nothing, + agentEffort = Nothing } +-- | Parse a reasoning-effort level name (case-insensitive) into a Baikai +-- 'ThinkingLevel'. Accepts the six canonical Baikai level names. +effortFromText :: Text -> Either Text ThinkingLevel +effortFromText raw = + case Text.toLower (Text.strip raw) of + "minimal" -> Right ThinkingMinimal + "low" -> Right ThinkingLow + "medium" -> Right ThinkingMedium + "high" -> Right ThinkingHigh + "xhigh" -> Right ThinkingXHigh + "max" -> Right ThinkingMax + other -> + Left $ + "Unknown reasoning effort '" + <> other + <> "'. Expected one of: minimal, low, medium, high, xhigh, max." + +-- | Render a 'ThinkingLevel' to its canonical name (via Baikai). +effortToText :: ThinkingLevel -> Text +effortToText = renderThinkingLevel + +-- | The deterministic default model for a provider when the user has configured +-- none. The two local CLI providers pin a specific model so a @seihou agent@ +-- session never inherits whatever model the ambient @claude@ or @codex@ session +-- happens to have active — that would be non-deterministic and could silently +-- run a token-hungry model another session left selected. The API providers +-- return 'Nothing' here; they already send an explicit model chosen in +-- 'buildBaikaiModel', so they are deterministic without a pinned default. +defaultModelForProvider :: AgentProvider -> Maybe Text +defaultModelForProvider AgentProviderClaudeCli = Just "claude-opus-4-8" +defaultModelForProvider AgentProviderCodexCli = Just "gpt-5.6-terra" +defaultModelForProvider AgentProviderAnthropic = Nothing +defaultModelForProvider AgentProviderOpenAI = Nothing + providerFromText :: Text -> Either Text AgentProvider providerFromText raw = case Text.toLower (Text.strip raw) of @@ -132,7 +174,8 @@ { Baikai.systemPrompt = Just req.completionSystemPrompt, Baikai.messages = initialMessages } - result <- try (Baikai.completeRequest model ctx Baikai.emptyOptions) :: IO (Either Baikai.BaikaiError Baikai.Response) + options = Baikai.emptyOptions {BaikaiOptions.thinking = req.completionModelConfig.agentEffort} + result <- try (Baikai.completeRequest model ctx options) :: IO (Either Baikai.BaikaiError Baikai.Response) pure $ case result of Left err -> Left (Text.pack (show err)) Right resp -> diff --git a/src/Seihou/CLI/AgentConfig.hs b/src/Seihou/CLI/AgentConfig.hs --- a/src/Seihou/CLI/AgentConfig.hs +++ b/src/Seihou/CLI/AgentConfig.hs @@ -1,19 +1,52 @@ module Seihou.CLI.AgentConfig - ( AgentConfigInputs (..), + ( -- * Inputs + AgentConfigInputs (..), + baseAgentConfigInputs, + + -- * Command identity + AgentCommandName (..), + agentCommandSegment, + agentCommandLabel, + allAgentCommands, + + -- * Config keys and environment variables agentProviderConfigKey, agentModelConfigKey, + agentEffortConfigKey, + agentCommandProviderConfigKey, + agentCommandModelConfigKey, + agentCommandEffortConfigKey, agentProviderEnvVar, agentModelEnvVar, + agentEffortEnvVar, + + -- * Provenance + AgentConfigSource (..), + AgentField (..), + ResolvedAgentField (..), + agentConfigSourceLabel, + + -- * Resolution resolveAgentModelConfig, + resolveAgentModelConfigFor, loadAgentModelConfig, + loadAgentModelConfigFor, + + -- * Whole-configuration inspection + ResolvedCommandConfig (..), + loadResolvedAgentConfig, ) where +import Baikai.ThinkingLevel (ThinkingLevel) import Data.Map.Strict qualified as Map import Data.Text qualified as T import Seihou.CLI.AgentCompletion ( AgentModelConfig (..), + AgentProvider (..), defaultAgentModelConfig, + defaultModelForProvider, + effortFromText, providerFromText, ) import Seihou.CLI.Shared (formatConfigError) @@ -22,45 +55,393 @@ import Seihou.Prelude import System.Environment (lookupEnv) +-- | All the raw material provider/model resolution draws on, in one record so +-- the pure resolver can be unit-tested without touching the filesystem or the +-- environment. +-- +-- The two @cli*FromSubcommand@ flags record whether the (already combined) +-- winning CLI flag originated from the subcommand's own @--provider@/@--model@ +-- (as opposed to the parent @seihou agent@ flag). They only affect the +-- provenance label reported for a CLI-sourced value; they never change which +-- value wins. data AgentConfigInputs = AgentConfigInputs { cliProvider :: Maybe Text, cliModel :: Maybe Text, + cliEffort :: Maybe Text, + cliProviderFromSubcommand :: Bool, + cliModelFromSubcommand :: Bool, + cliEffortFromSubcommand :: Bool, envProvider :: Maybe Text, envModel :: Maybe Text, + envEffort :: Maybe Text, localConfig :: Map Text Text, globalConfig :: Map Text Text } deriving stock (Eq, Show) +-- | An 'AgentConfigInputs' with nothing set: no flags, no environment, empty +-- config maps. Handy as a base for tests and for callers that only populate a +-- few fields. +baseAgentConfigInputs :: AgentConfigInputs +baseAgentConfigInputs = + AgentConfigInputs + { cliProvider = Nothing, + cliModel = Nothing, + cliEffort = Nothing, + cliProviderFromSubcommand = False, + cliModelFromSubcommand = False, + cliEffortFromSubcommand = False, + envProvider = Nothing, + envModel = Nothing, + envEffort = Nothing, + localConfig = Map.empty, + globalConfig = Map.empty + } + +-- | The agent-driven commands whose provider/model can be configured +-- independently. Each maps to a config-key segment (see 'agentCommandSegment'). +data AgentCommandName + = AgentCmdAssist + | AgentCmdBootstrap + | AgentCmdSetup + | AgentCmdRun + | AgentCmdMigrate + | AgentCmdPromptRun + deriving stock (Eq, Show, Enum, Bounded) + +-- | The token used inside per-command config keys, e.g. @"assist"@ in +-- @agent.assist.model@. +agentCommandSegment :: AgentCommandName -> Text +agentCommandSegment AgentCmdAssist = "assist" +agentCommandSegment AgentCmdBootstrap = "bootstrap" +agentCommandSegment AgentCmdSetup = "setup" +agentCommandSegment AgentCmdRun = "run" +agentCommandSegment AgentCmdMigrate = "migrate" +agentCommandSegment AgentCmdPromptRun = "prompt-run" + +-- | Human-facing label for display, e.g. @"prompt run"@ for the two-word +-- @seihou prompt run@ command. +agentCommandLabel :: AgentCommandName -> Text +agentCommandLabel AgentCmdPromptRun = "prompt run" +agentCommandLabel c = agentCommandSegment c + +-- | Every configurable agent command, in display order. +allAgentCommands :: [AgentCommandName] +allAgentCommands = [minBound .. maxBound] + +-- | The cross-command default provider key, @agent.provider@. agentProviderConfigKey :: Text agentProviderConfigKey = "agent.provider" +-- | The cross-command default model key, @agent.model@. agentModelConfigKey :: Text agentModelConfigKey = "agent.model" +-- | The cross-command default reasoning-effort key, @agent.effort@. +agentEffortConfigKey :: Text +agentEffortConfigKey = "agent.effort" + +-- | The per-command provider key, e.g. @agent.assist.provider@. +agentCommandProviderConfigKey :: AgentCommandName -> Text +agentCommandProviderConfigKey c = "agent." <> agentCommandSegment c <> ".provider" + +-- | The per-command model key, e.g. @agent.run.model@. +agentCommandModelConfigKey :: AgentCommandName -> Text +agentCommandModelConfigKey c = "agent." <> agentCommandSegment c <> ".model" + +-- | The per-command reasoning-effort key, e.g. @agent.run.effort@. +agentCommandEffortConfigKey :: AgentCommandName -> Text +agentCommandEffortConfigKey c = "agent." <> agentCommandSegment c <> ".effort" + agentProviderEnvVar :: String agentProviderEnvVar = "SEIHOU_AGENT_PROVIDER" agentModelEnvVar :: String agentModelEnvVar = "SEIHOU_AGENT_MODEL" +agentEffortEnvVar :: String +agentEffortEnvVar = "SEIHOU_AGENT_EFFORT" + +-- | Which of the resolvable fields a value belongs to. Used only to build +-- provenance labels. +data AgentField = ProviderField | ModelField | EffortField + deriving stock (Eq, Show) + +-- | Where a resolved value came from, highest precedence first. +data AgentConfigSource + = -- | @--provider@/@--model@ on the subcommand. + SourceCliSubcommand + | -- | @--provider@/@--model@ on @seihou agent@. + SourceCliParent + | -- | @SEIHOU_AGENT_PROVIDER@/@SEIHOU_AGENT_MODEL@. + SourceEnv + | -- | Local @agent..@. + SourceLocalCommand + | -- | Local @agent.@. + SourceLocalDefault + | -- | Global @agent..@. + SourceGlobalCommand + | -- | Global @agent.@. + SourceGlobalDefault + | -- | The hard-coded fallback (provider @claude-cli@, model unset). + SourceBuiltinDefault + deriving stock (Eq, Show) + +-- | A resolved value paired with the source that supplied it. +data ResolvedAgentField a = ResolvedAgentField + { resolvedValue :: a, + resolvedSource :: AgentConfigSource + } + deriving stock (Eq, Show) + +-- | A short human label describing where a value came from, suitable for +-- bracketed display. For config-file sources it names the concrete key that +-- won, e.g. @"local: agent.run.model"@ or @"global: agent.provider"@. +agentConfigSourceLabel :: AgentCommandName -> AgentField -> AgentConfigSource -> Text +agentConfigSourceLabel c field src = + case src of + SourceCliSubcommand -> "flag on subcommand" + SourceCliParent -> "flag on `seihou agent`" + SourceEnv -> "env: " <> T.pack (envVarName field) + SourceLocalCommand -> "local: " <> commandKey field c + SourceLocalDefault -> "local: " <> defaultKey field + SourceGlobalCommand -> "global: " <> commandKey field c + SourceGlobalDefault -> "global: " <> defaultKey field + SourceBuiltinDefault -> "built-in default" + +envVarName :: AgentField -> String +envVarName ProviderField = agentProviderEnvVar +envVarName ModelField = agentModelEnvVar +envVarName EffortField = agentEffortEnvVar + +defaultKey :: AgentField -> Text +defaultKey ProviderField = agentProviderConfigKey +defaultKey ModelField = agentModelConfigKey +defaultKey EffortField = agentEffortConfigKey + +commandKey :: AgentField -> AgentCommandName -> Text +commandKey ProviderField = agentCommandProviderConfigKey +commandKey ModelField = agentCommandModelConfigKey +commandKey EffortField = agentCommandEffortConfigKey + +-- | The full result of resolving one command's provider and model, with +-- provenance, used by the @seihou agent config@ inspection command. +data ResolvedCommandConfig = ResolvedCommandConfig + { rccCommand :: AgentCommandName, + rccProvider :: ResolvedAgentField AgentProvider, + rccModel :: ResolvedAgentField (Maybe Text), + rccEffort :: ResolvedAgentField (Maybe ThinkingLevel) + } + deriving stock (Eq, Show) + +-- | Flat resolver, preserved for backward compatibility. It never consults the +-- per-command config keys, so a caller with only @agent.provider@/@agent.model@ +-- set (or none) gets exactly the historical behavior. resolveAgentModelConfig :: AgentConfigInputs -> Either Text AgentModelConfig resolveAgentModelConfig inputs = do provider <- - maybe - (Right defaultAgentModelConfig.agentProvider) - providerFromText - (firstNonBlank [inputs.cliProvider, inputs.envProvider, configValue inputs.localConfig agentProviderConfigKey, configValue inputs.globalConfig agentProviderConfigKey]) + resolveProvider + [ candidate inputs.cliProvider SourceCliSubcommand, + candidate inputs.envProvider SourceEnv, + candidate (Map.lookup agentProviderConfigKey inputs.localConfig) SourceLocalDefault, + candidate (Map.lookup agentProviderConfigKey inputs.globalConfig) SourceGlobalDefault + ] + let modelField = + applyProviderDefaultModel provider.resolvedValue $ + resolveModel + [ candidate inputs.cliModel SourceCliSubcommand, + candidate inputs.envModel SourceEnv, + candidate (Map.lookup agentModelConfigKey inputs.localConfig) SourceLocalDefault, + candidate (Map.lookup agentModelConfigKey inputs.globalConfig) SourceGlobalDefault + ] pure AgentModelConfig - { agentProvider = provider, - agentModel = firstNonBlank [inputs.cliModel, inputs.envModel, configValue inputs.localConfig agentModelConfigKey, configValue inputs.globalConfig agentModelConfigKey] + { agentProvider = provider.resolvedValue, + agentModel = modelField.resolvedValue, + agentEffort = Nothing } +-- | Resolve the provider, model, and reasoning effort for a specific command, +-- honoring the full precedence chain including the per-command config tiers, and +-- reporting the source of each value. +-- +-- Precedence, highest first: subcommand flag, parent @agent@ flag, environment +-- variable, local @agent..@, local @agent.@, global +-- @agent..@, global @agent.@, built-in default. +resolveAgentModelConfigFor :: + AgentCommandName -> + AgentConfigInputs -> + Either + Text + ( ResolvedAgentField AgentProvider, + ResolvedAgentField (Maybe Text), + ResolvedAgentField (Maybe ThinkingLevel) + ) +resolveAgentModelConfigFor c inputs = do + provider <- + (\p -> ResolvedAgentField p.resolvedValue p.resolvedSource) + <$> resolveProvider (providerCandidates c inputs) + let model = applyProviderDefaultModel provider.resolvedValue (resolveModel (modelCandidates c inputs)) + effort <- resolveEffort (effortCandidates c inputs) + pure (provider, model, effort) + +-- | When no model was configured (source is the built-in default), substitute +-- the provider's deterministic default so the two local CLI providers always +-- resolve to a concrete model instead of 'Nothing'. The source stays +-- 'SourceBuiltinDefault' — the value is a built-in, just a non-empty one. +applyProviderDefaultModel :: AgentProvider -> ResolvedAgentField (Maybe Text) -> ResolvedAgentField (Maybe Text) +applyProviderDefaultModel prov field = + case field.resolvedValue of + Just _ -> field + Nothing -> case defaultModelForProvider prov of + Just m -> field {resolvedValue = Just m} + Nothing -> field + +providerCandidates :: AgentCommandName -> AgentConfigInputs -> [(Maybe Text, AgentConfigSource)] +providerCandidates c inputs = + [ candidate inputs.cliProvider (cliSource inputs.cliProviderFromSubcommand), + candidate inputs.envProvider SourceEnv, + candidate (Map.lookup (agentCommandProviderConfigKey c) inputs.localConfig) SourceLocalCommand, + candidate (Map.lookup agentProviderConfigKey inputs.localConfig) SourceLocalDefault, + candidate (Map.lookup (agentCommandProviderConfigKey c) inputs.globalConfig) SourceGlobalCommand, + candidate (Map.lookup agentProviderConfigKey inputs.globalConfig) SourceGlobalDefault + ] + +modelCandidates :: AgentCommandName -> AgentConfigInputs -> [(Maybe Text, AgentConfigSource)] +modelCandidates c inputs = + [ candidate inputs.cliModel (cliSource inputs.cliModelFromSubcommand), + candidate inputs.envModel SourceEnv, + candidate (Map.lookup (agentCommandModelConfigKey c) inputs.localConfig) SourceLocalCommand, + candidate (Map.lookup agentModelConfigKey inputs.localConfig) SourceLocalDefault, + candidate (Map.lookup (agentCommandModelConfigKey c) inputs.globalConfig) SourceGlobalCommand, + candidate (Map.lookup agentModelConfigKey inputs.globalConfig) SourceGlobalDefault + ] + +effortCandidates :: AgentCommandName -> AgentConfigInputs -> [(Maybe Text, AgentConfigSource)] +effortCandidates c inputs = + [ candidate inputs.cliEffort (cliSource inputs.cliEffortFromSubcommand), + candidate inputs.envEffort SourceEnv, + candidate (Map.lookup (agentCommandEffortConfigKey c) inputs.localConfig) SourceLocalCommand, + candidate (Map.lookup agentEffortConfigKey inputs.localConfig) SourceLocalDefault, + candidate (Map.lookup (agentCommandEffortConfigKey c) inputs.globalConfig) SourceGlobalCommand, + candidate (Map.lookup agentEffortConfigKey inputs.globalConfig) SourceGlobalDefault + ] + +cliSource :: Bool -> AgentConfigSource +cliSource True = SourceCliSubcommand +cliSource False = SourceCliParent + +-- | Resolve a provider from an ordered candidate list, parsing the winning text +-- and falling back to the built-in default provider when nothing is set. +resolveProvider :: [(Maybe Text, AgentConfigSource)] -> Either Text (ResolvedAgentField AgentProvider) +resolveProvider candidates = + case firstNonBlankWithSource candidates of + Just (txt, src) -> (\p -> ResolvedAgentField p src) <$> providerFromText txt + Nothing -> Right (ResolvedAgentField defaultAgentModelConfig.agentProvider SourceBuiltinDefault) + +-- | Resolve a model from an ordered candidate list. An unset model resolves to +-- 'Nothing' with source 'SourceBuiltinDefault', letting the provider pick. +resolveModel :: [(Maybe Text, AgentConfigSource)] -> ResolvedAgentField (Maybe Text) +resolveModel candidates = + case firstNonBlankWithSource candidates of + Just (txt, src) -> ResolvedAgentField (Just txt) src + Nothing -> ResolvedAgentField Nothing SourceBuiltinDefault + +-- | Resolve a reasoning effort from an ordered candidate list. The winning text +-- is parsed with 'effortFromText'; a parse failure returns 'Left'. An unset +-- effort resolves to 'Nothing' with source 'SourceBuiltinDefault', which leaves +-- the provider/CLI default untouched. +resolveEffort :: [(Maybe Text, AgentConfigSource)] -> Either Text (ResolvedAgentField (Maybe ThinkingLevel)) +resolveEffort candidates = + case firstNonBlankWithSource candidates of + Just (txt, src) -> (\lvl -> ResolvedAgentField (Just lvl) src) <$> effortFromText txt + Nothing -> Right (ResolvedAgentField Nothing SourceBuiltinDefault) + +candidate :: Maybe Text -> AgentConfigSource -> (Maybe Text, AgentConfigSource) +candidate value src = (value, src) + +-- | The leftmost candidate whose value is present and non-blank (whitespace is +-- stripped, and @""@ counts as absent), together with its source. +firstNonBlankWithSource :: [(Maybe Text, AgentConfigSource)] -> Maybe (Text, AgentConfigSource) +firstNonBlankWithSource = + foldr step Nothing + where + step (value, src) acc = + case T.strip <$> value of + Just "" -> acc + Just stripped -> Just (stripped, src) + Nothing -> acc + +-- | Read the two environment variables and the local + global config, then run +-- the flat resolver. Preserved for backward compatibility. loadAgentModelConfig :: Maybe Text -> Maybe Text -> IO (Either Text AgentModelConfig) loadAgentModelConfig cliProvider cliModel = do + inputsOrErr <- gatherAgentConfigInputs cliProvider cliModel Nothing False False False + pure (inputsOrErr >>= resolveAgentModelConfig) + +-- | Read the environment and config, then resolve provider/model/effort for a +-- specific command, projecting away the provenance the command handler does not +-- need. +loadAgentModelConfigFor :: + AgentCommandName -> + -- | winning provider flag (subcommand @<|>@ parent) + Maybe Text -> + -- | winning model flag + Maybe Text -> + -- | winning effort flag + Maybe Text -> + -- | provider flag came from the subcommand? + Bool -> + -- | model flag came from the subcommand? + Bool -> + -- | effort flag came from the subcommand? + Bool -> + IO (Either Text AgentModelConfig) +loadAgentModelConfigFor c cliProvider cliModel cliEffort providerFromSub modelFromSub effortFromSub = do + inputsOrErr <- gatherAgentConfigInputs cliProvider cliModel cliEffort providerFromSub modelFromSub effortFromSub + pure $ do + inputs <- inputsOrErr + (provider, model, effort) <- resolveAgentModelConfigFor c inputs + pure + AgentModelConfig + { agentProvider = provider.resolvedValue, + agentModel = model.resolvedValue, + agentEffort = effort.resolvedValue + } + +-- | Resolve every configurable command from the real environment and config, +-- with no CLI flags, for the @seihou agent config@ inspection view. +loadResolvedAgentConfig :: IO (Either Text [ResolvedCommandConfig]) +loadResolvedAgentConfig = do + inputsOrErr <- gatherAgentConfigInputs Nothing Nothing Nothing False False False + pure $ do + inputs <- inputsOrErr + traverse (resolveOne inputs) allAgentCommands + where + resolveOne inputs c = do + (provider, model, effort) <- resolveAgentModelConfigFor c inputs + pure + ResolvedCommandConfig + { rccCommand = c, + rccProvider = provider, + rccModel = model, + rccEffort = effort + } + +-- | Shared IO: read @SEIHOU_AGENT_*@ and the local + global config maps into an +-- 'AgentConfigInputs'. Any config read error surfaces as 'Left'. +gatherAgentConfigInputs :: + Maybe Text -> + Maybe Text -> + Maybe Text -> + Bool -> + Bool -> + Bool -> + IO (Either Text AgentConfigInputs) +gatherAgentConfigInputs cliProvider cliModel cliEffort providerFromSub modelFromSub effortFromSub = do envProvider <- fmap T.pack <$> lookupEnv agentProviderEnvVar envModel <- fmap T.pack <$> lookupEnv agentModelEnvVar + envEffort <- fmap T.pack <$> lookupEnv agentEffortEnvVar (localResult, globalResult) <- runEff $ runConfigReader $ do local <- readLocalConfig global <- readGlobalConfig @@ -68,26 +449,17 @@ pure $ do local <- first formatConfigError localResult global <- first formatConfigError globalResult - resolveAgentModelConfig + pure AgentConfigInputs { cliProvider = cliProvider, cliModel = cliModel, + cliEffort = cliEffort, + cliProviderFromSubcommand = providerFromSub, + cliModelFromSubcommand = modelFromSub, + cliEffortFromSubcommand = effortFromSub, envProvider = envProvider, envModel = envModel, + envEffort = envEffort, localConfig = local, globalConfig = global } - -configValue :: Map Text Text -> Text -> Maybe Text -configValue config key = Map.lookup key config - -firstNonBlank :: [Maybe Text] -> Maybe Text -firstNonBlank = - foldr - ( \candidate acc -> - case T.strip <$> candidate of - Just "" -> acc - Just value -> Just value - Nothing -> acc - ) - Nothing diff --git a/src/Seihou/CLI/AgentConfigShow.hs b/src/Seihou/CLI/AgentConfigShow.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/CLI/AgentConfigShow.hs @@ -0,0 +1,108 @@ +module Seihou.CLI.AgentConfigShow + ( handleAgentConfigShow, + formatResolvedAgentConfig, + ) +where + +import Data.Text qualified as T +import Data.Text.IO qualified as TIO +import Seihou.CLI.AgentCompletion (effortToText, providerToText) +import Seihou.CLI.AgentConfig + ( AgentField (..), + ResolvedAgentField (..), + ResolvedCommandConfig (..), + agentCommandLabel, + agentConfigSourceLabel, + loadResolvedAgentConfig, + ) +import Seihou.Prelude +import System.Exit (exitFailure) + +-- | @seihou agent config@: read the real environment and config, resolve the +-- provider, model, and reasoning effort for every agent command, and print a +-- table labelling the source that supplied each value, followed by the +-- precedence legend. +handleAgentConfigShow :: IO () +handleAgentConfigShow = do + result <- loadResolvedAgentConfig + case result of + Left err -> do + TIO.putStrLn $ "Error: " <> err + exitFailure + Right resolved -> TIO.putStr (formatResolvedAgentConfig resolved) + +-- | Render the resolved per-command configuration as the displayed block. Pure, +-- so it is unit-testable without touching the filesystem. +formatResolvedAgentConfig :: [ResolvedCommandConfig] -> Text +formatResolvedAgentConfig resolved = + T.unlines $ + [ "Resolved agent provider, model, and effort per command", + "(highest-precedence source wins; see precedence list below)", + "" + ] + <> concatMap renderCommand resolved + <> ["", precedenceLegend] + where + labelWidth = maximum (0 : map (\rcc -> T.length (agentCommandLabel rcc.rccCommand)) resolved) + valueWidth = maximum (0 : concatMap commandValueWidths resolved) + + commandValueWidths rcc = + [ T.length (providerValue rcc), + T.length (modelValue rcc), + T.length (effortValue rcc) + ] + + providerValue rcc = providerToText rcc.rccProvider.resolvedValue + modelValue rcc = maybe "(default)" id rcc.rccModel.resolvedValue + effortValue rcc = maybe "(default)" effortToText rcc.rccEffort.resolvedValue + + renderCommand rcc = + let cmd = rcc.rccCommand + label = agentCommandLabel cmd + in [ row + (padRight labelWidth label) + "provider" + (providerValue rcc) + (agentConfigSourceLabel cmd ProviderField rcc.rccProvider.resolvedSource), + row + (padRight labelWidth "") + "model " + (modelValue rcc) + (agentConfigSourceLabel cmd ModelField rcc.rccModel.resolvedSource), + row + (padRight labelWidth "") + "effort " + (effortValue rcc) + (agentConfigSourceLabel cmd EffortField rcc.rccEffort.resolvedSource) + ] + + row label field value sourceLabel = + " " + <> label + <> " " + <> field + <> " " + <> padRight valueWidth value + <> " [" + <> sourceLabel + <> "]" + +padRight :: Int -> Text -> Text +padRight width value = value <> T.replicate (max 0 (width - T.length value)) " " + +precedenceLegend :: Text +precedenceLegend = + T.intercalate + "\n" + [ "Precedence, highest first:", + " 1. --provider / --model / --effort flag on the subcommand", + " 2. --provider / --model / --effort flag on `seihou agent`", + " 3. SEIHOU_AGENT_PROVIDER / SEIHOU_AGENT_MODEL / SEIHOU_AGENT_EFFORT environment variables", + " 4. local .seihou/config.dhall agent..{provider,model,effort}", + " 5. local .seihou/config.dhall agent.{provider,model,effort}", + " 6. global ~/.config/seihou/config.dhall agent..{provider,model,effort}", + " 7. global ~/.config/seihou/config.dhall agent.{provider,model,effort}", + " 8. built-in default: provider claude-cli; model pinned per provider", + " (claude-cli -> claude-opus-4-8, codex-cli -> gpt-5.6-terra); effort unset", + " (the CLI/provider chooses its own reasoning effort)" + ] diff --git a/src/Seihou/CLI/AgentModels.hs b/src/Seihou/CLI/AgentModels.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/CLI/AgentModels.hs @@ -0,0 +1,103 @@ +module Seihou.CLI.AgentModels + ( availableAgentModels, + providersForModel, + filterAgentModels, + formatAgentModels, + ) +where + +import Baikai.Model (Model) +import Baikai.Model qualified as BaikaiModel +import Baikai.Models.Generated qualified as Models +import Data.List (sortOn) +import Data.Text (Text) +import Data.Text qualified as Text +import Seihou.CLI.AgentCompletion + ( AgentProvider (..), + providerToText, + ) + +availableAgentModels :: [Model] +availableAgentModels = + [ Models.anthropic_claude_fable_5, + Models.anthropic_claude_haiku_4_5, + Models.anthropic_claude_opus_4_5, + Models.anthropic_claude_opus_4_6, + Models.anthropic_claude_opus_4_7, + Models.anthropic_claude_opus_4_8, + Models.anthropic_claude_sonnet_4_5, + Models.anthropic_claude_sonnet_4_6, + Models.anthropic_claude_sonnet_5, + Models.openai_gpt_4_1, + Models.openai_gpt_4_1_mini, + Models.openai_gpt_4_1_nano, + Models.openai_gpt_4o, + Models.openai_gpt_4o_mini, + Models.openai_gpt_5, + Models.openai_gpt_5_1, + Models.openai_gpt_5_2, + Models.openai_gpt_5_4, + Models.openai_gpt_5_4_mini, + Models.openai_gpt_5_4_nano, + Models.openai_gpt_5_5, + Models.openai_gpt_5_6, + Models.openai_gpt_5_6_luna, + Models.openai_gpt_5_6_sol, + Models.openai_gpt_5_6_terra, + Models.openai_gpt_5_mini, + Models.openai_gpt_5_nano, + Models.openai_o1, + Models.openai_o3, + Models.openai_o3_mini, + Models.openai_o4_mini + ] + +providersForModel :: Model -> [AgentProvider] +providersForModel model = + case BaikaiModel.provider model of + "anthropic" -> [AgentProviderAnthropic, AgentProviderClaudeCli] + "openai" -> [AgentProviderOpenAI, AgentProviderCodexCli] + _ -> [] + +filterAgentModels :: Maybe AgentProvider -> [Model] -> [Model] +filterAgentModels Nothing = id +filterAgentModels (Just provider) = + filter (elem provider . providersForModel) + +formatAgentModels :: Maybe AgentProvider -> [Model] -> Text +formatAgentModels providerFilter models = + Text.unlines $ + [ "Available agent models:", + "", + formatRow modelWidth nameWidth "MODEL" "NAME" "PROVIDERS" + ] + <> map formatModel sortedModels + <> [ "", + Text.pack (show (length sortedModels)) <> " models found.", + "Provider-specific aliases and custom model IDs remain accepted by --model." + ] + where + sortedModels = + sortOn + (\model -> (BaikaiModel.provider model, BaikaiModel.modelId model)) + (filterAgentModels providerFilter models) + modelWidth = maximum (Text.length "MODEL" : map (Text.length . BaikaiModel.modelId) sortedModels) + nameWidth = maximum (Text.length "NAME" : map (Text.length . BaikaiModel.name) sortedModels) + formatModel model = + formatRow + modelWidth + nameWidth + (BaikaiModel.modelId model) + (BaikaiModel.name model) + (Text.intercalate ", " (map providerToText (providersForModel model))) + +formatRow :: Int -> Int -> Text -> Text -> Text -> Text +formatRow modelWidth nameWidth model name providers = + padRight modelWidth model + <> " " + <> padRight nameWidth name + <> " " + <> providers + +padRight :: Int -> Text -> Text +padRight width value = value <> Text.replicate (width - Text.length value) " " diff --git a/src/Seihou/CLI/AppliedBlueprintMigration.hs b/src/Seihou/CLI/AppliedBlueprintMigration.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/CLI/AppliedBlueprintMigration.hs @@ -0,0 +1,31 @@ +-- | Durable manifest receipts for agent-guided blueprint migrations. +module Seihou.CLI.AppliedBlueprintMigration + ( recordAppliedBlueprintMigration, + ) +where + +import Seihou.Core.Types (AppliedBlueprintMigration (..)) +import Seihou.Effect.Filesystem (createDirectoryIfMissing) +import Seihou.Effect.FilesystemInterp (runFilesystem) +import Seihou.Effect.ManifestStore (readManifest, writeManifest) +import Seihou.Effect.ManifestStoreInterp (runManifestStore) +import Seihou.Manifest.Types (emptyManifest, writeAppliedBlueprintMigration) +import Seihou.Prelude +import System.FilePath (takeDirectory) + +-- | Read or create the project manifest, upsert one exact migration receipt, +-- and write it atomically. A corrupt existing manifest is reported and left +-- untouched rather than being replaced. +recordAppliedBlueprintMigration :: FilePath -> AppliedBlueprintMigration -> IO (Either Text ()) +recordAppliedBlueprintMigration manifestPath receipt = + runEff $ runFilesystem $ runManifestStore manifestPath $ do + createDirectoryIfMissing True (takeDirectory manifestPath) + mManifest <- readManifest + case mManifest of + Right (Just manifest) -> do + writeManifest (writeAppliedBlueprintMigration receipt manifest) + pure (Right ()) + Right Nothing -> do + writeManifest (writeAppliedBlueprintMigration receipt (emptyManifest receipt.appliedAt)) + pure (Right ()) + Left err -> pure (Left err) diff --git a/src/Seihou/CLI/BlueprintExecution.hs b/src/Seihou/CLI/BlueprintExecution.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/CLI/BlueprintExecution.hs @@ -0,0 +1,165 @@ +-- | Shared preparation for normal and migration blueprint execution. +-- +-- This module deliberately knows nothing about executable command options or +-- provider processes. It resolves the blueprint's variables through Seihou's +-- standard precedence chain, prepares reference-file access, and renders the +-- shared blueprint prompt once for downstream execution modes. +module Seihou.CLI.BlueprintExecution + ( BlueprintExecutionRequest (..), + PreparedBlueprintExecution (..), + prepareBlueprintExecution, + renderBlueprintText, + varValueToText, + ) +where + +import Data.Map.Strict qualified as Map +import Data.Maybe (fromMaybe) +import Data.Text qualified as T +import Seihou.CLI.AgentLaunch + ( formatReferenceFiles, + formatReferenceFilesDir, + resolveBlueprintTools, + ) +import Seihou.CLI.Shared + ( deriveNamespace, + toVarNameMap, + unwrapConfig, + ) +import Seihou.Composition.Instance (primaryInstance) +import Seihou.Composition.Resolve (resolveWithPrompts) +import Seihou.Core.Context (resolveContext) +import Seihou.Core.Types +import Seihou.Effect.ConfigReader + ( readContextConfig, + readGlobalConfig, + readLocalConfig, + readNamespaceConfig, + ) +import Seihou.Effect.ConfigReaderInterp (runConfigReader) +import Seihou.Effect.ConsoleInterp (runConsole) +import Seihou.Prelude +import System.Directory (doesDirectoryExist, makeAbsolute) +import System.Environment (getEnvironment) + +-- | Inputs shared by normal blueprint runs and blueprint migrations. +-- Provider capability is represented as a boolean so this library module does +-- not need to know about Baikai or the executable command model. +data BlueprintExecutionRequest = BlueprintExecutionRequest + { executionBlueprint :: Blueprint, + executionBlueprintDir :: FilePath, + executionVariableOverrides :: [(Text, Text)], + executionNamespaceOverride :: Maybe Text, + executionContextOverride :: Maybe Text, + executionCanMountFiles :: Bool, + executionLogLevel :: LogLevel + } + deriving stock (Eq, Show) + +-- | Prepared state that both execution modes consume. The mounted path is +-- absolute when present; the access text preserves the existing API-provider +-- explanation when local files cannot be mounted. +data PreparedBlueprintExecution = PreparedBlueprintExecution + { preparedBlueprint :: Blueprint, + preparedBlueprintDir :: FilePath, + preparedResolvedVariables :: Map VarName ResolvedVar, + preparedMountedFilesDir :: Maybe FilePath, + preparedReferenceFiles :: Text, + preparedReferenceFilesAccess :: Text, + preparedSharedPrompt :: Text, + preparedAllowedTools :: [String] + } + deriving stock (Eq, Show) + +-- | Resolve one blueprint through the same CLI/environment/config/prompt +-- precedence used by @seihou run@ and the existing agent runner. +prepareBlueprintExecution :: + BlueprintExecutionRequest -> + IO (Either [VarError] PreparedBlueprintExecution) +prepareBlueprintExecution request = do + let bp = request.executionBlueprint + blueprintDir = request.executionBlueprintDir + filesDir = blueprintDir "files" + filesExist <- doesDirectoryExist filesDir + mountedFilesDir <- + if filesExist && request.executionCanMountFiles + then Just <$> makeAbsolute filesDir + else pure Nothing + + let placeholderModule = + Module + { name = bp.name, + version = bp.version, + description = bp.description, + vars = bp.vars, + exports = [], + prompts = bp.prompts, + steps = [], + commands = [], + dependencies = [], + removal = Nothing, + migrations = [] + } + placeholderInst = primaryInstance bp.name + placeholderTriple = (placeholderInst, placeholderModule, blueprintDir) + + envPairs <- getEnvironment + let cliOverrides = + Map.fromList + [(VarName key, value) | (key, value) <- request.executionVariableOverrides] + envVars = Map.fromList [(T.pack key, T.pack value) | (key, value) <- envPairs] + namespace = + fromMaybe (deriveNamespace bp.name) request.executionNamespaceOverride + context <- resolveContext request.executionContextOverride envVars + let contextName = fromMaybe "" context + + resolveResult <- runEff $ runConfigReader $ runConsole $ do + localCfg <- readLocalConfig >>= unwrapConfig request.executionLogLevel + nsCfg <- readNamespaceConfig namespace >>= unwrapConfig request.executionLogLevel + ctxCfg <- readContextConfig contextName >>= unwrapConfig request.executionLogLevel + globalCfg <- readGlobalConfig >>= unwrapConfig request.executionLogLevel + resolveWithPrompts + [placeholderTriple] + cliOverrides + envVars + namespace + contextName + (toVarNameMap localCfg) + (toVarNameMap nsCfg) + (toVarNameMap ctxCfg) + (toVarNameMap globalCfg) + + pure $ do + allResolved <- resolveResult + let resolved = Map.findWithDefault Map.empty placeholderInst allResolved + Right + PreparedBlueprintExecution + { preparedBlueprint = bp, + preparedBlueprintDir = blueprintDir, + preparedResolvedVariables = resolved, + preparedMountedFilesDir = mountedFilesDir, + preparedReferenceFiles = formatReferenceFiles bp.files, + preparedReferenceFilesAccess = formatReferenceFilesDir mountedFilesDir, + preparedSharedPrompt = renderBlueprintText resolved bp.prompt, + preparedAllowedTools = resolveBlueprintTools bp.allowedTools + } + +-- | Substitute resolved blueprint variables into any blueprint-owned text. +renderBlueprintText :: Map VarName ResolvedVar -> Text -> Text +renderBlueprintText resolved template = + foldl' + ( \rendered (name, value) -> + T.replace + ("{{" <> name.unVarName <> "}}") + (varValueToText value.value) + rendered + ) + template + (Map.toList resolved) + +varValueToText :: VarValue -> Text +varValueToText (VText value) = value +varValueToText (VBool True) = "true" +varValueToText (VBool False) = "false" +varValueToText (VInt value) = T.pack (show value) +varValueToText (VList values) = T.intercalate "," (map varValueToText values) diff --git a/src/Seihou/CLI/BlueprintMigration.hs b/src/Seihou/CLI/BlueprintMigration.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/CLI/BlueprintMigration.hs @@ -0,0 +1,174 @@ +-- | Pure selection/rendering and callback-driven execution for ordered +-- agent-guided blueprint migrations. +module Seihou.CLI.BlueprintMigration + ( BlueprintMigrationLaunchFailure (..), + BlueprintMigrationRunResult (..), + renderBlueprintMigrationInstruction, + renderBlueprintMigrationSystemPrompt, + formatBlueprintMigrationDebugOutput, + pendingBlueprintMigrations, + runBlueprintMigrationsWith, + ) +where + +import Data.Maybe (fromMaybe) +import Data.Text qualified as T +import Seihou.CLI.AgentLaunch + ( AgentContext (..), + formatAvailableModules, + formatLocalModules, + formatManifestState, + formatModuleDhallState, + formatSeihouProjectState, + substitute, + ) +import Seihou.CLI.BlueprintExecution + ( PreparedBlueprintExecution (..), + renderBlueprintText, + ) +import Seihou.Core.Migration + ( BlueprintMigration (..), + BlueprintMigrationPlan (..), + ) +import Seihou.Core.Types + ( AppliedBlueprintMigration (..), + Blueprint (..), + ModuleName (..), + ResolvedVar, + VarName, + ) +import Seihou.Prelude +import System.Exit (ExitCode) + +-- | Provider failures retain either a real interactive process exit or API +-- error text rather than collapsing both paths into an artificial exit code. +data BlueprintMigrationLaunchFailure + = BlueprintMigrationProcessFailure ExitCode + | BlueprintMigrationProviderFailure Text + deriving stock (Eq, Show) + +-- | Terminal outcome for one pending migration chain. +data BlueprintMigrationRunResult + = BlueprintMigrationNoWork + | BlueprintMigrationComplete [BlueprintMigration] + | BlueprintMigrationLaunchFailed BlueprintMigration BlueprintMigrationLaunchFailure + | BlueprintMigrationRecordFailed BlueprintMigration Text + deriving stock (Eq, Show) + +-- | Render the edge-specific instruction with the same resolved variables as +-- the blueprint's shared prompt. +renderBlueprintMigrationInstruction :: + Map VarName ResolvedVar -> + BlueprintMigration -> + Text +renderBlueprintMigrationInstruction resolved migration = + renderBlueprintText resolved migration.prompt + +-- | Fill the migration-specific embedded template. The template itself stays +-- in the executable target because @Data.FileEmbed@ traps it there; accepting +-- it as an argument keeps all rendering policy pure and unit-testable here. +renderBlueprintMigrationSystemPrompt :: + Text -> + AgentContext -> + PreparedBlueprintExecution -> + Int -> + Int -> + BlueprintMigration -> + Text +renderBlueprintMigrationSystemPrompt template ctx prepared position total migration = + let blueprint = prepared.preparedBlueprint + renderedInstruction = + renderBlueprintMigrationInstruction prepared.preparedResolvedVariables migration + in substitute + [ ("cwd", ctx.cwd), + ("seihou_project_state", formatSeihouProjectState ctx), + ("manifest_state", formatManifestState ctx), + ("module_dhall_state", formatModuleDhallState ctx), + ("local_modules", formatLocalModules ctx), + ("available_modules", formatAvailableModules ctx), + ("blueprint_name", blueprint.name.unModuleName), + ("blueprint_version", fromMaybe "(unspecified)" blueprint.version), + ("blueprint_description", fromMaybe "(no description)" blueprint.description), + ("migration_from", migration.from), + ("migration_to", migration.to), + ("migration_position", T.pack (show position)), + ("migration_total", T.pack (show total)), + ("reference_files", prepared.preparedReferenceFiles), + ("reference_files_dir", prepared.preparedReferenceFilesAccess), + ("shared_prompt", prepared.preparedSharedPrompt), + ("migration_prompt", renderedInstruction) + ] + template + +-- | Clearly delimit every pending prompt for parent debug mode. This pure +-- function cannot launch a provider or receive a recorder, which makes the +-- migration debug path structurally read-only. +formatBlueprintMigrationDebugOutput :: + (Int -> Int -> BlueprintMigration -> Text) -> + [BlueprintMigration] -> + Text +formatBlueprintMigrationDebugOutput render migrations = + T.intercalate + "\n\n" + [ T.unlines + [ "===== [" + <> T.pack (show position) + <> "/" + <> T.pack (show total) + <> "] " + <> migration.from + <> " -> " + <> migration.to + <> " =====", + render position total migration + ] + | (position, migration) <- zip [1 ..] migrations + ] + where + total = length migrations + +-- | Remove exact-edge receipts while retaining planner order. Artifact +-- versions and timestamps are intentionally not part of the completion key. +pendingBlueprintMigrations :: + Bool -> + ModuleName -> + [AppliedBlueprintMigration] -> + BlueprintMigrationPlan -> + [BlueprintMigration] +pendingBlueprintMigrations rerun blueprintName receipts plan + | rerun = plan.blueprintPlanSteps + | otherwise = filter (not . alreadyApplied) plan.blueprintPlanSteps + where + alreadyApplied migration = + any + ( \receipt -> + receipt.name == blueprintName + && receipt.fromVersion == migration.from + && receipt.toVersion == migration.to + ) + receipts + +-- | Launch and record one pending edge at a time. A receipt is requested only +-- after its launch succeeds, and either callback failure stops the chain before +-- the next launch. +runBlueprintMigrationsWith :: + (Int -> Int -> BlueprintMigration -> IO (Either BlueprintMigrationLaunchFailure ())) -> + (BlueprintMigration -> IO (Either Text ())) -> + [BlueprintMigration] -> + IO BlueprintMigrationRunResult +runBlueprintMigrationsWith _launch _record [] = pure BlueprintMigrationNoWork +runBlueprintMigrationsWith launch record migrations = + go [] (zip [1 ..] migrations) + where + total = length migrations + + go completed [] = pure (BlueprintMigrationComplete (reverse completed)) + go completed ((position, migration) : rest) = do + launchResult <- launch position total migration + case launchResult of + Left failure -> pure (BlueprintMigrationLaunchFailed migration failure) + Right () -> do + recordResult <- record migration + case recordResult of + Left err -> pure (BlueprintMigrationRecordFailed migration err) + Right () -> go (migration : completed) rest diff --git a/src/Seihou/CLI/CommandExecution.hs b/src/Seihou/CLI/CommandExecution.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/CLI/CommandExecution.hs @@ -0,0 +1,189 @@ +module Seihou.CLI.CommandExecution + ( CommandPolicy (..), + CommandDisposition (..), + PlannedCommand (..), + CommandPlan (..), + CommandPlanSummary (..), + CommandExecutionError (..), + planCommands, + summarizeCommandPlan, + executeCommandPlan, + executeCommandPlanWithOutput, + finalizeCommandReceipts, + ) +where + +import Data.Map.Strict qualified as Map +import Data.Maybe (mapMaybe) +import Data.Time (UTCTime) +import Seihou.Core.CommandFingerprint (fingerprintCommand) +import Seihou.Core.Types +import Seihou.Effect.Process (Process, runProcess) +import Seihou.Prelude +import System.Exit (ExitCode (..)) + +-- | Whether a command phase runs every declaration, only declarations that +-- lack a successful receipt, or no declarations. +data CommandPolicy + = RunAllCommands + | RunChangedCommands + | DisableCommands + deriving stock (Eq, Show) + +-- | The action selected for one rendered command. +data CommandDisposition + = CommandWillRun + | CommandSkippedUnchanged + | CommandSkippedDisabled + deriving stock (Eq, Show) + +-- | A rendered command paired with its stable identity and selected action. +data PlannedCommand = PlannedCommand + { operation :: Operation, + fingerprint :: CommandFingerprint, + disposition :: CommandDisposition + } + deriving stock (Eq, Show) + +-- | An ordered command phase. Declaration/composition order is also execution +-- order. +newtype CommandPlan = CommandPlan + { commands :: [PlannedCommand] + } + deriving stock (Eq, Show) + +-- | Counts suitable for human or machine-readable previews. +data CommandPlanSummary = CommandPlanSummary + { willRun :: Int, + skippedUnchanged :: Int, + skippedDisabled :: Int + } + deriving stock (Eq, Show) + +-- | A failed shell command and its captured process result. +data CommandExecutionError = CommandExecutionError + { command :: PlannedCommand, + exitCode :: Int, + stdout :: Text, + stderr :: Text + } + deriving stock (Eq, Show) + +-- | Select command dispositions according to policy and prior successful +-- receipts. Non-command operations are ignored. +planCommands :: + CommandPolicy -> + Map CommandFingerprint CommandReceipt -> + [Operation] -> + CommandPlan +planCommands policy priorReceipts = + CommandPlan . mapMaybe planOne + where + planOne operation = do + fingerprint <- fingerprintCommand operation + let disposition = case policy of + RunAllCommands -> CommandWillRun + RunChangedCommands + | Map.member fingerprint priorReceipts -> CommandSkippedUnchanged + | otherwise -> CommandWillRun + DisableCommands -> CommandSkippedDisabled + pure PlannedCommand {operation, fingerprint, disposition} + +-- | Count each command disposition without changing command order. +summarizeCommandPlan :: CommandPlan -> CommandPlanSummary +summarizeCommandPlan commandPlan = + foldl' count emptySummary commandPlan.commands + where + emptySummary = CommandPlanSummary {willRun = 0, skippedUnchanged = 0, skippedDisabled = 0} + count summary planned = case planned.disposition of + CommandWillRun -> summary {willRun = summary.willRun + 1} + CommandSkippedUnchanged -> summary {skippedUnchanged = summary.skippedUnchanged + 1} + CommandSkippedDisabled -> summary {skippedDisabled = summary.skippedDisabled + 1} + +-- | Execute runnable commands sequentially with @sh -c@. Stop at the first +-- failure. The caller receives receipts only if the entire phase succeeds. +executeCommandPlan :: + (Process :> es) => + UTCTime -> + CommandPlan -> + Eff es (Either CommandExecutionError [CommandReceipt]) +executeCommandPlan completedAt commandPlan = go [] commandPlan.commands + where + go = executeCommands completedAt (\_ _ _ -> pure ()) + +-- | Execute a command plan while exposing successful captured output to an +-- effectful callback. The executable uses this to preserve its historical +-- stdout behavior; library callers that only need receipts use +-- 'executeCommandPlan'. +executeCommandPlanWithOutput :: + (Process :> es) => + UTCTime -> + (PlannedCommand -> Text -> Text -> Eff es ()) -> + CommandPlan -> + Eff es (Either CommandExecutionError [CommandReceipt]) +executeCommandPlanWithOutput completedAt onSuccess commandPlan = + executeCommands completedAt onSuccess [] commandPlan.commands + +executeCommands :: + (Process :> es) => + UTCTime -> + (PlannedCommand -> Text -> Text -> Eff es ()) -> + [CommandReceipt] -> + [PlannedCommand] -> + Eff es (Either CommandExecutionError [CommandReceipt]) +executeCommands completedAt onSuccess = go + where + go completed [] = pure (Right (reverse completed)) + go completed (planned : remaining) = case planned.disposition of + CommandSkippedUnchanged -> go completed remaining + CommandSkippedDisabled -> go completed remaining + CommandWillRun -> case planned.operation of + RunCommandOp {command, workDir, moduleName} -> do + (processExit, stdout, stderr) <- runProcess "sh" ["-c", command] workDir + case processExit of + ExitSuccess -> do + onSuccess planned stdout stderr + let receipt = + CommandReceipt + { fingerprint = planned.fingerprint, + moduleName, + command, + workDir, + completedAt + } + go (receipt : completed) remaining + ExitFailure exitCode -> + pure + ( Left + CommandExecutionError + { command = planned, + exitCode, + stdout, + stderr + } + ) + _ -> go completed remaining + +-- | Produce the accepted receipt map for the plan's current declaration set. +-- Removed commands are dropped. Fresh successes replace old receipts; +-- unchanged or explicitly disabled declarations retain a matching old receipt. +finalizeCommandReceipts :: + CommandPlan -> + [CommandReceipt] -> + Map CommandFingerprint CommandReceipt -> + Map CommandFingerprint CommandReceipt +finalizeCommandReceipts commandPlan completed priorReceipts = + Map.fromList (mapMaybe receiptFor commandPlan.commands) + where + completedByFingerprint = Map.fromList [(receipt.fingerprint, receipt) | receipt <- completed] + + receiptFor planned = + case Map.lookup planned.fingerprint completedByFingerprint of + Just receipt -> Just (planned.fingerprint, receipt) + Nothing -> case planned.disposition of + CommandWillRun -> Nothing + CommandSkippedUnchanged -> retainPrior planned + CommandSkippedDisabled -> retainPrior planned + + retainPrior planned = + (planned.fingerprint,) <$> Map.lookup planned.fingerprint priorReceipts diff --git a/src/Seihou/CLI/CommitMessage.hs b/src/Seihou/CLI/CommitMessage.hs --- a/src/Seihou/CLI/CommitMessage.hs +++ b/src/Seihou/CLI/CommitMessage.hs @@ -88,6 +88,6 @@ _ -> txt fallbackMessage :: [ModuleName] -> T.Text -fallbackMessage [] = "seihou: apply modules" -fallbackMessage [m] = "seihou: apply module " <> m.unModuleName -fallbackMessage ms = "seihou: apply modules " <> T.intercalate ", " (map (.unModuleName) ms) +fallbackMessage [] = "chore(seihou): apply modules" +fallbackMessage [m] = "chore(seihou): apply " <> m.unModuleName +fallbackMessage ms = "chore(seihou): apply " <> T.intercalate ", " (map (.unModuleName) ms) diff --git a/src/Seihou/CLI/PendingMigrations.hs b/src/Seihou/CLI/PendingMigrations.hs --- a/src/Seihou/CLI/PendingMigrations.hs +++ b/src/Seihou/CLI/PendingMigrations.hs @@ -72,7 +72,10 @@ T.unlines $ "Pending migrations detected:" : map renderEntry pendings - ++ ["", "Run 'seihou migrate ' for each, or pass --with-migrations to apply during this run."] + ++ [ "", + "For a recorded project application, run 'seihou update '.", + "For focused recovery, run 'seihou migrate ' for each, or pass --with-migrations to this explicit reconfiguration run." + ] where renderEntry (name, plan) = " " diff --git a/src/Seihou/CLI/SchemaVersion.hs b/src/Seihou/CLI/SchemaVersion.hs --- a/src/Seihou/CLI/SchemaVersion.hs +++ b/src/Seihou/CLI/SchemaVersion.hs @@ -9,11 +9,11 @@ -- | Raw URL for the seihou-schema package.dhall at a pinned commit schemaUrl :: Text -schemaUrl = "https://raw.githubusercontent.com/shinzui/seihou-schema/a0fba0d17b43b14bfdf6d0bf98f1b7ff7af4ebab/package.dhall" +schemaUrl = "https://raw.githubusercontent.com/shinzui/seihou-schema/2dffa0592be47835a60784b89a289226ba990aa8/package.dhall" -- | SHA256 integrity hash for the schema import schemaHash :: Text -schemaHash = "sha256:36250d32d50cec0ea8c74926684ffb8b20f6d0b4f2152930dfa04a1ff108ef3f" +schemaHash = "sha256:01b6f873520459f3958baa34d3f97a49a4263b9a7225a758cddca5ab3a911f61" -- | Complete Dhall import line for use in generated modules schemaImportLine :: Text diff --git a/src/Seihou/CLI/StatusRender.hs b/src/Seihou/CLI/StatusRender.hs --- a/src/Seihou/CLI/StatusRender.hs +++ b/src/Seihou/CLI/StatusRender.hs @@ -1,13 +1,15 @@ module Seihou.CLI.StatusRender ( formatStatus, + formatBlueprintMigrations, ModuleAdvice (..), - moduleAdvice, ) where -import Data.List (intersperse) +import Data.List (intersperse, nub) import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map +import Data.Maybe (isJust, listToMaybe, mapMaybe) +import Data.Set qualified as Set import Data.Text (Text) import Data.Text qualified as T import Data.Time.Format (defaultTimeLocale, formatTime) @@ -19,8 +21,12 @@ import Seihou.Core.Migration (MigrationPlan (..)) import Seihou.Core.Types ( AppliedBlueprint (..), + AppliedBlueprintMigration (..), + AppliedComposition (..), + AppliedInstanceState (..), AppliedModule (..), AppliedRecipe (..), + AppliedTarget (..), Manifest (..), ModuleName (..), ParentVars (..), @@ -31,41 +37,15 @@ ) import Seihou.Core.Version (renderVersion) --- | What action a single applied-module row recommends. --- --- Order of precedence: a pending migration always wins over a bare --- "outdated" annotation, because @seihou migrate@ (after EP-2) is --- self-contained and one command suffices to bring the project to the --- new version. An outdated row with no detected pending plan falls --- back to @seihou upgrade@. +-- | What action an applied module or recorded application recommends. +-- Pending migrations and ordinary version drift both route through the +-- project-aware update workflow. data ModuleAdvice - = -- | Nothing pending; do not emit a hint. - AdviceNone - | -- | Module is outdated and no pending migration was detected. The - -- renderer prints @"Run: seihou upgrade "@. - AdviceUpgradeOnly Text - | -- | A pending migration was detected. The carried 'MigrationPlan' - -- describes the version range and the in-window migrations that - -- would run; 'planSteps' may be empty (a pure version bump) or - -- non-empty. The renderer prints a one-line summary and - -- @"Run: seihou migrate "@. - AdvicePendingMigration Text MigrationPlan + = AdviceNone + | AdviceProjectUpdate Text (Maybe MigrationPlan) + | AdviceProjectUpdateAll deriving stock (Eq, Show) --- | Decide which advice to emit for a single applied module. Any --- detected pending plan wins over a bare outdated annotation because --- @seihou migrate@ (after EP-2) is self-contained. -moduleAdvice :: - AppliedModule -> - Maybe OutdatedStatus -> - Maybe MigrationPlan -> - ModuleAdvice -moduleAdvice am mStatus mPlan = case mPlan of - Just plan -> AdvicePendingMigration am.name.unModuleName plan - Nothing -> case mStatus of - Just OutdatedSt -> AdviceUpgradeOnly am.name.unModuleName - _ -> AdviceNone - -- | Render the full @seihou status@ output as a single 'Text' value. -- -- @color@ controls ANSI styling; pass 'False' for plain text (used by @@ -82,6 +62,7 @@ ["Seihou Status:", ""] ++ recipeSection manifest ++ blueprintSection manifest + ++ formatBlueprintMigrations manifest.blueprintMigrations ++ appliedSection color manifest mEntries pendings ++ trackedSection color tracked ++ varsSection manifest @@ -93,19 +74,7 @@ Nothing -> Map.empty pendingMap = Map.fromList [(name.unModuleName, plan) | (name, plan) <- pendings] - adviceList = map (rowAdvice entryMap pendingMap) manifest.modules - --- | Build a 'ModuleAdvice' for one applied module from the lookup maps. -rowAdvice :: - Map Text OutdatedEntry -> - Map Text MigrationPlan -> - AppliedModule -> - ModuleAdvice -rowAdvice entryMap pendingMap am = - let name = am.name.unModuleName - mStatus = (.status) <$> Map.lookup name entryMap - mPlan = Map.lookup name pendingMap - in moduleAdvice am mStatus mPlan + adviceList = projectAdviceList manifest entryMap pendingMap -- --------------------------------------------------------------------------- -- Section renderers @@ -145,6 +114,27 @@ Just p -> [" Prompt: \"" <> p <> "\""] in [header, baselineLine] ++ promptLines ++ [""] +-- | Render durable agent-guided migration receipts. An empty ledger adds no +-- output; each populated row includes the artifact, exact edge, and timestamp. +formatBlueprintMigrations :: [AppliedBlueprintMigration] -> [Text] +formatBlueprintMigrations [] = [] +formatBlueprintMigrations receipts = + "Blueprint migrations:" + : map renderReceipt receipts + <> [""] + where + renderReceipt receipt = + " " + <> receipt.name.unModuleName + <> maybe "" (\version -> " v" <> version) receipt.blueprintVersion + <> ": " + <> receipt.fromVersion + <> " -> " + <> receipt.toVersion + <> " (applied " + <> T.pack (formatTime defaultTimeLocale "%Y-%m-%d %H:%M UTC" receipt.appliedAt) + <> ")" + -- | Render the baseline body for the blueprint section. Three cases: -- @--no-baseline@ was passed, the blueprint declared no baseline at -- all, or one or more baseline modules were applied. @@ -173,16 +163,17 @@ Map.fromList [(name.unModuleName, plan) | (name, plan) <- pendings] moduleLines | null manifest.modules = [" (none)"] - | otherwise = - concatMap - ( \am -> - let advice = rowAdvice entryMap pendingMap am - annotation = lookupEntry mEntries entryMap am - headerLine = formatModuleLine color annotation am - hintLines = formatAdvice color advice - in headerLine : hintLines - ) - manifest.modules + | otherwise = renderRows Set.empty manifest.modules + renderRows _ [] = [] + renderRows seen (am : rest) = + let name = am.name.unModuleName + annotation = lookupEntry mEntries entryMap am + headerLine = formatModuleLine color annotation am + hintLines + | Set.member name seen = [] + | null manifest.applications = formatAdvice color (rowProjectAdvice entryMap pendingMap am) + | otherwise = maybe [] (formatPendingDetail color) (Map.lookup name pendingMap) + in headerLine : hintLines <> renderRows (Set.insert name seen) rest trackedSection :: Bool -> [TrackedFile] -> [Text] trackedSection color tracked = @@ -217,14 +208,14 @@ -- actionable problem. recommendedActionsSection :: [ModuleAdvice] -> [Text] recommendedActionsSection advices = - case [c | Just c <- map adviceCommand advices] of + case nub [c | Just c <- map adviceCommand advices] of [] -> [] cmds -> ["", "Recommended actions:"] ++ map (" " <>) cmds adviceCommand :: ModuleAdvice -> Maybe Text adviceCommand AdviceNone = Nothing -adviceCommand (AdviceUpgradeOnly name) = Just ("seihou upgrade " <> name) -adviceCommand (AdvicePendingMigration name _) = Just ("seihou migrate " <> name) +adviceCommand (AdviceProjectUpdate target _) = Just ("seihou update " <> target) +adviceCommand AdviceProjectUpdateAll = Just "seihou update" -- --------------------------------------------------------------------------- -- Per-row formatting @@ -287,23 +278,81 @@ -- under the module name. formatAdvice :: Bool -> ModuleAdvice -> [Text] formatAdvice _ AdviceNone = [] -formatAdvice color (AdviceUpgradeOnly name) = - [" " <> applyColor color yellow ("Run: seihou upgrade " <> name)] -formatAdvice color (AdvicePendingMigration name plan) = - [" " <> applyColor color yellow (planSummary name plan)] +formatAdvice color (AdviceProjectUpdate target Nothing) = + [" " <> applyColor color yellow ("Run: seihou update " <> target)] +formatAdvice color (AdviceProjectUpdate target (Just plan)) = + [" " <> applyColor color yellow (projectPlanSummary target plan)] +formatAdvice color AdviceProjectUpdateAll = + [" " <> applyColor color yellow "Run: seihou update"] --- | Format the "Pending migration: from -> to (N step(s)). Run: --- seihou migrate " line for a pending-migration advice row. -planSummary :: Text -> MigrationPlan -> Text -planSummary name plan = +projectPlanSummary :: Text -> MigrationPlan -> Text +projectPlanSummary target plan = "Pending migration: " <> renderVersion plan.planFrom <> " -> " <> renderVersion plan.planTo <> " (" <> T.pack (show (length plan.planSteps)) - <> " step(s)). Run: seihou migrate " - <> name + <> " step(s)). Run: seihou update " + <> target + +formatPendingDetail :: Bool -> MigrationPlan -> [Text] +formatPendingDetail color plan = + [ " " + <> applyColor + color + yellow + ( "Pending migration: " + <> renderVersion plan.planFrom + <> " -> " + <> renderVersion plan.planTo + <> " (" + <> T.pack (show (length plan.planSteps)) + <> " step(s))" + ) + ] + +rowProjectAdvice :: + Map Text OutdatedEntry -> + Map Text MigrationPlan -> + AppliedModule -> + ModuleAdvice +rowProjectAdvice entryMap pendingMap applied = + if actionable + then AdviceProjectUpdate name pending + else AdviceNone + where + name = applied.name.unModuleName + pending = Map.lookup name pendingMap + outdated = maybe False ((== OutdatedSt) . (.status)) (Map.lookup name entryMap) + actionable = outdated || isJust pending + +projectAdviceList :: + Manifest -> + Map Text OutdatedEntry -> + Map Text MigrationPlan -> + [ModuleAdvice] +projectAdviceList manifest entryMap pendingMap + | null manifest.applications = + map (rowProjectAdvice entryMap pendingMap) (deduplicateModules manifest.modules) + | otherwise = + let applicationAdvice = mapMaybe adviceForApplication manifest.applications + in applicationAdvice <> [AdviceProjectUpdateAll | length applicationAdvice > 1] + where + adviceForApplication application = + let names = map (.name.unModuleName) application.instances + pending = listToMaybe (mapMaybe (`Map.lookup` pendingMap) names) + outdated = any (maybe False ((== OutdatedSt) . (.status)) . (`Map.lookup` entryMap)) names + in if outdated || isJust pending + then Just (AdviceProjectUpdate (targetText application.target) pending) + else Nothing + +deduplicateModules :: [AppliedModule] -> [AppliedModule] +deduplicateModules = Map.elems . Map.fromList . map (\applied -> (applied.name.unModuleName, applied)) + +targetText :: AppliedTarget -> Text +targetText (AppliedModuleTarget name) = name.unModuleName +targetText (AppliedRecipeTarget name) = name.unRecipeName renderEntry :: Bool -> OutdatedEntry -> Text renderEntry color e = case e.status of diff --git a/src/Seihou/CLI/Style.hs b/src/Seihou/CLI/Style.hs --- a/src/Seihou/CLI/Style.hs +++ b/src/Seihou/CLI/Style.hs @@ -87,8 +87,10 @@ renderNonFileColor :: PreviewLine -> Text renderNonFileColor (DirPreview path) = " " <> cyan "mkdir" <> " " <> cyan (T.pack path) -renderNonFileColor (CommandPreview cmd) = - " " <> dim "run" <> " " <> dim cmd +renderNonFileColor (CommandPreview cmd mOwner) = + " " <> dim "run" <> " " <> dim cmd <> ownerSuffix mOwner + where + ownerSuffix = maybe "" (\owner -> " " <> dim ("(" <> owner.unModuleName <> ")")) renderNonFileColor (OrphanPreview path modName') = " " <> magenta "[orphaned]" <> " " <> magenta (T.pack path) <> " " <> dim ("(orphaned from " <> modName'.unModuleName <> ")") renderNonFileColor _ = "" diff --git a/src/Seihou/CLI/Update.hs b/src/Seihou/CLI/Update.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/CLI/Update.hs @@ -0,0 +1,1068 @@ +module Seihou.CLI.Update + ( UpdateSelection (..), + PromptPolicy (..), + UpdateRequest (..), + VersionChange (..), + InputChangeSummary (..), + CandidateArtifactKind (..), + CandidateArtifact (..), + PlannedUpdateMigration (..), + UpdateWarning (..), + UpdatePlan (..), + CommandSummary (..), + UpdateResult (..), + UpdateError (..), + planProjectUpdate, + applyProjectUpdate, + withProjectUpdate, + isUpdateNoOp, + ) +where + +import Control.Exception (SomeException, displayException, try) +import Control.Monad (foldM, forM, forM_, when) +import Data.Foldable (traverse_) +import Data.List (find, isPrefixOf) +import Data.Map.Strict qualified as Map +import Data.Maybe (fromMaybe, isJust, mapMaybe, maybeToList) +import Data.Set qualified as Set +import Data.Text qualified as T +import Data.Text.IO qualified as TIO +import Data.Time (UTCTime, getCurrentTime) +import Effectful (runEff) +import Seihou.CLI.CommandExecution +import Seihou.CLI.InstallShared (installModuleDir) +import Seihou.CLI.Shared (deriveNamespace, toVarNameMap) +import Seihou.CLI.Update.Migrations +import Seihou.CLI.Update.Recovery +import Seihou.CLI.Update.Selection +import Seihou.CLI.Update.Source +import Seihou.CLI.Update.Types +import Seihou.Composition.Instance (ModuleInstance (..)) +import Seihou.Composition.Plan (compileComposedPlan) +import Seihou.Composition.Recipe (expandRecipe) +import Seihou.Composition.Resolve + ( PromptPermission (..), + SavedInstanceValues, + loadComposition, + resolveWithPromptPermission, + ) +import Seihou.Core.Application (buildAppliedComposition, replaceAppliedComposition) +import Seihou.Core.Module (defaultSearchPaths, discoverRunnable) +import Seihou.Core.Types +import Seihou.Core.Version (parseVersion) +import Seihou.Effect.BaselineStore (pruneBaselines) +import Seihou.Effect.BaselineStoreInterp (runBaselineStore) +import Seihou.Effect.ConfigReader +import Seihou.Effect.ConfigReaderInterp (runConfigReader) +import Seihou.Effect.ConsoleInterp (runConsole) +import Seihou.Effect.FilesystemInterp (runFilesystem) +import Seihou.Effect.FilesystemPure (PureFS (..)) +import Seihou.Effect.ManifestStore (readManifest, writeManifest) +import Seihou.Effect.ManifestStoreInterp (runManifestStore) +import Seihou.Effect.ProcessInterp (runProcessIO) +import Seihou.Engine.Baseline (manifestBaselineRefs) +import Seihou.Engine.Migrate (ExecutedMigrationPlan (..), MigrationOpInstance (..), classifyMigration, executeMigration) +import Seihou.Engine.Reconcile +import Seihou.Engine.UpdateTransaction +import Seihou.Manifest.Hash (hashContent) +import Seihou.Manifest.Types (currentManifestVersion) +import Seihou.Prelude +import System.Directory qualified as Directory +import System.Environment (getEnvironment) +import System.FilePath (takeDirectory) +import System.IO.Temp (createTempDirectory, getCanonicalTemporaryDirectory, withSystemTempDirectory) + +-- | Lifetime-safe public planning entry point. Candidate clones exist for the +-- callback only, so an 'UpdatePlan' cannot accidentally outlive its sources. +withProjectUpdate :: + UpdateRequest -> + (Either UpdateError UpdatePlan -> IO a) -> + IO a +withProjectUpdate request callback = + withSystemTempDirectory "seihou-project-update" $ \sessionDirectory -> + planProjectUpdateIn sessionDirectory request >>= callback + +-- | Internal/test-facing planner. Prefer 'withProjectUpdate'; this form keeps +-- its temporary session until process exit or a test removes it. +planProjectUpdate :: UpdateRequest -> IO (Either UpdateError UpdatePlan) +planProjectUpdate request = do + temporaryRoot <- getCanonicalTemporaryDirectory + sessionDirectory <- createTempDirectory temporaryRoot "seihou-project-update" + result <- planProjectUpdateIn sessionDirectory request + case result of + Left _ -> Directory.removePathForcibly sessionDirectory + Right _ -> pure () + pure result + +planProjectUpdateIn :: FilePath -> UpdateRequest -> IO (Either UpdateError UpdatePlan) +planProjectUpdateIn sessionDirectory request = do + projectRoot <- Directory.getCurrentDirectory + installedDirectory <- standardInstalledDirectory + recovery <- recoverAtEntry projectRoot + case recovery of + Left err -> pure (Left err) + Right () -> do + let manifestPath = projectRoot ".seihou" "manifest.json" + baselineDirectory = projectRoot ".seihou" "baselines" + manifestResult <- readManifestIO manifestPath + case manifestResult of + Left err -> pure (Left err) + Right manifest -> do + now <- getCurrentTime + seeded <- selectAndSeedLegacy request manifest now + case seeded of + Left err -> pure (Left err) + Right (selected, seedWarnings) -> do + staged <- stageCandidateSources sessionDirectory selected + case staged of + Left err -> pure (Left err) + Right (catalog, sourceWarnings) -> do + plannedApplicationsResult <- traverse (planApplication request installedDirectory catalog now) selected + case sequence plannedApplicationsResult of + Left err -> pure (Left err) + Right plannedApplications -> do + let applicationInputs = + [ (Just previous, planned.modulesInOrder) + | (previous, planned) <- zip selected plannedApplications + ] + stagedMigrations <- planAndStageMigrations projectRoot manifest catalog applicationInputs + case stagedMigrations of + Left err -> pure (Left err) + Right migrationStage -> do + let (operations, owners, compositionWarnings) = combineApplicationPlans plannedApplications + selectedIds = Set.fromList (map (.candidate.applicationId) plannedApplications) + stageRoot <- materializeStagedProject sessionDirectory projectRoot migrationStage.filesystem operations + reconciliationResult <- + runEff $ + runFilesystem $ + runBaselineStore baselineDirectory $ + planReconciliation stageRoot migrationStage.manifest selectedIds operations owners + case reconciliationResult of + Left err -> pure (Left (UpdateReconciliationFailed err)) + Right reconciliation -> do + evidence <- versionEvidence catalog selected plannedApplications + case evidence of + Left err -> pure (Left err) + Right (versionChanges, versionWarnings) -> do + let usedArtifacts = artifactsUsedBy catalog plannedApplications + priorReceipts = Map.unions (map (.commandReceipts) selected) + commandPlan = planCommands request.commandPolicy priorReceipts operations + warnings = + seedWarnings + <> sourceWarnings + <> migrationStage.warnings + <> compositionWarnings + <> versionWarnings + inputChanges = summarizeInputChanges seedWarnings plannedApplications + transactionTargets = transactionTargetPaths manifest reconciliation migrationStage.plans + observedProjectHashes <- + observePaths + projectRoot + (Set.insert (".seihou" "manifest.json") transactionTargets) + let snapshot = + UpdateSnapshot + { sessionDirectory, + projectRoot, + manifestPath, + baselineDirectory, + installedDirectory, + originalManifest = manifest, + candidateHashes = Map.fromList [(artifact.originalDirectory, artifact.contentHash) | artifact <- usedArtifacts], + observedProjectHashes, + transactionTargets + } + pure + ( Right + UpdatePlan + { applications = map (.candidate) plannedApplications, + versionChanges, + inputChanges, + migrations = migrationStage.plans, + reconciliation, + commandPlan, + candidateArtifacts = usedArtifacts, + warnings, + request, + snapshot, + plannedApplications + } + ) + +applyProjectUpdate :: UpdatePlan -> IO (Either UpdateError UpdateResult) +applyProjectUpdate plan = + Directory.withCurrentDirectory plan.snapshot.projectRoot $ do + recovery <- recoverAtEntry plan.snapshot.projectRoot + case recovery of + Left err -> pure (Left err) + Right () -> do + stale <- stalePlanPaths plan + if not (Set.null stale) + then pure (Left (UpdatePlanStale stale)) + else + if plan.request.dryRun + then pure (Right (dryRunResult plan)) + else + if not (Set.null (unresolvedPaths plan.reconciliation)) + then pure (Left (UpdateHasUnresolvedPaths (unresolvedPaths plan.reconciliation))) + else + if isStructuredNoOp plan + then pure (Right (noOpResult plan)) + else applyAcceptedPlan plan + +applyAcceptedPlan :: UpdatePlan -> IO (Either UpdateError UpdateResult) +applyAcceptedPlan plan = do + transactionResult <- beginUpdateTransaction plan.snapshot.projectRoot plan.snapshot.transactionTargets + case transactionResult of + Left err -> pure (Left (UpdateTransactionFailed err)) + Right transaction -> do + backupResult <- prepareServiceBackups transaction plan.snapshot.installedDirectory plan.migrations plan.candidateArtifacts + case backupResult of + Left err -> abortUpdate transaction err + Right () -> do + now <- getCurrentTime + migrated <- runRealMigrations now plan.snapshot.originalManifest plan.migrations + case migrated of + Left err -> abortUpdate transaction err + Right migratedManifest -> do + actualReconciliation <- planActualReconciliation plan migratedManifest + case actualReconciliation of + Left err -> abortUpdate transaction err + Right actual -> case reapplyPlannedResolutions plan.reconciliation actual of + Left _ -> + abortUpdate + transaction + ( UpdateChangedAfterMigrationCommand + (reconciliationSummary plan.reconciliation) + (reconciliationSummary actual) + ) + Right resolvedActual + | resolvedActual /= plan.reconciliation -> + abortUpdate + transaction + ( UpdateChangedAfterMigrationCommand + (reconciliationSummary plan.reconciliation) + (reconciliationSummary resolvedActual) + ) + | otherwise -> do + let reconciliationManifest = migratedManifest {genAt = now} + appliedFiles <- applyReconciliation transaction resolvedActual reconciliationManifest + case appliedFiles of + Left err -> abortUpdate transaction (UpdateTransactionFailed err) + Right filesManifest -> do + commandResult <- + runEff $ + runProcessIO $ + executeCommandPlan now plan.commandPlan + case commandResult of + Left err -> + abortUpdate + transaction + (UpdateCommandFailed err [ArbitraryCommandSideEffectsMayRemain]) + Right completedReceipts -> do + let finalManifest = buildFinalManifest now plan filesManifest completedReceipts + markerResult <- setCommitMarkers transaction finalManifest + case markerResult of + Left err -> abortUpdate transaction err + Right () -> do + publication <- publishCandidates plan.candidateArtifacts + case publication of + Left err -> abortUpdate transaction err + Right () -> do + written <- writeManifestIO plan.snapshot.manifestPath finalManifest + case written of + Left err -> abortUpdate transaction err + Right () -> finishCommitted transaction plan finalManifest completedReceipts + +planApplication :: + UpdateRequest -> + FilePath -> + CandidateCatalog -> + UTCTime -> + AppliedComposition -> + IO (Either UpdateError PlannedApplication) +planApplication request installedDirectory catalog now previous = do + fallback <- defaultSearchPaths + case candidateRoot catalog previous of + Left err -> pure (Left err) + Right (primary, recipeAdditional, recipeOverrides, targetArtifact) -> do + let allAdditional = recipeAdditional <> previous.additionalModules + loaded <- loadComposition (catalog.searchRoot : fallback) 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 recipeOverrides modulesInOrder + case resolved of + Left err -> pure (Left err) + Right 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 (operations, compositionWarnings, rawOwners) -> do + let targetSource = publishedArtifactSource installedDirectory targetArtifact + candidate0 = + ( buildAppliedComposition + previous.target + targetSource + targetArtifact.version + previous.additionalModules + (Just namespace) + previous.context + modulesInOrder + resolvedValues + now + ) + { applicationId = previous.applicationId + } + candidate = + setCompositionState + (map (publishInstanceSource installedDirectory catalog) 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, + desiredOwners + } + ) + where + compositionWarning (FileOverwritten path old new) = CrossApplicationLastWriter path old new + compositionWarning (ContentMerged 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 + AppliedModuleTarget name -> do + artifact <- lookupArtifact catalog CandidateModule name.unModuleName + Right (name, [], Map.empty, artifact) + 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) + +lookupArtifact :: CandidateCatalog -> CandidateArtifactKind -> Text -> Either UpdateError CandidateArtifact +lookupArtifact catalog kind name = + maybe (Left (CandidateArtifactMissing kind name)) Right (Map.lookup (kind, name) catalog.artifacts) + +resolveApplicationValues :: + UpdateRequest -> + Text -> + Text -> + SavedInstanceValues -> + Map VarName Text -> + [(ModuleInstance, Module, FilePath)] -> + IO (Either UpdateError (Map ModuleInstance (Map VarName ResolvedVar))) +resolveApplicationValues request namespace context saved recipeOverrides modulesInOrder = do + envPairs <- getEnvironment + configs <- loadConfigMaps namespace context + case configs of + Left err -> pure (Left err) + Right (localConfig, namespaceConfig, contextConfig, globalConfig) -> do + let cli = Map.fromList [(VarName name, value) | (name, value) <- request.varOverrides] + overrides = Map.union cli recipeOverrides + env = Map.fromList [(T.pack key, T.pack value) | (key, value) <- envPairs] + promptPermission = case request.promptPolicy of + AllowPrompts -> PromptsAllowed + ForbidPrompts -> PromptsForbidden + result <- + runEff $ + runConsole $ + resolveWithPromptPermission + promptPermission + modulesInOrder + saved + overrides + env + namespace + context + localConfig + namespaceConfig + contextConfig + globalConfig + pure (first UpdateVariableErrors result) + +loadConfigMaps :: Text -> Text -> IO (Either UpdateError (Map VarName Text, Map VarName Text, Map VarName Text, Map VarName Text)) +loadConfigMaps namespace context = + runEff $ runConfigReader $ do + local <- readLocalConfig + namespaceValues <- readNamespaceConfig namespace + contextValues <- readContextConfig context + global <- readGlobalConfig + pure $ do + local' <- configResult local + namespace' <- configResult namespaceValues + context' <- configResult contextValues + global' <- configResult global + Right (toVarNameMap local', toVarNameMap namespace', toVarNameMap context', toVarNameMap global') + where + configResult = first (UpdateConfigurationFailed . T.pack . show) + +selectAndSeedLegacy :: + UpdateRequest -> + Manifest -> + UTCTime -> + IO (Either UpdateError ([AppliedComposition], [UpdateWarning])) +selectAndSeedLegacy request manifest now = case selectApplications request.selection manifest of + Left err -> pure (Left err) + Right (RecordedSelection selected) -> pure (Right (selected, [])) + Right (LegacySelection name) -> seedLegacyApplication request manifest now name + +seedLegacyApplication :: + UpdateRequest -> Manifest -> UTCTime -> Text -> IO (Either UpdateError ([AppliedComposition], [UpdateWarning])) +seedLegacyApplication request manifest now requested = do + searchPaths <- defaultSearchPaths + discovered <- discoverRunnable searchPaths (ModuleName requested) + 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) + _ -> Left (CandidateArtifactMissing CandidateModule requested) + case root of + Left err -> pure (Left err) + Right (target, primary, additional, recipeOverrides, targetSource, targetVersion) -> do + 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 + resolved <- resolveApplicationValues request namespace "" saved recipeOverrides modulesInOrder + case resolved of + Left err -> pure (Left err) + Right resolvedValues -> do + let provisional0 = + buildAppliedComposition target targetSource targetVersion [] (Just namespace) Nothing modulesInOrder resolvedValues now + provisional = provisional0 {instances = map (restoreLegacyVersion manifest) provisional0.instances} + pure (Right ([provisional], warnings)) + +legacySavedValues :: + Manifest -> + [(ModuleInstance, Module, FilePath)] -> + (SavedInstanceValues, [UpdateWarning]) +legacySavedValues manifest modulesInOrder = (saved, warnings) + where + declarations = [(instanceId, declaration) | (instanceId, modul, _) <- modulesInOrder, declaration <- modul.vars] + counts = Map.fromListWith (+) [(declaration.name, 1 :: Int) | (_, declaration) <- declarations] + saved = + Map.fromListWith + Map.union + [ (instanceId, Map.singleton declaration.name value) + | (instanceId, declaration) <- declarations, + Map.lookup declaration.name counts == Just 1, + Just value <- [Map.lookup declaration.name manifest.vars] + ] + ambiguous = + [ AmbiguousLegacyValue name + | (name, count) <- Map.toAscList counts, + count > 1, + Map.member name manifest.vars + ] + missing = + [ MissingLegacyValue declaration.name + | (_, declaration) <- declarations, + declaration.required, + Map.notMember declaration.name manifest.vars + ] + warnings = ambiguous <> missing + +restoreLegacyVersion :: Manifest -> AppliedInstanceState -> AppliedInstanceState +restoreLegacyVersion manifest state = + case find (\applied -> applied.name == state.name && applied.parentVars == state.parentVars) manifest.modules of + Nothing -> state + Just applied -> + AppliedInstanceState + { name = state.name, + parentVars = state.parentVars, + source = applied.source, + moduleVersion = applied.moduleVersion, + resolvedVars = state.resolvedVars + } + +savedInstanceValues :: AppliedComposition -> SavedInstanceValues +savedInstanceValues application = + Map.fromList + [ (ModuleInstance state.name state.parentVars, state.resolvedVars) + | state <- application.instances + ] + +combineApplicationPlans :: + [PlannedApplication] -> + ([Operation], Map FilePath DesiredFileOwner, [UpdateWarning]) +combineApplicationPlans = foldl' addApplication ([], Map.empty, []) + where + addApplication (operations, owners, warnings) application = + let crossWarnings = + [ CrossApplicationLastWriter path prior.moduleName next.moduleName + | (path, next) <- Map.toAscList application.desiredOwners, + Just prior <- [Map.lookup path owners], + prior.moduleName /= next.moduleName + ] + mergedOwners = Map.unionWith mergeOwner application.desiredOwners owners + in (operations <> application.operations, mergedOwners, warnings <> crossWarnings) + mergeOwner newest prior = + DesiredFileOwner newest.moduleName (Set.union newest.applicationIds prior.applicationIds) + +materializeStagedProject :: FilePath -> FilePath -> PureFS -> [Operation] -> IO FilePath +materializeStagedProject sessionDirectory projectRoot filesystem operations = do + let stageRoot = sessionDirectory "staged-project" + Directory.createDirectoryIfMissing True stageRoot + forM_ (Map.toAscList filesystem.files) $ \(path, content) -> writeStageFile stageRoot path content + forM_ (Set.toAscList filesystem.dirs) $ \path -> Directory.createDirectoryIfMissing True (stageRoot path) + forM_ (Set.toAscList (Set.fromList (mapMaybe operationDestination operations))) $ \path -> do + stagedExists <- Directory.doesFileExist (stageRoot path) + when (not stagedExists) $ do + let projectPath = projectRoot path + projectExists <- Directory.doesFileExist projectPath + when projectExists (TIO.readFile projectPath >>= writeStageFile stageRoot path) + pure stageRoot + +writeStageFile :: FilePath -> FilePath -> Text -> IO () +writeStageFile root path content = do + Directory.createDirectoryIfMissing True (takeDirectory (root path)) + TIO.writeFile (root path) content + +operationDestination :: Operation -> Maybe FilePath +operationDestination WriteFileOp {dest} = Just dest +operationDestination CopyFileOp {dest} = Just dest +operationDestination PatchFileOp {dest} = Just dest +operationDestination _ = Nothing + +versionEvidence :: + CandidateCatalog -> + [AppliedComposition] -> + [PlannedApplication] -> + IO (Either UpdateError ([VersionChange], [UpdateWarning])) +versionEvidence catalog previousApplications plannedApplications = do + evidence <- fmap concat $ sequence (zipWith applicationEvidence previousApplications plannedApplications) + pure $ do + changes <- sequence evidence + let actualChanges = filter isActualChange changes + traverse_ validateVersionChange actualChanges + let unique = Map.elems (Map.fromList [(versionKey change, change) | change <- actualChanges]) + warnings = + [ SameVersionContentChanged change.name + | change <- unique, + change.sameVersionContentChanged, + isJust change.fromVersion + ] + Right (unique, warnings) + where + applicationEvidence previous planned = do + instanceEvidence <- traverse (instanceVersionEvidence previous) planned.modulesInOrder + targetEvidence <- targetVersionEvidence previous + pure (targetEvidence : instanceEvidence) + + instanceVersionEvidence previous (instanceId, candidateModule, _) = do + let prior = find (\state -> state.name == instanceId.instanceModule && state.parentVars == instanceId.instanceParentVars) previous.instances + case prior of + Nothing -> pure (Right (VersionChange candidateModule.name.unModuleName Nothing candidateModule.version False)) + Just old -> compareArtifact old.name.unModuleName old.moduleVersion candidateModule.version old.source CandidateModule + + targetVersionEvidence previous = case previous.target of + AppliedModuleTarget _ -> pure (Right (VersionChange "" Nothing Nothing False)) + AppliedRecipeTarget name -> compareArtifact name.unRecipeName previous.targetVersion (candidateVersion CandidateRecipe name.unRecipeName) previous.targetSource CandidateRecipe + + candidateVersion kind name = (.version) =<< Map.lookup (kind, name) catalog.artifacts + + compareArtifact name fromVersion toVersion oldSource kind = do + oldHashResult <- try @SomeException (hashArtifactDirectory oldSource) + let candidateHash = (.contentHash) <$> Map.lookup (kind, name) catalog.artifacts + changed = case (oldHashResult, candidateHash) of + (Right oldHash, Just newHash) -> oldHash /= newHash + _ -> True + pure + ( Right + VersionChange + { name, + fromVersion, + toVersion, + sameVersionContentChanged = changed && fromVersion == toVersion + } + ) + + versionKey change = (change.name, change.fromVersion, change.toVersion, change.sameVersionContentChanged) + isActualChange change = + not (T.null change.name) + && (change.fromVersion /= change.toVersion || change.sameVersionContentChanged) + +validateVersionChange :: VersionChange -> Either UpdateError () +validateVersionChange change + | T.null change.name = Right () + | otherwise = case (change.fromVersion, change.toVersion) of + (Just fromText, Just toText) -> do + fromVersion <- maybe (Left (CandidateVersionInvalid change.name fromText)) Right (parseVersion fromText) + toVersion <- maybe (Left (CandidateVersionInvalid change.name toText)) Right (parseVersion toText) + if toVersion < fromVersion + then Left (CandidateDowngrade change.name change.fromVersion change.toVersion) + else Right () + _ -> Right () + +artifactsUsedBy :: CandidateCatalog -> [PlannedApplication] -> [CandidateArtifact] +artifactsUsedBy catalog planned = Map.elems (Map.restrictKeys catalog.artifacts keys) + where + keys = + Set.fromList $ + concatMap applicationKeys planned + applicationKeys application = + targetKey application.candidate.target + : [(CandidateModule, modul.name.unModuleName) | (_, modul, _) <- application.modulesInOrder] + targetKey (AppliedModuleTarget name) = (CandidateModule, name.unModuleName) + targetKey (AppliedRecipeTarget name) = (CandidateRecipe, name.unRecipeName) + +summarizeInputChanges :: [UpdateWarning] -> [PlannedApplication] -> InputChangeSummary +summarizeInputChanges seedWarnings planned = + foldl' summarizeApplication emptySummary planned + where + emptySummary = + InputChangeSummary + { reused = 0, + overridden = 0, + newlyResolved = 0, + removed = 0, + ambiguousLegacy = [name | AmbiguousLegacyValue name <- seedWarnings] + } + summarizeApplication summary application = + let prior = maybe Map.empty savedInstanceValues application.previous + candidateValues = application.resolvedValues + resolvedList = + [ (instanceId, name, value) + | (instanceId, values) <- Map.toList candidateValues, + (name, value) <- Map.toList values + ] + reusedCount = length [() | (_, _, value) <- resolvedList, value.source == FromApplication] + overriddenCount = + length + [ () + | (instanceId, name, value) <- resolvedList, + value.source == FromCLI, + Map.member name (Map.findWithDefault Map.empty instanceId prior) + ] + newCount = + length + [ () + | (instanceId, name, _) <- resolvedList, + Map.notMember name (Map.findWithDefault Map.empty instanceId prior) + ] + removedCount = + length + [ () + | (instanceId, oldValues) <- Map.toList prior, + name <- Map.keys oldValues, + Map.notMember name (Map.findWithDefault Map.empty instanceId candidateValues) + ] + in summary + { reused = summary.reused + reusedCount, + overridden = summary.overridden + overriddenCount, + newlyResolved = summary.newlyResolved + newCount, + removed = summary.removed + removedCount + } + +transactionTargetPaths :: Manifest -> ReconciliationPlan -> [PlannedUpdateMigration] -> Set FilePath +transactionTargetPaths manifest reconciliation migrations = + Map.keysSet reconciliation.files `Set.union` Set.fromList (concatMap migrationTargets migrations) + where + migrationTargets migration = concatMap targets migration.stagedPlan.planOps + targets (MoveFileInst source destination _) = [source, destination] + targets (DeleteFileInst path _) = [path] + targets (MoveDirInst source destination) = + concatMap (moveDirectoryTarget source destination) (Map.keys manifest.files) + targets (DeleteDirInst path) = filter (isPathAtOrBelow path) (Map.keys manifest.files) + targets RunCommandInst {} = [] + moveDirectoryTarget source destination path + | isPathAtOrBelow source path = [path, replacePrefix source destination path] + | isPathAtOrBelow destination path = [path] + | otherwise = [] + +isPathAtOrBelow :: FilePath -> FilePath -> Bool +isPathAtOrBelow directory path = path == directory || (directory <> "/") `isPrefixOf` path + +replacePrefix :: FilePath -> FilePath -> FilePath -> FilePath +replacePrefix source destination path + | path == source = destination + | otherwise = destination <> drop (length source) path + +observePaths :: FilePath -> Set FilePath -> IO (Map FilePath (Maybe SHA256)) +observePaths projectRoot paths = + Map.fromList <$> traverse observe (Set.toAscList paths) + where + observe path = do + let fullPath = projectRoot path + exists <- Directory.doesFileExist fullPath + hash <- if exists then Just . hashContent <$> TIO.readFile fullPath else pure Nothing + pure (path, hash) + +stalePlanPaths :: UpdatePlan -> IO (Set FilePath) +stalePlanPaths plan = do + currentProject <- + observePaths + plan.snapshot.projectRoot + (Map.keysSet plan.snapshot.observedProjectHashes) + candidateChecks <- forM (Map.toAscList plan.snapshot.candidateHashes) $ \(path, expected) -> do + current <- try @SomeException (hashArtifactDirectory path) + pure $ case current of + Right actual | actual == expected -> [] + _ -> [path] + let projectChanges = + Map.keysSet + (Map.filterWithKey (\path observed -> Map.lookup path currentProject /= Just observed) plan.snapshot.observedProjectHashes) + pure (Set.union projectChanges (Set.fromList (concat candidateChecks))) + +planActualReconciliation :: UpdatePlan -> Manifest -> IO (Either UpdateError ReconciliationPlan) +planActualReconciliation plan manifest = do + let (operations, owners, _) = combineApplicationPlans plan.plannedApplications + selected = Set.fromList (map (.applicationId) plan.applications) + result <- + runEff $ + runFilesystem $ + runBaselineStore plan.snapshot.baselineDirectory $ + planReconciliation plan.snapshot.projectRoot manifest selected operations owners + pure (first UpdateReconciliationFailed result) + +-- | Reapply choices gathered after the initial read-only plan to the +-- reconciliation rebuilt after real migration commands. Exact equality is +-- still required afterward, so a command-induced classification or content +-- change remains a stale-plan failure rather than inheriting an old choice. +reapplyPlannedResolutions :: + ReconciliationPlan -> + ReconciliationPlan -> + Either ReconciliationError ReconciliationPlan +reapplyPlannedResolutions planned actual = + foldM reapplyOne actual (Map.toAscList planned.files) + where + reapplyOne actual (path, FileConflict _ _ _ _ _ _ (Just resolved)) = + resolveFileConflict path resolved.choice actual + reapplyOne actual (path, FileOrphanEdited _ _ _ _ (Just choice)) = + resolveEditedOrphan path choice actual + reapplyOne actual _ = Right actual + +runRealMigrations :: UTCTime -> Manifest -> [PlannedUpdateMigration] -> IO (Either UpdateError Manifest) +runRealMigrations now manifest migrations = + runEff $ runFilesystem $ runProcessIO $ go manifest migrations + where + go current [] = pure (Right current) + go current (migration : rest) = do + classified <- classifyMigration current migration.sourcePlan + case classified of + Left err -> pure (Left (UpdateMigrationFailed migration.moduleName err)) + Right executable -> do + executed <- executeMigration False executable current now + case executed of + Left err -> pure (Left (UpdateMigrationFailed migration.moduleName err)) + Right next -> go next rest + +buildFinalManifest :: UTCTime -> UpdatePlan -> Manifest -> [CommandReceipt] -> Manifest +buildFinalManifest now plan filesManifest completedReceipts = + Manifest + { version = currentManifestVersion, + genAt = now, + modules = updateAppliedModules filesManifest.modules filesManifest.applications plan.plannedApplications now, + vars = Map.union candidateVars filesManifest.vars, + files = filesManifest.files, + applications = foldl' (flip replaceAppliedComposition) filesManifest.applications finalApplications, + recipe = updatedRecipe, + blueprint = filesManifest.blueprint, + blueprintMigrations = filesManifest.blueprintMigrations + } + where + finalApplications = map finalizeApplication plan.plannedApplications + finalizeApplication application = + let priorReceipts = maybe Map.empty (.commandReceipts) application.previous + applicationPlan = planCommands plan.request.commandPolicy priorReceipts application.operations + receipts = finalizeCommandReceipts applicationPlan completedReceipts priorReceipts + in setCompositionState application.candidate.instances receipts application.candidate + candidateVars = + Map.unions + [ Map.map (varValueToText . (.value)) values + | application <- plan.plannedApplications, + values <- Map.elems application.resolvedValues + ] + updatedRecipe = + foldl' updateRecipe filesManifest.recipe finalApplications + updateRecipe current application = case application.target of + AppliedRecipeTarget name -> Just AppliedRecipe {name, recipeVersion = application.targetVersion, appliedAt = now} + AppliedModuleTarget _ -> current + +updateAppliedModules :: [AppliedModule] -> [AppliedComposition] -> [PlannedApplication] -> UTCTime -> [AppliedModule] +updateAppliedModules existing recordedApplications applications now = + let modulesInOrder = concatMap (.modulesInOrder) applications + candidateKeys = Set.fromList [(instanceId.instanceModule, instanceId.instanceParentVars) | (instanceId, _, _) <- modulesInOrder] + selectedIds = Set.fromList (map (.candidate.applicationId) applications) + priorSelectedKeys = + Set.fromList + [ (state.name, state.parentVars) + | application <- applications, + previous <- maybeToList application.previous, + state <- previous.instances + ] + protectedKeys = + Set.fromList + [ (state.name, state.parentVars) + | application <- recordedApplications, + Set.notMember application.applicationId selectedIds, + state <- application.instances + ] + replacedOrRemoved key = + Set.member key candidateKeys + || (Set.member key priorSelectedKeys && Set.notMember key protectedKeys) + retained = filter (not . replacedOrRemoved . (\applied -> (applied.name, applied.parentVars))) existing + updated = + [ AppliedModule + { name = instanceId.instanceModule, + parentVars = instanceId.instanceParentVars, + source = publishInstanceDirectory application instanceId, + moduleVersion = modul.version, + appliedAt = now, + removal = modul.removal + } + | (application, instanceId, modul) <- deduplicateInstances applications + ] + in retained <> updated + where + deduplicateInstances = go Set.empty . concatMap expand + where + expand application = + [ (application, instanceId, modul) + | (instanceId, modul, _) <- application.modulesInOrder + ] + go _ [] = [] + go seen (entry@(_, instanceId, _) : rest) + | Set.member key seen = go seen rest + | otherwise = entry : go (Set.insert key seen) rest + where + key = (instanceId.instanceModule, instanceId.instanceParentVars) + + publishInstanceDirectory application instanceId = + case find (\state -> state.name == instanceId.instanceModule && state.parentVars == instanceId.instanceParentVars) application.candidate.instances of + Just state -> state.source + Nothing -> error "candidate application lost a loaded module instance" + +setCompositionState :: [AppliedInstanceState] -> Map CommandFingerprint CommandReceipt -> AppliedComposition -> AppliedComposition +setCompositionState instances receipts composition = + AppliedComposition + { applicationId = composition.applicationId, + target = composition.target, + targetSource = composition.targetSource, + targetVersion = composition.targetVersion, + additionalModules = composition.additionalModules, + namespace = composition.namespace, + context = composition.context, + instances, + commandReceipts = receipts, + appliedAt = composition.appliedAt + } + +publishInstanceSource :: FilePath -> CandidateCatalog -> AppliedInstanceState -> AppliedInstanceState +publishInstanceSource installedDirectory catalog state = + case Map.lookup (CandidateModule, state.name.unModuleName) catalog.artifacts of + Nothing -> state + Just artifact -> + AppliedInstanceState + { name = state.name, + parentVars = state.parentVars, + source = publishedArtifactSource installedDirectory artifact, + moduleVersion = state.moduleVersion, + resolvedVars = state.resolvedVars + } + +publishedArtifactSource :: FilePath -> CandidateArtifact -> FilePath +publishedArtifactSource installedDirectory artifact = + if isJust artifact.sourceUrl + then installedDirectory T.unpack artifact.name + else artifact.originalDirectory + +publishCandidates :: [CandidateArtifact] -> IO (Either UpdateError ()) +publishCandidates artifacts = do + result <- try @SomeException $ + forM_ artifacts $ \artifact -> case artifact.sourceUrl of + Nothing -> pure () + Just sourceUrl -> + installModuleDir + artifact.originalDirectory + (T.unpack artifact.name) + sourceUrl + artifact.repoName + artifact.version + artifact.tags + pure $ first (UpdateCachePublicationFailed . T.pack . displayException) result + +setCommitMarkers :: UpdateTransaction -> Manifest -> IO (Either UpdateError ()) +setCommitMarkers transaction manifest = do + core <- setUpdateTransactionExpectedManifest transaction manifest + case core of + Left err -> pure (Left (UpdateTransactionFailed err)) + Right () -> setServiceExpectedManifest transaction manifest + +writeManifestIO :: FilePath -> Manifest -> IO (Either UpdateError ()) +writeManifestIO path manifest = do + result <- try @SomeException $ runEff $ runFilesystem $ runManifestStore path $ writeManifest manifest + pure $ first (UpdateManifestWriteFailed . T.pack . displayException) result + +readManifestIO :: FilePath -> IO (Either UpdateError Manifest) +readManifestIO path = do + result <- try @SomeException $ runEff $ runFilesystem $ runManifestStore path readManifest + pure $ case result of + Left err -> Left (UpdateManifestUnreadable path (T.pack (displayException err))) + Right (Left err) -> Left (UpdateManifestUnreadable path err) + Right (Right Nothing) -> Left (UpdateManifestMissing path) + Right (Right (Just manifest)) -> Right manifest + +abortUpdate :: UpdateTransaction -> UpdateError -> IO (Either UpdateError a) +abortUpdate transaction original = do + serviceRestore <- restoreServiceBackups transaction + coreRestore <- rollbackUpdateTransaction transaction + pure $ case (serviceRestore, coreRestore) of + (Left restoreError, _) -> Left restoreError + (_, Left restoreError) -> Left (UpdateTransactionFailed restoreError) + _ -> Left original + +finishCommitted :: + UpdateTransaction -> + UpdatePlan -> + Manifest -> + [CommandReceipt] -> + IO (Either UpdateError UpdateResult) +finishCommitted transaction plan manifest completedReceipts = do + completion <- completeUpdateTransaction transaction + pruneResult <- + try @SomeException $ + runEff $ + runFilesystem $ + runBaselineStore plan.snapshot.baselineDirectory $ + pruneBaselines (manifestBaselineRefs manifest) + let cleanupWarnings = case completion of + Left err -> [RecoveryCleanupDeferred (T.pack (show err))] + Right () -> [] + pruneWarnings = case pruneResult of + Left err -> [BaselinePruneFailed (T.pack (displayException err))] + Right _ -> [] + summary = summarizeCommandPlan plan.commandPlan + originalBaselineRefs = manifestBaselineRefs plan.snapshot.originalManifest + finalBaselineRefs = manifestBaselineRefs manifest + changedBaselineRefs = + (originalBaselineRefs Set.\\ finalBaselineRefs) + `Set.union` (finalBaselineRefs Set.\\ originalBaselineRefs) + baselinePaths = + Set.map + (\ref -> ".seihou" "baselines" T.unpack ref.unBaselineRef.unSHA256) + changedBaselineRefs + touched = + plan.snapshot.transactionTargets + `Set.union` baselinePaths + `Set.union` Set.singleton (".seihou" "manifest.json") + pure + ( Right + UpdateResult + { updatedApplications = map (.applicationId) plan.applications, + manifest, + versions = plan.versionChanges, + fileSummary = reconciliationSummary plan.reconciliation, + commandSummary = + CommandSummary + { executed = length completedReceipts, + skippedUnchanged = summary.skippedUnchanged, + skippedDisabled = summary.skippedDisabled + }, + touchedPaths = touched, + warnings = plan.warnings <> cleanupWarnings <> pruneWarnings + } + ) + +recoverAtEntry :: FilePath -> IO (Either UpdateError ()) +recoverAtEntry projectRoot = do + serviceResults <- recoverServiceBackups projectRoot + case [err | Left err <- serviceResults] of + firstFailure : _ -> pure (Left firstFailure) + [] -> do + coreResults <- recoverIncompleteTransactions projectRoot + let failures = [err | Left err <- coreResults] + pure $ if null failures then Right () else Left (UpdateRecoveryFailed failures) + +standardInstalledDirectory :: IO FilePath +standardInstalledDirectory = do + searchPaths <- defaultSearchPaths + pure (last searchPaths) + +dryRunResult :: UpdatePlan -> UpdateResult +dryRunResult plan = + (noOpResult plan) + { versions = plan.versionChanges, + fileSummary = reconciliationSummary plan.reconciliation, + commandSummary = commandSummaryForPlan plan.commandPlan, + warnings = plan.warnings + } + +noOpResult :: UpdatePlan -> UpdateResult +noOpResult plan = + UpdateResult + { updatedApplications = [], + manifest = plan.snapshot.originalManifest, + versions = [], + fileSummary = reconciliationSummary plan.reconciliation, + commandSummary = CommandSummary 0 0 0, + touchedPaths = Set.empty, + warnings = plan.warnings + } + +commandSummaryForPlan :: CommandPlan -> CommandSummary +commandSummaryForPlan commandPlan = + let summary = summarizeCommandPlan commandPlan + in CommandSummary summary.willRun summary.skippedUnchanged summary.skippedDisabled + +isUpdateNoOp :: UpdatePlan -> Bool +isUpdateNoOp plan = + null plan.versionChanges + && null plan.migrations + && plan.inputChanges.overridden == 0 + && plan.inputChanges.newlyResolved == 0 + && plan.inputChanges.removed == 0 + && (summarizeCommandPlan plan.commandPlan).willRun == 0 + && all unchangedFile (Map.elems plan.reconciliation.files) + && and (zipWith sameApplication (mapMaybe (.previous) plan.plannedApplications) plan.applications) + where + unchangedFile FileUnchanged {} = True + unchangedFile _ = False + sameApplication previous candidate = + previous.target == candidate.target + && previous.targetSource == candidate.targetSource + && previous.targetVersion == candidate.targetVersion + && previous.additionalModules == candidate.additionalModules + && previous.namespace == candidate.namespace + && previous.context == candidate.context + && previous.instances == candidate.instances + && previous.commandReceipts == candidate.commandReceipts + +isStructuredNoOp :: UpdatePlan -> Bool +isStructuredNoOp = isUpdateNoOp + +varValueToText :: VarValue -> Text +varValueToText (VText value) = value +varValueToText (VBool True) = "true" +varValueToText (VBool False) = "false" +varValueToText (VInt value) = T.pack (show value) +varValueToText (VList values) = T.intercalate "," (map varValueToText values) diff --git a/src/Seihou/CLI/Update/Interaction.hs b/src/Seihou/CLI/Update/Interaction.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/CLI/Update/Interaction.hs @@ -0,0 +1,170 @@ +module Seihou.CLI.Update.Interaction + ( InteractionMode (..), + InteractionError (..), + ResolutionDecision (..), + applyResolutionDecisions, + forceResolveUpdatePlan, + resolveInteractively, + ) +where + +import Control.Exception (IOException, try) +import Control.Monad (foldM) +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set +import Data.Text qualified as T +import Data.Text.IO qualified as TIO +import Seihou.CLI.Update.Types (UpdatePlan (..)) +import Seihou.Engine.Reconcile + ( FileConflictChoice (..), + FileReconciliation (..), + OrphanChoice (..), + ReconciliationError, + ReconciliationPlan (..), + ReconciliationReason (..), + resolveEditedOrphan, + resolveFileConflict, + unresolvedPaths, + ) +import Seihou.Prelude +import System.IO (hFlush, isEOF, stderr, stdin) + +data InteractionMode = Interactive | NonInteractive + deriving stock (Eq, Show) + +data InteractionError + = InteractionRequired (Set FilePath) + | InteractionAborted FilePath + | InteractionResolutionFailed ReconciliationError + | InteractionInputFailed Text + deriving stock (Eq, Show) + +data ResolutionDecision + = ResolveFile FilePath FileConflictChoice + | ResolveOrphan FilePath OrphanChoice + deriving stock (Eq, Show) + +applyResolutionDecisions :: + [ResolutionDecision] -> + UpdatePlan -> + Either InteractionError UpdatePlan +applyResolutionDecisions decisions plan = do + reconciliation <- foldM applyOne plan.reconciliation decisions + pure plan {reconciliation} + where + applyOne current (ResolveFile path choice) = + first InteractionResolutionFailed (resolveFileConflict path choice current) + applyOne current (ResolveOrphan path choice) = + first InteractionResolutionFailed (resolveEditedOrphan path choice current) + +forceResolveUpdatePlan :: UpdatePlan -> Either InteractionError UpdatePlan +forceResolveUpdatePlan plan = applyResolutionDecisions decisions plan + where + decisions = concatMap forceOne (Map.toAscList plan.reconciliation.files) + forceOne (path, FileConflict _ _ _ reason _ _ Nothing) = case reason of + MergeDriverUnavailable _ -> [] + _ -> [ResolveFile path AcceptGenerated] + forceOne (path, FileOrphanEdited _ _ _ _ Nothing) = + [ResolveOrphan path RetainTrackedOrphan] + forceOne _ = [] + +resolveInteractively :: + InteractionMode -> + UpdatePlan -> + IO (Either InteractionError UpdatePlan) +resolveInteractively mode plan + | Set.null remaining = pure (Right plan) + | mode == NonInteractive = pure (Left (InteractionRequired remaining)) + | otherwise = go plan (Map.toAscList plan.reconciliation.files) + where + remaining = unresolvedPaths plan.reconciliation + go current [] = pure (Right current) + go current ((path, reconciliation) : rest) = case reconciliation of + FileConflict _ currentText markers reason _ _ Nothing -> do + decision <- promptConflict path currentText markers reason + case decision of + Left err -> pure (Left err) + Right choice -> case applyResolutionDecisions [ResolveFile path choice] current of + Left err -> pure (Left err) + Right updated -> go updated rest + FileOrphanEdited _ _ content _ Nothing -> do + decision <- promptOrphan path content + case decision of + Left err -> pure (Left err) + Right choice -> case applyResolutionDecisions [ResolveOrphan path choice] current of + Left err -> pure (Left err) + Right updated -> go updated rest + _ -> go current rest + +promptConflict :: + FilePath -> + Text -> + Text -> + ReconciliationReason -> + IO (Either InteractionError FileConflictChoice) +promptConflict path current markers reason = do + TIO.hPutStrLn stderr ("Conflict: " <> T.pack path <> " (" <> T.pack (show reason) <> ")") + TIO.hPutStrLn stderr " Labels: baseline = previous generated, current = project, generated = candidate" + TIO.hPutStrLn stderr " Diff3 preview:" + TIO.hPutStrLn stderr (indentPreview (if T.null markers then current else markers)) + promptChoice path "Choose [g]enerated, [k]eep current, [m]arkers, [a]bort: " parse + where + parse "g" = Just AcceptGenerated + parse "generated" = Just AcceptGenerated + parse "k" = Just KeepCurrent + parse "keep" = Just KeepCurrent + parse "m" = Just WriteConflictMarkers + parse "markers" = Just WriteConflictMarkers + parse "a" = Nothing + parse "abort" = Nothing + parse _ = Nothing + +promptOrphan :: FilePath -> Text -> IO (Either InteractionError OrphanChoice) +promptOrphan path content = do + TIO.hPutStrLn stderr ("Edited orphan: " <> T.pack path) + TIO.hPutStrLn stderr (indentPreview content) + promptChoice path "Choose [d]elete, [r]etain tracked, [u]nmanage and keep, [a]bort: " parse + where + parse "d" = Just DeleteEditedOrphan + parse "delete" = Just DeleteEditedOrphan + parse "r" = Just RetainTrackedOrphan + parse "retain" = Just RetainTrackedOrphan + parse "u" = Just DetachAndKeepOrphan + parse "unmanage" = Just DetachAndKeepOrphan + parse "a" = Nothing + parse "abort" = Nothing + parse _ = Nothing + +promptChoice :: + FilePath -> + Text -> + (Text -> Maybe a) -> + IO (Either InteractionError a) +promptChoice path prompt parse = loop + where + loop = do + TIO.hPutStr stderr prompt + hFlush stderr + eofResult <- try @IOException isEOF + case eofResult of + Left err -> pure (Left (InteractionInputFailed (T.pack (show err)))) + Right True -> pure (Left (InteractionAborted path)) + Right False -> do + inputResult <- try @IOException TIO.getLine + case inputResult of + Left err -> pure (Left (InteractionInputFailed (T.pack (show err)))) + Right input -> + let normalized = T.toLower (T.strip input) + in if normalized `elem` ["a", "abort"] + then pure (Left (InteractionAborted path)) + else case parse normalized of + Just choice -> pure (Right choice) + _ -> do + TIO.hPutStrLn stderr "Invalid choice; enter one of the displayed letters or words." + loop + +indentPreview :: Text -> Text +indentPreview content = + let shownLines = take 80 (T.lines content) + suffix = if length (T.lines content) > 80 then [" ... preview truncated ..."] else [] + in T.unlines (map (" " <>) shownLines <> suffix) diff --git a/src/Seihou/CLI/Update/Migrations.hs b/src/Seihou/CLI/Update/Migrations.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/CLI/Update/Migrations.hs @@ -0,0 +1,233 @@ +module Seihou.CLI.Update.Migrations + ( StagedMigrations (..), + planAndStageMigrations, + migrationTouchedPaths, + migrationTouchesDirectories, + ) +where + +import Control.Monad (guard) +import Data.List (find) +import Data.Map.Strict qualified as Map +import Data.Maybe (mapMaybe) +import Data.Set qualified as Set +import Data.Text.IO qualified as TIO +import Effectful (runPureEff) +import Seihou.CLI.Update.Types +import Seihou.Composition.Instance (ModuleInstance (..)) +import Seihou.Core.Migration (Migration (..), MigrationOp (..), MigrationPlan (..), planMigrationChain) +import Seihou.Core.Types +import Seihou.Core.Version (parseVersion) +import Seihou.Effect.FilesystemPure (PureFS (..), runFilesystemPure) +import Seihou.Effect.ProcessPure (ProcessMock (..), runProcessPure) +import Seihou.Engine.Migrate + ( ExecutedMigrationPlan (..), + MigrationOpInstance (..), + classifyMigration, + executeMigration, + ) +import Seihou.Prelude +import System.Directory qualified as Directory +import System.Exit (ExitCode (..)) +import System.FilePath (takeDirectory) + +data StagedMigrations = StagedMigrations + { plans :: [PlannedUpdateMigration], + manifest :: Manifest, + filesystem :: PureFS, + warnings :: [UpdateWarning] + } + deriving stock (Eq, Show) + +data Transition = Transition + { moduleName :: ModuleName, + originUrl :: Maybe Text, + fromVersion :: Text, + toVersion :: Text, + candidateModule :: Module, + sourceDirectory :: FilePath + } + +-- | Deduplicate equal module transitions and simulate them against a complete +-- snapshot of tracked project text. Shell commands are mocked as successful +-- and retained as explicit warnings for the real apply/revalidation phase. +planAndStageMigrations :: + FilePath -> + Manifest -> + CandidateCatalog -> + [(Maybe AppliedComposition, [(ModuleInstance, Module, FilePath)])] -> + IO (Either UpdateError StagedMigrations) +planAndStageMigrations projectRoot manifest catalog applications = do + initialFilesystem <- snapshotTrackedFiles projectRoot manifest + pure $ do + transitions <- collectTransitions catalog applications + planned <- traverse planTransition (deduplicateTransitions transitions) + let processMocks = concatMap commandMocks planned + ((stageResult, finalFilesystem)) = + runPureEff $ + runFilesystemPure initialFilesystem $ + runProcessPure processMocks $ + stageAll manifest [] planned + (finalManifest, stagedPlans) <- stageResult + let warnings = + [ MigrationCommandNotSimulated plannedMigration.moduleName command + | plannedMigration <- stagedPlans, + RunCommandInst command _ <- plannedMigration.stagedPlan.planOps + ] + Right + StagedMigrations + { plans = stagedPlans, + manifest = finalManifest, + filesystem = finalFilesystem, + warnings + } + +stageAll manifest completed [] = pure (Right (manifest, reverse completed)) +stageAll manifest completed ((transition, sourcePlan) : rest) = do + classified <- classifyMigration manifest sourcePlan + case classified of + Left err -> pure (Left (UpdateMigrationStageFailed transition.moduleName err)) + Right stagedPlan -> do + executed <- executeMigration False stagedPlan manifest manifest.genAt + case executed of + Left err -> pure (Left (UpdateMigrationStageFailed transition.moduleName err)) + Right nextManifest -> + let planned = + PlannedUpdateMigration + { moduleName = transition.moduleName, + sourceDirectory = transition.sourceDirectory, + sourcePlan, + stagedPlan, + containsCommands = any isCommand stagedPlan.planOps + } + in stageAll nextManifest (planned : completed) rest + where + isCommand RunCommandInst {} = True + isCommand _ = False + +collectTransitions :: + CandidateCatalog -> + [(Maybe AppliedComposition, [(ModuleInstance, Module, FilePath)])] -> + Either UpdateError [Transition] +collectTransitions catalog applications = do + let raw = concatMap applicationTransitions applications + priorByModule = + Map.fromListWith + Set.union + [ ((transition.moduleName, transition.originUrl), Set.singleton transition.fromVersion) + | transition <- raw + ] + case [ (name, Set.toAscList versions) + | ((name, _), versions) <- Map.toAscList priorByModule, + Set.size versions > 1 + ] of + (name, versions) : _ -> Left (UpdateConflictingPriorVersions name versions) + [] -> Right raw + where + applicationTransitions (Nothing, _) = [] + applicationTransitions (Just previous, candidates) = + mapMaybe (transitionFor previous) candidates + + transitionFor previous (instanceId, candidateModule, sourceDirectory) = do + prior <- find (matches instanceId) previous.instances + fromVersion <- prior.moduleVersion + toVersion <- candidateModule.version + guard (fromVersion /= toVersion) + let artifact = Map.lookup (CandidateModule, candidateModule.name.unModuleName) catalog.artifacts + pure + Transition + { moduleName = candidateModule.name, + originUrl = artifact >>= (.sourceUrl), + fromVersion, + toVersion, + candidateModule, + sourceDirectory + } + + matches instanceId state = + state.name == instanceId.instanceModule + && state.parentVars == instanceId.instanceParentVars + +deduplicateTransitions :: [Transition] -> [Transition] +deduplicateTransitions = go Set.empty + where + go _ [] = [] + go seen (transition : rest) + | Set.member (transitionKey transition) seen = go seen rest + | otherwise = transition : go (Set.insert (transitionKey transition) seen) rest + + transitionKey transition = + ( transition.moduleName, + transition.originUrl, + transition.fromVersion, + transition.toVersion + ) + +planTransition :: Transition -> Either UpdateError (Transition, MigrationPlan) +planTransition transition = do + fromVersion <- + maybe + (Left (CandidateVersionInvalid transition.moduleName.unModuleName transition.fromVersion)) + Right + (parseVersion transition.fromVersion) + toVersion <- + maybe + (Left (CandidateVersionInvalid transition.moduleName.unModuleName transition.toVersion)) + Right + (parseVersion transition.toVersion) + planned <- + first + (UpdateMigrationPlanFailed transition.moduleName) + (planMigrationChain transition.moduleName.unModuleName transition.candidateModule.migrations fromVersion toVersion) + case planned of + Nothing -> error "planTransition received unequal versions but no migration plan" + Just sourcePlan -> Right (transition, sourcePlan) + +commandMocks :: (Transition, MigrationPlan) -> [ProcessMock] +commandMocks (_, sourcePlan) = + [ ProcessMock + { mockCommand = "/bin/sh", + mockArgs = ["-c", command], + mockResult = (ExitSuccess, "", "") + } + | migration <- sourcePlan.planSteps, + RunCommand command _ <- migration.ops + ] + +snapshotTrackedFiles :: FilePath -> Manifest -> IO PureFS +snapshotTrackedFiles projectRoot manifest = do + files <- fmap Map.fromList . fmap concat $ traverse readTracked (Map.keys manifest.files) + let directories = + Set.fromList + [ directory + | path <- Map.keys files, + directory <- parents path + ] + pure PureFS {files, dirs = directories} + where + readTracked path = do + let fullPath = projectRoot path + exists <- Directory.doesFileExist fullPath + if exists + then do + content <- TIO.readFile fullPath + pure [(path, content)] + else pure [] + + parents path = takeWhile (\directory -> directory /= "." && directory /= "") (iterate takeDirectory (takeDirectory path)) + +migrationTouchedPaths :: [PlannedUpdateMigration] -> Set FilePath +migrationTouchedPaths = Set.fromList . concatMap (concatMap touched . (.stagedPlan.planOps)) + where + touched (MoveFileInst source destination _) = [source, destination] + touched (MoveDirInst source destination) = [source, destination] + touched (DeleteFileInst path _) = [path] + touched (DeleteDirInst path) = [path] + touched RunCommandInst {} = [] + +migrationTouchesDirectories :: PlannedUpdateMigration -> Bool +migrationTouchesDirectories migration = any touchesDirectory migration.stagedPlan.planOps + where + touchesDirectory MoveDirInst {} = True + touchesDirectory DeleteDirInst {} = True + touchesDirectory _ = False diff --git a/src/Seihou/CLI/Update/Recovery.hs b/src/Seihou/CLI/Update/Recovery.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/CLI/Update/Recovery.hs @@ -0,0 +1,278 @@ +module Seihou.CLI.Update.Recovery + ( prepareServiceBackups, + setServiceExpectedManifest, + restoreServiceBackups, + recoverServiceBackups, + ) +where + +import Control.Exception (SomeException, displayException, try) +import Control.Monad (forM, forM_, unless, when) +import Data.Aeson (FromJSON (..), ToJSON (..), (.:), (.:?), (.=)) +import Data.Aeson qualified as Aeson +import Data.ByteString.Lazy qualified as LBS +import Data.List (isPrefixOf, sortOn) +import Data.Maybe (catMaybes, isJust) +import Data.Ord (Down (..)) +import Data.Set qualified as Set +import Data.Text qualified as T +import Seihou.CLI.Update.Types +import Seihou.Core.Path (validateProjectRelativePath) +import Seihou.Core.Types +import Seihou.Engine.Migrate (ExecutedMigrationPlan (..), MigrationOpInstance (..)) +import Seihou.Engine.UpdateTransaction (UpdateTransaction (..)) +import Seihou.Manifest.Types (manifestFromJSON) +import Seihou.Prelude +import System.Directory qualified as Directory +import System.FilePath (splitDirectories, takeDirectory, takeFileName) + +data BackupScope = ProjectDirectory | InstalledArtifact + deriving stock (Eq, Show) + +data ServiceBackup = ServiceBackup + { scope :: BackupScope, + target :: FilePath, + backupName :: Maybe FilePath + } + deriving stock (Eq, Show) + +data ServiceJournal = ServiceJournal + { version :: Int, + installedRoot :: FilePath, + entries :: [ServiceBackup], + expectedManifest :: Maybe Manifest + } + deriving stock (Eq, Show) + +instance ToJSON BackupScope where + toJSON ProjectDirectory = Aeson.String "project-directory" + toJSON InstalledArtifact = Aeson.String "installed-artifact" + +instance FromJSON BackupScope where + parseJSON = Aeson.withText "BackupScope" $ \case + "project-directory" -> pure ProjectDirectory + "installed-artifact" -> pure InstalledArtifact + other -> fail ("unknown backup scope: " <> T.unpack other) + +instance ToJSON ServiceBackup where + toJSON entry = + Aeson.object + [ "scope" .= entry.scope, + "target" .= entry.target, + "backup" .= entry.backupName + ] + +instance FromJSON ServiceBackup where + parseJSON = Aeson.withObject "ServiceBackup" $ \object -> + ServiceBackup <$> object .: "scope" <*> object .: "target" <*> object .:? "backup" + +instance ToJSON ServiceJournal where + toJSON journal = + Aeson.object + [ "version" .= journal.version, + "installedRoot" .= journal.installedRoot, + "entries" .= journal.entries, + "expectedManifest" .= journal.expectedManifest + ] + +instance FromJSON ServiceJournal where + parseJSON = Aeson.withObject "ServiceJournal" $ \object -> do + version <- object .: "version" + unless (version == (1 :: Int)) (fail "unsupported service journal version") + ServiceJournal + <$> pure version + <*> object .: "installedRoot" + <*> object .: "entries" + <*> object .:? "expectedManifest" + +-- | Persist byte-for-byte backups for whole migration directories and shared +-- cache destinations inside EP-66's transaction directory. The companion +-- recovery pass runs before EP-66 recovery and uses the same manifest commit +-- boundary. +prepareServiceBackups :: + UpdateTransaction -> + FilePath -> + [PlannedUpdateMigration] -> + [CandidateArtifact] -> + IO (Either UpdateError ()) +prepareServiceBackups transaction installedRoot migrations artifacts = do + let projectDirectories = normalizeDirectories (concatMap migrationDirectories migrations) + installedNames = + Set.toAscList . Set.fromList $ + [ T.unpack artifact.name + | artifact <- artifacts, + isJust artifact.sourceUrl + ] + requests = + map (ProjectDirectory,) projectDirectories + <> map (InstalledArtifact,) installedNames + backupRoot = transaction.transactionDirectory "service-backups" + result <- try @SomeException $ do + Directory.createDirectoryIfMissing True backupRoot + entries <- forM (zip [0 :: Int ..] requests) $ \(index, (scope, target)) -> do + fullTarget <- resolveTarget transaction.projectRoot installedRoot scope target + exists <- Directory.doesDirectoryExist fullTarget + if exists + then do + let backupName = show index + backupPath = backupRoot backupName + copyDirectoryBytes fullTarget backupPath + pure ServiceBackup {scope, target, backupName = Just backupName} + else pure ServiceBackup {scope, target, backupName = Nothing} + writeServiceJournal + transaction.transactionDirectory + ServiceJournal + { version = 1, + installedRoot, + entries, + expectedManifest = Nothing + } + pure $ first (UpdateCachePublicationFailed . T.pack . displayException) result + +setServiceExpectedManifest :: UpdateTransaction -> Manifest -> IO (Either UpdateError ()) +setServiceExpectedManifest transaction expected = do + current <- readServiceJournal transaction.transactionDirectory + case current of + Left err -> pure (Left err) + Right Nothing -> pure (Right ()) + Right (Just journal) -> do + result <- + try @SomeException $ + writeServiceJournal + transaction.transactionDirectory + journal {expectedManifest = Just expected} + pure $ first (UpdateManifestWriteFailed . T.pack . displayException) result + +restoreServiceBackups :: UpdateTransaction -> IO (Either UpdateError ()) +restoreServiceBackups transaction = do + current <- readServiceJournal transaction.transactionDirectory + case current of + Left err -> pure (Left err) + Right Nothing -> pure (Right ()) + Right (Just journal) -> restoreJournal transaction.projectRoot transaction.transactionDirectory journal + +-- | Restore or accept every service journal before the core transaction +-- recovery pass. A durable matching manifest means cache/directory publication +-- committed; every other state restores the byte backups. +recoverServiceBackups :: FilePath -> IO [Either UpdateError ()] +recoverServiceBackups projectRoot = do + let transactionsRoot = projectRoot ".seihou" "transactions" + exists <- Directory.doesDirectoryExist transactionsRoot + if not exists + then pure [] + else do + names <- Directory.listDirectory transactionsRoot + fmap catMaybes . forM names $ \name -> do + let transactionDirectory = transactionsRoot name + isDirectory <- Directory.doesDirectoryExist transactionDirectory + if not isDirectory + then pure Nothing + else do + current <- readServiceJournal transactionDirectory + case current of + Left err -> pure (Just (Left err)) + Right Nothing -> pure Nothing + Right (Just journal) -> do + committed <- manifestMatches projectRoot journal.expectedManifest + if committed + then pure (Just (Right ())) + else Just <$> restoreJournal projectRoot transactionDirectory journal + +restoreJournal :: FilePath -> FilePath -> ServiceJournal -> IO (Either UpdateError ()) +restoreJournal projectRoot transactionDirectory journal = do + result <- try @SomeException $ + forM_ (sortOn (Down . pathDepth . (.target)) journal.entries) $ \entry -> do + fullTarget <- resolveTarget projectRoot journal.installedRoot entry.scope entry.target + targetExists <- Directory.doesPathExist fullTarget + when targetExists (Directory.removePathForcibly fullTarget) + case entry.backupName of + Nothing -> pure () + Just backupName -> do + validateBackupName backupName + copyDirectoryBytes (transactionDirectory "service-backups" backupName) fullTarget + pure $ first (UpdateCachePublicationFailed . T.pack . displayException) result + +resolveTarget :: FilePath -> FilePath -> BackupScope -> FilePath -> IO FilePath +resolveTarget projectRoot _ ProjectDirectory target = + case validateProjectRelativePath (T.pack target) of + Left reason -> ioError (userError ("unsafe project backup path: " <> T.unpack reason)) + Right safe + | safe == "." || targetsControlPath safe -> ioError (userError "unsafe project backup target") + | otherwise -> pure (projectRoot safe) +resolveTarget _ installedRoot InstalledArtifact target + | takeFileName target == target && target /= "." && target /= ".." = pure (installedRoot target) + | otherwise = ioError (userError "unsafe installed artifact backup target") + +validateBackupName :: FilePath -> IO () +validateBackupName name + | takeFileName name == name && name /= "." && name /= ".." = pure () + | otherwise = ioError (userError "unsafe service backup name") + +targetsControlPath :: FilePath -> Bool +targetsControlPath path = case splitDirectories path of + first : _ -> first == ".seihou" || first == ".git" + [] -> False + +migrationDirectories :: PlannedUpdateMigration -> [FilePath] +migrationDirectories migration = concatMap directories migration.stagedPlan.planOps + where + directories (MoveDirInst source destination) = [source, destination] + directories (DeleteDirInst path) = [path] + directories _ = [] + +normalizeDirectories :: [FilePath] -> [FilePath] +normalizeDirectories paths = filter notCovered sorted + where + sorted = sortOn pathDepth (Set.toAscList (Set.fromList paths)) + notCovered path = not (any (isParentOf path) sorted) + isParentOf child parent = + parent /= child + && splitDirectories parent `isPrefixOf` splitDirectories child + +pathDepth :: FilePath -> Int +pathDepth = length . splitDirectories + +copyDirectoryBytes :: FilePath -> FilePath -> IO () +copyDirectoryBytes source destination = do + Directory.createDirectoryIfMissing True destination + names <- Directory.listDirectory source + forM_ names $ \name -> do + let sourcePath = source name + destinationPath = destination name + isDirectory <- Directory.doesDirectoryExist sourcePath + if isDirectory + then copyDirectoryBytes sourcePath destinationPath + else Directory.copyFile sourcePath destinationPath + +writeServiceJournal :: FilePath -> ServiceJournal -> IO () +writeServiceJournal transactionDirectory journal = do + let path = serviceJournalPath transactionDirectory + temporaryPath = path <> ".tmp" + LBS.writeFile temporaryPath (Aeson.encode journal) + Directory.renamePath temporaryPath path + +readServiceJournal :: FilePath -> IO (Either UpdateError (Maybe ServiceJournal)) +readServiceJournal transactionDirectory = do + let path = serviceJournalPath transactionDirectory + exists <- Directory.doesFileExist path + if not exists + then pure (Right Nothing) + else do + result <- try @SomeException (LBS.readFile path) + pure $ case result of + Left err -> Left (UpdateCachePublicationFailed (T.pack (displayException err))) + Right bytes -> first (UpdateCachePublicationFailed . T.pack) (Just <$> Aeson.eitherDecode bytes) + +serviceJournalPath :: FilePath -> FilePath +serviceJournalPath transactionDirectory = transactionDirectory "service-journal.json" + +manifestMatches :: FilePath -> Maybe Manifest -> IO Bool +manifestMatches _ Nothing = pure False +manifestMatches projectRoot (Just expected) = do + let path = projectRoot ".seihou" "manifest.json" + exists <- Directory.doesFileExist path + if not exists + then pure False + else do + bytes <- LBS.readFile path + pure (manifestFromJSON bytes == Right expected) diff --git a/src/Seihou/CLI/Update/Render.hs b/src/Seihou/CLI/Update/Render.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/CLI/Update/Render.hs @@ -0,0 +1,396 @@ +module Seihou.CLI.Update.Render + ( UpdateOutput (..), + UpdatePlanView, + UpdateResultView, + UpdateErrorView, + planOutput, + resultOutput, + errorOutput, + renderUpdateHuman, + encodeUpdateOutput, + ) +where + +import Data.Aeson (Value, encode, object, (.=)) +import Data.ByteString.Lazy (ByteString) +import Data.Map.Strict qualified as Map +import Data.Maybe (fromMaybe) +import Data.Set qualified as Set +import Data.Text qualified as T +import Seihou.CLI.CommandExecution + ( CommandDisposition (..), + CommandPlan (..), + CommandPlanSummary (..), + PlannedCommand (..), + summarizeCommandPlan, + ) +import Seihou.CLI.Update.Types +import Seihou.Core.Migration (MigrationPlan (..)) +import Seihou.Core.Types + ( ApplicationId (..), + AppliedComposition (..), + AppliedTarget (..), + BaselineRef (..), + CommandFingerprint (..), + ModuleName (..), + Operation (..), + RecipeName (..), + SHA256 (..), + VarName (..), + ) +import Seihou.Engine.Reconcile + ( DesiredFile (..), + FileConflictChoice (..), + FileReconciliation (..), + OrphanChoice (..), + ReconciliationPlan (..), + ReconciliationSummary (..), + ResolvedFileConflict (..), + reconciliationSummary, + ) +import Seihou.Prelude + +newtype UpdatePlanView = UpdatePlanView UpdatePlan + +newtype UpdateResultView = UpdateResultView UpdateResult + +newtype UpdateErrorView = UpdateErrorView UpdateError + +data UpdateOutput + = UpdatePlanOutput UpdatePlanView + | UpdateAppliedOutput UpdateResultView + | UpdateFailedOutput UpdateErrorView + +planOutput :: UpdatePlan -> UpdateOutput +planOutput = UpdatePlanOutput . UpdatePlanView + +resultOutput :: UpdateResult -> UpdateOutput +resultOutput = UpdateAppliedOutput . UpdateResultView + +errorOutput :: UpdateError -> UpdateOutput +errorOutput = UpdateFailedOutput . UpdateErrorView + +renderUpdateHuman :: Bool -> UpdateOutput -> Text +renderUpdateHuman _ (UpdatePlanOutput (UpdatePlanView plan)) = + T.unlines $ + versionLines plan + <> [ renderInputs plan.inputChanges, + "Migrations: " <> count (length plan.migrations) <> migrationCaveat plan, + renderFiles (reconciliationSummary plan.reconciliation), + renderCommands (summarizeCommandPlan plan.commandPlan) + ] + <> conflictLines plan.reconciliation + <> warningLines plan.warnings +renderUpdateHuman _ (UpdateAppliedOutput (UpdateResultView result)) = + T.unlines $ + [ "Updated " <> count (length result.updatedApplications) <> " application(s).", + renderFiles result.fileSummary, + "Commands: " + <> count result.commandSummary.executed + <> " executed; " + <> count result.commandSummary.skippedUnchanged + <> " unchanged skipped; " + <> count result.commandSummary.skippedDisabled + <> " disabled" + ] + <> warningLines result.warnings +renderUpdateHuman _ (UpdateFailedOutput (UpdateErrorView err)) = + "Update failed [" <> errorCode err <> "]: " <> errorMessage err <> "\n" + +encodeUpdateOutput :: UpdateOutput -> ByteString +encodeUpdateOutput = encode . outputValue + +outputValue :: UpdateOutput -> Value +outputValue (UpdatePlanOutput (UpdatePlanView plan)) = + object + [ "schemaVersion" .= (1 :: Int), + "outcome" .= ("plan" :: Text), + "alreadyUpToDate" .= planLooksUnchanged plan, + "applications" .= map applicationIdText plan.applications, + "versions" .= map versionValue plan.versionChanges, + "inputs" .= inputValue plan.inputChanges, + "migrations" .= map migrationValue plan.migrations, + "files" .= map fileValue (Map.toAscList plan.reconciliation.files), + "commands" .= map commandValue plan.commandPlan.commands, + "warnings" .= map warningText plan.warnings + ] +outputValue (UpdateAppliedOutput (UpdateResultView result)) = + object + [ "schemaVersion" .= (1 :: Int), + "outcome" .= ("applied" :: Text), + "applications" .= map (.unApplicationId) result.updatedApplications, + "versions" .= map versionValue result.versions, + "files" .= summaryValue result.fileSummary, + "commands" + .= object + [ "executed" .= result.commandSummary.executed, + "skippedUnchanged" .= result.commandSummary.skippedUnchanged, + "skippedDisabled" .= result.commandSummary.skippedDisabled + ], + "touchedPaths" .= Set.toAscList result.touchedPaths, + "warnings" .= map warningText result.warnings + ] +outputValue (UpdateFailedOutput (UpdateErrorView err)) = + object + [ "schemaVersion" .= (1 :: Int), + "outcome" .= ("error" :: Text), + "error" .= object ["code" .= errorCode err, "message" .= errorMessage err] + ] + +versionLines :: UpdatePlan -> [Text] +versionLines plan + | null plan.versionChanges = ["Versions: unchanged"] + | otherwise = map renderVersionChange plan.versionChanges + +renderVersionChange :: VersionChange -> Text +renderVersionChange change = + change.name + <> " " + <> fromMaybe "unversioned" change.fromVersion + <> " -> " + <> fromMaybe "unversioned" change.toVersion + <> if change.sameVersionContentChanged then " (content changed at same version)" else "" + +renderInputs :: InputChangeSummary -> Text +renderInputs summary = + "Inputs: " + <> count summary.reused + <> " reused; " + <> count summary.overridden + <> " overridden; " + <> count summary.newlyResolved + <> " newly resolved; " + <> count summary.removed + <> " removed" + +renderFiles :: ReconciliationSummary -> Text +renderFiles summary = + "Files: " + <> count summary.creates + <> " created; " + <> count summary.updates + <> " updated; " + <> count summary.merged + <> " merged; " + <> count summary.unchanged + <> " unchanged; " + <> count summary.conflicts + <> " conflicts; " + <> count summary.safeDeletes + <> " deleted; " + <> count summary.editedOrphans + <> " edited orphans" + +renderCommands summary = + "Commands: " + <> count summary.willRun + <> " will run; " + <> count summary.skippedUnchanged + <> " unchanged skipped; " + <> count summary.skippedDisabled + <> " disabled" + +migrationCaveat plan + | any (.containsCommands) plan.migrations = " (includes non-simulatable commands)" + | otherwise = "" + +conflictLines :: ReconciliationPlan -> [Text] +conflictLines reconciliation = concatMap renderOne (Map.toAscList reconciliation.files) + where + renderOne (path, FileConflict _ _ _ reason _ _ resolution) = + [ "Conflict: " + <> T.pack path + <> " (" + <> T.pack (show reason) + <> maybe "; unresolved" (("; " <>) . resolutionText . (.choice)) resolution + <> ")" + ] + renderOne (path, FileOrphanEdited _ _ _ _ choice) = + [ "Orphan: " + <> T.pack path + <> maybe " (unresolved)" ((" (" <>) . (<> ")") . orphanChoiceText) choice + ] + renderOne _ = [] + +warningLines :: [UpdateWarning] -> [Text] +warningLines = map (("Warning: " <>) . warningText) + +versionValue :: VersionChange -> Value +versionValue change = + object + [ "name" .= change.name, + "from" .= change.fromVersion, + "to" .= change.toVersion, + "sameVersionContentChanged" .= change.sameVersionContentChanged + ] + +inputValue :: InputChangeSummary -> Value +inputValue summary = + object + [ "reused" .= summary.reused, + "overridden" .= summary.overridden, + "newlyResolved" .= summary.newlyResolved, + "removed" .= summary.removed, + "ambiguousLegacy" .= map (.unVarName) summary.ambiguousLegacy + ] + +migrationValue :: PlannedUpdateMigration -> Value +migrationValue migration = + object + [ "module" .= migration.moduleName.unModuleName, + "from" .= showText migration.sourcePlan.planFrom, + "to" .= showText migration.sourcePlan.planTo, + "steps" .= length migration.sourcePlan.planSteps, + "containsCommands" .= migration.containsCommands + ] + +fileValue :: (FilePath, FileReconciliation) -> Value +fileValue (path, reconciliation) = + object + [ "path" .= path, + "classification" .= classification reconciliation, + "resolution" .= resolutionFor reconciliation + ] + +classification :: FileReconciliation -> Text +classification FileCreate {} = "create" +classification FileUpdate {} = "update" +classification FileAutoMerge {} = "autoMerge" +classification FileUnchanged {} = "unchanged" +classification FileConflict {} = "conflict" +classification FileDeleteSafe {} = "safeDelete" +classification FileOrphanEdited {} = "editedOrphan" +classification FileReleaseSharedOwnership {} = "releaseSharedOwnership" +classification FileAlreadyAbsent {} = "alreadyAbsent" + +resolutionFor :: FileReconciliation -> Maybe Text +resolutionFor (FileConflict _ _ _ _ _ _ resolution) = resolutionText . (.choice) <$> resolution +resolutionFor (FileOrphanEdited _ _ _ _ choice) = orphanChoiceText <$> choice +resolutionFor _ = Nothing + +commandValue :: PlannedCommand -> Value +commandValue planned = + object + [ "fingerprint" .= fingerprintText planned.fingerprint, + "status" .= dispositionText planned.disposition, + "module" .= commandModule planned.operation, + "command" .= commandText planned.operation + ] + +commandModule :: Operation -> Maybe Text +commandModule RunCommandOp {moduleName} = Just moduleName.unModuleName +commandModule _ = Nothing + +commandText :: Operation -> Maybe Text +commandText RunCommandOp {command} = Just command +commandText _ = Nothing + +dispositionText :: CommandDisposition -> Text +dispositionText CommandWillRun = "willRun" +dispositionText CommandSkippedUnchanged = "skippedUnchanged" +dispositionText CommandSkippedDisabled = "skippedDisabled" + +resolutionText :: FileConflictChoice -> Text +resolutionText AcceptGenerated = "useGenerated" +resolutionText KeepCurrent = "keepCurrent" +resolutionText WriteConflictMarkers = "writeConflictMarkers" +resolutionText AbortUpdate = "abort" + +orphanChoiceText :: OrphanChoice -> Text +orphanChoiceText DeleteEditedOrphan = "delete" +orphanChoiceText RetainTrackedOrphan = "retainTracked" +orphanChoiceText DetachAndKeepOrphan = "detachAndKeep" +orphanChoiceText AbortOrphanUpdate = "abort" + +summaryValue :: ReconciliationSummary -> Value +summaryValue summary = + object + [ "created" .= summary.creates, + "updated" .= summary.updates, + "merged" .= summary.merged, + "unchanged" .= summary.unchanged, + "conflicts" .= summary.conflicts, + "safeDeletes" .= summary.safeDeletes, + "editedOrphans" .= summary.editedOrphans, + "sharedOwnership" .= summary.sharedOwnership + ] + +applicationIdText :: AppliedComposition -> Text +applicationIdText application = application.applicationId.unApplicationId + +fingerprintText :: CommandFingerprint -> Text +fingerprintText (CommandFingerprint (SHA256 value)) = value + +warningText :: UpdateWarning -> Text +warningText = T.pack . show + +errorCode :: UpdateError -> Text +errorCode UpdateManifestMissing {} = "manifest_missing" +errorCode UpdateManifestUnreadable {} = "manifest_unreadable" +errorCode NoRecordedApplications = "no_recorded_applications" +errorCode LegacyUpdateRequiresOneTarget = "legacy_update_requires_one_target" +errorCode UpdateTargetNotFound {} = "target_not_found" +errorCode SharedPathRequiresApplications {} = "shared_path_requires_applications" +errorCode CandidateCloneFailed {} = "candidate_clone_failed" +errorCode CandidateRepositoryInvalid {} = "candidate_repository_invalid" +errorCode CandidateArtifactMissing {} = "candidate_artifact_missing" +errorCode CandidateArtifactAmbiguous {} = "candidate_artifact_ambiguous" +errorCode CandidateLoadFailed {} = "candidate_load_failed" +errorCode CandidateDowngrade {} = "candidate_downgrade" +errorCode CandidateVersionInvalid {} = "candidate_version_invalid" +errorCode UpdateConflictingPriorVersions {} = "conflicting_prior_versions" +errorCode UpdateVariableErrors {} = "variable_errors" +errorCode UpdateConfigurationFailed {} = "configuration_failed" +errorCode UpdateMigrationPlanFailed {} = "migration_plan_failed" +errorCode UpdateMigrationStageFailed {} = "migration_stage_failed" +errorCode UpdateCompositionFailed {} = "composition_failed" +errorCode UpdateReconciliationFailed {} = "reconciliation_failed" +errorCode UpdateHasUnresolvedPaths {} = "unresolved_paths" +errorCode UpdateRecoveryFailed {} = "recovery_failed" +errorCode UpdatePlanStale {} = "plan_stale" +errorCode UpdateTransactionFailed {} = "transaction_failed" +errorCode UpdateMigrationFailed {} = "migration_failed" +errorCode UpdateChangedAfterMigrationCommand {} = "changed_after_migration_command" +errorCode UpdateCommandFailed {} = "command_failed" +errorCode UpdateCachePublicationFailed {} = "cache_publication_failed" +errorCode UpdateManifestWriteFailed {} = "manifest_write_failed" + +errorMessage :: UpdateError -> Text +errorMessage (UpdateManifestMissing path) = + "No Seihou manifest was found at " <> T.pack path <> ". Run seihou run first." +errorMessage (UpdateTargetNotFound target available) = + "No recorded application matches '" + <> target + <> "'. Available targets: " + <> T.intercalate ", " available +errorMessage (SharedPathRequiresApplications path selected required) = + "Path " + <> T.pack path + <> " is also owned by application(s) " + <> T.intercalate ", " (map (.unApplicationId) (Set.toAscList required)) + <> ". Select every owner or run seihou update with no targets. Selected: " + <> T.intercalate ", " (map (.unApplicationId) (Set.toAscList selected)) +errorMessage (UpdateHasUnresolvedPaths paths) = + "Resolve these paths before apply: " <> T.intercalate ", " (map T.pack (Set.toAscList paths)) +errorMessage (UpdatePlanStale paths) = + "The project changed after planning: " <> T.intercalate ", " (map T.pack (Set.toAscList paths)) +errorMessage err = T.pack (show err) + +planLooksUnchanged :: UpdatePlan -> Bool +planLooksUnchanged plan = + null plan.versionChanges + && null plan.migrations + && plan.inputChanges.overridden == 0 + && plan.inputChanges.newlyResolved == 0 + && plan.inputChanges.removed == 0 + && (summarizeCommandPlan plan.commandPlan).willRun == 0 + && all isUnchanged (Map.elems plan.reconciliation.files) + where + isUnchanged FileUnchanged {} = True + isUnchanged _ = False + +count :: Int -> Text +count = T.pack . show + +showText :: (Show a) => a -> Text +showText = T.pack . show diff --git a/src/Seihou/CLI/Update/Selection.hs b/src/Seihou/CLI/Update/Selection.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/CLI/Update/Selection.hs @@ -0,0 +1,85 @@ +module Seihou.CLI.Update.Selection + ( SelectedApplications (..), + selectApplications, + targetName, + availableTargets, + ) +where + +import Control.Monad (foldM) +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set +import Seihou.CLI.Update.Types +import Seihou.Core.Types +import Seihou.Prelude + +data SelectedApplications + = RecordedSelection [AppliedComposition] + | LegacySelection Text + deriving stock (Eq, Show) + +-- | Select applications in manifest order. Bare module names select every +-- recorded application containing that module instance; target names take +-- precedence for each requested name. +selectApplications :: UpdateSelection -> Manifest -> Either UpdateError SelectedApplications +selectApplications selection manifest = case selection of + AllRecordedApplications + | null manifest.applications -> Left NoRecordedApplications + | otherwise -> Right (RecordedSelection manifest.applications) + NamedUpdateTargets names + | null manifest.applications -> case nubOrd names of + [name] -> Right (LegacySelection name) + _ -> Left LegacyUpdateRequiresOneTarget + | otherwise -> do + selectedIds <- foldM selectName Set.empty (nubOrd names) + let selected = filter ((`Set.member` selectedIds) . (.applicationId)) manifest.applications + ensureOwnershipClosure manifest selectedIds + Right (RecordedSelection selected) + where + selectName selected name = + let exact = filter ((== name) . targetName) manifest.applications + matches = + if null exact + then filter (containsModule name) manifest.applications + else exact + in if null matches + then Left (UpdateTargetNotFound name (availableTargets manifest)) + else Right (foldl' (flip (Set.insert . (.applicationId))) selected matches) + +ensureOwnershipClosure :: Manifest -> Set ApplicationId -> Either UpdateError () +ensureOwnershipClosure manifest selected = + case [ (path, selectedOwners, missingOwners) + | (path, record) <- Map.toAscList manifest.files, + let selectedOwners = Set.intersection selected record.applicationIds, + let missingOwners = record.applicationIds Set.\\ selected, + not (Set.null selectedOwners), + not (Set.null missingOwners) + ] of + (path, selectedOwners, missingOwners) : _ -> + Left (SharedPathRequiresApplications path selectedOwners missingOwners) + [] -> Right () + +targetName :: AppliedComposition -> Text +targetName application = case application.target of + AppliedModuleTarget name -> name.unModuleName + AppliedRecipeTarget name -> name.unRecipeName + +availableTargets :: Manifest -> [Text] +availableTargets manifest = nubOrd (map targetName manifest.applications <> instanceNames) + where + instanceNames = + [ state.name.unModuleName + | application <- manifest.applications, + state <- application.instances + ] + +containsModule :: Text -> AppliedComposition -> Bool +containsModule name = any ((== name) . (.name.unModuleName)) . (.instances) + +nubOrd :: (Ord a) => [a] -> [a] +nubOrd = go Set.empty + where + go _ [] = [] + go seen (value : rest) + | Set.member value seen = go seen rest + | otherwise = value : go (Set.insert value seen) rest diff --git a/src/Seihou/CLI/Update/Source.hs b/src/Seihou/CLI/Update/Source.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/CLI/Update/Source.hs @@ -0,0 +1,360 @@ +module Seihou.CLI.Update.Source + ( stageCandidateSources, + hashArtifactDirectory, + ) +where + +import Control.Exception (SomeException, displayException, try) +import Control.Monad (foldM, forM) +import Data.ByteString qualified as BS +import Data.Foldable (traverse_) +import Data.List (sort) +import Data.Map.Strict qualified as Map +import Data.Text qualified as T +import Seihou.CLI.InstallShared + ( OriginInfo (..), + cloneRepo, + copyDirectoryRecursive, + readOriginInfo, + ) +import Seihou.CLI.Update.Types +import Seihou.Core.Module (validateModule) +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.Manifest.Hash (hashContent) +import Seihou.Prelude +import System.Directory qualified as Directory +import System.Exit (ExitCode (..)) +import System.Process (readProcessWithExitCode) + +data ArtifactRequirement = ArtifactRequirement + { kind :: CandidateArtifactKind, + name :: Text, + sourceDirectory :: FilePath, + origin :: Maybe OriginInfo + } + +-- | Clone every distinct remote once, validate its complete module/recipe +-- catalog, and materialize a name-keyed temporary search root. Local artifacts +-- remain a fallback and are called out explicitly. +stageCandidateSources :: + FilePath -> + [AppliedComposition] -> + IO (Either UpdateError (CandidateCatalog, [UpdateWarning])) +stageCandidateSources sessionRoot selected = do + requirements <- requirementsFor selected + let remoteOrigins = + Map.fromList + [ (origin.sourceUrl, origin) + | requirement <- requirements, + Just origin <- [requirement.origin] + ] + clonesRoot = sessionRoot "clones" + searchRoot = sessionRoot "search" + Directory.createDirectoryIfMissing True clonesRoot + Directory.createDirectoryIfMissing True searchRoot + remoteResult <- stageRemoteOrigins clonesRoot searchRoot (Map.toAscList remoteOrigins) + case remoteResult of + Left err -> pure (Left err) + Right (remoteArtifacts, clones) -> do + localResult <- stageLocalRequirements searchRoot remoteArtifacts requirements + pure $ do + (allArtifacts, localWarnings) <- localResult + verifyRemoteRequirements requirements allArtifacts + Right + ( CandidateCatalog + { searchRoot, + artifacts = allArtifacts, + clonedOrigins = clones + }, + localWarnings + ) + +requirementsFor :: [AppliedComposition] -> IO [ArtifactRequirement] +requirementsFor applications = concat <$> mapM applicationRequirements applications + where + applicationRequirements application = do + targetOrigin <- readOriginInfo application.targetSource + instanceRequirements <- forM application.instances $ \state -> do + origin <- readOriginInfo state.source + pure + ArtifactRequirement + { kind = CandidateModule, + name = state.name.unModuleName, + sourceDirectory = state.source, + origin + } + let targetRequirement = case application.target of + AppliedModuleTarget name -> + ArtifactRequirement CandidateModule name.unModuleName application.targetSource targetOrigin + AppliedRecipeTarget name -> + ArtifactRequirement CandidateRecipe name.unRecipeName application.targetSource targetOrigin + pure (targetRequirement : instanceRequirements) + +stageRemoteOrigins :: + FilePath -> + FilePath -> + [(Text, OriginInfo)] -> + IO + ( Either + UpdateError + (Map (CandidateArtifactKind, Text) CandidateArtifact, Map Text FilePath) + ) +stageRemoteOrigins clonesRoot searchRoot = go 0 Map.empty Map.empty + where + go _ artifacts clones [] = pure (Right (artifacts, clones)) + go index artifacts clones ((url, origin) : rest) = do + let cloneDirectory = clonesRoot show index + cloneResult <- cloneRepo url cloneDirectory + case cloneResult of + Left message -> pure (Left (CandidateCloneFailed url message)) + Right () -> do + revision <- gitRevision cloneDirectory + discovered <- discoverRemote url origin revision cloneDirectory + case discovered of + Left err -> pure (Left err) + Right candidates -> do + inserted <- foldM (insertCandidate searchRoot) (Right artifacts) candidates + case inserted of + Left err -> pure (Left err) + Right artifacts' -> + go (index + 1) artifacts' (Map.insert url cloneDirectory clones) rest + +discoverRemote :: + Text -> + OriginInfo -> + Maybe Text -> + FilePath -> + IO (Either UpdateError [CandidateArtifact]) +discoverRemote url origin revision repoRoot = do + let registryFile = repoRoot "seihou-registry.dhall" + hasRegistry <- Directory.doesFileExist registryFile + if hasRegistry + then do + decoded <- evalRegistryFromFile registryFile + case decoded of + Left err -> pure (Left (CandidateLoadFailed (T.pack registryFile) err)) + Right registry -> do + validationErrors <- validateRegistry repoRoot registry + if null validationErrors + then discoverRegistryArtifacts url revision repoRoot registry + else pure (Left (CandidateRepositoryInvalid url validationErrors)) + else discoverSingleArtifact url origin revision repoRoot + +discoverRegistryArtifacts :: + Text -> + Maybe Text -> + FilePath -> + Registry -> + IO (Either UpdateError [CandidateArtifact]) +discoverRegistryArtifacts url revision repoRoot registry = do + modules <- traverse (loadRemoteModule url (Just registry.repoName) revision repoRoot) registry.modules + recipes <- traverse (loadRemoteRecipe url (Just registry.repoName) revision repoRoot) registry.recipes + pure ((<>) <$> sequence modules <*> sequence recipes) + +discoverSingleArtifact :: + Text -> + OriginInfo -> + Maybe Text -> + FilePath -> + IO (Either UpdateError [CandidateArtifact]) +discoverSingleArtifact url origin revision repoRoot = do + hasModule <- Directory.doesFileExist (repoRoot "module.dhall") + hasRecipe <- Directory.doesFileExist (repoRoot "recipe.dhall") + if hasModule + then fmap (fmap (: [])) (loadModuleArtifact (Just url) origin.repoName [] revision repoRoot) + else + if hasRecipe + then fmap (fmap (: [])) (loadRecipeArtifact (Just url) origin.repoName [] revision repoRoot) + else pure (Left (CandidateRepositoryInvalid url ["repository contains no module, recipe, or registry"])) + +loadRemoteModule :: + Text -> Maybe Text -> Maybe Text -> FilePath -> RegistryEntry -> IO (Either UpdateError CandidateArtifact) +loadRemoteModule url repoName revision repoRoot entry = + loadModuleArtifact (Just url) repoName entry.tags revision (repoRoot entry.path) + +loadRemoteRecipe :: + Text -> Maybe Text -> Maybe Text -> FilePath -> RegistryEntry -> IO (Either UpdateError CandidateArtifact) +loadRemoteRecipe url repoName revision repoRoot entry = + loadRecipeArtifact (Just url) repoName entry.tags revision (repoRoot entry.path) + +loadModuleArtifact :: + Maybe Text -> Maybe Text -> [Text] -> Maybe Text -> FilePath -> IO (Either UpdateError CandidateArtifact) +loadModuleArtifact sourceUrl repoName tags revision directory = do + decoded <- evalModuleFromFile (directory "module.dhall") + case decoded of + Left err -> pure (Left (CandidateLoadFailed (T.pack directory) err)) + Right modul -> do + validated <- validateModule directory modul + case validated of + Left err -> pure (Left (CandidateLoadFailed modul.name.unModuleName err)) + Right candidateModule -> do + contentHash <- hashArtifactDirectory directory + pure + ( Right + CandidateArtifact + { kind = CandidateModule, + name = candidateModule.name.unModuleName, + version = candidateModule.version, + originalDirectory = directory, + sourceDirectory = directory, + sourceUrl, + repoName, + tags, + sourceRevision = revision, + contentHash, + moduleDefinition = Just candidateModule, + recipeDefinition = Nothing + } + ) + +loadRecipeArtifact :: + Maybe Text -> Maybe Text -> [Text] -> Maybe Text -> FilePath -> IO (Either UpdateError CandidateArtifact) +loadRecipeArtifact sourceUrl repoName tags revision directory = do + decoded <- evalRecipeFromFile (directory "recipe.dhall") + case first (CandidateLoadFailed (T.pack directory)) decoded of + Left err -> pure (Left err) + Right recipe -> case first (CandidateRepositoryInvalid (maybe "local" id sourceUrl)) (validateRecipe recipe) of + Left err -> pure (Left err) + Right validated -> do + contentHash <- hashArtifactDirectory directory + pure + ( Right + CandidateArtifact + { kind = CandidateRecipe, + name = validated.name.unRecipeName, + version = validated.version, + originalDirectory = directory, + sourceDirectory = directory, + sourceUrl, + repoName, + tags, + sourceRevision = revision, + contentHash, + moduleDefinition = Nothing, + recipeDefinition = Just validated + } + ) + +stageLocalRequirements :: + FilePath -> + Map (CandidateArtifactKind, Text) CandidateArtifact -> + [ArtifactRequirement] -> + IO (Either UpdateError (Map (CandidateArtifactKind, Text) CandidateArtifact, [UpdateWarning])) +stageLocalRequirements searchRoot initial = go initial [] + where + go artifacts warnings [] = pure (Right (artifacts, reverse warnings)) + go artifacts warnings (requirement : rest) = case requirement.origin of + Just _ -> go artifacts warnings rest + Nothing + | Map.member (requirement.kind, requirement.name) artifacts -> go artifacts warnings rest + | otherwise -> do + loaded <- case requirement.kind of + CandidateModule -> loadModuleArtifact Nothing Nothing [] Nothing requirement.sourceDirectory + CandidateRecipe -> loadRecipeArtifact Nothing Nothing [] Nothing requirement.sourceDirectory + case loaded of + Left err -> pure (Left err) + Right candidate -> do + inserted <- insertCandidate searchRoot (Right artifacts) candidate + case inserted of + Left err -> pure (Left err) + Right artifacts' -> + go artifacts' (LocalArtifactHasNoRemote requirement.name : warnings) rest + +insertCandidate :: + FilePath -> + Either UpdateError (Map (CandidateArtifactKind, Text) CandidateArtifact) -> + CandidateArtifact -> + IO (Either UpdateError (Map (CandidateArtifactKind, Text) CandidateArtifact)) +insertCandidate _ (Left err) _ = pure (Left err) +insertCandidate searchRoot (Right artifacts) candidate = + case Map.lookup key artifacts of + Just existing -> + pure + ( Left + ( CandidateArtifactAmbiguous + candidate.kind + candidate.name + (map (maybe "local" id . (.sourceUrl)) [existing, candidate]) + ) + ) + Nothing -> do + let destination = searchRoot T.unpack candidate.name + Directory.createDirectoryIfMissing True destination + copied <- try @SomeException (copyDirectoryRecursive candidate.sourceDirectory destination) + pure $ case copied of + Left err -> Left (CandidateRepositoryInvalid candidate.name [T.pack (displayException err)]) + Right () -> + Right + ( Map.insert + key + (setCandidateSource destination candidate) + artifacts + ) + where + key = (candidate.kind, candidate.name) + +setCandidateSource :: FilePath -> CandidateArtifact -> CandidateArtifact +setCandidateSource directory candidate = + CandidateArtifact + { kind = candidate.kind, + name = candidate.name, + version = candidate.version, + originalDirectory = candidate.originalDirectory, + sourceDirectory = directory, + sourceUrl = candidate.sourceUrl, + repoName = candidate.repoName, + tags = candidate.tags, + sourceRevision = candidate.sourceRevision, + contentHash = candidate.contentHash, + moduleDefinition = candidate.moduleDefinition, + recipeDefinition = candidate.recipeDefinition + } + +verifyRemoteRequirements :: + [ArtifactRequirement] -> + Map (CandidateArtifactKind, Text) CandidateArtifact -> + Either UpdateError () +verifyRemoteRequirements requirements artifacts = traverse_ verify requirements + where + verify requirement = case Map.lookup (requirement.kind, requirement.name) artifacts of + Nothing -> Left (CandidateArtifactMissing requirement.kind requirement.name) + Just candidate -> case requirement.origin of + Nothing -> Right () + Just origin + | candidate.sourceUrl == Just origin.sourceUrl -> Right () + | otherwise -> Left (CandidateArtifactMissing requirement.kind requirement.name) + +gitRevision :: FilePath -> IO (Maybe Text) +gitRevision directory = do + result <- try @SomeException (readProcessWithExitCode "git" ["-C", directory, "rev-parse", "HEAD"] "") + pure $ case result of + Right (ExitSuccess, stdout, _) -> Just (T.strip (T.pack stdout)) + _ -> Nothing + +hashArtifactDirectory :: FilePath -> IO SHA256 +hashArtifactDirectory root = do + entries <- collectFiles root "" + chunks <- forM entries $ \relative -> do + bytes <- BS.readFile (root relative) + pure (T.pack relative <> "\NUL" <> T.pack (show bytes)) + pure (hashContent (T.intercalate "\NUL" chunks)) + where + collectFiles base relative = do + let directory = if null relative then base else base relative + names <- sort <$> Directory.listDirectory directory + fmap concat $ forM names $ \name -> do + let childRelative = if null relative then name else relative name + child = base childRelative + isDirectory <- Directory.doesDirectoryExist child + if name == ".seihou-origin.json" + then pure [] + else + if isDirectory + then + if name == ".git" + then pure [] + else collectFiles base childRelative + else pure [childRelative] diff --git a/src/Seihou/CLI/Update/Types.hs b/src/Seihou/CLI/Update/Types.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/CLI/Update/Types.hs @@ -0,0 +1,215 @@ +module Seihou.CLI.Update.Types + ( UpdateSelection (..), + PromptPolicy (..), + UpdateRequest (..), + VersionChange (..), + InputChangeSummary (..), + CandidateArtifactKind (..), + CandidateArtifact (..), + CandidateCatalog (..), + PlannedUpdateMigration (..), + PlannedApplication (..), + UpdateSnapshot (..), + UpdateWarning (..), + UpdatePlan (..), + CommandSummary (..), + UpdateResult (..), + UpdateError (..), + ) +where + +import Data.Map.Strict (Map) +import Data.Set (Set) +import Seihou.CLI.CommandExecution + ( CommandExecutionError, + CommandPlan, + CommandPolicy, + ) +import Seihou.Composition.Instance (ModuleInstance) +import Seihou.Core.Migration (MigrationPlan, MigrationPlanError) +import Seihou.Core.Types +import Seihou.Engine.Migrate (ExecutedMigrationPlan, MigrationExecError) +import Seihou.Engine.Reconcile + ( DesiredFileOwner, + ReconciliationError, + ReconciliationPlan, + ReconciliationSummary, + ) +import Seihou.Engine.UpdateTransaction (TransactionError) +import Seihou.Prelude + +data UpdateSelection + = AllRecordedApplications + | NamedUpdateTargets [Text] + deriving stock (Eq, Show) + +data PromptPolicy + = AllowPrompts + | ForbidPrompts + deriving stock (Eq, Show) + +data UpdateRequest = UpdateRequest + { selection :: UpdateSelection, + varOverrides :: [(Text, Text)], + reconfigure :: Bool, + promptPolicy :: PromptPolicy, + commandPolicy :: CommandPolicy, + dryRun :: Bool + } + deriving stock (Eq, Show) + +data VersionChange = VersionChange + { name :: Text, + fromVersion :: Maybe Text, + toVersion :: Maybe Text, + sameVersionContentChanged :: Bool + } + deriving stock (Eq, Show) + +data InputChangeSummary = InputChangeSummary + { reused :: Int, + overridden :: Int, + newlyResolved :: Int, + removed :: Int, + ambiguousLegacy :: [VarName] + } + deriving stock (Eq, Show) + +data CandidateArtifactKind = CandidateModule | CandidateRecipe + deriving stock (Eq, Ord, Show) + +-- | One validated artifact staged for this update session. The source path is +-- temporary for remote candidates and must not escape 'withProjectUpdate'. +data CandidateArtifact = CandidateArtifact + { kind :: CandidateArtifactKind, + name :: Text, + version :: Maybe Text, + originalDirectory :: FilePath, + sourceDirectory :: FilePath, + sourceUrl :: Maybe Text, + repoName :: Maybe Text, + tags :: [Text], + sourceRevision :: Maybe Text, + contentHash :: SHA256, + moduleDefinition :: Maybe Module, + recipeDefinition :: Maybe Recipe + } + deriving stock (Eq, Show) + +data CandidateCatalog = CandidateCatalog + { searchRoot :: FilePath, + artifacts :: Map (CandidateArtifactKind, Text) CandidateArtifact, + clonedOrigins :: Map Text FilePath + } + deriving stock (Eq, Show) + +data PlannedUpdateMigration = PlannedUpdateMigration + { moduleName :: ModuleName, + sourceDirectory :: FilePath, + sourcePlan :: MigrationPlan, + stagedPlan :: ExecutedMigrationPlan, + containsCommands :: Bool + } + deriving stock (Eq, Show) + +-- | Internal, renderer-neutral material retained so apply can re-plan after +-- migration commands without reusing parser state. +data PlannedApplication = PlannedApplication + { previous :: Maybe AppliedComposition, + candidate :: AppliedComposition, + modulesInOrder :: [(ModuleInstance, Module, FilePath)], + resolvedValues :: Map ModuleInstance (Map VarName ResolvedVar), + operations :: [Operation], + desiredOwners :: Map FilePath DesiredFileOwner + } + deriving stock (Eq, Show) + +data UpdateSnapshot = UpdateSnapshot + { sessionDirectory :: FilePath, + projectRoot :: FilePath, + manifestPath :: FilePath, + baselineDirectory :: FilePath, + installedDirectory :: FilePath, + originalManifest :: Manifest, + candidateHashes :: Map FilePath SHA256, + observedProjectHashes :: Map FilePath (Maybe SHA256), + transactionTargets :: Set FilePath + } + deriving stock (Eq, Show) + +data UpdateWarning + = LocalArtifactHasNoRemote Text + | SameVersionContentChanged Text + | AmbiguousLegacyValue VarName + | MissingLegacyValue VarName + | MigrationCommandNotSimulated ModuleName Text + | CrossApplicationLastWriter FilePath ModuleName ModuleName + | ArbitraryCommandSideEffectsMayRemain + | BaselinePruneFailed Text + | RecoveryCleanupDeferred Text + deriving stock (Eq, Show) + +data UpdatePlan = UpdatePlan + { applications :: [AppliedComposition], + versionChanges :: [VersionChange], + inputChanges :: InputChangeSummary, + migrations :: [PlannedUpdateMigration], + reconciliation :: ReconciliationPlan, + commandPlan :: CommandPlan, + candidateArtifacts :: [CandidateArtifact], + warnings :: [UpdateWarning], + request :: UpdateRequest, + snapshot :: UpdateSnapshot, + plannedApplications :: [PlannedApplication] + } + deriving stock (Eq, Show) + +data CommandSummary = CommandSummary + { executed :: Int, + skippedUnchanged :: Int, + skippedDisabled :: Int + } + deriving stock (Eq, Show) + +data UpdateResult = UpdateResult + { updatedApplications :: [ApplicationId], + manifest :: Manifest, + versions :: [VersionChange], + fileSummary :: ReconciliationSummary, + commandSummary :: CommandSummary, + touchedPaths :: Set FilePath, + warnings :: [UpdateWarning] + } + deriving stock (Eq, Show) + +data UpdateError + = UpdateManifestMissing FilePath + | UpdateManifestUnreadable FilePath Text + | NoRecordedApplications + | LegacyUpdateRequiresOneTarget + | UpdateTargetNotFound Text [Text] + | SharedPathRequiresApplications FilePath (Set ApplicationId) (Set ApplicationId) + | CandidateCloneFailed Text Text + | CandidateRepositoryInvalid Text [Text] + | CandidateArtifactMissing CandidateArtifactKind Text + | CandidateArtifactAmbiguous CandidateArtifactKind Text [Text] + | CandidateLoadFailed Text ModuleLoadError + | CandidateDowngrade Text (Maybe Text) (Maybe Text) + | CandidateVersionInvalid Text Text + | UpdateConflictingPriorVersions ModuleName [Text] + | UpdateVariableErrors [VarError] + | UpdateConfigurationFailed Text + | UpdateMigrationPlanFailed ModuleName MigrationPlanError + | UpdateMigrationStageFailed ModuleName MigrationExecError + | UpdateCompositionFailed [Text] + | UpdateReconciliationFailed ReconciliationError + | UpdateHasUnresolvedPaths (Set FilePath) + | UpdateRecoveryFailed [TransactionError] + | UpdatePlanStale (Set FilePath) + | UpdateTransactionFailed TransactionError + | UpdateMigrationFailed ModuleName MigrationExecError + | UpdateChangedAfterMigrationCommand ReconciliationSummary ReconciliationSummary + | UpdateCommandFailed CommandExecutionError [UpdateWarning] + | UpdateCachePublicationFailed Text + | UpdateManifestWriteFailed Text + deriving stock (Eq, Show) diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,10 +1,16 @@ module Main (main) where import Seihou.CLI.AgentCompletionSpec qualified as AgentCompletionSpec +import Seihou.CLI.AgentConfigShowSpec qualified as AgentConfigShowSpec import Seihou.CLI.AgentConfigSpec qualified as AgentConfigSpec import Seihou.CLI.AgentLaunchSpec qualified as AgentLaunchSpec +import Seihou.CLI.AgentMigrateE2ESpec qualified as AgentMigrateE2ESpec +import Seihou.CLI.AgentModelsSpec qualified as AgentModelsSpec +import Seihou.CLI.AppliedBlueprintMigrationSpec qualified as AppliedBlueprintMigrationSpec import Seihou.CLI.AppliedBlueprintSpec qualified as AppliedBlueprintSpec +import Seihou.CLI.BlueprintMigrationSpec qualified as BlueprintMigrationSpec import Seihou.CLI.BrowseFormatSpec qualified as BrowseFormatSpec +import Seihou.CLI.CommandExecutionSpec qualified as CommandExecutionSpec import Seihou.CLI.CommitMessageSpec qualified as CommitMessageSpec import Seihou.CLI.DiffSpec qualified as DiffSpec import Seihou.CLI.ExtensionSpec qualified as ExtensionSpec @@ -21,6 +27,10 @@ import Seihou.CLI.RunBlueprintRefusalSpec qualified as RunBlueprintRefusalSpec import Seihou.CLI.SavePromptedSpec qualified as SavePromptedSpec import Seihou.CLI.StatusSpec qualified as StatusSpec +import Seihou.CLI.UpdateE2ESpec qualified as UpdateE2ESpec +import Seihou.CLI.UpdateInteractionSpec qualified as UpdateInteractionSpec +import Seihou.CLI.UpdateRenderSpec qualified as UpdateRenderSpec +import Seihou.CLI.UpdateSpec qualified as UpdateSpec import Seihou.CLI.UpgradeSpec qualified as UpgradeSpec import Seihou.FzfSpec qualified as FzfSpec import Test.Tasty @@ -30,11 +40,17 @@ tests <- sequence [ AgentLaunchSpec.tests, + AgentMigrateE2ESpec.tests, AgentCompletionSpec.tests, AgentConfigSpec.tests, + AgentConfigShowSpec.tests, + AgentModelsSpec.tests, AppliedBlueprintSpec.tests, + AppliedBlueprintMigrationSpec.tests, + BlueprintMigrationSpec.tests, BrowseFormatSpec.tests, CommitMessageSpec.tests, + CommandExecutionSpec.tests, DiffSpec.tests, ExtensionSpec.tests, GitSpec.tests, @@ -51,6 +67,10 @@ SavePromptedSpec.tests, StatusSpec.tests, UpgradeSpec.tests, + UpdateSpec.tests, + UpdateInteractionSpec.tests, + UpdateE2ESpec.tests, + UpdateRenderSpec.tests, FzfSpec.tests ] defaultMain (testGroup "seihou-cli" tests) diff --git a/test/Seihou/CLI/AgentCompletionSpec.hs b/test/Seihou/CLI/AgentCompletionSpec.hs --- a/test/Seihou/CLI/AgentCompletionSpec.hs +++ b/test/Seihou/CLI/AgentCompletionSpec.hs @@ -40,7 +40,8 @@ defaultAgentModelConfig `shouldBe` AgentModelConfig { agentProvider = AgentProviderClaudeCli, - agentModel = Nothing + agentModel = Nothing, + agentEffort = Nothing } it "builds a Claude CLI model using the CLI API tag" $ do @@ -48,7 +49,8 @@ buildBaikaiModel AgentModelConfig { agentProvider = AgentProviderClaudeCli, - agentModel = Just "sonnet" + agentModel = Just "sonnet", + agentEffort = Nothing } BaikaiModel.api model `shouldBe` Baikai.AnthropicMessagesCli BaikaiModel.provider model `shouldBe` "anthropic" @@ -59,7 +61,8 @@ buildBaikaiModel AgentModelConfig { agentProvider = AgentProviderCodexCli, - agentModel = Just "gpt-5" + agentModel = Just "gpt-5", + agentEffort = Nothing } BaikaiModel.api model `shouldBe` Baikai.OpenAICompletionsCli BaikaiModel.provider model `shouldBe` "openai" @@ -70,7 +73,8 @@ let config = AgentModelConfig { agentProvider = AgentProviderCodexCli, - agentModel = Just "gpt-5" + agentModel = Just "gpt-5", + agentEffort = Nothing } buildAgentCompletionRequest config "system" (Just "user") `shouldBe` AgentCompletionRequest diff --git a/test/Seihou/CLI/AgentConfigShowSpec.hs b/test/Seihou/CLI/AgentConfigShowSpec.hs new file mode 100644 --- /dev/null +++ b/test/Seihou/CLI/AgentConfigShowSpec.hs @@ -0,0 +1,81 @@ +module Seihou.CLI.AgentConfigShowSpec (tests) where + +import Baikai.ThinkingLevel (ThinkingLevel (..)) +import Data.Text (Text) +import Data.Text qualified as Text +import Seihou.CLI.AgentCompletion (AgentProvider (..)) +import Seihou.CLI.AgentConfig + ( AgentCommandName (..), + AgentConfigSource (..), + ResolvedAgentField (..), + ResolvedCommandConfig (..), + ) +import Seihou.CLI.AgentConfigShow (formatResolvedAgentConfig) +import Test.Hspec +import Test.Tasty +import Test.Tasty.Hspec (testSpec) + +tests :: IO TestTree +tests = testSpec "Seihou.CLI.AgentConfigShow" spec + +spec :: Spec +spec = + describe "formatResolvedAgentConfig" $ do + let rendered = formatResolvedAgentConfig sample + -- A line exists containing every fragment (order-independent). + hasLine fragments = + any (\ln -> all (`Text.isInfixOf` ln) fragments) (Text.lines rendered) + + -- The command label is printed on the provider row; the model row's label + -- column is blank, so model-row assertions match on value + source only + -- (each is unique to one command in the sample). + it "labels a per-command local model with its concrete key" $ + hasLine ["model", "claude-opus-4-8", "[local: agent.run.model]"] `shouldBe` True + + it "shows an unset model as (default) with built-in provenance" $ + hasLine ["model", "(default)", "[built-in default]"] `shouldBe` True + + it "labels a global default model with the shared key" $ + hasLine ["model", "claude-sonnet-5", "[global: agent.model]"] `shouldBe` True + + it "labels a global per-command provider with its command key on the labelled row" $ + hasLine ["assist", "provider", "codex-cli", "[global: agent.assist.provider]"] `shouldBe` True + + it "renders the migrate command and its concrete config key" $ + hasLine ["migrate", "model", "gpt-5-mini", "[local: agent.migrate.model]"] `shouldBe` True + + it "labels a per-command local effort with its concrete key" $ + hasLine ["effort", "max", "[local: agent.run.effort]"] `shouldBe` True + + it "labels a global default effort with the shared key" $ + hasLine ["effort", "high", "[global: agent.effort]"] `shouldBe` True + + it "shows an unset effort as (default) with built-in provenance" $ + hasLine ["effort", "(default)", "[built-in default]"] `shouldBe` True + + it "includes the precedence legend" $ + ("Precedence, highest first:" `Text.isInfixOf` rendered) `shouldBe` True + +sample :: [ResolvedCommandConfig] +sample = + [ ResolvedCommandConfig + AgentCmdAssist + (ResolvedAgentField AgentProviderCodexCli SourceGlobalCommand) + (ResolvedAgentField Nothing SourceBuiltinDefault) + (ResolvedAgentField (Just ThinkingHigh) SourceGlobalDefault), + ResolvedCommandConfig + AgentCmdBootstrap + (ResolvedAgentField AgentProviderClaudeCli SourceBuiltinDefault) + (ResolvedAgentField (Just "claude-sonnet-5") SourceGlobalDefault) + (ResolvedAgentField Nothing SourceBuiltinDefault), + ResolvedCommandConfig + AgentCmdRun + (ResolvedAgentField AgentProviderClaudeCli SourceBuiltinDefault) + (ResolvedAgentField (Just "claude-opus-4-8") SourceLocalCommand) + (ResolvedAgentField (Just ThinkingMax) SourceLocalCommand), + ResolvedCommandConfig + AgentCmdMigrate + (ResolvedAgentField AgentProviderOpenAI SourceLocalCommand) + (ResolvedAgentField (Just "gpt-5-mini") SourceLocalCommand) + (ResolvedAgentField Nothing SourceBuiltinDefault) + ] diff --git a/test/Seihou/CLI/AgentConfigSpec.hs b/test/Seihou/CLI/AgentConfigSpec.hs --- a/test/Seihou/CLI/AgentConfigSpec.hs +++ b/test/Seihou/CLI/AgentConfigSpec.hs @@ -1,5 +1,6 @@ module Seihou.CLI.AgentConfigSpec (tests) where +import Baikai.ThinkingLevel (ThinkingLevel (..)) import Data.Map.Strict qualified as Map import Data.Text (Text) import Data.Text qualified as Text @@ -15,36 +16,29 @@ spec :: Spec spec = do describe "resolveAgentModelConfig" $ do - it "uses CLI flags before environment variables" $ do + it "uses CLI flags before environment variables" $ resolveAgentModelConfig (baseInputs {cliProvider = Just "codex-cli", cliModel = Just "gpt-5", envProvider = Just "anthropic", envModel = Just "claude-sonnet-4-6"}) - `shouldBe` Right - AgentModelConfig - { agentProvider = AgentProviderCodexCli, - agentModel = Just "gpt-5" - } + `shouldBe` Right (cfg AgentProviderCodexCli (Just "gpt-5")) - it "uses environment variables before local config" $ do + it "uses environment variables before local config" $ resolveAgentModelConfig (baseInputs {envProvider = Just "openai", envModel = Just "gpt-4o", localConfig = config "anthropic" "claude-sonnet-4-6"}) - `shouldBe` Right - AgentModelConfig - { agentProvider = AgentProviderOpenAI, - agentModel = Just "gpt-4o" - } + `shouldBe` Right (cfg AgentProviderOpenAI (Just "gpt-4o")) - it "uses local config before global config" $ do + it "uses local config before global config" $ resolveAgentModelConfig (baseInputs {localConfig = config "anthropic" "claude-opus-4-1", globalConfig = config "openai" "gpt-4o-mini"}) - `shouldBe` Right - AgentModelConfig - { agentProvider = AgentProviderAnthropic, - agentModel = Just "claude-opus-4-1" - } + `shouldBe` Right (cfg AgentProviderAnthropic (Just "claude-opus-4-1")) - it "falls back to the Claude CLI default" $ - resolveAgentModelConfig baseInputs `shouldBe` Right defaultAgentModelConfig + it "pins the deterministic claude-cli default model when nothing is set" $ + resolveAgentModelConfig baseInputs + `shouldBe` Right (cfg AgentProviderClaudeCli (Just "claude-opus-4-8")) + it "pins the deterministic codex-cli default model when only the provider is set" $ + resolveAgentModelConfig (baseInputs {cliProvider = Just "codex-cli"}) + `shouldBe` Right (cfg AgentProviderCodexCli (Just "gpt-5.6-terra")) + it "returns provider diagnostics for invalid provider text" $ resolveAgentModelConfig (baseInputs {cliProvider = Just "llama"}) `shouldSatisfy` \case Left err -> @@ -55,31 +49,151 @@ it "allows a model-only override while keeping the default provider" $ resolveAgentModelConfig (baseInputs {cliModel = Just "sonnet"}) - `shouldBe` Right - AgentModelConfig - { agentProvider = AgentProviderClaudeCli, - agentModel = Just "sonnet" - } + `shouldBe` Right (cfg AgentProviderClaudeCli (Just "sonnet")) it "ignores blank higher-precedence values" $ resolveAgentModelConfig (baseInputs {cliProvider = Just " ", envProvider = Just "codex-cli", cliModel = Just "", envModel = Just "gpt-5"}) - `shouldBe` Right - AgentModelConfig - { agentProvider = AgentProviderCodexCli, - agentModel = Just "gpt-5" - } + `shouldBe` Right (cfg AgentProviderCodexCli (Just "gpt-5")) + describe "resolveAgentModelConfigFor (per-command)" $ do + it "prefers a per-command model over the default in the same scope" $ do + let inputs = + baseInputs + { localConfig = + Map.fromList + [ (agentModelConfigKey, "claude-sonnet-5"), + (agentCommandModelConfigKey AgentCmdRun, "claude-opus-4-8") + ] + } + modelOf AgentCmdRun inputs `shouldBe` Right (Just "claude-opus-4-8", SourceLocalCommand) + modelOf AgentCmdAssist inputs `shouldBe` Right (Just "claude-sonnet-5", SourceLocalDefault) + + it "lets a local default override a global per-command key (project over global)" $ do + let inputs = + baseInputs + { localConfig = Map.fromList [(agentModelConfigKey, "claude-sonnet-5")], + globalConfig = Map.fromList [(agentCommandModelConfigKey AgentCmdRun, "gpt-5")] + } + modelOf AgentCmdRun inputs `shouldBe` Right (Just "claude-sonnet-5", SourceLocalDefault) + + it "prefers a global per-command key over the global default" $ do + let inputs = + baseInputs + { globalConfig = + Map.fromList + [ (agentProviderConfigKey, "anthropic"), + (agentCommandProviderConfigKey AgentCmdAssist, "openai") + ] + } + providerOf AgentCmdAssist inputs `shouldBe` Right (AgentProviderOpenAI, SourceGlobalCommand) + providerOf AgentCmdSetup inputs `shouldBe` Right (AgentProviderAnthropic, SourceGlobalDefault) + + it "labels a subcommand CLI flag distinctly from a parent flag" $ do + providerOf AgentCmdAssist (baseInputs {cliProvider = Just "codex-cli", cliProviderFromSubcommand = True}) + `shouldBe` Right (AgentProviderCodexCli, SourceCliSubcommand) + providerOf AgentCmdAssist (baseInputs {cliProvider = Just "codex-cli", cliProviderFromSubcommand = False}) + `shouldBe` Right (AgentProviderCodexCli, SourceCliParent) + + it "falls back to the pinned CLI default model with built-in provenance" $ do + providerOf AgentCmdRun baseInputs `shouldBe` Right (AgentProviderClaudeCli, SourceBuiltinDefault) + modelOf AgentCmdRun baseInputs `shouldBe` Right (Just "claude-opus-4-8", SourceBuiltinDefault) + + it "keeps claude-cli and codex-cli deterministic: model is never Nothing" $ do + -- With nothing configured, every command resolves to a concrete model for + -- both local CLI providers, so seihou always passes an explicit --model. + modelOf AgentCmdAssist baseInputs `shouldBe` Right (Just "claude-opus-4-8", SourceBuiltinDefault) + modelOf AgentCmdAssist (baseInputs {cliProvider = Just "codex-cli", cliProviderFromSubcommand = True}) + `shouldBe` Right (Just "gpt-5.6-terra", SourceBuiltinDefault) + + it "keeps environment variables above per-command config" $ do + let inputs = + baseInputs + { envModel = Just "gpt-5", + localConfig = Map.fromList [(agentCommandModelConfigKey AgentCmdRun, "claude-opus-4-8")] + } + modelOf AgentCmdRun inputs `shouldBe` Right (Just "gpt-5", SourceEnv) + + it "resolves migrate from its own per-command keys" $ do + let inputs = + baseInputs + { localConfig = + Map.fromList + [ (agentCommandProviderConfigKey AgentCmdMigrate, "openai"), + (agentCommandModelConfigKey AgentCmdMigrate, "gpt-5-mini"), + (agentCommandModelConfigKey AgentCmdRun, "claude-opus-4-8") + ] + } + providerOf AgentCmdMigrate inputs `shouldBe` Right (AgentProviderOpenAI, SourceLocalCommand) + modelOf AgentCmdMigrate inputs `shouldBe` Right (Just "gpt-5-mini", SourceLocalCommand) + modelOf AgentCmdRun inputs `shouldBe` Right (Just "claude-opus-4-8", SourceLocalCommand) + + describe "resolveAgentModelConfigFor (reasoning effort)" $ do + it "defaults to unset effort when nothing is configured" $ + effortOf AgentCmdRun baseInputs `shouldBe` Right (Nothing, SourceBuiltinDefault) + + it "prefers a per-command effort over the shared default in the same scope" $ do + let inputs = + baseInputs + { localConfig = + Map.fromList + [ (agentEffortConfigKey, "medium"), + (agentCommandEffortConfigKey AgentCmdRun, "max") + ] + } + effortOf AgentCmdRun inputs `shouldBe` Right (Just ThinkingMax, SourceLocalCommand) + effortOf AgentCmdAssist inputs `shouldBe` Right (Just ThinkingMedium, SourceLocalDefault) + + it "lets a local default effort override a global per-command effort" $ do + let inputs = + baseInputs + { localConfig = Map.fromList [(agentEffortConfigKey, "low")], + globalConfig = Map.fromList [(agentCommandEffortConfigKey AgentCmdRun, "max")] + } + effortOf AgentCmdRun inputs `shouldBe` Right (Just ThinkingLow, SourceLocalDefault) + + it "keeps the effort environment variable above config" $ do + let inputs = + baseInputs + { envEffort = Just "high", + localConfig = Map.fromList [(agentCommandEffortConfigKey AgentCmdRun, "minimal")] + } + effortOf AgentCmdRun inputs `shouldBe` Right (Just ThinkingHigh, SourceEnv) + + it "prefers the subcommand effort flag over everything" $ + effortOf + AgentCmdRun + (baseInputs {cliEffort = Just "xhigh", cliEffortFromSubcommand = True, envEffort = Just "low"}) + `shouldBe` Right (Just ThinkingXHigh, SourceCliSubcommand) + + it "parses effort case-insensitively" $ + effortOf AgentCmdRun (baseInputs {cliEffort = Just " MAX "}) `shouldBe` Right (Just ThinkingMax, SourceCliParent) + + it "returns a diagnostic for an invalid effort value" $ + resolveAgentModelConfigFor AgentCmdRun (baseInputs {cliEffort = Just "ultra"}) `shouldSatisfy` \case + Left err -> "Unknown reasoning effort" `Text.isInfixOf` err && "xhigh" `Text.isInfixOf` err + Right _ -> False + +providerOf :: AgentCommandName -> AgentConfigInputs -> Either Text (AgentProvider, AgentConfigSource) +providerOf c inputs = + (\(p, _, _) -> (p.resolvedValue, p.resolvedSource)) <$> resolveAgentModelConfigFor c inputs + +modelOf :: AgentCommandName -> AgentConfigInputs -> Either Text (Maybe Text, AgentConfigSource) +modelOf c inputs = + (\(_, m, _) -> (m.resolvedValue, m.resolvedSource)) <$> resolveAgentModelConfigFor c inputs + +effortOf :: AgentCommandName -> AgentConfigInputs -> Either Text (Maybe ThinkingLevel, AgentConfigSource) +effortOf c inputs = + (\(_, _, e) -> (e.resolvedValue, e.resolvedSource)) <$> resolveAgentModelConfigFor c inputs + +-- | Build an expected 'AgentModelConfig' with effort unset (the flat resolver +-- never sets effort). +cfg :: AgentProvider -> Maybe Text -> AgentModelConfig +cfg provider model = + AgentModelConfig {agentProvider = provider, agentModel = model, agentEffort = Nothing} + baseInputs :: AgentConfigInputs -baseInputs = - AgentConfigInputs - { cliProvider = Nothing, - cliModel = Nothing, - envProvider = Nothing, - envModel = Nothing, - localConfig = Map.empty, - globalConfig = Map.empty - } +baseInputs = baseAgentConfigInputs config :: Text -> Text -> Map.Map Text Text config provider model = diff --git a/test/Seihou/CLI/AgentLaunchSpec.hs b/test/Seihou/CLI/AgentLaunchSpec.hs --- a/test/Seihou/CLI/AgentLaunchSpec.hs +++ b/test/Seihou/CLI/AgentLaunchSpec.hs @@ -150,7 +150,8 @@ baseModules = [], files = [], allowedTools = Nothing, - tags = [] + tags = [], + migrations = [] } it "renders name, version, description as a three-line block" $ formatBlueprintIdentity (mk (Just "0.1") (Just "a thing")) diff --git a/test/Seihou/CLI/AgentMigrateE2ESpec.hs b/test/Seihou/CLI/AgentMigrateE2ESpec.hs new file mode 100644 --- /dev/null +++ b/test/Seihou/CLI/AgentMigrateE2ESpec.hs @@ -0,0 +1,191 @@ +module Seihou.CLI.AgentMigrateE2ESpec (tests) where + +import Data.ByteString.Lazy qualified as LBS +import Data.Maybe (fromMaybe) +import Data.Text qualified as T +import Data.Text.IO qualified as TIO +import Seihou.Core.Types (AppliedBlueprintMigration (..), Manifest (..)) +import Seihou.Manifest.Types (manifestFromJSON) +import System.Directory + ( createDirectoryIfMissing, + doesFileExist, + executable, + getPermissions, + setPermissions, + ) +import System.Environment (getEnvironment, getExecutablePath) +import System.Exit (ExitCode (..)) +import System.FilePath (searchPathSeparator, takeDirectory, ()) +import System.IO.Temp (withSystemTempDirectory) +import System.Process (CreateProcess (..), proc, readCreateProcessWithExitCode) +import Test.Hspec +import Test.Tasty (TestTree) +import Test.Tasty.Hspec (testSpec) + +tests :: IO TestTree +tests = testSpec "Agent migrate end-to-end" $ do + it "exposes the required version window and rerun option in help" $ do + binary <- seihouBinary + (exitCode, output, _) <- runProcessText binary ["agent", "migrate", "--help"] Nothing Nothing + exitCode `shouldBe` ExitSuccess + output `shouldSatisfy` T.isInfixOf "Usage: seihou agent migrate BLUEPRINT --from VERSION --to VERSION [PROMPT]" + output `shouldSatisfy` T.isInfixOf "--rerun" + output `shouldNotSatisfy` T.isInfixOf "--no-baseline" + output `shouldNotSatisfy` T.isInfixOf "--force" + + it "renders gap-tolerant pending prompts in order without writing a receipt" $ + withSystemTempDirectory "seihou-agent-migrate-debug" $ \root -> do + binary <- seihouBinary + let blueprintDir = root ".seihou" "modules" "payments" + blueprintPath = blueprintDir "blueprint.dhall" + manifestPath = root ".seihou" "manifest.json" + xdgHome = root "xdg" + createDirectoryIfMissing True blueprintDir + createDirectoryIfMissing True xdgHome + TIO.writeFile blueprintPath migrationBlueprintDhall + inherited <- getEnvironment + let overriddenNames = ["XDG_CONFIG_HOME", "SEIHOU_AGENT_PROVIDER", "SEIHOU_AGENT_MODEL", "SEIHOU_CONTEXT"] + environment = + ("XDG_CONFIG_HOME", xdgHome) + : ("SEIHOU_AGENT_PROVIDER", "claude-cli") + : filter (\(key, _) -> key `notElem` overriddenNames) inherited + (exitCode, output, errorOutput) <- + runProcessText + binary + [ "agent", + "--debug", + "migrate", + "payments", + "--from", + "1.0.0", + "--to", + "3.0.0", + "--var", + "library.name=baikai" + ] + (Just root) + (Just environment) + case exitCode of + ExitSuccess -> pure () + ExitFailure code -> + expectationFailure $ + "debug migration exited " + <> show code + <> "\nstdout:\n" + <> T.unpack output + <> "\nstderr:\n" + <> T.unpack errorOutput + output `shouldSatisfy` T.isInfixOf "Blueprint migrations for payments: 1.0.0 -> 3.0.0" + output `shouldSatisfy` T.isInfixOf "===== [1/2] 1.0.0 -> 2.0.0 =====" + output `shouldSatisfy` T.isInfixOf "===== [2/2] 2.5.0 -> 3.0.0 =====" + output `shouldSatisfy` T.isInfixOf "Shared upgrade guidance for baikai." + output `shouldSatisfy` T.isInfixOf "Replace baikai legacy calls." + let (_, afterFirst) = T.breakOn "1.0.0 -> 2.0.0" output + (_, afterSecond) = T.breakOn "2.5.0 -> 3.0.0" afterFirst + afterFirst `shouldNotBe` "" + afterSecond `shouldNotBe` "" + doesFileExist manifestPath `shouldReturn` False + + it "records successful edges and skips them on the next invocation" $ + withSystemTempDirectory "seihou-agent-migrate-receipts" $ \root -> do + binary <- seihouBinary + let blueprintDir = root ".seihou" "modules" "payments" + blueprintPath = blueprintDir "blueprint.dhall" + manifestPath = root ".seihou" "manifest.json" + xdgHome = root "xdg" + fakeBin = root "bin" + fakeClaude = fakeBin "claude" + launchLog = root "agent-launches.log" + createDirectoryIfMissing True blueprintDir + createDirectoryIfMissing True xdgHome + createDirectoryIfMissing True fakeBin + TIO.writeFile blueprintPath migrationBlueprintDhall + TIO.writeFile fakeClaude "#!/bin/sh\nprintf 'called\\n' >> \"$SEIHOU_FAKE_AGENT_LOG\"\nexit 0\n" + permissions <- getPermissions fakeClaude + setPermissions fakeClaude (permissions {executable = True}) + + inherited <- getEnvironment + let inheritedPath = fromMaybe "" (lookup "PATH" inherited) + overriddenNames = ["PATH", "XDG_CONFIG_HOME", "SEIHOU_AGENT_PROVIDER", "SEIHOU_AGENT_MODEL", "SEIHOU_CONTEXT", "SEIHOU_FAKE_AGENT_LOG"] + environment = + ("PATH", fakeBin <> [searchPathSeparator] <> inheritedPath) + : ("XDG_CONFIG_HOME", xdgHome) + : ("SEIHOU_AGENT_PROVIDER", "claude-cli") + : ("SEIHOU_FAKE_AGENT_LOG", launchLog) + : filter (\(key, _) -> key `notElem` overriddenNames) inherited + args = + [ "agent", + "migrate", + "payments", + "--from", + "1.0.0", + "--to", + "3.0.0", + "--var", + "library.name=baikai" + ] + + (firstExit, _, firstError) <- runProcessText binary args (Just root) (Just environment) + case firstExit of + ExitSuccess -> pure () + ExitFailure code -> expectationFailure ("migration exited " <> show code <> "\nstderr:\n" <> T.unpack firstError) + T.lines <$> TIO.readFile launchLog `shouldReturn` ["called", "called"] + beforeResume <- LBS.readFile manifestPath + manifest <- + case manifestFromJSON beforeResume of + Left err -> expectationFailure err >> fail "unreachable" + Right decoded -> pure decoded + map (\receipt -> (receipt.fromVersion, receipt.toVersion)) manifest.blueprintMigrations + `shouldBe` [("1.0.0", "2.0.0"), ("2.5.0", "3.0.0")] + + (resumeExit, resumeOutput, resumeError) <- runProcessText binary args (Just root) (Just environment) + case resumeExit of + ExitSuccess -> pure () + ExitFailure code -> expectationFailure ("resume exited " <> show code <> "\nstderr:\n" <> T.unpack resumeError) + resumeOutput `shouldSatisfy` T.isInfixOf "already have receipts" + T.lines <$> TIO.readFile launchLog `shouldReturn` ["called", "called"] + LBS.readFile manifestPath `shouldReturn` beforeResume + +seihouBinary :: IO FilePath +seihouBinary = do + testBinary <- getExecutablePath + pure (takeDirectory (takeDirectory testBinary) "seihou" "seihou") + +runProcessText :: + FilePath -> + [String] -> + Maybe FilePath -> + Maybe [(String, String)] -> + IO (ExitCode, T.Text, T.Text) +runProcessText binary args workingDirectory environment = do + let command = (proc binary args) {cwd = workingDirectory, env = environment} + (exitCode, stdoutText, stderrText) <- readCreateProcessWithExitCode command "" + pure (exitCode, T.pack stdoutText, T.pack stderrText) + +migrationBlueprintDhall :: T.Text +migrationBlueprintDhall = + T.unlines + [ "{ name = \"payments\"", + ", version = Some \"4.2.0\"", + ", description = Some \"Payments library upgrade\"", + ", prompt = \"Shared upgrade guidance for {{library.name}}.\"", + ", vars =", + " [ { name = \"library.name\"", + " , type = \"text\"", + " , default = None Text", + " , description = None Text", + " , required = True", + " , validation = None Text", + " }", + " ]", + ", prompts = [] : List { var : Text, text : Text, when : Optional Text, choices : Optional (List Text) }", + ", baseModules = [] : List { module : Text, vars : List { name : Text, value : Text } }", + ", files = [] : List { src : Text, description : Optional Text }", + ", allowedTools = None (List Text)", + ", tags = [] : List Text", + ", migrations =", + " [ { from = \"2.5.0\", to = \"3.0.0\", prompt = \"Finish the baikai upgrade.\" }", + " , { from = \"1.0.0\", to = \"2.0.0\", prompt = \"Replace {{library.name}} legacy calls.\" }", + " ]", + "}" + ] diff --git a/test/Seihou/CLI/AgentModelsSpec.hs b/test/Seihou/CLI/AgentModelsSpec.hs new file mode 100644 --- /dev/null +++ b/test/Seihou/CLI/AgentModelsSpec.hs @@ -0,0 +1,66 @@ +module Seihou.CLI.AgentModelsSpec (tests) where + +import Baikai.Model (Model) +import Baikai.Model qualified as BaikaiModel +import Data.Set qualified as Set +import Data.Text (Text) +import Data.Text qualified as Text +import Seihou.CLI.AgentCompletion (AgentProvider (..)) +import Seihou.CLI.AgentModels +import Test.Hspec +import Test.Tasty (TestTree) +import Test.Tasty.Hspec (testSpec) + +tests :: IO TestTree +tests = testSpec "Seihou.CLI.AgentModels" $ do + describe "availableAgentModels" $ do + it "contains 31 unique Anthropic and OpenAI model IDs" $ do + let ids = modelIds availableAgentModels + length ids `shouldBe` 31 + Set.size (Set.fromList ids) `shouldBe` 31 + Set.fromList (map BaikaiModel.provider availableAgentModels) + `shouldBe` Set.fromList ["anthropic", "openai"] + + it "contains the newest Claude and GPT-5.6 models" $ + modelIds availableAgentModels + `shouldSatisfy` \ids -> + all + (`elem` ids) + ["claude-sonnet-5", "gpt-5.6", "gpt-5.6-luna", "gpt-5.6-sol", "gpt-5.6-terra"] + + describe "filterAgentModels" $ do + it "maps the Anthropic API and Claude CLI providers to the same 9 models" $ do + let anthropicIds = filteredIds AgentProviderAnthropic + claudeCliIds = filteredIds AgentProviderClaudeCli + anthropicIds `shouldBe` claudeCliIds + length anthropicIds `shouldBe` 9 + + it "maps the OpenAI API and Codex CLI providers to the same 22 models" $ do + let openAIIds = filteredIds AgentProviderOpenAI + codexCliIds = filteredIds AgentProviderCodexCli + openAIIds `shouldBe` codexCliIds + length openAIIds `shouldBe` 22 + + describe "formatAgentModels" $ do + it "renders model names, compatible providers, count, and alias guidance" $ do + let output = formatAgentModels Nothing availableAgentModels + output `shouldSatisfy` Text.isInfixOf "MODEL" + output `shouldSatisfy` Text.isInfixOf "Claude Sonnet 5" + output `shouldSatisfy` Text.isInfixOf "anthropic, claude-cli" + output `shouldSatisfy` Text.isInfixOf "GPT-5.6 Terra" + output `shouldSatisfy` Text.isInfixOf "openai, codex-cli" + output `shouldSatisfy` Text.isInfixOf "31 models found." + output `shouldSatisfy` Text.isInfixOf "aliases and custom model IDs remain accepted" + + it "reports the filtered model count" $ do + formatAgentModels (Just AgentProviderAnthropic) availableAgentModels + `shouldSatisfy` Text.isInfixOf "9 models found." + formatAgentModels (Just AgentProviderCodexCli) availableAgentModels + `shouldSatisfy` Text.isInfixOf "22 models found." + +modelIds :: [Model] -> [Text] +modelIds = map BaikaiModel.modelId + +filteredIds :: AgentProvider -> [Text] +filteredIds provider = + modelIds (filterAgentModels (Just provider) availableAgentModels) diff --git a/test/Seihou/CLI/AppliedBlueprintMigrationSpec.hs b/test/Seihou/CLI/AppliedBlueprintMigrationSpec.hs new file mode 100644 --- /dev/null +++ b/test/Seihou/CLI/AppliedBlueprintMigrationSpec.hs @@ -0,0 +1,80 @@ +module Seihou.CLI.AppliedBlueprintMigrationSpec (tests) where + +import Data.ByteString.Lazy qualified as LBS +import Data.Text qualified as T +import Data.Time (UTCTime, defaultTimeLocale, parseTimeOrError) +import Seihou.CLI.AppliedBlueprintMigration (recordAppliedBlueprintMigration) +import Seihou.Core.Types (AppliedBlueprintMigration (..), Manifest (..), ModuleName (..)) +import Seihou.Manifest.Types (currentManifestVersion, manifestFromJSON) +import System.FilePath (()) +import System.IO.Temp (withSystemTempDirectory) +import Test.Hspec +import Test.Tasty +import Test.Tasty.Hspec (testSpec) + +tests :: IO TestTree +tests = testSpec "Seihou.CLI.AppliedBlueprintMigration" spec + +fixedTime :: UTCTime +fixedTime = + parseTimeOrError True defaultTimeLocale "%Y-%m-%dT%H:%M:%SZ" "2026-07-20T12:00:00Z" + +fixedTime2 :: UTCTime +fixedTime2 = + parseTimeOrError True defaultTimeLocale "%Y-%m-%dT%H:%M:%SZ" "2026-07-20T13:00:00Z" + +mkReceipt :: T.Text -> T.Text -> T.Text -> UTCTime -> AppliedBlueprintMigration +mkReceipt blueprintName fromVersion toVersion appliedAt = + AppliedBlueprintMigration + { name = ModuleName blueprintName, + blueprintVersion = Just "0.4.0", + fromVersion = fromVersion, + toVersion = toVersion, + appliedAt = appliedAt, + agentSessionId = Nothing + } + +readManifestFile :: FilePath -> IO Manifest +readManifestFile path = do + bytes <- LBS.readFile path + case manifestFromJSON bytes of + Right manifest -> pure manifest + Left err -> error ("test fixture: malformed manifest: " <> err) + +spec :: Spec +spec = describe "recordAppliedBlueprintMigration" $ do + it "creates a version-5 manifest for the first receipt" $ + withSystemTempDirectory "seihou-blueprint-migration" $ \dir -> do + let manifestPath = dir ".seihou" "manifest.json" + receipt = mkReceipt "payments" "1.0.0" "2.0.0" fixedTime + result <- recordAppliedBlueprintMigration manifestPath receipt + result `shouldBe` Right () + manifest <- readManifestFile manifestPath + manifest.version `shouldBe` currentManifestVersion + manifest.blueprintMigrations `shouldBe` [receipt] + + it "upserts the same exact edge and retains unrelated edges" $ + withSystemTempDirectory "seihou-blueprint-migration" $ \dir -> do + let manifestPath = dir "manifest.json" + first = mkReceipt "payments" "1.0.0" "2.0.0" fixedTime + second = mkReceipt "payments" "2.5.0" "3.0.0" fixedTime + replacement = + (mkReceipt "payments" "1.0.0" "2.0.0" fixedTime2) + { blueprintVersion = Just "0.5.0" + } + recordAppliedBlueprintMigration manifestPath first `shouldReturn` Right () + recordAppliedBlueprintMigration manifestPath second `shouldReturn` Right () + recordAppliedBlueprintMigration manifestPath replacement `shouldReturn` Right () + manifest <- readManifestFile manifestPath + manifest.blueprintMigrations `shouldBe` [replacement, second] + + it "returns Left and preserves a corrupt existing manifest" $ + withSystemTempDirectory "seihou-blueprint-migration" $ \dir -> do + let manifestPath = dir "manifest.json" + corrupt = "{ this is not valid json" + writeFile manifestPath corrupt + result <- recordAppliedBlueprintMigration manifestPath (mkReceipt "payments" "1.0.0" "2.0.0" fixedTime) + case result of + Left err -> err `shouldSatisfy` not . T.null + Right () -> expectationFailure "expected corrupt manifest failure" + readFile manifestPath `shouldReturn` corrupt diff --git a/test/Seihou/CLI/BlueprintMigrationSpec.hs b/test/Seihou/CLI/BlueprintMigrationSpec.hs new file mode 100644 --- /dev/null +++ b/test/Seihou/CLI/BlueprintMigrationSpec.hs @@ -0,0 +1,248 @@ +module Seihou.CLI.BlueprintMigrationSpec (tests) where + +import Data.IORef +import Data.Map.Strict qualified as Map +import Data.Text (Text) +import Data.Text qualified as T +import Data.Time (UTCTime) +import Seihou.CLI.AgentLaunch (AgentContext (..)) +import Seihou.CLI.BlueprintExecution (PreparedBlueprintExecution (..)) +import Seihou.CLI.BlueprintMigration +import Seihou.Core.Migration +import Seihou.Core.Types +import Seihou.Core.Version (Version, parseVersion) +import System.Exit (ExitCode (..)) +import Test.Hspec +import Test.Tasty (TestTree) +import Test.Tasty.Hspec (testSpec) + +tests :: IO TestTree +tests = testSpec "Seihou.CLI.BlueprintMigration" $ do + describe "pendingBlueprintMigrations" $ do + it "retains the planner's order across an intentional version gap" $ do + let late = migration "2.5.0" "3.0.0" + early = migration "1.0.0" "2.0.0" + Right (Just migrationPlan) = + planBlueprintMigrationChain + "payments" + [late, early] + (version "1.0.0") + (version "3.0.0") + pendingBlueprintMigrations False blueprintName [] migrationPlan + `shouldBe` [early, late] + + it "resumes by filtering only an already-recorded exact edge" $ do + let migrationPlan = plan [first, second] + receipts = + [ receipt blueprintName "1.0.0" "2.0.0", + receipt "another-blueprint" "2.0.0" "3.0.0" + ] + pendingBlueprintMigrations False blueprintName receipts migrationPlan + `shouldBe` [second] + + it "keeps recorded edges when rerun is requested" $ do + let migrationPlan = plan [first, second] + receipts = [receipt blueprintName "1.0.0" "2.0.0"] + pendingBlueprintMigrations True blueprintName receipts migrationPlan + `shouldBe` [first, second] + + describe "renderBlueprintMigrationInstruction" $ do + it "substitutes the variables resolved for the shared blueprint" $ do + let declaration = VarDecl "library.name" VTText Nothing Nothing False Nothing + resolved = + Map.singleton + "library.name" + (ResolvedVar (VText "baikai") FromDefault declaration) + renderBlueprintMigrationInstruction resolved (migrationWithPrompt "1" "2" "Upgrade {{library.name}}.") + `shouldBe` "Upgrade baikai." + + describe "renderBlueprintMigrationSystemPrompt" $ do + it "renders identity, position, shared guidance, edge instructions, and reference access" $ do + let edge = migrationWithPrompt "1.0.0" "2.0.0" "Upgrade {{library.name}} now." + rendered = + renderBlueprintMigrationSystemPrompt + "{{blueprint_name}} {{blueprint_version}} | {{migration_position}}/{{migration_total}} | {{migration_from}} -> {{migration_to}} | {{shared_prompt}} | {{migration_prompt}} | {{reference_files_dir}} | {{cwd}}" + sampleContext + samplePrepared + 1 + 2 + edge + rendered + `shouldBe` "payments 4.2.0 | 1/2 | 1.0.0 -> 2.0.0 | Shared guidance for baikai. | Upgrade baikai now. | mounted at /tmp/payments/files | /tmp/project" + + it "delimits debug prompts in pending order without any execution callback" $ do + let output = + formatBlueprintMigrationDebugOutput + (\position total edge -> "prompt " <> tshow position <> "/" <> tshow total <> " " <> edge.from) + [first, second] + output `shouldSatisfy` T.isInfixOf "===== [1/2] 1.0.0 -> 2.0.0 =====" + output `shouldSatisfy` T.isInfixOf "===== [2/2] 2.0.0 -> 3.0.0 =====" + T.breakOn "2.0.0 -> 3.0.0" output `shouldSatisfy` (not . T.null . snd) + + describe "runBlueprintMigrationsWith" $ do + it "reports no work without invoking either callback" $ do + calls <- newIORef ([] :: [Text]) + result <- + runBlueprintMigrationsWith + (\_ _ _ -> modifyIORef' calls (<> ["launch"]) >> pure (Right ())) + (\_ -> modifyIORef' calls (<> ["record"]) >> pure (Right ())) + [] + result `shouldBe` BlueprintMigrationNoWork + readIORef calls `shouldReturn` [] + + it "launches and records every edge sequentially" $ do + calls <- newIORef ([] :: [Text]) + let launch position total edge = do + modifyIORef' calls (<> ["launch " <> tshow position <> "/" <> tshow total <> " " <> edge.from]) + pure (Right ()) + record edge = do + modifyIORef' calls (<> ["record " <> edge.from]) + pure (Right ()) + result <- runBlueprintMigrationsWith launch record [first, second] + result `shouldBe` BlueprintMigrationComplete [first, second] + readIORef calls + `shouldReturn` [ "launch 1/2 1.0.0", + "record 1.0.0", + "launch 2/2 2.0.0", + "record 2.0.0" + ] + + it "records only completed edges after failure and resumes at the failed edge" $ do + calls <- newIORef ([] :: [Text]) + recorded <- newIORef ([] :: [AppliedBlueprintMigration]) + let third = migration "3.0.0" "4.0.0" + migrationPlan = + BlueprintMigrationPlan + { blueprintPlanName = "payments", + blueprintPlanFrom = version "1.0.0", + blueprintPlanTo = version "4.0.0", + blueprintPlanSteps = [first, second, third] + } + launch _ _ edge = do + modifyIORef' calls (<> ["launch " <> edge.from]) + pure $ + if edge == second + then Left (BlueprintMigrationProcessFailure (ExitFailure 17)) + else Right () + record edge = do + modifyIORef' calls (<> ["record " <> edge.from]) + modifyIORef' recorded (<> [receipt blueprintName edge.from edge.to]) + pure (Right ()) + result <- runBlueprintMigrationsWith launch record [first, second, third] + result + `shouldBe` BlueprintMigrationLaunchFailed second (BlueprintMigrationProcessFailure (ExitFailure 17)) + readIORef calls + `shouldReturn` ["launch 1.0.0", "record 1.0.0", "launch 2.0.0"] + + savedReceipts <- readIORef recorded + let resumed = pendingBlueprintMigrations False blueprintName savedReceipts migrationPlan + resumed `shouldBe` [second, third] + + resumedResult <- + runBlueprintMigrationsWith + (\_ _ edge -> modifyIORef' calls (<> ["resume " <> edge.from]) >> pure (Right ())) + record + resumed + resumedResult `shouldBe` BlueprintMigrationComplete [second, third] + readIORef recorded `shouldReturn` map (\edge -> receipt blueprintName edge.from edge.to) [first, second, third] + + it "stops before the next launch when receipt recording fails" $ do + calls <- newIORef ([] :: [Text]) + let launch _ _ edge = modifyIORef' calls (<> ["launch " <> edge.from]) >> pure (Right ()) + record edge = modifyIORef' calls (<> ["record " <> edge.from]) >> pure (Left "disk full") + result <- runBlueprintMigrationsWith launch record [first, second] + result `shouldBe` BlueprintMigrationRecordFailed first "disk full" + readIORef calls `shouldReturn` ["launch 1.0.0", "record 1.0.0"] + +blueprintName :: ModuleName +blueprintName = "payments" + +first :: BlueprintMigration +first = migration "1.0.0" "2.0.0" + +second :: BlueprintMigration +second = migration "2.0.0" "3.0.0" + +migration :: Text -> Text -> BlueprintMigration +migration fromVersion toVersion = + migrationWithPrompt fromVersion toVersion ("Migrate from " <> fromVersion <> " to " <> toVersion) + +migrationWithPrompt :: Text -> Text -> Text -> BlueprintMigration +migrationWithPrompt fromVersion toVersion instructions = + BlueprintMigration + { from = fromVersion, + to = toVersion, + prompt = instructions + } + +plan :: [BlueprintMigration] -> BlueprintMigrationPlan +plan steps = + BlueprintMigrationPlan + { blueprintPlanName = "payments", + blueprintPlanFrom = version "1.0.0", + blueprintPlanTo = version "3.0.0", + blueprintPlanSteps = steps + } + +receipt :: ModuleName -> Text -> Text -> AppliedBlueprintMigration +receipt name fromVersion toVersion = + AppliedBlueprintMigration + { name, + blueprintVersion = Just "4.2.0", + fromVersion, + toVersion, + appliedAt = read "2026-07-20 12:00:00 UTC" :: UTCTime, + agentSessionId = Nothing + } + +version :: Text -> Version +version raw = + case parseVersion raw of + Just parsed -> parsed + Nothing -> error "test version should parse" + +tshow :: (Show a) => a -> Text +tshow = T.pack . show + +sampleContext :: AgentContext +sampleContext = + AgentContext + { cwd = "/tmp/project", + seihouInitialized = True, + hasManifest = False, + localModuleDhall = False, + localModules = [], + availableModules = [] + } + +samplePrepared :: PreparedBlueprintExecution +samplePrepared = + let declaration = VarDecl "library.name" VTText Nothing Nothing False Nothing + resolved = + Map.singleton + "library.name" + (ResolvedVar (VText "baikai") FromDefault declaration) + blueprint = + Blueprint + { name = blueprintName, + version = Just "4.2.0", + description = Just "Payments upgrade", + prompt = "Shared guidance for {{library.name}}.", + vars = [declaration], + prompts = [], + baseModules = [], + files = [], + allowedTools = Nothing, + tags = [], + migrations = [first, second] + } + in PreparedBlueprintExecution + { preparedBlueprint = blueprint, + preparedBlueprintDir = "/tmp/payments", + preparedResolvedVariables = resolved, + preparedMountedFilesDir = Just "/tmp/payments/files", + preparedReferenceFiles = " - guide.md", + preparedReferenceFilesAccess = "mounted at /tmp/payments/files", + preparedSharedPrompt = "Shared guidance for baikai.", + preparedAllowedTools = ["Read"] + } diff --git a/test/Seihou/CLI/CommandExecutionSpec.hs b/test/Seihou/CLI/CommandExecutionSpec.hs new file mode 100644 --- /dev/null +++ b/test/Seihou/CLI/CommandExecutionSpec.hs @@ -0,0 +1,158 @@ +module Seihou.CLI.CommandExecutionSpec (tests) where + +import Data.Map.Strict qualified as Map +import Data.Maybe (fromJust) +import Data.Time (UTCTime, defaultTimeLocale, parseTimeOrError) +import Effectful (runPureEff) +import Seihou.CLI.CommandExecution +import Seihou.Core.CommandFingerprint (fingerprintCommand) +import Seihou.Core.Types +import Seihou.Effect.ProcessPure (ProcessMock (..), runProcessPure) +import Seihou.Prelude +import System.Exit (ExitCode (..)) +import Test.Hspec +import Test.Tasty +import Test.Tasty.Hspec (testSpec) + +tests :: IO TestTree +tests = testSpec "Seihou.CLI.CommandExecution" spec + +fixedTime :: UTCTime +fixedTime = parseTimeOrError True defaultTimeLocale "%Y-%m-%dT%H:%M:%SZ" "2026-07-19T18:00:00Z" + +laterTime :: UTCTime +laterTime = parseTimeOrError True defaultTimeLocale "%Y-%m-%dT%H:%M:%SZ" "2026-07-19T19:00:00Z" + +commandOp :: Text -> Maybe FilePath -> ModuleName -> Int -> Operation +commandOp command workDir moduleName occurrence = + RunCommandOp {command, workDir, moduleName, occurrence} + +fingerprintOf :: Operation -> CommandFingerprint +fingerprintOf = fromJust . fingerprintCommand + +receiptFor :: UTCTime -> Operation -> CommandReceipt +receiptFor completedAt operation@RunCommandOp {command, workDir, moduleName} = + CommandReceipt + { fingerprint = fingerprintOf operation, + moduleName, + command, + workDir, + completedAt + } +receiptFor _ _ = error "receiptFor requires RunCommandOp" + +successMock :: Text -> ProcessMock +successMock command = + ProcessMock + { mockCommand = "sh", + mockArgs = ["-c", command], + mockResult = (ExitSuccess, "output", "") + } + +spec :: Spec +spec = do + describe "planCommands" $ do + it "preserves command order and ignores non-command operations" $ do + let first = commandOp "echo first" Nothing "app" 0 + second = commandOp "echo second" Nothing "app" 0 + plan = planCommands RunAllCommands Map.empty [first, WriteFileOp "file" "content" Template, second] + map (.operation) plan.commands `shouldBe` [first, second] + map (.disposition) plan.commands `shouldBe` [CommandWillRun, CommandWillRun] + + it "skips only fingerprints with successful prior receipts in changed-only mode" $ do + let unchanged = commandOp "echo same" Nothing "app" 0 + changed = commandOp "echo changed" Nothing "app" 0 + prior = Map.singleton (fingerprintOf unchanged) (receiptFor fixedTime unchanged) + plan = planCommands RunChangedCommands prior [unchanged, changed] + map (.disposition) plan.commands + `shouldBe` [CommandSkippedUnchanged, CommandWillRun] + summarizeCommandPlan plan + `shouldBe` CommandPlanSummary {willRun = 1, skippedUnchanged = 1, skippedDisabled = 0} + + it "runs duplicate declarations independently because occurrences differ" $ do + let first = commandOp "echo same" Nothing "app" 0 + second = commandOp "echo same" Nothing "app" 1 + prior = Map.singleton (fingerprintOf first) (receiptFor fixedTime first) + plan = planCommands RunChangedCommands prior [first, second] + map (.disposition) plan.commands + `shouldBe` [CommandSkippedUnchanged, CommandWillRun] + + it "marks every command disabled without minting receipts" $ do + let operations = [commandOp "echo one" Nothing "app" 0, commandOp "echo two" Nothing "app" 0] + plan = planCommands DisableCommands Map.empty operations + map (.disposition) plan.commands + `shouldBe` [CommandSkippedDisabled, CommandSkippedDisabled] + + describe "executeCommandPlan" $ do + it "executes runnable commands in order and returns successful receipts" $ do + let first = commandOp "echo first" Nothing "app" 0 + second = commandOp "echo second" (Just "subdir") "app" 0 + plan = planCommands RunAllCommands Map.empty [first, second] + result = + runPureEff $ + runProcessPure [successMock "echo first", successMock "echo second"] $ + executeCommandPlan laterTime plan + case result of + Right receipts -> do + map (.fingerprint) receipts `shouldBe` map fingerprintOf [first, second] + map (.completedAt) receipts `shouldBe` [laterTime, laterTime] + Left err -> expectationFailure ("Expected success, got: " <> show err) + + it "does not execute skipped commands" $ do + let operation = commandOp "echo skipped" Nothing "app" 0 + priorReceipt = receiptFor fixedTime operation + prior = Map.singleton priorReceipt.fingerprint priorReceipt + plan = planCommands RunChangedCommands prior [operation] + result = runPureEff $ runProcessPure [] $ executeCommandPlan laterTime plan + result `shouldBe` Right [] + + it "returns a structured error at the first failure" $ do + let failing = commandOp "exit 7" Nothing "app" 0 + neverReached = commandOp "echo later" Nothing "app" 0 + plan = planCommands RunAllCommands Map.empty [failing, neverReached] + mocks = + [ ProcessMock + { mockCommand = "sh", + mockArgs = ["-c", "exit 7"], + mockResult = (ExitFailure 7, "partial", "boom") + }, + successMock "echo later" + ] + result = runPureEff $ runProcessPure mocks $ executeCommandPlan laterTime plan + case result of + Left err -> do + err.exitCode `shouldBe` 7 + err.stdout `shouldBe` "partial" + err.stderr `shouldBe` "boom" + err.command.operation `shouldBe` failing + Right receipts -> expectationFailure ("Expected failure, got receipts: " <> show receipts) + + describe "finalizeCommandReceipts" $ do + it "keeps fresh successes and unchanged receipts while dropping removed commands" $ do + let unchanged = commandOp "echo unchanged" Nothing "app" 0 + changed = commandOp "echo changed" Nothing "app" 0 + removed = commandOp "echo removed" Nothing "app" 0 + oldUnchanged = receiptFor fixedTime unchanged + oldRemoved = receiptFor fixedTime removed + newChanged = receiptFor laterTime changed + prior = + Map.fromList + [ (oldUnchanged.fingerprint, oldUnchanged), + (oldRemoved.fingerprint, oldRemoved) + ] + plan = planCommands RunChangedCommands prior [unchanged, changed] + finalized = finalizeCommandReceipts plan [newChanged] prior + finalized + `shouldBe` Map.fromList + [ (oldUnchanged.fingerprint, oldUnchanged), + (newChanged.fingerprint, newChanged) + ] + + it "retains only matching old receipts when commands are disabled" $ do + let old = commandOp "echo old" Nothing "app" 0 + new = commandOp "echo new" Nothing "app" 0 + oldReceipt = receiptFor fixedTime old + prior = Map.singleton oldReceipt.fingerprint oldReceipt + plan = planCommands DisableCommands prior [old, new] + finalizeCommandReceipts plan [] prior + `shouldBe` Map.singleton oldReceipt.fingerprint oldReceipt diff --git a/test/Seihou/CLI/MigrateSpec.hs b/test/Seihou/CLI/MigrateSpec.hs --- a/test/Seihou/CLI/MigrateSpec.hs +++ b/test/Seihou/CLI/MigrateSpec.hs @@ -129,7 +129,9 @@ { hash = hashContent content, moduleName = modName, strategy = Template, - generatedAt = fixedTime + generatedAt = fixedTime, + baseline = Nothing, + applicationIds = mempty } ) | (path, content) <- entries @@ -269,7 +271,9 @@ { hash = hashContent content, moduleName = ModuleName fix.modName, strategy = Template, - generatedAt = fixedTime + generatedAt = fixedTime, + baseline = Nothing, + applicationIds = mempty } ) | (path, content) <- entries diff --git a/test/Seihou/CLI/StatusSpec.hs b/test/Seihou/CLI/StatusSpec.hs --- a/test/Seihou/CLI/StatusSpec.hs +++ b/test/Seihou/CLI/StatusSpec.hs @@ -15,10 +15,16 @@ MigrationPlan (..), ) import Seihou.Core.Types - ( AppliedBlueprint (..), + ( ApplicationId (..), + AppliedBlueprint (..), + AppliedBlueprintMigration (..), + AppliedComposition (..), + AppliedInstanceState (..), AppliedModule (..), + AppliedTarget (..), Manifest (..), ModuleName (..), + RecipeName (..), emptyParentVars, ) import Seihou.Core.Version qualified @@ -56,6 +62,30 @@ files = Map.empty } +mkApplication :: Text -> [Text] -> AppliedComposition +mkApplication target modules = + AppliedComposition + { applicationId = ApplicationId ("app-" <> target), + target = AppliedRecipeTarget (RecipeName target), + targetSource = "/installed/" <> T.unpack target, + targetVersion = Just "1.0.0", + additionalModules = [], + namespace = Nothing, + context = Nothing, + instances = map mkInstance modules, + commandReceipts = Map.empty, + appliedAt = fixedTime + } + where + mkInstance name = + AppliedInstanceState + { name = ModuleName name, + parentVars = emptyParentVars, + source = "/installed/" <> T.unpack name, + moduleVersion = Just "1.0.0", + resolvedVars = Map.empty + } + -- | Build a 'MigrationPlan' fixture for use with formatStatus. mkPlan :: Text -> Text -> Text -> Int -> MigrationPlan mkPlan modName from to nSteps = @@ -101,6 +131,17 @@ withManifestBlueprint :: Maybe AppliedBlueprint -> Manifest -> Manifest withManifestBlueprint mb m = m {blueprint = mb} +mkBlueprintMigrationReceipt :: Text -> Maybe Text -> Text -> Text -> AppliedBlueprintMigration +mkBlueprintMigrationReceipt blueprintName artifactVersion fromVersion toVersion = + AppliedBlueprintMigration + { name = ModuleName blueprintName, + blueprintVersion = artifactVersion, + fromVersion = fromVersion, + toVersion = toVersion, + appliedAt = fixedTime, + agentSessionId = Nothing + } + spec :: Spec spec = describe "formatStatus" $ do describe "blueprint provenance" $ do @@ -165,6 +206,19 @@ out `shouldSatisfy` T.isInfixOf "Blueprint: pure-prompt (applied" out `shouldSatisfy` T.isInfixOf " Baseline: (none declared)" + describe "blueprint migration receipts" $ do + it "omits the section for an empty ledger" $ do + let out = formatStatus False (mkManifest []) [] Nothing [] + out `shouldNotSatisfy` T.isInfixOf "Blueprint migrations:" + + it "renders blueprint name, artifact version, exact edge, and timestamp" $ do + let receipt = mkBlueprintMigrationReceipt "payments" (Just "0.4.0") "1.0.0" "2.0.0" + manifest = (mkManifest []) {blueprintMigrations = [receipt]} + out = formatStatus False manifest [] Nothing [] + out `shouldSatisfy` T.isInfixOf "Blueprint migrations:" + out `shouldSatisfy` T.isInfixOf "payments v0.4.0: 1.0.0 -> 2.0.0" + out `shouldSatisfy` T.isInfixOf "2026-04-15 10:00 UTC" + it "all modules clean: no remediation, no Recommended actions block" $ do let am = mkApplied "demo" (Just "1.0.0") manifest = mkManifest [am] @@ -176,29 +230,29 @@ out `shouldNotSatisfy` T.isInfixOf "Recommended actions" out `shouldNotSatisfy` T.isInfixOf "Pending migration" - it "outdated only (no migration declared): per-row upgrade hint and summary entry" $ do + it "outdated only recommends the project-aware update workflow" $ do let am = mkApplied "demo" (Just "0.1.0") manifest = mkManifest [am] entries = Just [mkEntry "demo" (Just "0.1.0") (Just "0.3.0") OutdatedSt] out = formatStatus False manifest [] entries [] out `shouldSatisfy` T.isInfixOf "outdated: 0.3.0 available" - out `shouldSatisfy` T.isInfixOf "Run: seihou upgrade demo" + out `shouldSatisfy` T.isInfixOf "Run: seihou update demo" out `shouldSatisfy` T.isInfixOf "Recommended actions:" - out `shouldSatisfy` T.isInfixOf " seihou upgrade demo" + out `shouldSatisfy` T.isInfixOf " seihou update demo" out `shouldNotSatisfy` T.isInfixOf "Pending migration" - it "pending migration (full chain): per-row migrate hint and summary" $ do + it "pending migration keeps detail and recommends update" $ do let am = mkApplied "demo" (Just "1.0.0") manifest = mkManifest [am] plan = mkPlan "demo" "1.0.0" "2.0.0" 1 out = formatStatus False manifest [] Nothing [(ModuleName "demo", plan)] out `shouldSatisfy` T.isInfixOf "Pending migration: 1.0.0 -> 2.0.0 (1 step(s))" - out `shouldSatisfy` T.isInfixOf "Run: seihou migrate demo" + out `shouldSatisfy` T.isInfixOf "Run: seihou update demo" out `shouldSatisfy` T.isInfixOf "Recommended actions:" - out `shouldSatisfy` T.isInfixOf " seihou migrate demo" + out `shouldSatisfy` T.isInfixOf " seihou update demo" out `shouldNotSatisfy` T.isInfixOf "seihou upgrade" - it "outdated + pending migration: single migrate hint, no upgrade hint" $ do + it "outdated plus pending migration produces one update hint" $ do let am = mkApplied "demo" (Just "0.1.0") manifest = mkManifest [am] plan = mkPlan "demo" "0.1.0" "0.3.0" 6 @@ -206,15 +260,15 @@ out = formatStatus False manifest [] entries [(ModuleName "demo", plan)] out `shouldSatisfy` T.isInfixOf "outdated: 0.3.0 available" out `shouldSatisfy` T.isInfixOf "Pending migration: 0.1.0 -> 0.3.0 (6 step(s))" - out `shouldSatisfy` T.isInfixOf "Run: seihou migrate demo" + out `shouldSatisfy` T.isInfixOf "Run: seihou update demo" out `shouldNotSatisfy` T.isInfixOf "seihou upgrade demo" out `shouldSatisfy` T.isInfixOf "Recommended actions:" - out `shouldSatisfy` T.isInfixOf " seihou migrate demo" + out `shouldSatisfy` T.isInfixOf " seihou update demo" -- Master-plan live-tree fixture: manifest=0.1.0, installed=0.3.0, -- declared [0.1.0 → 0.2.0]. The chain reaches 0.2 via ops; the -- supplied target is 0.3, so planTo = 0.3. Status surfaces the - -- single in-window step and points at `seihou migrate demo` as the + -- single in-window step and points at `seihou update demo` as the -- remediation. it "partial-cover plan: chain reaches an intermediate version, target is the user's installed copy" $ do let am = mkApplied "demo" (Just "0.1.0") @@ -222,9 +276,9 @@ plan = mkPlan "demo" "0.1.0" "0.3.0" 1 out = formatStatus False manifest [] Nothing [(ModuleName "demo", plan)] out `shouldSatisfy` T.isInfixOf "Pending migration: 0.1.0 -> 0.3.0 (1 step(s))" - out `shouldSatisfy` T.isInfixOf "Run: seihou migrate demo" + out `shouldSatisfy` T.isInfixOf "Run: seihou update demo" out `shouldSatisfy` T.isInfixOf "Recommended actions:" - out `shouldSatisfy` T.isInfixOf " seihou migrate demo" + out `shouldSatisfy` T.isInfixOf " seihou update demo" -- Doomed vocabulary is gone from status output. out `shouldNotSatisfy` T.isInfixOf "Blocked" out `shouldNotSatisfy` T.isInfixOf "no migration declared from" @@ -246,10 +300,49 @@ } out = formatStatus False manifest [] Nothing [(ModuleName "demo", plan)] out `shouldSatisfy` T.isInfixOf "Pending migration: 0.2.0 -> 0.3.0 (0 step(s))" - out `shouldSatisfy` T.isInfixOf "Run: seihou migrate demo" + out `shouldSatisfy` T.isInfixOf "Run: seihou update demo" out `shouldSatisfy` T.isInfixOf "Recommended actions:" - out `shouldSatisfy` T.isInfixOf " seihou migrate demo" + out `shouldSatisfy` T.isInfixOf " seihou update demo" -- The doomed vocabulary stays out of the rendered status. out `shouldNotSatisfy` T.isInfixOf "Blocked" out `shouldNotSatisfy` T.isInfixOf "--bump-only" out `shouldNotSatisfy` T.isInfixOf "[blocked]" + + it "deduplicates repeated instances into one recipe application action" $ do + let duplicate = mkApplied "demo" (Just "1.0.0") + manifest = + (mkManifest [duplicate, duplicate]) + { applications = [mkApplication "stack" ["demo", "demo"]] + } + plan = mkPlan "demo" "1.0.0" "2.0.0" 1 + out = formatStatus False manifest [] Nothing [(ModuleName "demo", plan)] + recommendationLines = filter (== " seihou update stack") (T.lines out) + recommendationLines `shouldBe` [" seihou update stack"] + T.count "seihou update stack" out `shouldBe` 1 + out `shouldNotSatisfy` T.isInfixOf " seihou migrate demo" + + it "recommends each affected application plus the whole-project update" $ do + let shared = mkApplied "shared" (Just "1.0.0") + manifest = + (mkManifest [shared]) + { applications = + [ mkApplication "stack-one" ["shared"], + mkApplication "stack-two" ["shared"] + ] + } + plan = mkPlan "shared" "1.0.0" "2.0.0" 1 + out = formatStatus False manifest [] Nothing [(ModuleName "shared", plan)] + recommendationLines = dropWhile (/= "Recommended actions:") (T.lines out) + recommendationLines + `shouldBe` [ "Recommended actions:", + " seihou update stack-one", + " seihou update stack-two", + " seihou update" + ] + + it "deduplicates legacy instances by bare module name" $ do + let duplicate = mkApplied "demo" (Just "1.0.0") + manifest = mkManifest [duplicate, duplicate] + plan = mkPlan "demo" "1.0.0" "2.0.0" 1 + out = formatStatus False manifest [] Nothing [(ModuleName "demo", plan)] + T.count "seihou update demo" out `shouldBe` 2 diff --git a/test/Seihou/CLI/UpdateE2ESpec.hs b/test/Seihou/CLI/UpdateE2ESpec.hs new file mode 100644 --- /dev/null +++ b/test/Seihou/CLI/UpdateE2ESpec.hs @@ -0,0 +1,182 @@ +module Seihou.CLI.UpdateE2ESpec (tests) where + +import Data.ByteString.Lazy qualified as LBS +import Data.Text qualified as T +import Data.Text.IO qualified as TIO +import Seihou.CLI.UpdateSpec (UpdateFixture (..), prepareUpdateFixture) +import System.Directory (doesFileExist) +import System.Environment (getEnvironment, getExecutablePath) +import System.Exit (ExitCode (..)) +import System.FilePath (takeDirectory, ()) +import System.IO.Temp (withSystemTempDirectory) +import System.Process (CreateProcess (..), callProcess, proc, readCreateProcessWithExitCode, readProcess) +import Test.Hspec +import Test.Tasty +import Test.Tasty.Hspec (testSpec) + +tests :: IO TestTree +tests = testSpec "Update end-to-end" spec + +spec :: Spec +spec = do + it "updates through the executable and preserves a non-overlapping user edit" $ + withSystemTempDirectory "seihou-update-executable" $ \root -> do + fixture <- prepareUpdateFixture root + binary <- seihouBinary + TIO.writeFile fixture.projectFile "hello accepted by-user\nkeep\nv1\n" + (exitCode, stdoutText, stderrText) <- runSeihou binary fixture ["update", "demo", "--json"] + case exitCode of + ExitSuccess -> pure () + ExitFailure code -> expectationFailure ("update exited " <> show code <> "\nstdout:\n" <> T.unpack stdoutText <> "\nstderr:\n" <> T.unpack stderrText) + stdoutText `shouldSatisfy` T.isInfixOf "\"outcome\":\"applied\"" + stdoutText `shouldSatisfy` T.isInfixOf "\"skippedUnchanged\":1" + stdoutText `shouldNotSatisfy` T.isInfixOf "Apply?" + stderrText `shouldNotSatisfy` T.isInfixOf "Apply?" + TIO.readFile fixture.projectFile `shouldReturn` "hello accepted by-user\nkeep\nv2\n" + TIO.readFile (fixture.installedModule <> "/module.dhall") + `shouldReturnSatisfy` T.isInfixOf "Some \"2.0.0\"" + doesFileExist (fixture.projectRoot <> "/command.log") `shouldReturn` False + (statusExit, statusOut, _) <- runSeihou binary fixture ["status"] + statusExit `shouldBe` ExitSuccess + statusOut `shouldNotSatisfy` T.isInfixOf "seihou update demo" + afterApply <- LBS.readFile fixture.manifestPath + (noOpExit, noOpOut, noOpErr) <- runSeihou binary fixture ["update", "demo", "--json"] + noOpExit `shouldBe` ExitSuccess + noOpOut `shouldSatisfy` T.isInfixOf "\"alreadyUpToDate\":true" + noOpOut `shouldSatisfy` T.isInfixOf "\"outcome\":\"plan\"" + noOpErr `shouldNotSatisfy` T.isInfixOf "Apply?" + LBS.readFile fixture.manifestPath `shouldReturn` afterApply + + it "keeps project, manifest, and installed cache byte-identical for JSON dry-run" $ + withSystemTempDirectory "seihou-update-executable-dry" $ \root -> do + fixture <- prepareUpdateFixture root + binary <- seihouBinary + beforeProject <- TIO.readFile fixture.projectFile + beforeManifest <- LBS.readFile fixture.manifestPath + beforeInstalled <- TIO.readFile (fixture.installedModule <> "/module.dhall") + (exitCode, stdoutText, _) <- runSeihou binary fixture ["update", "--dry-run", "--json"] + exitCode `shouldBe` ExitSuccess + stdoutText `shouldSatisfy` T.isInfixOf "\"outcome\":\"plan\"" + TIO.readFile fixture.projectFile `shouldReturn` beforeProject + LBS.readFile fixture.manifestPath `shouldReturn` beforeManifest + TIO.readFile (fixture.installedModule <> "/module.dhall") `shouldReturn` beforeInstalled + + it "commits exactly the managed update paths with a requested Conventional Commit message" $ + withSystemTempDirectory "seihou-update-executable-commit" $ \root -> do + fixture <- prepareUpdateFixture root + binary <- seihouBinary + callProcess "git" ["-C", fixture.projectRoot, "init", "-q"] + callProcess "git" ["-C", fixture.projectRoot, "config", "user.name", "Seihou Test"] + callProcess "git" ["-C", fixture.projectRoot, "config", "user.email", "test@example.com"] + callProcess "git" ["-C", fixture.projectRoot, "add", "."] + callProcess "git" ["-C", fixture.projectRoot, "commit", "-qm", "test: record v1 fixture"] + (exitCode, stdoutText, stderrText) <- + runSeihou + binary + fixture + ["update", "demo", "--json", "--commit-message", "chore(seihou): update demo"] + case exitCode of + ExitSuccess -> pure () + ExitFailure code -> expectationFailure ("update exited " <> show code <> "\nstdout:\n" <> T.unpack stdoutText <> "\nstderr:\n" <> T.unpack stderrText) + subject <- T.strip . T.pack <$> readProcess "git" ["-C", fixture.projectRoot, "log", "-1", "--pretty=%s"] "" + subject `shouldBe` "chore(seihou): update demo" + worktree <- T.strip . T.pack <$> readProcess "git" ["-C", fixture.projectRoot, "status", "--porcelain"] "" + worktree `shouldBe` "" + + it "retains an edited orphan under --force" $ + withSystemTempDirectory "seihou-update-executable-orphan" $ \root -> do + fixture <- prepareUpdateFixture root + binary <- seihouBinary + let modulePath = fixture.remote <> "/module.dhall" + moduleBody <- TIO.readFile modulePath + TIO.writeFile + modulePath + ( T.replace + ", steps = [{ strategy = \"template\", src = \"README.tmpl\", dest = \"README.md\", when = None Text, patch = None Text }]" + ", steps = [] : List { strategy : Text, src : Text, dest : Text, when : Optional Text, patch : Optional Text }" + moduleBody + ) + callProcess "git" ["-C", fixture.remote, "add", "module.dhall"] + callProcess "git" ["-C", fixture.remote, "-c", "user.name=Seihou Test", "-c", "user.email=test@example.com", "commit", "-qm", "remove generated file"] + TIO.writeFile fixture.projectFile "user-owned orphan\n" + (exitCode, stdoutText, stderrText) <- runSeihou binary fixture ["update", "demo", "--force", "--json"] + case exitCode of + ExitSuccess -> pure () + ExitFailure code -> expectationFailure ("update exited " <> show code <> "\nstdout:\n" <> T.unpack stdoutText <> "\nstderr:\n" <> T.unpack stderrText) + stdoutText `shouldSatisfy` T.isInfixOf "\"editedOrphans\":1" + TIO.readFile fixture.projectFile `shouldReturn` "user-owned orphan\n" + TIO.readFile fixture.manifestPath `shouldReturnSatisfy` T.isInfixOf "README.md" + + it "reports an unresolved overlap before publishing project, manifest, or cache state" $ + withSystemTempDirectory "seihou-update-executable-conflict" $ \root -> do + fixture <- prepareUpdateFixture root + binary <- seihouBinary + TIO.writeFile (fixture.remote <> "/files/README.tmpl") "candidate {{project.name}}\nkeep\nv2\n" + callProcess "git" ["-C", fixture.remote, "add", "files/README.tmpl"] + callProcess "git" ["-C", fixture.remote, "-c", "user.name=Seihou Test", "-c", "user.email=test@example.com", "commit", "-qm", "overlap"] + TIO.writeFile fixture.projectFile "user accepted\nkeep\nv1\n" + beforeManifest <- LBS.readFile fixture.manifestPath + beforeInstalled <- LBS.readFile (fixture.installedModule <> "/module.dhall") + (exitCode, stdoutText, _) <- runSeihou binary fixture ["update", "demo", "--json"] + exitCode `shouldSatisfy` (/= ExitSuccess) + stdoutText `shouldSatisfy` T.isInfixOf "\"code\":\"unresolved_conflicts\"" + TIO.readFile fixture.projectFile `shouldReturn` "user accepted\nkeep\nv1\n" + LBS.readFile fixture.manifestPath `shouldReturn` beforeManifest + LBS.readFile (fixture.installedModule <> "/module.dhall") `shouldReturn` beforeInstalled + (forceExit, forceOut, forceErr) <- runSeihou binary fixture ["update", "demo", "--force", "--json"] + case forceExit of + ExitSuccess -> pure () + ExitFailure code -> expectationFailure ("forced update exited " <> show code <> "\nstdout:\n" <> T.unpack forceOut <> "\nstderr:\n" <> T.unpack forceErr) + forceOut `shouldSatisfy` T.isInfixOf "\"outcome\":\"applied\"" + TIO.readFile fixture.projectFile `shouldReturn` "candidate accepted\nkeep\nv2\n" + + it "exposes update and its options through the shared Bash, Zsh, and Fish completion protocol" $ do + binary <- seihouBinary + (topExit, topOutput, _) <- runProcessText binary ["--bash-completion-enriched", "--bash-completion-index", "0"] Nothing Nothing + topExit `shouldBe` ExitSuccess + topOutput `shouldSatisfy` T.isInfixOf "update\tUpdate recorded project applications" + (optionExit, optionOutput, _) <- + runProcessText + binary + [ "--bash-completion-enriched", + "--bash-completion-index", + "2", + "--bash-completion-word", + "seihou", + "--bash-completion-word", + "update" + ] + Nothing + Nothing + optionExit `shouldBe` ExitSuccess + optionOutput `shouldSatisfy` T.isInfixOf "--force\tUse generated content" + (exclusiveExit, _, exclusiveErr) <- + runProcessText binary ["update", "--run-all-commands", "--no-commands"] Nothing Nothing + exclusiveExit `shouldSatisfy` (/= ExitSuccess) + exclusiveErr `shouldSatisfy` T.isInfixOf "Invalid option" + mapM_ + ( \shell -> do + (shellExit, script, _) <- runProcessText binary ["completions", shell] Nothing Nothing + shellExit `shouldBe` ExitSuccess + script `shouldSatisfy` T.isInfixOf "bash-completion" + ) + ["bash", "zsh", "fish"] + +seihouBinary :: IO FilePath +seihouBinary = do + testBinary <- getExecutablePath + pure (takeDirectory (takeDirectory testBinary) "seihou" "seihou") + +runSeihou :: FilePath -> UpdateFixture -> [String] -> IO (ExitCode, T.Text, T.Text) +runSeihou binary fixture args = do + inherited <- getEnvironment + let environment = ("XDG_CONFIG_HOME", fixture.xdgHome) : filter ((/= "XDG_CONFIG_HOME") . fst) inherited + runProcessText binary args (Just fixture.projectRoot) (Just environment) + +runProcessText binary args workingDirectory environment = do + let command = (proc binary args) {cwd = workingDirectory, env = environment} + (exitCode, stdoutText, stderrText) <- readCreateProcessWithExitCode command "" + pure (exitCode, T.pack stdoutText, T.pack stderrText) + +shouldReturnSatisfy :: IO T.Text -> (T.Text -> Bool) -> Expectation +shouldReturnSatisfy action predicate = action >>= (`shouldSatisfy` predicate) diff --git a/test/Seihou/CLI/UpdateFixture.hs b/test/Seihou/CLI/UpdateFixture.hs new file mode 100644 --- /dev/null +++ b/test/Seihou/CLI/UpdateFixture.hs @@ -0,0 +1,135 @@ +module Seihou.CLI.UpdateFixture + ( minimalPlan, + conflictPlan, + unavailableConflictPlan, + orphanPlan, + ) +where + +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set +import Data.Time (UTCTime, defaultTimeLocale, parseTimeOrError) +import Seihou.CLI.CommandExecution (CommandPlan (..), CommandPolicy (..)) +import Seihou.CLI.Update + ( InputChangeSummary (..), + PromptPolicy (..), + UpdatePlan (..), + UpdateRequest (..), + UpdateSelection (..), + ) +import Seihou.CLI.Update.Types (UpdateSnapshot (..)) +import Seihou.Core.Types + ( FileRecord (..), + ModuleName (..), + SHA256 (..), + Strategy (..), + ) +import Seihou.Engine.Reconcile + ( DesiredFile (..), + FileReconciliation (..), + ObservedFile (..), + ReconciliationPlan (..), + ReconciliationReason (..), + ) +import Seihou.Manifest.Types (emptyManifest) + +fixedTime :: UTCTime +fixedTime = + parseTimeOrError True defaultTimeLocale "%Y-%m-%dT%H:%M:%SZ" "2026-07-19T12:00:00Z" + +minimalPlan :: ReconciliationPlan -> UpdatePlan +minimalPlan reconciliation = + UpdatePlan + { applications = [], + versionChanges = [], + inputChanges = InputChangeSummary 0 0 0 0 [], + migrations = [], + reconciliation, + commandPlan = CommandPlan [], + candidateArtifacts = [], + warnings = [], + request = + UpdateRequest + { selection = AllRecordedApplications, + varOverrides = [], + reconfigure = False, + promptPolicy = ForbidPrompts, + commandPolicy = RunChangedCommands, + dryRun = True + }, + snapshot = + UpdateSnapshot + { sessionDirectory = "/tmp/session", + projectRoot = "/tmp/project", + manifestPath = "/tmp/project/.seihou/manifest.json", + baselineDirectory = "/tmp/project/.seihou/baselines", + installedDirectory = "/tmp/installed", + originalManifest = emptyManifest fixedTime, + candidateHashes = Map.empty, + observedProjectHashes = Map.empty, + transactionTargets = Set.empty + }, + plannedApplications = [] + } + +conflictPlan :: UpdatePlan +conflictPlan = minimalPlan (oneFile conflict) + where + conflict = + FileConflict + desired + "title: user\nbody: old\n" + "<<<<<<< current\ntitle: user\n||||||| baseline\ntitle: old\n=======\ntitle: generated\n>>>>>>> generated\n" + OverlappingEdits + (ObservedFile True (Just (SHA256 "current"))) + Nothing + Nothing + +unavailableConflictPlan :: UpdatePlan +unavailableConflictPlan = minimalPlan (oneFile conflict) + where + conflict = + FileConflict + desired + "binary-current" + "binary-current" + (MergeDriverUnavailable "binary input") + (ObservedFile True (Just (SHA256 "current"))) + Nothing + Nothing + +orphanPlan :: UpdatePlan +orphanPlan = minimalPlan (oneFile orphan) + where + orphan = + FileOrphanEdited + "README.md" + FileRecord + { hash = SHA256 "applied", + moduleName = ModuleName "demo", + strategy = Template, + generatedAt = fixedTime, + baseline = Nothing, + applicationIds = Set.empty + } + "user edit" + (ObservedFile True (Just (SHA256 "current"))) + Nothing + +desired :: DesiredFile +desired = + DesiredFile + { path = "README.md", + generatedContent = "title: generated\nbody: old\n", + moduleName = ModuleName "demo", + strategy = Template, + applicationIds = Set.empty + } + +oneFile :: FileReconciliation -> ReconciliationPlan +oneFile reconciliation = + ReconciliationPlan + { applicationIds = Set.empty, + files = Map.singleton "README.md" reconciliation, + requiredDirectories = Set.empty + } diff --git a/test/Seihou/CLI/UpdateInteractionSpec.hs b/test/Seihou/CLI/UpdateInteractionSpec.hs new file mode 100644 --- /dev/null +++ b/test/Seihou/CLI/UpdateInteractionSpec.hs @@ -0,0 +1,67 @@ +module Seihou.CLI.UpdateInteractionSpec (tests) where + +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set +import Seihou.CLI.Update (UpdatePlan (..)) +import Seihou.CLI.Update.Interaction + ( InteractionError (..), + InteractionMode (..), + ResolutionDecision (..), + applyResolutionDecisions, + forceResolveUpdatePlan, + resolveInteractively, + ) +import Seihou.CLI.UpdateFixture (conflictPlan, orphanPlan, unavailableConflictPlan) +import Seihou.Engine.Reconcile + ( FileConflictChoice (..), + FileReconciliation (..), + OrphanChoice (..), + ReconciliationPlan (..), + ResolvedFileConflict (..), + unresolvedPaths, + ) +import Test.Hspec +import Test.Tasty +import Test.Tasty.Hspec (testSpec) + +tests :: IO TestTree +tests = testSpec "Seihou.CLI.Update.Interaction" spec + +spec :: Spec +spec = do + it "refuses unresolved plans in non-interactive mode" $ do + result <- resolveInteractively NonInteractive conflictPlan + result `shouldBe` Left (InteractionRequired (Set.singleton "README.md")) + + it "force accepts ordinary generated conflicts" $ do + resolved <- expectResolved conflictPlan (forceResolveUpdatePlan conflictPlan) + unresolvedPaths resolved.reconciliation `shouldBe` Set.empty + case Map.lookup "README.md" resolved.reconciliation.files of + Just (FileConflict _ _ _ _ _ _ (Just choice)) -> + choice.choice `shouldBe` AcceptGenerated + other -> expectationFailure ("expected resolved conflict, got " <> show other) + + it "force retains edited orphans as tracked state" $ do + resolved <- expectResolved orphanPlan (forceResolveUpdatePlan orphanPlan) + case Map.lookup "README.md" resolved.reconciliation.files of + Just (FileOrphanEdited _ _ _ _ (Just choice)) -> + choice `shouldBe` RetainTrackedOrphan + other -> expectationFailure ("expected resolved orphan, got " <> show other) + + it "force leaves merge-driver failures unresolved" $ do + resolved <- expectResolved unavailableConflictPlan (forceResolveUpdatePlan unavailableConflictPlan) + unresolvedPaths resolved.reconciliation `shouldBe` Set.singleton "README.md" + + it "applies explicit keep-current and detach-orphan choices without writing" $ do + kept <- expectResolved conflictPlan (applyResolutionDecisions [ResolveFile "README.md" KeepCurrent] conflictPlan) + case Map.lookup "README.md" kept.reconciliation.files of + Just (FileConflict _ _ _ _ _ _ (Just choice)) -> choice.choice `shouldBe` KeepCurrent + other -> expectationFailure ("expected keep-current conflict resolution, got " <> show other) + detached <- expectResolved orphanPlan (applyResolutionDecisions [ResolveOrphan "README.md" DetachAndKeepOrphan] orphanPlan) + case Map.lookup "README.md" detached.reconciliation.files of + Just (FileOrphanEdited _ _ _ _ (Just choice)) -> choice `shouldBe` DetachAndKeepOrphan + other -> expectationFailure ("expected detached orphan resolution, got " <> show other) + +expectResolved fallback result = case result of + Left err -> expectationFailure (show err) >> pure fallback + Right resolved -> pure resolved diff --git a/test/Seihou/CLI/UpdateRenderSpec.hs b/test/Seihou/CLI/UpdateRenderSpec.hs new file mode 100644 --- /dev/null +++ b/test/Seihou/CLI/UpdateRenderSpec.hs @@ -0,0 +1,38 @@ +module Seihou.CLI.UpdateRenderSpec (tests) where + +import Data.List (isInfixOf) +import Data.Text qualified as T +import Seihou.CLI.Update (UpdateError (..)) +import Seihou.CLI.Update.Render + ( encodeUpdateOutput, + errorOutput, + planOutput, + renderUpdateHuman, + ) +import Seihou.CLI.UpdateFixture (conflictPlan) +import Test.Hspec +import Test.Tasty +import Test.Tasty.Hspec (testSpec) + +tests :: IO TestTree +tests = testSpec "Seihou.CLI.Update.Render" spec + +spec :: Spec +spec = do + it "groups a human plan and names unresolved paths" $ do + let rendered = renderUpdateHuman False (planOutput conflictPlan) + rendered `shouldSatisfy` T.isInfixOf "Files:" + rendered `shouldSatisfy` T.isInfixOf "Conflict: README.md" + rendered `shouldSatisfy` T.isInfixOf "Commands:" + + it "emits one versioned JSON plan document" $ do + let rendered = show (encodeUpdateOutput (planOutput conflictPlan)) + rendered `shouldSatisfy` isInfixOf "\\\"schemaVersion\\\":1" + rendered `shouldSatisfy` isInfixOf "\\\"outcome\\\":\\\"plan\\\"" + rendered `shouldSatisfy` isInfixOf "\\\"classification\\\":\\\"conflict\\\"" + + it "uses a stable machine error code" $ do + let rendered = show (encodeUpdateOutput (errorOutput (UpdateManifestMissing ".seihou/manifest.json"))) + rendered `shouldSatisfy` isInfixOf "manifest_missing" + renderUpdateHuman False (errorOutput (UpdateManifestMissing "manifest")) + `shouldSatisfy` T.isInfixOf "Update failed [manifest_missing]" diff --git a/test/Seihou/CLI/UpdateSpec.hs b/test/Seihou/CLI/UpdateSpec.hs new file mode 100644 --- /dev/null +++ b/test/Seihou/CLI/UpdateSpec.hs @@ -0,0 +1,738 @@ +module Seihou.CLI.UpdateSpec + ( tests, + UpdateFixture (..), + prepareUpdateFixture, + ) +where + +import Control.Exception (bracket) +import Data.ByteString.Lazy qualified as LBS +import Data.Map.Strict qualified as Map +import Data.Maybe (fromMaybe, listToMaybe) +import Data.Set qualified as Set +import Data.Text (Text) +import Data.Text qualified as T +import Data.Text.IO qualified as TIO +import Data.Time (UTCTime (..), fromGregorian) +import Seihou.CLI.CommandExecution (CommandPolicy (..)) +import Seihou.CLI.Update (PromptPolicy (..), UpdateRequest (..), UpdateSelection (..), applyProjectUpdate, isUpdateNoOp, withProjectUpdate) +import Seihou.CLI.Update.Migrations (StagedMigrations (..), planAndStageMigrations) +import Seihou.CLI.Update.Selection +import Seihou.CLI.Update.Source +import Seihou.CLI.Update.Types +import Seihou.Composition.Instance (ModuleInstance (..)) +import Seihou.Core.Application (mkApplicationId) +import Seihou.Core.CommandFingerprint (fingerprintCommand) +import Seihou.Core.Migration (Migration (..), MigrationOp (..)) +import Seihou.Core.Types +import Seihou.Manifest.Hash (hashContent) +import Seihou.Manifest.Types (emptyManifest, manifestFromJSON, manifestToJSON) +import System.Directory (createDirectoryIfMissing, doesFileExist, withCurrentDirectory) +import System.Environment (lookupEnv, setEnv, unsetEnv) +import System.FilePath (()) +import System.IO.Temp (withSystemTempDirectory) +import System.Process (callProcess) +import Test.Hspec +import Test.Tasty +import Test.Tasty.Hspec (testSpec) + +tests :: IO TestTree +tests = testSpec "Seihou.CLI.Update" spec + +spec :: Spec +spec = do + describe "application selection" $ do + it "selects every application containing a requested bare module" $ do + let first = application (AppliedModuleTarget "one") [instanceState "shared" "/one/shared"] + second = application (AppliedRecipeTarget "stack") [instanceState "shared" "/two/shared"] + manifest :: Manifest + manifest = manifestForApplications [first, second] Map.empty + selectApplications (NamedUpdateTargets ["shared"]) manifest + `shouldBe` Right (RecordedSelection [first, second]) + + it "keeps manifest order for all applications and deduplicates repeated targets" $ do + let first = application (AppliedModuleTarget "one") [instanceState "one" "/one"] + second = application (AppliedModuleTarget "two") [instanceState "two" "/two"] + manifest :: Manifest + manifest = manifestForApplications [first, second] Map.empty + selectApplications AllRecordedApplications manifest + `shouldBe` Right (RecordedSelection [first, second]) + selectApplications (NamedUpdateTargets ["two", "two", "one"]) manifest + `shouldBe` Right (RecordedSelection [first, second]) + + it "rejects a partial selection that shares an owned path" $ do + let first = application (AppliedModuleTarget "one") [instanceState "one" "/one"] + second = application (AppliedModuleTarget "two") [instanceState "two" "/two"] + owners = Set.fromList [first.applicationId, second.applicationId] + record = FileRecord (hashContent "old") "one" Template testTime Nothing owners + manifest :: Manifest + manifest = manifestForApplications [first, second] (Map.singleton "shared.txt" record) + selectApplications (NamedUpdateTargets ["one"]) manifest + `shouldBe` Left (SharedPathRequiresApplications "shared.txt" (Set.singleton first.applicationId) (Set.singleton second.applicationId)) + + it "requires one explicit target to seed a legacy manifest" $ do + selectApplications AllRecordedApplications (emptyManifest testTime) `shouldBe` Left NoRecordedApplications + selectApplications (NamedUpdateTargets ["one", "two"]) (emptyManifest testTime) + `shouldBe` Left LegacyUpdateRequiresOneTarget + + describe "candidate source staging" $ do + it "keeps local artifacts as an explicit candidate-first fallback" $ + withSystemTempDirectory "seihou-update-source" $ \root -> do + let moduleDirectory = root "current" "demo" + sessionDirectory = root "session" + applied = application (AppliedModuleTarget "demo") [instanceState "demo" moduleDirectory] + createDirectoryIfMissing True moduleDirectory + TIO.writeFile (moduleDirectory "module.dhall") (moduleDhall "demo" "1.0.0") + result <- stageCandidateSources sessionDirectory [applied {targetSource = moduleDirectory}] + case result of + Left err -> expectationFailure (show err) + Right (catalog, warnings) -> do + warnings `shouldContain` [LocalArtifactHasNoRemote "demo"] + let candidate = catalog.artifacts Map.! (CandidateModule, "demo") + candidate.originalDirectory `shouldBe` moduleDirectory + candidate.sourceUrl `shouldBe` Nothing + doesFileExist (catalog.searchRoot "demo" "module.dhall") `shouldReturn` True + + it "clones one registry origin once for a recipe and all of its modules" $ + withSystemTempDirectory "seihou-update-registry-source" $ \root -> do + let remote = root "remote" + installed = root "installed" + moduleOne = installed "one" + moduleTwo = installed "two" + recipeDirectory = installed "stack" + sessionDirectory = root "session" + sourceUrl = T.pack remote + applied = + (application (AppliedRecipeTarget "stack") [instanceState "one" moduleOne, instanceState "two" moduleTwo]) + { targetSource = recipeDirectory, + additionalModules = [] + } + createDirectoryIfMissing True (remote "modules" "one") + createDirectoryIfMissing True (remote "modules" "two") + createDirectoryIfMissing True (remote "recipes" "stack") + TIO.writeFile (remote "modules" "one" "module.dhall") (moduleDhall "one" "2.0.0") + TIO.writeFile (remote "modules" "two" "module.dhall") (moduleDhall "two" "2.0.0") + TIO.writeFile (remote "recipes" "stack" "recipe.dhall") (recipeDhall "stack" "2.0.0" ["one", "two"]) + TIO.writeFile (remote "seihou-registry.dhall") registryDhall + callProcess "git" ["-C", remote, "init", "-q"] + callProcess "git" ["-C", remote, "add", "."] + callProcess "git" ["-C", remote, "-c", "user.name=Seihou Test", "-c", "user.email=test@example.com", "commit", "-qm", "registry"] + mapM_ (writeOrigin sourceUrl) [moduleOne, moduleTwo, recipeDirectory] + result <- stageCandidateSources sessionDirectory [applied] + case result of + Left err -> expectationFailure (show err) + Right (catalog, _) -> do + Map.size catalog.clonedOrigins `shouldBe` 1 + Map.keysSet catalog.artifacts + `shouldBe` Set.fromList [(CandidateModule, "one"), (CandidateModule, "two"), (CandidateRecipe, "stack")] + + it "returns a structured clone error before touching the project" $ + withSystemTempDirectory "seihou-update-clone-error" $ \root -> do + let moduleDirectory = root "installed" "demo" + missingRemote = T.pack (root "missing-remote") + applied = (application (AppliedModuleTarget "demo") [instanceState "demo" moduleDirectory]) {targetSource = moduleDirectory} + writeOrigin missingRemote moduleDirectory + result <- stageCandidateSources (root "session") [applied] + result `shouldSatisfy` \case + Left (CandidateCloneFailed url message) -> url == missingRemote && "git clone failed" `T.isInfixOf` message + _ -> False + + describe "staged update service" $ do + it "reuses accepted inputs, keeps dry-run read-only, and publishes one coherent update" $ + withSystemTempDirectory "seihou-update-e2e" $ \root -> do + fixture <- prepareUpdateFixture root + withSavedEnv "XDG_CONFIG_HOME" (Just fixture.xdgHome) $ + withCurrentDirectory fixture.projectRoot $ do + beforeManifest <- LBS.readFile fixture.manifestPath + beforeProject <- TIO.readFile fixture.projectFile + beforeInstalled <- TIO.readFile (fixture.installedModule "module.dhall") + let dryRequest = updateRequest True + dryResult <- withProjectUpdate dryRequest $ \case + Left err -> pure (Left err) + Right plan -> applyProjectUpdate plan + case dryResult of + Left err -> expectationFailure (show err) + Right _ -> pure () + LBS.readFile fixture.manifestPath `shouldReturn` beforeManifest + TIO.readFile fixture.projectFile `shouldReturn` beforeProject + TIO.readFile (fixture.installedModule "module.dhall") `shouldReturn` beforeInstalled + + applied <- withProjectUpdate (updateRequest False) $ \case + Left err -> pure (Left err) + Right plan -> applyProjectUpdate plan + case applied of + Left err -> expectationFailure (show err) + Right result -> do + result.versions `shouldSatisfy` any (\change -> change.name == "demo" && change.fromVersion == Just "1.0.0" && change.toVersion == Just "2.0.0") + result.updatedApplications `shouldBe` [fixture.applicationId] + TIO.readFile fixture.projectFile `shouldReturn` "hello accepted\nkeep\nv2\n" + installedBytes <- TIO.readFile (fixture.installedModule "module.dhall") + installedBytes `shouldSatisfy` T.isInfixOf "Some \"2.0.0\"" + decoded <- manifestFromJSON <$> LBS.readFile fixture.manifestPath + case decoded of + Left err -> expectationFailure err + Right manifest -> case manifest.applications of + updated : _ -> case updated.instances of + instanceState : _ -> do + instanceState.resolvedVars `shouldBe` Map.singleton "project.name" "accepted" + instanceState.moduleVersion `shouldBe` Just "2.0.0" + [] -> expectationFailure "updated application has no instances" + [] -> expectationFailure "updated manifest has no applications" + + afterFirstApply <- LBS.readFile fixture.manifestPath + noOp <- withProjectUpdate (updateRequest False) $ \case + Left err -> pure (Left err) + Right plan -> applyProjectUpdate plan + case noOp of + Left err -> expectationFailure (show err) + Right result -> result.updatedApplications `shouldBe` [] + LBS.readFile fixture.manifestPath `shouldReturn` afterFirstApply + + it "rejects a plan when its manifest snapshot changes" $ + withSystemTempDirectory "seihou-update-stale" $ \root -> do + fixture <- prepareUpdateFixture root + withSavedEnv "XDG_CONFIG_HOME" (Just fixture.xdgHome) $ + withCurrentDirectory fixture.projectRoot $ do + result <- withProjectUpdate (updateRequest False) $ \case + Left err -> pure (Left err) + Right plan -> do + TIO.appendFile fixture.manifestPath "\n" + applyProjectUpdate plan + result `shouldSatisfy` \case + Left (UpdatePlanStale paths) -> Set.member (".seihou" "manifest.json") paths + _ -> False + + it "plans changed content at the same declared version with an explicit warning" $ + withSystemTempDirectory "seihou-update-same-version" $ \root -> do + fixture <- prepareUpdateFixture root + let modulePath = fixture.remote "module.dhall" + body <- TIO.readFile modulePath + TIO.writeFile modulePath (T.replace "Some \"2.0.0\"" "Some \"1.0.0\"" body) + callProcess "git" ["-C", fixture.remote, "add", "module.dhall"] + callProcess "git" ["-C", fixture.remote, "-c", "user.name=Seihou Test", "-c", "user.email=test@example.com", "commit", "-qm", "same-version content change"] + withSavedEnv "XDG_CONFIG_HOME" (Just fixture.xdgHome) $ + withCurrentDirectory fixture.projectRoot $ do + result <- withProjectUpdate (updateRequest True) pure + case result of + Left err -> expectationFailure (show err) + Right plan -> do + isUpdateNoOp plan `shouldBe` False + plan.versionChanges `shouldSatisfy` any (.sameVersionContentChanged) + plan.warnings `shouldContain` [SameVersionContentChanged "demo"] + + it "re-expands a candidate recipe and removes dependencies dropped by it" $ + withSystemTempDirectory "seihou-update-recipe" $ \root -> do + fixture <- prepareRecipeUpdateFixture root + withSavedEnv "XDG_CONFIG_HOME" (Just fixture.recipeXdgHome) $ + withCurrentDirectory fixture.recipeProjectRoot $ do + result <- withProjectUpdate (updateRequest False) $ \case + Left err -> pure (Left err) + Right plan -> applyProjectUpdate plan + case result of + Left err -> expectationFailure (show err) + Right updateResult -> updateResult.updatedApplications `shouldBe` [fixture.recipeApplicationId] + decoded <- manifestFromJSON <$> LBS.readFile fixture.recipeManifestPath + case decoded of + Left err -> expectationFailure err + Right manifest -> case manifest.applications of + [updated] -> do + updated.applicationId `shouldBe` fixture.recipeApplicationId + updated.targetVersion `shouldBe` Just "2.0.0" + updated.additionalModules `shouldBe` [] + Set.fromList (map (.name) updated.instances) `shouldBe` Set.fromList ["one", "new"] + Set.fromList (map (.name) manifest.modules) `shouldBe` Set.fromList ["one", "new"] + other -> expectationFailure ("expected one updated recipe application, got " <> show other) + doesFileExist (fixture.recipeXdgHome "seihou" "installed" "new" "module.dhall") `shouldReturn` True + + it "refuses an unresolved three-way conflict without mutating durable state" $ + withSystemTempDirectory "seihou-update-conflict" $ \root -> do + fixture <- prepareUpdateFixture root + TIO.writeFile (fixture.remote "files" "README.tmpl") "candidate {{project.name}}\nv2\n" + callProcess "git" ["-C", fixture.remote, "add", "files/README.tmpl"] + callProcess "git" ["-C", fixture.remote, "-c", "user.name=Seihou Test", "-c", "user.email=test@example.com", "commit", "-qm", "conflicting template"] + withSavedEnv "XDG_CONFIG_HOME" (Just fixture.xdgHome) $ + withCurrentDirectory fixture.projectRoot $ do + TIO.writeFile fixture.projectFile "user accepted\nv1\n" + beforeManifest <- LBS.readFile fixture.manifestPath + beforeInstalled <- LBS.readFile (fixture.installedModule "module.dhall") + result <- withProjectUpdate (updateRequest False) $ \case + Left err -> pure (Left err) + Right plan -> applyProjectUpdate plan + result `shouldSatisfy` \case + Left (UpdateHasUnresolvedPaths paths) -> Set.member "README.md" paths + _ -> False + LBS.readFile fixture.manifestPath `shouldReturn` beforeManifest + TIO.readFile fixture.projectFile `shouldReturn` "user accepted\nv1\n" + LBS.readFile (fixture.installedModule "module.dhall") `shouldReturn` beforeInstalled + + it "seeds one explicit legacy target and records it only after success" $ + withSystemTempDirectory "seihou-update-legacy" $ \root -> do + fixture <- prepareUpdateFixture root + decoded <- manifestFromJSON <$> LBS.readFile fixture.manifestPath + legacy <- case decoded of + Left err -> expectationFailure err >> pure (emptyManifest testTime) + Right manifest -> pure (withoutApplications manifest) + LBS.writeFile fixture.manifestPath (manifestToJSON legacy) + let request = (updateRequest False) {selection = NamedUpdateTargets ["demo"]} + withSavedEnv "XDG_CONFIG_HOME" (Just fixture.xdgHome) $ + withCurrentDirectory fixture.projectRoot $ do + result <- withProjectUpdate request $ \case + Left err -> pure (Left err) + Right plan -> applyProjectUpdate plan + case result of + Left err -> expectationFailure (show err) + Right updateResult -> updateResult.updatedApplications `shouldBe` [fixture.applicationId] + updated <- manifestFromJSON <$> LBS.readFile fixture.manifestPath + case updated of + Left err -> expectationFailure err + Right manifest -> case manifest.applications of + [applicationState] -> case applicationState.instances of + [moduleState] -> moduleState.resolvedVars `shouldBe` Map.singleton "project.name" "accepted" + other -> expectationFailure ("expected one legacy module instance, got " <> show other) + other -> expectationFailure ("expected one seeded application, got " <> show other) + + it "rolls managed project and cache state back when a candidate command fails" $ + withSystemTempDirectory "seihou-update-command-failure" $ \root -> do + fixture <- prepareUpdateFixture root + let modulePath = fixture.remote "module.dhall" + body <- TIO.readFile modulePath + TIO.writeFile + modulePath + ( T.replace + ", commands = [{ run = \"printf should-not-run >> command.log\", workDir = None Text, when = None Text }]" + ", commands = [{ run = \"exit 7\", workDir = None Text, when = None Text }]" + body + ) + callProcess "git" ["-C", fixture.remote, "add", "module.dhall"] + callProcess "git" ["-C", fixture.remote, "-c", "user.name=Seihou Test", "-c", "user.email=test@example.com", "commit", "-qm", "failing command"] + withSavedEnv "XDG_CONFIG_HOME" (Just fixture.xdgHome) $ + withCurrentDirectory fixture.projectRoot $ do + beforeManifest <- LBS.readFile fixture.manifestPath + beforeProject <- TIO.readFile fixture.projectFile + beforeInstalled <- LBS.readFile (fixture.installedModule "module.dhall") + result <- withProjectUpdate (updateRequest False) $ \case + Left err -> pure (Left err) + Right plan -> applyProjectUpdate plan + result `shouldSatisfy` \case + Left UpdateCommandFailed {} -> True + _ -> False + LBS.readFile fixture.manifestPath `shouldReturn` beforeManifest + TIO.readFile fixture.projectFile `shouldReturn` beforeProject + LBS.readFile (fixture.installedModule "module.dhall") `shouldReturn` beforeInstalled + + it "rolls managed state back when installed-cache publication fails" $ + withSystemTempDirectory "seihou-update-cache-failure" $ \root -> do + fixture <- prepareUpdateFixture root + withSavedEnv "XDG_CONFIG_HOME" (Just fixture.xdgHome) $ + withCurrentDirectory fixture.projectRoot $ do + beforeManifest <- LBS.readFile fixture.manifestPath + beforeProject <- TIO.readFile fixture.projectFile + beforeInstalled <- LBS.readFile (fixture.installedModule "module.dhall") + result <- withProjectUpdate (updateRequest False) $ \case + Left err -> pure (Left err) + Right plan -> applyProjectUpdate (breakCandidatePublication plan) + result `shouldSatisfy` \case + Left UpdateCachePublicationFailed {} -> True + _ -> False + LBS.readFile fixture.manifestPath `shouldReturn` beforeManifest + TIO.readFile fixture.projectFile `shouldReturn` beforeProject + LBS.readFile (fixture.installedModule "module.dhall") `shouldReturn` beforeInstalled + + describe "migration staging" $ do + it "preserves parameterized instances while planning their shared transition once" $ + withSystemTempDirectory "seihou-update-shared-migration" $ \projectRoot -> do + let parentOne = ParentVars (Map.singleton "tenant" "one") + parentTwo = ParentVars (Map.singleton "tenant" "two") + instanceOne = ModuleInstance "shared" parentOne + instanceTwo = ModuleInstance "shared" parentTwo + stateFor parent = AppliedInstanceState "shared" parent "/installed/shared" (Just "1.0.0") Map.empty + previous = application (AppliedModuleTarget "shared") [stateFor parentOne, stateFor parentTwo] + candidate = + Module + { name = "shared", + version = Just "2.0.0", + description = Nothing, + vars = [], + exports = [], + prompts = [], + steps = [], + commands = [], + dependencies = [], + removal = Nothing, + migrations = [Migration "1.0.0" "2.0.0" [RunCommand "true" Nothing]] + } + appliedModules = + [ AppliedModule "shared" parentOne "/installed/shared" (Just "1.0.0") testTime Nothing, + AppliedModule "shared" parentTwo "/installed/shared" (Just "1.0.0") testTime Nothing + ] + base = emptyManifest testTime + manifest = + Manifest + { version = base.version, + genAt = base.genAt, + modules = appliedModules, + vars = Map.empty, + files = Map.empty, + applications = [previous], + recipe = Nothing, + blueprint = Nothing, + blueprintMigrations = [] + } + catalog = CandidateCatalog (projectRoot "search") Map.empty Map.empty + candidates = [(instanceOne, candidate, "/candidate/shared"), (instanceTwo, candidate, "/candidate/shared")] + staged <- planAndStageMigrations projectRoot manifest catalog [(Just previous, candidates)] + case staged of + Left err -> expectationFailure (show err) + Right migrationStage -> do + length migrationStage.plans `shouldBe` 1 + migrationStage.plans `shouldSatisfy` all (.containsCommands) + migrationStage.warnings `shouldBe` [MigrationCommandNotSimulated "shared" "true"] + map (.moduleVersion) migrationStage.manifest.modules `shouldBe` [Just "2.0.0", Just "2.0.0"] + +data UpdateFixture = UpdateFixture + { projectRoot :: FilePath, + projectFile :: FilePath, + manifestPath :: FilePath, + xdgHome :: FilePath, + installedModule :: FilePath, + remote :: FilePath, + applicationId :: ApplicationId + } + +data RecipeUpdateFixture = RecipeUpdateFixture + { recipeProjectRoot :: FilePath, + recipeManifestPath :: FilePath, + recipeXdgHome :: FilePath, + recipeApplicationId :: ApplicationId + } + +prepareUpdateFixture :: FilePath -> IO UpdateFixture +prepareUpdateFixture root = do + let projectRoot = root "project" + manifestPath = projectRoot ".seihou" "manifest.json" + projectFile = projectRoot "README.md" + remote = root "remote" + xdgHome = root "xdg" + installedModule = xdgHome "seihou" "installed" "demo" + unchangedCommand = "printf should-not-run >> command.log" + commandOperation = RunCommandOp unchangedCommand Nothing "demo" 0 + commandFingerprint = fromMaybe (error "test fixture command fingerprint") (fingerprintCommand commandOperation) + commandReceipt = CommandReceipt commandFingerprint "demo" unchangedCommand Nothing testTime + baselineContent = "hello accepted\nkeep\nv1\n" + baselineRef = BaselineRef (hashContent baselineContent) + target = AppliedModuleTarget "demo" + applicationId = mkApplicationId target [] + app = + (application target [instanceState "demo" installedModule]) + { applicationId, + targetSource = installedModule, + targetVersion = Just "1.0.0", + commandReceipts = Map.singleton commandFingerprint commandReceipt, + instances = + [ (instanceState "demo" installedModule) + { resolvedVars = Map.singleton "project.name" "accepted" + } + ] + } + appliedModule = AppliedModule "demo" emptyParentVars installedModule (Just "1.0.0") testTime Nothing + fileRecord = + FileRecord + (hashContent baselineContent) + "demo" + Template + testTime + (Just baselineRef) + (Set.singleton applicationId) + manifest = + (emptyManifest testTime) + { modules = [appliedModule], + vars = Map.singleton "project.name" "accepted", + files = Map.singleton "README.md" fileRecord, + applications = [app] + } + createDirectoryIfMissing True (installedModule "files") + TIO.writeFile (installedModule "module.dhall") (moduleDhallWithTemplate "demo" "1.0.0" "old-default") + TIO.writeFile (installedModule "files" "README.tmpl") "hello {{project.name}}\nkeep\nv1\n" + createDirectoryIfMissing True (remote "files") + TIO.writeFile (remote "module.dhall") (moduleDhallWithTemplate "demo" "2.0.0" "new-default") + TIO.writeFile (remote "files" "README.tmpl") "hello {{project.name}}\nkeep\nv2\n" + callProcess "git" ["-C", remote, "init", "-q"] + callProcess "git" ["-C", remote, "add", "."] + callProcess "git" ["-C", remote, "-c", "user.name=Seihou Test", "-c", "user.email=test@example.com", "commit", "-qm", "v2"] + TIO.writeFile + (installedModule ".seihou-origin.json") + ("{\"sourceUrl\":\"" <> T.pack remote <> "\",\"version\":\"1.0.0\"}") + createDirectoryIfMissing True (projectRoot ".seihou" "baselines") + TIO.writeFile projectFile baselineContent + TIO.writeFile + (projectRoot ".seihou" "baselines" T.unpack baselineRef.unBaselineRef.unSHA256) + baselineContent + LBS.writeFile manifestPath (manifestToJSON manifest) + pure UpdateFixture {projectRoot, projectFile, manifestPath, xdgHome, installedModule, remote, applicationId} + +prepareRecipeUpdateFixture :: FilePath -> IO RecipeUpdateFixture +prepareRecipeUpdateFixture root = do + let projectRoot = root "project" + manifestPath = projectRoot ".seihou" "manifest.json" + remote = root "remote" + xdgHome = root "xdg" + installedRoot = xdgHome "seihou" "installed" + installedOne = installedRoot "one" + installedOld = installedRoot "old" + installedRecipe = installedRoot "stack" + target = AppliedRecipeTarget "stack" + applicationId = mkApplicationId target [] + app = + AppliedComposition + { applicationId, + target, + targetSource = installedRecipe, + targetVersion = Just "1.0.0", + additionalModules = [], + namespace = Just "one", + context = Nothing, + instances = [instanceState "old" installedOld, instanceState "one" installedOne], + commandReceipts = Map.empty, + appliedAt = testTime + } + base = emptyManifest testTime + manifest = + Manifest + { version = base.version, + genAt = base.genAt, + modules = + [ AppliedModule "old" emptyParentVars installedOld (Just "1.0.0") testTime Nothing, + AppliedModule "one" emptyParentVars installedOne (Just "1.0.0") testTime Nothing + ], + vars = Map.empty, + files = Map.empty, + applications = [app], + recipe = Just (AppliedRecipe "stack" (Just "1.0.0") testTime), + blueprint = Nothing, + blueprintMigrations = [] + } + sourceUrl = T.pack remote + createDirectoryIfMissing True installedOne + createDirectoryIfMissing True installedOld + createDirectoryIfMissing True installedRecipe + TIO.writeFile (installedOne "module.dhall") (moduleDhall "one" "1.0.0") + TIO.writeFile (installedOld "module.dhall") (moduleDhall "old" "1.0.0") + TIO.writeFile (installedRecipe "recipe.dhall") (recipeDhall "stack" "1.0.0" ["one", "old"]) + mapM_ (writeOrigin sourceUrl) [installedOne, installedOld, installedRecipe] + createDirectoryIfMissing True (remote "modules" "one") + createDirectoryIfMissing True (remote "modules" "old") + createDirectoryIfMissing True (remote "modules" "new") + createDirectoryIfMissing True (remote "recipes" "stack") + TIO.writeFile (remote "modules" "one" "module.dhall") (moduleDhall "one" "2.0.0") + TIO.writeFile (remote "modules" "old" "module.dhall") (moduleDhall "old" "1.0.0") + TIO.writeFile (remote "modules" "new" "module.dhall") (moduleDhall "new" "1.0.0") + TIO.writeFile (remote "recipes" "stack" "recipe.dhall") (recipeDhall "stack" "2.0.0" ["one", "new"]) + TIO.writeFile (remote "seihou-registry.dhall") recipeUpdateRegistryDhall + callProcess "git" ["-C", remote, "init", "-q"] + callProcess "git" ["-C", remote, "add", "."] + callProcess "git" ["-C", remote, "-c", "user.name=Seihou Test", "-c", "user.email=test@example.com", "commit", "-qm", "recipe v2"] + createDirectoryIfMissing True (projectRoot ".seihou") + LBS.writeFile manifestPath (manifestToJSON manifest) + pure + RecipeUpdateFixture + { recipeProjectRoot = projectRoot, + recipeManifestPath = manifestPath, + recipeXdgHome = xdgHome, + recipeApplicationId = applicationId + } + +updateRequest :: Bool -> UpdateRequest +updateRequest dryRun = + UpdateRequest + { selection = AllRecordedApplications, + varOverrides = [], + reconfigure = False, + promptPolicy = ForbidPrompts, + commandPolicy = RunChangedCommands, + dryRun + } + +moduleDhallWithTemplate :: Text -> Text -> Text -> Text +moduleDhallWithTemplate name version defaultValue = + T.unlines + [ "{ name = \"" <> name <> "\"", + ", version = Some \"" <> version <> "\"", + ", description = None Text", + ", vars = [{ name = \"project.name\", type = \"text\", default = Some \"" <> defaultValue <> "\", description = None Text, required = False, validation = None Text }]", + ", exports = [] : List { var : Text, alias : Optional Text }", + ", prompts = [] : List { var : Text, text : Text, when : Optional Text, choices : Optional (List Text) }", + ", steps = [{ strategy = \"template\", src = \"README.tmpl\", dest = \"README.md\", when = None Text, patch = None Text }]", + ", commands = [{ run = \"printf should-not-run >> command.log\", workDir = None Text, when = None Text }]", + ", dependencies = [] : List Text", + ", removal = None { steps : List { action : Text, dest : Text, src : Optional Text }, commands : List { run : Text, workDir : Optional Text, when : Optional Text } }", + "}" + ] + +withSavedEnv :: String -> Maybe String -> IO a -> IO a +withSavedEnv key value action = + bracket + (lookupEnv key <* setValue value) + setValue + (const action) + where + setValue (Just current) = setEnv key current + setValue Nothing = unsetEnv key + +application :: AppliedTarget -> [AppliedInstanceState] -> AppliedComposition +application target instances = + AppliedComposition + { applicationId = mkApplicationId target [], + target, + targetSource = maybe "" (.source) (listToMaybe instances), + targetVersion = Just "1.0.0", + additionalModules = [], + namespace = Nothing, + context = Nothing, + instances, + commandReceipts = Map.empty, + appliedAt = testTime + } + +instanceState :: ModuleName -> FilePath -> AppliedInstanceState +instanceState name source = + AppliedInstanceState + { name, + parentVars = emptyParentVars, + source, + moduleVersion = Just "1.0.0", + resolvedVars = Map.empty + } + +moduleDhall :: Text -> Text -> Text +moduleDhall name version = + T.unlines + [ "{ name = \"" <> name <> "\"", + ", version = Some \"" <> version <> "\"", + ", description = None Text", + ", vars = [] : List { name : Text, type : Text, default : Optional Text, description : Optional Text, required : Bool, validation : Optional Text }", + ", exports = [] : List { var : Text, alias : Optional Text }", + ", prompts = [] : List { var : Text, text : Text, when : Optional Text, choices : Optional (List Text) }", + ", steps = [] : List { strategy : Text, src : Text, dest : Text, when : Optional Text, patch : Optional Text }", + ", commands = [] : List { run : Text, workDir : Optional Text, when : Optional Text }", + ", dependencies = [] : List Text", + ", removal = None { steps : List { action : Text, dest : Text, src : Optional Text }, commands : List { run : Text, workDir : Optional Text, when : Optional Text } }", + "}" + ] + +recipeDhall :: Text -> Text -> [Text] -> Text +recipeDhall name version modules = + T.unlines + [ "{ name = \"" <> name <> "\"", + ", version = Some \"" <> version <> "\"", + ", description = None Text", + ", modules = [" + <> T.intercalate + ", " + [ "{ module = \"" <> moduleName <> "\", vars = [] : List { name : Text, value : Text } }" + | moduleName <- modules + ] + <> "]", + ", 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) }", + "}" + ] + +registryDhall :: Text +registryDhall = + T.unlines + [ "{ repoName = \"update-test\"", + ", repoDescription = None Text", + ", modules =", + " [ { name = \"one\", version = Some \"2.0.0\", path = \"modules/one\", description = None Text, tags = [] : List Text }", + " , { name = \"two\", version = Some \"2.0.0\", path = \"modules/two\", description = None Text, tags = [] : List Text }", + " ]", + ", recipes = [{ name = \"stack\", version = Some \"2.0.0\", path = \"recipes/stack\", description = None Text, tags = [] : List Text }]", + ", blueprints = [] : List { name : Text, version : Optional Text, path : Text, description : Optional Text, tags : List Text }", + ", prompts = [] : List { name : Text, version : Optional Text, path : Text, description : Optional Text, tags : List Text }", + "}" + ] + +recipeUpdateRegistryDhall :: Text +recipeUpdateRegistryDhall = + T.unlines + [ "{ repoName = \"recipe-update-test\"", + ", repoDescription = None Text", + ", modules =", + " [ { name = \"one\", version = Some \"2.0.0\", path = \"modules/one\", description = None Text, tags = [] : List Text }", + " , { name = \"old\", version = Some \"1.0.0\", path = \"modules/old\", description = None Text, tags = [] : List Text }", + " , { name = \"new\", version = Some \"1.0.0\", path = \"modules/new\", description = None Text, tags = [] : List Text }", + " ]", + ", recipes = [{ name = \"stack\", version = Some \"2.0.0\", path = \"recipes/stack\", description = None Text, tags = [] : List Text }]", + ", blueprints = [] : List { name : Text, version : Optional Text, path : Text, description : Optional Text, tags : List Text }", + ", prompts = [] : List { name : Text, version : Optional Text, path : Text, description : Optional Text, tags : List Text }", + "}" + ] + +writeOrigin :: Text -> FilePath -> IO () +writeOrigin sourceUrl directory = do + createDirectoryIfMissing True directory + TIO.writeFile (directory ".seihou-origin.json") ("{\"sourceUrl\":\"" <> sourceUrl <> "\"}") + +manifestForApplications :: [AppliedComposition] -> Map.Map FilePath FileRecord -> Manifest +manifestForApplications applicationRecords fileRecords = + let base = emptyManifest testTime + in Manifest + { version = base.version, + genAt = base.genAt, + modules = base.modules, + vars = base.vars, + files = fileRecords, + applications = applicationRecords, + recipe = base.recipe, + blueprint = base.blueprint, + blueprintMigrations = base.blueprintMigrations + } + +breakCandidatePublication :: UpdatePlan -> UpdatePlan +breakCandidatePublication plan = + UpdatePlan + { applications = plan.applications, + versionChanges = plan.versionChanges, + inputChanges = plan.inputChanges, + migrations = plan.migrations, + reconciliation = plan.reconciliation, + commandPlan = plan.commandPlan, + candidateArtifacts = map breakArtifact plan.candidateArtifacts, + warnings = plan.warnings, + request = plan.request, + snapshot = plan.snapshot, + plannedApplications = plan.plannedApplications + } + where + breakArtifact artifact = + CandidateArtifact + { kind = artifact.kind, + name = artifact.name, + version = artifact.version, + originalDirectory = plan.snapshot.sessionDirectory "missing-publication-source", + sourceDirectory = artifact.sourceDirectory, + sourceUrl = artifact.sourceUrl, + repoName = artifact.repoName, + tags = artifact.tags, + sourceRevision = artifact.sourceRevision, + contentHash = artifact.contentHash, + moduleDefinition = artifact.moduleDefinition, + recipeDefinition = artifact.recipeDefinition + } + +withoutApplications :: Manifest -> Manifest +withoutApplications manifest = + Manifest + { version = manifest.version, + genAt = manifest.genAt, + modules = manifest.modules, + vars = manifest.vars, + files = manifest.files, + applications = [], + recipe = manifest.recipe, + blueprint = manifest.blueprint, + blueprintMigrations = manifest.blueprintMigrations + } + +testTime :: UTCTime +testTime = UTCTime (fromGregorian 2026 7 19) 0