seihou-cli 0.9.0.0 → 0.10.0.0

raw patch · 62 files changed

+8182/−643 lines, 62 filesdep ~baikaidep ~baikai-claudedep ~baikai-kitPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: baikai, baikai-claude, baikai-kit, baikai-openai, seihou-core

API changes (from Hackage documentation)

Files

• data/upgrade-prompt.md +237/−0
• help/agent.md +16/−1
• help/kit.md +14/−2
• help/manifest.md +46/−1
• help/modules.md +4/−0
• help/update.md +20/−9
• seihou-cli.cabal +33/−12
• src-exe/Main.hs +12/−0
• src-exe/Seihou/CLI/AgentLaunchExec.hs +31/−26
• src-exe/Seihou/CLI/AgentRun.hs +3/−1
• src-exe/Seihou/CLI/AgentUpgrade.hs +178/−0
• src-exe/Seihou/CLI/Commands.hs +167/−8
• src-exe/Seihou/CLI/Install.hs +31/−21
• src-exe/Seihou/CLI/Kit.hs +4/−37
• src-exe/Seihou/CLI/Remove.hs +75/−1
• src-exe/Seihou/CLI/Run.hs +95/−63
• src-exe/Seihou/CLI/Status.hs +9/−1
• src-exe/Seihou/CLI/Sync.hs +31/−0
• src-exe/Seihou/CLI/Update.hs +3/−3
• src/Seihou/CLI/AgentCompletion.hs +8/−3
• src/Seihou/CLI/AgentConfig.hs +2/−0
• src/Seihou/CLI/AgentLaunch.hs +18/−0
• src/Seihou/CLI/ApplicationDisplay.hs +84/−0
• src/Seihou/CLI/CheckoutSync.hs +166/−0
• src/Seihou/CLI/InstallShared.hs +104/−1
• src/Seihou/CLI/KitConfig.hs +11/−0
• src/Seihou/CLI/Manifest.hs +3/−0
• src/Seihou/CLI/ManifestCapabilityUpgrade.hs +456/−0
• src/Seihou/CLI/ManifestGuard.hs +51/−7
• src/Seihou/CLI/ManifestRepairOrigins.hs +627/−0
• src/Seihou/CLI/ManifestUpgrade.hs +383/−105
• src/Seihou/CLI/RecordedRelease.hs +297/−0
• src/Seihou/CLI/SchemaVersion.hs +2/−2
• src/Seihou/CLI/StatusRender.hs +13/−22
• src/Seihou/CLI/Style.hs +1/−0
• src/Seihou/CLI/Update.hs +358/−85
• src/Seihou/CLI/Update/Migrations.hs +1/−1
• src/Seihou/CLI/Update/Recovery.hs +17/−0
• src/Seihou/CLI/Update/Render.hs +371/−24
• src/Seihou/CLI/Update/Selection.hs +139/−66
• src/Seihou/CLI/Update/Types.hs +58/−3
• src/Seihou/CLI/UpgradeDiagnosis.hs +989/−0
• test/Main.hs +18/−0
• test/Seihou/CLI/AgentMigrateE2ESpec.hs +47/−1
• test/Seihou/CLI/AgentUpgradeE2ESpec.hs +160/−0
• test/Seihou/CLI/CheckoutSyncE2ESpec.hs +215/−0
• test/Seihou/CLI/CheckoutSyncSpec.hs +46/−0
• test/Seihou/CLI/InstallSourceSpec.hs +113/−0
• test/Seihou/CLI/ManifestCapabilityUpgradeSpec.hs +300/−0
• test/Seihou/CLI/ManifestGuardSpec.hs +27/−0
• test/Seihou/CLI/ManifestRepairOriginsSpec.hs +203/−0
• test/Seihou/CLI/ManifestUpgradeSpec.hs +261/−9
• test/Seihou/CLI/MigrateSpec.hs +3/−2
• test/Seihou/CLI/RecordedReleaseSpec.hs +193/−0
• test/Seihou/CLI/RepairOriginsE2ESpec.hs +268/−0
• test/Seihou/CLI/StatusSpec.hs +13/−0
• test/Seihou/CLI/UpdateE2ESpec.hs +228/−31
• test/Seihou/CLI/UpdateFixture.hs +7/−2
• test/Seihou/CLI/UpdateRenderSpec.hs +263/−7
• test/Seihou/CLI/UpdateSpec.hs +318/−86
• test/Seihou/CLI/UpgradeDiagnosisSpec.hs +238/−0
• test/Seihou/CLI/UpgradeFixture.hs +93/−0

@@ -0,0 +1,237 @@+You are a Seihou upgrade assistant. Your job is to upgrade the module+`{{module}}` in the project at `{{cwd}}` to the newest available release, and to+leave `.seihou/manifest.json` in a state where the next plain+`seihou update {{module}}` succeeds with no agent involved. That second part is+the point: every repair you make should be one a future upgrade does not need to+repeat.++Seihou already diagnosed the project, without changing anything, before starting+this session. Its findings are below. Trust them as a starting point, and re-run+`seihou agent upgrade {{module}} --check` whenever you need a fresh verdict.++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, run the+commands yourself. When they are not, give the user the exact commands to run,+in order, and say what to look for in each result.++The user's own request for this upgrade, if they gave one:++{{user_request}}+++## Current state++Seihou version: {{seihou_version}}++### Readiness++The upgrade is done when every check below reads ✓. This is the output of+`seihou agent upgrade {{module}} --check` at the start of the session:++{{diagnosis_summary}}++### Manifest++{{manifest_section}}++### Target++{{target_section}}++### Installed copy++{{installed_section}}++### Shared-write evidence and recorded origins++{{shared_evidence_section}}++### Manifest schema upgrade++{{manifest_upgrade_section}}++### Update dry run++{{update_dry_run_section}}++### Git++{{git_section}}++### Findings++Probes that failed or timed out, and anything seihou fell back on while starting+this session:++{{findings_section}}+++## Upgrade procedure++Work through these steps in order. Repair a failing check with the playbook+below before moving on, and diagnose again after each repair.++1. If the git working tree has uncommitted changes, ask the user before touching+   anything, and suggest committing or stashing them first.+2. Run `seihou outdated` to find the newest release of `{{module}}`.+3. Run `seihou upgrade {{module}}` to refresh the installed copy.+4. Run `seihou update {{module}} --dry-run` and walk the user through the plan:+   version changes, migrations, files, commands, and warnings.+5. Run `seihou update {{module}}`. Resolve any conflicts with the user.+6. Run `seihou agent upgrade {{module}} --check` until its last line is+   `Upgrade readiness: ready`.+7. Offer a Conventional Commit of the changed paths, for example+   `chore(seihou): upgrade {{module}} to <version>`.++If `seihou update {{module}}` fails, its message leads with the remedy and ends+with an error code in brackets, such as `[shared_write_evidence_unavailable]`.+Find the code in the playbook.+++## Repair playbook++Each entry is an error code from `seihou update` (also shown with `--json` as+`error.code`), what it means, and how to repair it with seihou's own commands.++### manifest_missing+There is no `.seihou/manifest.json`. You are probably in the wrong directory.+Ask the user for the project root. Never create a manifest by hand.++### manifest_unreadable+The manifest is not valid JSON or does not decode. Inspect+`git log -p -- .seihou/manifest.json`, show the user the last good version, and+restore it with their agreement (`git checkout <rev> -- .seihou/manifest.json`).++### manifest_upgrade_required+The manifest is at schema 5 or older. Only `seihou manifest upgrade` converts it,+because the conversion infers artifact origins from paths on the machine that+wrote it. Run `seihou manifest upgrade --dry-run`, show the user every inferred+origin and its confidence, then run `seihou manifest upgrade`. Never pass+`--force` unless the user agrees after seeing which artifacts are missing.++### no_recorded_applications and legacy_update_requires_one_target+The manifest predates recorded applications. Run one `seihou update {{module}}`+(exactly one target) to seed the record. Later updates can name any target.++### target_not_found+`{{module}}` is not a recorded target. The message lists the ones that are. Ask+the user which one they meant; do not guess.++### shared_path_requires_applications+A path the upgrade touches is written whole by an owner outside the selection,+so its owners must be updated together. Either name every owner as a target+(the message gives the command), or pass `--include-shared-owners` after telling+the user it updates those applications in full.++### shared_write_evidence_unavailable+Nothing records how the owners of a shared path write it, and seihou could not+read a co-owner's recorded version to find out. `seihou update` already tried+the installed copy and then fetched the co-owner's exact recorded release from+its recorded origin; the message says why each failed.++- If a recorded origin is a path on some machine (`/Users/...`, `./...`), run+  `seihou manifest repair-origins --dry-run`, show the report, run+  `seihou manifest repair-origins`, and retry.+- If the origin is unreachable (network, authentication), fix that and retry.+- If no commit of the remote declares the recorded version, explain that to the+  user. They decide whether to update the co-owner too+  (`--include-shared-owners`, which updates it in full) or to install that exact+  version from wherever it still exists.++Never swap versions inside `~/.config/seihou/installed/` to satisfy+certification, and never edit `sharedWriteMode` by hand to get past this.++### Origin mismatch ("installed here from a different origin than recorded")+Reported by `seihou status`, the artifact guard (`candidate_*` or a refusal+before an update), or certification.++- If the recorded origin is a local path, run+  `seihou manifest repair-origins --dry-run`, show the report, then run it. For+  a path it cannot resolve, ask the user for the repository URL and pass+  `--set NAME=URL`.+- If both origins are remote URLs, the installed copy really comes from a+  different source. Ask the user which is right, and reinstall from the recorded+  origin (`seihou install <url> --force`) rather than editing the manifest.++### candidate_clone_failed, candidate_repository_invalid, candidate_artifact_missing, candidate_artifact_unresolved, candidate_artifact_ambiguous, candidate_load_failed+Seihou could not stage the new release from the recorded origin. Check the URL+and access (`git ls-remote <url>`), check that the repository still contains the+artifact, and run `seihou validate-module` on a local checkout if it fails to+load. For an unresolved artifact with no remote, install it+(`seihou install <url>`).++### candidate_downgrade+The candidate is older than what the manifest records. Explain which versions are+involved. Never pass `--allow-downgrade` without the user's explicit consent.++### candidate_version_invalid and conflicting_prior_versions+A version string does not parse, or one module is recorded at several versions.+Show the user the versions involved; this usually needs a fixed release of the+module rather than a change to the project.++### variable_errors and configuration_failed+A variable has no value or the configuration does not load. Supply values with+`--var KEY=VALUE` or `seihou config set KEY VALUE`, asking the user for anything+that is not already recorded. `seihou vars {{module}} --explain` shows where each+value comes from.++### migration_plan_failed, migration_stage_failed, migration_failed, changed_after_migration_command+A module migration between the recorded and the new version failed. The update+rolled back. Read the migration named in the message, show the user what it+does, and decide together whether to fix the project first or to upgrade to an+intermediate version.++### composition_failed and reconciliation_failed+The new release does not compose with the rest of the project, or its files+cannot be reconciled with what is recorded. Show the user the message; this is+usually a module bug to report, not a project repair.++### unresolved_paths+Some files have conflicts that need a decision. Run an interactive+`seihou update {{module}}` with the user and resolve each one.++### recovery_failed, plan_stale, and an interrupted update found by diagnosis+An earlier update was interrupted or the project changed while planning. Run+`seihou update --dry-run` once to let seihou recover the interrupted+transaction, then diagnose again.++### transaction_failed, command_failed, cache_publication_failed, manifest_write_failed+The update rolled back after a failure while applying. Read the message, fix the+cause (a failing command, a full disk, permissions), and run the update again.+++## Safety rules++These rules protect invariants the rest of seihou relies on. Follow them even+when breaking one would make a check pass.++- Repair through seihou's commands. Edit `.seihou/manifest.json` by hand only as+  a last resort, only after telling the user why no command can do it, and only+  after saving a backup: `cp .seihou/manifest.json {{backup_dir}}/manifest.json`.+- Never invent an origin URL. Use what `seihou manifest repair-origins` finds or+  what the user confirms.+- Never mark a path `additive-only` without reading every owner's operations for+  that path in the modules themselves.+- Never delete file records or applications to get past a gate.+- Never lower a recorded version.+- Never pass `--force` or `--allow-downgrade` without the user's agreement.+- Never change anything under `~/.config/seihou/installed/` except through+  `seihou install` and `seihou upgrade`.+- After any manual edit, run `seihou status`, `seihou manifest upgrade --dry-run`,+  and `seihou agent upgrade {{module}} --check`.+- Blueprint migrations (`seihou agent migrate`) are a different mechanism,+  shipped by a library for its consumers. They are in scope only if the user+  asks.++The upgrade brief and any backups live in `{{backup_dir}}`, outside the project.+++## Finish with a repair report++End the session with a short section titled `Repair report` that tells the user:++- which readiness checks failed at the start, and what fixed each one;+- whether any manual manifest edit was needed. If one was, say which seihou+  command could not express the fix, so the maintainers know what to automate+  next;+- the final `Upgrade readiness` line.

@@ -3,7 +3,8 @@ `seihou agent` renders Seihou-aware prompts and starts a configured provider. The agent commands are for AI-assisted module authoring, bootstrapping, project setup, running agent-driven-blueprints, and applying ordered blueprint library migrations.+blueprints, applying ordered blueprint library migrations, and+repairing a project's manifest state to upgrade a module.  CLI providers open interactive local Claude Code or Codex sessions. API providers send one rendered prompt as a batch completion and print@@ -111,6 +112,20 @@       Render a prompt for using existing Seihou modules in a project:       selecting modules, configuring variables, previewing, running,       verifying, and committing.++  seihou agent upgrade MODULE [PROMPT] [--check]+      Diagnose the project for upgrading MODULE without changing+      anything, write an upgrade brief (findings, a repair playbook+      keyed by update error code, safety rules) outside the project,+      print its path, and start an agent session that repairs the+      manifest state and performs the upgrade. It never fails on+      project or configuration state: problems become findings, and+      when no session can start it says how to use the saved brief.++      --check prints the readiness report and exits 0. Its last line+      is 'Upgrade readiness: ready' or 'Upgrade readiness: not ready+      (N ...)'. When it reads ready, a plain `seihou update MODULE`+      needs no agent.    seihou agent run BLUEPRINT [PROMPT] [--var KEY=VALUE] [--no-baseline]       Resolve a blueprint, optionally apply its baseline modules,

@@ -6,15 +6,22 @@  COMMANDS -  seihou kit list                     List available skills and agents+  seihou kit list [--json]            List available skills and agents   seihou kit install NAME             Install to user scope (global)   seihou kit install NAME --project   Install to project scope (local)   seihou kit update                   Pull latest and re-install all   seihou kit update NAME              Pull latest and re-install one   seihou kit uninstall NAME           Remove from user scope   seihou kit uninstall NAME --project Remove from project scope-  seihou kit status                   Show installed items with scope, providers, and state+  seihou kit status [--json]          Show installed items with scope, providers, and state +OPTIONS++  --json                  JSON output for list, status, and update+  --force                 Overwrite local edits during update+  --shared / --tool-only  Override item visibility during install+  --accept-shared-codex   Accept shared Codex custom agents during install+ SCOPES    User scope (default):@@ -48,6 +55,11 @@   Claude scope directories are passed to Claude Code via --add-dir   flags. Claude Code discovers .claude/skills/ and .claude/agents/   within each add-dir automatically.++  Skills are tool-only by default. Seihou enables its own Codex skills+  in interactive and batch sessions. Use --shared to expose items in+  other sessions. Codex custom agents require shared visibility or+  --accept-shared-codex because Codex cannot isolate them.    Codex discovers skills from .agents/skills and custom agents from   .codex/agents in the project, or from ~/.agents/skills and

@@ -37,7 +37,11 @@      seihou manifest upgrade     seihou manifest upgrade --dry-run    # show the report, write nothing+    seihou manifest upgrade --to 6       # stop after a given schema version +  The command runs one schema step at a time and prints each one. Only the+  5 -> 6 step infers anything; the others are mechanical.+   Each recorded path is resolved to an artifact on this machine and replaced   with that artifact's portable origin. Every conversion is printed, because   recovering an upstream URL from somebody else's absolute path is inference@@ -45,15 +49,55 @@      Reading .seihou/manifest.json (schema version 5) +      5 -> 6  portable artifact origins  (inferred; review before committing)+       haskell-base       /Users/shinzui/.config/seihou/installed/haskell-base                       →  remote https://github.com/shinzui/seihou-modules.git -    ✓ Upgraded .seihou/manifest.json to schema version 6.+      6 -> 7  explicit shared-write evidence++      shared-write evidence+      .gitignore  unknown -> additive-only++    ✓ Upgraded .seihou/manifest.json to schema version 7.       Review the diff and commit it: git diff .seihou/manifest.json    Running it on a manifest that is already current reports that there is   nothing to do and exits zero. +SHARED-WRITE EVIDENCE++  Schema 7 records, for every file, whether all of its owners only append to+  it (additive-only), whether one rewrites it (requires-ownership-closure), or+  that nobody has established either yet (unknown). A targeted+  seihou update can leave a co-owner out only for an additive-only file.++  After reaching schema 7 the upgrade compiles each unknown file's owners from+  their recorded module versions and saved values, writes nothing but the+  manifest, and records what it finds. An owner whose recorded version is not+  installed here leaves the file unknown, and the report names it.++  seihou update <target> performs the same certification for just the shared+  paths it touches and records it with the update, so running this first is+  optional. It inspects co-owners; it never updates their files.++ORIGINS RECORDED AS A PATH++  Installing from a local checkout used to record the checkout's path as the+  artifact's origin, and the path reached the manifest. Current seihou records+  the checkout's published remote instead, or an unknown (local) origin when+  the installed commit is not pushed. Repair a manifest that still names a+  path:++    seihou manifest repair-origins --dry-run    # proposed rewrites + evidence+    seihou manifest repair-origins              # write them+    seihou manifest repair-origins --set NAME=URL   # when seihou finds no remote++  Evidence comes from the path's own 'origin' remote, if the checkout is here,+  and from the installed copy of each artifact recorded under the path. Every+  record under one path is rewritten to the same URL. The command exits 1 while+  any path is unresolved or conflicting.+ INSTALL FIRST    The upgrade can only record what this machine can see. If an artifact the@@ -80,3 +124,4 @@    seihou help migrations       moving a project between module versions   seihou manifest upgrade -h   the full flag reference+  seihou manifest repair-origins -h

@@ -94,3 +94,7 @@   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.++## Checkout directory links++A step with strategy `symlink` and lifecycle `Some "checkout"` declares a link from a real project source directory to an ignored local path. Run records portable intent; `seihou sync` reconstructs it in fresh clones without modules or commands. For example, link `config/editor` to `.editor-local/config` and ignore `.editor-local/`. Links have no patches or content hashes.

@@ -42,16 +42,27 @@   Otherwise the update stops, because regenerating the file for one owner   would discard another's content. That covers any path an owner writes   wholesale, and the position-dependent `append-file` / `prepend-file`-  patches. A manifest written before Seihou recorded this distinction has no-  answer and is treated conservatively. One no-target update records it: a-  missing answer counts as pending work even when nothing else has changed,-  and writing it down touches no project file.+  patches. -  When the refusal is genuine, name every required owner, run the no-target-  form, or pass `--include-shared-owners` to expand the selection to exactly-  the owners required. Each added application is reported. Seihou will not-  guess how to reconstruct an omitted layer, and never broadens a named-  selection without being asked.+  The answer is recorded per path as `sharedWriteMode`: `additive-only`,+  `requires-ownership-closure`, or `unknown` for a manifest that predates it.+  A targeted update resolves `unknown` itself: it compiles each co-owner from+  its recorded version, reads how it writes the path, and records the answer+  (upgrading a schema-6 manifest to 7) with its own manifest. It inspects the+  co-owners but never updates their files. `--dry-run` shows this as+  `Manifest: schema 6 -> 7` and writes nothing.++  If a co-owner's recorded version is not installed here, the update stops+  with `shared_write_evidence_unavailable`: install that version and retry.+  A schema-5 or older manifest stops with `manifest_upgrade_required`: run+  `seihou manifest upgrade --dry-run`, review, then `seihou manifest upgrade`.++  When the refusal is genuine (`shared_path_requires_applications`), name the+  required owners as targets, or pass `--include-shared-owners` to expand the+  selection to exactly the owners required, updating their full+  applications. Each added application is reported. Owners are named as+  `seihou status` names them, e.g. `exec-plan [skill.name=exec-plan]`.+  Seihou never broadens a named selection without being asked.  SAVED INPUTS 

@@ -1,6 +1,6 @@ cabal-version: 3.0 name: seihou-cli-version: 0.9.0.0+version: 0.10.0.0 synopsis: CLI for Seihou project scaffolding description:   Command-line interface for Seihou, a composable project scaffolding@@ -23,6 +23,7 @@   data/bootstrap-prompt.md   data/prompt-run-prompt.md   data/setup-prompt.md+  data/upgrade-prompt.md   help/agent.md   help/blueprints.md   help/config.md@@ -61,11 +62,13 @@     Seihou.CLI.AgentLaunch     Seihou.CLI.AgentModels     Seihou.CLI.AgentTrace+    Seihou.CLI.ApplicationDisplay     Seihou.CLI.AppliedBlueprint     Seihou.CLI.AppliedBlueprintMigration     Seihou.CLI.BlueprintExecution     Seihou.CLI.BlueprintMigration     Seihou.CLI.BrowseFormat+    Seihou.CLI.CheckoutSync     Seihou.CLI.CommandExecution     Seihou.CLI.CommitMessage     Seihou.CLI.Completions.Bash@@ -77,14 +80,18 @@     Seihou.CLI.Init     Seihou.CLI.InstallHistory     Seihou.CLI.InstallShared+    Seihou.CLI.KitConfig     Seihou.CLI.List     Seihou.CLI.Manifest+    Seihou.CLI.ManifestCapabilityUpgrade     Seihou.CLI.ManifestGuard+    Seihou.CLI.ManifestRepairOrigins     Seihou.CLI.ManifestUpgrade     Seihou.CLI.Migrate     Seihou.CLI.MigrationCohort     Seihou.CLI.PendingMigrations     Seihou.CLI.PromptRender+    Seihou.CLI.RecordedRelease     Seihou.CLI.Registry     Seihou.CLI.Registry.Sync     Seihou.CLI.Registry.Validate@@ -102,6 +109,7 @@     Seihou.CLI.Update.Selection     Seihou.CLI.Update.Source     Seihou.CLI.Update.Types+    Seihou.CLI.UpgradeDiagnosis     Seihou.CLI.VersionCompare     Seihou.Effect.Fzf     Seihou.Effect.FzfInterp@@ -113,9 +121,10 @@     aeson >=2.1 && <3,     aeson-pretty >=0.8 && <1,     ansi-terminal >=1.1 && <2,-    baikai ^>=0.7.0.0,-    baikai-claude ^>=0.7.0.0,-    baikai-openai ^>=0.7.0.0,+    baikai ^>=0.8.0.0,+    baikai-claude ^>=0.7.1.1,+    baikai-kit ^>=0.4.0.1,+    baikai-openai ^>=0.7.1.1,     base >=4.18 && <5,     bytestring >=0.11 && <1,     containers >=0.6 && <1,@@ -126,7 +135,7 @@     generic-lens >=2.2 && <3,     lens >=5.2 && <6,     process >=1.6 && <2,-    seihou-core ^>=0.9.0.0,+    seihou-core ^>=0.10.0.0,     streamly-core >=0.3 && <0.5,     temporary >=1.3 && <2,     text >=2.0 && <3,@@ -161,6 +170,7 @@     Seihou.CLI.AgentLaunchExec     Seihou.CLI.AgentMigrate     Seihou.CLI.AgentRun+    Seihou.CLI.AgentUpgrade     Seihou.CLI.Assist     Seihou.CLI.Bootstrap     Seihou.CLI.Browse@@ -182,6 +192,7 @@     Seihou.CLI.SchemaUpgrade     Seihou.CLI.Setup     Seihou.CLI.Status+    Seihou.CLI.Sync     Seihou.CLI.Update     Seihou.CLI.Upgrade     Seihou.CLI.Validate@@ -194,10 +205,10 @@     aeson >=2.1 && <3,     aeson-pretty >=0.8 && <1,     ansi-terminal >=1.1 && <2,-    baikai ^>=0.7.0.0,-    baikai-claude ^>=0.7.0.0,-    baikai-kit ^>=0.2.0.1,-    baikai-openai ^>=0.7.0.0,+    baikai ^>=0.8.0.0,+    baikai-claude ^>=0.7.1.1,+    baikai-kit ^>=0.4.0.1,+    baikai-openai ^>=0.7.1.1,     base >=4.18 && <5,     bytestring >=0.11 && <1,     containers >=0.6 && <1,@@ -211,7 +222,7 @@     optparse-applicative >=0.18 && <1,     process >=1.6 && <2,     seihou-cli-internal,-    seihou-core ^>=0.9.0.0,+    seihou-core ^>=0.10.0.0,     temporary >=1.3 && <2,     text >=2.0 && <3,     time >=1.12 && <2,@@ -239,10 +250,13 @@     Seihou.CLI.AgentModelsSpec     Seihou.CLI.AgentTraceE2ESpec     Seihou.CLI.AgentTraceSpec+    Seihou.CLI.AgentUpgradeE2ESpec     Seihou.CLI.AppliedBlueprintMigrationSpec     Seihou.CLI.AppliedBlueprintSpec     Seihou.CLI.BlueprintMigrationSpec     Seihou.CLI.BrowseFormatSpec+    Seihou.CLI.CheckoutSyncE2ESpec+    Seihou.CLI.CheckoutSyncSpec     Seihou.CLI.CommandExecutionSpec     Seihou.CLI.CommitMessageSpec     Seihou.CLI.DiffSpec@@ -251,15 +265,20 @@     Seihou.CLI.InitSpec     Seihou.CLI.InstallCollisionSpec     Seihou.CLI.InstallHistorySpec+    Seihou.CLI.InstallSourceSpec     Seihou.CLI.ListSpec+    Seihou.CLI.ManifestCapabilityUpgradeSpec     Seihou.CLI.ManifestGuardSpec+    Seihou.CLI.ManifestRepairOriginsSpec     Seihou.CLI.ManifestUpgradeSpec     Seihou.CLI.MigrateSpec     Seihou.CLI.PendingMigrationSpec     Seihou.CLI.PromptRenderSpec+    Seihou.CLI.RecordedReleaseSpec     Seihou.CLI.Registry.SyncSpec     Seihou.CLI.Registry.ValidateSpec     Seihou.CLI.RemoteVersionSpec+    Seihou.CLI.RepairOriginsE2ESpec     Seihou.CLI.RunBlueprintRefusalSpec     Seihou.CLI.SavePromptedSpec     Seihou.CLI.SeihouBinary@@ -271,6 +290,8 @@     Seihou.CLI.UpdateInteractionSpec     Seihou.CLI.UpdateRenderSpec     Seihou.CLI.UpdateSpec+    Seihou.CLI.UpgradeDiagnosisSpec+    Seihou.CLI.UpgradeFixture     Seihou.CLI.UpgradeSpec     Seihou.FzfSpec @@ -279,7 +300,7 @@    build-depends:     aeson >=2.1 && <3,-    baikai ^>=0.7.0.0,+    baikai ^>=0.8.0.0,     base >=4.18 && <5,     bytestring >=0.11 && <1,     containers >=0.6 && <1,@@ -291,7 +312,7 @@     lens >=5.2 && <6,     process >=1.6 && <2,     seihou-cli-internal,-    seihou-core ^>=0.9.0.0,+    seihou-core ^>=0.10.0.0,     streamly-core >=0.3 && <0.5,     tasty >=1.4 && <2,     tasty-hspec >=1.2 && <2,

@@ -15,6 +15,7 @@ import Seihou.CLI.AgentMigrate (handleAgentMigrate) import Seihou.CLI.AgentModels qualified as AgentModels import Seihou.CLI.AgentRun (handleAgentRun)+import Seihou.CLI.AgentUpgrade (handleAgentUpgrade, upgradeModelConfig) import Seihou.CLI.Assist (handleAssist) import Seihou.CLI.Bootstrap (handleBootstrap) import Seihou.CLI.Browse (handleBrowse)@@ -43,12 +44,14 @@ import Seihou.CLI.SchemaUpgrade (handleSchemaUpgrade) import Seihou.CLI.Setup (handleSetup) import Seihou.CLI.Status (handleStatus)+import Seihou.CLI.Sync (handleSync) import Seihou.CLI.Update (handleUpdate) import Seihou.CLI.Upgrade (handleUpgrade) import Seihou.CLI.Validate (handleValidateModule) import Seihou.CLI.ValidateBlueprint (handleValidateBlueprint) import Seihou.CLI.ValidatePrompt (handleValidatePrompt) import Seihou.CLI.Vars (handleVars)+import Seihou.CLI.Version (seihouVersionWithGit) import Seihou.Core.Module (RunnableKind (..)) import System.Environment (getArgs) import System.Exit (exitFailure)@@ -91,6 +94,8 @@       handleVars varsOpts     Install installOpts ->       handleInstall installOpts+    Sync syncOpts ->+      handleSync syncOpts     Status statusOpts ->       handleStatus statusOpts     Diff ->@@ -153,6 +158,13 @@         AgentMigrate migrationOpts -> do           pending <- pendingAgentConfigFor AgentCmdMigrate (parentAgentFlags agentOpts) (AgentSettingFlags (migrationOpts ^. #provider) (migrationOpts ^. #model) (migrationOpts ^. #effort) (migrationOpts ^. #trace))           handleAgentMigrate (agentOpts ^. #debug) pending migrationOpts+        AgentUpgrade upgradeOpts -> do+          -- Never 'resolveAgentModelConfigFor': it exits on a configuration+          -- error, and this command must not fail on configuration state.+          (modelConfig, configProblem) <-+            upgradeModelConfig $+              loadAgentModelConfigFor AgentCmdUpgrade (parentAgentFlags agentOpts) (AgentSettingFlags (upgradeOpts ^. #provider) (upgradeOpts ^. #model) (upgradeOpts ^. #effort) (upgradeOpts ^. #trace))+          handleAgentUpgrade (agentOpts ^. #debug) seihouVersionWithGit modelConfig configProblem upgradeOpts         AgentModels modelsOpts ->           case agentOpts ^. #model of             Just _ -> do

@@ -11,13 +11,7 @@     CodexSandboxMode (CodexWorkspaceWrite),     InteractiveLaunchResult (..),     InteractiveSafety (ClaudeAllowedTools, CodexSandbox),-    effort,-    extraDirs,     interactiveLaunchRequest,-    modelId,-    safety,-    systemPrompt,-    workingDir,   ) import Baikai.Kit.Session qualified as KitSession import Baikai.Provider.Claude.Interactive@@ -75,16 +69,20 @@       launchExitCode         =<< launchClaudeInteractive           defaultClaudeInteractiveConfig-          -- InteractiveLaunchRequest comes from baikai and has no Generic instance,-          -- so these fields have no labels. Record update syntax is the only option.-          (interactiveLaunchRequest (promptOrEmpty initialPrompt))-            { systemPrompt = Just systemPrompt,-              modelId = model,-              effort = effortLevel,-              workingDir = Just cwd,-              extraDirs = addDirs,-              safety = ClaudeAllowedTools (map T.pack tools)-            }+          ( interactiveLaunchRequest (promptOrEmpty initialPrompt)+              & #systemPrompt+              .~ Just systemPrompt+              & #modelId+              .~ model+              & #effort+              .~ effortLevel+              & #workingDir+              .~ Just cwd+              & #extraDirs+              .~ addDirs+              & #safety+              .~ ClaudeAllowedTools (map T.pack tools)+          )  launchCodex :: [FilePath] -> Maybe Text -> Maybe ThinkingLevel -> Text -> Maybe Text -> IO ExitCode launchCodex addDirs model effortLevel systemPrompt initialPrompt = do@@ -96,19 +94,26 @@       exitFailure     Just _ -> do       cwd <- getCurrentDirectory+      sessionArgs <- KitSession.codexSessionArgs seihouKitConfig       launchExitCode         =<< launchCodexInteractive           defaultCodexInteractiveConfig-          -- InteractiveLaunchRequest comes from baikai and has no Generic instance,-          -- so these fields have no labels. Record update syntax is the only option.-          (interactiveLaunchRequest (promptOrEmpty initialPrompt))-            { systemPrompt = Just systemPrompt,-              modelId = model,-              effort = effortLevel,-              workingDir = Just cwd,-              extraDirs = addDirs,-              safety = CodexSandbox CodexWorkspaceWrite CodexApprovalOnRequest-            }+          ( interactiveLaunchRequest (promptOrEmpty initialPrompt)+              & #systemPrompt+              .~ Just systemPrompt+              & #modelId+              .~ model+              & #effort+              .~ effortLevel+              & #workingDir+              .~ Just cwd+              & #extraDirs+              .~ addDirs+              & #extraArgs+              .~ sessionArgs+              & #safety+              .~ CodexSandbox CodexWorkspaceWrite CodexApprovalOnRequest+          )  -- | The launched session's exit code. A 'Left' means baikai refused to render -- the launch (the provider cannot honor the requested safety policy), so no

@@ -464,7 +464,7 @@                           generatedAt = now,                           baseline = Nothing,                           applicationIds = mempty,-                          additiveOnly = False+                          sharedWriteMode = SharedWriteUnknown                         }                 )               | (c, KeepCurrent) <- conflictResolved@@ -499,6 +499,8 @@                                 applications = manifest ^. #applications,                                 recipe = manifest ^. #recipe,                                 blueprint = manifest ^. #blueprint,+                                seeds = manifest ^. #seeds,+                                checkoutOutputs = manifest ^. #checkoutOutputs,                                 blueprintMigrations = manifest ^. #blueprintMigrations                               }                       writeManifest newManifest

