seihou-cli-0.10.0.0: src/Seihou/CLI/Update.hs
module Seihou.CLI.Update
( UpdateSelection (..),
PromptPolicy (..),
UpdateRequest (..),
VersionChange (..),
InputChangeSummary (..),
CandidateArtifactKind (..),
CandidateArtifact (..),
PlannedUpdateMigration (..),
UpdateWarning (..),
UpdatePlan (..),
CommandSummary (..),
UpdateResult (..),
UpdateError (..),
planProjectUpdate,
applyProjectUpdate,
withProjectUpdate,
isUpdateNoOp,
)
where
import Control.Exception (SomeException, displayException, throwIO, toException, try)
import Control.Monad (foldM, forM, forM_, when)
import Data.Aeson qualified as Aeson
import Data.ByteString qualified as BS
import Data.ByteString.Lazy qualified as LBS
import Data.Containers.ListUtils (nubOrd)
import Data.Foldable (traverse_)
import Data.Generics.Labels ()
import Data.List (find, isPrefixOf)
import Data.Map.Strict qualified as Map
import Data.Maybe (fromMaybe, isJust, isNothing, listToMaybe, mapMaybe, maybeToList)
import Data.Set qualified as Set
import Data.Text qualified as T
import Data.Text.IO qualified as TIO
import Data.Time (UTCTime, getCurrentTime)
import Effectful (runEff)
import Seihou.CLI.CommandExecution
import Seihou.CLI.InstallShared (InstallOutcome (..), installModuleDir, summarizeInstallRefusal)
import Seihou.CLI.ManifestCapabilityUpgrade
( CertificationGap (..),
CertificationScope (..),
EvidencePolicy (..),
EvidenceSource,
SharedWriteCertification,
certifiedChanges,
certifySharedWriteModesIO,
)
import Seihou.CLI.Shared (deriveNamespace, toVarNameMap)
import Seihou.CLI.Update.Migrations
import Seihou.CLI.Update.Recovery
import Seihou.CLI.Update.Selection
import Seihou.CLI.Update.Source
import Seihou.CLI.Update.Types
import Seihou.Composition.Instance (ModuleInstance (..))
import Seihou.Composition.Plan (compileComposedPlan)
import Seihou.Composition.Recipe (expandRecipe)
import Seihou.Composition.Resolve
( PromptPermission (..),
SavedInstanceValues,
loadComposition,
resolveWithPromptPermission,
)
import Seihou.Core.Application (buildAppliedComposition, replaceAppliedComposition)
import Seihou.Core.ArtifactOriginDetect (detectArtifactOrigin)
import Seihou.Core.ArtifactRef (renderArtifactRefError, resolveArtifactOrigin)
import Seihou.Core.Checkout
import Seihou.Core.Module (defaultSearchPaths, discoverRunnable)
import Seihou.Core.Types
import Seihou.Core.Version (parseVersion)
import Seihou.Effect.BaselineStore (pruneBaselines)
import Seihou.Effect.BaselineStoreInterp (runBaselineStore)
import Seihou.Effect.ConfigReader
import Seihou.Effect.ConfigReaderInterp (runConfigReader)
import Seihou.Effect.ConsoleInterp (runConsole)
import Seihou.Effect.Filesystem (PathEntry (..), inspectPath)
import Seihou.Effect.FilesystemInterp (runFilesystem)
import Seihou.Effect.FilesystemPure (PureFS (..))
import Seihou.Effect.ManifestStore (writeManifest)
import Seihou.Effect.ManifestStoreInterp (runManifestStore)
import Seihou.Effect.ProcessInterp (runProcessIO)
import Seihou.Engine.Baseline (manifestBaselineRefs)
import Seihou.Engine.Checkout
import Seihou.Engine.Migrate (ExecutedMigrationPlan (..), MigrationOpInstance (..), classifyMigration, executeMigration)
import Seihou.Engine.Reconcile
import Seihou.Engine.UpdateTransaction
import Seihou.Manifest.Hash (hashContent)
import Seihou.Manifest.JSON (decodeManifestValue)
import Seihou.Manifest.Types
( currentManifestVersion,
manifestFromJSON,
manifestSupports,
minimumManifestVersion,
oldestDecodableManifestVersion,
)
import Seihou.Manifest.Upgrade (documentSchemaVersion, renderManifestUpgradeError, upgradeDocumentLosslessly)
import Seihou.Prelude
import System.Directory qualified as Directory
import System.Environment (getEnvironment)
import System.FilePath (takeDirectory)
import System.IO.Temp (createTempDirectory, getCanonicalTemporaryDirectory, withSystemTempDirectory)
-- | Lifetime-safe public planning entry point. Candidate clones exist for the
-- callback only, so an 'UpdatePlan' cannot accidentally outlive its sources.
withProjectUpdate ::
UpdateRequest ->
(Either UpdateError UpdatePlan -> IO a) ->
IO a
withProjectUpdate request callback =
withSystemTempDirectory "seihou-project-update" $ \sessionDirectory ->
planProjectUpdateIn sessionDirectory request >>= callback
-- | Internal/test-facing planner. Prefer 'withProjectUpdate'; this form keeps
-- its temporary session until process exit or a test removes it.
planProjectUpdate :: UpdateRequest -> IO (Either UpdateError UpdatePlan)
planProjectUpdate request = do
temporaryRoot <- getCanonicalTemporaryDirectory
sessionDirectory <- createTempDirectory temporaryRoot "seihou-project-update"
result <- planProjectUpdateIn sessionDirectory request
case result of
Left _ -> Directory.removePathForcibly sessionDirectory
Right _ -> pure ()
pure result
planProjectUpdateIn :: FilePath -> UpdateRequest -> IO (Either UpdateError UpdatePlan)
planProjectUpdateIn sessionDirectory request = do
projectRoot <- Directory.getCurrentDirectory
installedDirectory <- standardInstalledDirectory
recovery <- recoverAtEntry projectRoot
case recovery of
Left err -> pure (Left err)
Right () -> do
let manifestPath = projectRoot </> ".seihou" </> "manifest.json"
baselineDirectory = projectRoot </> ".seihou" </> "baselines"
manifestResult <- readManifestForUpdate manifestPath
case manifestResult of
Left err -> pure (Left err)
Right (document, manifest) -> do
now <- getCurrentTime
resolved <- resolveSelection request sessionDirectory projectRoot installedDirectory manifestPath document manifest now
case resolved of
Left err -> pure (Left err)
Right resolution -> do
let base = resolution ^. #manifest
selected = resolution ^. #applications
seedWarnings = resolution ^. #warnings
staging <- case resolution ^. #staged of
Just staged -> pure (Right staged)
Nothing -> stageSelection request sessionDirectory projectRoot installedDirectory now selected
case staging of
Left err -> pure (Left err)
Right staged -> do
let catalog = staged ^. #catalog
sourceWarnings = staged ^. #warnings
plannedApplications = staged ^. #plannedApplications
applicationInputs =
[ (Just previous, planned ^. #modulesInOrder)
| (previous, planned) <- zip selected plannedApplications
]
stagedMigrations <- planAndStageMigrations projectRoot base catalog applicationInputs
case stagedMigrations of
Left err -> pure (Left err)
Right migrationStage -> do
let (operations, owners, compositionWarnings) = combineApplicationPlans plannedApplications
selectedIds = Set.fromList (map (^. #candidate . #applicationId) plannedApplications)
stageRoot <- materializeStagedProject sessionDirectory projectRoot (migrationStage ^. #filesystem) operations
reconciliationResult <-
runEff $
runFilesystem $
runBaselineStore baselineDirectory $
planReconciliation stageRoot (migrationStage ^. #manifest) selectedIds operations owners
case reconciliationResult of
Left err -> pure (Left (UpdateReconciliationFailed err))
Right reconciliation -> do
checkoutSetup <- planCheckoutUpdate projectRoot base plannedApplications
case checkoutSetup of
Left err -> pure (Left err)
Right (checkoutCandidate, checkoutPlan) -> do
evidence <- versionEvidence (request ^. #allowDowngrade) projectRoot catalog selected plannedApplications
case evidence of
Left err -> pure (Left err)
Right (versionChanges, versionWarnings) -> do
let usedArtifacts = artifactsUsedBy catalog plannedApplications
priorReceipts = Map.unions (map (^. #commandReceipts) selected)
commandPlan = planCommands (request ^. #commandPolicy) priorReceipts operations
warnings =
seedWarnings
<> sourceWarnings
<> migrationStage ^. #warnings
<> compositionWarnings
<> versionWarnings
<> map CheckoutWarning (concatMap (^. #warnings) (checkoutPlan ^. #entries))
inputChanges = summarizeInputChanges seedWarnings plannedApplications
transactionTargets = transactionTargetPaths base reconciliation (migrationStage ^. #plans) `Set.union` Set.fromList [entry ^. #dest | entry <- checkoutPlan ^. #entries, entry ^. #action `elem` [CreateLink, ReplaceLink, RetireLink]]
-- The manifest is observed as it is on disk, before
-- any in-memory preparation, so an edit made between
-- planning and apply is reported as a stale plan.
observedProjectHashes <-
observePaths
projectRoot
(Set.insert (".seihou" </> "manifest.json") transactionTargets)
let snapshot =
UpdateSnapshot
{ sessionDirectory,
projectRoot,
manifestPath,
baselineDirectory,
installedDirectory,
originalManifest = manifest,
candidateHashes = Map.fromList [(artifact ^. #originalDirectory, artifact ^. #contentHash) | artifact <- usedArtifacts],
observedProjectHashes,
transactionTargets
}
pure
( Right
UpdatePlan
{ applications = map (^. #candidate) plannedApplications,
versionChanges,
inputChanges,
migrations = migrationStage ^. #plans,
reconciliation,
checkoutPlan,
checkoutOutputs = checkoutCandidate ^. #checkoutOutputs,
commandPlan,
candidateArtifacts = usedArtifacts,
warnings,
request,
snapshot,
plannedApplications,
manifestPreparation = manifestPreparationFor manifest base (resolution ^. #evidenceSources)
}
)
-- | Candidate sources staged for a set of applications, and those
-- applications planned against them.
data StagedSelection = StagedSelection
{ applicationIds :: !(Set ApplicationId),
catalog :: !CandidateCatalog,
warnings :: ![UpdateWarning],
plannedApplications :: ![PlannedApplication]
}
deriving stock (Generic)
-- | What an update will apply to, decided before anything outside the
-- temporary session is touched.
data SelectionResolution = SelectionResolution
{ -- | The manifest planning starts from: the on-disk manifest, or the one
-- a targeted update prepared in memory.
manifest :: !Manifest,
applications :: ![AppliedComposition],
warnings :: ![UpdateWarning],
-- | Candidates already staged for exactly 'applications' while
-- establishing evidence, so they are not cloned or compiled twice.
staged :: !(Maybe StagedSelection),
-- | Recorded releases fetched from their remotes to certify paths.
evidenceSources :: ![EvidenceSource]
}
deriving stock (Generic)
-- | Match the request, then settle the ownership closure.
--
-- A targeted update needs the 'TargetedAdditiveSharedPathUpdate' capability,
-- so an older manifest is first prepared in memory with the lossless schema
-- steps that reach its minimum. Paths the closure cannot yet decide because
-- their shared-write mode is unknown are certified for the selection: the
-- selected applications' candidates are staged and compiled, the recorded
-- co-owners are compiled from their recorded state, and the closure is
-- enforced again on the certified manifest. Nothing here writes outside the
-- session directory, runs a command, or reconciles a co-owner's files.
resolveSelection ::
UpdateRequest ->
FilePath ->
FilePath ->
FilePath ->
FilePath ->
Aeson.Value ->
Manifest ->
UTCTime ->
IO (Either UpdateError SelectionResolution)
resolveSelection request sessionDirectory projectRoot installedDirectory manifestPath document manifest now =
case matchApplications (request ^. #selection) manifest of
Left err -> pure (Left err)
Right (MatchedAll applications) -> pure (Right (SelectionResolution manifest applications [] Nothing []))
Right (MatchedLegacy name) -> do
seeded <- seedLegacyApplication request projectRoot manifest now name
pure (fmap (\(applications, warnings) -> SelectionResolution manifest applications warnings Nothing []) seeded)
Right (MatchedNamed named) ->
case prepareManifestSchema manifestPath TargetedAdditiveSharedPathUpdate document manifest of
Left err -> pure (Left err)
Right prepared -> closeOver (1 :: Int) prepared Nothing [] named
where
policy
| request ^. #includeSharedOwners = IncludeSharedOwners
| otherwise = RequireNamedOwners
closeOver attempt current staged sources named = case enforceOwnershipClosure policy current named of
Left err -> pure (Left err)
Right (ClosureSatisfied ids warnings) ->
pure (Right (SelectionResolution current (applicationsWithIds current ids) warnings (reusable ids staged) sources))
Right (ClosureNeedsEvidence ids _ paths) -> do
stagedResult <- case reusable ids staged of
Just existing -> pure (Right existing)
Nothing ->
stageSelection
request
(sessionDirectory </> ("evidence-" <> show attempt))
projectRoot
installedDirectory
now
(applicationsWithIds current ids)
case stagedResult of
Left err -> pure (Left err)
Right evidenceStage -> do
searchPaths <- defaultSearchPaths
let supplied =
Map.fromList
[ (planned ^. #candidate . #applicationId, planned ^. #operations)
| planned <- evidenceStage ^. #plannedApplications
]
-- A co-owner whose recorded release is no longer installed is
-- read from its recorded remote into this session, never into
-- the install cache.
certification <-
certifySharedWriteModesIO
(FetchRecordedReleases sessionDirectory)
projectRoot
searchPaths
(CertifyPathsForApplications ids)
current
supplied
-- Certification only ever turns unknown into known, so a round
-- that changes nothing cannot be followed by one that does.
if null (certifiedChanges certification)
then pure (Left (evidenceUnavailable current certification paths))
else
closeOver
(attempt + 1)
(certification ^. #manifest)
(Just evidenceStage)
(nubOrd (sources <> certification ^. #fetchedSources))
named
reusable ids staged = case staged of
Just existing | existing ^. #applicationIds == ids -> Just existing
_ -> Nothing
-- | The first path the closure is waiting on that certification could not
-- settle, with every owner whose evidence is missing.
evidenceUnavailable :: Manifest -> SharedWriteCertification -> [FilePath] -> UpdateError
evidenceUnavailable manifest certification paths =
case [entry | entry <- certification ^. #entries, entry ^. #path `elem` paths, entry ^. #certifiedMode == SharedWriteUnknown] of
entry : _ ->
SharedWriteEvidenceUnavailable
(entry ^. #path)
[(applicationRef manifest (gapOwner gap), gap) | gap <- entry ^. #gaps]
[] -> SharedWriteEvidenceUnavailable (fromMaybe "" (listToMaybe paths)) []
where
gapOwner (OwnerNotRecorded owner) = owner
gapOwner (OwnerEvidenceUnavailable owner _) = owner
gapOwner (OwnerEmitsNoOperation owner) = owner
-- | Stage candidates for these applications and plan each of them.
stageSelection ::
UpdateRequest ->
FilePath ->
FilePath ->
FilePath ->
UTCTime ->
[AppliedComposition] ->
IO (Either UpdateError StagedSelection)
stageSelection request stagingDirectory projectRoot installedDirectory now selected = do
staged <- stageCandidateSources stagingDirectory projectRoot installedDirectory selected
case staged of
Left err -> pure (Left err)
Right (catalog, warnings) -> do
planned <- traverse (planApplication request projectRoot catalog now) selected
pure $ do
plannedApplications <- sequence planned
Right
StagedSelection
{ applicationIds = Set.fromList (map (^. #applicationId) selected),
catalog,
warnings,
plannedApplications
}
-- | Bring a manifest up to the schema a capability needs, in memory, using
-- lossless steps only. The on-disk file is untouched; the result is
-- published, if at all, with the update that needed it
-- (docs/adr/0014-every-semantic-manifest-change-advances-the-schema-version.md).
prepareManifestSchema :: FilePath -> ManifestCapability -> Aeson.Value -> Manifest -> Either UpdateError Manifest
prepareManifestSchema path capability document manifest
| manifestSupports capability manifest = Right manifest
| otherwise = do
(_, upgraded) <-
first
(UpdateManifestUnreadable path . renderManifestUpgradeError)
(upgradeDocumentLosslessly (minimumManifestVersion capability) document)
case Aeson.fromJSON upgraded of
Aeson.Error err -> Left (UpdateManifestUnreadable path (T.pack err))
Aeson.Success prepared -> Right prepared
-- | Describe what preparation changed, or 'Nothing' when it changed nothing.
manifestPreparationFor :: Manifest -> Manifest -> [EvidenceSource] -> Maybe ManifestPreparation
manifestPreparationFor original prepared evidenceSources
| original ^. #version == prepared ^. #version && Map.null modeChanges = Nothing
| otherwise =
Just
ManifestPreparation
{ fromVersion = original ^. #version,
toVersion = prepared ^. #version,
modeChanges,
evidenceSources,
preparedManifest = prepared
}
where
modeChanges =
Map.fromList
[ (path, (before ^. #sharedWriteMode, after ^. #sharedWriteMode))
| (path, after) <- Map.toAscList (prepared ^. #files),
Just before <- [Map.lookup path (original ^. #files)],
before ^. #sharedWriteMode /= after ^. #sharedWriteMode
]
-- | The manifest an accepted plan applies on top of.
planBaseManifest :: UpdatePlan -> Manifest
planBaseManifest plan =
maybe (plan ^. #snapshot . #originalManifest) (^. #preparedManifest) (plan ^. #manifestPreparation)
applyProjectUpdate :: UpdatePlan -> IO (Either UpdateError UpdateResult)
applyProjectUpdate plan =
Directory.withCurrentDirectory (plan ^. #snapshot . #projectRoot) $ do
recovery <- recoverAtEntry (plan ^. #snapshot . #projectRoot)
case recovery of
Left err -> pure (Left err)
Right () -> do
stale <- stalePlanPaths plan
if not (Set.null stale)
then pure (Left (UpdatePlanStale stale))
else
if plan ^. #request . #dryRun
then pure (Right (dryRunResult plan))
else
if not (Set.null (unresolvedPaths (plan ^. #reconciliation)))
then pure (Left (UpdateHasUnresolvedPaths (unresolvedPaths (plan ^. #reconciliation))))
else
if isStructuredNoOp plan
then pure (Right (noOpResult plan))
else applyAcceptedPlan plan
applyAcceptedPlan :: UpdatePlan -> IO (Either UpdateError UpdateResult)
applyAcceptedPlan plan = do
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)
case backupResult of
Left err -> abortUpdate transaction err
Right () -> do
now <- getCurrentTime
migrated <- runRealMigrations now (planBaseManifest plan) (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
Left _ ->
abortUpdate
transaction
( UpdateChangedAfterMigrationCommand
(reconciliationSummary (plan ^. #reconciliation))
(reconciliationSummary actual)
)
Right resolvedActual
| resolvedActual /= plan ^. #reconciliation ->
abortUpdate
transaction
( UpdateChangedAfterMigrationCommand
(reconciliationSummary (plan ^. #reconciliation))
(reconciliationSummary resolvedActual)
)
| otherwise -> do
let reconciliationManifest = (migratedManifest & #genAt .~ now)
appliedFiles <- applyReconciliation transaction resolvedActual reconciliationManifest
case appliedFiles of
Left err -> abortUpdate transaction (UpdateTransactionFailed err)
Right filesManifest -> do
linkResult <- applyUpdateCheckout plan migratedManifest filesManifest
case linkResult of
Left err -> abortUpdate transaction err
Right () -> do
commandResult <-
runEff $
runProcessIO $
executeCommandPlan now (plan ^. #commandPlan)
case commandResult of
Left err ->
abortUpdate
transaction
(UpdateCommandFailed err [ArbitraryCommandSideEffectsMayRemain])
Right completedReceipts -> do
let finalManifest = buildFinalManifest now plan filesManifest completedReceipts
markerResult <- setCommitMarkers transaction finalManifest
case markerResult of
Left err -> abortUpdate transaction err
Right () -> do
publication <- publishCandidates (plan ^. #candidateArtifacts)
case publication of
Left err -> abortUpdate transaction err
Right () -> do
written <- writeManifestIO (plan ^. #snapshot . #manifestPath) finalManifest
case written of
Left err -> abortUpdate transaction err
Right () -> finishCommitted transaction plan finalManifest completedReceipts
planApplication ::
UpdateRequest ->
FilePath ->
CandidateCatalog ->
UTCTime ->
AppliedComposition ->
IO (Either UpdateError PlannedApplication)
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
case loaded of
Left err -> pure (Left (CandidateLoadFailed (primary ^. #unModuleName) err))
Right modulesInOrder -> do
let savedValues
| (request ^. #reconfigure) = Map.empty
| otherwise = savedInstanceValues previous
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) <- modulesInOrder
]
case compiled of
Left errors -> pure (Left (UpdateCompositionFailed errors))
Right (operations, compositionWarnings, rawOwners) -> do
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
(candidate0 ^. #instances)
(previous ^. #commandReceipts)
candidate0
desiredOwners =
Map.map
(\owner -> DesiredFileOwner owner (Set.singleton (candidate ^. #applicationId)))
rawOwners
renderedWarnings = map compositionWarning compositionWarnings
pure
( Right
PlannedApplication
{ previous = Just previous,
candidate,
modulesInOrder,
resolvedValues,
operations,
desiredOwners
}
)
where
compositionWarning (FileOverwritten path old new) = CrossApplicationLastWriter path old new
compositionWarning (ContentMerged path old new) = CrossApplicationLastWriter path old new
candidateRoot ::
CandidateCatalog ->
AppliedComposition ->
Either UpdateError (ModuleName, [ModuleName], Map VarName Text, CandidateArtifact)
candidateRoot catalog previous = case previous ^. #target of
AppliedModuleTarget name -> do
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)
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))
resolveApplicationValues ::
UpdateRequest ->
Text ->
Text ->
SavedInstanceValues ->
Map VarName Text ->
[(ModuleInstance, Module, FilePath)] ->
IO (Either UpdateError (Map ModuleInstance (Map VarName ResolvedVar)))
resolveApplicationValues request namespace context saved recipeOverrides modulesInOrder = do
envPairs <- getEnvironment
configs <- loadConfigMaps namespace context
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]
overrides = Map.union cli recipeOverrides
env = Map.fromList [(T.pack key, T.pack value) | (key, value) <- envPairs]
promptPermission = case request ^. #promptPolicy of
AllowPrompts -> PromptsAllowed
ForbidPrompts -> PromptsForbidden
result <-
runEff $
runConsole $
resolveWithPromptPermission
promptPermission
modulesInOrder
saved
overrides
env
namespace
context
localConfig
namespaceConfig
contextConfig
globalConfig
pure (first UpdateVariableErrors result)
loadConfigMaps :: Text -> Text -> IO (Either UpdateError (Map VarName Text, Map VarName Text, Map VarName Text, Map VarName Text))
loadConfigMaps namespace context =
runEff $ runConfigReader $ do
local <- readLocalConfig
namespaceValues <- readNamespaceConfig namespace
contextValues <- readContextConfig context
global <- readGlobalConfig
pure $ do
local' <- configResult local
namespace' <- configResult namespaceValues
context' <- configResult contextValues
global' <- configResult global
Right (toVarNameMap local', toVarNameMap namespace', toVarNameMap context', toVarNameMap global')
where
configResult = first (UpdateConfigurationFailed . T.pack . show)
seedLegacyApplication ::
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)
RunnableRecipe recipe directory -> do
(primary, additional, overrides, _, _) <- first (CandidateRepositoryInvalid requested) (expandRecipe recipe)
Right (AppliedRecipeTarget (recipe ^. #name), primary, additional, overrides, directory, recipe ^. #version)
_ -> Left (CandidateArtifactMissing CandidateModule requested)
case root of
Left err -> pure (Left err)
Right (target, primary, additional, recipeOverrides, targetSource, targetVersion) -> do
loaded <- loadComposition searchPaths primary additional
case loaded of
Left err -> pure (Left (CandidateLoadFailed requested err))
Right modulesInOrder -> do
let (saved, warnings) = legacySavedValues manifest modulesInOrder
namespace = deriveNamespace primary
resolved <- resolveApplicationValues request namespace "" saved recipeOverrides modulesInOrder
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 targetOrigin targetVersion [] (Just namespace) Nothing originedModules resolvedValues now
provisional =
( provisional0
& #instances
%~ map (restoreLegacyVersion manifest)
)
pure (Right ([provisional], warnings))
legacySavedValues ::
Manifest ->
[(ModuleInstance, Module, FilePath)] ->
(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]
saved =
Map.fromListWith
Map.union
[ (instanceId, Map.singleton (declaration ^. #name) value)
| (instanceId, declaration) <- declarations,
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)
]
missing =
[ MissingLegacyValue (declaration ^. #name)
| (_, declaration) <- declarations,
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
Nothing -> state
Just applied ->
AppliedInstanceState
{ 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
]
combineApplicationPlans ::
[PlannedApplication] ->
([Operation], Map FilePath DesiredFileOwner, [UpdateWarning])
combineApplicationPlans = foldl' addApplication ([], Map.empty, [])
where
addApplication (operations, owners, warnings) application =
let crossWarnings =
[ CrossApplicationLastWriter path (prior ^. #moduleName) (next ^. #moduleName)
| (path, next) <- Map.toAscList (application ^. #desiredOwners),
Just prior <- [Map.lookup path owners],
prior ^. #moduleName /= next ^. #moduleName
]
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))
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_ (Set.toAscList (Set.fromList (mapMaybe operationDestination operations))) $ \path -> do
stagedExists <- Directory.doesFileExist (stageRoot </> path)
when (not stagedExists) $ do
let projectPath = projectRoot </> path
projectExists <- Directory.doesFileExist projectPath
when projectExists (TIO.readFile projectPath >>= writeStageFile stageRoot path)
pure stageRoot
writeStageFile :: FilePath -> FilePath -> Text -> IO ()
writeStageFile root path content = do
Directory.createDirectoryIfMissing True (takeDirectory (root </> path))
TIO.writeFile (root </> path) content
operationDestination :: Operation -> Maybe FilePath
operationDestination WriteFileOp {dest} = Just dest
operationDestination CopyFileOp {dest} = Just dest
operationDestination PatchFileOp {dest} = Just dest
operationDestination _ = Nothing
versionEvidence ::
-- | Whether @--allow-downgrade@ was passed.
Bool ->
FilePath ->
CandidateCatalog ->
[AppliedComposition] ->
[PlannedApplication] ->
IO (Either UpdateError ([VersionChange], [UpdateWarning]))
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 allowDowngrade) actualChanges
let unique = Map.elems (Map.fromList [(versionKey change, change) | change <- actualChanges])
warnings =
[ SameVersionContentChanged (change ^. #name)
| change <- unique,
change ^. #sameVersionContentChanged,
isJust (change ^. #fromVersion)
]
Right (unique, warnings)
where
applicationEvidence previous planned = do
instanceEvidence <- traverse (instanceVersionEvidence previous) (planned ^. #modulesInOrder)
targetEvidence <- targetVersionEvidence previous
pure (targetEvidence : instanceEvidence)
instanceVersionEvidence previous (instanceId, candidateModule, _) = do
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 ^. #origin) CandidateModule
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 ^. #targetOrigin) CandidateRecipe
candidateVersion kind name = (^. #version) =<< 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
pure
( Right
VersionChange
{ name,
fromVersion,
toVersion,
sameVersionContentChanged = changed && fromVersion == toVersion
}
)
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)
-- | 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 && 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)
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)
summarizeInputChanges :: [UpdateWarning] -> [PlannedApplication] -> InputChangeSummary
summarizeInputChanges seedWarnings planned =
foldl' summarizeApplication emptySummary planned
where
emptySummary =
InputChangeSummary
{ reused = 0,
overridden = 0,
newlyResolved = 0,
removed = 0,
ambiguousLegacy = [name | AmbiguousLegacyValue name <- seedWarnings]
}
summarizeApplication summary application =
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]
overriddenCount =
length
[ ()
| (instanceId, name, value) <- resolvedList,
value ^. #source == FromCLI,
Map.member name (Map.findWithDefault Map.empty instanceId prior)
]
newCount =
length
[ ()
| (instanceId, name, _) <- resolvedList,
Map.notMember name (Map.findWithDefault Map.empty instanceId prior)
]
removedCount =
length
[ ()
| (instanceId, oldValues) <- Map.toList prior,
name <- Map.keys oldValues,
Map.notMember name (Map.findWithDefault Map.empty instanceId candidateValues)
]
in summary
& #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)
where
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))
targets RunCommandInst {} = []
moveDirectoryTarget source destination path
| isPathAtOrBelow source path = [path, replacePrefix source destination path]
| isPathAtOrBelow destination path = [path]
| otherwise = []
isPathAtOrBelow :: FilePath -> FilePath -> Bool
isPathAtOrBelow directory path = path == directory || (directory <> "/") `isPrefixOf` path
replacePrefix :: FilePath -> FilePath -> FilePath -> FilePath
replacePrefix source destination path
| path == source = destination
| otherwise = destination <> drop (length source) path
observePaths :: FilePath -> Set FilePath -> IO (Map FilePath (Maybe SHA256))
observePaths projectRoot paths =
Map.fromList <$> traverse observe (Set.toAscList paths)
where
observe path = do
let fullPath = projectRoot </> path
entry <- runEff $ runFilesystem $ inspectPath fullPath
hash <- case entry of
EntrySymlink target -> pure (Just (hashContent ("symlink\0" <> T.pack target)))
EntryFile -> Just . hashContent <$> TIO.readFile fullPath
_ -> pure Nothing
pure (path, hash)
stalePlanPaths :: UpdatePlan -> IO (Set FilePath)
stalePlanPaths plan = do
currentProject <-
observePaths
(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))
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))
result <-
runEff $
runFilesystem $
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
-- reconciliation rebuilt after real migration commands. Exact equality is
-- still required afterward, so a command-induced classification or content
-- change remains a stale-plan failure rather than inheriting an old choice.
reapplyPlannedResolutions ::
ReconciliationPlan ->
ReconciliationPlan ->
Either ReconciliationError ReconciliationPlan
reapplyPlannedResolutions planned actual =
foldM reapplyOne actual (Map.toAscList (planned ^. #files))
where
reapplyOne actual (path, FileConflict _ _ _ _ _ _ (Just resolved)) =
resolveFileConflict path (resolved ^. #choice) actual
reapplyOne actual (path, FileOrphanEdited _ _ _ _ (Just choice)) =
resolveEditedOrphan path choice actual
reapplyOne actual _ = Right actual
runRealMigrations :: UTCTime -> Manifest -> [PlannedUpdateMigration] -> IO (Either UpdateError Manifest)
runRealMigrations now manifest migrations =
runEff $ runFilesystem $ runProcessIO $ go manifest migrations
where
go current [] = pure (Right current)
go current (migration : rest) = do
classified <- classifyMigration current (migration ^. #sourcePlan)
case classified of
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))
Right next -> go next rest
buildFinalManifest :: UTCTime -> UpdatePlan -> Manifest -> [CommandReceipt] -> Manifest
buildFinalManifest now plan filesManifest completedReceipts =
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,
recipe = updatedRecipe,
blueprint = filesManifest ^. #blueprint,
seeds = filesManifest ^. #seeds,
checkoutOutputs = plan ^. #checkoutOutputs,
blueprintMigrations = filesManifest ^. #blueprintMigrations
}
where
finalApplications = map finalizeApplication (plan ^. #plannedApplications)
finalizeApplication application =
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)
candidateVars =
Map.unions
[ Map.map (varValueToText . (^. #value)) values
| application <- plan ^. #plannedApplications,
values <- Map.elems (application ^. #resolvedValues)
]
updatedRecipe =
foldl' updateRecipe (filesManifest ^. #recipe) finalApplications
-- The composition's targetOrigin is the recipe's own portable identity on
-- this branch, because the target is the recipe.
updateRecipe current application = case application ^. #target of
AppliedRecipeTarget name ->
Just
AppliedRecipe
{ name,
origin = application ^. #targetOrigin,
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 ^. #module_, instanceId ^. #parentVars) | (instanceId, _, _) <- modulesInOrder]
selectedIds = Set.fromList (map (^. #candidate . #applicationId) applications)
priorSelectedKeys =
Set.fromList
[ (state ^. #name, state ^. #parentVars)
| application <- applications,
previous <- maybeToList (application ^. #previous),
state <- previous ^. #instances
]
protectedKeys =
Set.fromList
[ (state ^. #name, state ^. #parentVars)
| application <- recordedApplications,
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
updated =
[ AppliedModule
{ name = instanceId ^. #module_,
parentVars = instanceId ^. #parentVars,
origin = publishedInstance application instanceId ^. #origin,
moduleVersion = modul ^. #version,
appliedAt = now,
removal = modul ^. #removal
}
| (application, instanceId, modul) <- deduplicateInstances applications
]
in retained <> updated
where
deduplicateInstances = go Set.empty . concatMap expand
where
expand application =
[ (application, instanceId, modul)
| (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 ^. #module_, instanceId ^. #parentVars)
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,
targetOrigin = composition ^. #targetOrigin,
targetVersion = composition ^. #targetVersion,
additionalModules = composition ^. #additionalModules,
namespace = composition ^. #namespace,
context = composition ^. #context,
instances,
commandReceipts = receipts,
appliedAt = composition ^. #appliedAt
}
-- | 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)
-- | 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
Nothing -> pure ()
Just sourceUrl -> do
-- Pass force = False deliberately. Every candidate was fetched from
-- the URL the manifest itself records for that artifact, so this is
-- structurally the same-source case and must never refuse. A refusal
-- means the shared cache holds a different artifact under this name,
-- which would make the update publish over somebody else's
-- installation — reported as a publication failure rather than
-- overridden. Do not "fix" it by passing True.
outcome <-
installModuleDir
False
(artifact ^. #originalDirectory)
(T.unpack (artifact ^. #name))
sourceUrl
(artifact ^. #repoName)
(artifact ^. #version)
(artifact ^. #tags)
case outcome of
InstallPerformed -> pure ()
InstallRefused collision ->
throwIO . userError . T.unpack $
"publishing '"
<> (artifact ^. #name)
<> "' to the shared install cache was "
<> summarizeInstallRefusal sourceUrl collision
pure $ first (UpdateCachePublicationFailed . T.pack . displayException) result
setCommitMarkers :: UpdateTransaction -> Manifest -> IO (Either UpdateError ())
setCommitMarkers transaction manifest = do
core <- setUpdateTransactionExpectedManifest transaction manifest
case core of
Left err -> pure (Left (UpdateTransactionFailed err))
Right () -> setServiceExpectedManifest transaction manifest
writeManifestIO :: FilePath -> Manifest -> IO (Either UpdateError ())
writeManifestIO path manifest = do
result <- try @SomeException $ runEff $ runFilesystem $ runManifestStore path $ writeManifest manifest
pure $ first (UpdateManifestWriteFailed . T.pack . displayException) result
-- | Read the manifest, keeping the raw document so a targeted update can
-- run lossless schema steps on it. The schema is inspected before decoding,
-- so a manifest only the explicit converter can read gets its own error
-- naming that command rather than a generic decode failure.
readManifestForUpdate :: FilePath -> IO (Either UpdateError (Aeson.Value, Manifest))
readManifestForUpdate path = do
exists <- Directory.doesFileExist path
if not exists
then pure (Left (UpdateManifestMissing path))
else do
result <- try @SomeException (BS.readFile path)
pure $ case result of
Left err -> Left (UpdateManifestUnreadable path (T.pack (displayException err)))
Right strict -> do
let bytes = LBS.fromStrict strict
document <- first (UpdateManifestUnreadable path . T.pack) (decodeManifestValue bytes)
case documentSchemaVersion document of
Right version
| version < oldestDecodableManifestVersion -> Left (UpdateManifestUpgradeRequired path version)
_ -> do
manifest <- first (UpdateManifestUnreadable path . T.pack) (manifestFromJSON bytes)
Right (document, manifest)
abortUpdate :: UpdateTransaction -> UpdateError -> IO (Either UpdateError a)
abortUpdate transaction original = do
serviceRestore <- restoreServiceBackups transaction
coreRestore <- rollbackUpdateTransaction transaction
pure $ case (serviceRestore, coreRestore) of
(Left restoreError, _) -> Left restoreError
(_, Left restoreError) -> Left (UpdateTransactionFailed restoreError)
_ -> Left original
finishCommitted ::
UpdateTransaction ->
UpdatePlan ->
Manifest ->
[CommandReceipt] ->
IO (Either UpdateError UpdateResult)
finishCommitted transaction plan manifest completedReceipts = do
completion <- completeUpdateTransaction transaction
pruneResult <-
try @SomeException $
runEff $
runFilesystem $
runBaselineStore (plan ^. #snapshot . #baselineDirectory) $
pruneBaselines (manifestBaselineRefs manifest)
let cleanupWarnings = case completion of
Left err -> [RecoveryCleanupDeferred (T.pack (show err))]
Right () -> []
pruneWarnings = case pruneResult of
Left err -> [BaselinePruneFailed (T.pack (displayException err))]
Right _ -> []
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))
changedBaselineRefs
touched =
(plan ^. #snapshot . #transactionTargets)
`Set.union` baselinePaths
`Set.union` Set.singleton (".seihou" </> "manifest.json")
pure
( Right
UpdateResult
{ updatedApplications = map (^. #applicationId) (plan ^. #applications),
manifest,
versions = plan ^. #versionChanges,
fileSummary = reconciliationSummary (plan ^. #reconciliation),
commandSummary =
CommandSummary
{ executed = length completedReceipts,
skippedUnchanged = summary ^. #skippedUnchanged,
skippedDisabled = summary ^. #skippedDisabled
},
touchedPaths = touched,
warnings = plan ^. #warnings <> cleanupWarnings <> pruneWarnings
}
)
recoverAtEntry :: FilePath -> IO (Either UpdateError ())
recoverAtEntry projectRoot = do
serviceResults <- recoverServiceBackups projectRoot
case [err | Left err <- serviceResults] of
firstFailure : _ -> pure (Left firstFailure)
[] -> do
coreResults <- recoverIncompleteTransactions projectRoot
let failures = [err | Left err <- coreResults]
pure $ if null failures then Right () else Left (UpdateRecoveryFailed failures)
standardInstalledDirectory :: IO FilePath
standardInstalledDirectory = do
searchPaths <- defaultSearchPaths
pure (last searchPaths)
dryRunResult :: UpdatePlan -> UpdateResult
dryRunResult plan =
(noOpResult plan)
& #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,
versions = [],
fileSummary = reconciliationSummary (plan ^. #reconciliation),
commandSummary = CommandSummary 0 0 0,
touchedPaths = Set.empty,
warnings = plan ^. #warnings
}
commandSummaryForPlan :: CommandPlan -> CommandSummary
commandSummaryForPlan commandPlan =
let summary = summarizeCommandPlan commandPlan
in CommandSummary (summary ^. #willRun) (summary ^. #skippedUnchanged) (summary ^. #skippedDisabled)
isUpdateNoOp :: UpdatePlan -> Bool
isUpdateNoOp plan =
-- A lossless schema step or a newly certified shared-write mode is a
-- change to applied state that only this update will publish (ADR 0004),
-- so a plan carrying one is never a deliberate no-op (ADR 0007).
plan ^. #checkoutOutputs == plan ^. #snapshot . #originalManifest . #checkoutOutputs
&& all ((== UnchangedLink) . (^. #action)) (plan ^. #checkoutPlan . #entries)
&& isNothing (plan ^. #manifestPreparation)
&& null (plan ^. #versionChanges)
&& null (plan ^. #migrations)
&& plan ^. #inputChanges . #overridden == 0
&& plan ^. #inputChanges . #newlyResolved == 0
&& 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
-- A file whose content is unchanged can still carry a manifest record
-- that is out of date. The shared-write mode is the case that matters: a
-- project whose manifest predates the evidence has no answer for any path, and
-- treating that as a no-op would mean the answer is never written, so the
-- shared-path exemption could never take effect on an existing project.
-- Recording a fact about applied state is a change to applied state
-- (ADR 0004), so such a plan is not a deliberate no-op (ADR 0007).
unchangedFile (FileUnchanged desired _ _ prior) =
maybe True (\record -> record ^. #sharedWriteMode == recordedSharedWriteMode (plan ^. #reconciliation . #applicationIds) desired prior) prior
unchangedFile _ = False
-- Compare only what the manifest actually records. Anything derived from
-- where an artifact happens to sit on this machine would differ between a
-- decoded application and a freshly loaded candidate, and would report
-- every re-run as a change.
sameApplication previous candidate =
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
varValueToText :: VarValue -> Text
varValueToText (VText value) = value
varValueToText (VBool True) = "true"
varValueToText (VBool False) = "false"
varValueToText (VInt value) = T.pack (show value)
varValueToText (VList values) = T.intercalate "," (map varValueToText values)
planCheckoutUpdate :: FilePath -> Manifest -> [PlannedApplication] -> IO (Either UpdateError (Manifest, CheckoutPlan))
planCheckoutUpdate root prior applications = case replaceCheckoutApplications prior [(app ^. #candidate, app ^. #operations) | app <- applications] of
Left err -> pure (Left (UpdateCheckoutFailed err))
Right candidate -> do
planned <- runEff $ runFilesystem $ runProcessIO $ prepareCheckoutApplication root prior candidate (concatMap (^. #operations) applications)
pure $ do
plan <- first UpdateCheckoutFailed planned
case concatMap (^. #errors) (plan ^. #entries) of
err : _ -> Left (UpdateCheckoutFailed err)
[] -> Right (candidate, plan)
applyUpdateCheckout :: UpdatePlan -> Manifest -> Manifest -> IO (Either UpdateError ())
applyUpdateCheckout plan prior filesManifest = runEff $ runFilesystem $ runProcessIO $ do
let candidate = filesManifest & #checkoutOutputs .~ plan ^. #checkoutOutputs & #applications .~ foldl' (flip replaceAppliedComposition) (filesManifest ^. #applications) (plan ^. #applications)
root = plan ^. #snapshot . #projectRoot
checked <- prepareCheckoutPlan Reconcile ApplyDeclaration root prior candidate []
case checked of
Left err -> pure (Left (UpdateCheckoutFailed err))
Right links -> case concatMap (^. #errors) (links ^. #entries) of
err : _ -> pure (Left (UpdateCheckoutFailed err))
[] -> do
applied <- applyCheckoutPlan ApplyDeclaration root links
pure $ maybe (Right ()) (Left . UpdateCheckoutFailed) (applied ^. #failure)