seihou-cli-0.16.0.0: src-exe/Seihou/CLI/Upgrade.hs
module Seihou.CLI.Upgrade
( handleUpgrade,
)
where
import Control.Applicative ((<|>))
import Control.Exception (SomeException, try)
import Control.Monad (forM, forM_, when)
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.Maybe (fromMaybe, isJust)
import Data.Text qualified as T
import Data.Text.IO qualified as TIO
import Data.Time (getCurrentTime)
import Seihou.CLI.Commands (UpgradeOpts (..))
import Seihou.CLI.Install (installModuleDir)
import Seihou.CLI.InstallClosure (ClosureArtifact (..), publishStagedClosure)
import Seihou.CLI.InstallShared (InstallOutcome (..), OriginInfo (..), installedRoot, readOriginInfo, summarizeInstallRefusal)
import Seihou.CLI.InstalledRunnables (RefreshOptions (..), installKey, matchesRequest, refreshInstalledRunnables, selectInstalledRunnables)
import Seihou.CLI.Migrate
( MigrateError (..),
MigrateOpts (..),
MigrateResult (..),
pendingChainFor,
runMigrate,
)
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.Update.Render (errorOutput, renderUpdateHuman)
import Seihou.CLI.Update.Source (hashArtifactDirectory, stageCandidateSources)
import Seihou.CLI.Update.Types (CandidateArtifact (..), CandidateCatalog (..))
import Seihou.CLI.UpgradeReport (UpgradeEntry (..), UpgradeStatus (..), isFailedEntry, isRefusedEntry)
import Seihou.CLI.VersionCompare (OutdatedStatus (..), compareVersions)
import Seihou.Core.Application (buildAppliedComposition)
import Seihou.Core.Install (parseModuleName)
import Seihou.Core.Migration (MigrationPlan (..))
import Seihou.Core.Module (DiscoveredModule (..), DiscoveredRunnable (..), ModuleSource (..), RunnableKind (..), defaultSearchPaths, discoverAllModules, discoverAllRunnables, validateModule)
import Seihou.Core.Registry (Registry (..), RegistryEntry (..), RepoContents (..), discoverRepoContents)
import Seihou.Core.Types (AppliedModule (..), AppliedTarget (..), ArtifactOrigin (..), Manifest (..), Module (..), ModuleName (..), RecipeName (..))
import Seihou.Core.Version (renderVersion)
import Seihou.Dhall.Eval (evalModuleFromFile, evalRegistryFromFile)
import Seihou.Effect.FilesystemInterp (runFilesystem)
import Seihou.Effect.ManifestStore (readManifest)
import Seihou.Effect.ManifestStoreInterp (runManifestStore)
import Seihou.Prelude
import System.Directory qualified as Directory
import System.Exit (ExitCode (..), exitFailure)
import System.IO.Temp (withSystemTempDirectory)
import System.Process (readProcessWithExitCode)
handleUpgrade :: UpgradeOpts -> IO ()
handleUpgrade uopts = do
searchPaths <- defaultSearchPaths
modules <- discoverAllModules searchPaths
runnables <- discoverAllRunnables searchPaths
let installed = filter (\dm -> dm ^. #source == SourceInstalled) modules
recipes = [recipe | recipe <- runnables, recipe ^. #source == SourceInstalled, recipe ^. #kind == KindRecipe]
requested = uopts ^. #modules
selectedRecipes = [recipe | recipe <- recipes, null requested || recipe ^. #name `elem` requested]
originsWithModules <- mapM readOriginWithModule installed
installedRunnables <- selectInstalledRunnables runnables
let withOrigins = [(dm, origin) | (dm, Just origin) <- originsWithModules]
-- With no names, refresh every blueprint, prompt, and judgement that records its
-- source. A named one is selected even without provenance, so the
-- refusal below can say why it cannot be refreshed.
selectedRunnables =
[ (r, origin)
| (r, origin) <- installedRunnables,
if null requested then isJust origin else any (`matchesRequest` r) requested
]
found = map (moduleNameFromDm . fst) withOrigins <> map (^. #name) recipes
missing = filter (\name -> name `notElem` found && not (any (matchesRequest name . fst) installedRunnables)) requested
when (not (null missing)) $ TIO.putStrLn ("Artifact(s) not found: " <> T.intercalate ", " missing) >> exitFailure
-- ADR 0006: without provenance Seihou cannot know which source to refresh
-- from, and must not guess.
let unprovenanced =
[ UpgradeEntry (installKey r) Nothing Nothing $
UpgradeFailed
( "no origin metadata in "
<> T.pack (r ^. #dir </> ".seihou-origin.json")
<> "; reinstall it with 'seihou install <url> --force'"
)
| (r, Nothing) <- selectedRunnables
]
provenanced = [(r, origin) | (r, Just origin) <- selectedRunnables]
recipeResult <- upgradeRecipes uopts selectedRecipes
case recipeResult of
Left message -> do
if uopts ^. #json
then LBS.putStr (encodePretty [UpgradeEntry (recipe ^. #name) Nothing Nothing (UpgradeFailed message) | recipe <- selectedRecipes])
else TIO.putStrLn ("Recipe upgrade failed: " <> message)
exitFailure
Right (recipeEntries, covered) -> do
cache <- installedRoot
(runnableEntries, runnableCovered) <-
refreshInstalledRunnables (RefreshOptions (uopts ^. #dryRun) (uopts ^. #skipUnversioned)) cache provenanced
let filtered =
[ (dm, origin)
| (dm, origin) <- withOrigins,
null requested || moduleNameFromDm dm `elem` requested,
moduleNameFromDm dm `notElem` covered,
moduleNameFromDm dm `notElem` runnableCovered
]
grouped = Map.toList $ Map.fromListWith (++) [(origin ^. #sourceUrl, [(dm, origin)]) | (dm, origin) <- filtered]
moduleEntries <- concat <$> mapM (upgradeSource uopts) grouped
let entries = dedupeEntries (recipeEntries <> unprovenanced <> runnableEntries <> moduleEntries)
if null entries
then
if uopts ^. #json
then LBS.putStr (encodePretty entries)
else TIO.putStrLn "No installed modules, recipes, blueprints, prompts, or judgements with origin metadata found."
else do
if uopts ^. #json then LBS.putStr (encodePretty entries) else renderUpgradeTable (uopts ^. #dryRun) entries
unless (uopts ^. #dryRun) $ do
handlePostUpgradeMigrations uopts entries
when (not (uopts ^. #json)) $ forM_ selectedRecipes $ \recipe -> TIO.putStrLn $ "Run 'seihou update " <> recipe ^. #name <> "' to reconcile the recorded project application."
-- ADR 0006: a cache write that did not fully succeed exits
-- non-zero. An unreachable source is transient and does not.
when (any isRefusedEntry entries) exitFailure
-- | One row per artifact name; the first path to report a name wins.
dedupeEntries :: [UpgradeEntry] -> [UpgradeEntry]
dedupeEntries = go []
where
go _ [] = []
go seen (entry : rest)
| entry ^. #moduleName `elem` seen = go seen rest
| otherwise = entry : go (entry ^. #moduleName : seen) rest
-- Refresh each selected recipe's complete candidate closure, including an
-- unchanged child whose base has changed. Publication uses staged bytes only.
upgradeRecipes :: UpgradeOpts -> [DiscoveredRunnable] -> IO (Either Text ([UpgradeEntry], [Text]))
upgradeRecipes _ [] = pure (Right ([], []))
upgradeRecipes opts recipes = withSystemTempDirectory "seihou-recipe-upgrade" $ \session -> do
now <- getCurrentTime
root <- Directory.getCurrentDirectory
cache <- installedRoot
roots <- forM recipes $ \recipe -> do
origin <- readOriginInfo (recipe ^. #dir)
pure $ case origin of
Nothing -> Left ("Recipe '" <> recipe ^. #name <> "' has no origin metadata; reinstall it from its registry.")
Just info -> Right (buildAppliedComposition (AppliedRecipeTarget (RecipeName (recipe ^. #name))) (RemoteOrigin (info ^. #sourceUrl) (recipe ^. #name) (info ^. #repoName)) (info ^. #version) [] Nothing Nothing [] Map.empty now)
case sequence roots of
Left message -> pure (Left message)
Right applications -> do
staged <- stageCandidateSources session root cache applications
case staged of
Left err -> pure (Left (renderUpdateHuman False (errorOutput err)))
Right (catalog, _) -> do
compared <- forM (Map.elems (catalog ^. #artifacts)) $ \artifact -> do
let path = cache </> T.unpack (artifact ^. #name)
old <- readOriginInfo path
present <- Directory.doesDirectoryExist path
oldHash <- if present then Just <$> hashArtifactDirectory path else pure Nothing
let changed = oldHash /= Just (artifact ^. #contentHash)
skipped = opts ^. #skipUnversioned && (artifact ^. #version == Nothing || maybe False ((== Nothing) . (^. #version)) old)
status
| changed && skipped = Skipped
| changed = Upgraded
| otherwise = AlreadyUpToDate
entry = UpgradeEntry (artifact ^. #name) (old >>= (^. #version)) (artifact ^. #version) status
prepared = ClosureArtifact (artifact ^. #name) (fromMaybe "" (artifact ^. #sourceUrl)) (artifact ^. #repoName) (artifact ^. #version) (artifact ^. #tags) (artifact ^. #sourceRevision) (artifact ^. #sourceDirectory)
pure (entry, prepared)
let blocked = any ((== Skipped) . (^. #upgradeStatus) . fst) compared
entries = [if blocked && entry ^. #upgradeStatus == Upgraded then entry & #upgradeStatus .~ Skipped else entry | (entry, _) <- compared]
changes = [artifact | (entry, artifact) <- compared, entry ^. #upgradeStatus == Upgraded]
published <- if opts ^. #dryRun || blocked || null changes then pure (Right ()) else publishStagedClosure cache changes
pure $ do
published
Right (entries, map (^. #name) (Map.elems (catalog ^. #artifacts)))
upgradeSource :: UpgradeOpts -> (Text, [(DiscoveredModule, OriginInfo)]) -> IO [UpgradeEntry]
upgradeSource uopts (sourceUrl, modulesWithOrigins) = do
let repoName = parseModuleName sourceUrl
-- Under --json, stdout carries only the JSON document.
when (not (uopts ^. #json)) $ TIO.putStrLn $ " Cloning " <> T.pack repoName <> "..."
result <- try $ withSystemTempDirectory "seihou-upgrade" $ \tmpDir -> do
let cloneDir = tmpDir </> repoName
(exitCode, _stdout, _stderr) <- readProcessWithExitCode "git" ["clone", "--depth", "1", T.unpack sourceUrl, cloneDir] ""
case exitCode of
ExitFailure _ -> pure Nothing
ExitSuccess -> do
contents <- discoverRepoContents evalRegistryFromFile cloneDir
Just <$> mapM (upgradeModule uopts cloneDir contents sourceUrl) modulesWithOrigins
case result of
Left (_ :: SomeException) ->
pure [mkUnreachableEntry dm origin | (dm, origin) <- modulesWithOrigins]
Right Nothing ->
pure [mkUnreachableEntry dm origin | (dm, origin) <- modulesWithOrigins]
Right (Just entries) ->
pure entries
mkUnreachableEntry :: DiscoveredModule -> OriginInfo -> UpgradeEntry
mkUnreachableEntry dm origin =
UpgradeEntry
{ moduleName = moduleNameFromDm dm,
oldVersion = origin ^. #version,
newVersion = Nothing,
upgradeStatus = SourceUnreachable
}
upgradeModule :: UpgradeOpts -> FilePath -> RepoContents -> Text -> (DiscoveredModule, OriginInfo) -> IO UpgradeEntry
upgradeModule uopts cloneDir contents sourceUrl (dm, origin) = do
let name = moduleNameFromDm dm
installedVer = (origin ^. #version)
availableVer <- fetchAvailable cloneDir (ModuleName name)
let status = compareVersions installedVer availableVer
case status of
OutdatedSt
| uopts ^. #dryRun ->
pure UpgradeEntry {moduleName = name, oldVersion = installedVer, newVersion = availableVer, upgradeStatus = Upgraded}
| otherwise ->
doUpgrade uopts cloneDir contents sourceUrl origin name installedVer availableVer
UpToDate ->
pure UpgradeEntry {moduleName = name, oldVersion = installedVer, newVersion = availableVer, upgradeStatus = AlreadyUpToDate}
Unversioned
| uopts ^. #skipUnversioned ->
pure UpgradeEntry {moduleName = name, oldVersion = installedVer, newVersion = availableVer, upgradeStatus = Skipped}
| uopts ^. #dryRun ->
pure UpgradeEntry {moduleName = name, oldVersion = installedVer, newVersion = availableVer, upgradeStatus = Upgraded}
| otherwise ->
doUpgrade uopts cloneDir contents sourceUrl origin name installedVer availableVer
Unreachable ->
pure UpgradeEntry {moduleName = name, oldVersion = installedVer, newVersion = Nothing, upgradeStatus = SourceUnreachable}
doUpgrade :: UpgradeOpts -> FilePath -> RepoContents -> Text -> OriginInfo -> Text -> Maybe Text -> Maybe Text -> IO UpgradeEntry
doUpgrade uopts cloneDir contents sourceUrl origin name installedVer availableVer = do
let result = case contents of
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))
[] -> Nothing
SingleRecipe _ -> Nothing
SingleBlueprint _ -> Nothing
SinglePrompt _ -> Nothing
SingleJudgement _ -> Nothing
EmptyRepo -> Nothing
case result of
Nothing ->
pure UpgradeEntry {moduleName = name, oldVersion = installedVer, newVersion = availableVer, upgradeStatus = UpgradeFailed "module not found in remote"}
Just (moduleDir, registryName) -> do
let dhallFile = moduleDir </> "module.dhall"
decoded <- evalModuleFromFile dhallFile
case decoded of
Left err ->
pure UpgradeEntry {moduleName = name, oldVersion = installedVer, newVersion = availableVer, upgradeStatus = UpgradeFailed (T.pack (show err))}
Right modul -> do
valResult <- validateModule moduleDir modul
case valResult of
Left err ->
pure UpgradeEntry {moduleName = name, oldVersion = installedVer, newVersion = availableVer, upgradeStatus = UpgradeFailed (T.pack (show err))}
Right _ -> do
-- Trust the module.dhall version over the registry's static
-- entry.version: the registry can be stale (the bug fixed in
-- 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, 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, [])
-- Pass force = False deliberately. This reinstalls from the URL
-- the installed copy already records, so it is structurally the
-- same-source case and must never refuse. If it ever does, the
-- cache and its own provenance file disagree — real news, and
-- reported as an upgrade failure rather than overridden. Do not
-- "fix" a refusal here by passing True.
outcome <- installModuleDir False moduleDir (T.unpack name) sourceUrl registryName ver tags
case outcome of
InstallRefused collision ->
pure
UpgradeEntry
{ moduleName = name,
oldVersion = installedVer,
newVersion = availableVer,
upgradeStatus = UpgradeFailed (summarizeInstallRefusal sourceUrl collision)
}
InstallPerformed -> do
when (not (uopts ^. #json)) $ TIO.putStrLn $ " Upgraded " <> name
pure UpgradeEntry {moduleName = name, oldVersion = installedVer, newVersion = availableVer, upgradeStatus = Upgraded}
renderUpgradeTable :: Bool -> [UpgradeEntry] -> IO ()
renderUpgradeTable dryRun entries = do
colorEnabled <- useColor
let upgradedLabel = if dryRun then "would upgrade" else "upgraded"
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) " "
header =
padR maxNameLen "Artifact"
<> padR maxOldLen "Old"
<> padR maxNewLen "New"
<> "Status"
formatRow e =
let oldText = maybe "(none)" id (e ^. #oldVersion)
newText = maybe "(none)" id (e ^. #newVersion)
statusTxt = case e ^. #upgradeStatus of
Upgraded -> if colorEnabled then green upgradedLabel else upgradedLabel
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)
<> padR maxOldLen oldText
<> padR maxNewLen newText
<> statusTxt
TIO.putStrLn ""
TIO.putStrLn header
mapM_ (TIO.putStrLn . formatRow) entries
let upgraded = length (filter (\e -> e ^. #upgradeStatus == Upgraded) entries)
failed = length (filter isFailedEntry entries)
skipped = length (filter (\e -> e ^. #upgradeStatus == Skipped) entries)
TIO.putStrLn ""
TIO.putStrLn $
T.pack (show (length entries))
<> " artifact(s) checked, "
<> T.pack (show upgraded)
<> " "
<> upgradedLabel
<> (if failed > 0 then ", " <> T.pack (show failed) <> " failed" else "")
<> (if skipped > 0 then ", " <> T.pack (show skipped) <> " skipped" else "")
<> "."
-- | After the upgrade table is printed, look at the project's local
-- manifest for each module that was just upgraded. If the upgrade
-- raised the installed-copy version above the manifest's recorded
-- version, there are migrations to run. With @--with-migrations@,
-- run them. Otherwise, print a single advisory line per module.
--
-- If there's no local manifest at all (the user is upgrading without
-- a project), this is a silent no-op.
handlePostUpgradeMigrations :: UpgradeOpts -> [UpgradeEntry] -> IO ()
handlePostUpgradeMigrations uopts entries = do
let manifestPath = ".seihou" </> "manifest.json"
upgraded =
[ entry ^. #moduleName | entry <- entries, entry ^. #upgradeStatus == Upgraded
]
if null upgraded
then pure ()
else do
mfRes <- runEff $ runFilesystem $ runManifestStore manifestPath readManifest
case mfRes of
Left _ -> pure ()
Right Nothing -> pure ()
Right (Just manifest) ->
mapM_ (handleOneModule uopts manifest) upgraded
handleOneModule :: UpgradeOpts -> Manifest -> Text -> IO ()
handleOneModule uopts manifest name =
case findAppliedByName manifest name of
Nothing -> pure ()
Just am -> do
-- 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 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
(am : _) -> Just am
[] -> Nothing
printAdvisory :: Text -> MigrationPlan -> IO ()
printAdvisory name plan = do
colorEnabled <- useColor
let msg =
"note: "
<> name
<> " has "
<> T.pack (show (length (plan ^. #steps)))
<> " migration(s) pending ("
<> renderVersion (plan ^. #from)
<> " → "
<> renderVersion (plan ^. #to)
<> "); run 'seihou update' to reconcile the recorded project application"
TIO.putStrLn $ if colorEnabled then yellow msg else msg
-- | Run a migration for a single module. Reads the manifest fresh so
-- chained migrations against multiple upgraded modules see each
-- other's effects.
runOnePostUpgradeMigration :: FilePath -> Text -> IO ()
runOnePostUpgradeMigration installedDir name = do
let manifestPath = ".seihou" </> "manifest.json"
mfRes <- runEff $ runFilesystem $ runManifestStore manifestPath readManifest
case mfRes of
Right (Just manifest) -> do
let opts =
MigrateOpts
{ 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'.
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
Right (MigrateApplied _ _ _ _) -> do
colorEnabled <- useColor
let msg = " Migrated " <> name
TIO.putStrLn $ if colorEnabled then green msg else msg
Right (MigrateNoOp _) -> pure ()
Right (MigrateDryRunOK {}) -> pure ()
Left err -> do
colorEnabled <- useColor
let msg = " Migration failed for " <> name <> ": " <> renderMigrateError err
TIO.putStrLn $ if colorEnabled then red msg else msg
_ -> pure ()
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 (use --force or revert your edits)"
MigrateNoManifest _ -> "no manifest in current dir"
-- | Local @unless@ to avoid pulling in another import.
unless :: Bool -> IO () -> IO ()
unless True _ = pure ()
unless False action = action
-- | Look up the available version of a module in a cloned repo by reading
-- its @module.dhall@. Fetch errors collapse to @Nothing@; downstream
-- 'compareVersions' treats that as "unversioned" and 'doUpgrade' will
-- still attempt the install (the registry's static @version@ is no longer
-- consulted for the comparison — see EP-1).
fetchAvailable :: FilePath -> ModuleName -> IO (Maybe Text)
fetchAvailable cloneDir name = do
result <- fetchTrueModuleVersion cloneDir name
case result of
Right v -> pure v
Left _ -> pure Nothing