@@ -0,0 +1,178 @@+{-# LANGUAGE TemplateHaskell #-}++-- | @seihou agent upgrade MODULE [PROMPT]@: diagnose a project for a module+-- upgrade, write an upgrade brief outside the project, and start an agent+-- session that repairs the manifest state and performs the upgrade.+--+-- The command never fails because of project, machine, network, or+-- configuration state. Diagnosis turns every such problem into a finding+-- ("Seihou.CLI.UpgradeDiagnosis"), the brief is always written somewhere and+-- its path printed, and a session that cannot start falls back to telling+-- the user how to use the brief. The only non-zero exit is the interactive+-- session's own exit code, passed through as the other agent commands do.+-- See docs/adr/0016-agent-assisted-upgrade-diagnoses-read-only-and-never-fails.md.+module Seihou.CLI.AgentUpgrade+  ( handleAgentUpgrade,+    upgradeModelConfig,+  )+where++import Control.Exception (SomeException, displayException, try)+import Data.FileEmbed (embedFile)+import Data.Generics.Labels ()+import Data.Maybe (fromMaybe)+import Data.Text qualified as T+import Data.Text.Encoding qualified as TE+import Data.Text.IO qualified as TIO+import Seihou.CLI.AgentCompletion+  ( AgentModelConfig (..),+    AgentProvider (..),+    buildAgentCompletionRequestWith,+    defaultAgentModelConfig,+    providerToText,+    runAgentCompletion,+  )+import Seihou.CLI.AgentLaunch (substitute, upgradeAllowedTools)+import Seihou.CLI.AgentLaunchExec (launchConfiguredAgent)+import Seihou.CLI.AgentTrace (traceSinkForConfig)+import Seihou.CLI.Commands (AgentUpgradeOpts (..))+import Seihou.CLI.UpgradeDiagnosis+  ( BriefLocation (..),+    UpgradeDiagnosis,+    briefSections,+    createBriefDirectory,+    diagnoseUpgrade,+    diagnosisEnvFor,+    emptyDiagnosis,+    readiness,+    renderReadinessReport,+    writeBrief,+  )+import Seihou.Core.Types (LogLevel (..))+import Seihou.Prelude+import System.Directory (findExecutable, getCurrentDirectory)+import System.Exit (ExitCode (..), exitWith)+import System.IO (stderr)++-- | The fixed part of the brief, embedded at compile time from+-- data/upgrade-prompt.md.+promptTemplate :: Text+promptTemplate = TE.decodeUtf8 $(embedFile "data/upgrade-prompt.md")++-- | Resolve the agent configuration without ever exiting. A configuration+-- error becomes a finding for the brief, and the command carries on with+-- the built-in default provider.+upgradeModelConfig :: IO (Either Text AgentModelConfig) -> IO (AgentModelConfig, Maybe Text)+upgradeModelConfig load = do+  result <- try @SomeException load+  pure $ case result of+    Right (Right config) -> (config, Nothing)+    Right (Left err) -> (defaultAgentModelConfig, Just (fallbackFinding err))+    Left err -> (defaultAgentModelConfig, Just (fallbackFinding (T.pack (displayException err))))+  where+    fallbackFinding err =+      "agent configuration could not be resolved ("+        <> err+        <> "); fell back to the built-in default provider, "+        <> providerToText (defaultAgentModelConfig ^. #provider)++-- | Arguments: @--debug@, the seihou version text, the resolved agent+-- configuration, the configuration-fallback finding if any, and the options.+handleAgentUpgrade :: Bool -> Text -> AgentModelConfig -> Maybe Text -> AgentUpgradeOpts -> IO ()+handleAgentUpgrade debug version modelConfig configProblem opts = do+  let target = opts ^. #target+  (diagnosis, escaped) <- diagnose target+  if opts ^. #check+    then TIO.putStr (renderReadinessReport target (readiness diagnosis))+    else do+      directory <- createBriefDirectory target+      let findings = maybe [] pure configProblem <> escaped+          backupDir = either (\reason -> "a directory outside the project (" <> reason <> ")") T.pack directory+          brief = renderBrief version diagnosis findings backupDir (opts ^. #prompt)+      location <- writeBrief directory brief+      TIO.hPutStrLn stderr $ case location of+        BriefSaved path -> "Upgrade brief: " <> T.pack path+        BriefNotSaved reason -> "Upgrade brief not saved: " <> reason+      if debug+        then TIO.putStr brief+        else launch target modelConfig brief location (opts ^. #prompt)++-- | Run the diagnosis. It never throws, but if something escapes anyway the+-- brief says so and the command carries on with an empty diagnosis.+diagnose :: Text -> IO (UpgradeDiagnosis, [Text])+diagnose target = do+  rootResult <- try @SomeException getCurrentDirectory+  let root = either (const ".") id rootResult+  result <- try @SomeException (diagnosisEnvFor root >>= \env -> diagnoseUpgrade env target)+  pure $ case result of+    Right diagnosis -> (diagnosis, [])+    Left err ->+      let reason = "the diagnosis stopped unexpectedly: " <> T.pack (displayException err)+       in (emptyDiagnosis root target reason, [reason])++renderBrief :: Text -> UpgradeDiagnosis -> [Text] -> Text -> Maybe Text -> Text+renderBrief version diagnosis findings backupDir userPrompt =+  substitute+    ( briefSections diagnosis findings+        <> [ ("seihou_version", version),+             ("backup_dir", backupDir),+             ("user_request", fromMaybe "(none given)" userPrompt)+           ]+    )+    promptTemplate++launch :: Text -> AgentModelConfig -> Text -> BriefLocation -> Maybe Text -> IO ()+launch target modelConfig brief location userPrompt =+  case modelConfig ^. #provider of+    AgentProviderClaudeCli -> interactive "claude"+    AgentProviderCodexCli -> interactive "codex"+    _ -> completion+  where+    -- Without a request of the user's own, the session opens by asking the+    -- agent to start, so it does not sit waiting for input.+    initialPrompt =+      Just (fromMaybe ("Upgrade " <> target <> " by following the upgrade brief in your system prompt.") userPrompt)++    interactive binary = do+      found <- findExecutable binary+      case found of+        Nothing -> fallback location (T.pack binary <> " is not on PATH")+        Just _ -> do+          result <- try @SomeException (launchConfiguredAgent modelConfig upgradeAllowedTools False brief initialPrompt)+          case result of+            Left err -> fallback location ("the session could not start: " <> T.pack (displayException err))+            Right code -> do+              (after, _) <- diagnose target+              TIO.putStr ("\nAfter the session:\n" <> renderReadinessReport target (readiness after))+              exitWith code++    completion = do+      result <- try @SomeException $ do+        sink <- traceSinkForConfig LogNormal modelConfig+        runAgentCompletion (buildAgentCompletionRequestWith sink modelConfig brief initialPrompt)+      case result of+        Right (Right assistantText) -> TIO.putStrLn assistantText+        Right (Left err) -> fallback location ("the provider returned an error: " <> err)+        Left err -> fallback location ("the provider could not be reached: " <> T.pack (displayException err))++-- | How to use the brief when seihou could not start a session with it.+-- Always exits 0: the brief is the deliverable.+fallback :: BriefLocation -> Text -> IO ()+fallback location reason = do+  TIO.putStrLn ("Could not start the agent: " <> reason <> ".")+  case location of+    BriefSaved path ->+      TIO.putStr $+        T.unlines+          [ "The upgrade brief is saved at " <> T.pack path <> ". To use it, run:",+            "",+            "  claude --append-system-prompt \"$(cat " <> T.pack path <> ")\"",+            "",+            "or open the file in any coding agent."+          ]+    BriefNotSaved why ->+      TIO.putStrLn+        ( "The upgrade brief could not be saved ("+            <> why+            <> "). Re-run with 'seihou agent --debug upgrade' to print it, and give it to any coding agent."+        )

@@ -17,6 +17,7 @@     ContextAction (..),     ListOpts (..),     StatusOpts (..),+    SyncOpts (..),     BrowseOpts (..),     OutdatedOpts (..),     UpgradeOpts (..),@@ -28,6 +29,7 @@     AssistOpts (..),     BootstrapOpts (..),     SetupOpts (..),+    AgentUpgradeOpts (..),     BlueprintRunOpts (..),     BlueprintMigrationOpts (..),     PromptCommand (..),@@ -53,13 +55,14 @@ import Seihou.CLI.Help (HelpCommand, helpCommandParser) import Seihou.CLI.Kit (KitCommand, kitCommandParser) import Seihou.CLI.Manifest (ManifestCommand (..))+import Seihou.CLI.ManifestRepairOrigins (RepairOriginsOpts (..)) import Seihou.CLI.ManifestUpgrade (ManifestUpgradeOpts (..)) import Seihou.CLI.Migrate (MigrateOpts (..)) import Seihou.CLI.Registry (RegistryCommand (..)) import Seihou.CLI.Registry.Sync (SyncVersionsOpts (..)) import Seihou.CLI.Registry.Validate (ValidateRegistryOpts (..)) import Seihou.CLI.Version (seihouVersionWithGit)-import Seihou.Core.Types (ModuleName (..))+import Seihou.Core.Types (ApplicationId (..), ManifestSchemaVersion (..), ModuleName (..)) import Seihou.Prelude  data Command@@ -70,6 +73,7 @@   | Vars VarsOpts   | Install InstallOpts   | Status StatusOpts+  | Sync SyncOpts   | Diff   | List ListOpts   | NewModule NewModuleOpts@@ -127,6 +131,7 @@   | AgentSetup SetupOpts   | AgentRun BlueprintRunOpts   | AgentMigrate BlueprintMigrationOpts+  | AgentUpgrade AgentUpgradeOpts   | AgentModels AgentModelsOpts   | AgentConfigShow   deriving stock (Eq, Show, Generic)@@ -195,6 +200,7 @@  data RemoveOpts = RemoveOpts   { module_ :: !ModuleName,+    application :: !(Maybe ApplicationId),     dryRun :: !Bool,     force :: !Bool,     verbose :: !Bool@@ -302,6 +308,9 @@   }   deriving stock (Eq, Show, Generic) +data SyncOpts = SyncOpts {dryRun :: !Bool, json :: !Bool}+  deriving stock (Eq, Show, Generic)+ data StatusOpts = StatusOpts   { statusCheckUpdates :: !Bool,     -- | Print the blueprint's stored prompt in full instead of the bounded@@ -364,6 +373,20 @@   }   deriving stock (Eq, Show, Generic) +-- | Flags parsed for @seihou agent upgrade MODULE [PROMPT]@.+data AgentUpgradeOpts = AgentUpgradeOpts+  { -- | The MODULE argument; named target because module is a Haskell keyword.+    target :: !Text,+    prompt :: !(Maybe Text),+    -- | Print the readiness report and exit, contacting no provider.+    check :: !Bool,+    provider :: !(Maybe Text),+    model :: !(Maybe Text),+    effort :: !(Maybe Text),+    trace :: !(Maybe Text)+  }+  deriving stock (Eq, Show, Generic)+ data BlueprintRunOpts = BlueprintRunOpts   { name :: !ModuleName,     prompt :: !(Maybe Text),@@ -470,6 +493,7 @@         <> command "update" updateInfo         <> command "remove" removeInfo         <> command "status" statusInfo+        <> command "sync" syncInfo         <> command "diff" diffInfo         <> command "manifest" manifestInfo     )@@ -638,6 +662,7 @@   fmap Remove $     RemoveOpts       <$> argument moduleNameReader (metavar "MODULE" <> help "Module to remove")+      <*> optional (ApplicationId . T.pack <$> strOption (long "application" <> metavar "ID" <> help "Select a checkout-owning recorded application"))       <*> switch (long "dry-run" <> help "Show removal plan without executing")       <*> switch (long "force" <> help "Delete conflicted files without prompting")       <*> switch (long "verbose" <> short 'v' <> help "Show detailed progress messages")@@ -1460,14 +1485,16 @@                   pretty ("Current subcommands:" :: String),                   indent 2 $                     vsep-                      [ pretty ("upgrade   Convert a manifest written by an older seihou" :: String)+                      [ pretty ("upgrade          Convert a manifest written by an older seihou" :: String),+                        pretty ("repair-origins   Replace origins recorded as a path on one machine" :: String)                       ],                   line,                   pretty ("Examples:" :: String),                   indent 2 $                     vsep                       [ pretty ("seihou manifest upgrade --dry-run" :: String),-                        pretty ("seihou manifest upgrade" :: String)+                        pretty ("seihou manifest upgrade" :: String),+                        pretty ("seihou manifest repair-origins --dry-run" :: String)                       ]                 ]           )@@ -1476,18 +1503,76 @@ manifestCommandParser :: Parser ManifestCommand manifestCommandParser =   hsubparser-    (command "upgrade" manifestUpgradeInfo)+    ( command "upgrade" manifestUpgradeInfo+        <> command "repair-origins" manifestRepairOriginsInfo+    ) +manifestRepairOriginsInfo :: ParserInfo ManifestCommand+manifestRepairOriginsInfo =+  info+    (manifestRepairOriginsParser <**> helper)+    ( fullDesc+        <> progDesc "Replace artifact origins recorded as a path on one machine with a remote URL"+        <> footerDoc+          ( Just $+              vsep+                [ pretty ("An artifact installed from a local checkout used to record that" :: String),+                  pretty ("checkout's path as its origin, and the path reached the manifest." :: String),+                  pretty ("A path means nothing on another machine and turns into an origin" :: String),+                  pretty ("mismatch here once the artifact is reinstalled from its real remote." :: String),+                  line,+                  pretty ("For each recorded path this command proposes a remote, in order of" :: String),+                  pretty ("preference: the path's own 'origin' remote if the checkout exists" :: String),+                  pretty ("here, the remote the installed copy of an artifact recorded under the" :: String),+                  pretty ("path records, or a URL you give with --set NAME=URL. Every origin" :: String),+                  pretty ("recorded under the same path is rewritten to the same URL." :: String),+                  line,+                  pretty ("The report prints every proposal and its evidence. The command exits" :: String),+                  pretty ("1 while any path is unresolved or conflicting, even if others were" :: String),+                  pretty ("written. Needs a manifest at the current schema; run" :: String),+                  pretty ("'seihou manifest upgrade' first if it is older." :: String),+                  line,+                  pretty ("Examples:" :: String),+                  indent 2 $+                    vsep+                      [ pretty ("seihou manifest repair-origins --dry-run" :: String),+                        pretty ("seihou manifest repair-origins" :: String),+                        pretty ("seihou manifest repair-origins --set nix-haskell-flake=https://github.com/shinzui/seihou-modules.git" :: String)+                      ]+                ]+          )+    )++manifestRepairOriginsParser :: Parser ManifestCommand+manifestRepairOriginsParser =+  fmap ManifestRepairOrigins $+    RepairOriginsOpts+      <$> switch (long "dry-run" <> help "Print the proposed rewrites without writing the manifest")+      <*> many+        ( option+            overridePair+            ( long "set"+                <> metavar "NAME=URL"+                <> help "Use URL as the remote for the path the artifact NAME is recorded under (repeatable)"+            )+        )+ manifestUpgradeInfo :: ParserInfo ManifestCommand manifestUpgradeInfo =   info     (manifestUpgradeParser <**> helper)     ( fullDesc-        <> progDesc "Convert a manifest written by an older seihou to the portable format"+        <> progDesc "Upgrade a manifest written by an older seihou, one schema step at a time"         <> footerDoc           ( Just $               vsep-                [ pretty ("Manifests written before schema version 6 record, for every applied" :: String),+                [ pretty ("Every manifest schema change has one adjacent upgrade step, and this" :: String),+                  pretty ("command runs each step in order up to the current schema, or up to" :: String),+                  pretty ("--to VERSION. Once the manifest reaches schema 7 it also works out, for" :: String),+                  pretty ("each path whose shared-write mode is unknown, whether every owner only" :: String),+                  pretty ("appends to it; that needs each owner's recorded module version installed." :: String),+                  line,+                  pretty ("Manifests written before schema version 6 record, for every applied" :: String),                   pretty ("module, the absolute directory that module occupied on the machine" :: String),                   pretty ("that ran seihou. Those paths mean nothing in another clone, so this" :: String),                   pretty ("command replaces each one with a portable origin: the git URL the" :: String),@@ -1506,8 +1591,16 @@ manifestUpgradeParser =   fmap ManifestUpgrade $     ManifestUpgradeOpts-      <$> switch (long "dry-run" <> help "Show every conversion without writing the manifest")-      <*> switch (long "force" <> help "Write even when a converted artifact is missing or stale here")+      <$> switch (long "dry-run" <> help "Show every step and conversion without writing the manifest")+      <*> switch (long "force" <> help "Accept inferred origins even when an artifact is missing or stale here")+      <*> optional+        ( option+            (ManifestSchemaVersion <$> auto)+            ( long "to"+                <> metavar "VERSION"+                <> help "Stop at this schema version instead of the current one"+            )+        )  registryInfo :: ParserInfo Command registryInfo =@@ -1644,6 +1737,7 @@                         pretty ("setup       Guided project setup: configure, run, and commit" :: String),                         pretty ("run         Run an agent-driven blueprint" :: String),                         pretty ("migrate     Run ordered library-upgrade blueprint migrations" :: String),+                        pretty ("upgrade     Upgrade a module with an agent that repairs manifest state" :: String),                         pretty ("models      List known agent models" :: String)                       ]                 ]@@ -1683,6 +1777,7 @@         <> command "setup" agentSetupInfo         <> command "run" agentRunInfo         <> command "migrate" agentMigrateInfo+        <> command "upgrade" agentUpgradeInfo         <> command "models" agentModelsInfo         <> command "config" agentConfigInfo     )@@ -1804,6 +1899,52 @@       <*> effortOption       <*> traceOption +agentUpgradeInfo :: ParserInfo AgentCommand+agentUpgradeInfo =+  info+    (agentUpgradeParser <**> helper)+    ( fullDesc+        <> progDesc "Upgrade a module with an agent that repairs manifest state"+        <> footerDoc+          ( Just $+              vsep+                [ pretty ("Diagnoses the project for MODULE without changing anything: the manifest," :: String),+                  pretty ("the installed copy, shared-write evidence, recorded origins, and a dry run" :: String),+                  pretty ("of the update. Writes the findings, a repair playbook, and safety rules into" :: String),+                  pretty ("an upgrade brief outside the project, prints its path, and starts an agent" :: String),+                  pretty ("session with the brief as its system prompt." :: String),+                  line,+                  pretty ("The command never fails because of project state: a missing or corrupt" :: String),+                  pretty ("manifest, a missing agent binary, or a bad agent configuration becomes a" :: String),+                  pretty ("finding in the brief. --debug prints the brief without contacting a provider." :: String),+                  line,+                  pretty ("--check prints the readiness report and exits 0. Its last line is" :: String),+                  pretty ("'Upgrade readiness: ready' or 'Upgrade readiness: not ready (N ...)'." :: String),+                  line,+                  pretty ("Examples:" :: String),+                  indent 2 $+                    vsep+                      [ pretty ("seihou agent upgrade nix-haskell-flake" :: String),+                        pretty ("seihou agent upgrade nix-haskell-flake \"stay on the 0.x line\"" :: String),+                        pretty ("seihou agent upgrade nix-haskell-flake --check" :: String),+                        pretty ("seihou agent --debug upgrade nix-haskell-flake" :: String)+                      ]+                ]+          )+    )++agentUpgradeParser :: Parser AgentCommand+agentUpgradeParser =+  fmap AgentUpgrade $+    AgentUpgradeOpts+      <$> argument (T.pack <$> str) (metavar "MODULE" <> help "The module (or recorded target) to upgrade")+      <*> optional (argument (T.pack <$> str) (metavar "PROMPT" <> help "Anything the agent should know about this upgrade"))+      <*> switch (long "check" <> help "Print the upgrade readiness report and exit 0 without starting an agent")+      <*> providerOption+      <*> modelOption+      <*> effortOption+      <*> traceOption+ agentRunInfo :: ParserInfo AgentCommand agentRunInfo =   info@@ -2181,6 +2322,14 @@       | T.null v -> Left "expected KEY=VALUE format"       | otherwise -> Right (k, T.drop 1 v) +overridePair :: ReadM (Text, Text)+overridePair = eitherReader $ \s ->+  case T.breakOn "=" (T.pack s) of+    (name, url)+      | T.null name -> Left "artifact name cannot be empty"+      | T.null (T.drop 1 url) -> Left "expected NAME=URL format"+      | otherwise -> Right (name, T.drop 1 url)+ providerOption :: Parser (Maybe Text) providerOption =   optional $@@ -2220,3 +2369,13 @@           <> metavar "SETTING"           <> help "Record model calls: off, file, stdout, or stderr (file path: agent.tracePath)"       )++syncInfo :: ParserInfo Command+syncInfo = info (syncParser <**> helper) (fullDesc <> progDesc "Rebuild ignored checkout outputs from the manifest")+  where+    syncParser =+      Sync+        <$> ( SyncOpts+                <$> switch (long "dry-run" <> help "Show planned links without changing anything")+                <*> switch (long "json" <> help "Print one JSON report")+            )

@@ -19,7 +19,10 @@     cloneRepo,     copyDirectoryRecursive,     formatInstallRefusal,+    formatRecordedSourceNotice,     installModuleDir,+    recordedSourceUrl,+    resolveRecordedSource,   ) import Seihou.CLI.Registry.Sync (checkRegistryVersionDrift) import Seihou.CLI.Shared (logIO)@@ -47,6 +50,13 @@    TIO.putStrLn $ "Installing from " <> source <> "..." +  -- The clone reads from the argument as given; what the installed copy+  -- records as its origin may differ. A local checkout records its published+  -- remote so no machine-local path reaches a project's manifest.+  recordedSource <- resolveRecordedSource source+  mapM_ TIO.putStrLn (formatRecordedSourceNotice recordedSource)+  let recorded = recordedSourceUrl recordedSource+   -- Clone into a temporary directory   withSystemTempDirectory "seihou-install" $ \tmpDir -> do     let repoName = parseModuleName source@@ -68,19 +78,19 @@       SingleModule rootDir -> do         when (not (null (iopts ^. #modules)) || iopts ^. #all) $           logIO LogNormal (logWarn "--module and --all flags are ignored for single-module repositories.")-        installSingleModule iopts rootDir source Nothing+        installSingleModule iopts rootDir source recorded Nothing       SingleRecipe rootDir -> do         when (not (null (iopts ^. #modules)) || iopts ^. #all) $           logIO LogNormal (logWarn "--module and --all flags are ignored for single-recipe repositories.")-        installSingleRecipe iopts rootDir source+        installSingleRecipe iopts rootDir source recorded       SingleBlueprint rootDir -> do         when (not (null (iopts ^. #modules)) || iopts ^. #all) $           logIO LogNormal (logWarn "--module and --all flags are ignored for single-blueprint repositories.")-        installSingleBlueprint iopts rootDir source+        installSingleBlueprint iopts rootDir source recorded       SinglePrompt rootDir -> do         when (not (null (iopts ^. #modules)) || iopts ^. #all) $           logIO LogNormal (logWarn "--module and --all flags are ignored for single-prompt repositories.")-        installSinglePrompt iopts rootDir source+        installSinglePrompt iopts rootDir source recorded       MultiModule registry -> do         regErrors <- validateRegistry cloneDir registry         if not (null regErrors)@@ -92,7 +102,7 @@           else do             driftWarnings <- checkRegistryVersionDrift cloneDir registry             logIO LogNormal (mapM_ logWarn driftWarnings)-            installFromRegistry iopts cloneDir registry source+            installFromRegistry iopts cloneDir registry recorded    -- Record URL in history for future recall (only reached on success)   recordUrl source@@ -159,8 +169,8 @@       exitFailure  -- | Install a single-module repo (legacy behavior).-installSingleModule :: InstallOpts -> FilePath -> Text -> Maybe Text -> IO ()-installSingleModule iopts rootDir source registryName = do+installSingleModule :: InstallOpts -> FilePath -> Text -> Text -> Maybe Text -> IO ()+installSingleModule iopts rootDir source recorded registryName = do   let name = case iopts ^. #name of         Just n -> T.unpack n         Nothing -> parseModuleName source@@ -188,14 +198,14 @@     Right _ -> pure ()   TIO.putStrLn "  Validated module definition" -  outcome <- installModuleDir (iopts ^. #force) rootDir name source registryName (modul ^. #version) []-  reportSingleInstall name source outcome+  outcome <- installModuleDir (iopts ^. #force) rootDir name recorded registryName (modul ^. #version) []+  reportSingleInstall name recorded outcome   TIO.putStrLn ""   TIO.putStrLn $ "Module available as: " <> T.pack name  -- | Install a single-recipe repo.-installSingleRecipe :: InstallOpts -> FilePath -> Text -> IO ()-installSingleRecipe iopts rootDir source = do+installSingleRecipe :: InstallOpts -> FilePath -> Text -> Text -> IO ()+installSingleRecipe iopts rootDir source recorded = do   let name = case iopts ^. #name of         Just n -> T.unpack n         Nothing -> parseModuleName source@@ -203,14 +213,14 @@   -- Validate recipe.dhall exists (discoverRepoContents already confirmed it)   TIO.putStrLn "  Validated recipe definition" -  outcome <- installModuleDir (iopts ^. #force) rootDir name source Nothing Nothing []-  reportSingleInstall name source outcome+  outcome <- installModuleDir (iopts ^. #force) rootDir name recorded Nothing Nothing []+  reportSingleInstall name recorded outcome   TIO.putStrLn ""   TIO.putStrLn $ "Recipe available as: " <> T.pack name  -- | Install a single-blueprint repo.-installSingleBlueprint :: InstallOpts -> FilePath -> Text -> IO ()-installSingleBlueprint iopts rootDir source = do+installSingleBlueprint :: InstallOpts -> FilePath -> Text -> Text -> IO ()+installSingleBlueprint iopts rootDir source recorded = do   let name = case iopts ^. #name of         Just n -> T.unpack n         Nothing -> parseModuleName source@@ -239,14 +249,14 @@   TIO.putStrLn "  Validated blueprint definition"    let bpVersion = (bp ^. #version)-  outcome <- installModuleDir (iopts ^. #force) rootDir name source Nothing bpVersion []-  reportSingleInstall name source outcome+  outcome <- installModuleDir (iopts ^. #force) rootDir name recorded Nothing bpVersion []+  reportSingleInstall name recorded outcome   TIO.putStrLn ""   TIO.putStrLn $ "Blueprint available as: " <> T.pack name  -- | Install a single-prompt repo.-installSinglePrompt :: InstallOpts -> FilePath -> Text -> IO ()-installSinglePrompt iopts rootDir source = do+installSinglePrompt :: InstallOpts -> FilePath -> Text -> Text -> IO ()+installSinglePrompt iopts rootDir source recorded = do   let name = case iopts ^. #name of         Just n -> T.unpack n         Nothing -> parseModuleName source@@ -274,8 +284,8 @@     Right _ -> pure ()   TIO.putStrLn "  Validated prompt definition" -  outcome <- installModuleDir (iopts ^. #force) rootDir name source Nothing (prompt ^. #version) []-  reportSingleInstall name source outcome+  outcome <- installModuleDir (iopts ^. #force) rootDir name recorded Nothing (prompt ^. #version) []+  reportSingleInstall name recorded outcome   TIO.putStrLn ""   TIO.putStrLn $ "Prompt available as: " <> T.pack name 

@@ -6,47 +6,14 @@   ) where -import Baikai.Interactive (InteractiveProvider (..))+import Baikai.Kit.Command (KitCommand (..)) import Baikai.Kit.Command qualified as Kit-import Baikai.Kit.Config (KitConfig (..), KitScope (..))-import Baikai.Kit.Install (OverwritePolicy) import Options.Applicative (Parser)+import Seihou.CLI.KitConfig (seihouKitConfig) import Seihou.Prelude -data KitCommand-  = KitList-  | KitInstall !Text !KitScope-  | KitUpdate !(Maybe Text) !OverwritePolicy-  | KitUninstall !Text !KitScope-  | KitStatus-  deriving stock (Eq, Show)- kitCommandParser :: Parser KitCommand-kitCommandParser = fromShared <$> Kit.kitCommandParser--seihouKitConfig :: KitConfig-seihouKitConfig =-  KitConfig-    { toolName = "seihou",-      repoUrl = "https://github.com/shinzui/seihou-kit.git",-      providers = [InteractiveClaude, InteractiveCodex]-    }+kitCommandParser = Kit.kitCommandParser seihouKitConfig  runKit :: KitCommand -> IO ()-runKit = Kit.runKit seihouKitConfig . toShared--fromShared :: Kit.KitCommand -> KitCommand-fromShared = \case-  Kit.KitList -> KitList-  Kit.KitInstall name scope -> KitInstall name scope-  Kit.KitUpdate name policy -> KitUpdate name policy-  Kit.KitUninstall name scope -> KitUninstall name scope-  Kit.KitStatus -> KitStatus--toShared :: KitCommand -> Kit.KitCommand-toShared = \case-  KitList -> Kit.KitList-  KitInstall name scope -> Kit.KitInstall name scope-  KitUpdate name policy -> Kit.KitUpdate name policy-  KitUninstall name scope -> Kit.KitUninstall name scope-  KitStatus -> Kit.KitStatus+runKit = Kit.runKit seihouKitConfig

