seihou-cli-0.6.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.Generics.Labels ()
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.ManifestGuard
( ArtifactCheck,
blockingChecks,
checkAppliedArtifactsFor,
formatGuardOverride,
formatGuardRefusal,
)
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, 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)
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.Directory (getCurrentDirectory)
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 ^. #additional)
level = if runOpts ^. #verbose then LogVerbose else LogNormal
-- 0. Resolve module name (from argument or fzf picker)
modName <- case runOpts ^. #module_ 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 ^. #vars]) recipeOverrides
envVars = Map.fromList [(T.pack k, T.pack v) | (k, v) <- envPairs]
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
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 ^. #confirmDefaults
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 ^. #noCommands
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)
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.
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.
-- 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
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
] of
receipts : _ -> receipts
[] -> Map.empty
commandPolicy =
if runOpts ^. #noCommands
then DisableCommands
else RunAllCommands
commandPlan = planCommands commandPolicy priorCommandReceipts ops
candidateCommandReceipts =
finalizeCommandReceipts commandPlan [] priorCommandReceipts
-- 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 ^. #module_, 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 ^. #dryRun
then
TIO.putStr (formatPlanViewColor colorEnabled modNames allVarValues preview diff)
else
if runOpts ^. #diff
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 ^. #force)) $ 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 ^. #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)
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) originedModules 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
targetOrigin
targetVersion
additional
(Just namespace)
context
originedModules
resolved
now
appliedComposition =
( appliedCompositionWithoutReceipts
& #commandReceipts
.~ candidateCommandReceipts
)
applicationDestinations =
Set.fromList [path | Just path <- map operationDestination opsFiltered]
combinedFiles = Map.unions [baselineRecords, keepRecords, cleanedFiles]
ownedFiles =
Map.mapWithKey
( \path record ->
if Set.member path applicationDestinations
then attachApplication (appliedComposition ^. #applicationId) (Map.lookup path (manifest ^. #files)) record
else record
)
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 ^. #commit || isJust (runOpts ^. #commitMessage)) $ 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 ^. #commitMessage 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 ^. #savePrompted) 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
where
updateApplication application
| 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
-- 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 ^. #withMigrations) = do
TIO.putStr (formatRefusalMessage pendings)
exitFailure
| (runOpts ^. #dryRun) = 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 ^. #from)
<> " -> "
<> renderVersion (plan ^. #to)
<> " ("
<> T.pack (show (length (plan ^. #steps)))
<> " step(s))"
-- | Apply one pending plan in-band. Reuses 'runMigrate' with
-- @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
-- 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
{ 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
}
-- 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)
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"
MigrateArtifactUnresolved refErr -> renderArtifactRefError refErr
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, ArtifactOrigin)] ->
UTCTime ->
[AppliedModule]
updateAllModules existing modulesInOrder now =
let composedKeys =
Set.fromList
[ (inst ^. #module_, inst ^. #parentVars)
| (inst, _, _) <- modulesInOrder
]
filtered = filter (\am -> not (Set.member (am ^. #name, am ^. #parentVars) composedKeys)) existing
new =
[ AppliedModule
{ name = inst ^. #module_,
parentVars = inst ^. #parentVars,
origin = origin,
moduleVersion = m ^. #version,
appliedAt = now,
removal = m ^. #removal
}
| (inst, m, origin) <- modulesInOrder
]
in filtered ++ new