seihou-cli-0.5.0.0: src-exe/Seihou/CLI/Run.hs
module Seihou.CLI.Run
( handleRun,
)
where
import Control.Exception (IOException, displayException, try)
import Control.Monad (foldM, forM_, unless, when)
import Data.Map.Strict qualified as Map
import Data.Maybe (fromMaybe, isJust)
import Data.Set qualified as Set
import Data.Text qualified as T
import Data.Text.IO qualified as TIO
import Data.Time (UTCTime)
import Data.Time.Clock (getCurrentTime)
import Seihou.CLI.CommandExecution
( CommandDisposition (..),
CommandExecutionError (..),
CommandPlan (..),
CommandPolicy (..),
PlannedCommand (..),
executeCommandPlanWithOutput,
finalizeCommandReceipts,
planCommands,
)
import Seihou.CLI.Commands (RunOpts (..))
import Seihou.CLI.CommitMessage (generateCommitMessage)
import Seihou.CLI.Git (gitAdd, gitCheckIgnore, gitCommit, gitDiffCached, isGitRepo)
import Seihou.CLI.Migrate
( MigrateError (..),
MigrateOpts (..),
MigrateResult (..),
runMigrate,
)
import Seihou.CLI.PendingMigrations
( detectPendingMigrations,
formatRefusalMessage,
)
import Seihou.CLI.SavePrompted (collectPromptedValues, offerSavePrompted)
import Seihou.CLI.Shared (deriveNamespace, formatBlueprintRefusal, formatVarError, logIO, 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.Context (resolveContext)
import Seihou.Core.Migration (MigrationPlan (..))
import Seihou.Core.Module (defaultSearchPaths, discoverRunnable)
import Seihou.Core.Types
import Seihou.Core.Variable (diagnoseResolution)
import Seihou.Core.Version (renderVersion)
import Seihou.Effect.BaselineStore (pruneBaselines)
import Seihou.Effect.BaselineStoreInterp (runBaselineStore)
import Seihou.Effect.ConfigReader (readContextConfig, readGlobalConfig, readLocalConfig, readNamespaceConfig)
import Seihou.Effect.ConfigReaderInterp (runConfigReader)
import Seihou.Effect.ConfigWriterInterp (runConfigWriter)
import Seihou.Effect.ConsoleInterp (runConsole)
import Seihou.Effect.Filesystem (createDirectoryIfMissing)
import Seihou.Effect.FilesystemInterp (runFilesystem)
import Seihou.Effect.FzfInterp (runFzfIO)
import Seihou.Effect.Logger (logDebug, logError, logInfo, logWarn)
import Seihou.Effect.ManifestStore (readManifest, writeManifest)
import Seihou.Effect.ManifestStoreInterp (runManifestStore)
import Seihou.Effect.ProcessInterp (runProcessIO)
import Seihou.Engine.Baseline (manifestBaselineRefs, recordGeneratedBaselines)
import Seihou.Engine.Conflict (resolveConflicts)
import Seihou.Engine.Diff (computeDiff)
import Seihou.Engine.Execute (executePlan)
import Seihou.Engine.Preview (buildPreview)
import Seihou.Fzf (FzfResult (..), detectFzfConfig, isFzfUsable)
import Seihou.Fzf.Selector (selectModule)
import Seihou.Interaction.Confirm (confirmDefaults)
import Seihou.Manifest.Types (currentManifestVersion, emptyManifest)
import Seihou.Prelude
import System.Environment (getEnvironment)
import System.Exit (ExitCode (..), exitFailure, exitWith)
import System.FilePath (takeDirectory)
import System.IO (hFlush, hIsTerminalDevice, stdin, stdout)
handleRun :: RunOpts -> IO ()
handleRun runOpts = do
let additional = runOpts.runAdditional
level = if runOpts.runVerbose then LogVerbose else LogNormal
-- 0. Resolve module name (from argument or fzf picker)
modName <- case runOpts.runModule of
Just name -> pure name
Nothing -> do
fzfCfg <- detectFzfConfig
if isFzfUsable fzfCfg
then do
result <- runEff $ runFzfIO fzfCfg $ selectModule
case result of
FzfSelected name -> pure name
FzfCancelled -> exitWith ExitSuccess
FzfNoMatch -> do
logIO level (logError "No modules found.")
exitFailure
FzfError err -> do
logIO level (logError $ "fzf error: " <> err)
exitFailure
else do
logIO level (logError "MODULE argument is required when fzf is not available.")
exitFailure
-- 0b. Recipe detection: check if the name resolves to a recipe or a module
searchPaths <- defaultSearchPaths
(primaryName, allAdditional, recipeOverrides, recipeInfo, targetInfo) <- do
runnableResult <- discoverRunnable searchPaths modName
case runnableResult of
Right (RunnableRecipe recipe recipeDir) -> do
case expandRecipe recipe of
Left errs -> do
logIO level $
logError $
"Invalid recipe '"
<> recipe.name.unRecipeName
<> "': "
<> T.intercalate "; " errs
exitFailure
Right (primary, recipeAdditional, overrides, _recipeVars, _recipePrompts) -> do
logIO level $
logInfo $
"Recipe '" <> recipe.name.unRecipeName <> "' expanding to " <> T.pack (show (length recipe.modules)) <> " modules"
pure
( primary,
recipeAdditional ++ additional,
overrides,
Just (recipe.name, recipe.version),
(AppliedRecipeTarget recipe.name, recipeDir, recipe.version)
)
Right (RunnableModule modul moduleDir) ->
pure
( modName,
additional,
Map.empty,
Nothing,
(AppliedModuleTarget modName, moduleDir, modul.version)
)
Right (RunnableBlueprint _b _blueprintDir) -> do
-- Use the user-typed name (modName) rather than the blueprint's
-- declared name. Discovery resolves by directory name; the
-- suggested 'seihou agent run NAME' must match what the user
-- can re-type to find the same artifact.
logIO level $ logError (formatBlueprintRefusal modName)
exitFailure
Left _ ->
-- Discovery failed — let loadComposition handle the error with its detailed message
pure
( modName,
additional,
Map.empty,
Nothing,
(AppliedModuleTarget modName, "", Nothing)
)
-- 1. Load all modules in the composition (primary + additional + transitive deps)
compositionResult <- loadComposition searchPaths primaryName allAdditional
modulesInOrder <- case compositionResult of
Left (ModuleNotFound name searched) -> do
logIO level $ do
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)
exitFailure
Left err -> exitError level (T.pack (show err))
Right ms -> pure ms
-- Report composition when multiple modules are involved
when (length modulesInOrder > 1) $
logIO level $ do
logInfo $ "Composing " <> T.pack (show (length modulesInOrder)) <> " modules:"
mapM_ (\(_, m, _) -> logInfo $ " " <> m.name.unModuleName) modulesInOrder
-- 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
envVars = Map.fromList [(T.pack k, T.pack v) | (k, v) <- envPairs]
namespace = fromMaybe (deriveNamespace primaryName) runOpts.runNamespace
context <- resolveContext runOpts.runContext envVars
let contextName = fromMaybe "" context
(resolveResult, localMap, nsMap, ctxMap, globalMap) <- runEff $ runConfigReader $ runConsole $ do
localCfg <- readLocalConfig >>= unwrapConfig level
namespaceCfg <- readNamespaceConfig namespace >>= unwrapConfig level
contextCfg <- readContextConfig contextName >>= unwrapConfig level
globalCfg <- readGlobalConfig >>= unwrapConfig level
let lm = toVarNameMap localCfg
nm = toVarNameMap namespaceCfg
cm = toVarNameMap contextCfg
gm = toVarNameMap globalCfg
r <- resolveWithPrompts modulesInOrder cliOverrides envVars namespace contextName lm nm cm gm
pure (r, lm, nm, cm, gm)
resolvedInitial <- case resolveResult of
Left errs -> do
logIO level $ do
logError "Error resolving variables:"
mapM_ (logError . (" " <>) . formatVarError) errs
exitFailure
Right r -> pure r
-- 2a. Optionally confirm default-sourced values.
resolved <-
if runOpts.runConfirmDefaults
then runEff $ runConsole $ confirmDefaults modulesInOrder resolvedInitial
else pure resolvedInitial
-- 2b. Emit diagnostics for unused config keys
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)
-- 3. Compile composed plan (all modules merged)
let quads =
[ (inst, m, dir, Map.map (.value) (resolved Map.! inst))
| (inst, m, dir) <- modulesInOrder
]
planResult <- compileComposedPlan quads
(ops, warnings, ownerMap) <- case planResult of
Left errs -> do
logIO level $ do
logError "Errors compiling plan:"
mapM_ (logError . (" " <>)) errs
exitFailure
Right r -> pure r
-- 4. Filter out command ops if --no-commands
let opsFiltered =
if runOpts.runNoCommands
then filter (not . isCommandOp) ops
else ops
-- 5. Print composition warnings
mapM_ (printWarning level) warnings
-- 6. Compute diff (shared by dry-run, --diff, and execution paths)
now <- getCurrentTime
let manifestPath = ".seihou" </> "manifest.json"
baselineDir = ".seihou" </> "baselines"
planned =
[(dest, content, modName, Nothing) | WriteFileOp dest content _ <- opsFiltered]
++ [(dest, content, mName, Just pOp) | PatchFileOp dest content pOp _ mName <- opsFiltered]
-- 6a. Read the manifest before computing the diff so the pre-flight
-- migration check can run against it (and, with --with-migrations, so
-- 'runMigrate' can rewrite it before the diff is taken).
existingRes <- runEff $ runFilesystem $ runManifestStore manifestPath $ do
createDirectoryIfMissing True (takeDirectory manifestPath)
readManifest
initialManifest <- case existingRes of
Left err -> do
logIO level (logError $ "Error reading manifest: " <> err)
exitFailure
Right m -> pure (fromMaybe (emptyManifest now) m)
-- 6b. 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 <-
handlePendingMigrations level runOpts manifestPath initialManifest pendings
-- Commands are planned against the previously accepted receipts for this
-- exact top-level application. Ordinary run deliberately remains run-all;
-- --no-commands disables execution while retaining matching old receipts.
let (appliedTarget, targetSource, targetVersion) = targetInfo
currentApplicationId = mkApplicationId appliedTarget additional
priorCommandReceipts =
case [ application.commandReceipts
| application <- manifest.applications,
application.applicationId == currentApplicationId
] of
receipts : _ -> receipts
[] -> Map.empty
commandPolicy =
if runOpts.runNoCommands
then DisableCommands
else RunAllCommands
commandPlan = planCommands commandPolicy priorCommandReceipts ops
candidateCommandReceipts =
finalizeCommandReceipts commandPlan [] priorCommandReceipts
-- 6c. Compute the diff against the (possibly post-migration) manifest.
diff <- runEff $ runFilesystem $ runManifestStore manifestPath $ do
-- Diff needs every name that could own a manifest file. Each
-- 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
computeDiff manifest composedNames planned
colorEnabled <- useColor
let modNames = map (\(_, m, _) -> m.name) modulesInOrder
allVarValues =
Map.unions
[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
then
TIO.putStr (formatPlanViewColor colorEnabled modNames allVarValues preview diff)
else
if runOpts.runDiff
then TIO.putStr (formatDiff colorEnabled diff ownerMap)
else do
-- Show plan view
TIO.putStr (formatPlanViewColor colorEnabled modNames allVarValues preview diff)
-- Prompt for confirmation (skip if --force or non-interactive)
interactive <- hIsTerminalDevice stdin
when (interactive && not runOpts.runForce) $ do
TIO.putStr "\n Proceed? [Y/n] "
hFlush stdout
response <- T.strip . T.pack <$> getLine
when (response /= "" && T.toLower response /= "y") $
exitWith (ExitFailure 3)
-- Resolve conflicts interactively (or abort)
resolutions <-
runEff $
runConsole $
resolveConflicts runOpts.runForce 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
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
Just existing ->
existing {hash = c.diskHash, generatedAt = now}
Nothing ->
FileRecord
{ hash = c.diskHash,
moduleName = c.moduleName,
strategy = Template,
generatedAt = now,
baseline = Nothing,
applicationIds = mempty
}
)
| (c, KeepCurrent) <- conflictResolved
]
skipPaths = [c.path | (c, Skip) <- conflictResolved]
excludePaths = Set.fromList (Map.keys keepRecords ++ skipPaths)
opsForExec = filter (not . opTargetsPath excludePaths) opsFiltered
-- Execute the plan (excluding kept/skipped files), capture the
-- exact post-execution baselines, and only then publish the
-- manifest that references those blobs.
generationAttempt <-
try @IOException $
runEff $
runFilesystem $
runBaselineStore baselineDir $
runManifestStore manifestPath $ do
recs <- executePlan "" opsForExec ownerMap modName now
baselineResult <- recordGeneratedBaselines "" recs
case baselineResult of
Left err -> pure (Left err)
Right baselineRecords -> do
-- Build updated manifest with all composed modules.
let orphanedPaths = map (.path) diff.orphaned
cleanedFiles = foldr Map.delete manifest.files orphanedPaths
allModuleEntries = updateAllModules manifest.modules modulesInOrder now
allResolvedVals =
Map.unions
[Map.map (.value) vs | vs <- Map.elems resolved]
appliedRecipe = case recipeInfo of
Just (rName, rVersion) ->
Just AppliedRecipe {name = rName, recipeVersion = rVersion, appliedAt = now}
Nothing -> manifest.recipe
appliedCompositionWithoutReceipts =
buildAppliedComposition
appliedTarget
targetSource
targetVersion
additional
(Just namespace)
context
modulesInOrder
resolved
now
appliedComposition =
appliedCompositionWithoutReceipts
{ commandReceipts = candidateCommandReceipts
}
applicationDestinations =
Set.fromList [path | Just path <- map operationDestination opsFiltered]
combinedFiles = Map.unions [baselineRecords, keepRecords, cleanedFiles]
ownedFiles =
Map.mapWithKey
( \path record ->
if Set.member path applicationDestinations
then attachApplication appliedComposition.applicationId (Map.lookup path manifest.files) record
else record
)
combinedFiles
newManifest =
Manifest
{ version = currentManifestVersion,
genAt = now,
modules = allModuleEntries,
vars = Map.union (Map.map varValueToText allResolvedVals) manifest.vars,
files = ownedFiles,
applications = replaceAppliedComposition appliedComposition manifest.applications,
recipe = appliedRecipe,
blueprint = manifest.blueprint,
blueprintMigrations = manifest.blueprintMigrations
}
writeManifest newManifest
pure (Right newManifest)
newManifest <- case generationAttempt of
Left err -> do
logIO level $ logError $ "Error applying files or storing generated baselines: " <> T.pack (displayException err)
exitFailure
Right (Left err) -> do
logIO level $ logError $ "Error storing generated baselines: " <> T.pack (show err)
exitFailure
Right (Right saved) -> pure saved
-- Pruning is safe only after the new manifest is durable. A
-- pruning failure cannot invalidate the successful generation.
pruneAttempt <-
try @IOException $
runEff $
runFilesystem $
runBaselineStore baselineDir $
pruneBaselines (manifestBaselineRefs newManifest)
case pruneAttempt of
Left err ->
logIO level $ logWarn $ "Warning: could not prune generated baselines: " <> T.pack (displayException err)
Right _ -> pure ()
-- Report results
let nNew = length diff.new
nMod = length diff.modified
nUnch = length diff.unchanged
TIO.putStrLn $
T.pack (show nNew)
<> " new, "
<> T.pack (show nMod)
<> " modified, "
<> T.pack (show nUnch)
<> " unchanged."
-- Execute commands after file generation. The command library
-- returns candidate receipts only when the entire phase
-- succeeds, so a failed run leaves the candidate manifest with
-- no newly-minted success evidence.
forM_ commandPlan.commands $ \planned ->
when (planned.disposition == CommandWillRun) $
logIO level (logDebug $ " run " <> plannedCommandText planned)
commandResult <-
runEff $
runProcessIO $
executeCommandPlanWithOutput
now
( \_ commandStdout _ ->
when (not (T.null commandStdout)) (liftIO $ TIO.putStr commandStdout)
)
commandPlan
completedReceipts <- case commandResult of
Right receipts -> pure receipts
Left commandError -> do
when (not (T.null commandError.stdout)) $ TIO.putStr commandError.stdout
when (not (T.null commandError.stderr)) $ TIO.putStr commandError.stderr
logIO level $
logError $
"Command failed (exit "
<> T.pack (show commandError.exitCode)
<> "): "
<> plannedCommandText commandError.command
exitFailure
let finalCommandReceipts =
finalizeCommandReceipts commandPlan completedReceipts priorCommandReceipts
receiptManifest =
setApplicationCommandReceipts
currentApplicationId
finalCommandReceipts
newManifest
receiptWriteAttempt <-
try @IOException $
runEff $
runFilesystem $
runManifestStore manifestPath $
writeManifest receiptManifest
case receiptWriteAttempt of
Left err -> do
logIO level $ logError $ "Commands succeeded but their receipts could not be recorded: " <> T.pack (displayException err)
exitFailure
Right () -> pure ()
-- Commit generated files if --commit or --commit-message
when (runOpts.runCommit || isJust runOpts.runCommitMessage) $ do
let filesToStage =
map (.path) diff.new
++ map (.path) diff.modified
++ [manifestPath, baselineDir]
inGit <- runEff $ runProcessIO $ isGitRepo
if inGit
then do
ignored <- runEff $ runProcessIO $ gitCheckIgnore filesToStage
let filteredFiles = filter (`notElem` ignored) filesToStage
if null filteredFiles
then logIO level (logDebug "--commit: all generated files are git-ignored, skipping commit.")
else do
(addExit, _, addErr) <- runEff $ runProcessIO $ gitAdd filteredFiles
case addExit of
ExitFailure _ -> logIO level (logWarn $ "git add failed: " <> addErr)
ExitSuccess -> do
commitMsg <- case runOpts.runCommitMessage of
Just msg -> pure msg
Nothing -> do
diffText <- runEff $ runProcessIO $ gitDiffCached
generateCommitMessage modNames diffText
(commitExit, _, commitErr) <- runEff $ runProcessIO $ gitCommit commitMsg
case commitExit of
ExitSuccess -> logIO level (logInfo "Committed generated files to git.")
ExitFailure _ -> logIO level (logWarn $ "git commit failed: " <> commitErr)
else
logIO level (logDebug "--commit: not inside a git repository, skipping.")
-- Offer to save prompted values to local config
let prompted = collectPromptedValues resolved localMap
when (not (null prompted)) $
runEff $
runConfigWriter $
runConsole $
offerSavePrompted runOpts.runSavePrompted interactive prompted
-- Helpers
exitError :: LogLevel -> Text -> IO a
exitError level msg = do
logIO level (logError $ "Error: " <> msg)
exitFailure
printWarning :: LogLevel -> CompositionWarning -> IO ()
printWarning level (FileOverwritten path overwritten overwriter) =
logIO level . logWarn $
"Warning: "
<> T.pack path
<> " (from "
<> overwritten.unModuleName
<> ") overwritten by "
<> overwriter.unModuleName
printWarning level (ContentMerged path base contributor) =
logIO level . logWarn $
"Merged: "
<> T.pack path
<> " (base from "
<> base.unModuleName
<> ", patched by "
<> contributor.unModuleName
<> ")"
formatDiff :: Bool -> DiffResult -> Map.Map FilePath ModuleName -> Text
formatDiff color diff ownerMap' =
T.unlines $
concat
[ 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
then []
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
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
then []
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 <> ")")
Nothing -> ""
varValueToText :: VarValue -> Text
varValueToText (VText t) = t
varValueToText (VBool True) = "true"
varValueToText (VBool False) = "false"
varValueToText (VInt n) = T.pack (show n)
varValueToText (VList vs) = T.intercalate "," (map varValueToText vs)
-- | Whether an operation is a command (RunCommandOp).
isCommandOp :: Operation -> Bool
isCommandOp RunCommandOp {} = True
isCommandOp _ = False
-- | Check whether an operation targets a file in the given path set.
opTargetsPath :: Set.Set FilePath -> Operation -> Bool
opTargetsPath paths (WriteFileOp dest _ _) = Set.member dest paths
opTargetsPath paths (PatchFileOp dest _ _ _ _) = Set.member dest paths
opTargetsPath _ _ = False
-- | Return the tracked destination produced by a file operation.
operationDestination :: Operation -> Maybe FilePath
operationDestination (WriteFileOp dest _ _) = Just dest
operationDestination (CopyFileOp _ dest) = Just dest
operationDestination (PatchFileOp dest _ _ _ _) = Just dest
operationDestination _ = Nothing
plannedCommandText :: PlannedCommand -> Text
plannedCommandText planned = case planned.operation of
RunCommandOp {command} -> command
_ -> "<non-command operation>"
setApplicationCommandReceipts ::
ApplicationId ->
Map CommandFingerprint CommandReceipt ->
Manifest ->
Manifest
setApplicationCommandReceipts applicationId receipts manifest =
manifest
{ applications = map updateApplication manifest.applications
}
where
updateApplication application
| application.applicationId == applicationId =
application {commandReceipts = receipts}
| otherwise = application
-- | Apply the pending-migration policy.
--
-- Without @--with-migrations@: the run refuses and prints a one-line
-- summary per pending module.
-- With @--with-migrations@ in dry-run mode: print the same summary
-- and proceed with the diff against the current (pre-migration) disk
-- state.
-- With @--with-migrations@ in apply mode: run @seihou migrate@ for
-- each pending module before computing the run plan, persist the new
-- manifest, and continue.
--
-- Returns the manifest the run flow should continue with.
handlePendingMigrations ::
LogLevel ->
RunOpts ->
FilePath ->
Manifest ->
[(ModuleName, MigrationPlan)] ->
IO Manifest
handlePendingMigrations _ _ _ manifest [] = pure manifest
handlePendingMigrations level runOpts manifestPath manifest pendings
| not runOpts.runWithMigrations = do
TIO.putStr (formatRefusalMessage pendings)
exitFailure
| runOpts.runDryRun = do
TIO.putStrLn "Pending migrations detected (--with-migrations + --dry-run):"
mapM_ (TIO.putStrLn . renderPendingSummary) pendings
TIO.putStrLn ""
TIO.putStrLn "Note: the run plan below is computed against the current (pre-migration)"
TIO.putStrLn "disk state. Re-run without --dry-run to apply migrations and regenerate."
pure manifest
| otherwise = do
logIO level (logInfo "Applying pending migrations before run plan...")
manifest' <- foldM (applyOneMigration level) manifest pendings
runEff $
runFilesystem $
runManifestStore manifestPath $
writeManifest manifest'
pure manifest'
renderPendingSummary :: (ModuleName, MigrationPlan) -> Text
renderPendingSummary (name, plan) =
" "
<> name.unModuleName
<> ": "
<> renderVersion plan.planFrom
<> " -> "
<> renderVersion plan.planTo
<> " ("
<> T.pack (show (length plan.planSteps))
<> " step(s))"
-- | Apply one pending plan in-band. Reuses 'runMigrate' with
-- @migrateNoFetch=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
-- failure here; @seihou run --force@ governs the run plan's diff
-- conflicts, not migration conflicts. The fix is to run @seihou
-- migrate <module> --force@ first.
applyOneMigration ::
LogLevel ->
Manifest ->
(ModuleName, MigrationPlan) ->
IO Manifest
applyOneMigration level manifest (modName, _) =
case findAppliedByName manifest modName of
Nothing -> do
logIO level $
logError $
"internal error: applied module '"
<> 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
}
result <- runMigrate opts manifest am.source
case result of
Right (MigrateApplied _ manifest' _ _) -> do
TIO.putStrLn $ " Migrated " <> modName.unModuleName
pure manifest'
Right (MigrateNoOp _) -> pure manifest
Right (MigrateDryRunOK {}) -> pure manifest
Left err -> do
logIO level $
logError $
"Migration failed for "
<> 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
MigrateInstalledModuleEvalFailed _ msg -> msg
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 <module> --force' first"
MigrateNoManifest _ -> "no manifest in current dir"
findAppliedByName :: Manifest -> ModuleName -> Maybe AppliedModule
findAppliedByName manifest name =
case filter (\am -> am.name == name) manifest.modules of
(am : _) -> Just am
[] -> Nothing
-- | Update manifest's applied modules list with all composed modules.
-- | Merge the freshly-composed module instances into the manifest's
-- applied-modules list.
--
-- Each entry keeps its bare 'ModuleName' plus the edge decoration that
-- produced it, so two instances of the same module with different
-- 'ParentVars' coexist in the manifest. Matching against existing
-- entries uses the @(name, parentVars)@ pair, so regenerating only
-- refreshes the matching instance and leaves siblings unchanged.
updateAllModules ::
[AppliedModule] ->
[(ModuleInstance, Module, FilePath)] ->
UTCTime ->
[AppliedModule]
updateAllModules existing modulesInOrder now =
let composedKeys =
Set.fromList
[ (inst.instanceModule, inst.instanceParentVars)
| (inst, _, _) <- modulesInOrder
]
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,
appliedAt = now,
removal = m.removal
}
| (inst, m, dir) <- modulesInOrder
]
in filtered ++ new