@@ -3,20 +3,27 @@   ) where -import Control.Monad (foldM, when)+import Control.Exception (IOException, try)+import Control.Monad (foldM, forM_, unless, when) import Data.Generics.Labels ()+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 Data.Time.Clock (getCurrentTime)+import Seihou.CLI.CheckoutSync (renderCheckoutPlan) import Seihou.CLI.Commands (RemoveOpts (..)) import Seihou.CLI.Style (bold, dim, green, useColor, yellow)+import Seihou.Core.Checkout import Seihou.Core.Types import Seihou.Effect.FilesystemInterp (runFilesystem) import Seihou.Effect.ManifestStore (readManifest, writeManifest) import Seihou.Effect.ManifestStoreInterp (runManifestStore)+import Seihou.Effect.ProcessInterp (runProcessIO)+import Seihou.Engine.Checkout import Seihou.Engine.Remove import Seihou.Prelude+import System.Directory (getCurrentDirectory) import System.Exit (ExitCode (..), exitFailure, exitWith) import System.IO (hFlush, hIsTerminalDevice, stdin, stdout) @@ -36,6 +43,11 @@       exitFailure     Right (Just m) -> pure m +  case selectCheckoutRemoval manifest modName (opts ^. #application) of+    Left err -> TIO.putStrLn (err ^. #message) >> exitFailure+    Right (Just selected) -> handleCheckoutRemoval opts manifest selected >> exitWith ExitSuccess+    Right Nothing -> pure ()+   -- Find the module's removal spec   let mApplied = findAppliedModule manifest modName   case mApplied of@@ -193,3 +205,65 @@ applyColor :: Bool -> (Text -> Text) -> Text -> Text applyColor True f t = f t applyColor False _ t = t++-- | Automatic cleanup uses recorded declarations even without a custom spec.+handleCheckoutRemoval :: RemoveOpts -> Manifest -> CheckoutRemovalSelection -> IO ()+handleCheckoutRemoval opts manifest selected = do+  root <- getCurrentDirectory+  let candidate = selected ^. #candidateManifest+  checked <- runEff $ runFilesystem $ runProcessIO $ prepareCheckoutPlan Reconcile ApplyDeclaration root manifest candidate []+  plan <- case checked of+    Left err -> TIO.putStrLn (err ^. #message) >> exitFailure+    Right plan -> pure plan+  TIO.putStr (renderCheckoutPlan (opts ^. #dryRun) plan)+  unless (checkoutApplicable plan) exitFailure+  ordinary <- case selected ^. #removal of+    Nothing -> pure (ExecutedRemovalPlan (selected ^. #moduleName) [])+    Just spec -> do+      forM_ (spec ^. #steps) $ \step ->+        when (any (pathsOverlap (T.unpack (step ^. #dest))) (Map.keys (manifest ^. #checkoutOutputs))) $ do+          TIO.putStrLn "Custom removal overlaps a checkout destination; remove that custom step because checkout links are retired automatically."+          exitFailure+      result <- runEff $ runFilesystem $ buildRemovalOps manifest (selected ^. #moduleName) spec+      case result of+        Left _ -> TIO.putStrLn "Cannot plan the module's custom removal; correct its declared paths first." >> exitFailure+        Right removal -> pure removal+  -- A selected application's removal cannot delete another application's files.+  forM_ (ordinary ^. #ops) $ \op -> forM_ (removalDestination op) $ \path ->+    case Map.lookup path (manifest ^. #files) of+      Just record+        | not (Set.null (Set.delete (selected ^. #applicationId) (record ^. #applicationIds))) ->+            TIO.putStrLn ("Removal path has surviving application owners: " <> T.pack path) >> exitFailure+      _ -> pure ()+  color <- useColor+  mapM_ (displayOp color) (ordinary ^. #ops)+  when (opts ^. #dryRun) (exitWith ExitSuccess)+  interactive <- hIsTerminalDevice stdin+  when (not (opts ^. #force) && interactive) $ do+    TIO.putStr "\n  Proceed? [y/N] "+    hFlush stdout+    response <- T.strip . T.pack <$> getLine+    unless (T.toLower response == "y") (exitWith (ExitFailure 3))+  let conflicts = [path | DeleteFileOp path RFConflict <- ordinary ^. #ops]+  unless (null conflicts || opts ^. #force) $ do+    TIO.putStrLn "Custom removal has modified files; use --force after reviewing them."+    exitFailure+  now <- getCurrentTime+  applied <- runEff $ runFilesystem $ runProcessIO $ applyCheckoutPlan ApplyDeclaration root plan+  case applied ^. #failure of+    Just err -> TIO.putStrLn (err ^. #message) >> exitFailure+    Nothing -> pure ()+  result <- try @IOException $ do+    _ <- runEff $ runFilesystem $ executeRemovalOps manifest ordinary Set.empty now+    runEff $ runFilesystem $ runManifestStore ".seihou/manifest.json" $ writeManifest (candidate & #genAt .~ now)+  case result of+    Left err -> do+      _ <- runEff $ runFilesystem $ rollbackCheckout root (applied ^. #undo)+      TIO.putStrLn ("Removal failed: " <> T.pack (show err))+      exitFailure+    Right () -> TIO.putStrLn ("Removed checkout ownership for " <> selected ^. #instanceName . #unModuleName <> ".")+  where+    removalDestination (DeleteFileOp path _) = Just path+    removalDestination (StripSectionOp path) = Just path+    removalDestination (RewriteOp path _) = Just path+    removalDestination RemovalCommandOp {} = Nothing

@@ -13,6 +13,8 @@ import Data.Text.IO qualified as TIO import Data.Time (UTCTime) import Data.Time.Clock (getCurrentTime)+import Effectful.Exception qualified as E+import Seihou.CLI.CheckoutSync (renderCheckoutPlan) import Seihou.CLI.CommandExecution   ( CommandDisposition (..),     CommandExecutionError (..),@@ -51,6 +53,7 @@ import Seihou.Core.Application (attachApplication, buildAppliedComposition, mkApplicationId, replaceAppliedComposition) import Seihou.Core.ArtifactOriginDetect (detectArtifactOrigin) import Seihou.Core.ArtifactRef (renderArtifactRefError)+import Seihou.Core.Checkout import Seihou.Core.Context (resolveContext) import Seihou.Core.Migration (MigrationPlan (..)) import Seihou.Core.Module (defaultSearchPaths, discoverRunnable)@@ -71,6 +74,7 @@ import Seihou.Effect.ManifestStoreInterp (runManifestStore) import Seihou.Effect.ProcessInterp (runProcessIO) import Seihou.Engine.Baseline (manifestBaselineRefs, recordGeneratedBaselines)+import Seihou.Engine.Checkout import Seihou.Engine.Conflict (resolveConflicts) import Seihou.Engine.Diff (computeDiff) import Seihou.Engine.Execute (executePlan)@@ -326,6 +330,22 @@       candidateCommandReceipts =         finalizeCommandReceipts commandPlan [] priorCommandReceipts +  let declarationApplication =+        buildAppliedComposition appliedTarget targetOrigin targetVersion additional (Just namespace) context originedModules resolved now+  checkoutCandidate <- case replaceCheckoutApplications manifest [(declarationApplication, opsFiltered)] of+    Left err -> TIO.putStrLn (err ^. #message) >> exitFailure+    Right candidate -> pure candidate+  checkoutPreflight <-+    runEff $+      runFilesystem $+        runProcessIO $+          prepareCheckoutApplication projectRoot manifest checkoutCandidate opsFiltered+  checkoutPlan <- case checkoutPreflight of+    Left err -> TIO.putStrLn (err ^. #message) >> exitFailure+    Right plan -> pure plan+  TIO.putStr (renderCheckoutPlan (runOpts ^. #dryRun || runOpts ^. #diff) checkoutPlan)+  when (not (checkoutApplicable checkoutPlan)) exitFailure+   -- 6d. 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@@ -396,7 +416,7 @@                                   generatedAt = now,                                   baseline = Nothing,                                   applicationIds = mempty,-                                  additiveOnly = False+                                  sharedWriteMode = SharedWriteUnknown                                 }                         )                       | (c, KeepCurrent) <- conflictResolved@@ -412,69 +432,81 @@                 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) originedModules now-                                  allResolvedVals =-                                    Map.unions-                                      [Map.map (^. #value) vs | vs <- Map.elems resolved]-                                  appliedRecipe = case recipeInfo of-                                    Just (rName, rVersion) ->-                                      -- targetOrigin is the recipe's own origin-                                      -- here: recipeInfo is Just only on the-                                      -- branch where targetInfo was built from-                                      -- the discovered recipe directory.-                                      Just AppliedRecipe {name = rName, origin = targetOrigin, recipeVersion = rVersion, appliedAt = now}-                                    Nothing -> (manifest ^. #recipe)-                                  appliedCompositionWithoutReceipts =-                                    buildAppliedComposition-                                      appliedTarget-                                      targetOrigin-                                      targetVersion-                                      additional-                                      (Just namespace)-                                      context-                                      originedModules-                                      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+                      runProcessIO $+                        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) originedModules now+                                    allResolvedVals =+                                      Map.unions+                                        [Map.map (^. #value) vs | vs <- Map.elems resolved]+                                    appliedRecipe = case recipeInfo of+                                      Just (rName, rVersion) ->+                                        -- targetOrigin is the recipe's own origin+                                        -- here: recipeInfo is Just only on the+                                        -- branch where targetInfo was built from+                                        -- the discovered recipe directory.+                                        Just AppliedRecipe {name = rName, origin = targetOrigin, recipeVersion = rVersion, appliedAt = now}+                                      Nothing -> (manifest ^. #recipe)+                                    appliedCompositionWithoutReceipts =+                                      buildAppliedComposition+                                        appliedTarget+                                        targetOrigin+                                        targetVersion+                                        additional+                                        (Just namespace)+                                        context+                                        originedModules+                                        resolved+                                        now+                                    appliedComposition =+                                      ( appliedCompositionWithoutReceipts+                                          & #commandReceipts+                                          .~ candidateCommandReceipts                                       )-                                      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)+                                    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,+                                          seeds = manifest ^. #seeds,+                                          checkoutOutputs = checkoutCandidate ^. #checkoutOutputs,+                                          blueprintMigrations = manifest ^. #blueprintMigrations+                                        }+                                actual <- prepareCheckoutPlan Reconcile ApplyDeclaration projectRoot manifest checkoutCandidate []+                                checked <- case actual of+                                  Left err -> E.throwIO (userError (T.unpack (err ^. #message)))+                                  Right plan | checkoutApplicable plan -> pure plan+                                  Right plan -> E.throwIO (userError (T.unpack (renderCheckoutPlan False plan)))+                                links <- applyCheckoutPlan ApplyDeclaration projectRoot checked+                                case links ^. #failure of+                                  Just err -> E.throwIO (userError (T.unpack (err ^. #message)))+                                  Nothing -> pure ()+                                writeManifest newManifest `E.onException` (rollbackCheckout projectRoot (links ^. #undo) >> pure ())+                                pure (Right newManifest)                newManifest <- case generationAttempt of                 Left err -> do

@@ -12,9 +12,10 @@ import Seihou.CLI.Outdated (checkInstalledModulesForUpdates) import Seihou.CLI.PendingMigrations (detectPendingMigrations) import Seihou.CLI.Shared (logIO)-import Seihou.CLI.StatusRender (PromptDisplay (..), formatArtifactChecks, formatStatusWith)+import Seihou.CLI.StatusRender (PromptDisplay (..), formatArtifactChecks, formatCheckoutStatus, formatStatusWith) import Seihou.CLI.Style (useColor) import Seihou.CLI.VersionCompare (OutdatedEntry (..))+import Seihou.Core.Checkout import Seihou.Core.Module (defaultSearchPaths, discoverAllModules) import Seihou.Core.Status (computeTrackedFileStatuses) import Seihou.Core.Types@@ -22,6 +23,8 @@ import Seihou.Effect.Logger (logError) import Seihou.Effect.ManifestStore (readManifest) import Seihou.Effect.ManifestStoreInterp (runManifestStore)+import Seihou.Effect.ProcessInterp (runProcessIO)+import Seihou.Engine.Checkout import Seihou.Prelude import System.Directory (getCurrentDirectory) import System.Exit (exitFailure)@@ -50,6 +53,11 @@     Right Nothing ->       TIO.putStrLn "No Seihou manifest found. Run 'seihou run <module>' to generate a project."     Right (Just (manifest, tracked)) -> do+      root <- getCurrentDirectory+      checkout <- runEff $ runFilesystem $ runProcessIO $ prepareCheckoutPlan Rebuild SyncIgnoredOnly root manifest manifest []+      case checkout of+        Left err -> TIO.putStrLn ("Checkout outputs: " <> err ^. #message)+        Right plan -> TIO.putStr (formatCheckoutStatus plan)       mEntries <-         if opts ^. #statusCheckUpdates && not (null (manifest ^. #modules))           then fetchUpdateEntries

@@ -0,0 +1,31 @@+module Seihou.CLI.Sync (handleSync) where++import Data.Aeson qualified as A+import Data.ByteString.Lazy.Char8 qualified as LBS+import Data.Generics.Labels ()+import Data.Maybe (isJust)+import Data.Text.IO qualified as TIO+import Seihou.CLI.CheckoutSync+import Seihou.CLI.Commands (SyncOpts (..))+import Seihou.Core.Checkout+import Seihou.Engine.Checkout (CheckoutExecution (..))+import Seihou.Prelude+import System.Exit (exitFailure)++handleSync :: SyncOpts -> IO ()+handleSync opts = do+  result <- runCheckoutSync (opts ^. #dryRun)+  case result of+    Left err -> do+      if opts ^. #json+        then LBS.putStrLn (A.encode (checkoutFailureJSON (opts ^. #dryRun) err))+        else TIO.putStrLn (err ^. #message)+      exitFailure+    Right report -> do+      if opts ^. #json+        then LBS.putStrLn (A.encode (checkoutReportJSON report))+        else do+          TIO.putStr (renderCheckoutPlan (opts ^. #dryRun) (report ^. #plan))+          mapM_ TIO.putStrLn (report ^. #notices)+          mapM_ (TIO.putStrLn . (^. #message)) (report ^. #execution . #failure)+      if not (checkoutApplicable (report ^. #plan)) || isJust (report ^. #execution . #failure) then exitFailure else pure ()

@@ -24,7 +24,7 @@   ) import Seihou.CLI.Update.Render   ( encodeUpdateOutput,-    errorOutput,+    errorOutputFor,     planOutput,     renderUpdateHuman,     resultOutput,@@ -77,8 +77,8 @@ handlePlanned :: Bool -> UpdateOpts -> Either Service.UpdateError Service.UpdatePlan -> IO () handlePlanned _ opts (Left err) = do   if opts ^. #json-    then LBS.putStrLn (encodeUpdateOutput (errorOutput err))-    else TIO.hPutStr stderr (renderUpdateHuman False (errorOutput err))+    then LBS.putStrLn (encodeUpdateOutput (errorOutputFor (opts ^. #targets) err))+    else TIO.hPutStr stderr (renderUpdateHuman False (errorOutputFor (opts ^. #targets) err))   exitFailure handlePlanned terminal opts (Right originalPlan) = do   forced <-

@@ -24,6 +24,7 @@ where  import Baikai qualified+import Baikai.Kit.Session qualified as KitSession import Baikai.Options qualified as BaikaiOptions import Baikai.Provider.Claude.Api qualified as ClaudeApi import Baikai.Provider.Claude.Cli qualified as ClaudeCli@@ -34,12 +35,13 @@ import Baikai.Trace qualified as BaikaiTrace import Baikai.Trace.Sink (TraceSink, silent) import Control.Exception (try)-import Control.Lens ((^.))+import Control.Lens ((&), (.~), (^.)) import Data.Generics.Labels () import Data.Text (Text) import Data.Text qualified as Text import Data.Vector qualified as V import GHC.Generics (Generic)+import Seihou.CLI.KitConfig (seihouKitConfig) import System.Directory (getCurrentDirectory)  data AgentProvider@@ -306,13 +308,16 @@ registerAgentProviders :: IO () registerAgentProviders = do   ClaudeCli.register-  CodexCli.register+  sessionArgs <- KitSession.codexSessionArgs seihouKitConfig+  Baikai.registerApiProvider $+    CodexCli.codexCliProvider (CodexCli.defaultCodexCliConfig & #extraArgs .~ sessionArgs)   ClaudeApi.register   OpenAIApi.register  registerAgentProvidersWithCliAccess :: [FilePath] -> [String] -> IO () registerAgentProvidersWithCliAccess extraDirs tools = do   cwd <- getCurrentDirectory+  sessionArgs <- KitSession.codexSessionArgs seihouKitConfig   Baikai.registerApiProvider $     ClaudeCli.claudeCliProvider       ClaudeCli.defaultClaudeCliConfig@@ -323,7 +328,7 @@     CodexCli.codexCliProvider       CodexCli.defaultCodexCliConfig         { CodexCli.workingDir = Just cwd,-          CodexCli.extraArgs = codexAccessArgs extraDirs+          CodexCli.extraArgs = codexAccessArgs extraDirs <> sessionArgs         }   ClaudeApi.register   OpenAIApi.register

@@ -203,6 +203,7 @@   | AgentCmdSetup   | AgentCmdRun   | AgentCmdMigrate+  | AgentCmdUpgrade   | AgentCmdPromptRun   deriving stock (Eq, Show, Enum, Bounded) @@ -214,6 +215,7 @@ agentCommandSegment AgentCmdSetup = "setup" agentCommandSegment AgentCmdRun = "run" agentCommandSegment AgentCmdMigrate = "migrate"+agentCommandSegment AgentCmdUpgrade = "upgrade" agentCommandSegment AgentCmdPromptRun = "prompt-run"  -- | Human-facing label for display, e.g. @"prompt run"@ for the two-word

@@ -4,6 +4,7 @@     gatherAgentContext,     defaultAllowedTools,     setupAllowedTools,+    upgradeAllowedTools,     bootstrapAllowedTools,     substitute,     formatSeihouProjectState,@@ -99,6 +100,23 @@     "EnterWorktree",     "ExitWorktree"   ]++-- | Allowed tools for @seihou agent upgrade@: setup's, plus what backing up+-- and comparing a manifest needs. Anything else (a project build, say) asks+-- the user in the session as usual.+upgradeAllowedTools :: [String]+upgradeAllowedTools =+  nub $+    setupAllowedTools+      <> [ "Bash(cp *)",+           "Bash(mv *)",+           "Bash(diff *)",+           "Bash(mktemp *)",+           "Bash(find *)",+           "Bash(head *)",+           "Bash(tail *)",+           "Bash(jq *)"+         ]  -- | Allowed tools for the bootstrap command — grants full git access, temp directories, -- and common shell utilities so the agent can scaffold, test, and commit without prompting.

@@ -0,0 +1,84 @@+-- | The one vocabulary the CLI uses to name a recorded application or an+-- applied module instance to a person.+--+-- An application id is a SHA-256 digest; nobody recognises it. What people+-- recognise is the target they ran and, for a repeated module, the parent+-- variables that told the instances apart, which @seihou status@ already+-- prints as @link-skill [skill.name=exec-plan]@. Status and update both render+-- through this module so the two can never drift apart.+--+-- Everything here is pure: it never resolves an artifact, inspects a path on+-- this machine, or renders a resolved variable value. Parent variables are+-- identity context the manifest records verbatim, not user secrets.+module Seihou.CLI.ApplicationDisplay+  ( applicationLabel,+    appliedModuleLabel,+    appliedTargetName,+    parentVarsText,+    moduleNameText,+  )+where++import Data.Generics.Labels ()+import Data.Map.Strict qualified as Map+import Data.Text qualified as T+import Seihou.CLI.Update.Types (ApplicationRef (..))+import Seihou.Core.Types+  ( ApplicationId (..),+    AppliedModule (..),+    AppliedTarget (..),+    ModuleName (..),+    ParentVars (..),+    RecipeName (..),+    VarName (..),+  )+import Seihou.Prelude++-- | How a recorded application is named: its target, the root instance's+-- parent variables, and any additional modules applied with it.+--+-- An application id is derived from exactly the target and the additional+-- modules, so two recorded applications never share a label. A file record+-- can still name an owner the manifest does not record as an application;+-- only then is a short prefix of the digest shown, because nothing else+-- identifies it.+--+-- For example, @exec-plan [skill.name=exec-plan]@ or+-- @nix-haskell-flake (with direnv)@.+applicationLabel :: ApplicationRef -> Text+applicationLabel ref = case ref ^. #target of+  Nothing -> "unrecorded application " <> T.take 12 (ref ^. #applicationId . #unApplicationId)+  Just target ->+    appliedTargetName target+      <> maybe "" (" " <>) (parentVarsText (ref ^. #parentVars))+      <> additional (ref ^. #additionalModules)+  where+    additional [] = ""+    additional modules = " (with " <> T.intercalate ", " (map moduleNameText modules) <> ")"++-- | How @seihou status@ names an applied module instance:+-- @name [key=value, ...]@.+appliedModuleLabel :: AppliedModule -> Text+appliedModuleLabel applied =+  moduleNameText (applied ^. #name)+    <> maybe "" (" " <>) (parentVarsText (applied ^. #parentVars))++-- | The name a user types to select a recorded target.+appliedTargetName :: AppliedTarget -> Text+appliedTargetName (AppliedModuleTarget name) = moduleNameText name+appliedTargetName (AppliedRecipeTarget name) = name ^. #unRecipeName++-- | Parent variables as sorted @[key=value, ...]@, or 'Nothing' when there+-- are none, so callers can style the bracket separately.+parentVarsText :: ParentVars -> Maybe Text+parentVarsText (ParentVars vars)+  | Map.null vars = Nothing+  | otherwise =+      Just+        ( "["+            <> T.intercalate ", " [name ^. #unVarName <> "=" <> value | (name, value) <- Map.toAscList vars]+            <> "]"+        )++moduleNameText :: ModuleName -> Text+moduleNameText name = name ^. #unModuleName

@@ -0,0 +1,166 @@+module Seihou.CLI.CheckoutSync+  ( CheckoutSyncResult (..),+    runCheckoutSync,+    checkoutReportJSON,+    renderCheckoutPlan,+    renderCheckoutStatus,+    checkoutFailureJSON,+  )+where++import Control.Exception (IOException, displayException, try)+import Data.Aeson qualified as A+import Data.ByteString.Lazy qualified as LBS+import Data.Generics.Labels ()+import Data.Map.Strict qualified as Map+import Data.Text qualified as T+import Data.Text.Encoding qualified as TE+import Seihou.Core.Checkout+import Seihou.Core.Types+import Seihou.Effect.Filesystem hiding (CreateDirectoryLink)+import Seihou.Effect.FilesystemInterp (runFilesystem)+import Seihou.Effect.ProcessInterp (runProcessIO)+import Seihou.Engine.Checkout+import Seihou.Manifest.Types (manifestFromJSON)+import Seihou.Prelude++-- | Planning and execution remain separate so dry-run never reports writes.+data CheckoutSyncResult = CheckoutSyncResult+  { root :: !FilePath,+    dryRun :: !Bool,+    plan :: !CheckoutPlan,+    execution :: !CheckoutExecution,+    notices :: ![Text]+  }+  deriving stock (Eq, Show, Generic)++runCheckoutSync :: Bool -> IO (Either CheckoutError CheckoutSyncResult)+runCheckoutSync dryRun = do+  result <- try @IOException $ runEff $ runFilesystem $ runProcessIO $ do+    root <- normalizePath =<< getCurrentDirectory+    gitRoot <- checkoutGitRoot root+    case gitRoot of+      Nothing -> pure (Left (checkoutError "checkout_git_required" "seihou sync requires a Git working tree; run it from the working-tree root"))+      Just gitRoot | gitRoot /= root -> pure (Left (checkoutError "checkout_wrong_root" ("change directory to the Git working-tree root: " <> T.pack gitRoot)))+      _ -> do+        safe <- safeCheckoutManifest root+        case safe of+          Left err -> pure (Left err)+          Right () -> do+            bytes <- readFileText (root </> ".seihou/manifest.json")+            case manifestFromJSON (LBS.fromStrict (TE.encodeUtf8 bytes)) of+              Left err -> pure (Left (checkoutError "checkout_manifest_invalid" (T.pack err <> "; use seihou manifest upgrade for an older manifest, or a newer seihou for a newer schema")))+              Right manifest -> do+                planned <- prepareCheckoutPlan Rebuild SyncIgnoredOnly root manifest manifest []+                case planned of+                  Left err -> pure (Left err)+                  Right plan -> do+                    execution <- if dryRun then pure (CheckoutExecution Map.empty [] Nothing) else applyCheckoutPlan SyncIgnoredOnly root plan+                    let notices = ["No checkout declarations. Apply a declaring module release once before future clones can use seihou sync." | Map.null (manifest ^. #checkoutOutputs)]+                    pure (Right (CheckoutSyncResult root dryRun plan execution notices))+  pure $ case result of+    Left err -> Left (checkoutError "checkout_io_failed" ("cannot inspect checkout: " <> T.pack (displayException err)))+    Right value -> value++checkoutFailureJSON :: Bool -> CheckoutError -> A.Value+checkoutFailureJSON dryRun err = A.object ["mode" A..= mode dryRun, "outputs" A..= ([] :: [A.Value]), "errors" A..= [errorJSON err], "summary" A..= A.object ["planned" A..= counts [], "applied" A..= counts []]]++checkoutReportJSON :: CheckoutSyncResult -> A.Value+checkoutReportJSON result =+  A.object+    [ "mode" A..= mode (result ^. #dryRun),+      "root" A..= (result ^. #root),+      "applicable" A..= checkoutApplicable (result ^. #plan),+      "outputs" A..= map entryJSON entries,+      "errors" A..= map errorJSON (maybe [] pure (result ^. #execution . #failure)),+      "notices" A..= (result ^. #notices),+      "summary"+        A..= A.object+          [ "planned" A..= counts (map (^. #action) entries),+            "applied" A..= counts [entry ^. #action | entry <- entries, Map.lookup (entry ^. #dest) (result ^. #execution . #outcomes) == Just "applied"]+          ]+    ]+  where+    entries = result ^. #plan . #entries+    entryJSON entry =+      A.object+        [ "destination" A..= (entry ^. #dest),+          "kind" A..= ("directory-symlink" :: Text),+          "plannedAction" A..= actionText (entry ^. #action),+          "observation" A..= observationJSON (entry ^. #observation),+          "outcome" A..= Map.findWithDefault "not-applied" (entry ^. #dest) (result ^. #execution . #outcomes),+          "errors" A..= map errorJSON (entry ^. #errors),+          "warnings" A..= (entry ^. #warnings)+        ]++mode :: Bool -> Text+mode True = "dry-run"+mode False = "apply"++counts :: [CheckoutAction] -> A.Value+counts actions = A.object ["created" A..= count CreateLink, "replaced" A..= count ReplaceLink, "retired" A..= count RetireLink, "unchanged" A..= count UnchangedLink, "refused" A..= count RefusedLink]+  where+    count action = length (filter (== action) actions)++errorJSON :: CheckoutError -> A.Value+errorJSON err = A.object ["code" A..= (err ^. #code), "message" A..= (err ^. #message)]++observationJSON :: CheckoutObservation -> A.Value+observationJSON observation =+  A.object+    [ "entry" A..= kind,+      "target" A..= target,+      "sourceDirectory" A..= (observation ^. #sourceDirectory),+      "gitAvailable" A..= (observation ^. #gitAvailable),+      "ignored" A..= (observation ^. #ignored)+    ]+  where+    (kind, target) = case observation ^. #entry of+      EntryMissing -> ("missing" :: Text, Nothing)+      EntryFile -> ("file", Nothing)+      EntryDirectory -> ("directory", Nothing)+      EntrySymlink target -> ("symlink", Just target)++actionText :: CheckoutAction -> Text+actionText CreateLink = "create"+actionText ReplaceLink = "replace-link"+actionText RetireLink = "retire-matching-link"+actionText UnchangedLink = "unchanged"+actionText AlreadyAbsent = "already-absent"+actionText PreserveModified = "preserve-modified"+actionText RefusedLink = "refused"++renderCheckoutPlan :: Bool -> CheckoutPlan -> Text+renderCheckoutPlan dryRun plan =+  T.unlines+    [ (if dryRun && entry ^. #action `elem` [CreateLink, ReplaceLink, RetireLink] then "would-" else "")+        <> actionText (entry ^. #action)+        <> " "+        <> T.pack (entry ^. #dest)+        <> T.concat [": " <> err ^. #message | err <- entry ^. #errors]+        <> T.concat ["; " <> warning | warning <- entry ^. #warnings]+    | entry <- plan ^. #entries+    ]++renderCheckoutStatus :: CheckoutPlan -> Text+renderCheckoutStatus plan =+  let affected = filter ((/= UnchangedLink) . (^. #action)) (plan ^. #entries)+      count = length affected+   in "Checkout outputs: "+        <> T.pack (show (length (plan ^. #entries)))+        <> " declared, "+        <> T.pack (show count)+        <> " need attention.\n"+        <> T.concat ["  " <> T.pack (entry ^. #dest) <> ": " <> reason entry <> "\n" | entry <- take 10 affected]+        <> (if count > 10 then "  … " <> T.pack (show (count - 10)) <> " more affected paths\n" else "")+  where+    reason entry = case entry ^. #errors of+      err : _ -> err ^. #message+      [] -> case entry ^. #action of+        CreateLink -> "missing link; run seihou sync"+        ReplaceLink -> "wrong link target; run seihou sync"+        RetireLink -> "retirement pending"+        AlreadyAbsent -> "already absent"+        PreserveModified -> "modified entry preserved"+        UnchangedLink -> "correct"+        RefusedLink -> "repair refused; inspect this path"

@@ -12,6 +12,13 @@     formatInstallOverride,     summarizeInstallRefusal, +    -- * Recorded install source+    RecordedSource (..),+    resolveRecordedSource,+    recordedSourceUrl,+    formatRecordedSourceNotice,+    expandLocalPath,+     -- * Install primitives     installModuleDir,     installModuleDirInto,@@ -30,7 +37,7 @@ import Data.Text.IO qualified as TIO import Data.Time (getCurrentTime) import Data.Time.Format.ISO8601 (iso8601Show)-import Seihou.Core.ArtifactIdentity (normalizeOriginUrl)+import Seihou.Core.ArtifactIdentity (isMachineLocalOriginUrl, normalizeOriginUrl) import Seihou.Core.ArtifactOriginDetect (OriginInfo (..), readOriginInfo) import Seihou.Prelude import System.Directory@@ -38,6 +45,7 @@     copyFile,     createDirectoryIfMissing,     doesDirectoryExist,+    getHomeDirectory,     getXdgDirectory,     listDirectory,     removeDirectoryRecursive,@@ -213,6 +221,101 @@       ]   NoExistingInstall -> ""   SameSource _ -> ""++-- ----------------------------------------------------------------------------+-- Recorded install source+-- ----------------------------------------------------------------------------++-- | What @seihou install@ records as an installed copy's @sourceUrl@.+--+-- @git clone@ accepts a local checkout, so @seihou install ~\/src\/modules@+-- works. A path recorded verbatim, though, is meaningful only on this+-- machine. It used to reach the checked-in manifest and turn into a false+-- origin mismatch once the artifact was reinstalled from its real remote. So+-- for a local checkout, install records the checkout's @origin@ remote+-- instead. It does that only when the commit being installed is published+-- there, because only then does the remote really hold the installed content.+data RecordedSource+  = -- | Record this URL; the clone reads from the argument as given.+    RecordSource !Text+  | -- | A local checkout whose installed commit is published at this remote.+    RecordPublishedRemote !Text !Text -- remote url, local path+  | -- | A local path with no remote that holds the installed commit.+    RecordLocalPath !Text !Text -- path as given, why no remote+  deriving stock (Eq, Show, Generic)++-- | The URL to write into @.seihou-origin.json@ and to compare against an+-- existing install. A local path stays a path here: the install cache is+-- machine-local by design, and 'Seihou.Core.ArtifactOriginDetect' keeps the+-- path out of the manifest.+recordedSourceUrl :: RecordedSource -> Text+recordedSourceUrl = \case+  RecordSource url -> url+  RecordPublishedRemote remote _ -> remote+  RecordLocalPath path _ -> path++-- | Decide what to record for an install argument. A URL is recorded as+-- given. For a machine-local path, ask git whether the checkout's @origin@+-- remote holds the commit that @git clone@ will copy (the checkout's @HEAD@).+resolveRecordedSource :: Text -> IO RecordedSource+resolveRecordedSource source+  | not (isMachineLocalOriginUrl source) = pure (RecordSource source)+  | otherwise = do+      dir <- expandLocalPath (T.strip source)+      headRes <- git dir ["rev-parse", "--verify", "HEAD"]+      case headRes of+        Nothing -> pure (RecordLocalPath source "not a git repository")+        Just _ -> do+          remoteRes <- git dir ["remote", "get-url", "origin"]+          case T.strip <$> remoteRes of+            Nothing -> pure (RecordLocalPath source "no origin remote")+            Just remote+              | T.null remote -> pure (RecordLocalPath source "no origin remote")+              | isMachineLocalOriginUrl remote ->+                  pure (RecordLocalPath source ("its origin remote " <> remote <> " is itself a local path"))+              | otherwise -> do+                  containing <- git dir ["branch", "-r", "--contains", "HEAD", "--list", "origin/*"]+                  pure $ case filter (not . T.null) . map T.strip . T.lines <$> containing of+                    Just (_ : _) -> RecordPublishedRemote remote source+                    _ -> RecordLocalPath source "HEAD is not on any remote branch; push it first"+  where+    git dir args = do+      (code, out, _err) <- readProcessWithExitCode "git" (["-C", dir] <> args) ""+      pure $ case code of+        ExitSuccess -> Just (T.pack out)+        ExitFailure _ -> Nothing++-- | Turn an install argument that names a local path into something @git -C@+-- accepts: expand a leading @~@ and drop a @file:\/\/@ scheme.+expandLocalPath :: Text -> IO FilePath+expandLocalPath path+  | Just rest <- T.stripPrefix "file://" path = pure (T.unpack rest)+  | Just rest <- T.stripPrefix "file:" path = pure (T.unpack rest)+  | path == "~" = getHomeDirectory+  | Just rest <- T.stripPrefix "~/" path = do+      home <- getHomeDirectory+      pure (home </> T.unpack rest)+  | otherwise = pure (T.unpack path)++-- | The line install prints about what it recorded, if any. A URL argument is+-- recorded as given and needs no comment.+formatRecordedSourceNotice :: RecordedSource -> Maybe Text+formatRecordedSourceNotice = \case+  RecordSource _ -> Nothing+  RecordPublishedRemote remote path ->+    Just $+      "note: recording origin "+        <> remote+        <> " (the 'origin' remote of "+        <> path+        <> ", which contains the installed commit)"+  RecordLocalPath path reason ->+    Just $+      "warning: "+        <> path+        <> " is recorded as a local path ("+        <> reason+        <> "); projects generated from it record its origin as unknown"  -- ---------------------------------------------------------------------------- -- Install primitives

@@ -0,0 +1,11 @@+module Seihou.CLI.KitConfig (seihouKitConfig) where++import Baikai.Interactive (InteractiveProvider (..))+import Baikai.Kit.Config (KitConfig, kitConfig)++seihouKitConfig :: KitConfig+seihouKitConfig =+  kitConfig+    "seihou"+    "https://github.com/shinzui/seihou-kit.git"+    [InteractiveClaude, InteractiveCodex]

@@ -4,6 +4,7 @@   ) where +import Seihou.CLI.ManifestRepairOrigins (RepairOriginsOpts, handleRepairOrigins) import Seihou.CLI.ManifestUpgrade (ManifestUpgradeOpts, handleManifestUpgrade) import Seihou.Prelude @@ -12,8 +13,10 @@ -- another CLI restructuring pass. data ManifestCommand   = ManifestUpgrade ManifestUpgradeOpts+  | ManifestRepairOrigins RepairOriginsOpts   deriving stock (Eq, Show, Generic)  -- | Dispatch the selected @manifest@ subcommand to its handler. handleManifest :: ManifestCommand -> IO () handleManifest (ManifestUpgrade opts) = handleManifestUpgrade opts+handleManifest (ManifestRepairOrigins opts) = handleRepairOrigins opts

@@ -0,0 +1,456 @@+-- | Establish the shared-write mode of manifest paths whose mode is+-- 'SharedWriteUnknown', without touching any project file.+--+-- A path's mode is a conjunction across its owners: it is additive-only+-- exactly when every owner reaches it through an additive, non-overlapping+-- patch ('isAdditiveOperation'), and it requires the ownership closure when+-- any owner writes it otherwise+-- (docs\/adr\/0012-an-additive-co-write-is-not-a-shared-path-conflict.md).+-- A schema-6 manifest usually cannot say which, so this module recompiles+-- the owners' operations and reads the answer off them.+--+-- The work is split in two. 'certifySharedWriteModes' is pure: given the+-- manifest and the operations each owner compiles to, it classifies every+-- path in scope. 'gatherApplicationEvidence' is the IO shell that obtains+-- those operations from what the manifest records — each instance's+-- recorded origin, version, parent variables and resolved values — and+-- refuses any artifact that is not provably the one recorded+-- (docs\/adr\/0003-a-stale-or-substituted-artifact-is-a-hard-error.md).+-- Compilation never reconciles, executes a command, applies a migration, or+-- writes anything; its only product is operations to inspect.+--+-- A path is certified additive-only only when operations for every owner are+-- available and all of them are additive. One owner that writes the path any+-- other way proves a closure requirement by itself. Anything else leaves the+-- path 'SharedWriteUnknown' with a reason, so the caller keeps the ownership+-- closure rather than guessing.+module Seihou.CLI.ManifestCapabilityUpgrade+  ( -- * Scope and evidence+    CertificationScope (..),+    EvidencePolicy (..),+    EvidenceSource (..),+    ApplicationEvidence (..),+    CertificationGap (..),+    SharedWriteCertificationEntry (..),+    SharedWriteCertification (..),++    -- * Classifying+    certifySharedWriteModes,+    pathsInScope,+    certifiedChanges,++    -- * Obtaining evidence+    gatherApplicationEvidence,+    certifySharedWriteModesIO,++    -- * Rendering+    renderCertificationGap,+    renderEvidenceSource,+  )+where++import Data.Containers.ListUtils (nubOrd)+import Data.Generics.Labels ()+import Data.List (find)+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.ManifestGuard (ArtifactVerdict (..), judgeArtifact, machineLocalOriginNote)+import Seihou.CLI.RecordedRelease (RecordedRelease (..), locateRecordedRelease, renderRecordedReleaseError)+import Seihou.Composition.Instance (ModuleInstance (..))+import Seihou.Composition.Plan (compileComposedPlan)+import Seihou.Composition.Resolve (PromptPermission (..), resolveWithPromptPermission)+import Seihou.Core.ArtifactIdentity (isMachineLocalOriginUrl)+import Seihou.Core.ArtifactOriginDetect (detectArtifactOrigin)+import Seihou.Core.ArtifactRef (resolveArtifactOrigin)+import Seihou.Core.Types+import Seihou.Dhall.Eval (evalModuleFromFile)+import Seihou.Effect.ConsoleInterp (runConsole)+import Seihou.Prelude+import System.Directory (doesPathExist)++-- | Which unknown paths to certify.+data CertificationScope+  = -- | Every path whose mode is unknown. Used by the explicit+    -- @seihou manifest upgrade@.+    CertifyAllUnknownPaths+  | -- | Only unknown paths that one of these applications shares with an+    -- application outside the set: the paths whose mode decides whether a+    -- targeted update of these applications may leave a co-owner out.+    CertifyPathsForApplications !(Set ApplicationId)+  deriving stock (Eq, Show, Generic)++-- | Where a co-owner's recorded release may be read from.+data EvidencePolicy+  = -- | Only copies installed on this machine.+    InstalledReleasesOnly+  | -- | Installed copies first; otherwise the exact recorded release, fetched+    --   from the recorded remote into this session directory. The fetched+    --   copy never enters the install cache+    --   (docs\/adr\/0012-an-additive-co-write-is-not-a-shared-path-conflict.md).+    FetchRecordedReleases !FilePath+  deriving stock (Eq, Show, Generic)++-- | A module instance whose evidence was read from a fetched recorded+-- release rather than an installed copy.+data EvidenceSource = EvidenceSource+  { moduleName :: !ModuleName,+    version :: !Text,+    originUrl :: !Text,+    -- | The short id of the commit the release was read at.+    revision :: !Text+  }+  deriving stock (Eq, Ord, Show, Generic)++-- | What is known about one application's contribution.+data ApplicationEvidence+  = -- | Every operation the application compiles to, in plan order, and the+    --   instances that were compiled from a fetched release (empty when all+    --   of them were installed).+    EvidenceOperations ![Operation] ![EvidenceSource]+  | -- | The application could not be compiled from its recorded state.+    EvidenceUnavailable !Text+  deriving stock (Eq, Show, Generic)++-- | Why a path in scope stayed unknown.+data CertificationGap+  = -- | The owner is not among the manifest's recorded applications.+    OwnerNotRecorded !ApplicationId+  | -- | The owner is recorded but its operations could not be obtained.+    OwnerEvidenceUnavailable !ApplicationId !Text+  | -- | The owner's operations no longer write this path, so what they say+    -- is not evidence about how the path was written.+    OwnerEmitsNoOperation !ApplicationId+  deriving stock (Eq, Show, Generic)++-- | The outcome for one path in scope.+data SharedWriteCertificationEntry = SharedWriteCertificationEntry+  { path :: !FilePath,+    owners :: !(Set ApplicationId),+    previousMode :: !SharedWriteMode,+    certifiedMode :: !SharedWriteMode,+    -- | Empty exactly when 'certifiedMode' is known.+    gaps :: ![CertificationGap]+  }+  deriving stock (Eq, Show, Generic)++-- | The manifest with every certified mode applied, and one entry per path+-- in scope. The manifest's version is not changed; the caller decides what+-- schema to publish it as.+data SharedWriteCertification = SharedWriteCertification+  { manifest :: !Manifest,+    entries :: ![SharedWriteCertificationEntry],+    -- | Every fetched release the evidence was compiled from.+    fetchedSources :: ![EvidenceSource]+  }+  deriving stock (Eq, Show, Generic)++-- | The unknown paths a scope covers, with their records, in path order.+pathsInScope :: CertificationScope -> Manifest -> [(FilePath, FileRecord)]+pathsInScope scope manifest =+  [ (path, record)+  | (path, record) <- Map.toAscList (manifest ^. #files),+    record ^. #sharedWriteMode == SharedWriteUnknown,+    -- A path nobody owns is outside every ownership check, so its mode+    -- decides nothing.+    not (Set.null (record ^. #applicationIds)),+    inScope (record ^. #applicationIds)+  ]+  where+    inScope owners = case scope of+      CertifyAllUnknownPaths -> True+      CertifyPathsForApplications selected ->+        not (Set.null (Set.intersection selected owners))+          && not (owners `Set.isSubsetOf` selected)++-- | Classify every path in scope from the owners' operations.+--+-- Pure, so the whole decision can be tested with small fixtures. Only+-- 'SharedWriteUnknown' records are ever changed, so a known answer —+-- in particular a closure requirement — is never overwritten here.+certifySharedWriteModes ::+  CertificationScope ->+  Manifest ->+  Map ApplicationId ApplicationEvidence ->+  SharedWriteCertification+certifySharedWriteModes scope manifest evidence =+  SharedWriteCertification+    { manifest = manifest & #files %~ \files -> foldl' applyEntry files entries,+      entries = entries,+      fetchedSources = nubOrd (concat [sources | EvidenceOperations _ sources <- Map.elems evidence])+    }+  where+    recorded = Set.fromList (map (^. #applicationId) (manifest ^. #applications))+    entries = map (uncurry classify) (pathsInScope scope manifest)++    applyEntry files entry+      | entry ^. #certifiedMode == SharedWriteUnknown = files+      | otherwise = Map.adjust (& #sharedWriteMode .~ (entry ^. #certifiedMode)) (entry ^. #path) files++    classify path record =+      let owners = record ^. #applicationIds+          perOwner = map (ownerContribution path) (Set.toAscList owners)+          missing = [gap | Left gap <- perOwner]+          -- One owner that writes the path other than additively settles the+          -- conjunction on its own, whatever the missing owners do.+          anyWholeFile = or [not (all isAdditiveOperation operations) | Right operations <- perOwner]+          (mode, gaps)+            | anyWholeFile = (SharedWriteRequiresOwnershipClosure, [])+            | not (null missing) = (SharedWriteUnknown, missing)+            | otherwise = (SharedWriteAdditiveOnly, [])+       in SharedWriteCertificationEntry+            { path = path,+              owners = owners,+              previousMode = record ^. #sharedWriteMode,+              certifiedMode = mode,+              gaps = gaps+            }++    ownerContribution path owner+      | Set.notMember owner recorded = Left (OwnerNotRecorded owner)+      | otherwise = case Map.lookup owner evidence of+          Nothing -> Left (OwnerEvidenceUnavailable owner "its operations were not compiled")+          Just (EvidenceUnavailable reason) -> Left (OwnerEvidenceUnavailable owner reason)+          Just (EvidenceOperations operations _) ->+            case filter ((== Just path) . operationDestination) operations of+              [] -> Left (OwnerEmitsNoOperation owner)+              writes -> Right writes++-- | The entries whose mode actually changed.+certifiedChanges :: SharedWriteCertification -> [SharedWriteCertificationEntry]+certifiedChanges certification =+  [ entry+  | entry <- certification ^. #entries,+    entry ^. #certifiedMode /= entry ^. #previousMode+  ]++operationDestination :: Operation -> Maybe FilePath+operationDestination (WriteFileOp path _ _) = Just path+operationDestination (CopyFileOp _ path) = Just path+operationDestination (PatchFileOp path _ _ _ _) = Just path+operationDestination CheckoutOutputOp {} = Nothing+operationDestination CreateDirOp {} = Nothing+operationDestination RunCommandOp {} = Nothing++-- | Compile the named recorded applications from exactly what the manifest+-- records about them.+--+-- For each instance the recorded origin is resolved through @searchPaths@,+-- and the copy found must have the same identity and the /same/ declared+-- version as recorded: a newer local copy would describe how the module+-- writes today, not how it wrote the project, so it is refused rather than+-- used. Under 'FetchRecordedReleases', an instance with no such installed+-- copy is read instead from the commit of its recorded remote that declares+-- the recorded version ("Seihou.CLI.RecordedRelease"); no other version is+-- ever substituted. The instances are compiled in their recorded order with+-- their recorded parent variables and resolved values; nothing is prompted+-- for and no configuration or environment value is consulted.+gatherApplicationEvidence ::+  EvidencePolicy ->+  FilePath ->+  [FilePath] ->+  Manifest ->+  Set ApplicationId ->+  IO (Map ApplicationId ApplicationEvidence)+gatherApplicationEvidence policy projectRoot searchPaths manifest wanted =+  Map.fromList+    <$> traverse+      (\application -> (application ^. #applicationId,) <$> compileRecorded application)+      [ application+      | application <- manifest ^. #applications,+        Set.member (application ^. #applicationId) wanted+      ]+  where+    compileRecorded application = do+      loaded <- traverse loadInstance (application ^. #instances)+      case sequence loaded of+        Left reason -> pure (EvidenceUnavailable reason)+        Right loadedInOrder+          | null loadedInOrder -> pure (EvidenceUnavailable "it records no module instances")+          | otherwise -> do+              let modulesInOrder = map fst loadedInOrder+                  sources = [source | (_, Just source) <- loadedInOrder]+                  saved =+                    Map.fromList+                      [ (instanceId, state ^. #resolvedVars)+                      | ((instanceId, _, _), state) <- zip modulesInOrder (application ^. #instances)+                      ]+              resolved <-+                runEff $+                  runConsole $+                    resolveWithPromptPermission+                      PromptsForbidden+                      modulesInOrder+                      saved+                      Map.empty+                      Map.empty+                      (fromMaybeText (application ^. #namespace))+                      (fromMaybeText (application ^. #context))+                      Map.empty+                      Map.empty+                      Map.empty+                      Map.empty+              case resolved of+                Left errors ->+                  pure (EvidenceUnavailable ("its recorded values no longer resolve: " <> T.pack (show errors)))+                Right values -> do+                  compiled <-+                    compileComposedPlan+                      [ (instanceId, modul, directory, Map.map (^. #value) (Map.findWithDefault Map.empty instanceId values))+                      | (instanceId, modul, directory) <- modulesInOrder+                      ]+                  pure $ case compiled of+                    Left errors -> EvidenceUnavailable ("it no longer compiles: " <> T.intercalate "; " errors)+                    Right (operations, _, _) -> EvidenceOperations operations sources++    loadInstance state = do+      installed <- loadInstalled state+      case installed of+        Right loaded -> pure (Right (loaded, Nothing))+        Left (reason, noted) -> do+          fetched <- case policy of+            InstalledReleasesOnly -> pure (Left Nothing)+            FetchRecordedReleases session -> first Just <$> loadFetched session state+          let recordedOrigin = state ^. #origin+              attachNote text+                | noted = withLocalOriginNote recordedOrigin text+                | otherwise = text+          pure $ case fetched of+            Right loaded -> Right loaded+            Left Nothing -> Left (attachNote reason)+            Left (Just fetchReason) -> Left (attachNote (reason <> "; " <> fetchReason))++    -- The installed copy, or why it cannot be used and whether the+    -- machine-local origin note explains that.+    loadInstalled state = do+      let name = state ^. #name+          recordedOrigin = state ^. #origin+          recordedVersion = state ^. #moduleVersion+      located <- resolveArtifactOrigin projectRoot searchPaths "module.dhall" recordedOrigin+      case located of+        Left _ ->+          pure+            ( Left+                ( "module "+                    <> name ^. #unModuleName+                    <> maybe "" (" " <>) recordedVersion+                    <> " is not installed here",+                  True+                )+            )+        Right directory -> do+          localOrigin <- detectArtifactOrigin projectRoot directory+          evaluated <- evalModuleFromFile (directory </> "module.dhall")+          pure $ case evaluated of+            Left _ -> Left ("module " <> name ^. #unModuleName <> " installed here does not evaluate", False)+            Right modul -> case judgeArtifact recordedOrigin recordedVersion localOrigin (modul ^. #version) of+              ArtifactOriginMismatch _ _ ->+                Left ("module " <> name ^. #unModuleName <> " is installed here from a different origin than recorded", True)+              _+                | modul ^. #version /= recordedVersion ->+                    Left+                      ( "module "+                          <> name ^. #unModuleName+                          <> " is "+                          <> describeVersion (modul ^. #version)+                          <> " here but the manifest records "+                          <> describeVersion recordedVersion,+                        False+                      )+                | otherwise -> Right (ModuleInstance name (state ^. #parentVars), modul, directory)++    -- The exact recorded release from the recorded remote, or why not.+    loadFetched session state = do+      let name = state ^. #name+      case (state ^. #origin, state ^. #moduleVersion) of+        (RemoteOrigin url _ _, Just recordedVersion) -> do+          unreachable <- isUnreachablePath url+          if unreachable+            then pure (Left ("its recorded origin " <> url <> " is a path on another machine"))+            else do+              located <- locateRecordedRelease session url (name ^. #unModuleName) "module.dhall" recordedVersion+              case located of+                Left err -> pure (Left (renderRecordedReleaseError err))+                Right release -> do+                  let directory = release ^. #directory+                  evaluated <- evalModuleFromFile (directory </> "module.dhall")+                  pure $ case evaluated of+                    Right modul+                      | modul ^. #version == Just recordedVersion ->+                          Right+                            ( (ModuleInstance name (state ^. #parentVars), modul, directory),+                              Just+                                EvidenceSource+                                  { moduleName = name,+                                    version = recordedVersion,+                                    originUrl = url,+                                    revision = release ^. #revision+                                  }+                            )+                    _ -> Left ("the release of " <> name ^. #unModuleName <> " fetched from " <> url <> " does not evaluate to the recorded version")+        (RemoteOrigin {}, Nothing) -> pure (Left "it records no version to fetch")+        _ -> pure (Left "its recorded origin names no remote to fetch from")++    -- A recorded path that does not exist here cannot be cloned; one that+    -- does exist is cloned like any other remote.+    isUnreachablePath url+      | isMachineLocalOriginUrl url = not <$> doesPathExist (T.unpack (fromMaybe url (T.stripPrefix "file://" url)))+      | otherwise = pure False++    fromMaybeText = fromMaybe ""+    describeVersion = maybe "unversioned" ("version " <>)++    -- A path recorded as the origin is why the installed copy cannot be+    -- matched, and installing the recorded version will not fix that.+    withLocalOriginNote recordedOrigin reason = case machineLocalOriginNote recordedOrigin of+      Just note -> reason <> ". " <> note+      Nothing -> reason++-- | Certify a scope, compiling every owner the scope needs except those the+-- caller already supplies operations for. A targeted update supplies the+-- candidate operations of the applications it is about to apply, because+-- that is the contribution the update will actually write.+certifySharedWriteModesIO ::+  EvidencePolicy ->+  FilePath ->+  [FilePath] ->+  CertificationScope ->+  Manifest ->+  Map ApplicationId [Operation] ->+  IO SharedWriteCertification+certifySharedWriteModesIO policy projectRoot searchPaths scope manifest supplied = do+  let needed =+        Set.unions [record ^. #applicationIds | (_, record) <- pathsInScope scope manifest]+          Set.\\ Map.keysSet supplied+  gathered <- gatherApplicationEvidence policy projectRoot searchPaths manifest needed+  let evidence = Map.union (Map.map (`EvidenceOperations` []) supplied) gathered+  pure (certifySharedWriteModes scope manifest evidence)++-- | One line explaining a gap, naming the application by its target.+renderCertificationGap :: Manifest -> CertificationGap -> Text+renderCertificationGap manifest gap = case gap of+  OwnerNotRecorded owner -> label owner <> " owns the path but is not a recorded application"+  OwnerEvidenceUnavailable owner reason -> label owner <> ": " <> reason+  OwnerEmitsNoOperation owner -> label owner <> " no longer writes this path"+  where+    label owner =+      maybe+        (owner ^. #unApplicationId)+        targetLabel+        (find ((== owner) . (^. #applicationId)) (manifest ^. #applications))+    targetLabel application = case application ^. #target of+      AppliedModuleTarget name -> name ^. #unModuleName+      AppliedRecipeTarget name -> name ^. #unRecipeName++-- | How a fetched release is named in a report, for example+-- @nix-haskell-flake 0.13.2 read from https:\/\/github.com\/o\/r.git at 08191d3@.+renderEvidenceSource :: EvidenceSource -> Text+renderEvidenceSource source =+  source ^. #moduleName . #unModuleName+    <> " "+    <> source ^. #version+    <> " read from "+    <> source ^. #originUrl+    <> " at "+    <> source ^. #revision

@@ -27,6 +27,7 @@     checkAppliedBlueprint,     checkRecordedBlueprint,     blockingChecks,+    localModuleVersion,      -- * Enforcing     enforceArtifactGuard,@@ -35,6 +36,7 @@     formatGuardRefusal,     formatGuardOverride,     summarizeCheck,+    machineLocalOriginNote,   ) where @@ -45,7 +47,7 @@ import Data.Set qualified as Set import Data.Text qualified as T import Data.Text.IO qualified as TIO-import Seihou.Core.ArtifactIdentity (normalizeOriginUrl, normalizeProjectPath)+import Seihou.Core.ArtifactIdentity (isMachineLocalOriginUrl, normalizeOriginUrl, normalizeProjectPath) import Seihou.Core.ArtifactOriginDetect (detectArtifactOrigin) import Seihou.Core.ArtifactRef   ( ArtifactRefError,@@ -431,7 +433,21 @@ -- carries its own status symbol, because a refusal and a deliberate override -- print the same body but are not the same news. refusalBlock :: Text -> ArtifactCheck -> Text-refusalBlock leadIn check = case check ^. #verdict of+refusalBlock leadIn check = withLocalOriginNote (verdictBlock leadIn check)+  where+    -- A recorded path explains most verdicts better than the verdict does:+    -- the path is why nothing here matches it, and no install can fix it.+    withLocalOriginNote block+      | T.null block = block+      | otherwise = case machineLocalOriginNote (check ^. #origin) of+          Just note -> block <> "\n\n" <> wrapNote note+          Nothing -> block+    wrapNote note = case T.breakOn "; " note of+      (before, after) | not (T.null after) -> "  " <> before <> ";\n  " <> T.drop 2 after+      _ -> "  " <> note++verdictBlock :: Text -> ArtifactCheck -> Text+verdictBlock leadIn check = case check ^. #verdict of   ArtifactStale recordedVersion localVersion ->     T.intercalate "\n" $       [ leadIn <> ": your local copy of '" <> label <> "' is older than the",@@ -456,10 +472,13 @@         "  These are different artifacts that happen to share a name."       ]         <> case recorded of-          RemoteOrigin url _ _ ->-            [ "  Install the one this project records:",-              "    seihou install " <> url-            ]+          RemoteOrigin url _ _+            -- Installing a path from another machine is no remedy; the+            -- note 'refusalBlock' appends names the one that is.+            | not (isMachineLocalOriginUrl url) ->+                [ "  Install the one this project records:",+                  "    seihou install " <> url+                ]           _ -> []   ArtifactUnresolvable refErr ->     leadIn <> ".\n\n" <> renderArtifactRefError refErr@@ -491,7 +510,13 @@ -- like @seihou status@ that must never fail on a verdict. 'Nothing' means -- there is nothing to say. summarizeCheck :: ArtifactCheck -> Maybe Text-summarizeCheck check = case check ^. #verdict of+summarizeCheck check = withLocalOriginNote <$> summarizeVerdict check+  where+    withLocalOriginNote summary =+      maybe summary (\note -> summary <> ". " <> note) (machineLocalOriginNote (check ^. #origin))++summarizeVerdict :: ArtifactCheck -> Maybe Text+summarizeVerdict check = case check ^. #verdict of   ArtifactOk -> Nothing   ArtifactStale recordedVersion localVersion ->     Just $@@ -519,6 +544,25 @@     Just (label <> ": no recorded provenance, so its identity cannot be verified")   where     label = check ^. #name . #unModuleName++-- | The sentence every message about an artifact appends when the manifest+-- records its origin as a path on the machine that wrote it.+--+-- Such a path cannot match anything installed from a real remote, and no+-- install can make it match, so the ordinary remedies a verdict names do not+-- apply. The explicit repair command does: see+-- "Seihou.CLI.ManifestRepairOrigins". 'Nothing' for every other origin, whose+-- messages stay exactly as they were.+machineLocalOriginNote :: ArtifactOrigin -> Maybe Text+machineLocalOriginNote = \case+  RemoteOrigin url _ _+    | isMachineLocalOriginUrl url ->+        Just+          ( "The manifest records "+              <> url+              <> ", a path on the machine that wrote it; run 'seihou manifest repair-origins'."+          )+  _ -> Nothing  -- | How to name an origin in a comparison line. originDescription :: ArtifactOrigin -> Text

@@ -0,0 +1,627 @@+-- | @seihou manifest repair-origins@: rewrite origins recorded as a path on+-- the machine that wrote them.+--+-- @.seihou\/manifest.json@ is checked in and must mean the same thing on every+-- machine (docs\/adr\/0001-manifest-is-a-checked-in-machine-independent-artifact.md).+-- Before plan 98, @seihou install \<local checkout\>@ stored the checkout's+-- path as the installed copy's @sourceUrl@, and every command that records+-- applied state copied it into the manifest as a 'RemoteOrigin'. Once the+-- artifact was reinstalled from its real remote, the guard reported an+-- origin mismatch that no command could clear. 'detectArtifactOrigin' no+-- longer lets a path through, but manifests written before that still hold+-- one. This command finds them, proposes a remote for each with the evidence+-- for it, and rewrites them.+--+-- Choosing a remote for a recorded path is inference, so the command is+-- explicit and prints everything it concludes, as+-- docs\/adr\/0005-legacy-manifests-convert-through-an-explicit-command.md+-- requires. It rewrites by URL rather than by record: every origin recorded+-- under one path gets the same new URL, because blueprint migration receipts+-- use the origin as part of their identity (docs\/adr\/0002) and rewriting+-- some records for a path but not others would split one artifact in two.+--+-- The core ('localOriginUrls', 'planRepair', 'applyRepair',+-- 'renderRepairOutcome') is pure. 'gatherOriginEvidence' and+-- 'runRepairOrigins' are the IO shell.+module Seihou.CLI.ManifestRepairOrigins+  ( -- * Options and outcome+    RepairOriginsOpts (..),+    RepairOutcome (..),++    -- * Sites, evidence, decisions+    SiteKind (..),+    OriginSite (..),+    OriginEvidence (..),+    RepairDecision (..),+    evidenceUrl,++    -- * Pure core+    localOriginUrls,+    validateOverrides,+    planRepair,+    applyRepair,+    overManifestOrigins,+    sameRepository,++    -- * IO shell+    gatherOriginEvidence,+    runRepairOrigins,+    renderRepairOutcome,+    handleRepairOrigins,+  )+where++import Control.Applicative ((<|>))+import Control.Monad (when)+import Data.Aeson qualified as Aeson+import Data.Aeson.Types (parseMaybe, (.:))+import Data.ByteString.Lazy qualified as LBS+import Data.Char (isDigit, toLower)+import Data.Generics.Labels ()+import Data.List (nub, nubBy)+import Data.Map.Strict qualified as Map+import Data.Maybe (mapMaybe)+import Data.Text qualified as T+import Data.Text.IO qualified as TIO+import Seihou.CLI.ApplicationDisplay (appliedModuleLabel, appliedTargetName, moduleNameText)+import Seihou.CLI.InstallShared (expandLocalPath)+import Seihou.Core.ArtifactIdentity (isMachineLocalOriginUrl, normalizeOriginUrl)+import Seihou.Core.ArtifactOriginDetect (readOriginInfo)+import Seihou.Core.ArtifactRef (resolveArtifactOrigin)+import Seihou.Core.Module (defaultSearchPaths)+import Seihou.Core.Types+  ( AppliedTarget (..),+    ArtifactOrigin (..),+    Manifest,+    ManifestSchemaVersion (..),+  )+import Seihou.Manifest.Types (currentManifestVersion, manifestFromJSON, manifestToJSON)+import Seihou.Prelude+import System.Directory (doesDirectoryExist, doesFileExist, getCurrentDirectory, renamePath)+import System.Exit (ExitCode (..), exitFailure)+import System.Process (readProcessWithExitCode)++-- ----------------------------------------------------------------------------+-- Types+-- ----------------------------------------------------------------------------++-- | Flags parsed for @seihou manifest repair-origins@.+data RepairOriginsOpts = RepairOriginsOpts+  { -- | Print the report without writing the manifest.+    dryRun :: !Bool,+    -- | @--set NAME=URL@, in order: the remote for the path under which the+    -- artifact @NAME@ is recorded.+    overrides :: ![(Text, Text)]+  }+  deriving stock (Eq, Show, Generic)++-- | Which of the six origin-bearing manifest records a site is.+data SiteKind+  = SiteModule+  | SiteApplicationTarget+  | SiteApplicationInstance+  | SiteRecipe+  | SiteBlueprint+  | SiteBlueprintMigration+  deriving stock (Eq, Ord, Show, Generic)++-- | One manifest record whose origin is a machine-local path.+data OriginSite = OriginSite+  { kind :: !SiteKind,+    -- | Where the record is, for the report, e.g. @modules[nix-haskell-flake]@.+    location :: !Text,+    -- | The URL exactly as recorded, before normalisation.+    recordedUrl :: !Text,+    artifactName :: !Text,+    repoName :: !(Maybe Text),+    -- | The file that makes a directory count as this kind of artifact, used+    -- to find its installed copy.+    definitionFile :: !FilePath+  }+  deriving stock (Eq, Show, Generic)++-- | Why a remote is proposed for a recorded path.+data OriginEvidence+  = -- | The recorded path is a checkout on this machine whose @origin@ remote+    -- is this URL.+    FromCheckoutRemote !Text+  | -- | The installed copy of this artifact records this URL, and its+    -- repository name agrees with the manifest's. Fields: artifact name,+    -- URL, repository name.+    FromInstalledCopy !Text !Text !(Maybe Text)+  | -- | The user passed @--set NAME=URL@. Fields: artifact name, URL.+    FromOverride !Text !Text+  deriving stock (Eq, Show, Generic)++-- | What to do about one recorded path.+data RepairDecision+  = -- | Rewrite every origin recorded under the path. Fields: the path as+    -- recorded, the new URL, the evidence, the records affected.+    Rewrite !Text !Text ![OriginEvidence] ![OriginSite]+  | -- | The evidence names more than one repository; nothing is written for+    -- this path.+    Conflicting !Text ![OriginEvidence] ![OriginSite]+  | -- | Nothing on this machine suggests a remote.+    Unresolved !Text ![OriginSite]+  deriving stock (Eq, Show, Generic)++-- | Terminal outcome of a run, decoupled from printing and exit codes so it+-- can be asserted on directly.+data RepairOutcome+  = -- | No origin is recorded as a machine-local path.+    RepairNotNeeded+  | -- | @--dry-run@: the decisions a real run would carry out.+    RepairWouldWrite ![RepairDecision]+  | -- | The manifest was rewritten according to these decisions.+    RepairWritten ![RepairDecision]+  | -- | Not a dry run, but no path had a remote to rewrite to, so the manifest+    -- was left alone.+    RepairUnwritten ![RepairDecision]+  | -- | Nothing was written; carries the message to show the user.+    RepairFailed !Text+  deriving stock (Eq, Show, Generic)++-- | The URL a piece of evidence proposes.+evidenceUrl :: OriginEvidence -> Text+evidenceUrl = \case+  FromCheckoutRemote url -> url+  FromInstalledCopy _ url _ -> url+  FromOverride _ url -> url++-- ----------------------------------------------------------------------------+-- Pure core+-- ----------------------------------------------------------------------------++-- | Every record whose origin is a 'RemoteOrigin' with a machine-local URL,+-- grouped by the normalised URL, in manifest order within each group.+localOriginUrls :: Manifest -> Map Text [OriginSite]+localOriginUrls manifest =+  Map.fromListWith+    (\later earlier -> earlier <> later)+    [ (normalizeOriginUrl (site ^. #recordedUrl), [site])+    | site <- allSites,+      isMachineLocalOriginUrl (site ^. #recordedUrl)+    ]+  where+    allSites =+      mapMaybe moduleSite (manifest ^. #modules)+        <> concatMap applicationSites (manifest ^. #applications)+        <> maybe [] (maybe [] pure . recipeSite) (manifest ^. #recipe)+        <> maybe [] (maybe [] pure . blueprintSite) (manifest ^. #blueprint)+        <> mapMaybe migrationSite (manifest ^. #blueprintMigrations)++    moduleSite applied =+      site SiteModule ("modules[" <> appliedModuleLabel applied <> "]") "module.dhall" (applied ^. #origin)++    applicationSites application =+      let targetName = appliedTargetName (application ^. #target)+          targetDefinition = case application ^. #target of+            AppliedModuleTarget _ -> "module.dhall"+            AppliedRecipeTarget _ -> "recipe.dhall"+          instanceSite state =+            site+              SiteApplicationInstance+              ( "applications["+                  <> targetName+                  <> "].instances["+                  <> moduleNameText (state ^. #name)+                  <> "]"+              )+              "module.dhall"+              (state ^. #origin)+       in maybe [] pure (site SiteApplicationTarget ("applications[" <> targetName <> "]") targetDefinition (application ^. #targetOrigin))+            <> mapMaybe instanceSite (application ^. #instances)++    recipeSite applied =+      site SiteRecipe ("recipe[" <> applied ^. #name . #unRecipeName <> "]") "recipe.dhall" (applied ^. #origin)++    blueprintSite applied =+      site SiteBlueprint ("blueprint[" <> moduleNameText (applied ^. #name) <> "]") "blueprint.dhall" (applied ^. #origin)++    migrationSite receipt =+      site+        SiteBlueprintMigration+        ( "blueprintMigrations["+            <> moduleNameText (receipt ^. #name)+            <> " "+            <> receipt ^. #fromVersion+            <> "->"+            <> receipt ^. #toVersion+            <> "]"+        )+        "blueprint.dhall"+        (receipt ^. #origin)++    site siteKind loc definition = \case+      RemoteOrigin url name repo ->+        Just+          OriginSite+            { kind = siteKind,+              location = loc,+              recordedUrl = url,+              artifactName = name,+              repoName = repo,+              definitionFile = definition+            }+      _ -> Nothing++-- | Check @--set@ overrides before anything is planned. A URL that is itself+-- a machine-local path would reproduce the problem being repaired, and a name+-- recorded under no local path is almost certainly a typo.+validateOverrides :: Map Text [OriginSite] -> [(Text, Text)] -> Either Text ()+validateOverrides sites overrides =+  case (localOverrides, unknownNames) of+    ((name, url) : _, _) ->+      Left+        ( "--set "+            <> name+            <> "="+            <> url+            <> ": "+            <> url+            <> " is a path on this machine, which is what this command removes.\n"+            <> "Give the URL other developers clone the artifact from."+        )+    ([], name : _) ->+      Left+        ( "--set "+            <> name+            <> "=...: no origin recorded as a machine-local path names "+            <> name+            <> ".\nRecorded under local paths: "+            <> T.intercalate ", " (nub [s ^. #artifactName | s <- concat (Map.elems sites)])+        )+    ([], []) -> Right ()+  where+    localOverrides = filter (isMachineLocalOriginUrl . snd) overrides+    recordedNames = [s ^. #artifactName | s <- concat (Map.elems sites)]+    unknownNames = [name | (name, _) <- overrides, name `notElem` recordedNames]++-- | Decide, for each recorded path, what to rewrite it to.+--+-- An override for any artifact recorded under the path wins over evidence.+-- Otherwise the evidence must agree on one repository ('sameRepository', so+-- an @ssh@ checkout remote and an @https@ install of the same repository+-- agree). The URL written is the installed copy's spelling when there is one,+-- because that is what the guard compares the manifest against on this+-- machine; otherwise the checkout remote's.+planRepair :: Map Text [OriginSite] -> Map Text [OriginEvidence] -> [(Text, Text)] -> [RepairDecision]+planRepair sites evidence overrides =+  [ decide key siteList+  | (key, siteList) <- Map.toList sites,+    not (null siteList)+  ]+  where+    decide key siteList =+      let old = recordedAs siteList+          names = map (^. #artifactName) siteList+          overriding = [FromOverride name url | (name, url) <- overrides, name `elem` names]+          gathered = Map.findWithDefault [] key evidence+       in case overriding of+            (chosen : _)+              | agrees overriding -> Rewrite old (evidenceUrl chosen) (overriding <> gathered) siteList+              | otherwise -> Conflicting old overriding siteList+            []+              | null gathered -> Unresolved old siteList+              | agrees gathered -> Rewrite old (preferredUrl gathered) gathered siteList+              | otherwise -> Conflicting old gathered siteList++    recordedAs siteList = case siteList of+      (first' : _) -> first' ^. #recordedUrl+      [] -> ""++    agrees items = case map evidenceUrl items of+      [] -> True+      (url : rest) -> all (sameRepository url) rest++    preferredUrl items =+      case [url | FromInstalledCopy _ url _ <- items] <> map evidenceUrl items of+        (url : _) -> url+        [] -> ""++-- | Rewrite every origin whose normalised URL is the old path of a+-- 'Rewrite'. The artifact name is kept; a missing repository name is filled+-- in from an installed copy that supplied the new URL.+applyRepair :: [RepairDecision] -> Manifest -> Manifest+applyRepair decisions = overManifestOrigins rewrite+  where+    table =+      Map.fromList+        [ (normalizeOriginUrl old, (new, repoFrom new evidence))+        | Rewrite old new evidence _ <- decisions+        ]++    repoFrom new evidence =+      case [repo | FromInstalledCopy _ url (Just repo) <- evidence, sameRepository url new] of+        (repo : _) -> Just repo+        [] -> Nothing++    rewrite origin = case origin of+      RemoteOrigin url name repo+        | isMachineLocalOriginUrl url,+          Just (new, evidenceRepo) <- Map.lookup (normalizeOriginUrl url) table ->+            RemoteOrigin new name (repo <|> evidenceRepo)+      _ -> origin++-- | Apply a function to every origin the manifest records, across all six+-- origin-bearing record kinds.+overManifestOrigins :: (ArtifactOrigin -> ArtifactOrigin) -> Manifest -> Manifest+overManifestOrigins f manifest =+  manifest+    & #modules+    . traverse+    . #origin+    %~ f+    & #applications+    . traverse+    . #targetOrigin+    %~ f+    & #applications+    . traverse+    . #instances+    . traverse+    . #origin+    %~ f+    & #recipe+    . _Just+    . #origin+    %~ f+    & #blueprint+    . _Just+    . #origin+    %~ f+    & #blueprintMigrations+    . traverse+    . #origin+    %~ f++-- | Whether two git URLs name the same repository regardless of transport:+-- @git\@github.com:o\/r.git@, @ssh:\/\/git\@github.com\/o\/r@ and+-- @https:\/\/github.com\/o\/r.git@ all agree.+sameRepository :: Text -> Text -> Bool+sameRepository left right = repositoryKey left == repositoryKey right++repositoryKey :: Text -> Text+repositoryKey raw =+  let url = normalizeOriginUrl raw+      (schemeless, hadScheme) = case T.breakOn "://" url of+        (_, rest) | not (T.null rest) -> (T.drop 3 rest, True)+        _ -> (url, False)+      withoutUser = case T.breakOn "@" schemeless of+        (_, rest)+          | not (T.null rest),+            not (T.isInfixOf "/" (T.takeWhile (/= '@') schemeless)) ->+              T.drop 1 rest+        _ -> schemeless+      (host, path) =+        if hadScheme+          then T.breakOn "/" withoutUser+          else case T.breakOn ":" withoutUser of+            (h, rest)+              | not (T.null rest),+                not (T.isInfixOf "/" h) ->+                  (h, "/" <> T.drop 1 rest)+            _ -> T.breakOn "/" withoutUser+      hostWithoutPort = case T.breakOn ":" host of+        (h, port) | not (T.null port), T.all isDigit (T.drop 1 port) -> h+        _ -> host+   in T.map toLower hostWithoutPort <> "/" <> T.dropWhile (== '/') path++-- ----------------------------------------------------------------------------+-- IO shell+-- ----------------------------------------------------------------------------++-- | For each recorded path, what this machine can observe about its remote:+-- the path's own @origin@ remote if the checkout still exists here, and the+-- remote recorded by the installed copy of each artifact recorded under it.+gatherOriginEvidence :: FilePath -> [FilePath] -> Map Text [OriginSite] -> IO (Map Text [OriginEvidence])+gatherOriginEvidence projectRoot searchPaths = traverse gatherFor+  where+    gatherFor siteList = do+      fromCheckout <- concat <$> traverse checkoutRemote (nub (map (^. #recordedUrl) siteList))+      fromInstalled <- concat <$> traverse (installedCopy siteList) (nubBy sameArtifact siteList)+      pure (fromCheckout <> fromInstalled)++    sameArtifact a b =+      a ^. #artifactName == b ^. #artifactName && a ^. #definitionFile == b ^. #definitionFile++    checkoutRemote recorded = do+      dir <- expandLocalPath recorded+      exists <- doesDirectoryExist dir+      if not exists+        then pure []+        else do+          (code, out, _) <- readProcessWithExitCode "git" ["-C", dir, "remote", "get-url", "origin"] ""+          let remote = T.strip (T.pack out)+          pure+            [ FromCheckoutRemote remote+            | code == ExitSuccess,+              not (T.null remote),+              not (isMachineLocalOriginUrl remote)+            ]++    installedCopy siteList representative = do+      let name = representative ^. #artifactName+          recordedRepos = [s ^. #repoName | s <- siteList, s ^. #artifactName == name]+      located <- resolveArtifactOrigin projectRoot searchPaths (representative ^. #definitionFile) (LocalOrigin name)+      case located of+        Left _ -> pure []+        Right dir -> do+          info <- readOriginInfo dir+          pure $ case info of+            Just origin+              | not (isMachineLocalOriginUrl (origin ^. #sourceUrl)),+                all (maybe True (\repo -> Just repo == origin ^. #repoName)) recordedRepos ->+                  [FromInstalledCopy name (origin ^. #sourceUrl) (origin ^. #repoName)]+            _ -> []++-- | Where a project's manifest lives, relative to the project root.+manifestRelativePath :: FilePath+manifestRelativePath = ".seihou" </> "manifest.json"++-- | Testable core of @seihou manifest repair-origins@: read the manifest in+-- the current directory, plan a repair for every origin recorded as a+-- machine-local path, and, unless this is a dry run, write the result.+runRepairOrigins :: RepairOriginsOpts -> IO RepairOutcome+runRepairOrigins opts = do+  projectRoot <- getCurrentDirectory+  let manifestPath = projectRoot </> manifestRelativePath+  present <- doesFileExist manifestPath+  if not present+    then+      pure+        ( RepairFailed+            ( "No "+                <> T.pack manifestRelativePath+                <> " here. Run this from the root of a project seihou has generated into."+            )+        )+    else do+      bytes <- LBS.readFile manifestPath+      case readCurrentManifest bytes of+        Left message -> pure (RepairFailed message)+        Right manifest -> do+          let sites = localOriginUrls manifest+          if Map.null sites+            then pure RepairNotNeeded+            else case validateOverrides sites (opts ^. #overrides) of+              Left message -> pure (RepairFailed message)+              Right () -> do+                searchPaths <- defaultSearchPaths+                evidence <- gatherOriginEvidence projectRoot searchPaths sites+                let decisions = planRepair sites evidence (opts ^. #overrides)+                    rewrites = [d | d@Rewrite {} <- decisions]+                case () of+                  _+                    | opts ^. #dryRun -> pure (RepairWouldWrite decisions)+                    | null rewrites -> pure (RepairUnwritten decisions)+                    | otherwise -> do+                        writeManifestAtomically manifestPath (applyRepair decisions manifest)+                        pure (RepairWritten decisions)++-- | Decode a manifest at the current schema. An older schema is refused with+-- the command that upgrades it: this command works on the decoded manifest,+-- and the upgrade to the current schema is lossless.+readCurrentManifest :: LBS.ByteString -> Either Text Manifest+readCurrentManifest bytes =+  case Aeson.eitherDecode bytes of+    Left err -> Left (unreadable (T.pack err))+    Right (Aeson.Object object)+      | Just version <- parseMaybe (.: "version") object,+        ManifestSchemaVersion version /= currentManifestVersion ->+          Left+            ( T.pack manifestRelativePath+                <> " is at schema version "+                <> T.pack (show (version :: Int))+                <> "; this command needs schema version "+                <> T.pack (show (currentManifestVersion ^. #unManifestSchemaVersion))+                <> ".\nRun 'seihou manifest upgrade' first, then run this again."+            )+    Right _ -> first (unreadable . T.pack) (manifestFromJSON bytes)+  where+    unreadable err = T.pack manifestRelativePath <> " could not be read: " <> err++-- | Write to a temporary file beside the manifest, then rename over it, so an+-- interrupted run never leaves a half-written manifest.+writeManifestAtomically :: FilePath -> Manifest -> IO ()+writeManifestAtomically manifestPath manifest = do+  let temporaryPath = manifestPath <> ".tmp"+  LBS.writeFile temporaryPath (manifestToJSON manifest)+  renamePath temporaryPath manifestPath++-- | The report printed for an outcome.+renderRepairOutcome :: RepairOutcome -> Text+renderRepairOutcome = \case+  RepairNotNeeded ->+    "✓ " <> T.pack manifestRelativePath <> " records no origin as a machine-local path; nothing to repair.\n"+  RepairWouldWrite decisions ->+    renderDecisions decisions <> "--dry-run: nothing was written.\n"+  RepairWritten decisions ->+    renderDecisions decisions+      <> "✓ Rewrote "+      <> T.pack (show (length (concat [sites | Rewrite _ _ _ sites <- decisions])))+      <> " recorded origin(s) in "+      <> T.pack manifestRelativePath+      <> ".\n  Review the diff and commit it: git diff "+      <> T.pack manifestRelativePath+      <> "\n"+  RepairUnwritten decisions ->+    renderDecisions decisions <> "No recorded path had a remote to rewrite to; nothing was written.\n"+  RepairFailed message -> message <> "\n"++renderDecisions :: [RepairDecision] -> Text+renderDecisions = T.concat . map renderDecision++renderDecision :: RepairDecision -> Text+renderDecision = \case+  Rewrite old new evidence sites ->+    T.unlines $+      [old, "  -> " <> new]+        <> map (("     evidence: " <>) . describeEvidence new) evidence+        <> ["     records: " <> describeSites sites]+  Conflicting old evidence sites ->+    T.unlines $+      [old, "  ! the evidence names different repositories; nothing is written for this path"]+        <> map (("     evidence: " <>) . describeEvidence "") evidence+        <> ["     records: " <> describeSites sites, remedy sites]+  Unresolved old sites ->+    T.unlines+      [ old,+        "  ! no remote found for this path",+        "     records: " <> describeSites sites,+        remedy sites+      ]+  where+    remedy sites =+      "     pass --set "+        <> maybe "<name>" (^. #artifactName) (headMay sites)+        <> "=<url> for the artifact recorded under this path"++    headMay = \case+      (x : _) -> Just x+      [] -> Nothing++-- | One evidence line. When the evidence proposes the URL being written, it+-- says "this remote" instead of repeating it.+describeEvidence :: Text -> OriginEvidence -> Text+describeEvidence chosen evidence = case evidence of+  FromCheckoutRemote url -> "the checkout at this path has 'origin' remote " <> remote url+  FromInstalledCopy name url _ -> "the installed copy of " <> name <> " records " <> remote url+  FromOverride name url -> "--set " <> name <> "=" <> url+  where+    remote url+      | not (T.null chosen) && normalizeOriginUrl url == normalizeOriginUrl chosen = "this remote"+      | otherwise = url++-- | The records under one path: each module, application, recipe, and+-- blueprint by name, and instances and migration receipts by count.+describeSites :: [OriginSite] -> Text+describeSites sites =+  T.intercalate ", " (named <> counted SiteApplicationInstance "application instance" <> counted SiteBlueprintMigration "blueprint migration receipt")+  where+    named = nub [site ^. #location | site <- sites, site ^. #kind `notElem` [SiteApplicationInstance, SiteBlueprintMigration]]+    counted siteKind noun =+      case length (filter ((== siteKind) . (^. #kind)) sites) of+        0 -> []+        1 -> ["1 " <> noun]+        n -> [T.pack (show n) <> " " <> noun <> "s"]++-- | Print the report and exit non-zero when anything is left for the user to+-- do: a failure, or any path that could not be resolved, even when others+-- were written.+handleRepairOrigins :: RepairOriginsOpts -> IO ()+handleRepairOrigins opts = do+  outcome <- runRepairOrigins opts+  TIO.putStr (renderRepairOutcome outcome)+  when (needsAttention outcome) exitFailure+  where+    needsAttention = \case+      RepairNotNeeded -> False+      RepairFailed _ -> True+      RepairWouldWrite decisions -> any unfinished decisions+      RepairWritten decisions -> any unfinished decisions+      RepairUnwritten decisions -> any unfinished decisions+    unfinished = \case+      Rewrite {} -> False+      Conflicting {} -> True+      Unresolved {} -> True

@@ -1,6 +1,10 @@--- | Convert a @.seihou\/manifest.json@ written before schema version 6 into--- the portable form every current command expects.+-- | Upgrade a @.seihou\/manifest.json@ through the ordered schema steps of+-- "Seihou.Manifest.Upgrade", one adjacent step at a time, and establish the+-- shared-write evidence schema 7 can record. --+-- Most of this module is the one inference-bearing step, schema 5 to 6: the+-- conversion of machine-local artifact paths into portable origins.+-- -- Schema-5-and-earlier manifests record, for each applied artifact, the -- absolute directory that artifact occupied on the machine that ran seihou — -- entries like @\/Users\/shinzui\/.config\/seihou\/installed\/haskell-base@.@@ -37,8 +41,11 @@      -- * Rewriting the document     UpgradeReportEntry (..),+    UpgradeStepReport (..),+    SharedWriteReportEntry (..),     UpgradeResult (..),     applyUpgrade,+    convertMachineLocalPaths,     formatUpgradeReport,      -- * The command@@ -47,6 +54,7 @@     manifestRelativePath,     formatUpgradeRefusal,     runManifestUpgrade,+    renderUpgradeOutcome,     handleManifestUpgrade,   ) where@@ -60,9 +68,22 @@ import Data.Foldable (toList) import Data.Generics.Labels () import Data.List (foldl')+import Data.Map.Strict qualified as Map+import Data.Maybe (fromMaybe) import Data.Text qualified as T import Data.Text.IO qualified as TIO import Data.Vector qualified as V+import Seihou.CLI.ManifestCapabilityUpgrade+  ( CertificationScope (..),+    EvidencePolicy (..),+    EvidenceSource (..),+    SharedWriteCertification (..),+    SharedWriteCertificationEntry (..),+    certifiedChanges,+    certifySharedWriteModesIO,+    renderCertificationGap,+    renderEvidenceSource,+  ) import Seihou.CLI.ManifestGuard   ( ArtifactCheck,     blockingChecks,@@ -72,11 +93,35 @@ import Seihou.Core.ArtifactOriginDetect (detectArtifactOrigin) import Seihou.Core.ArtifactRef (resolveArtifactOrigin) import Seihou.Core.Module (defaultSearchPaths)-import Seihou.Core.Types (ArtifactOrigin (..), Manifest)-import Seihou.Manifest.Types (currentManifestVersion)+import Seihou.Core.Types+  ( ArtifactOrigin (..),+    Manifest,+    ManifestCapability (..),+    ManifestSchemaVersion (..),+    SharedWriteMode (..),+  )+import Seihou.Manifest.JSON (decodeManifestValue)+import Seihou.Manifest.Types+  ( currentManifestVersion,+    manifestSupports,+    oldestDecodableManifestVersion,+    sharedWriteModeToText,+  )+import Seihou.Manifest.Upgrade+  ( ManifestUpgradeStep (..),+    UpgradeStepAction (..),+    UpgradeStepKind (..),+    applyLosslessUpgradeStep,+    documentSchemaVersion,+    planManifestUpgrade,+    renderManifestUpgradeError,+    setDocumentSchemaVersion,+    upgradeStepKind,+  ) import Seihou.Prelude import System.Directory (doesFileExist, getCurrentDirectory, renamePath) import System.Exit (exitFailure)+import System.IO.Temp (withSystemTempDirectory) import Text.Read (readMaybe)  -- ----------------------------------------------------------------------------@@ -114,16 +159,16 @@   }   deriving stock (Eq, Show, Generic) --- | Parse a manifest document that has not yet been upgraded.+-- | Parse a manifest document whose artifact references are still+-- machine-local paths. ----- Returns 'Nothing' when the document's @version@ is already at or above the--- current schema version, so callers can treat "nothing to do" as an ordinary--- outcome rather than an error. A manifest from a /newer/ seihou is also--- 'Nothing': there is nothing here to convert, and complaining about it is--- 'Seihou.Manifest.Types.checkManifestVersion''s job.+-- Returns 'Nothing' when the document's @version@ is already portable+-- (schema 6 or later), so a schema-6 document can never reach 'collectRefs'.+-- A manifest from a /newer/ seihou is also 'Nothing': there is nothing here+-- to convert, and complaining about it is the step planner's job. readLegacyManifest :: LBS.ByteString -> Either String (Maybe LegacyManifest) readLegacyManifest bytes = do-  value <- Aeson.eitherDecode bytes+  value <- decodeManifestValue bytes   fields <- case value of     Aeson.Object fields -> Right fields     _ -> Left "manifest is not a JSON object"@@ -132,7 +177,7 @@     Just _ -> Left "manifest 'version' is not a number"     Nothing -> Left "manifest has no 'version' field"   pure $-    if schemaVersion >= currentManifestVersion+    if schemaVersion >= oldestDecodableManifestVersion ^. #unManifestSchemaVersion       then Nothing       else         Just@@ -336,29 +381,91 @@   }   deriving stock (Eq, Show, Generic) +-- | One adjacent schema step that ran.+data UpgradeStepReport = UpgradeStepReport+  { fromVersion :: !ManifestSchemaVersion,+    toVersion :: !ManifestSchemaVersion,+    kind :: !UpgradeStepKind,+    summary :: !Text+  }+  deriving stock (Eq, Show, Generic)+ -- | An upgraded document plus the reviewable account of how it was reached. data UpgradeResult = UpgradeResult-  { fromVersion :: !Int,+  { -- | The schema the document was read at.+    fromVersion :: !ManifestSchemaVersion,+    -- | The schema of the last step that actually ran.+    toVersion :: !ManifestSchemaVersion,+    -- | Every step that ran, in order.+    steps :: ![UpgradeStepReport],+    -- | The origin conversions of the schema 5 to 6 step, if it ran.     entries :: ![UpgradeReportEntry],+    -- | Shared-write modes established after reaching schema 7, including+    -- paths that stayed unknown and why.+    certification :: ![SharedWriteReportEntry],+    -- | The recorded releases fetched from their remotes to establish that+    -- evidence, because no installed copy was the recorded version.+    evidenceSources :: ![EvidenceSource],     upgradedDocument :: !Aeson.Value   }   deriving stock (Eq, Show, Generic) --- | Convert a legacy manifest. Pure given the inferences, so the report and--- the resulting bytes can both be asserted on without a filesystem.------ Each reference's recorded path is deleted and the portable origin written in--- its place — @source@ becomes @origin@, @targetSource@ becomes--- @targetOrigin@ — and the document's @version@ is set to the current schema--- version. Nothing else in the document is touched.+-- | One path's shared-write outcome, with any gap already rendered.+data SharedWriteReportEntry = SharedWriteReportEntry+  { path :: !FilePath,+    previousMode :: !SharedWriteMode,+    certifiedMode :: !SharedWriteMode,+    reasons :: ![Text]+  }+  deriving stock (Eq, Show, Generic)++sharedWriteReportEntry :: Manifest -> SharedWriteCertificationEntry -> SharedWriteReportEntry+sharedWriteReportEntry manifest entry =+  SharedWriteReportEntry+    { path = entry ^. #path,+      previousMode = entry ^. #previousMode,+      certifiedMode = entry ^. #certifiedMode,+      reasons = map (renderCertificationGap manifest) (entry ^. #gaps)+    }++stepReport :: ManifestUpgradeStep -> UpgradeStepReport+stepReport step =+  UpgradeStepReport+    { fromVersion = step ^. #fromVersion,+      toVersion = step ^. #toVersion,+      kind = upgradeStepKind (step ^. #action),+      summary = step ^. #summary+    }++-- | Convert a legacy manifest straight to schema 6. Pure given the+-- inferences, so the report and the resulting bytes can both be asserted on+-- without a filesystem. The steps below 5 only stamp the version, so they+-- are reported but need no transform here. applyUpgrade :: LegacyManifest -> [(LegacyRef, InferenceOutcome)] -> UpgradeResult applyUpgrade legacy conversions =   UpgradeResult-    { fromVersion = legacy ^. #schemaVersion,-      entries = dedupeEntries (map reportEntry conversions),-      upgradedDocument = setSchemaVersion (foldl' rewrite (legacy ^. #document) conversions)+    { fromVersion = source,+      toVersion = oldestDecodableManifestVersion,+      steps = either (const []) (map stepReport) (planManifestUpgrade source oldestDecodableManifestVersion),+      entries = reportEntries,+      certification = [],+      evidenceSources = [],+      upgradedDocument = document     }   where+    source = ManifestSchemaVersion (legacy ^. #schemaVersion)+    (reportEntries, document) = convertMachineLocalPaths legacy conversions++-- | The schema 5 to 6 step: each reference's recorded path is deleted and+-- the portable origin written in its place — @source@ becomes @origin@,+-- @targetSource@ becomes @targetOrigin@ — and the document is stamped+-- schema 6. Nothing else in the document is touched.+convertMachineLocalPaths :: LegacyManifest -> [(LegacyRef, InferenceOutcome)] -> ([UpgradeReportEntry], Aeson.Value)+convertMachineLocalPaths legacy conversions =+  ( dedupeEntries (map reportEntry conversions),+    setDocumentSchemaVersion oldestDecodableManifestVersion (foldl' rewrite (legacy ^. #document) conversions)+  )+  where     rewrite document (ref, outcome) =       replaceAt (ref ^. #jsonPointer) (Aeson.toJSON (inferredOrigin outcome)) document @@ -424,24 +531,37 @@       _ -> value   _ -> value -setSchemaVersion :: Aeson.Value -> Aeson.Value-setSchemaVersion (Aeson.Object fields) =-  Aeson.Object (KeyMap.insert "version" (Aeson.toJSON currentManifestVersion) fields)-setSchemaVersion other = other---- | Render the conversion account shown in the terminal, without the closing+-- | Render the upgrade account shown in the terminal, without the closing -- line — whether the file was written is the caller's news to deliver.+--+-- Steps are listed in the order they ran; the origin conversions sit under+-- the 5 to 6 step that made them, and the shared-write evidence follows the+-- steps because it is established once the document can record it. formatUpgradeReport :: UpgradeResult -> Text formatUpgradeReport result =-  T.unlines (header : "" : concatMap entryLines (result ^. #entries))+  T.unlines (header : "" : concatMap stepLines (result ^. #steps) <> certificationLines)   where     header =       "Reading "         <> T.pack manifestRelativePath         <> " (schema version "-        <> T.pack (show (result ^. #fromVersion))+        <> showVersion (result ^. #fromVersion)         <> ")" +    stepLines step =+      [ "  "+          <> showVersion (step ^. #fromVersion)+          <> " -> "+          <> showVersion (step ^. #toVersion)+          <> "  "+          <> step ^. #summary+          <> (if step ^. #kind == InferenceBearingUpgrade then "  (inferred; review before committing)" else "")+      ]+        <> ( if step ^. #toVersion == oldestDecodableManifestVersion+               then "" : concatMap entryLines (result ^. #entries)+               else []+           )+     nameColumn =       maximum (5 : map (T.length . (^. #artifactName)) (result ^. #entries)) + 5 @@ -465,6 +585,34 @@             ]       _ -> [] +    certificationLines = case result ^. #certification of+      [] -> []+      entries ->+        ""+          : "  shared-write evidence"+          : concatMap certificationEntryLines entries+            <> [ "    (" <> renderEvidenceSource source <> ")"+               | source <- result ^. #evidenceSources+               ]++    pathColumn =+      maximum (5 : map (T.length . T.pack . (^. #path)) (result ^. #certification)) + 2++    certificationEntryLines entry =+      ( "  "+          <> T.justifyLeft pathColumn ' ' (T.pack (entry ^. #path))+          <> ( if entry ^. #previousMode == entry ^. #certifiedMode+                 then sharedWriteModeToText (entry ^. #certifiedMode) <> " (unchanged)"+                 else sharedWriteModeToText (entry ^. #previousMode) <> " -> " <> sharedWriteModeToText (entry ^. #certifiedMode)+             )+      )+        : [ T.replicate (pathColumn + 4) " " <> gapText+          | gapText <- entry ^. #reasons+          ]++showVersion :: ManifestSchemaVersion -> Text+showVersion (ManifestSchemaVersion v) = T.pack (show v)+ -- ---------------------------------------------------------------------------- -- The command -- ----------------------------------------------------------------------------@@ -480,30 +628,37 @@     -- | Write even when the converted manifest names artifacts this machine     -- cannot satisfy. For the developer who is upgrading a manifest on a     -- machine that deliberately does not have every artifact installed.-    force :: !Bool+    -- Only the inference-bearing 5 to 6 step consults it.+    force :: !Bool,+    -- | Stop at this schema. 'Nothing' means the current schema.+    targetVersion :: !(Maybe ManifestSchemaVersion)   }   deriving stock (Eq, Show, Generic)  -- | Terminal outcome of an upgrade run, decoupled from printing and exit codes -- so it can be asserted on directly. data UpgradeOutcome-  = -- | The manifest is already at the current schema version.-    UpgradeNotNeeded-  | -- | @--dry-run@: the document was converted and thrown away. Carries any+  = -- | Nothing to change: the document is at the requested schema and no+    -- shared-write evidence could be added. Carries the schema and every path+    -- that is still unknown, with why.+    UpgradeNotNeeded !ManifestSchemaVersion ![SharedWriteReportEntry]+  | -- | @--dry-run@: the document was upgraded and thrown away. Carries any     -- check that would have blocked a real write.     UpgradeWouldWrite UpgradeResult ![ArtifactCheck]-  | -- | The converted document was written over the manifest.+  | -- | The upgraded document was written over the manifest.     UpgradeWritten UpgradeResult-  | -- | The conversion succeeded but writing it would leave the project-    -- naming artifacts this machine cannot satisfy, so nothing was written.+  | -- | The path conversion succeeded but writing it would leave the project+    -- naming artifacts this machine cannot satisfy, so nothing was written+    -- and no later step ran.     UpgradeBlocked UpgradeResult ![ArtifactCheck]   | -- | Nothing was written; carries the message to show the user.     UpgradeFailed Text   deriving stock (Eq, Show, Generic)  -- | Testable core of @seihou manifest upgrade@: read the manifest in the--- current directory, infer an origin for every recorded path, rewrite the--- document, and — unless this is a dry run — write it back.+-- current directory, run each adjacent step up to the requested schema,+-- establish shared-write evidence once the document can record it, and —+-- unless this is a dry run — write the result back. runManifestUpgrade :: ManifestUpgradeOpts -> IO UpgradeOutcome runManifestUpgrade opts = do   projectRoot <- getCurrentDirectory@@ -520,41 +675,147 @@         )     else do       bytes <- LBS.readFile manifestPath-      case readLegacyManifest bytes of+      case decodeManifestValue bytes >>= \document -> first (T.unpack . renderManifestUpgradeError) ((document,) <$> documentSchemaVersion document) of         Left err -> pure (UpgradeFailed (T.pack manifestRelativePath <> " could not be read: " <> T.pack err))-        Right Nothing -> pure UpgradeNotNeeded-        Right (Just legacy) -> do-          searchPaths <- defaultSearchPaths-          conversions <--            traverse-              (\ref -> (ref,) <$> inferOriginFromLegacyPath projectRoot searchPaths ref)-              (legacy ^. #refs)-          let result = applyUpgrade legacy conversions-          case validateUpgrade result of-            Left err -> pure (UpgradeFailed err)-            Right manifest -> do-              blocking <--                if opts ^. #force-                  then pure []-                  else blockingChecks <$> checkAppliedArtifacts projectRoot searchPaths manifest-              if opts ^. #dryRun-                then pure (UpgradeWouldWrite result blocking)-                else-                  if null blocking-                    then do-                      writeDocument manifestPath (result ^. #upgradedDocument)-                      pure (UpgradeWritten result)-                    else pure (UpgradeBlocked result blocking)+        Right (document, source) -> do+          let target = fromMaybe currentManifestVersion (opts ^. #targetVersion)+          case planManifestUpgrade source target of+            Left err -> pure (UpgradeFailed (renderManifestUpgradeError err))+            Right steps -> do+              searchPaths <- defaultSearchPaths+              chained <- runSteps projectRoot searchPaths source document steps+              case chained of+                Left err -> pure (UpgradeFailed err)+                Right (result, blocking)+                  | not (null blocking) ->+                      pure $+                        if opts ^. #dryRun+                          then UpgradeWouldWrite result blocking+                          else UpgradeBlocked result blocking+                  | otherwise -> do+                      -- A co-owner whose recorded release is no longer+                      -- installed is read from its recorded remote into this+                      -- temporary directory, never into the install cache.+                      certified <-+                        withSystemTempDirectory "seihou-manifest-upgrade" $ \session ->+                          certifyDocument (FetchRecordedReleases session) projectRoot searchPaths result+                      case certified of+                        Left err -> pure (UpgradeFailed err)+                        Right final+                          | null (final ^. #steps) && not (any changed (final ^. #certification)) ->+                              pure (UpgradeNotNeeded (final ^. #toVersion) (final ^. #certification))+                          | opts ^. #dryRun -> pure (UpgradeWouldWrite final [])+                          | otherwise -> do+                              writeDocument manifestPath (final ^. #upgradedDocument)+                              pure (UpgradeWritten final)+  where+    runSteps projectRoot searchPaths source document =+      go+        UpgradeResult+          { fromVersion = source,+            toVersion = source,+            steps = [],+            entries = [],+            certification = [],+            evidenceSources = [],+            upgradedDocument = document+          }+      where+        go result [] = pure (Right (result, []))+        go result (step : rest) = do+          ran <- runStep projectRoot searchPaths step (result ^. #upgradedDocument)+          case ran of+            Left err -> pure (Left err)+            Right (conversions, next, blocking) -> do+              let advanced =+                    result+                      & #steps+                      %~ (<> [stepReport step])+                      & #entries+                      %~ (<> conversions)+                      & #toVersion+                      .~ (step ^. #toVersion)+                      & #upgradedDocument+                      .~ next+              if null blocking+                then go advanced rest+                else pure (Right (advanced, blocking)) --- | Decode the converted document with the ordinary manifest decoder, which--- turns the write into a correctness check: whatever is about to land on disk--- is proven readable by every command that will read it.-validateUpgrade :: UpgradeResult -> Either Text Manifest-validateUpgrade result =-  case Aeson.fromJSON (result ^. #upgradedDocument) of+    runStep projectRoot searchPaths step document = case step ^. #action of+      ConvertMachineLocalPaths -> do+        let legacy =+              LegacyManifest+                { schemaVersion = step ^. #fromVersion . #unManifestSchemaVersion,+                  document = document,+                  refs = collectRefs document+                }+        conversions <-+          traverse+            (\ref -> (ref,) <$> inferOriginFromLegacyPath projectRoot searchPaths ref)+            (legacy ^. #refs)+        let (reported, converted) = convertMachineLocalPaths legacy conversions+        case validateDocument converted of+          Left err -> pure (Left err)+          Right manifest -> do+            blocking <-+              if opts ^. #force+                then pure []+                else blockingChecks <$> checkAppliedArtifacts projectRoot searchPaths manifest+            pure (Right (reported, converted, blocking))+      _ -> case applyLosslessUpgradeStep step document of+        Left err -> pure (Left (renderManifestUpgradeError err))+        Right next+          | step ^. #toVersion >= oldestDecodableManifestVersion ->+              pure ((\_ -> ([], next, [])) <$> validateDocument next)+          | otherwise -> pure (Right ([], next, []))++    -- Evidence is established only once the document is at a schema that+    -- can record every answer, which is exactly the capability that needs it.+    certifyDocument policy projectRoot searchPaths result+      | result ^. #toVersion < oldestDecodableManifestVersion = pure (Right result)+      | otherwise = case validateDocument (result ^. #upgradedDocument) of+          Left err -> pure (Left err)+          Right manifest+            | not (manifestSupports TargetedAdditiveSharedPathUpdate manifest) -> pure (Right result)+            | otherwise -> do+                certification <-+                  certifySharedWriteModesIO policy projectRoot searchPaths CertifyAllUnknownPaths manifest Map.empty+                let document =+                      foldl'+                        (\current entry -> setRecordedSharedWriteMode (entry ^. #path) (entry ^. #certifiedMode) current)+                        (result ^. #upgradedDocument)+                        (certifiedChanges certification)+                    reported = map (sharedWriteReportEntry manifest) (certification ^. #entries)+                    certified =+                      result+                        & #certification+                        .~ reported+                        & #evidenceSources+                        .~ (certification ^. #fetchedSources)+                        & #upgradedDocument+                        .~ document+                pure (certified <$ validateDocument document)++    changed entry = entry ^. #previousMode /= entry ^. #certifiedMode++-- | Set one file record's @sharedWriteMode@ in a schema-7 raw document,+-- leaving every other member alone.+setRecordedSharedWriteMode :: FilePath -> SharedWriteMode -> Aeson.Value -> Aeson.Value+setRecordedSharedWriteMode path mode =+  updateAt ["files", T.pack path] $ \case+    Aeson.Object record ->+      Aeson.Object (KeyMap.insert "sharedWriteMode" (Aeson.String (sharedWriteModeToText mode)) record)+    other -> other++-- | Decode a document with the ordinary manifest decoder, which turns every+-- write into a correctness check: whatever is about to land on disk is+-- proven readable by every command that will read it.+validateDocument :: Aeson.Value -> Either Text Manifest+validateDocument document =+  case Aeson.fromJSON document of     Aeson.Error err ->       Left-        ( "The converted manifest is not one this build can read, so nothing was\n\+        ( "The upgraded manifest is not one this build can read, so nothing was\n\           \written. This is a bug in 'seihou manifest upgrade'; please report it.\n\n\           \  "             <> T.pack err@@ -599,41 +860,58 @@ handleManifestUpgrade :: ManifestUpgradeOpts -> IO () handleManifestUpgrade opts = do   outcome <- runManifestUpgrade opts+  TIO.putStr (renderUpgradeOutcome outcome)   case outcome of-    UpgradeNotNeeded ->-      TIO.putStrLn-        ( "✓ "-            <> T.pack manifestRelativePath-            <> " is already at schema version "-            <> T.pack (show currentManifestVersion)-            <> "; nothing to do."-        )-    UpgradeWouldWrite result blocking -> do-      TIO.putStr (formatUpgradeReport result)-      unless (null blocking) $-        TIO.putStr (formatUpgradeRefusal "! Without --force, this upgrade would be refused." blocking)-      TIO.putStrLn "--dry-run: nothing was written."-    UpgradeBlocked result blocking -> do-      TIO.putStr (formatUpgradeReport result)-      TIO.putStr-        ( formatUpgradeRefusal-            ("✗ Refusing to write " <> T.pack manifestRelativePath <> ".")-            blocking-        )-      exitFailure-    UpgradeWritten result -> do-      TIO.putStr (formatUpgradeReport result)-      TIO.putStrLn-        ( "✓ Upgraded "-            <> T.pack manifestRelativePath-            <> " to schema version "-            <> T.pack (show currentManifestVersion)-            <> "."-        )-      TIO.putStrLn ("  Review the diff and commit it: git diff " <> T.pack manifestRelativePath)-    UpgradeFailed message -> do-      TIO.putStrLn message-      exitFailure+    UpgradeBlocked {} -> exitFailure+    UpgradeFailed {} -> exitFailure+    _ -> pure ()++-- | Everything @seihou manifest upgrade@ prints for an outcome, exactly as+-- the command prints it. Pure, so a reader other than the command (the+-- upgrade diagnosis behind @seihou agent upgrade@) can show the same report.+renderUpgradeOutcome :: UpgradeOutcome -> Text+renderUpgradeOutcome = \case+  UpgradeNotNeeded version stillUnknown ->+    ( "✓ "+        <> T.pack manifestRelativePath+        <> " is already at schema version "+        <> showVersion version+        <> "; nothing to do.\n"+    )+      <> (if null stillUnknown then "" else formatStillUnknown stillUnknown)+  UpgradeWouldWrite result blocking ->+    formatUpgradeReport result+      <> (if null blocking then "" else formatUpgradeRefusal "! Without --force, this upgrade would be refused." blocking)+      <> "--dry-run: nothing was written.\n"+  UpgradeBlocked result blocking ->+    formatUpgradeReport result+      <> formatUpgradeRefusal+        ("✗ Refusing to write " <> T.pack manifestRelativePath <> ".")+        blocking+  UpgradeWritten result ->+    formatUpgradeReport result+      <> ( "✓ Upgraded "+             <> T.pack manifestRelativePath+             <> " to schema version "+             <> showVersion (result ^. #toVersion)+             <> ".\n"+         )+      <> ("  Review the diff and commit it: git diff " <> T.pack manifestRelativePath <> "\n")+  UpgradeFailed message -> message <> "\n"++-- | The paths an up-to-date manifest still cannot answer for, and why.+formatStillUnknown :: [SharedWriteReportEntry] -> Text+formatStillUnknown entries =+  T.unlines $+    [ "",+      "  The shared-write mode of these paths is still unknown, so a targeted",+      "  update that leaves one of their owners out will be refused:"+    ]+      <> concat+        [ ("    " <> T.pack (entry ^. #path)) : ["      " <> reason | reason <- entry ^. #reasons]+        | entry <- entries,+          entry ^. #certifiedMode == SharedWriteUnknown+        ]  -- ---------------------------------------------------------------------------- -- Small JSON accessors

@@ -0,0 +1,297 @@+-- | Find an artifact exactly as it was when it declared a recorded version,+-- in the git history of its recorded origin.+--+-- Certifying a shared path compiles every co-owner from the version the+-- manifest records. The install cache holds one version per name, normally+-- the newest, so as soon as a co-owner is upgraded on this machine its+-- recorded release is no longer installed. This module recovers that+-- release from the recorded remote instead: it clones the repository into a+-- caller-owned session directory and finds the newest commit at which an+-- artifact of the recorded name declares the recorded version.+--+-- The release is identified by content, not by tag. The main module+-- registry has no tags, but every commit's definition file states its+-- @version@, which is exactly what the manifest records. Among the commits+-- that declare it, the newest is the author's final word on that version.+--+-- Nothing here writes outside the session directory, and the install cache+-- is never consulted or changed+-- (docs\/adr\/0006-the-install-cache-will-not-silently-substitute-an-artifact.md).+-- Only the exact recorded version is ever returned; another version is not+-- a substitute for it+-- (docs\/adr\/0003-a-stale-or-substituted-artifact-is-a-hard-error.md).+module Seihou.CLI.RecordedRelease+  ( RecordedRelease (..),+    RecordedReleaseError (..),+    RevisionSearch (..),+    locateRecordedRelease,+    chooseRevision,+    planRevisionSearch,+    renderRecordedReleaseError,+  )+where++import Data.Containers.ListUtils (nubOrd)+import Data.Generics.Labels ()+import Data.List (find)+import Data.Maybe (fromMaybe, listToMaybe, mapMaybe)+import Data.Set qualified as Set+import Data.Text qualified as T+import Seihou.Core.ArtifactIdentity (normalizeOriginUrl)+import Seihou.Core.Registry (RepoContents (..), discoverRepoContents)+import Seihou.Core.Types (Module (..), ModuleName (..), Recipe (..), RecipeName (..), SHA256 (..))+import Seihou.Dhall.Eval (evalModuleFromFile, evalRecipeFromFile, evalRegistryFromFile)+import Seihou.Manifest.Hash (hashContent)+import Seihou.Prelude+import System.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist)+import System.Environment (getEnvironment)+import System.Exit (ExitCode (..))+import System.FilePath (makeRelative, takeFileName)+import System.Process (CreateProcess (..), proc, readCreateProcessWithExitCode)++-- | An artifact's recorded release, checked out in the session directory.+data RecordedRelease = RecordedRelease+  { -- | The artifact's own directory, holding its definition file.+    directory :: !FilePath,+    -- | The short id of the commit it was read at.+    revision :: !Text+  }+  deriving stock (Eq, Show, Generic)++-- | Why a recorded release could not be found.+data RecordedReleaseError+  = -- | The origin could not be cloned: the URL and git's message.+    RecordedReleaseCloneFailed !Text !Text+  | -- | No commit declares the artifact at the version: the URL, the+    --   artifact name, the version, and how many revisions were searched.+    RecordedReleaseNotFound !Text !Text !Text !Int+  | -- | A git command other than the clone failed: what was being done, and+    --   git's message.+    RecordedReleaseGitFailed !Text !Text+  deriving stock (Eq, Show, Generic)++-- | Which revisions to evaluate.+data RevisionSearch+  = -- | These revisions, found by searching for the version literal.+    SearchRevisions ![Text]+  | -- | The literal never appears, so the version is computed rather than+    --   written out: walk recent history instead.+    WalkRecentHistory+  deriving stock (Eq, Show, Generic)++-- | How many commits the fallback walk evaluates at most.+historyWalkLimit :: Int+historyWalkLimit = 200++-- | Decide which revisions to evaluate from the commits whose count of the+-- version literal changed, each with its first parent, and the tip.+--+-- A commit that introduces the literal may be the newest to declare it; one+-- that removes it has the newest declaring commit as its parent; and a+-- version still current is declared at the tip. Those are all the places+-- the newest declaring commit can be. No hit at all means the literal is+-- not written anywhere, so a narrowed search cannot find it.+planRevisionSearch :: Text -> [(Text, Maybe Text)] -> RevisionSearch+planRevisionSearch tip hits+  | null hits = WalkRecentHistory+  | otherwise = SearchRevisions (nubOrd (tip : concat [commit : maybe [] pure parent | (commit, parent) <- hits]))++-- | The first revision, newest first, that declares the version.+chooseRevision :: Text -> [(Text, Maybe Text)] -> Maybe Text+chooseRevision version = fmap fst . find (declares version . snd)++declares :: Text -> Maybe Text -> Bool+declares version declared = declared == Just version++-- | Locate the release of @name@ that declares @version@ in the repository+-- at @url@, cloning it into @session@ if this session has not already.+locateRecordedRelease ::+  -- | Session directory; everything is written below it.+  FilePath ->+  -- | Origin URL.+  Text ->+  -- | Artifact name.+  Text ->+  -- | Definition file, @module.dhall@ or @recipe.dhall@.+  FilePath ->+  -- | Recorded version.+  Text ->+  IO (Either RecordedReleaseError RecordedRelease)+locateRecordedRelease session url name definitionFile version = do+  cloned <- cloneForHistory session url+  case cloned of+    Left err -> pure (Left err)+    Right clone -> do+      tip <- git ["-C", clone, "rev-parse", "HEAD"]+      case T.strip <$> tip of+        Left err -> pure (Left (RecordedReleaseGitFailed "read the default branch" err))+        Right tipRevision -> do+          -- Where the artifact lives now narrows the search to its own+          -- definition file. The tip is always a candidate, so this+          -- evaluation is reused rather than repeated.+          atTip <- declaredAt session clone name definitionFile tipRevision+          case atTip of+            Left err -> pure (Left err)+            Right located -> do+              let scope = (\(directory, _) -> makeRelative (worktreeFor session clone tipRevision) directory) <$> located+              candidates <- candidateRevisions clone tipRevision version (fmap (</> definitionFile) scope) scope+              case candidates of+                Left err -> pure (Left err)+                Right revisions -> search clone revisions (0 :: Int)+  where+    search _ [] searched = pure (Left (RecordedReleaseNotFound url name version searched))+    search clone (revision : rest) searched = do+      evaluated <- declaredAt session clone name definitionFile revision+      case evaluated of+        Left err -> pure (Left err)+        Right (Just (directory, declared))+          | chooseRevision version [(revision, declared)] == Just revision ->+              pure (Right RecordedRelease {directory, revision = T.take 7 revision})+        Right _ -> search clone rest (searched + 1)++-- | A blobless clone of @url@ with full history, shared by every lookup in+-- the session that names the same origin.+cloneForHistory :: FilePath -> Text -> IO (Either RecordedReleaseError FilePath)+cloneForHistory session url = do+  let key = T.take 16 (hashContent (normalizeOriginUrl url) ^. #unSHA256)+      clone = releasesRoot session </> T.unpack ("clone-" <> key)+  existing <- doesDirectoryExist clone+  if existing+    then pure (Right clone)+    else do+      createDirectoryIfMissing True (releasesRoot session)+      -- Servers and local paths that ignore the filter fall back to a full+      -- clone, which is slower but equally correct.+      result <- git ["clone", "--filter=blob:none", "--no-checkout", "--quiet", T.unpack url, clone]+      pure (either (Left . RecordedReleaseCloneFailed url) (const (Right clone)) result)++-- | Revisions to evaluate, newest first.+--+-- With the artifact's current definition file and directory known, the+-- literal is searched only in that file and the fallback walk only visits+-- commits that touch that directory. Without them, which happens when the+-- default branch no longer holds the artifact, every Dhall file and every+-- commit is in scope.+--+-- Newest means topological order, children before parents, so commits made+-- within the same second still come out in the order they were made.+candidateRevisions :: FilePath -> Text -> Text -> Maybe FilePath -> Maybe FilePath -> IO (Either RecordedReleaseError [Text])+candidateRevisions clone tip version definitionPath artifactPath = do+  hits <-+    git+      ( ["-C", clone, "log", "--all", "--format=%H %P", "-S\"" <> T.unpack version <> "\"", "--"]+          <> [fromMaybe "*.dhall" definitionPath]+      )+  history <- git ["-C", clone, "rev-list", "--all", "--topo-order"]+  case (,) <$> hits <*> history of+    Left err -> pure (Left (RecordedReleaseGitFailed "search the history" err))+    Right (hitText, historyText) ->+      case planRevisionSearch tip (mapMaybe parseHit (T.lines hitText)) of+        WalkRecentHistory ->+          either (Left . RecordedReleaseGitFailed "list the history") (Right . T.lines)+            <$> git+              ( ["-C", clone, "rev-list", "--all", "--topo-order", "-n", show historyWalkLimit]+                  <> maybe [] (\path -> ["--", path]) artifactPath+              )+        SearchRevisions revisions ->+          let wanted = Set.fromList revisions+           in pure (Right (filter (`Set.member` wanted) (T.lines historyText)))+  where+    parseHit line = case T.words line of+      commit : parents -> Just (commit, listToMaybe parents)+      [] -> Nothing++-- | Check a revision out and read the declared version of the named+-- artifact there, with the artifact's directory. 'Nothing' when the+-- revision holds no such artifact or its definition does not evaluate.+declaredAt :: FilePath -> FilePath -> Text -> FilePath -> Text -> IO (Either RecordedReleaseError (Maybe (FilePath, Maybe Text)))+declaredAt session clone name definitionFile revision = do+  -- One worktree per commit, shared by every lookup in the session that+  -- visits it, and left in place: the whole session is removed at the end.+  let worktree = worktreeFor session clone revision+  existing <- doesDirectoryExist worktree+  added <-+    if existing+      then pure (Right "")+      else git ["-C", clone, "worktree", "add", "--detach", "--quiet", worktree, T.unpack revision]+  case added of+    Left err -> pure (Left (RecordedReleaseGitFailed ("check out " <> T.take 7 revision) err))+    Right _ -> do+      located <- artifactDirectory worktree name definitionFile+      case located of+        Nothing -> pure (Right Nothing)+        Just directory -> do+          declared <- declaredIdentity (directory </> definitionFile)+          pure $ Right $ case declared of+            Just (declaredName, declaredVersion) | declaredName == name -> Just (directory, declaredVersion)+            _ -> Nothing++-- | Where a checked-out repository keeps the named artifact.+artifactDirectory :: FilePath -> Text -> FilePath -> IO (Maybe FilePath)+artifactDirectory root name definitionFile = do+  contents <- discoverRepoContents evalRegistryFromFile root+  case contents of+    MultiModule registry ->+      let entries+            | definitionFile == "recipe.dhall" = registry ^. #recipes+            | otherwise = registry ^. #modules+       in case find ((== name) . (^. #name . #unModuleName)) entries of+            Just entry -> existingDefinition (root </> (entry ^. #path))+            Nothing -> pure Nothing+    _ -> existingDefinition root+  where+    existingDefinition directory = do+      present <- doesFileExist (directory </> definitionFile)+      pure (if present then Just directory else Nothing)++-- | The name and version a definition file declares.+declaredIdentity :: FilePath -> IO (Maybe (Text, Maybe Text))+declaredIdentity path+  | takeFileName path == "recipe.dhall" =+      either (const Nothing) (\recipe -> Just (recipe ^. #name . #unRecipeName, recipe ^. #version))+        <$> evalRecipeFromFile path+  | otherwise =+      either (const Nothing) (\modul -> Just (modul ^. #name . #unModuleName, modul ^. #version))+        <$> evalModuleFromFile path++-- | Where a commit of a clone is checked out. The clone's name keeps two+-- origins' identical commits apart.+worktreeFor :: FilePath -> FilePath -> Text -> FilePath+worktreeFor session clone revision =+  releasesRoot session </> ("wt-" <> takeFileName clone <> "-" <> T.unpack revision)++releasesRoot :: FilePath -> FilePath+releasesRoot session = session </> "recorded-releases"++-- | Run git without ever prompting: a remote that wants credentials fails+-- like any other unreachable remote.+git :: [String] -> IO (Either Text Text)+git arguments = do+  inherited <- getEnvironment+  let environment = ("GIT_TERMINAL_PROMPT", "0") : filter ((/= "GIT_TERMINAL_PROMPT") . fst) inherited+  (exitCode, out, err) <- readCreateProcessWithExitCode ((proc "git" arguments) {env = Just environment}) ""+  pure $ case exitCode of+    ExitSuccess -> Right (T.pack out)+    ExitFailure _ -> Left (T.strip (T.pack err))++-- | One sentence, suitable as the tail of a certification gap.+renderRecordedReleaseError :: RecordedReleaseError -> Text+renderRecordedReleaseError = \case+  RecordedReleaseCloneFailed url err ->+    "its recorded origin " <> url <> " could not be cloned (" <> firstLine err <> ")"+  RecordedReleaseNotFound url name version searched ->+    "no commit of "+      <> url+      <> " declares "+      <> name+      <> " "+      <> version+      <> " (searched "+      <> T.pack (show searched)+      <> (if searched == 1 then " revision)" else " revisions)")+  RecordedReleaseGitFailed what err ->+    "git could not " <> what <> " of its recorded origin (" <> firstLine err <> ")"+  where+    firstLine text = case T.lines text of+      line : _ -> line+      [] -> "no message"

@@ -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/49ff1e5b353b171b1b52946f478623ee4423ea93/package.dhall"+schemaUrl = "https://raw.githubusercontent.com/shinzui/seihou-schema/367b0a1390ac1ed3dda6e2cacfdf3e72b1f624df/package.dhall"  -- | SHA256 integrity hash for the schema import schemaHash :: Text-schemaHash = "sha256:cadacb688dd31ec39feb7f2fe599973a1ad58ef8fcc8ed1100bf3da22a1222cb"+schemaHash = "sha256:ef20d62c240dfe0e1126e05534d58c467188af4198307ad3c2a4a713bcd93505"  -- | Complete Dhall import line for use in generated modules schemaImportLine :: Text

@@ -1,6 +1,7 @@ module Seihou.CLI.StatusRender   ( formatStatus,     formatStatusWith,+    formatCheckoutStatus,     formatArtifactChecks,     formatBlueprintMigrations,     ModuleAdvice (..),@@ -10,7 +11,7 @@  import Control.Lens (to, (^.)) import Data.Generics.Labels ()-import Data.List (intersperse, nub)+import Data.List (nub) import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map import Data.Maybe (isJust, listToMaybe, mapMaybe)@@ -18,12 +19,15 @@ import Data.Text (Text) import Data.Text qualified as T import Data.Time.Format (defaultTimeLocale, formatTime)+import Seihou.CLI.ApplicationDisplay (appliedTargetName, parentVarsText)+import Seihou.CLI.CheckoutSync (renderCheckoutStatus) import Seihou.CLI.ManifestGuard (ArtifactCheck, summarizeCheck) import Seihou.CLI.Style (dim, green, red, yellow) import Seihou.CLI.VersionCompare   ( OutdatedEntry (..),     OutdatedStatus (..),   )+import Seihou.Core.Checkout (CheckoutPlan) import Seihou.Core.Migration (MigrationPlan (..)) import Seihou.Core.Types   ( AppliedBlueprint (..),@@ -307,28 +311,15 @@         "    (applied "           <> T.pack (formatTime defaultTimeLocale "%Y-%m-%d" (am ^. #appliedAt))           <> ")"-      parentVarsText =-        let m = (am ^. #parentVars . #unParentVars)-         in if Map.null m-              then ""-              else-                let pairs =-                      T.concat-                        ( intersperse-                            ", "-                            [ vn ^. #unVarName <> "=" <> v-                            | (vn, v) <- Map.toAscList m-                            ]-                        )-                    rendered = " [" <> pairs <> "]"-                 in applyColor color dim rendered+      contextText =+        maybe "" (applyColor color dim . (" " <>)) (parentVarsText (am ^. #parentVars))       updateText = case annotation of         NoCheck -> ""         NoOrigin -> "  " <> applyColor color dim "(no origin)"         Entry e -> "  " <> renderEntry color e    in "  "         <> am ^. #name . #unModuleName-        <> parentVarsText+        <> contextText         <> verText         <> appliedText         <> updateText@@ -404,16 +395,12 @@           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)+            then Just (AdviceProjectUpdate (appliedTargetName (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   UpToDate -> applyColor color dim "up to date"@@ -493,3 +480,7 @@ applyColor :: Bool -> (Text -> Text) -> Text -> Text applyColor True f = f applyColor False _ = id++-- | Bounded checkout diagnostics, observed independently of artifact availability.+formatCheckoutStatus :: CheckoutPlan -> Text+formatCheckoutStatus = renderCheckoutStatus

@@ -89,6 +89,7 @@ renderColorLine _ other = renderNonFileColor other  renderNonFileColor :: PreviewLine -> Text+renderNonFileColor (LinkPreview dest source) = "    " <> cyan "link" <> "   " <> cyan (T.pack dest) <> " -> " <> cyan (T.pack source) renderNonFileColor (DirPreview path) =   "    " <> cyan "mkdir" <> "  " <> cyan (T.pack path) renderNonFileColor (CommandPreview cmd mOwner) =

@@ -21,11 +21,15 @@  import Control.Exception (SomeException, displayException, throwIO, toException, try) import Control.Monad (foldM, forM, forM_, when)+import Data.Aeson qualified as Aeson+import Data.ByteString qualified as BS+import Data.ByteString.Lazy qualified as LBS+import Data.Containers.ListUtils (nubOrd) import Data.Foldable (traverse_) import Data.Generics.Labels () import Data.List (find, isPrefixOf) import Data.Map.Strict qualified as Map-import Data.Maybe (fromMaybe, isJust, mapMaybe, maybeToList)+import Data.Maybe (fromMaybe, isJust, isNothing, listToMaybe, mapMaybe, maybeToList) import Data.Set qualified as Set import Data.Text qualified as T import Data.Text.IO qualified as TIO@@ -33,6 +37,15 @@ import Effectful (runEff) import Seihou.CLI.CommandExecution import Seihou.CLI.InstallShared (InstallOutcome (..), installModuleDir, summarizeInstallRefusal)+import Seihou.CLI.ManifestCapabilityUpgrade+  ( CertificationGap (..),+    CertificationScope (..),+    EvidencePolicy (..),+    EvidenceSource,+    SharedWriteCertification,+    certifiedChanges,+    certifySharedWriteModesIO,+  ) import Seihou.CLI.Shared (deriveNamespace, toVarNameMap) import Seihou.CLI.Update.Migrations import Seihou.CLI.Update.Recovery@@ -51,6 +64,7 @@ import Seihou.Core.Application (buildAppliedComposition, replaceAppliedComposition) import Seihou.Core.ArtifactOriginDetect (detectArtifactOrigin) import Seihou.Core.ArtifactRef (renderArtifactRefError, resolveArtifactOrigin)+import Seihou.Core.Checkout import Seihou.Core.Module (defaultSearchPaths, discoverRunnable) import Seihou.Core.Types import Seihou.Core.Version (parseVersion)@@ -59,17 +73,27 @@ import Seihou.Effect.ConfigReader import Seihou.Effect.ConfigReaderInterp (runConfigReader) import Seihou.Effect.ConsoleInterp (runConsole)+import Seihou.Effect.Filesystem (PathEntry (..), inspectPath) import Seihou.Effect.FilesystemInterp (runFilesystem) import Seihou.Effect.FilesystemPure (PureFS (..))-import Seihou.Effect.ManifestStore (readManifest, writeManifest)+import Seihou.Effect.ManifestStore (writeManifest) import Seihou.Effect.ManifestStoreInterp (runManifestStore) import Seihou.Effect.ProcessInterp (runProcessIO) import Seihou.Engine.Baseline (manifestBaselineRefs)+import Seihou.Engine.Checkout 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.Manifest.JSON (decodeManifestValue)+import Seihou.Manifest.Types+  ( currentManifestVersion,+    manifestFromJSON,+    manifestSupports,+    minimumManifestVersion,+    oldestDecodableManifestVersion,+  )+import Seihou.Manifest.Upgrade (documentSchemaVersion, renderManifestUpgradeError, upgradeDocumentLosslessly) import Seihou.Prelude import System.Directory qualified as Directory import System.Environment (getEnvironment)@@ -108,42 +132,50 @@     Right () -> do       let manifestPath = projectRoot </> ".seihou" </> "manifest.json"           baselineDirectory = projectRoot </> ".seihou" </> "baselines"-      manifestResult <- readManifestIO manifestPath+      manifestResult <- readManifestForUpdate manifestPath       case manifestResult of         Left err -> pure (Left err)-        Right manifest -> do+        Right (document, manifest) -> do           now <- getCurrentTime-          seeded <- selectAndSeedLegacy request projectRoot manifest now-          case seeded of+          resolved <- resolveSelection request sessionDirectory projectRoot installedDirectory manifestPath document manifest now+          case resolved of             Left err -> pure (Left err)-            Right (selected, seedWarnings) -> do-              staged <- stageCandidateSources sessionDirectory projectRoot installedDirectory selected-              case staged of+            Right resolution -> do+              let base = resolution ^. #manifest+                  selected = resolution ^. #applications+                  seedWarnings = resolution ^. #warnings+              staging <- case resolution ^. #staged of+                Just staged -> pure (Right staged)+                Nothing -> stageSelection request sessionDirectory projectRoot installedDirectory now selected+              case staging of                 Left err -> pure (Left err)-                Right (catalog, sourceWarnings) -> do-                  plannedApplicationsResult <- traverse (planApplication request projectRoot catalog now) selected-                  case sequence plannedApplicationsResult of+                Right staged -> do+                  let catalog = staged ^. #catalog+                      sourceWarnings = staged ^. #warnings+                      plannedApplications = staged ^. #plannedApplications+                      applicationInputs =+                        [ (Just previous, planned ^. #modulesInOrder)+                        | (previous, planned) <- zip selected plannedApplications+                        ]+                  stagedMigrations <- planAndStageMigrations projectRoot base catalog applicationInputs+                  case stagedMigrations 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+                    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+                          checkoutSetup <- planCheckoutUpdate projectRoot base plannedApplications+                          case checkoutSetup of+                            Left err -> pure (Left err)+                            Right (checkoutCandidate, checkoutPlan) -> do                               evidence <- versionEvidence (request ^. #allowDowngrade) projectRoot catalog selected plannedApplications                               case evidence of                                 Left err -> pure (Left err)@@ -157,8 +189,12 @@                                           <> migrationStage ^. #warnings                                           <> compositionWarnings                                           <> versionWarnings+                                          <> map CheckoutWarning (concatMap (^. #warnings) (checkoutPlan ^. #entries))                                       inputChanges = summarizeInputChanges seedWarnings plannedApplications-                                      transactionTargets = transactionTargetPaths manifest reconciliation (migrationStage ^. #plans)+                                      transactionTargets = transactionTargetPaths base reconciliation (migrationStage ^. #plans) `Set.union` Set.fromList [entry ^. #dest | entry <- checkoutPlan ^. #entries, entry ^. #action `elem` [CreateLink, ReplaceLink, RetireLink]]+                                  -- The manifest is observed as it is on disk, before+                                  -- any in-memory preparation, so an edit made between+                                  -- planning and apply is reported as a stale plan.                                   observedProjectHashes <-                                     observePaths                                       projectRoot@@ -183,15 +219,214 @@                                             inputChanges,                                             migrations = migrationStage ^. #plans,                                             reconciliation,+                                            checkoutPlan,+                                            checkoutOutputs = checkoutCandidate ^. #checkoutOutputs,                                             commandPlan,                                             candidateArtifacts = usedArtifacts,                                             warnings,                                             request,                                             snapshot,-                                            plannedApplications+                                            plannedApplications,+                                            manifestPreparation = manifestPreparationFor manifest base (resolution ^. #evidenceSources)                                           }                                     ) +-- | Candidate sources staged for a set of applications, and those+-- applications planned against them.+data StagedSelection = StagedSelection+  { applicationIds :: !(Set ApplicationId),+    catalog :: !CandidateCatalog,+    warnings :: ![UpdateWarning],+    plannedApplications :: ![PlannedApplication]+  }+  deriving stock (Generic)++-- | What an update will apply to, decided before anything outside the+-- temporary session is touched.+data SelectionResolution = SelectionResolution+  { -- | The manifest planning starts from: the on-disk manifest, or the one+    -- a targeted update prepared in memory.+    manifest :: !Manifest,+    applications :: ![AppliedComposition],+    warnings :: ![UpdateWarning],+    -- | Candidates already staged for exactly 'applications' while+    -- establishing evidence, so they are not cloned or compiled twice.+    staged :: !(Maybe StagedSelection),+    -- | Recorded releases fetched from their remotes to certify paths.+    evidenceSources :: ![EvidenceSource]+  }+  deriving stock (Generic)++-- | Match the request, then settle the ownership closure.+--+-- A targeted update needs the 'TargetedAdditiveSharedPathUpdate' capability,+-- so an older manifest is first prepared in memory with the lossless schema+-- steps that reach its minimum. Paths the closure cannot yet decide because+-- their shared-write mode is unknown are certified for the selection: the+-- selected applications' candidates are staged and compiled, the recorded+-- co-owners are compiled from their recorded state, and the closure is+-- enforced again on the certified manifest. Nothing here writes outside the+-- session directory, runs a command, or reconciles a co-owner's files.+resolveSelection ::+  UpdateRequest ->+  FilePath ->+  FilePath ->+  FilePath ->+  FilePath ->+  Aeson.Value ->+  Manifest ->+  UTCTime ->+  IO (Either UpdateError SelectionResolution)+resolveSelection request sessionDirectory projectRoot installedDirectory manifestPath document manifest now =+  case matchApplications (request ^. #selection) manifest of+    Left err -> pure (Left err)+    Right (MatchedAll applications) -> pure (Right (SelectionResolution manifest applications [] Nothing []))+    Right (MatchedLegacy name) -> do+      seeded <- seedLegacyApplication request projectRoot manifest now name+      pure (fmap (\(applications, warnings) -> SelectionResolution manifest applications warnings Nothing []) seeded)+    Right (MatchedNamed named) ->+      case prepareManifestSchema manifestPath TargetedAdditiveSharedPathUpdate document manifest of+        Left err -> pure (Left err)+        Right prepared -> closeOver (1 :: Int) prepared Nothing [] named+  where+    policy+      | request ^. #includeSharedOwners = IncludeSharedOwners+      | otherwise = RequireNamedOwners++    closeOver attempt current staged sources named = case enforceOwnershipClosure policy current named of+      Left err -> pure (Left err)+      Right (ClosureSatisfied ids warnings) ->+        pure (Right (SelectionResolution current (applicationsWithIds current ids) warnings (reusable ids staged) sources))+      Right (ClosureNeedsEvidence ids _ paths) -> do+        stagedResult <- case reusable ids staged of+          Just existing -> pure (Right existing)+          Nothing ->+            stageSelection+              request+              (sessionDirectory </> ("evidence-" <> show attempt))+              projectRoot+              installedDirectory+              now+              (applicationsWithIds current ids)+        case stagedResult of+          Left err -> pure (Left err)+          Right evidenceStage -> do+            searchPaths <- defaultSearchPaths+            let supplied =+                  Map.fromList+                    [ (planned ^. #candidate . #applicationId, planned ^. #operations)+                    | planned <- evidenceStage ^. #plannedApplications+                    ]+            -- A co-owner whose recorded release is no longer installed is+            -- read from its recorded remote into this session, never into+            -- the install cache.+            certification <-+              certifySharedWriteModesIO+                (FetchRecordedReleases sessionDirectory)+                projectRoot+                searchPaths+                (CertifyPathsForApplications ids)+                current+                supplied+            -- Certification only ever turns unknown into known, so a round+            -- that changes nothing cannot be followed by one that does.+            if null (certifiedChanges certification)+              then pure (Left (evidenceUnavailable current certification paths))+              else+                closeOver+                  (attempt + 1)+                  (certification ^. #manifest)+                  (Just evidenceStage)+                  (nubOrd (sources <> certification ^. #fetchedSources))+                  named++    reusable ids staged = case staged of+      Just existing | existing ^. #applicationIds == ids -> Just existing+      _ -> Nothing++-- | The first path the closure is waiting on that certification could not+-- settle, with every owner whose evidence is missing.+evidenceUnavailable :: Manifest -> SharedWriteCertification -> [FilePath] -> UpdateError+evidenceUnavailable manifest certification paths =+  case [entry | entry <- certification ^. #entries, entry ^. #path `elem` paths, entry ^. #certifiedMode == SharedWriteUnknown] of+    entry : _ ->+      SharedWriteEvidenceUnavailable+        (entry ^. #path)+        [(applicationRef manifest (gapOwner gap), gap) | gap <- entry ^. #gaps]+    [] -> SharedWriteEvidenceUnavailable (fromMaybe "" (listToMaybe paths)) []+  where+    gapOwner (OwnerNotRecorded owner) = owner+    gapOwner (OwnerEvidenceUnavailable owner _) = owner+    gapOwner (OwnerEmitsNoOperation owner) = owner++-- | Stage candidates for these applications and plan each of them.+stageSelection ::+  UpdateRequest ->+  FilePath ->+  FilePath ->+  FilePath ->+  UTCTime ->+  [AppliedComposition] ->+  IO (Either UpdateError StagedSelection)+stageSelection request stagingDirectory projectRoot installedDirectory now selected = do+  staged <- stageCandidateSources stagingDirectory projectRoot installedDirectory selected+  case staged of+    Left err -> pure (Left err)+    Right (catalog, warnings) -> do+      planned <- traverse (planApplication request projectRoot catalog now) selected+      pure $ do+        plannedApplications <- sequence planned+        Right+          StagedSelection+            { applicationIds = Set.fromList (map (^. #applicationId) selected),+              catalog,+              warnings,+              plannedApplications+            }++-- | Bring a manifest up to the schema a capability needs, in memory, using+-- lossless steps only. The on-disk file is untouched; the result is+-- published, if at all, with the update that needed it+-- (docs/adr/0014-every-semantic-manifest-change-advances-the-schema-version.md).+prepareManifestSchema :: FilePath -> ManifestCapability -> Aeson.Value -> Manifest -> Either UpdateError Manifest+prepareManifestSchema path capability document manifest+  | manifestSupports capability manifest = Right manifest+  | otherwise = do+      (_, upgraded) <-+        first+          (UpdateManifestUnreadable path . renderManifestUpgradeError)+          (upgradeDocumentLosslessly (minimumManifestVersion capability) document)+      case Aeson.fromJSON upgraded of+        Aeson.Error err -> Left (UpdateManifestUnreadable path (T.pack err))+        Aeson.Success prepared -> Right prepared++-- | Describe what preparation changed, or 'Nothing' when it changed nothing.+manifestPreparationFor :: Manifest -> Manifest -> [EvidenceSource] -> Maybe ManifestPreparation+manifestPreparationFor original prepared evidenceSources+  | original ^. #version == prepared ^. #version && Map.null modeChanges = Nothing+  | otherwise =+      Just+        ManifestPreparation+          { fromVersion = original ^. #version,+            toVersion = prepared ^. #version,+            modeChanges,+            evidenceSources,+            preparedManifest = prepared+          }+  where+    modeChanges =+      Map.fromList+        [ (path, (before ^. #sharedWriteMode, after ^. #sharedWriteMode))+        | (path, after) <- Map.toAscList (prepared ^. #files),+          Just before <- [Map.lookup path (original ^. #files)],+          before ^. #sharedWriteMode /= after ^. #sharedWriteMode+        ]++-- | The manifest an accepted plan applies on top of.+planBaseManifest :: UpdatePlan -> Manifest+planBaseManifest plan =+  maybe (plan ^. #snapshot . #originalManifest) (^. #preparedManifest) (plan ^. #manifestPreparation)+ applyProjectUpdate :: UpdatePlan -> IO (Either UpdateError UpdateResult) applyProjectUpdate plan =   Directory.withCurrentDirectory (plan ^. #snapshot . #projectRoot) $ do@@ -224,7 +459,7 @@         Left err -> abortUpdate transaction err         Right () -> do           now <- getCurrentTime-          migrated <- runRealMigrations now (plan ^. #snapshot . #originalManifest) (plan ^. #migrations)+          migrated <- runRealMigrations now (planBaseManifest plan) (plan ^. #migrations)           case migrated of             Left err -> abortUpdate transaction err             Right migratedManifest -> do@@ -253,29 +488,33 @@                         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+                            linkResult <- applyUpdateCheckout plan migratedManifest filesManifest+                            case linkResult of+                              Left err -> abortUpdate transaction err+                              Right () -> 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-                                        written <- writeManifestIO (plan ^. #snapshot . #manifestPath) finalManifest-                                        case written of+                                        publication <- publishCandidates (plan ^. #candidateArtifacts)+                                        case publication of                                           Left err -> abortUpdate transaction err-                                          Right () -> finishCommitted transaction plan finalManifest completedReceipts+                                          Right () -> do+                                            written <- writeManifestIO (plan ^. #snapshot . #manifestPath) finalManifest+                                            case written of+                                              Left err -> abortUpdate transaction err+                                              Right () -> finishCommitted transaction plan finalManifest completedReceipts  planApplication ::   UpdateRequest ->@@ -422,21 +661,6 @@   where     configResult = first (UpdateConfigurationFailed . T.pack . show) -selectAndSeedLegacy ::-  UpdateRequest ->-  FilePath ->-  Manifest ->-  UTCTime ->-  IO (Either UpdateError ([AppliedComposition], [UpdateWarning]))-selectAndSeedLegacy request projectRoot manifest now = case selectApplications policy (request ^. #selection) manifest of-  Left err -> pure (Left err)-  Right (RecordedSelection selected, warnings) -> pure (Right (selected, warnings))-  Right (LegacySelection name, _) -> seedLegacyApplication request projectRoot manifest now name-  where-    policy-      | request ^. #includeSharedOwners = IncludeSharedOwners-      | otherwise = RequireNamedOwners- seedLegacyApplication ::   UpdateRequest -> FilePath -> Manifest -> UTCTime -> Text -> IO (Either UpdateError ([AppliedComposition], [UpdateWarning])) seedLegacyApplication request projectRoot manifest now requested = do@@ -758,8 +982,11 @@   where     observe path = do       let fullPath = projectRoot </> path-      exists <- Directory.doesFileExist fullPath-      hash <- if exists then Just . hashContent <$> TIO.readFile fullPath else pure Nothing+      entry <- runEff $ runFilesystem $ inspectPath fullPath+      hash <- case entry of+        EntrySymlink target -> pure (Just (hashContent ("symlink\0" <> T.pack target)))+        EntryFile -> Just . hashContent <$> TIO.readFile fullPath+        _ -> pure Nothing       pure (path, hash)  stalePlanPaths :: UpdatePlan -> IO (Set FilePath)@@ -832,6 +1059,8 @@       applications = foldl' (flip replaceAppliedComposition) (filesManifest ^. #applications) finalApplications,       recipe = updatedRecipe,       blueprint = filesManifest ^. #blueprint,+      seeds = filesManifest ^. #seeds,+      checkoutOutputs = plan ^. #checkoutOutputs,       blueprintMigrations = filesManifest ^. #blueprintMigrations     }   where@@ -1002,14 +1231,28 @@   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+-- | Read the manifest, keeping the raw document so a targeted update can+-- run lossless schema steps on it. The schema is inspected before decoding,+-- so a manifest only the explicit converter can read gets its own error+-- naming that command rather than a generic decode failure.+readManifestForUpdate :: FilePath -> IO (Either UpdateError (Aeson.Value, Manifest))+readManifestForUpdate path = do+  exists <- Directory.doesFileExist path+  if not exists+    then pure (Left (UpdateManifestMissing path))+    else do+      result <- try @SomeException (BS.readFile path)+      pure $ case result of+        Left err -> Left (UpdateManifestUnreadable path (T.pack (displayException err)))+        Right strict -> do+          let bytes = LBS.fromStrict strict+          document <- first (UpdateManifestUnreadable path . T.pack) (decodeManifestValue bytes)+          case documentSchemaVersion document of+            Right version+              | version < oldestDecodableManifestVersion -> Left (UpdateManifestUpgradeRequired path version)+            _ -> do+              manifest <- first (UpdateManifestUnreadable path . T.pack) (manifestFromJSON bytes)+              Right (document, manifest)  abortUpdate :: UpdateTransaction -> UpdateError -> IO (Either UpdateError a) abortUpdate transaction original = do@@ -1120,7 +1363,13 @@  isUpdateNoOp :: UpdatePlan -> Bool isUpdateNoOp plan =-  null (plan ^. #versionChanges)+  -- A lossless schema step or a newly certified shared-write mode is a+  -- change to applied state that only this update will publish (ADR 0004),+  -- so a plan carrying one is never a deliberate no-op (ADR 0007).+  plan ^. #checkoutOutputs == plan ^. #snapshot . #originalManifest . #checkoutOutputs+    && all ((== UnchangedLink) . (^. #action)) (plan ^. #checkoutPlan . #entries)+    && isNothing (plan ^. #manifestPreparation)+    && null (plan ^. #versionChanges)     && null (plan ^. #migrations)     && plan ^. #inputChanges . #overridden == 0     && plan ^. #inputChanges . #newlyResolved == 0@@ -1130,14 +1379,14 @@     && and (zipWith sameApplication (mapMaybe (^. #previous) (plan ^. #plannedApplications)) (plan ^. #applications))   where     -- A file whose content is unchanged can still carry a manifest record-    -- that is out of date. @additiveOnly@ is the case that matters: a project-    -- whose manifest predates the field has no answer for any path, and+    -- that is out of date. The shared-write mode is the case that matters: a+    -- project whose manifest predates the evidence has no answer for any path, and     -- treating that as a no-op would mean the answer is never written, so the     -- shared-path exemption could never take effect on an existing project.     -- Recording a fact about applied state is a change to applied state     -- (ADR 0004), so such a plan is not a deliberate no-op (ADR 0007).     unchangedFile (FileUnchanged desired _ _ prior) =-      maybe True (\record -> record ^. #additiveOnly == desired ^. #additiveOnly) prior+      maybe True (\record -> record ^. #sharedWriteMode == recordedSharedWriteMode (plan ^. #reconciliation . #applicationIds) desired prior) prior     unchangedFile _ = False     -- Compare only what the manifest actually records. Anything derived from     -- where an artifact happens to sit on this machine would differ between a@@ -1170,3 +1419,27 @@ varValueToText (VBool False) = "false" varValueToText (VInt value) = T.pack (show value) varValueToText (VList values) = T.intercalate "," (map varValueToText values)++planCheckoutUpdate :: FilePath -> Manifest -> [PlannedApplication] -> IO (Either UpdateError (Manifest, CheckoutPlan))+planCheckoutUpdate root prior applications = case replaceCheckoutApplications prior [(app ^. #candidate, app ^. #operations) | app <- applications] of+  Left err -> pure (Left (UpdateCheckoutFailed err))+  Right candidate -> do+    planned <- runEff $ runFilesystem $ runProcessIO $ prepareCheckoutApplication root prior candidate (concatMap (^. #operations) applications)+    pure $ do+      plan <- first UpdateCheckoutFailed planned+      case concatMap (^. #errors) (plan ^. #entries) of+        err : _ -> Left (UpdateCheckoutFailed err)+        [] -> Right (candidate, plan)++applyUpdateCheckout :: UpdatePlan -> Manifest -> Manifest -> IO (Either UpdateError ())+applyUpdateCheckout plan prior filesManifest = runEff $ runFilesystem $ runProcessIO $ do+  let candidate = filesManifest & #checkoutOutputs .~ plan ^. #checkoutOutputs & #applications .~ foldl' (flip replaceAppliedComposition) (filesManifest ^. #applications) (plan ^. #applications)+      root = plan ^. #snapshot . #projectRoot+  checked <- prepareCheckoutPlan Reconcile ApplyDeclaration root prior candidate []+  case checked of+    Left err -> pure (Left (UpdateCheckoutFailed err))+    Right links -> case concatMap (^. #errors) (links ^. #entries) of+      err : _ -> pure (Left (UpdateCheckoutFailed err))+      [] -> do+        applied <- applyCheckoutPlan ApplyDeclaration root links+        pure $ maybe (Right ()) (Left . UpdateCheckoutFailed) (applied ^. #failure)

@@ -205,7 +205,7 @@           | path <- Map.keys files,             directory <- parents path           ]-  pure PureFS {files, dirs = directories}+  pure PureFS {files, dirs = directories, links = Map.empty}   where     readTracked path = do       let fullPath = projectRoot </> path

@@ -3,6 +3,7 @@     setServiceExpectedManifest,     restoreServiceBackups,     recoverServiceBackups,+    pendingUpdateRecovery,   ) where @@ -178,6 +179,22 @@                 if committed                   then pure (Just (Right ()))                   else Just <$> restoreJournal projectRoot transactionDirectory journal++-- | Whether an update transaction is waiting under @.seihou\/transactions@,+-- which the next planning call would roll back or clean up before doing+-- anything else. Read-only: it performs the discovery 'recoverServiceBackups'+-- and 'Seihou.Engine.UpdateTransaction.recoverIncompleteTransactions' share+-- (every directory under that root is recovered, committed or not) and acts+-- on nothing.+pendingUpdateRecovery :: FilePath -> IO Bool+pendingUpdateRecovery projectRoot = do+  let transactionsRoot = projectRoot </> ".seihou" </> "transactions"+  exists <- Directory.doesDirectoryExist transactionsRoot+  if not exists+    then pure False+    else do+      names <- Directory.listDirectory transactionsRoot+      or <$> traverse (Directory.doesDirectoryExist . (transactionsRoot </>)) names  restoreJournal :: FilePath -> FilePath -> ServiceJournal -> IO (Either UpdateError ()) restoreJournal projectRoot transactionDirectory journal = do

@@ -6,8 +6,11 @@     planOutput,     resultOutput,     errorOutput,+    errorOutputFor,+    agentUpgradeHint,     renderUpdateHuman,     encodeUpdateOutput,+    errorCode,   ) where @@ -15,9 +18,11 @@ import Data.ByteString.Lazy (ByteString) import Data.Generics.Labels () import Data.Map.Strict qualified as Map-import Data.Maybe (fromMaybe)+import Data.Maybe (fromMaybe, isNothing) import Data.Set qualified as Set import Data.Text qualified as T+import Seihou.CLI.ApplicationDisplay (applicationLabel, appliedTargetName, moduleNameText)+import Seihou.CLI.CheckoutSync (CheckoutSyncResult (..), checkoutReportJSON, renderCheckoutPlan) import Seihou.CLI.CommandExecution   ( CommandDisposition (..),     CommandPlan (..),@@ -25,37 +30,62 @@     PlannedCommand (..),     summarizeCommandPlan,   )+import Seihou.CLI.ManifestCapabilityUpgrade (CertificationGap (..), EvidenceSource (..), renderEvidenceSource)+import Seihou.CLI.Shared (formatVarError) import Seihou.CLI.Update.Types-import Seihou.Core.Migration (MigrationPlan (..))+import Seihou.Core.ArtifactRef (renderArtifactRefError)+import Seihou.Core.Checkout (CheckoutAction (..), CheckoutEntry (..), CheckoutError (..), CheckoutPlan (..))+import Seihou.Core.Migration (MigrationPlan (..), MigrationPlanError (..)) import Seihou.Core.Types   ( ApplicationId (..),     AppliedComposition (..),     AppliedTarget (..),     BaselineRef (..),     CommandFingerprint (..),+    ManifestSchemaVersion (..),+    ModuleLoadError (..),     ModuleName (..),     Operation (..),-    RecipeName (..),     SHA256 (..),     VarName (..),   )+import Seihou.Core.Version (renderVersion)+import Seihou.Engine.Checkout (CheckoutExecution (..))+import Seihou.Engine.Migrate (MigrationExecError (..)) import Seihou.Engine.Reconcile   ( DesiredFile (..),     FileConflictChoice (..),     FileReconciliation (..),     OrphanChoice (..),+    ReconciliationError+      ( CopySourceUnavailable,+        DesiredOwnerOutsideSelection,+        InvalidReconciliationPath,+        MissingDesiredOwner,+        NotAFileConflict,+        NotAnEditedOrphan,+        PatchMaterializationFailed,+        ReconciliationPathNotFound,+        UpdateAborted+      ),     ReconciliationPlan (..),     ReconciliationSummary (..),     ResolvedFileConflict (..),     reconciliationSummary,+    recordedSharedWriteMode,   )+import Seihou.Engine.Reconcile qualified as Reconcile+import Seihou.Engine.UpdateTransaction (TransactionError (..))+import Seihou.Manifest.Types (sharedWriteModeToText) import Seihou.Prelude  newtype UpdatePlanView = UpdatePlanView UpdatePlan  newtype UpdateResultView = UpdateResultView UpdateResult -newtype UpdateErrorView = UpdateErrorView UpdateError+-- | A failure, and the first target the update named, which the human+-- rendering's @seihou agent upgrade@ hint repeats.+data UpdateErrorView = UpdateErrorView (Maybe Text) UpdateError  data UpdateOutput   = UpdatePlanOutput UpdatePlanView@@ -69,17 +99,32 @@ resultOutput = UpdateAppliedOutput . UpdateResultView  errorOutput :: UpdateError -> UpdateOutput-errorOutput = UpdateFailedOutput . UpdateErrorView+errorOutput = errorOutputFor [] +-- | 'errorOutput' for an update that named these targets.+errorOutputFor :: [Text] -> UpdateError -> UpdateOutput+errorOutputFor targets = UpdateFailedOutput . UpdateErrorView (case targets of target : _ -> Just target; [] -> Nothing)++-- | The line every human update failure ends with, after the remedy-first+-- message: the escape hatch when that remedy is unclear. JSON output never+-- carries it, so @error.message@ stays stable.+agentUpgradeHint :: Maybe Text -> Text+agentUpgradeHint target =+  "If this keeps failing, run 'seihou agent upgrade "+    <> fromMaybe "<module>" target+    <> "' to have an agent repair the manifest state and finish the upgrade.\n"+ renderUpdateHuman :: Bool -> UpdateOutput -> Text renderUpdateHuman _ (UpdatePlanOutput (UpdatePlanView plan)) =   T.unlines $-    versionLines plan+    preparationLines (plan ^. #manifestPreparation)+      <> versionLines plan       <> [ renderInputs (plan ^. #inputChanges),            "Migrations:  " <> count (length (plan ^. #migrations)) <> migrationCaveat plan,            renderFiles (reconciliationSummary (plan ^. #reconciliation)),            renderCommands (summarizeCommandPlan (plan ^. #commandPlan))          ]+      <> T.lines (renderCheckoutPlan True (plan ^. #checkoutPlan))       <> conflictLines (plan ^. #reconciliation)       <> warningLines (plan ^. #warnings) renderUpdateHuman _ (UpdateAppliedOutput (UpdateResultView result)) =@@ -95,8 +140,8 @@         <> " disabled"     ]       <> warningLines (result ^. #warnings)-renderUpdateHuman _ (UpdateFailedOutput (UpdateErrorView err)) =-  "Update failed [" <> errorCode err <> "]: " <> errorMessage err <> "\n"+renderUpdateHuman _ (UpdateFailedOutput (UpdateErrorView target err)) =+  "Update failed [" <> errorCode err <> "]: " <> errorMessage err <> "\n" <> agentUpgradeHint target  encodeUpdateOutput :: UpdateOutput -> ByteString encodeUpdateOutput = encode . outputValue@@ -107,10 +152,12 @@     [ "schemaVersion" .= (1 :: Int),       "outcome" .= ("plan" :: Text),       "alreadyUpToDate" .= planLooksUnchanged plan,+      "manifestPreparation" .= fmap preparationValue (plan ^. #manifestPreparation),       "applications" .= map applicationIdText (plan ^. #applications),       "versions" .= map versionValue (plan ^. #versionChanges),       "inputs" .= inputValue (plan ^. #inputChanges),       "migrations" .= map migrationValue (plan ^. #migrations),+      "checkout" .= checkoutReportJSON (CheckoutSyncResult (plan ^. #snapshot . #projectRoot) True (plan ^. #checkoutPlan) (CheckoutExecution Map.empty [] Nothing) []),       "files" .= map fileValue (Map.toAscList (plan ^. #reconciliation . #files)),       "commands" .= map commandValue (plan ^. #commandPlan . #commands),       "warnings" .= map warningText (plan ^. #warnings)@@ -131,13 +178,66 @@       "touchedPaths" .= Set.toAscList (result ^. #touchedPaths),       "warnings" .= map warningText (result ^. #warnings)     ]-outputValue (UpdateFailedOutput (UpdateErrorView err)) =+outputValue (UpdateFailedOutput (UpdateErrorView _ err)) =   object     [ "schemaVersion" .= (1 :: Int),       "outcome" .= ("error" :: Text),       "error" .= object ["code" .= errorCode err, "message" .= errorMessage err]     ] +-- | The manifest change a targeted update stages before it plans.+preparationLines :: Maybe ManifestPreparation -> [Text]+preparationLines Nothing = []+preparationLines (Just preparation) =+  ("Manifest:    " <> schemaChange preparation)+    : [ "             "+          <> T.pack path+          <> " evidence "+          <> sharedWriteModeToText before+          <> " -> "+          <> sharedWriteModeToText after+      | (path, (before, after)) <- Map.toAscList (preparation ^. #modeChanges)+      ]+      <> [ "             (" <> renderEvidenceSource source <> ")"+         | source <- preparation ^. #evidenceSources+         ]+  where+    schemaChange p+      | p ^. #fromVersion == p ^. #toVersion = "schema " <> schemaText (p ^. #toVersion) <> " (evidence recorded)"+      | otherwise = "schema " <> schemaText (p ^. #fromVersion) <> " -> " <> schemaText (p ^. #toVersion)++preparationValue :: ManifestPreparation -> Value+preparationValue preparation =+  object $+    [ "fromSchema" .= (preparation ^. #fromVersion . #unManifestSchemaVersion),+      "toSchema" .= (preparation ^. #toVersion . #unManifestSchemaVersion),+      "sharedWriteModes"+        .= [ object+               [ "path" .= path,+                 "from" .= sharedWriteModeToText before,+                 "to" .= sharedWriteModeToText after+               ]+           | (path, (before, after)) <- Map.toAscList (preparation ^. #modeChanges)+           ]+    ]+      -- Additive and omitted when empty, so an update that fetched nothing+      -- prints exactly what it printed before.+      <> [ "evidenceSources" .= map evidenceSourceValue sources+         | let sources = preparation ^. #evidenceSources,+           not (null sources)+         ]+  where+    evidenceSourceValue source =+      object+        [ "module" .= (source ^. #moduleName . #unModuleName),+          "version" .= (source ^. #version),+          "origin" .= (source ^. #originUrl),+          "revision" .= (source ^. #revision)+        ]++schemaText :: ManifestSchemaVersion -> Text+schemaText version = T.pack (show (version ^. #unManifestSchemaVersion))+ versionLines :: UpdatePlan -> [Text] versionLines plan   | null (plan ^. #versionChanges) = ["Versions:    unchanged"]@@ -316,27 +416,73 @@       "sharedOwnership" .= (summary ^. #sharedOwnership)     ] +gapText :: CertificationGap -> Text+gapText (OwnerNotRecorded _) = "the manifest does not record it as an application, so nothing describes how it writes"+gapText (OwnerEvidenceUnavailable _ reason) = reason+gapText (OwnerEmitsNoOperation _) = "its recorded version no longer writes this path"+ applicationIdText :: AppliedComposition -> Text applicationIdText application = (application ^. #applicationId . #unApplicationId)  fingerprintText :: CommandFingerprint -> Text fingerprintText (CommandFingerprint (SHA256 value)) = value +-- | Every warning, as a sentence a person can act on. Deliberately+-- exhaustive, with no fallback to 'show': a new constructor must not compile+-- its way into the terminal as Haskell syntax. warningText :: UpdateWarning -> Text+warningText (LocalArtifactHasNoRemote name) =+  name+    <> " has no recorded remote, so the locally installed copy is the update candidate;"+    <> " record its origin to update it from upstream"+warningText (SameVersionContentChanged name) =+  name <> " changed content without changing its declared version"+warningText (AmbiguousLegacyValue name) =+  "the legacy manifest value for "+    <> name ^. #unVarName+    <> " is declared by more than one module, so it was not reused; it is resolved again"+warningText (MissingLegacyValue name) =+  "the legacy manifest has no value for required variable " <> name ^. #unVarName <> "; it is resolved again"+warningText (MigrationCommandNotSimulated name command) =+  "a migration of "+    <> moduleNameText name+    <> " runs '"+    <> command+    <> "', which a dry run cannot simulate; the file summary assumes it changes nothing"+warningText (CrossApplicationLastWriter path earlier later)+  | earlier == later = T.pack path <> " is written more than once by " <> moduleNameText later+  | otherwise =+      T.pack path+        <> " receives content from both "+        <> moduleNameText earlier+        <> " and "+        <> moduleNameText later+        <> "; "+        <> moduleNameText later+        <> " is recorded as its last writer (ownership attribution only, not a content change)"+warningText ArbitraryCommandSideEffectsMayRemain =+  "a command ran before the failure; managed files were restored, but anything else it changed was not"+warningText (BaselinePruneFailed reason) =+  "the update succeeded, but old update baselines could not be pruned: " <> reason+warningText (CheckoutWarning reason) = reason+warningText (RecoveryCleanupDeferred reason) =+  "the update succeeded, but cleaning up its recovery data was deferred: " <> reason warningText (SelectionExpandedForSharedPath path owner) =   "also updating "-    <> (owner ^. #unApplicationId)+    <> applicationLabel owner     <> " because it co-owns "     <> T.pack path-warningText other = T.pack (show other)+    <> " (--include-shared-owners)"  errorCode :: UpdateError -> Text errorCode UpdateManifestMissing {} = "manifest_missing" errorCode UpdateManifestUnreadable {} = "manifest_unreadable"+errorCode UpdateManifestUpgradeRequired {} = "manifest_upgrade_required" errorCode NoRecordedApplications = "no_recorded_applications" errorCode LegacyUpdateRequiresOneTarget = "legacy_update_requires_one_target" errorCode UpdateTargetNotFound {} = "target_not_found" errorCode SharedPathRequiresApplications {} = "shared_path_requires_applications"+errorCode SharedWriteEvidenceUnavailable {} = "shared_write_evidence_unavailable" errorCode CandidateCloneFailed {} = "candidate_clone_failed" errorCode CandidateRepositoryInvalid {} = "candidate_repository_invalid" errorCode CandidateArtifactMissing {} = "candidate_artifact_missing"@@ -350,6 +496,7 @@ errorCode UpdateConfigurationFailed {} = "configuration_failed" errorCode UpdateMigrationPlanFailed {} = "migration_plan_failed" errorCode UpdateMigrationStageFailed {} = "migration_stage_failed"+errorCode (UpdateCheckoutFailed err) = err ^. #code errorCode UpdateCompositionFailed {} = "composition_failed" errorCode UpdateReconciliationFailed {} = "reconciliation_failed" errorCode UpdateHasUnresolvedPaths {} = "unresolved_paths"@@ -362,34 +509,234 @@ errorCode UpdateCachePublicationFailed {} = "cache_publication_failed" errorCode UpdateManifestWriteFailed {} = "manifest_write_failed" +-- | Every error, as prose that leads with the repair. Deliberately+-- exhaustive, like 'warningText'. errorMessage :: UpdateError -> Text errorMessage (UpdateManifestMissing path) =   "No Seihou manifest was found at " <> T.pack path <> ". Run seihou run first."+errorMessage (UpdateManifestUnreadable path reason) =+  "The manifest at " <> T.pack path <> " could not be read: " <> reason+errorMessage (UpdateManifestUpgradeRequired path version) =+  "Run 'seihou manifest upgrade --dry-run' to review the conversion, then 'seihou manifest upgrade',"+    <> " then update again. The manifest at "+    <> T.pack path+    <> " uses schema "+    <> schemaText version+    <> ", which records machine-specific artifact paths; converting them to portable origins"+    <> " is inference, so it is never done implicitly."+errorMessage NoRecordedApplications =+  "The manifest records no applications to update. Run seihou run <target> first."+errorMessage LegacyUpdateRequiresOneTarget =+  "This manifest predates recorded applications. Name exactly one target to update, and"+    <> " seihou records it as the first application." errorMessage (UpdateTargetNotFound target available) =   "No recorded application matches '"     <> target     <> "'. Available targets: "     <> T.intercalate ", " available errorMessage (SharedPathRequiresApplications path selected required) =-  "Path "+  "At least one owner of "     <> T.pack path-    <> " is also owned by application(s) "-    <> T.intercalate ", " (map (^. #unApplicationId) (Set.toAscList required))-    <> ", and it is not recorded as written only by additive patches"-    <> " -- either an owner writes the whole file, or the manifest predates that record,"-    <> " in which case one seihou update with no targets will record it."-    <> " Select every owner, pass --include-shared-owners, or run seihou update"-    <> " with no targets. Selected: "-    <> T.intercalate ", " (map (^. #unApplicationId) (Set.toAscList selected))+    <> " writes the whole file, so its owners have to be updated together. Selected: "+    <> labels selected+    <> ". Also required: "+    <> labels required+    <> ". Name them as targets"+    <> maybe "" (\command -> " (" <> command <> ")") (selectionCommand (selected <> required))+    <> ", or pass --include-shared-owners to update their full applications too."+  where+    labels = T.intercalate ", " . map applicationLabel . Set.toAscList+errorMessage (SharedWriteEvidenceUnavailable path gaps) =+  "Seihou has to inspect how the owners of "+    <> T.pack path+    <> " write it before a targeted update may leave any of them out, and it could not read the"+    <> " recorded version of each application below, either installed here or from its recorded origin: "+    <> T.intercalate "; " [applicationLabel owner <> ": " <> gapText gap | (owner, gap) <- gaps]+    <> ". Install that exact version, or make its recorded origin reachable, then update again."+    <> " Inspecting an owner does not update it, and selecting more applications would not"+    <> " supply the missing evidence. 'seihou manifest upgrade --dry-run' lists every path still unresolved."+errorMessage (CandidateCloneFailed url reason) =+  "Could not clone " <> url <> ": " <> reason+errorMessage (CandidateRepositoryInvalid source problems) =+  source <> " is not a usable Seihou artifact source: " <> T.intercalate "; " problems+errorMessage (CandidateArtifactMissing kind name) =+  "No candidate " <> kindText kind <> " named " <> name <> " was found in its recorded source."+errorMessage (CandidateArtifactUnresolved err) =+  renderArtifactRefError err+errorMessage (CandidateArtifactAmbiguous kind name locations) =+  "More than one candidate "+    <> kindText kind+    <> " named "+    <> name+    <> " was found: "+    <> T.intercalate ", " locations+errorMessage (CandidateLoadFailed name err) =+  "Candidate " <> name <> " could not be loaded: " <> loadErrorText err+errorMessage (CandidateDowngrade name recorded candidate) =+  "Updating "+    <> name+    <> " would move it from "+    <> fromMaybe "unversioned" recorded+    <> " back to "+    <> fromMaybe "unversioned" candidate+    <> ". Pass --allow-downgrade if that is intended."+errorMessage (CandidateVersionInvalid name version) =+  "Candidate " <> name <> " declares a version seihou cannot parse: '" <> version <> "'"+errorMessage (UpdateConflictingPriorVersions name versions) =+  "Module "+    <> moduleNameText name+    <> " is recorded at more than one version ("+    <> T.intercalate ", " versions+    <> "), so there is no single starting point to plan its migrations from."+errorMessage (UpdateVariableErrors errors) =+  "Variables could not be resolved: " <> T.intercalate "; " (map formatVarError errors)+errorMessage (UpdateConfigurationFailed reason) =+  "Configuration could not be loaded: " <> reason+errorMessage (UpdateMigrationPlanFailed name err) =+  "Cannot plan migrations for " <> moduleNameText name <> ": " <> migrationPlanErrorText err+errorMessage (UpdateMigrationStageFailed name err) =+  "Staging the migrations for " <> moduleNameText name <> " failed: " <> migrationExecErrorText err+errorMessage (UpdateCheckoutFailed err) = err ^. #message+errorMessage (UpdateCompositionFailed problems) =+  "The candidate composition is invalid: " <> T.intercalate "; " problems+errorMessage (UpdateReconciliationFailed err) =+  reconciliationErrorText err errorMessage (UpdateHasUnresolvedPaths paths) =   "Resolve these paths before apply: " <> T.intercalate ", " (map T.pack (Set.toAscList paths))+errorMessage (UpdateRecoveryFailed errors) =+  "An interrupted update could not be recovered: " <> T.intercalate "; " (map transactionErrorText errors) errorMessage (UpdatePlanStale paths) =   "The project changed after planning: " <> T.intercalate ", " (map T.pack (Set.toAscList paths))-errorMessage err = T.pack (show err)+errorMessage (UpdateTransactionFailed err) =+  "Publishing the update failed: " <> transactionErrorText err+errorMessage (UpdateMigrationFailed name err) =+  "A migration of " <> moduleNameText name <> " failed and the update was rolled back: " <> migrationExecErrorText err+errorMessage (UpdateChangedAfterMigrationCommand planned actual) =+  "A migration command changed the project in a way the plan did not show (planned "+    <> summaryText planned+    <> "; found "+    <> summaryText actual+    <> "). The update was rolled back; review the migration and plan again."+errorMessage (UpdateCommandFailed failure warnings) =+  "Command"+    <> maybe "" (\command -> " '" <> command <> "'") (commandText (failure ^. #command . #operation))+    <> " exited with code "+    <> count (failure ^. #exitCode)+    <> " and the update was rolled back"+    <> stderrText (failure ^. #stderr)+    <> T.concat [". Warning: " <> warningText warning | warning <- warnings]+  where+    stderrText output+      | T.null (T.strip output) = ""+      | otherwise = ": " <> T.strip output+errorMessage (UpdateCachePublicationFailed reason) =+  "The installed module cache could not be updated, so the update was rolled back: " <> reason+errorMessage (UpdateManifestWriteFailed reason) =+  "The manifest could not be written, so the update was rolled back: " <> reason +-- | A command line that names every recorded target among these owners,+-- when each has one.+selectionCommand :: Set.Set ApplicationRef -> Maybe Text+selectionCommand refs = do+  targets <- traverse (^. #target) (Set.toAscList refs)+  pure ("seihou update " <> T.unwords (Set.toAscList (Set.fromList (map appliedTargetName targets))))++kindText :: CandidateArtifactKind -> Text+kindText CandidateModule = "module"+kindText CandidateRecipe = "recipe"++loadErrorText :: ModuleLoadError -> Text+loadErrorText (ModuleNotFound name searched) =+  "module " <> moduleNameText name <> " was not found (searched " <> T.intercalate ", " (map T.pack searched) <> ")"+loadErrorText (DhallEvalError name reason) = "evaluating " <> moduleNameText name <> " failed: " <> reason+loadErrorText (DhallDecodeError name reason) = "decoding " <> moduleNameText name <> " failed: " <> reason+loadErrorText (ValidationError name problems) =+  moduleNameText name <> " is invalid: " <> T.intercalate "; " problems+loadErrorText (CircularDependency names) =+  "circular dependency: " <> T.intercalate " -> " (map moduleNameText names)+loadErrorText (MissingSourceFile name path) =+  moduleNameText name <> " is missing its source file " <> T.pack path+loadErrorText (RegistryEvalError source reason) =+  "evaluating registry " <> source <> " failed: " <> reason++migrationPlanErrorText :: MigrationPlanError -> Text+migrationPlanErrorText (MigrationVersionUnparseable version) =+  "a migration declares an unparseable version '" <> version <> "'"+migrationPlanErrorText (MigrationDowngradeNotSupported installed target) =+  "migrating down from " <> renderVersion installed <> " to " <> renderVersion target <> " is not supported"+migrationPlanErrorText (MigrationDuplicateEdge from _) =+  "more than one migration starts at " <> renderVersion from <> ", so the chain is ambiguous"++migrationExecErrorText :: MigrationExecError -> Text+migrationExecErrorText (MigrationConflict paths) =+  "these files were edited since they were generated: " <> T.intercalate ", " (map T.pack paths)+migrationExecErrorText (MigrationCommandFailed output code) =+  "a migration command exited with code " <> count code <> ": " <> output+migrationExecErrorText (MigrationUnsafePath label path reason) =+  "unsafe migration " <> label <> " '" <> T.pack path <> "': " <> reason++reconciliationErrorText :: ReconciliationError -> Text+reconciliationErrorText (InvalidReconciliationPath path reason) =+  "Path " <> T.pack path <> " cannot be reconciled: " <> reason+reconciliationErrorText (MissingDesiredOwner path) =+  "No selected application claims " <> T.pack path <> "."+reconciliationErrorText (DesiredOwnerOutsideSelection path owners) =+  T.pack path <> " would be written by " <> ownerCount owners <> " outside the selection."+reconciliationErrorText (Reconcile.SharedPathRequiresApplications path owners) =+  T.pack path+    <> " is also owned by "+    <> ownerCount owners+    <> " outside the selection and is not written only by additive patches."+    <> " Name those owners as targets, or pass --include-shared-owners."+reconciliationErrorText (CopySourceUnavailable path) =+  "The source for " <> T.pack path <> " is unavailable."+reconciliationErrorText (PatchMaterializationFailed path _ name reason) =+  "The patch " <> moduleNameText name <> " applies to " <> T.pack path <> " could not be applied: " <> reason+reconciliationErrorText (ReconciliationPathNotFound path) =+  "No planned change exists for " <> T.pack path <> "."+reconciliationErrorText (NotAFileConflict path) =+  T.pack path <> " is not a conflict, so it cannot be resolved as one."+reconciliationErrorText (NotAnEditedOrphan path) =+  T.pack path <> " is not an edited orphan, so it cannot be resolved as one."+reconciliationErrorText (UpdateAborted path) =+  "The update was aborted at " <> T.pack path <> "."++-- | Count, never list, application ids the engine hands over bare: a digest+-- is not a name.+ownerCount :: Set.Set ApplicationId -> Text+ownerCount owners = count (Set.size owners) <> " other application(s)"++transactionErrorText :: TransactionError -> Text+transactionErrorText (InvalidTransactionPath path reason) = T.pack path <> ": " <> reason+transactionErrorText (TransactionStartFailed reason) = "the update transaction could not start: " <> reason+transactionErrorText (TransactionJournalMalformed path reason) =+  "the update journal " <> T.pack path <> " is malformed: " <> reason+transactionErrorText (TransactionUnjournaledPaths paths) =+  "these paths are not covered by the update journal: " <> T.intercalate ", " (map T.pack (Set.toAscList paths))+transactionErrorText (TransactionUnresolvedPaths paths) =+  "these paths are unresolved: " <> T.intercalate ", " (map T.pack (Set.toAscList paths))+transactionErrorText (TransactionStalePlan path _ _) =+  T.pack path <> " changed after planning"+transactionErrorText (TransactionApplyFailed reason rollback) =+  reason <> maybe "; the project was restored" ("; restoring the project also failed: " <>) rollback+transactionErrorText (TransactionRollbackFailed reason) = "restoring the project failed: " <> reason+transactionErrorText (TransactionCompletionFailed reason) = "finishing the update failed: " <> reason++summaryText :: ReconciliationSummary -> Text+summaryText summary =+  count (summary ^. #creates)+    <> " created, "+    <> count (summary ^. #updates)+    <> " updated, "+    <> count (summary ^. #safeDeletes)+    <> " deleted"+ planLooksUnchanged :: UpdatePlan -> Bool planLooksUnchanged plan =-  null (plan ^. #versionChanges)+  plan ^. #checkoutOutputs == plan ^. #snapshot . #originalManifest . #checkoutOutputs+    && all ((== UnchangedLink) . (^. #action)) (plan ^. #checkoutPlan . #entries)+    && isNothing (plan ^. #manifestPreparation)+    && null (plan ^. #versionChanges)     && null (plan ^. #migrations)     && plan ^. #inputChanges . #overridden == 0     && plan ^. #inputChanges . #newlyResolved == 0@@ -399,10 +746,10 @@   where     -- Kept in step with 'Seihou.CLI.Update.isUpdateNoOp': a file whose bytes     -- are unchanged still counts as a change when this plan would record a-    -- different @additiveOnly@ than the manifest holds, so @alreadyUpToDate@+    -- different shared-write mode than the manifest holds, so @alreadyUpToDate@     -- does not claim otherwise.     isUnchanged (FileUnchanged desired _ _ prior) =-      maybe True (\record -> record ^. #additiveOnly == desired ^. #additiveOnly) prior+      maybe True (\record -> record ^. #sharedWriteMode == recordedSharedWriteMode (plan ^. #reconciliation . #applicationIds) desired prior) prior     isUnchanged _ = False  count :: Int -> Text

@@ -1,7 +1,11 @@ module Seihou.CLI.Update.Selection-  ( SelectedApplications (..),+  ( MatchedApplications (..),     SelectionPolicy (..),-    selectApplications,+    ClosureOutcome (..),+    matchApplications,+    enforceOwnershipClosure,+    applicationsWithIds,+    applicationRef,     targetName,     availableTargets,   )@@ -9,15 +13,24 @@  import Control.Monad (foldM) import Data.Generics.Labels ()+import Data.List (find) 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+-- | Which recorded applications a request names, before the ownership+-- closure is consulted.+data MatchedApplications+  = -- | Every recorded application, in manifest order. Selecting all of them+    --   satisfies every closure by construction.+    MatchedAll [AppliedComposition]+  | -- | The ids a named selection matched. The closure has not been+    --   enforced yet, so this is not yet what will be updated.+    MatchedNamed (Set ApplicationId)+  | -- | A manifest with no recorded applications, seeded from one target.+    MatchedLegacy Text   deriving stock (Eq, Show)  -- | What to do when a named selection does not satisfy the ownership closure.@@ -30,36 +43,37 @@     IncludeSharedOwners   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.+-- | The result of enforcing the ownership closure on a named selection.+data ClosureOutcome+  = -- | The selection, possibly expanded, is safe to update, with a warning+    --   for every application the expansion added.+    ClosureSatisfied (Set ApplicationId) [UpdateWarning]+  | -- | No known closure requirement is violated, but these paths intersect+    --   the selection, leave an owner out, and record 'SharedWriteUnknown'.+    --   Their modes must be certified before the closure can be decided;+    --   selecting more applications would not supply them. The selection and+    --   warnings are those reached so far.+    ClosureNeedsEvidence (Set ApplicationId) [UpdateWarning] [FilePath]+  deriving stock (Eq, Show)++-- | Phase one: find the applications a request names, in manifest order.+-- Bare module names select every recorded application containing that+-- module instance; target names take precedence for each requested name. ----- Returns the warnings the selection produced, which under--- 'IncludeSharedOwners' name every application the expansion added and the--- path it was added for.-selectApplications ::-  SelectionPolicy ->-  UpdateSelection ->-  Manifest ->-  Either UpdateError (SelectedApplications, [UpdateWarning])-selectApplications policy selection manifest = case selection of+-- This never consults shared ownership. Matching has to come first because+-- which paths' evidence matters depends on what was selected.+matchApplications :: UpdateSelection -> Manifest -> Either UpdateError MatchedApplications+matchApplications selection manifest = case selection of   AllRecordedApplications     | null (manifest ^. #applications) -> Left NoRecordedApplications-    | otherwise -> Right (RecordedSelection (manifest ^. #applications), [])+    | otherwise -> Right (MatchedAll (manifest ^. #applications))   NamedUpdateTargets names     -- A manifest with no recorded applications has no ownership to close     -- over, so the policy cannot apply.     | null (manifest ^. #applications) -> case nubOrd names of-        [name] -> Right (LegacySelection name, [])+        [name] -> Right (MatchedLegacy name)         _ -> Left LegacyUpdateRequiresOneTarget-    | otherwise -> do-        namedIds <- foldM selectName Set.empty (nubOrd names)-        let (selectedIds, warnings) = case policy of-              RequireNamedOwners -> (namedIds, [])-              IncludeSharedOwners -> expandToSharedOwners manifest namedIds-            selected = filter ((`Set.member` selectedIds) . (^. #applicationId)) (manifest ^. #applications)-        ensureOwnershipClosure manifest selectedIds-        Right (RecordedSelection selected, warnings)+    | otherwise -> MatchedNamed <$> foldM selectName Set.empty (nubOrd names)   where     selectName selected name =       let exact = filter ((== name) . targetName) (manifest ^. #applications)@@ -71,61 +85,120 @@             then Left (UpdateTargetNotFound name (availableTargets manifest))             else Right (foldl' (flip (Set.insert . (^. #applicationId))) selected matches) --- | Grow the selection until it satisfies the ownership closure.+-- | Phase two: decide whether a named selection may be updated as it+-- stands. ----- For every managed path that is /not/ additive-only and whose owners--- intersect the selection, add all of that path's owners. This has to iterate--- to a fixed point rather than run once: an application pulled in through one--- path may co-own a different path with a third application, which then has--- to come along too.+-- Every managed path whose owners intersect the selection and leave an+-- owner out is judged by its recorded 'SharedWriteMode': ----- Additive-only paths are skipped, because they no longer require the--- closure; expanding for them would update applications the user did not ask--- for and did not need.+-- * 'SharedWriteAdditiveOnly' paths pass. Every owner reaches the path+--   through an additive, non-overlapping patch, so reconciling one of them+--   provably cannot disturb another.+-- * 'SharedWriteRequiresOwnershipClosure' paths refuse with+--   'SharedPathRequiresApplications', or under 'IncludeSharedOwners' pull+--   the missing owners in, iterating to a fixed point because an added+--   application may co-own another path with a third.+-- * 'SharedWriteUnknown' paths are neither: the answer has not been+--   established, so the result is 'ClosureNeedsEvidence'. Expansion is never+--   used for them, because updating whole applications does not supply a+--   missing fact.+--+-- A known refusal is reported before a request for evidence, since+-- certifying other paths could not lift it.+--+-- This is the preflight and uses only the manifest;+-- 'Seihou.Engine.Reconcile.validateOwner' checks the candidate's own+-- operations later. See+-- docs/adr/0012-an-additive-co-write-is-not-a-shared-path-conflict.md.+enforceOwnershipClosure ::+  SelectionPolicy ->+  Manifest ->+  Set ApplicationId ->+  Either UpdateError ClosureOutcome+enforceOwnershipClosure policy manifest named =+  case (closureViolations SharedWriteRequiresOwnershipClosure, closureViolations SharedWriteUnknown) of+    ((path, selectedOwners, missingOwners) : _, _) ->+      Left+        ( SharedPathRequiresApplications+            path+            (Set.map (applicationRef manifest) selectedOwners)+            (Set.map (applicationRef manifest) missingOwners)+        )+    ([], []) -> Right (ClosureSatisfied selected warnings)+    ([], unknown) -> Right (ClosureNeedsEvidence selected warnings [path | (path, _, _) <- unknown])+  where+    (selected, warnings) = case policy of+      RequireNamedOwners -> (named, [])+      IncludeSharedOwners -> expandToSharedOwners manifest named++    closureViolations mode =+      [ (path, selectedOwners, missingOwners)+      | (path, record) <- Map.toAscList (manifest ^. #files),+        record ^. #sharedWriteMode == mode,+        let selectedOwners = Set.intersection selected (record ^. #applicationIds),+        let missingOwners = (record ^. #applicationIds) Set.\\ selected,+        not (Set.null selectedOwners),+        not (Set.null missingOwners)+      ]++-- | Grow the selection until no path /known/ to require the closure leaves+-- an owner out.+--+-- For every managed path recorded 'SharedWriteRequiresOwnershipClosure'+-- whose owners intersect the selection, add all of that path's owners, to a+-- fixed point: an application pulled in through one path may co-own a+-- different path with a third application, which then has to come along too.+--+-- Additive-only paths are skipped because they do not require the closure,+-- and unknown paths because their answer is missing rather than known to+-- require it. expandToSharedOwners :: Manifest -> Set ApplicationId -> (Set ApplicationId, [UpdateWarning]) expandToSharedOwners manifest = go []   where     go warnings selected =       case [ (path, owner)            | (path, record) <- Map.toAscList (manifest ^. #files),-             not (record ^. #additiveOnly),+             record ^. #sharedWriteMode == SharedWriteRequiresOwnershipClosure,              not (Set.null (Set.intersection selected (record ^. #applicationIds))),              owner <- Set.toAscList ((record ^. #applicationIds) Set.\\ selected)            ] of         [] -> (selected, reverse warnings)         additions ->           go-            ([SelectionExpandedForSharedPath path owner | (path, owner) <- additions] <> warnings)+            ([SelectionExpandedForSharedPath path (applicationRef manifest owner) | (path, owner) <- additions] <> warnings)             (Set.union selected (Set.fromList (map snd additions))) --- | For every managed path a selected application owns, require that every--- other owner is selected too — because regenerating a file normally means--- rewriting all of it, which would discard an unselected owner's content.------ A path whose manifest record says @additiveOnly@ is exempt: every owner--- reaches it through an additive, non-overlapping patch, so reconciling one--- of them provably cannot disturb another. This is the preflight, and it runs--- before any candidate artifact is fetched, so the manifest is the only--- evidence available here; 'Seihou.Engine.Reconcile.validateOwner' checks the--- candidate's own operations later, once they are known.------ A @False@ cannot distinguish "an owner writes the whole file" from "this--- manifest predates the field", so the refusal message names both.------ See docs/adr/0012-an-additive-co-write-is-not-a-shared-path-conflict.md.-ensureOwnershipClosure :: Manifest -> Set ApplicationId -> Either UpdateError ()-ensureOwnershipClosure manifest selected =-  case [ (path, selectedOwners, missingOwners)-       | (path, record) <- Map.toAscList (manifest ^. #files),-         not (record ^. #additiveOnly),-         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 ()+-- | The recorded applications with these ids, in manifest order.+applicationsWithIds :: Manifest -> Set ApplicationId -> [AppliedComposition]+applicationsWithIds manifest ids =+  filter ((`Set.member` ids) . (^. #applicationId)) (manifest ^. #applications)++-- | A renderer-neutral reference to an application id, carrying the+-- recorded target and its root instance's parent variables when the+-- manifest records the application.+applicationRef :: Manifest -> ApplicationId -> ApplicationRef+applicationRef manifest applicationId =+  case find ((== applicationId) . (^. #applicationId)) (manifest ^. #applications) of+    Nothing -> ApplicationRef applicationId Nothing emptyParentVars []+    Just application ->+      ApplicationRef+        { applicationId,+          target = Just (application ^. #target),+          parentVars = maybe emptyParentVars (^. #parentVars) (rootInstance application),+          additionalModules = application ^. #additionalModules+        }++-- | The instance a composition was applied for: the one named after a+-- module target, or the last instance, which composition order puts after+-- its dependencies.+rootInstance :: AppliedComposition -> Maybe AppliedInstanceState+rootInstance application = case application ^. #target of+  AppliedModuleTarget name+    | Just state <- find ((== name) . (^. #name)) (reverse (application ^. #instances)) -> Just state+  _ -> lastMaybe (application ^. #instances)+  where+    lastMaybe [] = Nothing+    lastMaybe states = Just (last states)  targetName :: AppliedComposition -> Text targetName application = case application ^. #target of

@@ -10,6 +10,8 @@     PlannedUpdateMigration (..),     PlannedApplication (..),     UpdateSnapshot (..),+    ApplicationRef (..),+    ManifestPreparation (..),     UpdateWarning (..),     UpdatePlan (..),     CommandSummary (..),@@ -25,8 +27,10 @@     CommandPlan,     CommandPolicy,   )+import Seihou.CLI.ManifestCapabilityUpgrade (CertificationGap, EvidenceSource) import Seihou.Composition.Instance (ModuleInstance) import Seihou.Core.ArtifactRef (ArtifactRefError)+import Seihou.Core.Checkout (CheckoutError, CheckoutPlan) import Seihou.Core.Migration (MigrationPlan, MigrationPlanError) import Seihou.Core.Types import Seihou.Engine.Migrate (ExecutedMigrationPlan, MigrationExecError)@@ -148,6 +152,41 @@   }   deriving stock (Eq, Generic, Show) +-- | A renderer-neutral reference to one recorded application: enough for a+-- renderer to label it without ever showing only an opaque digest.+data ApplicationRef = ApplicationRef+  { applicationId :: !ApplicationId,+    -- | The recorded root target, or 'Nothing' when a file record names an+    -- owner the manifest does not record as an application.+    target :: !(Maybe AppliedTarget),+    -- | The parent variables of the target's root instance.+    parentVars :: !ParentVars,+    -- | The modules applied alongside the target. Together with the target+    -- they are the whole of the application id, so a label built from both+    -- is unique among recorded applications.+    additionalModules :: ![ModuleName]+  }+  deriving stock (Eq, Ord, Show, Generic)++-- | The lossless manifest change a targeted update stages in memory before+-- it enforces the ownership closure: the schema step the feature requires+-- (docs/adr/0014-every-semantic-manifest-change-advances-the-schema-version.md)+-- and every shared-write mode certification established. It is published+-- only with the update's own manifest, never as a separate write.+data ManifestPreparation = ManifestPreparation+  { fromVersion :: !ManifestSchemaVersion,+    toVersion :: !ManifestSchemaVersion,+    -- | Each certified path with its mode before and after.+    modeChanges :: !(Map FilePath (SharedWriteMode, SharedWriteMode)),+    -- | The recorded releases fetched from their remotes to certify those+    -- modes, because no installed copy was the recorded version.+    evidenceSources :: ![EvidenceSource],+    -- | The manifest planning, migration, reconciliation, and the final+    -- manifest build start from instead of the on-disk one.+    preparedManifest :: !Manifest+  }+  deriving stock (Eq, Generic, Show)+ data UpdateWarning   = LocalArtifactHasNoRemote Text   | SameVersionContentChanged Text@@ -158,9 +197,10 @@   | ArbitraryCommandSideEffectsMayRemain   | BaselinePruneFailed Text   | RecoveryCleanupDeferred Text+  | CheckoutWarning Text   | -- | @--include-shared-owners@ added this application to the selection     --   because it co-owns the named path with something the user asked for.-    SelectionExpandedForSharedPath FilePath ApplicationId+    SelectionExpandedForSharedPath FilePath ApplicationRef   deriving stock (Eq, Show)  data UpdatePlan = UpdatePlan@@ -169,12 +209,15 @@     inputChanges :: !InputChangeSummary,     migrations :: ![PlannedUpdateMigration],     reconciliation :: !ReconciliationPlan,+    checkoutPlan :: !CheckoutPlan,+    checkoutOutputs :: !(Map FilePath CheckoutOutputRecord),     commandPlan :: !CommandPlan,     candidateArtifacts :: ![CandidateArtifact],     warnings :: ![UpdateWarning],     request :: !UpdateRequest,     snapshot :: !UpdateSnapshot,-    plannedApplications :: ![PlannedApplication]+    plannedApplications :: ![PlannedApplication],+    manifestPreparation :: !(Maybe ManifestPreparation)   }   deriving stock (Eq, Generic, Show) @@ -199,10 +242,21 @@ data UpdateError   = UpdateManifestMissing FilePath   | UpdateManifestUnreadable FilePath Text+  | -- | The manifest is at a schema older than the ordinary decoder reads.+    -- Converting it recovers artifact origins from machine-local paths,+    -- which is inference and so only @seihou manifest upgrade@ may do it+    -- (docs/adr/0005-legacy-manifests-convert-through-an-explicit-command.md).+    UpdateManifestUpgradeRequired FilePath ManifestSchemaVersion   | NoRecordedApplications   | LegacyUpdateRequiresOneTarget   | UpdateTargetNotFound Text [Text]-  | SharedPathRequiresApplications FilePath (Set ApplicationId) (Set ApplicationId)+  | -- | The path is known to require the ownership closure: selected+    -- owners, then the owners missing from the selection.+    SharedPathRequiresApplications FilePath (Set ApplicationRef) (Set ApplicationRef)+  | -- | Nothing records how the path's owners write it, and certification+    -- could not establish it: each owner whose evidence is missing, with why.+    -- Selecting more applications would not supply the missing fact.+    SharedWriteEvidenceUnavailable FilePath [(ApplicationRef, CertificationGap)]   | CandidateCloneFailed Text Text   | CandidateRepositoryInvalid Text [Text]   | CandidateArtifactMissing CandidateArtifactKind Text@@ -219,6 +273,7 @@   | UpdateMigrationPlanFailed ModuleName MigrationPlanError   | UpdateMigrationStageFailed ModuleName MigrationExecError   | UpdateCompositionFailed [Text]+  | UpdateCheckoutFailed CheckoutError   | UpdateReconciliationFailed ReconciliationError   | UpdateHasUnresolvedPaths (Set FilePath)   | UpdateRecoveryFailed [TransactionError]

@@ -0,0 +1,989 @@+-- | What stands between a project and a plain @seihou update MODULE@?+--+-- @seihou agent upgrade@ answers that question before it hands a project to+-- a coding agent, and @seihou agent upgrade MODULE --check@ answers it again+-- as the definition of done. This module is the answer: a set of guarded,+-- read-only probes ('diagnoseUpgrade'), the readiness checks computed from+-- them ('readiness'), and the pure renderers for the upgrade brief and the+-- readiness report.+--+-- Two properties matter more than any single probe:+--+-- * Diagnosis never throws. Every probe runs under 'guarded' (or+--   'guardedWithin' when it can block on the network), so a missing+--   manifest, a corrupt one, or a bug in a probe becomes a finding rather+--   than an exception.+-- * Diagnosis writes nothing under the project, the install cache, or the+--   manifest. Planning an update would roll back an interrupted transaction+--   before planning, so the update probe is skipped whenever one is+--   pending; the agent performs that recovery in the open.+--+-- See docs/adr/0016-agent-assisted-upgrade-diagnoses-read-only-and-never-fails.md.+module Seihou.CLI.UpgradeDiagnosis+  ( -- * Diagnosis+    DiagnosisEnv (..),+    diagnosisEnvFor,+    Probe (..),+    ManifestState (..),+    TargetState (..),+    InstalledCopy (..),+    SharedUnknownPath (..),+    LocalOriginRecord (..),+    UpdateProbe (..),+    GitState (..),+    UpgradeDiagnosis (..),+    diagnoseUpgrade,+    emptyDiagnosis,++    -- * Readiness+    ReadinessStatus (..),+    ReadinessCheck (..),+    readiness,+    isReady,+    renderReadinessReport,++    -- * The upgrade brief+    briefSections,+    BriefLocation (..),+    createBriefDirectory,+    writeBrief,+  )+where++import Control.Concurrent (forkIO, killThread)+import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)+import Control.Exception (SomeException, displayException, evaluate, try)+import Data.Aeson qualified as Aeson+import Data.ByteString.Lazy qualified as LBS+import Data.Char (isAlphaNum, toUpper)+import Data.Generics.Labels ()+import Data.List (nub)+import Data.Map.Strict qualified as Map+import Data.Maybe (mapMaybe)+import Data.Set qualified as Set+import Data.Text qualified as T+import Data.Text.IO qualified as TIO+import Data.Time (defaultTimeLocale, formatTime, getCurrentTime)+import Seihou.CLI.ApplicationDisplay (applicationLabel)+import Seihou.CLI.CommandExecution (CommandPolicy (..))+import Seihou.CLI.ManifestGuard (ArtifactCheck (..), blockingChecks, checkAppliedArtifactsFor, localModuleVersion, summarizeCheck)+import Seihou.CLI.ManifestRepairOrigins (OriginSite (..), localOriginUrls)+import Seihou.CLI.ManifestUpgrade (ManifestUpgradeOpts (..), renderUpgradeOutcome, runManifestUpgrade)+import Seihou.CLI.Update (PromptPolicy (..), UpdateRequest (..), UpdateSelection (..), isUpdateNoOp, withProjectUpdate)+import Seihou.CLI.Update.Recovery (pendingUpdateRecovery)+import Seihou.CLI.Update.Render (agentUpgradeHint, errorCode, errorOutputFor, planOutput, renderUpdateHuman)+import Seihou.CLI.Update.Selection (MatchedApplications (..), applicationRef, matchApplications)+import Seihou.CLI.Update.Types (ApplicationRef (..), VersionChange (..))+import Seihou.Core.ArtifactRef (resolveArtifactOrigin)+import Seihou.Core.Types+import Seihou.Manifest.JSON (decodeManifestValue)+import Seihou.Manifest.Types (currentManifestVersion, manifestFromJSON, oldestDecodableManifestVersion)+import Seihou.Manifest.Upgrade (documentSchemaVersion, renderManifestUpgradeError)+import Seihou.Prelude+import System.Directory qualified as Directory+import System.Exit (ExitCode (..))+import System.FilePath (takeDirectory)+import System.Process (readProcessWithExitCode)+import System.Timeout (timeout)++-- ----------------------------------------------------------------------------+-- Diagnosis+-- ----------------------------------------------------------------------------++-- | Where and how to diagnose. Search paths are passed in rather than read+-- from the environment inside a probe, so a test can point them at a+-- fixture.+data DiagnosisEnv = DiagnosisEnv+  { projectRoot :: !FilePath,+    searchPaths :: ![FilePath],+    -- | Upper bound for each probe that can reach the network, in seconds+    -- (180 in production).+    updateTimeoutSeconds :: !Int+  }+  deriving stock (Eq, Show, Generic)++-- | The production environment for a project root: the same search paths+-- 'Seihou.Core.Module.defaultSearchPaths' builds for that directory.+diagnosisEnvFor :: FilePath -> IO DiagnosisEnv+diagnosisEnvFor root = do+  xdgConfig <- Directory.getXdgDirectory Directory.XdgConfig "seihou"+  pure+    DiagnosisEnv+      { projectRoot = root,+        searchPaths =+          [ root </> ".seihou" </> "modules",+            xdgConfig </> "modules",+            xdgConfig </> "installed"+          ],+        updateTimeoutSeconds = 180+      }++-- | The outcome of one guarded probe. Never an exception.+data Probe a+  = ProbeOk !a+  | -- | The probe was not run; the reason says why.+    ProbeSkipped !Text+  | -- | The probe raised an exception; the text says which probe and what.+    ProbeFailed !Text+  | -- | The probe did not finish within this many seconds.+    ProbeTimedOut !Int+  deriving stock (Eq, Show, Generic, Functor)++data ManifestState+  = ManifestAbsent+  | ManifestNotJson !Text+  | -- | Parsed as JSON, has this schema, did not decode (for example schema 5).+    ManifestUndecodable !ManifestSchemaVersion !Text+  | -- | Parsed as JSON, but its schema version could not be read.+    ManifestSchemaUnreadable !Text+  | ManifestDecoded !ManifestSchemaVersion !Manifest+  deriving stock (Eq, Show, Generic)++data TargetState+  = -- | The matched applications, and each recorded version of the target+    -- module as @name version@.+    TargetMatched ![ApplicationRef] ![Text]+  | -- | The targets the manifest does record.+    TargetNotFound ![Text]+  | -- | The manifest records no applications: the legacy shape one+    -- targeted update seeds.+    TargetLegacyManifest+  deriving stock (Eq, Show, Generic)++-- | The installed copy of one module the upgrade concerns.+data InstalledCopy = InstalledCopy+  { name :: !Text,+    -- | Where the recorded origin resolves on this machine, if anywhere.+    directory :: !(Maybe FilePath),+    -- | The version the installed @module.dhall@ declares.+    version :: !(Maybe Text),+    -- | The version the manifest records.+    recordedVersion :: !(Maybe Text)+  }+  deriving stock (Eq, Show, Generic)++-- | A managed path the target shares with an application outside it, whose+-- shared-write mode nothing records.+data SharedUnknownPath = SharedUnknownPath+  { path :: !FilePath,+    otherOwners :: ![ApplicationRef]+  }+  deriving stock (Eq, Show, Generic)++-- | One origin URL recorded as a path on the machine that wrote it, with+-- the artifacts recorded under it.+data LocalOriginRecord = LocalOriginRecord+  { url :: !Text,+    artifacts :: ![Text]+  }+  deriving stock (Eq, Show, Generic)++-- | What @seihou update TARGET --dry-run@ said.+data UpdateProbe = UpdateProbe+  { errorCode :: !(Maybe Text),+    noOp :: !Bool,+    -- | One line naming the version changes, for the readiness report.+    headline :: !Text,+    -- | The human rendering, exactly as @seihou update@ prints it.+    rendered :: !Text+  }+  deriving stock (Eq, Show, Generic)++data GitState = GitState+  { isRepository :: !Bool,+    dirtyPaths :: ![Text]+  }+  deriving stock (Eq, Show, Generic)++data UpgradeDiagnosis = UpgradeDiagnosis+  { target :: !Text,+    projectRoot :: !FilePath,+    manifest :: !(Probe ManifestState),+    pendingRecovery :: !(Probe Bool),+    targetState :: !(Probe TargetState),+    installedCopies :: !(Probe [InstalledCopy]),+    installedChecks :: !(Probe [ArtifactCheck]),+    unknownSharedPaths :: !(Probe [SharedUnknownPath]),+    -- | Project-wide count of paths with more than one owner and an unknown+    -- shared-write mode, as context.+    projectUnknownCount :: !(Probe Int),+    localOrigins :: !(Probe [LocalOriginRecord]),+    -- | @seihou manifest upgrade --dry-run@, rendered as the command prints it.+    manifestUpgrade :: !(Probe Text),+    updateDryRun :: !(Probe UpdateProbe),+    git :: !(Probe GitState)+  }+  deriving stock (Eq, Show, Generic)++-- | A diagnosis in which nothing ran, for a caller whose diagnosis escaped+-- with an exception despite every guard.+emptyDiagnosis :: FilePath -> Text -> Text -> UpgradeDiagnosis+emptyDiagnosis root target reason =+  UpgradeDiagnosis+    { target,+      projectRoot = root,+      manifest = ProbeFailed reason,+      pendingRecovery = skipped,+      targetState = skipped,+      installedCopies = skipped,+      installedChecks = skipped,+      unknownSharedPaths = skipped,+      projectUnknownCount = skipped,+      localOrigins = skipped,+      manifestUpgrade = skipped,+      updateDryRun = skipped,+      git = skipped+    }+  where+    skipped = ProbeSkipped "the diagnosis did not run"++-- | Diagnose a project for upgrading one module. Never throws, and writes+-- nothing under the project, the install cache, or the manifest.+diagnoseUpgrade :: DiagnosisEnv -> Text -> IO UpgradeDiagnosis+diagnoseUpgrade env target = do+  let root = env ^. #projectRoot+      seconds = env ^. #updateTimeoutSeconds+  manifestProbe <- guarded "reading the manifest" (probeManifest root)+  pending <- guarded "looking for an interrupted update" (pendingUpdateRecovery root)+  let decoded = case manifestProbe of+        ProbeOk (ManifestDecoded _ recorded) -> Just recorded+        _ -> Nothing+      needsManifest :: Probe a+      needsManifest = ProbeSkipped "the manifest could not be decoded"+      fromManifest :: Text -> (Manifest -> IO a) -> IO (Probe a)+      fromManifest label action = maybe (pure needsManifest) (guarded label . action) decoded+  targetProbe <- fromManifest "matching the target" (pure . matchTarget target)+  let matchedIds = case (decoded, targetProbe) of+        (Just recorded, ProbeOk TargetMatched {}) -> matchedApplicationIds target recorded+        _ -> Set.empty+      concernedModules recorded = targetModules target recorded matchedIds+  copies <- fromManifest "locating the installed copy" $ \recorded ->+    traverse (installedCopy root (env ^. #searchPaths)) (targetAppliedModules (concernedModules recorded) recorded)+  checks <- fromManifest "checking the installed copy" $ \recorded ->+    checkAppliedArtifactsFor root (env ^. #searchPaths) (Just (concernedModules recorded)) recorded+  unknown <- fromManifest "reading shared-write evidence" (pure . sharedUnknownPaths matchedIds)+  unknownCount <- fromManifest "counting unknown shared paths" (pure . projectUnknownPaths)+  locals <- fromManifest "reading recorded origins" (pure . machineLocalOrigins)+  upgradeProbe <- case manifestProbe of+    ProbeOk ManifestAbsent -> pure (ProbeSkipped "there is no manifest")+    ProbeOk (ManifestNotJson _) -> pure (ProbeSkipped "the manifest is not valid JSON")+    _ ->+      guardedWithin "seihou manifest upgrade --dry-run" seconds $+        Directory.withCurrentDirectory root $ do+          outcome <- runManifestUpgrade ManifestUpgradeOpts {dryRun = True, force = False, targetVersion = Nothing}+          let rendered = renderUpgradeOutcome outcome+          _ <- evaluate (T.length rendered)+          pure rendered+  updateProbe <- case (pending, decoded) of+    (ProbeOk True, _) ->+      pure (ProbeSkipped "an interrupted update is waiting to be recovered, and planning an update would recover it")+    (ProbeOk False, Just _) -> guardedWithin ("seihou update " <> target <> " --dry-run") seconds (probeUpdate root target)+    (ProbeOk False, Nothing) -> pure needsManifest+    _ -> pure (ProbeSkipped "whether an interrupted update is waiting could not be determined")+  gitProbe <- guarded "reading git state" (probeGit root)+  pure+    UpgradeDiagnosis+      { target,+        projectRoot = root,+        manifest = manifestProbe,+        pendingRecovery = pending,+        targetState = targetProbe,+        installedCopies = copies,+        installedChecks = checks,+        unknownSharedPaths = unknown,+        projectUnknownCount = unknownCount,+        localOrigins = locals,+        manifestUpgrade = upgradeProbe,+        updateDryRun = updateProbe,+        git = gitProbe+      }++-- | Run a probe, turning any exception into 'ProbeFailed'.+guarded :: Text -> IO a -> IO (Probe a)+guarded label action = do+  result <- try @SomeException (action >>= evaluate)+  pure $ case result of+    Left err -> ProbeFailed (failureText label err)+    Right value -> ProbeOk value++-- | 'guarded', bounded in time. The probe runs on its own thread and is+-- abandoned (and sent a kill) when the deadline passes. The deadline is+-- enforced by waiting on the result rather than by interrupting the probe,+-- because the update planner catches every exception in places, which would+-- swallow an interrupting timeout and report it as a planning error.+guardedWithin :: Text -> Int -> IO a -> IO (Probe a)+guardedWithin label seconds action = do+  box <- newEmptyMVar+  worker <- forkIO (try @SomeException (action >>= evaluate) >>= putMVar box)+  outcome <- timeout (seconds * 1000000) (takeMVar box)+  case outcome of+    Nothing -> do+      _ <- forkIO (killThread worker)+      pure (ProbeTimedOut seconds)+    Just (Left err) -> pure (ProbeFailed (failureText label err))+    Just (Right value) -> pure (ProbeOk value)++failureText :: Text -> SomeException -> Text+failureText label err = label <> " failed: " <> T.strip (T.pack (displayException err))++probeManifest :: FilePath -> IO ManifestState+probeManifest root = do+  let path = root </> ".seihou" </> "manifest.json"+  present <- Directory.doesFileExist path+  if not present+    then pure ManifestAbsent+    else do+      bytes <- LBS.readFile path+      pure $ case decodeManifestValue bytes of+        Left err -> ManifestNotJson (T.pack err)+        Right document -> case documentSchemaVersion document of+          Left err -> ManifestSchemaUnreadable (renderManifestUpgradeError err)+          Right schema -> case manifestFromJSON bytes of+            Left err -> ManifestUndecodable schema (T.pack err)+            Right recorded -> ManifestDecoded schema recorded++matchTarget :: Text -> Manifest -> TargetState+matchTarget target recorded =+  case matchApplications (NamedUpdateTargets [target]) recorded of+    Right (MatchedNamed ids) ->+      TargetMatched+        (map (applicationRef recorded) (Set.toAscList ids))+        (nub [nameAndVersion applied | applied <- recorded ^. #modules, applied ^. #name . #unModuleName == target])+    Right (MatchedLegacy _) -> TargetLegacyManifest+    Right (MatchedAll _) -> TargetLegacyManifest+    Left _ -> TargetNotFound (availableTargetsOf recorded)+  where+    nameAndVersion applied =+      applied ^. #name . #unModuleName <> " " <> maybe "(no recorded version)" id (applied ^. #moduleVersion)++availableTargetsOf :: Manifest -> [Text]+availableTargetsOf recorded =+  nub+    ( [targetText (application ^. #target) | application <- recorded ^. #applications]+        <> [state ^. #name . #unModuleName | application <- recorded ^. #applications, state <- application ^. #instances]+    )+  where+    targetText (AppliedModuleTarget name) = name ^. #unModuleName+    targetText (AppliedRecipeTarget name) = name ^. #unRecipeName++matchedApplicationIds :: Text -> Manifest -> Set ApplicationId+matchedApplicationIds target recorded =+  case matchApplications (NamedUpdateTargets [target]) recorded of+    Right (MatchedNamed ids) -> ids+    _ -> Set.empty++-- | The modules an upgrade of the target concerns: the target itself, and+-- every module instance of the applications it matched (a recipe target+-- names no module of its own).+targetModules :: Text -> Manifest -> Set ApplicationId -> Set ModuleName+targetModules target recorded ids =+  Set.insert+    (ModuleName target)+    ( Set.fromList+        [ state ^. #name+        | application <- recorded ^. #applications,+          Set.member (application ^. #applicationId) ids,+          state <- application ^. #instances+        ]+    )++targetAppliedModules :: Set ModuleName -> Manifest -> [AppliedModule]+targetAppliedModules names recorded =+  dedupe [applied | applied <- recorded ^. #modules, Set.member (applied ^. #name) names]+  where+    dedupe = go Set.empty+    go _ [] = []+    go seen (applied : rest)+      | Set.member (applied ^. #name) seen = go seen rest+      | otherwise = applied : go (Set.insert (applied ^. #name) seen) rest++installedCopy :: FilePath -> [FilePath] -> AppliedModule -> IO InstalledCopy+installedCopy root paths applied = do+  resolved <- resolveArtifactOrigin root paths "module.dhall" (applied ^. #origin)+  case resolved of+    Left _ -> pure (copy Nothing Nothing)+    Right directory -> copy (Just directory) <$> localModuleVersion directory+  where+    copy directory version =+      InstalledCopy+        { name = applied ^. #name . #unModuleName,+          directory,+          version,+          recordedVersion = applied ^. #moduleVersion+        }++sharedUnknownPaths :: Set ApplicationId -> Manifest -> [SharedUnknownPath]+sharedUnknownPaths selected recorded =+  [ SharedUnknownPath path (map (applicationRef recorded) (Set.toAscList others))+  | (path, record) <- Map.toAscList (recorded ^. #files),+    record ^. #sharedWriteMode == SharedWriteUnknown,+    let owners = record ^. #applicationIds,+    not (Set.null (Set.intersection owners selected)),+    let others = owners Set.\\ selected,+    not (Set.null others)+  ]++projectUnknownPaths :: Manifest -> Int+projectUnknownPaths recorded =+  length+    [ ()+    | record <- Map.elems (recorded ^. #files),+      record ^. #sharedWriteMode == SharedWriteUnknown,+      Set.size (record ^. #applicationIds) > 1+    ]++machineLocalOrigins :: Manifest -> [LocalOriginRecord]+machineLocalOrigins recorded =+  [ LocalOriginRecord recordedUrl (nub (map (^. #artifactName) sites))+  | (_, sites@(site : _)) <- Map.toAscList (localOriginUrls recorded),+    let recordedUrl = site ^. #recordedUrl+  ]++probeUpdate :: FilePath -> Text -> IO UpdateProbe+probeUpdate root target =+  Directory.withCurrentDirectory root $+    withProjectUpdate request $ \result -> do+      let probe = case result of+            Left err ->+              UpdateProbe+                { errorCode = Just (errorCode err),+                  noOp = False,+                  headline = "",+                  -- The brief is already the agent path, so the hint+                  -- pointing at it is dropped.+                  rendered =+                    T.replace+                      (agentUpgradeHint (Just target))+                      ""+                      (renderUpdateHuman False (errorOutputFor [target] err))+                }+            Right plan ->+              UpdateProbe+                { errorCode = Nothing,+                  noOp = isUpdateNoOp plan,+                  headline = versionHeadline (plan ^. #versionChanges),+                  rendered =+                    if isUpdateNoOp plan+                      then "Already up to date.\n"+                      else renderUpdateHuman False (planOutput plan)+                }+      _ <- evaluate (T.length (probe ^. #rendered) + T.length (probe ^. #headline))+      pure probe+  where+    request =+      UpdateRequest+        { selection = NamedUpdateTargets [target],+          varOverrides = [],+          reconfigure = False,+          promptPolicy = ForbidPrompts,+          commandPolicy = RunChangedCommands,+          dryRun = True,+          allowDowngrade = False,+          includeSharedOwners = False+        }++versionHeadline :: [VersionChange] -> Text+versionHeadline [] = "no version changes"+versionHeadline changes = T.intercalate ", " (map one changes)+  where+    one change =+      change ^. #name+        <> " "+        <> maybe "(none)" id (change ^. #fromVersion)+        <> " -> "+        <> maybe "(none)" id (change ^. #toVersion)++probeGit :: FilePath -> IO GitState+probeGit root = do+  (insideCode, insideOut, _) <- readProcessWithExitCode "git" ["-C", root, "rev-parse", "--is-inside-work-tree"] ""+  if insideCode /= ExitSuccess || T.strip (T.pack insideOut) /= "true"+    then pure GitState {isRepository = False, dirtyPaths = []}+    else do+      -- --no-optional-locks keeps status from refreshing the index, which is+      -- a write.+      (statusCode, statusOut, statusErr) <-+        readProcessWithExitCode "git" ["--no-optional-locks", "-C", root, "status", "--porcelain"] ""+      case statusCode of+        ExitSuccess -> pure GitState {isRepository = True, dirtyPaths = filter (not . T.null) (T.lines (T.pack statusOut))}+        ExitFailure _ -> ioError (userError ("git status failed: " <> statusErr))++-- ----------------------------------------------------------------------------+-- Readiness+-- ----------------------------------------------------------------------------++-- | A check's verdict. 'CouldNotDetermine' counts as needing attention: an+-- upgrade cannot be called ready on a question nobody answered.+data ReadinessStatus = Ready | NeedsAttention | CouldNotDetermine+  deriving stock (Eq, Show, Generic)++data ReadinessCheck = ReadinessCheck+  { -- | Stable, used in the report, e.g. @manifest-readable@.+    name :: !Text,+    status :: !ReadinessStatus,+    -- | One line: what was found, or for a failing check, what is wrong and+    -- how to repair it.+    detail :: !Text+  }+  deriving stock (Eq, Show, Generic)++-- | The checks behind a plain @seihou update TARGET@, in report order.+-- Git state is reported in the brief but is not a check: a dirty tree does+-- not make a future upgrade need an agent.+readiness :: UpgradeDiagnosis -> [ReadinessCheck]+readiness diagnosis =+  [ check "manifest-readable" manifestReadable,+    check "manifest-schema-current" schemaCurrent,+    check "no-interrupted-update" noInterruptedUpdate,+    check "target-recorded" targetRecorded,+    check "installed-copy-trusted" installedTrusted,+    check "origins-portable" originsPortable,+    check "shared-evidence-known" sharedEvidenceKnown,+    check "update-plans-cleanly" updatePlansCleanly+  ]+  where+    check checkName (checkStatus, checkDetail) = ReadinessCheck checkName checkStatus checkDetail+    ready = (Ready,)+    attention = (NeedsAttention,)+    unknown = (CouldNotDetermine,)+    target = diagnosis ^. #target+    manifestFile = ".seihou/manifest.json"++    manifestReadable = case diagnosis ^. #manifest of+      ProbeOk ManifestAbsent ->+        attention (manifestFile <> " does not exist; run this from the root of a seihou project")+      ProbeOk (ManifestNotJson err) -> attention (manifestFile <> " is not valid JSON: " <> firstLine err)+      ProbeOk (ManifestSchemaUnreadable err) -> attention (manifestFile <> ": " <> err)+      ProbeOk (ManifestUndecodable schema err)+        | schema < oldestDecodableManifestVersion ->+            attention (manifestFile <> " is schema " <> schemaText schema <> ", which only seihou manifest upgrade converts")+        | otherwise ->+            attention (manifestFile <> " is schema " <> schemaText schema <> " and does not decode: " <> firstLine err)+      ProbeOk (ManifestDecoded schema _) -> ready (manifestFile <> " is schema " <> schemaText schema <> " and decodes")+      other -> undetermined other++    schemaCurrent = case diagnosis ^. #manifest of+      ProbeOk (ManifestDecoded schema _) -> judgeSchema schema+      ProbeOk (ManifestUndecodable schema _) -> judgeSchema schema+      ProbeOk _ -> unknown "the manifest's schema could not be read"+      other -> undetermined other++    judgeSchema schema+      | schema == currentManifestVersion = ready ("schema " <> schemaText schema <> " is current")+      | schema > currentManifestVersion =+          attention+            ( "schema "+                <> schemaText schema+                <> " is newer than this seihou reads ("+                <> schemaText currentManifestVersion+                <> "); upgrade seihou"+            )+      | schema < oldestDecodableManifestVersion =+          attention+            ( "schema "+                <> schemaText schema+                <> " is older than "+                <> schemaText oldestDecodableManifestVersion+                <> "; run seihou manifest upgrade"+            )+      | otherwise =+          attention+            ( "schema "+                <> schemaText schema+                <> " is older than "+                <> schemaText currentManifestVersion+                <> "; seihou update steps it forward, or run seihou manifest upgrade"+            )++    noInterruptedUpdate = case diagnosis ^. #pendingRecovery of+      ProbeOk False -> ready "no update transaction is waiting to be recovered"+      ProbeOk True ->+        attention "an interrupted update is waiting under .seihou/transactions; run seihou update --dry-run once to recover it"+      other -> undetermined other++    targetRecorded = case diagnosis ^. #targetState of+      ProbeOk (TargetMatched refs _) -> ready (T.intercalate ", " (map applicationLabel refs))+      ProbeOk (TargetNotFound available) ->+        attention+          ( target+              <> " is not a recorded target"+              <> (if null available then "" else "; recorded targets: " <> T.intercalate ", " available)+          )+      ProbeOk TargetLegacyManifest ->+        attention ("the manifest records no applications; run seihou update " <> target <> " once to seed the record")+      other -> undetermined other++    installedTrusted = case (diagnosis ^. #targetState, diagnosis ^. #installedChecks) of+      (ProbeOk (TargetNotFound _), _) -> unknown (target <> " is not recorded, so there is no installed copy to check")+      (_, ProbeOk checks) -> case blockingChecks checks of+        [] -> ready (installedSummary (diagnosis ^. #installedCopies))+        blocking -> attention (T.intercalate "; " (mapMaybe summarizeCheck blocking))+      (_, other) -> undetermined other++    installedSummary = \case+      ProbeOk [] -> "no recorded module needs an installed copy"+      ProbeOk [copy] -> copyText copy <> " and matches the manifest's source"+      ProbeOk copies -> T.intercalate "; " (map copyText copies) <> "; each matches the manifest's source"+      _ -> "the installed copy matches the manifest's source"+      where+        copyText copy =+          "module " <> copy ^. #name <> maybe "" (" " <>) (copy ^. #version) <> " is installed"++    originsPortable = case diagnosis ^. #localOrigins of+      ProbeOk [] -> ready "every recorded origin is a remote URL or a project path"+      ProbeOk records ->+        attention+          ( T.intercalate "; " [record ^. #url <> " is recorded for " <> T.intercalate ", " (record ^. #artifacts) | record <- records]+              <> "; run seihou manifest repair-origins"+          )+      other -> undetermined other++    sharedEvidenceKnown = case diagnosis ^. #unknownSharedPaths of+      ProbeOk [] -> ready "no path shared with another application has an unknown write mode"+      ProbeOk paths ->+        attention+          ( T.intercalate+              "; "+              [ T.pack (shared ^. #path)+                  <> " is shared with "+                  <> T.intercalate ", " (map applicationLabel (shared ^. #otherOwners))+                  <> " and its write mode is unknown"+              | shared <- paths+              ]+          )+      other -> undetermined other++    updatePlansCleanly = case diagnosis ^. #updateDryRun of+      ProbeOk probe -> case probe ^. #errorCode of+        Just code ->+          attention ("seihou update " <> target <> " --dry-run failed [" <> code <> "]: " <> failureMessage (probe ^. #rendered))+        Nothing+          | probe ^. #noOp -> ready ("seihou update " <> target <> " --dry-run: already up to date")+          | otherwise -> ready ("seihou update " <> target <> " --dry-run: " <> probe ^. #headline)+      other -> undetermined other++    undetermined :: Probe a -> (ReadinessStatus, Text)+    undetermined probe = unknown (probeProblem probe)++-- | Why a probe produced no value, as one line.+probeProblem :: Probe a -> Text+probeProblem = \case+  ProbeOk _ -> "the probe succeeded"+  ProbeSkipped reason -> "not checked: " <> reason+  ProbeFailed reason -> firstLine reason+  ProbeTimedOut seconds -> "did not finish within " <> T.pack (show seconds) <> " seconds"++-- | The first line of an @Update failed [code]: message@ rendering, without+-- the lead-in.+failureMessage :: Text -> Text+failureMessage rendered =+  let line = firstLine rendered+      (_, rest) = T.breakOn "]: " line+   in if T.null rest then line else T.drop 3 rest++firstLine :: Text -> Text+firstLine text = case T.lines (T.strip text) of+  line : _ -> line+  [] -> ""++schemaText :: ManifestSchemaVersion -> Text+schemaText schema = T.pack (show (schema ^. #unManifestSchemaVersion))++isReady :: [ReadinessCheck] -> Bool+isReady = all ((== Ready) . (^. #status))++-- | The readiness report. Its last line is exactly @Upgrade readiness: ready@+-- or @Upgrade readiness: not ready (N check(s) need(s) attention)@, and it+-- uses no colour, so scripts can read it through a pipe.+renderReadinessReport :: Text -> [ReadinessCheck] -> Text+renderReadinessReport target checks =+  T.unlines $+    ["Upgrade readiness for " <> target]+      <> map line checks+      <> [verdict]+  where+    width = 2 + maximum (0 : map (T.length . (^. #name)) checks)+    line item = "  " <> mark (item ^. #status) <> " " <> T.justifyLeft width ' ' (item ^. #name) <> item ^. #detail+    mark = \case+      Ready -> "✓"+      NeedsAttention -> "✗"+      CouldNotDetermine -> "?"+    failing = length (filter ((/= Ready) . (^. #status)) checks)+    verdict+      | failing == 0 = "Upgrade readiness: ready"+      | failing == 1 = "Upgrade readiness: not ready (1 check needs attention)"+      | otherwise = "Upgrade readiness: not ready (" <> T.pack (show failing) <> " checks need attention)"++-- ----------------------------------------------------------------------------+-- The upgrade brief+-- ----------------------------------------------------------------------------++-- | Placeholder name/value pairs for the upgrade prompt template. Findings+-- from the caller (a configuration fallback, an escaped exception) are+-- rendered into @findings_section@ after the diagnosis' own.+briefSections :: UpgradeDiagnosis -> [Text] -> [(Text, Text)]+briefSections diagnosis callerFindings =+  [ ("module", diagnosis ^. #target),+    ("cwd", T.pack (diagnosis ^. #projectRoot)),+    ("diagnosis_summary", fenced (renderReadinessReport (diagnosis ^. #target) (readiness diagnosis))),+    ("manifest_section", manifestSection),+    ("target_section", targetSection),+    ("installed_section", installedSection),+    ("shared_evidence_section", sharedSection),+    ("manifest_upgrade_section", upgradeSection),+    ("update_dry_run_section", updateSection),+    ("git_section", gitSection),+    ("findings_section", findingsSection)+  ]+  where+    target = diagnosis ^. #target+    manifestFile = "`.seihou/manifest.json`"++    manifestSection = case diagnosis ^. #manifest of+      ProbeOk ManifestAbsent ->+        "There is no "+          <> manifestFile+          <> " here. Either this is not the root of a seihou project, or nothing has been generated\+             \ into it yet. Ask the user which project they meant before doing anything else."+      ProbeOk (ManifestNotJson err) ->+        manifestFile+          <> " exists but is not valid JSON ("+          <> firstLine err+          <> "). Nothing can repair that through seihou. Look at `git log -p -- .seihou/manifest.json`,\+             \ restore the last good version with the user's agreement, and diagnose again."+      ProbeOk (ManifestSchemaUnreadable err) ->+        manifestFile <> " is JSON, but its schema version cannot be read: " <> err <> "."+      ProbeOk (ManifestUndecodable schema err)+        | schema < oldestDecodableManifestVersion ->+            manifestFile+              <> " is at schema "+              <> schemaText schema+              <> ". This seihou reads schema "+              <> schemaText oldestDecodableManifestVersion+              <> " and newer, and only `seihou manifest upgrade` converts an older one, because the conversion\+                 \ infers artifact origins from paths on the machine that wrote it."+        | otherwise ->+            manifestFile <> " is at schema " <> schemaText schema <> " but does not decode: " <> firstLine err+      ProbeOk (ManifestDecoded schema recorded) ->+        manifestFile+          <> " is at schema "+          <> schemaText schema+          <> " (current is "+          <> schemaText currentManifestVersion+          <> "). It records "+          <> countOf (length (recorded ^. #applications)) "application"+          <> ", "+          <> countOf (length (recorded ^. #modules)) "module instance"+          <> ", and "+          <> countOf (Map.size (recorded ^. #files)) "managed file"+          <> "."+      other -> "The manifest could not be read. " <> sentence other++    targetSection = case diagnosis ^. #targetState of+      ProbeOk (TargetMatched refs versions) ->+        "`"+          <> target+          <> "` matches these recorded applications: "+          <> T.intercalate ", " (map applicationLabel refs)+          <> "."+          <> (if null versions then "" else "\nRecorded versions: " <> T.intercalate ", " versions <> ".")+      ProbeOk (TargetNotFound available) ->+        "`"+          <> target+          <> "` is not a recorded target in this project."+          <> ( if null available+                 then ""+                 else " The recorded targets are: " <> T.intercalate ", " available <> ". Ask the user which one they meant."+             )+      ProbeOk TargetLegacyManifest ->+        "The manifest records no applications (a manifest written before applications were recorded).\+        \ One `seihou update "+          <> target+          <> "` seeds the record."+      other -> sentence other++    installedSection =+      T.unlines $+        ( case diagnosis ^. #installedCopies of+            ProbeOk [] -> ["No recorded module instance of `" <> target <> "` needs an installed copy."]+            ProbeOk copies -> map copyLine copies+            other -> ["Installed copies were not located. " <> sentence other]+        )+          <> ( case diagnosis ^. #installedChecks of+                 ProbeOk checks -> case mapMaybe summarizeCheck checks of+                   [] -> ["The artifact guard has nothing to report: each installed copy matches the manifest's source and is not older than recorded."]+                   summaries -> "The artifact guard reports:" : map ("- " <>) summaries+                 other -> ["The artifact guard did not run. " <> sentence other]+             )++    copyLine copy =+      "- "+        <> copy ^. #name+        <> ": recorded at "+        <> maybe "no version" id (copy ^. #recordedVersion)+        <> "; "+        <> case copy ^. #directory of+          Nothing -> "not installed on this machine"+          Just directory ->+            "installed at `"+              <> T.pack directory+              <> "`, declaring "+              <> maybe "no readable version" ("version " <>) (copy ^. #version)++    sharedSection =+      T.unlines $+        ( case diagnosis ^. #unknownSharedPaths of+            ProbeOk [] -> ["No path `" <> target <> "` shares with another application has an unknown shared-write mode."]+            ProbeOk paths ->+              "These paths are shared with applications outside the upgrade, and nothing records how their owners write them:"+                : [ "- `"+                      <> T.pack (shared ^. #path)+                      <> "`: also owned by "+                      <> T.intercalate ", " (map applicationLabel (shared ^. #otherOwners))+                  | shared <- paths+                  ]+            other -> [sentence other]+        )+          <> ( case diagnosis ^. #projectUnknownCount of+                 ProbeOk count+                   | count > 0 -> ["Project-wide, " <> countOf count "shared path" <> " record an unknown write mode."]+                 _ -> []+             )+          <> ( case diagnosis ^. #localOrigins of+                 ProbeOk [] -> []+                 ProbeOk records ->+                   "These recorded origins are paths on the machine that wrote the manifest, not remote URLs:"+                     : [ "- `" <> record ^. #url <> "`: recorded for " <> T.intercalate ", " (record ^. #artifacts)+                       | record <- records+                       ]+                 other -> ["Recorded origins were not read. " <> sentence other]+             )++    upgradeSection = case diagnosis ^. #manifestUpgrade of+      ProbeOk rendered -> "`seihou manifest upgrade --dry-run` reports:\n\n" <> fenced rendered+      other -> "`seihou manifest upgrade --dry-run` did not run. " <> sentence other++    updateSection = case diagnosis ^. #updateDryRun of+      ProbeOk probe ->+        "`seihou update "+          <> target+          <> " --dry-run` "+          <> maybe "planned:" (\code -> "failed with `" <> code <> "`:") (probe ^. #errorCode)+          <> "\n\n"+          <> fenced (probe ^. #rendered)+      other -> "`seihou update " <> target <> " --dry-run` did not run. " <> sentence other++    gitSection = case diagnosis ^. #git of+      ProbeOk state+        | not (state ^. #isRepository) ->+            "This directory is not inside a git repository, so there is no easy undo. Tell the user before changing anything."+        | null (state ^. #dirtyPaths) -> "The git working tree is clean."+        | otherwise ->+            "The git working tree has uncommitted changes. Ask the user before working on top of them:\n\n"+              <> fenced (T.unlines (take 40 (state ^. #dirtyPaths)))+      other -> "Git state was not read. " <> sentence other++    findingsSection = case probeFindings <> callerFindings of+      [] -> "None. Every probe ran."+      findings -> T.unlines (map ("- " <>) findings)++    probeFindings =+      mapMaybe+        (\(label, problem) -> ((label <> ": ") <>) <$> problem)+        [ ("manifest", failureOf (diagnosis ^. #manifest)),+          ("interrupted-update check", failureOf (diagnosis ^. #pendingRecovery)),+          ("target", failureOf (diagnosis ^. #targetState)),+          ("installed copy", failureOf (diagnosis ^. #installedCopies)),+          ("artifact guard", failureOf (diagnosis ^. #installedChecks)),+          ("shared-write evidence", failureOf (diagnosis ^. #unknownSharedPaths)),+          ("recorded origins", failureOf (diagnosis ^. #localOrigins)),+          ("manifest upgrade dry run", failureOf (diagnosis ^. #manifestUpgrade)),+          ("update dry run", failureOf (diagnosis ^. #updateDryRun)),+          ("git", failureOf (diagnosis ^. #git))+        ]++    -- Skipped probes are explained in their own sections; only a failure or+    -- a timeout is a finding.+    failureOf :: Probe a -> Maybe Text+    failureOf = \case+      probe@ProbeFailed {} -> Just (probeProblem probe)+      probe@ProbeTimedOut {} -> Just (probeProblem probe)+      _ -> Nothing++-- | 'probeProblem' as a sentence of its own.+sentence :: Probe a -> Text+sentence probe = case T.uncons (probeProblem probe) of+  Just (initial, rest) -> T.cons (toUpper initial) rest <> "."+  Nothing -> ""++fenced :: Text -> Text+fenced body = "```text\n" <> T.stripEnd body <> "\n```"++countOf :: Int -> Text -> Text+countOf 1 noun = "1 " <> noun+countOf n noun = T.pack (show n) <> " " <> noun <> "s"++-- | Where the brief was written, or why it could not be.+data BriefLocation = BriefSaved !FilePath | BriefNotSaved !Text+  deriving stock (Eq, Show, Generic)++-- | Create a fresh directory for one run's brief and manifest backups:+-- @\<XDG state\>\/seihou\/agent-upgrade\/\<UTC stamp\>-\<module\>@, or the+-- same name under the system temporary directory when the state directory+-- cannot be created. It lives outside the project because the brief holds+-- machine-local paths+-- (docs/adr/0001-manifest-is-a-checked-in-machine-independent-artifact.md).+-- Never throws; a 'Left' says why neither location worked.+createBriefDirectory :: Text -> IO (Either Text FilePath)+createBriefDirectory target = do+  stampResult <- try @SomeException (formatTime defaultTimeLocale "%Y%m%dT%H%M%SZ" <$> getCurrentTime)+  let stamp = either (const "run") id stampResult+      leaf = stamp <> "-" <> safeName target+  stateAttempt <- try @SomeException $ do+    state <- Directory.getXdgDirectory Directory.XdgState "seihou"+    fresh (state </> "agent-upgrade" </> leaf)+  case stateAttempt of+    Right directory -> pure (Right directory)+    Left stateError -> do+      tempAttempt <- try @SomeException $ do+        temporary <- Directory.getTemporaryDirectory+        fresh (temporary </> "seihou-agent-upgrade" </> leaf)+      pure $ case tempAttempt of+        Right directory -> Right directory+        Left tempError ->+          Left+            ( "the brief directory could not be created ("+                <> T.pack (displayException stateError)+                <> "; "+                <> T.pack (displayException tempError)+                <> ")"+            )+  where+    -- A second run within the same second gets a numbered sibling rather+    -- than sharing (and overwriting) the first one's directory.+    fresh base = go (0 :: Int)+      where+        go attempt = do+          let candidate = if attempt == 0 then base else base <> "-" <> show attempt+          exists <- Directory.doesPathExist candidate+          if exists && attempt < 100+            then go (attempt + 1)+            else do+              Directory.createDirectoryIfMissing True (takeDirectory candidate)+              Directory.createDirectory candidate+              pure candidate++    safeName name =+      case T.unpack (T.map (\c -> if isAlphaNum c || c `elem` ("-_." :: String) then c else '_') name) of+        "" -> "module"+        cleaned -> cleaned++-- | Write the brief into the directory 'createBriefDirectory' made. Never+-- throws.+writeBrief :: Either Text FilePath -> Text -> IO BriefLocation+writeBrief (Left reason) _ = pure (BriefNotSaved reason)+writeBrief (Right directory) brief = do+  let path = directory </> "brief.md"+  result <- try @SomeException (TIO.writeFile path brief)+  pure $ case result of+    Left err -> BriefNotSaved ("the brief could not be written to " <> T.pack path <> ": " <> T.pack (displayException err))+    Right () -> BriefSaved path

@@ -9,10 +9,13 @@ import Seihou.CLI.AgentModelsSpec qualified as AgentModelsSpec import Seihou.CLI.AgentTraceE2ESpec qualified as AgentTraceE2ESpec import Seihou.CLI.AgentTraceSpec qualified as AgentTraceSpec+import Seihou.CLI.AgentUpgradeE2ESpec qualified as AgentUpgradeE2ESpec 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.CheckoutSyncE2ESpec qualified as CheckoutSyncE2ESpec+import Seihou.CLI.CheckoutSyncSpec qualified as CheckoutSyncSpec import Seihou.CLI.CommandExecutionSpec qualified as CommandExecutionSpec import Seihou.CLI.CommitMessageSpec qualified as CommitMessageSpec import Seihou.CLI.DiffSpec qualified as DiffSpec@@ -21,15 +24,20 @@ import Seihou.CLI.InitSpec qualified as InitSpec import Seihou.CLI.InstallCollisionSpec qualified as InstallCollisionSpec import Seihou.CLI.InstallHistorySpec qualified as InstallHistorySpec+import Seihou.CLI.InstallSourceSpec qualified as InstallSourceSpec import Seihou.CLI.ListSpec qualified as ListSpec+import Seihou.CLI.ManifestCapabilityUpgradeSpec qualified as ManifestCapabilityUpgradeSpec import Seihou.CLI.ManifestGuardSpec qualified as ManifestGuardSpec+import Seihou.CLI.ManifestRepairOriginsSpec qualified as ManifestRepairOriginsSpec import Seihou.CLI.ManifestUpgradeSpec qualified as ManifestUpgradeSpec import Seihou.CLI.MigrateSpec qualified as MigrateSpec import Seihou.CLI.PendingMigrationSpec qualified as PendingMigrationSpec import Seihou.CLI.PromptRenderSpec qualified as PromptRenderSpec+import Seihou.CLI.RecordedReleaseSpec qualified as RecordedReleaseSpec import Seihou.CLI.Registry.SyncSpec qualified as RegistrySyncSpec import Seihou.CLI.Registry.ValidateSpec qualified as RegistryValidateSpec import Seihou.CLI.RemoteVersionSpec qualified as RemoteVersionSpec+import Seihou.CLI.RepairOriginsE2ESpec qualified as RepairOriginsE2ESpec import Seihou.CLI.RunBlueprintRefusalSpec qualified as RunBlueprintRefusalSpec import Seihou.CLI.SavePromptedSpec qualified as SavePromptedSpec import Seihou.CLI.SharedManifestE2ESpec qualified as SharedManifestE2ESpec@@ -38,6 +46,7 @@ import Seihou.CLI.UpdateInteractionSpec qualified as UpdateInteractionSpec import Seihou.CLI.UpdateRenderSpec qualified as UpdateRenderSpec import Seihou.CLI.UpdateSpec qualified as UpdateSpec+import Seihou.CLI.UpgradeDiagnosisSpec qualified as UpgradeDiagnosisSpec import Seihou.CLI.UpgradeSpec qualified as UpgradeSpec import Seihou.FzfSpec qualified as FzfSpec import Test.Tasty@@ -67,17 +76,24 @@         InitSpec.tests,         InstallCollisionSpec.tests,         InstallHistorySpec.tests,+        InstallSourceSpec.tests,         ListSpec.tests,         ManifestGuardSpec.tests,+        ManifestCapabilityUpgradeSpec.tests,+        ManifestRepairOriginsSpec.tests,         ManifestUpgradeSpec.tests,         MigrateSpec.tests,         PendingMigrationSpec.tests,         PromptRenderSpec.tests,         RegistrySyncSpec.tests,         RegistryValidateSpec.tests,+        RecordedReleaseSpec.tests,         RemoteVersionSpec.tests,+        RepairOriginsE2ESpec.tests,         RunBlueprintRefusalSpec.tests,         SavePromptedSpec.tests,+        CheckoutSyncSpec.tests,+        CheckoutSyncE2ESpec.tests,         SharedManifestE2ESpec.tests,         StatusSpec.tests,         UpgradeSpec.tests,@@ -85,6 +101,8 @@         UpdateInteractionSpec.tests,         UpdateE2ESpec.tests,         UpdateRenderSpec.tests,+        UpgradeDiagnosisSpec.tests,+        AgentUpgradeE2ESpec.tests,         FzfSpec.tests       ]   defaultMain (testGroup "seihou-cli" tests)

@@ -17,7 +17,8 @@   ) import Seihou.Manifest.Types (manifestFromJSON) import System.Directory-  ( createDirectoryIfMissing,+  ( canonicalizePath,+    createDirectoryIfMissing,     doesFileExist,     executable,     getPermissions,@@ -42,6 +43,51 @@     exitCode `shouldBe` ExitSuccess     output `shouldSatisfy` T.isInfixOf "--batch"     output `shouldSatisfy` T.isInfixOf "stdin is not a terminal"++  it "enables Seihou's tool-only Codex skills in interactive and batch launches" $+    withSystemTempDirectory "seihou-codex-kit-session" $ \root -> do+      binary <- seihouBinary+      let blueprintDir = root </> ".seihou" </> "modules" </> "payments"+          skillDir = root </> ".agents" </> "skills" </> "seihou-test-skill"+          fakeBin = root </> "bin"+          fakeCodex = fakeBin </> "codex"+          launchLog = root </> "codex.args"+          xdgHome = root </> "xdg"+      mapM_ (createDirectoryIfMissing True) [blueprintDir, skillDir, fakeBin, xdgHome]+      TIO.writeFile (blueprintDir </> "blueprint.dhall") migrationBlueprintDhall+      TIO.writeFile (skillDir </> "SKILL.md") "---\nname: seihou-test-skill\ndescription: Test skill\n---\n"+      TIO.writeFile+        (skillDir </> ".seihou-kit.json")+        "{\"name\":\"seihou-test-skill\",\"kind\":\"skill\",\"hash\":\"test\",\"installedAt\":\"2026-10-15T00:00:00Z\",\"visibility\":\"tool-only\"}"+      TIO.writeFile+        fakeCodex+        "#!/bin/sh\nif [ \"$1\" = \"--version\" ]; then printf 'codex-cli 1.0.0\\n'; exit 0; fi\nprintf '%s\\n' \"$@\" > \"$SEIHOU_FAKE_AGENT_LOG\"\nprintf '%s\\n' '{\"type\":\"item.completed\",\"item\":{\"type\":\"agent_message\",\"text\":\"kit session complete\"}}'\n"+      permissions <- getPermissions fakeCodex+      -- Permissions comes from directory and has no Generic instance.+      setPermissions fakeCodex (permissions {executable = True})+      inherited <- getEnvironment+      let overriddenNames = ["PATH", "XDG_CONFIG_HOME", "SEIHOU_AGENT_PROVIDER", "SEIHOU_AGENT_MODEL", "SEIHOU_CONTEXT", "SEIHOU_FAKE_AGENT_LOG"]+          environment =+            ("PATH", fakeBin <> [searchPathSeparator] <> fromMaybe "" (lookup "PATH" inherited))+              : ("XDG_CONFIG_HOME", xdgHome)+              : ("SEIHOU_AGENT_PROVIDER", "codex-cli")+              : ("SEIHOU_FAKE_AGENT_LOG", launchLog)+              : filter (\(key, _) -> key `notElem` overriddenNames) inherited+          run args = runProcessText binary args (Just root) (Just environment)+      skillPath <- canonicalizePath (skillDir </> "SKILL.md")+      let checkSession = do+            args <- T.lines <$> TIO.readFile launchLog+            args `shouldSatisfy` elem "-c"+            args `shouldSatisfy` any (T.isInfixOf (T.pack skillPath))+            args `shouldSatisfy` any (T.isInfixOf "enabled=true")+      (interactiveExit, interactiveOutput, interactiveError) <-+        run ["agent", "migrate", "payments", "--from", "1.0.0", "--to", "2.0.0", "--var", "library.name=baikai"]+      expectSuccess "Codex kit interactive launch" interactiveExit interactiveOutput interactiveError+      checkSession+      (batchExit, batchOutput, batchError) <- run ["agent", "run", "payments", "--batch", "--var", "library.name=baikai"]+      expectSuccess "Codex kit batch launch" batchExit batchOutput batchError+      batchOutput `shouldSatisfy` T.isInfixOf "kit session complete"+      checkSession    it "automatically uses the batch CLI provider when stdin is not a terminal" $     withSystemTempDirectory "seihou-agent-run-batch" $ \root -> do