seihou-cli-0.9.0.0: test/Seihou/CLI/UpdateSpec.hs
module Seihou.CLI.UpdateSpec
( tests,
UpdateFixture (..),
prepareUpdateFixture,
SharedPathFixture (..),
CoOwnerWriteMode (..),
prepareSharedPathFixture,
)
where
import Control.Exception (bracket)
import Control.Lens ((&), (.~), (^.))
import Data.ByteString.Lazy qualified as LBS
import Data.Generics.Labels ()
import Data.Map.Strict qualified as Map
import Data.Maybe (fromMaybe, listToMaybe)
import Data.Set qualified as Set
import Data.Text (Text)
import Data.Text qualified as T
import Data.Text.IO qualified as TIO
import Data.Time (UTCTime (..), fromGregorian)
import GHC.Generics (Generic)
import Seihou.CLI.CommandExecution (CommandPolicy (..))
import Seihou.CLI.Update (PromptPolicy (..), UpdateRequest (..), UpdateSelection (..), applyProjectUpdate, isUpdateNoOp, withProjectUpdate)
import Seihou.CLI.Update.Migrations (StagedMigrations (..), planAndStageMigrations)
import Seihou.CLI.Update.Selection
import Seihou.CLI.Update.Source
import Seihou.CLI.Update.Types
import Seihou.CLI.UpdateFixture (minimalPlan)
import Seihou.Composition.Instance (ModuleInstance (..))
import Seihou.Core.Application (mkApplicationId)
import Seihou.Core.CommandFingerprint (fingerprintCommand)
import Seihou.Core.Migration (Migration (..), MigrationOp (..))
import Seihou.Core.Types
import Seihou.Engine.Reconcile
( DesiredFile (..),
FileReconciliation (..),
ObservedFile (..),
PlannedFileState (..),
ReconciliationPlan (..),
)
import Seihou.Manifest.Hash (hashContent)
import Seihou.Manifest.Types (emptyManifest, manifestFromJSON, manifestToJSON)
import System.Directory (createDirectoryIfMissing, doesFileExist, withCurrentDirectory)
import System.Environment (lookupEnv, setEnv, unsetEnv)
import System.FilePath ((</>))
import System.IO.Temp (withSystemTempDirectory)
import System.Process (callProcess)
import Test.Hspec
import Test.Tasty
import Test.Tasty.Hspec (testSpec)
tests :: IO TestTree
tests = testSpec "Seihou.CLI.Update" spec
spec :: Spec
spec = do
describe "application selection" $ do
it "selects every application containing a requested bare module" $ do
let first = application (AppliedModuleTarget "one") [instanceState "shared"]
second = application (AppliedRecipeTarget "stack") [instanceState "shared"]
manifest :: Manifest
manifest = manifestForApplications [first, second] Map.empty
selectApplications RequireNamedOwners (NamedUpdateTargets ["shared"]) manifest
`shouldBe` Right (RecordedSelection [first, second], [])
it "keeps manifest order for all applications and deduplicates repeated targets" $ do
let first = application (AppliedModuleTarget "one") [instanceState "one"]
second = application (AppliedModuleTarget "two") [instanceState "two"]
manifest :: Manifest
manifest = manifestForApplications [first, second] Map.empty
selectApplications RequireNamedOwners AllRecordedApplications manifest
`shouldBe` Right (RecordedSelection [first, second], [])
selectApplications RequireNamedOwners (NamedUpdateTargets ["two", "two", "one"]) manifest
`shouldBe` Right (RecordedSelection [first, second], [])
it "rejects a partial selection that shares an owned path" $ do
let first = application (AppliedModuleTarget "one") [instanceState "one"]
second = application (AppliedModuleTarget "two") [instanceState "two"]
owners = Set.fromList [first ^. #applicationId, second ^. #applicationId]
record = FileRecord (hashContent "old") "one" Template testTime Nothing owners False
manifest :: Manifest
manifest = manifestForApplications [first, second] (Map.singleton "shared.txt" record)
selectApplications RequireNamedOwners (NamedUpdateTargets ["one"]) manifest
`shouldBe` Left (SharedPathRequiresApplications "shared.txt" (Set.singleton (first ^. #applicationId)) (Set.singleton (second ^. #applicationId)))
it "accepts a partial selection when the shared path is additive-only" $ do
-- Every owner reaches the path through an additive, non-overlapping
-- patch, so reconciling one of them cannot disturb the other's bytes.
let first = application (AppliedModuleTarget "one") [instanceState "one"]
second = application (AppliedModuleTarget "two") [instanceState "two"]
owners = Set.fromList [first ^. #applicationId, second ^. #applicationId]
record = FileRecord (hashContent "old") "one" Template testTime Nothing owners True
manifest :: Manifest
manifest = manifestForApplications [first, second] (Map.singleton ".gitignore" record)
selectApplications RequireNamedOwners (NamedUpdateTargets ["one"]) manifest
`shouldBe` Right (RecordedSelection [first], [])
it "still rejects a partial selection when one shared path is not additive-only" $ do
-- The exemption is per path: an additive shared path does not excuse a
-- whole-file one in the same manifest.
let first = application (AppliedModuleTarget "one") [instanceState "one"]
second = application (AppliedModuleTarget "two") [instanceState "two"]
owners = Set.fromList [first ^. #applicationId, second ^. #applicationId]
additive = FileRecord (hashContent "ignore") "one" Template testTime Nothing owners True
wholeFile = FileRecord (hashContent "old") "one" Template testTime Nothing owners False
manifest :: Manifest
manifest =
manifestForApplications
[first, second]
(Map.fromList [(".gitignore", additive), ("shared.txt", wholeFile)])
selectApplications RequireNamedOwners (NamedUpdateTargets ["one"]) manifest
`shouldBe` Left
( SharedPathRequiresApplications
"shared.txt"
(Set.singleton (first ^. #applicationId))
(Set.singleton (second ^. #applicationId))
)
it "expands a named selection to the owners the closure requires" $ do
let first = application (AppliedModuleTarget "one") [instanceState "one"]
second = application (AppliedModuleTarget "two") [instanceState "two"]
owners = Set.fromList [first ^. #applicationId, second ^. #applicationId]
record = FileRecord (hashContent "old") "one" Template testTime Nothing owners False
manifest :: Manifest
manifest = manifestForApplications [first, second] (Map.singleton "shared.txt" record)
selectApplications IncludeSharedOwners (NamedUpdateTargets ["one"]) manifest
`shouldBe` Right
( RecordedSelection [first, second],
[SelectionExpandedForSharedPath "shared.txt" (second ^. #applicationId)]
)
it "expands to a fixed point across a chain of shared paths" $ do
-- One and two share a.txt; two and three share b.txt. Selecting one
-- pulls in two, which then forces three: a single pass is not enough.
let first = application (AppliedModuleTarget "one") [instanceState "one"]
second = application (AppliedModuleTarget "two") [instanceState "two"]
third = application (AppliedModuleTarget "three") [instanceState "three"]
pair left right =
FileRecord
(hashContent "old")
"one"
Template
testTime
Nothing
(Set.fromList [left ^. #applicationId, right ^. #applicationId])
False
manifest :: Manifest
manifest =
manifestForApplications
[first, second, third]
(Map.fromList [("a.txt", pair first second), ("b.txt", pair second third)])
case selectApplications IncludeSharedOwners (NamedUpdateTargets ["one"]) manifest of
Left err -> expectationFailure ("expected an expanded selection, got " <> show err)
Right (selected, warnings) -> do
selected `shouldBe` RecordedSelection [first, second, third]
warnings
`shouldBe` [ SelectionExpandedForSharedPath "a.txt" (second ^. #applicationId),
SelectionExpandedForSharedPath "b.txt" (third ^. #applicationId)
]
it "does not expand for a shared path that is additive-only" $ do
-- The path no longer requires the closure, so pulling the co-owner in
-- would update an application the user neither asked for nor needed.
let first = application (AppliedModuleTarget "one") [instanceState "one"]
second = application (AppliedModuleTarget "two") [instanceState "two"]
owners = Set.fromList [first ^. #applicationId, second ^. #applicationId]
record = FileRecord (hashContent "old") "one" Template testTime Nothing owners True
manifest :: Manifest
manifest = manifestForApplications [first, second] (Map.singleton ".gitignore" record)
selectApplications IncludeSharedOwners (NamedUpdateTargets ["one"]) manifest
`shouldBe` Right (RecordedSelection [first], [])
it "requires one explicit target to seed a legacy manifest" $ do
selectApplications RequireNamedOwners AllRecordedApplications (emptyManifest testTime)
`shouldBe` Left NoRecordedApplications
selectApplications RequireNamedOwners (NamedUpdateTargets ["one", "two"]) (emptyManifest testTime)
`shouldBe` Left LegacyUpdateRequiresOneTarget
describe "candidate source staging" $ do
it "keeps local artifacts as an explicit candidate-first fallback" $
withSystemTempDirectory "seihou-update-source" $ \root -> do
let localProjectRoot = root </> "current"
moduleDirectory = localProjectRoot </> "demo"
sessionDirectory = root </> "session"
origin = ProjectOrigin "demo"
applied =
application (AppliedModuleTarget "demo") [instanceStateFrom "demo" origin]
& #targetOrigin .~ origin
createDirectoryIfMissing True moduleDirectory
TIO.writeFile (moduleDirectory </> "module.dhall") (moduleDhall "demo" "1.0.0")
result <- stageCandidateSources sessionDirectory localProjectRoot (root </> "installed") [applied]
case result of
Left err -> expectationFailure (show err)
Right (catalog, warnings) -> do
warnings `shouldContain` [LocalArtifactHasNoRemote "demo"]
let candidate = (catalog ^. #artifacts) Map.! (CandidateModule, "demo")
(candidate ^. #originalDirectory) `shouldBe` moduleDirectory
(candidate ^. #sourceUrl) `shouldBe` Nothing
doesFileExist (catalog ^. #searchRoot </> "demo" </> "module.dhall") `shouldReturn` True
it "clones one registry origin once for a recipe and all of its modules" $
withSystemTempDirectory "seihou-update-registry-source" $ \root -> do
let remote = root </> "remote"
installed = root </> "installed"
moduleOne = installed </> "one"
moduleTwo = installed </> "two"
recipeDirectory = installed </> "stack"
sessionDirectory = root </> "session"
sourceUrl = T.pack remote
remoteOrigin name = RemoteOrigin sourceUrl name Nothing
applied =
application
(AppliedRecipeTarget "stack")
[ instanceStateFrom "one" (remoteOrigin "one"),
instanceStateFrom "two" (remoteOrigin "two")
]
& #targetOrigin .~ remoteOrigin "stack"
& #additionalModules .~ []
createDirectoryIfMissing True (remote </> "modules" </> "one")
createDirectoryIfMissing True (remote </> "modules" </> "two")
createDirectoryIfMissing True (remote </> "recipes" </> "stack")
TIO.writeFile (remote </> "modules" </> "one" </> "module.dhall") (moduleDhall "one" "2.0.0")
TIO.writeFile (remote </> "modules" </> "two" </> "module.dhall") (moduleDhall "two" "2.0.0")
TIO.writeFile (remote </> "recipes" </> "stack" </> "recipe.dhall") (recipeDhall "stack" "2.0.0" ["one", "two"])
TIO.writeFile (remote </> "seihou-registry.dhall") registryDhall
callProcess "git" ["-C", remote, "init", "-q"]
callProcess "git" ["-C", remote, "add", "."]
callProcess "git" ["-C", remote, "-c", "user.name=Seihou Test", "-c", "user.email=test@example.com", "commit", "-qm", "registry"]
mapM_ (writeOrigin sourceUrl) [moduleOne, moduleTwo, recipeDirectory]
result <- stageCandidateSources sessionDirectory root installed [applied]
case result of
Left err -> expectationFailure (show err)
Right (catalog, _) -> do
Map.size (catalog ^. #clonedOrigins) `shouldBe` 1
Map.keysSet (catalog ^. #artifacts)
`shouldBe` Set.fromList [(CandidateModule, "one"), (CandidateModule, "two"), (CandidateRecipe, "stack")]
it "returns a structured clone error before touching the project" $
withSystemTempDirectory "seihou-update-clone-error" $ \root -> do
let moduleDirectory = root </> "installed" </> "demo"
missingRemote = T.pack (root </> "missing-remote")
missingOrigin = RemoteOrigin missingRemote "demo" Nothing
applied =
application (AppliedModuleTarget "demo") [instanceStateFrom "demo" missingOrigin]
& #targetOrigin .~ missingOrigin
writeOrigin missingRemote moduleDirectory
result <- stageCandidateSources (root </> "session") root (root </> "installed") [applied]
result `shouldSatisfy` \case
Left (CandidateCloneFailed url message) -> url == missingRemote && "git clone failed" `T.isInfixOf` message
_ -> False
describe "staged update service" $ do
it "reuses accepted inputs, keeps dry-run read-only, and publishes one coherent update" $
withSystemTempDirectory "seihou-update-e2e" $ \root -> do
fixture <- prepareUpdateFixture root
withSavedEnv "XDG_CONFIG_HOME" (Just (fixture ^. #xdgHome)) $
withCurrentDirectory (fixture ^. #projectRoot) $ do
beforeManifest <- LBS.readFile (fixture ^. #manifestPath)
beforeProject <- TIO.readFile (fixture ^. #projectFile)
beforeInstalled <- TIO.readFile (fixture ^. #installedModule </> "module.dhall")
let dryRequest = updateRequest True
dryResult <- withProjectUpdate dryRequest $ \case
Left err -> pure (Left err)
Right plan -> applyProjectUpdate plan
case dryResult of
Left err -> expectationFailure (show err)
Right _ -> pure ()
LBS.readFile (fixture ^. #manifestPath) `shouldReturn` beforeManifest
TIO.readFile (fixture ^. #projectFile) `shouldReturn` beforeProject
TIO.readFile (fixture ^. #installedModule </> "module.dhall") `shouldReturn` beforeInstalled
applied <- withProjectUpdate (updateRequest False) $ \case
Left err -> pure (Left err)
Right plan -> applyProjectUpdate plan
case applied of
Left err -> expectationFailure (show err)
Right result -> do
(result ^. #versions) `shouldSatisfy` any (\change -> change ^. #name == "demo" && change ^. #fromVersion == Just "1.0.0" && change ^. #toVersion == Just "2.0.0")
(result ^. #updatedApplications) `shouldBe` [fixture ^. #applicationId]
TIO.readFile (fixture ^. #projectFile) `shouldReturn` "hello accepted\nkeep\nv2\n"
installedBytes <- TIO.readFile (fixture ^. #installedModule </> "module.dhall")
installedBytes `shouldSatisfy` T.isInfixOf "Some \"2.0.0\""
decoded <- manifestFromJSON <$> LBS.readFile (fixture ^. #manifestPath)
case decoded of
Left err -> expectationFailure err
Right manifest -> case manifest ^. #applications of
updated : _ -> case updated ^. #instances of
instanceState : _ -> do
(instanceState ^. #resolvedVars) `shouldBe` Map.singleton "project.name" "accepted"
(instanceState ^. #moduleVersion) `shouldBe` Just "2.0.0"
[] -> expectationFailure "updated application has no instances"
[] -> expectationFailure "updated manifest has no applications"
afterFirstApply <- LBS.readFile (fixture ^. #manifestPath)
noOp <- withProjectUpdate (updateRequest False) $ \case
Left err -> pure (Left err)
Right plan -> applyProjectUpdate plan
case noOp of
Left err -> expectationFailure (show err)
Right result -> (result ^. #updatedApplications) `shouldBe` []
LBS.readFile (fixture ^. #manifestPath) `shouldReturn` afterFirstApply
it "is not a no-op when a file's recorded write mode is stale" $ do
-- A manifest that predates `additiveOnly` has no answer for any path.
-- If that counted as a no-op, nothing would ever write the answer down
-- and 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 it is not a deliberate no-op (ADR 0007).
isUpdateNoOp (unchangedFilePlan False True) `shouldBe` False
isUpdateNoOp (unchangedFilePlan True False) `shouldBe` False
it "is a no-op when the recorded write mode already agrees" $ do
isUpdateNoOp (unchangedFilePlan True True) `shouldBe` True
isUpdateNoOp (unchangedFilePlan False False) `shouldBe` True
it "rejects a plan when its manifest snapshot changes" $
withSystemTempDirectory "seihou-update-stale" $ \root -> do
fixture <- prepareUpdateFixture root
withSavedEnv "XDG_CONFIG_HOME" (Just (fixture ^. #xdgHome)) $
withCurrentDirectory (fixture ^. #projectRoot) $ do
result <- withProjectUpdate (updateRequest False) $ \case
Left err -> pure (Left err)
Right plan -> do
TIO.appendFile (fixture ^. #manifestPath) "\n"
applyProjectUpdate plan
result `shouldSatisfy` \case
Left (UpdatePlanStale paths) -> Set.member (".seihou" </> "manifest.json") paths
_ -> False
it "plans changed content at the same declared version with an explicit warning" $
withSystemTempDirectory "seihou-update-same-version" $ \root -> do
fixture <- prepareUpdateFixture root
let modulePath = fixture ^. #remote </> "module.dhall"
body <- TIO.readFile modulePath
TIO.writeFile modulePath (T.replace "Some \"2.0.0\"" "Some \"1.0.0\"" body)
callProcess "git" ["-C", fixture ^. #remote, "add", "module.dhall"]
callProcess "git" ["-C", fixture ^. #remote, "-c", "user.name=Seihou Test", "-c", "user.email=test@example.com", "commit", "-qm", "same-version content change"]
withSavedEnv "XDG_CONFIG_HOME" (Just (fixture ^. #xdgHome)) $
withCurrentDirectory (fixture ^. #projectRoot) $ do
result <- withProjectUpdate (updateRequest True) pure
case result of
Left err -> expectationFailure (show err)
Right plan -> do
isUpdateNoOp plan `shouldBe` False
(plan ^. #versionChanges) `shouldSatisfy` any (^. #sameVersionContentChanged)
(plan ^. #warnings) `shouldContain` [SameVersionContentChanged "demo"]
it "re-expands a candidate recipe and removes dependencies dropped by it" $
withSystemTempDirectory "seihou-update-recipe" $ \root -> do
fixture <- prepareRecipeUpdateFixture root
withSavedEnv "XDG_CONFIG_HOME" (Just (fixture ^. #xdgHome)) $
withCurrentDirectory (fixture ^. #projectRoot) $ do
result <- withProjectUpdate (updateRequest False) $ \case
Left err -> pure (Left err)
Right plan -> applyProjectUpdate plan
case result of
Left err -> expectationFailure (show err)
Right updateResult -> (updateResult ^. #updatedApplications) `shouldBe` [fixture ^. #applicationId]
decoded <- manifestFromJSON <$> LBS.readFile (fixture ^. #manifestPath)
case decoded of
Left err -> expectationFailure err
Right manifest -> case manifest ^. #applications of
[updated] -> do
(updated ^. #applicationId) `shouldBe` (fixture ^. #applicationId)
(updated ^. #targetVersion) `shouldBe` Just "2.0.0"
(updated ^. #additionalModules) `shouldBe` []
Set.fromList (map (^. #name) (updated ^. #instances)) `shouldBe` Set.fromList ["one", "new"]
Set.fromList (map (^. #name) (manifest ^. #modules)) `shouldBe` Set.fromList ["one", "new"]
other -> expectationFailure ("expected one updated recipe application, got " <> show other)
doesFileExist (fixture ^. #xdgHome </> "seihou" </> "installed" </> "new" </> "module.dhall") `shouldReturn` True
it "refuses an unresolved three-way conflict without mutating durable state" $
withSystemTempDirectory "seihou-update-conflict" $ \root -> do
fixture <- prepareUpdateFixture root
TIO.writeFile (fixture ^. #remote </> "files" </> "README.tmpl") "candidate {{project.name}}\nv2\n"
callProcess "git" ["-C", fixture ^. #remote, "add", "files/README.tmpl"]
callProcess "git" ["-C", fixture ^. #remote, "-c", "user.name=Seihou Test", "-c", "user.email=test@example.com", "commit", "-qm", "conflicting template"]
withSavedEnv "XDG_CONFIG_HOME" (Just (fixture ^. #xdgHome)) $
withCurrentDirectory (fixture ^. #projectRoot) $ do
TIO.writeFile (fixture ^. #projectFile) "user accepted\nv1\n"
beforeManifest <- LBS.readFile (fixture ^. #manifestPath)
beforeInstalled <- LBS.readFile (fixture ^. #installedModule </> "module.dhall")
result <- withProjectUpdate (updateRequest False) $ \case
Left err -> pure (Left err)
Right plan -> applyProjectUpdate plan
result `shouldSatisfy` \case
Left (UpdateHasUnresolvedPaths paths) -> Set.member "README.md" paths
_ -> False
LBS.readFile (fixture ^. #manifestPath) `shouldReturn` beforeManifest
TIO.readFile (fixture ^. #projectFile) `shouldReturn` "user accepted\nv1\n"
LBS.readFile (fixture ^. #installedModule </> "module.dhall") `shouldReturn` beforeInstalled
it "seeds one explicit legacy target and records it only after success" $
withSystemTempDirectory "seihou-update-legacy" $ \root -> do
fixture <- prepareUpdateFixture root
decoded <- manifestFromJSON <$> LBS.readFile (fixture ^. #manifestPath)
legacy <- case decoded of
Left err -> expectationFailure err >> pure (emptyManifest testTime)
Right manifest -> pure (withoutApplications manifest)
LBS.writeFile (fixture ^. #manifestPath) (manifestToJSON legacy)
let request = ((updateRequest False) & #selection .~ NamedUpdateTargets ["demo"])
withSavedEnv "XDG_CONFIG_HOME" (Just (fixture ^. #xdgHome)) $
withCurrentDirectory (fixture ^. #projectRoot) $ do
result <- withProjectUpdate request $ \case
Left err -> pure (Left err)
Right plan -> applyProjectUpdate plan
case result of
Left err -> expectationFailure (show err)
Right updateResult -> (updateResult ^. #updatedApplications) `shouldBe` [fixture ^. #applicationId]
updated <- manifestFromJSON <$> LBS.readFile (fixture ^. #manifestPath)
case updated of
Left err -> expectationFailure err
Right manifest -> case manifest ^. #applications of
[applicationState] -> case applicationState ^. #instances of
[moduleState] -> (moduleState ^. #resolvedVars) `shouldBe` Map.singleton "project.name" "accepted"
other -> expectationFailure ("expected one legacy module instance, got " <> show other)
other -> expectationFailure ("expected one seeded application, got " <> show other)
it "rolls managed project and cache state back when a candidate command fails" $
withSystemTempDirectory "seihou-update-command-failure" $ \root -> do
fixture <- prepareUpdateFixture root
let modulePath = fixture ^. #remote </> "module.dhall"
body <- TIO.readFile modulePath
TIO.writeFile
modulePath
( T.replace
", commands = [{ run = \"printf should-not-run >> command.log\", workDir = None Text, when = None Text }]"
", commands = [{ run = \"exit 7\", workDir = None Text, when = None Text }]"
body
)
callProcess "git" ["-C", fixture ^. #remote, "add", "module.dhall"]
callProcess "git" ["-C", fixture ^. #remote, "-c", "user.name=Seihou Test", "-c", "user.email=test@example.com", "commit", "-qm", "failing command"]
withSavedEnv "XDG_CONFIG_HOME" (Just (fixture ^. #xdgHome)) $
withCurrentDirectory (fixture ^. #projectRoot) $ do
beforeManifest <- LBS.readFile (fixture ^. #manifestPath)
beforeProject <- TIO.readFile (fixture ^. #projectFile)
beforeInstalled <- LBS.readFile (fixture ^. #installedModule </> "module.dhall")
result <- withProjectUpdate (updateRequest False) $ \case
Left err -> pure (Left err)
Right plan -> applyProjectUpdate plan
result `shouldSatisfy` \case
Left UpdateCommandFailed {} -> True
_ -> False
LBS.readFile (fixture ^. #manifestPath) `shouldReturn` beforeManifest
TIO.readFile (fixture ^. #projectFile) `shouldReturn` beforeProject
LBS.readFile (fixture ^. #installedModule </> "module.dhall") `shouldReturn` beforeInstalled
it "rolls managed state back when installed-cache publication fails" $
withSystemTempDirectory "seihou-update-cache-failure" $ \root -> do
fixture <- prepareUpdateFixture root
withSavedEnv "XDG_CONFIG_HOME" (Just (fixture ^. #xdgHome)) $
withCurrentDirectory (fixture ^. #projectRoot) $ do
beforeManifest <- LBS.readFile (fixture ^. #manifestPath)
beforeProject <- TIO.readFile (fixture ^. #projectFile)
beforeInstalled <- LBS.readFile (fixture ^. #installedModule </> "module.dhall")
result <- withProjectUpdate (updateRequest False) $ \case
Left err -> pure (Left err)
Right plan -> applyProjectUpdate (breakCandidatePublication plan)
result `shouldSatisfy` \case
Left UpdateCachePublicationFailed {} -> True
_ -> False
LBS.readFile (fixture ^. #manifestPath) `shouldReturn` beforeManifest
TIO.readFile (fixture ^. #projectFile) `shouldReturn` beforeProject
LBS.readFile (fixture ^. #installedModule </> "module.dhall") `shouldReturn` beforeInstalled
describe "migration staging" $ do
it "preserves parameterized instances while planning their shared transition once" $
withSystemTempDirectory "seihou-update-shared-migration" $ \projectRoot -> do
let parentOne = ParentVars (Map.singleton "tenant" "one")
parentTwo = ParentVars (Map.singleton "tenant" "two")
instanceOne = ModuleInstance "shared" parentOne
instanceTwo = ModuleInstance "shared" parentTwo
stateFor parent = AppliedInstanceState "shared" parent (LocalOrigin "shared") (Just "1.0.0") Map.empty
previous = application (AppliedModuleTarget "shared") [stateFor parentOne, stateFor parentTwo]
candidate =
Module
{ name = "shared",
version = Just "2.0.0",
description = Nothing,
vars = [],
exports = [],
prompts = [],
steps = [],
commands = [],
dependencies = [],
removal = Nothing,
migrations = [Migration "1.0.0" "2.0.0" [RunCommand "true" Nothing]]
}
appliedModules =
[ AppliedModule "shared" parentOne (LocalOrigin "shared") (Just "1.0.0") testTime Nothing,
AppliedModule "shared" parentTwo (LocalOrigin "shared") (Just "1.0.0") testTime Nothing
]
base = emptyManifest testTime
manifest =
Manifest
{ version = base ^. #version,
genAt = base ^. #genAt,
modules = appliedModules,
vars = Map.empty,
files = Map.empty,
applications = [previous],
recipe = Nothing,
blueprint = Nothing,
blueprintMigrations = []
}
catalog = CandidateCatalog (projectRoot </> "search") Map.empty Map.empty
candidates = [(instanceOne, candidate, "/candidate/shared"), (instanceTwo, candidate, "/candidate/shared")]
staged <- planAndStageMigrations projectRoot manifest catalog [(Just previous, candidates)]
case staged of
Left err -> expectationFailure (show err)
Right migrationStage -> do
length (migrationStage ^. #plans) `shouldBe` 1
(migrationStage ^. #plans) `shouldSatisfy` all (^. #containsCommands)
(migrationStage ^. #warnings) `shouldBe` [MigrationCommandNotSimulated "shared" "true"]
map (^. #moduleVersion) (migrationStage ^. #manifest . #modules) `shouldBe` [Just "2.0.0", Just "2.0.0"]
-- | A plan whose one file is byte-unchanged on disk, parameterized by the
-- @additiveOnly@ the manifest holds and the one this run would record.
unchangedFilePlan :: Bool -> Bool -> UpdatePlan
unchangedFilePlan priorAdditive desiredAdditive =
minimalPlan
( ReconciliationPlan
{ applicationIds = Set.empty,
files = Map.singleton ".gitignore" (FileUnchanged desired state observedFile (Just prior)),
requiredDirectories = Set.empty
}
)
where
content = "/dist-newstyle\n"
desired =
DesiredFile
{ path = ".gitignore",
generatedContent = content,
moduleName = "alpha",
strategy = Template,
applicationIds = Set.empty,
additiveOnly = desiredAdditive
}
state = PlannedFileState content content (hashContent content) False
observedFile = ObservedFile True (Just (hashContent content))
prior =
FileRecord
(hashContent content)
"alpha"
Template
testTime
Nothing
Set.empty
priorAdditive
data UpdateFixture = UpdateFixture
{ projectRoot :: !FilePath,
projectFile :: !FilePath,
manifestPath :: !FilePath,
xdgHome :: !FilePath,
installedModule :: !FilePath,
remote :: !FilePath,
applicationId :: !ApplicationId
}
deriving stock (Generic)
data RecipeUpdateFixture = RecipeUpdateFixture
{ projectRoot :: !FilePath,
manifestPath :: !FilePath,
xdgHome :: !FilePath,
applicationId :: !ApplicationId
}
deriving stock (Generic)
prepareUpdateFixture :: FilePath -> IO UpdateFixture
prepareUpdateFixture root = do
let projectRoot = root </> "project"
manifestPath = projectRoot </> ".seihou" </> "manifest.json"
projectFile = projectRoot </> "README.md"
remote = root </> "remote"
xdgHome = root </> "xdg"
installedModule = xdgHome </> "seihou" </> "installed" </> "demo"
unchangedCommand = "printf should-not-run >> command.log"
commandOperation = RunCommandOp unchangedCommand Nothing "demo" 0
commandFingerprint = fromMaybe (error "test fixture command fingerprint") (fingerprintCommand commandOperation)
commandReceipt = CommandReceipt commandFingerprint "demo" unchangedCommand Nothing testTime
baselineContent = "hello accepted\nkeep\nv1\n"
baselineRef = BaselineRef (hashContent baselineContent)
target = AppliedModuleTarget "demo"
applicationId = mkApplicationId target []
demoOrigin = RemoteOrigin (T.pack remote) "demo" Nothing
app =
(application target [instanceStateFrom "demo" demoOrigin])
{ applicationId,
targetOrigin = demoOrigin,
targetVersion = Just "1.0.0",
commandReceipts = Map.singleton commandFingerprint commandReceipt,
instances =
[ (instanceStateFrom "demo" demoOrigin)
& #resolvedVars .~ Map.singleton "project.name" "accepted"
]
}
appliedModule = AppliedModule "demo" emptyParentVars demoOrigin (Just "1.0.0") testTime Nothing
fileRecord =
FileRecord
(hashContent baselineContent)
"demo"
Template
testTime
(Just baselineRef)
(Set.singleton applicationId)
False
manifest =
( (emptyManifest testTime)
& #modules .~ [appliedModule]
& #vars .~ Map.singleton "project.name" "accepted"
& #files .~ Map.singleton "README.md" fileRecord
& #applications .~ [app]
)
createDirectoryIfMissing True (installedModule </> "files")
TIO.writeFile (installedModule </> "module.dhall") (moduleDhallWithTemplate "demo" "1.0.0" "old-default")
TIO.writeFile (installedModule </> "files" </> "README.tmpl") "hello {{project.name}}\nkeep\nv1\n"
createDirectoryIfMissing True (remote </> "files")
TIO.writeFile (remote </> "module.dhall") (moduleDhallWithTemplate "demo" "2.0.0" "new-default")
TIO.writeFile (remote </> "files" </> "README.tmpl") "hello {{project.name}}\nkeep\nv2\n"
callProcess "git" ["-C", remote, "init", "-q"]
callProcess "git" ["-C", remote, "add", "."]
callProcess "git" ["-C", remote, "-c", "user.name=Seihou Test", "-c", "user.email=test@example.com", "commit", "-qm", "v2"]
TIO.writeFile
(installedModule </> ".seihou-origin.json")
("{\"sourceUrl\":\"" <> T.pack remote <> "\",\"version\":\"1.0.0\"}")
createDirectoryIfMissing True (projectRoot </> ".seihou" </> "baselines")
TIO.writeFile projectFile baselineContent
TIO.writeFile
(projectRoot </> ".seihou" </> "baselines" </> T.unpack (baselineRef ^. #unBaselineRef . #unSHA256))
baselineContent
LBS.writeFile manifestPath (manifestToJSON manifest)
pure UpdateFixture {projectRoot, projectFile, manifestPath, xdgHome, installedModule, remote, applicationId}
-- | How the co-owning application @beta@ writes the shared @.gitignore@.
data CoOwnerWriteMode
= -- | @append-line-if-absent@: beta occupies a disjoint slice of the file,
-- so the path records @additiveOnly = True@ and a targeted update of
-- @alpha@ alone is safe.
CoOwnerAppends
| -- | A whole-file @template@ step: regenerating the path on alpha's behalf
-- would discard beta's content, so the path records
-- @additiveOnly = False@ and stays under the ownership closure.
CoOwnerWritesWholeFile
| -- | Beta appends, exactly as 'CoOwnerAppends', but the manifest predates
-- the @additiveOnly@ record and so has no answer. This models every
-- project in the wild at the moment the field was introduced. Alpha's
-- remote is published at the installed version with identical content,
-- so the /only/ thing a whole-project update has to do is write the
-- missing record down.
CoOwnerAppendsUnrecorded
deriving stock (Eq, Show)
-- | A project whose @.gitignore@ is co-owned by two recorded applications.
data SharedPathFixture = SharedPathFixture
{ projectRoot :: !FilePath,
gitignorePath :: !FilePath,
manifestPath :: !FilePath,
xdgHome :: !FilePath,
alphaApplicationId :: !ApplicationId,
betaApplicationId :: !ApplicationId
}
deriving stock (Generic)
-- | Build a project where @alpha@ and @beta@ both own @.gitignore@.
--
-- The recorded baseline holds both owners' lines. Alpha's installed module is
-- at 1.0.0 and its remote at 2.0.0 with one extra line, so
-- @seihou update alpha@ has real work to do. Beta is recorded but never
-- updated, which is exactly the partial selection the ownership closure used
-- to refuse.
prepareSharedPathFixture :: CoOwnerWriteMode -> FilePath -> IO SharedPathFixture
prepareSharedPathFixture writeMode root = do
let projectRoot = root </> "project"
manifestPath = projectRoot </> ".seihou" </> "manifest.json"
gitignorePath = projectRoot </> ".gitignore"
xdgHome = root </> "xdg"
installedRoot = xdgHome </> "seihou" </> "installed"
remoteRoot = root </> "remote"
baselineContent = "/dist-newstyle\n/result\n"
baselineRef = BaselineRef (hashContent baselineContent)
alphaTarget = AppliedModuleTarget "alpha"
betaTarget = AppliedModuleTarget "beta"
alphaApplicationId = mkApplicationId alphaTarget []
betaApplicationId = mkApplicationId betaTarget []
originFor name = RemoteOrigin (T.pack (remoteRoot </> T.unpack name)) name Nothing
appliedFor name target applicationId version =
(application target [instanceStateFrom (ModuleName name) (originFor name)])
{ applicationId,
targetOrigin = originFor name,
targetVersion = Just version,
instances = [instanceStateFrom (ModuleName name) (originFor name)]
}
betaPatch = case writeMode of
CoOwnerAppends -> Just "append-line-if-absent"
CoOwnerAppendsUnrecorded -> Just "append-line-if-absent"
CoOwnerWritesWholeFile -> Nothing
-- What alpha's remote publishes. Under 'CoOwnerAppendsUnrecorded' it
-- matches the installed module exactly, so nothing about the sources
-- has changed and the only pending work is the manifest record.
(alphaRemoteVersion, alphaRemoteContent) = case writeMode of
CoOwnerAppendsUnrecorded -> ("1.0.0", "/dist-newstyle\n")
_ -> ("2.0.0", "/dist-newstyle\n/alpha-v2\n")
fileRecord =
FileRecord
(hashContent baselineContent)
"alpha"
Template
testTime
(Just baselineRef)
(Set.fromList [alphaApplicationId, betaApplicationId])
(writeMode == CoOwnerAppends)
manifest =
( (emptyManifest testTime)
& #modules
.~ [ AppliedModule "alpha" emptyParentVars (originFor "alpha") (Just "1.0.0") testTime Nothing,
AppliedModule "beta" emptyParentVars (originFor "beta") (Just "1.0.0") testTime Nothing
]
& #files .~ Map.singleton ".gitignore" fileRecord
& #applications
.~ [ appliedFor "alpha" alphaTarget alphaApplicationId "1.0.0",
appliedFor "beta" betaTarget betaApplicationId "1.0.0"
]
)
-- Install one module and publish the same content as its git remote.
installModule name version patchOp content = do
let installed = installedRoot </> T.unpack name
remote = remoteRoot </> T.unpack name
createDirectoryIfMissing True (installed </> "files")
TIO.writeFile (installed </> "module.dhall") (moduleDhallForGitignore name version patchOp)
TIO.writeFile (installed </> "files" </> "gitignore.tmpl") content
TIO.writeFile
(installed </> ".seihou-origin.json")
("{\"sourceUrl\":\"" <> T.pack remote <> "\",\"version\":\"" <> version <> "\"}")
pure installed
publishRemote name version patchOp content = do
let remote = remoteRoot </> T.unpack name
createDirectoryIfMissing True (remote </> "files")
TIO.writeFile (remote </> "module.dhall") (moduleDhallForGitignore name version patchOp)
TIO.writeFile (remote </> "files" </> "gitignore.tmpl") content
callProcess "git" ["-C", remote, "init", "-q"]
callProcess "git" ["-C", remote, "add", "."]
callProcess "git" ["-C", remote, "-c", "user.name=Seihou Test", "-c", "user.email=test@example.com", "commit", "-qm", "v" <> T.unpack version]
_ <- installModule "alpha" "1.0.0" (Just "append-line-if-absent") "/dist-newstyle\n"
_ <- installModule "beta" "1.0.0" betaPatch "/result\n"
publishRemote "alpha" alphaRemoteVersion (Just "append-line-if-absent") alphaRemoteContent
publishRemote "beta" "1.0.0" betaPatch "/result\n"
createDirectoryIfMissing True (projectRoot </> ".seihou" </> "baselines")
TIO.writeFile gitignorePath baselineContent
TIO.writeFile
(projectRoot </> ".seihou" </> "baselines" </> T.unpack (baselineRef ^. #unBaselineRef . #unSHA256))
baselineContent
LBS.writeFile manifestPath (manifestToJSON manifest)
pure
SharedPathFixture
{ projectRoot,
gitignorePath,
manifestPath,
xdgHome,
alphaApplicationId,
betaApplicationId
}
-- | A module whose only step contributes to @.gitignore@, either through the
-- given patch operation or, with 'Nothing', as a whole-file template.
moduleDhallForGitignore :: Text -> Text -> Maybe Text -> Text
moduleDhallForGitignore name version patchOp =
T.unlines
[ "{ name = \"" <> name <> "\"",
", version = Some \"" <> version <> "\"",
", description = None Text",
", vars = [] : List { name : Text, type : Text, default : Optional Text, description : Optional Text, required : Bool, validation : Optional Text }",
", exports = [] : List { var : Text, alias : Optional Text }",
", prompts = [] : List { var : Text, text : Text, when : Optional Text, choices : Optional (List Text) }",
", steps = [{ strategy = \"template\", src = \"gitignore.tmpl\", dest = \".gitignore\", when = None Text, patch = "
<> maybe "None Text" (\op -> "Some \"" <> op <> "\"") patchOp
<> " }]",
", commands = [] : List { run : Text, workDir : Optional Text, when : Optional Text }",
", dependencies = [] : List Text",
", removal = None { steps : List { action : Text, dest : Text, src : Optional Text }, commands : List { run : Text, workDir : Optional Text, when : Optional Text } }",
"}"
]
prepareRecipeUpdateFixture :: FilePath -> IO RecipeUpdateFixture
prepareRecipeUpdateFixture root = do
let projectRoot = root </> "project"
manifestPath = projectRoot </> ".seihou" </> "manifest.json"
remote = root </> "remote"
xdgHome = root </> "xdg"
installedRoot = xdgHome </> "seihou" </> "installed"
installedOne = installedRoot </> "one"
installedOld = installedRoot </> "old"
installedRecipe = installedRoot </> "stack"
target = AppliedRecipeTarget "stack"
applicationId = mkApplicationId target []
app =
AppliedComposition
{ applicationId,
target,
targetOrigin = remoteOrigin "stack",
targetVersion = Just "1.0.0",
additionalModules = [],
namespace = Just "one",
context = Nothing,
instances =
[ instanceStateFrom "old" (remoteOrigin "old"),
instanceStateFrom "one" (remoteOrigin "one")
],
commandReceipts = Map.empty,
appliedAt = testTime
}
base = emptyManifest testTime
manifest =
Manifest
{ version = base ^. #version,
genAt = base ^. #genAt,
modules =
[ AppliedModule "old" emptyParentVars (remoteOrigin "old") (Just "1.0.0") testTime Nothing,
AppliedModule "one" emptyParentVars (remoteOrigin "one") (Just "1.0.0") testTime Nothing
],
vars = Map.empty,
files = Map.empty,
applications = [app],
recipe = Just (AppliedRecipe "stack" (remoteOrigin "stack") (Just "1.0.0") testTime),
blueprint = Nothing,
blueprintMigrations = []
}
sourceUrl = T.pack remote
remoteOrigin name = RemoteOrigin sourceUrl name Nothing
createDirectoryIfMissing True installedOne
createDirectoryIfMissing True installedOld
createDirectoryIfMissing True installedRecipe
TIO.writeFile (installedOne </> "module.dhall") (moduleDhall "one" "1.0.0")
TIO.writeFile (installedOld </> "module.dhall") (moduleDhall "old" "1.0.0")
TIO.writeFile (installedRecipe </> "recipe.dhall") (recipeDhall "stack" "1.0.0" ["one", "old"])
mapM_ (writeOrigin sourceUrl) [installedOne, installedOld, installedRecipe]
createDirectoryIfMissing True (remote </> "modules" </> "one")
createDirectoryIfMissing True (remote </> "modules" </> "old")
createDirectoryIfMissing True (remote </> "modules" </> "new")
createDirectoryIfMissing True (remote </> "recipes" </> "stack")
TIO.writeFile (remote </> "modules" </> "one" </> "module.dhall") (moduleDhall "one" "2.0.0")
TIO.writeFile (remote </> "modules" </> "old" </> "module.dhall") (moduleDhall "old" "1.0.0")
TIO.writeFile (remote </> "modules" </> "new" </> "module.dhall") (moduleDhall "new" "1.0.0")
TIO.writeFile (remote </> "recipes" </> "stack" </> "recipe.dhall") (recipeDhall "stack" "2.0.0" ["one", "new"])
TIO.writeFile (remote </> "seihou-registry.dhall") recipeUpdateRegistryDhall
callProcess "git" ["-C", remote, "init", "-q"]
callProcess "git" ["-C", remote, "add", "."]
callProcess "git" ["-C", remote, "-c", "user.name=Seihou Test", "-c", "user.email=test@example.com", "commit", "-qm", "recipe v2"]
createDirectoryIfMissing True (projectRoot </> ".seihou")
LBS.writeFile manifestPath (manifestToJSON manifest)
pure
RecipeUpdateFixture
{ projectRoot = projectRoot,
manifestPath = manifestPath,
xdgHome = xdgHome,
applicationId = applicationId
}
updateRequest :: Bool -> UpdateRequest
updateRequest dryRun =
UpdateRequest
{ selection = AllRecordedApplications,
varOverrides = [],
reconfigure = False,
promptPolicy = ForbidPrompts,
commandPolicy = RunChangedCommands,
dryRun,
allowDowngrade = False,
includeSharedOwners = False
}
moduleDhallWithTemplate :: Text -> Text -> Text -> Text
moduleDhallWithTemplate name version defaultValue =
T.unlines
[ "{ name = \"" <> name <> "\"",
", version = Some \"" <> version <> "\"",
", description = None Text",
", vars = [{ name = \"project.name\", type = \"text\", default = Some \"" <> defaultValue <> "\", description = None Text, required = False, validation = None Text }]",
", exports = [] : List { var : Text, alias : Optional Text }",
", prompts = [] : List { var : Text, text : Text, when : Optional Text, choices : Optional (List Text) }",
", steps = [{ strategy = \"template\", src = \"README.tmpl\", dest = \"README.md\", when = None Text, patch = None Text }]",
", commands = [{ run = \"printf should-not-run >> command.log\", workDir = None Text, when = None Text }]",
", dependencies = [] : List Text",
", removal = None { steps : List { action : Text, dest : Text, src : Optional Text }, commands : List { run : Text, workDir : Optional Text, when : Optional Text } }",
"}"
]
withSavedEnv :: String -> Maybe String -> IO a -> IO a
withSavedEnv key value action =
bracket
(lookupEnv key <* setValue value)
setValue
(const action)
where
setValue (Just current) = setEnv key current
setValue Nothing = unsetEnv key
application :: AppliedTarget -> [AppliedInstanceState] -> AppliedComposition
application target instances =
AppliedComposition
{ applicationId = mkApplicationId target [],
target,
targetOrigin = LocalOrigin targetName,
targetVersion = Just "1.0.0",
additionalModules = [],
namespace = Nothing,
context = Nothing,
instances,
commandReceipts = Map.empty,
appliedAt = testTime
}
where
targetName = case target of
AppliedModuleTarget name -> name ^. #unModuleName
AppliedRecipeTarget name -> name ^. #unRecipeName
instanceState :: ModuleName -> AppliedInstanceState
instanceState name = instanceStateFrom name (LocalOrigin (name ^. #unModuleName))
instanceStateFrom :: ModuleName -> ArtifactOrigin -> AppliedInstanceState
instanceStateFrom name origin =
AppliedInstanceState
{ name,
parentVars = emptyParentVars,
origin,
moduleVersion = Just "1.0.0",
resolvedVars = Map.empty
}
moduleDhall :: Text -> Text -> Text
moduleDhall name version =
T.unlines
[ "{ name = \"" <> name <> "\"",
", version = Some \"" <> version <> "\"",
", description = None Text",
", vars = [] : List { name : Text, type : Text, default : Optional Text, description : Optional Text, required : Bool, validation : Optional Text }",
", exports = [] : List { var : Text, alias : Optional Text }",
", prompts = [] : List { var : Text, text : Text, when : Optional Text, choices : Optional (List Text) }",
", steps = [] : List { strategy : Text, src : Text, dest : Text, when : Optional Text, patch : Optional Text }",
", commands = [] : List { run : Text, workDir : Optional Text, when : Optional Text }",
", dependencies = [] : List Text",
", removal = None { steps : List { action : Text, dest : Text, src : Optional Text }, commands : List { run : Text, workDir : Optional Text, when : Optional Text } }",
"}"
]
recipeDhall :: Text -> Text -> [Text] -> Text
recipeDhall name version modules =
T.unlines
[ "{ name = \"" <> name <> "\"",
", version = Some \"" <> version <> "\"",
", description = None Text",
", modules = ["
<> T.intercalate
", "
[ "{ module = \"" <> moduleName <> "\", vars = [] : List { name : Text, value : Text } }"
| moduleName <- modules
]
<> "]",
", vars = [] : List { name : Text, type : Text, default : Optional Text, description : Optional Text, required : Bool, validation : Optional Text }",
", prompts = [] : List { var : Text, text : Text, when : Optional Text, choices : Optional (List Text) }",
"}"
]
registryDhall :: Text
registryDhall =
T.unlines
[ "{ repoName = \"update-test\"",
", repoDescription = None Text",
", modules =",
" [ { name = \"one\", version = Some \"2.0.0\", path = \"modules/one\", description = None Text, tags = [] : List Text }",
" , { name = \"two\", version = Some \"2.0.0\", path = \"modules/two\", description = None Text, tags = [] : List Text }",
" ]",
", recipes = [{ name = \"stack\", version = Some \"2.0.0\", path = \"recipes/stack\", description = None Text, tags = [] : List Text }]",
", blueprints = [] : List { name : Text, version : Optional Text, path : Text, description : Optional Text, tags : List Text }",
", prompts = [] : List { name : Text, version : Optional Text, path : Text, description : Optional Text, tags : List Text }",
"}"
]
recipeUpdateRegistryDhall :: Text
recipeUpdateRegistryDhall =
T.unlines
[ "{ repoName = \"recipe-update-test\"",
", repoDescription = None Text",
", modules =",
" [ { name = \"one\", version = Some \"2.0.0\", path = \"modules/one\", description = None Text, tags = [] : List Text }",
" , { name = \"old\", version = Some \"1.0.0\", path = \"modules/old\", description = None Text, tags = [] : List Text }",
" , { name = \"new\", version = Some \"1.0.0\", path = \"modules/new\", description = None Text, tags = [] : List Text }",
" ]",
", recipes = [{ name = \"stack\", version = Some \"2.0.0\", path = \"recipes/stack\", description = None Text, tags = [] : List Text }]",
", blueprints = [] : List { name : Text, version : Optional Text, path : Text, description : Optional Text, tags : List Text }",
", prompts = [] : List { name : Text, version : Optional Text, path : Text, description : Optional Text, tags : List Text }",
"}"
]
writeOrigin :: Text -> FilePath -> IO ()
writeOrigin sourceUrl directory = do
createDirectoryIfMissing True directory
TIO.writeFile (directory </> ".seihou-origin.json") ("{\"sourceUrl\":\"" <> sourceUrl <> "\"}")
manifestForApplications :: [AppliedComposition] -> Map.Map FilePath FileRecord -> Manifest
manifestForApplications applicationRecords fileRecords =
let base = emptyManifest testTime
in Manifest
{ version = base ^. #version,
genAt = base ^. #genAt,
modules = base ^. #modules,
vars = base ^. #vars,
files = fileRecords,
applications = applicationRecords,
recipe = base ^. #recipe,
blueprint = base ^. #blueprint,
blueprintMigrations = base ^. #blueprintMigrations
}
breakCandidatePublication :: UpdatePlan -> UpdatePlan
breakCandidatePublication plan =
UpdatePlan
{ applications = plan ^. #applications,
versionChanges = plan ^. #versionChanges,
inputChanges = plan ^. #inputChanges,
migrations = plan ^. #migrations,
reconciliation = plan ^. #reconciliation,
commandPlan = plan ^. #commandPlan,
candidateArtifacts = map breakArtifact (plan ^. #candidateArtifacts),
warnings = plan ^. #warnings,
request = plan ^. #request,
snapshot = plan ^. #snapshot,
plannedApplications = plan ^. #plannedApplications
}
where
breakArtifact artifact =
CandidateArtifact
{ kind = artifact ^. #kind,
name = artifact ^. #name,
version = artifact ^. #version,
originalDirectory = plan ^. #snapshot . #sessionDirectory </> "missing-publication-source",
sourceDirectory = artifact ^. #sourceDirectory,
sourceUrl = artifact ^. #sourceUrl,
repoName = artifact ^. #repoName,
tags = artifact ^. #tags,
sourceRevision = artifact ^. #sourceRevision,
contentHash = artifact ^. #contentHash,
moduleDefinition = artifact ^. #moduleDefinition,
recipeDefinition = artifact ^. #recipeDefinition
}
withoutApplications :: Manifest -> Manifest
withoutApplications manifest =
Manifest
{ version = manifest ^. #version,
genAt = manifest ^. #genAt,
modules = manifest ^. #modules,
vars = manifest ^. #vars,
files = manifest ^. #files,
applications = [],
recipe = manifest ^. #recipe,
blueprint = manifest ^. #blueprint,
blueprintMigrations = manifest ^. #blueprintMigrations
}
testTime :: UTCTime
testTime = UTCTime (fromGregorian 2026 7 19) 0