diff --git a/help/manifest.md b/help/manifest.md new file mode 100644 --- /dev/null +++ b/help/manifest.md @@ -0,0 +1,82 @@ +MANIFEST + +Every project seihou generates into carries a .seihou/manifest.json recording +which files were written, which module wrote each one, and which version was +applied. It describes the project rather than the machine, so it is committed +to git alongside the code it describes. + +WHAT IT MAY NOT CONTAIN + + No absolute path, home directory, XDG root, or username. Every location the + manifest names is either relative to the project root or expressed as an + artifact origin: + + remote a git URL plus the artifact's name — a module installed from + somewhere, e.g. https://github.com/user/seihou-modules.git + project a path relative to the project root, for an artifact that lives + inside the project at .seihou/modules/ + local only a name, for an artifact discovered in your personal + ~/.config/seihou/modules/ with no recorded upstream + + A "local" origin is deliberately weak. Commands can still find the artifact + by name, but nothing can verify it is the one the project was generated + from, and seihou says so rather than pretending otherwise. + +OLDER MANIFESTS + + Manifests written before schema version 6 recorded the absolute directory + each module occupied on the machine that ran the command. That path means + nothing in another clone, so seihou refuses to read such a manifest instead + of guessing: + + [error] Error reading manifest: this manifest uses schema version 5, which + records machine-specific absolute paths; run 'seihou manifest upgrade' to + convert it + + Convert it from the project root: + + seihou manifest upgrade + seihou manifest upgrade --dry-run # show the report, write nothing + + 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 + and inference belongs on screen, not hidden inside a committed file. + + Reading .seihou/manifest.json (schema version 5) + + 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. + 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. + +INSTALL FIRST + + The upgrade can only record what this machine can see. If an artifact the + manifest names is missing here — or the copy here is older than the version + recorded — the conversion would have to guess, so the command refuses and + names what to install or upgrade first. + + seihou install # for one that is not here at all + seihou upgrade # for one that is merely out of date + + Pass --force to write anyway, when recording what this machine has is what + you actually mean. + +RECOVERING + + The upgrade rewrites a file that is in git, which is how you undo it: + + git checkout -- .seihou/manifest.json + + The write is atomic: a complete temporary file is renamed over the manifest, + so an interrupted run cannot leave a truncated one. + +SEE ALSO + + seihou help migrations moving a project between module versions + seihou manifest upgrade -h the full flag reference diff --git a/help/migrations.md b/help/migrations.md --- a/help/migrations.md +++ b/help/migrations.md @@ -193,6 +193,43 @@ applicable migrations and the run will only advance the manifest). Recommendations are deduplicated by recorded top-level application. +REFUSING TO GO BACKWARDS + + A migration chain is computed from the locally installed module's + declared migration list, so a local copy older than the version + .seihou/manifest.json records produces a chain that stops short of + where the project already is and rewinds the manifest to match. + + Before planning or generating, 'seihou run' and 'seihou migrate' + compare the manifest's recorded version and origin against the copy + installed on this machine. A strictly older local copy, or one + installed from a different git URL than the manifest records, stops + the command before any file is written: + + ✗ Refusing to run: your local copy of 'haskell-base' is older than the + version this project expects. + + Recorded in .seihou/manifest.json: 2.0.0 + Installed on this machine: 1.4.0 + Origin: https://github.com/shinzui/seihou-modules.git + + Update your local copy first: + seihou upgrade haskell-base + + To proceed anyway — pinning this project to what is installed here — + re-run with --allow-downgrade. + + Nothing is fetched; seihou reports what to run. Pass + --allow-downgrade to proceed anyway — the blocks are still printed, + under a "! Proceeding anyway" heading. 'seihou update' accepts the + same flag for a candidate older than the recorded version. + + A module found in ~/.config/seihou/modules/ has no recorded + provenance. Its version is still compared, but its identity is + reported as unverifiable rather than blocked. + + 'seihou status' lists every differing artifact and always exits zero. + MANIFEST GUARANTEE After a successful (non-dry-run) migration, the manifest's files map diff --git a/seihou-cli.cabal b/seihou-cli.cabal --- a/seihou-cli.cabal +++ b/seihou-cli.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: seihou-cli -version: 0.5.0.0 +version: 0.6.0.0 synopsis: CLI for Seihou project scaffolding description: Command-line interface for Seihou, a composable project scaffolding @@ -29,6 +29,7 @@ help/contexts.md help/git-repository.md help/kit.md + help/manifest.md help/migrations.md help/modules.md help/prompts.md @@ -43,10 +44,10 @@ library seihou-cli-internal default-language: GHC2024 default-extensions: + DeriveAnyClass DuplicateRecordFields NoFieldSelectors OverloadedLabels - OverloadedRecordDot OverloadedStrings TypeFamilies @@ -58,6 +59,7 @@ Seihou.CLI.AgentConfigShow Seihou.CLI.AgentLaunch Seihou.CLI.AgentModels + Seihou.CLI.AgentTrace Seihou.CLI.AppliedBlueprint Seihou.CLI.AppliedBlueprintMigration Seihou.CLI.BlueprintExecution @@ -75,6 +77,9 @@ Seihou.CLI.InstallHistory Seihou.CLI.InstallShared Seihou.CLI.List + Seihou.CLI.Manifest + Seihou.CLI.ManifestGuard + Seihou.CLI.ManifestUpgrade Seihou.CLI.Migrate Seihou.CLI.PendingMigrations Seihou.CLI.PromptRender @@ -106,9 +111,9 @@ aeson >=2.1 && <3, aeson-pretty >=0.8 && <1, ansi-terminal >=1.1 && <2, - baikai ^>=0.4.0.0, - baikai-claude ^>=0.3.0.1, - baikai-openai ^>=0.3.0.1, + baikai ^>=0.4.1.0, + baikai-claude ^>=0.4.0.0, + baikai-openai ^>=0.4.0.0, base >=4.18 && <5, bytestring >=0.11 && <1, containers >=0.6 && <1, @@ -116,8 +121,11 @@ effectful-core >=2.4 && <3, file-embed >=0.0.15 && <1, filepath >=1.4 && <2, + generic-lens >=2.2 && <3, + lens >=5.2 && <6, process >=1.6 && <2, - seihou-core ^>=0.5.0.0, + seihou-core ^>=0.6.0.0, + streamly-core >=0.3 && <0.5, temporary >=1.3 && <2, text >=2.0 && <3, time >=1.12 && <2, @@ -127,10 +135,10 @@ default-language: GHC2024 ghc-options: -threaded default-extensions: + DeriveAnyClass DuplicateRecordFields NoFieldSelectors OverloadedLabels - OverloadedRecordDot OverloadedStrings PackageImports TypeFamilies @@ -184,10 +192,10 @@ aeson >=2.1 && <3, aeson-pretty >=0.8 && <1, ansi-terminal >=1.1 && <2, - baikai ^>=0.4.0.0, - baikai-claude ^>=0.3.0.1, + baikai ^>=0.4.1.0, + baikai-claude ^>=0.4.0.0, baikai-kit ^>=0.1.0.2, - baikai-openai ^>=0.3.0.1, + baikai-openai ^>=0.4.0.0, base >=4.18 && <5, bytestring >=0.11 && <1, containers >=0.6 && <1, @@ -195,11 +203,13 @@ effectful-core >=2.4 && <3, file-embed >=0.0.15 && <1, filepath >=1.4 && <2, + generic-lens >=2.2 && <3, githash ^>=0.1, + lens >=5.2 && <6, optparse-applicative >=0.18 && <1, process >=1.6 && <2, seihou-cli-internal, - seihou-core ^>=0.5.0.0, + seihou-core ^>=0.6.0.0, temporary >=1.3 && <2, text >=2.0 && <3, time >=1.12 && <2, @@ -208,17 +218,15 @@ type: exitcode-stdio-1.0 default-language: GHC2024 default-extensions: + DeriveAnyClass DuplicateRecordFields NoFieldSelectors OverloadedLabels - OverloadedRecordDot OverloadedStrings + TypeFamilies hs-source-dirs: test main-is: Main.hs - default-extensions: - TypeFamilies - other-modules: Seihou.CLI.AgentCompletionSpec Seihou.CLI.AgentConfigShowSpec @@ -226,6 +234,8 @@ Seihou.CLI.AgentLaunchSpec Seihou.CLI.AgentMigrateE2ESpec Seihou.CLI.AgentModelsSpec + Seihou.CLI.AgentTraceE2ESpec + Seihou.CLI.AgentTraceSpec Seihou.CLI.AppliedBlueprintMigrationSpec Seihou.CLI.AppliedBlueprintSpec Seihou.CLI.BlueprintMigrationSpec @@ -238,6 +248,8 @@ Seihou.CLI.InitSpec Seihou.CLI.InstallHistorySpec Seihou.CLI.ListSpec + Seihou.CLI.ManifestGuardSpec + Seihou.CLI.ManifestUpgradeSpec Seihou.CLI.MigrateSpec Seihou.CLI.PendingMigrationSpec Seihou.CLI.PromptRenderSpec @@ -246,7 +258,10 @@ Seihou.CLI.RemoteVersionSpec Seihou.CLI.RunBlueprintRefusalSpec Seihou.CLI.SavePromptedSpec + Seihou.CLI.SeihouBinary + Seihou.CLI.SharedManifestE2ESpec Seihou.CLI.StatusSpec + Seihou.CLI.TwoDeveloperFixture Seihou.CLI.UpdateE2ESpec Seihou.CLI.UpdateFixture Seihou.CLI.UpdateInteractionSpec @@ -260,17 +275,20 @@ build-depends: aeson >=2.1 && <3, - baikai ^>=0.4.0.0, + baikai ^>=0.4.1.0, base >=4.18 && <5, bytestring >=0.11 && <1, containers >=0.6 && <1, directory >=1.3 && <2, effectful-core >=2.4 && <3, filepath >=1.4 && <2, + generic-lens >=2.2 && <3, hspec >=2.11 && <3, + lens >=5.2 && <6, process >=1.6 && <2, seihou-cli-internal, - seihou-core ^>=0.5.0.0, + seihou-core ^>=0.6.0.0, + streamly-core >=0.3 && <0.5, tasty >=1.4 && <2, tasty-hspec >=1.2 && <2, temporary >=1.3 && <2, diff --git a/src-exe/Main.hs b/src-exe/Main.hs --- a/src-exe/Main.hs +++ b/src-exe/Main.hs @@ -1,6 +1,8 @@ module Main (main) where import Control.Applicative ((<|>)) +import Control.Lens ((^.)) +import Data.Generics.Labels () import Data.List (isPrefixOf) import Data.Maybe (isJust) import Data.String (fromString) @@ -8,7 +10,7 @@ import Data.Text.IO qualified as TIO import Options.Applicative (customExecParser, prefs, showHelpOnEmpty) import Seihou.CLI.AgentCompletion qualified as AgentCompletion -import Seihou.CLI.AgentConfig (AgentCommandName (..), loadAgentModelConfigFor) +import Seihou.CLI.AgentConfig (AgentCommandName (..), AgentSettingFlags (..), PendingAgentConfig, loadAgentModelConfigFor, loadPendingAgentConfig, noAgentSettingFlags) import Seihou.CLI.AgentConfigShow (handleAgentConfigShow) import Seihou.CLI.AgentMigrate (handleAgentMigrate) import Seihou.CLI.AgentModels qualified as AgentModels @@ -27,6 +29,7 @@ import Seihou.CLI.Install (handleInstall) import Seihou.CLI.Kit (runKit) import Seihou.CLI.List (ListFilter (..), handleList) +import Seihou.CLI.Manifest (handleManifest) import Seihou.CLI.Migrate (handleMigrate) import Seihou.CLI.NewBlueprint (handleNewBlueprint) import Seihou.CLI.NewModule (handleNewModule) @@ -65,8 +68,8 @@ | not ("-" `isPrefixOf` name) = Just ExtensionRunOpts - { extensionName = fromString name, - extensionArgs = + { name = fromString name, + args = case rest of "--" : forwarded -> forwarded forwarded -> forwarded @@ -94,11 +97,11 @@ handleDiff List listOpts -> let kinds = - [KindModule | listOpts.listModulesOnly] - <> [KindRecipe | listOpts.listRecipesOnly] - <> [KindBlueprint | listOpts.listBlueprintsOnly] - <> [KindPrompt | listOpts.listPromptsOnly] - in handleList (ListFilter listOpts.listRepo listOpts.listTag kinds) + [KindModule | listOpts ^. #modulesOnly] + <> [KindRecipe | listOpts ^. #recipesOnly] + <> [KindBlueprint | listOpts ^. #blueprintsOnly] + <> [KindPrompt | listOpts ^. #promptsOnly] + in handleList (ListFilter (listOpts ^. #repo) (listOpts ^. #tag) kinds) NewModule newModOpts -> handleNewModule newModOpts NewRecipe newRecOpts -> @@ -129,32 +132,34 @@ handleSchemaUpgrade schemaUpgradeOpts Registry registryCmd -> handleRegistry registryCmd + ManifestCmd manifestCmd -> + handleManifest manifestCmd Kit kitCmd -> runKit kitCmd Agent agentOpts -> do - case agentOpts.agentCommand of + case agentOpts ^. #command of AgentAssist assistOpts -> do - modelConfig <- resolveAgentModelConfigFor AgentCmdAssist agentOpts.agentProvider agentOpts.agentModel agentOpts.agentEffort assistOpts.assistProvider assistOpts.assistModel assistOpts.assistEffort - handleAssist agentOpts.agentDebug modelConfig assistOpts + modelConfig <- resolveAgentModelConfigFor AgentCmdAssist (parentAgentFlags agentOpts) (AgentSettingFlags (assistOpts ^. #provider) (assistOpts ^. #model) (assistOpts ^. #effort) (assistOpts ^. #trace)) + handleAssist (agentOpts ^. #debug) modelConfig assistOpts AgentBootstrap bootstrapOpts -> do - modelConfig <- resolveAgentModelConfigFor AgentCmdBootstrap agentOpts.agentProvider agentOpts.agentModel agentOpts.agentEffort bootstrapOpts.bootstrapProvider bootstrapOpts.bootstrapModel bootstrapOpts.bootstrapEffort - handleBootstrap agentOpts.agentDebug modelConfig bootstrapOpts + modelConfig <- resolveAgentModelConfigFor AgentCmdBootstrap (parentAgentFlags agentOpts) (AgentSettingFlags (bootstrapOpts ^. #provider) (bootstrapOpts ^. #model) (bootstrapOpts ^. #effort) (bootstrapOpts ^. #trace)) + handleBootstrap (agentOpts ^. #debug) modelConfig bootstrapOpts AgentSetup setupOpts -> do - modelConfig <- resolveAgentModelConfigFor AgentCmdSetup agentOpts.agentProvider agentOpts.agentModel agentOpts.agentEffort setupOpts.setupProvider setupOpts.setupModel setupOpts.setupEffort - handleSetup agentOpts.agentDebug modelConfig setupOpts + modelConfig <- resolveAgentModelConfigFor AgentCmdSetup (parentAgentFlags agentOpts) (AgentSettingFlags (setupOpts ^. #provider) (setupOpts ^. #model) (setupOpts ^. #effort) (setupOpts ^. #trace)) + handleSetup (agentOpts ^. #debug) modelConfig setupOpts AgentRun blueprintRunOpts -> do - modelConfig <- resolveAgentModelConfigFor AgentCmdRun agentOpts.agentProvider agentOpts.agentModel agentOpts.agentEffort blueprintRunOpts.runBlueprintProvider blueprintRunOpts.runBlueprintModel blueprintRunOpts.runBlueprintEffort - handleAgentRun agentOpts.agentDebug modelConfig blueprintRunOpts + pending <- pendingAgentConfigFor AgentCmdRun (parentAgentFlags agentOpts) (AgentSettingFlags (blueprintRunOpts ^. #provider) (blueprintRunOpts ^. #model) (blueprintRunOpts ^. #effort) (blueprintRunOpts ^. #trace)) + handleAgentRun (agentOpts ^. #debug) pending blueprintRunOpts AgentMigrate migrationOpts -> do - modelConfig <- resolveAgentModelConfigFor AgentCmdMigrate agentOpts.agentProvider agentOpts.agentModel agentOpts.agentEffort migrationOpts.migrateBlueprintProvider migrationOpts.migrateBlueprintModel migrationOpts.migrateBlueprintEffort - handleAgentMigrate agentOpts.agentDebug modelConfig migrationOpts + pending <- pendingAgentConfigFor AgentCmdMigrate (parentAgentFlags agentOpts) (AgentSettingFlags (migrationOpts ^. #provider) (migrationOpts ^. #model) (migrationOpts ^. #effort) (migrationOpts ^. #trace)) + handleAgentMigrate (agentOpts ^. #debug) pending migrationOpts AgentModels modelsOpts -> - case agentOpts.agentModel of + case agentOpts ^. #model of Just _ -> do TIO.putStrLn "Error: --model does not apply to 'seihou agent models'; omit it to list known choices." exitFailure Nothing -> - case modelsOpts.modelsProvider <|> agentOpts.agentProvider of + case modelsOpts ^. #modelsProvider <|> agentOpts ^. #provider of Nothing -> TIO.putStr (AgentModels.formatAgentModels Nothing AgentModels.availableAgentModels) Just providerText -> @@ -169,8 +174,8 @@ Prompt promptCmd -> do case promptCmd of PromptRun promptRunOpts -> do - modelConfig <- resolveAgentModelConfigFor AgentCmdPromptRun Nothing Nothing Nothing promptRunOpts.runPromptProvider promptRunOpts.runPromptModel promptRunOpts.runPromptEffort - handlePromptRun modelConfig promptRunOpts + pending <- pendingAgentConfigFor AgentCmdPromptRun noAgentSettingFlags (AgentSettingFlags (promptRunOpts ^. #provider) (promptRunOpts ^. #model) (promptRunOpts ^. #effort) (promptRunOpts ^. #trace)) + handlePromptRun pending promptRunOpts Extension extensionCmd -> do case extensionCmd of ExtensionRun extensionRunOpts -> @@ -180,29 +185,53 @@ Completions completionsCmd -> handleCompletionsCommand completionsCmd --- | Resolve the effective provider/model/effort for one agent command. The --- subcommand flag wins over the parent @seihou agent@ flag; that combined flag --- then feeds the per-command config resolution, which also consults the +-- | The four agent settings as given on the parent @seihou agent@ command. +parentAgentFlags :: AgentOpts -> AgentSettingFlags +parentAgentFlags agentOpts = + AgentSettingFlags + { provider = agentOpts ^. #provider, + model = agentOpts ^. #model, + effort = agentOpts ^. #effort, + trace = agentOpts ^. #trace + } + +-- | Resolve the effective provider/model/effort/trace for one agent command. +-- The subcommand flag wins over the parent @seihou agent@ flag; that combined +-- flag then feeds the per-command config resolution, which also consults the -- command's own @agent..*@ keys before the shared @agent.*@ defaults. resolveAgentModelConfigFor :: AgentCommandName -> - -- | parent @seihou agent@ provider, model, effort - Maybe Text -> - Maybe Text -> - Maybe Text -> - -- | subcommand provider, model, effort - Maybe Text -> - Maybe Text -> - Maybe Text -> + -- | flags on the parent @seihou agent@ command + AgentSettingFlags -> + -- | flags on the subcommand itself + AgentSettingFlags -> IO AgentCompletion.AgentModelConfig -resolveAgentModelConfigFor cmd parentProvider parentModel parentEffort commandProvider commandModel commandEffort = do - let provider = commandProvider <|> parentProvider - model = commandModel <|> parentModel - effort = commandEffort <|> parentEffort - configResult <- - loadAgentModelConfigFor cmd provider model effort (isJust commandProvider) (isJust commandModel) (isJust commandEffort) +resolveAgentModelConfigFor cmd parentFlags commandFlags = do + configResult <- loadAgentModelConfigFor cmd parentFlags commandFlags case configResult of Left err -> do TIO.putStrLn $ "Error: " <> err exitFailure Right config -> pure config + +-- | Gather flags, environment, and config for a command whose artifact may +-- declare its own launch settings, stopping one step short of resolution. +-- +-- The blueprint or prompt is not loaded until the handler runs, so the handler +-- finishes resolution itself with 'resolveDeclaredAgentConfig' once it knows +-- what the artifact declares. Flag combination and error reporting match +-- 'resolveAgentModelConfigFor' exactly. +pendingAgentConfigFor :: + AgentCommandName -> + -- | flags on the parent @seihou agent@ command + AgentSettingFlags -> + -- | flags on the subcommand itself + AgentSettingFlags -> + IO PendingAgentConfig +pendingAgentConfigFor cmd parentFlags commandFlags = do + pendingResult <- loadPendingAgentConfig cmd parentFlags commandFlags + case pendingResult of + Left err -> do + TIO.putStrLn $ "Error: " <> err + exitFailure + Right pending -> pure pending diff --git a/src-exe/Seihou/CLI/AgentLaunchExec.hs b/src-exe/Seihou/CLI/AgentLaunchExec.hs --- a/src-exe/Seihou/CLI/AgentLaunchExec.hs +++ b/src-exe/Seihou/CLI/AgentLaunchExec.hs @@ -28,6 +28,7 @@ launchCodexInteractive, ) import Baikai.ThinkingLevel (ThinkingLevel) +import Data.Generics.Labels () import Data.Text qualified as T import Data.Text.IO qualified as TIO import Seihou.CLI.AgentCompletion (AgentModelConfig (..), AgentProvider (..)) @@ -50,11 +51,11 @@ TIO.putStr systemPrompt pure ExitSuccess | otherwise = - case modelConfig.agentProvider of + case modelConfig ^. #provider of AgentProviderClaudeCli -> - launchClaude addDirs tools modelConfig.agentModel modelConfig.agentEffort systemPrompt initialPrompt + launchClaude addDirs tools (modelConfig ^. #model) (modelConfig ^. #effort) systemPrompt initialPrompt AgentProviderCodexCli -> - launchCodex addDirs modelConfig.agentModel modelConfig.agentEffort systemPrompt initialPrompt + launchCodex addDirs (modelConfig ^. #model) (modelConfig ^. #effort) systemPrompt initialPrompt AgentProviderAnthropic -> unsupportedInteractiveProvider "anthropic" AgentProviderOpenAI -> @@ -73,6 +74,8 @@ InteractiveLaunchResult {exitCode} <- 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, @@ -96,6 +99,8 @@ InteractiveLaunchResult {exitCode} <- 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, diff --git a/src-exe/Seihou/CLI/AgentMigrate.hs b/src-exe/Seihou/CLI/AgentMigrate.hs --- a/src-exe/Seihou/CLI/AgentMigrate.hs +++ b/src-exe/Seihou/CLI/AgentMigrate.hs @@ -5,7 +5,9 @@ ) where +import Baikai.Trace.Sink (TraceSink) import Data.FileEmbed (embedFile) +import Data.Generics.Labels () import Data.Maybe (maybeToList) import Data.Text qualified as T import Data.Text.Encoding qualified as TE @@ -14,11 +16,17 @@ import Seihou.CLI.AgentCompletion ( AgentModelConfig (..), AgentProvider (..), - buildAgentCompletionRequest, + buildAgentCompletionRequestWith, runAgentCompletion, ) +import Seihou.CLI.AgentConfig + ( PendingAgentConfig, + agentLaunchDeclaration, + resolveDeclaredAgentConfig, + ) import Seihou.CLI.AgentLaunch (gatherAgentContext) import Seihou.CLI.AgentLaunchExec (launchConfiguredAgentAddingDirs) +import Seihou.CLI.AgentTrace (traceSinkForConfig) import Seihou.CLI.AppliedBlueprintMigration (recordAppliedBlueprintMigration) import Seihou.CLI.BlueprintExecution ( BlueprintExecutionRequest (..), @@ -55,21 +63,31 @@ migrationPromptTemplate :: Text migrationPromptTemplate = TE.decodeUtf8 $(embedFile "data/blueprint-migration-prompt.md") -handleAgentMigrate :: Bool -> AgentModelConfig -> BlueprintMigrationOpts -> IO () -handleAgentMigrate debug modelConfig opts = do - let level = if opts.migrateBlueprintVerbose then LogVerbose else LogNormal +handleAgentMigrate :: Bool -> PendingAgentConfig -> BlueprintMigrationOpts -> IO () +handleAgentMigrate debug pendingConfig opts = do + let level = if opts ^. #verbose then LogVerbose else LogNormal manifestPath = ".seihou" "manifest.json" - (blueprint, blueprintDir) <- discoverMigrationBlueprint level opts.migrateBlueprintName + (blueprint, blueprintDir) <- discoverMigrationBlueprint level (opts ^. #name) validationResult <- validateBlueprint blueprintDir blueprint case validationResult of Left err -> exitErr level (renderModuleLoadError err) Right _ -> pure () - current <- parseRequestedVersion level "--from" opts.migrateBlueprintFrom - target <- parseRequestedVersion level "--to" opts.migrateBlueprintTo + -- Finish provider/model/effort resolution now that the blueprint is loaded: + -- `agent migrate` reads the same Blueprint record as `agent run`, so it + -- honors the same launch declaration. + modelConfig <- + resolveDeclaredAgentConfig + level + ("blueprint '" <> blueprint ^. #name . #unModuleName <> "'") + pendingConfig + (agentLaunchDeclaration (blueprint ^. #launch)) + + current <- parseRequestedVersion level "--from" (opts ^. #from) + target <- parseRequestedVersion level "--to" (opts ^. #to) planned <- - case planBlueprintMigrationChain blueprint.name.unModuleName blueprint.migrations current target of + case planBlueprintMigrationChain (blueprint ^. #name . #unModuleName) (blueprint ^. #migrations) current target of Left err -> exitErr level (renderPlanError err) Right Nothing -> do TIO.putStrLn "No blueprint migration needed: --from and --to resolve to the same version." @@ -82,14 +100,15 @@ receipts <- readMigrationReceipts level manifestPath let pending = pendingBlueprintMigrations - opts.migrateBlueprintRerun - blueprint.name + (opts ^. #rerun) + (blueprint ^. #name) receipts migrationPlan if null pending then reportNoPending migrationPlan else do prepared <- prepare level modelConfig opts blueprint blueprintDir + traceSink <- traceSinkForConfig level modelConfig context <- gatherAgentContext let renderStep position total migration = renderBlueprintMigrationSystemPrompt @@ -104,26 +123,26 @@ <> maybe "" ("\n\n===== Initial user instruction =====\n" <>) - opts.migrateBlueprintPrompt + (opts ^. #prompt) if debug then TIO.putStrLn $ "Blueprint migrations for " - <> blueprint.name.unModuleName + <> blueprint ^. #name . #unModuleName <> ": " - <> renderVersion migrationPlan.blueprintPlanFrom + <> renderVersion (migrationPlan ^. #from) <> " -> " - <> renderVersion migrationPlan.blueprintPlanTo + <> renderVersion (migrationPlan ^. #to) <> "\n" <> formatBlueprintMigrationDebugOutput renderDebugStep pending else do result <- runBlueprintMigrationsWith - (launchMigration modelConfig opts prepared renderStep) + (launchMigration traceSink modelConfig opts prepared renderStep) (recordMigration manifestPath blueprint) pending - handleRunResult level blueprint.name result + handleRunResult level (blueprint ^. #name) result discoverMigrationBlueprint :: LogLevel -> ModuleName -> IO (Blueprint, FilePath) discoverMigrationBlueprint level requestedName = do @@ -132,11 +151,11 @@ case runnableResult of Right (RunnableBlueprint blueprint dir) -> pure (blueprint, dir) Right (RunnableModule _ _) -> - exitErr level $ "'" <> requestedName.unModuleName <> "' is a module, not a blueprint." + exitErr level $ "'" <> requestedName ^. #unModuleName <> "' is a module, not a blueprint." Right (RunnableRecipe _ _) -> - exitErr level $ "'" <> requestedName.unModuleName <> "' is a recipe, not a blueprint." + exitErr level $ "'" <> requestedName ^. #unModuleName <> "' is a recipe, not a blueprint." Right (RunnableAgentPrompt _ _) -> - exitErr level $ "'" <> requestedName.unModuleName <> "' is a prompt, not a blueprint." + exitErr level $ "'" <> requestedName ^. #unModuleName <> "' is a prompt, not a blueprint." Left err -> exitErr level (renderModuleLoadError err) parseRequestedVersion :: LogLevel -> Text -> Text -> IO Version @@ -151,7 +170,7 @@ case result of Left err -> exitErr level ("Error reading migration receipts: " <> err) Right Nothing -> pure [] - Right (Just manifest) -> pure manifest.blueprintMigrations + Right (Just manifest) -> pure (manifest ^. #blueprintMigrations) prepare :: LogLevel -> @@ -162,18 +181,18 @@ IO PreparedBlueprintExecution prepare level modelConfig opts blueprint blueprintDir = do let providerCanMountFiles = - modelConfig.agentProvider == AgentProviderClaudeCli - || modelConfig.agentProvider == AgentProviderCodexCli + modelConfig ^. #provider == AgentProviderClaudeCli + || modelConfig ^. #provider == AgentProviderCodexCli result <- prepareBlueprintExecution BlueprintExecutionRequest - { executionBlueprint = blueprint, - executionBlueprintDir = blueprintDir, - executionVariableOverrides = opts.migrateBlueprintVars, - executionNamespaceOverride = opts.migrateBlueprintNamespace, - executionContextOverride = opts.migrateBlueprintContext, - executionCanMountFiles = providerCanMountFiles, - executionLogLevel = level + { blueprint = blueprint, + blueprintDir = blueprintDir, + variableOverrides = opts ^. #vars, + namespaceOverride = opts ^. #namespace, + contextOverride = opts ^. #context, + canMountFiles = providerCanMountFiles, + logLevel = level } case result of Left errs -> do @@ -183,6 +202,8 @@ Right prepared -> pure prepared launchMigration :: + -- | built once per command, so every migration edge appends to one destination + TraceSink -> AgentModelConfig -> BlueprintMigrationOpts -> PreparedBlueprintExecution -> @@ -191,18 +212,18 @@ Int -> BlueprintMigration -> IO (Either BlueprintMigrationLaunchFailure ()) -launchMigration modelConfig opts prepared renderStep position total migration = do +launchMigration traceSink modelConfig opts prepared renderStep position total migration = do TIO.putStrLn $ "Running blueprint migration " <> T.pack (show position) <> "/" <> T.pack (show total) <> ": " - <> migration.from + <> migration ^. #from <> " -> " - <> migration.to + <> (migration ^. #to) let systemPrompt = renderStep position total migration - case modelConfig.agentProvider of + case modelConfig ^. #provider of AgentProviderClaudeCli -> launchInteractive systemPrompt AgentProviderCodexCli -> launchInteractive systemPrompt AgentProviderAnthropic -> launchCompletion systemPrompt @@ -211,12 +232,12 @@ launchInteractive systemPrompt = do exitCode <- launchConfiguredAgentAddingDirs - (maybeToList prepared.preparedMountedFilesDir) + (maybeToList (prepared ^. #mountedFilesDir)) modelConfig - prepared.preparedAllowedTools + (prepared ^. #allowedTools) False systemPrompt - opts.migrateBlueprintPrompt + (opts ^. #prompt) pure $ case exitCode of ExitSuccess -> Right () failure -> Left (BlueprintMigrationProcessFailure failure) @@ -224,7 +245,7 @@ launchCompletion systemPrompt = do result <- runAgentCompletion - (buildAgentCompletionRequest modelConfig systemPrompt opts.migrateBlueprintPrompt) + (buildAgentCompletionRequestWith traceSink modelConfig systemPrompt (opts ^. #prompt)) case result of Left err -> pure (Left (BlueprintMigrationProviderFailure err)) Right assistantText -> do @@ -241,10 +262,10 @@ recordAppliedBlueprintMigration manifestPath AppliedBlueprintMigration - { name = blueprint.name, - blueprintVersion = blueprint.version, - fromVersion = migration.from, - toVersion = migration.to, + { name = blueprint ^. #name, + blueprintVersion = blueprint ^. #version, + fromVersion = migration ^. #from, + toVersion = migration ^. #to, appliedAt = now, agentSessionId = Nothing } @@ -258,14 +279,14 @@ "Completed " <> T.pack (show (length completed)) <> " blueprint migration(s) for '" - <> blueprintName.unModuleName + <> blueprintName ^. #unModuleName <> "'." BlueprintMigrationLaunchFailed migration failure -> do let prefix = "Blueprint migration " - <> migration.from + <> migration ^. #from <> " -> " - <> migration.to + <> migration ^. #to <> " failed; completed earlier edges remain recorded. " retry = "Fix the provider error, then rerun the same command to resume." case failure of @@ -279,9 +300,9 @@ logIO level $ logError $ "Agent completed blueprint migration " - <> migration.from + <> migration ^. #from <> " -> " - <> migration.to + <> migration ^. #to <> ", but its receipt could not be recorded: " <> err <> ". The next edge was not started; repair manifest access, then rerun the same command." @@ -289,7 +310,7 @@ reportNoPending :: BlueprintMigrationPlan -> IO () reportNoPending migrationPlan - | null migrationPlan.blueprintPlanSteps = + | null (migrationPlan ^. #steps) = TIO.putStrLn "No blueprint migrations are declared inside the requested version window." | otherwise = TIO.putStrLn "All blueprint migrations in the requested version window already have receipts." @@ -312,22 +333,22 @@ renderModuleLoadError = \case ModuleNotFound name searched -> "Blueprint '" - <> name.unModuleName + <> name ^. #unModuleName <> "' not found. Searched in:\n" <> T.intercalate "\n" (map ((" " <>) . T.pack) searched) DhallEvalError name msg -> - "Failed to evaluate '" <> name.unModuleName <> "': " <> msg + "Failed to evaluate '" <> name ^. #unModuleName <> "': " <> msg DhallDecodeError name msg -> - "Failed to decode '" <> name.unModuleName <> "': " <> msg + "Failed to decode '" <> name ^. #unModuleName <> "': " <> msg ValidationError name msgs -> "Validation failed for '" - <> name.unModuleName + <> name ^. #unModuleName <> "':\n" <> T.intercalate "\n" (map (" " <>) msgs) CircularDependency names -> - "Circular dependency detected: " <> T.intercalate " -> " (map (.unModuleName) names) + "Circular dependency detected: " <> T.intercalate " -> " (map (^. #unModuleName) names) MissingSourceFile name path -> - "Missing source file in '" <> name.unModuleName <> "': " <> T.pack path + "Missing source file in '" <> name ^. #unModuleName <> "': " <> T.pack path RegistryEvalError path msg -> "Failed to evaluate registry at '" <> path <> "': " <> msg diff --git a/src-exe/Seihou/CLI/AgentRun.hs b/src-exe/Seihou/CLI/AgentRun.hs --- a/src-exe/Seihou/CLI/AgentRun.hs +++ b/src-exe/Seihou/CLI/AgentRun.hs @@ -15,6 +15,7 @@ import Control.Exception (IOException, displayException, try) import Control.Monad (when) import Data.FileEmbed (embedFile) +import Data.Generics.Labels () import Data.Map.Strict qualified as Map import Data.Maybe (fromMaybe, maybeToList) import Data.Set qualified as Set @@ -26,9 +27,14 @@ import Seihou.CLI.AgentCompletion ( AgentModelConfig (..), AgentProvider (..), - buildAgentCompletionRequest, - runAgentCompletion, + buildAgentCompletionRequestWith, + runAgentCompletionWithCliAccess, ) +import Seihou.CLI.AgentConfig + ( PendingAgentConfig, + agentLaunchDeclaration, + resolveDeclaredAgentConfig, + ) import Seihou.CLI.AgentLaunch ( AgentContext (..), BaselineStatus (..), @@ -42,6 +48,7 @@ substitute, ) import Seihou.CLI.AgentLaunchExec (launchConfiguredAgentAddingDirs) +import Seihou.CLI.AgentTrace (traceSinkForConfig) import Seihou.CLI.AppliedBlueprint (recordAppliedBlueprint) import Seihou.CLI.BlueprintExecution ( BlueprintExecutionRequest (..), @@ -60,6 +67,7 @@ import Seihou.Composition.Instance (ModuleInstance (..), qualifiedName) import Seihou.Composition.Plan (compileComposedPlan) import Seihou.Composition.Resolve (loadComposition, resolveWithPrompts) +import Seihou.Core.ArtifactOriginDetect (detectArtifactOrigin) import Seihou.Core.Context (resolveContext) import Seihou.Core.Module (defaultSearchPaths, discoverRunnable) import Seihou.Core.Types @@ -84,54 +92,69 @@ import Seihou.Engine.Execute (executePlan) import Seihou.Manifest.Types (currentManifestVersion, emptyManifest) import Seihou.Prelude +import System.Directory (getCurrentDirectory) import System.Environment (getEnvironment) import System.Exit (ExitCode (..), exitFailure, exitWith) import System.FilePath (takeDirectory, ()) +import System.IO (hIsTerminalDevice, stdin) -- | The prompt template, embedded at compile time from data/blueprint-prompt.md. promptTemplate :: Text promptTemplate = TE.decodeUtf8 $(embedFile "data/blueprint-prompt.md") -handleAgentRun :: Bool -> AgentModelConfig -> BlueprintRunOpts -> IO () -handleAgentRun debug modelConfig opts = do - let level = if opts.runBlueprintVerbose then LogVerbose else LogNormal +handleAgentRun :: Bool -> PendingAgentConfig -> BlueprintRunOpts -> IO () +handleAgentRun debug pending opts = do + let level = if opts ^. #verbose then LogVerbose else LogNormal + stdinIsTerminal <- hIsTerminalDevice stdin + let batch = opts ^. #batch || not stdinIsTerminal -- (a) Discover and validate. discoverRunnable resolves by directory -- name (priority: module > recipe > blueprint). searchPaths <- defaultSearchPaths - runnableResult <- discoverRunnable searchPaths opts.runBlueprintName + runnableResult <- discoverRunnable searchPaths (opts ^. #name) (bp, blueprintDir) <- case runnableResult of Right (RunnableBlueprint b dir) -> pure (b, dir) Right (RunnableModule _ _) -> exitErr level $ "'" - <> opts.runBlueprintName.unModuleName + <> opts ^. #name . #unModuleName <> "' is a module, not a blueprint. Did you mean 'seihou run " - <> opts.runBlueprintName.unModuleName + <> opts ^. #name . #unModuleName <> "'?" Right (RunnableRecipe _ _) -> exitErr level $ "'" - <> opts.runBlueprintName.unModuleName + <> opts ^. #name . #unModuleName <> "' is a recipe, not a blueprint. Did you mean 'seihou run " - <> opts.runBlueprintName.unModuleName + <> opts ^. #name . #unModuleName <> "'?" Left err -> exitErr level (renderModuleLoadError err) + -- Finish provider/model/effort resolution now that the blueprint is loaded + -- and its launch declaration is known. This must precede the + -- providerCanMountFiles computation below, which depends on the final + -- provider. + modelConfig <- + resolveDeclaredAgentConfig + level + ("blueprint '" <> bp ^. #name . #unModuleName <> "'") + pending + (agentLaunchDeclaration (bp ^. #launch)) + let providerCanMountFiles = - modelConfig.agentProvider == AgentProviderClaudeCli - || modelConfig.agentProvider == AgentProviderCodexCli + modelConfig ^. #provider == AgentProviderClaudeCli + || modelConfig ^. #provider == AgentProviderCodexCli -- (b) Resolve variables and prepare the shared prompt/reference/tool state. preparedResult <- prepareBlueprintExecution BlueprintExecutionRequest - { executionBlueprint = bp, - executionBlueprintDir = blueprintDir, - executionVariableOverrides = opts.runBlueprintVars, - executionNamespaceOverride = opts.runBlueprintNamespace, - executionContextOverride = opts.runBlueprintContext, - executionCanMountFiles = providerCanMountFiles, - executionLogLevel = level + { blueprint = bp, + blueprintDir = blueprintDir, + variableOverrides = opts ^. #vars, + namespaceOverride = opts ^. #namespace, + contextOverride = opts ^. #context, + canMountFiles = providerCanMountFiles, + logLevel = level } prepared <- case preparedResult of Left errs -> do @@ -139,17 +162,17 @@ mapM_ (logIO level . logError . (" " <>) . formatVarError) errs exitFailure Right result -> pure result - let resolved = prepared.preparedResolvedVariables - cliOverrides = Map.fromList [(VarName k, v) | (k, v) <- opts.runBlueprintVars] + let resolved = (prepared ^. #resolvedVariables) + cliOverrides = Map.fromList [(VarName k, v) | (k, v) <- opts ^. #vars] -- (c) Baseline. baseline <- - if opts.runBlueprintNoBaseline + if opts ^. #noBaseline then pure BaselineSkipped else - if null bp.baseModules + if null (bp ^. #baseModules) then pure BaselineEmpty - else applyBaseline level opts bp.baseModules cliOverrides resolved + else applyBaseline level opts (bp ^. #baseModules) cliOverrides resolved -- (d) Render the system prompt around the prepared shared body. ctx <- gatherAgentContext @@ -157,13 +180,14 @@ -- (f) Launch. launchSucceeded <- - runRenderedAgentPrompt + runRenderedAgentPromptMode debug + batch modelConfig - prepared.preparedAllowedTools - prepared.preparedMountedFilesDir + (prepared ^. #allowedTools) + (prepared ^. #mountedFilesDir) systemPrompt - opts.runBlueprintPrompt + (opts ^. #prompt) -- (g) Record the applied-blueprint provenance into -- .seihou/manifest.json only after a successful provider response. In @@ -183,11 +207,14 @@ <> err runRenderedAgentPrompt :: Bool -> AgentModelConfig -> [String] -> Maybe FilePath -> Text -> Maybe Text -> IO Bool -runRenderedAgentPrompt debug modelConfig tools mFilesDir systemPrompt initialPrompt +runRenderedAgentPrompt debug = runRenderedAgentPromptMode debug False + +runRenderedAgentPromptMode :: Bool -> Bool -> AgentModelConfig -> [String] -> Maybe FilePath -> Text -> Maybe Text -> IO Bool +runRenderedAgentPromptMode debug batch modelConfig tools mFilesDir systemPrompt initialPrompt | debug = do TIO.putStr systemPrompt pure True - | modelConfig.agentProvider == AgentProviderClaudeCli || modelConfig.agentProvider == AgentProviderCodexCli = do + | not batch && (modelConfig ^. #provider == AgentProviderClaudeCli || modelConfig ^. #provider == AgentProviderCodexCli) = do exitCode <- launchConfiguredAgentAddingDirs (maybeToList mFilesDir) @@ -200,7 +227,12 @@ ExitSuccess -> pure True ExitFailure _ -> exitWith exitCode | otherwise = do - result <- runAgentCompletion (buildAgentCompletionRequest modelConfig systemPrompt initialPrompt) + sink <- traceSinkForConfig LogNormal modelConfig + result <- + runAgentCompletionWithCliAccess + (maybeToList mFilesDir) + tools + (buildAgentCompletionRequestWith sink modelConfig systemPrompt initialPrompt) case result of Right assistantText -> do TIO.putStrLn assistantText @@ -217,8 +249,8 @@ Blueprint -> BaselineStatus -> BlueprintRunOpts -> UTCTime -> AppliedBlueprint appliedBlueprintFromOutcome bp baseline opts now = AppliedBlueprint - { name = bp.name, - blueprintVersion = bp.version, + { name = bp ^. #name, + blueprintVersion = bp ^. #version, appliedAt = now, baselineModules = case baseline of BaselineApplied entries -> map fst entries @@ -227,7 +259,7 @@ noBaseline = case baseline of BaselineSkipped -> True _ -> False, - userPrompt = opts.runBlueprintPrompt, + userPrompt = opts ^. #prompt, agentSessionId = Nothing } @@ -250,7 +282,7 @@ applyBaseline level opts baseModules cliOverridesIn resolvedBlueprintVars = do searchPaths <- defaultSearchPaths (primary, additionals) <- case baseModules of - d : rs -> pure (d.depModule, map (.depModule) rs) + d : rs -> pure (d ^. #module_, map (^. #module_) rs) [] -> exitErr level "internal error: applyBaseline called with empty baseModules" compositionResult <- loadComposition searchPaths primary additionals modulesInOrder <- case compositionResult of @@ -259,18 +291,27 @@ exitFailure Right ms -> pure ms + -- Classify every baseline module's discovery directory into a portable + -- origin before anything is recorded, so the manifest stays meaningful on + -- another developer's machine. + projectRoot <- getCurrentDirectory + originedModules <- + traverse + (\(inst, m, dir) -> (inst,m,) <$> detectArtifactOrigin projectRoot dir) + modulesInOrder + -- Fold the blueprint's resolved vars into the CLI override map for -- the base modules. CLI overrides (already present in cliOverridesIn) -- win over blueprint values, mirroring 'seihou run' semantics. let blueprintAsOverrides = Map.fromList - [(vn, varValueToText rv.value) | (vn, rv) <- Map.toList resolvedBlueprintVars] + [(vn, varValueToText (rv ^. #value)) | (vn, rv) <- Map.toList resolvedBlueprintVars] cliOverrides = Map.union cliOverridesIn blueprintAsOverrides envPairs <- getEnvironment let envVars = Map.fromList [(T.pack k, T.pack v) | (k, v) <- envPairs] - namespace = fromMaybe (deriveNamespace primary) opts.runBlueprintNamespace - context <- resolveContext opts.runBlueprintContext envVars + namespace = fromMaybe (deriveNamespace primary) (opts ^. #namespace) + context <- resolveContext (opts ^. #context) envVars let contextName = fromMaybe "" context baseResolveResult <- runEff $ runConfigReader $ runConsole $ do @@ -298,7 +339,7 @@ -- Compile the plan. let quads = - [ (inst, m, dir, Map.map (.value) (baseResolved Map.! inst)) + [ (inst, m, dir, Map.map (^. #value) (baseResolved Map.! inst)) | (inst, m, dir) <- modulesInOrder ] planResult <- compileComposedPlan quads @@ -330,26 +371,33 @@ diff <- runEff $ runFilesystem $ runManifestStore manifestPath $ do let composedNames = Set.fromList $ - concatMap (\(inst, _, _) -> [inst.instanceModule, qualifiedName inst]) modulesInOrder + concatMap (\(inst, _, _) -> [inst ^. #module_, qualifiedName inst]) modulesInOrder computeDiff manifest composedNames planned resolutions <- - runEff $ runConsole $ resolveConflicts opts.runBlueprintForce diff.conflicts + runEff $ runConsole $ resolveConflicts (opts ^. #force) (diff ^. #conflicts) case resolutions of Nothing -> do logIO level $ logError "Baseline conflicts detected (use --force to overwrite):" - mapM_ (\c -> logIO level (logError (" ! " <> T.pack c.path))) diff.conflicts + mapM_ (\c -> logIO level (logError (" ! " <> T.pack (c ^. #path)))) (diff ^. #conflicts) exitFailure Just conflictResolved -> do let keepRecords = Map.fromList - [ ( c.path, - case Map.lookup c.path manifest.files of - Just existing -> existing {hash = c.diskHash, generatedAt = now} + [ ( c ^. #path, + case Map.lookup (c ^. #path) (manifest ^. #files) of + Just existing -> + ( existing + & #hash + .~ c + ^. #diskHash + & #generatedAt + .~ now + ) Nothing -> FileRecord - { hash = c.diskHash, - moduleName = c.moduleName, + { hash = c ^. #diskHash, + moduleName = c ^. #moduleName, strategy = Template, generatedAt = now, baseline = Nothing, @@ -358,7 +406,7 @@ ) | (c, KeepCurrent) <- conflictResolved ] - skipPaths = [c.path | (c, Skip) <- conflictResolved] + skipPaths = [c ^. #path | (c, Skip) <- conflictResolved] excludePaths = Set.fromList (Map.keys keepRecords ++ skipPaths) opsForExec = filter (not . opTargetsPath excludePaths) ops @@ -373,22 +421,22 @@ case baselineResult of Left err -> pure (Left err) Right baselineRecords -> do - let orphanedPaths = map (.path) diff.orphaned - cleanedFiles = foldr Map.delete manifest.files orphanedPaths - allModuleEntries = updateAllModules manifest.modules modulesInOrder now + 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 baseResolved] + Map.unions [Map.map (^. #value) vs | vs <- Map.elems baseResolved] newManifest = Manifest { version = currentManifestVersion, genAt = now, modules = allModuleEntries, - vars = Map.union (Map.map varValueToText allResolvedVals) manifest.vars, + vars = Map.union (Map.map varValueToText allResolvedVals) (manifest ^. #vars), files = Map.unions [baselineRecords, keepRecords, cleanedFiles], - applications = manifest.applications, - recipe = manifest.recipe, - blueprint = manifest.blueprint, - blueprintMigrations = manifest.blueprintMigrations + applications = manifest ^. #applications, + recipe = manifest ^. #recipe, + blueprint = manifest ^. #blueprint, + blueprintMigrations = manifest ^. #blueprintMigrations } writeManifest newManifest pure (Right newManifest) @@ -413,9 +461,9 @@ logIO level $ logWarn $ "Warning: could not prune generated baselines: " <> T.pack (displayException err) Right _ -> pure () - let nNew = length diff.new - nMod = length diff.modified - nUnch = length diff.unchanged + let nNew = length (diff ^. #new) + nMod = length (diff ^. #modified) + nUnch = length (diff ^. #unchanged) logIO level $ logInfo $ "Baseline applied: " @@ -427,27 +475,27 @@ <> " unchanged." pure $ BaselineApplied - [(m.name, m.version) | (_, m, _) <- modulesInOrder] + [(m ^. #name, m ^. #version) | (_, m, _) <- modulesInOrder] -- | Stitch the system-prompt template together. Each block in -- @blueprint-prompt.md@ has a @{{key}}@ placeholder filled here. renderSystemPrompt :: AgentContext -> PreparedBlueprintExecution -> BaselineStatus -> Text renderSystemPrompt ctx prepared baseline = - let bp = prepared.preparedBlueprint + let bp = (prepared ^. #blueprint) in substitute - [ ("cwd", ctx.cwd), + [ ("cwd", ctx ^. #cwd), ("seihou_project_state", formatSeihouProjectState ctx), ("manifest_state", formatManifestState ctx), ("module_dhall_state", formatModuleDhallState ctx), ("local_modules", formatLocalModules ctx), ("available_modules", formatAvailableModules ctx), - ("blueprint_name", bp.name.unModuleName), - ("blueprint_version", fromMaybe "(unspecified)" bp.version), - ("blueprint_description", fromMaybe "(no description)" bp.description), + ("blueprint_name", bp ^. #name . #unModuleName), + ("blueprint_version", fromMaybe "(unspecified)" (bp ^. #version)), + ("blueprint_description", fromMaybe "(no description)" (bp ^. #description)), ("baseline_status", formatBaselineStatus baseline), - ("reference_files", prepared.preparedReferenceFiles), - ("reference_files_dir", prepared.preparedReferenceFilesAccess), - ("user_prompt", prepared.preparedSharedPrompt) + ("reference_files", prepared ^. #referenceFiles), + ("reference_files_dir", prepared ^. #referenceFilesAccess), + ("user_prompt", prepared ^. #sharedPrompt) ] promptTemplate @@ -462,27 +510,27 @@ -- applied-modules list. Local copy of @Seihou.CLI.Run.updateAllModules@. updateAllModules :: [AppliedModule] -> - [(ModuleInstance, Module, FilePath)] -> + [(ModuleInstance, Module, ArtifactOrigin)] -> UTCTime -> [AppliedModule] updateAllModules existing modulesInOrder now = let composedKeys = Set.fromList - [ (inst.instanceModule, inst.instanceParentVars) + [ (inst ^. #module_, inst ^. #parentVars) | (inst, _, _) <- modulesInOrder ] filtered = - filter (\am -> not (Set.member (am.name, am.parentVars) composedKeys)) existing + filter (\am -> not (Set.member (am ^. #name, am ^. #parentVars) composedKeys)) existing new = [ AppliedModule - { name = inst.instanceModule, - parentVars = inst.instanceParentVars, - source = dir, - moduleVersion = m.version, + { name = inst ^. #module_, + parentVars = inst ^. #parentVars, + origin = origin, + moduleVersion = m ^. #version, appliedAt = now, - removal = m.removal + removal = m ^. #removal } - | (inst, m, dir) <- modulesInOrder + | (inst, m, origin) <- modulesInOrder ] in filtered ++ new @@ -497,24 +545,24 @@ renderModuleLoadError = \case ModuleNotFound name searched -> "Module '" - <> name.unModuleName + <> name ^. #unModuleName <> "' not found. Searched in:\n" <> T.intercalate "\n" (map ((" " <>) . T.pack) searched) DhallEvalError name msg -> - "Failed to evaluate '" <> name.unModuleName <> "': " <> msg + "Failed to evaluate '" <> name ^. #unModuleName <> "': " <> msg DhallDecodeError name msg -> - "Failed to decode '" <> name.unModuleName <> "': " <> msg + "Failed to decode '" <> name ^. #unModuleName <> "': " <> msg ValidationError name msgs -> "Validation failed for '" - <> name.unModuleName + <> name ^. #unModuleName <> "':\n" <> T.intercalate "\n" (map (" " <>) msgs) CircularDependency names -> "Circular dependency detected: " - <> T.intercalate " -> " (map (.unModuleName) names) + <> T.intercalate " -> " (map (^. #unModuleName) names) MissingSourceFile name path -> "Missing source file in '" - <> name.unModuleName + <> name ^. #unModuleName <> "': " <> T.pack path RegistryEvalError path msg -> diff --git a/src-exe/Seihou/CLI/Assist.hs b/src-exe/Seihou/CLI/Assist.hs --- a/src-exe/Seihou/CLI/Assist.hs +++ b/src-exe/Seihou/CLI/Assist.hs @@ -6,12 +6,13 @@ where import Data.FileEmbed (embedFile) +import Data.Generics.Labels () import Data.Text.Encoding qualified as TE import Data.Text.IO qualified as TIO import Seihou.CLI.AgentCompletion ( AgentModelConfig (..), AgentProvider (..), - buildAgentCompletionRequest, + buildAgentCompletionRequestWith, runAgentCompletion, ) import Seihou.CLI.AgentLaunch @@ -26,7 +27,9 @@ substitute, ) import Seihou.CLI.AgentLaunchExec (launchConfiguredAgent) +import Seihou.CLI.AgentTrace (traceSinkForConfig) import Seihou.CLI.Commands (AssistOpts (..)) +import Seihou.Core.Types (LogLevel (..)) import Seihou.Prelude import System.Exit (exitFailure, exitWith) @@ -38,12 +41,12 @@ handleAssist debug modelConfig assistOpts = do ctx <- gatherAgentContext let systemPrompt = renderPrompt ctx - runRenderedAgentPrompt debug modelConfig systemPrompt assistOpts.assistPrompt + runRenderedAgentPrompt debug modelConfig systemPrompt (assistOpts ^. #prompt) renderPrompt :: AgentContext -> Text renderPrompt ctx = substitute - [ ("cwd", ctx.cwd), + [ ("cwd", ctx ^. #cwd), ("seihou_project_state", formatSeihouProjectState ctx), ("manifest_state", formatManifestState ctx), ("module_dhall_state", formatModuleDhallState ctx), @@ -55,11 +58,12 @@ runRenderedAgentPrompt :: Bool -> AgentModelConfig -> Text -> Maybe Text -> IO () runRenderedAgentPrompt debug modelConfig systemPrompt initialPrompt | debug = TIO.putStr systemPrompt - | modelConfig.agentProvider == AgentProviderClaudeCli || modelConfig.agentProvider == AgentProviderCodexCli = do + | modelConfig ^. #provider == AgentProviderClaudeCli || modelConfig ^. #provider == AgentProviderCodexCli = do exitCode <- launchConfiguredAgent modelConfig defaultAllowedTools debug systemPrompt initialPrompt exitWith exitCode | otherwise = do - result <- runAgentCompletion (buildAgentCompletionRequest modelConfig systemPrompt initialPrompt) + sink <- traceSinkForConfig LogNormal modelConfig + result <- runAgentCompletion (buildAgentCompletionRequestWith sink modelConfig systemPrompt initialPrompt) case result of Right assistantText -> TIO.putStrLn assistantText Left err -> do diff --git a/src-exe/Seihou/CLI/Bootstrap.hs b/src-exe/Seihou/CLI/Bootstrap.hs --- a/src-exe/Seihou/CLI/Bootstrap.hs +++ b/src-exe/Seihou/CLI/Bootstrap.hs @@ -6,13 +6,14 @@ where import Data.FileEmbed (embedFile) +import Data.Generics.Labels () 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 (..), - buildAgentCompletionRequest, + buildAgentCompletionRequestWith, runAgentCompletion, ) import Seihou.CLI.AgentLaunch @@ -27,7 +28,9 @@ substitute, ) import Seihou.CLI.AgentLaunchExec (launchConfiguredAgent) +import Seihou.CLI.AgentTrace (traceSinkForConfig) import Seihou.CLI.Commands (BootstrapOpts (..)) +import Seihou.Core.Types (LogLevel (..)) import Seihou.Prelude import System.Exit (exitFailure, exitWith) @@ -39,12 +42,12 @@ handleBootstrap debug modelConfig bootstrapOpts = do ctx <- gatherAgentContext let systemPrompt = renderPrompt ctx bootstrapOpts - runRenderedAgentPrompt debug modelConfig systemPrompt bootstrapOpts.bootstrapPrompt + runRenderedAgentPrompt debug modelConfig systemPrompt (bootstrapOpts ^. #prompt) renderPrompt :: AgentContext -> BootstrapOpts -> Text renderPrompt ctx bootstrapOpts = substitute - [ ("cwd", ctx.cwd), + [ ("cwd", ctx ^. #cwd), ("seihou_project_state", formatSeihouProjectState ctx), ("manifest_state", formatManifestState ctx), ("module_dhall_state", formatModuleDhallState ctx), @@ -57,11 +60,12 @@ runRenderedAgentPrompt :: Bool -> AgentModelConfig -> Text -> Maybe Text -> IO () runRenderedAgentPrompt debug modelConfig systemPrompt initialPrompt | debug = TIO.putStr systemPrompt - | modelConfig.agentProvider == AgentProviderClaudeCli || modelConfig.agentProvider == AgentProviderCodexCli = do + | modelConfig ^. #provider == AgentProviderClaudeCli || modelConfig ^. #provider == AgentProviderCodexCli = do exitCode <- launchConfiguredAgent modelConfig bootstrapAllowedTools debug systemPrompt initialPrompt exitWith exitCode | otherwise = do - result <- runAgentCompletion (buildAgentCompletionRequest modelConfig systemPrompt initialPrompt) + sink <- traceSinkForConfig LogNormal modelConfig + result <- runAgentCompletion (buildAgentCompletionRequestWith sink modelConfig systemPrompt initialPrompt) case result of Right assistantText -> TIO.putStrLn assistantText Left err -> do @@ -70,7 +74,7 @@ bootstrapMode :: BootstrapOpts -> Text bootstrapMode opts - | opts.bootstrapRepo = + | (opts ^. #repo) = T.unlines [ "**Mode: Multi-module repository**", "", diff --git a/src-exe/Seihou/CLI/Browse.hs b/src-exe/Seihou/CLI/Browse.hs --- a/src-exe/Seihou/CLI/Browse.hs +++ b/src-exe/Seihou/CLI/Browse.hs @@ -3,6 +3,7 @@ ) where +import Data.Generics.Labels () import Data.Text qualified as T import Data.Text.IO qualified as TIO import Seihou.CLI.BrowseFormat (formatBrowseRegistry, formatBrowseSingleBlueprint, formatBrowseSingleModule, formatBrowseSinglePrompt) @@ -21,7 +22,7 @@ handleBrowse :: BrowseOpts -> IO () handleBrowse bopts = do - let source = bopts.browseSource + let source = (bopts ^. #source) withSystemTempDirectory "seihou-browse" $ \tmpDir -> do let repoName = parseModuleName source @@ -50,7 +51,7 @@ logIO LogNormal (logError $ "failed to load module: " <> T.pack (show err)) exitFailure Right m -> - TIO.putStr $ formatBrowseSingleModule source m.name.unModuleName m.description + TIO.putStr $ formatBrowseSingleModule source (m ^. #name . #unModuleName) (m ^. #description) SingleRecipe rootDir -> do let dhallFile = rootDir "recipe.dhall" decoded <- evalRecipeFromFile dhallFile @@ -59,7 +60,7 @@ logIO LogNormal (logError $ "failed to load recipe: " <> T.pack (show err)) exitFailure Right r -> - TIO.putStr $ formatBrowseSingleModule source r.name.unRecipeName r.description + TIO.putStr $ formatBrowseSingleModule source (r ^. #name . #unRecipeName) (r ^. #description) SingleBlueprint rootDir -> do let dhallFile = rootDir "blueprint.dhall" decoded <- evalBlueprintFromFile dhallFile @@ -68,9 +69,7 @@ logIO LogNormal (logError $ "failed to load blueprint: " <> T.pack (show err)) exitFailure Right b -> do - let bpName = case b of Blueprint nm _ _ _ _ _ _ _ _ _ _ -> nm - bpDesc = case b of Blueprint _ _ d _ _ _ _ _ _ _ _ -> d - TIO.putStr $ formatBrowseSingleBlueprint source bpName.unModuleName bpDesc + TIO.putStr $ formatBrowseSingleBlueprint source (b ^. #name . #unModuleName) (b ^. #description) SinglePrompt rootDir -> do let dhallFile = rootDir "prompt.dhall" decoded <- evalAgentPromptFromFile dhallFile @@ -79,16 +78,16 @@ logIO LogNormal (logError $ "failed to load prompt: " <> T.pack (show err)) exitFailure Right p -> - TIO.putStr $ formatBrowseSinglePrompt source p.name.unModuleName p.description + TIO.putStr $ formatBrowseSinglePrompt source (p ^. #name . #unModuleName) (p ^. #description) MultiModule registry -> do driftWarnings <- checkRegistryVersionDrift cloneDir registry logIO LogNormal (mapM_ logWarn driftWarnings) - let matchTag e = case bopts.browseTag of + let matchTag e = case bopts ^. #tag of Nothing -> True - Just tag -> tag `elem` e.tags + Just tag -> tag `elem` (e ^. #tags) tagged = - [(ModuleEntry, e) | e <- registry.modules, matchTag e] - ++ [(RecipeEntry, e) | e <- registry.recipes, matchTag e] - ++ [(BlueprintEntry, e) | e <- registry.blueprints, matchTag e] - ++ [(PromptEntry, e) | e <- registry.prompts, matchTag e] - TIO.putStr $ formatBrowseRegistry source registry tagged bopts.browseTag + [(ModuleEntry, e) | e <- registry ^. #modules, matchTag e] + ++ [(RecipeEntry, e) | e <- registry ^. #recipes, matchTag e] + ++ [(BlueprintEntry, e) | e <- registry ^. #blueprints, matchTag e] + ++ [(PromptEntry, e) | e <- registry ^. #prompts, matchTag e] + TIO.putStr $ formatBrowseRegistry source registry tagged (bopts ^. #tag) diff --git a/src-exe/Seihou/CLI/Commands.hs b/src-exe/Seihou/CLI/Commands.hs --- a/src-exe/Seihou/CLI/Commands.hs +++ b/src-exe/Seihou/CLI/Commands.hs @@ -39,18 +39,21 @@ RegistryCommand (..), SyncVersionsOpts (..), ValidateRegistryOpts (..), + ManifestCommand (..), + ManifestUpgradeOpts (..), commandParser, opts, ) where import Data.Text qualified as T -import GHC.Generics (Generic) import Options.Applicative import Options.Applicative.Help.Pretty (Doc, indent, line, pretty, vsep) import Seihou.CLI.Extension (ExtensionRunOpts (..)) import Seihou.CLI.Help (HelpCommand, helpCommandParser) import Seihou.CLI.Kit (KitCommand, kitCommandParser) +import Seihou.CLI.Manifest (ManifestCommand (..)) +import Seihou.CLI.ManifestUpgrade (ManifestUpgradeOpts (..)) import Seihou.CLI.Migrate (MigrateOpts (..)) import Seihou.CLI.Registry (RegistryCommand (..)) import Seihou.CLI.Registry.Sync (SyncVersionsOpts (..)) @@ -84,6 +87,7 @@ | Migrate MigrateOpts | SchemaUpgrade SchemaUpgradeOpts | Registry RegistryCommand + | ManifestCmd ManifestCommand | Kit KitCommand | Agent AgentOpts | Prompt PromptCommand @@ -103,16 +107,17 @@ deriving stock (Eq, Show, Generic) data AgentOpts = AgentOpts - { agentDebug :: Bool, - agentProvider :: Maybe Text, - agentModel :: Maybe Text, - agentEffort :: Maybe Text, - agentCommand :: AgentCommand + { debug :: !Bool, + provider :: !(Maybe Text), + model :: !(Maybe Text), + effort :: !(Maybe Text), + trace :: !(Maybe Text), + command :: !AgentCommand } deriving stock (Eq, Show, Generic) data AgentModelsOpts = AgentModelsOpts - { modelsProvider :: Maybe Text + { modelsProvider :: !(Maybe Text) } deriving stock (Eq, Show, Generic) @@ -127,20 +132,20 @@ deriving stock (Eq, Show, Generic) data RunOpts = RunOpts - { runModule :: Maybe ModuleName, - runAdditional :: [ModuleName], - runVars :: [(Text, Text)], - runDryRun :: Bool, - runDiff :: Bool, - runForce :: Bool, - runNoCommands :: Bool, - runNamespace :: Maybe Text, - runContext :: Maybe Text, - runVerbose :: Bool, - runSavePrompted :: Maybe Bool, - runConfirmDefaults :: Bool, - runCommit :: Bool, - runCommitMessage :: Maybe Text, + { module_ :: !(Maybe ModuleName), + additional :: ![ModuleName], + vars :: ![(Text, Text)], + dryRun :: !Bool, + diff :: !Bool, + force :: !Bool, + noCommands :: !Bool, + namespace :: !(Maybe Text), + context :: !(Maybe Text), + verbose :: !Bool, + savePrompted :: !(Maybe Bool), + confirmDefaults :: !Bool, + commit :: !Bool, + commitMessage :: !(Maybe Text), -- | When 'True', a pre-flight pending-migration check that finds -- any chain for one of the composed modules will apply that chain -- to the project (and the manifest) before the run plan is @@ -148,89 +153,106 @@ -- 'seihou run' to refuse with an actionable message and a -- non-zero exit, so a user never silently writes new templates -- into paths a migration would have moved. - runWithMigrations :: Bool + withMigrations :: !Bool, + -- | When 'True', generate even though a module installed on this + -- machine is older than the version @.seihou\/manifest.json@ + -- records, or came from a different origin than it records. When + -- 'False' (the default), either condition makes @seihou run@ refuse + -- before writing anything, so a developer whose install cache lags + -- behind a teammate's commit cannot silently regenerate the project + -- from the older module. The blocking artifacts are printed either + -- way; the flag only decides whether the run continues. + allowDowngrade :: !Bool } deriving stock (Eq, Show, Generic) data UpdateOpts = UpdateOpts - { updateTargets :: [Text], - updateVars :: [(Text, Text)], - updateDryRun :: Bool, - updateJson :: Bool, - updateReconfigure :: Bool, - updateForce :: Bool, - updateRunAllCommands :: Bool, - updateNoCommands :: Bool, - updateCommit :: Bool, - updateCommitMessage :: Maybe Text + { targets :: ![Text], + vars :: ![(Text, Text)], + dryRun :: !Bool, + json :: !Bool, + reconfigure :: !Bool, + force :: !Bool, + runAllCommands :: !Bool, + noCommands :: !Bool, + commit :: !Bool, + commitMessage :: !(Maybe Text), + -- | When 'True', accept a candidate artifact whose version is lower + -- than the version @.seihou\/manifest.json@ records. Unlike + -- @seihou run@, @seihou update@ does not generate from whatever is + -- installed locally — it clones from the origin URL the manifest + -- itself records — so the only downgrade it can produce is an + -- upstream that moved backwards. This flag is the escape hatch for + -- pinning to such a version deliberately. + allowDowngrade :: !Bool } deriving stock (Eq, Show, Generic) data RemoveOpts = RemoveOpts - { removeModule :: ModuleName, - removeDryRun :: Bool, - removeForce :: Bool, - removeVerbose :: Bool + { module_ :: !ModuleName, + dryRun :: !Bool, + force :: !Bool, + verbose :: !Bool } deriving stock (Eq, Show, Generic) data VarsOpts = VarsOpts - { varsModule :: Maybe ModuleName, - varsExplain :: Bool, - varsVars :: [(Text, Text)], - varsNamespace :: Maybe Text, - varsContext :: Maybe Text + { module_ :: !(Maybe ModuleName), + explain :: !Bool, + vars :: ![(Text, Text)], + namespace :: !(Maybe Text), + context :: !(Maybe Text) } deriving stock (Eq, Show, Generic) data InstallOpts = InstallOpts - { installSource :: Maybe Text, - installName :: Maybe Text, - installModules :: [Text], - installAll :: Bool + { source :: !(Maybe Text), + name :: !(Maybe Text), + modules :: ![Text], + all :: !Bool } deriving stock (Eq, Show, Generic) data NewModuleOpts = NewModuleOpts - { newModuleName :: Text, - newModulePath :: Maybe FilePath + { name :: !Text, + path :: !(Maybe FilePath) } deriving stock (Eq, Show, Generic) data NewRecipeOpts = NewRecipeOpts - { newRecipeName :: Text, - newRecipeModules :: [Text], - newRecipePath :: Maybe FilePath + { name :: !Text, + modules :: ![Text], + path :: !(Maybe FilePath) } deriving stock (Eq, Show, Generic) data NewBlueprintOpts = NewBlueprintOpts - { newBlueprintName :: Text, - newBlueprintPath :: Maybe FilePath + { name :: !Text, + path :: !(Maybe FilePath) } deriving stock (Eq, Show, Generic) data NewPromptOpts = NewPromptOpts - { newPromptName :: Text, - newPromptPath :: Maybe FilePath + { name :: !Text, + path :: !(Maybe FilePath) } deriving stock (Eq, Show, Generic) data ValidateOpts = ValidateOpts - { validatePath :: Maybe FilePath, - validateLint :: Bool + { path :: !(Maybe FilePath), + lint :: !Bool } deriving stock (Eq, Show, Generic) data ValidateBlueprintOpts = ValidateBlueprintOpts - { validateBlueprintPath :: Maybe FilePath, - validateBlueprintLint :: Bool + { path :: !(Maybe FilePath), + lint :: !Bool } deriving stock (Eq, Show, Generic) data ValidatePromptOpts = ValidatePromptOpts - { validatePromptPath :: Maybe FilePath, - validatePromptLint :: Bool + { path :: !(Maybe FilePath), + lint :: !Bool } deriving stock (Eq, Show, Generic) @@ -242,11 +264,11 @@ deriving stock (Eq, Show, Generic) data ConfigOpts = ConfigOpts - { configAction :: ConfigAction, - configGlobal :: Bool, - configNamespace :: Maybe Text, - configContext :: Maybe Text, - configEffective :: Bool + { action :: !ConfigAction, + global :: !Bool, + namespace :: !(Maybe Text), + context :: !(Maybe Text), + effective :: !Bool } deriving stock (Eq, Show, Generic) @@ -259,105 +281,111 @@ deriving stock (Eq, Show, Generic) data ListOpts = ListOpts - { listRepo :: Maybe Text, - listTag :: Maybe Text, - listModulesOnly :: Bool, - listRecipesOnly :: Bool, - listBlueprintsOnly :: Bool, - listPromptsOnly :: Bool + { repo :: !(Maybe Text), + tag :: !(Maybe Text), + modulesOnly :: !Bool, + recipesOnly :: !Bool, + blueprintsOnly :: !Bool, + promptsOnly :: !Bool } deriving stock (Eq, Show, Generic) data BrowseOpts = BrowseOpts - { browseSource :: Text, - browseTag :: Maybe Text + { source :: !Text, + tag :: !(Maybe Text) } deriving stock (Eq, Show, Generic) data StatusOpts = StatusOpts - { statusCheckUpdates :: Bool + { statusCheckUpdates :: !Bool } deriving stock (Eq, Show, Generic) data OutdatedOpts = OutdatedOpts - { outdatedJson :: Bool + { outdatedJson :: !Bool } deriving stock (Eq, Show, Generic) data UpgradeOpts = UpgradeOpts - { upgradeModules :: [Text], - upgradeDryRun :: Bool, - upgradeJson :: Bool, - upgradeSkipUnversioned :: Bool, + { modules :: ![Text], + dryRun :: !Bool, + json :: !Bool, + skipUnversioned :: !Bool, -- | If 'True', after each successful per-module upgrade, also run -- 'Seihou.CLI.Migrate.runMigrate' against the *current project* -- (cwd), if and only if that module is applied locally. Default -- 'False'; the unset path emits a one-line advisory pointing the -- user at @seihou update@ when migrations would be pending. - upgradeWithMigrations :: Bool + withMigrations :: !Bool } deriving stock (Eq, Show, Generic) data SchemaUpgradeOpts = SchemaUpgradeOpts - { schemaUpgradePath :: Maybe FilePath, - schemaUpgradeDryRun :: Bool, - schemaUpgradeAll :: Bool + { path :: !(Maybe FilePath), + dryRun :: !Bool, + all :: !Bool } deriving stock (Eq, Show, Generic) data AssistOpts = AssistOpts - { assistPrompt :: Maybe Text, - assistProvider :: Maybe Text, - assistModel :: Maybe Text, - assistEffort :: Maybe Text + { prompt :: !(Maybe Text), + provider :: !(Maybe Text), + model :: !(Maybe Text), + effort :: !(Maybe Text), + trace :: !(Maybe Text) } deriving stock (Eq, Show, Generic) data BootstrapOpts = BootstrapOpts - { bootstrapPrompt :: Maybe Text, - bootstrapRepo :: Bool, - bootstrapProvider :: Maybe Text, - bootstrapModel :: Maybe Text, - bootstrapEffort :: Maybe Text + { prompt :: !(Maybe Text), + repo :: !Bool, + provider :: !(Maybe Text), + model :: !(Maybe Text), + effort :: !(Maybe Text), + trace :: !(Maybe Text) } deriving stock (Eq, Show, Generic) data SetupOpts = SetupOpts - { setupPrompt :: Maybe Text, - setupProvider :: Maybe Text, - setupModel :: Maybe Text, - setupEffort :: Maybe Text + { prompt :: !(Maybe Text), + provider :: !(Maybe Text), + model :: !(Maybe Text), + effort :: !(Maybe Text), + trace :: !(Maybe Text) } deriving stock (Eq, Show, Generic) data BlueprintRunOpts = BlueprintRunOpts - { runBlueprintName :: ModuleName, - runBlueprintPrompt :: Maybe Text, - runBlueprintVars :: [(Text, Text)], - runBlueprintNoBaseline :: Bool, - runBlueprintNamespace :: Maybe Text, - runBlueprintContext :: Maybe Text, - runBlueprintVerbose :: Bool, - runBlueprintForce :: Bool, - runBlueprintProvider :: Maybe Text, - runBlueprintModel :: Maybe Text, - runBlueprintEffort :: Maybe Text + { name :: !ModuleName, + prompt :: !(Maybe Text), + vars :: ![(Text, Text)], + noBaseline :: !Bool, + namespace :: !(Maybe Text), + context :: !(Maybe Text), + verbose :: !Bool, + force :: !Bool, + batch :: !Bool, + provider :: !(Maybe Text), + model :: !(Maybe Text), + effort :: !(Maybe Text), + trace :: !(Maybe Text) } deriving stock (Eq, Show, Generic) data BlueprintMigrationOpts = BlueprintMigrationOpts - { migrateBlueprintName :: ModuleName, - migrateBlueprintFrom :: Text, - migrateBlueprintTo :: Text, - migrateBlueprintPrompt :: Maybe Text, - migrateBlueprintVars :: [(Text, Text)], - migrateBlueprintNamespace :: Maybe Text, - migrateBlueprintContext :: Maybe Text, - migrateBlueprintVerbose :: Bool, - migrateBlueprintRerun :: Bool, - migrateBlueprintProvider :: Maybe Text, - migrateBlueprintModel :: Maybe Text, - migrateBlueprintEffort :: Maybe Text + { name :: !ModuleName, + from :: !Text, + to :: !Text, + prompt :: !(Maybe Text), + vars :: ![(Text, Text)], + namespace :: !(Maybe Text), + context :: !(Maybe Text), + verbose :: !Bool, + rerun :: !Bool, + provider :: !(Maybe Text), + model :: !(Maybe Text), + effort :: !(Maybe Text), + trace :: !(Maybe Text) } deriving stock (Eq, Show, Generic) @@ -366,16 +394,17 @@ deriving stock (Eq, Show, Generic) data PromptRunOpts = PromptRunOpts - { runPromptName :: ModuleName, - runPromptPrompt :: Maybe Text, - runPromptVars :: [(Text, Text)], - runPromptNamespace :: Maybe Text, - runPromptContext :: Maybe Text, - runPromptVerbose :: Bool, - runPromptDebug :: Bool, - runPromptProvider :: Maybe Text, - runPromptModel :: Maybe Text, - runPromptEffort :: Maybe Text + { name :: !ModuleName, + prompt :: !(Maybe Text), + vars :: ![(Text, Text)], + namespace :: !(Maybe Text), + context :: !(Maybe Text), + verbose :: !Bool, + debug :: !Bool, + provider :: !(Maybe Text), + model :: !(Maybe Text), + effort :: !(Maybe Text), + trace :: !(Maybe Text) } deriving stock (Eq, Show, Generic) @@ -420,6 +449,7 @@ <> command "remove" removeInfo <> command "status" statusInfo <> command "diff" diffInfo + <> command "manifest" manifestInfo ) <|> hsubparser ( command "list" listInfo @@ -833,6 +863,10 @@ ( long "with-migrations" <> help "Apply any pending module migrations before the run plan; without this, 'seihou run' refuses when migrations are pending" ) + <*> switch + ( long "allow-downgrade" + <> help "Proceed even when a module installed locally is older than the version recorded in .seihou/manifest.json" + ) updateParser :: Parser Command updateParser = @@ -851,19 +885,24 @@ <*> updateCommandFlags <*> switch (long "commit" <> help "Commit successfully updated managed paths") <*> optional (option (T.pack <$> str) (long "commit-message" <> metavar "MSG" <> help "Custom commit message (implies --commit)")) + <*> switch + ( long "allow-downgrade" + <> help "Accept a candidate artifact older than the version recorded in .seihou/manifest.json" + ) where - makeUpdateOpts targets vars dryRun json reconfigure force (runAll, noCommands) commit commitMessage = + makeUpdateOpts targets vars dryRun json reconfigure force (runAll, noCommands) commit commitMessage allowDowngrade = UpdateOpts - { updateTargets = targets, - updateVars = vars, - updateDryRun = dryRun, - updateJson = json, - updateReconfigure = reconfigure, - updateForce = force, - updateRunAllCommands = runAll, - updateNoCommands = noCommands, - updateCommit = commit, - updateCommitMessage = commitMessage + { targets = targets, + vars = vars, + dryRun = dryRun, + json = json, + reconfigure = reconfigure, + force = force, + runAllCommands = runAll, + noCommands = noCommands, + commit = commit, + commitMessage = commitMessage, + allowDowngrade = allowDowngrade } updateCommandFlags = flag' (True, False) (long "run-all-commands" <> help "Run every generated command, including unchanged ones") @@ -1278,6 +1317,10 @@ <*> switch (long "no-fetch" <> help "Skip the remote fetch; use only the locally installed copy") <*> switch (long "commit" <> help "Commit migrated files to git after execution (uses AI-generated message)") <*> optional (option (T.pack <$> str) (long "commit-message" <> metavar "MSG" <> help "Custom commit message (implies --commit)")) + <*> switch + ( long "allow-downgrade" + <> help "Proceed even when a module installed locally is older than the version recorded in .seihou/manifest.json" + ) migrateFooter :: Doc migrateFooter = @@ -1366,6 +1409,70 @@ <> progDesc "Manage Claude Code and Codex skills and subagents" ) +manifestInfo :: ParserInfo Command +manifestInfo = + info + (ManifestCmd <$> manifestCommandParser <**> helper) + ( fullDesc + <> progDesc "Operate on this project's .seihou/manifest.json" + <> footerDoc + ( Just $ + vsep + [ pretty ("The manifest is checked into version control and describes the" :: String), + pretty ("project, not the machine. These commands maintain it." :: String), + line, + pretty ("Current subcommands:" :: String), + indent 2 $ + vsep + [ pretty ("upgrade Convert a manifest written by an older seihou" :: String) + ], + line, + pretty ("Examples:" :: String), + indent 2 $ + vsep + [ pretty ("seihou manifest upgrade --dry-run" :: String), + pretty ("seihou manifest upgrade" :: String) + ] + ] + ) + ) + +manifestCommandParser :: Parser ManifestCommand +manifestCommandParser = + hsubparser + (command "upgrade" manifestUpgradeInfo) + +manifestUpgradeInfo :: ParserInfo ManifestCommand +manifestUpgradeInfo = + info + (manifestUpgradeParser <**> helper) + ( fullDesc + <> progDesc "Convert a manifest written by an older seihou to the portable format" + <> footerDoc + ( Just $ + vsep + [ 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), + pretty ("module was installed from, or a path relative to the project root." :: String), + line, + pretty ("Recovering an upstream URL from somebody else's absolute path takes" :: String), + pretty ("inference, so every conversion is printed. Review the result with" :: String), + pretty ("git diff .seihou/manifest.json before committing it." :: String), + line, + pretty ("Run from the project root. Running it twice is safe." :: String) + ] + ) + ) + +manifestUpgradeParser :: Parser ManifestCommand +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") + registryInfo :: ParserInfo Command registryInfo = info @@ -1529,6 +1636,7 @@ ) ) <*> effortOption + <*> traceOption <*> agentCommandParser agentCommandParser :: Parser AgentCommand @@ -1581,6 +1689,7 @@ <*> providerOption <*> modelOption <*> effortOption + <*> traceOption agentBootstrapInfo :: ParserInfo AgentCommand agentBootstrapInfo = @@ -1619,6 +1728,7 @@ <*> providerOption <*> modelOption <*> effortOption + <*> traceOption agentSetupInfo :: ParserInfo AgentCommand agentSetupInfo = @@ -1656,6 +1766,7 @@ <*> providerOption <*> modelOption <*> effortOption + <*> traceOption agentRunInfo :: ParserInfo AgentCommand agentRunInfo = @@ -1678,6 +1789,8 @@ pretty ("Pass --no-baseline to skip baseline application; --debug (on the parent" :: String), pretty ("'seihou agent --debug') prints the resolved system prompt without" :: String), pretty ("contacting the configured provider." :: String), + pretty ("Pass --batch to use a non-interactive CLI provider; Seihou selects" :: String), + pretty ("batch mode automatically when stdin is not a terminal." :: String), line, pretty ("Examples:" :: String), indent 2 $ @@ -1686,6 +1799,7 @@ pretty ("seihou agent run my-blueprint \"set this up for billing\"" :: String), pretty ("seihou agent run my-blueprint --var service.name=billing" :: String), pretty ("seihou agent run my-blueprint --no-baseline" :: String), + pretty ("seihou agent run my-blueprint --batch" :: String), pretty ("seihou agent --debug run my-blueprint" :: String) ] ] @@ -1708,9 +1822,11 @@ <*> optional (option (T.pack <$> str) (long "context" <> short 'c' <> metavar "CTX" <> help "Override context for config lookup")) <*> switch (long "verbose" <> short 'v' <> help "Show detailed progress messages") <*> switch (long "force" <> help "Auto-resolve baseline conflicts (accept new files)") + <*> switch (long "batch" <> help "Run a non-interactive CLI provider (automatic when stdin is not a terminal)") <*> providerOption <*> modelOption <*> effortOption + <*> traceOption agentMigrateInfo :: ParserInfo AgentCommand agentMigrateInfo = @@ -1760,6 +1876,7 @@ <*> providerOption <*> modelOption <*> effortOption + <*> traceOption agentModelsInfo :: ParserInfo AgentCommand agentModelsInfo = @@ -1896,6 +2013,7 @@ <*> providerOption <*> modelOption <*> effortOption + <*> traceOption helpCmdInfo :: ParserInfo Command helpCmdInfo = @@ -2021,4 +2139,14 @@ ( long "effort" <> metavar "LEVEL" <> help "Reasoning effort: minimal, low, medium, high, xhigh, or max" + ) + +traceOption :: Parser (Maybe Text) +traceOption = + optional $ + option + (T.pack <$> str) + ( long "trace" + <> metavar "SETTING" + <> help "Record model calls: off, file, stdout, or stderr (file path: agent.tracePath)" ) diff --git a/src-exe/Seihou/CLI/Config.hs b/src-exe/Seihou/CLI/Config.hs --- a/src-exe/Seihou/CLI/Config.hs +++ b/src-exe/Seihou/CLI/Config.hs @@ -18,15 +18,15 @@ import System.Exit (exitFailure) handleConfig :: ConfigOpts -> IO () -handleConfig ConfigOpts {configAction, configGlobal, configNamespace, configContext, configEffective} = do - let scope = resolveScope configGlobal configNamespace configContext - case configAction of +handleConfig ConfigOpts {action, global, namespace, context, effective} = do + let scope = resolveScope global namespace context + case action of ConfigSet key value -> handleSet scope key value ConfigGet key -> handleGet scope key ConfigUnset key -> handleUnset scope key ConfigList - | configEffective -> handleListEffective configNamespace configContext - | otherwise -> handleList configGlobal configNamespace configContext + | effective -> handleListEffective namespace context + | otherwise -> handleList global namespace context resolveScope :: Bool -> Maybe Text -> Maybe Text -> ConfigScope resolveScope True _ _ = ScopeGlobal diff --git a/src-exe/Seihou/CLI/Context.hs b/src-exe/Seihou/CLI/Context.hs --- a/src-exe/Seihou/CLI/Context.hs +++ b/src-exe/Seihou/CLI/Context.hs @@ -64,7 +64,7 @@ else do entries <- listDirectory contextsDir dirs <- filterM (doesDirectoryExist . (contextsDir )) entries - let candidates = [Candidate {candidateDisplay = T.pack d, candidateValue = T.pack d} | d <- dirs] + let candidates = [Candidate {display = T.pack d, value = T.pack d} | d <- dirs] opts = withPrompt "context> " <> withHeight "40%" <> withAnsi <> withNoSort runEff $ runFzfIO fzfCfg $ selectOne opts candidates where diff --git a/src-exe/Seihou/CLI/Help.hs b/src-exe/Seihou/CLI/Help.hs --- a/src-exe/Seihou/CLI/Help.hs +++ b/src-exe/Seihou/CLI/Help.hs @@ -9,6 +9,7 @@ import Data.FileEmbed (embedStringFile) import Data.Foldable (forM_) +import Data.Generics.Labels () import Data.List (find) import Data.Text qualified as T import Data.Text.IO qualified as TIO @@ -16,10 +17,11 @@ import Seihou.Prelude data HelpTopic = HelpTopic - { topicName :: !Text, - topicDescription :: !Text, - topicContent :: !Text + { name :: !Text, + description :: !Text, + content :: !Text } + deriving stock (Generic) data HelpCommand = ListTopics @@ -36,6 +38,7 @@ HelpTopic "config" "Config scopes, reading, and writing values" configContent, HelpTopic "git-repository" "Sharing and installing items from git" gitRepositoryContent, HelpTopic "kit" "Manage Claude Code and Codex skills and subagents" kitContent, + HelpTopic "manifest" "What .seihou/manifest.json records and how to upgrade it" manifestContent, HelpTopic "migrations" "Migrating a project between module versions" migrationsContent, HelpTopic "prompts" "Reusable agent-session prompt artifacts" promptsContent, HelpTopic "templating" "Placeholder substitution, {{#if}} blocks, and patterns" templatingContent, @@ -66,6 +69,9 @@ kitContent :: Text kitContent = $(embedStringFile "help/kit.md") +manifestContent :: Text +manifestContent = $(embedStringFile "help/manifest.md") + migrationsContent :: Text migrationsContent = $(embedStringFile "help/migrations.md") @@ -90,7 +96,7 @@ <> help ("Help topic: " <> T.unpack topicList) ) where - topicList = T.intercalate ", " (map (.topicName) helpTopics) + topicList = T.intercalate ", " (map (^. #name) helpTopics) handleHelpCommand :: HelpCommand -> IO () handleHelpCommand = \case @@ -101,7 +107,7 @@ listTopics = do TIO.putStrLn "HELP TOPICS\n" forM_ helpTopics $ \t -> - TIO.putStrLn $ " " <> padRight 17 t.topicName <> t.topicDescription + TIO.putStrLn $ " " <> padRight 17 (t ^. #name) <> (t ^. #description) TIO.putStrLn "\nUse 'seihou help ' for details." padRight :: Int -> Text -> Text @@ -109,8 +115,8 @@ showTopic :: Text -> IO () showTopic name = - case find (\t -> t.topicName == T.toLower name) helpTopics of - Just t -> TIO.putStrLn t.topicContent + case find (\t -> t ^. #name == T.toLower name) helpTopics of + Just t -> TIO.putStrLn (t ^. #content) Nothing -> do TIO.putStrLn $ "Unknown topic: " <> name - TIO.putStrLn $ "Available: " <> T.intercalate ", " (map (.topicName) helpTopics) + TIO.putStrLn $ "Available: " <> T.intercalate ", " (map (^. #name) helpTopics) diff --git a/src-exe/Seihou/CLI/Install.hs b/src-exe/Seihou/CLI/Install.hs --- a/src-exe/Seihou/CLI/Install.hs +++ b/src-exe/Seihou/CLI/Install.hs @@ -8,6 +8,7 @@ import Control.Applicative ((<|>)) import Control.Monad (when) +import Data.Generics.Labels () import Data.Text qualified as T import Data.Text.IO qualified as TIO import Seihou.CLI.BrowseFormat (kindLabel) @@ -36,7 +37,7 @@ handleInstall :: InstallOpts -> IO () handleInstall iopts = do - source <- resolveSource iopts.installSource + source <- resolveSource (iopts ^. #source) TIO.putStrLn $ "Installing from " <> source <> "..." @@ -59,19 +60,19 @@ logIO LogNormal (logError "repository contains neither seihou-registry.dhall nor a supported runnable Dhall file.") exitFailure SingleModule rootDir -> do - when (not (null iopts.installModules) || iopts.installAll) $ + 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 SingleRecipe rootDir -> do - when (not (null iopts.installModules) || iopts.installAll) $ + when (not (null (iopts ^. #modules)) || iopts ^. #all) $ logIO LogNormal (logWarn "--module and --all flags are ignored for single-recipe repositories.") installSingleRecipe iopts rootDir source SingleBlueprint rootDir -> do - when (not (null iopts.installModules) || iopts.installAll) $ + when (not (null (iopts ^. #modules)) || iopts ^. #all) $ logIO LogNormal (logWarn "--module and --all flags are ignored for single-blueprint repositories.") installSingleBlueprint iopts rootDir source SinglePrompt rootDir -> do - when (not (null iopts.installModules) || iopts.installAll) $ + when (not (null (iopts ^. #modules)) || iopts ^. #all) $ logIO LogNormal (logWarn "--module and --all flags are ignored for single-prompt repositories.") installSinglePrompt iopts rootDir source MultiModule registry -> do @@ -95,7 +96,7 @@ resolveSource (Just url) = pure url resolveSource Nothing = do history <- readHistory - case history.entries of + case history ^. #entries of [] -> do TIO.putStrLn "No URL specified and no install history found." TIO.putStrLn "Usage: seihou install " @@ -111,8 +112,8 @@ fzfUrlSelection fzfCfg entries = do let candidates = [ Candidate - { candidateDisplay = entry.url, - candidateValue = entry.url + { display = entry ^. #url, + value = entry ^. #url } | entry <- entries ] @@ -137,7 +138,7 @@ TIO.putStrLn "Previously used sources:" let numbered = zip [1 :: Int ..] entries mapM_ - (\(i, entry) -> TIO.putStrLn $ " " <> T.pack (show i) <> ") " <> entry.url) + (\(i, entry) -> TIO.putStrLn $ " " <> T.pack (show i) <> ") " <> entry ^. #url) numbered TIO.putStrLn "" TIO.putStr "Select a source (number): " @@ -146,7 +147,7 @@ case readMaybe (T.unpack (T.strip input)) of Just n | n >= 1 && n <= length entries -> - pure (entries !! (n - 1)).url + pure ((entries !! (n - 1)) ^. #url) _ -> do TIO.putStrLn "Invalid selection." exitFailure @@ -154,7 +155,7 @@ -- | Install a single-module repo (legacy behavior). installSingleModule :: InstallOpts -> FilePath -> Text -> Maybe Text -> IO () installSingleModule iopts rootDir source registryName = do - let name = case iopts.installName of + let name = case iopts ^. #name of Just n -> T.unpack n Nothing -> parseModuleName source @@ -181,14 +182,14 @@ Right _ -> pure () TIO.putStrLn " Validated module definition" - installModuleDir rootDir name source registryName modul.version [] + installModuleDir rootDir name source registryName (modul ^. #version) [] 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 - let name = case iopts.installName of + let name = case iopts ^. #name of Just n -> T.unpack n Nothing -> parseModuleName source @@ -202,7 +203,7 @@ -- | Install a single-blueprint repo. installSingleBlueprint :: InstallOpts -> FilePath -> Text -> IO () installSingleBlueprint iopts rootDir source = do - let name = case iopts.installName of + let name = case iopts ^. #name of Just n -> T.unpack n Nothing -> parseModuleName source @@ -229,7 +230,7 @@ Right _ -> pure () TIO.putStrLn " Validated blueprint definition" - let bpVersion = case bp of Blueprint _ v _ _ _ _ _ _ _ _ _ -> v + let bpVersion = (bp ^. #version) installModuleDir rootDir name source Nothing bpVersion [] TIO.putStrLn "" TIO.putStrLn $ "Blueprint available as: " <> T.pack name @@ -237,7 +238,7 @@ -- | Install a single-prompt repo. installSinglePrompt :: InstallOpts -> FilePath -> Text -> IO () installSinglePrompt iopts rootDir source = do - let name = case iopts.installName of + let name = case iopts ^. #name of Just n -> T.unpack n Nothing -> parseModuleName source @@ -264,7 +265,7 @@ Right _ -> pure () TIO.putStrLn " Validated prompt definition" - installModuleDir rootDir name source Nothing prompt.version [] + installModuleDir rootDir name source Nothing (prompt ^. #version) [] TIO.putStrLn "" TIO.putStrLn $ "Prompt available as: " <> T.pack name @@ -275,7 +276,7 @@ if null selected then TIO.putStrLn "No entries selected." else do - results <- mapM (installRegistryEntry cloneDir source registry.repoName) selected + results <- mapM (installRegistryEntry cloneDir source (registry ^. #repoName)) selected let succeeded = length (filter id results) failed = length results - succeeded TIO.putStrLn "" @@ -290,7 +291,7 @@ -- | All registry entries (modules, recipes, blueprints, prompts) in display order. -- Used wherever installation must treat all four kinds uniformly. allEntries :: Registry -> [RegistryEntry] -allEntries registry = registry.modules ++ registry.recipes ++ registry.blueprints ++ registry.prompts +allEntries registry = registry ^. #modules ++ registry ^. #recipes ++ registry ^. #blueprints ++ (registry ^. #prompts) -- | Pair each registry entry with its 'EntryKind' tag, preserving the -- module → recipe → blueprint → prompt display order. Used by the install picker @@ -298,18 +299,18 @@ -- after selection. labelledEntries :: Registry -> [(EntryKind, RegistryEntry)] labelledEntries registry = - map ((,) ModuleEntry) registry.modules - ++ map ((,) RecipeEntry) registry.recipes - ++ map ((,) BlueprintEntry) registry.blueprints - ++ map ((,) PromptEntry) registry.prompts + map ((,) ModuleEntry) (registry ^. #modules) + ++ map ((,) RecipeEntry) (registry ^. #recipes) + ++ map ((,) BlueprintEntry) (registry ^. #blueprints) + ++ map ((,) PromptEntry) (registry ^. #prompts) -- | Select which modules to install from a registry. selectModules :: InstallOpts -> Registry -> IO [RegistryEntry] selectModules iopts registry - | iopts.installAll = pure (allEntries registry) - | not (null iopts.installModules) = do + | (iopts ^. #all) = pure (allEntries registry) + | not (null (iopts ^. #modules)) = do let entries = allEntries registry - findEntry name = filter (\e -> e.name.unModuleName == name) entries + findEntry name = filter (\e -> e ^. #name . #unModuleName == name) entries (found, missing) = foldr ( \name (f, m) -> case findEntry name of @@ -317,7 +318,7 @@ [] -> (f, name : m) ) ([], []) - iopts.installModules + (iopts ^. #modules) if not (null missing) then do logIO LogNormal $ do @@ -337,13 +338,13 @@ let entries = labelledEntries registry candidates = [ Candidate - { candidateDisplay = + { display = kindLabel kind <> " " - <> entry.name.unModuleName - <> maybe "" (\d -> " " <> d) entry.description - <> if null entry.tags then "" else " [" <> T.intercalate ", " entry.tags <> "]", - candidateValue = entry + <> entry ^. #name . #unModuleName + <> maybe "" (\d -> " " <> d) (entry ^. #description) + <> if null (entry ^. #tags) then "" else " [" <> T.intercalate ", " (entry ^. #tags) <> "]", + value = entry } | (kind, entry) <- entries ] @@ -361,8 +362,8 @@ promptModuleSelection :: Registry -> IO [RegistryEntry] promptModuleSelection registry = do TIO.putStrLn "" - TIO.putStrLn $ registry.repoName - case registry.repoDescription of + TIO.putStrLn $ (registry ^. #repoName) + case registry ^. #repoDescription of Just desc -> TIO.putStrLn $ " " <> desc Nothing -> pure () TIO.putStrLn "" @@ -376,8 +377,8 @@ <> ") " <> kindLabel kind <> " " - <> entry.name.unModuleName - <> maybe "" (\d -> " - " <> d) entry.description + <> entry ^. #name . #unModuleName + <> maybe "" (\d -> " - " <> d) (entry ^. #description) ) entries TIO.putStrLn "" @@ -407,13 +408,13 @@ -- | Install a single registry entry (module, recipe, blueprint, or prompt). installRegistryEntry :: FilePath -> Text -> Text -> RegistryEntry -> IO Bool installRegistryEntry cloneDir source repoName entry = do - let entryDir = cloneDir entry.path - name = T.unpack entry.name.unModuleName + let entryDir = cloneDir (entry ^. #path) + name = T.unpack (entry ^. #name . #unModuleName) moduleDhall = entryDir "module.dhall" recipeDhall = entryDir "recipe.dhall" blueprintDhall = entryDir "blueprint.dhall" promptDhall = entryDir "prompt.dhall" - TIO.putStrLn $ " Installing " <> entry.name.unModuleName <> "..." + TIO.putStrLn $ " Installing " <> entry ^. #name . #unModuleName <> "..." hasModule <- doesFileExist moduleDhall if hasModule @@ -422,29 +423,29 @@ case decoded of Left err -> do logIO LogNormal $ do - logError $ " failed to load " <> entry.name.unModuleName <> ": " <> T.pack (show err) + logError $ " failed to load " <> entry ^. #name . #unModuleName <> ": " <> T.pack (show err) pure False Right modul -> do result <- validateModule entryDir modul case result of Left (ValidationError _ errors) -> do logIO LogNormal $ do - logError $ " " <> entry.name.unModuleName <> " has validation errors:" + logError $ " " <> entry ^. #name . #unModuleName <> " has validation errors:" mapM_ (\e -> logError $ " - " <> e) errors pure False Left err -> do logIO LogNormal (logError $ " " <> T.pack (show err)) pure False Right _ -> do - let ver = entry.version <|> modul.version - installModuleDir entryDir name source (Just repoName) ver entry.tags + let ver = entry ^. #version <|> (modul ^. #version) + installModuleDir entryDir name source (Just repoName) ver (entry ^. #tags) TIO.putStrLn $ " Installed as: " <> T.pack name pure True else do hasRecipe <- doesFileExist recipeDhall if hasRecipe then do - installModuleDir entryDir name source (Just repoName) entry.version entry.tags + installModuleDir entryDir name source (Just repoName) (entry ^. #version) (entry ^. #tags) TIO.putStrLn $ " Installed recipe as: " <> T.pack name pure True else do @@ -455,12 +456,12 @@ case decoded of Left err -> do logIO LogNormal $ do - logError $ " failed to load " <> entry.name.unModuleName <> ": " <> T.pack (show err) + logError $ " failed to load " <> entry ^. #name . #unModuleName <> ": " <> T.pack (show err) pure False Right bp -> do - let bpVersion = case bp of Blueprint _ v _ _ _ _ _ _ _ _ _ -> v - ver = entry.version <|> bpVersion - installModuleDir entryDir name source (Just repoName) ver entry.tags + let bpVersion = (bp ^. #version) + ver = entry ^. #version <|> bpVersion + installModuleDir entryDir name source (Just repoName) ver (entry ^. #tags) TIO.putStrLn $ " Installed blueprint as: " <> T.pack name pure True else do @@ -471,27 +472,27 @@ case decoded of Left err -> do logIO LogNormal $ do - logError $ " failed to load " <> entry.name.unModuleName <> ": " <> T.pack (show err) + logError $ " failed to load " <> entry ^. #name . #unModuleName <> ": " <> T.pack (show err) pure False Right prompt -> do result <- validateAgentPrompt entryDir prompt case result of Left (ValidationError _ errors) -> do logIO LogNormal $ do - logError $ " " <> entry.name.unModuleName <> " has validation errors:" + logError $ " " <> entry ^. #name . #unModuleName <> " has validation errors:" mapM_ (\e -> logError $ " - " <> e) errors pure False Left err -> do logIO LogNormal (logError $ " " <> T.pack (show err)) pure False Right _ -> do - let ver = entry.version <|> prompt.version - installModuleDir entryDir name source (Just repoName) ver entry.tags + let ver = entry ^. #version <|> (prompt ^. #version) + installModuleDir entryDir name source (Just repoName) ver (entry ^. #tags) TIO.putStrLn $ " Installed prompt as: " <> T.pack name pure True else do logIO LogNormal $ do - logError $ " entry '" <> entry.name.unModuleName <> "' has no supported runnable Dhall file at " <> T.pack entry.path + logError $ " entry '" <> entry ^. #name . #unModuleName <> "' has no supported runnable Dhall file at " <> T.pack (entry ^. #path) pure False readMaybe :: String -> Maybe Int diff --git a/src-exe/Seihou/CLI/NewBlueprint.hs b/src-exe/Seihou/CLI/NewBlueprint.hs --- a/src-exe/Seihou/CLI/NewBlueprint.hs +++ b/src-exe/Seihou/CLI/NewBlueprint.hs @@ -3,6 +3,7 @@ ) where +import Data.Generics.Labels () import Data.Text qualified as T import Data.Text.IO qualified as TIO import Seihou.CLI.Commands (NewBlueprintOpts (..)) @@ -17,7 +18,7 @@ handleNewBlueprint :: NewBlueprintOpts -> IO () handleNewBlueprint nopts = do - let name = nopts.newBlueprintName + let name = (nopts ^. #name) -- Validate blueprint name format if not (isValidBlueprintName name) @@ -29,7 +30,7 @@ else pure () -- Determine output directory - let outputDir = case nopts.newBlueprintPath of + let outputDir = case nopts ^. #path of Just p -> p Nothing -> T.unpack name diff --git a/src-exe/Seihou/CLI/NewModule.hs b/src-exe/Seihou/CLI/NewModule.hs --- a/src-exe/Seihou/CLI/NewModule.hs +++ b/src-exe/Seihou/CLI/NewModule.hs @@ -3,6 +3,7 @@ ) where +import Data.Generics.Labels () import Data.Text qualified as T import Data.Text.IO qualified as TIO import Seihou.CLI.Commands (NewModuleOpts (..)) @@ -17,7 +18,7 @@ handleNewModule :: NewModuleOpts -> IO () handleNewModule nopts = do - let name = nopts.newModuleName + let name = (nopts ^. #name) -- Validate module name format if not (isValidModuleName name) @@ -29,7 +30,7 @@ else pure () -- Determine output directory - let outputDir = case nopts.newModulePath of + let outputDir = case nopts ^. #path of Just p -> p Nothing -> T.unpack name diff --git a/src-exe/Seihou/CLI/NewPrompt.hs b/src-exe/Seihou/CLI/NewPrompt.hs --- a/src-exe/Seihou/CLI/NewPrompt.hs +++ b/src-exe/Seihou/CLI/NewPrompt.hs @@ -3,6 +3,7 @@ ) where +import Data.Generics.Labels () import Data.Text qualified as T import Data.Text.IO qualified as TIO import Seihou.CLI.Commands (NewPromptOpts (..)) @@ -18,7 +19,7 @@ handleNewPrompt :: NewPromptOpts -> IO () handleNewPrompt nopts = do - let name = nopts.newPromptName + let name = (nopts ^. #name) if not (isValidModuleName name) then do @@ -28,7 +29,7 @@ exitFailure else pure () - let outputDir = case nopts.newPromptPath of + let outputDir = case nopts ^. #path of Just p -> p Nothing -> T.unpack name diff --git a/src-exe/Seihou/CLI/NewRecipe.hs b/src-exe/Seihou/CLI/NewRecipe.hs --- a/src-exe/Seihou/CLI/NewRecipe.hs +++ b/src-exe/Seihou/CLI/NewRecipe.hs @@ -3,6 +3,7 @@ ) where +import Data.Generics.Labels () import Data.Text qualified as T import Data.Text.IO qualified as TIO import Seihou.CLI.Commands (NewRecipeOpts (..)) @@ -15,7 +16,7 @@ handleNewRecipe :: NewRecipeOpts -> IO () handleNewRecipe ropts = do - let name = ropts.newRecipeName + let name = (ropts ^. #name) -- Validate recipe name format if not (isValidRecipeName name) @@ -27,7 +28,7 @@ else pure () -- Determine output directory - let outputDir = case ropts.newRecipePath of + let outputDir = case ropts ^. #path of Just p -> p Nothing -> T.unpack name @@ -43,7 +44,7 @@ createDirectoryIfMissing True outputDir -- Write recipe.dhall - let dhallContent = recipeDhall name ropts.newRecipeModules + let dhallContent = recipeDhall name (ropts ^. #modules) writeFile (outputDir "recipe.dhall") (T.unpack dhallContent) TIO.putStrLn $ "Created " <> T.pack (outputDir "recipe.dhall") diff --git a/src-exe/Seihou/CLI/Outdated.hs b/src-exe/Seihou/CLI/Outdated.hs --- a/src-exe/Seihou/CLI/Outdated.hs +++ b/src-exe/Seihou/CLI/Outdated.hs @@ -11,6 +11,7 @@ import Data.Aeson qualified as Aeson import Data.Aeson.Encode.Pretty (encodePretty) import Data.ByteString.Lazy qualified as LBS +import Data.Generics.Labels () import Data.Map.Strict qualified as Map import Data.Text qualified as T import Data.Text.IO qualified as TIO @@ -37,7 +38,7 @@ handleOutdated oopts = do searchPaths <- defaultSearchPaths modules <- discoverAllModules searchPaths - let installed = filter (\dm -> dm.discoveredSource == SourceInstalled) modules + let installed = filter (\dm -> dm ^. #source == SourceInstalled) modules if null installed then TIO.putStrLn "No installed modules found." @@ -46,7 +47,7 @@ if null entries then TIO.putStrLn "No installed modules with origin metadata found." else - if oopts.outdatedJson + if oopts ^. #outdatedJson then LBS.putStr (encodePretty entries) else renderTable entries @@ -63,7 +64,7 @@ [DiscoveredModule] -> IO ([OutdatedEntry], CheckStats) checkInstalledModulesForUpdates modules = do - let installed = filter (\dm -> dm.discoveredSource == SourceInstalled) modules + let installed = filter (\dm -> dm ^. #source == SourceInstalled) modules originsWithModules <- mapM readOriginWithModule installed let withOrigins = [(dm, origin) | (dm, Just origin) <- originsWithModules] skipped = length installed - length withOrigins @@ -78,7 +79,7 @@ Map.toList $ Map.fromListWith (++) - [(origin.sourceUrl, [(dm, origin)]) | (dm, origin) <- withOrigins] + [(origin ^. #sourceUrl, [(dm, origin)]) | (dm, origin) <- withOrigins] TIO.putStrLn "Checking installed modules for updates..." entries <- concat <$> mapM checkSource grouped pure @@ -89,7 +90,7 @@ -- | Read origin info from a discovered module's directory. readOriginWithModule :: DiscoveredModule -> IO (DiscoveredModule, Maybe OriginInfo) readOriginWithModule dm = do - let originFile = dm.discoveredDir ".seihou-origin.json" + let originFile = dm ^. #dir ".seihou-origin.json" exists <- doesFileExist originFile if exists then do @@ -130,7 +131,7 @@ compareModule :: FilePath -> (DiscoveredModule, OriginInfo) -> IO OutdatedEntry compareModule cloneDir (dm, origin) = do let name = moduleNameFromDm dm - installedVer = origin.version + installedVer = (origin ^. #version) availableVer <- fetchAvailable cloneDir (ModuleName name) let status = compareVersions installedVer availableVer pure @@ -155,9 +156,9 @@ -- | Compare installed and available version strings. -- | Extract the module name text from a DiscoveredModule. moduleNameFromDm :: DiscoveredModule -> Text -moduleNameFromDm dm = case dm.discoveredResult of - Right m -> m.name.unModuleName - Left _ -> dirName dm.discoveredDir +moduleNameFromDm dm = case dm ^. #result of + Right m -> (m ^. #name . #unModuleName) + Left _ -> dirName (dm ^. #dir) -- | Extract the last path component as a name. dirName :: FilePath -> Text @@ -170,7 +171,7 @@ mkUnreachable dm origin = OutdatedEntry { moduleName = moduleNameFromDm dm, - installedVersion = origin.version, + installedVersion = origin ^. #version, availableVersion = Nothing, status = Unreachable } @@ -179,9 +180,9 @@ renderTable :: [OutdatedEntry] -> IO () renderTable entries = do colorEnabled <- useColor - let maxNameLen = max 6 (maximum (map (T.length . (.moduleName)) entries)) - maxInstLen = max 9 (maximum (map (T.length . maybe "(none)" id . (.installedVersion)) entries)) - maxAvailLen = max 9 (maximum (map (T.length . maybe "(none)" id . (.availableVersion)) entries)) + let maxNameLen = max 6 (maximum (map (T.length . (^. #moduleName)) entries)) + maxInstLen = max 9 (maximum (map (T.length . maybe "(none)" id . (^. #installedVersion)) entries)) + maxAvailLen = max 9 (maximum (map (T.length . maybe "(none)" id . (^. #availableVersion)) entries)) padR n t = t <> T.replicate (n - T.length t + 2) " " @@ -192,14 +193,14 @@ <> "Status" formatRow e = - let instText = maybe "(none)" id e.installedVersion - availText = maybe "(none)" id e.availableVersion - statusTxt = case e.status of + let instText = maybe "(none)" id (e ^. #installedVersion) + availText = maybe "(none)" id (e ^. #availableVersion) + statusTxt = case e ^. #status of UpToDate -> if colorEnabled then green "up to date" else "up to date" OutdatedSt -> if colorEnabled then red "outdated" else "outdated" Unversioned -> if colorEnabled then dim "unversioned" else "unversioned" Unreachable -> if colorEnabled then yellow "unreachable" else "unreachable" - in padR maxNameLen e.moduleName + in padR maxNameLen (e ^. #moduleName) <> padR maxInstLen instText <> padR maxAvailLen availText <> statusTxt @@ -209,7 +210,7 @@ mapM_ (TIO.putStrLn . formatRow) entries let total = length entries - outdated = length (filter (\e -> e.status == OutdatedSt) entries) + outdated = length (filter (\e -> e ^. #status == OutdatedSt) entries) TIO.putStrLn "" TIO.putStrLn $ T.pack (show total) diff --git a/src-exe/Seihou/CLI/PromptRun.hs b/src-exe/Seihou/CLI/PromptRun.hs --- a/src-exe/Seihou/CLI/PromptRun.hs +++ b/src-exe/Seihou/CLI/PromptRun.hs @@ -3,11 +3,16 @@ ) where +import Data.Generics.Labels () 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.AgentCompletion (AgentModelConfig) +import Seihou.CLI.AgentConfig + ( PendingAgentConfig, + agentLaunchDeclaration, + resolveDeclaredAgentConfig, + ) import Seihou.CLI.AgentLaunch (gatherAgentContext, setupAllowedTools) import Seihou.CLI.AgentRun (runRenderedAgentPrompt) import Seihou.CLI.Commands (PromptRunOpts (..)) @@ -40,34 +45,34 @@ import System.Environment (getEnvironment) import System.Exit (exitFailure) -handlePromptRun :: AgentModelConfig -> PromptRunOpts -> IO () -handlePromptRun modelConfig opts = do - let level = if opts.runPromptVerbose then LogVerbose else LogNormal +handlePromptRun :: PendingAgentConfig -> PromptRunOpts -> IO () +handlePromptRun pending opts = do + let level = if opts ^. #verbose then LogVerbose else LogNormal searchPaths <- defaultSearchPaths - runnableResult <- discoverRunnable searchPaths opts.runPromptName + runnableResult <- discoverRunnable searchPaths (opts ^. #name) (prompt, promptDir) <- case runnableResult of Right (RunnableAgentPrompt p dir) -> pure (p, dir) Right (RunnableModule _ _) -> exitErr level $ "'" - <> opts.runPromptName.unModuleName + <> opts ^. #name . #unModuleName <> "' is a module, not a prompt. Did you mean 'seihou run " - <> opts.runPromptName.unModuleName + <> opts ^. #name . #unModuleName <> "'?" Right (RunnableRecipe _ _) -> exitErr level $ "'" - <> opts.runPromptName.unModuleName + <> opts ^. #name . #unModuleName <> "' is a recipe, not a prompt. Did you mean 'seihou run " - <> opts.runPromptName.unModuleName + <> opts ^. #name . #unModuleName <> "'?" Right (RunnableBlueprint _ _) -> exitErr level $ "'" - <> opts.runPromptName.unModuleName + <> opts ^. #name . #unModuleName <> "' is a blueprint, not a prompt. Did you mean 'seihou agent run " - <> opts.runPromptName.unModuleName + <> opts ^. #name . #unModuleName <> "'?" Left err -> exitErr level (renderModuleLoadError err) @@ -76,28 +81,37 @@ Left err -> exitErr level (renderModuleLoadError err) Right _ -> pure () + -- Finish provider/model/effort resolution now that the prompt is loaded, so + -- an unusable declaration is reported alongside the prompt's other errors. + modelConfig <- + resolveDeclaredAgentConfig + level + ("prompt '" <> prompt ^. #name . #unModuleName <> "'") + pending + (agentLaunchDeclaration (prompt ^. #launch)) + let placeholderModule = Module - { name = prompt.name, - version = prompt.version, - description = prompt.description, - vars = relaxCommandVarDecls prompt.commandVars prompt.vars, + { name = prompt ^. #name, + version = prompt ^. #version, + description = prompt ^. #description, + vars = relaxCommandVarDecls (prompt ^. #commandVars) (prompt ^. #vars), exports = [], - prompts = prompt.prompts, + prompts = prompt ^. #prompts, steps = [], commands = [], dependencies = [], removal = Nothing, migrations = [] } - placeholderInst = primaryInstance prompt.name + placeholderInst = primaryInstance (prompt ^. #name) placeholderTriple = (placeholderInst, placeholderModule, promptDir) envPairs <- getEnvironment - let cliOverrides = Map.fromList [(VarName k, v) | (k, v) <- opts.runPromptVars] + let cliOverrides = Map.fromList [(VarName k, v) | (k, v) <- opts ^. #vars] envVars = Map.fromList [(T.pack k, T.pack v) | (k, v) <- envPairs] - namespace = fromMaybe (deriveNamespace prompt.name) opts.runPromptNamespace - context <- resolveContext opts.runPromptContext envVars + namespace = fromMaybe (deriveNamespace (prompt ^. #name)) (opts ^. #namespace) + context <- resolveContext (opts ^. #context) envVars let contextName = fromMaybe "" context resolveResult <- runEff $ runConfigReader $ runConsole $ do @@ -124,7 +138,7 @@ exitFailure Right r -> pure (Map.findWithDefault Map.empty placeholderInst r) - commandResult <- runEff $ runProcessIO $ resolveCommandVars prompt.vars prompt.commandVars resolvedNormal + commandResult <- runEff $ runProcessIO $ resolveCommandVars (prompt ^. #vars) (prompt ^. #commandVars) resolvedNormal resolved <- case commandResult of Left errs -> do logIO level $ do @@ -133,27 +147,27 @@ exitFailure Right r -> pure r - let renderedPrompt = renderPromptBody resolved prompt.prompt + let renderedPrompt = renderPromptBody resolved (prompt ^. #prompt) ctx <- gatherAgentContext - let systemPrompt = renderPromptSystemPrompt ctx prompt resolved renderedPrompt opts.runPromptPrompt + let systemPrompt = renderPromptSystemPrompt ctx prompt resolved renderedPrompt (opts ^. #prompt) _ <- runRenderedAgentPrompt - opts.runPromptDebug + (opts ^. #debug) modelConfig setupAllowedTools Nothing systemPrompt - opts.runPromptPrompt + (opts ^. #prompt) pure () relaxCommandVarDecls :: [CommandVar] -> [VarDecl] -> [VarDecl] relaxCommandVarDecls commandVars = map relaxOne where - commandNames = Set.fromList (map (.name) commandVars) + commandNames = Set.fromList (map (^. #name) commandVars) relaxOne decl - | Set.member decl.name commandNames = decl {required = False} + | Set.member (decl ^. #name) commandNames = decl & #required .~ False | otherwise = decl exitErr :: LogLevel -> Text -> IO a @@ -165,24 +179,24 @@ renderModuleLoadError = \case ModuleNotFound name searched -> "Prompt '" - <> name.unModuleName + <> name ^. #unModuleName <> "' not found. Searched in:\n" <> T.intercalate "\n" (map ((" " <>) . T.pack) searched) DhallEvalError name msg -> - "Failed to evaluate '" <> name.unModuleName <> "': " <> msg + "Failed to evaluate '" <> name ^. #unModuleName <> "': " <> msg DhallDecodeError name msg -> - "Failed to decode '" <> name.unModuleName <> "': " <> msg + "Failed to decode '" <> name ^. #unModuleName <> "': " <> msg ValidationError name msgs -> "Validation failed for '" - <> name.unModuleName + <> name ^. #unModuleName <> "':\n" <> T.intercalate "\n" (map (" " <>) msgs) CircularDependency names -> "Circular dependency detected: " - <> T.intercalate " -> " (map (.unModuleName) names) + <> T.intercalate " -> " (map (^. #unModuleName) names) MissingSourceFile name path -> "Missing source file in '" - <> name.unModuleName + <> name ^. #unModuleName <> "': " <> T.pack path RegistryEvalError path msg -> diff --git a/src-exe/Seihou/CLI/Remove.hs b/src-exe/Seihou/CLI/Remove.hs --- a/src-exe/Seihou/CLI/Remove.hs +++ b/src-exe/Seihou/CLI/Remove.hs @@ -4,6 +4,7 @@ where import Control.Monad (foldM, when) +import Data.Generics.Labels () import Data.Set qualified as Set import Data.Text qualified as T import Data.Text.IO qualified as TIO @@ -22,7 +23,7 @@ handleRemove :: RemoveOpts -> IO () handleRemove opts = do let manifestPath = ".seihou" "manifest.json" - modName = opts.removeModule + modName = (opts ^. #module_) -- Read the manifest manifestResult <- runEff $ runFilesystem $ runManifestStore manifestPath readManifest @@ -39,13 +40,13 @@ let mApplied = findAppliedModule manifest modName case mApplied of Nothing -> do - TIO.putStrLn $ "Module '" <> modName.unModuleName <> "' is not applied in this project." + TIO.putStrLn $ "Module '" <> modName ^. #unModuleName <> "' is not applied in this project." exitFailure - Just am -> case am.removal of + Just am -> case am ^. #removal of Nothing -> do TIO.putStrLn $ "Module '" - <> modName.unModuleName + <> modName ^. #unModuleName <> "' has no removal spec. Add a 'removal' section to its module.dhall to make it removable." exitFailure Just removal -> do @@ -53,12 +54,12 @@ planResult <- runEff $ runFilesystem $ buildRemovalOps manifest modName removal plan <- case planResult of Left (ModuleNotApplied name) -> do - TIO.putStrLn $ "Module '" <> name.unModuleName <> "' is not applied in this project." + TIO.putStrLn $ "Module '" <> name ^. #unModuleName <> "' is not applied in this project." exitFailure Left (ModuleNotRemovable name) -> do TIO.putStrLn $ "Module '" - <> name.unModuleName + <> name ^. #unModuleName <> "' has no removal spec." exitFailure Left (RemovalUnsafePath label path reason) -> do @@ -75,24 +76,24 @@ colorEnabled <- useColor -- Display plan - TIO.putStrLn $ "Removal plan for " <> modName.unModuleName <> ":" + TIO.putStrLn $ "Removal plan for " <> modName ^. #unModuleName <> ":" - if null plan.ops + if null (plan ^. #ops) then TIO.putStrLn " (no removal operations)" - else mapM_ (displayOp colorEnabled) plan.ops + else mapM_ (displayOp colorEnabled) (plan ^. #ops) -- Dry run exits here - when opts.removeDryRun $ do + when (opts ^. #dryRun) $ do TIO.putStrLn "" TIO.putStrLn $ applyColor colorEnabled dim "(dry run — no changes made)" exitWith ExitSuccess -- Collect conflict files for interactive resolution - let conflictFiles = [p | DeleteFileOp p RFConflict <- plan.ops] + let conflictFiles = [p | DeleteFileOp p RFConflict <- plan ^. #ops] -- Resolve conflicts keepSet <- - if null conflictFiles || opts.removeForce + if null conflictFiles || opts ^. #force then pure Set.empty else do isInteractive <- hIsTerminalDevice stdin @@ -103,7 +104,7 @@ else resolveConflictsInteractively conflictFiles -- Prompt for confirmation (if there are any actionable ops) - let actionableOps = [() | op <- plan.ops, isActionable op] + let actionableOps = [() | op <- plan ^. #ops, isActionable op] when (not (null actionableOps)) $ do TIO.putStr "\n Proceed? [y/N] " hFlush stdout @@ -119,13 +120,13 @@ runEff $ runFilesystem $ runManifestStore manifestPath $ writeManifest updatedManifest -- Report - let deleted = length [() | DeleteFileOp _ s <- plan.ops, s /= RFGone, not (Set.member "" keepSet)] - stripped = length [() | StripSectionOp _ <- plan.ops] - commands = length [() | RemovalCommandOp _ _ <- plan.ops] + let deleted = length [() | DeleteFileOp _ s <- plan ^. #ops, s /= RFGone, not (Set.member "" keepSet)] + stripped = length [() | StripSectionOp _ <- plan ^. #ops] + commands = length [() | RemovalCommandOp _ _ <- plan ^. #ops] TIO.putStrLn $ applyColor colorEnabled green "✓" <> " Removed module " - <> applyColor colorEnabled bold modName.unModuleName + <> applyColor colorEnabled bold (modName ^. #unModuleName) <> "." <> formatCounts deleted stripped commands @@ -170,7 +171,7 @@ -- | Find an applied module by name in the manifest. findAppliedModule :: Manifest -> ModuleName -> Maybe AppliedModule findAppliedModule manifest modName = - case filter (\am -> am.name == modName) manifest.modules of + case filter (\am -> am ^. #name == modName) (manifest ^. #modules) of (am : _) -> Just am [] -> Nothing diff --git a/src-exe/Seihou/CLI/Run.hs b/src-exe/Seihou/CLI/Run.hs --- a/src-exe/Seihou/CLI/Run.hs +++ b/src-exe/Seihou/CLI/Run.hs @@ -5,6 +5,7 @@ import Control.Exception (IOException, displayException, try) import Control.Monad (foldM, forM_, unless, when) +import Data.Generics.Labels () import Data.Map.Strict qualified as Map import Data.Maybe (fromMaybe, isJust) import Data.Set qualified as Set @@ -25,6 +26,13 @@ import Seihou.CLI.Commands (RunOpts (..)) import Seihou.CLI.CommitMessage (generateCommitMessage) import Seihou.CLI.Git (gitAdd, gitCheckIgnore, gitCommit, gitDiffCached, isGitRepo) +import Seihou.CLI.ManifestGuard + ( ArtifactCheck, + blockingChecks, + checkAppliedArtifactsFor, + formatGuardOverride, + formatGuardRefusal, + ) import Seihou.CLI.Migrate ( MigrateError (..), MigrateOpts (..), @@ -36,13 +44,15 @@ formatRefusalMessage, ) import Seihou.CLI.SavePrompted (collectPromptedValues, offerSavePrompted) -import Seihou.CLI.Shared (deriveNamespace, formatBlueprintRefusal, formatVarError, logIO, toVarNameMap, unwrapConfig) +import Seihou.CLI.Shared (deriveNamespace, formatBlueprintRefusal, formatVarError, logIO, resolveAppliedArtifactDir, toVarNameMap, unwrapConfig) import Seihou.CLI.Style (bold, dim, formatPlanViewColor, green, magenta, red, useColor, yellow) import Seihou.Composition.Instance (ModuleInstance (..), qualifiedName) import Seihou.Composition.Plan (compileComposedPlan) import Seihou.Composition.Recipe (expandRecipe) import Seihou.Composition.Resolve (loadComposition, resolveWithPrompts) import Seihou.Core.Application (attachApplication, buildAppliedComposition, mkApplicationId, replaceAppliedComposition) +import Seihou.Core.ArtifactOriginDetect (detectArtifactOrigin) +import Seihou.Core.ArtifactRef (renderArtifactRefError) import Seihou.Core.Context (resolveContext) import Seihou.Core.Migration (MigrationPlan (..)) import Seihou.Core.Module (defaultSearchPaths, discoverRunnable) @@ -72,6 +82,7 @@ import Seihou.Interaction.Confirm (confirmDefaults) import Seihou.Manifest.Types (currentManifestVersion, emptyManifest) import Seihou.Prelude +import System.Directory (getCurrentDirectory) import System.Environment (getEnvironment) import System.Exit (ExitCode (..), exitFailure, exitWith) import System.FilePath (takeDirectory) @@ -79,11 +90,11 @@ handleRun :: RunOpts -> IO () handleRun runOpts = do - let additional = runOpts.runAdditional - level = if runOpts.runVerbose then LogVerbose else LogNormal + let additional = (runOpts ^. #additional) + level = if runOpts ^. #verbose then LogVerbose else LogNormal -- 0. Resolve module name (from argument or fzf picker) - modName <- case runOpts.runModule of + modName <- case runOpts ^. #module_ of Just name -> pure name Nothing -> do fzfCfg <- detectFzfConfig @@ -114,20 +125,20 @@ logIO level $ logError $ "Invalid recipe '" - <> recipe.name.unRecipeName + <> recipe ^. #name . #unRecipeName <> "': " <> T.intercalate "; " errs exitFailure Right (primary, recipeAdditional, overrides, _recipeVars, _recipePrompts) -> do logIO level $ logInfo $ - "Recipe '" <> recipe.name.unRecipeName <> "' expanding to " <> T.pack (show (length recipe.modules)) <> " modules" + "Recipe '" <> recipe ^. #name . #unRecipeName <> "' expanding to " <> T.pack (show (length (recipe ^. #modules))) <> " modules" pure ( primary, recipeAdditional ++ additional, overrides, - Just (recipe.name, recipe.version), - (AppliedRecipeTarget recipe.name, recipeDir, recipe.version) + Just (recipe ^. #name, recipe ^. #version), + (AppliedRecipeTarget (recipe ^. #name), recipeDir, recipe ^. #version) ) Right (RunnableModule modul moduleDir) -> pure @@ -135,7 +146,7 @@ additional, Map.empty, Nothing, - (AppliedModuleTarget modName, moduleDir, modul.version) + (AppliedModuleTarget modName, moduleDir, modul ^. #version) ) Right (RunnableBlueprint _b _blueprintDir) -> do -- Use the user-typed name (modName) rather than the blueprint's @@ -159,14 +170,14 @@ modulesInOrder <- case compositionResult of Left (ModuleNotFound name searched) -> do logIO level $ do - logError $ "Module '" <> name.unModuleName <> "' not found." + logError $ "Module '" <> name ^. #unModuleName <> "' not found." logError "Searched in:" mapM_ (\p -> logError $ " " <> T.pack p) searched exitFailure Left (CircularDependency names) -> do logIO level $ do logError "Circular dependency detected:" - logError $ " " <> T.intercalate " -> " (map (.unModuleName) names) + logError $ " " <> T.intercalate " -> " (map (^. #unModuleName) names) exitFailure Left err -> exitError level (T.pack (show err)) Right ms -> pure ms @@ -175,15 +186,15 @@ when (length modulesInOrder > 1) $ logIO level $ do logInfo $ "Composing " <> T.pack (show (length modulesInOrder)) <> " modules:" - mapM_ (\(_, m, _) -> logInfo $ " " <> m.name.unModuleName) modulesInOrder + mapM_ (\(_, m, _) -> logInfo $ " " <> m ^. #name . #unModuleName) modulesInOrder -- 2. Resolve variables with export visibility and interactive prompts envPairs <- getEnvironment -- Merge recipe overrides with CLI overrides (CLI wins on conflict) - let cliOverrides = Map.union (Map.fromList [(VarName k, v) | (k, v) <- runOpts.runVars]) recipeOverrides + let cliOverrides = Map.union (Map.fromList [(VarName k, v) | (k, v) <- runOpts ^. #vars]) recipeOverrides envVars = Map.fromList [(T.pack k, T.pack v) | (k, v) <- envPairs] - namespace = fromMaybe (deriveNamespace primaryName) runOpts.runNamespace - context <- resolveContext runOpts.runContext envVars + namespace = fromMaybe (deriveNamespace primaryName) (runOpts ^. #namespace) + context <- resolveContext (runOpts ^. #context) envVars let contextName = fromMaybe "" context (resolveResult, localMap, nsMap, ctxMap, globalMap) <- runEff $ runConfigReader $ runConsole $ do localCfg <- readLocalConfig >>= unwrapConfig level @@ -206,23 +217,23 @@ -- 2a. Optionally confirm default-sourced values. resolved <- - if runOpts.runConfirmDefaults + if runOpts ^. #confirmDefaults then runEff $ runConsole $ confirmDefaults modulesInOrder resolvedInitial else pure resolvedInitial -- 2b. Emit diagnostics for unused config keys - let allDecls = concatMap (\(_, m, _) -> m.vars) modulesInOrder + let allDecls = concatMap (\(_, m, _) -> m ^. #vars) modulesInOrder allResolved = Map.unions [vs | vs <- Map.elems resolved] (unusedKeys, _) = diagnoseResolution allResolved allDecls localMap nsMap ctxMap globalMap when (not (null unusedKeys)) $ logIO level $ logWarn $ "Config keys not matching any declared variable: " - <> T.intercalate ", " (map (.unVarName) unusedKeys) + <> T.intercalate ", " (map (^. #unVarName) unusedKeys) -- 3. Compile composed plan (all modules merged) let quads = - [ (inst, m, dir, Map.map (.value) (resolved Map.! inst)) + [ (inst, m, dir, Map.map (^. #value) (resolved Map.! inst)) | (inst, m, dir) <- modulesInOrder ] planResult <- compileComposedPlan quads @@ -236,7 +247,7 @@ -- 4. Filter out command ops if --no-commands let opsFiltered = - if runOpts.runNoCommands + if runOpts ^. #noCommands then filter (not . isCommandOp) ops else ops @@ -263,11 +274,26 @@ exitFailure Right m -> pure (fromMaybe (emptyManifest now) m) - -- 6b. Pre-flight pending-migration check. We only consider modules in + let composedModuleNames = + Set.fromList [m ^. #name | (_, m, _) <- modulesInOrder] + + -- 6b. Pre-flight downgrade and origin guard: refuse to generate from a + -- module that is older than, or came from somewhere other than, what the + -- manifest records. This runs *before* the pending-migration check below + -- because a stale local copy is the more fundamental problem — the + -- migration chain is computed from that same older copy, so its advice + -- would point the wrong way. Like the migration check, it considers only + -- modules in the current composition; a stale module this run does not + -- touch must not block it. + projectRoot <- getCurrentDirectory + searchPaths <- defaultSearchPaths + guardChecks <- + checkAppliedArtifactsFor projectRoot searchPaths (Just composedModuleNames) initialManifest + enforceArtifactGuard runOpts (blockingChecks guardChecks) + + -- 6c. Pre-flight pending-migration check. We only consider modules in -- the current composition: a pending chain on an unrelated module -- must not block this run. - let composedModuleNames = - Set.fromList [m.name | (_, m, _) <- modulesInOrder] pendings <- detectPendingMigrations initialManifest (Just composedModuleNames) manifest <- @@ -276,47 +302,56 @@ -- Commands are planned against the previously accepted receipts for this -- exact top-level application. Ordinary run deliberately remains run-all; -- --no-commands disables execution while retaining matching old receipts. + -- What lands in the manifest must mean the same thing on every machine, so + -- each artifact's discovery directory is classified into a portable origin + -- before it is recorded. See docs/adr/0001-manifest-is-a-checked-in-machine-independent-artifact.md. let (appliedTarget, targetSource, targetVersion) = targetInfo - currentApplicationId = mkApplicationId appliedTarget additional + targetOrigin <- detectArtifactOrigin projectRoot targetSource + originedModules <- + traverse + (\(inst, m, dir) -> (inst,m,) <$> detectArtifactOrigin projectRoot dir) + modulesInOrder + + let currentApplicationId = mkApplicationId appliedTarget additional priorCommandReceipts = - case [ application.commandReceipts - | application <- manifest.applications, - application.applicationId == currentApplicationId + case [ application ^. #commandReceipts + | application <- manifest ^. #applications, + application ^. #applicationId == currentApplicationId ] of receipts : _ -> receipts [] -> Map.empty commandPolicy = - if runOpts.runNoCommands + if runOpts ^. #noCommands then DisableCommands else RunAllCommands commandPlan = planCommands commandPolicy priorCommandReceipts ops candidateCommandReceipts = finalizeCommandReceipts commandPlan [] priorCommandReceipts - -- 6c. Compute the diff against the (possibly post-migration) manifest. + -- 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 -- instance owns its qualified name; the bare module name is still -- matched to cover manifest entries written before the schema bump. let composedNames = Set.fromList $ - concatMap (\(inst, _, _) -> [inst.instanceModule, qualifiedName inst]) modulesInOrder + concatMap (\(inst, _, _) -> [inst ^. #module_, qualifiedName inst]) modulesInOrder computeDiff manifest composedNames planned colorEnabled <- useColor - let modNames = map (\(_, m, _) -> m.name) modulesInOrder + let modNames = map (\(_, m, _) -> m ^. #name) modulesInOrder allVarValues = Map.unions - [Map.map (.value) vs | vs <- Map.elems resolved] + [Map.map (^. #value) vs | vs <- Map.elems resolved] preview = buildPreview opsFiltered (Just diff) ownerMap -- 6. Handle --dry-run: show plan view and exit - if runOpts.runDryRun + if runOpts ^. #dryRun then TIO.putStr (formatPlanViewColor colorEnabled modNames allVarValues preview diff) else - if runOpts.runDiff + if runOpts ^. #diff then TIO.putStr (formatDiff colorEnabled diff ownerMap) else do -- Show plan view @@ -324,7 +359,7 @@ -- Prompt for confirmation (skip if --force or non-interactive) interactive <- hIsTerminalDevice stdin - when (interactive && not runOpts.runForce) $ do + when (interactive && not (runOpts ^. #force)) $ do TIO.putStr "\n Proceed? [Y/n] " hFlush stdout response <- T.strip . T.pack <$> getLine @@ -335,24 +370,30 @@ resolutions <- runEff $ runConsole $ - resolveConflicts runOpts.runForce diff.conflicts + resolveConflicts (runOpts ^. #force) (diff ^. #conflicts) case resolutions of Nothing -> do TIO.putStrLn "Conflicts detected (use --force to overwrite):" - mapM_ (\c -> TIO.putStrLn $ " ! " <> T.pack c.path) diff.conflicts + mapM_ (\c -> TIO.putStrLn $ " ! " <> T.pack (c ^. #path)) (diff ^. #conflicts) exitFailure Just conflictResolved -> do -- Partition resolutions: accept (overwrite), keep (update manifest only), skip (ignore) let keepRecords = Map.fromList - [ ( c.path, - case Map.lookup c.path manifest.files of + [ ( c ^. #path, + case Map.lookup (c ^. #path) (manifest ^. #files) of Just existing -> - existing {hash = c.diskHash, generatedAt = now} + ( existing + & #hash + .~ c + ^. #diskHash + & #generatedAt + .~ now + ) Nothing -> FileRecord - { hash = c.diskHash, - moduleName = c.moduleName, + { hash = c ^. #diskHash, + moduleName = c ^. #moduleName, strategy = Template, generatedAt = now, baseline = Nothing, @@ -361,7 +402,7 @@ ) | (c, KeepCurrent) <- conflictResolved ] - skipPaths = [c.path | (c, Skip) <- conflictResolved] + skipPaths = [c ^. #path | (c, Skip) <- conflictResolved] excludePaths = Set.fromList (Map.keys keepRecords ++ skipPaths) opsForExec = filter (not . opTargetsPath excludePaths) opsFiltered @@ -380,31 +421,32 @@ Left err -> pure (Left err) Right baselineRecords -> do -- Build updated manifest with all composed modules. - let orphanedPaths = map (.path) diff.orphaned - cleanedFiles = foldr Map.delete manifest.files orphanedPaths - allModuleEntries = updateAllModules manifest.modules modulesInOrder now + 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] + [Map.map (^. #value) vs | vs <- Map.elems resolved] appliedRecipe = case recipeInfo of Just (rName, rVersion) -> Just AppliedRecipe {name = rName, recipeVersion = rVersion, appliedAt = now} - Nothing -> manifest.recipe + Nothing -> (manifest ^. #recipe) appliedCompositionWithoutReceipts = buildAppliedComposition appliedTarget - targetSource + targetOrigin targetVersion additional (Just namespace) context - modulesInOrder + originedModules resolved now appliedComposition = - appliedCompositionWithoutReceipts - { commandReceipts = candidateCommandReceipts - } + ( appliedCompositionWithoutReceipts + & #commandReceipts + .~ candidateCommandReceipts + ) applicationDestinations = Set.fromList [path | Just path <- map operationDestination opsFiltered] combinedFiles = Map.unions [baselineRecords, keepRecords, cleanedFiles] @@ -412,7 +454,7 @@ Map.mapWithKey ( \path record -> if Set.member path applicationDestinations - then attachApplication appliedComposition.applicationId (Map.lookup path manifest.files) record + then attachApplication (appliedComposition ^. #applicationId) (Map.lookup path (manifest ^. #files)) record else record ) combinedFiles @@ -421,12 +463,12 @@ { version = currentManifestVersion, genAt = now, modules = allModuleEntries, - vars = Map.union (Map.map varValueToText allResolvedVals) manifest.vars, + vars = Map.union (Map.map varValueToText allResolvedVals) (manifest ^. #vars), files = ownedFiles, - applications = replaceAppliedComposition appliedComposition manifest.applications, + applications = replaceAppliedComposition appliedComposition (manifest ^. #applications), recipe = appliedRecipe, - blueprint = manifest.blueprint, - blueprintMigrations = manifest.blueprintMigrations + blueprint = manifest ^. #blueprint, + blueprintMigrations = manifest ^. #blueprintMigrations } writeManifest newManifest pure (Right newManifest) @@ -454,9 +496,9 @@ Right _ -> pure () -- Report results - let nNew = length diff.new - nMod = length diff.modified - nUnch = length diff.unchanged + let nNew = length (diff ^. #new) + nMod = length (diff ^. #modified) + nUnch = length (diff ^. #unchanged) TIO.putStrLn $ T.pack (show nNew) <> " new, " @@ -469,8 +511,8 @@ -- returns candidate receipts only when the entire phase -- succeeds, so a failed run leaves the candidate manifest with -- no newly-minted success evidence. - forM_ commandPlan.commands $ \planned -> - when (planned.disposition == CommandWillRun) $ + forM_ (commandPlan ^. #commands) $ \planned -> + when (planned ^. #disposition == CommandWillRun) $ logIO level (logDebug $ " run " <> plannedCommandText planned) commandResult <- runEff $ @@ -484,14 +526,14 @@ completedReceipts <- case commandResult of Right receipts -> pure receipts Left commandError -> do - when (not (T.null commandError.stdout)) $ TIO.putStr commandError.stdout - when (not (T.null commandError.stderr)) $ TIO.putStr commandError.stderr + when (not (T.null (commandError ^. #stdout))) $ TIO.putStr (commandError ^. #stdout) + when (not (T.null (commandError ^. #stderr))) $ TIO.putStr (commandError ^. #stderr) logIO level $ logError $ "Command failed (exit " - <> T.pack (show commandError.exitCode) + <> T.pack (show (commandError ^. #exitCode)) <> "): " - <> plannedCommandText commandError.command + <> plannedCommandText (commandError ^. #command) exitFailure let finalCommandReceipts = @@ -514,10 +556,10 @@ Right () -> pure () -- Commit generated files if --commit or --commit-message - when (runOpts.runCommit || isJust runOpts.runCommitMessage) $ do + when (runOpts ^. #commit || isJust (runOpts ^. #commitMessage)) $ do let filesToStage = - map (.path) diff.new - ++ map (.path) diff.modified + map (^. #path) (diff ^. #new) + ++ map (^. #path) (diff ^. #modified) ++ [manifestPath, baselineDir] inGit <- runEff $ runProcessIO $ isGitRepo if inGit @@ -531,7 +573,7 @@ case addExit of ExitFailure _ -> logIO level (logWarn $ "git add failed: " <> addErr) ExitSuccess -> do - commitMsg <- case runOpts.runCommitMessage of + commitMsg <- case runOpts ^. #commitMessage of Just msg -> pure msg Nothing -> do diffText <- runEff $ runProcessIO $ gitDiffCached @@ -549,7 +591,7 @@ runEff $ runConfigWriter $ runConsole $ - offerSavePrompted runOpts.runSavePrompted interactive prompted + offerSavePrompted (runOpts ^. #savePrompted) interactive prompted -- Helpers @@ -564,43 +606,43 @@ "Warning: " <> T.pack path <> " (from " - <> overwritten.unModuleName + <> overwritten ^. #unModuleName <> ") overwritten by " - <> overwriter.unModuleName + <> (overwriter ^. #unModuleName) printWarning level (ContentMerged path base contributor) = logIO level . logWarn $ "Merged: " <> T.pack path <> " (base from " - <> base.unModuleName + <> base ^. #unModuleName <> ", patched by " - <> contributor.unModuleName + <> contributor ^. #unModuleName <> ")" formatDiff :: Bool -> DiffResult -> Map.Map FilePath ModuleName -> Text formatDiff color diff ownerMap' = T.unlines $ concat - [ if null diff.new + [ if null (diff ^. #new) then [] - else "New files:" : map (\f -> " " <> colorWrap green "[new]" <> " " <> colorWrap green (T.pack f.path) <> modSuffix f.path) diff.new, - if null diff.modified + else "New files:" : map (\f -> " " <> colorWrap green "[new]" <> " " <> colorWrap green (T.pack (f ^. #path)) <> modSuffix (f ^. #path)) (diff ^. #new), + if null (diff ^. #modified) then [] - else "Modified files:" : map (\f -> " " <> colorWrap yellow "[modified]" <> " " <> colorWrap yellow (T.pack f.path) <> modSuffix f.path) diff.modified, - if null diff.unchanged + else "Modified files:" : map (\f -> " " <> colorWrap yellow "[modified]" <> " " <> colorWrap yellow (T.pack (f ^. #path)) <> modSuffix (f ^. #path)) (diff ^. #modified), + if null (diff ^. #unchanged) then [] - else "Unchanged files:" : map (\f -> " " <> colorWrap dim "[unchanged]" <> " " <> colorWrap dim (T.pack f)) diff.unchanged, - if null diff.conflicts + else "Unchanged files:" : map (\f -> " " <> colorWrap dim "[unchanged]" <> " " <> colorWrap dim (T.pack f)) (diff ^. #unchanged), + if null (diff ^. #conflicts) then [] - else "Conflicts:" : map (\f -> " " <> colorWrap (bold . red) "[conflict]" <> " " <> colorWrap (bold . red) (T.pack f.path) <> modSuffix f.path) diff.conflicts, - if null diff.orphaned + else "Conflicts:" : map (\f -> " " <> colorWrap (bold . red) "[conflict]" <> " " <> colorWrap (bold . red) (T.pack (f ^. #path)) <> modSuffix (f ^. #path)) (diff ^. #conflicts), + if null (diff ^. #orphaned) then [] - else "Orphaned files:" : map (\f -> " " <> colorWrap magenta "[orphaned]" <> " " <> colorWrap magenta (T.pack f.path)) diff.orphaned + else "Orphaned files:" : map (\f -> " " <> colorWrap magenta "[orphaned]" <> " " <> colorWrap magenta (T.pack (f ^. #path))) (diff ^. #orphaned) ] where colorWrap fn t = if color then fn t else t modSuffix path = case Map.lookup path ownerMap' of - Just mn -> " " <> colorWrap dim ("(" <> mn.unModuleName <> ")") + Just mn -> " " <> colorWrap dim ("(" <> mn ^. #unModuleName <> ")") Nothing -> "" varValueToText :: VarValue -> Text @@ -629,7 +671,7 @@ operationDestination _ = Nothing plannedCommandText :: PlannedCommand -> Text -plannedCommandText planned = case planned.operation of +plannedCommandText planned = case planned ^. #operation of RunCommandOp {command} -> command _ -> "" @@ -640,14 +682,32 @@ Manifest setApplicationCommandReceipts applicationId receipts manifest = manifest - { applications = map updateApplication manifest.applications - } + & #applications + %~ map updateApplication where updateApplication application - | application.applicationId == applicationId = - application {commandReceipts = receipts} + | application ^. #applicationId == applicationId = + application & #commandReceipts .~ receipts | otherwise = application +-- | Apply the downgrade / origin-mismatch policy. +-- +-- Without @--allow-downgrade@: the run refuses before a single file is +-- written, so the project and its manifest are left byte-identical. +-- +-- With @--allow-downgrade@: the same blocks are printed under a +-- "proceeding anyway" lead-in and the run continues. They are printed +-- rather than suppressed on purpose — a deliberate downgrade is still a +-- downgrade, and the diff it produces should not be the first time anyone +-- hears about it. +enforceArtifactGuard :: RunOpts -> [ArtifactCheck] -> IO () +enforceArtifactGuard _ [] = pure () +enforceArtifactGuard runOpts blocking + | runOpts ^. #allowDowngrade = TIO.putStr (formatGuardOverride blocking) + | otherwise = do + TIO.putStr (formatGuardRefusal blocking) + exitFailure + -- | Apply the pending-migration policy. -- -- Without @--with-migrations@: the run refuses and prints a one-line @@ -669,10 +729,10 @@ IO Manifest handlePendingMigrations _ _ _ manifest [] = pure manifest handlePendingMigrations level runOpts manifestPath manifest pendings - | not runOpts.runWithMigrations = do + | not (runOpts ^. #withMigrations) = do TIO.putStr (formatRefusalMessage pendings) exitFailure - | runOpts.runDryRun = do + | (runOpts ^. #dryRun) = do TIO.putStrLn "Pending migrations detected (--with-migrations + --dry-run):" mapM_ (TIO.putStrLn . renderPendingSummary) pendings TIO.putStrLn "" @@ -691,17 +751,17 @@ renderPendingSummary :: (ModuleName, MigrationPlan) -> Text renderPendingSummary (name, plan) = " " - <> name.unModuleName + <> name ^. #unModuleName <> ": " - <> renderVersion plan.planFrom + <> renderVersion (plan ^. #from) <> " -> " - <> renderVersion plan.planTo + <> renderVersion (plan ^. #to) <> " (" - <> T.pack (show (length plan.planSteps)) + <> T.pack (show (length (plan ^. #steps))) <> " step(s))" -- | Apply one pending plan in-band. Reuses 'runMigrate' with --- @migrateNoFetch=True@ since 'detectPendingMigrations' already +-- @noFetch=True@ since 'detectPendingMigrations' already -- compared against the locally installed copy: there is no need to -- clone the source repo a second time. Migration conflicts (a tracked -- file the user has edited since generation) propagate as a hard @@ -719,26 +779,43 @@ logIO level $ logError $ "internal error: applied module '" - <> modName.unModuleName + <> modName ^. #unModuleName <> "' missing while applying its migration" exitFailure Just am -> do let opts = MigrateOpts - { migrateModule = modName, - migrateTo = Nothing, - migrateDryRun = False, - migrateForce = False, - migrateJson = False, - migrateVerbose = False, - migrateNoFetch = True, - migrateCommit = False, - migrateCommitMessage = Nothing + { module_ = modName, + to = Nothing, + dryRun = False, + force = False, + json = False, + verbose = False, + noFetch = True, + commit = False, + commitMessage = Nothing, + -- Only 'handleMigrate' consults this; 'runMigrate' is the + -- guard-free core, and 'handleRun' has already applied the + -- guard to this run's composition above. + allowDowngrade = False } - result <- runMigrate opts manifest am.source + -- The manifest records a portable origin, so the module has to be + -- located on this machine before it can be re-read. + resolved <- resolveAppliedArtifactDir "module.dhall" (am ^. #origin) + moduleDir <- case resolved of + Left refErr -> do + logIO level $ + logError $ + "Migration failed for " + <> modName ^. #unModuleName + <> ":\n\n" + <> renderArtifactRefError refErr + exitFailure + Right directory -> pure directory + result <- runMigrate opts manifest moduleDir case result of Right (MigrateApplied _ manifest' _ _) -> do - TIO.putStrLn $ " Migrated " <> modName.unModuleName + TIO.putStrLn $ " Migrated " <> (modName ^. #unModuleName) pure manifest' Right (MigrateNoOp _) -> pure manifest Right (MigrateDryRunOK {}) -> pure manifest @@ -746,27 +823,28 @@ logIO level $ logError $ "Migration failed for " - <> modName.unModuleName + <> modName ^. #unModuleName <> ": " <> renderMigrateError err exitFailure renderMigrateError :: MigrateError -> Text renderMigrateError err = case err of - MigrateModuleNotApplied n -> "module " <> n.unModuleName <> " not applied" - MigrateNoRecordedVersion n -> "no version recorded for " <> n.unModuleName + MigrateModuleNotApplied n -> "module " <> n ^. #unModuleName <> " not applied" + MigrateNoRecordedVersion n -> "no version recorded for " <> (n ^. #unModuleName) MigrateInstalledModuleEvalFailed _ msg -> msg - MigrateInstalledModuleHasNoVersion n _ -> "no version on installed " <> n.unModuleName + MigrateInstalledModuleHasNoVersion n _ -> "no version on installed " <> (n ^. #unModuleName) MigrateUnparseableInstalledVersion v -> "bad version " <> v MigrateUnparseableTargetVersion v -> "bad target version " <> v MigrateUnparseableManifestVersion v -> "bad manifest version " <> v MigratePlanFailed _ -> "plan failed" MigrateExecFailed _ -> "execution failed; revert your edits or run 'seihou migrate --force' first" MigrateNoManifest _ -> "no manifest in current dir" + MigrateArtifactUnresolved refErr -> renderArtifactRefError refErr findAppliedByName :: Manifest -> ModuleName -> Maybe AppliedModule findAppliedByName manifest name = - case filter (\am -> am.name == name) manifest.modules of + case filter (\am -> am ^. #name == name) (manifest ^. #modules) of (am : _) -> Just am [] -> Nothing @@ -781,25 +859,25 @@ -- refreshes the matching instance and leaves siblings unchanged. updateAllModules :: [AppliedModule] -> - [(ModuleInstance, Module, FilePath)] -> + [(ModuleInstance, Module, ArtifactOrigin)] -> UTCTime -> [AppliedModule] updateAllModules existing modulesInOrder now = let composedKeys = Set.fromList - [ (inst.instanceModule, inst.instanceParentVars) + [ (inst ^. #module_, inst ^. #parentVars) | (inst, _, _) <- modulesInOrder ] - filtered = filter (\am -> not (Set.member (am.name, am.parentVars) composedKeys)) existing + filtered = filter (\am -> not (Set.member (am ^. #name, am ^. #parentVars) composedKeys)) existing new = [ AppliedModule - { name = inst.instanceModule, - parentVars = inst.instanceParentVars, - source = dir, - moduleVersion = m.version, + { name = inst ^. #module_, + parentVars = inst ^. #parentVars, + origin = origin, + moduleVersion = m ^. #version, appliedAt = now, - removal = m.removal + removal = m ^. #removal } - | (inst, m, dir) <- modulesInOrder + | (inst, m, origin) <- modulesInOrder ] in filtered ++ new diff --git a/src-exe/Seihou/CLI/SchemaUpgrade.hs b/src-exe/Seihou/CLI/SchemaUpgrade.hs --- a/src-exe/Seihou/CLI/SchemaUpgrade.hs +++ b/src-exe/Seihou/CLI/SchemaUpgrade.hs @@ -3,6 +3,7 @@ ) where +import Data.Generics.Labels () import Data.Text qualified as T import Data.Text.IO qualified as TIO import Seihou.CLI.Commands (SchemaUpgradeOpts (..)) @@ -16,14 +17,14 @@ handleSchemaUpgrade :: SchemaUpgradeOpts -> IO () handleSchemaUpgrade opts - | opts.schemaUpgradeAll = do + | (opts ^. #all) = do searchPaths <- defaultSearchPaths modules <- discoverAllModules searchPaths - let paths = [dir "module.dhall" | DiscoveredModule {discoveredDir = dir} <- modules] - results <- mapM (processModule opts.schemaUpgradeDryRun) paths + let paths = [dir "module.dhall" | DiscoveredModule {dir = dir} <- modules] + results <- mapM (processModule (opts ^. #dryRun)) paths printSummary results | otherwise = do - moduleDir <- case opts.schemaUpgradePath of + moduleDir <- case opts ^. #path of Just p -> pure p Nothing -> getCurrentDirectory let dhallFile = moduleDir "module.dhall" @@ -33,7 +34,7 @@ TIO.putStrLn $ "Error: " <> T.pack dhallFile <> " not found." exitFailure else do - results <- sequence [processModule opts.schemaUpgradeDryRun dhallFile] + results <- sequence [processModule (opts ^. #dryRun) dhallFile] printSummary results data ProcessResult diff --git a/src-exe/Seihou/CLI/Setup.hs b/src-exe/Seihou/CLI/Setup.hs --- a/src-exe/Seihou/CLI/Setup.hs +++ b/src-exe/Seihou/CLI/Setup.hs @@ -6,12 +6,13 @@ where import Data.FileEmbed (embedFile) +import Data.Generics.Labels () import Data.Text.Encoding qualified as TE import Data.Text.IO qualified as TIO import Seihou.CLI.AgentCompletion ( AgentModelConfig (..), AgentProvider (..), - buildAgentCompletionRequest, + buildAgentCompletionRequestWith, runAgentCompletion, ) import Seihou.CLI.AgentLaunch @@ -26,7 +27,9 @@ substitute, ) import Seihou.CLI.AgentLaunchExec (launchConfiguredAgent) +import Seihou.CLI.AgentTrace (traceSinkForConfig) import Seihou.CLI.Commands (SetupOpts (..)) +import Seihou.Core.Types (LogLevel (..)) import Seihou.Prelude import System.Exit (exitFailure, exitWith) @@ -38,12 +41,12 @@ handleSetup debug modelConfig setupOpts = do ctx <- gatherAgentContext let systemPrompt = renderPrompt ctx - runRenderedAgentPrompt debug modelConfig systemPrompt setupOpts.setupPrompt + runRenderedAgentPrompt debug modelConfig systemPrompt (setupOpts ^. #prompt) renderPrompt :: AgentContext -> Text renderPrompt ctx = substitute - [ ("cwd", ctx.cwd), + [ ("cwd", ctx ^. #cwd), ("seihou_project_state", formatSeihouProjectState ctx), ("manifest_state", formatManifestState ctx), ("module_dhall_state", formatModuleDhallState ctx), @@ -55,11 +58,12 @@ runRenderedAgentPrompt :: Bool -> AgentModelConfig -> Text -> Maybe Text -> IO () runRenderedAgentPrompt debug modelConfig systemPrompt initialPrompt | debug = TIO.putStr systemPrompt - | modelConfig.agentProvider == AgentProviderClaudeCli || modelConfig.agentProvider == AgentProviderCodexCli = do + | modelConfig ^. #provider == AgentProviderClaudeCli || modelConfig ^. #provider == AgentProviderCodexCli = do exitCode <- launchConfiguredAgent modelConfig setupAllowedTools debug systemPrompt initialPrompt exitWith exitCode | otherwise = do - result <- runAgentCompletion (buildAgentCompletionRequest modelConfig systemPrompt initialPrompt) + sink <- traceSinkForConfig LogNormal modelConfig + result <- runAgentCompletion (buildAgentCompletionRequestWith sink modelConfig systemPrompt initialPrompt) case result of Right assistantText -> TIO.putStrLn assistantText Left err -> do diff --git a/src-exe/Seihou/CLI/Status.hs b/src-exe/Seihou/CLI/Status.hs --- a/src-exe/Seihou/CLI/Status.hs +++ b/src-exe/Seihou/CLI/Status.hs @@ -4,12 +4,14 @@ where import Control.Exception (SomeException, try) +import Data.Generics.Labels () import Data.Text.IO qualified as TIO import Seihou.CLI.Commands (StatusOpts (..)) +import Seihou.CLI.ManifestGuard (ArtifactCheck, checkAppliedArtifacts) import Seihou.CLI.Outdated (checkInstalledModulesForUpdates) import Seihou.CLI.PendingMigrations (detectPendingMigrations) import Seihou.CLI.Shared (logIO) -import Seihou.CLI.StatusRender (formatStatus) +import Seihou.CLI.StatusRender (formatArtifactChecks, formatStatus) import Seihou.CLI.Style (useColor) import Seihou.CLI.VersionCompare (OutdatedEntry (..)) import Seihou.Core.Module (defaultSearchPaths, discoverAllModules) @@ -20,6 +22,7 @@ import Seihou.Effect.ManifestStore (readManifest) import Seihou.Effect.ManifestStoreInterp (runManifestStore) import Seihou.Prelude +import System.Directory (getCurrentDirectory) import System.Exit (exitFailure) import System.IO (hPutStrLn, stderr) @@ -47,11 +50,32 @@ TIO.putStrLn "No Seihou manifest found. Run 'seihou run ' to generate a project." Right (Just (manifest, tracked)) -> do mEntries <- - if opts.statusCheckUpdates && not (null manifest.modules) + if opts ^. #statusCheckUpdates && not (null (manifest ^. #modules)) then fetchUpdateEntries else pure Nothing pendings <- detectPendingMigrations manifest Nothing TIO.putStr (formatStatus colorEnabled manifest tracked mEntries pendings) + -- Report, never fail: a stale or mismatched module makes 'seihou run' + -- refuse, and this is where a developer finds out before that happens. + -- Any IO failure while checking is swallowed for the same reason. + guardChecks <- fetchArtifactChecks manifest + TIO.putStr (formatArtifactChecks colorEnabled guardChecks) + +-- | Compare every recorded artifact against this machine, catching any IO +-- failure so status still renders. An empty list means "nothing to report", +-- which is also what a failed check yields — @seihou status@ must not turn a +-- reporting problem into an exit code. +fetchArtifactChecks :: Manifest -> IO [ArtifactCheck] +fetchArtifactChecks manifest = do + outcome <- try $ do + projectRoot <- getCurrentDirectory + searchPaths <- defaultSearchPaths + checkAppliedArtifacts projectRoot searchPaths manifest + case outcome of + Left (e :: SomeException) -> do + hPutStrLn stderr ("warning: artifact check failed: " <> show e) + pure [] + Right checks -> pure checks -- | Run the update check, catching any IO failure so status still renders. fetchUpdateEntries :: IO (Maybe [OutdatedEntry]) diff --git a/src-exe/Seihou/CLI/Update.hs b/src-exe/Seihou/CLI/Update.hs --- a/src-exe/Seihou/CLI/Update.hs +++ b/src-exe/Seihou/CLI/Update.hs @@ -6,6 +6,7 @@ import Control.Monad (unless, when) import Data.Aeson (encode, object, (.=)) import Data.ByteString.Lazy.Char8 qualified as LBS +import Data.Generics.Labels () import Data.Maybe (isJust) import Data.Set qualified as Set import Data.Text qualified as T @@ -45,9 +46,9 @@ validateOptions :: UpdateOpts -> IO () validateOptions opts - | opts.updateDryRun && (opts.updateCommit || isJust opts.updateCommitMessage) = + | opts ^. #dryRun && (opts ^. #commit || isJust (opts ^. #commitMessage)) = failCli opts "invalid_options" "--commit and --commit-message cannot be used with --dry-run" - | opts.updateRunAllCommands && opts.updateNoCommands = + | opts ^. #runAllCommands && (opts ^. #noCommands) = failCli opts "invalid_options" "--run-all-commands and --no-commands are mutually exclusive" | otherwise = pure () @@ -55,50 +56,51 @@ requestFromOptions terminal opts = Service.UpdateRequest { selection = - if null opts.updateTargets + if null (opts ^. #targets) then Service.AllRecordedApplications - else Service.NamedUpdateTargets opts.updateTargets, - varOverrides = opts.updateVars, - reconfigure = opts.updateReconfigure, + else Service.NamedUpdateTargets (opts ^. #targets), + varOverrides = opts ^. #vars, + reconfigure = opts ^. #reconfigure, promptPolicy = - if terminal && not opts.updateJson + if terminal && not (opts ^. #json) then Service.AllowPrompts else Service.ForbidPrompts, commandPolicy = - if opts.updateRunAllCommands + if opts ^. #runAllCommands then RunAllCommands - else if opts.updateNoCommands then DisableCommands else RunChangedCommands, - dryRun = opts.updateDryRun + else if opts ^. #noCommands then DisableCommands else RunChangedCommands, + dryRun = opts ^. #dryRun, + allowDowngrade = opts ^. #allowDowngrade } handlePlanned :: Bool -> UpdateOpts -> Either Service.UpdateError Service.UpdatePlan -> IO () handlePlanned _ opts (Left err) = do - if opts.updateJson + if opts ^. #json then LBS.putStrLn (encodeUpdateOutput (errorOutput err)) else TIO.hPutStr stderr (renderUpdateHuman False (errorOutput err)) exitFailure handlePlanned terminal opts (Right originalPlan) = do forced <- - if opts.updateForce + if opts ^. #force then either (failInteraction opts) pure (forceResolveUpdatePlan originalPlan) else pure originalPlan resolved <- resolveInteractively - (if terminal && not opts.updateJson then Interactive else NonInteractive) + (if terminal && not (opts ^. #json) then Interactive else NonInteractive) forced >>= either (failInteraction opts) pure color <- useColor if Service.isUpdateNoOp resolved then - if opts.updateJson + if opts ^. #json then LBS.putStrLn (encodeUpdateOutput (planOutput resolved)) else TIO.putStrLn "Already up to date." else - if opts.updateDryRun + if opts ^. #dryRun then emitPlan color opts resolved else do - unless opts.updateJson $ TIO.putStr (renderUpdateHuman color (planOutput resolved)) - accepted <- if opts.updateJson then pure True else confirmApply terminal + unless (opts ^. #json) $ TIO.putStr (renderUpdateHuman color (planOutput resolved)) + accepted <- if opts ^. #json then pure True else confirmApply terminal if not accepted then TIO.hPutStrLn stderr "Update cancelled; no managed state was changed." else do @@ -106,10 +108,10 @@ case applied of Left err -> handlePlanned terminal opts (Left err) Right result -> do - if opts.updateJson + if opts ^. #json then LBS.putStrLn (encodeUpdateOutput (resultOutput result)) else TIO.putStr (renderUpdateHuman color (resultOutput result)) - when (opts.updateCommit || isJust opts.updateCommitMessage) $ do + when (opts ^. #commit || isJust (opts ^. #commitMessage)) $ do committed <- commitUpdate opts result case committed of Left err -> do @@ -119,7 +121,7 @@ emitPlan :: Bool -> UpdateOpts -> Service.UpdatePlan -> IO () emitPlan color opts plan = - if opts.updateJson + if opts ^. #json then LBS.putStrLn (encodeUpdateOutput (planOutput plan)) else TIO.putStr (renderUpdateHuman color (planOutput plan)) @@ -147,7 +149,7 @@ commitUpdate :: UpdateOpts -> Service.UpdateResult -> IO (Either Text ()) commitUpdate opts result = do - let candidates = filter (not . isAbsolute) (Set.toAscList result.touchedPaths) + let candidates = filter (not . isAbsolute) (Set.toAscList (result ^. #touchedPaths)) inRepo <- runEff $ runProcessIO isGitRepo if not inRepo then pure (Right ()) @@ -161,11 +163,11 @@ case addExit of ExitFailure _ -> pure (Left (T.strip addErr)) ExitSuccess -> do - message <- case opts.updateCommitMessage of + message <- case opts ^. #commitMessage of Just custom -> pure custom Nothing -> do diff <- runEff $ runProcessIO gitDiffCached - let modules = map (ModuleName . (.name)) result.versions + let modules = map (ModuleName . (^. #name)) (result ^. #versions) generateCommitMessage modules diff (commitExit, _, commitErr) <- runEff $ runProcessIO $ gitCommit message pure $ case commitExit of @@ -190,7 +192,7 @@ failCli :: UpdateOpts -> Text -> Text -> IO a failCli opts code message = do - if opts.updateJson + if opts ^. #json then LBS.putStrLn $ encode $ diff --git a/src-exe/Seihou/CLI/Upgrade.hs b/src-exe/Seihou/CLI/Upgrade.hs --- a/src-exe/Seihou/CLI/Upgrade.hs +++ b/src-exe/Seihou/CLI/Upgrade.hs @@ -9,6 +9,7 @@ import Data.Aeson (ToJSON (..), object, (.=)) import Data.Aeson.Encode.Pretty (encodePretty) import Data.ByteString.Lazy qualified as LBS +import Data.Generics.Labels () import Data.Map.Strict qualified as Map import Data.Text qualified as T import Data.Text.IO qualified as TIO @@ -24,6 +25,7 @@ ) import Seihou.CLI.Outdated (moduleNameFromDm, readOriginWithModule) import Seihou.CLI.RemoteVersion (fetchTrueModuleVersion) +import Seihou.CLI.Shared (resolveAppliedArtifactDir) import Seihou.CLI.Style (dim, green, red, useColor, yellow) import Seihou.CLI.VersionCompare (OutdatedStatus (..), compareVersions) import Seihou.Core.Install (parseModuleName) @@ -50,20 +52,20 @@ deriving stock (Eq, Show) data UpgradeEntry = UpgradeEntry - { moduleName :: Text, - oldVersion :: Maybe Text, - newVersion :: Maybe Text, - upgradeStatus :: UpgradeStatus + { moduleName :: !Text, + oldVersion :: !(Maybe Text), + newVersion :: !(Maybe Text), + upgradeStatus :: !UpgradeStatus } - deriving stock (Eq, Show) + deriving stock (Eq, Generic, Show) instance ToJSON UpgradeEntry where toJSON e = object - [ "module" .= e.moduleName, - "oldVersion" .= e.oldVersion, - "newVersion" .= e.newVersion, - "status" .= statusText e.upgradeStatus + [ "module" .= (e ^. #moduleName), + "oldVersion" .= (e ^. #oldVersion), + "newVersion" .= (e ^. #newVersion), + "status" .= statusText (e ^. #upgradeStatus) ] where statusText :: UpgradeStatus -> Text @@ -77,7 +79,7 @@ handleUpgrade uopts = do searchPaths <- defaultSearchPaths modules <- discoverAllModules searchPaths - let installed = filter (\dm -> dm.discoveredSource == SourceInstalled) modules + let installed = filter (\dm -> dm ^. #source == SourceInstalled) modules if null installed then TIO.putStrLn "No installed modules found." @@ -85,7 +87,7 @@ originsWithModules <- mapM readOriginWithModule installed let withOrigins = [(dm, origin) | (dm, Just origin) <- originsWithModules] - filtered <- case uopts.upgradeModules of + filtered <- case uopts ^. #modules of [] -> pure withOrigins names -> do let result = [(dm, origin) | (dm, origin) <- withOrigins, moduleNameFromDm dm `elem` names] @@ -99,15 +101,15 @@ if null filtered then TIO.putStrLn "No installed modules with origin metadata found." else do - let grouped = Map.toList $ Map.fromListWith (++) [(origin.sourceUrl, [(dm, origin)]) | (dm, origin) <- filtered] + let grouped = Map.toList $ Map.fromListWith (++) [(origin ^. #sourceUrl, [(dm, origin)]) | (dm, origin) <- filtered] - if uopts.upgradeDryRun + if uopts ^. #dryRun then TIO.putStrLn "Checking installed modules for updates (dry run)..." else TIO.putStrLn "Upgrading installed modules..." entries <- concat <$> mapM (upgradeSource uopts) grouped - if uopts.upgradeJson + if uopts ^. #json then LBS.putStr (encodePretty entries) else renderUpgradeTable entries @@ -115,7 +117,7 @@ -- migrations pending for any module that was upgraded just -- now. Either run them (--with-migrations) or print a -- one-line advisory per module. - unless uopts.upgradeDryRun $ + unless (uopts ^. #dryRun) $ handlePostUpgradeMigrations uopts entries upgradeSource :: UpgradeOpts -> (Text, [(DiscoveredModule, OriginInfo)]) -> IO [UpgradeEntry] @@ -144,7 +146,7 @@ mkUnreachableEntry dm origin = UpgradeEntry { moduleName = moduleNameFromDm dm, - oldVersion = origin.version, + oldVersion = origin ^. #version, newVersion = Nothing, upgradeStatus = SourceUnreachable } @@ -152,22 +154,22 @@ upgradeModule :: UpgradeOpts -> FilePath -> RepoContents -> Text -> (DiscoveredModule, OriginInfo) -> IO UpgradeEntry upgradeModule uopts cloneDir contents sourceUrl (dm, origin) = do let name = moduleNameFromDm dm - installedVer = origin.version + installedVer = (origin ^. #version) availableVer <- fetchAvailable cloneDir (ModuleName name) let status = compareVersions installedVer availableVer case status of OutdatedSt - | uopts.upgradeDryRun -> + | uopts ^. #dryRun -> pure UpgradeEntry {moduleName = name, oldVersion = installedVer, newVersion = availableVer, upgradeStatus = Upgraded} | otherwise -> doUpgrade cloneDir contents sourceUrl origin name installedVer availableVer UpToDate -> pure UpgradeEntry {moduleName = name, oldVersion = installedVer, newVersion = availableVer, upgradeStatus = AlreadyUpToDate} Unversioned - | uopts.upgradeSkipUnversioned -> + | uopts ^. #skipUnversioned -> pure UpgradeEntry {moduleName = name, oldVersion = installedVer, newVersion = availableVer, upgradeStatus = Skipped} - | uopts.upgradeDryRun -> + | uopts ^. #dryRun -> pure UpgradeEntry {moduleName = name, oldVersion = installedVer, newVersion = availableVer, upgradeStatus = Upgraded} | otherwise -> doUpgrade cloneDir contents sourceUrl origin name installedVer availableVer @@ -177,10 +179,10 @@ doUpgrade :: FilePath -> RepoContents -> Text -> OriginInfo -> Text -> Maybe Text -> Maybe Text -> IO UpgradeEntry doUpgrade cloneDir contents sourceUrl origin name installedVer availableVer = do let result = case contents of - SingleModule rootDir -> Just (rootDir, origin.repoName) + SingleModule rootDir -> Just (rootDir, origin ^. #repoName) MultiModule registry -> - case filter (\e -> e.name.unModuleName == name) registry.modules of - (entry : _) -> Just (cloneDir entry.path, Just registry.repoName) + case filter (\e -> e ^. #name . #unModuleName == name) (registry ^. #modules) of + (entry : _) -> Just (cloneDir entry ^. #path, Just (registry ^. #repoName)) [] -> Nothing SingleRecipe _ -> Nothing SingleBlueprint _ -> Nothing @@ -207,21 +209,21 @@ -- docs/plans/14-fix-outdated-version-detection.md). Tags are -- still sourced from the registry entry since module.dhall -- has no equivalent field. - let (ver, entryTags) = case contents of - MultiModule registry -> case filter (\e -> e.name.unModuleName == name) registry.modules of - (entry : _) -> (modul.version <|> entry.version, entry.tags) - [] -> (modul.version, []) - _ -> (modul.version, []) - installModuleDir moduleDir (T.unpack name) sourceUrl registryName ver entryTags + let (ver, tags) = case contents of + MultiModule registry -> case filter (\e -> e ^. #name . #unModuleName == name) (registry ^. #modules) of + (entry : _) -> (modul ^. #version <|> entry ^. #version, entry ^. #tags) + [] -> (modul ^. #version, []) + _ -> (modul ^. #version, []) + installModuleDir moduleDir (T.unpack name) sourceUrl registryName ver tags TIO.putStrLn $ " Upgraded " <> name pure UpgradeEntry {moduleName = name, oldVersion = installedVer, newVersion = availableVer, upgradeStatus = Upgraded} renderUpgradeTable :: [UpgradeEntry] -> IO () renderUpgradeTable entries = do colorEnabled <- useColor - let maxNameLen = max 6 (maximum (map (T.length . (.moduleName)) entries)) - maxOldLen = max 3 (maximum (map (T.length . maybe "(none)" id . (.oldVersion)) entries)) - maxNewLen = max 3 (maximum (map (T.length . maybe "(none)" id . (.newVersion)) entries)) + let maxNameLen = max 6 (maximum (map (T.length . (^. #moduleName)) entries)) + maxOldLen = max 3 (maximum (map (T.length . maybe "(none)" id . (^. #oldVersion)) entries)) + maxNewLen = max 3 (maximum (map (T.length . maybe "(none)" id . (^. #newVersion)) entries)) padR n t = t <> T.replicate (n - T.length t + 2) " " @@ -232,15 +234,15 @@ <> "Status" formatRow e = - let oldText = maybe "(none)" id e.oldVersion - newText = maybe "(none)" id e.newVersion - statusTxt = case e.upgradeStatus of + let oldText = maybe "(none)" id (e ^. #oldVersion) + newText = maybe "(none)" id (e ^. #newVersion) + statusTxt = case e ^. #upgradeStatus of Upgraded -> if colorEnabled then green "upgraded" else "upgraded" AlreadyUpToDate -> if colorEnabled then dim "up to date" else "up to date" Skipped -> if colorEnabled then yellow "skipped (unversioned)" else "skipped (unversioned)" UpgradeFailed reason -> if colorEnabled then red ("failed: " <> reason) else "failed: " <> reason SourceUnreachable -> if colorEnabled then yellow "unreachable" else "unreachable" - in padR maxNameLen e.moduleName + in padR maxNameLen (e ^. #moduleName) <> padR maxOldLen oldText <> padR maxNewLen newText <> statusTxt @@ -249,9 +251,9 @@ TIO.putStrLn header mapM_ (TIO.putStrLn . formatRow) entries - let upgraded = length (filter (\e -> e.upgradeStatus == Upgraded) entries) + let upgraded = length (filter (\e -> e ^. #upgradeStatus == Upgraded) entries) failed = length (filter isFailedEntry entries) - skipped = length (filter (\e -> e.upgradeStatus == Skipped) entries) + skipped = length (filter (\e -> e ^. #upgradeStatus == Skipped) entries) TIO.putStrLn "" TIO.putStrLn $ T.pack (show (length entries)) @@ -263,7 +265,7 @@ <> "." isFailedEntry :: UpgradeEntry -> Bool -isFailedEntry e = case e.upgradeStatus of +isFailedEntry e = case e ^. #upgradeStatus of UpgradeFailed _ -> True SourceUnreachable -> True _ -> False @@ -280,7 +282,7 @@ handlePostUpgradeMigrations uopts entries = do let manifestPath = ".seihou" "manifest.json" upgraded = - [ entry.moduleName | entry <- entries, entry.upgradeStatus == Upgraded + [ entry ^. #moduleName | entry <- entries, entry ^. #upgradeStatus == Upgraded ] if null upgraded then pure () @@ -297,20 +299,27 @@ case findAppliedByName manifest name of Nothing -> pure () Just am -> do - let dhallFile = am.source "module.dhall" - r <- evalModuleFromFile dhallFile - case r of + -- The manifest records a portable origin, so the just-upgraded module + -- has to be located on this machine before its migrations can be read. + -- This is advisory reporting after a successful upgrade, so a module + -- that does not resolve here is skipped rather than reported. + resolved <- resolveAppliedArtifactDir "module.dhall" (am ^. #origin) + case resolved of Left _ -> pure () - Right installed -> - case pendingChainFor am installed of - Nothing -> pure () - Just plan - | uopts.upgradeWithMigrations -> runOnePostUpgradeMigration am.source name - | otherwise -> printAdvisory name plan + Right moduleDir -> do + r <- evalModuleFromFile (moduleDir "module.dhall") + case r of + Left _ -> pure () + Right installed -> + case pendingChainFor am installed of + Nothing -> pure () + Just plan + | uopts ^. #withMigrations -> runOnePostUpgradeMigration moduleDir name + | otherwise -> printAdvisory name plan findAppliedByName :: Manifest -> Text -> Maybe AppliedModule findAppliedByName manifest name = - case filter (\am -> am.name.unModuleName == name) manifest.modules of + case filter (\am -> am ^. #name . #unModuleName == name) (manifest ^. #modules) of (am : _) -> Just am [] -> Nothing @@ -321,11 +330,11 @@ "note: " <> name <> " has " - <> T.pack (show (length plan.planSteps)) + <> T.pack (show (length (plan ^. #steps))) <> " migration(s) pending (" - <> renderVersion plan.planFrom + <> renderVersion (plan ^. #from) <> " → " - <> renderVersion plan.planTo + <> renderVersion (plan ^. #to) <> "); run 'seihou update' to reconcile the recorded project application" TIO.putStrLn $ if colorEnabled then yellow msg else msg @@ -340,18 +349,22 @@ Right (Just manifest) -> do let opts = MigrateOpts - { migrateModule = ModuleName name, - migrateTo = Nothing, - migrateDryRun = False, - migrateForce = False, - migrateJson = False, - migrateVerbose = False, + { module_ = ModuleName name, + to = Nothing, + dryRun = False, + force = False, + json = False, + verbose = False, -- The post-upgrade hook has already refreshed the -- installed copy via 'seihou upgrade'; skip the -- redundant fetch in 'runMigrate'. - migrateNoFetch = True, - migrateCommit = False, - migrateCommitMessage = Nothing + noFetch = True, + commit = False, + commitMessage = Nothing, + -- Only 'handleMigrate' consults this; 'runMigrate' is the + -- guard-free core, and the upgrade that got us here has + -- just refreshed the installed copy anyway. + allowDowngrade = False } result <- runMigrate opts manifest installedDir case result of @@ -369,10 +382,10 @@ renderMigrateError :: MigrateError -> Text renderMigrateError err = case err of - MigrateModuleNotApplied n -> "module " <> n.unModuleName <> " not applied" - MigrateNoRecordedVersion n -> "no version recorded for " <> n.unModuleName + MigrateModuleNotApplied n -> "module " <> n ^. #unModuleName <> " not applied" + MigrateNoRecordedVersion n -> "no version recorded for " <> (n ^. #unModuleName) MigrateInstalledModuleEvalFailed _ msg -> msg - MigrateInstalledModuleHasNoVersion n _ -> "no version on installed " <> n.unModuleName + MigrateInstalledModuleHasNoVersion n _ -> "no version on installed " <> (n ^. #unModuleName) MigrateUnparseableInstalledVersion v -> "bad version " <> v MigrateUnparseableTargetVersion v -> "bad target version " <> v MigrateUnparseableManifestVersion v -> "bad manifest version " <> v diff --git a/src-exe/Seihou/CLI/Validate.hs b/src-exe/Seihou/CLI/Validate.hs --- a/src-exe/Seihou/CLI/Validate.hs +++ b/src-exe/Seihou/CLI/Validate.hs @@ -3,6 +3,7 @@ ) where +import Data.Generics.Labels () import Data.Text qualified as T import Data.Text.IO qualified as TIO import Seihou.CLI.Commands (ValidateOpts (..)) @@ -19,7 +20,7 @@ handleValidateModule :: ValidateOpts -> IO () handleValidateModule vopts = do -- Determine module path - moduleDir <- case vopts.validatePath of + moduleDir <- case vopts ^. #path of Just p -> pure p Nothing -> getCurrentDirectory @@ -39,7 +40,7 @@ case decoded of Left err -> do - -- Dhall failed: build a report with reportDhallOk = False + -- Dhall failed: build a report with dhallOk = False let dummyModule = Module { name = ModuleName "", @@ -56,17 +57,17 @@ } report = ValidateReport - { reportModule = dummyModule, - reportPath = moduleDir, - reportDhallOk = False, - reportDhallError = Just (T.pack (show err)), - reportChecks = [] + { module_ = dummyModule, + path = moduleDir, + dhallOk = False, + dhallError = Just (T.pack (show err)), + checks = [] } TIO.putStr (renderReportColor colorEnabled report) exitFailure Right modul -> do -- Build the structured report - report <- buildReport vopts.validateLint moduleDir modul + report <- buildReport (vopts ^. #lint) moduleDir modul TIO.putStr (renderReportColor colorEnabled report) if reportHasErrors report then exitFailure diff --git a/src-exe/Seihou/CLI/ValidateBlueprint.hs b/src-exe/Seihou/CLI/ValidateBlueprint.hs --- a/src-exe/Seihou/CLI/ValidateBlueprint.hs +++ b/src-exe/Seihou/CLI/ValidateBlueprint.hs @@ -3,8 +3,10 @@ ) where +import Data.Generics.Labels () import Data.Text qualified as T import Data.Text.IO qualified as TIO +import Seihou.CLI.AgentConfig (agentLaunchDeclaration, validateAgentLaunchDeclaration) import Seihou.CLI.Commands (ValidateBlueprintOpts (..)) import Seihou.CLI.Shared (logIO) import Seihou.CLI.Style (bold, cyan, dim, green, red, useColor, yellow) @@ -12,6 +14,7 @@ ( checkBlueprintAllowedTools, checkBlueprintBaseModules, checkBlueprintFiles, + checkBlueprintLaunch, checkBlueprintNameFormat, checkBlueprintPromptNonEmpty, checkBlueprintPromptRefs, @@ -34,18 +37,19 @@ -- and a 'files/' integrity check). data BlueprintReport = BlueprintReport { -- | 'Nothing' when Dhall evaluation failed; otherwise the decoded record - brBlueprint :: Maybe Blueprint, + blueprint :: !(Maybe Blueprint), -- | Display name; equals the decoded blueprint's name when available - brName :: Text, - brPath :: FilePath, - brDhallOk :: Bool, - brDhallError :: Maybe Text, - brChecks :: [DiagCheck] + name :: !Text, + path :: !FilePath, + dhallOk :: !Bool, + dhallError :: !(Maybe Text), + checks :: ![DiagCheck] } + deriving stock (Generic) handleValidateBlueprint :: ValidateBlueprintOpts -> IO () handleValidateBlueprint vopts = do - blueprintDir <- case vopts.validateBlueprintPath of + blueprintDir <- case vopts ^. #path of Just p -> pure p Nothing -> getCurrentDirectory @@ -65,12 +69,12 @@ Left err -> do let report = BlueprintReport - { brBlueprint = Nothing, - brName = "", - brPath = blueprintDir, - brDhallOk = False, - brDhallError = Just (T.pack (show err)), - brChecks = [] + { blueprint = Nothing, + name = "", + path = blueprintDir, + dhallOk = False, + dhallError = Just (T.pack (show err)), + checks = [] } TIO.putStr (renderBlueprintReport colorEnabled report) exitFailure @@ -99,27 +103,35 @@ DiagCheck "Base modules" DiagError baseErrors, DiagCheck "Reference file existence" DiagError fileErrors, DiagCheck "Tags" DiagError (checkBlueprintTags b), - DiagCheck "Allowed tools" DiagError (checkBlueprintAllowedTools b) + DiagCheck "Allowed tools" DiagError (checkBlueprintAllowedTools b), + -- Two layers: the core rule rejects blanks, and the CLI parses the + -- declared provider and effort against the vocabularies it owns. + DiagCheck + "Launch settings" + DiagError + ( checkBlueprintLaunch b + <> validateAgentLaunchDeclaration (agentLaunchDeclaration (b ^. #launch)) + ) ] pure BlueprintReport - { brBlueprint = Just b, - brName = b.name.unModuleName, - brPath = baseDir, - brDhallOk = True, - brDhallError = Nothing, - brChecks = checks + { blueprint = Just b, + name = b ^. #name . #unModuleName, + path = baseDir, + dhallOk = True, + dhallError = Nothing, + checks = checks } blueprintReportHasErrors :: BlueprintReport -> Bool blueprintReportHasErrors r = - not r.brDhallOk - || any (\c -> c.diagSeverity == DiagError && not (null c.diagDetails)) r.brChecks + not (r ^. #dhallOk) + || any (\c -> c ^. #severity == DiagError && not (null (c ^. #details))) (r ^. #checks) renderBlueprintReport :: Bool -> BlueprintReport -> Text renderBlueprintReport color report = T.unlines $ - [ "Validating blueprint at " <> T.pack report.brPath <> "...", + [ "Validating blueprint at " <> T.pack (report ^. #path) <> "...", "" ] ++ dhallLine @@ -137,45 +149,45 @@ labelWarn t = if color then yellow t else t dhallLine = - if report.brDhallOk + if report ^. #dhallOk then [" " <> okMark <> " blueprint.dhall evaluates successfully"] else [" " <> errMark <> " blueprint.dhall failed to evaluate"] - ++ case report.brDhallError of + ++ case report ^. #dhallError of Just errText -> [" " <> detailStyle errText] Nothing -> [] - summaryLines = case report.brBlueprint of + summaryLines = case report ^. #blueprint of Nothing -> [] Just b -> - [ " " <> okMark <> " Blueprint name: " <> nameStyle b.name.unModuleName, - " " <> okMark <> " " <> T.pack (show (length b.vars)) <> " variables declared", - " " <> okMark <> " " <> T.pack (show (length b.prompts)) <> " prompts defined", - " " <> okMark <> " " <> T.pack (show (length b.baseModules)) <> " base modules declared", - " " <> okMark <> " " <> T.pack (show (length b.files)) <> " reference files declared" + [ " " <> okMark <> " Blueprint name: " <> nameStyle (b ^. #name . #unModuleName), + " " <> okMark <> " " <> T.pack (show (length (b ^. #vars))) <> " variables declared", + " " <> okMark <> " " <> T.pack (show (length (b ^. #prompts))) <> " prompts defined", + " " <> okMark <> " " <> T.pack (show (length (b ^. #baseModules))) <> " base modules declared", + " " <> okMark <> " " <> T.pack (show (length (b ^. #files))) <> " reference files declared" ] - checkLines = concatMap renderCheck report.brChecks + checkLines = concatMap renderCheck (report ^. #checks) renderCheck c - | null c.diagDetails = - [" " <> okMark <> " " <> c.diagLabel] - | c.diagSeverity == DiagWarning = - (" " <> warnMark <> " " <> labelWarn c.diagLabel) - : map (\d -> " " <> detailStyle d) c.diagDetails + | null (c ^. #details) = + [" " <> okMark <> " " <> c ^. #label] + | c ^. #severity == DiagWarning = + (" " <> warnMark <> " " <> labelWarn (c ^. #label)) + : map (\d -> " " <> detailStyle d) (c ^. #details) | otherwise = - (" " <> errMark <> " " <> labelErr c.diagLabel) - : map (\d -> " " <> detailStyle d) c.diagDetails + (" " <> errMark <> " " <> labelErr (c ^. #label)) + : map (\d -> " " <> detailStyle d) (c ^. #details) errorCount = length [ () - | c <- report.brChecks, - c.diagSeverity == DiagError, - not (null c.diagDetails) + | c <- report ^. #checks, + c ^. #severity == DiagError, + not (null (c ^. #details)) ] - dhallFailed = not report.brDhallOk + dhallFailed = not (report ^. #dhallOk) totalErrors = errorCount + (if dhallFailed then 1 else 0) resultLine @@ -183,5 +195,5 @@ let msg = T.pack (show totalErrors) <> " error(s) found." in (if color then bold (red msg) else msg) <> " Blueprint is invalid." | otherwise = - let msg = "Blueprint '" <> report.brName <> "' is valid." + let msg = "Blueprint '" <> report ^. #name <> "' is valid." in if color then green msg else msg diff --git a/src-exe/Seihou/CLI/ValidatePrompt.hs b/src-exe/Seihou/CLI/ValidatePrompt.hs --- a/src-exe/Seihou/CLI/ValidatePrompt.hs +++ b/src-exe/Seihou/CLI/ValidatePrompt.hs @@ -3,8 +3,10 @@ ) where +import Data.Generics.Labels () import Data.Text qualified as T import Data.Text.IO qualified as TIO +import Seihou.CLI.AgentConfig (agentLaunchDeclaration, validateAgentLaunchDeclaration) import Seihou.CLI.Commands (ValidatePromptOpts (..)) import Seihou.CLI.Shared (logIO) import Seihou.CLI.Style (bold, cyan, dim, green, red, useColor, yellow) @@ -14,6 +16,7 @@ checkAgentPromptCommandVars, checkAgentPromptFiles, checkAgentPromptGuidance, + checkAgentPromptLaunch, checkAgentPromptNameFormat, checkAgentPromptPromptRefs, checkAgentPromptTags, @@ -29,17 +32,18 @@ import System.Exit (ExitCode (..), exitFailure, exitWith) data PromptReport = PromptReport - { prPrompt :: Maybe AgentPrompt, - prName :: Text, - prPath :: FilePath, - prDhallOk :: Bool, - prDhallError :: Maybe Text, - prChecks :: [DiagCheck] + { prompt :: !(Maybe AgentPrompt), + name :: !Text, + path :: !FilePath, + dhallOk :: !Bool, + dhallError :: !(Maybe Text), + checks :: ![DiagCheck] } + deriving stock (Generic) handleValidatePrompt :: ValidatePromptOpts -> IO () handleValidatePrompt vopts = do - promptDir <- case vopts.validatePromptPath of + promptDir <- case vopts ^. #path of Just p -> pure p Nothing -> getCurrentDirectory @@ -59,12 +63,12 @@ Left err -> do let report = PromptReport - { prPrompt = Nothing, - prName = "", - prPath = promptDir, - prDhallOk = False, - prDhallError = Just (T.pack (show err)), - prChecks = [] + { prompt = Nothing, + name = "", + path = promptDir, + dhallOk = False, + dhallError = Just (T.pack (show err)), + checks = [] } TIO.putStr (renderPromptReport colorEnabled report) exitFailure @@ -88,27 +92,35 @@ DiagCheck "Prompt guidance" DiagError (checkAgentPromptGuidance p), DiagCheck "Reference file existence" DiagError fileErrors, DiagCheck "Tags" DiagError (checkAgentPromptTags p), - DiagCheck "Allowed tools" DiagError (checkAgentPromptAllowedTools p) + DiagCheck "Allowed tools" DiagError (checkAgentPromptAllowedTools p), + -- Two layers: the core rule rejects blanks, and the CLI parses the + -- declared provider and effort against the vocabularies it owns. + DiagCheck + "Launch settings" + DiagError + ( checkAgentPromptLaunch p + <> validateAgentLaunchDeclaration (agentLaunchDeclaration (p ^. #launch)) + ) ] pure PromptReport - { prPrompt = Just p, - prName = p.name.unModuleName, - prPath = baseDir, - prDhallOk = True, - prDhallError = Nothing, - prChecks = checks + { prompt = Just p, + name = p ^. #name . #unModuleName, + path = baseDir, + dhallOk = True, + dhallError = Nothing, + checks = checks } promptReportHasErrors :: PromptReport -> Bool promptReportHasErrors r = - not r.prDhallOk - || any (\c -> c.diagSeverity == DiagError && not (null c.diagDetails)) r.prChecks + not (r ^. #dhallOk) + || any (\c -> c ^. #severity == DiagError && not (null (c ^. #details))) (r ^. #checks) renderPromptReport :: Bool -> PromptReport -> Text renderPromptReport color report = T.unlines $ - [ "Validating prompt at " <> T.pack report.prPath <> "...", + [ "Validating prompt at " <> T.pack (report ^. #path) <> "...", "" ] ++ dhallLine @@ -126,46 +138,46 @@ labelWarn t = if color then yellow t else t dhallLine = - if report.prDhallOk + if report ^. #dhallOk then [" " <> okMark <> " prompt.dhall evaluates successfully"] else [" " <> errMark <> " prompt.dhall failed to evaluate"] - ++ case report.prDhallError of + ++ case report ^. #dhallError of Just errText -> [" " <> detailStyle errText] Nothing -> [] - summaryLines = case report.prPrompt of + summaryLines = case report ^. #prompt of Nothing -> [] Just p -> - [ " " <> okMark <> " Prompt name: " <> nameStyle p.name.unModuleName, - " " <> okMark <> " " <> T.pack (show (length p.vars)) <> " variables declared", - " " <> okMark <> " " <> T.pack (show (length p.prompts)) <> " prompts defined", - " " <> okMark <> " " <> T.pack (show (length p.commandVars)) <> " command variables declared", - " " <> okMark <> " " <> T.pack (show (length p.guidance)) <> " guidance blocks declared", - " " <> okMark <> " " <> T.pack (show (length p.files)) <> " reference files declared" + [ " " <> okMark <> " Prompt name: " <> nameStyle (p ^. #name . #unModuleName), + " " <> okMark <> " " <> T.pack (show (length (p ^. #vars))) <> " variables declared", + " " <> okMark <> " " <> T.pack (show (length (p ^. #prompts))) <> " prompts defined", + " " <> okMark <> " " <> T.pack (show (length (p ^. #commandVars))) <> " command variables declared", + " " <> okMark <> " " <> T.pack (show (length (p ^. #guidance))) <> " guidance blocks declared", + " " <> okMark <> " " <> T.pack (show (length (p ^. #files))) <> " reference files declared" ] - checkLines = concatMap renderCheck report.prChecks + checkLines = concatMap renderCheck (report ^. #checks) renderCheck c - | null c.diagDetails = - [" " <> okMark <> " " <> c.diagLabel] - | c.diagSeverity == DiagWarning = - (" " <> warnMark <> " " <> labelWarn c.diagLabel) - : map (\d -> " " <> detailStyle d) c.diagDetails + | null (c ^. #details) = + [" " <> okMark <> " " <> c ^. #label] + | c ^. #severity == DiagWarning = + (" " <> warnMark <> " " <> labelWarn (c ^. #label)) + : map (\d -> " " <> detailStyle d) (c ^. #details) | otherwise = - (" " <> errMark <> " " <> labelErr c.diagLabel) - : map (\d -> " " <> detailStyle d) c.diagDetails + (" " <> errMark <> " " <> labelErr (c ^. #label)) + : map (\d -> " " <> detailStyle d) (c ^. #details) errorCount = length [ () - | c <- report.prChecks, - c.diagSeverity == DiagError, - not (null c.diagDetails) + | c <- report ^. #checks, + c ^. #severity == DiagError, + not (null (c ^. #details)) ] - dhallFailed = not report.prDhallOk + dhallFailed = not (report ^. #dhallOk) totalErrors = errorCount + (if dhallFailed then 1 else 0) resultLine @@ -173,5 +185,5 @@ let msg = T.pack (show totalErrors) <> " error(s) found." in (if color then bold (red msg) else msg) <> " Prompt is invalid." | otherwise = - let msg = "Prompt '" <> report.prName <> "' is valid." + let msg = "Prompt '" <> report ^. #name <> "' is valid." in if color then green msg else msg diff --git a/src-exe/Seihou/CLI/Vars.hs b/src-exe/Seihou/CLI/Vars.hs --- a/src-exe/Seihou/CLI/Vars.hs +++ b/src-exe/Seihou/CLI/Vars.hs @@ -4,6 +4,7 @@ where import Control.Monad (when) +import Data.Generics.Labels () import Data.Map.Strict qualified as Map import Data.Maybe (fromMaybe) import Data.Text qualified as T @@ -30,7 +31,7 @@ handleVars :: VarsOpts -> IO () handleVars vopts = do -- Resolve module name (from argument or fzf picker) - modName <- case vopts.varsModule of + modName <- case vopts ^. #module_ of Just name -> pure name Nothing -> do fzfCfg <- detectFzfConfig @@ -61,7 +62,7 @@ case discResult of Left (ModuleNotFound _ searched) -> do logIO LogNormal $ do - logError $ "Module '" <> modName.unModuleName <> "' not found." + logError $ "Module '" <> modName ^. #unModuleName <> "' not found." logError "Searched in:" mapM_ (\p -> logError $ " " <> T.pack p) searched exitFailure @@ -69,18 +70,18 @@ logIO LogNormal (logError $ T.pack (show err)) exitFailure Right (RunnableModule m _) -> - if vopts.varsExplain + if vopts ^. #explain then explainMode modName vopts else declarationModeModule m Right (RunnableRecipe r _) -> - if vopts.varsExplain + if vopts ^. #explain then explainMode modName vopts else declarationModeRecipe r Right (RunnableBlueprint b _) -> - if vopts.varsExplain + if vopts ^. #explain then do logIO LogNormal $ do - logError $ "'" <> modName.unModuleName <> "' is a blueprint; --explain is not supported in this release." + logError $ "'" <> modName ^. #unModuleName <> "' is a blueprint; --explain is not supported in this release." logError "Resolving a blueprint's variables requires the agent runner." logError "Run `seihou agent run ` instead (when EP-31 ships)." logError "For a read-only listing of declared variables, omit --explain." @@ -90,11 +91,11 @@ -- | Declaration mode for a module: list declared variables. declarationModeModule :: Module -> IO () declarationModeModule modul = do - let vs = modul.vars + let vs = (modul ^. #vars) if null vs then TIO.putStrLn "No variables declared." else do - TIO.putStrLn $ "Variables for " <> modul.name.unModuleName <> ":" + TIO.putStrLn $ "Variables for " <> modul ^. #name . #unModuleName <> ":" TIO.putStrLn "" TIO.putStr (formatDeclarations vs) @@ -103,11 +104,11 @@ -- compose); this prints those without expanding the recipe. declarationModeRecipe :: Recipe -> IO () declarationModeRecipe r = do - let vs = r.vars + let vs = (r ^. #vars) if null vs then TIO.putStrLn "No variables declared." else do - TIO.putStrLn $ "Variables for " <> r.name.unRecipeName <> " (recipe):" + TIO.putStrLn $ "Variables for " <> r ^. #name . #unRecipeName <> " (recipe):" TIO.putStrLn "" TIO.putStr (formatDeclarations vs) @@ -116,11 +117,11 @@ -- glance that this is the agent-driven runnable, not a module/recipe. declarationModeBlueprint :: Blueprint -> IO () declarationModeBlueprint b = do - let vs = b.vars + let vs = (b ^. #vars) if null vs then TIO.putStrLn "No variables declared." else do - TIO.putStrLn $ "Variables for " <> b.name.unModuleName <> " (blueprint):" + TIO.putStrLn $ "Variables for " <> b ^. #name . #unModuleName <> " (blueprint):" TIO.putStrLn "" TIO.putStr (formatDeclarations vs) @@ -133,14 +134,14 @@ modulesInOrder <- case compositionResult of Left (ModuleNotFound name searched) -> do logIO LogNormal $ do - logError $ "Module '" <> name.unModuleName <> "' not found." + logError $ "Module '" <> name ^. #unModuleName <> "' not found." logError "Searched in:" mapM_ (\p -> logError $ " " <> T.pack p) searched exitFailure Left (CircularDependency names) -> do logIO LogNormal $ do logError "Circular dependency detected:" - logError $ " " <> T.intercalate " -> " (map (.unModuleName) names) + logError $ " " <> T.intercalate " -> " (map (^. #unModuleName) names) exitFailure Left err -> do logIO LogNormal (logError $ T.pack (show err)) @@ -157,10 +158,10 @@ -- Resolve variables with the full composition pipeline envPairs <- getEnvironment - let cliOverrides = Map.fromList [(VarName k, v) | (k, v) <- vopts.varsVars] + let cliOverrides = Map.fromList [(VarName k, v) | (k, v) <- vopts ^. #vars] envVars = Map.fromList [(T.pack k, T.pack v) | (k, v) <- envPairs] - namespace = fromMaybe (deriveNamespace modName) vopts.varsNamespace - context <- resolveContext vopts.varsContext envVars + namespace = fromMaybe (deriveNamespace modName) (vopts ^. #namespace) + context <- resolveContext (vopts ^. #context) envVars let contextName = fromMaybe "" context (resolveResult, localMap, nsMap, ctxMap, globalMap) <- runEff $ runConfigReader $ runConsole $ do localCfg <- readLocalConfig >>= unwrapConfig LogNormal @@ -188,16 +189,16 @@ Map.unions [ vs | (inst, vs) <- Map.toList resolved, - inst.instanceModule == modName + inst ^. #module_ == modName ] - TIO.putStrLn $ "Variables for " <> modName.unModuleName <> ":" + TIO.putStrLn $ "Variables for " <> modName ^. #unModuleName <> ":" TIO.putStrLn "" if Map.null targetResolved then TIO.putStrLn " (no variables resolved)" else TIO.putStr (formatExplain targetResolved) -- Show diagnostics - let allDecls = concatMap (\(_, m, _) -> m.vars) modulesInOrder + let allDecls = concatMap (\(_, m, _) -> m ^. #vars) modulesInOrder allResolved = Map.unions [vs | vs <- Map.elems resolved] (unusedKeys, unresolvedOpt) = diagnoseResolution allResolved allDecls localMap nsMap ctxMap globalMap when (not (null unusedKeys)) $ do diff --git a/src/Seihou/CLI/AgentCompletion.hs b/src/Seihou/CLI/AgentCompletion.hs --- a/src/Seihou/CLI/AgentCompletion.hs +++ b/src/Seihou/CLI/AgentCompletion.hs @@ -4,15 +4,21 @@ ( AgentProvider (..), AgentModelConfig (..), AgentCompletionRequest (..), + TraceSetting (..), defaultAgentModelConfig, defaultModelForProvider, providerFromText, providerToText, effortFromText, effortToText, + traceFromText, + traceToText, buildAgentCompletionRequest, + buildAgentCompletionRequestWith, buildBaikaiModel, runAgentCompletion, + runAgentCompletionWithCliAccess, + runAgentCompletionWith, responseText, ) where @@ -23,11 +29,18 @@ import Baikai.Provider.Claude.Cli qualified as ClaudeCli import Baikai.Provider.OpenAI.Api qualified as OpenAIApi import Baikai.Provider.OpenAI.Cli qualified as CodexCli +import Baikai.Response qualified as BaikaiResponse import Baikai.ThinkingLevel (ThinkingLevel (..), renderThinkingLevel) +import Baikai.Trace qualified as BaikaiTrace +import Baikai.Trace.Sink (TraceSink, silent) import Control.Exception (try) +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 System.Directory (getCurrentDirectory) data AgentProvider = AgentProviderClaudeCli @@ -36,35 +49,81 @@ | AgentProviderOpenAI deriving stock (Eq, Show) +-- | Where trace events for a model call should go. +-- +-- Baikai emits a small stream of 'Baikai.Trace.Event.TraceEvent' values per +-- call — one when the call starts, one when it finishes or fails — carrying +-- the provider, model, elapsed milliseconds, token counts, and dollar cost. +-- This closed vocabulary names the four destinations Seihou exposes, rather +-- than exposing Baikai's composable @TraceSink@ surface (a streamly fold), +-- which no config string could express. +data TraceSetting + = -- | Emit nothing. The default, and byte-for-byte the historical behavior. + TraceOff + | -- | Append one JSON object per line to the resolved trace file. + TraceFile + | -- | Print one human-readable line per event to stdout. + TraceStdout + | -- | Print one human-readable line per event to stderr. + TraceStderr + deriving stock (Eq, Show) + data AgentModelConfig = AgentModelConfig - { agentProvider :: AgentProvider, - agentModel :: Maybe Text, + { provider :: !AgentProvider, + model :: !(Maybe Text), -- | Reasoning effort. 'Nothing' leaves the provider/CLI default alone. - agentEffort :: Maybe ThinkingLevel + effort :: !(Maybe ThinkingLevel), + -- | Where call traces go. 'TraceOff' emits nothing. + trace :: !TraceSetting, + -- | The configured @agent.tracePath@, when set. 'Nothing' means the + -- built-in default path is used by the file sink. + tracePath :: !(Maybe FilePath) } - deriving stock (Eq, Show) + deriving stock (Eq, Generic, Show) +-- | Note the absence of 'Eq' and 'Show': 'TraceSink' wraps a streamly fold, +-- which is a function and so has neither. Tests compare the inspectable fields +-- individually. data AgentCompletionRequest = AgentCompletionRequest - { completionSystemPrompt :: Text, - completionInitialPrompt :: Maybe Text, - completionModelConfig :: AgentModelConfig + { systemPrompt :: !Text, + initialPrompt :: !(Maybe Text), + modelConfig :: !AgentModelConfig, + -- | Where this call's trace events go. Baikai's 'silent' sink when tracing + -- is off, which is the default and costs nothing. + traceSink :: !TraceSink } - deriving stock (Eq, Show) + deriving stock (Generic) +-- | Build a request that emits no trace events. buildAgentCompletionRequest :: AgentModelConfig -> Text -> Maybe Text -> AgentCompletionRequest -buildAgentCompletionRequest modelConfig systemPrompt initialPrompt = +buildAgentCompletionRequest = buildAgentCompletionRequestWith silent + +-- | Build a request whose model call reports to the given sink. Construct the +-- sink with 'Seihou.CLI.AgentTrace.traceSinkFor'; build it once per command +-- rather than per call, so a command that makes several calls appends them all +-- to the same destination. +buildAgentCompletionRequestWith :: + TraceSink -> + AgentModelConfig -> + Text -> + Maybe Text -> AgentCompletionRequest - { completionSystemPrompt = systemPrompt, - completionInitialPrompt = initialPrompt, - completionModelConfig = modelConfig +buildAgentCompletionRequestWith sink modelConfig systemPrompt initialPrompt = + AgentCompletionRequest + { systemPrompt = systemPrompt, + initialPrompt = initialPrompt, + modelConfig = modelConfig, + traceSink = sink } defaultAgentModelConfig :: AgentModelConfig defaultAgentModelConfig = AgentModelConfig - { agentProvider = AgentProviderClaudeCli, - agentModel = Nothing, - agentEffort = Nothing + { provider = AgentProviderClaudeCli, + model = Nothing, + effort = Nothing, + trace = TraceOff, + tracePath = Nothing } -- | Parse a reasoning-effort level name (case-insensitive) into a Baikai @@ -88,6 +147,27 @@ effortToText :: ThinkingLevel -> Text effortToText = renderThinkingLevel +-- | Parse a trace-destination name (case-insensitive) into a 'TraceSetting'. +traceFromText :: Text -> Either Text TraceSetting +traceFromText raw = + case Text.toLower (Text.strip raw) of + "off" -> Right TraceOff + "file" -> Right TraceFile + "stdout" -> Right TraceStdout + "stderr" -> Right TraceStderr + other -> + Left $ + "Unknown trace setting '" + <> other + <> "'. Expected one of: off, file, stdout, stderr." + +-- | Render a 'TraceSetting' to its canonical name. +traceToText :: TraceSetting -> Text +traceToText TraceOff = "off" +traceToText TraceFile = "file" +traceToText TraceStdout = "stdout" +traceToText TraceStderr = "stderr" + -- | The deterministic default model for a provider when the user has configured -- none. The two local CLI providers pin a specific model so a @seihou agent@ -- session never inherits whatever model the ambient @claude@ or @codex@ session @@ -122,33 +202,33 @@ buildBaikaiModel :: AgentModelConfig -> Baikai.Model buildBaikaiModel config = - case config.agentProvider of + case config ^. #provider of AgentProviderClaudeCli -> baseCliModel - { Baikai.modelId = maybe "" id config.agentModel, - Baikai.name = maybe "Claude CLI default" id config.agentModel, + { Baikai.modelId = maybe "" id (config ^. #model), + Baikai.name = maybe "Claude CLI default" id (config ^. #model), Baikai.api = Baikai.AnthropicMessagesCli, Baikai.provider = "anthropic" } AgentProviderCodexCli -> baseCliModel - { Baikai.modelId = maybe "" id config.agentModel, - Baikai.name = maybe "Codex CLI default" id config.agentModel, + { Baikai.modelId = maybe "" id (config ^. #model), + Baikai.name = maybe "Codex CLI default" id (config ^. #model), Baikai.api = Baikai.OpenAICompletionsCli, Baikai.provider = "openai" } AgentProviderAnthropic -> Baikai.emptyModel - { Baikai.modelId = maybe "claude-sonnet-4-6" id config.agentModel, - Baikai.name = maybe "Claude Sonnet 4.6" id config.agentModel, + { Baikai.modelId = maybe "claude-sonnet-4-6" id (config ^. #model), + Baikai.name = maybe "Claude Sonnet 4.6" id (config ^. #model), Baikai.api = Baikai.AnthropicMessages, Baikai.provider = "anthropic", Baikai.baseUrl = "https://api.anthropic.com" } AgentProviderOpenAI -> Baikai.emptyModel - { Baikai.modelId = maybe "gpt-4o-mini" id config.agentModel, - Baikai.name = maybe "GPT-4o Mini" id config.agentModel, + { Baikai.modelId = maybe "gpt-4o-mini" id (config ^. #model), + Baikai.name = maybe "GPT-4o Mini" id (config ^. #model), Baikai.api = Baikai.OpenAIChatCompletions, Baikai.provider = "openai", Baikai.baseUrl = "https://api.openai.com" @@ -161,28 +241,57 @@ } runAgentCompletion :: AgentCompletionRequest -> IO (Either Text Text) -runAgentCompletion req = do - registerAgentProviders +runAgentCompletion = runAgentCompletionWith registerAgentProviders + +-- | Run a completion while granting local CLI providers access to the current +-- workspace and mounted blueprint references. API providers ignore this local +-- access configuration. This is the non-interactive counterpart to the +-- interactive launcher used by normal @seihou agent run@ sessions. +runAgentCompletionWithCliAccess :: [FilePath] -> [String] -> AgentCompletionRequest -> IO (Either Text Text) +runAgentCompletionWithCliAccess extraDirs tools = + runAgentCompletionWith (registerAgentProvidersWithCliAccess extraDirs tools) + +-- | The shared implementation behind 'runAgentCompletion' and +-- 'runAgentCompletionWithCliAccess', parameterised by which providers to +-- register. Exported so tests can install a stub provider in place of a real +-- one; production callers should use one of the two wrappers. +runAgentCompletionWith :: IO () -> AgentCompletionRequest -> IO (Either Text Text) +runAgentCompletionWith registerProviders req = do + registerProviders initialMessages <- maybe (pure V.empty) (fmap V.singleton . Baikai.userNow) - req.completionInitialPrompt - let model = buildBaikaiModel req.completionModelConfig + (req ^. #initialPrompt) + let model = buildBaikaiModel (req ^. #modelConfig) ctx = Baikai.emptyContext - { Baikai.systemPrompt = Just req.completionSystemPrompt, + { Baikai.systemPrompt = Just (req ^. #systemPrompt), Baikai.messages = initialMessages } - options = Baikai.emptyOptions {BaikaiOptions.thinking = req.completionModelConfig.agentEffort} - result <- try (Baikai.completeRequest model ctx options) :: IO (Either Baikai.BaikaiError Baikai.Response) + options = Baikai.emptyOptions {BaikaiOptions.thinking = req ^. #modelConfig . #effort} + result <- + try (BaikaiTrace.withTrace (req ^. #traceSink) model ctx options) :: + IO (Either Baikai.BaikaiError Baikai.Response) pure $ case result of + -- Retained deliberately. 'withTrace' does not throw for provider failures, + -- but its doc comment states that downstream-of-the-fold exceptions still + -- propagate — an unwritable trace path, for instance. Left err -> Left (Text.pack (show err)) - Right resp -> - let body = responseText resp - in if Text.null (Text.strip body) - then Left "Provider returned no assistant text." - else Right body + Right resp -> case BaikaiResponse.responseError resp of + -- 'withTrace' surfaces a provider failure as an error-shaped Response + -- rather than an exception, and such a response has no assistant text. + -- Without this branch every provider error — a bad API key, a rate + -- limit, an unknown model — would fall through to the empty-text guard + -- below and be reported as "Provider returned no assistant text.", + -- losing the message the user needs. Formatting matches the exception + -- branch exactly, so the text a user sees is what it always was. + Just err -> Left (Text.pack (show err)) + Nothing -> + let body = responseText resp + in if Text.null (Text.strip body) + then Left "Provider returned no assistant text." + else Right body responseText :: Baikai.Response -> Text responseText = @@ -200,3 +309,34 @@ CodexCli.register ClaudeApi.register OpenAIApi.register + +registerAgentProvidersWithCliAccess :: [FilePath] -> [String] -> IO () +registerAgentProvidersWithCliAccess extraDirs tools = do + cwd <- getCurrentDirectory + Baikai.registerApiProvider $ + ClaudeCli.claudeCliProvider + ClaudeCli.defaultClaudeCliConfig + { ClaudeCli.workingDir = Just cwd, + ClaudeCli.extraArgs = claudeAccessArgs extraDirs tools + } + Baikai.registerApiProvider $ + CodexCli.codexCliProvider + CodexCli.defaultCodexCliConfig + { CodexCli.workingDir = Just cwd, + CodexCli.extraArgs = codexAccessArgs extraDirs + } + ClaudeApi.register + OpenAIApi.register + +claudeAccessArgs :: [FilePath] -> [String] -> [Text] +claudeAccessArgs extraDirs tools = + ( if null tools + then [] + else ["--allowedTools", Text.intercalate "," (map Text.pack tools)] + ) + <> concatMap (\dir -> ["--add-dir", Text.pack dir]) extraDirs + +codexAccessArgs :: [FilePath] -> [Text] +codexAccessArgs extraDirs = + ["--sandbox", "workspace-write"] + <> concatMap (\dir -> ["--add-dir", Text.pack dir]) extraDirs diff --git a/src/Seihou/CLI/AgentConfig.hs b/src/Seihou/CLI/AgentConfig.hs --- a/src/Seihou/CLI/AgentConfig.hs +++ b/src/Seihou/CLI/AgentConfig.hs @@ -2,6 +2,8 @@ ( -- * Inputs AgentConfigInputs (..), baseAgentConfigInputs, + AgentSettingFlags (..), + noAgentSettingFlags, -- * Command identity AgentCommandName (..), @@ -13,12 +15,16 @@ agentProviderConfigKey, agentModelConfigKey, agentEffortConfigKey, + agentTraceConfigKey, + agentTracePathConfigKey, agentCommandProviderConfigKey, agentCommandModelConfigKey, agentCommandEffortConfigKey, + agentCommandTraceConfigKey, agentProviderEnvVar, agentModelEnvVar, agentEffortEnvVar, + agentTraceEnvVar, -- * Provenance AgentConfigSource (..), @@ -29,9 +35,22 @@ -- * Resolution resolveAgentModelConfig, resolveAgentModelConfigFor, + resolveTracePath, loadAgentModelConfig, loadAgentModelConfigFor, + -- * Artifact-declared launch settings + AgentLaunchDeclaration (..), + noAgentLaunchDeclaration, + agentLaunchDeclaration, + validateAgentLaunchDeclaration, + PendingAgentConfig (..), + loadPendingAgentConfig, + resolvePendingAgentConfig, + resolvedAgentModelConfig, + formatResolvedAgentProvenance, + resolveDeclaredAgentConfig, + -- * Whole-configuration inspection ResolvedCommandConfig (..), loadResolvedAgentConfig, @@ -39,21 +58,32 @@ where import Baikai.ThinkingLevel (ThinkingLevel) +import Control.Applicative ((<|>)) +import Data.Generics.Labels () import Data.Map.Strict qualified as Map +import Data.Maybe (fromMaybe, isJust) import Data.Text qualified as T import Seihou.CLI.AgentCompletion ( AgentModelConfig (..), AgentProvider (..), + TraceSetting (..), defaultAgentModelConfig, defaultModelForProvider, effortFromText, + effortToText, providerFromText, + providerToText, + traceFromText, + traceToText, ) -import Seihou.CLI.Shared (formatConfigError) +import Seihou.CLI.Shared (formatConfigError, logIO) +import Seihou.Core.Types (AgentLaunch (..), LogLevel) import Seihou.Effect.ConfigReader (readGlobalConfig, readLocalConfig) import Seihou.Effect.ConfigReaderInterp (runConfigReader) +import Seihou.Effect.Logger (logError, logInfo) import Seihou.Prelude import System.Environment (lookupEnv) +import System.Exit (exitFailure) -- | All the raw material provider/model resolution draws on, in one record so -- the pure resolver can be unit-tested without touching the filesystem or the @@ -65,19 +95,32 @@ -- provenance label reported for a CLI-sourced value; they never change which -- value wins. data AgentConfigInputs = AgentConfigInputs - { cliProvider :: Maybe Text, - cliModel :: Maybe Text, - cliEffort :: Maybe Text, - cliProviderFromSubcommand :: Bool, - cliModelFromSubcommand :: Bool, - cliEffortFromSubcommand :: Bool, - envProvider :: Maybe Text, - envModel :: Maybe Text, - envEffort :: Maybe Text, - localConfig :: Map Text Text, - globalConfig :: Map Text Text + { cliProvider :: !(Maybe Text), + cliModel :: !(Maybe Text), + cliEffort :: !(Maybe Text), + cliTrace :: !(Maybe Text), + cliProviderFromSubcommand :: !Bool, + cliModelFromSubcommand :: !Bool, + cliEffortFromSubcommand :: !Bool, + cliTraceFromSubcommand :: !Bool, + envProvider :: !(Maybe Text), + envModel :: !(Maybe Text), + envEffort :: !(Maybe Text), + envTrace :: !(Maybe Text), + -- | Declared by the blueprint or prompt being run, when the command has + -- one. Only populated once the artifact has been loaded; see + -- 'resolvePendingAgentConfig'. + declaredProvider :: !(Maybe Text), + declaredModel :: !(Maybe Text), + declaredEffort :: !(Maybe Text), + -- | Reserved: no schema field feeds this yet. It exists so all four + -- settings are structurally identical, making a future @launch.trace@ an + -- insertion rather than a redesign. + declaredTrace :: !(Maybe Text), + localConfig :: !(Map Text Text), + globalConfig :: !(Map Text Text) } - deriving stock (Eq, Show) + deriving stock (Eq, Generic, Show) -- | An 'AgentConfigInputs' with nothing set: no flags, no environment, empty -- config maps. Handy as a base for tests and for callers that only populate a @@ -88,16 +131,70 @@ { cliProvider = Nothing, cliModel = Nothing, cliEffort = Nothing, + cliTrace = Nothing, cliProviderFromSubcommand = False, cliModelFromSubcommand = False, cliEffortFromSubcommand = False, + cliTraceFromSubcommand = False, envProvider = Nothing, envModel = Nothing, envEffort = Nothing, + envTrace = Nothing, + declaredProvider = Nothing, + declaredModel = Nothing, + declaredEffort = Nothing, + declaredTrace = Nothing, localConfig = Map.empty, globalConfig = Map.empty } +-- | The four agent settings as supplied on one command-line tier — either the +-- parent @seihou agent@ command or the subcommand itself. +-- +-- Grouping them keeps the loader signatures honest: four same-typed +-- @Maybe Text@ values in a row, twice over, are trivial to transpose by +-- accident, and the compiler would not notice. +data AgentSettingFlags = AgentSettingFlags + { provider :: !(Maybe Text), + model :: !(Maybe Text), + effort :: !(Maybe Text), + trace :: !(Maybe Text) + } + deriving stock (Eq, Generic, Show) + +-- | No flags supplied on this tier. +noAgentSettingFlags :: AgentSettingFlags +noAgentSettingFlags = + AgentSettingFlags + { provider = Nothing, + model = Nothing, + effort = Nothing, + trace = Nothing + } + +-- | Fold the parent and subcommand flag tiers into gathered inputs. The +-- subcommand's own flag wins over the parent @seihou agent@ flag; which tier +-- supplied the winner only affects the provenance label, never the value. +applyAgentSettingFlags :: AgentSettingFlags -> AgentSettingFlags -> AgentConfigInputs -> AgentConfigInputs +applyAgentSettingFlags parent command inputs = + inputs + & #cliProvider + .~ (command ^. #provider <|> parent ^. #provider) + & #cliModel + .~ (command ^. #model <|> parent ^. #model) + & #cliEffort + .~ (command ^. #effort <|> parent ^. #effort) + & #cliTrace + .~ (command ^. #trace <|> parent ^. #trace) + & #cliProviderFromSubcommand + .~ isJust (command ^. #provider) + & #cliModelFromSubcommand + .~ isJust (command ^. #model) + & #cliEffortFromSubcommand + .~ isJust (command ^. #effort) + & #cliTraceFromSubcommand + .~ isJust (command ^. #trace) + -- | The agent-driven commands whose provider/model can be configured -- independently. Each maps to a config-key segment (see 'agentCommandSegment'). data AgentCommandName @@ -141,6 +238,15 @@ agentEffortConfigKey :: Text agentEffortConfigKey = "agent.effort" +-- | The cross-command default trace-destination key, @agent.trace@. +agentTraceConfigKey :: Text +agentTraceConfigKey = "agent.trace" + +-- | The trace file path key, @agent.tracePath@. Free-form (any path) and +-- deliberately not per-command: one project writes one trace file. +agentTracePathConfigKey :: Text +agentTracePathConfigKey = "agent.tracePath" + -- | The per-command provider key, e.g. @agent.assist.provider@. agentCommandProviderConfigKey :: AgentCommandName -> Text agentCommandProviderConfigKey c = "agent." <> agentCommandSegment c <> ".provider" @@ -153,6 +259,10 @@ agentCommandEffortConfigKey :: AgentCommandName -> Text agentCommandEffortConfigKey c = "agent." <> agentCommandSegment c <> ".effort" +-- | The per-command trace-destination key, e.g. @agent.run.trace@. +agentCommandTraceConfigKey :: AgentCommandName -> Text +agentCommandTraceConfigKey c = "agent." <> agentCommandSegment c <> ".trace" + agentProviderEnvVar :: String agentProviderEnvVar = "SEIHOU_AGENT_PROVIDER" @@ -162,9 +272,12 @@ agentEffortEnvVar :: String agentEffortEnvVar = "SEIHOU_AGENT_EFFORT" +agentTraceEnvVar :: String +agentTraceEnvVar = "SEIHOU_AGENT_TRACE" + -- | Which of the resolvable fields a value belongs to. Used only to build -- provenance labels. -data AgentField = ProviderField | ModelField | EffortField +data AgentField = ProviderField | ModelField | EffortField | TraceField deriving stock (Eq, Show) -- | Where a resolved value came from, highest precedence first. @@ -175,6 +288,8 @@ SourceCliParent | -- | @SEIHOU_AGENT_PROVIDER@/@SEIHOU_AGENT_MODEL@. SourceEnv + | -- | The blueprint's or prompt's own @launch.@ declaration. + SourceArtifactDeclaration | -- | Local @agent..@. SourceLocalCommand | -- | Local @agent.@. @@ -189,10 +304,10 @@ -- | A resolved value paired with the source that supplied it. data ResolvedAgentField a = ResolvedAgentField - { resolvedValue :: a, - resolvedSource :: AgentConfigSource + { value :: !a, + source :: !AgentConfigSource } - deriving stock (Eq, Show) + deriving stock (Eq, Generic, Show) -- | A short human label describing where a value came from, suitable for -- bracketed display. For config-file sources it names the concrete key that @@ -203,36 +318,57 @@ SourceCliSubcommand -> "flag on subcommand" SourceCliParent -> "flag on `seihou agent`" SourceEnv -> "env: " <> T.pack (envVarName field) + SourceArtifactDeclaration -> artifactKind c <> ": launch." <> fieldName field SourceLocalCommand -> "local: " <> commandKey field c SourceLocalDefault -> "local: " <> defaultKey field SourceGlobalCommand -> "global: " <> commandKey field c SourceGlobalDefault -> "global: " <> defaultKey field SourceBuiltinDefault -> "built-in default" +-- | Which kind of artifact declares launch settings for a command, so the +-- provenance label names the thing the user actually ran. +artifactKind :: AgentCommandName -> Text +artifactKind AgentCmdPromptRun = "prompt" +artifactKind _ = "blueprint" + +fieldName :: AgentField -> Text +fieldName ProviderField = "provider" +fieldName ModelField = "model" +fieldName EffortField = "effort" +fieldName TraceField = "trace" + envVarName :: AgentField -> String envVarName ProviderField = agentProviderEnvVar envVarName ModelField = agentModelEnvVar envVarName EffortField = agentEffortEnvVar +envVarName TraceField = agentTraceEnvVar defaultKey :: AgentField -> Text defaultKey ProviderField = agentProviderConfigKey defaultKey ModelField = agentModelConfigKey defaultKey EffortField = agentEffortConfigKey +defaultKey TraceField = agentTraceConfigKey commandKey :: AgentField -> AgentCommandName -> Text commandKey ProviderField = agentCommandProviderConfigKey commandKey ModelField = agentCommandModelConfigKey commandKey EffortField = agentCommandEffortConfigKey +commandKey TraceField = agentCommandTraceConfigKey -- | The full result of resolving one command's provider and model, with -- provenance, used by the @seihou agent config@ inspection command. data ResolvedCommandConfig = ResolvedCommandConfig - { rccCommand :: AgentCommandName, - rccProvider :: ResolvedAgentField AgentProvider, - rccModel :: ResolvedAgentField (Maybe Text), - rccEffort :: ResolvedAgentField (Maybe ThinkingLevel) + { command :: !AgentCommandName, + provider :: !(ResolvedAgentField AgentProvider), + model :: !(ResolvedAgentField (Maybe Text)), + effort :: !(ResolvedAgentField (Maybe ThinkingLevel)), + trace :: !(ResolvedAgentField TraceSetting), + -- | The configured @agent.tracePath@, if any. Carried without provenance: + -- it is free-form, has no CLI flag and no per-command variant, so there is + -- no precedence story worth displaying. + tracePath :: !(Maybe FilePath) } - deriving stock (Eq, Show) + deriving stock (Eq, Generic, Show) -- | Flat resolver, preserved for backward compatibility. It never consults the -- per-command config keys, so a caller with only @agent.provider@/@agent.model@ @@ -241,24 +377,26 @@ resolveAgentModelConfig inputs = do provider <- resolveProvider - [ candidate inputs.cliProvider SourceCliSubcommand, - candidate inputs.envProvider SourceEnv, - candidate (Map.lookup agentProviderConfigKey inputs.localConfig) SourceLocalDefault, - candidate (Map.lookup agentProviderConfigKey inputs.globalConfig) SourceGlobalDefault + [ candidate (inputs ^. #cliProvider) SourceCliSubcommand, + candidate (inputs ^. #envProvider) SourceEnv, + candidate (Map.lookup agentProviderConfigKey (inputs ^. #localConfig)) SourceLocalDefault, + candidate (Map.lookup agentProviderConfigKey (inputs ^. #globalConfig)) SourceGlobalDefault ] let modelField = - applyProviderDefaultModel provider.resolvedValue $ + applyProviderDefaultModel (provider ^. #value) $ resolveModel - [ candidate inputs.cliModel SourceCliSubcommand, - candidate inputs.envModel SourceEnv, - candidate (Map.lookup agentModelConfigKey inputs.localConfig) SourceLocalDefault, - candidate (Map.lookup agentModelConfigKey inputs.globalConfig) SourceGlobalDefault + [ candidate (inputs ^. #cliModel) SourceCliSubcommand, + candidate (inputs ^. #envModel) SourceEnv, + candidate (Map.lookup agentModelConfigKey (inputs ^. #localConfig)) SourceLocalDefault, + candidate (Map.lookup agentModelConfigKey (inputs ^. #globalConfig)) SourceGlobalDefault ] pure AgentModelConfig - { agentProvider = provider.resolvedValue, - agentModel = modelField.resolvedValue, - agentEffort = Nothing + { provider = provider ^. #value, + model = modelField ^. #value, + effort = Nothing, + trace = TraceOff, + tracePath = Nothing } -- | Resolve the provider, model, and reasoning effort for a specific command, @@ -266,8 +404,14 @@ -- reporting the source of each value. -- -- Precedence, highest first: subcommand flag, parent @agent@ flag, environment --- variable, local @agent..@, local @agent.@, global +-- variable, the artifact's own @launch.@ declaration, local +-- @agent..@, local @agent.@, global -- @agent..@, global @agent.@, built-in default. +-- +-- The declaration tier is only populated for commands that load an artifact +-- first; see 'resolvePendingAgentConfig'. For every other caller the +-- @declared*@ inputs are 'Nothing' and this behaves exactly as it did before +-- the tier existed. resolveAgentModelConfigFor :: AgentCommandName -> AgentConfigInputs -> @@ -275,58 +419,86 @@ Text ( ResolvedAgentField AgentProvider, ResolvedAgentField (Maybe Text), - ResolvedAgentField (Maybe ThinkingLevel) + ResolvedAgentField (Maybe ThinkingLevel), + ResolvedAgentField TraceSetting ) resolveAgentModelConfigFor c inputs = do provider <- - (\p -> ResolvedAgentField p.resolvedValue p.resolvedSource) + (\p -> ResolvedAgentField (p ^. #value) (p ^. #source)) <$> resolveProvider (providerCandidates c inputs) - let model = applyProviderDefaultModel provider.resolvedValue (resolveModel (modelCandidates c inputs)) + let model = applyProviderDefaultModel (provider ^. #value) (resolveModel (modelCandidates c inputs)) effort <- resolveEffort (effortCandidates c inputs) - pure (provider, model, effort) + trace <- resolveTrace (traceCandidates c inputs) + pure (provider, model, effort, trace) +-- | Resolve the trace file path: local @agent.tracePath@ beats global, and a +-- blank value counts as absent. There is no CLI flag and no per-command +-- variant — 'agentTracePathConfigKey' is free-form, so it stays outside the +-- validated four-value 'TraceSetting' vocabulary. +resolveTracePath :: AgentConfigInputs -> Maybe FilePath +resolveTracePath inputs = + T.unpack . fst + <$> firstNonBlankWithSource + [ candidate (Map.lookup agentTracePathConfigKey (inputs ^. #localConfig)) SourceLocalDefault, + candidate (Map.lookup agentTracePathConfigKey (inputs ^. #globalConfig)) SourceGlobalDefault + ] + -- | When no model was configured (source is the built-in default), substitute -- the provider's deterministic default so the two local CLI providers always -- resolve to a concrete model instead of 'Nothing'. The source stays -- 'SourceBuiltinDefault' — the value is a built-in, just a non-empty one. applyProviderDefaultModel :: AgentProvider -> ResolvedAgentField (Maybe Text) -> ResolvedAgentField (Maybe Text) applyProviderDefaultModel prov field = - case field.resolvedValue of + case field ^. #value of Just _ -> field Nothing -> case defaultModelForProvider prov of - Just m -> field {resolvedValue = Just m} + Just m -> (field & #value ?~ m) Nothing -> field providerCandidates :: AgentCommandName -> AgentConfigInputs -> [(Maybe Text, AgentConfigSource)] providerCandidates c inputs = - [ candidate inputs.cliProvider (cliSource inputs.cliProviderFromSubcommand), - candidate inputs.envProvider SourceEnv, - candidate (Map.lookup (agentCommandProviderConfigKey c) inputs.localConfig) SourceLocalCommand, - candidate (Map.lookup agentProviderConfigKey inputs.localConfig) SourceLocalDefault, - candidate (Map.lookup (agentCommandProviderConfigKey c) inputs.globalConfig) SourceGlobalCommand, - candidate (Map.lookup agentProviderConfigKey inputs.globalConfig) SourceGlobalDefault + [ candidate (inputs ^. #cliProvider) (cliSource (inputs ^. #cliProviderFromSubcommand)), + candidate (inputs ^. #envProvider) SourceEnv, + candidate (inputs ^. #declaredProvider) SourceArtifactDeclaration, + candidate (Map.lookup (agentCommandProviderConfigKey c) (inputs ^. #localConfig)) SourceLocalCommand, + candidate (Map.lookup agentProviderConfigKey (inputs ^. #localConfig)) SourceLocalDefault, + candidate (Map.lookup (agentCommandProviderConfigKey c) (inputs ^. #globalConfig)) SourceGlobalCommand, + candidate (Map.lookup agentProviderConfigKey (inputs ^. #globalConfig)) SourceGlobalDefault ] modelCandidates :: AgentCommandName -> AgentConfigInputs -> [(Maybe Text, AgentConfigSource)] modelCandidates c inputs = - [ candidate inputs.cliModel (cliSource inputs.cliModelFromSubcommand), - candidate inputs.envModel SourceEnv, - candidate (Map.lookup (agentCommandModelConfigKey c) inputs.localConfig) SourceLocalCommand, - candidate (Map.lookup agentModelConfigKey inputs.localConfig) SourceLocalDefault, - candidate (Map.lookup (agentCommandModelConfigKey c) inputs.globalConfig) SourceGlobalCommand, - candidate (Map.lookup agentModelConfigKey inputs.globalConfig) SourceGlobalDefault + [ candidate (inputs ^. #cliModel) (cliSource (inputs ^. #cliModelFromSubcommand)), + candidate (inputs ^. #envModel) SourceEnv, + candidate (inputs ^. #declaredModel) SourceArtifactDeclaration, + candidate (Map.lookup (agentCommandModelConfigKey c) (inputs ^. #localConfig)) SourceLocalCommand, + candidate (Map.lookup agentModelConfigKey (inputs ^. #localConfig)) SourceLocalDefault, + candidate (Map.lookup (agentCommandModelConfigKey c) (inputs ^. #globalConfig)) SourceGlobalCommand, + candidate (Map.lookup agentModelConfigKey (inputs ^. #globalConfig)) SourceGlobalDefault ] effortCandidates :: AgentCommandName -> AgentConfigInputs -> [(Maybe Text, AgentConfigSource)] effortCandidates c inputs = - [ candidate inputs.cliEffort (cliSource inputs.cliEffortFromSubcommand), - candidate inputs.envEffort SourceEnv, - candidate (Map.lookup (agentCommandEffortConfigKey c) inputs.localConfig) SourceLocalCommand, - candidate (Map.lookup agentEffortConfigKey inputs.localConfig) SourceLocalDefault, - candidate (Map.lookup (agentCommandEffortConfigKey c) inputs.globalConfig) SourceGlobalCommand, - candidate (Map.lookup agentEffortConfigKey inputs.globalConfig) SourceGlobalDefault + [ candidate (inputs ^. #cliEffort) (cliSource (inputs ^. #cliEffortFromSubcommand)), + candidate (inputs ^. #envEffort) SourceEnv, + candidate (inputs ^. #declaredEffort) SourceArtifactDeclaration, + candidate (Map.lookup (agentCommandEffortConfigKey c) (inputs ^. #localConfig)) SourceLocalCommand, + candidate (Map.lookup agentEffortConfigKey (inputs ^. #localConfig)) SourceLocalDefault, + candidate (Map.lookup (agentCommandEffortConfigKey c) (inputs ^. #globalConfig)) SourceGlobalCommand, + candidate (Map.lookup agentEffortConfigKey (inputs ^. #globalConfig)) SourceGlobalDefault ] +traceCandidates :: AgentCommandName -> AgentConfigInputs -> [(Maybe Text, AgentConfigSource)] +traceCandidates c inputs = + [ candidate (inputs ^. #cliTrace) (cliSource (inputs ^. #cliTraceFromSubcommand)), + candidate (inputs ^. #envTrace) SourceEnv, + candidate (inputs ^. #declaredTrace) SourceArtifactDeclaration, + candidate (Map.lookup (agentCommandTraceConfigKey c) (inputs ^. #localConfig)) SourceLocalCommand, + candidate (Map.lookup agentTraceConfigKey (inputs ^. #localConfig)) SourceLocalDefault, + candidate (Map.lookup (agentCommandTraceConfigKey c) (inputs ^. #globalConfig)) SourceGlobalCommand, + candidate (Map.lookup agentTraceConfigKey (inputs ^. #globalConfig)) SourceGlobalDefault + ] + cliSource :: Bool -> AgentConfigSource cliSource True = SourceCliSubcommand cliSource False = SourceCliParent @@ -337,7 +509,7 @@ resolveProvider candidates = case firstNonBlankWithSource candidates of Just (txt, src) -> (\p -> ResolvedAgentField p src) <$> providerFromText txt - Nothing -> Right (ResolvedAgentField defaultAgentModelConfig.agentProvider SourceBuiltinDefault) + Nothing -> Right (ResolvedAgentField (defaultAgentModelConfig ^. #provider) SourceBuiltinDefault) -- | Resolve a model from an ordered candidate list. An unset model resolves to -- 'Nothing' with source 'SourceBuiltinDefault', letting the provider pick. @@ -357,6 +529,16 @@ Just (txt, src) -> (\lvl -> ResolvedAgentField (Just lvl) src) <$> effortFromText txt Nothing -> Right (ResolvedAgentField Nothing SourceBuiltinDefault) +-- | Resolve a trace destination from an ordered candidate list. Unlike the +-- model and effort resolvers there is no \"unset\" state: an unconfigured trace +-- resolves to 'TraceOff' with source 'SourceBuiltinDefault', which emits +-- nothing. +resolveTrace :: [(Maybe Text, AgentConfigSource)] -> Either Text (ResolvedAgentField TraceSetting) +resolveTrace candidates = + case firstNonBlankWithSource candidates of + Just (txt, src) -> (\t -> ResolvedAgentField t src) <$> traceFromText txt + Nothing -> Right (ResolvedAgentField TraceOff SourceBuiltinDefault) + candidate :: Maybe Text -> AgentConfigSource -> (Maybe Text, AgentConfigSource) candidate value src = (value, src) @@ -376,7 +558,15 @@ -- the flat resolver. Preserved for backward compatibility. loadAgentModelConfig :: Maybe Text -> Maybe Text -> IO (Either Text AgentModelConfig) loadAgentModelConfig cliProvider cliModel = do - inputsOrErr <- gatherAgentConfigInputs cliProvider cliModel Nothing False False False + inputsOrErr <- + gatherAgentConfigInputs + noAgentSettingFlags + ( noAgentSettingFlags + & #provider + .~ cliProvider + & #model + .~ cliModel + ) pure (inputsOrErr >>= resolveAgentModelConfig) -- | Read the environment and config, then resolve provider/model/effort for a @@ -384,64 +574,59 @@ -- need. loadAgentModelConfigFor :: AgentCommandName -> - -- | winning provider flag (subcommand @<|>@ parent) - Maybe Text -> - -- | winning model flag - Maybe Text -> - -- | winning effort flag - Maybe Text -> - -- | provider flag came from the subcommand? - Bool -> - -- | model flag came from the subcommand? - Bool -> - -- | effort flag came from the subcommand? - Bool -> + -- | flags on the parent @seihou agent@ command + AgentSettingFlags -> + -- | flags on the subcommand itself + AgentSettingFlags -> IO (Either Text AgentModelConfig) -loadAgentModelConfigFor c cliProvider cliModel cliEffort providerFromSub modelFromSub effortFromSub = do - inputsOrErr <- gatherAgentConfigInputs cliProvider cliModel cliEffort providerFromSub modelFromSub effortFromSub +loadAgentModelConfigFor c parentFlags commandFlags = do + inputsOrErr <- gatherAgentConfigInputs parentFlags commandFlags pure $ do inputs <- inputsOrErr - (provider, model, effort) <- resolveAgentModelConfigFor c inputs + (provider, model, effort, trace) <- resolveAgentModelConfigFor c inputs pure AgentModelConfig - { agentProvider = provider.resolvedValue, - agentModel = model.resolvedValue, - agentEffort = effort.resolvedValue + { provider = provider ^. #value, + model = model ^. #value, + effort = effort ^. #value, + trace = trace ^. #value, + tracePath = resolveTracePath inputs } -- | Resolve every configurable command from the real environment and config, -- with no CLI flags, for the @seihou agent config@ inspection view. loadResolvedAgentConfig :: IO (Either Text [ResolvedCommandConfig]) loadResolvedAgentConfig = do - inputsOrErr <- gatherAgentConfigInputs Nothing Nothing Nothing False False False + inputsOrErr <- gatherAgentConfigInputs noAgentSettingFlags noAgentSettingFlags pure $ do inputs <- inputsOrErr traverse (resolveOne inputs) allAgentCommands where resolveOne inputs c = do - (provider, model, effort) <- resolveAgentModelConfigFor c inputs + (provider, model, effort, trace) <- resolveAgentModelConfigFor c inputs pure ResolvedCommandConfig - { rccCommand = c, - rccProvider = provider, - rccModel = model, - rccEffort = effort + { command = c, + provider = provider, + model = model, + effort = effort, + trace = trace, + tracePath = resolveTracePath inputs } -- | Shared IO: read @SEIHOU_AGENT_*@ and the local + global config maps into an -- 'AgentConfigInputs'. Any config read error surfaces as 'Left'. gatherAgentConfigInputs :: - Maybe Text -> - Maybe Text -> - Maybe Text -> - Bool -> - Bool -> - Bool -> + -- | flags on the parent @seihou agent@ command + AgentSettingFlags -> + -- | flags on the subcommand itself + AgentSettingFlags -> IO (Either Text AgentConfigInputs) -gatherAgentConfigInputs cliProvider cliModel cliEffort providerFromSub modelFromSub effortFromSub = do +gatherAgentConfigInputs parentFlags commandFlags = do envProvider <- fmap T.pack <$> lookupEnv agentProviderEnvVar envModel <- fmap T.pack <$> lookupEnv agentModelEnvVar envEffort <- fmap T.pack <$> lookupEnv agentEffortEnvVar + envTrace <- fmap T.pack <$> lookupEnv agentTraceEnvVar (localResult, globalResult) <- runEff $ runConfigReader $ do local <- readLocalConfig global <- readGlobalConfig @@ -449,17 +634,176 @@ pure $ do local <- first formatConfigError localResult global <- first formatConfigError globalResult - pure - AgentConfigInputs - { cliProvider = cliProvider, - cliModel = cliModel, - cliEffort = cliEffort, - cliProviderFromSubcommand = providerFromSub, - cliModelFromSubcommand = modelFromSub, - cliEffortFromSubcommand = effortFromSub, - envProvider = envProvider, - envModel = envModel, - envEffort = envEffort, - localConfig = local, - globalConfig = global - } + pure $ + applyAgentSettingFlags + parentFlags + commandFlags + ( baseAgentConfigInputs + & #envProvider + .~ envProvider + & #envModel + .~ envModel + & #envEffort + .~ envEffort + & #envTrace + .~ envTrace + & #localConfig + .~ local + & #globalConfig + .~ global + ) + +-- | The three launch fields the resolver understands, projected out of an +-- artifact's @launch@ record. @mode@ is deliberately absent: it is reserved +-- and no part of the resolution path. +data AgentLaunchDeclaration = AgentLaunchDeclaration + { provider :: !(Maybe Text), + model :: !(Maybe Text), + effort :: !(Maybe Text) + } + deriving stock (Eq, Generic, Show) + +-- | A declaration that states nothing, leaving every field to the user's +-- flags, environment, and config. +noAgentLaunchDeclaration :: AgentLaunchDeclaration +noAgentLaunchDeclaration = + AgentLaunchDeclaration + { provider = Nothing, + model = Nothing, + effort = Nothing + } + +-- | Project a decoded artifact's launch record into the resolver's declaration +-- tier. An artifact with no @launch@ record declares nothing. +agentLaunchDeclaration :: Maybe AgentLaunch -> AgentLaunchDeclaration +agentLaunchDeclaration Nothing = noAgentLaunchDeclaration +agentLaunchDeclaration (Just l) = + AgentLaunchDeclaration + { provider = l ^. #provider, + model = l ^. #model, + effort = l ^. #effort + } + +-- | Parse-check a declared launch record, returning one message per invalid +-- value. An empty list means the declaration is usable. +-- +-- The model is not checked: it is free-form by design, since providers accept +-- aliases and custom model IDs. +validateAgentLaunchDeclaration :: AgentLaunchDeclaration -> [Text] +validateAgentLaunchDeclaration decl = + check "launch.provider" providerFromText (decl ^. #provider) + <> check "launch.effort" effortFromText (decl ^. #effort) + where + check :: Text -> (Text -> Either Text a) -> Maybe Text -> [Text] + check key parse value = + [ key <> ": " <> err + | Just raw <- [value], + not (T.null (T.strip raw)), + Left err <- [parse (T.strip raw)] + ] + +-- | Everything needed to finish resolution later: the command identity plus +-- the flags, environment, and config already gathered. A handler holds one of +-- these while it discovers and decodes its artifact, then finishes with +-- 'resolvePendingAgentConfig'. +-- +-- This two-phase shape exists because the artifact's declaration is only known +-- after the handler loads it, but resolution must still be a single pass over +-- one ordered precedence list. +data PendingAgentConfig = PendingAgentConfig + { command :: !AgentCommandName, + inputs :: !AgentConfigInputs + } + deriving stock (Eq, Generic, Show) + +-- | Read the environment and config for a command whose artifact may declare +-- its own launch settings, stopping short of resolution. +loadPendingAgentConfig :: + AgentCommandName -> + -- | flags on the parent @seihou agent@ command + AgentSettingFlags -> + -- | flags on the subcommand itself + AgentSettingFlags -> + IO (Either Text PendingAgentConfig) +loadPendingAgentConfig c parentFlags commandFlags = do + inputsOrErr <- gatherAgentConfigInputs parentFlags commandFlags + pure (PendingAgentConfig c <$> inputsOrErr) + +-- | Finish resolution by folding the artifact's declaration into the gathered +-- inputs and running the ordinary precedence chain. +resolvePendingAgentConfig :: + PendingAgentConfig -> + AgentLaunchDeclaration -> + Either Text ResolvedCommandConfig +resolvePendingAgentConfig pending decl = do + let inputs = + ( (pending ^. #inputs) + & #declaredProvider + .~ decl + ^. #provider + & #declaredModel + .~ decl + ^. #model + & #declaredEffort + .~ decl + ^. #effort + ) + (provider, model, effort, trace) <- resolveAgentModelConfigFor (pending ^. #command) inputs + pure + ResolvedCommandConfig + { command = pending ^. #command, + provider = provider, + model = model, + effort = effort, + trace = trace, + tracePath = resolveTracePath inputs + } + +-- | Project a resolved command config down to what the launch layer needs, +-- discarding provenance. +resolvedAgentModelConfig :: ResolvedCommandConfig -> AgentModelConfig +resolvedAgentModelConfig rcc = + AgentModelConfig + { provider = rcc ^. #provider . #value, + model = rcc ^. #model . #value, + effort = rcc ^. #effort . #value, + trace = rcc ^. #trace . #value, + tracePath = rcc ^. #tracePath + } + +-- | A one-line provenance summary for a verbose log line, e.g. +-- +-- > provider claude-cli [built-in default], model claude-sonnet-5 [blueprint: launch.model], effort max [blueprint: launch.effort] +formatResolvedAgentProvenance :: ResolvedCommandConfig -> Text +formatResolvedAgentProvenance rcc = + T.intercalate + ", " + [ part "provider" (providerToText (rcc ^. #provider . #value)) ProviderField (rcc ^. #provider . #source), + part "model" (fromMaybe "" (rcc ^. #model . #value)) ModelField (rcc ^. #model . #source), + part "effort" (maybe "" effortToText (rcc ^. #effort . #value)) EffortField (rcc ^. #effort . #source), + part "trace" (traceToText (rcc ^. #trace . #value)) TraceField (rcc ^. #trace . #source) + ] + where + part label value field src = + label <> " " <> value <> " [" <> agentConfigSourceLabel (rcc ^. #command) field src <> "]" + +-- | Finish resolution with the artifact's declaration, logging the resolved +-- provenance at verbose level and exiting with an actionable message when the +-- artifact declares an unusable value. +-- +-- The label names the artifact in the error message, e.g. +-- @"blueprint 'payments-service'"@. +resolveDeclaredAgentConfig :: + LogLevel -> + Text -> + PendingAgentConfig -> + AgentLaunchDeclaration -> + IO AgentModelConfig +resolveDeclaredAgentConfig level label pending decl = + case resolvePendingAgentConfig pending decl of + Left err -> do + logIO level (logError $ "Invalid agent settings for " <> label <> ": " <> err) + exitFailure + Right resolved -> do + logIO level (logInfo $ "Agent: " <> formatResolvedAgentProvenance resolved) + pure (resolvedAgentModelConfig resolved) diff --git a/src/Seihou/CLI/AgentConfigShow.hs b/src/Seihou/CLI/AgentConfigShow.hs --- a/src/Seihou/CLI/AgentConfigShow.hs +++ b/src/Seihou/CLI/AgentConfigShow.hs @@ -4,9 +4,10 @@ ) where +import Data.Generics.Labels () import Data.Text qualified as T import Data.Text.IO qualified as TIO -import Seihou.CLI.AgentCompletion (effortToText, providerToText) +import Seihou.CLI.AgentCompletion (effortToText, providerToText, traceToText) import Seihou.CLI.AgentConfig ( AgentField (..), ResolvedAgentField (..), @@ -19,9 +20,9 @@ import System.Exit (exitFailure) -- | @seihou agent config@: read the real environment and config, resolve the --- provider, model, and reasoning effort for every agent command, and print a --- table labelling the source that supplied each value, followed by the --- precedence legend. +-- provider, model, reasoning effort, and trace destination for every agent +-- command, and print a table labelling the source that supplied each value, +-- followed by the precedence legend. handleAgentConfigShow :: IO () handleAgentConfigShow = do result <- loadResolvedAgentConfig @@ -36,44 +37,51 @@ formatResolvedAgentConfig :: [ResolvedCommandConfig] -> Text formatResolvedAgentConfig resolved = T.unlines $ - [ "Resolved agent provider, model, and effort per command", + [ "Resolved agent provider, model, effort, and trace per command", "(highest-precedence source wins; see precedence list below)", "" ] <> concatMap renderCommand resolved <> ["", precedenceLegend] where - labelWidth = maximum (0 : map (\rcc -> T.length (agentCommandLabel rcc.rccCommand)) resolved) + labelWidth = maximum (0 : map (\rcc -> T.length (agentCommandLabel (rcc ^. #command))) resolved) valueWidth = maximum (0 : concatMap commandValueWidths resolved) commandValueWidths rcc = [ T.length (providerValue rcc), T.length (modelValue rcc), - T.length (effortValue rcc) + T.length (effortValue rcc), + T.length (traceValue rcc) ] - providerValue rcc = providerToText rcc.rccProvider.resolvedValue - modelValue rcc = maybe "(default)" id rcc.rccModel.resolvedValue - effortValue rcc = maybe "(default)" effortToText rcc.rccEffort.resolvedValue + providerValue rcc = providerToText (rcc ^. #provider . #value) + modelValue rcc = maybe "(default)" id (rcc ^. #model . #value) + effortValue rcc = maybe "(default)" effortToText (rcc ^. #effort . #value) + traceValue rcc = traceToText (rcc ^. #trace . #value) renderCommand rcc = - let cmd = rcc.rccCommand + let cmd = (rcc ^. #command) label = agentCommandLabel cmd in [ row (padRight labelWidth label) "provider" (providerValue rcc) - (agentConfigSourceLabel cmd ProviderField rcc.rccProvider.resolvedSource), + (agentConfigSourceLabel cmd ProviderField (rcc ^. #provider . #source)), row (padRight labelWidth "") "model " (modelValue rcc) - (agentConfigSourceLabel cmd ModelField rcc.rccModel.resolvedSource), + (agentConfigSourceLabel cmd ModelField (rcc ^. #model . #source)), row (padRight labelWidth "") "effort " (effortValue rcc) - (agentConfigSourceLabel cmd EffortField rcc.rccEffort.resolvedSource) + (agentConfigSourceLabel cmd EffortField (rcc ^. #effort . #source)), + row + (padRight labelWidth "") + "trace " + (traceValue rcc) + (agentConfigSourceLabel cmd TraceField (rcc ^. #trace . #source)) ] row label field value sourceLabel = @@ -95,14 +103,25 @@ T.intercalate "\n" [ "Precedence, highest first:", - " 1. --provider / --model / --effort flag on the subcommand", - " 2. --provider / --model / --effort flag on `seihou agent`", - " 3. SEIHOU_AGENT_PROVIDER / SEIHOU_AGENT_MODEL / SEIHOU_AGENT_EFFORT environment variables", - " 4. local .seihou/config.dhall agent..{provider,model,effort}", - " 5. local .seihou/config.dhall agent.{provider,model,effort}", - " 6. global ~/.config/seihou/config.dhall agent..{provider,model,effort}", - " 7. global ~/.config/seihou/config.dhall agent.{provider,model,effort}", - " 8. built-in default: provider claude-cli; model pinned per provider", + " 1. --provider / --model / --effort / --trace flag on the subcommand", + " 2. --provider / --model / --effort / --trace flag on `seihou agent`", + " 3. SEIHOU_AGENT_PROVIDER / SEIHOU_AGENT_MODEL / SEIHOU_AGENT_EFFORT /", + " SEIHOU_AGENT_TRACE environment variables", + " 4. blueprint.dhall / prompt.dhall launch.{provider,model,effort}", + " 5. local .seihou/config.dhall agent..{provider,model,effort,trace}", + " 6. local .seihou/config.dhall agent.{provider,model,effort,trace}", + " 7. global ~/.config/seihou/config.dhall agent..{provider,model,effort,trace}", + " 8. global ~/.config/seihou/config.dhall agent.{provider,model,effort,trace}", + " 9. built-in default: provider claude-cli; model pinned per provider", " (claude-cli -> claude-opus-4-8, codex-cli -> gpt-5.6-terra); effort unset", - " (the CLI/provider chooses its own reasoning effort)" + " (the CLI/provider chooses its own reasoning effort); trace off", + "", + "Tier 4 is per-artifact: it depends on which blueprint or prompt you run, so", + "the table above cannot show it. Run with --verbose to see the resolved", + "settings and their sources for a specific run. `trace` has no tier-4", + "declaration: no blueprint or prompt schema field feeds it.", + "", + "The trace file path is set with agent.tracePath (local, then global). It is", + "free-form and has no flag, environment variable, or per-command variant;", + "unset means .seihou/trace.jsonl." ] diff --git a/src/Seihou/CLI/AgentLaunch.hs b/src/Seihou/CLI/AgentLaunch.hs --- a/src/Seihou/CLI/AgentLaunch.hs +++ b/src/Seihou/CLI/AgentLaunch.hs @@ -19,6 +19,7 @@ ) where +import Data.Generics.Labels () import Data.List (nub) import Data.Maybe (fromMaybe) import Data.Text qualified as T @@ -29,14 +30,15 @@ -- | Dynamic context gathered from the current directory, shared across agent commands. data AgentContext = AgentContext - { cwd :: Text, - seihouInitialized :: Bool, - hasManifest :: Bool, - localModuleDhall :: Bool, - localModules :: [Text], + { cwd :: !Text, + seihouInitialized :: !Bool, + hasManifest :: !Bool, + localModuleDhall :: !Bool, + localModules :: ![Text], -- | (name, description, source) - availableModules :: [(Text, Text, Text)] + availableModules :: ![(Text, Text, Text)] } + deriving stock (Generic) gatherAgentContext :: IO AgentContext gatherAgentContext = do @@ -140,31 +142,31 @@ formatSeihouProjectState :: AgentContext -> Text formatSeihouProjectState ctx - | ctx.seihouInitialized = "Seihou project: .seihou/ directory exists (this is a seihou-managed project)" + | (ctx ^. #seihouInitialized) = "Seihou project: .seihou/ directory exists (this is a seihou-managed project)" | otherwise = "Seihou project: No .seihou/ directory (not yet a seihou project in this directory)" formatManifestState :: AgentContext -> Text formatManifestState ctx - | ctx.hasManifest = "Manifest: .seihou/manifest.json exists (modules have been applied here)" + | (ctx ^. #hasManifest) = "Manifest: .seihou/manifest.json exists (modules have been applied here)" | otherwise = "Manifest: No manifest (no modules applied yet)" formatModuleDhallState :: AgentContext -> Text formatModuleDhallState ctx - | ctx.localModuleDhall = "Module in cwd: module.dhall found in current directory (user is authoring a module here)" + | (ctx ^. #localModuleDhall) = "Module in cwd: module.dhall found in current directory (user is authoring a module here)" | otherwise = "" formatLocalModules :: AgentContext -> Text formatLocalModules ctx - | null ctx.localModules = "" - | otherwise = T.intercalate "\n" $ "Local modules:" : map (" - " <>) ctx.localModules + | null (ctx ^. #localModules) = "" + | otherwise = T.intercalate "\n" $ "Local modules:" : map (" - " <>) (ctx ^. #localModules) formatAvailableModules :: AgentContext -> Text formatAvailableModules ctx - | null ctx.availableModules = "Available modules: None discovered" + | null (ctx ^. #availableModules) = "Available modules: None discovered" | otherwise = T.intercalate "\n" $ "Available modules across search paths:" - : map formatMod ctx.availableModules + : map formatMod (ctx ^. #availableModules) where formatMod (name, desc, src) = " - " <> name <> " — " <> desc <> " (" <> src <> ")" @@ -179,11 +181,11 @@ else pure [] toModuleInfo :: DiscoveredModule -> [(Text, Text, Text)] -toModuleInfo dm = case dm.discoveredResult of +toModuleInfo dm = case dm ^. #result of Right m -> - [ ( m.name.unModuleName, - maybe "(no description)" id m.description, - sourceLabel dm.discoveredSource + [ ( m ^. #name . #unModuleName, + maybe "(no description)" id (m ^. #description), + sourceLabel (dm ^. #source) ) ] Left _ -> [] @@ -211,9 +213,9 @@ formatBlueprintIdentity bp = T.intercalate "\n" - [ "Name: " <> bp.name.unModuleName, - "Version: " <> fromMaybe "(unspecified)" bp.version, - "Description: " <> fromMaybe "(no description)" bp.description + [ "Name: " <> bp ^. #name . #unModuleName, + "Version: " <> fromMaybe "(unspecified)" (bp ^. #version), + "Description: " <> fromMaybe "(no description)" (bp ^. #description) ] -- | Render the "## Baseline" body for the agent prompt. @@ -225,8 +227,8 @@ formatBaselineStatus (BaselineApplied entries) = T.intercalate "\n" (map render entries) where - render (n, Just v) = " - " <> n.unModuleName <> " (v" <> v <> ")" - render (n, Nothing) = " - " <> n.unModuleName <> " (unversioned)" + render (n, Just v) = " - " <> n ^. #unModuleName <> " (v" <> v <> ")" + render (n, Nothing) = " - " <> n ^. #unModuleName <> " (unversioned)" -- | Render a blueprint's @files@ list as the body of the -- "## Reference Files" block. When the directory exists, the interactive @@ -236,9 +238,9 @@ formatReferenceFiles [] = "(no reference files)" formatReferenceFiles bfs = T.intercalate "\n" (map render bfs) where - render bf = case bf.description of - Just d -> " - " <> T.pack bf.src <> " — " <> d - Nothing -> " - " <> T.pack bf.src + render bf = case bf ^. #description of + Just d -> " - " <> T.pack (bf ^. #src) <> " — " <> d + Nothing -> " - " <> T.pack (bf ^. #src) -- | Render guidance for the blueprint's reference-files directory. A -- present path means the directory is mounted and readable by the interactive diff --git a/src/Seihou/CLI/AgentTrace.hs b/src/Seihou/CLI/AgentTrace.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/CLI/AgentTrace.hs @@ -0,0 +1,87 @@ +-- | Turning a resolved 'TraceSetting' into a live Baikai 'TraceSink'. +-- +-- This is the only module in Seihou that touches the filesystem on behalf of +-- tracing (it creates the trace file's parent directory) and the only one that +-- imports "Baikai.Trace.Sink". Keeping it separate from +-- "Seihou.CLI.AgentCompletion" keeps sink construction — which is effectful — +-- out of the pure resolution path. +module Seihou.CLI.AgentTrace + ( traceSinkForConfig, + traceSinkFor, + resolveTraceFilePath, + defaultTraceFileName, + stderrSink, + ) +where + +import Baikai.Trace.Sink (TraceSink (..), fileSink, renderHuman, silent, stdoutSink) +import Data.Generics.Labels () +import Data.Text qualified as T +import Data.Text.IO qualified as TIO +import Seihou.CLI.AgentCompletion (AgentModelConfig (..), TraceSetting (..), traceToText) +import Seihou.CLI.Shared (logIO) +import Seihou.Core.Types (LogLevel) +import Seihou.Effect.Logger (logInfo) +import Seihou.Prelude +import Streamly.Data.Fold qualified as Fold +import System.Directory (createDirectoryIfMissing) +import System.FilePath (takeDirectory) +import System.IO (stderr) + +-- | Where the file sink writes when @agent.tracePath@ is unset: +-- @.seihou/trace.jsonl@, beside the manifest and project config that Seihou +-- already keeps there. +defaultTraceFileName :: FilePath +defaultTraceFileName = ".seihou" "trace.jsonl" + +-- | The configured @agent.tracePath@ when set and non-blank, otherwise +-- 'defaultTraceFileName'. A whitespace-only path counts as absent, matching +-- the resolver's treatment of every other setting. +resolveTraceFilePath :: Maybe FilePath -> FilePath +resolveTraceFilePath configured = + case configured of + Just raw | not (T.null (T.strip (T.pack raw))) -> raw + _ -> defaultTraceFileName + +-- | Print each event to stderr using Baikai's 'renderHuman'. +-- +-- Baikai ships 'stdoutSink' but no stderr equivalent, and stderr is where +-- Seihou already sends out-of-band information (see +-- "Seihou.Effect.LoggerInterp"), so trace lines never corrupt assistant output +-- a user is piping. +stderrSink :: TraceSink +stderrSink = TraceSink (Fold.drainMapM (TIO.hPutStrLn stderr . renderHuman)) + +-- | Build the sink a resolved trace setting names. +-- +-- 'TraceOff' yields Baikai's 'silent' sink, which discards every event — that +-- is the default, and it is what keeps tracing free when nobody asked for it. +-- 'TraceFile' creates the trace file's parent directory first, so the first +-- traced run in a project without a @.seihou/@ directory succeeds. +traceSinkFor :: TraceSetting -> Maybe FilePath -> IO TraceSink +traceSinkFor setting configuredPath = + case setting of + TraceOff -> pure silent + TraceStdout -> pure stdoutSink + TraceStderr -> pure stderrSink + TraceFile -> do + let path = resolveTraceFilePath configuredPath + createDirectoryIfMissing True (takeDirectory path) + fileSink path + +-- | Build the sink a resolved agent configuration asks for, naming the +-- destination at verbose level. +-- +-- Call this once per command rather than once per model call, so a command +-- that makes several calls — @seihou agent migrate@ walks one call per +-- migration edge — reports one destination and appends every call to it. +traceSinkForConfig :: LogLevel -> AgentModelConfig -> IO TraceSink +traceSinkForConfig level config = do + case config ^. #trace of + TraceOff -> pure () + TraceFile -> + logIO level $ + logInfo ("Trace: writing call traces to " <> T.pack (resolveTraceFilePath (config ^. #tracePath))) + other -> + logIO level (logInfo ("Trace: writing call traces to " <> traceToText other)) + traceSinkFor (config ^. #trace) (config ^. #tracePath) diff --git a/src/Seihou/CLI/AppliedBlueprint.hs b/src/Seihou/CLI/AppliedBlueprint.hs --- a/src/Seihou/CLI/AppliedBlueprint.hs +++ b/src/Seihou/CLI/AppliedBlueprint.hs @@ -11,6 +11,7 @@ ) where +import Data.Generics.Labels () import Seihou.Core.Types (AppliedBlueprint (..)) import Seihou.Effect.Filesystem (createDirectoryIfMissing) import Seihou.Effect.FilesystemInterp (runFilesystem) @@ -40,6 +41,6 @@ writeManifest (writeAppliedBlueprint ab m) pure (Right ()) Right Nothing -> do - writeManifest (writeAppliedBlueprint ab (emptyManifest ab.appliedAt)) + writeManifest (writeAppliedBlueprint ab (emptyManifest (ab ^. #appliedAt))) pure (Right ()) Left err -> pure (Left err) diff --git a/src/Seihou/CLI/AppliedBlueprintMigration.hs b/src/Seihou/CLI/AppliedBlueprintMigration.hs --- a/src/Seihou/CLI/AppliedBlueprintMigration.hs +++ b/src/Seihou/CLI/AppliedBlueprintMigration.hs @@ -4,6 +4,7 @@ ) where +import Data.Generics.Labels () import Seihou.Core.Types (AppliedBlueprintMigration (..)) import Seihou.Effect.Filesystem (createDirectoryIfMissing) import Seihou.Effect.FilesystemInterp (runFilesystem) @@ -26,6 +27,6 @@ writeManifest (writeAppliedBlueprintMigration receipt manifest) pure (Right ()) Right Nothing -> do - writeManifest (writeAppliedBlueprintMigration receipt (emptyManifest receipt.appliedAt)) + writeManifest (writeAppliedBlueprintMigration receipt (emptyManifest (receipt ^. #appliedAt))) pure (Right ()) Left err -> pure (Left err) diff --git a/src/Seihou/CLI/BlueprintExecution.hs b/src/Seihou/CLI/BlueprintExecution.hs --- a/src/Seihou/CLI/BlueprintExecution.hs +++ b/src/Seihou/CLI/BlueprintExecution.hs @@ -13,6 +13,7 @@ ) where +import Data.Generics.Labels () import Data.Map.Strict qualified as Map import Data.Maybe (fromMaybe) import Data.Text qualified as T @@ -46,30 +47,30 @@ -- Provider capability is represented as a boolean so this library module does -- not need to know about Baikai or the executable command model. data BlueprintExecutionRequest = BlueprintExecutionRequest - { executionBlueprint :: Blueprint, - executionBlueprintDir :: FilePath, - executionVariableOverrides :: [(Text, Text)], - executionNamespaceOverride :: Maybe Text, - executionContextOverride :: Maybe Text, - executionCanMountFiles :: Bool, - executionLogLevel :: LogLevel + { blueprint :: !Blueprint, + blueprintDir :: !FilePath, + variableOverrides :: ![(Text, Text)], + namespaceOverride :: !(Maybe Text), + contextOverride :: !(Maybe Text), + canMountFiles :: !Bool, + logLevel :: !LogLevel } - deriving stock (Eq, Show) + deriving stock (Eq, Generic, Show) -- | Prepared state that both execution modes consume. The mounted path is -- absolute when present; the access text preserves the existing API-provider -- explanation when local files cannot be mounted. data PreparedBlueprintExecution = PreparedBlueprintExecution - { preparedBlueprint :: Blueprint, - preparedBlueprintDir :: FilePath, - preparedResolvedVariables :: Map VarName ResolvedVar, - preparedMountedFilesDir :: Maybe FilePath, - preparedReferenceFiles :: Text, - preparedReferenceFilesAccess :: Text, - preparedSharedPrompt :: Text, - preparedAllowedTools :: [String] + { blueprint :: !Blueprint, + blueprintDir :: !FilePath, + resolvedVariables :: !(Map VarName ResolvedVar), + mountedFilesDir :: !(Maybe FilePath), + referenceFiles :: !Text, + referenceFilesAccess :: !Text, + sharedPrompt :: !Text, + allowedTools :: ![String] } - deriving stock (Eq, Show) + deriving stock (Eq, Generic, Show) -- | Resolve one blueprint through the same CLI/environment/config/prompt -- precedence used by @seihou run@ and the existing agent runner. @@ -77,47 +78,47 @@ BlueprintExecutionRequest -> IO (Either [VarError] PreparedBlueprintExecution) prepareBlueprintExecution request = do - let bp = request.executionBlueprint - blueprintDir = request.executionBlueprintDir + let bp = (request ^. #blueprint) + blueprintDir = (request ^. #blueprintDir) filesDir = blueprintDir "files" filesExist <- doesDirectoryExist filesDir mountedFilesDir <- - if filesExist && request.executionCanMountFiles + if filesExist && request ^. #canMountFiles then Just <$> makeAbsolute filesDir else pure Nothing let placeholderModule = Module - { name = bp.name, - version = bp.version, - description = bp.description, - vars = bp.vars, + { name = bp ^. #name, + version = bp ^. #version, + description = bp ^. #description, + vars = bp ^. #vars, exports = [], - prompts = bp.prompts, + prompts = bp ^. #prompts, steps = [], commands = [], dependencies = [], removal = Nothing, migrations = [] } - placeholderInst = primaryInstance bp.name + placeholderInst = primaryInstance (bp ^. #name) placeholderTriple = (placeholderInst, placeholderModule, blueprintDir) envPairs <- getEnvironment let cliOverrides = Map.fromList - [(VarName key, value) | (key, value) <- request.executionVariableOverrides] + [(VarName key, value) | (key, value) <- request ^. #variableOverrides] envVars = Map.fromList [(T.pack key, T.pack value) | (key, value) <- envPairs] namespace = - fromMaybe (deriveNamespace bp.name) request.executionNamespaceOverride - context <- resolveContext request.executionContextOverride envVars + fromMaybe (deriveNamespace (bp ^. #name)) (request ^. #namespaceOverride) + context <- resolveContext (request ^. #contextOverride) envVars let contextName = fromMaybe "" context resolveResult <- runEff $ runConfigReader $ runConsole $ do - localCfg <- readLocalConfig >>= unwrapConfig request.executionLogLevel - nsCfg <- readNamespaceConfig namespace >>= unwrapConfig request.executionLogLevel - ctxCfg <- readContextConfig contextName >>= unwrapConfig request.executionLogLevel - globalCfg <- readGlobalConfig >>= unwrapConfig request.executionLogLevel + localCfg <- readLocalConfig >>= unwrapConfig (request ^. #logLevel) + nsCfg <- readNamespaceConfig namespace >>= unwrapConfig (request ^. #logLevel) + ctxCfg <- readContextConfig contextName >>= unwrapConfig (request ^. #logLevel) + globalCfg <- readGlobalConfig >>= unwrapConfig (request ^. #logLevel) resolveWithPrompts [placeholderTriple] cliOverrides @@ -134,14 +135,14 @@ let resolved = Map.findWithDefault Map.empty placeholderInst allResolved Right PreparedBlueprintExecution - { preparedBlueprint = bp, - preparedBlueprintDir = blueprintDir, - preparedResolvedVariables = resolved, - preparedMountedFilesDir = mountedFilesDir, - preparedReferenceFiles = formatReferenceFiles bp.files, - preparedReferenceFilesAccess = formatReferenceFilesDir mountedFilesDir, - preparedSharedPrompt = renderBlueprintText resolved bp.prompt, - preparedAllowedTools = resolveBlueprintTools bp.allowedTools + { blueprint = bp, + blueprintDir = blueprintDir, + resolvedVariables = resolved, + mountedFilesDir = mountedFilesDir, + referenceFiles = formatReferenceFiles (bp ^. #files), + referenceFilesAccess = formatReferenceFilesDir mountedFilesDir, + sharedPrompt = renderBlueprintText resolved (bp ^. #prompt), + allowedTools = resolveBlueprintTools (bp ^. #allowedTools) } -- | Substitute resolved blueprint variables into any blueprint-owned text. @@ -150,8 +151,8 @@ foldl' ( \rendered (name, value) -> T.replace - ("{{" <> name.unVarName <> "}}") - (varValueToText value.value) + ("{{" <> name ^. #unVarName <> "}}") + (varValueToText (value ^. #value)) rendered ) template diff --git a/src/Seihou/CLI/BlueprintMigration.hs b/src/Seihou/CLI/BlueprintMigration.hs --- a/src/Seihou/CLI/BlueprintMigration.hs +++ b/src/Seihou/CLI/BlueprintMigration.hs @@ -11,6 +11,7 @@ ) where +import Data.Generics.Labels () import Data.Maybe (fromMaybe) import Data.Text qualified as T import Seihou.CLI.AgentLaunch @@ -62,7 +63,7 @@ BlueprintMigration -> Text renderBlueprintMigrationInstruction resolved migration = - renderBlueprintText resolved migration.prompt + renderBlueprintText resolved (migration ^. #prompt) -- | Fill the migration-specific embedded template. The template itself stays -- in the executable target because @Data.FileEmbed@ traps it there; accepting @@ -76,26 +77,26 @@ BlueprintMigration -> Text renderBlueprintMigrationSystemPrompt template ctx prepared position total migration = - let blueprint = prepared.preparedBlueprint + let blueprint = (prepared ^. #blueprint) renderedInstruction = - renderBlueprintMigrationInstruction prepared.preparedResolvedVariables migration + renderBlueprintMigrationInstruction (prepared ^. #resolvedVariables) migration in substitute - [ ("cwd", ctx.cwd), + [ ("cwd", ctx ^. #cwd), ("seihou_project_state", formatSeihouProjectState ctx), ("manifest_state", formatManifestState ctx), ("module_dhall_state", formatModuleDhallState ctx), ("local_modules", formatLocalModules ctx), ("available_modules", formatAvailableModules ctx), - ("blueprint_name", blueprint.name.unModuleName), - ("blueprint_version", fromMaybe "(unspecified)" blueprint.version), - ("blueprint_description", fromMaybe "(no description)" blueprint.description), - ("migration_from", migration.from), - ("migration_to", migration.to), + ("blueprint_name", blueprint ^. #name . #unModuleName), + ("blueprint_version", fromMaybe "(unspecified)" (blueprint ^. #version)), + ("blueprint_description", fromMaybe "(no description)" (blueprint ^. #description)), + ("migration_from", migration ^. #from), + ("migration_to", migration ^. #to), ("migration_position", T.pack (show position)), ("migration_total", T.pack (show total)), - ("reference_files", prepared.preparedReferenceFiles), - ("reference_files_dir", prepared.preparedReferenceFilesAccess), - ("shared_prompt", prepared.preparedSharedPrompt), + ("reference_files", prepared ^. #referenceFiles), + ("reference_files_dir", prepared ^. #referenceFilesAccess), + ("shared_prompt", prepared ^. #sharedPrompt), ("migration_prompt", renderedInstruction) ] template @@ -116,9 +117,9 @@ <> "/" <> T.pack (show total) <> "] " - <> migration.from + <> migration ^. #from <> " -> " - <> migration.to + <> migration ^. #to <> " =====", render position total migration ] @@ -136,15 +137,15 @@ BlueprintMigrationPlan -> [BlueprintMigration] pendingBlueprintMigrations rerun blueprintName receipts plan - | rerun = plan.blueprintPlanSteps - | otherwise = filter (not . alreadyApplied) plan.blueprintPlanSteps + | rerun = plan ^. #steps + | otherwise = filter (not . alreadyApplied) (plan ^. #steps) where alreadyApplied migration = any ( \receipt -> - receipt.name == blueprintName - && receipt.fromVersion == migration.from - && receipt.toVersion == migration.to + receipt ^. #name == blueprintName + && receipt ^. #fromVersion == migration ^. #from + && receipt ^. #toVersion == migration ^. #to ) receipts diff --git a/src/Seihou/CLI/BrowseFormat.hs b/src/Seihou/CLI/BrowseFormat.hs --- a/src/Seihou/CLI/BrowseFormat.hs +++ b/src/Seihou/CLI/BrowseFormat.hs @@ -7,6 +7,7 @@ ) where +import Data.Generics.Labels () import Data.Text qualified as T import Seihou.Core.Registry (EntryKind (..), Registry (..), RegistryEntry (..)) import Seihou.Core.Types (ModuleName (..)) @@ -27,9 +28,9 @@ formatBrowseRegistry :: Text -> Registry -> [(EntryKind, RegistryEntry)] -> Maybe Text -> Text formatBrowseRegistry source registry filtered tagFilter = let header = - registry.repoName + registry ^. #repoName <> "\n" - <> maybe "" (<> "\n") registry.repoDescription + <> maybe "" (<> "\n") (registry ^. #repoDescription) <> "\n" in if null filtered then @@ -39,7 +40,7 @@ Nothing -> "No entries in registry.\n" ) else - let nameOf e = let (ModuleName n) = e.name in n + let nameOf e = let (ModuleName n) = (e ^. #name) in n maxNameLen = maximum (map (T.length . nameOf . snd) filtered) entryLines = T.unlines (map (formatEntry maxNameLen) filtered) n = length filtered @@ -95,11 +96,11 @@ formatEntry :: Int -> (EntryKind, RegistryEntry) -> Text formatEntry maxNameLen (kind, entry) = - let (ModuleName name) = entry.name + let (ModuleName name) = (entry ^. #name) padding = T.replicate (maxNameLen - T.length name + 3) " " - desc = maybe "" id entry.description + desc = maybe "" id (entry ^. #description) tagsText = - if null entry.tags + if null (entry ^. #tags) then "" - else " [" <> T.intercalate ", " entry.tags <> "]" + else " [" <> T.intercalate ", " (entry ^. #tags) <> "]" in " " <> kindLabel kind <> " " <> name <> padding <> desc <> tagsText diff --git a/src/Seihou/CLI/CommandExecution.hs b/src/Seihou/CLI/CommandExecution.hs --- a/src/Seihou/CLI/CommandExecution.hs +++ b/src/Seihou/CLI/CommandExecution.hs @@ -13,6 +13,7 @@ ) where +import Data.Generics.Labels () import Data.Map.Strict qualified as Map import Data.Maybe (mapMaybe) import Data.Time (UTCTime) @@ -39,35 +40,35 @@ -- | A rendered command paired with its stable identity and selected action. data PlannedCommand = PlannedCommand - { operation :: Operation, - fingerprint :: CommandFingerprint, - disposition :: CommandDisposition + { operation :: !Operation, + fingerprint :: !CommandFingerprint, + disposition :: !CommandDisposition } - deriving stock (Eq, Show) + deriving stock (Eq, Generic, Show) -- | An ordered command phase. Declaration/composition order is also execution -- order. newtype CommandPlan = CommandPlan { commands :: [PlannedCommand] } - deriving stock (Eq, Show) + deriving stock (Eq, Generic, Show) -- | Counts suitable for human or machine-readable previews. data CommandPlanSummary = CommandPlanSummary - { willRun :: Int, - skippedUnchanged :: Int, - skippedDisabled :: Int + { willRun :: !Int, + skippedUnchanged :: !Int, + skippedDisabled :: !Int } - deriving stock (Eq, Show) + deriving stock (Eq, Generic, Show) -- | A failed shell command and its captured process result. data CommandExecutionError = CommandExecutionError - { command :: PlannedCommand, - exitCode :: Int, - stdout :: Text, - stderr :: Text + { command :: !PlannedCommand, + exitCode :: !Int, + stdout :: !Text, + stderr :: !Text } - deriving stock (Eq, Show) + deriving stock (Eq, Generic, Show) -- | Select command dispositions according to policy and prior successful -- receipts. Non-command operations are ignored. @@ -92,13 +93,13 @@ -- | Count each command disposition without changing command order. summarizeCommandPlan :: CommandPlan -> CommandPlanSummary summarizeCommandPlan commandPlan = - foldl' count emptySummary commandPlan.commands + foldl' count emptySummary (commandPlan ^. #commands) where emptySummary = CommandPlanSummary {willRun = 0, skippedUnchanged = 0, skippedDisabled = 0} - count summary planned = case planned.disposition of - CommandWillRun -> summary {willRun = summary.willRun + 1} - CommandSkippedUnchanged -> summary {skippedUnchanged = summary.skippedUnchanged + 1} - CommandSkippedDisabled -> summary {skippedDisabled = summary.skippedDisabled + 1} + count summary planned = case planned ^. #disposition of + CommandWillRun -> (summary & #willRun %~ (+ 1)) + CommandSkippedUnchanged -> (summary & #skippedUnchanged %~ (+ 1)) + CommandSkippedDisabled -> summary & #skippedDisabled %~ (+ 1) -- | Execute runnable commands sequentially with @sh -c@. Stop at the first -- failure. The caller receives receipts only if the entire phase succeeds. @@ -107,7 +108,7 @@ UTCTime -> CommandPlan -> Eff es (Either CommandExecutionError [CommandReceipt]) -executeCommandPlan completedAt commandPlan = go [] commandPlan.commands +executeCommandPlan completedAt commandPlan = go [] (commandPlan ^. #commands) where go = executeCommands completedAt (\_ _ _ -> pure ()) @@ -122,7 +123,7 @@ CommandPlan -> Eff es (Either CommandExecutionError [CommandReceipt]) executeCommandPlanWithOutput completedAt onSuccess commandPlan = - executeCommands completedAt onSuccess [] commandPlan.commands + executeCommands completedAt onSuccess [] (commandPlan ^. #commands) executeCommands :: (Process :> es) => @@ -134,10 +135,10 @@ executeCommands completedAt onSuccess = go where go completed [] = pure (Right (reverse completed)) - go completed (planned : remaining) = case planned.disposition of + go completed (planned : remaining) = case planned ^. #disposition of CommandSkippedUnchanged -> go completed remaining CommandSkippedDisabled -> go completed remaining - CommandWillRun -> case planned.operation of + CommandWillRun -> case planned ^. #operation of RunCommandOp {command, workDir, moduleName} -> do (processExit, stdout, stderr) <- runProcess "sh" ["-c", command] workDir case processExit of @@ -145,7 +146,7 @@ onSuccess planned stdout stderr let receipt = CommandReceipt - { fingerprint = planned.fingerprint, + { fingerprint = planned ^. #fingerprint, moduleName, command, workDir, @@ -173,17 +174,17 @@ Map CommandFingerprint CommandReceipt -> Map CommandFingerprint CommandReceipt finalizeCommandReceipts commandPlan completed priorReceipts = - Map.fromList (mapMaybe receiptFor commandPlan.commands) + Map.fromList (mapMaybe receiptFor (commandPlan ^. #commands)) where - completedByFingerprint = Map.fromList [(receipt.fingerprint, receipt) | receipt <- completed] + completedByFingerprint = Map.fromList [(receipt ^. #fingerprint, receipt) | receipt <- completed] receiptFor planned = - case Map.lookup planned.fingerprint completedByFingerprint of - Just receipt -> Just (planned.fingerprint, receipt) - Nothing -> case planned.disposition of + case Map.lookup (planned ^. #fingerprint) completedByFingerprint of + Just receipt -> Just (planned ^. #fingerprint, receipt) + Nothing -> case planned ^. #disposition of CommandWillRun -> Nothing CommandSkippedUnchanged -> retainPrior planned CommandSkippedDisabled -> retainPrior planned retainPrior planned = - (planned.fingerprint,) <$> Map.lookup planned.fingerprint priorReceipts + (planned ^. #fingerprint,) <$> Map.lookup (planned ^. #fingerprint) priorReceipts diff --git a/src/Seihou/CLI/CommitMessage.hs b/src/Seihou/CLI/CommitMessage.hs --- a/src/Seihou/CLI/CommitMessage.hs +++ b/src/Seihou/CLI/CommitMessage.hs @@ -5,6 +5,8 @@ where import Control.Exception (SomeException, try) +import Control.Lens ((^.)) +import Data.Generics.Labels () import Data.Text qualified as T import Data.Text.IO qualified as TIO import Seihou.Core.Types (ModuleName (..)) @@ -31,6 +33,8 @@ callClaude :: [ModuleName] -> T.Text -> IO (Maybe T.Text) callClaude modNames diffText = do + -- CreateProcess is a third-party type with no Generic instance, so it has + -- no #std_out label to set. Record update syntax is the only option here. let prompt = buildPrompt modNames diffText cp = (proc "claude" ["-p", T.unpack prompt]) @@ -69,7 +73,7 @@ "- Do not wrap the output in backticks or code fences" ] where - moduleList = T.intercalate ", " (map (.unModuleName) modNames) + moduleList = T.intercalate ", " (map (^. #unModuleName) modNames) -- | Strip markdown code-fence wrapping (``` ... ```) from text. -- Handles optional language tags (e.g., ```text). @@ -89,5 +93,5 @@ fallbackMessage :: [ModuleName] -> T.Text fallbackMessage [] = "chore(seihou): apply modules" -fallbackMessage [m] = "chore(seihou): apply " <> m.unModuleName -fallbackMessage ms = "chore(seihou): apply " <> T.intercalate ", " (map (.unModuleName) ms) +fallbackMessage [m] = "chore(seihou): apply " <> (m ^. #unModuleName) +fallbackMessage ms = "chore(seihou): apply " <> T.intercalate ", " (map (^. #unModuleName) ms) diff --git a/src/Seihou/CLI/Diff.hs b/src/Seihou/CLI/Diff.hs --- a/src/Seihou/CLI/Diff.hs +++ b/src/Seihou/CLI/Diff.hs @@ -4,6 +4,7 @@ ) where +import Data.Generics.Labels () import Data.Text qualified as T import Data.Text.IO qualified as TIO import Seihou.CLI.Shared (logIO) @@ -43,9 +44,9 @@ formatDiffOutput :: Bool -> [TrackedFile] -> Text formatDiffOutput color tracked = - let modified = filter (\t -> t.status == TfsModified) tracked - deleted = filter (\t -> t.status == TfsDeleted) tracked - unchanged = filter (\t -> t.status == TfsUnchanged) tracked + let modified = filter (\t -> t ^. #status == TfsModified) tracked + deleted = filter (\t -> t ^. #status == TfsDeleted) tracked + unchanged = filter (\t -> t ^. #status == TfsUnchanged) tracked nMod = length modified nDel = length deleted nUnch = length unchanged @@ -53,7 +54,7 @@ in if null changed then "No changes since last generation.\n" else - let maxPathLen = maximum (map (length . (.path)) changed) + let maxPathLen = maximum (map (length . (^. #path)) changed) header = "Seihou Diff:\n" fileLines = map (formatLine color maxPathLen) changed summary = @@ -68,12 +69,12 @@ formatLine :: Bool -> Int -> TrackedFile -> Text formatLine color maxPathLen tf = - let (label, colorFn) = case tf.status of + let (label, colorFn) = case tf ^. #status of TfsModified -> ("modified", yellow) TfsDeleted -> ("deleted ", red) TfsUnchanged -> ("unchanged", dim) - path = T.pack tf.path - modName = tf.moduleName.unModuleName + path = T.pack (tf ^. #path) + modName = (tf ^. #moduleName . #unModuleName) paddedLabel = if color then colorFn label else label paddedPath = path <> T.replicate (maxPathLen - T.length path + 3) " " modAttr = if color then dim ("(" <> modName <> ")") else "(" <> modName <> ")" diff --git a/src/Seihou/CLI/Extension.hs b/src/Seihou/CLI/Extension.hs --- a/src/Seihou/CLI/Extension.hs +++ b/src/Seihou/CLI/Extension.hs @@ -7,6 +7,7 @@ ) where +import Data.Generics.Labels () import Data.Text qualified as T import Data.Text.IO qualified as TIO import Seihou.Prelude @@ -16,10 +17,10 @@ import System.Process (rawSystem) data ExtensionRunOpts = ExtensionRunOpts - { extensionName :: Text, - extensionArgs :: [String] + { name :: !Text, + args :: ![String] } - deriving stock (Eq, Show) + deriving stock (Eq, Generic, Show) data ExtensionRunError = ExtensionNotFound Text String @@ -32,16 +33,16 @@ runExtension :: ExtensionRunOpts -> IO (Either ExtensionRunError ()) runExtension opts = do - let exeName = extensionExecutableName opts.extensionName + let exeName = extensionExecutableName (opts ^. #name) found <- findExecutable exeName case found of Nothing -> - pure (Left (ExtensionNotFound opts.extensionName exeName)) + pure (Left (ExtensionNotFound (opts ^. #name) exeName)) Just exePath -> do - code <- rawSystem exePath opts.extensionArgs + code <- rawSystem exePath (opts ^. #args) pure $ case code of ExitSuccess -> Right () - failure -> Left (ExtensionExited opts.extensionName failure) + failure -> Left (ExtensionExited (opts ^. #name) failure) handleExtensionRun :: ExtensionRunOpts -> IO () handleExtensionRun opts = do diff --git a/src/Seihou/CLI/InstallHistory.hs b/src/Seihou/CLI/InstallHistory.hs --- a/src/Seihou/CLI/InstallHistory.hs +++ b/src/Seihou/CLI/InstallHistory.hs @@ -15,6 +15,7 @@ import Data.Aeson.Encode.Pretty (encodePretty) import Data.ByteString qualified as BS import Data.ByteString.Lazy qualified as LBS +import Data.Generics.Labels () import Data.Text qualified as T import Data.Time (getCurrentTime) import Data.Time.Format.ISO8601 (iso8601Show) @@ -29,13 +30,13 @@ -- | A single entry in the install URL history. data HistoryEntry = HistoryEntry - { url :: Text, - lastUsed :: Text + { url :: !Text, + lastUsed :: !Text } - deriving stock (Eq, Show) + deriving stock (Eq, Generic, Show) instance ToJSON HistoryEntry where - toJSON e = object ["url" .= e.url, "lastUsed" .= e.lastUsed] + toJSON e = object ["url" .= (e ^. #url), "lastUsed" .= (e ^. #lastUsed)] instance FromJSON HistoryEntry where parseJSON = withObject "HistoryEntry" $ \o -> @@ -45,10 +46,10 @@ newtype InstallHistory = InstallHistory { entries :: [HistoryEntry] } - deriving stock (Eq, Show) + deriving stock (Eq, Generic, Show) instance ToJSON InstallHistory where - toJSON h = object ["entries" .= h.entries] + toJSON h = object ["entries" .= (h ^. #entries)] instance FromJSON InstallHistory where parseJSON = withObject "InstallHistory" $ \o -> @@ -101,6 +102,6 @@ history <- readHistoryFrom path let timestamp = T.pack (iso8601Show now) newEntry = HistoryEntry {url = url, lastUsed = timestamp} - filtered = filter (\e -> e.url /= url) history.entries + filtered = filter (\e -> e ^. #url /= url) (history ^. #entries) updated = take maxHistoryEntries (newEntry : filtered) writeHistoryTo path (InstallHistory updated) diff --git a/src/Seihou/CLI/InstallShared.hs b/src/Seihou/CLI/InstallShared.hs --- a/src/Seihou/CLI/InstallShared.hs +++ b/src/Seihou/CLI/InstallShared.hs @@ -12,14 +12,15 @@ where import Control.Monad (when) -import Data.Aeson (FromJSON (..), ToJSON (..), object, withObject, (.:), (.:?), (.=)) -import Data.Aeson qualified as Aeson +import Data.Aeson (ToJSON (..), object, (.=)) import Data.Aeson.Encode.Pretty (encodePretty) import Data.ByteString.Lazy qualified as LBS +import Data.Generics.Labels () import Data.Text qualified as T import Data.Time (getCurrentTime) import Data.Time.Format.ISO8601 (iso8601Show) import Seihou.CLI.Shared (logIO) +import Seihou.Core.ArtifactOriginDetect (OriginInfo (..), readOriginInfo) import Seihou.Core.Types (LogLevel (..)) import Seihou.Effect.Logger (logWarn) import Seihou.Prelude @@ -28,7 +29,6 @@ copyFile, createDirectoryIfMissing, doesDirectoryExist, - doesFileExist, getXdgDirectory, listDirectory, removeDirectoryRecursive, @@ -40,50 +40,33 @@ -- Origin metadata -- ---------------------------------------------------------------------------- --- | Read side of @.seihou-origin.json@. Tolerates files written by older --- 'seihou install' runs that may have been missing optional fields. -data OriginInfo = OriginInfo - { sourceUrl :: Text, - repoName :: Maybe Text, - version :: Maybe Text - } - deriving stock (Eq, Show) - -instance FromJSON OriginInfo where - parseJSON = withObject "OriginInfo" $ \v -> - OriginInfo <$> v .: "sourceUrl" <*> v .:? "repoName" <*> v .:? "version" - --- | Read and parse @.seihou-origin.json@ at the given installed-module --- directory. Returns 'Nothing' if the file is absent or unparseable. -readOriginInfo :: FilePath -> IO (Maybe OriginInfo) -readOriginInfo installedDir = do - let path = installedDir ".seihou-origin.json" - exists <- doesFileExist path - if not exists - then pure Nothing - else do - bs <- LBS.readFile path - pure (Aeson.decode bs) +-- The read side ('OriginInfo', 'readOriginInfo') lives in +-- "Seihou.Core.ArtifactOriginDetect" because @seihou-core@ needs it to +-- classify an artifact directory into a portable manifest origin and cannot +-- depend on @seihou-cli-internal@. It is re-exported here so existing +-- importers are unaffected. The write side below stays in the CLI, which is +-- the only place that installs anything. -- | Write side of @.seihou-origin.json@. Captures everything 'seihou -- install' / 'seihou upgrade' want to record at install time, including -- the timestamp. data OriginMeta = OriginMeta - { sourceUrl :: Text, - repoName :: Maybe Text, - installedAt :: Text, - version :: Maybe Text, - tags :: [Text] + { sourceUrl :: !Text, + repoName :: !(Maybe Text), + installedAt :: !Text, + version :: !(Maybe Text), + tags :: ![Text] } + deriving stock (Generic) instance ToJSON OriginMeta where toJSON m = object - [ "sourceUrl" .= m.sourceUrl, - "repoName" .= m.repoName, - "installedAt" .= m.installedAt, - "version" .= m.version, - "tags" .= m.tags + [ "sourceUrl" .= (m ^. #sourceUrl), + "repoName" .= (m ^. #repoName), + "installedAt" .= (m ^. #installedAt), + "version" .= (m ^. #version), + "tags" .= (m ^. #tags) ] -- ---------------------------------------------------------------------------- diff --git a/src/Seihou/CLI/List.hs b/src/Seihou/CLI/List.hs --- a/src/Seihou/CLI/List.hs +++ b/src/Seihou/CLI/List.hs @@ -12,6 +12,7 @@ import Data.Aeson (FromJSON (..), withObject, (.:?)) import Data.Aeson qualified as Aeson import Data.ByteString.Lazy qualified as LBS +import Data.Generics.Labels () import Data.Map.Strict qualified as Map import Data.Maybe (fromMaybe) import Data.Text qualified as T @@ -25,10 +26,11 @@ -- | Origin metadata read from @.seihou-origin.json@. data OriginInfo = OriginInfo - { originRepoName :: Maybe Text, - originVersion :: Maybe Text, - originTags :: [Text] + { repoName :: !(Maybe Text), + version :: !(Maybe Text), + tags :: ![Text] } + deriving stock (Generic) instance FromJSON OriginInfo where parseJSON = withObject "OriginInfo" $ \v -> @@ -38,11 +40,11 @@ -- imported from Commands) so the internal library does not depend on -- optparse-applicative. data ListFilter = ListFilter - { filterRepo :: Maybe Text, - filterTag :: Maybe Text, - filterKinds :: [RunnableKind] + { repo :: !(Maybe Text), + tag :: !(Maybe Text), + kinds :: ![RunnableKind] } - deriving stock (Eq, Show) + deriving stock (Eq, Generic, Show) noFilter :: ListFilter noFilter = ListFilter Nothing Nothing [] @@ -61,59 +63,59 @@ readOrigin :: DiscoveredModule -> IO (FilePath, Maybe OriginInfo) readOrigin dm = do - let originFile = dm.discoveredDir ".seihou-origin.json" + let originFile = dm ^. #dir ".seihou-origin.json" exists <- doesFileExist originFile if exists then do bs <- LBS.readFile originFile case Aeson.decode bs of - Just info -> pure (dm.discoveredDir, Just info) - Nothing -> pure (dm.discoveredDir, Nothing) - else pure (dm.discoveredDir, Nothing) + Just info -> pure (dm ^. #dir, Just info) + Nothing -> pure (dm ^. #dir, Nothing) + else pure (dm ^. #dir, Nothing) readRunnableOrigin :: DiscoveredRunnable -> IO (FilePath, Maybe OriginInfo) readRunnableOrigin dr = do - let originFile = dr.drDir ".seihou-origin.json" + let originFile = dr ^. #dir ".seihou-origin.json" exists <- doesFileExist originFile if exists then do bs <- LBS.readFile originFile case Aeson.decode bs of - Just info -> pure (dr.drDir, Just info) - Nothing -> pure (dr.drDir, Nothing) - else pure (dr.drDir, Nothing) + Just info -> pure (dr ^. #dir, Just info) + Nothing -> pure (dr ^. #dir, Nothing) + else pure (dr ^. #dir, Nothing) runnableToEntryWithOrigin :: Map FilePath (Maybe OriginInfo) -> DiscoveredRunnable -> Entry runnableToEntryWithOrigin origins dr = - let (originName, originVer, originTags) = case Map.lookup dr.drDir origins of - Just (Just info) -> (info.originRepoName, info.originVersion, info.originTags) + let (originName, originVer, tags) = case Map.lookup (dr ^. #dir) origins of + Just (Just info) -> (info ^. #repoName, info ^. #version, info ^. #tags) _ -> (Nothing, Nothing, []) - srcLabel = sourceLabelWithOrigin dr.drSource originName originVer - kindSuffix = case dr.drKind of + srcLabel = sourceLabelWithOrigin (dr ^. #source) originName originVer + kindSuffix = case dr ^. #kind of KindModule -> "" KindRecipe -> " [recipe]" KindBlueprint -> " [blueprint]" KindPrompt -> " [prompt]" - in if dr.drIsError + in if dr ^. #isError then Entry - { entryName = dr.drName, - entryDesc = "[error: " <> fromMaybe "unknown" dr.drError <> "]", - entrySource = srcLabel <> kindSuffix, - entryIsError = True, - entryRepoName = originName, - entryTags = originTags, - entryKind = dr.drKind + { name = dr ^. #name, + desc = "[error: " <> fromMaybe "unknown" (dr ^. #error) <> "]", + source = srcLabel <> kindSuffix, + isError = True, + repoName = originName, + tags = tags, + kind = dr ^. #kind } else Entry - { entryName = dr.drName, - entryDesc = fromMaybe "(no description)" dr.drDescription, - entrySource = srcLabel <> kindSuffix, - entryIsError = False, - entryRepoName = originName, - entryTags = originTags, - entryKind = dr.drKind + { name = dr ^. #name, + desc = fromMaybe "(no description)" (dr ^. #description), + source = srcLabel <> kindSuffix, + isError = False, + repoName = originName, + tags = tags, + kind = dr ^. #kind } -- | Format list output — backward-compatible version without origin info. @@ -128,21 +130,21 @@ | null entries = -- With nothing to show, the kind comes from the active filter (if any). "No " - <> pluralize 0 (summaryNoun listOpts.filterKinds) + <> pluralize 0 (summaryNoun (listOpts ^. #kinds)) <> " found." <> filterSuffix <> "\n\nSearched:\n" <> T.unlines (map (" " <>) searchPaths) | otherwise = - let maxNameLen = maximum (map (T.length . (.entryName)) entries) - maxDescLen = maximum (map (T.length . (.entryDesc)) entries) + let maxNameLen = maximum (map (T.length . (^. #name)) entries) + maxDescLen = maximum (map (T.length . (^. #desc)) entries) header = "Available modules, recipes, blueprints, and prompts:\n" fileLines = map (formatEntry color maxNameLen maxDescLen) entries n = length entries nSources = length searchPaths -- The count noun reflects the kinds actually shown: a single shared -- kind names that kind; a mix falls back to the neutral "item". - noun = pluralize n (summaryNoun (map (.entryKind) entries)) + noun = pluralize n (summaryNoun (map (^. #kind) entries)) summary = T.pack (show n) <> " " @@ -181,10 +183,10 @@ formatFilterSuffix :: ListFilter -> Text formatFilterSuffix opts = let parts = - maybe [] (\r -> ["repo=" <> r]) opts.filterRepo - <> maybe [] (\t -> ["tag=" <> t]) opts.filterTag + maybe [] (\r -> ["repo=" <> r]) (opts ^. #repo) + <> maybe [] (\t -> ["tag=" <> t]) (opts ^. #tag) <> kindPart - kindPart = case opts.filterKinds of + kindPart = case opts ^. #kinds of [] -> [] ks -> ["kind=" <> T.intercalate "+" (map kindNoun ks)] in if null parts @@ -202,56 +204,56 @@ applyFilters opts = filter match where match entry = repoMatch entry && tagMatch entry && kindMatch entry - repoMatch entry = case opts.filterRepo of + repoMatch entry = case opts ^. #repo of Nothing -> True - Just r -> entry.entryRepoName == Just r - tagMatch entry = case opts.filterTag of + Just r -> entry ^. #repoName == Just r + tagMatch entry = case opts ^. #tag of Nothing -> True - Just t -> t `elem` entry.entryTags - kindMatch entry = case opts.filterKinds of + Just t -> t `elem` (entry ^. #tags) + kindMatch entry = case opts ^. #kinds of [] -> True - ks -> entry.entryKind `elem` ks + ks -> (entry ^. #kind) `elem` ks data Entry = Entry - { entryName :: Text, - entryDesc :: Text, - entrySource :: Text, - entryIsError :: Bool, - entryRepoName :: Maybe Text, - entryTags :: [Text], - entryKind :: RunnableKind + { name :: !Text, + desc :: !Text, + source :: !Text, + isError :: !Bool, + repoName :: !(Maybe Text), + tags :: ![Text], + kind :: !RunnableKind } - deriving stock (Eq, Show) + deriving stock (Eq, Generic, Show) toEntry :: DiscoveredModule -> Entry toEntry = toEntryWithOrigin Map.empty toEntryWithOrigin :: Map FilePath (Maybe OriginInfo) -> DiscoveredModule -> Entry toEntryWithOrigin origins dm = - let (originName, originVer, originTags) = case Map.lookup dm.discoveredDir origins of - Just (Just info) -> (info.originRepoName, info.originVersion, info.originTags) + let (originName, originVer, tags) = case Map.lookup (dm ^. #dir) origins of + Just (Just info) -> (info ^. #repoName, info ^. #version, info ^. #tags) _ -> (Nothing, Nothing, []) - srcLabel = sourceLabelWithOrigin dm.discoveredSource originName originVer - in case dm.discoveredResult of + srcLabel = sourceLabelWithOrigin (dm ^. #source) originName originVer + in case dm ^. #result of Right m -> Entry - { entryName = m.name.unModuleName, - entryDesc = maybe "(no description)" id m.description, - entrySource = srcLabel, - entryIsError = False, - entryRepoName = originName, - entryTags = originTags, - entryKind = KindModule + { name = m ^. #name . #unModuleName, + desc = maybe "(no description)" id (m ^. #description), + source = srcLabel, + isError = False, + repoName = originName, + tags = tags, + kind = KindModule } Left err -> Entry - { entryName = dirName dm.discoveredDir, - entryDesc = "[error: " <> briefError err <> "]", - entrySource = srcLabel, - entryIsError = True, - entryRepoName = originName, - entryTags = originTags, - entryKind = KindModule + { name = dirName (dm ^. #dir), + desc = "[error: " <> briefError err <> "]", + source = srcLabel, + isError = True, + repoName = originName, + tags = tags, + kind = KindModule } sourceLabelWithOrigin :: ModuleSource -> Maybe Text -> Maybe Text -> Text @@ -278,13 +280,13 @@ formatEntry :: Bool -> Int -> Int -> Entry -> Text formatEntry color maxNameLen maxDescLen entry = - let name = entry.entryName - desc = entry.entryDesc - src = entry.entrySource + let name = (entry ^. #name) + desc = (entry ^. #desc) + src = (entry ^. #source) paddedName = name <> T.replicate (maxNameLen - T.length name + 3) " " paddedDesc = desc <> T.replicate (maxDescLen - T.length desc + 3) " " srcTag = "(" <> src <> ")" - colorDesc = if color && entry.entryIsError then red desc else desc + colorDesc = if color && entry ^. #isError then red desc else desc colorSrc = if color then dim srcTag else srcTag colorPaddedDesc = colorDesc <> T.replicate (maxDescLen - T.length desc + 3) " " - in " " <> paddedName <> (if color && entry.entryIsError then colorPaddedDesc else paddedDesc) <> colorSrc + in " " <> paddedName <> (if color && entry ^. #isError then colorPaddedDesc else paddedDesc) <> colorSrc diff --git a/src/Seihou/CLI/Manifest.hs b/src/Seihou/CLI/Manifest.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/CLI/Manifest.hs @@ -0,0 +1,19 @@ +module Seihou.CLI.Manifest + ( ManifestCommand (..), + handleManifest, + ) +where + +import Seihou.CLI.ManifestUpgrade (ManifestUpgradeOpts, handleManifestUpgrade) +import Seihou.Prelude + +-- | Subcommand selector for the @seihou manifest@ group. Reserves space for +-- future operations on @.seihou\/manifest.json@ — inspection, repair — without +-- another CLI restructuring pass. +data ManifestCommand + = ManifestUpgrade ManifestUpgradeOpts + deriving stock (Eq, Show, Generic) + +-- | Dispatch the selected @manifest@ subcommand to its handler. +handleManifest :: ManifestCommand -> IO () +handleManifest (ManifestUpgrade opts) = handleManifestUpgrade opts diff --git a/src/Seihou/CLI/ManifestGuard.hs b/src/Seihou/CLI/ManifestGuard.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/CLI/ManifestGuard.hs @@ -0,0 +1,407 @@ +-- | Compare what @.seihou\/manifest.json@ records against what is actually +-- installed on this machine, before anything is generated. +-- +-- The manifest is checked into version control (see +-- docs\/adr\/0001-manifest-is-a-checked-in-machine-independent-artifact.md), +-- so the copy of a module a developer has locally is not necessarily the copy +-- the manifest describes. Without a check, a developer whose install cache +-- lags behind the manifest regenerates every file from the older module and +-- rewrites the manifest to name it — a silent regression that looks like an +-- ordinary diff in code review. +-- +-- This module answers "should we generate from what is here?". Answering +-- "where is it?" is 'Seihou.Core.ArtifactRef'. +-- +-- The comparison itself ('judgeArtifact') is pure so it can be tested without +-- a filesystem; 'checkAppliedArtifacts' is the IO shell that locates each +-- recorded artifact and reads its version and provenance. +module Seihou.CLI.ManifestGuard + ( -- * Verdicts + ArtifactVerdict (..), + ArtifactCheck (..), + judgeArtifact, + + -- * Checking a manifest against this machine + checkAppliedArtifacts, + checkAppliedArtifactsFor, + blockingChecks, + + -- * Rendering + formatGuardRefusal, + formatGuardOverride, + summarizeCheck, + ) +where + +import Data.Generics.Labels () +import Data.List (nubBy) +import Data.Maybe (fromMaybe) +import Data.Set qualified as Set +import Data.Text qualified as T +import Seihou.Core.ArtifactOriginDetect (detectArtifactOrigin) +import Seihou.Core.ArtifactRef + ( ArtifactRefError, + renderArtifactRefError, + resolveArtifactOrigin, + ) +import Seihou.Core.Types + ( AppliedModule (..), + ArtifactOrigin (..), + Manifest (..), + Module (..), + ModuleName (..), + ) +import Seihou.Core.Version (parseVersion) +import Seihou.Dhall.Eval (evalModuleFromFile) +import Seihou.Prelude + +-- ---------------------------------------------------------------------------- +-- Verdicts +-- ---------------------------------------------------------------------------- + +-- | What the guard concluded about one applied artifact. +data ArtifactVerdict + = -- | Local copy matches or is newer than what the manifest records, + -- and the origin agrees. Nothing to say. + ArtifactOk + | -- | Local copy is strictly older than the recorded version. + -- Fields: recorded version, local version. + ArtifactStale !Text !Text + | -- | A module of this name is installed, but from a different origin + -- than the manifest records. Fields: recorded origin, local origin. + ArtifactOriginMismatch !ArtifactOrigin !ArtifactOrigin + | -- | The recorded artifact is not installed on this machine at all. + ArtifactUnresolvable !ArtifactRefError + | -- | Either side has a version string that 'parseVersion' rejects, so + -- no ordering can be established. Fields: recorded, local. + ArtifactVersionIncomparable !(Maybe Text) !(Maybe Text) + | -- | The recorded origin carries no provenance seihou can check against + -- what was found, so identity cannot be verified. The version was + -- still compared and did not indicate a downgrade. + ArtifactUnverifiableOrigin + deriving stock (Eq, Show, Generic) + +-- | One artifact's guard result, ready for rendering. +-- +-- The recorded origin is carried alongside the verdict rather than inside +-- it: it is a property of the artifact that was checked, not of the +-- conclusion, and every rendered block wants it. +data ArtifactCheck = ArtifactCheck + { name :: !ModuleName, + origin :: !ArtifactOrigin, + verdict :: !ArtifactVerdict + } + deriving stock (Eq, Show, Generic) + +-- | How much the recorded origin and the origin of the copy found locally +-- agree. +data OriginRelation + = -- | Both sides carry provenance and it is the same provenance. + OriginMatches + | -- | Both sides carry provenance and it disagrees. + OriginDiffers + | -- | At least one side carries no provenance, so identity is unknowable. + OriginUnverifiable + deriving stock (Eq, Show) + +-- | Compare one recorded artifact against what was found locally. +-- +-- @recordedOrigin@ and @recordedVersion@ come from the manifest. +-- @localOrigin@ and @localVersion@ come from the artifact actually found on +-- this machine — the origin by reading @.seihou-origin.json@ beside it, the +-- version from its @module.dhall@. +-- +-- Identity is checked before version, because a differing origin URL means a +-- different module and its version number is not comparable to the recorded +-- one at all. When identity cannot be disproved but also cannot be confirmed, +-- the version comparison still runs: a version does come from the artifact +-- itself, so "older than recorded" is meaningful even when "the same module" +-- is not provable. +judgeArtifact :: + ArtifactOrigin -> + Maybe Text -> + ArtifactOrigin -> + Maybe Text -> + ArtifactVerdict +judgeArtifact recordedOrigin recordedVersion localOrigin localVersion = + case originRelation recordedOrigin localOrigin of + OriginDiffers -> ArtifactOriginMismatch recordedOrigin localOrigin + OriginMatches -> fromMaybe ArtifactOk versionVerdict + OriginUnverifiable -> fromMaybe ArtifactUnverifiableOrigin versionVerdict + where + versionVerdict = judgeVersion recordedVersion localVersion + +-- | The version half of the comparison. 'Nothing' means "nothing to report". +judgeVersion :: Maybe Text -> Maybe Text -> Maybe ArtifactVerdict +judgeVersion recorded@(Just rawRecorded) local@(Just rawLocal) + | Just parsedRecorded <- parseVersion rawRecorded, + Just parsedLocal <- parseVersion rawLocal = + if parsedLocal < parsedRecorded + then Just (ArtifactStale rawRecorded rawLocal) + else Nothing + | otherwise = Just (ArtifactVersionIncomparable recorded local) +judgeVersion recorded local = Just (ArtifactVersionIncomparable recorded local) + +-- | Decide how much the two origins agree. +-- +-- A 'RemoteOrigin' on both sides is the only case where identity can be +-- confirmed or refuted outright. A 'RemoteOrigin' recorded against a locally +-- discovered copy with no provenance (a personal module shadowing an installed +-- one) is honestly unverifiable rather than a mismatch — a developer who +-- deliberately shadows a module should not be told they have the wrong one. +-- A recorded 'ProjectOrigin' resolves against the project root and nowhere +-- else, so anything but the same project path is a genuine inconsistency. +originRelation :: ArtifactOrigin -> ArtifactOrigin -> OriginRelation +originRelation recorded local = case (recorded, local) of + (RemoteOrigin recordedUrl _ _, RemoteOrigin localUrl _ _) + | normalizeOriginUrl recordedUrl == normalizeOriginUrl localUrl -> OriginMatches + | otherwise -> OriginDiffers + (RemoteOrigin {}, _) -> OriginUnverifiable + (ProjectOrigin recordedPath, ProjectOrigin localPath) + | normalizeProjectPath recordedPath == normalizeProjectPath localPath -> OriginMatches + | otherwise -> OriginDiffers + (ProjectOrigin {}, _) -> OriginDiffers + (LocalOrigin {}, _) -> OriginUnverifiable + +-- | Reduce a git URL to a form two spellings of the same repository share. +-- +-- @https:\/\/host\/repo@, @https:\/\/host\/repo.git@ and +-- @https:\/\/host\/repo\/@ all name the same repository, and a manifest +-- written by a developer who typed one of them must not read as a different +-- module to a developer who typed another. +normalizeOriginUrl :: Text -> Text +normalizeOriginUrl = + dropTrailingSlashes . dropGitSuffix . dropTrailingSlashes . T.strip + where + dropTrailingSlashes = T.dropWhileEnd (== '/') + dropGitSuffix url = fromMaybe url (T.stripSuffix ".git" url) + +-- | Reduce a project-relative path to a comparable form. The manifest stores +-- these with forward slashes; @.\/@ prefixes and trailing slashes are noise. +normalizeProjectPath :: FilePath -> FilePath +normalizeProjectPath = + dropWhileEnd' (== '/') . dropDotPrefix . dropWhileEnd' (== '/') + where + dropDotPrefix path = fromMaybe path (stripPrefix' "./" path) + stripPrefix' prefix path = + if take (length prefix) path == prefix + then Just (drop (length prefix) path) + else Nothing + dropWhileEnd' p = reverse . dropWhile p . reverse + +-- ---------------------------------------------------------------------------- +-- Checking a manifest against this machine +-- ---------------------------------------------------------------------------- + +-- | Check every module recorded in the manifest against this machine. +-- +-- @projectRoot@ is the absolute directory holding @.seihou@. @searchPaths@ is +-- normally 'Seihou.Core.Module.defaultSearchPaths'. Returns one +-- 'ArtifactCheck' per distinct recorded module, in manifest order, +-- deduplicated by module name — two instances of the same module with +-- different parent variables resolve to the same directory and would produce +-- the same verdict twice. +checkAppliedArtifacts :: + FilePath -> + [FilePath] -> + Manifest -> + IO [ArtifactCheck] +checkAppliedArtifacts projectRoot searchPaths = + checkAppliedArtifactsFor projectRoot searchPaths Nothing + +-- | 'checkAppliedArtifacts' restricted to a subset of module names. +-- +-- 'Nothing' means "every applied module" and is what @seihou status@ wants. +-- @'Just' names@ keeps only modules whose name is in the set, which is what +-- @seihou run@ wants: a stale module unrelated to the composition being +-- generated must not block the run, exactly as +-- 'Seihou.CLI.PendingMigrations.detectPendingMigrations' already treats an +-- unrelated pending migration. +checkAppliedArtifactsFor :: + FilePath -> + [FilePath] -> + Maybe (Set ModuleName) -> + Manifest -> + IO [ArtifactCheck] +checkAppliedArtifactsFor projectRoot searchPaths mFilter manifest = + traverse checkOne (dedupeByName (filter wanted (manifest ^. #modules))) + where + wanted applied = case mFilter of + Nothing -> True + Just names -> Set.member (applied ^. #name) names + + dedupeByName = nubBy (\a b -> a ^. #name == b ^. #name) + + checkOne applied = do + let recordedOrigin = applied ^. #origin + resolved <- resolveArtifactOrigin projectRoot searchPaths "module.dhall" recordedOrigin + verdict <- case resolved of + Left refErr -> pure (ArtifactUnresolvable refErr) + Right directory -> do + localOrigin <- detectArtifactOrigin projectRoot directory + localVersion <- localModuleVersion directory + pure (judgeArtifact recordedOrigin (applied ^. #moduleVersion) localOrigin localVersion) + pure + ArtifactCheck + { name = applied ^. #name, + origin = recordedOrigin, + verdict = verdict + } + +-- | The version the locally installed @module.dhall@ declares. +-- +-- A module that does not evaluate yields 'Nothing', which becomes +-- 'ArtifactVersionIncomparable'. That is deliberate: a broken @module.dhall@ +-- is a separate problem, and the generation path reports it far better than +-- the guard could. +localModuleVersion :: FilePath -> IO (Maybe Text) +localModuleVersion directory = do + result <- evalModuleFromFile (directory "module.dhall") + pure $ case result of + Left _ -> Nothing + Right modul -> modul ^. #version + +-- | Whether any verdict is severe enough to stop the command. +-- +-- 'ArtifactStale', 'ArtifactOriginMismatch' and 'ArtifactUnresolvable' block: +-- each one means generating now would produce files from something other than +-- what the project records. 'ArtifactVersionIncomparable' and +-- 'ArtifactUnverifiableOrigin' are reported but never block, because neither +-- is evidence of a problem — only evidence that seihou cannot prove there +-- isn't one. +blockingChecks :: [ArtifactCheck] -> [ArtifactCheck] +blockingChecks = filter (isBlocking . (^. #verdict)) + where + isBlocking = \case + ArtifactStale {} -> True + ArtifactOriginMismatch {} -> True + ArtifactUnresolvable {} -> True + ArtifactOk -> False + ArtifactVersionIncomparable {} -> False + ArtifactUnverifiableOrigin -> False + +-- ---------------------------------------------------------------------------- +-- Rendering +-- ---------------------------------------------------------------------------- + +-- | Render blocking verdicts as the multi-line refusal message, one block per +-- artifact, followed by a paragraph naming the escape hatch. +formatGuardRefusal :: [ArtifactCheck] -> Text +formatGuardRefusal [] = "" +formatGuardRefusal checks = + T.intercalate "\n\n" (map (refusalBlock "✗ Refusing to run") checks) + <> "\n\n" + <> T.intercalate + "\n" + [ "To proceed anyway — pinning this project to what is installed here —", + "re-run with --allow-downgrade." + ] + <> "\n" + +-- | The same blocks, printed when @--allow-downgrade@ was passed. A +-- deliberate downgrade should still be visible in the terminal; silently +-- honouring the flag would hide exactly the change this module exists to +-- make legible. +formatGuardOverride :: [ArtifactCheck] -> Text +formatGuardOverride [] = "" +formatGuardOverride checks = + T.intercalate "\n\n" (map (refusalBlock "! Proceeding anyway (--allow-downgrade)") checks) <> "\n" + +-- | One artifact's block, under a caller-supplied lead-in. The lead-in +-- 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 + ArtifactStale recordedVersion localVersion -> + T.intercalate "\n" $ + [ leadIn <> ": your local copy of '" <> label <> "' is older than the", + " version this project expects.", + "", + " Recorded in .seihou/manifest.json: " <> recordedVersion, + " Installed on this machine: " <> localVersion + ] + <> originLine + <> [ "", + " Update your local copy first:", + " seihou upgrade " <> label + ] + ArtifactOriginMismatch recorded local -> + T.intercalate "\n" $ + [ leadIn <> ": '" <> label <> "' is installed from a different source", + " than this project records.", + "", + " Recorded in .seihou/manifest.json: " <> originDescription recorded, + " Installed on this machine: " <> originDescription local, + "", + " These are different artifacts that happen to share a name." + ] + <> case recorded of + RemoteOrigin url _ _ -> + [ " Install the one this project records:", + " seihou install " <> url + ] + _ -> [] + ArtifactUnresolvable refErr -> + leadIn <> ".\n\n" <> renderArtifactRefError refErr + ArtifactVersionIncomparable recorded local -> + T.intercalate + "\n" + [ "! '" <> label <> "' cannot be version-checked against this project.", + "", + " Recorded in .seihou/manifest.json: " <> describeVersion recorded, + " Installed on this machine: " <> describeVersion local + ] + ArtifactUnverifiableOrigin -> + T.intercalate + "\n" + [ "! '" <> label <> "' has no recorded provenance, so seihou cannot confirm", + " the copy installed here is the one this project was generated from." + ] + ArtifactOk -> "" + where + label = check ^. #name . #unModuleName + + originLine = case check ^. #origin of + RemoteOrigin url _ _ -> [" Origin: " <> url] + _ -> [] + + describeVersion = fromMaybe "(none recorded)" + +-- | A one-line summary of anything worth mentioning, for reporting commands +-- 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 + ArtifactOk -> Nothing + ArtifactStale recordedVersion localVersion -> + Just $ + label + <> ": this project expects " + <> recordedVersion + <> " but " + <> localVersion + <> " is installed here (run 'seihou upgrade " + <> label + <> "')" + ArtifactOriginMismatch recorded local -> + Just $ + label + <> ": this project records " + <> originDescription recorded + <> " but " + <> originDescription local + <> " is installed here" + ArtifactUnresolvable _ -> + Just (label <> ": recorded in the manifest but not installed on this machine") + ArtifactVersionIncomparable _ _ -> + Just (label <> ": versions cannot be compared, so staleness is unknown") + ArtifactUnverifiableOrigin -> + Just (label <> ": no recorded provenance, so its identity cannot be verified") + where + label = check ^. #name . #unModuleName + +-- | How to name an origin in a comparison line. +originDescription :: ArtifactOrigin -> Text +originDescription (RemoteOrigin url _ _) = url +originDescription (ProjectOrigin path) = T.pack path <> " (inside this project)" +originDescription (LocalOrigin artifact) = artifact <> " (no recorded provenance)" diff --git a/src/Seihou/CLI/ManifestUpgrade.hs b/src/Seihou/CLI/ManifestUpgrade.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/CLI/ManifestUpgrade.hs @@ -0,0 +1,659 @@ +-- | Convert a @.seihou\/manifest.json@ written before schema version 6 into +-- the portable form every current command expects. +-- +-- 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@. +-- That string is meaningless in any other clone, which is why +-- docs\/adr\/0001-manifest-is-a-checked-in-machine-independent-artifact.md +-- forbids it and why +-- 'Seihou.Manifest.Types.checkManifestVersion' refuses such a manifest +-- outright rather than misreading it. +-- +-- This module turns those paths into 'ArtifactOrigin' values. Doing so +-- requires inference — the recorded path belongs to somebody else's machine, +-- so the upstream URL has to be recovered from what is installed here — and +-- inference that happens silently inside a file that is committed to git is +-- exactly what this initiative exists to remove. So the conversion is an +-- explicit command with a printed report rather than an automatic upgrade on +-- first read, and every entry says how confident it is. +-- +-- The document is manipulated as an 'Aeson.Value' rather than decoded into +-- mirror records. The upgrade only needs to find three keys and replace them; +-- every other field — resolved variables, file records, baseline references, +-- command receipts, blueprint migration receipts — must survive untouched, +-- and walking the 'Aeson.Value' guarantees that where decode-and-re-encode +-- would risk dropping a key some later schema version added. +module Seihou.CLI.ManifestUpgrade + ( -- * Reading a legacy manifest + LegacyRef (..), + LegacyManifest (..), + readLegacyManifest, + + -- * Inferring a portable origin + InferenceOutcome (..), + inferredOrigin, + inferOriginFromLegacyPath, + + -- * Rewriting the document + UpgradeReportEntry (..), + UpgradeResult (..), + applyUpgrade, + formatUpgradeReport, + + -- * The command + ManifestUpgradeOpts (..), + UpgradeOutcome (..), + manifestRelativePath, + formatUpgradeRefusal, + runManifestUpgrade, + handleManifestUpgrade, + ) +where + +import Control.Monad (unless) +import Data.Aeson qualified as Aeson +import Data.Aeson.Key (Key) +import Data.Aeson.Key qualified as Key +import Data.Aeson.KeyMap qualified as KeyMap +import Data.ByteString.Lazy qualified as LBS +import Data.Foldable (toList) +import Data.Generics.Labels () +import Data.List (foldl') +import Data.Text qualified as T +import Data.Text.IO qualified as TIO +import Data.Vector qualified as V +import Seihou.CLI.ManifestGuard + ( ArtifactCheck, + blockingChecks, + checkAppliedArtifacts, + summarizeCheck, + ) +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.Prelude +import System.Directory (doesFileExist, getCurrentDirectory, renamePath) +import System.Exit (exitFailure) +import Text.Read (readMaybe) + +-- ---------------------------------------------------------------------------- +-- Reading a legacy manifest +-- ---------------------------------------------------------------------------- + +-- | One legacy artifact reference found in a schema-5-or-earlier manifest. +-- +-- @jsonPointer@ locates the reference inside the document so the rewriter can +-- put the converted origin back in the right place, and so the report can say +-- which record it came from. It is a list of object keys and array indices +-- ending in the key that holds the path, for example +-- @["modules", "0", "source"]@ or +-- @["applications", "0", "instances", "1", "source"]@. +-- +-- @definitionFile@ is the file that must be present for a directory to count +-- as this artifact — @module.dhall@ for a module, @recipe.dhall@ for an +-- application whose target is a recipe. Inference needs it because it looks +-- the artifact up by name in the local search paths. +data LegacyRef = LegacyRef + { jsonPointer :: ![Text], + artifactName :: !Text, + legacyPath :: !FilePath, + recordedVersion :: !(Maybe Text), + definitionFile :: !FilePath + } + deriving stock (Eq, Show, Generic) + +-- | Every legacy reference in a document, together with the document itself +-- so the rewriter can operate on it directly. +data LegacyManifest = LegacyManifest + { schemaVersion :: !Int, + document :: !Aeson.Value, + refs :: ![LegacyRef] + } + deriving stock (Eq, Show, Generic) + +-- | Parse a manifest document that has not yet been upgraded. +-- +-- 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. +readLegacyManifest :: LBS.ByteString -> Either String (Maybe LegacyManifest) +readLegacyManifest bytes = do + value <- Aeson.eitherDecode bytes + fields <- case value of + Aeson.Object fields -> Right fields + _ -> Left "manifest is not a JSON object" + schemaVersion <- case KeyMap.lookup "version" fields of + Just (Aeson.Number n) -> Right (truncate n :: Int) + Just _ -> Left "manifest 'version' is not a number" + Nothing -> Left "manifest has no 'version' field" + pure $ + if schemaVersion >= currentManifestVersion + then Nothing + else + Just + LegacyManifest + { schemaVersion = schemaVersion, + document = value, + refs = collectRefs value + } + +-- | Every machine-specific path recorded in a legacy document, in the order a +-- reader meets them. +-- +-- Three keys hold such a path: @source@ inside each entry of @modules@, +-- @targetSource@ on each application, and @source@ inside each of an +-- application's @instances@. Everything else in the format is already +-- portable. +collectRefs :: Aeson.Value -> [LegacyRef] +collectRefs value = + concatMap moduleRef (withIndices (arrayAt value "modules")) + <> concatMap applicationRefs (withIndices (arrayAt value "applications")) + where + moduleRef (index, element) = + mkRef + ["modules", index, "source"] + "module.dhall" + (textAt element "name") + (textAt element "source") + (textAt element "version") + + applicationRefs (index, element) = + mkRef + ["applications", index, "targetSource"] + (targetDefinitionFile element) + (objectAt element "target" >>= \target -> textAt target "name") + (textAt element "targetSource") + (textAt element "targetVersion") + <> concatMap (instanceRef index) (withIndices (arrayAt element "instances")) + + instanceRef applicationIndex (index, element) = + mkRef + ["applications", applicationIndex, "instances", index, "source"] + "module.dhall" + (textAt element "name") + (textAt element "source") + (textAt element "version") + +-- | An application's target is either a module or a recipe, and the two are +-- discovered by different definition files. +targetDefinitionFile :: Aeson.Value -> FilePath +targetDefinitionFile application = + case objectAt application "target" >>= \target -> textAt target "kind" of + Just "recipe" -> "recipe.dhall" + _ -> "module.dhall" + +-- | Build a reference, or nothing when the record lacks a name or a path. +-- +-- A record with no @source@ is not an error: a hand-edited manifest, or a +-- record a future field made optional, simply has nothing to convert. +mkRef :: + [Text] -> + FilePath -> + Maybe Text -> + Maybe Text -> + Maybe Text -> + [LegacyRef] +mkRef pointer definitionFile mName mSource mVersion = + case (mName, mSource) of + (Just name, Just source) -> + [ LegacyRef + { jsonPointer = pointer, + artifactName = name, + legacyPath = T.unpack source, + recordedVersion = mVersion, + definitionFile = definitionFile + } + ] + _ -> [] + +-- ---------------------------------------------------------------------------- +-- Inferring a portable origin +-- ---------------------------------------------------------------------------- + +-- | How confident the upgrade is about a converted origin. +-- +-- The distinction is not decoration: it is what the printed report shows the +-- developer, and it is the difference between a manifest entry that names its +-- upstream and one that admits it cannot. +data InferenceOutcome + = -- | The artifact resolved locally and its install metadata gave a URL. + -- Strongest result. + InferredFromLocalInstall !ArtifactOrigin + | -- | The legacy path names a directory inside the project, so it converts + -- to a 'ProjectOrigin' by path arithmetic alone. Exact rather than + -- inferred: a project-relative path means the same thing in every clone. + InferredFromProjectPath !ArtifactOrigin + | -- | Nothing local matched, or what matched carries no provenance; fell + -- back to 'LocalOrigin' with only the recorded name. The developer can + -- improve this by reinstalling from the real upstream and re-running the + -- upgrade. + InferredAsUnverifiable !ArtifactOrigin + deriving stock (Eq, Show, Generic) + +-- | The converted origin, whatever the confidence. +inferredOrigin :: InferenceOutcome -> ArtifactOrigin +inferredOrigin (InferredFromLocalInstall origin) = origin +inferredOrigin (InferredFromProjectPath origin) = origin +inferredOrigin (InferredAsUnverifiable origin) = origin + +-- | Convert one legacy reference into a portable origin. +-- +-- @projectRoot@ is the absolute directory holding @.seihou@. @searchPaths@ is +-- normally 'Seihou.Core.Module.defaultSearchPaths'. +-- +-- Inference proceeds in three steps. +-- +-- First, path arithmetic that needs no local state. The recorded path was +-- written by another machine, so its project-root prefix is that machine's +-- checkout, not this one — which is why the test is on the /suffix/: a path +-- ending in @.seihou\/modules\/\@ names a project-local artifact in +-- every clone. Containment inside this machine's project root is checked +-- second, as confirmation, for a layout the suffix test does not recognise. +-- +-- Second, a local lookup by name through @searchPaths@, which is exactly what +-- 'Seihou.Core.ArtifactRef.resolveArtifactOrigin' does for a 'LocalOrigin'. +-- What is found is classified by 'detectArtifactOrigin', so an installed copy +-- with a @.seihou-origin.json@ yields the upstream URL the legacy path had +-- thrown away. +-- +-- Third, 'LocalOrigin' carrying only the recorded name — the honest +-- representation of "this came from somewhere on that developer's machine and +-- we cannot say where". +inferOriginFromLegacyPath :: + FilePath -> + [FilePath] -> + LegacyRef -> + IO InferenceOutcome +inferOriginFromLegacyPath projectRoot searchPaths ref = + case projectModuleSuffix (ref ^. #legacyPath) of + Just relative -> pure (InferredFromProjectPath (ProjectOrigin relative)) + Nothing -> do + recorded <- detectArtifactOrigin projectRoot (ref ^. #legacyPath) + case recorded of + ProjectOrigin _ -> pure (InferredFromProjectPath recorded) + _ -> fromLocalLookup + where + name = ref ^. #artifactName + + fromLocalLookup = do + resolved <- + resolveArtifactOrigin + projectRoot + searchPaths + (ref ^. #definitionFile) + (LocalOrigin name) + case resolved of + Left _ -> pure (InferredAsUnverifiable (LocalOrigin name)) + Right directory -> do + found <- detectArtifactOrigin projectRoot directory + pure $ case found of + RemoteOrigin {} -> InferredFromLocalInstall found + ProjectOrigin {} -> InferredFromProjectPath found + LocalOrigin {} -> InferredAsUnverifiable found + +-- | The project-relative form of a legacy path that names an artifact under +-- @.seihou\/modules\/@, whichever machine's checkout it was written on. +projectModuleSuffix :: FilePath -> Maybe FilePath +projectModuleSuffix path = case reverse (pathSegments path) of + (name : "modules" : ".seihou" : _) -> Just (".seihou/modules/" <> name) + _ -> Nothing + +-- | Whether a legacy path has the shape of an entry in the install cache, +-- @\\/seihou\/installed\/\@. +-- +-- A path with that shape says the original author had the artifact installed +-- from an upstream, so when inference still falls back to 'LocalOrigin' the +-- report can say the URL was lost rather than that there never was one. +legacyPathWasInstalled :: FilePath -> Bool +legacyPathWasInstalled path = case reverse (pathSegments path) of + (_ : "installed" : "seihou" : _) -> True + _ -> False + +-- | Split a recorded path into its segments, tolerating either separator: the +-- path may have been written by a machine that is not this one. +pathSegments :: FilePath -> [FilePath] +pathSegments = filter (not . null) . foldr split [[]] + where + split character segments@(current : rest) + | character == '/' || character == '\\' = [] : segments + | otherwise = (character : current) : rest + split _ [] = [] + +-- ---------------------------------------------------------------------------- +-- Rewriting the document +-- ---------------------------------------------------------------------------- + +-- | One line of the upgrade report. +data UpgradeReportEntry = UpgradeReportEntry + { artifactName :: !Text, + legacyPath :: !FilePath, + outcome :: !InferenceOutcome + } + deriving stock (Eq, Show, Generic) + +-- | An upgraded document plus the reviewable account of how it was reached. +data UpgradeResult = UpgradeResult + { fromVersion :: !Int, + entries :: ![UpgradeReportEntry], + 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. +applyUpgrade :: LegacyManifest -> [(LegacyRef, InferenceOutcome)] -> UpgradeResult +applyUpgrade legacy conversions = + UpgradeResult + { fromVersion = legacy ^. #schemaVersion, + entries = dedupeEntries (map reportEntry conversions), + upgradedDocument = setSchemaVersion (foldl' rewrite (legacy ^. #document) conversions) + } + where + rewrite document (ref, outcome) = + replaceAt (ref ^. #jsonPointer) (Aeson.toJSON (inferredOrigin outcome)) document + + reportEntry (ref, outcome) = + UpgradeReportEntry + { artifactName = ref ^. #artifactName, + legacyPath = ref ^. #legacyPath, + outcome = outcome + } + +-- | One line per distinct artifact-and-path pair, in first-seen order. +-- +-- The same module typically appears three times — once in @modules@, once as +-- an application's target, once as an instance — and the report should show it +-- once. Two records naming the same artifact at /different/ paths stay +-- separate, because that is a real thing the developer should see. +dedupeEntries :: [UpgradeReportEntry] -> [UpgradeReportEntry] +dedupeEntries = go [] + where + go _ [] = [] + go seen (entry : rest) + | key entry `elem` seen = go seen rest + | otherwise = entry : go (key entry : seen) rest + + key entry = (entry ^. #artifactName, entry ^. #legacyPath) + +-- | Replace the key at the end of a pointer with its portable counterpart. +replaceAt :: [Text] -> Aeson.Value -> Aeson.Value -> Aeson.Value +replaceAt [] _ document = document +replaceAt pointer origin document = + updateAt (init pointer) (renameKey (last pointer)) document + where + renameKey legacyKey (Aeson.Object fields) = + Aeson.Object + ( KeyMap.insert + (Key.fromText (portableKey legacyKey)) + origin + (KeyMap.delete (Key.fromText legacyKey) fields) + ) + renameKey _ other = other + +-- | The schema-6 name of a key that used to hold an absolute path. +portableKey :: Text -> Text +portableKey "source" = "origin" +portableKey "targetSource" = "targetOrigin" +portableKey other = other + +-- | Apply a function to the value a pointer names, leaving the document +-- unchanged when the pointer does not lead anywhere. +updateAt :: [Text] -> (Aeson.Value -> Aeson.Value) -> Aeson.Value -> Aeson.Value +updateAt [] f value = f value +updateAt (step : rest) f value = case value of + Aeson.Object fields -> + let name = Key.fromText step + in case KeyMap.lookup name fields of + Just child -> Aeson.Object (KeyMap.insert name (updateAt rest f child) fields) + Nothing -> value + Aeson.Array elements -> + case readMaybe (T.unpack step) of + Just index + | index >= 0 && index < V.length elements -> + Aeson.Array (elements V.// [(index, updateAt rest f (elements V.! index))]) + _ -> 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 +-- line — whether the file was written is the caller's news to deliver. +formatUpgradeReport :: UpgradeResult -> Text +formatUpgradeReport result = + T.unlines (header : "" : concatMap entryLines (result ^. #entries)) + where + header = + "Reading " + <> T.pack manifestRelativePath + <> " (schema version " + <> T.pack (show (result ^. #fromVersion)) + <> ")" + + nameColumn = + maximum (5 : map (T.length . (^. #artifactName)) (result ^. #entries)) + 5 + + entryLines entry = + [ " " <> T.justifyLeft nameColumn ' ' (entry ^. #artifactName) <> T.pack (entry ^. #legacyPath), + T.replicate (nameColumn - 1) " " <> "→ " <> describeOutcome (entry ^. #outcome) + ] + <> map (\note -> T.replicate (nameColumn + 2) " " <> note) (outcomeNotes entry) + <> [""] + + describeOutcome outcome = case inferredOrigin outcome of + RemoteOrigin url _ _ -> "remote " <> url + ProjectOrigin path -> "project " <> T.pack path + LocalOrigin name -> "local " <> name <> " (no upstream recorded)" + + outcomeNotes entry = case entry ^. #outcome of + InferredAsUnverifiable _ + | legacyPathWasInstalled (entry ^. #legacyPath) -> + [ "was installed from an upstream on the original machine, but no", + "local copy is available here to recover the URL" + ] + _ -> [] + +-- ---------------------------------------------------------------------------- +-- The command +-- ---------------------------------------------------------------------------- + +-- | Where a project's manifest lives, relative to the project root. Also the +-- name the report prints, so the two can never drift apart. +manifestRelativePath :: FilePath +manifestRelativePath = ".seihou" "manifest.json" + +-- | Flags parsed for @seihou manifest upgrade@. +data ManifestUpgradeOpts = ManifestUpgradeOpts + { dryRun :: !Bool, + -- | 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 + } + 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 + -- check that would have blocked a real write. + UpgradeWouldWrite UpgradeResult ![ArtifactCheck] + | -- | The converted 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. + 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. +runManifestUpgrade :: ManifestUpgradeOpts -> IO UpgradeOutcome +runManifestUpgrade opts = do + projectRoot <- getCurrentDirectory + let manifestPath = projectRoot manifestRelativePath + present <- doesFileExist manifestPath + if not present + then + pure + ( UpgradeFailed + ( "No " + <> T.pack manifestRelativePath + <> " here. Run this from the root of a project seihou has generated into." + ) + ) + else do + bytes <- LBS.readFile manifestPath + case readLegacyManifest bytes 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) + +-- | 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 + Aeson.Error err -> + Left + ( "The converted 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 + ) + Aeson.Success manifest -> Right manifest + +-- | Write the converted document, atomically. +-- +-- The bytes are the rewritten 'Aeson.Value' rather than a re-encoded +-- 'Manifest', so any field this build does not know about survives the round +-- trip. That rules out reusing 'Seihou.Effect.ManifestStore.writeManifest', +-- which encodes a typed manifest, so the write-to-temp-then-rename it performs +-- is replicated here. +writeDocument :: FilePath -> Aeson.Value -> IO () +writeDocument manifestPath document = do + let temporaryPath = manifestPath <> ".tmp" + LBS.writeFile temporaryPath (Aeson.encode document) + renamePath temporaryPath manifestPath + +-- | Explain why an upgrade this machine cannot satisfy was not written. +-- +-- The blocking verdicts are the guard's, but the remedy is this command's, so +-- the wording is here rather than reusing +-- 'Seihou.CLI.ManifestGuard.formatGuardRefusal' — that one ends by naming +-- @--allow-downgrade@, which is a flag on @seihou run@ and @seihou migrate@, +-- not on this command. +formatUpgradeRefusal :: Text -> [ArtifactCheck] -> Text +formatUpgradeRefusal leadIn checks = + T.unlines $ + [leadIn, ""] + <> [" " <> summary | Just summary <- map summarizeCheck checks] + <> [ "", + "Upgrading now would record what this machine can see rather than what", + "the project uses: an artifact that is missing or stale here converts to", + "an origin seihou had to guess at, and that guess would be committed.", + "", + "Install or upgrade the artifacts above and run this again, or re-run", + "with --force to accept the conversions exactly as shown." + ] + +-- | Print the outcome and exit non-zero on failure. +handleManifestUpgrade :: ManifestUpgradeOpts -> IO () +handleManifestUpgrade opts = do + outcome <- runManifestUpgrade opts + 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 + +-- ---------------------------------------------------------------------------- +-- Small JSON accessors +-- ---------------------------------------------------------------------------- + +-- | Pair every element of a list with its index, rendered as the text an +-- array position takes inside a pointer. +withIndices :: [a] -> [(Text, a)] +withIndices = zip (map (T.pack . show) [(0 :: Int) ..]) + +objectAt :: Aeson.Value -> Key -> Maybe Aeson.Value +objectAt (Aeson.Object fields) name = KeyMap.lookup name fields +objectAt _ _ = Nothing + +textAt :: Aeson.Value -> Key -> Maybe Text +textAt value name = case objectAt value name of + Just (Aeson.String text) -> Just text + _ -> Nothing + +arrayAt :: Aeson.Value -> Key -> [Aeson.Value] +arrayAt value name = case objectAt value name of + Just (Aeson.Array elements) -> toList elements + _ -> [] diff --git a/src/Seihou/CLI/Migrate.hs b/src/Seihou/CLI/Migrate.hs --- a/src/Seihou/CLI/Migrate.hs +++ b/src/Seihou/CLI/Migrate.hs @@ -21,12 +21,13 @@ import Data.Aeson qualified as Aeson import Data.Aeson.Encode.Pretty (encodePretty) import Data.ByteString.Lazy.Char8 qualified as LBS +import Data.Generics.Labels () import Data.Maybe (isJust) +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 Effectful (runEff) -import GHC.Generics (Generic) import Seihou.CLI.CommitMessage (generateCommitMessage) import Seihou.CLI.Git (gitAdd, gitCheckIgnore, gitCommit, gitDiffCached, isGitRepo) import Seihou.CLI.InstallShared @@ -35,7 +36,16 @@ installModuleDir, readOriginInfo, ) +import Seihou.CLI.ManifestGuard + ( ArtifactCheck, + blockingChecks, + checkAppliedArtifactsFor, + formatGuardOverride, + formatGuardRefusal, + ) +import Seihou.CLI.Shared (resolveAppliedArtifactDir) import Seihou.CLI.Style (bold, dim, green, red, useColor, yellow) +import Seihou.Core.ArtifactRef (ArtifactRefError, renderArtifactRefError) import Seihou.Core.Migration ( Migration (..), MigrationOp (..), @@ -43,6 +53,7 @@ MigrationPlanError (..), planMigrationChain, ) +import Seihou.Core.Module (defaultSearchPaths) import Seihou.Core.Registry ( Registry (..), RegistryEntry (..), @@ -70,7 +81,7 @@ executeMigration, ) import Seihou.Prelude -import System.Directory (doesFileExist) +import System.Directory (doesFileExist, getCurrentDirectory) import System.Exit (ExitCode (..), exitFailure, exitSuccess) import System.FilePath (takeFileName, ()) import System.IO (stderr) @@ -83,27 +94,27 @@ -- | Options for @seihou migrate@: applies module-declared migrations to -- the current project's working tree and manifest. data MigrateOpts = MigrateOpts - { migrateModule :: ModuleName, + { module_ :: !ModuleName, -- | Override the target version. Defaults to the installed -- module's current version (i.e. "migrate up to where the -- installed copy is now"). Under the gap-tolerant planner, the -- target is just the manifest's landing version: every declared -- migration whose @to@ does not exceed the target is applied, -- and the manifest advances to the target on success. - migrateTo :: Maybe Text, - migrateDryRun :: Bool, + to :: !(Maybe Text), + dryRun :: !Bool, -- | Proceed even when the plan touches files the user has edited -- since they were generated. Mirrors @seihou remove --force@. - migrateForce :: Bool, - migrateJson :: Bool, - migrateVerbose :: Bool, + force :: !Bool, + json :: !Bool, + verbose :: !Bool, -- | Skip the default fetch-and-refresh step that clones the module's -- source repo and refreshes @~/.config/seihou/installed//@ -- before planning the chain. When 'True', the command performs no -- network IO and uses only the locally installed copy as the source -- of truth. Default: 'False' (fetch is the new default after EP-2; -- before EP-2 the only behavior was local-only). - migrateNoFetch :: Bool, + noFetch :: !Bool, -- | When 'True', and only on success branches that mutated the -- project's working tree, stage the touched files plus -- @.seihou/manifest.json@ and create a git commit. The commit @@ -111,10 +122,23 @@ -- generated by 'Seihou.CLI.CommitMessage.generateCommitMessage'. -- Has no effect for dry-run or no-op outcomes. Has no effect -- outside a git work tree. - migrateCommit :: Bool, - -- | Custom commit message; implies @migrateCommit = True@. + commit :: !Bool, + -- | Custom commit message; implies @commit = True@. -- When 'Nothing', the AI-generated message is used. - migrateCommitMessage :: Maybe Text + commitMessage :: !(Maybe Text), + -- | When 'True', plan a migration even though the copy of the module + -- installed on this machine is older than the version + -- @.seihou\/manifest.json@ records, or came from a different origin + -- than it records. When 'False' (the default), 'handleMigrate' + -- refuses before planning. A stale copy is especially damaging here: + -- the chain is computed from the local module's declared migration + -- list, so an older copy produces a chain that stops short of where + -- the project already is. + -- + -- Only 'handleMigrate' consults this. 'runMigrate' is the guard-free + -- core that @seihou run --with-migrations@ and @seihou upgrade@ call + -- once they have done their own checking. + allowDowngrade :: !Bool } deriving stock (Eq, Show, Generic) @@ -136,6 +160,13 @@ | MigrateUnparseableManifestVersion Text | MigratePlanFailed MigrationPlanError | MigrateExecFailed MigrationExecError + | -- | The manifest records the module, but its recorded origin does not + -- resolve to anything on this machine. + MigrateArtifactUnresolved ArtifactRefError + | -- | The copy of the module installed here is older than, or came from + -- somewhere other than, what the manifest records. Carries the blocking + -- checks, rendered by 'formatGuardRefusal'. + MigrateArtifactGuardFailed [ArtifactCheck] deriving stock (Eq, Show, Generic) -- | Outcome of a successful @runMigrate@ call. @@ -166,7 +197,7 @@ handleMigrate :: MigrateOpts -> IO () handleMigrate opts = do let manifestPath = ".seihou" "manifest.json" - modName = opts.migrateModule + modName = (opts ^. #module_) manifestRes <- runEff $ runFilesystem $ runManifestStore manifestPath readManifest manifest <- case manifestRes of @@ -178,14 +209,34 @@ Nothing -> die (MigrateModuleNotApplied modName) Just am -> pure am - _fromV <- case applied.moduleVersion >>= parseVersion of + _fromV <- case applied ^. #moduleVersion >>= parseVersion of Just v -> pure v - Nothing -> case applied.moduleVersion of + Nothing -> case applied ^. #moduleVersion of Nothing -> die (MigrateNoRecordedVersion modName) Just t -> die (MigrateUnparseableManifestVersion t) - result <- runMigrate opts manifest applied.source + -- Refuse before planning if the copy installed here is not the copy the + -- manifest describes. A stale local copy is especially damaging to a + -- migration: the chain is computed from the local module's declared + -- migration list, so an older copy yields a chain that stops short of where + -- the project already is, and the manifest would be rewound to match. + projectRoot <- getCurrentDirectory + searchPaths <- defaultSearchPaths + guardChecks <- + checkAppliedArtifactsFor projectRoot searchPaths (Just (Set.singleton modName)) manifest + case blockingChecks guardChecks of + [] -> pure () + blocking + | opts ^. #allowDowngrade -> TIO.putStr (formatGuardOverride blocking) + | otherwise -> die (MigrateArtifactGuardFailed blocking) + -- The manifest records a portable origin, never a path, so the module has + -- to be located on this machine before it can be re-read. + resolved <- resolveAppliedArtifactDir "module.dhall" (applied ^. #origin) + installedDir <- either (die . MigrateArtifactUnresolved) pure resolved + + result <- runMigrate opts manifest installedDir + colorEnabled <- useColor case result of Left err -> die err @@ -193,13 +244,13 @@ TIO.putStrLn $ applyColor colorEnabled green "✓" <> " " - <> modName.unModuleName + <> modName ^. #unModuleName <> " is already at version " <> renderVersion toV <> "; nothing to do." exitSuccess Right (MigrateDryRunOK plan fromV toV) -> do - if opts.migrateJson + if opts ^. #json then LBS.putStr (encodePretty (planToJson plan)) else do renderPlan colorEnabled plan fromV toV @@ -207,21 +258,21 @@ TIO.putStrLn $ applyColor colorEnabled dim "(dry run — no changes made)" exitSuccess Right (MigrateApplied plan manifest' fromV toV) -> do - if opts.migrateJson + if opts ^. #json then LBS.putStr (encodePretty (planToJson plan)) else renderPlan colorEnabled plan fromV toV runEff $ runFilesystem $ runManifestStore manifestPath $ writeManifest manifest' - when (opts.migrateCommit || isJust opts.migrateCommitMessage) $ + when (opts ^. #commit || isJust (opts ^. #commitMessage)) $ commitMigratedFiles opts manifestPath plan - unless opts.migrateJson $ do + unless (opts ^. #json) $ do TIO.putStrLn "" TIO.putStrLn $ applyColor colorEnabled green "✓" <> " Migrated " - <> applyColor colorEnabled bold modName.unModuleName + <> applyColor colorEnabled bold (modName ^. #unModuleName) <> " " <> renderVersion fromV <> " → " @@ -232,7 +283,7 @@ -- other CLI surfaces (e.g. @seihou upgrade --with-migrations@) that -- already have a manifest and an installed-module dir in hand. -- --- Behavior depends on @opts.migrateNoFetch@: +-- Behavior depends on @opts.noFetch@: -- -- * @True@ — operate purely on the supplied @installedDir@. This is -- the legacy behavior used by @seihou upgrade --with-migrations@, @@ -251,7 +302,7 @@ FilePath -> IO (Either MigrateError MigrateResult) runMigrate opts manifest installedDir - | opts.migrateNoFetch = runMigrateLocal opts manifest installedDir + | (opts ^. #noFetch) = runMigrateLocal opts manifest installedDir | otherwise = runMigrateWithFetch opts manifest installedDir -- | Plan and (optionally) execute a migration chain using @sourceDir@ @@ -265,10 +316,10 @@ FilePath -> IO (Either MigrateError MigrateResult) runMigrateLocal opts manifest sourceDir = do - let modName = opts.migrateModule + let modName = (opts ^. #module_) case findApplied manifest modName of Nothing -> pure (Left (MigrateModuleNotApplied modName)) - Just applied -> case applied.moduleVersion of + Just applied -> case applied ^. #moduleVersion of Nothing -> pure (Left (MigrateNoRecordedVersion modName)) Just fromText -> case parseVersion fromText of @@ -300,8 +351,8 @@ Left e -> pure (Left e) Right toV -> case planMigrationChain - modName.unModuleName - sourceModule.migrations + (modName ^. #unModuleName) + (sourceModule ^. #migrations) fromV toV of Left e -> pure (Left (MigratePlanFailed e)) @@ -337,19 +388,19 @@ runMigrateLocal opts manifest installedDir Just o -> withSystemTempDirectory "seihou-migrate-fetch" $ \tmp -> do let cloneDir = tmp "clone" - note opts (" Fetching " <> o.sourceUrl <> "...") - cloneRes <- cloneRepo o.sourceUrl cloneDir + note opts (" Fetching " <> o ^. #sourceUrl <> "...") + cloneRes <- cloneRepo (o ^. #sourceUrl) cloneDir case cloneRes of Left err -> do note opts (" fetch failed: " <> err <> "; using locally installed copy.") runMigrateLocal opts manifest installedDir Right () -> do contents <- discoverRepoContents evalRegistryFromFile cloneDir - case findRemoteModuleDir cloneDir contents opts.migrateModule of + case findRemoteModuleDir cloneDir contents (opts ^. #module_) of Nothing -> do note opts $ " module '" - <> opts.migrateModule.unModuleName + <> opts ^. #module_ . #unModuleName <> "' not present in remote; using locally installed copy." runMigrateLocal opts manifest installedDir Just (moduleDir, tags) -> do @@ -370,7 +421,7 @@ -- and no-op outcomes leave it untouched. case result of Right (MigrateApplied {}) - | not opts.migrateDryRun -> + | not (opts ^. #dryRun) -> refreshInstalledFromClone moduleDir installedDir o tags _ -> pure () pure result @@ -400,13 +451,13 @@ resultStepCount :: MigrateResult -> Int resultStepCount = \case MigrateNoOp {} -> 0 - MigrateApplied execPlan _ _ _ -> length execPlan.planSource.planSteps - MigrateDryRunOK execPlan _ _ -> length execPlan.planSource.planSteps + MigrateApplied execPlan _ _ _ -> length (execPlan ^. #source . #steps) + MigrateDryRunOK execPlan _ _ -> length (execPlan ^. #source . #steps) -- | Print a one-line note unless JSON output is requested. Using JSON -- output requires a clean, parseable stdout. note :: MigrateOpts -> Text -> IO () -note opts msg = unless opts.migrateJson (TIO.putStrLn msg) +note opts msg = unless (opts ^. #json) (TIO.putStrLn msg) -- | Locate the module's directory inside a cloned repo and return any -- registry-declared tags. Returns 'Nothing' for empty repos or @@ -420,8 +471,8 @@ findRemoteModuleDir cloneDir contents modName = case contents of SingleModule rootDir -> Just (rootDir, []) MultiModule registry -> - case filter (\e -> e.name == modName) registry.modules of - (entry : _) -> Just (cloneDir entry.path, entry.tags) + case filter (\e -> e ^. #name == modName) (registry ^. #modules) of + (entry : _) -> Just (cloneDir entry ^. #path, entry ^. #tags) [] -> Nothing SingleRecipe _ -> Nothing SingleBlueprint _ -> Nothing @@ -449,9 +500,9 @@ installModuleDir moduleDir installedName - origin.sourceUrl - origin.repoName - modul.version + (origin ^. #sourceUrl) + (origin ^. #repoName) + (modul ^. #version) tags -- ---------------------------------------------------------------------------- @@ -476,13 +527,13 @@ Module -> Maybe MigrationPlan pendingChainFor applied installed = do - fromText <- applied.moduleVersion + fromText <- (applied ^. #moduleVersion) fromV <- parseVersion fromText - toText <- installed.version + toText <- (installed ^. #version) toV <- parseVersion toText case planMigrationChain - applied.name.unModuleName - installed.migrations + (applied ^. #name . #unModuleName) + (installed ^. #migrations) fromV toV of Right (Just plan) -> Just plan @@ -498,8 +549,8 @@ -- print. -- -- The plan from the gap-tolerant walker is always one shape — an --- ordered list of in-window migrations plus the supplied @planFrom@ --- and @planTo@. The dispatcher branches only on @planFrom == planTo@ +-- ordered list of in-window migrations plus the supplied @from@ +-- and @to@. The dispatcher branches only on @from == to@ -- (no work) and dry-run vs apply. dispatchPlan :: MigrateOpts -> @@ -507,13 +558,13 @@ MigrationPlan -> IO (Either MigrateError MigrateResult) dispatchPlan opts manifest plan - | plan.planFrom == plan.planTo = pure (Right (MigrateNoOp plan.planTo)) + | plan ^. #from == (plan ^. #to) = pure (Right (MigrateNoOp (plan ^. #to))) | otherwise = applyOrDryRun opts manifest plan -- | Classify the plan, optionally execute it, and return the -- appropriate 'MigrateResult' variant. Empty 'planSteps' is fine — -- 'executeMigration' runs zero file ops but still advances the --- manifest's recorded @moduleVersion@ to @planTo@. +-- manifest's recorded @moduleVersion@ to @to@. applyOrDryRun :: MigrateOpts -> Manifest -> @@ -527,19 +578,19 @@ case classifyResult of Left err -> pure (Left (MigrateExecFailed err)) Right executedPlan -> - if opts.migrateDryRun - then pure (Right (MigrateDryRunOK executedPlan plan.planFrom plan.planTo)) + if opts ^. #dryRun + then pure (Right (MigrateDryRunOK executedPlan (plan ^. #from) (plan ^. #to))) else do now <- getCurrentTime execRes <- runEff $ runFilesystem $ runProcessIO $ - executeMigration opts.migrateForce executedPlan manifest now + executeMigration (opts ^. #force) executedPlan manifest now case execRes of Left err -> pure (Left (MigrateExecFailed err)) Right manifest' -> - pure (Right (MigrateApplied executedPlan manifest' plan.planFrom plan.planTo)) + pure (Right (MigrateApplied executedPlan manifest' (plan ^. #from) (plan ^. #to))) -- | Stage and commit the files touched by a successful migration plan. -- Mirrors the @seihou run --commit@ post-execution helper. No-op @@ -555,7 +606,7 @@ ExecutedMigrationPlan -> IO () commitMigratedFiles opts manifestPath plan = do - let touched = concatMap pathsForOp plan.planOps + let touched = concatMap pathsForOp (plan ^. #ops) filesToStage = touched ++ [manifestPath] inGit <- runEff $ runProcessIO isGitRepo when inGit $ do @@ -566,11 +617,11 @@ case addExit of ExitFailure _ -> TIO.hPutStrLn stderr ("git add failed: " <> addErr) ExitSuccess -> do - msg <- case opts.migrateCommitMessage of + msg <- case opts ^. #commitMessage of Just m -> pure m Nothing -> do diffText <- runEff $ runProcessIO gitDiffCached - generateCommitMessage [opts.migrateModule] diffText + generateCommitMessage [opts ^. #module_] diffText (cExit, _, cErr) <- runEff $ runProcessIO $ gitCommit msg case cExit of ExitSuccess -> pure () @@ -587,11 +638,11 @@ resolveTarget :: MigrateOpts -> Module -> ModuleName -> FilePath -> Either MigrateError Version resolveTarget opts installedModule modName installedDhall = - case opts.migrateTo of + case opts ^. #to of Just t -> case parseVersion t of Just v -> Right v Nothing -> Left (MigrateUnparseableTargetVersion t) - Nothing -> case installedModule.version of + Nothing -> case installedModule ^. #version of Nothing -> Left (MigrateInstalledModuleHasNoVersion modName installedDhall) Just t -> case parseVersion t of Just v -> Right v @@ -599,34 +650,34 @@ findApplied :: Manifest -> ModuleName -> Maybe AppliedModule findApplied m name = - case filter (\am -> am.name == name) m.modules of + case filter (\am -> am ^. #name == name) (m ^. #modules) of (am : _) -> Just am [] -> Nothing -- | Render a classified plan to stdout in the human-readable format. -- The supplied versions are the user-visible "X → Y" header taken from --- the source plan's @planFrom@ and @planTo@; the manifest will land at --- @planTo@ even when 'planSteps' is empty. +-- the source plan's @from@ and @to@; the manifest will land at +-- @to@ even when 'planSteps' is empty. renderPlan :: Bool -> ExecutedMigrationPlan -> Version -> Version -> IO () renderPlan c plan fromV toV = do - let src = plan.planSource + let src = (plan ^. #source) TIO.putStrLn $ "Migration plan: " - <> applyColor c bold (src.planModule) + <> applyColor c bold (src ^. #module_) <> " " <> renderVersion fromV <> " → " <> renderVersion toV - if null src.planSteps + if null (src ^. #steps) then TIO.putStrLn " (no migration ops)" - else mapM_ (renderStep c) src.planSteps + else mapM_ (renderStep c) (src ^. #steps) let conflictCount = length - [ () | inst <- plan.planOps, isConflict inst + [ () | inst <- plan ^. #ops, isConflict inst ] affectedCount = length - [ () | inst <- plan.planOps, touchesFs inst + [ () | inst <- plan ^. #ops, touchesFs inst ] TIO.putStrLn "" TIO.putStrLn $ @@ -644,8 +695,8 @@ renderStep :: Bool -> Migration -> IO () renderStep c step = do - TIO.putStrLn $ " " <> step.from <> " → " <> step.to <> ":" - mapM_ (renderOp c) step.ops + TIO.putStrLn $ " " <> step ^. #from <> " → " <> step ^. #to <> ":" + mapM_ (renderOp c) (step ^. #ops) renderOp :: Bool -> MigrationOp -> IO () renderOp c op = case op of @@ -669,20 +720,20 @@ planToJson :: ExecutedMigrationPlan -> Aeson.Value planToJson plan = - let src = plan.planSource + let src = (plan ^. #source) in object - [ "module" .= plan.planModule.unModuleName, - "from" .= renderVersion src.planFrom, - "to" .= renderVersion src.planTo, + [ "module" .= (plan ^. #module_ . #unModuleName), + "from" .= renderVersion (src ^. #from), + "to" .= renderVersion (src ^. #to), "steps" .= [ object - [ "from" .= step.from, - "to" .= step.to, - "ops" .= map opToJson step.ops + [ "from" .= (step ^. #from), + "to" .= (step ^. #to), + "ops" .= map opToJson (step ^. #ops) ] - | step <- src.planSteps + | step <- src ^. #steps ], - "operations" .= map instToJson plan.planOps + "operations" .= map instToJson (plan ^. #ops) ] opToJson :: MigrationOp -> Aeson.Value @@ -747,16 +798,16 @@ renderError (MigrateNoManifest path) = "no Seihou manifest at " <> T.pack path <> "; run from a project that has been initialized." renderError (MigrateModuleNotApplied modName) = - "module '" <> modName.unModuleName <> "' is not applied in this project." + "module '" <> modName ^. #unModuleName <> "' is not applied in this project." renderError (MigrateNoRecordedVersion modName) = "module '" - <> modName.unModuleName + <> modName ^. #unModuleName <> "' has no version recorded in the manifest. Re-apply the module with 'seihou run' to record one before migrating." renderError (MigrateInstalledModuleEvalFailed path msg) = "could not evaluate installed module at " <> T.pack path <> ": " <> msg renderError (MigrateInstalledModuleHasNoVersion modName path) = "installed module '" - <> modName.unModuleName + <> modName ^. #unModuleName <> "' at " <> T.pack path <> " has no version field; either pass --to or add a version to its module.dhall." @@ -768,6 +819,10 @@ "manifest's recorded module version '" <> v <> "' is not a valid dotted version." renderError (MigratePlanFailed e) = renderPlanError e renderError (MigrateExecFailed e) = renderExecError e +renderError (MigrateArtifactUnresolved e) = + "cannot plan a migration.\n\n" <> renderArtifactRefError e +renderError (MigrateArtifactGuardFailed checks) = + "cannot plan a migration.\n\n" <> formatGuardRefusal checks renderPlanError :: MigrationPlanError -> Text renderPlanError (MigrationVersionUnparseable t) = diff --git a/src/Seihou/CLI/PendingMigrations.hs b/src/Seihou/CLI/PendingMigrations.hs --- a/src/Seihou/CLI/PendingMigrations.hs +++ b/src/Seihou/CLI/PendingMigrations.hs @@ -4,10 +4,12 @@ ) where +import Data.Generics.Labels () import Data.Set (Set) import Data.Set qualified as Set import Data.Text qualified as T import Seihou.CLI.Migrate (pendingChainFor) +import Seihou.CLI.Shared (resolveAppliedArtifactDir) import Seihou.Core.Migration (MigrationPlan (..)) import Seihou.Core.Types ( AppliedModule (..), @@ -17,7 +19,6 @@ import Seihou.Core.Version (renderVersion) import Seihou.Dhall.Eval (evalModuleFromFile) import Seihou.Prelude -import System.Directory (doesFileExist) -- | Detect pending migrations across applied modules in a manifest. -- @@ -48,19 +49,23 @@ (mapM check candidates) where candidates = case mFilter of - Nothing -> manifest.modules - Just names -> filter (\am -> Set.member am.name names) manifest.modules + Nothing -> (manifest ^. #modules) + Just names -> filter (\am -> Set.member (am ^. #name) names) (manifest ^. #modules) + -- The manifest records a portable origin, so the module has to be located + -- on this machine first. A module that does not resolve here is skipped + -- like any other read failure: detection is best-effort, and the command + -- that actually needs the module reports the resolution error properly. check am = do - let dhallFile = am.source "module.dhall" - exists <- doesFileExist dhallFile - if not exists - then pure (am.name, Nothing) - else do + resolved <- resolveAppliedArtifactDir "module.dhall" (am ^. #origin) + case resolved of + Left _ -> pure (am ^. #name, Nothing) + Right directory -> do + let dhallFile = directory "module.dhall" r <- evalModuleFromFile dhallFile case r of - Left _ -> pure (am.name, Nothing) - Right installed -> pure (am.name, pendingChainFor am installed) + Left _ -> pure (am ^. #name, Nothing) + Right installed -> pure (am ^. #name, pendingChainFor am installed) -- | Format the user-facing refusal message that @seihou run@ prints -- when it detects pending migrations and the user has not opted into @@ -79,11 +84,11 @@ where renderEntry (name, plan) = " " - <> name.unModuleName + <> name ^. #unModuleName <> ": " - <> renderVersion plan.planFrom + <> renderVersion (plan ^. #from) <> " -> " - <> renderVersion plan.planTo + <> renderVersion (plan ^. #to) <> " (" - <> T.pack (show (length plan.planSteps)) + <> T.pack (show (length (plan ^. #steps))) <> " step(s))" diff --git a/src/Seihou/CLI/PromptRender.hs b/src/Seihou/CLI/PromptRender.hs --- a/src/Seihou/CLI/PromptRender.hs +++ b/src/Seihou/CLI/PromptRender.hs @@ -7,7 +7,9 @@ ) where +import Control.Lens ((^.)) import Data.FileEmbed (embedFile) +import Data.Generics.Labels () import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map import Data.Maybe (fromMaybe) @@ -38,17 +40,17 @@ T.Text renderPromptSystemPrompt ctx prompt resolved renderedPrompt userPrompt = substitute - [ ("cwd", ctx.cwd), + [ ("cwd", ctx ^. #cwd), ("seihou_project_state", formatSeihouProjectState ctx), ("manifest_state", formatManifestState ctx), ("module_dhall_state", formatModuleDhallState ctx), ("local_modules", formatLocalModules ctx), ("available_modules", formatAvailableModules ctx), - ("prompt_name", prompt.name.unModuleName), - ("prompt_version", fromMaybe "(unspecified)" prompt.version), - ("prompt_description", fromMaybe "(no description)" prompt.description), - ("reference_files", formatReferenceFiles prompt.files), - ("prompt_guidance", formatPromptGuidance resolved prompt.guidance), + ("prompt_name", prompt ^. #name . #unModuleName), + ("prompt_version", fromMaybe "(unspecified)" (prompt ^. #version)), + ("prompt_description", fromMaybe "(no description)" (prompt ^. #description)), + ("reference_files", formatReferenceFiles (prompt ^. #files)), + ("prompt_guidance", formatPromptGuidance resolved (prompt ^. #guidance)), ("prompt_body", renderedPrompt), ("user_prompt", fromMaybe "(no one-off user instruction)" userPrompt) ] @@ -57,7 +59,7 @@ renderPromptBody :: Map VarName ResolvedVar -> T.Text -> T.Text renderPromptBody resolved tpl = substitute - [(vn.unVarName, varValueToText rv.value) | (vn, rv) <- Map.toList resolved] + [(vn ^. #unVarName, varValueToText (rv ^. #value)) | (vn, rv) <- Map.toList resolved] tpl formatPromptGuidance :: Map VarName ResolvedVar -> [PromptGuidance] -> T.Text @@ -66,18 +68,18 @@ [] -> "(no prompt guidance)" selectedGuidance -> T.intercalate "\n\n" (map render selectedGuidance) where - bindings = Map.map (.value) resolved + bindings = Map.map (^. #value) resolved selected g = - case g.condition of + case g ^. #condition of Nothing -> True Just cond -> evalExpr bindings cond render g = T.unlines - [ "### " <> g.title, + [ "### " <> g ^. #title, "", - g.body + g ^. #body ] varValueToText :: VarValue -> T.Text diff --git a/src/Seihou/CLI/Registry/Sync.hs b/src/Seihou/CLI/Registry/Sync.hs --- a/src/Seihou/CLI/Registry/Sync.hs +++ b/src/Seihou/CLI/Registry/Sync.hs @@ -10,10 +10,10 @@ ) where +import Data.Generics.Labels () import Data.Maybe (mapMaybe) import Data.Text qualified as T import Data.Text.IO qualified as TIO -import GHC.Generics (Generic) import Seihou.Core.Registry ( EntryKind (..), Registry (..), @@ -44,9 +44,9 @@ -- | Flags parsed for the @seihou registry sync-versions@ subcommand. data SyncVersionsOpts = SyncVersionsOpts - { syncVersionsDir :: Maybe FilePath, - syncVersionsDryRun :: Bool, - syncVersionsCheck :: Bool + { dir :: !(Maybe FilePath), + dryRun :: !Bool, + check :: !Bool } deriving stock (Eq, Show, Generic) @@ -75,7 +75,7 @@ -- when appropriate, and returns a structured outcome. runSync :: SyncVersionsOpts -> IO SyncOutcome runSync opts = do - let targetDir = maybe "." id opts.syncVersionsDir + let targetDir = maybe "." id (opts ^. #dir) dirExists <- doesDirectoryExist targetDir if not dirExists then pure (SyncFailure ("target directory does not exist: " <> T.pack targetDir)) @@ -85,13 +85,13 @@ MultiModule reg -> do lookups <- resolveOnDiskVersions targetDir reg let report = computeRegistrySync reg lookups - let checkMode = opts.syncVersionsCheck - dryRun = opts.syncVersionsDryRun && not checkMode + let checkMode = (opts ^. #check) + dryRun = opts ^. #dryRun && not checkMode writeMode = not checkMode && not dryRun action <- if writeMode then do - let rendered = renderRegistryDhall report.syncUpdated + let rendered = renderRegistryDhall (report ^. #updated) TIO.writeFile (targetDir "seihou-registry.dhall") rendered pure Wrote else @@ -114,39 +114,39 @@ Registry -> IO [(EntryKind, ModuleName, Maybe Text)] resolveOnDiskVersions repoRoot reg = do - modulePairs <- mapM (loadModule repoRoot) reg.modules - recipePairs <- mapM (loadRecipe repoRoot) reg.recipes - blueprintPairs <- mapM (loadBlueprint repoRoot) reg.blueprints - promptPairs <- mapM (loadPrompt repoRoot) reg.prompts + modulePairs <- mapM (loadModule repoRoot) (reg ^. #modules) + recipePairs <- mapM (loadRecipe repoRoot) (reg ^. #recipes) + blueprintPairs <- mapM (loadBlueprint repoRoot) (reg ^. #blueprints) + promptPairs <- mapM (loadPrompt repoRoot) (reg ^. #prompts) pure (concat modulePairs <> concat recipePairs <> concat blueprintPairs <> concat promptPairs) where loadModule :: FilePath -> RegistryEntry -> IO [(EntryKind, ModuleName, Maybe Text)] loadModule root entry = do - let path = root entry.path "module.dhall" + let path = root entry ^. #path "module.dhall" decoded <- evalModuleFromFile path case decoded of - Right m -> pure [(ModuleEntry, entry.name, moduleVersion m)] + Right m -> pure [(ModuleEntry, entry ^. #name, moduleVersion m)] Left _ -> pure [] loadRecipe :: FilePath -> RegistryEntry -> IO [(EntryKind, ModuleName, Maybe Text)] loadRecipe root entry = do - let path = root entry.path "recipe.dhall" + let path = root entry ^. #path "recipe.dhall" decoded <- evalRecipeFromFile path case decoded of - Right r -> pure [(RecipeEntry, entry.name, recipeVersion r)] + Right r -> pure [(RecipeEntry, entry ^. #name, recipeVersion r)] Left _ -> pure [] loadBlueprint :: FilePath -> RegistryEntry -> IO [(EntryKind, ModuleName, Maybe Text)] loadBlueprint root entry = do - let path = root entry.path "blueprint.dhall" + let path = root entry ^. #path "blueprint.dhall" decoded <- evalBlueprintFromFile path case decoded of - Right b -> pure [(BlueprintEntry, entry.name, blueprintVersion b)] + Right b -> pure [(BlueprintEntry, entry ^. #name, blueprintVersion b)] Left _ -> pure [] loadPrompt :: FilePath -> RegistryEntry -> IO [(EntryKind, ModuleName, Maybe Text)] loadPrompt root entry = do - let path = root entry.path "prompt.dhall" + let path = root entry ^. #path "prompt.dhall" decoded <- evalAgentPromptFromFile path case decoded of - Right p -> pure [(PromptEntry, entry.name, promptVersion p)] + Right p -> pure [(PromptEntry, entry ^. #name, promptVersion p)] Left _ -> pure [] -- | Extract the @version@ field from a 'Module' by pattern match. A direct @@ -191,7 +191,7 @@ -- The first entry in 'syncDiffs' appears first, preserving registry order. renderSyncReport :: SyncReport -> Text renderSyncReport report - | null report.syncDiffs = + | null (report ^. #diffs) = "Registry is empty.\n" | otherwise = T.unlines $ @@ -200,23 +200,23 @@ <> ["", summary report] where header = "Updated seihou-registry.dhall:" - rows = map renderRow report.syncDiffs + rows = map renderRow (report ^. #diffs) renderRow :: SyncDiff -> Text renderRow diff = - let label = kindPrefix diff.diffKind <> diff.diffName.unModuleName <> ":" + let label = kindPrefix (diff ^. #kind) <> diff ^. #name . #unModuleName <> ":" padded = padRight labelWidth label - old = renderVersion diff.diffOld - new = renderVersion diff.diffNew - arrow = case diff.diffStatus of + old = renderVersion (diff ^. #old) + new = renderVersion (diff ^. #new) + arrow = case diff ^. #status of SyncInSync -> " == " <> new <> " (no change)" - SyncOrphan -> " ?? " <> old <> " (" <> entryFile diff.diffKind <> " missing)" + SyncOrphan -> " ?? " <> old <> " (" <> entryFile (diff ^. #kind) <> " missing)" _ -> " -> " <> new in padded <> old <> arrow - labelWidth = maximum (24 : map diffLabelWidth report.syncDiffs) + labelWidth = maximum (24 : map diffLabelWidth (report ^. #diffs)) diffLabelWidth d = - T.length (kindPrefix d.diffKind <> d.diffName.unModuleName) + 2 + T.length (kindPrefix (d ^. #kind) <> d ^. #name . #unModuleName) + 2 kindPrefix :: EntryKind -> Text kindPrefix ModuleEntry = "modules." @@ -241,9 +241,9 @@ summary :: SyncReport -> Text summary report = - let updated = length [d | d <- report.syncDiffs, changesVersion d.diffStatus] - orphans = length [d | d <- report.syncDiffs, d.diffStatus == SyncOrphan] - unchanged = length [d | d <- report.syncDiffs, d.diffStatus == SyncInSync] + let updated = length [d | d <- report ^. #diffs, changesVersion (d ^. #status)] + orphans = length [d | d <- report ^. #diffs, d ^. #status == SyncOrphan] + unchanged = length [d | d <- report ^. #diffs, d ^. #status == SyncInSync] base = T.pack (show updated) <> " " @@ -266,11 +266,11 @@ anyDrift :: SyncReport -> Bool anyDrift report = any - ( \d -> case d.diffStatus of + ( \d -> case d ^. #status of SyncInSync -> False _ -> True ) - report.syncDiffs + (report ^. #diffs) -- | Soft-warning pass: compare each registry entry's 'version' with the -- on-disk module.dhall / recipe.dhall and return one warning per out-of-sync @@ -284,4 +284,4 @@ checkRegistryVersionDrift repoRoot reg = do lookups <- resolveOnDiskVersions repoRoot reg let report = computeRegistrySync reg lookups - pure (mapMaybe formatDriftWarning report.syncDiffs) + pure (mapMaybe formatDriftWarning (report ^. #diffs)) diff --git a/src/Seihou/CLI/Registry/Validate.hs b/src/Seihou/CLI/Registry/Validate.hs --- a/src/Seihou/CLI/Registry/Validate.hs +++ b/src/Seihou/CLI/Registry/Validate.hs @@ -7,9 +7,9 @@ ) where +import Data.Generics.Labels () import Data.Text qualified as T import Data.Text.IO qualified as TIO -import GHC.Generics (Generic) import Seihou.CLI.Registry.Sync (resolveOnDiskVersions) import Seihou.Core.Registry ( RegistryValidationIssue (..), @@ -28,7 +28,7 @@ -- | Flags parsed for the @seihou registry validate@ subcommand. data ValidateRegistryOpts = ValidateRegistryOpts - { validateRegistryDir :: Maybe FilePath + { validateRegistryDir :: !(Maybe FilePath) } deriving stock (Eq, Show, Generic) @@ -45,7 +45,7 @@ -- resolves each entry's on-disk version, and produces the unified report. runValidate :: ValidateRegistryOpts -> IO ValidateOutcome runValidate opts = do - let target = maybe "." id opts.validateRegistryDir + let target = maybe "." id (opts ^. #validateRegistryDir) dirExists <- doesDirectoryExist target if not dirExists then pure (ValidateFailed ("target directory does not exist: " <> T.pack target)) @@ -82,37 +82,37 @@ -- line on failure. renderValidationReport :: RegistryValidationReport -> Text renderValidationReport r - | null r.reportIssues = + | null (r ^. #issues) = T.unlines [ "OK: " - <> T.pack (show r.reportModuleCount) + <> T.pack (show (r ^. #moduleCount)) <> " " - <> pluralize r.reportModuleCount "module" "modules" + <> pluralize (r ^. #moduleCount) "module" "modules" <> ", " - <> T.pack (show r.reportRecipeCount) + <> T.pack (show (r ^. #recipeCount)) <> " " - <> pluralize r.reportRecipeCount "recipe" "recipes" + <> pluralize (r ^. #recipeCount) "recipe" "recipes" <> ", " - <> T.pack (show r.reportBlueprintCount) + <> T.pack (show (r ^. #blueprintCount)) <> " " - <> pluralize r.reportBlueprintCount "blueprint" "blueprints" + <> pluralize (r ^. #blueprintCount) "blueprint" "blueprints" <> ", " - <> T.pack (show r.reportPromptCount) + <> T.pack (show (r ^. #promptCount)) <> " " - <> pluralize r.reportPromptCount "prompt" "prompts" + <> pluralize (r ^. #promptCount) "prompt" "prompts" <> ", all versions in sync." ] | otherwise = T.unlines $ ["errors:"] - <> map ((" " <>) . formatValidationIssue) r.reportIssues + <> map ((" " <>) . formatValidationIssue) (r ^. #issues) <> [""] <> [summary r] summary :: RegistryValidationReport -> Text summary r = - let n = length r.reportIssues - hasVersionDrift = any isVersionMismatch r.reportIssues + let n = length (r ^. #issues) + hasVersionDrift = any isVersionMismatch (r ^. #issues) base = T.pack (show n) <> " " <> pluralize n "error" "errors" tail_ = if hasVersionDrift diff --git a/src/Seihou/CLI/RemoteVersion.hs b/src/Seihou/CLI/RemoteVersion.hs --- a/src/Seihou/CLI/RemoteVersion.hs +++ b/src/Seihou/CLI/RemoteVersion.hs @@ -5,6 +5,7 @@ ) where +import Data.Generics.Labels () import Data.Text qualified as T import Seihou.Core.Registry (Registry (..), RegistryEntry (..), RepoContents (..), discoverRepoContents) import Seihou.Core.Types (Module (..), ModuleName (..)) @@ -59,7 +60,7 @@ MultiModule registry -> case findEntry registry of Nothing -> pure (Left (EntryNotFound name)) Just entry -> - readModuleDhallVersion (clonedRepoPath entry.path "module.dhall") + readModuleDhallVersion (clonedRepoPath entry ^. #path "module.dhall") SingleRecipe _ -> pure (Left (RegistryNotFound clonedRepoPath)) SingleBlueprint _ -> pure (Left (RegistryNotFound clonedRepoPath)) SinglePrompt _ -> pure (Left (RegistryNotFound clonedRepoPath)) @@ -67,7 +68,7 @@ where findEntry :: Registry -> Maybe RegistryEntry findEntry registry = - case filter (\e -> e.name == name) registry.modules of + case filter (\e -> e ^. #name == name) (registry ^. #modules) of (entry : _) -> Just entry [] -> Nothing @@ -81,7 +82,7 @@ result <- evalModuleFromFile path case result of Left err -> pure (Left (ParseFailed (T.pack (show err)))) - Right modul -> pure (Right modul.version) + Right modul -> pure (Right (modul ^. #version)) -- | Render a 'FetchError' as a single-line human-readable message suitable -- for printing in CLI output ("could not determine remote version: ..."). diff --git a/src/Seihou/CLI/SavePrompted.hs b/src/Seihou/CLI/SavePrompted.hs --- a/src/Seihou/CLI/SavePrompted.hs +++ b/src/Seihou/CLI/SavePrompted.hs @@ -5,6 +5,7 @@ where import Control.Monad (when) +import Data.Generics.Labels () import Data.Map.Strict qualified as Map import Data.Text qualified as T import Seihou.Composition.Instance (ModuleInstance) @@ -28,8 +29,8 @@ | vs <- Map.elems resolved ] promptedOnly rv = - case rv.source of - FromPrompt -> Just (varValueToText rv.value) + case rv ^. #source of + FromPrompt -> Just (varValueToText (rv ^. #value)) _ -> Nothing in [ (vn, val, existing) | (vn, val) <- allPrompted, diff --git a/src/Seihou/CLI/SchemaVersion.hs b/src/Seihou/CLI/SchemaVersion.hs --- a/src/Seihou/CLI/SchemaVersion.hs +++ b/src/Seihou/CLI/SchemaVersion.hs @@ -9,11 +9,11 @@ -- | Raw URL for the seihou-schema package.dhall at a pinned commit schemaUrl :: Text -schemaUrl = "https://raw.githubusercontent.com/shinzui/seihou-schema/2dffa0592be47835a60784b89a289226ba990aa8/package.dhall" +schemaUrl = "https://raw.githubusercontent.com/shinzui/seihou-schema/0e1b875efcf2b4e4b98d93595ea627290459e3ad/package.dhall" -- | SHA256 integrity hash for the schema import schemaHash :: Text -schemaHash = "sha256:01b6f873520459f3958baa34d3f97a49a4263b9a7225a758cddca5ab3a911f61" +schemaHash = "sha256:356829d4e2b333ce157615dd7eccd0cd4765f3ef0d94ef637fa8c97398d3b92c" -- | Complete Dhall import line for use in generated modules schemaImportLine :: Text diff --git a/src/Seihou/CLI/Shared.hs b/src/Seihou/CLI/Shared.hs --- a/src/Seihou/CLI/Shared.hs +++ b/src/Seihou/CLI/Shared.hs @@ -7,19 +7,37 @@ logIO, unwrapConfig, shortenHome, + resolveAppliedArtifactDir, ) where +import Data.Generics.Labels () import Data.List (isPrefixOf) import Data.Map.Strict qualified as Map import Data.Text qualified as T +import Seihou.Core.ArtifactRef (ArtifactRefError, resolveArtifactOrigin) +import Seihou.Core.Module (defaultSearchPaths) import Seihou.Core.Types import Seihou.Effect.Logger (Logger, logError) import Seihou.Effect.LoggerInterp (runLoggerIO) import Seihou.Prelude -import System.Directory (getHomeDirectory) +import System.Directory (getCurrentDirectory, getHomeDirectory) import System.Exit (exitFailure) +-- | Locate, on this machine, the artifact an origin recorded in the manifest +-- names. +-- +-- Every command that re-reads an artifact after the fact goes through here, +-- so they all search the same places and all fail with the same wording. The +-- project root is the current working directory, which is what the commands +-- already assume when they build the manifest path as +-- @.seihou\/manifest.json@. +resolveAppliedArtifactDir :: FilePath -> ArtifactOrigin -> IO (Either ArtifactRefError FilePath) +resolveAppliedArtifactDir definitionFile origin = do + projectRoot <- getCurrentDirectory + searchPaths <- defaultSearchPaths + resolveArtifactOrigin projectRoot searchPaths definitionFile origin + -- | Format a 'VarError' for display in CLI output. formatVarError :: VarError -> Text formatVarError (MissingRequiredVar (VarName n)) = "missing required variable: " <> n @@ -44,9 +62,9 @@ formatBlueprintRefusal name = T.intercalate "\n" - [ "'" <> name.unModuleName <> "' is a blueprint, not a module or recipe.", + [ "'" <> name ^. #unModuleName <> "' is a blueprint, not a module or recipe.", "Blueprints must be run interactively via:", - " seihou agent run " <> name.unModuleName + " seihou agent run " <> name ^. #unModuleName ] -- | Derive the namespace from a module name by taking the prefix before the first hyphen. diff --git a/src/Seihou/CLI/StatusRender.hs b/src/Seihou/CLI/StatusRender.hs --- a/src/Seihou/CLI/StatusRender.hs +++ b/src/Seihou/CLI/StatusRender.hs @@ -1,10 +1,13 @@ module Seihou.CLI.StatusRender ( formatStatus, + formatArtifactChecks, formatBlueprintMigrations, ModuleAdvice (..), ) where +import Control.Lens (to, (^.)) +import Data.Generics.Labels () import Data.List (intersperse, nub) import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map @@ -13,6 +16,7 @@ import Data.Text (Text) import Data.Text qualified as T import Data.Time.Format (defaultTimeLocale, formatTime) +import Seihou.CLI.ManifestGuard (ArtifactCheck, summarizeCheck) import Seihou.CLI.Style (dim, green, red, yellow) import Seihou.CLI.VersionCompare ( OutdatedEntry (..), @@ -62,7 +66,7 @@ ["Seihou Status:", ""] ++ recipeSection manifest ++ blueprintSection manifest - ++ formatBlueprintMigrations manifest.blueprintMigrations + ++ formatBlueprintMigrations (manifest ^. #blueprintMigrations) ++ appliedSection color manifest mEntries pendings ++ trackedSection color tracked ++ varsSection manifest @@ -70,10 +74,10 @@ ++ recommendedActionsSection adviceList where entryMap = case mEntries of - Just es -> Map.fromList [(e.moduleName, e) | e <- es] + Just es -> Map.fromList [(e ^. #moduleName, e) | e <- es] Nothing -> Map.empty pendingMap = - Map.fromList [(name.unModuleName, plan) | (name, plan) <- pendings] + Map.fromList [(name ^. #unModuleName, plan) | (name, plan) <- pendings] adviceList = projectAdviceList manifest entryMap pendingMap -- --------------------------------------------------------------------------- @@ -81,12 +85,12 @@ -- --------------------------------------------------------------------------- recipeSection :: Manifest -> [Text] -recipeSection manifest = case manifest.recipe of +recipeSection manifest = case manifest ^. #recipe of Nothing -> [] Just ar -> [ "Recipe: " - <> ar.name.unRecipeName - <> maybe "" (\v -> " v" <> v) ar.recipeVersion, + <> ar ^. #name . #unRecipeName + <> maybe "" (\v -> " v" <> v) (ar ^. #recipeVersion), "" ] @@ -98,18 +102,18 @@ -- two empty-baseline placeholders. -- Prompt line: present only when the user passed a positional prompt. blueprintSection :: Manifest -> [Text] -blueprintSection manifest = case manifest.blueprint of +blueprintSection manifest = case manifest ^. #blueprint of Nothing -> [] Just ab -> let header = "Blueprint: " - <> ab.name.unModuleName - <> maybe "" (\v -> " v" <> v) ab.blueprintVersion + <> ab ^. #name . #unModuleName + <> maybe "" (\v -> " v" <> v) (ab ^. #blueprintVersion) <> " (applied " - <> T.pack (formatTime defaultTimeLocale "%Y-%m-%d %H:%M UTC" ab.appliedAt) + <> T.pack (formatTime defaultTimeLocale "%Y-%m-%d %H:%M UTC" (ab ^. #appliedAt)) <> ")" baselineLine = " Baseline: " <> renderBaseline ab - promptLines = case ab.userPrompt of + promptLines = case ab ^. #userPrompt of Nothing -> [] Just p -> [" Prompt: \"" <> p <> "\""] in [header, baselineLine] ++ promptLines ++ [""] @@ -125,14 +129,14 @@ where renderReceipt receipt = " " - <> receipt.name.unModuleName - <> maybe "" (\version -> " v" <> version) receipt.blueprintVersion + <> receipt ^. #name . #unModuleName + <> maybe "" (\version -> " v" <> version) (receipt ^. #blueprintVersion) <> ": " - <> receipt.fromVersion + <> receipt ^. #fromVersion <> " -> " - <> receipt.toVersion + <> receipt ^. #toVersion <> " (applied " - <> T.pack (formatTime defaultTimeLocale "%Y-%m-%d %H:%M UTC" receipt.appliedAt) + <> T.pack (formatTime defaultTimeLocale "%Y-%m-%d %H:%M UTC" (receipt ^. #appliedAt)) <> ")" -- | Render the baseline body for the blueprint section. Three cases: @@ -140,10 +144,10 @@ -- all, or one or more baseline modules were applied. renderBaseline :: AppliedBlueprint -> Text renderBaseline ab - | ab.noBaseline = "(none -- --no-baseline)" - | null ab.baselineModules = "(none declared)" + | (ab ^. #noBaseline) = "(none -- --no-baseline)" + | null (ab ^. #baselineModules) = "(none declared)" | otherwise = - T.intercalate ", " (map (.unModuleName) ab.baselineModules) + T.intercalate ", " (map (^. #unModuleName) (ab ^. #baselineModules)) appliedSection :: Bool -> @@ -157,21 +161,21 @@ ++ [""] where entryMap = case mEntries of - Just es -> Map.fromList [(e.moduleName, e) | e <- es] + Just es -> Map.fromList [(e ^. #moduleName, e) | e <- es] Nothing -> Map.empty pendingMap = - Map.fromList [(name.unModuleName, plan) | (name, plan) <- pendings] + Map.fromList [(name ^. #unModuleName, plan) | (name, plan) <- pendings] moduleLines - | null manifest.modules = [" (none)"] - | otherwise = renderRows Set.empty manifest.modules + | null (manifest ^. #modules) = [" (none)"] + | otherwise = renderRows Set.empty (manifest ^. #modules) renderRows _ [] = [] renderRows seen (am : rest) = - let name = am.name.unModuleName + let name = (am ^. #name . #unModuleName) annotation = lookupEntry mEntries entryMap am headerLine = formatModuleLine color annotation am hintLines | Set.member name seen = [] - | null manifest.applications = formatAdvice color (rowProjectAdvice entryMap pendingMap am) + | null (manifest ^. #applications) = formatAdvice color (rowProjectAdvice entryMap pendingMap am) | otherwise = maybe [] (formatPendingDetail color) (Map.lookup name pendingMap) in headerLine : hintLines <> renderRows (Set.insert name seen) rest @@ -184,18 +188,18 @@ ) ++ [""] where - maxPathLen = maximum (map (length . (.path)) tracked) - maxModLen = maximum (map (T.length . displayModuleName . (.moduleName)) tracked) + maxPathLen = maximum (map (length . (^. #path)) tracked) + maxModLen = maximum (map (T.length . displayModuleName . (^. #moduleName)) tracked) varsSection :: Manifest -> [Text] varsSection manifest = - ["Variables: " <> T.pack (show (Map.size manifest.vars)) <> " resolved"] + ["Variables: " <> T.pack (show (Map.size (manifest ^. #vars))) <> " resolved"] updateSummarySection :: Maybe [OutdatedEntry] -> [Text] updateSummarySection Nothing = [] updateSummarySection (Just entries) = let total = length entries - outdated = length (filter (\e -> e.status == OutdatedSt) entries) + outdated = length (filter (\e -> e ^. #status == OutdatedSt) entries) in [ "", T.pack (show total) <> " module(s) checked, " @@ -212,6 +216,22 @@ [] -> [] cmds -> ["", "Recommended actions:"] ++ map (" " <>) cmds +-- | Render the manifest guard's non-@ArtifactOk@ verdicts as a trailing +-- advisory block. +-- +-- @seihou status@ is a reporting command and must never fail because of a +-- verdict — this block is precisely what lets a developer discover a stale or +-- mismatched module *before* @seihou run@ refuses to use it. Returns the empty +-- text when every artifact is healthy, so the section disappears entirely +-- rather than printing a reassuring "0 problems". +formatArtifactChecks :: Bool -> [ArtifactCheck] -> Text +formatArtifactChecks color checks = case mapMaybe summarizeCheck checks of + [] -> "" + summaries -> + T.unlines $ + ["", applyColor color yellow "Artifacts that differ from what this project records:"] + ++ map (" " <>) summaries + adviceCommand :: ModuleAdvice -> Maybe Text adviceCommand AdviceNone = Nothing adviceCommand (AdviceProjectUpdate target _) = Just ("seihou update " <> target) @@ -234,21 +254,21 @@ AppliedModule -> UpdateAnnotation lookupEntry Nothing _ _ = NoCheck -lookupEntry (Just _) m am = case Map.lookup am.name.unModuleName m of +lookupEntry (Just _) m am = case Map.lookup (am ^. #name . #unModuleName) m of Just e -> Entry e Nothing -> NoOrigin formatModuleLine :: Bool -> UpdateAnnotation -> AppliedModule -> Text formatModuleLine color annotation am = - let verText = case am.moduleVersion of + let verText = case am ^. #moduleVersion of Just v -> " " <> applyColor color green ("v" <> v) Nothing -> "" appliedText = " (applied " - <> T.pack (formatTime defaultTimeLocale "%Y-%m-%d" am.appliedAt) + <> T.pack (formatTime defaultTimeLocale "%Y-%m-%d" (am ^. #appliedAt)) <> ")" parentVarsText = - let m = am.parentVars.unParentVars + let m = (am ^. #parentVars . #unParentVars) in if Map.null m then "" else @@ -256,7 +276,7 @@ T.concat ( intersperse ", " - [ vn.unVarName <> "=" <> v + [ vn ^. #unVarName <> "=" <> v | (vn, v) <- Map.toAscList m ] ) @@ -267,7 +287,7 @@ NoOrigin -> " " <> applyColor color dim "(no origin)" Entry e -> " " <> renderEntry color e in " " - <> am.name.unModuleName + <> am ^. #name . #unModuleName <> parentVarsText <> verText <> appliedText @@ -288,11 +308,11 @@ projectPlanSummary :: Text -> MigrationPlan -> Text projectPlanSummary target plan = "Pending migration: " - <> renderVersion plan.planFrom + <> renderVersion (plan ^. #from) <> " -> " - <> renderVersion plan.planTo + <> renderVersion (plan ^. #to) <> " (" - <> T.pack (show (length plan.planSteps)) + <> T.pack (show (length (plan ^. #steps))) <> " step(s)). Run: seihou update " <> target @@ -303,11 +323,11 @@ color yellow ( "Pending migration: " - <> renderVersion plan.planFrom + <> renderVersion (plan ^. #from) <> " -> " - <> renderVersion plan.planTo + <> renderVersion (plan ^. #to) <> " (" - <> T.pack (show (length plan.planSteps)) + <> T.pack (show (length (plan ^. #steps))) <> " step(s))" ) ] @@ -322,9 +342,9 @@ then AdviceProjectUpdate name pending else AdviceNone where - name = applied.name.unModuleName + name = (applied ^. #name . #unModuleName) pending = Map.lookup name pendingMap - outdated = maybe False ((== OutdatedSt) . (.status)) (Map.lookup name entryMap) + outdated = maybe False ((== OutdatedSt) . (^. #status)) (Map.lookup name entryMap) actionable = outdated || isJust pending projectAdviceList :: @@ -333,32 +353,32 @@ Map Text MigrationPlan -> [ModuleAdvice] projectAdviceList manifest entryMap pendingMap - | null manifest.applications = - map (rowProjectAdvice entryMap pendingMap) (deduplicateModules manifest.modules) + | null (manifest ^. #applications) = + map (rowProjectAdvice entryMap pendingMap) (deduplicateModules (manifest ^. #modules)) | otherwise = - let applicationAdvice = mapMaybe adviceForApplication manifest.applications + let applicationAdvice = mapMaybe adviceForApplication (manifest ^. #applications) in applicationAdvice <> [AdviceProjectUpdateAll | length applicationAdvice > 1] where adviceForApplication application = - let names = map (.name.unModuleName) application.instances + let names = map (^. #name . #unModuleName) (application ^. #instances) pending = listToMaybe (mapMaybe (`Map.lookup` pendingMap) names) - outdated = any (maybe False ((== OutdatedSt) . (.status)) . (`Map.lookup` entryMap)) 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 (targetText (application ^. #target)) pending) else Nothing deduplicateModules :: [AppliedModule] -> [AppliedModule] -deduplicateModules = Map.elems . Map.fromList . map (\applied -> (applied.name.unModuleName, applied)) +deduplicateModules = Map.elems . Map.fromList . map (\applied -> (applied ^. #name . #unModuleName, applied)) targetText :: AppliedTarget -> Text -targetText (AppliedModuleTarget name) = name.unModuleName -targetText (AppliedRecipeTarget name) = name.unRecipeName +targetText (AppliedModuleTarget name) = (name ^. #unModuleName) +targetText (AppliedRecipeTarget name) = (name ^. #unRecipeName) renderEntry :: Bool -> OutdatedEntry -> Text -renderEntry color e = case e.status of +renderEntry color e = case e ^. #status of UpToDate -> applyColor color dim "up to date" OutdatedSt -> - let avail = maybe "?" id e.availableVersion + let avail = maybe "?" id (e ^. #availableVersion) txt = "outdated: " <> avail <> " available" in applyColor color red txt Unversioned -> applyColor color dim "unversioned" @@ -366,12 +386,12 @@ formatTrackedFile :: Bool -> Int -> Int -> TrackedFile -> Text formatTrackedFile color maxPathLen maxModLen tf = - let path = T.pack tf.path - modName = displayModuleName tf.moduleName + let path = T.pack (tf ^. #path) + modName = displayModuleName (tf ^. #moduleName) paddedPath = path <> T.replicate (maxPathLen - T.length path + 3) " " paddedMod = modName <> T.replicate (maxModLen - T.length modName + 3) " " - label = statusLabel tf.status - colored = applyColor color (statusColor tf.status) label + label = statusLabel (tf ^. #status) + colored = applyColor color (statusColor (tf ^. #status)) label in " " <> paddedPath <> paddedMod <> colored displayModuleName :: ModuleName -> Text diff --git a/src/Seihou/CLI/Style.hs b/src/Seihou/CLI/Style.hs --- a/src/Seihou/CLI/Style.hs +++ b/src/Seihou/CLI/Style.hs @@ -13,6 +13,7 @@ ) where +import Data.Generics.Labels () import Data.Map.Strict qualified as Map import Data.Text qualified as T import Seihou.Core.Types (DiffResult (..), Module (..), ModuleName (..), VarName (..), VarValue (..)) @@ -71,7 +72,10 @@ where fileLines = [l | l@(FilePreview {}) <- lines'] nonFileLines = [l | l <- lines', not (isFilePreview' l)] - maxPathLen = maximum (0 : map (T.length . T.pack . (.previewPath)) fileLines) + -- PreviewLine is a sum type and `path` lives only in FilePreview, so this + -- is a pattern match rather than a #path read: generic-lens can only build + -- a lens for a field that every constructor has. + maxPathLen = maximum (0 : [T.length (T.pack p) | FilePreview {path = p} <- lines']) renderColorLine :: Int -> PreviewLine -> Text renderColorLine maxPath (FilePreview status path annotation mMod) = @@ -79,7 +83,7 @@ pathText = T.pack path pathPad = T.replicate (maxPath - T.length pathText) " " modSuffix = case mMod of - Just mn -> ", " <> mn.unModuleName + Just mn -> ", " <> (mn ^. #unModuleName) Nothing -> "" in " " <> tag <> " " <> colorFn pathText <> pathPad <> " " <> dim ("(" <> annotation <> modSuffix <> ")") renderColorLine _ other = renderNonFileColor other @@ -90,9 +94,9 @@ renderNonFileColor (CommandPreview cmd mOwner) = " " <> dim "run" <> " " <> dim cmd <> ownerSuffix mOwner where - ownerSuffix = maybe "" (\owner -> " " <> dim ("(" <> owner.unModuleName <> ")")) + ownerSuffix = maybe "" (\owner -> " " <> dim ("(" <> owner ^. #unModuleName <> ")")) renderNonFileColor (OrphanPreview path modName') = - " " <> magenta "[orphaned]" <> " " <> magenta (T.pack path) <> " " <> dim ("(orphaned from " <> modName'.unModuleName <> ")") + " " <> magenta "[orphaned]" <> " " <> magenta (T.pack path) <> " " <> dim ("(orphaned from " <> modName' ^. #unModuleName <> ")") renderNonFileColor _ = "" isFilePreview' :: PreviewLine -> Bool @@ -122,7 +126,7 @@ header = bold ( "Generation Plan (" - <> T.intercalate " + " (map (cyan . (.unModuleName)) modNames) + <> T.intercalate " + " (map (cyan . (^. #unModuleName)) modNames) <> "):" ) @@ -172,7 +176,7 @@ renderReportColor False report = renderReportPlain report renderReportColor True report = T.unlines $ - [ "Validating module at " <> T.pack report.reportPath <> "...", + [ "Validating module at " <> T.pack (report ^. #path) <> "...", "" ] ++ dhallLine' @@ -181,52 +185,52 @@ ++ [""] ++ [resultLine'] where - m = report.reportModule + m = (report ^. #module_) dhallLine' = - if report.reportDhallOk + if report ^. #dhallOk then [" " <> green "\x2713" <> " module.dhall evaluates successfully"] else [" " <> bold (red "\x2717") <> " module.dhall failed to evaluate"] - ++ case report.reportDhallError of + ++ case report ^. #dhallError of Just errText -> [" " <> dim errText] Nothing -> [] summaryLines' = - if report.reportDhallOk + if report ^. #dhallOk then - [ " " <> green "\x2713" <> " Module name: " <> cyan m.name.unModuleName, - " " <> green "\x2713" <> " " <> T.pack (show (length m.vars)) <> " variables declared", - " " <> green "\x2713" <> " " <> T.pack (show (length m.prompts)) <> " prompts defined", - " " <> green "\x2713" <> " " <> T.pack (show (length m.steps)) <> " steps defined" + [ " " <> green "\x2713" <> " Module name: " <> cyan (m ^. #name . #unModuleName), + " " <> green "\x2713" <> " " <> T.pack (show (length (m ^. #vars))) <> " variables declared", + " " <> green "\x2713" <> " " <> T.pack (show (length (m ^. #prompts))) <> " prompts defined", + " " <> green "\x2713" <> " " <> T.pack (show (length (m ^. #steps))) <> " steps defined" ] else [] - checkLines' = concatMap renderCheckColor (report.reportChecks) + checkLines' = concatMap renderCheckColor (report ^. #checks) renderCheckColor c - | null (c.diagDetails) = - [" " <> green "\x2713" <> " " <> c.diagLabel] - | c.diagSeverity == DiagWarning = - (" " <> yellow "\x26A0" <> " " <> yellow (c.diagLabel)) - : map (\d -> " " <> dim d) (c.diagDetails) + | null (c ^. #details) = + [" " <> green "\x2713" <> " " <> c ^. #label] + | c ^. #severity == DiagWarning = + (" " <> yellow "\x26A0" <> " " <> yellow (c ^. #label)) + : map (\d -> " " <> dim d) (c ^. #details) | otherwise = - (" " <> bold (red "\x2717") <> " " <> red (c.diagLabel)) - : map (\d -> " " <> dim d) (c.diagDetails) + (" " <> bold (red "\x2717") <> " " <> red (c ^. #label)) + : map (\d -> " " <> dim d) (c ^. #details) errorCount = length [ () - | c <- report.reportChecks, - c.diagSeverity == DiagError, - not (null (c.diagDetails)) + | c <- report ^. #checks, + c ^. #severity == DiagError, + not (null (c ^. #details)) ] - dhallFailed = not (report.reportDhallOk) + dhallFailed = not (report ^. #dhallOk) totalErrors = errorCount + (if dhallFailed then 1 else 0) resultLine' | totalErrors > 0 = bold (red (T.pack (show totalErrors) <> " error(s) found.")) <> " Module is invalid." | otherwise = - green ("Module '" <> m.name.unModuleName <> "' is valid.") + green ("Module '" <> m ^. #name . #unModuleName <> "' is valid.") diff --git a/src/Seihou/CLI/Update.hs b/src/Seihou/CLI/Update.hs --- a/src/Seihou/CLI/Update.hs +++ b/src/Seihou/CLI/Update.hs @@ -19,9 +19,10 @@ ) where -import Control.Exception (SomeException, displayException, try) +import Control.Exception (SomeException, displayException, toException, try) import Control.Monad (foldM, forM, forM_, when) 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) @@ -48,6 +49,8 @@ resolveWithPromptPermission, ) import Seihou.Core.Application (buildAppliedComposition, replaceAppliedComposition) +import Seihou.Core.ArtifactOriginDetect (detectArtifactOrigin) +import Seihou.Core.ArtifactRef (renderArtifactRefError, resolveArtifactOrigin) import Seihou.Core.Module (defaultSearchPaths, discoverRunnable) import Seihou.Core.Types import Seihou.Core.Version (parseVersion) @@ -110,20 +113,20 @@ Left err -> pure (Left err) Right manifest -> do now <- getCurrentTime - seeded <- selectAndSeedLegacy request manifest now + seeded <- selectAndSeedLegacy request projectRoot manifest now case seeded of Left err -> pure (Left err) Right (selected, seedWarnings) -> do - staged <- stageCandidateSources sessionDirectory selected + staged <- stageCandidateSources sessionDirectory projectRoot installedDirectory selected case staged of Left err -> pure (Left err) Right (catalog, sourceWarnings) -> do - plannedApplicationsResult <- traverse (planApplication request installedDirectory catalog now) selected + plannedApplicationsResult <- traverse (planApplication request projectRoot catalog now) selected case sequence plannedApplicationsResult of Left err -> pure (Left err) Right plannedApplications -> do let applicationInputs = - [ (Just previous, planned.modulesInOrder) + [ (Just previous, planned ^. #modulesInOrder) | (previous, planned) <- zip selected plannedApplications ] stagedMigrations <- planAndStageMigrations projectRoot manifest catalog applicationInputs @@ -131,31 +134,31 @@ 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 + 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 + planReconciliation stageRoot (migrationStage ^. #manifest) selectedIds operations owners case reconciliationResult of Left err -> pure (Left (UpdateReconciliationFailed err)) Right reconciliation -> do - evidence <- versionEvidence catalog selected plannedApplications + evidence <- versionEvidence (request ^. #allowDowngrade) projectRoot catalog selected plannedApplications case evidence of Left err -> pure (Left err) Right (versionChanges, versionWarnings) -> do let usedArtifacts = artifactsUsedBy catalog plannedApplications - priorReceipts = Map.unions (map (.commandReceipts) selected) - commandPlan = planCommands request.commandPolicy priorReceipts operations + priorReceipts = Map.unions (map (^. #commandReceipts) selected) + commandPlan = planCommands (request ^. #commandPolicy) priorReceipts operations warnings = seedWarnings <> sourceWarnings - <> migrationStage.warnings + <> migrationStage ^. #warnings <> compositionWarnings <> versionWarnings inputChanges = summarizeInputChanges seedWarnings plannedApplications - transactionTargets = transactionTargetPaths manifest reconciliation migrationStage.plans + transactionTargets = transactionTargetPaths manifest reconciliation (migrationStage ^. #plans) observedProjectHashes <- observePaths projectRoot @@ -168,17 +171,17 @@ baselineDirectory, installedDirectory, originalManifest = manifest, - candidateHashes = Map.fromList [(artifact.originalDirectory, artifact.contentHash) | artifact <- usedArtifacts], + candidateHashes = Map.fromList [(artifact ^. #originalDirectory, artifact ^. #contentHash) | artifact <- usedArtifacts], observedProjectHashes, transactionTargets } pure ( Right UpdatePlan - { applications = map (.candidate) plannedApplications, + { applications = map (^. #candidate) plannedApplications, versionChanges, inputChanges, - migrations = migrationStage.plans, + migrations = migrationStage ^. #plans, reconciliation, commandPlan, candidateArtifacts = usedArtifacts, @@ -191,8 +194,8 @@ applyProjectUpdate :: UpdatePlan -> IO (Either UpdateError UpdateResult) applyProjectUpdate plan = - Directory.withCurrentDirectory plan.snapshot.projectRoot $ do - recovery <- recoverAtEntry plan.snapshot.projectRoot + Directory.withCurrentDirectory (plan ^. #snapshot . #projectRoot) $ do + recovery <- recoverAtEntry (plan ^. #snapshot . #projectRoot) case recovery of Left err -> pure (Left err) Right () -> do @@ -200,11 +203,11 @@ if not (Set.null stale) then pure (Left (UpdatePlanStale stale)) else - if plan.request.dryRun + if plan ^. #request . #dryRun then pure (Right (dryRunResult plan)) else - if not (Set.null (unresolvedPaths plan.reconciliation)) - then pure (Left (UpdateHasUnresolvedPaths (unresolvedPaths plan.reconciliation))) + if not (Set.null (unresolvedPaths (plan ^. #reconciliation))) + then pure (Left (UpdateHasUnresolvedPaths (unresolvedPaths (plan ^. #reconciliation)))) else if isStructuredNoOp plan then pure (Right (noOpResult plan)) @@ -212,40 +215,40 @@ applyAcceptedPlan :: UpdatePlan -> IO (Either UpdateError UpdateResult) applyAcceptedPlan plan = do - transactionResult <- beginUpdateTransaction plan.snapshot.projectRoot plan.snapshot.transactionTargets + transactionResult <- beginUpdateTransaction (plan ^. #snapshot . #projectRoot) (plan ^. #snapshot . #transactionTargets) case transactionResult of Left err -> pure (Left (UpdateTransactionFailed err)) Right transaction -> do - backupResult <- prepareServiceBackups transaction plan.snapshot.installedDirectory plan.migrations plan.candidateArtifacts + backupResult <- prepareServiceBackups transaction (plan ^. #snapshot . #installedDirectory) (plan ^. #migrations) (plan ^. #candidateArtifacts) case backupResult of Left err -> abortUpdate transaction err Right () -> do now <- getCurrentTime - migrated <- runRealMigrations now plan.snapshot.originalManifest plan.migrations + migrated <- runRealMigrations now (plan ^. #snapshot . #originalManifest) (plan ^. #migrations) case migrated of Left err -> abortUpdate transaction err Right migratedManifest -> do actualReconciliation <- planActualReconciliation plan migratedManifest case actualReconciliation of Left err -> abortUpdate transaction err - Right actual -> case reapplyPlannedResolutions plan.reconciliation actual of + Right actual -> case reapplyPlannedResolutions (plan ^. #reconciliation) actual of Left _ -> abortUpdate transaction ( UpdateChangedAfterMigrationCommand - (reconciliationSummary plan.reconciliation) + (reconciliationSummary (plan ^. #reconciliation)) (reconciliationSummary actual) ) Right resolvedActual - | resolvedActual /= plan.reconciliation -> + | resolvedActual /= plan ^. #reconciliation -> abortUpdate transaction ( UpdateChangedAfterMigrationCommand - (reconciliationSummary plan.reconciliation) + (reconciliationSummary (plan ^. #reconciliation)) (reconciliationSummary resolvedActual) ) | otherwise -> do - let reconciliationManifest = migratedManifest {genAt = now} + let reconciliationManifest = (migratedManifest & #genAt .~ now) appliedFiles <- applyReconciliation transaction resolvedActual reconciliationManifest case appliedFiles of Left err -> abortUpdate transaction (UpdateTransactionFailed err) @@ -253,7 +256,7 @@ commandResult <- runEff $ runProcessIO $ - executeCommandPlan now plan.commandPlan + executeCommandPlan now (plan ^. #commandPlan) case commandResult of Left err -> abortUpdate @@ -265,11 +268,11 @@ case markerResult of Left err -> abortUpdate transaction err Right () -> do - publication <- publishCandidates plan.candidateArtifacts + publication <- publishCandidates (plan ^. #candidateArtifacts) case publication of Left err -> abortUpdate transaction err Right () -> do - written <- writeManifestIO plan.snapshot.manifestPath finalManifest + written <- writeManifestIO (plan ^. #snapshot . #manifestPath) finalManifest case written of Left err -> abortUpdate transaction err Right () -> finishCommitted transaction plan finalManifest completedReceipts @@ -281,56 +284,56 @@ UTCTime -> AppliedComposition -> IO (Either UpdateError PlannedApplication) -planApplication request installedDirectory catalog now previous = do +planApplication request projectRoot catalog now previous = do fallback <- defaultSearchPaths case candidateRoot catalog previous of Left err -> pure (Left err) Right (primary, recipeAdditional, recipeOverrides, targetArtifact) -> do - let allAdditional = recipeAdditional <> previous.additionalModules - loaded <- loadComposition (catalog.searchRoot : fallback) primary allAdditional + let allAdditional = recipeAdditional <> (previous ^. #additionalModules) + loaded <- loadComposition (catalog ^. #searchRoot : fallback) primary allAdditional case loaded of - Left err -> pure (Left (CandidateLoadFailed primary.unModuleName err)) + Left err -> pure (Left (CandidateLoadFailed (primary ^. #unModuleName) err)) Right modulesInOrder -> do let savedValues - | request.reconfigure = Map.empty + | (request ^. #reconfigure) = Map.empty | otherwise = savedInstanceValues previous - namespace = fromMaybe (deriveNamespace primary) previous.namespace - context = fromMaybe "" previous.context + namespace = fromMaybe (deriveNamespace primary) (previous ^. #namespace) + context = fromMaybe "" (previous ^. #context) resolved <- resolveApplicationValues request namespace context savedValues recipeOverrides modulesInOrder case resolved of Left err -> pure (Left err) Right resolvedValues -> do compiled <- compileComposedPlan - [ (instanceId, modul, directory, Map.map (.value) (resolvedValues Map.! instanceId)) + [ (instanceId, modul, directory, Map.map (^. #value) (resolvedValues Map.! instanceId)) | (instanceId, modul, directory) <- modulesInOrder ] case compiled of Left errors -> pure (Left (UpdateCompositionFailed errors)) Right (operations, compositionWarnings, rawOwners) -> do - let targetSource = publishedArtifactSource installedDirectory targetArtifact - candidate0 = - ( buildAppliedComposition - previous.target - targetSource - targetArtifact.version - previous.additionalModules - (Just namespace) - previous.context - modulesInOrder - resolvedValues - now - ) - { applicationId = previous.applicationId - } + targetOrigin <- publishedArtifactOrigin projectRoot targetArtifact + originedModules <- traverse (withInstanceOrigin projectRoot catalog) modulesInOrder + let candidate0 = + buildAppliedComposition + (previous ^. #target) + targetOrigin + (targetArtifact ^. #version) + (previous ^. #additionalModules) + (Just namespace) + (previous ^. #context) + originedModules + resolvedValues + now + & #applicationId + .~ (previous ^. #applicationId) candidate = setCompositionState - (map (publishInstanceSource installedDirectory catalog) candidate0.instances) - previous.commandReceipts + (candidate0 ^. #instances) + (previous ^. #commandReceipts) candidate0 desiredOwners = Map.map - (\owner -> DesiredFileOwner owner (Set.singleton candidate.applicationId)) + (\owner -> DesiredFileOwner owner (Set.singleton (candidate ^. #applicationId))) rawOwners renderedWarnings = map compositionWarning compositionWarnings pure @@ -352,19 +355,19 @@ CandidateCatalog -> AppliedComposition -> Either UpdateError (ModuleName, [ModuleName], Map VarName Text, CandidateArtifact) -candidateRoot catalog previous = case previous.target of +candidateRoot catalog previous = case previous ^. #target of AppliedModuleTarget name -> do - artifact <- lookupArtifact catalog CandidateModule name.unModuleName + artifact <- lookupArtifact catalog CandidateModule (name ^. #unModuleName) Right (name, [], Map.empty, artifact) AppliedRecipeTarget name -> do - artifact <- lookupArtifact catalog CandidateRecipe name.unRecipeName - recipe <- maybe (Left (CandidateArtifactMissing CandidateRecipe name.unRecipeName)) Right artifact.recipeDefinition - (primary, additional, overrides, _, _) <- first (CandidateRepositoryInvalid name.unRecipeName) (expandRecipe recipe) + artifact <- lookupArtifact catalog CandidateRecipe (name ^. #unRecipeName) + recipe <- maybe (Left (CandidateArtifactMissing CandidateRecipe (name ^. #unRecipeName))) Right (artifact ^. #recipeDefinition) + (primary, additional, overrides, _, _) <- first (CandidateRepositoryInvalid (name ^. #unRecipeName)) (expandRecipe recipe) Right (primary, additional, overrides, artifact) lookupArtifact :: CandidateCatalog -> CandidateArtifactKind -> Text -> Either UpdateError CandidateArtifact lookupArtifact catalog kind name = - maybe (Left (CandidateArtifactMissing kind name)) Right (Map.lookup (kind, name) catalog.artifacts) + maybe (Left (CandidateArtifactMissing kind name)) Right (Map.lookup (kind, name) (catalog ^. #artifacts)) resolveApplicationValues :: UpdateRequest -> @@ -380,10 +383,10 @@ case configs of Left err -> pure (Left err) Right (localConfig, namespaceConfig, contextConfig, globalConfig) -> do - let cli = Map.fromList [(VarName name, value) | (name, value) <- request.varOverrides] + let cli = Map.fromList [(VarName name, value) | (name, value) <- request ^. #varOverrides] overrides = Map.union cli recipeOverrides env = Map.fromList [(T.pack key, T.pack value) | (key, value) <- envPairs] - promptPermission = case request.promptPolicy of + promptPermission = case request ^. #promptPolicy of AllowPrompts -> PromptsAllowed ForbidPrompts -> PromptsForbidden result <- @@ -421,27 +424,28 @@ selectAndSeedLegacy :: UpdateRequest -> + FilePath -> Manifest -> UTCTime -> IO (Either UpdateError ([AppliedComposition], [UpdateWarning])) -selectAndSeedLegacy request manifest now = case selectApplications request.selection manifest of +selectAndSeedLegacy request projectRoot manifest now = case selectApplications (request ^. #selection) manifest of Left err -> pure (Left err) Right (RecordedSelection selected) -> pure (Right (selected, [])) - Right (LegacySelection name) -> seedLegacyApplication request manifest now name + Right (LegacySelection name) -> seedLegacyApplication request projectRoot manifest now name seedLegacyApplication :: - UpdateRequest -> Manifest -> UTCTime -> Text -> IO (Either UpdateError ([AppliedComposition], [UpdateWarning])) -seedLegacyApplication request manifest now requested = do + UpdateRequest -> FilePath -> Manifest -> UTCTime -> Text -> IO (Either UpdateError ([AppliedComposition], [UpdateWarning])) +seedLegacyApplication request projectRoot manifest now requested = do searchPaths <- defaultSearchPaths discovered <- discoverRunnable searchPaths (ModuleName requested) case discovered of Left err -> pure (Left (CandidateLoadFailed requested err)) Right runnable -> do let root = case runnable of - RunnableModule modul directory -> Right (AppliedModuleTarget modul.name, modul.name, [], Map.empty, directory, modul.version) + RunnableModule modul directory -> Right (AppliedModuleTarget (modul ^. #name), modul ^. #name, [], Map.empty, directory, modul ^. #version) RunnableRecipe recipe directory -> do (primary, additional, overrides, _, _) <- first (CandidateRepositoryInvalid requested) (expandRecipe recipe) - Right (AppliedRecipeTarget recipe.name, primary, additional, overrides, directory, recipe.version) + Right (AppliedRecipeTarget (recipe ^. #name), primary, additional, overrides, directory, recipe ^. #version) _ -> Left (CandidateArtifactMissing CandidateModule requested) case root of Left err -> pure (Left err) @@ -456,9 +460,18 @@ case resolved of Left err -> pure (Left err) Right resolvedValues -> do + targetOrigin <- detectArtifactOrigin projectRoot targetSource + originedModules <- + traverse + (\(instanceId, modul, directory) -> (instanceId,modul,) <$> detectArtifactOrigin projectRoot directory) + modulesInOrder let provisional0 = - buildAppliedComposition target targetSource targetVersion [] (Just namespace) Nothing modulesInOrder resolvedValues now - provisional = provisional0 {instances = map (restoreLegacyVersion manifest) provisional0.instances} + buildAppliedComposition target targetOrigin targetVersion [] (Just namespace) Nothing originedModules resolvedValues now + provisional = + ( provisional0 + & #instances + %~ map (restoreLegacyVersion manifest) + ) pure (Right ([provisional], warnings)) legacySavedValues :: @@ -467,48 +480,48 @@ (SavedInstanceValues, [UpdateWarning]) legacySavedValues manifest modulesInOrder = (saved, warnings) where - declarations = [(instanceId, declaration) | (instanceId, modul, _) <- modulesInOrder, declaration <- modul.vars] - counts = Map.fromListWith (+) [(declaration.name, 1 :: Int) | (_, declaration) <- declarations] + declarations = [(instanceId, declaration) | (instanceId, modul, _) <- modulesInOrder, declaration <- modul ^. #vars] + counts = Map.fromListWith (+) [(declaration ^. #name, 1 :: Int) | (_, declaration) <- declarations] saved = Map.fromListWith Map.union - [ (instanceId, Map.singleton declaration.name value) + [ (instanceId, Map.singleton (declaration ^. #name) value) | (instanceId, declaration) <- declarations, - Map.lookup declaration.name counts == Just 1, - Just value <- [Map.lookup declaration.name manifest.vars] + Map.lookup (declaration ^. #name) counts == Just 1, + Just value <- [Map.lookup (declaration ^. #name) (manifest ^. #vars)] ] ambiguous = [ AmbiguousLegacyValue name | (name, count) <- Map.toAscList counts, count > 1, - Map.member name manifest.vars + Map.member name (manifest ^. #vars) ] missing = - [ MissingLegacyValue declaration.name + [ MissingLegacyValue (declaration ^. #name) | (_, declaration) <- declarations, - declaration.required, - Map.notMember declaration.name manifest.vars + declaration ^. #required, + Map.notMember (declaration ^. #name) (manifest ^. #vars) ] warnings = ambiguous <> missing restoreLegacyVersion :: Manifest -> AppliedInstanceState -> AppliedInstanceState restoreLegacyVersion manifest state = - case find (\applied -> applied.name == state.name && applied.parentVars == state.parentVars) manifest.modules of + case find (\applied -> applied ^. #name == state ^. #name && applied ^. #parentVars == state ^. #parentVars) (manifest ^. #modules) of Nothing -> state Just applied -> AppliedInstanceState - { name = state.name, - parentVars = state.parentVars, - source = applied.source, - moduleVersion = applied.moduleVersion, - resolvedVars = state.resolvedVars + { name = state ^. #name, + parentVars = state ^. #parentVars, + origin = applied ^. #origin, + moduleVersion = applied ^. #moduleVersion, + resolvedVars = state ^. #resolvedVars } savedInstanceValues :: AppliedComposition -> SavedInstanceValues savedInstanceValues application = Map.fromList - [ (ModuleInstance state.name state.parentVars, state.resolvedVars) - | state <- application.instances + [ (ModuleInstance (state ^. #name) (state ^. #parentVars), state ^. #resolvedVars) + | state <- application ^. #instances ] combineApplicationPlans :: @@ -518,22 +531,22 @@ where addApplication (operations, owners, warnings) application = let crossWarnings = - [ CrossApplicationLastWriter path prior.moduleName next.moduleName - | (path, next) <- Map.toAscList application.desiredOwners, + [ CrossApplicationLastWriter path (prior ^. #moduleName) (next ^. #moduleName) + | (path, next) <- Map.toAscList (application ^. #desiredOwners), Just prior <- [Map.lookup path owners], - prior.moduleName /= next.moduleName + prior ^. #moduleName /= next ^. #moduleName ] - mergedOwners = Map.unionWith mergeOwner application.desiredOwners owners - in (operations <> application.operations, mergedOwners, warnings <> crossWarnings) + mergedOwners = Map.unionWith mergeOwner (application ^. #desiredOwners) owners + in (operations <> application ^. #operations, mergedOwners, warnings <> crossWarnings) mergeOwner newest prior = - DesiredFileOwner newest.moduleName (Set.union newest.applicationIds prior.applicationIds) + DesiredFileOwner (newest ^. #moduleName) (Set.union (newest ^. #applicationIds) (prior ^. #applicationIds)) materializeStagedProject :: FilePath -> FilePath -> PureFS -> [Operation] -> IO FilePath materializeStagedProject sessionDirectory projectRoot filesystem operations = do let stageRoot = sessionDirectory "staged-project" Directory.createDirectoryIfMissing True stageRoot - forM_ (Map.toAscList filesystem.files) $ \(path, content) -> writeStageFile stageRoot path content - forM_ (Set.toAscList filesystem.dirs) $ \path -> Directory.createDirectoryIfMissing True (stageRoot path) + forM_ (Map.toAscList (filesystem ^. #files)) $ \(path, content) -> writeStageFile stageRoot path content + forM_ (Set.toAscList (filesystem ^. #dirs)) $ \path -> Directory.createDirectoryIfMissing True (stageRoot path) forM_ (Set.toAscList (Set.fromList (mapMaybe operationDestination operations))) $ \path -> do stagedExists <- Directory.doesFileExist (stageRoot path) when (not stagedExists) $ do @@ -554,45 +567,58 @@ operationDestination _ = Nothing versionEvidence :: + -- | Whether @--allow-downgrade@ was passed. + Bool -> + FilePath -> CandidateCatalog -> [AppliedComposition] -> [PlannedApplication] -> IO (Either UpdateError ([VersionChange], [UpdateWarning])) -versionEvidence catalog previousApplications plannedApplications = do +versionEvidence allowDowngrade projectRoot catalog previousApplications plannedApplications = do evidence <- fmap concat $ sequence (zipWith applicationEvidence previousApplications plannedApplications) pure $ do changes <- sequence evidence let actualChanges = filter isActualChange changes - traverse_ validateVersionChange actualChanges + traverse_ (validateVersionChange allowDowngrade) actualChanges let unique = Map.elems (Map.fromList [(versionKey change, change) | change <- actualChanges]) warnings = - [ SameVersionContentChanged change.name + [ SameVersionContentChanged (change ^. #name) | change <- unique, - change.sameVersionContentChanged, - isJust change.fromVersion + change ^. #sameVersionContentChanged, + isJust (change ^. #fromVersion) ] Right (unique, warnings) where applicationEvidence previous planned = do - instanceEvidence <- traverse (instanceVersionEvidence previous) planned.modulesInOrder + instanceEvidence <- traverse (instanceVersionEvidence previous) (planned ^. #modulesInOrder) targetEvidence <- targetVersionEvidence previous pure (targetEvidence : instanceEvidence) instanceVersionEvidence previous (instanceId, candidateModule, _) = do - let prior = find (\state -> state.name == instanceId.instanceModule && state.parentVars == instanceId.instanceParentVars) previous.instances + let prior = find (\state -> state ^. #name == instanceId ^. #module_ && state ^. #parentVars == instanceId ^. #parentVars) (previous ^. #instances) case prior of - Nothing -> pure (Right (VersionChange candidateModule.name.unModuleName Nothing candidateModule.version False)) - Just old -> compareArtifact old.name.unModuleName old.moduleVersion candidateModule.version old.source CandidateModule + Nothing -> pure (Right (VersionChange (candidateModule ^. #name . #unModuleName) Nothing (candidateModule ^. #version) False)) + Just old -> compareArtifact (old ^. #name . #unModuleName) (old ^. #moduleVersion) (candidateModule ^. #version) (old ^. #origin) CandidateModule - targetVersionEvidence previous = case previous.target of + targetVersionEvidence previous = case previous ^. #target of AppliedModuleTarget _ -> pure (Right (VersionChange "" Nothing Nothing False)) - AppliedRecipeTarget name -> compareArtifact name.unRecipeName previous.targetVersion (candidateVersion CandidateRecipe name.unRecipeName) previous.targetSource CandidateRecipe + AppliedRecipeTarget name -> compareArtifact (name ^. #unRecipeName) (previous ^. #targetVersion) (candidateVersion CandidateRecipe (name ^. #unRecipeName)) (previous ^. #targetOrigin) CandidateRecipe - candidateVersion kind name = (.version) =<< Map.lookup (kind, name) catalog.artifacts + candidateVersion kind name = (^. #version) =<< Map.lookup (kind, name) (catalog ^. #artifacts) - compareArtifact name fromVersion toVersion oldSource kind = do - oldHashResult <- try @SomeException (hashArtifactDirectory oldSource) - let candidateHash = (.contentHash) <$> Map.lookup (kind, name) catalog.artifacts + -- The manifest records no path, so the already-applied artifact has to be + -- located from its recorded origin before its content can be hashed. A + -- resolution failure keeps the existing conservative behaviour of treating + -- the artifact as changed: this produces an advisory warning, not a + -- correctness gate. Aborting on a stale or missing artifact is the job of + -- docs/plans/78-refuse-accidental-module-downgrades-and-origin-mismatches.md. + compareArtifact name fromVersion toVersion oldOrigin kind = do + searchPaths <- defaultSearchPaths + resolved <- resolveArtifactOrigin projectRoot searchPaths (definitionFileFor kind) oldOrigin + oldHashResult <- case resolved of + Left refErr -> pure (Left (toException (userError (T.unpack (renderArtifactRefError refErr))))) + Right oldSource -> try @SomeException (hashArtifactDirectory oldSource) + let candidateHash = (^. #contentHash) <$> Map.lookup (kind, name) (catalog ^. #artifacts) changed = case (oldHashResult, candidateHash) of (Right oldHash, Just newHash) -> oldHash /= newHash _ -> True @@ -606,34 +632,46 @@ } ) - versionKey change = (change.name, change.fromVersion, change.toVersion, change.sameVersionContentChanged) + definitionFileFor CandidateModule = "module.dhall" + definitionFileFor CandidateRecipe = "recipe.dhall" + + versionKey change = (change ^. #name, change ^. #fromVersion, change ^. #toVersion, change ^. #sameVersionContentChanged) isActualChange change = - not (T.null change.name) - && (change.fromVersion /= change.toVersion || change.sameVersionContentChanged) + not (T.null (change ^. #name)) + && (change ^. #fromVersion /= change ^. #toVersion || change ^. #sameVersionContentChanged) -validateVersionChange :: VersionChange -> Either UpdateError () -validateVersionChange change - | T.null change.name = Right () - | otherwise = case (change.fromVersion, change.toVersion) of +-- | Refuse a candidate that would move the project to a lower version than +-- the manifest records, unless @--allow-downgrade@ was passed. +-- +-- @fromVersion@ is the version @.seihou\/manifest.json@ records for the +-- already-applied artifact and @toVersion@ is the candidate's. Note what this +-- does *not* need to guard: the candidate is cloned from the origin URL the +-- manifest itself records (see 'Seihou.CLI.Update.Source.remoteProvenance'), +-- never from whatever happens to be installed on this machine, so an update +-- cannot silently substitute a same-named artifact from a different source. +validateVersionChange :: Bool -> VersionChange -> Either UpdateError () +validateVersionChange allowDowngrade change + | T.null (change ^. #name) = Right () + | otherwise = case (change ^. #fromVersion, change ^. #toVersion) of (Just fromText, Just toText) -> do - fromVersion <- maybe (Left (CandidateVersionInvalid change.name fromText)) Right (parseVersion fromText) - toVersion <- maybe (Left (CandidateVersionInvalid change.name toText)) Right (parseVersion toText) - if toVersion < fromVersion - then Left (CandidateDowngrade change.name change.fromVersion change.toVersion) + fromVersion <- maybe (Left (CandidateVersionInvalid (change ^. #name) fromText)) Right (parseVersion fromText) + toVersion <- maybe (Left (CandidateVersionInvalid (change ^. #name) toText)) Right (parseVersion toText) + if toVersion < fromVersion && not allowDowngrade + then Left (CandidateDowngrade (change ^. #name) (change ^. #fromVersion) (change ^. #toVersion)) else Right () _ -> Right () artifactsUsedBy :: CandidateCatalog -> [PlannedApplication] -> [CandidateArtifact] -artifactsUsedBy catalog planned = Map.elems (Map.restrictKeys catalog.artifacts keys) +artifactsUsedBy catalog planned = Map.elems (Map.restrictKeys (catalog ^. #artifacts) keys) where keys = Set.fromList $ concatMap applicationKeys planned applicationKeys application = - targetKey application.candidate.target - : [(CandidateModule, modul.name.unModuleName) | (_, modul, _) <- application.modulesInOrder] - targetKey (AppliedModuleTarget name) = (CandidateModule, name.unModuleName) - targetKey (AppliedRecipeTarget name) = (CandidateRecipe, name.unRecipeName) + targetKey (application ^. #candidate . #target) + : [(CandidateModule, modul ^. #name . #unModuleName) | (_, modul, _) <- application ^. #modulesInOrder] + targetKey (AppliedModuleTarget name) = (CandidateModule, name ^. #unModuleName) + targetKey (AppliedRecipeTarget name) = (CandidateRecipe, name ^. #unRecipeName) summarizeInputChanges :: [UpdateWarning] -> [PlannedApplication] -> InputChangeSummary summarizeInputChanges seedWarnings planned = @@ -648,19 +686,19 @@ ambiguousLegacy = [name | AmbiguousLegacyValue name <- seedWarnings] } summarizeApplication summary application = - let prior = maybe Map.empty savedInstanceValues application.previous - candidateValues = application.resolvedValues + let prior = maybe Map.empty savedInstanceValues (application ^. #previous) + candidateValues = (application ^. #resolvedValues) resolvedList = [ (instanceId, name, value) | (instanceId, values) <- Map.toList candidateValues, (name, value) <- Map.toList values ] - reusedCount = length [() | (_, _, value) <- resolvedList, value.source == FromApplication] + reusedCount = length [() | (_, _, value) <- resolvedList, value ^. #source == FromApplication] overriddenCount = length [ () | (instanceId, name, value) <- resolvedList, - value.source == FromCLI, + value ^. #source == FromCLI, Map.member name (Map.findWithDefault Map.empty instanceId prior) ] newCount = @@ -677,22 +715,25 @@ Map.notMember name (Map.findWithDefault Map.empty instanceId candidateValues) ] in summary - { reused = summary.reused + reusedCount, - overridden = summary.overridden + overriddenCount, - newlyResolved = summary.newlyResolved + newCount, - removed = summary.removed + removedCount - } + & #reused + %~ (+ reusedCount) + & #overridden + %~ (+ overriddenCount) + & #newlyResolved + %~ (+ newCount) + & #removed + %~ (+ removedCount) transactionTargetPaths :: Manifest -> ReconciliationPlan -> [PlannedUpdateMigration] -> Set FilePath transactionTargetPaths manifest reconciliation migrations = - Map.keysSet reconciliation.files `Set.union` Set.fromList (concatMap migrationTargets migrations) + Map.keysSet (reconciliation ^. #files) `Set.union` Set.fromList (concatMap migrationTargets migrations) where - migrationTargets migration = concatMap targets migration.stagedPlan.planOps + migrationTargets migration = concatMap targets (migration ^. #stagedPlan . #ops) targets (MoveFileInst source destination _) = [source, destination] targets (DeleteFileInst path _) = [path] targets (MoveDirInst source destination) = - concatMap (moveDirectoryTarget source destination) (Map.keys manifest.files) - targets (DeleteDirInst path) = filter (isPathAtOrBelow path) (Map.keys manifest.files) + concatMap (moveDirectoryTarget source destination) (Map.keys (manifest ^. #files)) + targets (DeleteDirInst path) = filter (isPathAtOrBelow path) (Map.keys (manifest ^. #files)) targets RunCommandInst {} = [] moveDirectoryTarget source destination path | isPathAtOrBelow source path = [path, replacePrefix source destination path] @@ -721,27 +762,27 @@ stalePlanPaths plan = do currentProject <- observePaths - plan.snapshot.projectRoot - (Map.keysSet plan.snapshot.observedProjectHashes) - candidateChecks <- forM (Map.toAscList plan.snapshot.candidateHashes) $ \(path, expected) -> do + (plan ^. #snapshot . #projectRoot) + (Map.keysSet (plan ^. #snapshot . #observedProjectHashes)) + candidateChecks <- forM (Map.toAscList (plan ^. #snapshot . #candidateHashes)) $ \(path, expected) -> do current <- try @SomeException (hashArtifactDirectory path) pure $ case current of Right actual | actual == expected -> [] _ -> [path] let projectChanges = Map.keysSet - (Map.filterWithKey (\path observed -> Map.lookup path currentProject /= Just observed) plan.snapshot.observedProjectHashes) + (Map.filterWithKey (\path observed -> Map.lookup path currentProject /= Just observed) (plan ^. #snapshot . #observedProjectHashes)) pure (Set.union projectChanges (Set.fromList (concat candidateChecks))) planActualReconciliation :: UpdatePlan -> Manifest -> IO (Either UpdateError ReconciliationPlan) planActualReconciliation plan manifest = do - let (operations, owners, _) = combineApplicationPlans plan.plannedApplications - selected = Set.fromList (map (.applicationId) plan.applications) + let (operations, owners, _) = combineApplicationPlans (plan ^. #plannedApplications) + selected = Set.fromList (map (^. #applicationId) (plan ^. #applications)) result <- runEff $ runFilesystem $ - runBaselineStore plan.snapshot.baselineDirectory $ - planReconciliation plan.snapshot.projectRoot manifest selected operations owners + runBaselineStore (plan ^. #snapshot . #baselineDirectory) $ + planReconciliation (plan ^. #snapshot . #projectRoot) manifest selected operations owners pure (first UpdateReconciliationFailed result) -- | Reapply choices gathered after the initial read-only plan to the @@ -753,10 +794,10 @@ ReconciliationPlan -> Either ReconciliationError ReconciliationPlan reapplyPlannedResolutions planned actual = - foldM reapplyOne actual (Map.toAscList planned.files) + foldM reapplyOne actual (Map.toAscList (planned ^. #files)) where reapplyOne actual (path, FileConflict _ _ _ _ _ _ (Just resolved)) = - resolveFileConflict path resolved.choice actual + resolveFileConflict path (resolved ^. #choice) actual reapplyOne actual (path, FileOrphanEdited _ _ _ _ (Just choice)) = resolveEditedOrphan path choice actual reapplyOne actual _ = Right actual @@ -767,13 +808,13 @@ where go current [] = pure (Right current) go current (migration : rest) = do - classified <- classifyMigration current migration.sourcePlan + classified <- classifyMigration current (migration ^. #sourcePlan) case classified of - Left err -> pure (Left (UpdateMigrationFailed migration.moduleName err)) + Left err -> pure (Left (UpdateMigrationFailed (migration ^. #moduleName) err)) Right executable -> do executed <- executeMigration False executable current now case executed of - Left err -> pure (Left (UpdateMigrationFailed migration.moduleName err)) + Left err -> pure (Left (UpdateMigrationFailed (migration ^. #moduleName) err)) Right next -> go next rest buildFinalManifest :: UTCTime -> UpdatePlan -> Manifest -> [CommandReceipt] -> Manifest @@ -781,64 +822,64 @@ Manifest { version = currentManifestVersion, genAt = now, - modules = updateAppliedModules filesManifest.modules filesManifest.applications plan.plannedApplications now, - vars = Map.union candidateVars filesManifest.vars, - files = filesManifest.files, - applications = foldl' (flip replaceAppliedComposition) filesManifest.applications finalApplications, + modules = updateAppliedModules (filesManifest ^. #modules) (filesManifest ^. #applications) (plan ^. #plannedApplications) now, + vars = Map.union candidateVars (filesManifest ^. #vars), + files = filesManifest ^. #files, + applications = foldl' (flip replaceAppliedComposition) (filesManifest ^. #applications) finalApplications, recipe = updatedRecipe, - blueprint = filesManifest.blueprint, - blueprintMigrations = filesManifest.blueprintMigrations + blueprint = filesManifest ^. #blueprint, + blueprintMigrations = filesManifest ^. #blueprintMigrations } where - finalApplications = map finalizeApplication plan.plannedApplications + finalApplications = map finalizeApplication (plan ^. #plannedApplications) finalizeApplication application = - let priorReceipts = maybe Map.empty (.commandReceipts) application.previous - applicationPlan = planCommands plan.request.commandPolicy priorReceipts application.operations + let priorReceipts = maybe Map.empty (^. #commandReceipts) (application ^. #previous) + applicationPlan = planCommands (plan ^. #request . #commandPolicy) priorReceipts (application ^. #operations) receipts = finalizeCommandReceipts applicationPlan completedReceipts priorReceipts - in setCompositionState application.candidate.instances receipts application.candidate + in setCompositionState (application ^. #candidate . #instances) receipts (application ^. #candidate) candidateVars = Map.unions - [ Map.map (varValueToText . (.value)) values - | application <- plan.plannedApplications, - values <- Map.elems application.resolvedValues + [ Map.map (varValueToText . (^. #value)) values + | application <- plan ^. #plannedApplications, + values <- Map.elems (application ^. #resolvedValues) ] updatedRecipe = - foldl' updateRecipe filesManifest.recipe finalApplications - updateRecipe current application = case application.target of - AppliedRecipeTarget name -> Just AppliedRecipe {name, recipeVersion = application.targetVersion, appliedAt = now} + foldl' updateRecipe (filesManifest ^. #recipe) finalApplications + updateRecipe current application = case application ^. #target of + AppliedRecipeTarget name -> Just AppliedRecipe {name, recipeVersion = application ^. #targetVersion, appliedAt = now} AppliedModuleTarget _ -> current updateAppliedModules :: [AppliedModule] -> [AppliedComposition] -> [PlannedApplication] -> UTCTime -> [AppliedModule] updateAppliedModules existing recordedApplications applications now = - let modulesInOrder = concatMap (.modulesInOrder) applications - candidateKeys = Set.fromList [(instanceId.instanceModule, instanceId.instanceParentVars) | (instanceId, _, _) <- modulesInOrder] - selectedIds = Set.fromList (map (.candidate.applicationId) applications) + let modulesInOrder = concatMap (^. #modulesInOrder) applications + candidateKeys = Set.fromList [(instanceId ^. #module_, instanceId ^. #parentVars) | (instanceId, _, _) <- modulesInOrder] + selectedIds = Set.fromList (map (^. #candidate . #applicationId) applications) priorSelectedKeys = Set.fromList - [ (state.name, state.parentVars) + [ (state ^. #name, state ^. #parentVars) | application <- applications, - previous <- maybeToList application.previous, - state <- previous.instances + previous <- maybeToList (application ^. #previous), + state <- previous ^. #instances ] protectedKeys = Set.fromList - [ (state.name, state.parentVars) + [ (state ^. #name, state ^. #parentVars) | application <- recordedApplications, - Set.notMember application.applicationId selectedIds, - state <- application.instances + Set.notMember (application ^. #applicationId) selectedIds, + state <- application ^. #instances ] replacedOrRemoved key = Set.member key candidateKeys || (Set.member key priorSelectedKeys && Set.notMember key protectedKeys) - retained = filter (not . replacedOrRemoved . (\applied -> (applied.name, applied.parentVars))) existing + retained = filter (not . replacedOrRemoved . (\applied -> (applied ^. #name, applied ^. #parentVars))) existing updated = [ AppliedModule - { name = instanceId.instanceModule, - parentVars = instanceId.instanceParentVars, - source = publishInstanceDirectory application instanceId, - moduleVersion = modul.version, + { name = instanceId ^. #module_, + parentVars = instanceId ^. #parentVars, + origin = publishedInstance application instanceId ^. #origin, + moduleVersion = modul ^. #version, appliedAt = now, - removal = modul.removal + removal = modul ^. #removal } | (application, instanceId, modul) <- deduplicateInstances applications ] @@ -848,67 +889,75 @@ where expand application = [ (application, instanceId, modul) - | (instanceId, modul, _) <- application.modulesInOrder + | (instanceId, modul, _) <- application ^. #modulesInOrder ] go _ [] = [] go seen (entry@(_, instanceId, _) : rest) | Set.member key seen = go seen rest | otherwise = entry : go (Set.insert key seen) rest where - key = (instanceId.instanceModule, instanceId.instanceParentVars) + key = (instanceId ^. #module_, instanceId ^. #parentVars) - publishInstanceDirectory application instanceId = - case find (\state -> state.name == instanceId.instanceModule && state.parentVars == instanceId.instanceParentVars) application.candidate.instances of - Just state -> state.source + publishedInstance application instanceId = + case find (\state -> state ^. #name == instanceId ^. #module_ && state ^. #parentVars == instanceId ^. #parentVars) (application ^. #candidate . #instances) of + Just state -> state Nothing -> error "candidate application lost a loaded module instance" setCompositionState :: [AppliedInstanceState] -> Map CommandFingerprint CommandReceipt -> AppliedComposition -> AppliedComposition setCompositionState instances receipts composition = AppliedComposition - { applicationId = composition.applicationId, - target = composition.target, - targetSource = composition.targetSource, - targetVersion = composition.targetVersion, - additionalModules = composition.additionalModules, - namespace = composition.namespace, - context = composition.context, + { applicationId = composition ^. #applicationId, + target = composition ^. #target, + targetOrigin = composition ^. #targetOrigin, + targetVersion = composition ^. #targetVersion, + additionalModules = composition ^. #additionalModules, + namespace = composition ^. #namespace, + context = composition ^. #context, instances, commandReceipts = receipts, - appliedAt = composition.appliedAt + appliedAt = composition ^. #appliedAt } -publishInstanceSource :: FilePath -> CandidateCatalog -> AppliedInstanceState -> AppliedInstanceState -publishInstanceSource installedDirectory catalog state = - case Map.lookup (CandidateModule, state.name.unModuleName) catalog.artifacts of - Nothing -> state - Just artifact -> - AppliedInstanceState - { name = state.name, - parentVars = state.parentVars, - source = publishedArtifactSource installedDirectory artifact, - moduleVersion = state.moduleVersion, - resolvedVars = state.resolvedVars - } +-- | The portable manifest identity an artifact will have once this update +-- publishes it. +-- +-- A candidate staged from a git URL is recorded against that URL directly: +-- its staging directory is a temporary clone that no other machine will ever +-- see, so classifying the directory would produce a meaningless answer. A +-- candidate with no URL is classified from the directory it actually came +-- from. +publishedArtifactOrigin :: FilePath -> CandidateArtifact -> IO ArtifactOrigin +publishedArtifactOrigin projectRoot artifact = case artifact ^. #sourceUrl of + Just url -> pure (RemoteOrigin url (artifact ^. #name) (artifact ^. #repoName)) + Nothing -> detectArtifactOrigin projectRoot (artifact ^. #originalDirectory) -publishedArtifactSource :: FilePath -> CandidateArtifact -> FilePath -publishedArtifactSource installedDirectory artifact = - if isJust artifact.sourceUrl - then installedDirectory T.unpack artifact.name - else artifact.originalDirectory +-- | Pair one loaded module instance with the portable origin to record for +-- it. Modules this update stages take the staged candidate's published +-- identity; anything else is classified from the directory discovery found. +withInstanceOrigin :: + FilePath -> + CandidateCatalog -> + (ModuleInstance, Module, FilePath) -> + IO (ModuleInstance, Module, ArtifactOrigin) +withInstanceOrigin projectRoot catalog (instanceId, modul, directory) = do + origin <- case Map.lookup (CandidateModule, instanceId ^. #module_ . #unModuleName) (catalog ^. #artifacts) of + Just artifact -> publishedArtifactOrigin projectRoot artifact + Nothing -> detectArtifactOrigin projectRoot directory + pure (instanceId, modul, origin) publishCandidates :: [CandidateArtifact] -> IO (Either UpdateError ()) publishCandidates artifacts = do result <- try @SomeException $ - forM_ artifacts $ \artifact -> case artifact.sourceUrl of + forM_ artifacts $ \artifact -> case artifact ^. #sourceUrl of Nothing -> pure () Just sourceUrl -> installModuleDir - artifact.originalDirectory - (T.unpack artifact.name) + (artifact ^. #originalDirectory) + (T.unpack (artifact ^. #name)) sourceUrl - artifact.repoName - artifact.version - artifact.tags + (artifact ^. #repoName) + (artifact ^. #version) + (artifact ^. #tags) pure $ first (UpdateCachePublicationFailed . T.pack . displayException) result setCommitMarkers :: UpdateTransaction -> Manifest -> IO (Either UpdateError ()) @@ -953,7 +1002,7 @@ try @SomeException $ runEff $ runFilesystem $ - runBaselineStore plan.snapshot.baselineDirectory $ + runBaselineStore (plan ^. #snapshot . #baselineDirectory) $ pruneBaselines (manifestBaselineRefs manifest) let cleanupWarnings = case completion of Left err -> [RecoveryCleanupDeferred (T.pack (show err))] @@ -961,35 +1010,35 @@ pruneWarnings = case pruneResult of Left err -> [BaselinePruneFailed (T.pack (displayException err))] Right _ -> [] - summary = summarizeCommandPlan plan.commandPlan - originalBaselineRefs = manifestBaselineRefs plan.snapshot.originalManifest + summary = summarizeCommandPlan (plan ^. #commandPlan) + originalBaselineRefs = manifestBaselineRefs (plan ^. #snapshot . #originalManifest) finalBaselineRefs = manifestBaselineRefs manifest changedBaselineRefs = (originalBaselineRefs Set.\\ finalBaselineRefs) `Set.union` (finalBaselineRefs Set.\\ originalBaselineRefs) baselinePaths = Set.map - (\ref -> ".seihou" "baselines" T.unpack ref.unBaselineRef.unSHA256) + (\ref -> ".seihou" "baselines" T.unpack (ref ^. #unBaselineRef . #unSHA256)) changedBaselineRefs touched = - plan.snapshot.transactionTargets + (plan ^. #snapshot . #transactionTargets) `Set.union` baselinePaths `Set.union` Set.singleton (".seihou" "manifest.json") pure ( Right UpdateResult - { updatedApplications = map (.applicationId) plan.applications, + { updatedApplications = map (^. #applicationId) (plan ^. #applications), manifest, - versions = plan.versionChanges, - fileSummary = reconciliationSummary plan.reconciliation, + versions = plan ^. #versionChanges, + fileSummary = reconciliationSummary (plan ^. #reconciliation), commandSummary = CommandSummary { executed = length completedReceipts, - skippedUnchanged = summary.skippedUnchanged, - skippedDisabled = summary.skippedDisabled + skippedUnchanged = summary ^. #skippedUnchanged, + skippedDisabled = summary ^. #skippedDisabled }, touchedPaths = touched, - warnings = plan.warnings <> cleanupWarnings <> pruneWarnings + warnings = plan ^. #warnings <> cleanupWarnings <> pruneWarnings } ) @@ -1011,51 +1060,68 @@ dryRunResult :: UpdatePlan -> UpdateResult dryRunResult plan = (noOpResult plan) - { versions = plan.versionChanges, - fileSummary = reconciliationSummary plan.reconciliation, - commandSummary = commandSummaryForPlan plan.commandPlan, - warnings = plan.warnings - } + & #versions + .~ plan + ^. #versionChanges + & #fileSummary + .~ reconciliationSummary (plan ^. #reconciliation) + & #commandSummary + .~ commandSummaryForPlan (plan ^. #commandPlan) + & #warnings + .~ plan + ^. #warnings noOpResult :: UpdatePlan -> UpdateResult noOpResult plan = UpdateResult { updatedApplications = [], - manifest = plan.snapshot.originalManifest, + manifest = plan ^. #snapshot . #originalManifest, versions = [], - fileSummary = reconciliationSummary plan.reconciliation, + fileSummary = reconciliationSummary (plan ^. #reconciliation), commandSummary = CommandSummary 0 0 0, touchedPaths = Set.empty, - warnings = plan.warnings + warnings = plan ^. #warnings } commandSummaryForPlan :: CommandPlan -> CommandSummary commandSummaryForPlan commandPlan = let summary = summarizeCommandPlan commandPlan - in CommandSummary summary.willRun summary.skippedUnchanged summary.skippedDisabled + in CommandSummary (summary ^. #willRun) (summary ^. #skippedUnchanged) (summary ^. #skippedDisabled) isUpdateNoOp :: UpdatePlan -> Bool isUpdateNoOp plan = - null plan.versionChanges - && null plan.migrations - && plan.inputChanges.overridden == 0 - && plan.inputChanges.newlyResolved == 0 - && plan.inputChanges.removed == 0 - && (summarizeCommandPlan plan.commandPlan).willRun == 0 - && all unchangedFile (Map.elems plan.reconciliation.files) - && and (zipWith sameApplication (mapMaybe (.previous) plan.plannedApplications) plan.applications) + null (plan ^. #versionChanges) + && null (plan ^. #migrations) + && plan ^. #inputChanges . #overridden == 0 + && plan ^. #inputChanges . #newlyResolved == 0 + && plan ^. #inputChanges . #removed == 0 + && (summarizeCommandPlan (plan ^. #commandPlan)) ^. #willRun == 0 + && all unchangedFile (Map.elems (plan ^. #reconciliation . #files)) + && and (zipWith sameApplication (mapMaybe (^. #previous) (plan ^. #plannedApplications)) (plan ^. #applications)) where unchangedFile FileUnchanged {} = True unchangedFile _ = False + -- Compare only what the manifest actually records. Anything derived from + -- where an artifact happens to sit on this machine would differ between a + -- decoded application and a freshly loaded candidate, and would report + -- every re-run as a change. sameApplication previous candidate = - previous.target == candidate.target - && previous.targetSource == candidate.targetSource - && previous.targetVersion == candidate.targetVersion - && previous.additionalModules == candidate.additionalModules - && previous.namespace == candidate.namespace - && previous.context == candidate.context - && previous.instances == candidate.instances - && previous.commandReceipts == candidate.commandReceipts + previous ^. #target == candidate ^. #target + && previous ^. #targetOrigin == candidate ^. #targetOrigin + && previous ^. #targetVersion == candidate ^. #targetVersion + && previous ^. #additionalModules == candidate ^. #additionalModules + && previous ^. #namespace == candidate ^. #namespace + && previous ^. #context == candidate ^. #context + && length (previous ^. #instances) == length (candidate ^. #instances) + && and (zipWith sameInstance (previous ^. #instances) (candidate ^. #instances)) + && previous ^. #commandReceipts == (candidate ^. #commandReceipts) + + sameInstance previous candidate = + previous ^. #name == candidate ^. #name + && previous ^. #parentVars == candidate ^. #parentVars + && previous ^. #origin == candidate ^. #origin + && previous ^. #moduleVersion == candidate ^. #moduleVersion + && previous ^. #resolvedVars == candidate ^. #resolvedVars isStructuredNoOp :: UpdatePlan -> Bool isStructuredNoOp = isUpdateNoOp diff --git a/src/Seihou/CLI/Update/Interaction.hs b/src/Seihou/CLI/Update/Interaction.hs --- a/src/Seihou/CLI/Update/Interaction.hs +++ b/src/Seihou/CLI/Update/Interaction.hs @@ -10,6 +10,7 @@ import Control.Exception (IOException, try) import Control.Monad (foldM) +import Data.Generics.Labels () import Data.Map.Strict qualified as Map import Data.Set qualified as Set import Data.Text qualified as T @@ -49,7 +50,7 @@ UpdatePlan -> Either InteractionError UpdatePlan applyResolutionDecisions decisions plan = do - reconciliation <- foldM applyOne plan.reconciliation decisions + reconciliation <- foldM applyOne (plan ^. #reconciliation) decisions pure plan {reconciliation} where applyOne current (ResolveFile path choice) = @@ -60,7 +61,7 @@ forceResolveUpdatePlan :: UpdatePlan -> Either InteractionError UpdatePlan forceResolveUpdatePlan plan = applyResolutionDecisions decisions plan where - decisions = concatMap forceOne (Map.toAscList plan.reconciliation.files) + decisions = concatMap forceOne (Map.toAscList (plan ^. #reconciliation . #files)) forceOne (path, FileConflict _ _ _ reason _ _ Nothing) = case reason of MergeDriverUnavailable _ -> [] _ -> [ResolveFile path AcceptGenerated] @@ -75,9 +76,9 @@ resolveInteractively mode plan | Set.null remaining = pure (Right plan) | mode == NonInteractive = pure (Left (InteractionRequired remaining)) - | otherwise = go plan (Map.toAscList plan.reconciliation.files) + | otherwise = go plan (Map.toAscList (plan ^. #reconciliation . #files)) where - remaining = unresolvedPaths plan.reconciliation + remaining = unresolvedPaths (plan ^. #reconciliation) go current [] = pure (Right current) go current ((path, reconciliation) : rest) = case reconciliation of FileConflict _ currentText markers reason _ _ Nothing -> do diff --git a/src/Seihou/CLI/Update/Migrations.hs b/src/Seihou/CLI/Update/Migrations.hs --- a/src/Seihou/CLI/Update/Migrations.hs +++ b/src/Seihou/CLI/Update/Migrations.hs @@ -7,6 +7,7 @@ where import Control.Monad (guard) +import Data.Generics.Labels () import Data.List (find) import Data.Map.Strict qualified as Map import Data.Maybe (mapMaybe) @@ -32,21 +33,22 @@ import System.FilePath (takeDirectory) data StagedMigrations = StagedMigrations - { plans :: [PlannedUpdateMigration], - manifest :: Manifest, - filesystem :: PureFS, - warnings :: [UpdateWarning] + { plans :: ![PlannedUpdateMigration], + manifest :: !Manifest, + filesystem :: !PureFS, + warnings :: ![UpdateWarning] } - deriving stock (Eq, Show) + deriving stock (Eq, Generic, Show) data Transition = Transition - { moduleName :: ModuleName, - originUrl :: Maybe Text, - fromVersion :: Text, - toVersion :: Text, - candidateModule :: Module, - sourceDirectory :: FilePath + { moduleName :: !ModuleName, + originUrl :: !(Maybe Text), + fromVersion :: !Text, + toVersion :: !Text, + candidateModule :: !Module, + sourceDirectory :: !FilePath } + deriving stock (Generic) -- | Deduplicate equal module transitions and simulate them against a complete -- snapshot of tracked project text. Shell commands are mocked as successful @@ -70,9 +72,9 @@ stageAll manifest [] planned (finalManifest, stagedPlans) <- stageResult let warnings = - [ MigrationCommandNotSimulated plannedMigration.moduleName command + [ MigrationCommandNotSimulated (plannedMigration ^. #moduleName) command | plannedMigration <- stagedPlans, - RunCommandInst command _ <- plannedMigration.stagedPlan.planOps + RunCommandInst command _ <- plannedMigration ^. #stagedPlan . #ops ] Right StagedMigrations @@ -86,19 +88,19 @@ stageAll manifest completed ((transition, sourcePlan) : rest) = do classified <- classifyMigration manifest sourcePlan case classified of - Left err -> pure (Left (UpdateMigrationStageFailed transition.moduleName err)) + Left err -> pure (Left (UpdateMigrationStageFailed (transition ^. #moduleName) err)) Right stagedPlan -> do - executed <- executeMigration False stagedPlan manifest manifest.genAt + executed <- executeMigration False stagedPlan manifest (manifest ^. #genAt) case executed of - Left err -> pure (Left (UpdateMigrationStageFailed transition.moduleName err)) + Left err -> pure (Left (UpdateMigrationStageFailed (transition ^. #moduleName) err)) Right nextManifest -> let planned = PlannedUpdateMigration - { moduleName = transition.moduleName, - sourceDirectory = transition.sourceDirectory, + { moduleName = transition ^. #moduleName, + sourceDirectory = transition ^. #sourceDirectory, sourcePlan, stagedPlan, - containsCommands = any isCommand stagedPlan.planOps + containsCommands = any isCommand (stagedPlan ^. #ops) } in stageAll nextManifest (planned : completed) rest where @@ -114,7 +116,7 @@ priorByModule = Map.fromListWith Set.union - [ ((transition.moduleName, transition.originUrl), Set.singleton transition.fromVersion) + [ ((transition ^. #moduleName, transition ^. #originUrl), Set.singleton (transition ^. #fromVersion)) | transition <- raw ] case [ (name, Set.toAscList versions) @@ -129,15 +131,15 @@ mapMaybe (transitionFor previous) candidates transitionFor previous (instanceId, candidateModule, sourceDirectory) = do - prior <- find (matches instanceId) previous.instances - fromVersion <- prior.moduleVersion - toVersion <- candidateModule.version + prior <- find (matches instanceId) (previous ^. #instances) + fromVersion <- (prior ^. #moduleVersion) + toVersion <- (candidateModule ^. #version) guard (fromVersion /= toVersion) - let artifact = Map.lookup (CandidateModule, candidateModule.name.unModuleName) catalog.artifacts + let artifact = Map.lookup (CandidateModule, candidateModule ^. #name . #unModuleName) (catalog ^. #artifacts) pure Transition - { moduleName = candidateModule.name, - originUrl = artifact >>= (.sourceUrl), + { moduleName = candidateModule ^. #name, + originUrl = artifact >>= (^. #sourceUrl), fromVersion, toVersion, candidateModule, @@ -145,8 +147,8 @@ } matches instanceId state = - state.name == instanceId.instanceModule - && state.parentVars == instanceId.instanceParentVars + state ^. #name == instanceId ^. #module_ + && state ^. #parentVars == (instanceId ^. #parentVars) deduplicateTransitions :: [Transition] -> [Transition] deduplicateTransitions = go Set.empty @@ -157,28 +159,28 @@ | otherwise = transition : go (Set.insert (transitionKey transition) seen) rest transitionKey transition = - ( transition.moduleName, - transition.originUrl, - transition.fromVersion, - transition.toVersion + ( transition ^. #moduleName, + transition ^. #originUrl, + transition ^. #fromVersion, + transition ^. #toVersion ) planTransition :: Transition -> Either UpdateError (Transition, MigrationPlan) planTransition transition = do fromVersion <- maybe - (Left (CandidateVersionInvalid transition.moduleName.unModuleName transition.fromVersion)) + (Left (CandidateVersionInvalid (transition ^. #moduleName . #unModuleName) (transition ^. #fromVersion))) Right - (parseVersion transition.fromVersion) + (parseVersion (transition ^. #fromVersion)) toVersion <- maybe - (Left (CandidateVersionInvalid transition.moduleName.unModuleName transition.toVersion)) + (Left (CandidateVersionInvalid (transition ^. #moduleName . #unModuleName) (transition ^. #toVersion))) Right - (parseVersion transition.toVersion) + (parseVersion (transition ^. #toVersion)) planned <- first - (UpdateMigrationPlanFailed transition.moduleName) - (planMigrationChain transition.moduleName.unModuleName transition.candidateModule.migrations fromVersion toVersion) + (UpdateMigrationPlanFailed (transition ^. #moduleName)) + (planMigrationChain (transition ^. #moduleName . #unModuleName) (transition ^. #candidateModule . #migrations) fromVersion toVersion) case planned of Nothing -> error "planTransition received unequal versions but no migration plan" Just sourcePlan -> Right (transition, sourcePlan) @@ -186,17 +188,17 @@ commandMocks :: (Transition, MigrationPlan) -> [ProcessMock] commandMocks (_, sourcePlan) = [ ProcessMock - { mockCommand = "/bin/sh", - mockArgs = ["-c", command], - mockResult = (ExitSuccess, "", "") + { command = "/bin/sh", + args = ["-c", command], + result = (ExitSuccess, "", "") } - | migration <- sourcePlan.planSteps, - RunCommand command _ <- migration.ops + | migration <- sourcePlan ^. #steps, + RunCommand command _ <- migration ^. #ops ] snapshotTrackedFiles :: FilePath -> Manifest -> IO PureFS snapshotTrackedFiles projectRoot manifest = do - files <- fmap Map.fromList . fmap concat $ traverse readTracked (Map.keys manifest.files) + files <- fmap Map.fromList . fmap concat $ traverse readTracked (Map.keys (manifest ^. #files)) let directories = Set.fromList [ directory @@ -217,7 +219,7 @@ parents path = takeWhile (\directory -> directory /= "." && directory /= "") (iterate takeDirectory (takeDirectory path)) migrationTouchedPaths :: [PlannedUpdateMigration] -> Set FilePath -migrationTouchedPaths = Set.fromList . concatMap (concatMap touched . (.stagedPlan.planOps)) +migrationTouchedPaths = Set.fromList . concatMap (concatMap touched . (^. #stagedPlan . #ops)) where touched (MoveFileInst source destination _) = [source, destination] touched (MoveDirInst source destination) = [source, destination] @@ -226,7 +228,7 @@ touched RunCommandInst {} = [] migrationTouchesDirectories :: PlannedUpdateMigration -> Bool -migrationTouchesDirectories migration = any touchesDirectory migration.stagedPlan.planOps +migrationTouchesDirectories migration = any touchesDirectory (migration ^. #stagedPlan . #ops) where touchesDirectory MoveDirInst {} = True touchesDirectory DeleteDirInst {} = True diff --git a/src/Seihou/CLI/Update/Recovery.hs b/src/Seihou/CLI/Update/Recovery.hs --- a/src/Seihou/CLI/Update/Recovery.hs +++ b/src/Seihou/CLI/Update/Recovery.hs @@ -11,6 +11,7 @@ import Data.Aeson (FromJSON (..), ToJSON (..), (.:), (.:?), (.=)) import Data.Aeson qualified as Aeson import Data.ByteString.Lazy qualified as LBS +import Data.Generics.Labels () import Data.List (isPrefixOf, sortOn) import Data.Maybe (catMaybes, isJust) import Data.Ord (Down (..)) @@ -30,19 +31,19 @@ deriving stock (Eq, Show) data ServiceBackup = ServiceBackup - { scope :: BackupScope, - target :: FilePath, - backupName :: Maybe FilePath + { scope :: !BackupScope, + target :: !FilePath, + backupName :: !(Maybe FilePath) } - deriving stock (Eq, Show) + deriving stock (Eq, Generic, Show) data ServiceJournal = ServiceJournal - { version :: Int, - installedRoot :: FilePath, - entries :: [ServiceBackup], - expectedManifest :: Maybe Manifest + { version :: !Int, + installedRoot :: !FilePath, + entries :: ![ServiceBackup], + expectedManifest :: !(Maybe Manifest) } - deriving stock (Eq, Show) + deriving stock (Eq, Generic, Show) instance ToJSON BackupScope where toJSON ProjectDirectory = Aeson.String "project-directory" @@ -57,9 +58,9 @@ instance ToJSON ServiceBackup where toJSON entry = Aeson.object - [ "scope" .= entry.scope, - "target" .= entry.target, - "backup" .= entry.backupName + [ "scope" .= (entry ^. #scope), + "target" .= (entry ^. #target), + "backup" .= (entry ^. #backupName) ] instance FromJSON ServiceBackup where @@ -69,10 +70,10 @@ instance ToJSON ServiceJournal where toJSON journal = Aeson.object - [ "version" .= journal.version, - "installedRoot" .= journal.installedRoot, - "entries" .= journal.entries, - "expectedManifest" .= journal.expectedManifest + [ "version" .= (journal ^. #version), + "installedRoot" .= (journal ^. #installedRoot), + "entries" .= (journal ^. #entries), + "expectedManifest" .= (journal ^. #expectedManifest) ] instance FromJSON ServiceJournal where @@ -99,18 +100,18 @@ let projectDirectories = normalizeDirectories (concatMap migrationDirectories migrations) installedNames = Set.toAscList . Set.fromList $ - [ T.unpack artifact.name + [ T.unpack (artifact ^. #name) | artifact <- artifacts, - isJust artifact.sourceUrl + isJust (artifact ^. #sourceUrl) ] requests = map (ProjectDirectory,) projectDirectories <> map (InstalledArtifact,) installedNames - backupRoot = transaction.transactionDirectory "service-backups" + backupRoot = transaction ^. #transactionDirectory "service-backups" result <- try @SomeException $ do Directory.createDirectoryIfMissing True backupRoot entries <- forM (zip [0 :: Int ..] requests) $ \(index, (scope, target)) -> do - fullTarget <- resolveTarget transaction.projectRoot installedRoot scope target + fullTarget <- resolveTarget (transaction ^. #projectRoot) installedRoot scope target exists <- Directory.doesDirectoryExist fullTarget if exists then do @@ -120,7 +121,7 @@ pure ServiceBackup {scope, target, backupName = Just backupName} else pure ServiceBackup {scope, target, backupName = Nothing} writeServiceJournal - transaction.transactionDirectory + (transaction ^. #transactionDirectory) ServiceJournal { version = 1, installedRoot, @@ -131,7 +132,7 @@ setServiceExpectedManifest :: UpdateTransaction -> Manifest -> IO (Either UpdateError ()) setServiceExpectedManifest transaction expected = do - current <- readServiceJournal transaction.transactionDirectory + current <- readServiceJournal (transaction ^. #transactionDirectory) case current of Left err -> pure (Left err) Right Nothing -> pure (Right ()) @@ -139,17 +140,17 @@ result <- try @SomeException $ writeServiceJournal - transaction.transactionDirectory - journal {expectedManifest = Just expected} + (transaction ^. #transactionDirectory) + (journal & #expectedManifest ?~ expected) pure $ first (UpdateManifestWriteFailed . T.pack . displayException) result restoreServiceBackups :: UpdateTransaction -> IO (Either UpdateError ()) restoreServiceBackups transaction = do - current <- readServiceJournal transaction.transactionDirectory + current <- readServiceJournal (transaction ^. #transactionDirectory) case current of Left err -> pure (Left err) Right Nothing -> pure (Right ()) - Right (Just journal) -> restoreJournal transaction.projectRoot transaction.transactionDirectory journal + Right (Just journal) -> restoreJournal (transaction ^. #projectRoot) (transaction ^. #transactionDirectory) journal -- | Restore or accept every service journal before the core transaction -- recovery pass. A durable matching manifest means cache/directory publication @@ -173,7 +174,7 @@ Left err -> pure (Just (Left err)) Right Nothing -> pure Nothing Right (Just journal) -> do - committed <- manifestMatches projectRoot journal.expectedManifest + committed <- manifestMatches projectRoot (journal ^. #expectedManifest) if committed then pure (Just (Right ())) else Just <$> restoreJournal projectRoot transactionDirectory journal @@ -181,11 +182,11 @@ restoreJournal :: FilePath -> FilePath -> ServiceJournal -> IO (Either UpdateError ()) restoreJournal projectRoot transactionDirectory journal = do result <- try @SomeException $ - forM_ (sortOn (Down . pathDepth . (.target)) journal.entries) $ \entry -> do - fullTarget <- resolveTarget projectRoot journal.installedRoot entry.scope entry.target + forM_ (sortOn (Down . pathDepth . (^. #target)) (journal ^. #entries)) $ \entry -> do + fullTarget <- resolveTarget projectRoot (journal ^. #installedRoot) (entry ^. #scope) (entry ^. #target) targetExists <- Directory.doesPathExist fullTarget when targetExists (Directory.removePathForcibly fullTarget) - case entry.backupName of + case entry ^. #backupName of Nothing -> pure () Just backupName -> do validateBackupName backupName @@ -214,7 +215,7 @@ [] -> False migrationDirectories :: PlannedUpdateMigration -> [FilePath] -migrationDirectories migration = concatMap directories migration.stagedPlan.planOps +migrationDirectories migration = concatMap directories (migration ^. #stagedPlan . #ops) where directories (MoveDirInst source destination) = [source, destination] directories (DeleteDirInst path) = [path] diff --git a/src/Seihou/CLI/Update/Render.hs b/src/Seihou/CLI/Update/Render.hs --- a/src/Seihou/CLI/Update/Render.hs +++ b/src/Seihou/CLI/Update/Render.hs @@ -13,6 +13,7 @@ import Data.Aeson (Value, encode, object, (.=)) import Data.ByteString.Lazy (ByteString) +import Data.Generics.Labels () import Data.Map.Strict qualified as Map import Data.Maybe (fromMaybe) import Data.Set qualified as Set @@ -74,26 +75,26 @@ renderUpdateHuman _ (UpdatePlanOutput (UpdatePlanView plan)) = T.unlines $ versionLines plan - <> [ renderInputs plan.inputChanges, - "Migrations: " <> count (length plan.migrations) <> migrationCaveat plan, - renderFiles (reconciliationSummary plan.reconciliation), - renderCommands (summarizeCommandPlan plan.commandPlan) + <> [ renderInputs (plan ^. #inputChanges), + "Migrations: " <> count (length (plan ^. #migrations)) <> migrationCaveat plan, + renderFiles (reconciliationSummary (plan ^. #reconciliation)), + renderCommands (summarizeCommandPlan (plan ^. #commandPlan)) ] - <> conflictLines plan.reconciliation - <> warningLines plan.warnings + <> conflictLines (plan ^. #reconciliation) + <> warningLines (plan ^. #warnings) renderUpdateHuman _ (UpdateAppliedOutput (UpdateResultView result)) = T.unlines $ - [ "Updated " <> count (length result.updatedApplications) <> " application(s).", - renderFiles result.fileSummary, + [ "Updated " <> count (length (result ^. #updatedApplications)) <> " application(s).", + renderFiles (result ^. #fileSummary), "Commands: " - <> count result.commandSummary.executed + <> count (result ^. #commandSummary . #executed) <> " executed; " - <> count result.commandSummary.skippedUnchanged + <> count (result ^. #commandSummary . #skippedUnchanged) <> " unchanged skipped; " - <> count result.commandSummary.skippedDisabled + <> count (result ^. #commandSummary . #skippedDisabled) <> " disabled" ] - <> warningLines result.warnings + <> warningLines (result ^. #warnings) renderUpdateHuman _ (UpdateFailedOutput (UpdateErrorView err)) = "Update failed [" <> errorCode err <> "]: " <> errorMessage err <> "\n" @@ -106,29 +107,29 @@ [ "schemaVersion" .= (1 :: Int), "outcome" .= ("plan" :: Text), "alreadyUpToDate" .= planLooksUnchanged plan, - "applications" .= map applicationIdText plan.applications, - "versions" .= map versionValue plan.versionChanges, - "inputs" .= inputValue plan.inputChanges, - "migrations" .= map migrationValue plan.migrations, - "files" .= map fileValue (Map.toAscList plan.reconciliation.files), - "commands" .= map commandValue plan.commandPlan.commands, - "warnings" .= map warningText plan.warnings + "applications" .= map applicationIdText (plan ^. #applications), + "versions" .= map versionValue (plan ^. #versionChanges), + "inputs" .= inputValue (plan ^. #inputChanges), + "migrations" .= map migrationValue (plan ^. #migrations), + "files" .= map fileValue (Map.toAscList (plan ^. #reconciliation . #files)), + "commands" .= map commandValue (plan ^. #commandPlan . #commands), + "warnings" .= map warningText (plan ^. #warnings) ] outputValue (UpdateAppliedOutput (UpdateResultView result)) = object [ "schemaVersion" .= (1 :: Int), "outcome" .= ("applied" :: Text), - "applications" .= map (.unApplicationId) result.updatedApplications, - "versions" .= map versionValue result.versions, - "files" .= summaryValue result.fileSummary, + "applications" .= map (^. #unApplicationId) (result ^. #updatedApplications), + "versions" .= map versionValue (result ^. #versions), + "files" .= summaryValue (result ^. #fileSummary), "commands" .= object - [ "executed" .= result.commandSummary.executed, - "skippedUnchanged" .= result.commandSummary.skippedUnchanged, - "skippedDisabled" .= result.commandSummary.skippedDisabled + [ "executed" .= (result ^. #commandSummary . #executed), + "skippedUnchanged" .= (result ^. #commandSummary . #skippedUnchanged), + "skippedDisabled" .= (result ^. #commandSummary . #skippedDisabled) ], - "touchedPaths" .= Set.toAscList result.touchedPaths, - "warnings" .= map warningText result.warnings + "touchedPaths" .= Set.toAscList (result ^. #touchedPaths), + "warnings" .= map warningText (result ^. #warnings) ] outputValue (UpdateFailedOutput (UpdateErrorView err)) = object @@ -139,70 +140,70 @@ versionLines :: UpdatePlan -> [Text] versionLines plan - | null plan.versionChanges = ["Versions: unchanged"] - | otherwise = map renderVersionChange plan.versionChanges + | null (plan ^. #versionChanges) = ["Versions: unchanged"] + | otherwise = map renderVersionChange (plan ^. #versionChanges) renderVersionChange :: VersionChange -> Text renderVersionChange change = - change.name + change ^. #name <> " " - <> fromMaybe "unversioned" change.fromVersion + <> fromMaybe "unversioned" (change ^. #fromVersion) <> " -> " - <> fromMaybe "unversioned" change.toVersion - <> if change.sameVersionContentChanged then " (content changed at same version)" else "" + <> fromMaybe "unversioned" (change ^. #toVersion) + <> if change ^. #sameVersionContentChanged then " (content changed at same version)" else "" renderInputs :: InputChangeSummary -> Text renderInputs summary = "Inputs: " - <> count summary.reused + <> count (summary ^. #reused) <> " reused; " - <> count summary.overridden + <> count (summary ^. #overridden) <> " overridden; " - <> count summary.newlyResolved + <> count (summary ^. #newlyResolved) <> " newly resolved; " - <> count summary.removed + <> count (summary ^. #removed) <> " removed" renderFiles :: ReconciliationSummary -> Text renderFiles summary = "Files: " - <> count summary.creates + <> count (summary ^. #creates) <> " created; " - <> count summary.updates + <> count (summary ^. #updates) <> " updated; " - <> count summary.merged + <> count (summary ^. #merged) <> " merged; " - <> count summary.unchanged + <> count (summary ^. #unchanged) <> " unchanged; " - <> count summary.conflicts + <> count (summary ^. #conflicts) <> " conflicts; " - <> count summary.safeDeletes + <> count (summary ^. #safeDeletes) <> " deleted; " - <> count summary.editedOrphans + <> count (summary ^. #editedOrphans) <> " edited orphans" renderCommands summary = "Commands: " - <> count summary.willRun + <> count (summary ^. #willRun) <> " will run; " - <> count summary.skippedUnchanged + <> count (summary ^. #skippedUnchanged) <> " unchanged skipped; " - <> count summary.skippedDisabled + <> count (summary ^. #skippedDisabled) <> " disabled" migrationCaveat plan - | any (.containsCommands) plan.migrations = " (includes non-simulatable commands)" + | any (^. #containsCommands) (plan ^. #migrations) = " (includes non-simulatable commands)" | otherwise = "" conflictLines :: ReconciliationPlan -> [Text] -conflictLines reconciliation = concatMap renderOne (Map.toAscList reconciliation.files) +conflictLines reconciliation = concatMap renderOne (Map.toAscList (reconciliation ^. #files)) where renderOne (path, FileConflict _ _ _ reason _ _ resolution) = [ "Conflict: " <> T.pack path <> " (" <> T.pack (show reason) - <> maybe "; unresolved" (("; " <>) . resolutionText . (.choice)) resolution + <> maybe "; unresolved" (("; " <>) . resolutionText . (^. #choice)) resolution <> ")" ] renderOne (path, FileOrphanEdited _ _ _ _ choice) = @@ -218,30 +219,30 @@ versionValue :: VersionChange -> Value versionValue change = object - [ "name" .= change.name, - "from" .= change.fromVersion, - "to" .= change.toVersion, - "sameVersionContentChanged" .= change.sameVersionContentChanged + [ "name" .= (change ^. #name), + "from" .= (change ^. #fromVersion), + "to" .= (change ^. #toVersion), + "sameVersionContentChanged" .= (change ^. #sameVersionContentChanged) ] inputValue :: InputChangeSummary -> Value inputValue summary = object - [ "reused" .= summary.reused, - "overridden" .= summary.overridden, - "newlyResolved" .= summary.newlyResolved, - "removed" .= summary.removed, - "ambiguousLegacy" .= map (.unVarName) summary.ambiguousLegacy + [ "reused" .= (summary ^. #reused), + "overridden" .= (summary ^. #overridden), + "newlyResolved" .= (summary ^. #newlyResolved), + "removed" .= (summary ^. #removed), + "ambiguousLegacy" .= map (^. #unVarName) (summary ^. #ambiguousLegacy) ] migrationValue :: PlannedUpdateMigration -> Value migrationValue migration = object - [ "module" .= migration.moduleName.unModuleName, - "from" .= showText migration.sourcePlan.planFrom, - "to" .= showText migration.sourcePlan.planTo, - "steps" .= length migration.sourcePlan.planSteps, - "containsCommands" .= migration.containsCommands + [ "module" .= (migration ^. #moduleName . #unModuleName), + "from" .= showText (migration ^. #sourcePlan . #from), + "to" .= showText (migration ^. #sourcePlan . #to), + "steps" .= length (migration ^. #sourcePlan . #steps), + "containsCommands" .= (migration ^. #containsCommands) ] fileValue :: (FilePath, FileReconciliation) -> Value @@ -264,21 +265,21 @@ classification FileAlreadyAbsent {} = "alreadyAbsent" resolutionFor :: FileReconciliation -> Maybe Text -resolutionFor (FileConflict _ _ _ _ _ _ resolution) = resolutionText . (.choice) <$> resolution +resolutionFor (FileConflict _ _ _ _ _ _ resolution) = resolutionText . (^. #choice) <$> resolution resolutionFor (FileOrphanEdited _ _ _ _ choice) = orphanChoiceText <$> choice resolutionFor _ = Nothing commandValue :: PlannedCommand -> Value commandValue planned = object - [ "fingerprint" .= fingerprintText planned.fingerprint, - "status" .= dispositionText planned.disposition, - "module" .= commandModule planned.operation, - "command" .= commandText planned.operation + [ "fingerprint" .= fingerprintText (planned ^. #fingerprint), + "status" .= dispositionText (planned ^. #disposition), + "module" .= commandModule (planned ^. #operation), + "command" .= commandText (planned ^. #operation) ] commandModule :: Operation -> Maybe Text -commandModule RunCommandOp {moduleName} = Just moduleName.unModuleName +commandModule RunCommandOp {moduleName} = Just (moduleName ^. #unModuleName) commandModule _ = Nothing commandText :: Operation -> Maybe Text @@ -305,18 +306,18 @@ summaryValue :: ReconciliationSummary -> Value summaryValue summary = object - [ "created" .= summary.creates, - "updated" .= summary.updates, - "merged" .= summary.merged, - "unchanged" .= summary.unchanged, - "conflicts" .= summary.conflicts, - "safeDeletes" .= summary.safeDeletes, - "editedOrphans" .= summary.editedOrphans, - "sharedOwnership" .= summary.sharedOwnership + [ "created" .= (summary ^. #creates), + "updated" .= (summary ^. #updates), + "merged" .= (summary ^. #merged), + "unchanged" .= (summary ^. #unchanged), + "conflicts" .= (summary ^. #conflicts), + "safeDeletes" .= (summary ^. #safeDeletes), + "editedOrphans" .= (summary ^. #editedOrphans), + "sharedOwnership" .= (summary ^. #sharedOwnership) ] applicationIdText :: AppliedComposition -> Text -applicationIdText application = application.applicationId.unApplicationId +applicationIdText application = (application ^. #applicationId . #unApplicationId) fingerprintText :: CommandFingerprint -> Text fingerprintText (CommandFingerprint (SHA256 value)) = value @@ -334,6 +335,7 @@ errorCode CandidateCloneFailed {} = "candidate_clone_failed" errorCode CandidateRepositoryInvalid {} = "candidate_repository_invalid" errorCode CandidateArtifactMissing {} = "candidate_artifact_missing" +errorCode CandidateArtifactUnresolved {} = "candidate_artifact_unresolved" errorCode CandidateArtifactAmbiguous {} = "candidate_artifact_ambiguous" errorCode CandidateLoadFailed {} = "candidate_load_failed" errorCode CandidateDowngrade {} = "candidate_downgrade" @@ -367,9 +369,9 @@ "Path " <> T.pack path <> " is also owned by application(s) " - <> T.intercalate ", " (map (.unApplicationId) (Set.toAscList required)) + <> T.intercalate ", " (map (^. #unApplicationId) (Set.toAscList required)) <> ". Select every owner or run seihou update with no targets. Selected: " - <> T.intercalate ", " (map (.unApplicationId) (Set.toAscList selected)) + <> T.intercalate ", " (map (^. #unApplicationId) (Set.toAscList selected)) errorMessage (UpdateHasUnresolvedPaths paths) = "Resolve these paths before apply: " <> T.intercalate ", " (map T.pack (Set.toAscList paths)) errorMessage (UpdatePlanStale paths) = @@ -378,13 +380,13 @@ planLooksUnchanged :: UpdatePlan -> Bool planLooksUnchanged plan = - null plan.versionChanges - && null plan.migrations - && plan.inputChanges.overridden == 0 - && plan.inputChanges.newlyResolved == 0 - && plan.inputChanges.removed == 0 - && (summarizeCommandPlan plan.commandPlan).willRun == 0 - && all isUnchanged (Map.elems plan.reconciliation.files) + null (plan ^. #versionChanges) + && null (plan ^. #migrations) + && plan ^. #inputChanges . #overridden == 0 + && plan ^. #inputChanges . #newlyResolved == 0 + && plan ^. #inputChanges . #removed == 0 + && (summarizeCommandPlan (plan ^. #commandPlan)) ^. #willRun == 0 + && all isUnchanged (Map.elems (plan ^. #reconciliation . #files)) where isUnchanged FileUnchanged {} = True isUnchanged _ = False diff --git a/src/Seihou/CLI/Update/Selection.hs b/src/Seihou/CLI/Update/Selection.hs --- a/src/Seihou/CLI/Update/Selection.hs +++ b/src/Seihou/CLI/Update/Selection.hs @@ -7,6 +7,7 @@ where import Control.Monad (foldM) +import Data.Generics.Labels () import Data.Map.Strict qualified as Map import Data.Set qualified as Set import Seihou.CLI.Update.Types @@ -24,34 +25,34 @@ selectApplications :: UpdateSelection -> Manifest -> Either UpdateError SelectedApplications selectApplications selection manifest = case selection of AllRecordedApplications - | null manifest.applications -> Left NoRecordedApplications - | otherwise -> Right (RecordedSelection manifest.applications) + | null (manifest ^. #applications) -> Left NoRecordedApplications + | otherwise -> Right (RecordedSelection (manifest ^. #applications)) NamedUpdateTargets names - | null manifest.applications -> case nubOrd names of + | null (manifest ^. #applications) -> case nubOrd names of [name] -> Right (LegacySelection name) _ -> Left LegacyUpdateRequiresOneTarget | otherwise -> do selectedIds <- foldM selectName Set.empty (nubOrd names) - let selected = filter ((`Set.member` selectedIds) . (.applicationId)) manifest.applications + let selected = filter ((`Set.member` selectedIds) . (^. #applicationId)) (manifest ^. #applications) ensureOwnershipClosure manifest selectedIds Right (RecordedSelection selected) where selectName selected name = - let exact = filter ((== name) . targetName) manifest.applications + let exact = filter ((== name) . targetName) (manifest ^. #applications) matches = if null exact - then filter (containsModule name) manifest.applications + then filter (containsModule name) (manifest ^. #applications) else exact in if null matches then Left (UpdateTargetNotFound name (availableTargets manifest)) - else Right (foldl' (flip (Set.insert . (.applicationId))) selected matches) + else Right (foldl' (flip (Set.insert . (^. #applicationId))) selected matches) ensureOwnershipClosure :: Manifest -> Set ApplicationId -> Either UpdateError () ensureOwnershipClosure manifest selected = case [ (path, selectedOwners, missingOwners) - | (path, record) <- Map.toAscList manifest.files, - let selectedOwners = Set.intersection selected record.applicationIds, - let missingOwners = record.applicationIds Set.\\ selected, + | (path, record) <- Map.toAscList (manifest ^. #files), + let selectedOwners = Set.intersection selected (record ^. #applicationIds), + let missingOwners = (record ^. #applicationIds) Set.\\ selected, not (Set.null selectedOwners), not (Set.null missingOwners) ] of @@ -60,21 +61,21 @@ [] -> Right () targetName :: AppliedComposition -> Text -targetName application = case application.target of - AppliedModuleTarget name -> name.unModuleName - AppliedRecipeTarget name -> name.unRecipeName +targetName application = case application ^. #target of + AppliedModuleTarget name -> (name ^. #unModuleName) + AppliedRecipeTarget name -> (name ^. #unRecipeName) availableTargets :: Manifest -> [Text] -availableTargets manifest = nubOrd (map targetName manifest.applications <> instanceNames) +availableTargets manifest = nubOrd (map targetName (manifest ^. #applications) <> instanceNames) where instanceNames = - [ state.name.unModuleName - | application <- manifest.applications, - state <- application.instances + [ state ^. #name . #unModuleName + | application <- manifest ^. #applications, + state <- application ^. #instances ] containsModule :: Text -> AppliedComposition -> Bool -containsModule name = any ((== name) . (.name.unModuleName)) . (.instances) +containsModule name = any ((== name) . (^. #name . #unModuleName)) . (^. #instances) nubOrd :: (Ord a) => [a] -> [a] nubOrd = go Set.empty diff --git a/src/Seihou/CLI/Update/Source.hs b/src/Seihou/CLI/Update/Source.hs --- a/src/Seihou/CLI/Update/Source.hs +++ b/src/Seihou/CLI/Update/Source.hs @@ -8,6 +8,7 @@ import Control.Monad (foldM, forM) import Data.ByteString qualified as BS import Data.Foldable (traverse_) +import Data.Generics.Labels () import Data.List (sort) import Data.Map.Strict qualified as Map import Data.Text qualified as T @@ -15,10 +16,10 @@ ( OriginInfo (..), cloneRepo, copyDirectoryRecursive, - readOriginInfo, ) import Seihou.CLI.Update.Types -import Seihou.Core.Module (validateModule) +import Seihou.Core.ArtifactRef (ArtifactRefError, resolveArtifactOrigin) +import Seihou.Core.Module (defaultSearchPaths, validateModule) import Seihou.Core.Recipe (validateRecipe) import Seihou.Core.Registry (Registry (..), RegistryEntry (..), validateRegistry) import Seihou.Core.Types @@ -29,27 +30,37 @@ import System.Exit (ExitCode (..)) import System.Process (readProcessWithExitCode) +-- | One artifact an update has to obtain before it can re-plan. +-- +-- @sourceDirectory@ is where the currently-applied copy lives on this +-- machine, resolved from the manifest's recorded origin. It is only consulted +-- for artifacts with no remote to clone from, so a resolution failure is +-- carried rather than raised: an artifact that will be cloned does not need +-- to exist locally at all. data ArtifactRequirement = ArtifactRequirement - { kind :: CandidateArtifactKind, - name :: Text, - sourceDirectory :: FilePath, - origin :: Maybe OriginInfo + { kind :: !CandidateArtifactKind, + name :: !Text, + sourceDirectory :: !(Either ArtifactRefError FilePath), + origin :: !(Maybe OriginInfo) } + deriving stock (Generic) -- | Clone every distinct remote once, validate its complete module/recipe -- catalog, and materialize a name-keyed temporary search root. Local artifacts -- remain a fallback and are called out explicitly. stageCandidateSources :: FilePath -> + FilePath -> + FilePath -> [AppliedComposition] -> IO (Either UpdateError (CandidateCatalog, [UpdateWarning])) -stageCandidateSources sessionRoot selected = do - requirements <- requirementsFor selected +stageCandidateSources sessionRoot projectRoot installedDirectory selected = do + requirements <- requirementsFor projectRoot installedDirectory selected let remoteOrigins = Map.fromList - [ (origin.sourceUrl, origin) + [ (origin ^. #sourceUrl, origin) | requirement <- requirements, - Just origin <- [requirement.origin] + Just origin <- [requirement ^. #origin] ] clonesRoot = sessionRoot "clones" searchRoot = sessionRoot "search" @@ -72,27 +83,45 @@ localWarnings ) -requirementsFor :: [AppliedComposition] -> IO [ArtifactRequirement] -requirementsFor applications = concat <$> mapM applicationRequirements applications +requirementsFor :: FilePath -> FilePath -> [AppliedComposition] -> IO [ArtifactRequirement] +requirementsFor projectRoot installedDirectory applications = concat <$> mapM applicationRequirements applications where applicationRequirements application = do - targetOrigin <- readOriginInfo application.targetSource - instanceRequirements <- forM application.instances $ \state -> do - origin <- readOriginInfo state.source - pure - ArtifactRequirement - { kind = CandidateModule, - name = state.name.unModuleName, - sourceDirectory = state.source, - origin - } - let targetRequirement = case application.target of - AppliedModuleTarget name -> - ArtifactRequirement CandidateModule name.unModuleName application.targetSource targetOrigin - AppliedRecipeTarget name -> - ArtifactRequirement CandidateRecipe name.unRecipeName application.targetSource targetOrigin + targetRequirement <- + requirement + ( case application ^. #target of + AppliedModuleTarget name -> (CandidateModule, name ^. #unModuleName) + AppliedRecipeTarget name -> (CandidateRecipe, name ^. #unRecipeName) + ) + (application ^. #targetOrigin) + instanceRequirements <- + forM (application ^. #instances) $ \state -> + requirement (CandidateModule, state ^. #name . #unModuleName) (state ^. #origin) pure (targetRequirement : instanceRequirements) + requirement (kind, name) origin = do + searchPaths <- defaultSearchPaths + sourceDirectory <- resolveArtifactOrigin projectRoot searchPaths (definitionFileFor kind) origin + pure ArtifactRequirement {kind, name, sourceDirectory, origin = remoteProvenance origin} + +definitionFileFor :: CandidateArtifactKind -> FilePath +definitionFileFor CandidateModule = "module.dhall" +definitionFileFor CandidateRecipe = "recipe.dhall" + +-- | Recover the remote-provenance view an update needs from the manifest's +-- portable origin. +-- +-- Before schema version 6 this was read from the @.seihou-origin.json@ file +-- beside the absolute path the manifest recorded — that is, from whatever the +-- machine that ran the command happened to have installed. Taking it from the +-- manifest instead is both portable and more authoritative: it is the +-- project's own record of what it was generated from. The installed-at +-- version is deliberately not reconstructed here; nothing in staging reads it. +remoteProvenance :: ArtifactOrigin -> Maybe OriginInfo +remoteProvenance (RemoteOrigin url _ repo) = Just (OriginInfo url repo Nothing) +remoteProvenance (ProjectOrigin _) = Nothing +remoteProvenance (LocalOrigin _) = Nothing + stageRemoteOrigins :: FilePath -> FilePath -> @@ -150,8 +179,8 @@ Registry -> IO (Either UpdateError [CandidateArtifact]) discoverRegistryArtifacts url revision repoRoot registry = do - modules <- traverse (loadRemoteModule url (Just registry.repoName) revision repoRoot) registry.modules - recipes <- traverse (loadRemoteRecipe url (Just registry.repoName) revision repoRoot) registry.recipes + modules <- traverse (loadRemoteModule url (Just (registry ^. #repoName)) revision repoRoot) (registry ^. #modules) + recipes <- traverse (loadRemoteRecipe url (Just (registry ^. #repoName)) revision repoRoot) (registry ^. #recipes) pure ((<>) <$> sequence modules <*> sequence recipes) discoverSingleArtifact :: @@ -164,21 +193,21 @@ hasModule <- Directory.doesFileExist (repoRoot "module.dhall") hasRecipe <- Directory.doesFileExist (repoRoot "recipe.dhall") if hasModule - then fmap (fmap (: [])) (loadModuleArtifact (Just url) origin.repoName [] revision repoRoot) + then fmap (fmap (: [])) (loadModuleArtifact (Just url) (origin ^. #repoName) [] revision repoRoot) else if hasRecipe - then fmap (fmap (: [])) (loadRecipeArtifact (Just url) origin.repoName [] revision repoRoot) + then fmap (fmap (: [])) (loadRecipeArtifact (Just url) (origin ^. #repoName) [] revision repoRoot) else pure (Left (CandidateRepositoryInvalid url ["repository contains no module, recipe, or registry"])) loadRemoteModule :: Text -> Maybe Text -> Maybe Text -> FilePath -> RegistryEntry -> IO (Either UpdateError CandidateArtifact) loadRemoteModule url repoName revision repoRoot entry = - loadModuleArtifact (Just url) repoName entry.tags revision (repoRoot entry.path) + loadModuleArtifact (Just url) repoName (entry ^. #tags) revision (repoRoot entry ^. #path) loadRemoteRecipe :: Text -> Maybe Text -> Maybe Text -> FilePath -> RegistryEntry -> IO (Either UpdateError CandidateArtifact) loadRemoteRecipe url repoName revision repoRoot entry = - loadRecipeArtifact (Just url) repoName entry.tags revision (repoRoot entry.path) + loadRecipeArtifact (Just url) repoName (entry ^. #tags) revision (repoRoot entry ^. #path) loadModuleArtifact :: Maybe Text -> Maybe Text -> [Text] -> Maybe Text -> FilePath -> IO (Either UpdateError CandidateArtifact) @@ -189,15 +218,15 @@ Right modul -> do validated <- validateModule directory modul case validated of - Left err -> pure (Left (CandidateLoadFailed modul.name.unModuleName err)) + Left err -> pure (Left (CandidateLoadFailed (modul ^. #name . #unModuleName) err)) Right candidateModule -> do contentHash <- hashArtifactDirectory directory pure ( Right CandidateArtifact { kind = CandidateModule, - name = candidateModule.name.unModuleName, - version = candidateModule.version, + name = candidateModule ^. #name . #unModuleName, + version = candidateModule ^. #version, originalDirectory = directory, sourceDirectory = directory, sourceUrl, @@ -224,8 +253,8 @@ ( Right CandidateArtifact { kind = CandidateRecipe, - name = validated.name.unRecipeName, - version = validated.version, + name = validated ^. #name . #unRecipeName, + version = validated ^. #version, originalDirectory = directory, sourceDirectory = directory, sourceUrl, @@ -246,22 +275,27 @@ stageLocalRequirements searchRoot initial = go initial [] where go artifacts warnings [] = pure (Right (artifacts, reverse warnings)) - go artifacts warnings (requirement : rest) = case requirement.origin of + go artifacts warnings (requirement : rest) = case requirement ^. #origin of Just _ -> go artifacts warnings rest Nothing - | Map.member (requirement.kind, requirement.name) artifacts -> go artifacts warnings rest - | otherwise -> do - loaded <- case requirement.kind of - CandidateModule -> loadModuleArtifact Nothing Nothing [] Nothing requirement.sourceDirectory - CandidateRecipe -> loadRecipeArtifact Nothing Nothing [] Nothing requirement.sourceDirectory - case loaded of - Left err -> pure (Left err) - Right candidate -> do - inserted <- insertCandidate searchRoot (Right artifacts) candidate - case inserted of - Left err -> pure (Left err) - Right artifacts' -> - go artifacts' (LocalArtifactHasNoRemote requirement.name : warnings) rest + | Map.member (requirement ^. #kind, requirement ^. #name) artifacts -> go artifacts warnings rest + | otherwise -> case requirement ^. #sourceDirectory of + -- There is no remote to fall back on and no local copy either, so + -- the update cannot proceed. Report the resolution failure with + -- its own wording rather than a generic "artifact missing". + Left refErr -> pure (Left (CandidateArtifactUnresolved refErr)) + Right directory -> do + loaded <- case requirement ^. #kind of + CandidateModule -> loadModuleArtifact Nothing Nothing [] Nothing directory + CandidateRecipe -> loadRecipeArtifact Nothing Nothing [] Nothing directory + case loaded of + Left err -> pure (Left err) + Right candidate -> do + inserted <- insertCandidate searchRoot (Right artifacts) candidate + case inserted of + Left err -> pure (Left err) + Right artifacts' -> + go artifacts' (LocalArtifactHasNoRemote (requirement ^. #name) : warnings) rest insertCandidate :: FilePath -> @@ -275,17 +309,17 @@ pure ( Left ( CandidateArtifactAmbiguous - candidate.kind - candidate.name - (map (maybe "local" id . (.sourceUrl)) [existing, candidate]) + (candidate ^. #kind) + (candidate ^. #name) + (map (maybe "local" id . (^. #sourceUrl)) [existing, candidate]) ) ) Nothing -> do - let destination = searchRoot T.unpack candidate.name + let destination = searchRoot T.unpack (candidate ^. #name) Directory.createDirectoryIfMissing True destination - copied <- try @SomeException (copyDirectoryRecursive candidate.sourceDirectory destination) + copied <- try @SomeException (copyDirectoryRecursive (candidate ^. #sourceDirectory) destination) pure $ case copied of - Left err -> Left (CandidateRepositoryInvalid candidate.name [T.pack (displayException err)]) + Left err -> Left (CandidateRepositoryInvalid (candidate ^. #name) [T.pack (displayException err)]) Right () -> Right ( Map.insert @@ -294,23 +328,23 @@ artifacts ) where - key = (candidate.kind, candidate.name) + key = (candidate ^. #kind, candidate ^. #name) setCandidateSource :: FilePath -> CandidateArtifact -> CandidateArtifact setCandidateSource directory candidate = CandidateArtifact - { kind = candidate.kind, - name = candidate.name, - version = candidate.version, - originalDirectory = candidate.originalDirectory, + { kind = candidate ^. #kind, + name = candidate ^. #name, + version = candidate ^. #version, + originalDirectory = candidate ^. #originalDirectory, sourceDirectory = directory, - sourceUrl = candidate.sourceUrl, - repoName = candidate.repoName, - tags = candidate.tags, - sourceRevision = candidate.sourceRevision, - contentHash = candidate.contentHash, - moduleDefinition = candidate.moduleDefinition, - recipeDefinition = candidate.recipeDefinition + sourceUrl = candidate ^. #sourceUrl, + repoName = candidate ^. #repoName, + tags = candidate ^. #tags, + sourceRevision = candidate ^. #sourceRevision, + contentHash = candidate ^. #contentHash, + moduleDefinition = candidate ^. #moduleDefinition, + recipeDefinition = candidate ^. #recipeDefinition } verifyRemoteRequirements :: @@ -319,13 +353,13 @@ Either UpdateError () verifyRemoteRequirements requirements artifacts = traverse_ verify requirements where - verify requirement = case Map.lookup (requirement.kind, requirement.name) artifacts of - Nothing -> Left (CandidateArtifactMissing requirement.kind requirement.name) - Just candidate -> case requirement.origin of + verify requirement = case Map.lookup (requirement ^. #kind, requirement ^. #name) artifacts of + Nothing -> Left (CandidateArtifactMissing (requirement ^. #kind) (requirement ^. #name)) + Just candidate -> case requirement ^. #origin of Nothing -> Right () Just origin - | candidate.sourceUrl == Just origin.sourceUrl -> Right () - | otherwise -> Left (CandidateArtifactMissing requirement.kind requirement.name) + | candidate ^. #sourceUrl == Just (origin ^. #sourceUrl) -> Right () + | otherwise -> Left (CandidateArtifactMissing (requirement ^. #kind) (requirement ^. #name)) gitRevision :: FilePath -> IO (Maybe Text) gitRevision directory = do diff --git a/src/Seihou/CLI/Update/Types.hs b/src/Seihou/CLI/Update/Types.hs --- a/src/Seihou/CLI/Update/Types.hs +++ b/src/Seihou/CLI/Update/Types.hs @@ -26,6 +26,7 @@ CommandPolicy, ) import Seihou.Composition.Instance (ModuleInstance) +import Seihou.Core.ArtifactRef (ArtifactRefError) import Seihou.Core.Migration (MigrationPlan, MigrationPlanError) import Seihou.Core.Types import Seihou.Engine.Migrate (ExecutedMigrationPlan, MigrationExecError) @@ -49,31 +50,36 @@ deriving stock (Eq, Show) data UpdateRequest = UpdateRequest - { selection :: UpdateSelection, - varOverrides :: [(Text, Text)], - reconfigure :: Bool, - promptPolicy :: PromptPolicy, - commandPolicy :: CommandPolicy, - dryRun :: Bool + { selection :: !UpdateSelection, + varOverrides :: ![(Text, Text)], + reconfigure :: !Bool, + promptPolicy :: !PromptPolicy, + commandPolicy :: !CommandPolicy, + dryRun :: !Bool, + -- | When 'True', accept a candidate artifact whose version is lower + -- than the version @.seihou\/manifest.json@ records, instead of + -- failing with 'CandidateDowngrade'. The default is 'False', so an + -- update never moves a project backwards by accident. + allowDowngrade :: !Bool } - deriving stock (Eq, Show) + deriving stock (Eq, Generic, Show) data VersionChange = VersionChange - { name :: Text, - fromVersion :: Maybe Text, - toVersion :: Maybe Text, - sameVersionContentChanged :: Bool + { name :: !Text, + fromVersion :: !(Maybe Text), + toVersion :: !(Maybe Text), + sameVersionContentChanged :: !Bool } - deriving stock (Eq, Show) + deriving stock (Eq, Generic, Show) data InputChangeSummary = InputChangeSummary - { reused :: Int, - overridden :: Int, - newlyResolved :: Int, - removed :: Int, - ambiguousLegacy :: [VarName] + { reused :: !Int, + overridden :: !Int, + newlyResolved :: !Int, + removed :: !Int, + ambiguousLegacy :: ![VarName] } - deriving stock (Eq, Show) + deriving stock (Eq, Generic, Show) data CandidateArtifactKind = CandidateModule | CandidateRecipe deriving stock (Eq, Ord, Show) @@ -81,61 +87,61 @@ -- | One validated artifact staged for this update session. The source path is -- temporary for remote candidates and must not escape 'withProjectUpdate'. data CandidateArtifact = CandidateArtifact - { kind :: CandidateArtifactKind, - name :: Text, - version :: Maybe Text, - originalDirectory :: FilePath, - sourceDirectory :: FilePath, - sourceUrl :: Maybe Text, - repoName :: Maybe Text, - tags :: [Text], - sourceRevision :: Maybe Text, - contentHash :: SHA256, - moduleDefinition :: Maybe Module, - recipeDefinition :: Maybe Recipe + { kind :: !CandidateArtifactKind, + name :: !Text, + version :: !(Maybe Text), + originalDirectory :: !FilePath, + sourceDirectory :: !FilePath, + sourceUrl :: !(Maybe Text), + repoName :: !(Maybe Text), + tags :: ![Text], + sourceRevision :: !(Maybe Text), + contentHash :: !SHA256, + moduleDefinition :: !(Maybe Module), + recipeDefinition :: !(Maybe Recipe) } - deriving stock (Eq, Show) + deriving stock (Eq, Generic, Show) data CandidateCatalog = CandidateCatalog - { searchRoot :: FilePath, - artifacts :: Map (CandidateArtifactKind, Text) CandidateArtifact, - clonedOrigins :: Map Text FilePath + { searchRoot :: !FilePath, + artifacts :: !(Map (CandidateArtifactKind, Text) CandidateArtifact), + clonedOrigins :: !(Map Text FilePath) } - deriving stock (Eq, Show) + deriving stock (Eq, Generic, Show) data PlannedUpdateMigration = PlannedUpdateMigration - { moduleName :: ModuleName, - sourceDirectory :: FilePath, - sourcePlan :: MigrationPlan, - stagedPlan :: ExecutedMigrationPlan, - containsCommands :: Bool + { moduleName :: !ModuleName, + sourceDirectory :: !FilePath, + sourcePlan :: !MigrationPlan, + stagedPlan :: !ExecutedMigrationPlan, + containsCommands :: !Bool } - deriving stock (Eq, Show) + deriving stock (Eq, Generic, Show) -- | Internal, renderer-neutral material retained so apply can re-plan after -- migration commands without reusing parser state. data PlannedApplication = PlannedApplication - { previous :: Maybe AppliedComposition, - candidate :: AppliedComposition, - modulesInOrder :: [(ModuleInstance, Module, FilePath)], - resolvedValues :: Map ModuleInstance (Map VarName ResolvedVar), - operations :: [Operation], - desiredOwners :: Map FilePath DesiredFileOwner + { previous :: !(Maybe AppliedComposition), + candidate :: !AppliedComposition, + modulesInOrder :: ![(ModuleInstance, Module, FilePath)], + resolvedValues :: !(Map ModuleInstance (Map VarName ResolvedVar)), + operations :: ![Operation], + desiredOwners :: !(Map FilePath DesiredFileOwner) } - deriving stock (Eq, Show) + deriving stock (Eq, Generic, Show) data UpdateSnapshot = UpdateSnapshot - { sessionDirectory :: FilePath, - projectRoot :: FilePath, - manifestPath :: FilePath, - baselineDirectory :: FilePath, - installedDirectory :: FilePath, - originalManifest :: Manifest, - candidateHashes :: Map FilePath SHA256, - observedProjectHashes :: Map FilePath (Maybe SHA256), - transactionTargets :: Set FilePath + { sessionDirectory :: !FilePath, + projectRoot :: !FilePath, + manifestPath :: !FilePath, + baselineDirectory :: !FilePath, + installedDirectory :: !FilePath, + originalManifest :: !Manifest, + candidateHashes :: !(Map FilePath SHA256), + observedProjectHashes :: !(Map FilePath (Maybe SHA256)), + transactionTargets :: !(Set FilePath) } - deriving stock (Eq, Show) + deriving stock (Eq, Generic, Show) data UpdateWarning = LocalArtifactHasNoRemote Text @@ -150,37 +156,37 @@ deriving stock (Eq, Show) data UpdatePlan = UpdatePlan - { applications :: [AppliedComposition], - versionChanges :: [VersionChange], - inputChanges :: InputChangeSummary, - migrations :: [PlannedUpdateMigration], - reconciliation :: ReconciliationPlan, - commandPlan :: CommandPlan, - candidateArtifacts :: [CandidateArtifact], - warnings :: [UpdateWarning], - request :: UpdateRequest, - snapshot :: UpdateSnapshot, - plannedApplications :: [PlannedApplication] + { applications :: ![AppliedComposition], + versionChanges :: ![VersionChange], + inputChanges :: !InputChangeSummary, + migrations :: ![PlannedUpdateMigration], + reconciliation :: !ReconciliationPlan, + commandPlan :: !CommandPlan, + candidateArtifacts :: ![CandidateArtifact], + warnings :: ![UpdateWarning], + request :: !UpdateRequest, + snapshot :: !UpdateSnapshot, + plannedApplications :: ![PlannedApplication] } - deriving stock (Eq, Show) + deriving stock (Eq, Generic, Show) data CommandSummary = CommandSummary - { executed :: Int, - skippedUnchanged :: Int, - skippedDisabled :: Int + { executed :: !Int, + skippedUnchanged :: !Int, + skippedDisabled :: !Int } - deriving stock (Eq, Show) + deriving stock (Eq, Generic, Show) data UpdateResult = UpdateResult - { updatedApplications :: [ApplicationId], - manifest :: Manifest, - versions :: [VersionChange], - fileSummary :: ReconciliationSummary, - commandSummary :: CommandSummary, - touchedPaths :: Set FilePath, - warnings :: [UpdateWarning] + { updatedApplications :: ![ApplicationId], + manifest :: !Manifest, + versions :: ![VersionChange], + fileSummary :: !ReconciliationSummary, + commandSummary :: !CommandSummary, + touchedPaths :: !(Set FilePath), + warnings :: ![UpdateWarning] } - deriving stock (Eq, Show) + deriving stock (Eq, Generic, Show) data UpdateError = UpdateManifestMissing FilePath @@ -192,6 +198,9 @@ | CandidateCloneFailed Text Text | CandidateRepositoryInvalid Text [Text] | CandidateArtifactMissing CandidateArtifactKind Text + | -- | An artifact the manifest records could not be located on this + -- machine and has no remote to fetch it from. + CandidateArtifactUnresolved ArtifactRefError | CandidateArtifactAmbiguous CandidateArtifactKind Text [Text] | CandidateLoadFailed Text ModuleLoadError | CandidateDowngrade Text (Maybe Text) (Maybe Text) diff --git a/src/Seihou/CLI/VersionCompare.hs b/src/Seihou/CLI/VersionCompare.hs --- a/src/Seihou/CLI/VersionCompare.hs +++ b/src/Seihou/CLI/VersionCompare.hs @@ -6,8 +6,11 @@ ) where +import Control.Lens ((^.)) import Data.Aeson (ToJSON (..), object, (.=)) +import Data.Generics.Labels () import Data.Text (Text) +import GHC.Generics (Generic) import Seihou.Core.Version (parseVersion) -- | Status of a module with respect to available updates. @@ -22,20 +25,20 @@ -- @seihou outdated@ command (which formats them as a table) and -- @seihou status@ (which folds them into per-row annotations). data OutdatedEntry = OutdatedEntry - { moduleName :: Text, - installedVersion :: Maybe Text, - availableVersion :: Maybe Text, - status :: OutdatedStatus + { moduleName :: !Text, + installedVersion :: !(Maybe Text), + availableVersion :: !(Maybe Text), + status :: !OutdatedStatus } - deriving stock (Eq, Show) + deriving stock (Eq, Generic, Show) instance ToJSON OutdatedEntry where toJSON e = object - [ "module" .= e.moduleName, - "installed" .= e.installedVersion, - "available" .= e.availableVersion, - "status" .= statusText e.status + [ "module" .= (e ^. #moduleName), + "installed" .= (e ^. #installedVersion), + "available" .= (e ^. #availableVersion), + "status" .= statusText (e ^. #status) ] where statusText UpToDate = "up to date" :: Text @@ -45,10 +48,10 @@ -- | Summary statistics for an update check. data CheckStats = CheckStats - { checkedCount :: Int, - skippedNoOrigin :: Int + { checkedCount :: !Int, + skippedNoOrigin :: !Int } - deriving stock (Eq, Show) + deriving stock (Eq, Generic, Show) -- | Compare installed and available version strings. compareVersions :: Maybe Text -> Maybe Text -> OutdatedStatus diff --git a/src/Seihou/Effect/FzfInterp.hs b/src/Seihou/Effect/FzfInterp.hs --- a/src/Seihou/Effect/FzfInterp.hs +++ b/src/Seihou/Effect/FzfInterp.hs @@ -4,6 +4,7 @@ ) where +import Data.Generics.Labels () import Seihou.Effect.Fzf (Fzf (..)) import Seihou.Fzf (FzfConfig, FzfResult (..), isFzfUsable) import Seihou.Fzf qualified as Fzf @@ -22,6 +23,6 @@ SelectOne _ candidates -> pure $ if idx >= 0 && idx < length candidates - then FzfSelected (candidates !! idx).candidateValue + then FzfSelected ((candidates !! idx) ^. #value) else FzfNoMatch IsFzfAvailable -> pure True diff --git a/src/Seihou/Fzf.hs b/src/Seihou/Fzf.hs --- a/src/Seihou/Fzf.hs +++ b/src/Seihou/Fzf.hs @@ -24,10 +24,13 @@ where import Control.Exception (SomeException, try) +import Control.Lens ((&), (.~), (?~), (^.)) +import Data.Generics.Labels () import Data.Map.Strict qualified as Map import Data.Text (Text) import Data.Text qualified as T import Data.Text.IO qualified as TIO +import GHC.Generics (Generic) import System.Directory (findExecutable) import System.Exit (ExitCode (..)) import System.IO (IOMode (..), hClose, hIsTerminalDevice, openFile, stdin) @@ -42,12 +45,12 @@ -- | Runtime configuration for fzf, detected once at CLI startup. data FzfConfig = FzfConfig - { fzfBinary :: !FilePath, - fzfAvailable :: !Bool, + { binary :: !FilePath, + available :: !Bool, stdinIsTerminal :: !Bool, ttyAvailable :: !Bool } - deriving stock (Eq, Show) + deriving stock (Eq, Generic, Show) -- | Detect fzf availability and terminal state. detectFzfConfig :: IO FzfConfig @@ -57,8 +60,8 @@ ttyOk <- checkTtyAvailable pure FzfConfig - { fzfBinary = maybe "fzf" id mFzf, - fzfAvailable = case mFzf of Nothing -> False; Just _ -> True, + { binary = maybe "fzf" id mFzf, + available = case mFzf of Nothing -> False; Just _ -> True, stdinIsTerminal = stdinTerm, ttyAvailable = ttyOk } @@ -73,28 +76,31 @@ -- | Whether fzf can be used for interactive selection. isFzfUsable :: FzfConfig -> Bool -isFzfUsable cfg = cfg.fzfAvailable && (cfg.stdinIsTerminal || cfg.ttyAvailable) +isFzfUsable cfg = cfg ^. #available && (cfg ^. #stdinIsTerminal || cfg ^. #ttyAvailable) -- | Composable fzf options. Combine with '<>'. data FzfOpts = FzfOpts - { fzfPrompt :: !(Maybe Text), - fzfHeader :: !(Maybe Text), - fzfPreview :: !(Maybe Text), - fzfHeight :: !(Maybe Text), - fzfAnsi :: !Bool, - fzfNoSort :: !Bool + { prompt :: !(Maybe Text), + header :: !(Maybe Text), + preview :: !(Maybe Text), + height :: !(Maybe Text), + ansi :: !Bool, + noSort :: !Bool } - deriving stock (Eq, Show) + deriving stock (Eq, Generic, Show) instance Semigroup FzfOpts where a <> b = FzfOpts - { fzfPrompt = b.fzfPrompt <|> a.fzfPrompt, - fzfHeader = b.fzfHeader <|> a.fzfHeader, - fzfPreview = b.fzfPreview <|> a.fzfPreview, - fzfHeight = b.fzfHeight <|> a.fzfHeight, - fzfAnsi = a.fzfAnsi || b.fzfAnsi, - fzfNoSort = a.fzfNoSort || b.fzfNoSort + { -- (<|>) below is local to this instance and carries no fixity + -- declaration, so it defaults to infixl 9 -- tighter than (^.) at + -- infixl 8. Hence the parentheses. + prompt = (b ^. #prompt) <|> (a ^. #prompt), + header = (b ^. #header) <|> (a ^. #header), + preview = (b ^. #preview) <|> (a ^. #preview), + height = (b ^. #height) <|> (a ^. #height), + ansi = a ^. #ansi || b ^. #ansi, + noSort = a ^. #noSort || b ^. #noSort } where (<|>) :: Maybe a -> Maybe a -> Maybe a @@ -105,41 +111,41 @@ mempty = FzfOpts Nothing Nothing Nothing Nothing False False withPrompt :: Text -> FzfOpts -withPrompt p = mempty {fzfPrompt = Just p} +withPrompt p = mempty & #prompt ?~ p withHeader :: Text -> FzfOpts -withHeader h = mempty {fzfHeader = Just h} +withHeader h = mempty & #header ?~ h withHeight :: Text -> FzfOpts -withHeight h = mempty {fzfHeight = Just h} +withHeight h = mempty & #height ?~ h withAnsi :: FzfOpts -withAnsi = mempty {fzfAnsi = True} +withAnsi = mempty & #ansi .~ True withNoSort :: FzfOpts -withNoSort = mempty {fzfNoSort = True} +withNoSort = mempty & #noSort .~ True withPreview :: Text -> FzfOpts -withPreview p = mempty {fzfPreview = Just p} +withPreview p = mempty & #preview ?~ p -- | Convert options to fzf CLI arguments. optsToArgs :: FzfOpts -> [String] optsToArgs opts = concat - [ maybe [] (\p -> ["--prompt", T.unpack p]) opts.fzfPrompt, - maybe [] (\h -> ["--header", T.unpack h]) opts.fzfHeader, - maybe [] (\p -> ["--preview", T.unpack p]) opts.fzfPreview, - maybe [] (\h -> ["--height", T.unpack h]) opts.fzfHeight, - ["--ansi" | opts.fzfAnsi], - ["--no-sort" | opts.fzfNoSort] + [ maybe [] (\p -> ["--prompt", T.unpack p]) (opts ^. #prompt), + maybe [] (\h -> ["--header", T.unpack h]) (opts ^. #header), + maybe [] (\p -> ["--preview", T.unpack p]) (opts ^. #preview), + maybe [] (\h -> ["--height", T.unpack h]) (opts ^. #height), + ["--ansi" | opts ^. #ansi], + ["--no-sort" | opts ^. #noSort] ] -- | A selectable candidate with display text and an associated value. data Candidate a = Candidate - { candidateDisplay :: !Text, - candidateValue :: !a + { display :: !Text, + value :: !a } - deriving stock (Functor) + deriving stock (Functor, Generic) -- | Result of an fzf selection. data FzfResult a @@ -160,12 +166,12 @@ | not (isFzfUsable cfg) = pure (FzfError "fzf is not available") | otherwise = do let indexed = zip [0 :: Int ..] candidates - valueMap = Map.fromList [(i, c.candidateValue) | (i, c) <- indexed] - inputLines = [show i <> "\t" <> T.unpack c.candidateDisplay | (i, c) <- indexed] + valueMap = Map.fromList [(i, c ^. #value) | (i, c) <- indexed] + inputLines = [show i <> "\t" <> T.unpack (c ^. #display) | (i, c) <- indexed] args = ["-1", "--with-nth=2.."] ++ optsToArgs opts let processSpec = - (proc cfg.fzfBinary args) + (proc (cfg ^. #binary) args) { std_in = CreatePipe, std_out = CreatePipe, std_err = Inherit, diff --git a/src/Seihou/Fzf/Selector/Module.hs b/src/Seihou/Fzf/Selector/Module.hs --- a/src/Seihou/Fzf/Selector/Module.hs +++ b/src/Seihou/Fzf/Selector/Module.hs @@ -6,6 +6,7 @@ ) where +import Data.Generics.Labels () import Data.Maybe (mapMaybe) import Data.Text qualified as T import Seihou.Core.Module (DiscoveredModule (..), DiscoveredRunnable (..), ModuleSource (..), RunnableKind (..), defaultSearchPaths, discoverAllModules, discoverAllRunnables) @@ -17,37 +18,37 @@ -- | Format a discovered module as an fzf candidate. -- Returns 'Nothing' for modules that failed to load. formatModuleCandidate :: DiscoveredModule -> Maybe (Candidate ModuleName) -formatModuleCandidate dm = case dm.discoveredResult of +formatModuleCandidate dm = case dm ^. #result of Left _ -> Nothing Right m -> - let nameText = m.name.unModuleName - descText = maybe "" (\d -> " " <> d) m.description - sourceTag = case dm.discoveredSource of + let nameText = (m ^. #name . #unModuleName) + descText = maybe "" (\d -> " " <> d) (m ^. #description) + sourceTag = case dm ^. #source of SourceProject -> "[project]" SourceUser -> "[user]" SourceInstalled -> "[installed]" display = nameText <> descText <> " " <> sourceTag - in Just Candidate {candidateDisplay = display, candidateValue = m.name} + in Just Candidate {display = display, value = m ^. #name} -- | Format a discovered runnable (module or recipe) as an fzf candidate. -- Returns 'Nothing' for items that failed to load. formatRunnableCandidate :: DiscoveredRunnable -> Maybe (Candidate ModuleName) formatRunnableCandidate dr - | dr.drIsError = Nothing + | (dr ^. #isError) = Nothing | otherwise = - let nameText = dr.drName - descText = maybe "" (\d -> " " <> d) dr.drDescription - kindTag = case dr.drKind of + let nameText = (dr ^. #name) + descText = maybe "" (\d -> " " <> d) (dr ^. #description) + kindTag = case dr ^. #kind of KindModule -> "" KindRecipe -> " [recipe]" KindBlueprint -> " [blueprint]" KindPrompt -> " [prompt]" - sourceTag = case dr.drSource of + sourceTag = case dr ^. #source of SourceProject -> "[project]" SourceUser -> "[user]" SourceInstalled -> "[installed]" display = nameText <> descText <> kindTag <> " " <> sourceTag - in Just Candidate {candidateDisplay = display, candidateValue = ModuleName nameText} + in Just Candidate {display = display, value = ModuleName nameText} -- | Default fzf options for module selection. defaultModuleOpts :: FzfOpts diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -6,6 +6,8 @@ import Seihou.CLI.AgentLaunchSpec qualified as AgentLaunchSpec import Seihou.CLI.AgentMigrateE2ESpec qualified as AgentMigrateE2ESpec import Seihou.CLI.AgentModelsSpec qualified as AgentModelsSpec +import Seihou.CLI.AgentTraceE2ESpec qualified as AgentTraceE2ESpec +import Seihou.CLI.AgentTraceSpec qualified as AgentTraceSpec import Seihou.CLI.AppliedBlueprintMigrationSpec qualified as AppliedBlueprintMigrationSpec import Seihou.CLI.AppliedBlueprintSpec qualified as AppliedBlueprintSpec import Seihou.CLI.BlueprintMigrationSpec qualified as BlueprintMigrationSpec @@ -18,6 +20,8 @@ import Seihou.CLI.InitSpec qualified as InitSpec import Seihou.CLI.InstallHistorySpec qualified as InstallHistorySpec import Seihou.CLI.ListSpec qualified as ListSpec +import Seihou.CLI.ManifestGuardSpec qualified as ManifestGuardSpec +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 @@ -26,6 +30,7 @@ import Seihou.CLI.RemoteVersionSpec qualified as RemoteVersionSpec import Seihou.CLI.RunBlueprintRefusalSpec qualified as RunBlueprintRefusalSpec import Seihou.CLI.SavePromptedSpec qualified as SavePromptedSpec +import Seihou.CLI.SharedManifestE2ESpec qualified as SharedManifestE2ESpec import Seihou.CLI.StatusSpec qualified as StatusSpec import Seihou.CLI.UpdateE2ESpec qualified as UpdateE2ESpec import Seihou.CLI.UpdateInteractionSpec qualified as UpdateInteractionSpec @@ -45,6 +50,8 @@ AgentConfigSpec.tests, AgentConfigShowSpec.tests, AgentModelsSpec.tests, + AgentTraceSpec.tests, + AgentTraceE2ESpec.tests, AppliedBlueprintSpec.tests, AppliedBlueprintMigrationSpec.tests, BlueprintMigrationSpec.tests, @@ -57,6 +64,8 @@ InitSpec.tests, InstallHistorySpec.tests, ListSpec.tests, + ManifestGuardSpec.tests, + ManifestUpgradeSpec.tests, MigrateSpec.tests, PendingMigrationSpec.tests, PromptRenderSpec.tests, @@ -65,6 +74,7 @@ RemoteVersionSpec.tests, RunBlueprintRefusalSpec.tests, SavePromptedSpec.tests, + SharedManifestE2ESpec.tests, StatusSpec.tests, UpgradeSpec.tests, UpdateSpec.tests, diff --git a/test/Seihou/CLI/AgentCompletionSpec.hs b/test/Seihou/CLI/AgentCompletionSpec.hs --- a/test/Seihou/CLI/AgentCompletionSpec.hs +++ b/test/Seihou/CLI/AgentCompletionSpec.hs @@ -3,10 +3,22 @@ import Baikai qualified import Baikai.Model qualified as BaikaiModel import Baikai.Response qualified as BaikaiResponse +import Baikai.Trace.Sink (TraceSink, silent) +import Control.Exception (throwIO) +import Control.Lens ((^.)) +import Data.Aeson qualified as Aeson +import Data.Aeson.Key qualified as Key +import Data.Aeson.KeyMap qualified as KeyMap +import Data.ByteString.Lazy.Char8 qualified as BL8 +import Data.Generics.Labels () import Data.Text qualified as Text import Data.Time (UTCTime) import Data.Vector qualified as V import Seihou.CLI.AgentCompletion +import Seihou.CLI.AgentTrace (traceSinkFor) +import System.Directory (doesFileExist) +import System.FilePath (()) +import System.IO.Temp (withSystemTempDirectory) import Test.Hspec import Test.Tasty (TestTree) import Test.Tasty.Hspec (testSpec) @@ -35,22 +47,46 @@ && "openai" `Text.isInfixOf` err Right _ -> False + describe "trace setting text helpers" $ do + it "parses every accepted setting case-insensitively" $ do + traceFromText "off" `shouldBe` Right TraceOff + traceFromText "FILE" `shouldBe` Right TraceFile + traceFromText " stdout " `shouldBe` Right TraceStdout + traceFromText "StdErr" `shouldBe` Right TraceStderr + + it "names every accepted setting in the failure message" $ + traceFromText "syslog" `shouldSatisfy` \case + Left err -> + "off" `Text.isInfixOf` err + && "file" `Text.isInfixOf` err + && "stdout" `Text.isInfixOf` err + && "stderr" `Text.isInfixOf` err + Right _ -> False + + it "round-trips through traceToText" $ + traverse (traceFromText . traceToText) [TraceOff, TraceFile, TraceStdout, TraceStderr] + `shouldBe` Right [TraceOff, TraceFile, TraceStdout, TraceStderr] + describe "model construction" $ do it "defaults to the Claude CLI provider with no explicit model" $ defaultAgentModelConfig `shouldBe` AgentModelConfig - { agentProvider = AgentProviderClaudeCli, - agentModel = Nothing, - agentEffort = Nothing + { provider = AgentProviderClaudeCli, + model = Nothing, + effort = Nothing, + trace = TraceOff, + tracePath = Nothing } it "builds a Claude CLI model using the CLI API tag" $ do let model = buildBaikaiModel AgentModelConfig - { agentProvider = AgentProviderClaudeCli, - agentModel = Just "sonnet", - agentEffort = Nothing + { provider = AgentProviderClaudeCli, + model = Just "sonnet", + effort = Nothing, + trace = TraceOff, + tracePath = Nothing } BaikaiModel.api model `shouldBe` Baikai.AnthropicMessagesCli BaikaiModel.provider model `shouldBe` "anthropic" @@ -60,9 +96,11 @@ let model = buildBaikaiModel AgentModelConfig - { agentProvider = AgentProviderCodexCli, - agentModel = Just "gpt-5", - agentEffort = Nothing + { provider = AgentProviderCodexCli, + model = Just "gpt-5", + effort = Nothing, + trace = TraceOff, + tracePath = Nothing } BaikaiModel.api model `shouldBe` Baikai.OpenAICompletionsCli BaikaiModel.provider model `shouldBe` "openai" @@ -72,17 +110,81 @@ it "preserves rendered prompts and resolved model configuration" $ do let config = AgentModelConfig - { agentProvider = AgentProviderCodexCli, - agentModel = Just "gpt-5", - agentEffort = Nothing + { provider = AgentProviderCodexCli, + model = Just "gpt-5", + effort = Nothing, + trace = TraceOff, + tracePath = Nothing } - buildAgentCompletionRequest config "system" (Just "user") - `shouldBe` AgentCompletionRequest - { completionSystemPrompt = "system", - completionInitialPrompt = Just "user", - completionModelConfig = config - } + req = buildAgentCompletionRequest config "system" (Just "user") + -- AgentCompletionRequest has no Eq: it carries a TraceSink, which wraps a + -- streamly fold. Compare the inspectable fields instead. + (req ^. #systemPrompt) `shouldBe` "system" + (req ^. #initialPrompt) `shouldBe` Just "user" + (req ^. #modelConfig) `shouldBe` config + -- These drive the real Baikai.Trace.withTrace path against a stub provider + -- registered under the anthropic-messages tag. They exist because withTrace + -- reports provider failures as an error-shaped Response rather than by + -- throwing, the way completeRequest did: without the responseError branch in + -- runAgentCompletionWith, every one of these failures would be reported as + -- "Provider returned no assistant text." and the real message would be lost. + describe "runAgentCompletionWith" $ do + it "returns the assistant text of a successful call" $ do + result <- runStub (const (pure (okResponse "hello from the stub"))) Nothing + result `shouldBe` Right "hello from the stub" + + -- The regression test for the whole swap. Delete the responseError branch + -- in runAgentCompletionWith and this fails with the empty-text message. + it "reports the provider's message when the response is error-shaped" $ do + result <- runStub (\m -> pure (failedResponse m "invalid x-api-key")) Nothing + result `shouldSatisfy` \case + Left err -> "invalid x-api-key" `Text.isInfixOf` err + Right _ -> False + + it "does not mistake a provider error for missing assistant text" $ do + result <- runStub (\m -> pure (failedResponse m "model not found")) Nothing + result `shouldSatisfy` \case + Left err -> not ("Provider returned no assistant text." `Text.isInfixOf` err) + Right _ -> False + + -- ...and the empty-text guard must still fire for a genuinely empty + -- success, rather than being shadowed by the new branch. + it "still reports a successful but empty response as missing text" $ do + result <- runStub (const (pure (okResponse ""))) Nothing + result `shouldBe` Left "Provider returned no assistant text." + + it "reports a thrown provider exception, which withTrace still propagates" $ do + result <- runStub (const (throwIO (Baikai.providerError "connection reset"))) Nothing + result `shouldSatisfy` \case + Left err -> "connection reset" `Text.isInfixOf` err + Right _ -> False + + it "writes a correlated start/finish pair to a file sink" $ + withSystemTempDirectory "seihou-completion-trace" $ \root -> do + let path = root "trace.jsonl" + sink <- traceSinkFor TraceFile (Just path) + _ <- runStub (const (pure (okResponse "traced"))) (Just sink) + events <- traceEvents path + map fst events `shouldBe` ["call_started", "call_finished"] + case map snd events of + [a, b] -> a `shouldBe` b + other -> expectationFailure ("expected two events, got " <> show (length other)) + + it "writes a start/fail pair when the call fails" $ + withSystemTempDirectory "seihou-completion-trace-fail" $ \root -> do + let path = root "trace.jsonl" + sink <- traceSinkFor TraceFile (Just path) + _ <- runStub (\m -> pure (failedResponse m "rate limited")) (Just sink) + events <- traceEvents path + map fst events `shouldBe` ["call_started", "call_failed"] + + it "writes nothing when tracing is off" $ + withSystemTempDirectory "seihou-completion-trace-off" $ \root -> do + let path = root "trace.jsonl" + _ <- runStub (const (pure (okResponse "untraced"))) Nothing + doesFileExist path `shouldReturn` False + describe "responseText" $ do it "extracts and joins assistant text blocks only" $ do let resp = @@ -102,3 +204,79 @@ } } responseText resp `shouldBe` "hello\nworld" + +-- | Run a completion against a stub provider that returns whatever the given +-- action produces, optionally reporting to a trace sink. +-- +-- The stub registers under the @anthropic-messages@ tag, which is what +-- 'buildBaikaiModel' selects for 'AgentProviderAnthropic'. It supplies both +-- provider fields the way the real CLI providers do — a direct @complete@ and +-- a @stream@ lifted from it — because 'Baikai.Trace.withTrace' dispatches +-- through @stream@, not @complete@. +-- +-- Registration mutates Baikai's process-global registry. That is safe here +-- because the test binary is not built with @-threaded@, so tasty runs these +-- sequentially; a stub is always registered immediately before the call that +-- uses it. +runStub :: + (Baikai.Model -> IO BaikaiResponse.Response) -> + Maybe TraceSink -> + IO (Either Text.Text Text.Text) +runStub respond sink = + runAgentCompletionWith registerStub request + where + registerStub = + Baikai.registerApiProvider + Baikai.ApiProvider + { Baikai.apiTag = Baikai.AnthropicMessages, + Baikai.complete = \m _ _ -> respond m, + Baikai.stream = Baikai.liftCompleteToStream (\m _ _ -> respond m) + } + request = + buildAgentCompletionRequestWith + (maybe silent id sink) + AgentModelConfig + { provider = AgentProviderAnthropic, + model = Just "stub-model", + effort = Nothing, + trace = maybe TraceOff (const TraceFile) sink, + tracePath = Nothing + } + "system" + (Just "user") + +-- | A successful response carrying one assistant text block. +okResponse :: Text.Text -> BaikaiResponse.Response +okResponse body = + BaikaiResponse.emptyResponse + { BaikaiResponse.message = + Baikai.AssistantPayload + { Baikai.content = V.singleton (Baikai.AssistantText (Baikai.TextContent body)), + Baikai.usage = Baikai.zeroUsage, + Baikai.stopReason = Baikai.Stop, + Baikai.errorMessage = Nothing, + Baikai.timestamp = Just epoch + } + } + +-- | An error-shaped response, the way a conforming provider reports an in-band +-- failure: @stopReason = ErrorReason@ plus the provider's message. +failedResponse :: Baikai.Model -> Text.Text -> BaikaiResponse.Response +failedResponse m message = + BaikaiResponse.errorResponse m epoch 12 (Baikai.providerError message) + +epoch :: UTCTime +epoch = read "2026-07-27 00:00:00 UTC" + +-- | The @(kind, eventId)@ of every event in a JSONL trace file, in order. +traceEvents :: FilePath -> IO [(String, String)] +traceEvents path = do + contents <- BL8.readFile path + pure + [ (Text.unpack kind, Text.unpack eventId) + | line <- BL8.lines contents, + not (BL8.null line), + Just (Aeson.Object o) <- [Aeson.decode line], + Just (Aeson.String kind) <- [KeyMap.lookup (Key.fromString "kind") o], + Just (Aeson.String eventId) <- [KeyMap.lookup (Key.fromString "eventId") o] + ] diff --git a/test/Seihou/CLI/AgentConfigShowSpec.hs b/test/Seihou/CLI/AgentConfigShowSpec.hs --- a/test/Seihou/CLI/AgentConfigShowSpec.hs +++ b/test/Seihou/CLI/AgentConfigShowSpec.hs @@ -3,7 +3,7 @@ import Baikai.ThinkingLevel (ThinkingLevel (..)) import Data.Text (Text) import Data.Text qualified as Text -import Seihou.CLI.AgentCompletion (AgentProvider (..)) +import Seihou.CLI.AgentCompletion (AgentProvider (..), TraceSetting (..)) import Seihou.CLI.AgentConfig ( AgentCommandName (..), AgentConfigSource (..), @@ -53,29 +53,52 @@ it "shows an unset effort as (default) with built-in provenance" $ hasLine ["effort", "(default)", "[built-in default]"] `shouldBe` True + it "labels a per-command local trace with its concrete key" $ + hasLine ["trace", "file", "[local: agent.run.trace]"] `shouldBe` True + + it "labels a global default trace with the shared key" $ + hasLine ["trace", "stderr", "[global: agent.trace]"] `shouldBe` True + + it "shows an unconfigured trace as off with built-in provenance" $ + hasLine ["trace", "off", "[built-in default]"] `shouldBe` True + it "includes the precedence legend" $ ("Precedence, highest first:" `Text.isInfixOf` rendered) `shouldBe` True + it "names the trace environment variable in the legend" $ + ("SEIHOU_AGENT_TRACE" `Text.isInfixOf` rendered) `shouldBe` True + + it "names the trace path key in the legend" $ + ("agent.tracePath" `Text.isInfixOf` rendered) `shouldBe` True + sample :: [ResolvedCommandConfig] sample = [ ResolvedCommandConfig AgentCmdAssist (ResolvedAgentField AgentProviderCodexCli SourceGlobalCommand) (ResolvedAgentField Nothing SourceBuiltinDefault) - (ResolvedAgentField (Just ThinkingHigh) SourceGlobalDefault), + (ResolvedAgentField (Just ThinkingHigh) SourceGlobalDefault) + (ResolvedAgentField TraceStderr SourceGlobalDefault) + Nothing, ResolvedCommandConfig AgentCmdBootstrap (ResolvedAgentField AgentProviderClaudeCli SourceBuiltinDefault) (ResolvedAgentField (Just "claude-sonnet-5") SourceGlobalDefault) - (ResolvedAgentField Nothing SourceBuiltinDefault), + (ResolvedAgentField Nothing SourceBuiltinDefault) + (ResolvedAgentField TraceOff SourceBuiltinDefault) + Nothing, ResolvedCommandConfig AgentCmdRun (ResolvedAgentField AgentProviderClaudeCli SourceBuiltinDefault) (ResolvedAgentField (Just "claude-opus-4-8") SourceLocalCommand) - (ResolvedAgentField (Just ThinkingMax) SourceLocalCommand), + (ResolvedAgentField (Just ThinkingMax) SourceLocalCommand) + (ResolvedAgentField TraceFile SourceLocalCommand) + (Just "/tmp/trace.jsonl"), ResolvedCommandConfig AgentCmdMigrate (ResolvedAgentField AgentProviderOpenAI SourceLocalCommand) (ResolvedAgentField (Just "gpt-5-mini") SourceLocalCommand) (ResolvedAgentField Nothing SourceBuiltinDefault) + (ResolvedAgentField TraceOff SourceBuiltinDefault) + Nothing ] diff --git a/test/Seihou/CLI/AgentConfigSpec.hs b/test/Seihou/CLI/AgentConfigSpec.hs --- a/test/Seihou/CLI/AgentConfigSpec.hs +++ b/test/Seihou/CLI/AgentConfigSpec.hs @@ -1,11 +1,14 @@ module Seihou.CLI.AgentConfigSpec (tests) where import Baikai.ThinkingLevel (ThinkingLevel (..)) +import Control.Lens ((&), (.~), (?~), (^.)) +import Data.Generics.Labels () import Data.Map.Strict qualified as Map import Data.Text (Text) import Data.Text qualified as Text import Seihou.CLI.AgentCompletion import Seihou.CLI.AgentConfig +import Seihou.Core.Types (AgentLaunch (..)) import Test.Hspec import Test.Tasty import Test.Tasty.Hspec (testSpec) @@ -18,17 +21,29 @@ describe "resolveAgentModelConfig" $ do it "uses CLI flags before environment variables" $ resolveAgentModelConfig - (baseInputs {cliProvider = Just "codex-cli", cliModel = Just "gpt-5", envProvider = Just "anthropic", envModel = Just "claude-sonnet-4-6"}) + ( baseInputs + & #cliProvider ?~ "codex-cli" + & #cliModel ?~ "gpt-5" + & #envProvider ?~ "anthropic" + & #envModel ?~ "claude-sonnet-4-6" + ) `shouldBe` Right (cfg AgentProviderCodexCli (Just "gpt-5")) it "uses environment variables before local config" $ resolveAgentModelConfig - (baseInputs {envProvider = Just "openai", envModel = Just "gpt-4o", localConfig = config "anthropic" "claude-sonnet-4-6"}) + ( baseInputs + & #envProvider ?~ "openai" + & #envModel ?~ "gpt-4o" + & #localConfig .~ config "anthropic" "claude-sonnet-4-6" + ) `shouldBe` Right (cfg AgentProviderOpenAI (Just "gpt-4o")) it "uses local config before global config" $ resolveAgentModelConfig - (baseInputs {localConfig = config "anthropic" "claude-opus-4-1", globalConfig = config "openai" "gpt-4o-mini"}) + ( baseInputs + & #localConfig .~ config "anthropic" "claude-opus-4-1" + & #globalConfig .~ config "openai" "gpt-4o-mini" + ) `shouldBe` Right (cfg AgentProviderAnthropic (Just "claude-opus-4-1")) it "pins the deterministic claude-cli default model when nothing is set" $ @@ -36,11 +51,11 @@ `shouldBe` Right (cfg AgentProviderClaudeCli (Just "claude-opus-4-8")) it "pins the deterministic codex-cli default model when only the provider is set" $ - resolveAgentModelConfig (baseInputs {cliProvider = Just "codex-cli"}) + resolveAgentModelConfig (baseInputs & #cliProvider ?~ "codex-cli") `shouldBe` Right (cfg AgentProviderCodexCli (Just "gpt-5.6-terra")) it "returns provider diagnostics for invalid provider text" $ - resolveAgentModelConfig (baseInputs {cliProvider = Just "llama"}) `shouldSatisfy` \case + resolveAgentModelConfig (baseInputs & #cliProvider ?~ "llama") `shouldSatisfy` \case Left err -> "Unknown agent provider" `Text.isInfixOf` err && "claude-cli" `Text.isInfixOf` err @@ -48,51 +63,58 @@ Right _ -> False it "allows a model-only override while keeping the default provider" $ - resolveAgentModelConfig (baseInputs {cliModel = Just "sonnet"}) + resolveAgentModelConfig (baseInputs & #cliModel ?~ "sonnet") `shouldBe` Right (cfg AgentProviderClaudeCli (Just "sonnet")) it "ignores blank higher-precedence values" $ resolveAgentModelConfig - (baseInputs {cliProvider = Just " ", envProvider = Just "codex-cli", cliModel = Just "", envModel = Just "gpt-5"}) + ( baseInputs + & #cliProvider ?~ " " + & #envProvider ?~ "codex-cli" + & #cliModel ?~ "" + & #envModel ?~ "gpt-5" + ) `shouldBe` Right (cfg AgentProviderCodexCli (Just "gpt-5")) describe "resolveAgentModelConfigFor (per-command)" $ do it "prefers a per-command model over the default in the same scope" $ do let inputs = - baseInputs - { localConfig = - Map.fromList - [ (agentModelConfigKey, "claude-sonnet-5"), - (agentCommandModelConfigKey AgentCmdRun, "claude-opus-4-8") - ] - } + ( baseInputs + & #localConfig .~ Map.fromList [(agentModelConfigKey, "claude-sonnet-5"), (agentCommandModelConfigKey AgentCmdRun, "claude-opus-4-8")] + ) modelOf AgentCmdRun inputs `shouldBe` Right (Just "claude-opus-4-8", SourceLocalCommand) modelOf AgentCmdAssist inputs `shouldBe` Right (Just "claude-sonnet-5", SourceLocalDefault) it "lets a local default override a global per-command key (project over global)" $ do let inputs = - baseInputs - { localConfig = Map.fromList [(agentModelConfigKey, "claude-sonnet-5")], - globalConfig = Map.fromList [(agentCommandModelConfigKey AgentCmdRun, "gpt-5")] - } + ( baseInputs + & #localConfig .~ Map.fromList [(agentModelConfigKey, "claude-sonnet-5")] + & #globalConfig .~ Map.fromList [(agentCommandModelConfigKey AgentCmdRun, "gpt-5")] + ) modelOf AgentCmdRun inputs `shouldBe` Right (Just "claude-sonnet-5", SourceLocalDefault) it "prefers a global per-command key over the global default" $ do let inputs = - baseInputs - { globalConfig = - Map.fromList - [ (agentProviderConfigKey, "anthropic"), - (agentCommandProviderConfigKey AgentCmdAssist, "openai") - ] - } + ( baseInputs + & #globalConfig .~ Map.fromList [(agentProviderConfigKey, "anthropic"), (agentCommandProviderConfigKey AgentCmdAssist, "openai")] + ) providerOf AgentCmdAssist inputs `shouldBe` Right (AgentProviderOpenAI, SourceGlobalCommand) providerOf AgentCmdSetup inputs `shouldBe` Right (AgentProviderAnthropic, SourceGlobalDefault) it "labels a subcommand CLI flag distinctly from a parent flag" $ do - providerOf AgentCmdAssist (baseInputs {cliProvider = Just "codex-cli", cliProviderFromSubcommand = True}) + providerOf + AgentCmdAssist + ( baseInputs + & #cliProvider ?~ "codex-cli" + & #cliProviderFromSubcommand .~ True + ) `shouldBe` Right (AgentProviderCodexCli, SourceCliSubcommand) - providerOf AgentCmdAssist (baseInputs {cliProvider = Just "codex-cli", cliProviderFromSubcommand = False}) + providerOf + AgentCmdAssist + ( baseInputs + & #cliProvider ?~ "codex-cli" + & #cliProviderFromSubcommand .~ False + ) `shouldBe` Right (AgentProviderCodexCli, SourceCliParent) it "falls back to the pinned CLI default model with built-in provenance" $ do @@ -103,27 +125,27 @@ -- With nothing configured, every command resolves to a concrete model for -- both local CLI providers, so seihou always passes an explicit --model. modelOf AgentCmdAssist baseInputs `shouldBe` Right (Just "claude-opus-4-8", SourceBuiltinDefault) - modelOf AgentCmdAssist (baseInputs {cliProvider = Just "codex-cli", cliProviderFromSubcommand = True}) + modelOf + AgentCmdAssist + ( baseInputs + & #cliProvider ?~ "codex-cli" + & #cliProviderFromSubcommand .~ True + ) `shouldBe` Right (Just "gpt-5.6-terra", SourceBuiltinDefault) it "keeps environment variables above per-command config" $ do let inputs = - baseInputs - { envModel = Just "gpt-5", - localConfig = Map.fromList [(agentCommandModelConfigKey AgentCmdRun, "claude-opus-4-8")] - } + ( baseInputs + & #envModel ?~ "gpt-5" + & #localConfig .~ Map.fromList [(agentCommandModelConfigKey AgentCmdRun, "claude-opus-4-8")] + ) modelOf AgentCmdRun inputs `shouldBe` Right (Just "gpt-5", SourceEnv) it "resolves migrate from its own per-command keys" $ do let inputs = - baseInputs - { localConfig = - Map.fromList - [ (agentCommandProviderConfigKey AgentCmdMigrate, "openai"), - (agentCommandModelConfigKey AgentCmdMigrate, "gpt-5-mini"), - (agentCommandModelConfigKey AgentCmdRun, "claude-opus-4-8") - ] - } + ( baseInputs + & #localConfig .~ Map.fromList [(agentCommandProviderConfigKey AgentCmdMigrate, "openai"), (agentCommandModelConfigKey AgentCmdMigrate, "gpt-5-mini"), (agentCommandModelConfigKey AgentCmdRun, "claude-opus-4-8")] + ) providerOf AgentCmdMigrate inputs `shouldBe` Right (AgentProviderOpenAI, SourceLocalCommand) modelOf AgentCmdMigrate inputs `shouldBe` Right (Just "gpt-5-mini", SourceLocalCommand) modelOf AgentCmdRun inputs `shouldBe` Right (Just "claude-opus-4-8", SourceLocalCommand) @@ -134,63 +156,360 @@ it "prefers a per-command effort over the shared default in the same scope" $ do let inputs = - baseInputs - { localConfig = - Map.fromList - [ (agentEffortConfigKey, "medium"), - (agentCommandEffortConfigKey AgentCmdRun, "max") - ] - } + ( baseInputs + & #localConfig .~ Map.fromList [(agentEffortConfigKey, "medium"), (agentCommandEffortConfigKey AgentCmdRun, "max")] + ) effortOf AgentCmdRun inputs `shouldBe` Right (Just ThinkingMax, SourceLocalCommand) effortOf AgentCmdAssist inputs `shouldBe` Right (Just ThinkingMedium, SourceLocalDefault) it "lets a local default effort override a global per-command effort" $ do let inputs = - baseInputs - { localConfig = Map.fromList [(agentEffortConfigKey, "low")], - globalConfig = Map.fromList [(agentCommandEffortConfigKey AgentCmdRun, "max")] - } + ( baseInputs + & #localConfig .~ Map.fromList [(agentEffortConfigKey, "low")] + & #globalConfig .~ Map.fromList [(agentCommandEffortConfigKey AgentCmdRun, "max")] + ) effortOf AgentCmdRun inputs `shouldBe` Right (Just ThinkingLow, SourceLocalDefault) it "keeps the effort environment variable above config" $ do let inputs = - baseInputs - { envEffort = Just "high", - localConfig = Map.fromList [(agentCommandEffortConfigKey AgentCmdRun, "minimal")] - } + ( baseInputs + & #envEffort ?~ "high" + & #localConfig .~ Map.fromList [(agentCommandEffortConfigKey AgentCmdRun, "minimal")] + ) effortOf AgentCmdRun inputs `shouldBe` Right (Just ThinkingHigh, SourceEnv) it "prefers the subcommand effort flag over everything" $ effortOf AgentCmdRun - (baseInputs {cliEffort = Just "xhigh", cliEffortFromSubcommand = True, envEffort = Just "low"}) + ( baseInputs + & #cliEffort ?~ "xhigh" + & #cliEffortFromSubcommand .~ True + & #envEffort ?~ "low" + ) `shouldBe` Right (Just ThinkingXHigh, SourceCliSubcommand) it "parses effort case-insensitively" $ - effortOf AgentCmdRun (baseInputs {cliEffort = Just " MAX "}) `shouldBe` Right (Just ThinkingMax, SourceCliParent) + effortOf AgentCmdRun (baseInputs & #cliEffort ?~ " MAX ") `shouldBe` Right (Just ThinkingMax, SourceCliParent) it "returns a diagnostic for an invalid effort value" $ - resolveAgentModelConfigFor AgentCmdRun (baseInputs {cliEffort = Just "ultra"}) `shouldSatisfy` \case + resolveAgentModelConfigFor AgentCmdRun (baseInputs & #cliEffort ?~ "ultra") `shouldSatisfy` \case Left err -> "Unknown reasoning effort" `Text.isInfixOf` err && "xhigh" `Text.isInfixOf` err Right _ -> False + describe "resolveAgentModelConfigFor (call tracing)" $ do + it "defaults to tracing off when nothing is configured" $ + traceOf AgentCmdRun baseInputs `shouldBe` Right (TraceOff, SourceBuiltinDefault) + + it "prefers a per-command trace over the shared default in the same scope" $ do + let inputs = + ( baseInputs + & #localConfig .~ Map.fromList [(agentTraceConfigKey, "stderr"), (agentCommandTraceConfigKey AgentCmdRun, "file")] + ) + traceOf AgentCmdRun inputs `shouldBe` Right (TraceFile, SourceLocalCommand) + traceOf AgentCmdAssist inputs `shouldBe` Right (TraceStderr, SourceLocalDefault) + + it "lets a local default trace override a global per-command trace" $ do + let inputs = + ( baseInputs + & #localConfig .~ Map.fromList [(agentTraceConfigKey, "stdout")] + & #globalConfig .~ Map.fromList [(agentCommandTraceConfigKey AgentCmdRun, "file")] + ) + traceOf AgentCmdRun inputs `shouldBe` Right (TraceStdout, SourceLocalDefault) + + it "lets a global per-command trace beat a global default" $ do + let inputs = + ( baseInputs + & #globalConfig .~ Map.fromList [(agentTraceConfigKey, "stdout"), (agentCommandTraceConfigKey AgentCmdRun, "file")] + ) + traceOf AgentCmdRun inputs `shouldBe` Right (TraceFile, SourceGlobalCommand) + + it "keeps the trace environment variable above config" $ do + let inputs = + ( baseInputs + & #envTrace ?~ "stderr" + & #localConfig .~ Map.fromList [(agentCommandTraceConfigKey AgentCmdRun, "file")] + ) + traceOf AgentCmdRun inputs `shouldBe` Right (TraceStderr, SourceEnv) + + it "keeps a declared trace above config but below the environment" $ do + let declared = (baseInputs & #declaredTrace ?~ "file") + traceOf + AgentCmdRun + ( declared + & #localConfig .~ Map.fromList [(agentTraceConfigKey, "stdout")] + ) + `shouldBe` Right (TraceFile, SourceArtifactDeclaration) + traceOf AgentCmdRun (declared & #envTrace ?~ "stderr") + `shouldBe` Right (TraceStderr, SourceEnv) + + it "prefers the subcommand trace flag over everything" $ + traceOf + AgentCmdRun + ( baseInputs + & #cliTrace ?~ "off" + & #cliTraceFromSubcommand .~ True + & #envTrace ?~ "file" + ) + `shouldBe` Right (TraceOff, SourceCliSubcommand) + + it "attributes a parent `seihou agent` trace flag to that tier" $ + traceOf + AgentCmdRun + ( baseInputs + & #cliTrace ?~ "file" + & #cliTraceFromSubcommand .~ False + ) + `shouldBe` Right (TraceFile, SourceCliParent) + + it "parses trace settings case-insensitively" $ + traceOf AgentCmdRun (baseInputs & #cliTrace ?~ " STDERR ") + `shouldBe` Right (TraceStderr, SourceCliParent) + + it "skips a blank trace value in favor of the next tier" $ + traceOf + AgentCmdRun + ( baseInputs + & #cliTrace ?~ " " + & #localConfig .~ Map.fromList [(agentTraceConfigKey, "file")] + ) + `shouldBe` Right (TraceFile, SourceLocalDefault) + + it "returns a diagnostic naming every accepted trace setting" $ + resolveAgentModelConfigFor AgentCmdRun (baseInputs & #cliTrace ?~ "syslog") `shouldSatisfy` \case + Left err -> + "Unknown trace setting" `Text.isInfixOf` err + && "off" `Text.isInfixOf` err + && "file" `Text.isInfixOf` err + && "stdout" `Text.isInfixOf` err + && "stderr" `Text.isInfixOf` err + Right _ -> False + + describe "resolveTracePath" $ do + it "is unset when no agent.tracePath is configured" $ + resolveTracePath baseInputs `shouldBe` Nothing + + it "reads the local key before the global key" $ + resolveTracePath + ( baseInputs + & #localConfig .~ Map.fromList [(agentTracePathConfigKey, "/tmp/local.jsonl")] + & #globalConfig .~ Map.fromList [(agentTracePathConfigKey, "/tmp/global.jsonl")] + ) + `shouldBe` Just "/tmp/local.jsonl" + + it "falls back to the global key" $ + resolveTracePath + ( baseInputs + & #globalConfig .~ Map.fromList [(agentTracePathConfigKey, "/tmp/global.jsonl")] + ) + `shouldBe` Just "/tmp/global.jsonl" + + it "treats a blank local path as absent" $ + resolveTracePath + ( baseInputs + & #localConfig .~ Map.fromList [(agentTracePathConfigKey, " ")] + & #globalConfig .~ Map.fromList [(agentTracePathConfigKey, "/tmp/global.jsonl")] + ) + `shouldBe` Just "/tmp/global.jsonl" + + describe "artifact-declared launch settings" $ do + it "beats a per-command local config key" $ do + let inputs = + declaring + (decl Nothing (Just "claude-sonnet-5") Nothing) + ( baseInputs + & #localConfig .~ Map.fromList [(agentCommandModelConfigKey AgentCmdRun, "claude-haiku-4-5")] + ) + modelOf AgentCmdRun inputs `shouldBe` Right (Just "claude-sonnet-5", SourceArtifactDeclaration) + + it "beats both local and global default keys" $ do + let inputs = + declaring + (decl (Just "openai") Nothing (Just "high")) + ( baseInputs + & #localConfig .~ Map.fromList [(agentProviderConfigKey, "anthropic")] + & #globalConfig .~ Map.fromList [(agentEffortConfigKey, "low")] + ) + providerOf AgentCmdRun inputs `shouldBe` Right (AgentProviderOpenAI, SourceArtifactDeclaration) + effortOf AgentCmdRun inputs `shouldBe` Right (Just ThinkingHigh, SourceArtifactDeclaration) + + it "loses to a subcommand flag" $ do + let inputs = + declaring + (decl Nothing (Just "claude-sonnet-5") Nothing) + ( baseInputs + & #cliModel ?~ "claude-opus-4-8" + & #cliModelFromSubcommand .~ True + ) + modelOf AgentCmdRun inputs `shouldBe` Right (Just "claude-opus-4-8", SourceCliSubcommand) + + it "loses to a parent `seihou agent` flag" $ do + let inputs = + declaring + (decl Nothing (Just "claude-sonnet-5") Nothing) + ( baseInputs + & #cliModel ?~ "claude-opus-4-8" + & #cliModelFromSubcommand .~ False + ) + modelOf AgentCmdRun inputs `shouldBe` Right (Just "claude-opus-4-8", SourceCliParent) + + it "loses to an environment variable" $ do + let inputs = + declaring + (decl Nothing (Just "claude-sonnet-5") (Just "max")) + ( baseInputs + & #envEffort ?~ "low" + ) + effortOf AgentCmdRun inputs `shouldBe` Right (Just ThinkingLow, SourceEnv) + -- ...but only for the field the environment names. + modelOf AgentCmdRun inputs `shouldBe` Right (Just "claude-sonnet-5", SourceArtifactDeclaration) + + it "skips a blank declared value in favor of the next tier" $ do + let inputs = + declaring + (decl Nothing (Just " ") Nothing) + ( baseInputs + & #localConfig .~ Map.fromList [(agentModelConfigKey, "claude-haiku-4-5")] + ) + modelOf AgentCmdRun inputs `shouldBe` Right (Just "claude-haiku-4-5", SourceLocalDefault) + + -- Guards the applyProviderDefaultModel interaction: a declaration that only + -- changes the provider must pick up that provider's pinned default model, + -- not the previous provider's. + it "picks up the declared provider's pinned default model" $ do + let inputs = declaring (decl (Just "codex-cli") Nothing Nothing) baseInputs + providerOf AgentCmdRun inputs `shouldBe` Right (AgentProviderCodexCli, SourceArtifactDeclaration) + modelOf AgentCmdRun inputs `shouldBe` Right (Just "gpt-5.6-terra", SourceBuiltinDefault) + + it "returns a diagnostic naming the accepted providers for a bad declared provider" $ + resolveAgentModelConfigFor AgentCmdRun (declaring (decl (Just "llama") Nothing Nothing) baseInputs) + `shouldSatisfy` \case + Left err -> + "Unknown agent provider" `Text.isInfixOf` err + && "claude-cli" `Text.isInfixOf` err + && "openai" `Text.isInfixOf` err + Right _ -> False + + it "returns a diagnostic for a bad declared effort" $ + resolveAgentModelConfigFor AgentCmdRun (declaring (decl Nothing Nothing (Just "ultra")) baseInputs) + `shouldSatisfy` \case + Left err -> "Unknown reasoning effort" `Text.isInfixOf` err + Right _ -> False + + it "labels blueprint-run and migrate declarations as blueprint sources" $ do + agentConfigSourceLabel AgentCmdRun ModelField SourceArtifactDeclaration `shouldBe` "blueprint: launch.model" + agentConfigSourceLabel AgentCmdMigrate EffortField SourceArtifactDeclaration `shouldBe` "blueprint: launch.effort" + agentConfigSourceLabel AgentCmdRun ProviderField SourceArtifactDeclaration `shouldBe` "blueprint: launch.provider" + + it "labels a prompt-run declaration as a prompt source" $ + agentConfigSourceLabel AgentCmdPromptRun ModelField SourceArtifactDeclaration `shouldBe` "prompt: launch.model" + + describe "agentLaunchDeclaration" $ do + it "treats a missing launch record as declaring nothing" $ + agentLaunchDeclaration Nothing `shouldBe` noAgentLaunchDeclaration + + it "projects the three resolvable fields and drops the reserved mode" $ + agentLaunchDeclaration + (Just AgentLaunch {provider = Just "codex-cli", model = Just "gpt-5", effort = Just "max", mode = Just "ignored"}) + `shouldBe` AgentLaunchDeclaration + { provider = Just "codex-cli", + model = Just "gpt-5", + effort = Just "max" + } + + describe "validateAgentLaunchDeclaration" $ do + it "accepts a declaration that states nothing" $ + validateAgentLaunchDeclaration noAgentLaunchDeclaration `shouldBe` [] + + it "accepts valid provider and effort values" $ + validateAgentLaunchDeclaration (decl (Just "codex-cli") (Just "anything-goes") (Just "max")) `shouldBe` [] + + it "reports an unknown provider under its key" $ + validateAgentLaunchDeclaration (decl (Just "llama") Nothing Nothing) `shouldSatisfy` \case + [err] -> "launch.provider: " `Text.isPrefixOf` err && "Unknown agent provider" `Text.isInfixOf` err + _ -> False + + it "reports an unknown effort under its key" $ + validateAgentLaunchDeclaration (decl Nothing Nothing (Just "ultra")) `shouldSatisfy` \case + [err] -> "launch.effort: " `Text.isPrefixOf` err && "Unknown reasoning effort" `Text.isInfixOf` err + _ -> False + + it "reports both invalid values at once" $ + length (validateAgentLaunchDeclaration (decl (Just "llama") Nothing (Just "ultra"))) `shouldBe` 2 + + it "does not check the model, which is free-form" $ + validateAgentLaunchDeclaration (decl Nothing (Just "some-private-model-id") Nothing) `shouldBe` [] + + describe "formatResolvedAgentProvenance" $ do + it "names each field's value and source" $ do + let pending = PendingAgentConfig AgentCmdRun baseInputs + fmap formatResolvedAgentProvenance (resolvePendingAgentConfig pending (decl Nothing (Just "claude-sonnet-5") (Just "max"))) + `shouldBe` Right + "provider claude-cli [built-in default], model claude-sonnet-5 [blueprint: launch.model], effort max [blueprint: launch.effort], trace off [built-in default]" + + it "reports an unset effort rather than omitting it" $ do + let pending = PendingAgentConfig AgentCmdPromptRun baseInputs + fmap formatResolvedAgentProvenance (resolvePendingAgentConfig pending noAgentLaunchDeclaration) + `shouldBe` Right + "provider claude-cli [built-in default], model claude-opus-4-8 [built-in default], effort [built-in default], trace off [built-in default]" + + describe "resolvePendingAgentConfig" $ do + it "projects down to the config the launch layer consumes" $ do + let pending = PendingAgentConfig AgentCmdRun baseInputs + fmap resolvedAgentModelConfig (resolvePendingAgentConfig pending (decl (Just "codex-cli") Nothing (Just "high"))) + `shouldBe` Right + AgentModelConfig + { provider = AgentProviderCodexCli, + model = Just "gpt-5.6-terra", + effort = Just ThinkingHigh, + trace = TraceOff, + tracePath = Nothing + } + +-- | Build an 'AgentLaunchDeclaration' from the three resolvable fields. +decl :: Maybe Text -> Maybe Text -> Maybe Text -> AgentLaunchDeclaration +decl provider model effort = + AgentLaunchDeclaration + { provider = provider, + model = model, + effort = effort + } + +-- | Fold a declaration into an inputs record, the way +-- 'resolvePendingAgentConfig' does. +declaring :: AgentLaunchDeclaration -> AgentConfigInputs -> AgentConfigInputs +declaring d inputs = + inputs + & #declaredProvider .~ d ^. #provider + & #declaredModel .~ d ^. #model + & #declaredEffort .~ d ^. #effort + providerOf :: AgentCommandName -> AgentConfigInputs -> Either Text (AgentProvider, AgentConfigSource) providerOf c inputs = - (\(p, _, _) -> (p.resolvedValue, p.resolvedSource)) <$> resolveAgentModelConfigFor c inputs + (\(p, _, _, _) -> (p ^. #value, p ^. #source)) <$> resolveAgentModelConfigFor c inputs modelOf :: AgentCommandName -> AgentConfigInputs -> Either Text (Maybe Text, AgentConfigSource) modelOf c inputs = - (\(_, m, _) -> (m.resolvedValue, m.resolvedSource)) <$> resolveAgentModelConfigFor c inputs + (\(_, m, _, _) -> (m ^. #value, m ^. #source)) <$> resolveAgentModelConfigFor c inputs effortOf :: AgentCommandName -> AgentConfigInputs -> Either Text (Maybe ThinkingLevel, AgentConfigSource) effortOf c inputs = - (\(_, _, e) -> (e.resolvedValue, e.resolvedSource)) <$> resolveAgentModelConfigFor c inputs + (\(_, _, e, _) -> (e ^. #value, e ^. #source)) <$> resolveAgentModelConfigFor c inputs +traceOf :: AgentCommandName -> AgentConfigInputs -> Either Text (TraceSetting, AgentConfigSource) +traceOf c inputs = + (\(_, _, _, t) -> (t ^. #value, t ^. #source)) <$> resolveAgentModelConfigFor c inputs + -- | Build an expected 'AgentModelConfig' with effort unset (the flat resolver -- never sets effort). cfg :: AgentProvider -> Maybe Text -> AgentModelConfig cfg provider model = - AgentModelConfig {agentProvider = provider, agentModel = model, agentEffort = Nothing} + AgentModelConfig + { provider = provider, + model = model, + effort = Nothing, + trace = TraceOff, + tracePath = Nothing + } baseInputs :: AgentConfigInputs baseInputs = baseAgentConfigInputs diff --git a/test/Seihou/CLI/AgentLaunchSpec.hs b/test/Seihou/CLI/AgentLaunchSpec.hs --- a/test/Seihou/CLI/AgentLaunchSpec.hs +++ b/test/Seihou/CLI/AgentLaunchSpec.hs @@ -1,5 +1,6 @@ module Seihou.CLI.AgentLaunchSpec (tests) where +import Control.Lens ((&), (.~)) import Data.List (nub) import Data.Text qualified as T import Seihou.CLI.AgentLaunch @@ -56,7 +57,7 @@ describe "formatSeihouProjectState" $ do it "names .seihou/ when initialised" $ - formatSeihouProjectState (baseCtx {seihouInitialized = True}) + formatSeihouProjectState (baseCtx & #seihouInitialized .~ True) `shouldBe` "Seihou project: .seihou/ directory exists (this is a seihou-managed project)" it "states 'No .seihou/' when not initialised" $ formatSeihouProjectState baseCtx @@ -64,7 +65,7 @@ describe "formatManifestState" $ do it "names manifest.json when present" $ - formatManifestState (baseCtx {hasManifest = True}) + formatManifestState (baseCtx & #hasManifest .~ True) `shouldBe` "Manifest: .seihou/manifest.json exists (modules have been applied here)" it "reports no manifest otherwise" $ formatManifestState baseCtx @@ -72,7 +73,7 @@ describe "formatModuleDhallState" $ do it "names module.dhall when present in cwd" $ - formatModuleDhallState (baseCtx {localModuleDhall = True}) + formatModuleDhallState (baseCtx & #localModuleDhall .~ True) `shouldBe` "Module in cwd: module.dhall found in current directory (user is authoring a module here)" it "is empty when module.dhall is absent" $ formatModuleDhallState baseCtx `shouldBe` "" @@ -81,7 +82,7 @@ it "is empty when there are no local modules" $ formatLocalModules baseCtx `shouldBe` "" it "lists local modules with bullet prefixes" $ - formatLocalModules (baseCtx {localModules = ["foo", "bar"]}) + formatLocalModules (baseCtx & #localModules .~ ["foo", "bar"]) `shouldBe` "Local modules:\n - foo\n - bar" describe "formatAvailableModules" $ do @@ -90,7 +91,7 @@ `shouldBe` "Available modules: None discovered" it "renders entries as 'name — description (source)' lines" $ formatAvailableModules - (baseCtx {availableModules = [("foo", "the foo module", "user")]}) + (baseCtx & #availableModules .~ [("foo", "the foo module", "user")]) `shouldBe` "Available modules across search paths:\n - foo — the foo module (user)" describe "formatBaselineStatus" $ do @@ -151,7 +152,8 @@ files = [], allowedTools = Nothing, tags = [], - migrations = [] + migrations = [], + launch = Nothing } it "renders name, version, description as a three-line block" $ formatBlueprintIdentity (mk (Just "0.1") (Just "a thing")) diff --git a/test/Seihou/CLI/AgentMigrateE2ESpec.hs b/test/Seihou/CLI/AgentMigrateE2ESpec.hs --- a/test/Seihou/CLI/AgentMigrateE2ESpec.hs +++ b/test/Seihou/CLI/AgentMigrateE2ESpec.hs @@ -1,9 +1,12 @@ module Seihou.CLI.AgentMigrateE2ESpec (tests) where +import Control.Lens ((^.)) import Data.ByteString.Lazy qualified as LBS +import Data.Generics.Labels () import Data.Maybe (fromMaybe) import Data.Text qualified as T import Data.Text.IO qualified as TIO +import Seihou.CLI.SeihouBinary (seihouBinary) import Seihou.Core.Types (AppliedBlueprintMigration (..), Manifest (..)) import Seihou.Manifest.Types (manifestFromJSON) import System.Directory @@ -13,7 +16,7 @@ getPermissions, setPermissions, ) -import System.Environment (getEnvironment, getExecutablePath) +import System.Environment (getEnvironment) import System.Exit (ExitCode (..)) import System.FilePath (searchPathSeparator, takeDirectory, ()) import System.IO.Temp (withSystemTempDirectory) @@ -24,6 +27,108 @@ tests :: IO TestTree tests = testSpec "Agent migrate end-to-end" $ do + it "exposes non-interactive blueprint runs in help" $ do + binary <- seihouBinary + (exitCode, output, _) <- runProcessText binary ["agent", "run", "--help"] Nothing Nothing + exitCode `shouldBe` ExitSuccess + output `shouldSatisfy` T.isInfixOf "--batch" + output `shouldSatisfy` T.isInfixOf "stdin is not a terminal" + + it "automatically uses the batch CLI provider when stdin is not a terminal" $ + withSystemTempDirectory "seihou-agent-run-batch" $ \root -> do + binary <- seihouBinary + let blueprintDir = root ".seihou" "modules" "batch-blueprint" + blueprintPath = blueprintDir "blueprint.dhall" + referencePath = blueprintDir "files" "reference.md" + manifestPath = root ".seihou" "manifest.json" + xdgHome = root "xdg" + fakeBin = root "bin" + fakeClaude = fakeBin "claude" + launchLog = root "agent-launch.args" + workspaceFile = root "batch-ran.txt" + createDirectoryIfMissing True blueprintDir + createDirectoryIfMissing True (takeDirectory referencePath) + createDirectoryIfMissing True xdgHome + createDirectoryIfMissing True fakeBin + TIO.writeFile blueprintPath batchBlueprintDhall + TIO.writeFile referencePath "batch reference" + TIO.writeFile + fakeClaude + "#!/bin/sh\nprintf '%s\\n' \"$@\" > \"$SEIHOU_FAKE_AGENT_LOG\"\nprintf 'edited\\n' > \"$SEIHOU_FAKE_WORKSPACE_FILE\"\nprintf '%s\\n' '{\"result\":\"batch complete\",\"is_error\":false,\"session_id\":\"fake\"}'\n" + permissions <- getPermissions fakeClaude + -- Permissions comes from `directory` and has no Generic instance, so it + -- has no #executable label. Record update syntax is the only option. + setPermissions fakeClaude (permissions {executable = True}) + + inherited <- getEnvironment + let inheritedPath = fromMaybe "" (lookup "PATH" inherited) + overriddenNames = + [ "PATH", + "XDG_CONFIG_HOME", + "SEIHOU_AGENT_PROVIDER", + "SEIHOU_AGENT_MODEL", + "SEIHOU_CONTEXT", + "SEIHOU_FAKE_AGENT_LOG", + "SEIHOU_FAKE_WORKSPACE_FILE" + ] + environment = + ("PATH", fakeBin <> [searchPathSeparator] <> inheritedPath) + : ("XDG_CONFIG_HOME", xdgHome) + : ("SEIHOU_AGENT_PROVIDER", "claude-cli") + : ("SEIHOU_FAKE_AGENT_LOG", launchLog) + : ("SEIHOU_FAKE_WORKSPACE_FILE", workspaceFile) + : filter (\(key, _) -> key `notElem` overriddenNames) inherited + + (exitCode, output, errorOutput) <- + runProcessText binary ["agent", "run", "batch-blueprint"] (Just root) (Just environment) + case exitCode of + ExitSuccess -> pure () + ExitFailure code -> + expectationFailure $ + "batch run exited " + <> show code + <> "\nstdout:\n" + <> T.unpack output + <> "\nstderr:\n" + <> T.unpack errorOutput + output `shouldSatisfy` T.isInfixOf "batch complete" + doesFileExist workspaceFile `shouldReturn` True + doesFileExist manifestPath `shouldReturn` True + launchArgs <- T.lines <$> TIO.readFile launchLog + launchArgs `shouldSatisfy` elem "-p" + launchArgs `shouldSatisfy` elem "--allowedTools" + launchArgs `shouldSatisfy` elem "--add-dir" + launchArgs `shouldSatisfy` elem (T.pack (blueprintDir "files")) + + -- The two cases below are the end-to-end proof that a blueprint's own launch + -- declaration reaches the spawned agent process, rather than only reaching + -- seihou's internal accounting. They read back the argv the fake `claude` + -- script was called with. + it "applies a blueprint-declared model and effort to the launched agent" $ + withDeclaredLaunchBlueprint $ \root blueprintName runDeclared -> do + (exitCode, output, errorOutput, launchArgs) <- runDeclared [] + expectSuccess "declared launch run" exitCode output errorOutput + output `shouldSatisfy` T.isInfixOf "declared complete" + launchArgs `shouldSatisfy` elem "--model" + launchArgs `shouldSatisfy` elem "claude-sonnet-5" + launchArgs `shouldSatisfy` elem "--effort" + launchArgs `shouldSatisfy` elem "max" + -- Sanity: nothing in the environment or config supplied these; they came + -- from the blueprint, whose directory is under this temp root. + root `shouldSatisfy` (not . null) + blueprintName `shouldBe` "declared-launch" + + it "lets a --model flag override the blueprint declaration" $ + withDeclaredLaunchBlueprint $ \_ _ runDeclared -> do + (exitCode, output, errorOutput, launchArgs) <- runDeclared ["--model", "claude-opus-4-8"] + expectSuccess "flag override run" exitCode output errorOutput + launchArgs `shouldSatisfy` elem "claude-opus-4-8" + launchArgs `shouldNotSatisfy` elem "claude-sonnet-5" + -- Only the field the flag names moves; effort still comes from the + -- blueprint. + launchArgs `shouldSatisfy` elem "--effort" + launchArgs `shouldSatisfy` elem "max" + it "exposes the required version window and rerun option in help" $ do binary <- seihouBinary (exitCode, output, _) <- runProcessText binary ["agent", "migrate", "--help"] Nothing Nothing @@ -102,6 +207,8 @@ TIO.writeFile blueprintPath migrationBlueprintDhall TIO.writeFile fakeClaude "#!/bin/sh\nprintf 'called\\n' >> \"$SEIHOU_FAKE_AGENT_LOG\"\nexit 0\n" permissions <- getPermissions fakeClaude + -- Permissions comes from `directory` and has no Generic instance, so it + -- has no #executable label. Record update syntax is the only option. setPermissions fakeClaude (permissions {executable = True}) inherited <- getEnvironment @@ -135,7 +242,7 @@ case manifestFromJSON beforeResume of Left err -> expectationFailure err >> fail "unreachable" Right decoded -> pure decoded - map (\receipt -> (receipt.fromVersion, receipt.toVersion)) manifest.blueprintMigrations + map (\receipt -> (receipt ^. #fromVersion, receipt ^. #toVersion)) (manifest ^. #blueprintMigrations) `shouldBe` [("1.0.0", "2.0.0"), ("2.5.0", "3.0.0")] (resumeExit, resumeOutput, resumeError) <- runProcessText binary args (Just root) (Just environment) @@ -146,11 +253,6 @@ T.lines <$> TIO.readFile launchLog `shouldReturn` ["called", "called"] LBS.readFile manifestPath `shouldReturn` beforeResume -seihouBinary :: IO FilePath -seihouBinary = do - testBinary <- getExecutablePath - pure (takeDirectory (takeDirectory testBinary) "seihou" "seihou") - runProcessText :: FilePath -> [String] -> @@ -162,6 +264,111 @@ (exitCode, stdoutText, stderrText) <- readCreateProcessWithExitCode command "" pure (exitCode, T.pack stdoutText, T.pack stderrText) +-- | Fail with the captured streams when a run that was expected to succeed +-- did not. +expectSuccess :: String -> ExitCode -> T.Text -> T.Text -> Expectation +expectSuccess label exitCode output errorOutput = case exitCode of + ExitSuccess -> pure () + ExitFailure code -> + expectationFailure $ + label + <> " exited " + <> show code + <> "\nstdout:\n" + <> T.unpack output + <> "\nstderr:\n" + <> T.unpack errorOutput + +-- | Stand up a scratch project holding a blueprint that declares a model and +-- an effort, with a fake @claude@ first on @PATH@ that records its argv, an +-- empty @XDG_CONFIG_HOME@ so no real user config leaks in, and every +-- @SEIHOU_AGENT_*@ variable scrubbed from the inherited environment. Nothing +-- outside the blueprint supplies a model or effort, so whatever reaches the +-- recorded argv came from the declaration. +-- +-- The callback receives the project root, the blueprint's name, and a runner +-- that takes extra @seihou agent run@ arguments and returns the exit code, the +-- two output streams, and the recorded argv lines. +withDeclaredLaunchBlueprint :: + (FilePath -> T.Text -> ([String] -> IO (ExitCode, T.Text, T.Text, [T.Text])) -> IO a) -> + IO a +withDeclaredLaunchBlueprint action = + withSystemTempDirectory "seihou-agent-run-declared-launch" $ \root -> do + binary <- seihouBinary + let blueprintDir = root ".seihou" "modules" "declared-launch" + blueprintPath = blueprintDir "blueprint.dhall" + xdgHome = root "xdg" + fakeBin = root "bin" + fakeClaude = fakeBin "claude" + launchLog = root "agent-launch.args" + createDirectoryIfMissing True blueprintDir + createDirectoryIfMissing True xdgHome + createDirectoryIfMissing True fakeBin + TIO.writeFile blueprintPath declaredLaunchBlueprintDhall + -- The batch path parses the JSON line, so the fake must keep printing it. + TIO.writeFile + fakeClaude + "#!/bin/sh\nprintf '%s\\n' \"$@\" > \"$SEIHOU_FAKE_AGENT_LOG\"\nprintf '%s\\n' '{\"result\":\"declared complete\",\"is_error\":false,\"session_id\":\"fake\"}'\n" + permissions <- getPermissions fakeClaude + -- Permissions comes from `directory` and has no Generic instance, so it + -- has no #executable label. Record update syntax is the only option. + setPermissions fakeClaude (permissions {executable = True}) + + inherited <- getEnvironment + let inheritedPath = fromMaybe "" (lookup "PATH" inherited) + overriddenNames = + [ "PATH", + "XDG_CONFIG_HOME", + "SEIHOU_AGENT_PROVIDER", + "SEIHOU_AGENT_MODEL", + "SEIHOU_AGENT_EFFORT", + "SEIHOU_CONTEXT", + "SEIHOU_FAKE_AGENT_LOG" + ] + environment = + ("PATH", fakeBin <> [searchPathSeparator] <> inheritedPath) + : ("XDG_CONFIG_HOME", xdgHome) + : ("SEIHOU_FAKE_AGENT_LOG", launchLog) + : filter (\(key, _) -> key `notElem` overriddenNames) inherited + runDeclared extraArgs = do + (exitCode, output, errorOutput) <- + runProcessText + binary + (["agent", "run", "declared-launch"] <> extraArgs) + (Just root) + (Just environment) + launchArgs <- + doesFileExist launchLog >>= \case + True -> T.lines <$> TIO.readFile launchLog + False -> pure [] + pure (exitCode, output, errorOutput, launchArgs) + action root "declared-launch" runDeclared + +-- | A blueprint that declares a model and a reasoning effort but no provider, +-- so the provider still comes from the built-in default. +declaredLaunchBlueprintDhall :: T.Text +declaredLaunchBlueprintDhall = + T.unlines + [ "{ name = \"declared-launch\"", + ", version = Some \"1.0.0\"", + ", description = Some \"Blueprint declaring its own launch settings\"", + ", prompt = \"Think hard about this repository.\"", + ", vars = [] : List { name : Text, type : Text, default : Optional Text, description : Optional Text, required : Bool, validation : Optional Text }", + ", prompts = [] : List { var : Text, text : Text, when : Optional Text, choices : Optional (List Text) }", + ", baseModules = [] : List { module : Text, vars : List { name : Text, value : Text } }", + ", files = [] : List { src : Text, description : Optional Text }", + ", allowedTools = None (List Text)", + ", tags = [] : List Text", + ", migrations = [] : List { from : Text, to : Text, prompt : Text }", + ", launch = Some", + " { provider = None Text", + " , model = Some \"claude-sonnet-5\"", + " , effort = Some \"max\"", + " , mode = None Text", + " }", + "}" + ] + migrationBlueprintDhall :: T.Text migrationBlueprintDhall = T.unlines @@ -187,5 +394,22 @@ " [ { from = \"2.5.0\", to = \"3.0.0\", prompt = \"Finish the baikai upgrade.\" }", " , { from = \"1.0.0\", to = \"2.0.0\", prompt = \"Replace {{library.name}} legacy calls.\" }", " ]", + "}" + ] + +batchBlueprintDhall :: T.Text +batchBlueprintDhall = + T.unlines + [ "{ name = \"batch-blueprint\"", + ", version = Some \"1.0.0\"", + ", description = Some \"Batch blueprint fixture\"", + ", prompt = \"Use the mounted reference and update the workspace.\"", + ", vars = [] : List { name : Text, type : Text, default : Optional Text, description : Optional Text, required : Bool, validation : Optional Text }", + ", prompts = [] : List { var : Text, text : Text, when : Optional Text, choices : Optional (List Text) }", + ", baseModules = [] : List { module : Text, vars : List { name : Text, value : Text } }", + ", files = [ { src = \"reference.md\", description = Some \"Batch reference\" } ]", + ", allowedTools = Some [ \"Read\", \"Write\" ]", + ", tags = [ \"test\" ]", + ", migrations = [] : List { from : Text, to : Text, prompt : Text }", "}" ] diff --git a/test/Seihou/CLI/AgentTraceE2ESpec.hs b/test/Seihou/CLI/AgentTraceE2ESpec.hs new file mode 100644 --- /dev/null +++ b/test/Seihou/CLI/AgentTraceE2ESpec.hs @@ -0,0 +1,215 @@ +-- | End-to-end proof that call tracing reaches a JSONL file when it is turned +-- on, and touches nothing at all when it is not. +-- +-- These run the real @seihou@ binary against a fake @claude@ first on @PATH@, +-- with an empty @XDG_CONFIG_HOME@ and every @SEIHOU_AGENT_*@ variable scrubbed +-- from the inherited environment, so nothing outside the test configures +-- tracing. The unit specs cover sink construction and the completion path; +-- this covers the wiring between them, which is the part a stale binary or a +-- missed call site would silently break. +module Seihou.CLI.AgentTraceE2ESpec (tests) where + +import Data.Aeson qualified as Aeson +import Data.Aeson.Key qualified as Key +import Data.Aeson.KeyMap qualified as KeyMap +import Data.ByteString.Lazy.Char8 qualified as BL8 +import Data.Maybe (fromMaybe) +import Data.Text qualified as T +import Data.Text.IO qualified as TIO +import Seihou.CLI.SeihouBinary (seihouBinary) +import System.Directory + ( createDirectoryIfMissing, + doesFileExist, + executable, + getPermissions, + setPermissions, + ) +import System.Environment (getEnvironment) +import System.Exit (ExitCode (..)) +import System.FilePath (searchPathSeparator, ()) +import System.IO.Temp (withSystemTempDirectory) +import System.Process (CreateProcess (..), proc, readCreateProcessWithExitCode) +import Test.Hspec +import Test.Tasty (TestTree) +import Test.Tasty.Hspec (testSpec) + +tests :: IO TestTree +tests = testSpec "Agent call tracing end-to-end" $ do + -- The guarantee that tracing is genuinely off by default: no file, anywhere. + it "creates no trace file when tracing is not configured" $ + withTraceProject $ \root run -> do + (exitCode, output, errorOutput, _) <- run [] [] + expectSuccess "untraced run" exitCode output errorOutput + output `shouldSatisfy` T.isInfixOf "traced complete" + doesFileExist (root ".seihou" "trace.jsonl") `shouldReturn` False + + it "writes a correlated start/finish pair when SEIHOU_AGENT_TRACE=file" $ + withTraceProject $ \root run -> do + let tracePath = root "trace.jsonl" + (exitCode, output, errorOutput, _) <- + run [("SEIHOU_AGENT_TRACE", "file"), ("SEIHOU_AGENT_TRACE_PATH_FIXTURE", tracePath)] [] + expectSuccess "traced run" exitCode output errorOutput + events <- traceEvents tracePath + map fst events `shouldBe` ["call_started", "call_finished"] + case map snd events of + [started, finished] -> started `shouldBe` finished + other -> expectationFailure ("expected two events, got " <> show (length other)) + + it "lets --trace off override a configured file trace" $ + withTraceProject $ \root run -> do + let tracePath = root "trace.jsonl" + (exitCode, output, errorOutput, _) <- + run + [("SEIHOU_AGENT_TRACE", "file"), ("SEIHOU_AGENT_TRACE_PATH_FIXTURE", tracePath)] + ["--trace", "off"] + expectSuccess "flag-disabled run" exitCode output errorOutput + doesFileExist tracePath `shouldReturn` False + + -- Trace lines must never land in stdout, which callers pipe. + it "sends --trace stderr to stderr, leaving stdout clean" $ + withTraceProject $ \_ run -> do + (exitCode, output, errorOutput, _) <- run [] ["--trace", "stderr"] + expectSuccess "stderr-traced run" exitCode output errorOutput + errorOutput `shouldSatisfy` T.isInfixOf "START" + output `shouldNotSatisfy` T.isInfixOf "START" + output `shouldSatisfy` T.isInfixOf "traced complete" + + it "rejects an unknown trace setting, naming the accepted ones" $ + withTraceProject $ \_ run -> do + (exitCode, output, errorOutput, _) <- run [] ["--trace", "syslog"] + exitCode `shouldBe` ExitFailure 1 + (output <> errorOutput) `shouldSatisfy` T.isInfixOf "Unknown trace setting 'syslog'" + (output <> errorOutput) `shouldSatisfy` T.isInfixOf "off, file, stdout, stderr" + +-- | Stand up a scratch project with a trivial blueprint and a fake @claude@ +-- that prints the batch JSON line the CLI provider expects. +-- +-- The callback receives the project root and a runner taking extra environment +-- entries and extra @seihou agent run@ arguments. When the environment carries +-- @SEIHOU_AGENT_TRACE_PATH_FIXTURE@, that path is written into the project's +-- local config as @agent.tracePath@ before the run, since the path has no flag +-- or environment variable of its own by design. +withTraceProject :: + (FilePath -> ([(String, String)] -> [String] -> IO (ExitCode, T.Text, T.Text, [T.Text])) -> IO a) -> + IO a +withTraceProject action = + withSystemTempDirectory "seihou-agent-trace" $ \root -> do + binary <- seihouBinary + let blueprintDir = root ".seihou" "modules" "tracer" + blueprintPath = blueprintDir "blueprint.dhall" + configPath = root ".seihou" "config.dhall" + xdgHome = root "xdg" + fakeBin = root "bin" + fakeClaude = fakeBin "claude" + launchLog = root "agent-launch.args" + createDirectoryIfMissing True blueprintDir + createDirectoryIfMissing True xdgHome + createDirectoryIfMissing True fakeBin + TIO.writeFile blueprintPath tracerBlueprintDhall + TIO.writeFile + fakeClaude + "#!/bin/sh\nprintf '%s\\n' \"$@\" > \"$SEIHOU_FAKE_AGENT_LOG\"\nprintf '%s\\n' '{\"result\":\"traced complete\",\"is_error\":false,\"session_id\":\"fake\"}'\n" + permissions <- getPermissions fakeClaude + -- Permissions comes from `directory` and has no Generic instance, so it + -- has no #executable label. Record update syntax is the only option. + setPermissions fakeClaude (permissions {executable = True}) + + inherited <- getEnvironment + let inheritedPath = fromMaybe "" (lookup "PATH" inherited) + overriddenNames = + [ "PATH", + "XDG_CONFIG_HOME", + "SEIHOU_AGENT_PROVIDER", + "SEIHOU_AGENT_MODEL", + "SEIHOU_AGENT_EFFORT", + "SEIHOU_AGENT_TRACE", + "SEIHOU_CONTEXT", + "SEIHOU_FAKE_AGENT_LOG" + ] + baseEnvironment = + ("PATH", fakeBin <> [searchPathSeparator] <> inheritedPath) + : ("XDG_CONFIG_HOME", xdgHome) + : ("SEIHOU_FAKE_AGENT_LOG", launchLog) + : filter (\(key, _) -> key `notElem` overriddenNames) inherited + run extraEnv extraArgs = do + case lookup "SEIHOU_AGENT_TRACE_PATH_FIXTURE" extraEnv of + Nothing -> pure () + Just tracePath -> + TIO.writeFile configPath (localConfigDhall (T.pack tracePath)) + (exitCode, output, errorOutput) <- + runProcessText + binary + (["agent", "run", "tracer", "--batch"] <> extraArgs) + (Just root) + (Just (extraEnv <> baseEnvironment)) + launchArgs <- + doesFileExist launchLog >>= \case + True -> T.lines <$> TIO.readFile launchLog + False -> pure [] + pure (exitCode, output, errorOutput, launchArgs) + action root run + +runProcessText :: + FilePath -> + [String] -> + Maybe FilePath -> + Maybe [(String, String)] -> + IO (ExitCode, T.Text, T.Text) +runProcessText binary args workingDirectory environment = do + let command = (proc binary args) {cwd = workingDirectory, env = environment} + (exitCode, stdoutText, stderrText) <- readCreateProcessWithExitCode command "" + pure (exitCode, T.pack stdoutText, T.pack stderrText) + +expectSuccess :: String -> ExitCode -> T.Text -> T.Text -> Expectation +expectSuccess label exitCode output errorOutput = case exitCode of + ExitSuccess -> pure () + ExitFailure code -> + expectationFailure $ + label + <> " exited " + <> show code + <> "\nstdout:\n" + <> T.unpack output + <> "\nstderr:\n" + <> T.unpack errorOutput + +-- | The @(kind, eventId)@ of every event in a JSONL trace file, in order. +-- +-- Deliberately not asserting on token counts or cost: @claude-cli@ is +-- subscription-based and reports neither, so those fields are legitimately +-- absent from this fixture's @call_finished@ event. +traceEvents :: FilePath -> IO [(String, String)] +traceEvents path = do + contents <- BL8.readFile path + pure + [ (T.unpack kind, T.unpack eventId) + | line <- BL8.lines contents, + not (BL8.null line), + Just (Aeson.Object o) <- [Aeson.decode line], + Just (Aeson.String kind) <- [KeyMap.lookup (Key.fromString "kind") o], + Just (Aeson.String eventId) <- [KeyMap.lookup (Key.fromString "eventId") o] + ] + +-- | A project-local @.seihou/config.dhall@: a plain Dhall record of text +-- values with backtick-escaped dotted keys, which is the shape +-- 'Seihou.Dhall.Config.evalConfigFile' expects. +localConfigDhall :: T.Text -> T.Text +localConfigDhall tracePath = + "{ `agent.tracePath` = \"" <> tracePath <> "\" }\n" + +tracerBlueprintDhall :: T.Text +tracerBlueprintDhall = + T.unlines + [ "{ name = \"tracer\"", + ", version = Some \"1.0.0\"", + ", description = Some \"Blueprint fixture for call tracing\"", + ", prompt = \"Say hello.\"", + ", vars = [] : List { name : Text, type : Text, default : Optional Text, description : Optional Text, required : Bool, validation : Optional Text }", + ", prompts = [] : List { var : Text, text : Text, when : Optional Text, choices : Optional (List Text) }", + ", baseModules = [] : List { module : Text, vars : List { name : Text, value : Text } }", + ", files = [] : List { src : Text, description : Optional Text }", + ", allowedTools = None (List Text)", + ", tags = [] : List Text", + ", migrations = [] : List { from : Text, to : Text, prompt : Text }", + "}" + ] diff --git a/test/Seihou/CLI/AgentTraceSpec.hs b/test/Seihou/CLI/AgentTraceSpec.hs new file mode 100644 --- /dev/null +++ b/test/Seihou/CLI/AgentTraceSpec.hs @@ -0,0 +1,170 @@ +module Seihou.CLI.AgentTraceSpec (tests) where + +import Baikai.Trace.Event (TraceEvent (..)) +import Baikai.Trace.Sink (TraceSink (..)) +import Data.Aeson qualified as Aeson +import Data.Aeson.Key qualified as Key +import Data.Aeson.KeyMap qualified as KeyMap +import Data.ByteString.Lazy.Char8 qualified as BL8 +import Data.Text qualified as Text +import Data.Time (UTCTime (..), fromGregorian, secondsToDiffTime) +import Seihou.CLI.AgentCompletion (TraceSetting (..)) +import Seihou.CLI.AgentTrace + ( defaultTraceFileName, + resolveTraceFilePath, + traceSinkFor, + ) +import Streamly.Data.Stream qualified as Stream +import System.Directory (doesDirectoryExist, doesFileExist) +import System.FilePath (()) +import System.IO.Temp (withSystemTempDirectory) +import Test.Hspec +import Test.Tasty (TestTree) +import Test.Tasty.Hspec (testSpec) + +tests :: IO TestTree +tests = testSpec "Seihou.CLI.AgentTrace" spec + +spec :: Spec +spec = do + describe "resolveTraceFilePath" $ do + it "falls back to the project-local default when nothing is configured" $ + resolveTraceFilePath Nothing `shouldBe` defaultTraceFileName + + it "puts the default inside .seihou/" $ + defaultTraceFileName `shouldBe` ".seihou" "trace.jsonl" + + it "uses an explicitly configured path" $ + resolveTraceFilePath (Just "/tmp/seihou-trace.jsonl") `shouldBe` "/tmp/seihou-trace.jsonl" + + -- Blank counts as absent everywhere else in the resolver; a blank + -- agent.tracePath must not send the sink to "". + it "treats a blank configured path as absent" $ do + resolveTraceFilePath (Just "") `shouldBe` defaultTraceFileName + resolveTraceFilePath (Just " ") `shouldBe` defaultTraceFileName + + describe "traceSinkFor" $ do + it "writes nothing anywhere when tracing is off" $ + withSystemTempDirectory "seihou-trace-off" $ \root -> do + sink <- traceSinkFor TraceOff (Just (root "nested" "trace.jsonl")) + feed sink [startEvent] + doesDirectoryExist (root "nested") `shouldReturn` False + + it "creates the trace file's parent directory" $ + withSystemTempDirectory "seihou-trace-mkdir" $ \root -> do + let path = root "deeply" "nested" "trace.jsonl" + _ <- traceSinkFor TraceFile (Just path) + doesDirectoryExist (root "deeply" "nested") `shouldReturn` True + + it "appends one parseable JSON object per event" $ + withSystemTempDirectory "seihou-trace-file" $ \root -> do + let path = root "trace.jsonl" + sink <- traceSinkFor TraceFile (Just path) + feed sink [startEvent, finishEvent] + contents <- BL8.readFile path + let ls = filter (not . BL8.null) (BL8.lines contents) + length ls `shouldBe` 2 + traverse (Aeson.decode @Aeson.Value) ls `shouldSatisfy` \case + Just _ -> True + Nothing -> False + + it "tags each line with the event kind that jq filters on" $ + withSystemTempDirectory "seihou-trace-kind" $ \root -> do + let path = root "trace.jsonl" + sink <- traceSinkFor TraceFile (Just path) + feed sink [startEvent, finishEvent] + kinds <- traceKinds path + kinds `shouldBe` ["call_started", "call_finished"] + + it "correlates a start and its finish by eventId" $ + withSystemTempDirectory "seihou-trace-corr" $ \root -> do + let path = root "trace.jsonl" + sink <- traceSinkFor TraceFile (Just path) + feed sink [startEvent, finishEvent] + ids <- traceField "eventId" path + ids `shouldBe` ["call-1", "call-1"] + + it "records a failure as call_failed" $ + withSystemTempDirectory "seihou-trace-fail" $ \root -> do + let path = root "trace.jsonl" + sink <- traceSinkFor TraceFile (Just path) + feed sink [startEvent, failEvent] + traceKinds path `shouldReturn` ["call_started", "call_failed"] + + -- The file sink appends rather than truncating, so a second traced run in + -- the same project accumulates history instead of destroying it. + it "appends across separately constructed sinks" $ + withSystemTempDirectory "seihou-trace-append" $ \root -> do + let path = root "trace.jsonl" + first <- traceSinkFor TraceFile (Just path) + feed first [startEvent, finishEvent] + second <- traceSinkFor TraceFile (Just path) + feed second [startEvent, finishEvent] + kinds <- traceKinds path + length kinds `shouldBe` 4 + + it "creates no file for the stream settings" $ + withSystemTempDirectory "seihou-trace-stream" $ \root -> do + let path = root "trace.jsonl" + stderrOnly <- traceSinkFor TraceStderr (Just path) + _ <- pure stderrOnly + doesFileExist path `shouldReturn` False + +-- | Drive a sink's fold over a list of events, the way Baikai's trace bridge +-- drives it over the per-call event channel. +feed :: TraceSink -> [TraceEvent] -> IO () +feed (TraceSink f) events = Stream.fold f (Stream.fromList events) + +-- | The @kind@ tag of every line in a JSONL trace file, in order. +traceKinds :: FilePath -> IO [String] +traceKinds = traceField "kind" + +-- | One top-level string field from every line of a JSONL trace file. +traceField :: String -> FilePath -> IO [String] +traceField field path = do + contents <- BL8.readFile path + pure + [ Text.unpack value + | line <- BL8.lines contents, + not (BL8.null line), + Just (Aeson.Object o) <- [Aeson.decode line], + Just (Aeson.String value) <- [KeyMap.lookup (Key.fromString field) o] + ] + +at :: UTCTime +at = UTCTime (fromGregorian 2026 7 27) (secondsToDiffTime 0) + +startEvent :: TraceEvent +startEvent = + CallStarted + { eventId = "call-1", + timestamp = at, + provider = "anthropic", + model = "claude-sonnet-4-6", + maxTokens = 8192, + promptSummary = "add a health check module" + } + +finishEvent :: TraceEvent +finishEvent = + CallFinished + { eventId = "call-1", + timestamp = at, + provider = "anthropic", + model = "claude-sonnet-4-6", + latencyMs = 7913, + inputTokens = Just 4211, + outputTokens = Just 880, + usd = Just 0.0264 + } + +failEvent :: TraceEvent +failEvent = + CallFailed + { eventId = "call-1", + timestamp = at, + provider = "anthropic", + model = "claude-sonnet-4-6", + latencyMs = 120, + errorMessage = "invalid x-api-key" + } diff --git a/test/Seihou/CLI/AppliedBlueprintMigrationSpec.hs b/test/Seihou/CLI/AppliedBlueprintMigrationSpec.hs --- a/test/Seihou/CLI/AppliedBlueprintMigrationSpec.hs +++ b/test/Seihou/CLI/AppliedBlueprintMigrationSpec.hs @@ -1,6 +1,8 @@ module Seihou.CLI.AppliedBlueprintMigrationSpec (tests) where +import Control.Lens ((&), (.~), (^.)) import Data.ByteString.Lazy qualified as LBS +import Data.Generics.Labels () import Data.Text qualified as T import Data.Time (UTCTime, defaultTimeLocale, parseTimeOrError) import Seihou.CLI.AppliedBlueprintMigration (recordAppliedBlueprintMigration) @@ -50,8 +52,8 @@ result <- recordAppliedBlueprintMigration manifestPath receipt result `shouldBe` Right () manifest <- readManifestFile manifestPath - manifest.version `shouldBe` currentManifestVersion - manifest.blueprintMigrations `shouldBe` [receipt] + (manifest ^. #version) `shouldBe` currentManifestVersion + (manifest ^. #blueprintMigrations) `shouldBe` [receipt] it "upserts the same exact edge and retains unrelated edges" $ withSystemTempDirectory "seihou-blueprint-migration" $ \dir -> do @@ -59,14 +61,14 @@ first = mkReceipt "payments" "1.0.0" "2.0.0" fixedTime second = mkReceipt "payments" "2.5.0" "3.0.0" fixedTime replacement = - (mkReceipt "payments" "1.0.0" "2.0.0" fixedTime2) - { blueprintVersion = Just "0.5.0" - } + ( (mkReceipt "payments" "1.0.0" "2.0.0" fixedTime2) + & #blueprintVersion .~ Just "0.5.0" + ) recordAppliedBlueprintMigration manifestPath first `shouldReturn` Right () recordAppliedBlueprintMigration manifestPath second `shouldReturn` Right () recordAppliedBlueprintMigration manifestPath replacement `shouldReturn` Right () manifest <- readManifestFile manifestPath - manifest.blueprintMigrations `shouldBe` [replacement, second] + (manifest ^. #blueprintMigrations) `shouldBe` [replacement, second] it "returns Left and preserves a corrupt existing manifest" $ withSystemTempDirectory "seihou-blueprint-migration" $ \dir -> do diff --git a/test/Seihou/CLI/AppliedBlueprintSpec.hs b/test/Seihou/CLI/AppliedBlueprintSpec.hs --- a/test/Seihou/CLI/AppliedBlueprintSpec.hs +++ b/test/Seihou/CLI/AppliedBlueprintSpec.hs @@ -1,6 +1,8 @@ module Seihou.CLI.AppliedBlueprintSpec (tests) where +import Control.Lens ((&), (.~), (^.)) import Data.ByteString.Lazy qualified as LBS +import Data.Generics.Labels () import Data.Map.Strict qualified as Map import Data.Text (Text) import Data.Text qualified as T @@ -60,8 +62,8 @@ res <- recordAppliedBlueprint manifestPath entry res `shouldBe` Right () m <- readManifestFile manifestPath - m.version `shouldBe` currentManifestVersion - m.blueprint `shouldBe` Just entry + (m ^. #version) `shouldBe` currentManifestVersion + (m ^. #blueprint) `shouldBe` Just entry it "preserves unrelated manifest fields" $ withSystemTempDirectory "seihou-ab" $ \dir -> do @@ -73,17 +75,17 @@ appliedAt = fixedTime } seed = - (emptyManifest fixedTime) - { recipe = Just seedRecipe, - vars = Map.empty - } + ( (emptyManifest fixedTime) + & #recipe .~ Just seedRecipe + & #vars .~ Map.empty + ) LBS.writeFile manifestPath (manifestToJSON seed) let entry = mkEntry "payments-service" Nothing [] True Nothing res <- recordAppliedBlueprint manifestPath entry res `shouldBe` Right () m <- readManifestFile manifestPath - m.recipe `shouldBe` Just seedRecipe - m.blueprint `shouldBe` Just entry + (m ^. #recipe) `shouldBe` Just seedRecipe + (m ^. #blueprint) `shouldBe` Just entry it "overwrites a prior blueprint entry" $ withSystemTempDirectory "seihou-ab" $ \dir -> do @@ -93,7 +95,7 @@ _ <- recordAppliedBlueprint manifestPath ab1 _ <- recordAppliedBlueprint manifestPath ab2 m <- readManifestFile manifestPath - m.blueprint `shouldBe` Just ab2 + (m ^. #blueprint) `shouldBe` Just ab2 it "returns Left when the existing manifest is unreadable" $ withSystemTempDirectory "seihou-ab" $ \dir -> do diff --git a/test/Seihou/CLI/BlueprintMigrationSpec.hs b/test/Seihou/CLI/BlueprintMigrationSpec.hs --- a/test/Seihou/CLI/BlueprintMigrationSpec.hs +++ b/test/Seihou/CLI/BlueprintMigrationSpec.hs @@ -1,5 +1,7 @@ module Seihou.CLI.BlueprintMigrationSpec (tests) where +import Control.Lens (to, (^.)) +import Data.Generics.Labels () import Data.IORef import Data.Map.Strict qualified as Map import Data.Text (Text) @@ -73,7 +75,7 @@ it "delimits debug prompts in pending order without any execution callback" $ do let output = formatBlueprintMigrationDebugOutput - (\position total edge -> "prompt " <> tshow position <> "/" <> tshow total <> " " <> edge.from) + (\position total edge -> "prompt " <> tshow position <> "/" <> tshow total <> " " <> edge ^. #from) [first, second] output `shouldSatisfy` T.isInfixOf "===== [1/2] 1.0.0 -> 2.0.0 =====" output `shouldSatisfy` T.isInfixOf "===== [2/2] 2.0.0 -> 3.0.0 =====" @@ -93,10 +95,10 @@ it "launches and records every edge sequentially" $ do calls <- newIORef ([] :: [Text]) let launch position total edge = do - modifyIORef' calls (<> ["launch " <> tshow position <> "/" <> tshow total <> " " <> edge.from]) + modifyIORef' calls (<> ["launch " <> tshow position <> "/" <> tshow total <> " " <> edge ^. #from]) pure (Right ()) record edge = do - modifyIORef' calls (<> ["record " <> edge.from]) + modifyIORef' calls (<> ["record " <> edge ^. #from]) pure (Right ()) result <- runBlueprintMigrationsWith launch record [first, second] result `shouldBe` BlueprintMigrationComplete [first, second] @@ -113,20 +115,20 @@ let third = migration "3.0.0" "4.0.0" migrationPlan = BlueprintMigrationPlan - { blueprintPlanName = "payments", - blueprintPlanFrom = version "1.0.0", - blueprintPlanTo = version "4.0.0", - blueprintPlanSteps = [first, second, third] + { name = "payments", + from = version "1.0.0", + to = version "4.0.0", + steps = [first, second, third] } launch _ _ edge = do - modifyIORef' calls (<> ["launch " <> edge.from]) + modifyIORef' calls (<> ["launch " <> edge ^. #from]) pure $ if edge == second then Left (BlueprintMigrationProcessFailure (ExitFailure 17)) else Right () record edge = do - modifyIORef' calls (<> ["record " <> edge.from]) - modifyIORef' recorded (<> [receipt blueprintName edge.from edge.to]) + modifyIORef' calls (<> ["record " <> edge ^. #from]) + modifyIORef' recorded (<> [receipt blueprintName (edge ^. #from) (edge ^. #to)]) pure (Right ()) result <- runBlueprintMigrationsWith launch record [first, second, third] result @@ -140,16 +142,16 @@ resumedResult <- runBlueprintMigrationsWith - (\_ _ edge -> modifyIORef' calls (<> ["resume " <> edge.from]) >> pure (Right ())) + (\_ _ edge -> modifyIORef' calls (<> ["resume " <> edge ^. #from]) >> pure (Right ())) record resumed resumedResult `shouldBe` BlueprintMigrationComplete [second, third] - readIORef recorded `shouldReturn` map (\edge -> receipt blueprintName edge.from edge.to) [first, second, third] + readIORef recorded `shouldReturn` map (\edge -> receipt blueprintName (edge ^. #from) (edge ^. #to)) [first, second, third] it "stops before the next launch when receipt recording fails" $ do calls <- newIORef ([] :: [Text]) - let launch _ _ edge = modifyIORef' calls (<> ["launch " <> edge.from]) >> pure (Right ()) - record edge = modifyIORef' calls (<> ["record " <> edge.from]) >> pure (Left "disk full") + let launch _ _ edge = modifyIORef' calls (<> ["launch " <> edge ^. #from]) >> pure (Right ()) + record edge = modifyIORef' calls (<> ["record " <> edge ^. #from]) >> pure (Left "disk full") result <- runBlueprintMigrationsWith launch record [first, second] result `shouldBe` BlueprintMigrationRecordFailed first "disk full" readIORef calls `shouldReturn` ["launch 1.0.0", "record 1.0.0"] @@ -178,10 +180,10 @@ plan :: [BlueprintMigration] -> BlueprintMigrationPlan plan steps = BlueprintMigrationPlan - { blueprintPlanName = "payments", - blueprintPlanFrom = version "1.0.0", - blueprintPlanTo = version "3.0.0", - blueprintPlanSteps = steps + { name = "payments", + from = version "1.0.0", + to = version "3.0.0", + steps = steps } receipt :: ModuleName -> Text -> Text -> AppliedBlueprintMigration @@ -234,15 +236,16 @@ files = [], allowedTools = Nothing, tags = [], - migrations = [first, second] + migrations = [first, second], + launch = Nothing } in PreparedBlueprintExecution - { preparedBlueprint = blueprint, - preparedBlueprintDir = "/tmp/payments", - preparedResolvedVariables = resolved, - preparedMountedFilesDir = Just "/tmp/payments/files", - preparedReferenceFiles = " - guide.md", - preparedReferenceFilesAccess = "mounted at /tmp/payments/files", - preparedSharedPrompt = "Shared guidance for baikai.", - preparedAllowedTools = ["Read"] + { blueprint = blueprint, + blueprintDir = "/tmp/payments", + resolvedVariables = resolved, + mountedFilesDir = Just "/tmp/payments/files", + referenceFiles = " - guide.md", + referenceFilesAccess = "mounted at /tmp/payments/files", + sharedPrompt = "Shared guidance for baikai.", + allowedTools = ["Read"] } diff --git a/test/Seihou/CLI/CommandExecutionSpec.hs b/test/Seihou/CLI/CommandExecutionSpec.hs --- a/test/Seihou/CLI/CommandExecutionSpec.hs +++ b/test/Seihou/CLI/CommandExecutionSpec.hs @@ -1,5 +1,6 @@ module Seihou.CLI.CommandExecutionSpec (tests) where +import Data.Generics.Labels () import Data.Map.Strict qualified as Map import Data.Maybe (fromJust) import Data.Time (UTCTime, defaultTimeLocale, parseTimeOrError) @@ -44,9 +45,9 @@ successMock :: Text -> ProcessMock successMock command = ProcessMock - { mockCommand = "sh", - mockArgs = ["-c", command], - mockResult = (ExitSuccess, "output", "") + { command = "sh", + args = ["-c", command], + result = (ExitSuccess, "output", "") } spec :: Spec @@ -56,15 +57,15 @@ let first = commandOp "echo first" Nothing "app" 0 second = commandOp "echo second" Nothing "app" 0 plan = planCommands RunAllCommands Map.empty [first, WriteFileOp "file" "content" Template, second] - map (.operation) plan.commands `shouldBe` [first, second] - map (.disposition) plan.commands `shouldBe` [CommandWillRun, CommandWillRun] + map (^. #operation) (plan ^. #commands) `shouldBe` [first, second] + map (^. #disposition) (plan ^. #commands) `shouldBe` [CommandWillRun, CommandWillRun] it "skips only fingerprints with successful prior receipts in changed-only mode" $ do let unchanged = commandOp "echo same" Nothing "app" 0 changed = commandOp "echo changed" Nothing "app" 0 prior = Map.singleton (fingerprintOf unchanged) (receiptFor fixedTime unchanged) plan = planCommands RunChangedCommands prior [unchanged, changed] - map (.disposition) plan.commands + map (^. #disposition) (plan ^. #commands) `shouldBe` [CommandSkippedUnchanged, CommandWillRun] summarizeCommandPlan plan `shouldBe` CommandPlanSummary {willRun = 1, skippedUnchanged = 1, skippedDisabled = 0} @@ -74,13 +75,13 @@ second = commandOp "echo same" Nothing "app" 1 prior = Map.singleton (fingerprintOf first) (receiptFor fixedTime first) plan = planCommands RunChangedCommands prior [first, second] - map (.disposition) plan.commands + map (^. #disposition) (plan ^. #commands) `shouldBe` [CommandSkippedUnchanged, CommandWillRun] it "marks every command disabled without minting receipts" $ do let operations = [commandOp "echo one" Nothing "app" 0, commandOp "echo two" Nothing "app" 0] plan = planCommands DisableCommands Map.empty operations - map (.disposition) plan.commands + map (^. #disposition) (plan ^. #commands) `shouldBe` [CommandSkippedDisabled, CommandSkippedDisabled] describe "executeCommandPlan" $ do @@ -94,14 +95,14 @@ executeCommandPlan laterTime plan case result of Right receipts -> do - map (.fingerprint) receipts `shouldBe` map fingerprintOf [first, second] - map (.completedAt) receipts `shouldBe` [laterTime, laterTime] + map (^. #fingerprint) receipts `shouldBe` map fingerprintOf [first, second] + map (^. #completedAt) receipts `shouldBe` [laterTime, laterTime] Left err -> expectationFailure ("Expected success, got: " <> show err) it "does not execute skipped commands" $ do let operation = commandOp "echo skipped" Nothing "app" 0 priorReceipt = receiptFor fixedTime operation - prior = Map.singleton priorReceipt.fingerprint priorReceipt + prior = Map.singleton (priorReceipt ^. #fingerprint) priorReceipt plan = planCommands RunChangedCommands prior [operation] result = runPureEff $ runProcessPure [] $ executeCommandPlan laterTime plan result `shouldBe` Right [] @@ -112,19 +113,19 @@ plan = planCommands RunAllCommands Map.empty [failing, neverReached] mocks = [ ProcessMock - { mockCommand = "sh", - mockArgs = ["-c", "exit 7"], - mockResult = (ExitFailure 7, "partial", "boom") + { command = "sh", + args = ["-c", "exit 7"], + result = (ExitFailure 7, "partial", "boom") }, successMock "echo later" ] result = runPureEff $ runProcessPure mocks $ executeCommandPlan laterTime plan case result of Left err -> do - err.exitCode `shouldBe` 7 - err.stdout `shouldBe` "partial" - err.stderr `shouldBe` "boom" - err.command.operation `shouldBe` failing + (err ^. #exitCode) `shouldBe` 7 + (err ^. #stdout) `shouldBe` "partial" + (err ^. #stderr) `shouldBe` "boom" + (err ^. #command . #operation) `shouldBe` failing Right receipts -> expectationFailure ("Expected failure, got receipts: " <> show receipts) describe "finalizeCommandReceipts" $ do @@ -137,22 +138,22 @@ newChanged = receiptFor laterTime changed prior = Map.fromList - [ (oldUnchanged.fingerprint, oldUnchanged), - (oldRemoved.fingerprint, oldRemoved) + [ (oldUnchanged ^. #fingerprint, oldUnchanged), + (oldRemoved ^. #fingerprint, oldRemoved) ] plan = planCommands RunChangedCommands prior [unchanged, changed] finalized = finalizeCommandReceipts plan [newChanged] prior finalized `shouldBe` Map.fromList - [ (oldUnchanged.fingerprint, oldUnchanged), - (newChanged.fingerprint, newChanged) + [ (oldUnchanged ^. #fingerprint, oldUnchanged), + (newChanged ^. #fingerprint, newChanged) ] it "retains only matching old receipts when commands are disabled" $ do let old = commandOp "echo old" Nothing "app" 0 new = commandOp "echo new" Nothing "app" 0 oldReceipt = receiptFor fixedTime old - prior = Map.singleton oldReceipt.fingerprint oldReceipt + prior = Map.singleton (oldReceipt ^. #fingerprint) oldReceipt plan = planCommands DisableCommands prior [old, new] finalizeCommandReceipts plan [] prior - `shouldBe` Map.singleton oldReceipt.fingerprint oldReceipt + `shouldBe` Map.singleton (oldReceipt ^. #fingerprint) oldReceipt diff --git a/test/Seihou/CLI/InstallHistorySpec.hs b/test/Seihou/CLI/InstallHistorySpec.hs --- a/test/Seihou/CLI/InstallHistorySpec.hs +++ b/test/Seihou/CLI/InstallHistorySpec.hs @@ -1,5 +1,7 @@ module Seihou.CLI.InstallHistorySpec (tests) where +import Control.Lens ((^.)) +import Data.Generics.Labels () import Data.Text qualified as T import Seihou.CLI.InstallHistory ( HistoryEntry (..), @@ -25,14 +27,14 @@ it "returns empty history when file does not exist" $ do withSystemTempDirectory "history-test" $ \tmp -> do h <- readHistoryFrom (tmp "nonexistent.json") - h.entries `shouldBe` [] + (h ^. #entries) `shouldBe` [] it "returns empty history for malformed JSON" $ do withSystemTempDirectory "history-test" $ \tmp -> do let path = tmp "bad.json" writeFile path "not json" h <- readHistoryFrom path - h.entries `shouldBe` [] + (h ^. #entries) `shouldBe` [] describe "writeHistoryTo / readHistoryFrom round-trip" $ do it "round-trips an empty history" $ do @@ -63,8 +65,8 @@ exists <- doesFileExist path exists `shouldBe` True h <- readHistoryFrom path - length h.entries `shouldBe` 1 - (head h.entries).url `shouldBe` "https://github.com/foo/bar.git" + length (h ^. #entries) `shouldBe` 1 + ((head (h ^. #entries)) ^. #url) `shouldBe` "https://github.com/foo/bar.git" it "deduplicates by URL, keeping most recent first" $ do withSystemTempDirectory "history-test" $ \tmp -> do @@ -73,8 +75,8 @@ recordUrlTo path "https://github.com/b/second.git" recordUrlTo path "https://github.com/a/first.git" h <- readHistoryFrom path - length h.entries `shouldBe` 2 - (head h.entries).url `shouldBe` "https://github.com/a/first.git" + length (h ^. #entries) `shouldBe` 2 + ((head (h ^. #entries)) ^. #url) `shouldBe` "https://github.com/a/first.git" it "caps history at maxHistoryEntries" $ do withSystemTempDirectory "history-test" $ \tmp -> do @@ -83,4 +85,4 @@ (\i -> recordUrlTo path ("https://example.com/repo-" <> T.pack (show i) <> ".git")) [1 .. maxHistoryEntries + 5 :: Int] h <- readHistoryFrom path - length h.entries `shouldBe` maxHistoryEntries + length (h ^. #entries) `shouldBe` maxHistoryEntries diff --git a/test/Seihou/CLI/ListSpec.hs b/test/Seihou/CLI/ListSpec.hs --- a/test/Seihou/CLI/ListSpec.hs +++ b/test/Seihou/CLI/ListSpec.hs @@ -1,5 +1,7 @@ module Seihou.CLI.ListSpec (tests) where +import Control.Lens ((^.)) +import Data.Generics.Labels () import Data.Map.Strict qualified as Map import Data.Text qualified as T import Seihou.CLI.List (Entry (..), ListFilter (..), applyFilters, formatListOutput, formatListOutputEntries, runnableToEntryWithOrigin) @@ -16,7 +18,7 @@ validModule :: String -> String -> ModuleSource -> DiscoveredModule validModule name desc src = DiscoveredModule - { discoveredResult = + { result = Right Module { name = ModuleName (T.pack name), @@ -31,17 +33,17 @@ removal = Nothing, migrations = [] }, - discoveredSource = src, - discoveredDir = "/fake/" ++ name + source = src, + dir = "/fake/" ++ name } -- | A broken discovered module for testing. brokenModule :: String -> ModuleSource -> DiscoveredModule brokenModule name src = DiscoveredModule - { discoveredResult = Left (DhallEvalError (ModuleName (T.pack name)) "parse error"), - discoveredSource = src, - discoveredDir = "/fake/" ++ name + { result = Left (DhallEvalError (ModuleName (T.pack name)) "parse error"), + source = src, + dir = "/fake/" ++ name } -- | Helper to build an Entry for filter tests. Defaults the kind to a module. @@ -52,13 +54,13 @@ mkEntryK :: RunnableKind -> T.Text -> Maybe T.Text -> [T.Text] -> Entry mkEntryK kind name repo tags = Entry - { entryName = name, - entryDesc = "desc", - entrySource = "installed", - entryIsError = False, - entryRepoName = repo, - entryTags = tags, - entryKind = kind + { name = name, + desc = "desc", + source = "installed", + isError = False, + repoName = repo, + tags = tags, + kind = kind } noFilter :: ListFilter @@ -125,19 +127,19 @@ let opts = ListFilter (Just "repo-x") Nothing [] result = applyFilters opts entries length result `shouldBe` 2 - map (.entryName) result `shouldBe` ["mod-a", "mod-b"] + map (^. #name) result `shouldBe` ["mod-a", "mod-b"] it "filters by tag" $ do let opts = ListFilter Nothing (Just "haskell") [] result = applyFilters opts entries length result `shouldBe` 2 - map (.entryName) result `shouldBe` ["mod-a", "mod-c"] + map (^. #name) result `shouldBe` ["mod-a", "mod-c"] it "combines repo and tag filters with AND" $ do let opts = ListFilter (Just "repo-x") (Just "haskell") [] result = applyFilters opts entries length result `shouldBe` 1 - map (.entryName) result `shouldBe` ["mod-a"] + map (^. #name) result `shouldBe` ["mod-a"] it "returns empty list when repo filter matches nothing" $ do let opts = ListFilter (Just "nonexistent") Nothing [] @@ -152,7 +154,7 @@ it "excludes modules without origin metadata when repo filter is active" $ do let opts = ListFilter (Just "repo-x") Nothing [] result = applyFilters opts entries - all (\e -> e.entryRepoName == Just "repo-x") result `shouldBe` True + all (\e -> e ^. #repoName == Just "repo-x") result `shouldBe` True describe "applyFilters (by kind)" $ do let mixed = @@ -163,35 +165,35 @@ mkEntryK KindModule "mod-b" (Just "repo-x") ["haskell"] ] - it "keeps all kinds when filterKinds is empty" $ do + it "keeps all kinds when kinds is empty" $ do length (applyFilters (ListFilter Nothing Nothing []) mixed) `shouldBe` 5 it "keeps only modules with --modules" $ do let result = applyFilters (ListFilter Nothing Nothing [KindModule]) mixed - map (.entryName) result `shouldBe` ["mod-a", "mod-b"] + map (^. #name) result `shouldBe` ["mod-a", "mod-b"] it "keeps only recipes with --recipes" $ do let result = applyFilters (ListFilter Nothing Nothing [KindRecipe]) mixed - map (.entryName) result `shouldBe` ["rec-a"] + map (^. #name) result `shouldBe` ["rec-a"] it "keeps only blueprints with --blueprints" $ do let result = applyFilters (ListFilter Nothing Nothing [KindBlueprint]) mixed - map (.entryName) result `shouldBe` ["bp-a"] + map (^. #name) result `shouldBe` ["bp-a"] it "keeps only prompts with --prompts" $ do let result = applyFilters (ListFilter Nothing Nothing [KindPrompt]) mixed - map (.entryName) result `shouldBe` ["prompt-a"] + map (^. #name) result `shouldBe` ["prompt-a"] it "unions kinds when several flags are given" $ do let result = applyFilters (ListFilter Nothing Nothing [KindModule, KindRecipe]) mixed - map (.entryName) result `shouldBe` ["mod-a", "rec-a", "mod-b"] + map (^. #name) result `shouldBe` ["mod-a", "rec-a", "mod-b"] it "combines kind and repo with AND" $ do let result = applyFilters (ListFilter (Just "repo-x") Nothing [KindModule]) mixed - map (.entryName) result `shouldBe` ["mod-b"] + map (^. #name) result `shouldBe` ["mod-b"] it "returns empty when kind matches nothing in the set" $ do - let onlyRecipes = filter (\e -> e.entryKind == KindRecipe) mixed + let onlyRecipes = filter (\e -> e ^. #kind == KindRecipe) mixed result = applyFilters (ListFilter Nothing Nothing [KindBlueprint]) onlyRecipes result `shouldBe` [] @@ -234,34 +236,34 @@ it "tags blueprint entries with [blueprint] in the source label" $ do let dr = DiscoveredRunnable - { drName = "demo", - drDescription = Just "A new seihou blueprint", - drKind = KindBlueprint, - drSource = SourceProject, - drDir = "/fake/demo", - drIsError = False, - drError = Nothing + { name = "demo", + description = Just "A new seihou blueprint", + kind = KindBlueprint, + source = SourceProject, + dir = "/fake/demo", + isError = False, + error = Nothing } entry = runnableToEntryWithOrigin Map.empty dr - entry.entrySource `shouldBe` "project [blueprint]" - entry.entryName `shouldBe` "demo" - entry.entryIsError `shouldBe` False - entry.entryKind `shouldBe` KindBlueprint + (entry ^. #source) `shouldBe` "project [blueprint]" + (entry ^. #name) `shouldBe` "demo" + (entry ^. #isError) `shouldBe` False + (entry ^. #kind) `shouldBe` KindBlueprint describe "runnableToEntryWithOrigin (prompt)" $ do it "tags prompt entries with [prompt] in the source label" $ do let dr = DiscoveredRunnable - { drName = "review", - drDescription = Just "Review current changes", - drKind = KindPrompt, - drSource = SourceProject, - drDir = "/fake/review", - drIsError = False, - drError = Nothing + { name = "review", + description = Just "Review current changes", + kind = KindPrompt, + source = SourceProject, + dir = "/fake/review", + isError = False, + error = Nothing } entry = runnableToEntryWithOrigin Map.empty dr - entry.entrySource `shouldBe` "project [prompt]" - entry.entryName `shouldBe` "review" - entry.entryIsError `shouldBe` False - entry.entryKind `shouldBe` KindPrompt + (entry ^. #source) `shouldBe` "project [prompt]" + (entry ^. #name) `shouldBe` "review" + (entry ^. #isError) `shouldBe` False + (entry ^. #kind) `shouldBe` KindPrompt diff --git a/test/Seihou/CLI/ManifestGuardSpec.hs b/test/Seihou/CLI/ManifestGuardSpec.hs new file mode 100644 --- /dev/null +++ b/test/Seihou/CLI/ManifestGuardSpec.hs @@ -0,0 +1,183 @@ +module Seihou.CLI.ManifestGuardSpec (tests) where + +import Control.Lens ((^.)) +import Data.Generics.Labels () +import Data.Text (Text) +import Data.Text qualified as T +import Seihou.CLI.ManifestGuard + ( ArtifactCheck (..), + ArtifactVerdict (..), + blockingChecks, + formatGuardRefusal, + judgeArtifact, + summarizeCheck, + ) +import Seihou.Core.ArtifactRef (ArtifactRefError (..)) +import Seihou.Core.Types + ( ArtifactOrigin (..), + ModuleName (..), + ) +import Test.Hspec +import Test.Tasty +import Test.Tasty.Hspec (testSpec) + +tests :: IO TestTree +tests = testSpec "Seihou.CLI.ManifestGuard" spec + +demoUrl :: Text +demoUrl = "https://example.com/demo-modules.git" + +otherUrl :: Text +otherUrl = "https://example.com/other-modules.git" + +remote :: Text -> ArtifactOrigin +remote url = RemoteOrigin url "demo" (Just "demo-modules") + +check :: ArtifactOrigin -> ArtifactVerdict -> ArtifactCheck +check origin verdict = + ArtifactCheck {name = ModuleName "demo", origin = origin, verdict = verdict} + +spec :: Spec +spec = do + describe "judgeArtifact version comparison" $ do + it "reports a strictly older local copy as stale" $ + judgeArtifact (remote demoUrl) (Just "2.0.0") (remote demoUrl) (Just "1.4.0") + `shouldBe` ArtifactStale "2.0.0" "1.4.0" + + it "accepts a newer local copy without comment" $ + judgeArtifact (remote demoUrl) (Just "1.4.0") (remote demoUrl) (Just "2.0.0") + `shouldBe` ArtifactOk + + it "accepts an equal local copy" $ + judgeArtifact (remote demoUrl) (Just "2.0.0") (remote demoUrl) (Just "2.0.0") + `shouldBe` ArtifactOk + + it "pads shorter versions with zeros, so 1.4 and 1.4.0 are equal" $ + judgeArtifact (remote demoUrl) (Just "1.4") (remote demoUrl) (Just "1.4.0") + `shouldBe` ArtifactOk + + it "refuses to order a missing recorded version" $ + judgeArtifact (remote demoUrl) Nothing (remote demoUrl) (Just "1.4.0") + `shouldBe` ArtifactVersionIncomparable Nothing (Just "1.4.0") + + it "refuses to order a missing local version" $ + judgeArtifact (remote demoUrl) (Just "2.0.0") (remote demoUrl) Nothing + `shouldBe` ArtifactVersionIncomparable (Just "2.0.0") Nothing + + it "refuses to order a non-numeric version rather than guessing" $ + judgeArtifact (remote demoUrl) (Just "1.0.0-rc1") (remote demoUrl) (Just "1.0.0") + `shouldBe` ArtifactVersionIncomparable (Just "1.0.0-rc1") (Just "1.0.0") + + describe "judgeArtifact identity comparison" $ do + it "reports a differing origin URL as a mismatch" $ + judgeArtifact (remote demoUrl) (Just "2.0.0") (remote otherUrl) (Just "2.0.0") + `shouldBe` ArtifactOriginMismatch (remote demoUrl) (remote otherUrl) + + it "prefers the mismatch over a version difference" $ + judgeArtifact (remote demoUrl) (Just "2.0.0") (remote otherUrl) (Just "1.4.0") + `shouldBe` ArtifactOriginMismatch (remote demoUrl) (remote otherUrl) + + it "treats a trailing .git as the same repository" $ + judgeArtifact + (remote "https://example.com/demo-modules") + (Just "2.0.0") + (remote "https://example.com/demo-modules.git") + (Just "2.0.0") + `shouldBe` ArtifactOk + + it "treats a trailing slash as the same repository" $ + judgeArtifact + (remote "https://example.com/demo-modules.git") + (Just "2.0.0") + (remote "https://example.com/demo-modules/") + (Just "2.0.0") + `shouldBe` ArtifactOk + + it "reports a recorded LocalOrigin as unverifiable when versions agree" $ + judgeArtifact (LocalOrigin "demo") (Just "2.0.0") (LocalOrigin "demo") (Just "2.0.0") + `shouldBe` ArtifactUnverifiableOrigin + + it "still reports staleness under a recorded LocalOrigin" $ + judgeArtifact (LocalOrigin "demo") (Just "2.0.0") (LocalOrigin "demo") (Just "1.4.0") + `shouldBe` ArtifactStale "2.0.0" "1.4.0" + + it "reports a remote artifact shadowed by an unprovenanced copy as unverifiable" $ + judgeArtifact (remote demoUrl) (Just "2.0.0") (LocalOrigin "demo") (Just "2.0.0") + `shouldBe` ArtifactUnverifiableOrigin + + it "accepts a project artifact resolved at the recorded path" $ + judgeArtifact + (ProjectOrigin ".seihou/modules/demo") + (Just "2.0.0") + (ProjectOrigin ".seihou/modules/demo") + (Just "2.0.0") + `shouldBe` ArtifactOk + + it "reports a project artifact resolved at a different path as a mismatch" $ + judgeArtifact + (ProjectOrigin ".seihou/modules/demo") + (Just "2.0.0") + (ProjectOrigin "vendor/demo") + (Just "2.0.0") + `shouldBe` ArtifactOriginMismatch (ProjectOrigin ".seihou/modules/demo") (ProjectOrigin "vendor/demo") + + describe "blockingChecks" $ do + it "selects exactly the three blocking verdicts" $ do + let notFound = ArtifactNotFoundLocally (remote demoUrl) ["/nowhere/demo"] + all' = + [ check (remote demoUrl) ArtifactOk, + check (remote demoUrl) (ArtifactStale "2.0.0" "1.4.0"), + check (remote demoUrl) (ArtifactOriginMismatch (remote demoUrl) (remote otherUrl)), + check (remote demoUrl) (ArtifactUnresolvable notFound), + check (remote demoUrl) (ArtifactVersionIncomparable Nothing Nothing), + check (remote demoUrl) ArtifactUnverifiableOrigin + ] + map (^. #verdict) (blockingChecks all') + `shouldBe` [ ArtifactStale "2.0.0" "1.4.0", + ArtifactOriginMismatch (remote demoUrl) (remote otherUrl), + ArtifactUnresolvable notFound + ] + + it "returns nothing when every artifact is fine" $ + blockingChecks [check (remote demoUrl) ArtifactOk] `shouldBe` [] + + describe "formatGuardRefusal" $ do + it "names both versions, the origin, the remedy, and the escape hatch" $ do + let message = formatGuardRefusal [check (remote demoUrl) (ArtifactStale "2.0.0" "1.4.0")] + message `shouldSatisfy` T.isInfixOf "older than" + message `shouldSatisfy` T.isInfixOf "2.0.0" + message `shouldSatisfy` T.isInfixOf "1.4.0" + message `shouldSatisfy` T.isInfixOf demoUrl + message `shouldSatisfy` T.isInfixOf "seihou upgrade demo" + message `shouldSatisfy` T.isInfixOf "--allow-downgrade" + + it "names both URLs on a mismatch and does not talk about versions" $ do + let message = + formatGuardRefusal + [check (remote demoUrl) (ArtifactOriginMismatch (remote demoUrl) (remote otherUrl))] + message `shouldSatisfy` T.isInfixOf demoUrl + message `shouldSatisfy` T.isInfixOf otherUrl + message `shouldSatisfy` T.isInfixOf "different source" + message `shouldSatisfy` (not . T.isInfixOf "older than") + + it "embeds the resolver's own wording for an unresolvable artifact" $ do + let notFound = ArtifactNotFoundLocally (remote demoUrl) ["/nowhere/demo"] + message = formatGuardRefusal [check (remote demoUrl) (ArtifactUnresolvable notFound)] + message `shouldSatisfy` T.isInfixOf "not" + message `shouldSatisfy` T.isInfixOf "/nowhere/demo" + message `shouldSatisfy` T.isInfixOf "seihou install" + + it "is empty when nothing blocks" $ + formatGuardRefusal [] `shouldBe` "" + + describe "summarizeCheck" $ do + it "says nothing about a healthy artifact" $ + summarizeCheck (check (remote demoUrl) ArtifactOk) `shouldBe` Nothing + + it "reports a stale artifact on one line" $ + summarizeCheck (check (remote demoUrl) (ArtifactStale "2.0.0" "1.4.0")) + `shouldSatisfy` maybe False (T.isInfixOf "seihou upgrade demo") + + it "reports an unverifiable artifact without implying a fault" $ + summarizeCheck (check (LocalOrigin "demo") ArtifactUnverifiableOrigin) + `shouldSatisfy` maybe False (T.isInfixOf "cannot be verified") diff --git a/test/Seihou/CLI/ManifestUpgradeSpec.hs b/test/Seihou/CLI/ManifestUpgradeSpec.hs new file mode 100644 --- /dev/null +++ b/test/Seihou/CLI/ManifestUpgradeSpec.hs @@ -0,0 +1,407 @@ +module Seihou.CLI.ManifestUpgradeSpec (tests) where + +import Control.Lens ((^.)) +import Data.Aeson qualified as Aeson +import Data.Aeson.Key qualified as Key +import Data.Aeson.KeyMap qualified as KeyMap +import Data.ByteString.Lazy qualified as LBS +import Data.Generics.Labels () +import Data.Text (Text) +import Data.Text qualified as T +import Data.Text.Encoding qualified as TE +import Data.Vector qualified as V +import Seihou.CLI.ManifestGuard (ArtifactCheck (..), ArtifactVerdict (..)) +import Seihou.CLI.ManifestUpgrade + ( InferenceOutcome (..), + LegacyManifest (..), + LegacyRef (..), + UpgradeReportEntry (..), + UpgradeResult (..), + applyUpgrade, + formatUpgradeRefusal, + formatUpgradeReport, + inferOriginFromLegacyPath, + readLegacyManifest, + ) +import Seihou.Core.ArtifactRef (ArtifactRefError (..)) +import Seihou.Core.Types (ArtifactOrigin (..), Manifest (..), ModuleName (..)) +import System.Directory (createDirectoryIfMissing) +import System.FilePath (()) +import System.IO.Temp (withSystemTempDirectory) +import Test.Hspec +import Test.Tasty +import Test.Tasty.Hspec (testSpec) +import Text.Read (readMaybe) + +tests :: IO TestTree +tests = testSpec "Seihou.CLI.ManifestUpgrade" spec + +fixturePath :: FilePath +fixturePath = "test/fixtures/legacy-manifest-v5.json" + +-- | Every legacy reference the fixture contains, as +-- @(pointer, name, path, version, definition file)@. +expectedRefs :: [([String], String, FilePath, Maybe String, FilePath)] +expectedRefs = + [ ( ["modules", "0", "source"], + "haskell-base", + "/Users/someone-else/.config/seihou/installed/haskell-base", + Just "1.4.0", + "module.dhall" + ), + ( ["modules", "1", "source"], + "project-lint", + "/Users/someone-else/work/myproject/.seihou/modules/project-lint", + Just "0.2.0", + "module.dhall" + ), + ( ["applications", "0", "targetSource"], + "haskell-base", + "/Users/someone-else/.config/seihou/installed/haskell-base", + Just "1.4.0", + "module.dhall" + ), + ( ["applications", "0", "instances", "0", "source"], + "haskell-base", + "/Users/someone-else/.config/seihou/installed/haskell-base", + Just "1.4.0", + "module.dhall" + ), + ( ["applications", "1", "targetSource"], + "haskell-service", + "/Users/someone-else/.config/seihou/installed/haskell-service", + Just "3.1.0", + "recipe.dhall" + ), + ( ["applications", "1", "instances", "0", "source"], + "project-lint", + "/Users/someone-else/work/myproject/.seihou/modules/project-lint", + Just "0.2.0", + "module.dhall" + ), + ( ["applications", "1", "instances", "1", "source"], + "scratch-helper", + "/Users/someone-else/.config/seihou/modules/scratch-helper", + Nothing, + "module.dhall" + ) + ] + +describeRef :: LegacyRef -> ([String], String, FilePath, Maybe String, FilePath) +describeRef ref = + ( map T.unpack (ref ^. #jsonPointer), + T.unpack (ref ^. #artifactName), + ref ^. #legacyPath, + fmap T.unpack (ref ^. #recordedVersion), + ref ^. #definitionFile + ) + +spec :: Spec +spec = do + describe "readLegacyManifest" $ do + it "finds every legacy reference in a schema-5 manifest, in document order" $ do + bytes <- LBS.readFile fixturePath + case readLegacyManifest bytes of + Left err -> expectationFailure ("expected a legacy manifest, got: " <> err) + Right Nothing -> expectationFailure "expected a legacy manifest, got 'nothing to do'" + Right (Just legacy) -> do + (legacy ^. #schemaVersion) `shouldBe` 5 + map describeRef (legacy ^. #refs) `shouldBe` expectedRefs + + it "reports nothing to do for a manifest already at the current schema version" $ + readLegacyManifest "{\"version\":6,\"modules\":[]}" `shouldBe` Right Nothing + + it "reports nothing to do for a manifest from a newer seihou" $ + readLegacyManifest "{\"version\":7,\"modules\":[]}" `shouldBe` Right Nothing + + it "rejects a document with no version field" $ + readLegacyManifest "{\"modules\":[]}" + `shouldBe` Left "manifest has no 'version' field" + + describe "schema versions 1 through 5" $ + -- Version 6's guard made these documents undecodable by the ordinary + -- manifest decoder, so this is where their positive coverage now lives. + -- Every field a later schema version added is optional with an empty + -- default and none of them holds a path, so all five convert identically. + it "converts every pre-portable-origin schema version the same way" $ + mapM_ convertsCleanly [1 .. 5] + + describe "inferOriginFromLegacyPath" $ do + it "converts a foreign project path by its .seihou/modules suffix" $ do + outcome <- + inferOriginFromLegacyPath + "/nowhere/this-project" + [] + (legacyRef "demo" "/Users/someone-else/work/theirproject/.seihou/modules/demo") + outcome `shouldBe` InferredFromProjectPath (ProjectOrigin ".seihou/modules/demo") + + it "recovers the upstream URL from a locally installed copy" $ + withInstall (Just originJson) $ \projectRoot installRoot -> do + outcome <- + inferOriginFromLegacyPath + projectRoot + [installRoot] + (legacyRef "demo" "/Users/someone-else/.config/seihou/installed/demo") + outcome + `shouldBe` InferredFromLocalInstall + (RemoteOrigin "https://example.com/demo-modules.git" "demo" (Just "demo-modules")) + + it "falls back to an unverifiable local origin when nothing is installed here" $ + withSystemTempDirectory "seihou-upgrade" $ \root -> do + let projectRoot = root "project" + installRoot = root "home" "seihou" "installed" + createDirectoryIfMissing True projectRoot + createDirectoryIfMissing True installRoot + outcome <- + inferOriginFromLegacyPath + projectRoot + [installRoot] + (legacyRef "demo" "/Users/someone-else/.config/seihou/installed/demo") + outcome `shouldBe` InferredAsUnverifiable (LocalOrigin "demo") + + it "reports an installed copy with no recorded provenance as unverifiable" $ + withInstall Nothing $ \projectRoot installRoot -> do + outcome <- + inferOriginFromLegacyPath + projectRoot + [installRoot] + (legacyRef "demo" "/Users/someone-else/.config/seihou/modules/demo") + outcome `shouldBe` InferredAsUnverifiable (LocalOrigin "demo") + + describe "applyUpgrade" $ do + it "replaces every recorded path with its origin and bumps the schema version" $ do + result <- upgradedFixture + let document = result ^. #upgradedDocument + (result ^. #fromVersion) `shouldBe` 5 + documentKeys document `shouldNotContain` ["source"] + documentKeys document `shouldNotContain` ["targetSource"] + documentKeys document `shouldContain` ["origin"] + documentKeys document `shouldContain` ["targetOrigin"] + lookupPath ["version"] document `shouldBe` Just (Aeson.Number 6) + lookupPath ["modules", "0", "origin"] document + `shouldBe` Just (Aeson.toJSON (RemoteOrigin haskellBaseUrl "haskell-base" (Just "seihou-modules"))) + lookupPath ["applications", "1", "instances", "0", "origin"] document + `shouldBe` Just (Aeson.toJSON (ProjectOrigin ".seihou/modules/project-lint")) + + it "leaves no machine-specific path anywhere in the document" $ do + result <- upgradedFixture + -- The invariant of docs/adr/0001: nothing whose meaning depends on the + -- machine that wrote it. A variable whose *value* happens to name the + -- other developer is data, not a path, and must survive. + filter absoluteLooking (documentStrings (result ^. #upgradedDocument)) + `shouldBe` [] + + it "preserves every field it does not convert" $ do + result <- upgradedFixture + let document = result ^. #upgradedDocument + lookupPath ["variables", "project.author"] document + `shouldBe` Just (Aeson.String "someone-else") + lookupPath ["modules", "0", "parentVars", "project.name"] document + `shouldBe` Just (Aeson.String "demo") + lookupPath ["files", "flake.nix", "baseline"] document + `shouldBe` Just (Aeson.String (T.replicate 64 "2")) + lookupPath ["blueprintMigrations", "0", "agentSessionId"] document + `shouldBe` Just (Aeson.String "session-abc") + lookupPath ["blueprint", "userPrompt"] document + `shouldBe` Just (Aeson.String "build a service") + lookupPath + ["applications", "0", "commandReceipts", T.replicate 64 "4", "command"] + document + `shouldBe` Just (Aeson.String "cabal build") + + it "produces a document the ordinary manifest decoder accepts" $ do + result <- upgradedFixture + case Aeson.fromJSON (result ^. #upgradedDocument) :: Aeson.Result Manifest of + Aeson.Error err -> expectationFailure ("upgraded manifest does not decode: " <> err) + Aeson.Success manifest -> length (manifest ^. #modules) `shouldBe` 2 + + it "reports each artifact once even though it appears in three records" $ do + result <- upgradedFixture + map (^. #artifactName) (result ^. #entries) + `shouldBe` ["haskell-base", "project-lint", "haskell-service", "scratch-helper"] + + describe "formatUpgradeReport" $ + it "renders one aligned block per conversion" $ + formatUpgradeReport exampleResult `shouldBe` exampleReport + + describe "formatUpgradeRefusal" $ do + it "names every blocking artifact and the two ways forward" $ do + let refusal = formatUpgradeRefusal "✗ Refusing to write .seihou/manifest.json." [missingDemo] + refusal `shouldSatisfy` T.isInfixOf "✗ Refusing to write .seihou/manifest.json." + refusal `shouldSatisfy` T.isInfixOf "demo: recorded in the manifest but not installed on this machine" + refusal `shouldSatisfy` T.isInfixOf "Install or upgrade the artifacts above and run this again" + refusal `shouldSatisfy` T.isInfixOf "--force" + + it "does not offer --allow-downgrade, which is not a flag on this command" $ + formatUpgradeRefusal "✗" [missingDemo] `shouldSatisfy` (not . T.isInfixOf "--allow-downgrade") + +-- | A recorded artifact that is not installed on this machine — the verdict +-- an upgrade run on a fresh clone hits most often. +missingDemo :: ArtifactCheck +missingDemo = + ArtifactCheck + { name = ModuleName "demo", + origin = LocalOrigin "demo", + verdict = ArtifactUnresolvable (ArtifactNotFoundLocally (LocalOrigin "demo") []) + } + +haskellBaseUrl :: Text +haskellBaseUrl = "https://github.com/shinzui/seihou-modules.git" + +-- | A manifest at one of the historical schema versions, carrying only the +-- keys that version is guaranteed to have. +schemaVersionDocument :: Int -> LBS.ByteString +schemaVersionDocument version = + LBS.fromStrict . TE.encodeUtf8 . T.concat $ + [ "{\"version\":", + T.pack (show version), + ",\"generatedAt\":\"2026-07-01T12:00:00Z\"", + ",\"modules\":[{\"name\":\"demo\"", + ",\"source\":\"/Users/someone-else/.config/seihou/installed/demo\"", + ",\"version\":\"1.0.0\",\"appliedAt\":\"2026-07-01T12:00:00Z\"}]", + ",\"variables\":{},\"files\":{}}" + ] + +-- | One historical schema version reads, converts, and lands on version 6 +-- with a portable origin in place of the recorded path. +convertsCleanly :: Int -> Expectation +convertsCleanly version = + case readLegacyManifest (schemaVersionDocument version) of + Left err -> expectationFailure ("schema version " <> show version <> " did not read: " <> err) + Right Nothing -> expectationFailure ("schema version " <> show version <> " reported nothing to do") + Right (Just legacy) -> do + (legacy ^. #schemaVersion) `shouldBe` version + let converted = + applyUpgrade + legacy + [(ref, InferredAsUnverifiable (LocalOrigin "demo")) | ref <- legacy ^. #refs] + document = converted ^. #upgradedDocument + lookupPath ["version"] document `shouldBe` Just (Aeson.Number 6) + lookupPath ["modules", "0", "origin"] document + `shouldBe` Just (Aeson.toJSON (LocalOrigin "demo")) + lookupPath ["modules", "0", "version"] document `shouldBe` Just (Aeson.String "1.0.0") + filter absoluteLooking (documentStrings document) `shouldBe` [] + +-- | The fixture, converted with a fixed inference for each artifact so the +-- assertions are about the rewrite rather than about this machine. +upgradedFixture :: IO UpgradeResult +upgradedFixture = do + bytes <- LBS.readFile fixturePath + case readLegacyManifest bytes of + Right (Just legacy) -> + pure (applyUpgrade legacy [(ref, inferenceFor ref) | ref <- legacy ^. #refs]) + other -> fail ("fixture did not read as a legacy manifest: " <> show (fmap (fmap (^. #schemaVersion)) other)) + where + inferenceFor ref = case ref ^. #artifactName of + "project-lint" -> InferredFromProjectPath (ProjectOrigin ".seihou/modules/project-lint") + "scratch-helper" -> InferredAsUnverifiable (LocalOrigin "scratch-helper") + name -> InferredFromLocalInstall (RemoteOrigin haskellBaseUrl name (Just "seihou-modules")) + +exampleResult :: UpgradeResult +exampleResult = + UpgradeResult + { fromVersion = 5, + entries = + [ UpgradeReportEntry + { artifactName = "haskell-base", + legacyPath = "/Users/shinzui/.config/seihou/installed/haskell-base", + outcome = + InferredFromLocalInstall (RemoteOrigin haskellBaseUrl "haskell-base" (Just "seihou-modules")) + }, + UpgradeReportEntry + { artifactName = "project-lint", + legacyPath = "/Users/shinzui/work/myproject/.seihou/modules/project-lint", + outcome = InferredFromProjectPath (ProjectOrigin ".seihou/modules/project-lint") + }, + UpgradeReportEntry + { artifactName = "scratch-helper", + legacyPath = "/Users/other/.config/seihou/modules/scratch-helper", + outcome = InferredAsUnverifiable (LocalOrigin "scratch-helper") + } + ], + upgradedDocument = Aeson.Null + } + +exampleReport :: Text +exampleReport = + T.unlines + [ "Reading .seihou/manifest.json (schema version 5)", + "", + " haskell-base /Users/shinzui/.config/seihou/installed/haskell-base", + " → remote https://github.com/shinzui/seihou-modules.git", + "", + " project-lint /Users/shinzui/work/myproject/.seihou/modules/project-lint", + " → project .seihou/modules/project-lint", + "", + " scratch-helper /Users/other/.config/seihou/modules/scratch-helper", + " → local scratch-helper (no upstream recorded)", + "" + ] + +-- | Every object key appearing anywhere in a document. +documentKeys :: Aeson.Value -> [Text] +documentKeys (Aeson.Object fields) = + map Key.toText (KeyMap.keys fields) <> concatMap documentKeys (KeyMap.elems fields) +documentKeys (Aeson.Array elements) = concatMap documentKeys elements +documentKeys _ = [] + +-- | Whether a string looks like a path that only means something on the +-- machine that wrote it. +absoluteLooking :: Text -> Bool +absoluteLooking value = + T.isPrefixOf "/" value + || T.isPrefixOf "~" value + || T.isPrefixOf "\\\\" value + || (T.length value >= 3 && T.index value 1 == ':' && T.index value 2 == '\\') + +-- | Every string value appearing anywhere in a document. +documentStrings :: Aeson.Value -> [Text] +documentStrings (Aeson.String text) = [text] +documentStrings (Aeson.Object fields) = concatMap documentStrings (KeyMap.elems fields) +documentStrings (Aeson.Array elements) = concatMap documentStrings elements +documentStrings _ = [] + +-- | Follow a pointer of object keys and array indices. +lookupPath :: [Text] -> Aeson.Value -> Maybe Aeson.Value +lookupPath [] value = Just value +lookupPath (step : rest) (Aeson.Object fields) = + KeyMap.lookup (Key.fromText step) fields >>= lookupPath rest +lookupPath (step : rest) (Aeson.Array elements) = do + index <- readMaybe (T.unpack step) + element <- elements V.!? index + lookupPath rest element +lookupPath _ _ = Nothing + +-- | A reference to a module, which is all the inference tests need. +legacyRef :: Text -> FilePath -> LegacyRef +legacyRef name path = + LegacyRef + { jsonPointer = ["modules", "0", "source"], + artifactName = name, + legacyPath = path, + recordedVersion = Just "1.0.0", + definitionFile = "module.dhall" + } + +originJson :: String +originJson = + "{\"sourceUrl\":\"https://example.com/demo-modules.git\"\ + \,\"repoName\":\"demo-modules\"\ + \,\"installedAt\":\"2026-07-01T00:00:00Z\"\ + \,\"version\":\"1.0.0\",\"tags\":[]}" + +-- | A project root plus a search path holding an installed @demo@, with or +-- without the @.seihou-origin.json@ that records where it came from. +withInstall :: Maybe String -> (FilePath -> FilePath -> IO a) -> IO a +withInstall mOriginJson action = + withSystemTempDirectory "seihou-upgrade" $ \root -> do + let projectRoot = root "project" + installRoot = root "home" "seihou" "installed" + artifactDir = installRoot "demo" + createDirectoryIfMissing True projectRoot + createDirectoryIfMissing True artifactDir + writeFile (artifactDir "module.dhall") "{ name = \"demo\" }" + case mOriginJson of + Nothing -> pure () + Just contents -> writeFile (artifactDir ".seihou-origin.json") contents + action projectRoot installRoot diff --git a/test/Seihou/CLI/MigrateSpec.hs b/test/Seihou/CLI/MigrateSpec.hs --- a/test/Seihou/CLI/MigrateSpec.hs +++ b/test/Seihou/CLI/MigrateSpec.hs @@ -1,14 +1,17 @@ module Seihou.CLI.MigrateSpec (tests) where import Control.Exception (bracket_) +import Control.Lens (to, (&), (.~), (?~), (^.)) import Data.Aeson (encode, object, (.=)) import Data.ByteString.Lazy qualified as LBS +import Data.Generics.Labels () import Data.Map.Strict qualified as Map import Data.Text (Text) import Data.Text qualified as T import Data.Text.IO qualified as TIO import Data.Time (UTCTime, defaultTimeLocale, parseTimeOrError) import Effectful (runEff) +import GHC.Generics (Generic) import Seihou.CLI.Migrate ( MigrateError (..), MigrateOpts (..), @@ -19,6 +22,7 @@ import Seihou.Core.Migration (MigrationPlan (..)) import Seihou.Core.Types ( AppliedModule (..), + ArtifactOrigin (..), FileRecord (..), Manifest (..), ModuleName (..), @@ -112,44 +116,22 @@ mkManifest :: Text -> FilePath -> [(FilePath, Text)] -> Manifest mkManifest version installedDir entries = (emptyManifest fixedTime) - { modules = - [ AppliedModule - { name = modName, - parentVars = emptyParentVars, - source = installedDir, - moduleVersion = Just version, - appliedAt = fixedTime, - removal = Nothing - } - ], - files = - Map.fromList - [ ( path, - FileRecord - { hash = hashContent content, - moduleName = modName, - strategy = Template, - generatedAt = fixedTime, - baseline = Nothing, - applicationIds = mempty - } - ) - | (path, content) <- entries - ] - } + & #modules .~ [AppliedModule {name = modName, parentVars = emptyParentVars, origin = LocalOrigin (modName ^. #unModuleName), moduleVersion = Just version, appliedAt = fixedTime, removal = Nothing}] + & #files .~ Map.fromList [(path, FileRecord {hash = hashContent content, moduleName = modName, strategy = Template, generatedAt = fixedTime, baseline = Nothing, applicationIds = mempty}) | (path, content) <- entries] defaultOpts :: MigrateOpts defaultOpts = MigrateOpts - { migrateModule = modName, - migrateTo = Nothing, - migrateDryRun = False, - migrateForce = False, - migrateJson = False, - migrateVerbose = False, - migrateNoFetch = True, - migrateCommit = False, - migrateCommitMessage = Nothing + { module_ = modName, + to = Nothing, + dryRun = False, + force = False, + json = False, + verbose = False, + noFetch = True, + commit = False, + commitMessage = Nothing, + allowDowngrade = False } -- ---------------------------------------------------------------------------- @@ -157,11 +139,12 @@ -- ---------------------------------------------------------------------------- data FetchFixture = FetchFixture - { modName :: Text, - remoteDir :: FilePath, - installedDir :: FilePath, - projectDir :: FilePath + { modName :: !Text, + remoteDir :: !FilePath, + installedDir :: !FilePath, + projectDir :: !FilePath } + deriving stock (Generic) withFetchFixture :: Text -> Text -> Text -> (FetchFixture -> IO ()) -> IO () withFetchFixture installedVer remoteVer migrationsLit action = @@ -254,31 +237,8 @@ mkManifestAt :: FetchFixture -> Text -> [(FilePath, Text)] -> Manifest mkManifestAt fix version entries = (emptyManifest fixedTime) - { modules = - [ AppliedModule - { name = ModuleName fix.modName, - parentVars = emptyParentVars, - source = fix.installedDir, - moduleVersion = Just version, - appliedAt = fixedTime, - removal = Nothing - } - ], - files = - Map.fromList - [ ( path, - FileRecord - { hash = hashContent content, - moduleName = ModuleName fix.modName, - strategy = Template, - generatedAt = fixedTime, - baseline = Nothing, - applicationIds = mempty - } - ) - | (path, content) <- entries - ] - } + & #modules .~ [AppliedModule {name = ModuleName (fix ^. #modName), parentVars = emptyParentVars, origin = LocalOrigin (fix ^. #modName), moduleVersion = Just version, appliedAt = fixedTime, removal = Nothing}] + & #files .~ Map.fromList [(path, FileRecord {hash = hashContent content, moduleName = ModuleName (fix ^. #modName), strategy = Template, generatedAt = fixedTime, baseline = Nothing, applicationIds = mempty}) | (path, content) <- entries] withSavedEnv :: String -> Maybe String -> IO () -> IO () withSavedEnv key newVal action = do @@ -302,7 +262,7 @@ withSystemTempDirectory "seihou-migrate-cli" $ \dir -> do let installed = dir "installed-demo" writeInstalledModule installed "2.0.0" emptyMigrationsLit - let manifest = (emptyManifest fixedTime) {modules = []} + let manifest = ((emptyManifest fixedTime) & #modules .~ []) result <- withCurrentDirectory dir $ runMigrate defaultOpts manifest installed @@ -315,18 +275,9 @@ let installed = dir "installed-demo" writeInstalledModule installed "2.0.0" emptyMigrationsLit let manifest = - (emptyManifest fixedTime) - { modules = - [ AppliedModule - { name = modName, - parentVars = emptyParentVars, - source = installed, - moduleVersion = Nothing, - appliedAt = fixedTime, - removal = Nothing - } - ] - } + ( (emptyManifest fixedTime) + & #modules .~ [AppliedModule {name = modName, parentVars = emptyParentVars, origin = LocalOrigin (modName ^. #unModuleName), moduleVersion = Nothing, appliedAt = fixedTime, removal = Nothing}] + ) result <- withCurrentDirectory dir $ runMigrate defaultOpts manifest installed @@ -353,7 +304,7 @@ createDirectoryIfMissing True (dir "app") TIO.writeFile (dir "app" "Main.hs") "module Main where" let manifest = mkManifest "1.0.0" installed [("app/Main.hs", "module Main where")] - opts = defaultOpts {migrateDryRun = True} + opts = (defaultOpts & #dryRun .~ True) result <- withCurrentDirectory dir $ runMigrate opts manifest installed @@ -377,9 +328,9 @@ Right (MigrateApplied _plan manifest' fromV toV) -> do renderVersion fromV `shouldBe` "1.0.0" renderVersion toV `shouldBe` "2.0.0" - Map.member "src/Main.hs" manifest'.files `shouldBe` True - Map.member "app/Main.hs" manifest'.files `shouldBe` False - (head manifest'.modules).moduleVersion `shouldBe` Just "2.0.0" + Map.member "src/Main.hs" (manifest' ^. #files) `shouldBe` True + Map.member "app/Main.hs" (manifest' ^. #files) `shouldBe` False + ((head (manifest' ^. #modules)) ^. #moduleVersion) `shouldBe` Just "2.0.0" doesFileExist (dir "src" "Main.hs") `shouldReturn` True doesFileExist (dir "app" "Main.hs") `shouldReturn` False other -> expectationFailure ("expected MigrateApplied, got: " <> show other) @@ -406,7 +357,7 @@ createDirectoryIfMissing True (dir "app") TIO.writeFile (dir "app" "Main.hs") "user-edited" let manifest = mkManifest "1.0.0" installed [("app/Main.hs", "original")] - opts = defaultOpts {migrateForce = True} + opts = (defaultOpts & #force .~ True) result <- withCurrentDirectory dir $ runMigrate opts manifest installed @@ -414,7 +365,7 @@ Right (MigrateApplied _ manifest' _ _) -> do doesFileExist (dir "src" "Main.hs") `shouldReturn` True doesFileExist (dir "app" "Main.hs") `shouldReturn` False - Map.member "src/Main.hs" manifest'.files `shouldBe` True + Map.member "src/Main.hs" (manifest' ^. #files) `shouldBe` True other -> expectationFailure ("expected MigrateApplied, got: " <> show other) -- ------------------------------------------------------------------ @@ -423,22 +374,22 @@ -- ------------------------------------------------------------------ it "fetches a newer remote, refreshes the installed copy, and applies the chain" $ withFetchFixture "1.0.0" "2.0.0" moveOldToNewLit $ \fix -> do - TIO.writeFile (fix.projectDir "old.txt") "x" + TIO.writeFile (fix ^. #projectDir "old.txt") "x" let manifest = mkManifestAt fix "1.0.0" [("old.txt", "x")] - opts = (defaultOpts {migrateNoFetch = False}) {migrateModule = ModuleName fix.modName} + opts = defaultOpts & #noFetch .~ False & #module_ .~ ModuleName (fix ^. #modName) result <- - withCurrentDirectory fix.projectDir $ - runMigrate opts manifest fix.installedDir + withCurrentDirectory (fix ^. #projectDir) $ + runMigrate opts manifest (fix ^. #installedDir) case result of Right (MigrateApplied _ manifest' _ _) -> do - doesFileExist (fix.projectDir "old.txt") `shouldReturn` False - doesFileExist (fix.projectDir "new.txt") `shouldReturn` True - case manifest'.modules of - (am : _) -> am.moduleVersion `shouldBe` Just "2.0.0" + doesFileExist (fix ^. #projectDir "old.txt") `shouldReturn` False + doesFileExist (fix ^. #projectDir "new.txt") `shouldReturn` True + case manifest' ^. #modules of + (am : _) -> (am ^. #moduleVersion) `shouldBe` Just "2.0.0" [] -> expectationFailure "manifest has no modules" - Map.member "new.txt" manifest'.files `shouldBe` True - Map.member "old.txt" manifest'.files `shouldBe` False - installedBody <- TIO.readFile (fix.installedDir "module.dhall") + Map.member "new.txt" (manifest' ^. #files) `shouldBe` True + Map.member "old.txt" (manifest' ^. #files) `shouldBe` False + installedBody <- TIO.readFile (fix ^. #installedDir "module.dhall") T.isInfixOf "2.0.0" installedBody `shouldBe` True other -> expectationFailure ("expected MigrateApplied, got: " <> show other) @@ -446,10 +397,10 @@ it "is a no-op when the remote and installed versions match" $ withFetchFixture "1.0.0" "1.0.0" emptyMigrationsLit $ \fix -> do let manifest = mkManifestAt fix "1.0.0" [] - opts = (defaultOpts {migrateNoFetch = False}) {migrateModule = ModuleName fix.modName} + opts = defaultOpts & #noFetch .~ False & #module_ .~ ModuleName (fix ^. #modName) result <- - withCurrentDirectory fix.projectDir $ - runMigrate opts manifest fix.installedDir + withCurrentDirectory (fix ^. #projectDir) $ + runMigrate opts manifest (fix ^. #installedDir) case result of Right (MigrateNoOp _) -> pure () other -> expectationFailure ("expected MigrateNoOp, got: " <> show other) @@ -457,10 +408,10 @@ it "ignores a newer remote when --no-fetch is set" $ withFetchFixture "1.0.0" "2.0.0" moveOldToNewLit $ \fix -> do let manifest = mkManifestAt fix "1.0.0" [] - opts = (defaultOpts {migrateNoFetch = True}) {migrateModule = ModuleName fix.modName} + opts = defaultOpts & #noFetch .~ True & #module_ .~ ModuleName (fix ^. #modName) result <- - withCurrentDirectory fix.projectDir $ - runMigrate opts manifest fix.installedDir + withCurrentDirectory (fix ^. #projectDir) $ + runMigrate opts manifest (fix ^. #installedDir) case result of Right (MigrateNoOp _) -> pure () other -> expectationFailure ("expected MigrateNoOp, got: " <> show other) @@ -487,16 +438,16 @@ writeInstalledModule installed "2.0.0" twoStepLit TIO.writeFile (dir "a.txt") "x" let manifest = mkManifest "1.0.0" installed [("a.txt", "x")] - opts = defaultOpts {migrateTo = Just "1.5.0"} + opts = defaultOpts & #to .~ Just "1.5.0" result <- withCurrentDirectory dir $ runMigrate opts manifest installed case result of Right (MigrateApplied _ manifest' _ toV) -> do renderVersion toV `shouldBe` "1.5.0" - Map.member "b.txt" manifest'.files `shouldBe` True - Map.member "c.txt" manifest'.files `shouldBe` False - (head manifest'.modules).moduleVersion `shouldBe` Just "1.5.0" + Map.member "b.txt" (manifest' ^. #files) `shouldBe` True + Map.member "c.txt" (manifest' ^. #files) `shouldBe` False + ((head (manifest' ^. #modules)) ^. #moduleVersion) `shouldBe` Just "1.5.0" doesFileExist (dir "b.txt") `shouldReturn` True doesFileExist (dir "c.txt") `shouldReturn` False other -> expectationFailure ("expected MigrateApplied, got: " <> show other) @@ -528,9 +479,9 @@ Right (MigrateApplied _ manifest' fromV toV) -> do renderVersion fromV `shouldBe` "1.0.0" renderVersion toV `shouldBe` "3.0.0" - (head manifest'.modules).moduleVersion `shouldBe` Just "3.0.0" - Map.member "src/Main.hs" manifest'.files `shouldBe` True - Map.member "app/Main.hs" manifest'.files `shouldBe` False + ((head (manifest' ^. #modules)) ^. #moduleVersion) `shouldBe` Just "3.0.0" + Map.member "src/Main.hs" (manifest' ^. #files) `shouldBe` True + Map.member "app/Main.hs" (manifest' ^. #files) `shouldBe` False doesFileExist (dir "src" "Main.hs") `shouldReturn` True doesFileExist (dir "app" "Main.hs") `shouldReturn` False other -> @@ -547,8 +498,8 @@ case result of Right (MigrateApplied execPlan manifest' _ toV) -> do renderVersion toV `shouldBe` "0.3.0" - null execPlan.planSource.planSteps `shouldBe` True - (head manifest'.modules).moduleVersion `shouldBe` Just "0.3.0" + null (execPlan ^. #source . #steps) `shouldBe` True + ((head (manifest' ^. #modules)) ^. #moduleVersion) `shouldBe` Just "0.3.0" other -> expectationFailure ("expected MigrateApplied (pure bump), got: " <> show other) it "Scenario C: orphan-edge entirely outside the window also lands the manifest at target" $ @@ -573,8 +524,8 @@ case result of Right (MigrateApplied execPlan manifest' _ toV) -> do renderVersion toV `shouldBe` "0.3.0" - null execPlan.planSource.planSteps `shouldBe` True - (head manifest'.modules).moduleVersion `shouldBe` Just "0.3.0" + null (execPlan ^. #source . #steps) `shouldBe` True + ((head (manifest' ^. #modules)) ^. #moduleVersion) `shouldBe` Just "0.3.0" other -> expectationFailure ("expected MigrateApplied (orphan-edge skip), got: " <> show other) it "User's two-component fixture: 0.2 -> 0.6 with [{0.2->0.3}, {0.5->0.6}]" $ @@ -609,8 +560,8 @@ case result of Right (MigrateApplied execPlan manifest' _ toV) -> do renderVersion toV `shouldBe` "0.6" - length execPlan.planSource.planSteps `shouldBe` 2 - (head manifest'.modules).moduleVersion `shouldBe` Just "0.6" + length (execPlan ^. #source . #steps) `shouldBe` 2 + ((head (manifest' ^. #modules)) ^. #moduleVersion) `shouldBe` Just "0.6" doesFileExist (dir "v3.txt") `shouldReturn` True doesFileExist (dir "v6.txt") `shouldReturn` True doesFileExist (dir "v2.txt") `shouldReturn` False @@ -630,10 +581,10 @@ TIO.writeFile (dir "app" "Main.hs") "module Main where" let manifest = mkManifest "1.0.0" installed [("app/Main.hs", "module Main where")] opts = - defaultOpts - { migrateCommit = True, - migrateCommitMessage = Just "chore: migrate" - } + ( defaultOpts + & #commit .~ True + & #commitMessage ?~ "chore: migrate" + ) withCurrentDirectory dir $ do createDirectoryIfMissing True (dir ".seihou") runEff $ @@ -673,7 +624,7 @@ createDirectoryIfMissing True (dir "app") TIO.writeFile (dir "app" "Main.hs") "module Main where" let manifest = mkManifest "1.0.0" installed [("app/Main.hs", "module Main where")] - opts = defaultOpts {migrateCommitMessage = Just "chore: migrate"} + opts = (defaultOpts & #commitMessage ?~ "chore: migrate") withCurrentDirectory dir $ do createDirectoryIfMissing True (dir ".seihou") result <- runMigrate opts manifest installed @@ -697,11 +648,11 @@ TIO.writeFile (dir "app" "Main.hs") "module Main where" let manifest = mkManifest "1.0.0" installed [("app/Main.hs", "module Main where")] opts = - defaultOpts - { migrateDryRun = True, - migrateCommit = True, - migrateCommitMessage = Just "chore: migrate" - } + ( defaultOpts + & #dryRun .~ True + & #commit .~ True + & #commitMessage ?~ "chore: migrate" + ) withCurrentDirectory dir $ do initProjectRepo dir result <- runMigrate opts manifest installed @@ -733,23 +684,23 @@ "]" ] in withFetchFixture "0.3" "0.3" emptyMigrationsLit $ \fix -> do - writeInstalledModule fix.installedDir "0.3" partialLit - writeOriginJson fix.installedDir (T.pack fix.remoteDir) - TIO.writeFile (fix.projectDir "old.txt") "tracked\n" + writeInstalledModule (fix ^. #installedDir) "0.3" partialLit + writeOriginJson (fix ^. #installedDir) (T.pack (fix ^. #remoteDir)) + TIO.writeFile (fix ^. #projectDir "old.txt") "tracked\n" let manifest = mkManifestAt fix "0.1" [("old.txt", "tracked\n")] - opts = (defaultOpts {migrateNoFetch = False}) {migrateModule = ModuleName fix.modName} + opts = defaultOpts & #noFetch .~ False & #module_ .~ ModuleName (fix ^. #modName) result <- - withCurrentDirectory fix.projectDir $ - runMigrate opts manifest fix.installedDir + withCurrentDirectory (fix ^. #projectDir) $ + runMigrate opts manifest (fix ^. #installedDir) case result of Right (MigrateApplied execPlan manifest' _ toV) -> do renderVersion toV `shouldBe` "0.3" - length execPlan.planSource.planSteps `shouldBe` 1 - case manifest'.modules of - (am : _) -> am.moduleVersion `shouldBe` Just "0.3" + length (execPlan ^. #source . #steps) `shouldBe` 1 + case manifest' ^. #modules of + (am : _) -> (am ^. #moduleVersion) `shouldBe` Just "0.3" [] -> expectationFailure "manifest has no modules" - doesFileExist (fix.projectDir "new.txt") `shouldReturn` True - doesFileExist (fix.projectDir "old.txt") `shouldReturn` False + doesFileExist (fix ^. #projectDir "new.txt") `shouldReturn` True + doesFileExist (fix ^. #projectDir "old.txt") `shouldReturn` False other -> expectationFailure ("expected MigrateApplied (local fallback), got: " <> show other) @@ -757,16 +708,16 @@ it "fetch fallback: clone-based plan stands when neither side declares applicable edges" $ withFetchFixture "0.3" "0.3" emptyMigrationsLit $ \fix -> do let manifest = mkManifestAt fix "0.1" [] - opts = (defaultOpts {migrateNoFetch = False}) {migrateModule = ModuleName fix.modName} + opts = defaultOpts & #noFetch .~ False & #module_ .~ ModuleName (fix ^. #modName) result <- - withCurrentDirectory fix.projectDir $ - runMigrate opts manifest fix.installedDir + withCurrentDirectory (fix ^. #projectDir) $ + runMigrate opts manifest (fix ^. #installedDir) case result of Right (MigrateApplied execPlan manifest' _ toV) -> do renderVersion toV `shouldBe` "0.3" - null execPlan.planSource.planSteps `shouldBe` True - case manifest'.modules of - (am : _) -> am.moduleVersion `shouldBe` Just "0.3" + null (execPlan ^. #source . #steps) `shouldBe` True + case manifest' ^. #modules of + (am : _) -> (am ^. #moduleVersion) `shouldBe` Just "0.3" [] -> expectationFailure "manifest has no modules" other -> expectationFailure ("expected MigrateApplied (no-op-style bump), got: " <> show other) diff --git a/test/Seihou/CLI/PendingMigrationSpec.hs b/test/Seihou/CLI/PendingMigrationSpec.hs --- a/test/Seihou/CLI/PendingMigrationSpec.hs +++ b/test/Seihou/CLI/PendingMigrationSpec.hs @@ -1,5 +1,7 @@ module Seihou.CLI.PendingMigrationSpec (tests) where +import Control.Lens (to, (&), (.~), (^.)) +import Data.Generics.Labels () import Data.Map.Strict qualified as Map import Data.Set qualified as Set import Data.Text (Text) @@ -18,6 +20,7 @@ ) import Seihou.Core.Types ( AppliedModule (..), + ArtifactOrigin (..), Manifest (..), Module (..), ModuleName (..), @@ -25,7 +28,7 @@ ) import Seihou.Core.Version qualified import Seihou.Manifest.Types (emptyManifest) -import System.Directory (createDirectoryIfMissing) +import System.Directory (createDirectoryIfMissing, withCurrentDirectory) import System.FilePath (()) import System.IO.Temp (withSystemTempDirectory) import Test.Hspec @@ -48,7 +51,7 @@ AppliedModule { name = ModuleName "demo", parentVars = emptyParentVars, - source = "/installed/demo", + origin = LocalOrigin "demo", moduleVersion = mver, appliedAt = fixedTime, removal = Nothing @@ -107,17 +110,35 @@ emptyMigrationsLit = "[] : List { from : Text, to : Text, ops : List < MoveFile : { src : Text, dest : Text } | MoveDir : { src : Text, dest : Text } | DeleteFile : { path : Text } | DeleteDir : { path : Text } | RunCommand : { run : Text, workDir : Optional Text } > }" -mkAppliedAt :: Text -> FilePath -> Maybe Text -> AppliedModule -mkAppliedAt name source mver = +-- | An applied module recorded the way the manifest records one: by portable +-- origin, not by path. Detection resolves the origin against the current +-- working directory, so the tests below plant modules under +-- @/.seihou/modules/@ and run inside that project. +mkAppliedAt :: Text -> Maybe Text -> AppliedModule +mkAppliedAt name mver = AppliedModule { name = ModuleName name, parentVars = emptyParentVars, - source = source, + origin = ProjectOrigin (projectModulePath name), moduleVersion = mver, appliedAt = fixedTime, removal = Nothing } +-- | Where a project-origin module lives, relative to the project root. +projectModulePath :: Text -> FilePath +projectModulePath name = ".seihou/modules/" <> T.unpack name + +-- | Plant a module inside a scratch project and run the body from the project +-- root, which is what @detectPendingMigrations@ resolves origins against. +withProjectModules :: [(Text, Text, Text)] -> IO a -> IO a +withProjectModules modules body = + withSystemTempDirectory "seihou-pending-detect" $ \projectRoot -> do + mapM_ + (\(name, version, migrationsLit) -> writeInstalledModule (projectRoot projectModulePath name) name version migrationsLit) + modules + withCurrentDirectory projectRoot body + spec :: Spec spec = do describe "pendingChainFor" $ do @@ -142,8 +163,8 @@ installed = mkInstalled (Just "2.0.0") [mig] case pendingChainFor am installed of Just plan -> do - plan.planSteps `shouldBe` [mig] - plan.planTo `shouldBe` parseV "2.0.0" + (plan ^. #steps) `shouldBe` [mig] + (plan ^. #to) `shouldBe` parseV "2.0.0" Nothing -> expectationFailure "expected Just plan" it "returns Nothing for downgrade (manifest > installed)" $ do @@ -154,16 +175,16 @@ it "returns a partial-cover plan when the chain reaches some intermediate version" $ do -- master-plan live-tree fixture: manifest=0.1.0, installed=0.3.0, -- edges=[0.1.0 -> 0.2.0]. Under the gap-tolerant walker the plan - -- always carries the supplied target as planTo, regardless of + -- always carries the supplied target as to, regardless of -- whether the steps reach it. let am = mkApplied (Just "0.1.0") mig = Migration "0.1.0" "0.2.0" [DeleteFile "x"] installed = mkInstalled (Just "0.3.0") [mig] case pendingChainFor am installed of Just plan -> do - plan.planSteps `shouldBe` [mig] - plan.planFrom `shouldBe` parseV "0.1.0" - plan.planTo `shouldBe` parseV "0.3.0" + (plan ^. #steps) `shouldBe` [mig] + (plan ^. #from) `shouldBe` parseV "0.1.0" + (plan ^. #to) `shouldBe` parseV "0.3.0" Nothing -> expectationFailure "expected Just plan with partial cover" it "returns an empty-steps plan when no edge starts at the manifest version" $ do @@ -171,9 +192,9 @@ installed = mkInstalled (Just "0.3.0") [] case pendingChainFor am installed of Just plan -> do - plan.planSteps `shouldBe` [] - plan.planFrom `shouldBe` parseV "0.1.3" - plan.planTo `shouldBe` parseV "0.3.0" + (plan ^. #steps) `shouldBe` [] + (plan ^. #from) `shouldBe` parseV "0.1.3" + (plan ^. #to) `shouldBe` parseV "0.3.0" Nothing -> expectationFailure "expected Just plan with empty steps" it "[] vs [orphanEdge] both yield empty-steps plans (window walker)" $ do @@ -186,89 +207,65 @@ mkInstalled (Just "0.3.0") [Migration "0.5.0" "0.6.0" []] case (pendingChainFor am emptyInstalled, pendingChainFor am orphanInstalled) of (Just pEmpty, Just pOrphan) -> do - pEmpty.planSteps `shouldBe` [] - pOrphan.planSteps `shouldBe` [] - pEmpty.planFrom `shouldBe` pOrphan.planFrom - pEmpty.planTo `shouldBe` pOrphan.planTo + (pEmpty ^. #steps) `shouldBe` [] + (pOrphan ^. #steps) `shouldBe` [] + (pEmpty ^. #from) `shouldBe` (pOrphan ^. #from) + (pEmpty ^. #to) `shouldBe` (pOrphan ^. #to) other -> expectationFailure ("expected two Just plans, got: " <> show other) describe "detectPendingMigrations" $ do it "with Nothing filter, surfaces every applied module's pending plan" $ - withSystemTempDirectory "seihou-pending-detect" $ \dir -> do - let aDir = dir "demo-a" - bDir = dir "demo-b" - writeInstalledModule aDir "demo-a" "2.0.0" moveOldToNewLit - writeInstalledModule bDir "demo-b" "2.0.0" moveOldToNewLit + withProjectModules [("demo-a", "2.0.0", moveOldToNewLit), ("demo-b", "2.0.0", moveOldToNewLit)] $ do let manifest = - (emptyManifest fixedTime) - { modules = - [ mkAppliedAt "demo-a" aDir (Just "1.0.0"), - mkAppliedAt "demo-b" bDir (Just "1.0.0") - ], - files = Map.empty - } + ( (emptyManifest fixedTime) + & #modules .~ [mkAppliedAt "demo-a" (Just "1.0.0"), mkAppliedAt "demo-b" (Just "1.0.0")] + & #files .~ Map.empty + ) result <- detectPendingMigrations manifest Nothing map fst result `shouldMatchList` [ModuleName "demo-a", ModuleName "demo-b"] it "with a Just filter, restricts detection to the named modules" $ - withSystemTempDirectory "seihou-pending-detect" $ \dir -> do - let aDir = dir "demo-a" - bDir = dir "demo-b" - writeInstalledModule aDir "demo-a" "2.0.0" moveOldToNewLit - writeInstalledModule bDir "demo-b" "2.0.0" moveOldToNewLit + withProjectModules [("demo-a", "2.0.0", moveOldToNewLit), ("demo-b", "2.0.0", moveOldToNewLit)] $ do let manifest = - (emptyManifest fixedTime) - { modules = - [ mkAppliedAt "demo-a" aDir (Just "1.0.0"), - mkAppliedAt "demo-b" bDir (Just "1.0.0") - ], - files = Map.empty - } + ( (emptyManifest fixedTime) + & #modules .~ [mkAppliedAt "demo-a" (Just "1.0.0"), mkAppliedAt "demo-b" (Just "1.0.0")] + & #files .~ Map.empty + ) result <- detectPendingMigrations manifest (Just (Set.singleton (ModuleName "demo-a"))) map fst result `shouldBe` [ModuleName "demo-a"] - it "skips modules whose installed copy has no module.dhall" $ - withSystemTempDirectory "seihou-pending-detect" $ \dir -> do - let bogus = dir "missing-installed" + it "skips a module whose recorded origin does not resolve here" $ + withProjectModules [] $ do let manifest = - (emptyManifest fixedTime) - { modules = [mkAppliedAt "demo" bogus (Just "1.0.0")], - files = Map.empty - } + ( (emptyManifest fixedTime) + & #modules .~ [mkAppliedAt "demo" (Just "1.0.0")] + & #files .~ Map.empty + ) result <- detectPendingMigrations manifest Nothing result `shouldBe` [] it "skips modules with no pending chain (manifest already at installed version)" $ - withSystemTempDirectory "seihou-pending-detect" $ \dir -> do - let modDir = dir "demo" - writeInstalledModule modDir "demo" "1.0.0" emptyMigrationsLit + withProjectModules [("demo", "1.0.0", emptyMigrationsLit)] $ do let manifest = - (emptyManifest fixedTime) - { modules = [mkAppliedAt "demo" modDir (Just "1.0.0")], - files = Map.empty - } + ( (emptyManifest fixedTime) + & #modules .~ [mkAppliedAt "demo" (Just "1.0.0")] + & #files .~ Map.empty + ) result <- detectPendingMigrations manifest Nothing result `shouldBe` [] it "with a filter selecting only no-chain modules, returns empty" $ - withSystemTempDirectory "seihou-pending-detect" $ \dir -> do - let withChain = dir "with-chain" - noChain = dir "no-chain" - writeInstalledModule withChain "with-chain" "2.0.0" moveOldToNewLit - writeInstalledModule noChain "no-chain" "1.0.0" emptyMigrationsLit + withProjectModules [("with-chain", "2.0.0", moveOldToNewLit), ("no-chain", "1.0.0", emptyMigrationsLit)] $ do let manifest = - (emptyManifest fixedTime) - { modules = - [ mkAppliedAt "with-chain" withChain (Just "1.0.0"), - mkAppliedAt "no-chain" noChain (Just "1.0.0") - ], - files = Map.empty - } + ( (emptyManifest fixedTime) + & #modules .~ [mkAppliedAt "with-chain" (Just "1.0.0"), mkAppliedAt "no-chain" (Just "1.0.0")] + & #files .~ Map.empty + ) result <- detectPendingMigrations manifest @@ -279,10 +276,10 @@ it "lists each module's plan summary and the actionable next step" $ do let plan = MigrationPlan - { planModule = "demo", - planFrom = parseV "1.0.0", - planTo = parseV "2.0.0", - planSteps = + { module_ = "demo", + from = parseV "1.0.0", + to = parseV "2.0.0", + steps = [Migration "1.0.0" "2.0.0" [DeleteFile "Setup.hs"]] } msg = formatRefusalMessage [(ModuleName "demo", plan)] @@ -294,10 +291,10 @@ it "reports a 0-step pure version-bump entry without doomed vocabulary" $ do let plan = MigrationPlan - { planModule = "demo", - planFrom = parseV "0.2.0", - planTo = parseV "0.3.0", - planSteps = [] + { module_ = "demo", + from = parseV "0.2.0", + to = parseV "0.3.0", + steps = [] } msg = formatRefusalMessage [(ModuleName "demo", plan)] msg `shouldSatisfy` T.isInfixOf "demo: 0.2.0 -> 0.3.0 (0 step(s))" diff --git a/test/Seihou/CLI/Registry/SyncSpec.hs b/test/Seihou/CLI/Registry/SyncSpec.hs --- a/test/Seihou/CLI/Registry/SyncSpec.hs +++ b/test/Seihou/CLI/Registry/SyncSpec.hs @@ -2,6 +2,8 @@ module Seihou.CLI.Registry.SyncSpec (tests) where +import Control.Lens ((^.)) +import Data.Generics.Labels () import Data.Text (Text) import Data.Text qualified as T import Data.Text.IO qualified as TIO @@ -38,9 +40,9 @@ outcome <- runSync SyncVersionsOpts - { syncVersionsDir = Just dir, - syncVersionsDryRun = False, - syncVersionsCheck = False + { dir = Just dir, + dryRun = False, + check = False } case outcome of SyncFailure msg -> @@ -50,7 +52,7 @@ case reloaded of Left err -> expectationFailure ("failed to reload: " <> show err) Right reg -> do - map (.version) reg.modules `shouldBe` [Just "2.0.0", Just "2.0.0"] + map (^. #version) (reg ^. #modules) `shouldBe` [Just "2.0.0", Just "2.0.0"] it "leaves the file untouched under --dry-run" $ do withFixture $ \dir -> do @@ -58,9 +60,9 @@ outcome <- runSync SyncVersionsOpts - { syncVersionsDir = Just dir, - syncVersionsDryRun = True, - syncVersionsCheck = False + { dir = Just dir, + dryRun = True, + check = False } case outcome of SyncSuccess _ WouldWrite -> pure () @@ -74,14 +76,14 @@ outcome <- runSync SyncVersionsOpts - { syncVersionsDir = Just dir, - syncVersionsDryRun = False, - syncVersionsCheck = True + { dir = Just dir, + dryRun = False, + check = True } case outcome of SyncSuccess report Checked -> do -- first entry missing, second entry stale - map (.diffStatus) report.syncDiffs + map (^. #status) (report ^. #diffs) `shouldBe` [SyncMissing, SyncStale "2.0.0"] other -> expectationFailure ("expected Checked, got " <> show other) after <- TIO.readFile (dir "seihou-registry.dhall") @@ -92,9 +94,9 @@ outcome <- runSync SyncVersionsOpts - { syncVersionsDir = Just dir, - syncVersionsDryRun = False, - syncVersionsCheck = False + { dir = Just dir, + dryRun = False, + check = False } case outcome of SyncFailure _ -> pure () @@ -105,9 +107,9 @@ outcome <- runSync SyncVersionsOpts - { syncVersionsDir = Just dir, - syncVersionsDryRun = False, - syncVersionsCheck = False + { dir = Just dir, + dryRun = False, + check = False } case outcome of SyncFailure msg -> expectationFailure ("expected success, got: " <> T.unpack msg) @@ -115,16 +117,16 @@ reloaded <- evalRegistryFromFile (dir "seihou-registry.dhall") case reloaded of Left err -> expectationFailure ("failed to reload: " <> show err) - Right reg -> map (.version) reg.blueprints `shouldBe` [Just "0.2.0"] + Right reg -> map (^. #version) (reg ^. #blueprints) `shouldBe` [Just "0.2.0"] it "renderSyncReport prefixes blueprint rows with blueprints." $ do withBlueprintFixture $ \dir -> do outcome <- runSync SyncVersionsOpts - { syncVersionsDir = Just dir, - syncVersionsDryRun = True, - syncVersionsCheck = False + { dir = Just dir, + dryRun = True, + check = False } case outcome of SyncSuccess report _ -> do @@ -137,9 +139,9 @@ outcome <- runSync SyncVersionsOpts - { syncVersionsDir = Just dir, - syncVersionsDryRun = False, - syncVersionsCheck = False + { dir = Just dir, + dryRun = False, + check = False } case outcome of SyncFailure msg -> expectationFailure ("expected success, got: " <> T.unpack msg) @@ -147,16 +149,16 @@ reloaded <- evalRegistryFromFile (dir "seihou-registry.dhall") case reloaded of Left err -> expectationFailure ("failed to reload: " <> show err) - Right reg -> map (.version) reg.prompts `shouldBe` [Just "0.2.0"] + Right reg -> map (^. #version) (reg ^. #prompts) `shouldBe` [Just "0.2.0"] it "renderSyncReport prefixes prompt rows with prompts." $ do withPromptFixture $ \dir -> do outcome <- runSync SyncVersionsOpts - { syncVersionsDir = Just dir, - syncVersionsDryRun = True, - syncVersionsCheck = False + { dir = Just dir, + dryRun = True, + check = False } case outcome of SyncSuccess report _ -> do diff --git a/test/Seihou/CLI/Registry/ValidateSpec.hs b/test/Seihou/CLI/Registry/ValidateSpec.hs --- a/test/Seihou/CLI/Registry/ValidateSpec.hs +++ b/test/Seihou/CLI/Registry/ValidateSpec.hs @@ -2,6 +2,8 @@ module Seihou.CLI.Registry.ValidateSpec (tests) where +import Control.Lens ((^.)) +import Data.Generics.Labels () import Data.Text (Text) import Data.Text qualified as T import Data.Text.IO qualified as TIO @@ -35,9 +37,9 @@ outcome <- runValidate (ValidateRegistryOpts (Just dir)) case outcome of ValidateOk r -> do - r.reportIssues `shouldBe` [] - r.reportModuleCount `shouldBe` 2 - r.reportRecipeCount `shouldBe` 0 + (r ^. #issues) `shouldBe` [] + (r ^. #moduleCount) `shouldBe` 2 + (r ^. #recipeCount) `shouldBe` 0 other -> expectationFailure ("expected ValidateOk, got " <> show other) it "flags both stale and missing version entries" $ do @@ -46,8 +48,8 @@ case outcome of ValidateOk r -> do let statuses = - [ d.diffStatus - | VersionMismatch d <- r.reportIssues + [ d ^. #status + | VersionMismatch d <- r ^. #issues ] statuses `shouldBe` [SyncMissing, SyncStale "2.0.0"] other -> expectationFailure ("unexpected outcome: " <> show other) @@ -59,7 +61,7 @@ ValidateOk r -> do let structurals = [ msg - | StructuralError msg <- r.reportIssues + | StructuralError msg <- r ^. #issues ] any ("missing module.dhall" `T.isInfixOf`) structurals `shouldBe` True diff --git a/test/Seihou/CLI/SavePromptedSpec.hs b/test/Seihou/CLI/SavePromptedSpec.hs --- a/test/Seihou/CLI/SavePromptedSpec.hs +++ b/test/Seihou/CLI/SavePromptedSpec.hs @@ -1,5 +1,7 @@ module Seihou.CLI.SavePromptedSpec (tests) where +import Control.Lens ((^.)) +import Data.Generics.Labels () import Data.Map.Strict qualified as Map import Data.Text (Text) import Data.Text qualified as T @@ -118,7 +120,7 @@ runConsolePure ["y"] $ runConfigWriterPure emptyConfigWriterState $ offerSavePrompted Nothing True entries - cwState.cwLocal `shouldBe` Map.fromList [("project.name", "my-app"), ("license", "MIT")] + (cwState ^. #local) `shouldBe` Map.fromList [("project.name", "my-app"), ("license", "MIT")] it "does not save when user declines with 'n'" $ do (((), cwState), _consoleSt) <- @@ -126,7 +128,7 @@ runConsolePure ["n"] $ runConfigWriterPure emptyConfigWriterState $ offerSavePrompted Nothing True entries - cwState.cwLocal `shouldBe` Map.empty + (cwState ^. #local) `shouldBe` Map.empty it "saves without asking when --save-prompted (Just True)" $ do (((), cwState), consoleSt) <- @@ -134,9 +136,9 @@ runConsolePure [] $ runConfigWriterPure emptyConfigWriterState $ offerSavePrompted (Just True) True entries - cwState.cwLocal `shouldBe` Map.fromList [("project.name", "my-app"), ("license", "MIT")] + (cwState ^. #local) `shouldBe` Map.fromList [("project.name", "my-app"), ("license", "MIT")] -- Should not contain the confirmation prompt - any (T.isInfixOf "Save prompted values") consoleSt.consoleOutputs `shouldBe` False + any (T.isInfixOf "Save prompted values") (consoleSt ^. #outputs) `shouldBe` False it "skips entirely when --no-save-prompted (Just False)" $ do (((), cwState), consoleSt) <- @@ -144,8 +146,8 @@ runConsolePure [] $ runConfigWriterPure emptyConfigWriterState $ offerSavePrompted (Just False) True entries - cwState.cwLocal `shouldBe` Map.empty - consoleSt.consoleOutputs `shouldBe` [] + (cwState ^. #local) `shouldBe` Map.empty + (consoleSt ^. #outputs) `shouldBe` [] it "skips in non-interactive mode when no flag given" $ do (((), cwState), _consoleSt) <- @@ -153,7 +155,7 @@ runConsolePure [] $ runConfigWriterPure emptyConfigWriterState $ offerSavePrompted Nothing False entries - cwState.cwLocal `shouldBe` Map.empty + (cwState ^. #local) `shouldBe` Map.empty it "shows overwrite note for existing values" $ do let entriesWithOverwrite = @@ -164,7 +166,7 @@ runConsolePure ["y"] $ runConfigWriterPure emptyConfigWriterState $ offerSavePrompted Nothing True entriesWithOverwrite - any (T.isInfixOf "overwrites current") consoleSt.consoleOutputs `shouldBe` True + any (T.isInfixOf "overwrites current") (consoleSt ^. #outputs) `shouldBe` True it "does nothing when entries list is empty" $ do (((), cwState), consoleSt) <- @@ -172,8 +174,8 @@ runConsolePure [] $ runConfigWriterPure emptyConfigWriterState $ offerSavePrompted Nothing True [] - cwState.cwLocal `shouldBe` Map.empty - consoleSt.consoleOutputs `shouldBe` [] + (cwState ^. #local) `shouldBe` Map.empty + (consoleSt ^. #outputs) `shouldBe` [] it "displays confirmation message after saving" $ do (((), _cwState), consoleSt) <- @@ -181,4 +183,4 @@ runConsolePure ["y"] $ runConfigWriterPure emptyConfigWriterState $ offerSavePrompted Nothing True entries - any (T.isInfixOf "Saved 2 value(s)") consoleSt.consoleOutputs `shouldBe` True + any (T.isInfixOf "Saved 2 value(s)") (consoleSt ^. #outputs) `shouldBe` True diff --git a/test/Seihou/CLI/SeihouBinary.hs b/test/Seihou/CLI/SeihouBinary.hs new file mode 100644 --- /dev/null +++ b/test/Seihou/CLI/SeihouBinary.hs @@ -0,0 +1,52 @@ +-- | Locating the @seihou@ executable the end-to-end tests shell out to. +-- +-- The test suite declares @build-tool-depends: seihou-cli:seihou@, and cabal +-- used to satisfy that by symlinking the executable next to the test binary at +-- @\\/..\/seihou\/seihou@. Cabal 3.16 no longer creates that +-- symlink, so every end-to-end spec that assumed it went looking for a path +-- that does not exist. We probe the layouts cabal actually produces and report +-- every directory searched when none of them holds the binary, rather than +-- surfacing a bare @posix_spawnp: does not exist@ from deep inside a spec. +-- +-- Deliberately absent: a @PATH@ lookup. Falling back to whatever @seihou@ the +-- developer has installed would silently test a different build than the one +-- under test, which is worse than failing. +module Seihou.CLI.SeihouBinary + ( seihouBinary, + ) +where + +import Control.Monad (filterM) +import Data.List (intercalate) +import System.Directory (doesFileExist) +import System.Environment (getExecutablePath) +import System.FilePath (takeDirectory, ()) + +-- | The @seihou@ executable built alongside this test suite. +seihouBinary :: IO FilePath +seihouBinary = do + candidates <- seihouBinaryCandidates + found <- filterM doesFileExist candidates + case found of + (binary : _) -> pure binary + [] -> + fail $ + "Could not find the seihou executable built alongside this test suite.\n" + <> "Searched:\n" + <> intercalate "\n" (map (" " <>) candidates) + <> "\nBuild it with 'cabal build seihou-cli:seihou' and rerun." + +-- | The places cabal has been observed to put the executable, most specific +-- first: the @build-tool-depends@ symlink beside the test binary, then the +-- executable component's own build directory under the same package. +seihouBinaryCandidates :: IO [FilePath] +seihouBinaryCandidates = do + testBinary <- getExecutablePath + -- @\/t/seihou-cli-test/build@ + let testBuildDir = takeDirectory (takeDirectory testBinary) + -- @\@, three levels above @build@ + packageDir = takeDirectory (takeDirectory (takeDirectory testBuildDir)) + pure + [ testBuildDir "seihou" "seihou", + packageDir "x" "seihou" "build" "seihou" "seihou" + ] diff --git a/test/Seihou/CLI/SharedManifestE2ESpec.hs b/test/Seihou/CLI/SharedManifestE2ESpec.hs new file mode 100644 --- /dev/null +++ b/test/Seihou/CLI/SharedManifestE2ESpec.hs @@ -0,0 +1,172 @@ +-- | The initiative's headline claim, driven end to end through the real +-- binary: two developers can share @.seihou\/manifest.json@ safely. +-- +-- Four mechanisms have to hold together for that to be true — the manifest +-- records portable origins, every command resolves them locally, seihou +-- refuses to generate from an artifact older than the manifest records, and a +-- manifest written by an older seihou can be converted. Each has its own unit +-- tests. This spec is what stops them from drifting apart. +module Seihou.CLI.SharedManifestE2ESpec (tests) where + +import Control.Lens ((^.)) +import Data.ByteString.Lazy qualified as LBS +import Data.Generics.Labels () +import Data.Text (Text) +import Data.Text qualified as T +import Data.Text.IO qualified as TIO +import Seihou.CLI.TwoDeveloperFixture + ( TwoDeveloperFixture (..), + gitCommitAll, + gitStatus, + installModuleVersion, + moduleSourceUrl, + prepareTwoDeveloperFixture, + resetWorkingTree, + runSeihouAs, + seihouBinary, + ) +import System.Exit (ExitCode (..)) +import System.FilePath (()) +import System.IO.Temp (withSystemTempDirectory) +import Test.Hspec +import Test.Tasty +import Test.Tasty.Hspec (testSpec) + +tests :: IO TestTree +tests = testSpec "shared manifest across developers" spec + +spec :: Spec +spec = do + it "records a portable manifest and refuses a stale developer" $ + withGeneratedProject "seihou-shared-refuse" $ \binary fixture -> do + manifest <- TIO.readFile (fixture ^. #manifestPath) + manifest `shouldSatisfy` T.isInfixOf "\"kind\":\"remote\"" + manifest `shouldSatisfy` T.isInfixOf moduleSourceUrl + manifest `shouldNotSatisfy` T.isInfixOf (T.pack (fixture ^. #homeA)) + manifest `shouldNotSatisfy` T.isInfixOf (T.pack (fixture ^. #homeB)) + + (code, out, err) <- runSeihouAs binary fixture (fixture ^. #homeB) ["run", "demo"] + code `shouldSatisfy` (/= ExitSuccess) + let reported = out <> err + reported `shouldSatisfy` T.isInfixOf "2.0.0" + reported `shouldSatisfy` T.isInfixOf "1.4.0" + reported `shouldSatisfy` T.isInfixOf "seihou upgrade" + + -- The assertion that matters: an exit code proves the command reported + -- failure, only an unchanged working tree proves it did not write first. + gitStatus fixture `shouldReturn` "" + + it "proceeds under --allow-downgrade and says so" $ + withGeneratedProject "seihou-shared-allow" $ \binary fixture -> do + (code, out, err) <- + runSeihouAs binary fixture (fixture ^. #homeB) ["run", "demo", "--allow-downgrade"] + expectSuccess "developer B's deliberate downgrade" code out err + + -- A deliberate downgrade must still be visible; silently honouring the + -- flag would hide exactly the change the guard exists to make legible. + let reported = out <> err + reported `shouldSatisfy` T.isInfixOf "2.0.0" + reported `shouldSatisfy` T.isInfixOf "1.4.0" + + manifest <- TIO.readFile (fixture ^. #manifestPath) + manifest `shouldSatisfy` T.isInfixOf "\"version\":\"1.4.0\"" + TIO.readFile (fixture ^. #projectFile) `shouldReturnSatisfy` T.isInfixOf "demo 1.4.0" + + it "succeeds once the stale developer upgrades locally" $ + withGeneratedProject "seihou-shared-upgrade" $ \binary fixture -> do + resetWorkingTree fixture + installModuleVersion (fixture ^. #homeB) (fixture ^. #moduleName) "2.0.0" + + generated <- TIO.readFile (fixture ^. #projectFile) + (code, out, err) <- runSeihouAs binary fixture (fixture ^. #homeB) ["run", "demo"] + expectSuccess "developer B's run after upgrading" code out err + + -- Regenerating from the same version with the same inputs produces the + -- same bytes, so the generated file is untouched. The manifest is + -- rewritten regardless, because every run stamps a fresh 'generatedAt' + -- and 'appliedAt' — that is the only path git reports. + status <- gitStatus fixture + map T.strip (T.lines status) `shouldBe` ["M .seihou/manifest.json"] + TIO.readFile (fixture ^. #projectFile) `shouldReturn` generated + manifest <- TIO.readFile (fixture ^. #manifestPath) + manifest `shouldSatisfy` T.isInfixOf "\"version\":\"2.0.0\"" + + it "rejects, upgrades, and then accepts a legacy manifest" $ + withGeneratedProject "seihou-shared-legacy" $ \binary fixture -> do + TIO.writeFile (fixture ^. #manifestPath) legacyManifest + gitCommitAll fixture "test: commit a manifest from an older seihou" + + (statusCode, statusOut, statusErr) <- runSeihouAs binary fixture (fixture ^. #homeB) ["status"] + statusCode `shouldSatisfy` (/= ExitSuccess) + let rejected = statusOut <> statusErr + rejected `shouldSatisfy` T.isInfixOf "schema version 5" + rejected `shouldSatisfy` T.isInfixOf "seihou manifest upgrade" + + before <- LBS.readFile (fixture ^. #manifestPath) + (dryCode, dryOut, dryErr) <- + runSeihouAs binary fixture (fixture ^. #homeB) ["manifest", "upgrade", "--dry-run"] + expectSuccess "the dry-run upgrade" dryCode dryOut dryErr + dryOut `shouldSatisfy` T.isInfixOf foreignPath + dryOut `shouldSatisfy` T.isInfixOf ("remote " <> moduleSourceUrl) + LBS.readFile (fixture ^. #manifestPath) `shouldReturn` before + + (upgradeCode, upgradeOut, upgradeErr) <- + runSeihouAs binary fixture (fixture ^. #homeB) ["manifest", "upgrade"] + expectSuccess "the upgrade" upgradeCode upgradeOut upgradeErr + manifest <- TIO.readFile (fixture ^. #manifestPath) + manifest `shouldSatisfy` T.isInfixOf "\"kind\":\"remote\"" + manifest `shouldNotSatisfy` T.isInfixOf "someone-else" + + (afterCode, afterOut, afterErr) <- runSeihouAs binary fixture (fixture ^. #homeB) ["status"] + expectSuccess "status after the upgrade" afterCode afterOut afterErr + +-- | Developer A, on 2.0.0, generates the project and commits. Developer B has +-- 1.4.0 installed. Every scenario starts here. +withGeneratedProject :: String -> (FilePath -> TwoDeveloperFixture -> IO ()) -> IO () +withGeneratedProject label action = + withSystemTempDirectory label $ \root -> do + fixture <- prepareTwoDeveloperFixture root "2.0.0" "1.4.0" + binary <- seihouBinary + (code, out, err) <- runSeihouAs binary fixture (fixture ^. #homeA) ["run", "demo"] + expectSuccess "developer A's run" code out err + gitCommitAll fixture "feat: apply demo 2.0.0" + action binary fixture + +-- | The absolute path a third machine — neither developer's — recorded, the +-- kind of value a schema-5 manifest is full of. +foreignPath :: Text +foreignPath = "/Users/someone-else/.config/seihou/installed/demo" + +-- | A manifest as a released seihou wrote them: schema 5, with the module's +-- source recorded as somebody else's absolute path. +-- +-- It records 1.4.0, which is what developer B has installed, so the upgrade's +-- own guard is satisfied and the scenario exercises the conversion rather than +-- the refusal. +legacyManifest :: Text +legacyManifest = + T.concat + [ "{\"version\":5", + ",\"generatedAt\":\"2026-07-01T12:00:00Z\"", + ",\"modules\":[{\"name\":\"demo\",\"source\":\"", + foreignPath, + "\",\"version\":\"1.4.0\",\"appliedAt\":\"2026-07-01T12:00:00Z\"}]", + ",\"variables\":{},\"files\":{},\"applications\":[],\"blueprintMigrations\":[]}" + ] + +expectSuccess :: String -> ExitCode -> Text -> Text -> Expectation +expectSuccess label code out err = case code of + ExitSuccess -> pure () + ExitFailure status -> + expectationFailure + ( label + <> " exited " + <> show status + <> "\nstdout:\n" + <> T.unpack out + <> "\nstderr:\n" + <> T.unpack err + ) + +shouldReturnSatisfy :: IO Text -> (Text -> Bool) -> Expectation +shouldReturnSatisfy action predicate = action >>= (`shouldSatisfy` predicate) diff --git a/test/Seihou/CLI/StatusSpec.hs b/test/Seihou/CLI/StatusSpec.hs --- a/test/Seihou/CLI/StatusSpec.hs +++ b/test/Seihou/CLI/StatusSpec.hs @@ -1,10 +1,15 @@ module Seihou.CLI.StatusSpec (tests) where +import Control.Lens (to, (&), (.~)) import Data.Map.Strict qualified as Map import Data.Text (Text) import Data.Text qualified as T import Data.Time (UTCTime, defaultTimeLocale, parseTimeOrError) -import Seihou.CLI.StatusRender (formatStatus) +import Seihou.CLI.ManifestGuard + ( ArtifactCheck (..), + ArtifactVerdict (..), + ) +import Seihou.CLI.StatusRender (formatArtifactChecks, formatStatus) import Seihou.CLI.VersionCompare ( OutdatedEntry (..), OutdatedStatus (..), @@ -22,6 +27,7 @@ AppliedInstanceState (..), AppliedModule (..), AppliedTarget (..), + ArtifactOrigin (..), Manifest (..), ModuleName (..), RecipeName (..), @@ -49,7 +55,7 @@ AppliedModule { name = ModuleName name, parentVars = emptyParentVars, - source = "/installed/" <> T.unpack name, + origin = LocalOrigin name, moduleVersion = mver, appliedAt = fixedTime, removal = Nothing @@ -58,16 +64,15 @@ mkManifest :: [AppliedModule] -> Manifest mkManifest mods = (emptyManifest fixedTime) - { modules = mods, - files = Map.empty - } + & #modules .~ mods + & #files .~ Map.empty mkApplication :: Text -> [Text] -> AppliedComposition mkApplication target modules = AppliedComposition { applicationId = ApplicationId ("app-" <> target), target = AppliedRecipeTarget (RecipeName target), - targetSource = "/installed/" <> T.unpack target, + targetOrigin = LocalOrigin target, targetVersion = Just "1.0.0", additionalModules = [], namespace = Nothing, @@ -81,7 +86,7 @@ AppliedInstanceState { name = ModuleName name, parentVars = emptyParentVars, - source = "/installed/" <> T.unpack name, + origin = LocalOrigin name, moduleVersion = Just "1.0.0", resolvedVars = Map.empty } @@ -90,10 +95,10 @@ mkPlan :: Text -> Text -> Text -> Int -> MigrationPlan mkPlan modName from to nSteps = MigrationPlan - { planModule = modName, - planFrom = parseV from, - planTo = parseV to, - planSteps = replicate nSteps (Migration from to [DeleteFile "x"]) + { module_ = modName, + from = parseV from, + to = parseV to, + steps = replicate nSteps (Migration from to [DeleteFile "x"]) } parseV :: Text -> Seihou.Core.Version.Version @@ -129,7 +134,7 @@ } withManifestBlueprint :: Maybe AppliedBlueprint -> Manifest -> Manifest -withManifestBlueprint mb m = m {blueprint = mb} +withManifestBlueprint mb m = m & #blueprint .~ mb mkBlueprintMigrationReceipt :: Text -> Maybe Text -> Text -> Text -> AppliedBlueprintMigration mkBlueprintMigrationReceipt blueprintName artifactVersion fromVersion toVersion = @@ -213,7 +218,7 @@ it "renders blueprint name, artifact version, exact edge, and timestamp" $ do let receipt = mkBlueprintMigrationReceipt "payments" (Just "0.4.0") "1.0.0" "2.0.0" - manifest = (mkManifest []) {blueprintMigrations = [receipt]} + manifest = ((mkManifest []) & #blueprintMigrations .~ [receipt]) out = formatStatus False manifest [] Nothing [] out `shouldSatisfy` T.isInfixOf "Blueprint migrations:" out `shouldSatisfy` T.isInfixOf "payments v0.4.0: 1.0.0 -> 2.0.0" @@ -267,7 +272,7 @@ -- Master-plan live-tree fixture: manifest=0.1.0, installed=0.3.0, -- declared [0.1.0 → 0.2.0]. The chain reaches 0.2 via ops; the - -- supplied target is 0.3, so planTo = 0.3. Status surfaces the + -- supplied target is 0.3, so to = 0.3. Status surfaces the -- single in-window step and points at `seihou update demo` as the -- remediation. it "partial-cover plan: chain reaches an intermediate version, target is the user's installed copy" $ do @@ -293,10 +298,10 @@ manifest = mkManifest [am] plan = MigrationPlan - { planModule = "demo", - planFrom = parseV "0.2.0", - planTo = parseV "0.3.0", - planSteps = [] + { module_ = "demo", + from = parseV "0.2.0", + to = parseV "0.3.0", + steps = [] } out = formatStatus False manifest [] Nothing [(ModuleName "demo", plan)] out `shouldSatisfy` T.isInfixOf "Pending migration: 0.2.0 -> 0.3.0 (0 step(s))" @@ -311,9 +316,9 @@ it "deduplicates repeated instances into one recipe application action" $ do let duplicate = mkApplied "demo" (Just "1.0.0") manifest = - (mkManifest [duplicate, duplicate]) - { applications = [mkApplication "stack" ["demo", "demo"]] - } + ( (mkManifest [duplicate, duplicate]) + & #applications .~ [mkApplication "stack" ["demo", "demo"]] + ) plan = mkPlan "demo" "1.0.0" "2.0.0" 1 out = formatStatus False manifest [] Nothing [(ModuleName "demo", plan)] recommendationLines = filter (== " seihou update stack") (T.lines out) @@ -324,12 +329,9 @@ it "recommends each affected application plus the whole-project update" $ do let shared = mkApplied "shared" (Just "1.0.0") manifest = - (mkManifest [shared]) - { applications = - [ mkApplication "stack-one" ["shared"], - mkApplication "stack-two" ["shared"] - ] - } + ( (mkManifest [shared]) + & #applications .~ [mkApplication "stack-one" ["shared"], mkApplication "stack-two" ["shared"]] + ) plan = mkPlan "shared" "1.0.0" "2.0.0" 1 out = formatStatus False manifest [] Nothing [(ModuleName "shared", plan)] recommendationLines = dropWhile (/= "Recommended actions:") (T.lines out) @@ -346,3 +348,24 @@ plan = mkPlan "demo" "1.0.0" "2.0.0" 1 out = formatStatus False manifest [] Nothing [(ModuleName "demo", plan)] T.count "seihou update demo" out `shouldBe` 2 + + it "reports a stale artifact without failing, and names the remedy" $ do + let check = + ArtifactCheck + { name = ModuleName "demo", + origin = RemoteOrigin "https://example.com/demo.git" "demo" Nothing, + verdict = ArtifactStale "2.0.0" "1.4.0" + } + out = formatArtifactChecks False [check] + out `shouldSatisfy` T.isInfixOf "Artifacts that differ from what this project records:" + out `shouldSatisfy` T.isInfixOf "seihou upgrade demo" + + it "prints nothing at all when every artifact is healthy" $ do + let check = + ArtifactCheck + { name = ModuleName "demo", + origin = RemoteOrigin "https://example.com/demo.git" "demo" Nothing, + verdict = ArtifactOk + } + formatArtifactChecks False [check] `shouldBe` "" + formatArtifactChecks False [] `shouldBe` "" diff --git a/test/Seihou/CLI/TwoDeveloperFixture.hs b/test/Seihou/CLI/TwoDeveloperFixture.hs new file mode 100644 --- /dev/null +++ b/test/Seihou/CLI/TwoDeveloperFixture.hs @@ -0,0 +1,163 @@ +-- | One project shared by two simulated developers, each with their own +-- seihou configuration root. +-- +-- Both developers work in the same @projectRoot@ — that is the point, since it +-- models a git checkout they both have. What differs is @homeA@ and @homeB@, +-- each of which becomes @XDG_CONFIG_HOME@ for that developer's invocations, so +-- each has an independent @\\/seihou\/installed\/@ and +-- @\\/seihou\/modules\/@. That single variable is the whole difference +-- between two developers as far as seihou is concerned. +module Seihou.CLI.TwoDeveloperFixture + ( TwoDeveloperFixture (..), + prepareTwoDeveloperFixture, + installModuleVersion, + moduleSourceUrl, + seihouBinary, + runSeihouAs, + gitStatus, + gitCommitAll, + resetWorkingTree, + ) +where + +import Control.Lens ((^.)) +import Data.Generics.Labels () +import Data.Text (Text) +import Data.Text qualified as T +import Data.Text.IO qualified as TIO +import GHC.Generics (Generic) +import Seihou.CLI.SeihouBinary (seihouBinary) +import System.Directory (createDirectoryIfMissing) +import System.Environment (getEnvironment) +import System.Exit (ExitCode (..)) +import System.FilePath (()) +import System.Process (CreateProcess (..), callProcess, proc, readCreateProcessWithExitCode, readProcess) + +data TwoDeveloperFixture = TwoDeveloperFixture + { projectRoot :: !FilePath, + manifestPath :: !FilePath, + projectFile :: !FilePath, + homeA :: !FilePath, + homeB :: !FilePath, + moduleName :: !Text + } + deriving stock (Eq, Show, Generic) + +-- | The URL both developers' installed copies record as their upstream. +-- +-- Nothing is ever fetched from it. It exists so the two copies are recognisably +-- the *same* artifact — which is what lets the guard compare their versions +-- rather than reporting an origin mismatch. +moduleSourceUrl :: Text +moduleSourceUrl = "https://example.com/demo-modules.git" + +-- | Build the fixture under @root@. +-- +-- Installs @demo@ at @versionA@ into developer A's configuration root and at +-- @versionB@ into developer B's, both carrying the same +-- @.seihou-origin.json@ source URL, and initialises @projectRoot@ as a git +-- repository with an initial commit so working-tree assertions are meaningful. +prepareTwoDeveloperFixture :: FilePath -> Text -> Text -> IO TwoDeveloperFixture +prepareTwoDeveloperFixture root versionA versionB = do + let projectRoot = root "project" + fixture = + TwoDeveloperFixture + { projectRoot = projectRoot, + manifestPath = projectRoot ".seihou" "manifest.json", + projectFile = projectRoot "README.md", + homeA = root "home-a", + homeB = root "home-b", + moduleName = "demo" + } + createDirectoryIfMissing True projectRoot + TIO.writeFile (projectRoot "PROJECT.md") "a project two developers share\n" + installModuleVersion (fixture ^. #homeA) (fixture ^. #moduleName) versionA + installModuleVersion (fixture ^. #homeB) (fixture ^. #moduleName) versionB + callProcess "git" ["-C", projectRoot, "init", "-q"] + callProcess "git" ["-C", projectRoot, "config", "user.name", "Seihou Test"] + callProcess "git" ["-C", projectRoot, "config", "user.email", "test@example.com"] + gitCommitAll fixture "test: seed the shared project" + pure fixture + +-- | Install one version of a module into a developer's configuration root, +-- replacing whatever was there. Mirrors what @seihou install@ lays down: +-- the module directory, its template files, and the @.seihou-origin.json@ +-- recording where it came from. +installModuleVersion :: FilePath -> Text -> Text -> IO () +installModuleVersion home name version = do + let installed = home "seihou" "installed" T.unpack name + createDirectoryIfMissing True (installed "files") + TIO.writeFile (installed "module.dhall") (moduleDhall name version) + TIO.writeFile (installed "files" "README.tmpl") (readmeTemplate version) + TIO.writeFile + (installed ".seihou-origin.json") + ( "{\"sourceUrl\":\"" + <> moduleSourceUrl + <> "\",\"repoName\":\"demo-modules\",\"version\":\"" + <> version + <> "\",\"installedAt\":\"2026-07-01T00:00:00Z\",\"tags\":[]}" + ) + +-- | The generated file names its version, so a downgrade is visible on disk +-- and not only in the manifest. +readmeTemplate :: Text -> Text +readmeTemplate version = "# {{project.name}}\n\ngenerated by demo " <> version <> "\n" + +-- | A module that declares one defaulted variable and generates one file. +-- +-- Copied from @moduleDhallWithTemplate@ in +-- "Seihou.CLI.UpdateSpec" so the schema shape stays in step with the rest of +-- the suite. No prompts and no commands: this fixture drives the real binary +-- non-interactively. +moduleDhall :: Text -> Text -> Text +moduleDhall name version = + T.unlines + [ "{ name = \"" <> name <> "\"", + ", version = Some \"" <> version <> "\"", + ", description = None Text", + ", vars = [{ name = \"project.name\", type = \"text\", default = Some \"shared\", description = None Text, required = False, validation = None Text }]", + ", exports = [] : List { var : Text, alias : Optional Text }", + ", prompts = [] : List { var : Text, text : Text, when : Optional Text, choices : Optional (List Text) }", + ", steps = [{ strategy = \"template\", src = \"README.tmpl\", dest = \"README.md\", when = None Text, patch = None Text }]", + ", commands = [] : List { run : Text, workDir : Optional Text, when : Optional Text }", + ", dependencies = [] : List Text", + ", removal = None { steps : List { action : Text, dest : Text, src : Optional Text }, commands : List { run : Text, workDir : Optional Text, when : Optional Text } }", + "}" + ] + +-- | The @seihou@ executable Cabal built for this test run. +-- +-- @build-tool-depends: seihou-cli:seihou@ in the test-suite stanza is what puts +-- it at a predictable place beside the test binary. +-- | Run the real binary in the shared project as one of the two developers. +-- +-- @home@ becomes @XDG_CONFIG_HOME@, which is the only thing that distinguishes +-- them. The override is unconditional so a test can never reach the +-- developer's own @~\/.config\/seihou\/@. +runSeihouAs :: FilePath -> TwoDeveloperFixture -> FilePath -> [String] -> IO (ExitCode, Text, Text) +runSeihouAs binary fixture home args = do + inherited <- getEnvironment + let environment = ("XDG_CONFIG_HOME", home) : filter ((/= "XDG_CONFIG_HOME") . fst) inherited + command = (proc binary args) {cwd = Just (fixture ^. #projectRoot), env = Just environment} + (exitCode, stdoutText, stderrText) <- readCreateProcessWithExitCode command "" + pure (exitCode, T.pack stdoutText, T.pack stderrText) + +-- | @git status --porcelain@ in the shared project. Empty means nothing was +-- written. +gitStatus :: TwoDeveloperFixture -> IO Text +gitStatus fixture = + T.strip . T.pack <$> readProcess "git" ["-C", fixture ^. #projectRoot, "status", "--porcelain"] "" + +-- | Commit everything in the shared project, as a developer would before +-- pushing. +gitCommitAll :: TwoDeveloperFixture -> String -> IO () +gitCommitAll fixture message = do + callProcess "git" ["-C", fixture ^. #projectRoot, "add", "-A"] + callProcess "git" ["-C", fixture ^. #projectRoot, "commit", "-qm", message] + +-- | Throw away every uncommitted change, putting the shared project back to +-- the last commit. +resetWorkingTree :: TwoDeveloperFixture -> IO () +resetWorkingTree fixture = do + callProcess "git" ["-C", fixture ^. #projectRoot, "checkout", "-q", "--", "."] + callProcess "git" ["-C", fixture ^. #projectRoot, "clean", "-qfd"] diff --git a/test/Seihou/CLI/UpdateE2ESpec.hs b/test/Seihou/CLI/UpdateE2ESpec.hs --- a/test/Seihou/CLI/UpdateE2ESpec.hs +++ b/test/Seihou/CLI/UpdateE2ESpec.hs @@ -1,13 +1,15 @@ module Seihou.CLI.UpdateE2ESpec (tests) where +import Control.Lens ((^.)) import Data.ByteString.Lazy qualified as LBS +import Data.Generics.Labels () import Data.Text qualified as T import Data.Text.IO qualified as TIO +import Seihou.CLI.SeihouBinary (seihouBinary) import Seihou.CLI.UpdateSpec (UpdateFixture (..), prepareUpdateFixture) import System.Directory (doesFileExist) -import System.Environment (getEnvironment, getExecutablePath) +import System.Environment (getEnvironment) import System.Exit (ExitCode (..)) -import System.FilePath (takeDirectory, ()) import System.IO.Temp (withSystemTempDirectory) import System.Process (CreateProcess (..), callProcess, proc, readCreateProcessWithExitCode, readProcess) import Test.Hspec @@ -23,7 +25,7 @@ withSystemTempDirectory "seihou-update-executable" $ \root -> do fixture <- prepareUpdateFixture root binary <- seihouBinary - TIO.writeFile fixture.projectFile "hello accepted by-user\nkeep\nv1\n" + TIO.writeFile (fixture ^. #projectFile) "hello accepted by-user\nkeep\nv1\n" (exitCode, stdoutText, stderrText) <- runSeihou binary fixture ["update", "demo", "--json"] case exitCode of ExitSuccess -> pure () @@ -32,44 +34,44 @@ stdoutText `shouldSatisfy` T.isInfixOf "\"skippedUnchanged\":1" stdoutText `shouldNotSatisfy` T.isInfixOf "Apply?" stderrText `shouldNotSatisfy` T.isInfixOf "Apply?" - TIO.readFile fixture.projectFile `shouldReturn` "hello accepted by-user\nkeep\nv2\n" - TIO.readFile (fixture.installedModule <> "/module.dhall") + TIO.readFile (fixture ^. #projectFile) `shouldReturn` "hello accepted by-user\nkeep\nv2\n" + TIO.readFile (fixture ^. #installedModule <> "/module.dhall") `shouldReturnSatisfy` T.isInfixOf "Some \"2.0.0\"" - doesFileExist (fixture.projectRoot <> "/command.log") `shouldReturn` False + doesFileExist (fixture ^. #projectRoot <> "/command.log") `shouldReturn` False (statusExit, statusOut, _) <- runSeihou binary fixture ["status"] statusExit `shouldBe` ExitSuccess statusOut `shouldNotSatisfy` T.isInfixOf "seihou update demo" - afterApply <- LBS.readFile fixture.manifestPath + afterApply <- LBS.readFile (fixture ^. #manifestPath) (noOpExit, noOpOut, noOpErr) <- runSeihou binary fixture ["update", "demo", "--json"] noOpExit `shouldBe` ExitSuccess noOpOut `shouldSatisfy` T.isInfixOf "\"alreadyUpToDate\":true" noOpOut `shouldSatisfy` T.isInfixOf "\"outcome\":\"plan\"" noOpErr `shouldNotSatisfy` T.isInfixOf "Apply?" - LBS.readFile fixture.manifestPath `shouldReturn` afterApply + LBS.readFile (fixture ^. #manifestPath) `shouldReturn` afterApply it "keeps project, manifest, and installed cache byte-identical for JSON dry-run" $ withSystemTempDirectory "seihou-update-executable-dry" $ \root -> do fixture <- prepareUpdateFixture root binary <- seihouBinary - beforeProject <- TIO.readFile fixture.projectFile - beforeManifest <- LBS.readFile fixture.manifestPath - beforeInstalled <- TIO.readFile (fixture.installedModule <> "/module.dhall") + beforeProject <- TIO.readFile (fixture ^. #projectFile) + beforeManifest <- LBS.readFile (fixture ^. #manifestPath) + beforeInstalled <- TIO.readFile (fixture ^. #installedModule <> "/module.dhall") (exitCode, stdoutText, _) <- runSeihou binary fixture ["update", "--dry-run", "--json"] exitCode `shouldBe` ExitSuccess stdoutText `shouldSatisfy` T.isInfixOf "\"outcome\":\"plan\"" - TIO.readFile fixture.projectFile `shouldReturn` beforeProject - LBS.readFile fixture.manifestPath `shouldReturn` beforeManifest - TIO.readFile (fixture.installedModule <> "/module.dhall") `shouldReturn` beforeInstalled + TIO.readFile (fixture ^. #projectFile) `shouldReturn` beforeProject + LBS.readFile (fixture ^. #manifestPath) `shouldReturn` beforeManifest + TIO.readFile (fixture ^. #installedModule <> "/module.dhall") `shouldReturn` beforeInstalled it "commits exactly the managed update paths with a requested Conventional Commit message" $ withSystemTempDirectory "seihou-update-executable-commit" $ \root -> do fixture <- prepareUpdateFixture root binary <- seihouBinary - callProcess "git" ["-C", fixture.projectRoot, "init", "-q"] - callProcess "git" ["-C", fixture.projectRoot, "config", "user.name", "Seihou Test"] - callProcess "git" ["-C", fixture.projectRoot, "config", "user.email", "test@example.com"] - callProcess "git" ["-C", fixture.projectRoot, "add", "."] - callProcess "git" ["-C", fixture.projectRoot, "commit", "-qm", "test: record v1 fixture"] + callProcess "git" ["-C", fixture ^. #projectRoot, "init", "-q"] + callProcess "git" ["-C", fixture ^. #projectRoot, "config", "user.name", "Seihou Test"] + callProcess "git" ["-C", fixture ^. #projectRoot, "config", "user.email", "test@example.com"] + callProcess "git" ["-C", fixture ^. #projectRoot, "add", "."] + callProcess "git" ["-C", fixture ^. #projectRoot, "commit", "-qm", "test: record v1 fixture"] (exitCode, stdoutText, stderrText) <- runSeihou binary @@ -78,16 +80,16 @@ case exitCode of ExitSuccess -> pure () ExitFailure code -> expectationFailure ("update exited " <> show code <> "\nstdout:\n" <> T.unpack stdoutText <> "\nstderr:\n" <> T.unpack stderrText) - subject <- T.strip . T.pack <$> readProcess "git" ["-C", fixture.projectRoot, "log", "-1", "--pretty=%s"] "" + subject <- T.strip . T.pack <$> readProcess "git" ["-C", fixture ^. #projectRoot, "log", "-1", "--pretty=%s"] "" subject `shouldBe` "chore(seihou): update demo" - worktree <- T.strip . T.pack <$> readProcess "git" ["-C", fixture.projectRoot, "status", "--porcelain"] "" + worktree <- T.strip . T.pack <$> readProcess "git" ["-C", fixture ^. #projectRoot, "status", "--porcelain"] "" worktree `shouldBe` "" it "retains an edited orphan under --force" $ withSystemTempDirectory "seihou-update-executable-orphan" $ \root -> do fixture <- prepareUpdateFixture root binary <- seihouBinary - let modulePath = fixture.remote <> "/module.dhall" + let modulePath = fixture ^. #remote <> "/module.dhall" moduleBody <- TIO.readFile modulePath TIO.writeFile modulePath @@ -96,39 +98,39 @@ ", steps = [] : List { strategy : Text, src : Text, dest : Text, when : Optional Text, patch : Optional Text }" moduleBody ) - callProcess "git" ["-C", fixture.remote, "add", "module.dhall"] - callProcess "git" ["-C", fixture.remote, "-c", "user.name=Seihou Test", "-c", "user.email=test@example.com", "commit", "-qm", "remove generated file"] - TIO.writeFile fixture.projectFile "user-owned orphan\n" + callProcess "git" ["-C", fixture ^. #remote, "add", "module.dhall"] + callProcess "git" ["-C", fixture ^. #remote, "-c", "user.name=Seihou Test", "-c", "user.email=test@example.com", "commit", "-qm", "remove generated file"] + TIO.writeFile (fixture ^. #projectFile) "user-owned orphan\n" (exitCode, stdoutText, stderrText) <- runSeihou binary fixture ["update", "demo", "--force", "--json"] case exitCode of ExitSuccess -> pure () ExitFailure code -> expectationFailure ("update exited " <> show code <> "\nstdout:\n" <> T.unpack stdoutText <> "\nstderr:\n" <> T.unpack stderrText) stdoutText `shouldSatisfy` T.isInfixOf "\"editedOrphans\":1" - TIO.readFile fixture.projectFile `shouldReturn` "user-owned orphan\n" - TIO.readFile fixture.manifestPath `shouldReturnSatisfy` T.isInfixOf "README.md" + TIO.readFile (fixture ^. #projectFile) `shouldReturn` "user-owned orphan\n" + TIO.readFile (fixture ^. #manifestPath) `shouldReturnSatisfy` T.isInfixOf "README.md" it "reports an unresolved overlap before publishing project, manifest, or cache state" $ withSystemTempDirectory "seihou-update-executable-conflict" $ \root -> do fixture <- prepareUpdateFixture root binary <- seihouBinary - TIO.writeFile (fixture.remote <> "/files/README.tmpl") "candidate {{project.name}}\nkeep\nv2\n" - callProcess "git" ["-C", fixture.remote, "add", "files/README.tmpl"] - callProcess "git" ["-C", fixture.remote, "-c", "user.name=Seihou Test", "-c", "user.email=test@example.com", "commit", "-qm", "overlap"] - TIO.writeFile fixture.projectFile "user accepted\nkeep\nv1\n" - beforeManifest <- LBS.readFile fixture.manifestPath - beforeInstalled <- LBS.readFile (fixture.installedModule <> "/module.dhall") + TIO.writeFile (fixture ^. #remote <> "/files/README.tmpl") "candidate {{project.name}}\nkeep\nv2\n" + callProcess "git" ["-C", fixture ^. #remote, "add", "files/README.tmpl"] + callProcess "git" ["-C", fixture ^. #remote, "-c", "user.name=Seihou Test", "-c", "user.email=test@example.com", "commit", "-qm", "overlap"] + TIO.writeFile (fixture ^. #projectFile) "user accepted\nkeep\nv1\n" + beforeManifest <- LBS.readFile (fixture ^. #manifestPath) + beforeInstalled <- LBS.readFile (fixture ^. #installedModule <> "/module.dhall") (exitCode, stdoutText, _) <- runSeihou binary fixture ["update", "demo", "--json"] exitCode `shouldSatisfy` (/= ExitSuccess) stdoutText `shouldSatisfy` T.isInfixOf "\"code\":\"unresolved_conflicts\"" - TIO.readFile fixture.projectFile `shouldReturn` "user accepted\nkeep\nv1\n" - LBS.readFile fixture.manifestPath `shouldReturn` beforeManifest - LBS.readFile (fixture.installedModule <> "/module.dhall") `shouldReturn` beforeInstalled + TIO.readFile (fixture ^. #projectFile) `shouldReturn` "user accepted\nkeep\nv1\n" + LBS.readFile (fixture ^. #manifestPath) `shouldReturn` beforeManifest + LBS.readFile (fixture ^. #installedModule <> "/module.dhall") `shouldReturn` beforeInstalled (forceExit, forceOut, forceErr) <- runSeihou binary fixture ["update", "demo", "--force", "--json"] case forceExit of ExitSuccess -> pure () ExitFailure code -> expectationFailure ("forced update exited " <> show code <> "\nstdout:\n" <> T.unpack forceOut <> "\nstderr:\n" <> T.unpack forceErr) forceOut `shouldSatisfy` T.isInfixOf "\"outcome\":\"applied\"" - TIO.readFile fixture.projectFile `shouldReturn` "candidate accepted\nkeep\nv2\n" + TIO.readFile (fixture ^. #projectFile) `shouldReturn` "candidate accepted\nkeep\nv2\n" it "exposes update and its options through the shared Bash, Zsh, and Fish completion protocol" $ do binary <- seihouBinary @@ -162,16 +164,11 @@ ) ["bash", "zsh", "fish"] -seihouBinary :: IO FilePath -seihouBinary = do - testBinary <- getExecutablePath - pure (takeDirectory (takeDirectory testBinary) "seihou" "seihou") - runSeihou :: FilePath -> UpdateFixture -> [String] -> IO (ExitCode, T.Text, T.Text) runSeihou binary fixture args = do inherited <- getEnvironment - let environment = ("XDG_CONFIG_HOME", fixture.xdgHome) : filter ((/= "XDG_CONFIG_HOME") . fst) inherited - runProcessText binary args (Just fixture.projectRoot) (Just environment) + let environment = ("XDG_CONFIG_HOME", fixture ^. #xdgHome) : filter ((/= "XDG_CONFIG_HOME") . fst) inherited + runProcessText binary args (Just (fixture ^. #projectRoot)) (Just environment) runProcessText binary args workingDirectory environment = do let command = (proc binary args) {cwd = workingDirectory, env = environment} diff --git a/test/Seihou/CLI/UpdateFixture.hs b/test/Seihou/CLI/UpdateFixture.hs --- a/test/Seihou/CLI/UpdateFixture.hs +++ b/test/Seihou/CLI/UpdateFixture.hs @@ -55,7 +55,8 @@ reconfigure = False, promptPolicy = ForbidPrompts, commandPolicy = RunChangedCommands, - dryRun = True + dryRun = True, + allowDowngrade = False }, snapshot = UpdateSnapshot diff --git a/test/Seihou/CLI/UpdateInteractionSpec.hs b/test/Seihou/CLI/UpdateInteractionSpec.hs --- a/test/Seihou/CLI/UpdateInteractionSpec.hs +++ b/test/Seihou/CLI/UpdateInteractionSpec.hs @@ -1,5 +1,7 @@ module Seihou.CLI.UpdateInteractionSpec (tests) where +import Control.Lens ((^.)) +import Data.Generics.Labels () import Data.Map.Strict qualified as Map import Data.Set qualified as Set import Seihou.CLI.Update (UpdatePlan (..)) @@ -35,30 +37,30 @@ it "force accepts ordinary generated conflicts" $ do resolved <- expectResolved conflictPlan (forceResolveUpdatePlan conflictPlan) - unresolvedPaths resolved.reconciliation `shouldBe` Set.empty - case Map.lookup "README.md" resolved.reconciliation.files of + unresolvedPaths (resolved ^. #reconciliation) `shouldBe` Set.empty + case Map.lookup "README.md" (resolved ^. #reconciliation . #files) of Just (FileConflict _ _ _ _ _ _ (Just choice)) -> - choice.choice `shouldBe` AcceptGenerated + (choice ^. #choice) `shouldBe` AcceptGenerated other -> expectationFailure ("expected resolved conflict, got " <> show other) it "force retains edited orphans as tracked state" $ do resolved <- expectResolved orphanPlan (forceResolveUpdatePlan orphanPlan) - case Map.lookup "README.md" resolved.reconciliation.files of + case Map.lookup "README.md" (resolved ^. #reconciliation . #files) of Just (FileOrphanEdited _ _ _ _ (Just choice)) -> choice `shouldBe` RetainTrackedOrphan other -> expectationFailure ("expected resolved orphan, got " <> show other) it "force leaves merge-driver failures unresolved" $ do resolved <- expectResolved unavailableConflictPlan (forceResolveUpdatePlan unavailableConflictPlan) - unresolvedPaths resolved.reconciliation `shouldBe` Set.singleton "README.md" + unresolvedPaths (resolved ^. #reconciliation) `shouldBe` Set.singleton "README.md" it "applies explicit keep-current and detach-orphan choices without writing" $ do kept <- expectResolved conflictPlan (applyResolutionDecisions [ResolveFile "README.md" KeepCurrent] conflictPlan) - case Map.lookup "README.md" kept.reconciliation.files of - Just (FileConflict _ _ _ _ _ _ (Just choice)) -> choice.choice `shouldBe` KeepCurrent + case Map.lookup "README.md" (kept ^. #reconciliation . #files) of + Just (FileConflict _ _ _ _ _ _ (Just choice)) -> (choice ^. #choice) `shouldBe` KeepCurrent other -> expectationFailure ("expected keep-current conflict resolution, got " <> show other) detached <- expectResolved orphanPlan (applyResolutionDecisions [ResolveOrphan "README.md" DetachAndKeepOrphan] orphanPlan) - case Map.lookup "README.md" detached.reconciliation.files of + case Map.lookup "README.md" (detached ^. #reconciliation . #files) of Just (FileOrphanEdited _ _ _ _ (Just choice)) -> choice `shouldBe` DetachAndKeepOrphan other -> expectationFailure ("expected detached orphan resolution, got " <> show other) diff --git a/test/Seihou/CLI/UpdateSpec.hs b/test/Seihou/CLI/UpdateSpec.hs --- a/test/Seihou/CLI/UpdateSpec.hs +++ b/test/Seihou/CLI/UpdateSpec.hs @@ -6,7 +6,9 @@ where import Control.Exception (bracket) +import Control.Lens ((&), (.~), (^.)) import Data.ByteString.Lazy qualified as LBS +import Data.Generics.Labels () import Data.Map.Strict qualified as Map import Data.Maybe (fromMaybe, listToMaybe) import Data.Set qualified as Set @@ -14,6 +16,7 @@ import Data.Text qualified as T import Data.Text.IO qualified as TIO import Data.Time (UTCTime (..), fromGregorian) +import GHC.Generics (Generic) import Seihou.CLI.CommandExecution (CommandPolicy (..)) import Seihou.CLI.Update (PromptPolicy (..), UpdateRequest (..), UpdateSelection (..), applyProjectUpdate, isUpdateNoOp, withProjectUpdate) import Seihou.CLI.Update.Migrations (StagedMigrations (..), planAndStageMigrations) @@ -43,16 +46,16 @@ spec = do describe "application selection" $ do it "selects every application containing a requested bare module" $ do - let first = application (AppliedModuleTarget "one") [instanceState "shared" "/one/shared"] - second = application (AppliedRecipeTarget "stack") [instanceState "shared" "/two/shared"] + let first = application (AppliedModuleTarget "one") [instanceState "shared"] + second = application (AppliedRecipeTarget "stack") [instanceState "shared"] manifest :: Manifest manifest = manifestForApplications [first, second] Map.empty selectApplications (NamedUpdateTargets ["shared"]) manifest `shouldBe` Right (RecordedSelection [first, second]) it "keeps manifest order for all applications and deduplicates repeated targets" $ do - let first = application (AppliedModuleTarget "one") [instanceState "one" "/one"] - second = application (AppliedModuleTarget "two") [instanceState "two" "/two"] + let first = application (AppliedModuleTarget "one") [instanceState "one"] + second = application (AppliedModuleTarget "two") [instanceState "two"] manifest :: Manifest manifest = manifestForApplications [first, second] Map.empty selectApplications AllRecordedApplications manifest @@ -61,14 +64,14 @@ `shouldBe` Right (RecordedSelection [first, second]) it "rejects a partial selection that shares an owned path" $ do - let first = application (AppliedModuleTarget "one") [instanceState "one" "/one"] - second = application (AppliedModuleTarget "two") [instanceState "two" "/two"] - owners = Set.fromList [first.applicationId, second.applicationId] + let first = application (AppliedModuleTarget "one") [instanceState "one"] + second = application (AppliedModuleTarget "two") [instanceState "two"] + owners = Set.fromList [first ^. #applicationId, second ^. #applicationId] record = FileRecord (hashContent "old") "one" Template testTime Nothing owners manifest :: Manifest manifest = manifestForApplications [first, second] (Map.singleton "shared.txt" record) selectApplications (NamedUpdateTargets ["one"]) manifest - `shouldBe` Left (SharedPathRequiresApplications "shared.txt" (Set.singleton first.applicationId) (Set.singleton second.applicationId)) + `shouldBe` Left (SharedPathRequiresApplications "shared.txt" (Set.singleton (first ^. #applicationId)) (Set.singleton (second ^. #applicationId))) it "requires one explicit target to seed a legacy manifest" $ do selectApplications AllRecordedApplications (emptyManifest testTime) `shouldBe` Left NoRecordedApplications @@ -78,20 +81,24 @@ describe "candidate source staging" $ do it "keeps local artifacts as an explicit candidate-first fallback" $ withSystemTempDirectory "seihou-update-source" $ \root -> do - let moduleDirectory = root "current" "demo" + let localProjectRoot = root "current" + moduleDirectory = localProjectRoot "demo" sessionDirectory = root "session" - applied = application (AppliedModuleTarget "demo") [instanceState "demo" moduleDirectory] + origin = ProjectOrigin "demo" + applied = + application (AppliedModuleTarget "demo") [instanceStateFrom "demo" origin] + & #targetOrigin .~ origin createDirectoryIfMissing True moduleDirectory TIO.writeFile (moduleDirectory "module.dhall") (moduleDhall "demo" "1.0.0") - result <- stageCandidateSources sessionDirectory [applied {targetSource = moduleDirectory}] + result <- stageCandidateSources sessionDirectory localProjectRoot (root "installed") [applied] case result of Left err -> expectationFailure (show err) Right (catalog, warnings) -> do warnings `shouldContain` [LocalArtifactHasNoRemote "demo"] - let candidate = catalog.artifacts Map.! (CandidateModule, "demo") - candidate.originalDirectory `shouldBe` moduleDirectory - candidate.sourceUrl `shouldBe` Nothing - doesFileExist (catalog.searchRoot "demo" "module.dhall") `shouldReturn` True + let candidate = (catalog ^. #artifacts) Map.! (CandidateModule, "demo") + (candidate ^. #originalDirectory) `shouldBe` moduleDirectory + (candidate ^. #sourceUrl) `shouldBe` Nothing + doesFileExist (catalog ^. #searchRoot "demo" "module.dhall") `shouldReturn` True it "clones one registry origin once for a recipe and all of its modules" $ withSystemTempDirectory "seihou-update-registry-source" $ \root -> do @@ -102,11 +109,15 @@ recipeDirectory = installed "stack" sessionDirectory = root "session" sourceUrl = T.pack remote + remoteOrigin name = RemoteOrigin sourceUrl name Nothing applied = - (application (AppliedRecipeTarget "stack") [instanceState "one" moduleOne, instanceState "two" moduleTwo]) - { targetSource = recipeDirectory, - additionalModules = [] - } + application + (AppliedRecipeTarget "stack") + [ instanceStateFrom "one" (remoteOrigin "one"), + instanceStateFrom "two" (remoteOrigin "two") + ] + & #targetOrigin .~ remoteOrigin "stack" + & #additionalModules .~ [] createDirectoryIfMissing True (remote "modules" "one") createDirectoryIfMissing True (remote "modules" "two") createDirectoryIfMissing True (remote "recipes" "stack") @@ -118,21 +129,24 @@ callProcess "git" ["-C", remote, "add", "."] callProcess "git" ["-C", remote, "-c", "user.name=Seihou Test", "-c", "user.email=test@example.com", "commit", "-qm", "registry"] mapM_ (writeOrigin sourceUrl) [moduleOne, moduleTwo, recipeDirectory] - result <- stageCandidateSources sessionDirectory [applied] + result <- stageCandidateSources sessionDirectory root installed [applied] case result of Left err -> expectationFailure (show err) Right (catalog, _) -> do - Map.size catalog.clonedOrigins `shouldBe` 1 - Map.keysSet catalog.artifacts + Map.size (catalog ^. #clonedOrigins) `shouldBe` 1 + Map.keysSet (catalog ^. #artifacts) `shouldBe` Set.fromList [(CandidateModule, "one"), (CandidateModule, "two"), (CandidateRecipe, "stack")] it "returns a structured clone error before touching the project" $ withSystemTempDirectory "seihou-update-clone-error" $ \root -> do let moduleDirectory = root "installed" "demo" missingRemote = T.pack (root "missing-remote") - applied = (application (AppliedModuleTarget "demo") [instanceState "demo" moduleDirectory]) {targetSource = moduleDirectory} + missingOrigin = RemoteOrigin missingRemote "demo" Nothing + applied = + application (AppliedModuleTarget "demo") [instanceStateFrom "demo" missingOrigin] + & #targetOrigin .~ missingOrigin writeOrigin missingRemote moduleDirectory - result <- stageCandidateSources (root "session") [applied] + result <- stageCandidateSources (root "session") root (root "installed") [applied] result `shouldSatisfy` \case Left (CandidateCloneFailed url message) -> url == missingRemote && "git clone failed" `T.isInfixOf` message _ -> False @@ -141,11 +155,11 @@ it "reuses accepted inputs, keeps dry-run read-only, and publishes one coherent update" $ withSystemTempDirectory "seihou-update-e2e" $ \root -> do fixture <- prepareUpdateFixture root - withSavedEnv "XDG_CONFIG_HOME" (Just fixture.xdgHome) $ - withCurrentDirectory fixture.projectRoot $ do - beforeManifest <- LBS.readFile fixture.manifestPath - beforeProject <- TIO.readFile fixture.projectFile - beforeInstalled <- TIO.readFile (fixture.installedModule "module.dhall") + withSavedEnv "XDG_CONFIG_HOME" (Just (fixture ^. #xdgHome)) $ + withCurrentDirectory (fixture ^. #projectRoot) $ do + beforeManifest <- LBS.readFile (fixture ^. #manifestPath) + beforeProject <- TIO.readFile (fixture ^. #projectFile) + beforeInstalled <- TIO.readFile (fixture ^. #installedModule "module.dhall") let dryRequest = updateRequest True dryResult <- withProjectUpdate dryRequest $ \case Left err -> pure (Left err) @@ -153,9 +167,9 @@ case dryResult of Left err -> expectationFailure (show err) Right _ -> pure () - LBS.readFile fixture.manifestPath `shouldReturn` beforeManifest - TIO.readFile fixture.projectFile `shouldReturn` beforeProject - TIO.readFile (fixture.installedModule "module.dhall") `shouldReturn` beforeInstalled + LBS.readFile (fixture ^. #manifestPath) `shouldReturn` beforeManifest + TIO.readFile (fixture ^. #projectFile) `shouldReturn` beforeProject + TIO.readFile (fixture ^. #installedModule "module.dhall") `shouldReturn` beforeInstalled applied <- withProjectUpdate (updateRequest False) $ \case Left err -> pure (Left err) @@ -163,40 +177,40 @@ case applied of Left err -> expectationFailure (show err) Right result -> do - result.versions `shouldSatisfy` any (\change -> change.name == "demo" && change.fromVersion == Just "1.0.0" && change.toVersion == Just "2.0.0") - result.updatedApplications `shouldBe` [fixture.applicationId] - TIO.readFile fixture.projectFile `shouldReturn` "hello accepted\nkeep\nv2\n" - installedBytes <- TIO.readFile (fixture.installedModule "module.dhall") + (result ^. #versions) `shouldSatisfy` any (\change -> change ^. #name == "demo" && change ^. #fromVersion == Just "1.0.0" && change ^. #toVersion == Just "2.0.0") + (result ^. #updatedApplications) `shouldBe` [fixture ^. #applicationId] + TIO.readFile (fixture ^. #projectFile) `shouldReturn` "hello accepted\nkeep\nv2\n" + installedBytes <- TIO.readFile (fixture ^. #installedModule "module.dhall") installedBytes `shouldSatisfy` T.isInfixOf "Some \"2.0.0\"" - decoded <- manifestFromJSON <$> LBS.readFile fixture.manifestPath + decoded <- manifestFromJSON <$> LBS.readFile (fixture ^. #manifestPath) case decoded of Left err -> expectationFailure err - Right manifest -> case manifest.applications of - updated : _ -> case updated.instances of + Right manifest -> case manifest ^. #applications of + updated : _ -> case updated ^. #instances of instanceState : _ -> do - instanceState.resolvedVars `shouldBe` Map.singleton "project.name" "accepted" - instanceState.moduleVersion `shouldBe` Just "2.0.0" + (instanceState ^. #resolvedVars) `shouldBe` Map.singleton "project.name" "accepted" + (instanceState ^. #moduleVersion) `shouldBe` Just "2.0.0" [] -> expectationFailure "updated application has no instances" [] -> expectationFailure "updated manifest has no applications" - afterFirstApply <- LBS.readFile fixture.manifestPath + afterFirstApply <- LBS.readFile (fixture ^. #manifestPath) noOp <- withProjectUpdate (updateRequest False) $ \case Left err -> pure (Left err) Right plan -> applyProjectUpdate plan case noOp of Left err -> expectationFailure (show err) - Right result -> result.updatedApplications `shouldBe` [] - LBS.readFile fixture.manifestPath `shouldReturn` afterFirstApply + Right result -> (result ^. #updatedApplications) `shouldBe` [] + LBS.readFile (fixture ^. #manifestPath) `shouldReturn` afterFirstApply it "rejects a plan when its manifest snapshot changes" $ withSystemTempDirectory "seihou-update-stale" $ \root -> do fixture <- prepareUpdateFixture root - withSavedEnv "XDG_CONFIG_HOME" (Just fixture.xdgHome) $ - withCurrentDirectory fixture.projectRoot $ do + withSavedEnv "XDG_CONFIG_HOME" (Just (fixture ^. #xdgHome)) $ + withCurrentDirectory (fixture ^. #projectRoot) $ do result <- withProjectUpdate (updateRequest False) $ \case Left err -> pure (Left err) Right plan -> do - TIO.appendFile fixture.manifestPath "\n" + TIO.appendFile (fixture ^. #manifestPath) "\n" applyProjectUpdate plan result `shouldSatisfy` \case Left (UpdatePlanStale paths) -> Set.member (".seihou" "manifest.json") paths @@ -205,96 +219,96 @@ it "plans changed content at the same declared version with an explicit warning" $ withSystemTempDirectory "seihou-update-same-version" $ \root -> do fixture <- prepareUpdateFixture root - let modulePath = fixture.remote "module.dhall" + let modulePath = fixture ^. #remote "module.dhall" body <- TIO.readFile modulePath TIO.writeFile modulePath (T.replace "Some \"2.0.0\"" "Some \"1.0.0\"" body) - callProcess "git" ["-C", fixture.remote, "add", "module.dhall"] - callProcess "git" ["-C", fixture.remote, "-c", "user.name=Seihou Test", "-c", "user.email=test@example.com", "commit", "-qm", "same-version content change"] - withSavedEnv "XDG_CONFIG_HOME" (Just fixture.xdgHome) $ - withCurrentDirectory fixture.projectRoot $ do + callProcess "git" ["-C", fixture ^. #remote, "add", "module.dhall"] + callProcess "git" ["-C", fixture ^. #remote, "-c", "user.name=Seihou Test", "-c", "user.email=test@example.com", "commit", "-qm", "same-version content change"] + withSavedEnv "XDG_CONFIG_HOME" (Just (fixture ^. #xdgHome)) $ + withCurrentDirectory (fixture ^. #projectRoot) $ do result <- withProjectUpdate (updateRequest True) pure case result of Left err -> expectationFailure (show err) Right plan -> do isUpdateNoOp plan `shouldBe` False - plan.versionChanges `shouldSatisfy` any (.sameVersionContentChanged) - plan.warnings `shouldContain` [SameVersionContentChanged "demo"] + (plan ^. #versionChanges) `shouldSatisfy` any (^. #sameVersionContentChanged) + (plan ^. #warnings) `shouldContain` [SameVersionContentChanged "demo"] it "re-expands a candidate recipe and removes dependencies dropped by it" $ withSystemTempDirectory "seihou-update-recipe" $ \root -> do fixture <- prepareRecipeUpdateFixture root - withSavedEnv "XDG_CONFIG_HOME" (Just fixture.recipeXdgHome) $ - withCurrentDirectory fixture.recipeProjectRoot $ do + withSavedEnv "XDG_CONFIG_HOME" (Just (fixture ^. #xdgHome)) $ + withCurrentDirectory (fixture ^. #projectRoot) $ do result <- withProjectUpdate (updateRequest False) $ \case Left err -> pure (Left err) Right plan -> applyProjectUpdate plan case result of Left err -> expectationFailure (show err) - Right updateResult -> updateResult.updatedApplications `shouldBe` [fixture.recipeApplicationId] - decoded <- manifestFromJSON <$> LBS.readFile fixture.recipeManifestPath + Right updateResult -> (updateResult ^. #updatedApplications) `shouldBe` [fixture ^. #applicationId] + decoded <- manifestFromJSON <$> LBS.readFile (fixture ^. #manifestPath) case decoded of Left err -> expectationFailure err - Right manifest -> case manifest.applications of + Right manifest -> case manifest ^. #applications of [updated] -> do - updated.applicationId `shouldBe` fixture.recipeApplicationId - updated.targetVersion `shouldBe` Just "2.0.0" - updated.additionalModules `shouldBe` [] - Set.fromList (map (.name) updated.instances) `shouldBe` Set.fromList ["one", "new"] - Set.fromList (map (.name) manifest.modules) `shouldBe` Set.fromList ["one", "new"] + (updated ^. #applicationId) `shouldBe` (fixture ^. #applicationId) + (updated ^. #targetVersion) `shouldBe` Just "2.0.0" + (updated ^. #additionalModules) `shouldBe` [] + Set.fromList (map (^. #name) (updated ^. #instances)) `shouldBe` Set.fromList ["one", "new"] + Set.fromList (map (^. #name) (manifest ^. #modules)) `shouldBe` Set.fromList ["one", "new"] other -> expectationFailure ("expected one updated recipe application, got " <> show other) - doesFileExist (fixture.recipeXdgHome "seihou" "installed" "new" "module.dhall") `shouldReturn` True + doesFileExist (fixture ^. #xdgHome "seihou" "installed" "new" "module.dhall") `shouldReturn` True it "refuses an unresolved three-way conflict without mutating durable state" $ withSystemTempDirectory "seihou-update-conflict" $ \root -> do fixture <- prepareUpdateFixture root - TIO.writeFile (fixture.remote "files" "README.tmpl") "candidate {{project.name}}\nv2\n" - callProcess "git" ["-C", fixture.remote, "add", "files/README.tmpl"] - callProcess "git" ["-C", fixture.remote, "-c", "user.name=Seihou Test", "-c", "user.email=test@example.com", "commit", "-qm", "conflicting template"] - withSavedEnv "XDG_CONFIG_HOME" (Just fixture.xdgHome) $ - withCurrentDirectory fixture.projectRoot $ do - TIO.writeFile fixture.projectFile "user accepted\nv1\n" - beforeManifest <- LBS.readFile fixture.manifestPath - beforeInstalled <- LBS.readFile (fixture.installedModule "module.dhall") + TIO.writeFile (fixture ^. #remote "files" "README.tmpl") "candidate {{project.name}}\nv2\n" + callProcess "git" ["-C", fixture ^. #remote, "add", "files/README.tmpl"] + callProcess "git" ["-C", fixture ^. #remote, "-c", "user.name=Seihou Test", "-c", "user.email=test@example.com", "commit", "-qm", "conflicting template"] + withSavedEnv "XDG_CONFIG_HOME" (Just (fixture ^. #xdgHome)) $ + withCurrentDirectory (fixture ^. #projectRoot) $ do + TIO.writeFile (fixture ^. #projectFile) "user accepted\nv1\n" + beforeManifest <- LBS.readFile (fixture ^. #manifestPath) + beforeInstalled <- LBS.readFile (fixture ^. #installedModule "module.dhall") result <- withProjectUpdate (updateRequest False) $ \case Left err -> pure (Left err) Right plan -> applyProjectUpdate plan result `shouldSatisfy` \case Left (UpdateHasUnresolvedPaths paths) -> Set.member "README.md" paths _ -> False - LBS.readFile fixture.manifestPath `shouldReturn` beforeManifest - TIO.readFile fixture.projectFile `shouldReturn` "user accepted\nv1\n" - LBS.readFile (fixture.installedModule "module.dhall") `shouldReturn` beforeInstalled + LBS.readFile (fixture ^. #manifestPath) `shouldReturn` beforeManifest + TIO.readFile (fixture ^. #projectFile) `shouldReturn` "user accepted\nv1\n" + LBS.readFile (fixture ^. #installedModule "module.dhall") `shouldReturn` beforeInstalled it "seeds one explicit legacy target and records it only after success" $ withSystemTempDirectory "seihou-update-legacy" $ \root -> do fixture <- prepareUpdateFixture root - decoded <- manifestFromJSON <$> LBS.readFile fixture.manifestPath + decoded <- manifestFromJSON <$> LBS.readFile (fixture ^. #manifestPath) legacy <- case decoded of Left err -> expectationFailure err >> pure (emptyManifest testTime) Right manifest -> pure (withoutApplications manifest) - LBS.writeFile fixture.manifestPath (manifestToJSON legacy) - let request = (updateRequest False) {selection = NamedUpdateTargets ["demo"]} - withSavedEnv "XDG_CONFIG_HOME" (Just fixture.xdgHome) $ - withCurrentDirectory fixture.projectRoot $ do + LBS.writeFile (fixture ^. #manifestPath) (manifestToJSON legacy) + let request = ((updateRequest False) & #selection .~ NamedUpdateTargets ["demo"]) + withSavedEnv "XDG_CONFIG_HOME" (Just (fixture ^. #xdgHome)) $ + withCurrentDirectory (fixture ^. #projectRoot) $ do result <- withProjectUpdate request $ \case Left err -> pure (Left err) Right plan -> applyProjectUpdate plan case result of Left err -> expectationFailure (show err) - Right updateResult -> updateResult.updatedApplications `shouldBe` [fixture.applicationId] - updated <- manifestFromJSON <$> LBS.readFile fixture.manifestPath + Right updateResult -> (updateResult ^. #updatedApplications) `shouldBe` [fixture ^. #applicationId] + updated <- manifestFromJSON <$> LBS.readFile (fixture ^. #manifestPath) case updated of Left err -> expectationFailure err - Right manifest -> case manifest.applications of - [applicationState] -> case applicationState.instances of - [moduleState] -> moduleState.resolvedVars `shouldBe` Map.singleton "project.name" "accepted" + Right manifest -> case manifest ^. #applications of + [applicationState] -> case applicationState ^. #instances of + [moduleState] -> (moduleState ^. #resolvedVars) `shouldBe` Map.singleton "project.name" "accepted" other -> expectationFailure ("expected one legacy module instance, got " <> show other) other -> expectationFailure ("expected one seeded application, got " <> show other) it "rolls managed project and cache state back when a candidate command fails" $ withSystemTempDirectory "seihou-update-command-failure" $ \root -> do fixture <- prepareUpdateFixture root - let modulePath = fixture.remote "module.dhall" + let modulePath = fixture ^. #remote "module.dhall" body <- TIO.readFile modulePath TIO.writeFile modulePath @@ -303,40 +317,40 @@ ", commands = [{ run = \"exit 7\", workDir = None Text, when = None Text }]" body ) - callProcess "git" ["-C", fixture.remote, "add", "module.dhall"] - callProcess "git" ["-C", fixture.remote, "-c", "user.name=Seihou Test", "-c", "user.email=test@example.com", "commit", "-qm", "failing command"] - withSavedEnv "XDG_CONFIG_HOME" (Just fixture.xdgHome) $ - withCurrentDirectory fixture.projectRoot $ do - beforeManifest <- LBS.readFile fixture.manifestPath - beforeProject <- TIO.readFile fixture.projectFile - beforeInstalled <- LBS.readFile (fixture.installedModule "module.dhall") + callProcess "git" ["-C", fixture ^. #remote, "add", "module.dhall"] + callProcess "git" ["-C", fixture ^. #remote, "-c", "user.name=Seihou Test", "-c", "user.email=test@example.com", "commit", "-qm", "failing command"] + withSavedEnv "XDG_CONFIG_HOME" (Just (fixture ^. #xdgHome)) $ + withCurrentDirectory (fixture ^. #projectRoot) $ do + beforeManifest <- LBS.readFile (fixture ^. #manifestPath) + beforeProject <- TIO.readFile (fixture ^. #projectFile) + beforeInstalled <- LBS.readFile (fixture ^. #installedModule "module.dhall") result <- withProjectUpdate (updateRequest False) $ \case Left err -> pure (Left err) Right plan -> applyProjectUpdate plan result `shouldSatisfy` \case Left UpdateCommandFailed {} -> True _ -> False - LBS.readFile fixture.manifestPath `shouldReturn` beforeManifest - TIO.readFile fixture.projectFile `shouldReturn` beforeProject - LBS.readFile (fixture.installedModule "module.dhall") `shouldReturn` beforeInstalled + LBS.readFile (fixture ^. #manifestPath) `shouldReturn` beforeManifest + TIO.readFile (fixture ^. #projectFile) `shouldReturn` beforeProject + LBS.readFile (fixture ^. #installedModule "module.dhall") `shouldReturn` beforeInstalled it "rolls managed state back when installed-cache publication fails" $ withSystemTempDirectory "seihou-update-cache-failure" $ \root -> do fixture <- prepareUpdateFixture root - withSavedEnv "XDG_CONFIG_HOME" (Just fixture.xdgHome) $ - withCurrentDirectory fixture.projectRoot $ do - beforeManifest <- LBS.readFile fixture.manifestPath - beforeProject <- TIO.readFile fixture.projectFile - beforeInstalled <- LBS.readFile (fixture.installedModule "module.dhall") + withSavedEnv "XDG_CONFIG_HOME" (Just (fixture ^. #xdgHome)) $ + withCurrentDirectory (fixture ^. #projectRoot) $ do + beforeManifest <- LBS.readFile (fixture ^. #manifestPath) + beforeProject <- TIO.readFile (fixture ^. #projectFile) + beforeInstalled <- LBS.readFile (fixture ^. #installedModule "module.dhall") result <- withProjectUpdate (updateRequest False) $ \case Left err -> pure (Left err) Right plan -> applyProjectUpdate (breakCandidatePublication plan) result `shouldSatisfy` \case Left UpdateCachePublicationFailed {} -> True _ -> False - LBS.readFile fixture.manifestPath `shouldReturn` beforeManifest - TIO.readFile fixture.projectFile `shouldReturn` beforeProject - LBS.readFile (fixture.installedModule "module.dhall") `shouldReturn` beforeInstalled + LBS.readFile (fixture ^. #manifestPath) `shouldReturn` beforeManifest + TIO.readFile (fixture ^. #projectFile) `shouldReturn` beforeProject + LBS.readFile (fixture ^. #installedModule "module.dhall") `shouldReturn` beforeInstalled describe "migration staging" $ do it "preserves parameterized instances while planning their shared transition once" $ @@ -345,7 +359,7 @@ parentTwo = ParentVars (Map.singleton "tenant" "two") instanceOne = ModuleInstance "shared" parentOne instanceTwo = ModuleInstance "shared" parentTwo - stateFor parent = AppliedInstanceState "shared" parent "/installed/shared" (Just "1.0.0") Map.empty + stateFor parent = AppliedInstanceState "shared" parent (LocalOrigin "shared") (Just "1.0.0") Map.empty previous = application (AppliedModuleTarget "shared") [stateFor parentOne, stateFor parentTwo] candidate = Module @@ -362,14 +376,14 @@ migrations = [Migration "1.0.0" "2.0.0" [RunCommand "true" Nothing]] } appliedModules = - [ AppliedModule "shared" parentOne "/installed/shared" (Just "1.0.0") testTime Nothing, - AppliedModule "shared" parentTwo "/installed/shared" (Just "1.0.0") testTime Nothing + [ AppliedModule "shared" parentOne (LocalOrigin "shared") (Just "1.0.0") testTime Nothing, + AppliedModule "shared" parentTwo (LocalOrigin "shared") (Just "1.0.0") testTime Nothing ] base = emptyManifest testTime manifest = Manifest - { version = base.version, - genAt = base.genAt, + { version = base ^. #version, + genAt = base ^. #genAt, modules = appliedModules, vars = Map.empty, files = Map.empty, @@ -384,27 +398,29 @@ case staged of Left err -> expectationFailure (show err) Right migrationStage -> do - length migrationStage.plans `shouldBe` 1 - migrationStage.plans `shouldSatisfy` all (.containsCommands) - migrationStage.warnings `shouldBe` [MigrationCommandNotSimulated "shared" "true"] - map (.moduleVersion) migrationStage.manifest.modules `shouldBe` [Just "2.0.0", Just "2.0.0"] + length (migrationStage ^. #plans) `shouldBe` 1 + (migrationStage ^. #plans) `shouldSatisfy` all (^. #containsCommands) + (migrationStage ^. #warnings) `shouldBe` [MigrationCommandNotSimulated "shared" "true"] + map (^. #moduleVersion) (migrationStage ^. #manifest . #modules) `shouldBe` [Just "2.0.0", Just "2.0.0"] data UpdateFixture = UpdateFixture - { projectRoot :: FilePath, - projectFile :: FilePath, - manifestPath :: FilePath, - xdgHome :: FilePath, - installedModule :: FilePath, - remote :: FilePath, - applicationId :: ApplicationId + { projectRoot :: !FilePath, + projectFile :: !FilePath, + manifestPath :: !FilePath, + xdgHome :: !FilePath, + installedModule :: !FilePath, + remote :: !FilePath, + applicationId :: !ApplicationId } + deriving stock (Generic) data RecipeUpdateFixture = RecipeUpdateFixture - { recipeProjectRoot :: FilePath, - recipeManifestPath :: FilePath, - recipeXdgHome :: FilePath, - recipeApplicationId :: ApplicationId + { projectRoot :: !FilePath, + manifestPath :: !FilePath, + xdgHome :: !FilePath, + applicationId :: !ApplicationId } + deriving stock (Generic) prepareUpdateFixture :: FilePath -> IO UpdateFixture prepareUpdateFixture root = do @@ -422,19 +438,19 @@ baselineRef = BaselineRef (hashContent baselineContent) target = AppliedModuleTarget "demo" applicationId = mkApplicationId target [] + demoOrigin = RemoteOrigin (T.pack remote) "demo" Nothing app = - (application target [instanceState "demo" installedModule]) + (application target [instanceStateFrom "demo" demoOrigin]) { applicationId, - targetSource = installedModule, + targetOrigin = demoOrigin, targetVersion = Just "1.0.0", commandReceipts = Map.singleton commandFingerprint commandReceipt, instances = - [ (instanceState "demo" installedModule) - { resolvedVars = Map.singleton "project.name" "accepted" - } + [ (instanceStateFrom "demo" demoOrigin) + & #resolvedVars .~ Map.singleton "project.name" "accepted" ] } - appliedModule = AppliedModule "demo" emptyParentVars installedModule (Just "1.0.0") testTime Nothing + appliedModule = AppliedModule "demo" emptyParentVars demoOrigin (Just "1.0.0") testTime Nothing fileRecord = FileRecord (hashContent baselineContent) @@ -444,12 +460,12 @@ (Just baselineRef) (Set.singleton applicationId) manifest = - (emptyManifest testTime) - { modules = [appliedModule], - vars = Map.singleton "project.name" "accepted", - files = Map.singleton "README.md" fileRecord, - applications = [app] - } + ( (emptyManifest testTime) + & #modules .~ [appliedModule] + & #vars .~ Map.singleton "project.name" "accepted" + & #files .~ Map.singleton "README.md" fileRecord + & #applications .~ [app] + ) createDirectoryIfMissing True (installedModule "files") TIO.writeFile (installedModule "module.dhall") (moduleDhallWithTemplate "demo" "1.0.0" "old-default") TIO.writeFile (installedModule "files" "README.tmpl") "hello {{project.name}}\nkeep\nv1\n" @@ -465,7 +481,7 @@ createDirectoryIfMissing True (projectRoot ".seihou" "baselines") TIO.writeFile projectFile baselineContent TIO.writeFile - (projectRoot ".seihou" "baselines" T.unpack baselineRef.unBaselineRef.unSHA256) + (projectRoot ".seihou" "baselines" T.unpack (baselineRef ^. #unBaselineRef . #unSHA256)) baselineContent LBS.writeFile manifestPath (manifestToJSON manifest) pure UpdateFixture {projectRoot, projectFile, manifestPath, xdgHome, installedModule, remote, applicationId} @@ -486,23 +502,26 @@ AppliedComposition { applicationId, target, - targetSource = installedRecipe, + targetOrigin = remoteOrigin "stack", targetVersion = Just "1.0.0", additionalModules = [], namespace = Just "one", context = Nothing, - instances = [instanceState "old" installedOld, instanceState "one" installedOne], + instances = + [ instanceStateFrom "old" (remoteOrigin "old"), + instanceStateFrom "one" (remoteOrigin "one") + ], commandReceipts = Map.empty, appliedAt = testTime } base = emptyManifest testTime manifest = Manifest - { version = base.version, - genAt = base.genAt, + { version = base ^. #version, + genAt = base ^. #genAt, modules = - [ AppliedModule "old" emptyParentVars installedOld (Just "1.0.0") testTime Nothing, - AppliedModule "one" emptyParentVars installedOne (Just "1.0.0") testTime Nothing + [ AppliedModule "old" emptyParentVars (remoteOrigin "old") (Just "1.0.0") testTime Nothing, + AppliedModule "one" emptyParentVars (remoteOrigin "one") (Just "1.0.0") testTime Nothing ], vars = Map.empty, files = Map.empty, @@ -512,6 +531,7 @@ blueprintMigrations = [] } sourceUrl = T.pack remote + remoteOrigin name = RemoteOrigin sourceUrl name Nothing createDirectoryIfMissing True installedOne createDirectoryIfMissing True installedOld createDirectoryIfMissing True installedRecipe @@ -535,10 +555,10 @@ LBS.writeFile manifestPath (manifestToJSON manifest) pure RecipeUpdateFixture - { recipeProjectRoot = projectRoot, - recipeManifestPath = manifestPath, - recipeXdgHome = xdgHome, - recipeApplicationId = applicationId + { projectRoot = projectRoot, + manifestPath = manifestPath, + xdgHome = xdgHome, + applicationId = applicationId } updateRequest :: Bool -> UpdateRequest @@ -549,7 +569,8 @@ reconfigure = False, promptPolicy = ForbidPrompts, commandPolicy = RunChangedCommands, - dryRun + dryRun, + allowDowngrade = False } moduleDhallWithTemplate :: Text -> Text -> Text -> Text @@ -583,7 +604,7 @@ AppliedComposition { applicationId = mkApplicationId target [], target, - targetSource = maybe "" (.source) (listToMaybe instances), + targetOrigin = LocalOrigin targetName, targetVersion = Just "1.0.0", additionalModules = [], namespace = Nothing, @@ -592,13 +613,20 @@ commandReceipts = Map.empty, appliedAt = testTime } + where + targetName = case target of + AppliedModuleTarget name -> name ^. #unModuleName + AppliedRecipeTarget name -> name ^. #unRecipeName -instanceState :: ModuleName -> FilePath -> AppliedInstanceState -instanceState name source = +instanceState :: ModuleName -> AppliedInstanceState +instanceState name = instanceStateFrom name (LocalOrigin (name ^. #unModuleName)) + +instanceStateFrom :: ModuleName -> ArtifactOrigin -> AppliedInstanceState +instanceStateFrom name origin = AppliedInstanceState { name, parentVars = emptyParentVars, - source, + origin, moduleVersion = Just "1.0.0", resolvedVars = Map.empty } @@ -677,61 +705,61 @@ manifestForApplications applicationRecords fileRecords = let base = emptyManifest testTime in Manifest - { version = base.version, - genAt = base.genAt, - modules = base.modules, - vars = base.vars, + { version = base ^. #version, + genAt = base ^. #genAt, + modules = base ^. #modules, + vars = base ^. #vars, files = fileRecords, applications = applicationRecords, - recipe = base.recipe, - blueprint = base.blueprint, - blueprintMigrations = base.blueprintMigrations + recipe = base ^. #recipe, + blueprint = base ^. #blueprint, + blueprintMigrations = base ^. #blueprintMigrations } breakCandidatePublication :: UpdatePlan -> UpdatePlan breakCandidatePublication plan = UpdatePlan - { applications = plan.applications, - versionChanges = plan.versionChanges, - inputChanges = plan.inputChanges, - migrations = plan.migrations, - reconciliation = plan.reconciliation, - commandPlan = plan.commandPlan, - candidateArtifacts = map breakArtifact plan.candidateArtifacts, - warnings = plan.warnings, - request = plan.request, - snapshot = plan.snapshot, - plannedApplications = plan.plannedApplications + { applications = plan ^. #applications, + versionChanges = plan ^. #versionChanges, + inputChanges = plan ^. #inputChanges, + migrations = plan ^. #migrations, + reconciliation = plan ^. #reconciliation, + commandPlan = plan ^. #commandPlan, + candidateArtifacts = map breakArtifact (plan ^. #candidateArtifacts), + warnings = plan ^. #warnings, + request = plan ^. #request, + snapshot = plan ^. #snapshot, + plannedApplications = plan ^. #plannedApplications } where breakArtifact artifact = CandidateArtifact - { kind = artifact.kind, - name = artifact.name, - version = artifact.version, - originalDirectory = plan.snapshot.sessionDirectory "missing-publication-source", - sourceDirectory = artifact.sourceDirectory, - sourceUrl = artifact.sourceUrl, - repoName = artifact.repoName, - tags = artifact.tags, - sourceRevision = artifact.sourceRevision, - contentHash = artifact.contentHash, - moduleDefinition = artifact.moduleDefinition, - recipeDefinition = artifact.recipeDefinition + { kind = artifact ^. #kind, + name = artifact ^. #name, + version = artifact ^. #version, + originalDirectory = plan ^. #snapshot . #sessionDirectory "missing-publication-source", + sourceDirectory = artifact ^. #sourceDirectory, + sourceUrl = artifact ^. #sourceUrl, + repoName = artifact ^. #repoName, + tags = artifact ^. #tags, + sourceRevision = artifact ^. #sourceRevision, + contentHash = artifact ^. #contentHash, + moduleDefinition = artifact ^. #moduleDefinition, + recipeDefinition = artifact ^. #recipeDefinition } withoutApplications :: Manifest -> Manifest withoutApplications manifest = Manifest - { version = manifest.version, - genAt = manifest.genAt, - modules = manifest.modules, - vars = manifest.vars, - files = manifest.files, + { version = manifest ^. #version, + genAt = manifest ^. #genAt, + modules = manifest ^. #modules, + vars = manifest ^. #vars, + files = manifest ^. #files, applications = [], - recipe = manifest.recipe, - blueprint = manifest.blueprint, - blueprintMigrations = manifest.blueprintMigrations + recipe = manifest ^. #recipe, + blueprint = manifest ^. #blueprint, + blueprintMigrations = manifest ^. #blueprintMigrations } testTime :: UTCTime diff --git a/test/Seihou/FzfSpec.hs b/test/Seihou/FzfSpec.hs --- a/test/Seihou/FzfSpec.hs +++ b/test/Seihou/FzfSpec.hs @@ -1,5 +1,6 @@ module Seihou.FzfSpec (tests) where +import Data.Generics.Labels () import Data.Text qualified as T import Seihou.Core.Module (DiscoveredModule (..), DiscoveredRunnable (..), ModuleSource (..), RunnableKind (..)) import Seihou.Core.Types @@ -109,17 +110,17 @@ let dm = validModule "test-mod" "A test module" SourceUser case formatModuleCandidate dm of Just c -> do - c.candidateValue `shouldBe` ModuleName "test-mod" - T.isInfixOf "test-mod" c.candidateDisplay `shouldBe` True - T.isInfixOf "[user]" c.candidateDisplay `shouldBe` True + (c ^. #value) `shouldBe` ModuleName "test-mod" + T.isInfixOf "test-mod" (c ^. #display) `shouldBe` True + T.isInfixOf "[user]" (c ^. #display) `shouldBe` True Nothing -> expectationFailure "expected Just" it "returns Nothing for a failed module" $ do let dm = DiscoveredModule - { discoveredResult = Left (ModuleNotFound (ModuleName "bad") []), - discoveredSource = SourceProject, - discoveredDir = "/tmp/bad" + { result = Left (ModuleNotFound (ModuleName "bad") []), + source = SourceProject, + dir = "/tmp/bad" } case formatModuleCandidate dm of Nothing -> pure () @@ -128,7 +129,7 @@ it "includes description when present" $ do let dm = validModule "mod" "My description" SourceInstalled case formatModuleCandidate dm of - Just c -> T.isInfixOf "My description" c.candidateDisplay `shouldBe` True + Just c -> T.isInfixOf "My description" (c ^. #display) `shouldBe` True Nothing -> expectationFailure "expected Just" it "tags source correctly" $ do @@ -137,32 +138,32 @@ dmInstalled = validModule "m" "d" SourceInstalled case (formatModuleCandidate dmProject, formatModuleCandidate dmUser, formatModuleCandidate dmInstalled) of (Just p, Just u, Just i) -> do - T.isInfixOf "[project]" p.candidateDisplay `shouldBe` True - T.isInfixOf "[user]" u.candidateDisplay `shouldBe` True - T.isInfixOf "[installed]" i.candidateDisplay `shouldBe` True + T.isInfixOf "[project]" (p ^. #display) `shouldBe` True + T.isInfixOf "[user]" (u ^. #display) `shouldBe` True + T.isInfixOf "[installed]" (i ^. #display) `shouldBe` True _ -> expectationFailure "expected all Just" describe "formatRunnableCandidate" $ do it "tags prompt candidates with [prompt]" $ do let dr = DiscoveredRunnable - { drName = "review-changes", - drDescription = Just "Review current changes", - drKind = KindPrompt, - drSource = SourceProject, - drDir = "/tmp/review-changes", - drIsError = False, - drError = Nothing + { name = "review-changes", + description = Just "Review current changes", + kind = KindPrompt, + source = SourceProject, + dir = "/tmp/review-changes", + isError = False, + error = Nothing } case formatRunnableCandidate dr of - Just c -> T.isInfixOf "[prompt]" c.candidateDisplay `shouldBe` True + Just c -> T.isInfixOf "[prompt]" (c ^. #display) `shouldBe` True Nothing -> expectationFailure "expected Just" -- | Helper to create a valid discovered module for testing. validModule :: String -> String -> ModuleSource -> DiscoveredModule validModule name desc src = DiscoveredModule - { discoveredResult = + { result = Right Module { name = ModuleName (T.pack name), @@ -177,6 +178,6 @@ removal = Nothing, migrations = [] }, - discoveredSource = src, - discoveredDir = "/tmp/" ++ name + source = src, + dir = "/tmp/" ++ name }