seihou-cli-0.10.0.0: test/Seihou/CLI/UpdateSpec.hs
module Seihou.CLI.UpdateSpec
( tests,
UpdateFixture (..),
prepareUpdateFixture,
SharedPathFixture (..),
CoOwnerWriteMode (..),
prepareSharedPathFixture,
publishBetaReleases,
installBetaVersion,
)
where
import Control.Exception (bracket)
import Control.Lens ((&), (.~), (^.))
import Control.Monad (forM_)
import Data.ByteString.Lazy qualified as LBS
import Data.Foldable (traverse_)
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 (currentManifestVersion, emptyManifest, manifestFromJSON, manifestToJSON)
import System.Directory (createDirectoryIfMissing, doesFileExist, removePathForcibly, withCurrentDirectory)
import System.Environment (lookupEnv, setEnv, unsetEnv)
import System.FilePath (takeDirectory, (</>))
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 "matches 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
matchApplications (NamedUpdateTargets ["shared"]) manifest
`shouldBe` Right (MatchedNamed (Set.fromList [first ^. #applicationId, second ^. #applicationId]))
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
matchApplications AllRecordedApplications manifest
`shouldBe` Right (MatchedAll [first, second])
(applicationsWithIds manifest <$> namedIds (matchApplications (NamedUpdateTargets ["two", "two", "one"]) manifest))
`shouldBe` Right [first, second]
it "matches a named target without consulting shared ownership" $ do
-- Matching is phase one. Even a path known to require the closure does
-- not stop it; that is phase two's decision.
let (first, second, manifest) = sharedPair SharedWriteRequiresOwnershipClosure
matchApplications (NamedUpdateTargets ["one"]) manifest
`shouldBe` Right (MatchedNamed (Set.singleton (first ^. #applicationId)))
second ^. #applicationId `shouldNotBe` first ^. #applicationId
it "rejects a partial selection that shares a path known to require the closure" $ do
let (first, second, manifest) = sharedPair SharedWriteRequiresOwnershipClosure
enforceOwnershipClosure RequireNamedOwners manifest (Set.singleton (first ^. #applicationId))
`shouldBe` Left
( SharedPathRequiresApplications
"shared.txt"
(Set.singleton (applicationRef manifest (first ^. #applicationId)))
(Set.singleton (applicationRef manifest (second ^. #applicationId)))
)
it "names each owner by its recorded target, not only its id" $ do
let (_, second, manifest) = sharedPair SharedWriteRequiresOwnershipClosure
applicationRef manifest (second ^. #applicationId)
`shouldBe` ApplicationRef (second ^. #applicationId) (Just (AppliedModuleTarget "two")) emptyParentVars []
applicationRef manifest (ApplicationId "unrecorded")
`shouldBe` ApplicationRef (ApplicationId "unrecorded") Nothing emptyParentVars []
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, _, manifest) = sharedPair SharedWriteAdditiveOnly
enforceOwnershipClosure RequireNamedOwners manifest (Set.singleton (first ^. #applicationId))
`shouldBe` Right (ClosureSatisfied (Set.singleton (first ^. #applicationId)) [])
it "asks for evidence, not for more applications, when the shared path is unknown" $ do
let (first, _, manifest) = sharedPair SharedWriteUnknown
selected = Set.singleton (first ^. #applicationId)
enforceOwnershipClosure RequireNamedOwners manifest selected
`shouldBe` Right (ClosureNeedsEvidence selected [] ["shared.txt"])
-- --include-shared-owners is consulted only for a known requirement,
-- so an unknown path does not broaden the selection either.
enforceOwnershipClosure IncludeSharedOwners manifest selected
`shouldBe` Right (ClosureNeedsEvidence selected [] ["shared.txt"])
it "reports a known closure requirement before asking for evidence" $ do
let first = application (AppliedModuleTarget "one") [instanceState "one"]
second = application (AppliedModuleTarget "two") [instanceState "two"]
owners = Set.fromList [first ^. #applicationId, second ^. #applicationId]
unknown = FileRecord (hashContent "ignore") "one" Template testTime Nothing owners SharedWriteUnknown
wholeFile = FileRecord (hashContent "old") "one" Template testTime Nothing owners SharedWriteRequiresOwnershipClosure
manifest :: Manifest
manifest = manifestForApplications [first, second] (Map.fromList [(".gitignore", unknown), ("shared.txt", wholeFile)])
case enforceOwnershipClosure RequireNamedOwners manifest (Set.singleton (first ^. #applicationId)) of
Left (SharedPathRequiresApplications path _ _) -> path `shouldBe` "shared.txt"
other -> expectationFailure ("expected a known closure refusal, got " <> show other)
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 SharedWriteAdditiveOnly
wholeFile = FileRecord (hashContent "old") "one" Template testTime Nothing owners SharedWriteRequiresOwnershipClosure
manifest :: Manifest
manifest =
manifestForApplications
[first, second]
(Map.fromList [(".gitignore", additive), ("shared.txt", wholeFile)])
enforceOwnershipClosure RequireNamedOwners manifest (Set.singleton (first ^. #applicationId))
`shouldBe` Left
( SharedPathRequiresApplications
"shared.txt"
(Set.singleton (applicationRef manifest (first ^. #applicationId)))
(Set.singleton (applicationRef manifest (second ^. #applicationId)))
)
it "expands a named selection to the owners the closure requires" $ do
let (first, second, manifest) = sharedPair SharedWriteRequiresOwnershipClosure
enforceOwnershipClosure IncludeSharedOwners manifest (Set.singleton (first ^. #applicationId))
`shouldBe` Right
( ClosureSatisfied
(Set.fromList [first ^. #applicationId, second ^. #applicationId])
[SelectionExpandedForSharedPath "shared.txt" (applicationRef manifest (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])
SharedWriteRequiresOwnershipClosure
manifest :: Manifest
manifest =
manifestForApplications
[first, second, third]
(Map.fromList [("a.txt", pair first second), ("b.txt", pair second third)])
case enforceOwnershipClosure IncludeSharedOwners manifest (Set.singleton (first ^. #applicationId)) of
Right (ClosureSatisfied selected warnings) -> do
applicationsWithIds manifest selected `shouldBe` [first, second, third]
warnings
`shouldBe` [ SelectionExpandedForSharedPath "a.txt" (applicationRef manifest (second ^. #applicationId)),
SelectionExpandedForSharedPath "b.txt" (applicationRef manifest (third ^. #applicationId))
]
other -> expectationFailure ("expected an expanded selection, got " <> show other)
it "asks for evidence about a path an expansion exposed" $ do
-- One and two share a whole-file a.txt; two and three share b.txt,
-- whose mode nobody has recorded. Expanding for a.txt makes b.txt
-- relevant, and that one needs evidence rather than more expansion.
let first = application (AppliedModuleTarget "one") [instanceState "one"]
second = application (AppliedModuleTarget "two") [instanceState "two"]
third = application (AppliedModuleTarget "three") [instanceState "three"]
pair mode left right =
FileRecord (hashContent "old") "one" Template testTime Nothing (Set.fromList [left ^. #applicationId, right ^. #applicationId]) mode
manifest :: Manifest
manifest =
manifestForApplications
[first, second, third]
( Map.fromList
[ ("a.txt", pair SharedWriteRequiresOwnershipClosure first second),
("b.txt", pair SharedWriteUnknown second third)
]
)
enforceOwnershipClosure IncludeSharedOwners manifest (Set.singleton (first ^. #applicationId))
`shouldBe` Right
( ClosureNeedsEvidence
(Set.fromList [first ^. #applicationId, second ^. #applicationId])
[SelectionExpandedForSharedPath "a.txt" (applicationRef manifest (second ^. #applicationId))]
["b.txt"]
)
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, _, manifest) = sharedPair SharedWriteAdditiveOnly
enforceOwnershipClosure IncludeSharedOwners manifest (Set.singleton (first ^. #applicationId))
`shouldBe` Right (ClosureSatisfied (Set.singleton (first ^. #applicationId)) [])
it "requires one explicit target to seed a legacy manifest" $ do
matchApplications AllRecordedApplications (emptyManifest testTime)
`shouldBe` Left NoRecordedApplications
matchApplications (NamedUpdateTargets ["one", "two"]) (emptyManifest testTime)
`shouldBe` Left LegacyUpdateRequiresOneTarget
matchApplications (NamedUpdateTargets ["one"]) (emptyManifest testTime)
`shouldBe` Right (MatchedLegacy "one")
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 shared-write evidence 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 SharedWriteUnknown True) `shouldBe` False
isUpdateNoOp (unchangedFilePlan SharedWriteUnknown False) `shouldBe` False
isUpdateNoOp (unchangedFilePlan SharedWriteRequiresOwnershipClosure True) `shouldBe` False
isUpdateNoOp (unchangedFilePlan SharedWriteAdditiveOnly False) `shouldBe` False
it "is a no-op when the recorded write mode already agrees" $ do
isUpdateNoOp (unchangedFilePlan SharedWriteAdditiveOnly True) `shouldBe` True
isUpdateNoOp (unchangedFilePlan SharedWriteRequiresOwnershipClosure 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 "targeted update on an older manifest" $ do
it "stages the schema step and certificate in the plan and rolls both back on failure" $
withSystemTempDirectory "seihou-update-prepared-rollback" $ \root -> do
fixture <- prepareSharedPathFixture CoOwnerAppendsPredatingEvidence root
let request = (updateRequest False) & #selection .~ NamedUpdateTargets ["alpha"]
withSavedEnv "XDG_CONFIG_HOME" (Just (fixture ^. #xdgHome)) $
withCurrentDirectory (fixture ^. #projectRoot) $ do
beforeManifest <- LBS.readFile (fixture ^. #manifestPath)
beforeGitignore <- LBS.readFile (fixture ^. #gitignorePath)
-- Publication fails after the managed files have been written.
failed <- withProjectUpdate request $ \case
Left err -> pure (Left err)
Right plan -> do
(plan ^. #snapshot . #originalManifest . #version) `shouldBe` ManifestSchemaVersion 6
case plan ^. #manifestPreparation of
Nothing -> expectationFailure "expected a manifest preparation"
Just preparation -> do
(preparation ^. #fromVersion) `shouldBe` ManifestSchemaVersion 6
(preparation ^. #toVersion) `shouldBe` ManifestSchemaVersion 7
(preparation ^. #modeChanges)
`shouldBe` Map.singleton ".gitignore" (SharedWriteUnknown, SharedWriteAdditiveOnly)
map (^. #applicationId) (plan ^. #applications) `shouldBe` [fixture ^. #alphaApplicationId]
applyProjectUpdate (breakCandidatePublication plan)
failed `shouldSatisfy` \case
Left UpdateCachePublicationFailed {} -> True
_ -> False
LBS.readFile (fixture ^. #manifestPath) `shouldReturn` beforeManifest
LBS.readFile (fixture ^. #gitignorePath) `shouldReturn` beforeGitignore
retried <- withProjectUpdate request $ \case
Left err -> pure (Left err)
Right plan -> applyProjectUpdate plan
case retried of
Left err -> expectationFailure (show err)
Right result -> (result ^. #updatedApplications) `shouldBe` [fixture ^. #alphaApplicationId]
decoded <- manifestFromJSON <$> LBS.readFile (fixture ^. #manifestPath)
((^. #version) <$> decoded) `shouldBe` Right currentManifestVersion
it "refuses a schema-5 manifest before staging, naming the explicit upgrade" $
withSystemTempDirectory "seihou-update-schema-5" $ \root -> do
fixture <- prepareSharedPathFixture CoOwnerAppends root
manifestText <- TIO.readFile (fixture ^. #manifestPath)
TIO.writeFile (fixture ^. #manifestPath) (T.replace "\"version\":9" "\"version\":5" manifestText)
withSavedEnv "XDG_CONFIG_HOME" (Just (fixture ^. #xdgHome)) $
withCurrentDirectory (fixture ^. #projectRoot) $ do
forM_ [NamedUpdateTargets ["alpha"], AllRecordedApplications] $ \selection -> do
result <- withProjectUpdate ((updateRequest True) & #selection .~ selection) (pure . fmap (const ()))
result `shouldSatisfy` \case
Left (UpdateManifestUpgradeRequired _ (ManifestSchemaVersion 5)) -> True
_ -> False
it "still refuses a candidate that turned a recorded additive path into a whole-file write" $
withSystemTempDirectory "seihou-update-candidate-whole-file" $ \root -> do
-- The manifest says additive-only, so the preflight passes; the
-- candidate's own operations are what reconciliation checks.
fixture <- prepareSharedPathFixture CoOwnerAppends root
let remote = root </> "remote" </> "alpha"
body <- TIO.readFile (remote </> "module.dhall")
TIO.writeFile (remote </> "module.dhall") (T.replace "patch = Some \"append-line-if-absent\"" "patch = None Text" body)
callProcess "git" ["-C", remote, "add", "module.dhall"]
callProcess "git" ["-C", remote, "-c", "user.name=Seihou Test", "-c", "user.email=test@example.com", "commit", "-qm", "whole file"]
withSavedEnv "XDG_CONFIG_HOME" (Just (fixture ^. #xdgHome)) $
withCurrentDirectory (fixture ^. #projectRoot) $ do
result <- withProjectUpdate ((updateRequest True) & #selection .~ NamedUpdateTargets ["alpha"]) (pure . fmap (const ()))
result `shouldSatisfy` \case
Left (UpdateReconciliationFailed _) -> True
_ -> False
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,
seeds = Map.empty,
checkoutOutputs = Map.empty,
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
-- shared-write mode the manifest holds and whether this run's contribution is
-- additive.
unchangedFilePlan :: SharedWriteMode -> Bool -> UpdatePlan
unchangedFilePlan priorMode 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
priorMode
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)
SharedWriteRequiresOwnershipClosure
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 'SharedWriteAdditiveOnly' 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
-- 'SharedWriteRequiresOwnershipClosure' and stays under the ownership closure.
CoOwnerWritesWholeFile
| -- | Beta appends, exactly as 'CoOwnerAppends', but the manifest is a
-- schema-6 file with no @additiveOnly@ key 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
| -- | The reported BUG-1 shape: a schema-6 manifest with no
-- @additiveOnly@ key, beta appending, alpha with a newer release to
-- apply, and beta /also/ published at a newer release that would
-- rewrite its own @beta.txt@. A targeted update of alpha must certify
-- @.gitignore@ from beta's recorded state without updating beta.
CoOwnerAppendsPredatingEvidence
deriving stock (Eq, Show)
-- | A project whose @.gitignore@ is co-owned by two recorded applications.
data SharedPathFixture = SharedPathFixture
{ projectRoot :: !FilePath,
gitignorePath :: !FilePath,
-- | A file only beta owns: an unrelated application's file.
betaFilePath :: !FilePath,
-- | Where beta's recorded 1.0.0 release is installed.
betaInstalledPath :: !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"
betaFilePath = projectRoot </> "beta.txt"
betaContent = "beta v1\n"
betaBaselineRef = BaselineRef (hashContent betaContent)
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
CoOwnerWritesWholeFile -> Nothing
_ -> Just "append-line-if-absent"
predatesEvidence = writeMode `elem` [CoOwnerAppendsUnrecorded, CoOwnerAppendsPredatingEvidence]
-- 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])
( case writeMode of
CoOwnerAppends -> SharedWriteAdditiveOnly
CoOwnerWritesWholeFile -> SharedWriteRequiresOwnershipClosure
CoOwnerAppendsUnrecorded -> SharedWriteUnknown
CoOwnerAppendsPredatingEvidence -> SharedWriteUnknown
)
betaFileRecord =
FileRecord
(hashContent betaContent)
"beta"
Template
testTime
(Just betaBaselineRef)
(Set.singleton betaApplicationId)
(if predatesEvidence then SharedWriteUnknown else SharedWriteRequiresOwnershipClosure)
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.fromList [(".gitignore", fileRecord), ("beta.txt", betaFileRecord)]
& #applications
.~ [ appliedFor "alpha" alphaTarget alphaApplicationId "1.0.0",
appliedFor "beta" betaTarget betaApplicationId "1.0.0"
]
-- An unrecorded answer is what a schema-6 file without the key says.
& #version
.~ ( if predatesEvidence
then ManifestSchemaVersion 6
else currentManifestVersion
)
)
-- Install one module and publish the same content as its git remote.
installModule name version patchOp content ownFile = 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 (fst <$> ownFile))
TIO.writeFile (installed </> "files" </> "gitignore.tmpl") content
traverse_ (\(file, fileContent) -> TIO.writeFile (installed </> "files" </> file) fileContent) ownFile
TIO.writeFile
(installed </> ".seihou-origin.json")
("{\"sourceUrl\":\"" <> T.pack remote <> "\",\"version\":\"" <> version <> "\"}")
pure installed
publishRemote name version patchOp content ownFile = do
let remote = remoteRoot </> T.unpack name
createDirectoryIfMissing True (remote </> "files")
TIO.writeFile (remote </> "module.dhall") (moduleDhallForGitignore name version patchOp (fst <$> ownFile))
TIO.writeFile (remote </> "files" </> "gitignore.tmpl") content
traverse_ (\(file, fileContent) -> TIO.writeFile (remote </> "files" </> file) fileContent) ownFile
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" Nothing
betaInstalledPath <- installModule "beta" "1.0.0" betaPatch "/result\n" (Just ("beta.txt", betaContent))
publishRemote "alpha" alphaRemoteVersion (Just "append-line-if-absent") alphaRemoteContent Nothing
-- Beta's newer release would rewrite beta.txt; only an update of beta
-- itself may apply it.
if writeMode == CoOwnerAppendsPredatingEvidence
then publishRemote "beta" "2.0.0" betaPatch "/result\n" (Just ("beta.txt", "beta v2\n"))
else publishRemote "beta" "1.0.0" betaPatch "/result\n" (Just ("beta.txt", betaContent))
createDirectoryIfMissing True (projectRoot </> ".seihou" </> "baselines")
TIO.writeFile gitignorePath baselineContent
TIO.writeFile
(projectRoot </> ".seihou" </> "baselines" </> T.unpack (baselineRef ^. #unBaselineRef . #unSHA256))
baselineContent
TIO.writeFile betaFilePath betaContent
TIO.writeFile
(projectRoot </> ".seihou" </> "baselines" </> T.unpack (betaBaselineRef ^. #unBaselineRef . #unSHA256))
betaContent
LBS.writeFile manifestPath (manifestToJSON manifest)
pure
SharedPathFixture
{ projectRoot,
gitignorePath,
betaFilePath,
betaInstalledPath,
manifestPath,
xdgHome,
alphaApplicationId,
betaApplicationId
}
-- | Replace beta's published remote with a history of one commit per
-- version, in order, each declaring that version with beta's recorded
-- content. Returns the remote, which is also beta's recorded origin.
publishBetaReleases :: SharedPathFixture -> [Text] -> IO FilePath
publishBetaReleases fixture versions = do
let remote = takeDirectory (fixture ^. #projectRoot) </> "remote" </> "beta"
removePathForcibly remote
createDirectoryIfMissing True (remote </> "files")
callProcess "git" ["-C", remote, "init", "-q"]
forM_ versions $ \version -> do
TIO.writeFile (remote </> "module.dhall") (moduleDhallForGitignore "beta" version (Just "append-line-if-absent") (Just "beta.txt"))
TIO.writeFile (remote </> "files" </> "gitignore.tmpl") "/result\n"
TIO.writeFile (remote </> "files" </> "beta.txt") "beta v1\n"
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]
pure remote
-- | Install beta at another version than the manifest records, as
-- @seihou upgrade@ would: the install cache has moved on.
installBetaVersion :: SharedPathFixture -> Text -> IO ()
installBetaVersion fixture version = do
let installed = fixture ^. #betaInstalledPath
bump = T.replace "\"1.0.0\"" ("\"" <> version <> "\"")
moduleText <- TIO.readFile (installed </> "module.dhall")
originText <- TIO.readFile (installed </> ".seihou-origin.json")
TIO.writeFile (installed </> "module.dhall") (bump moduleText)
TIO.writeFile (installed </> ".seihou-origin.json") (bump originText)
-- | A module whose step contributes to @.gitignore@, either through the
-- given patch operation or, with 'Nothing', as a whole-file template, and
-- optionally writes one file of its own from a template of the same name.
moduleDhallForGitignore :: Text -> Text -> Maybe Text -> Maybe FilePath -> Text
moduleDhallForGitignore name version patchOp ownFile =
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
<> " }"
<> maybe
""
(\file -> ", { strategy = \"template\", src = \"" <> T.pack file <> "\", dest = \"" <> T.pack file <> "\", when = None Text, patch = None Text }")
ownFile
<> "]",
", 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,
seeds = Map.empty,
checkoutOutputs = Map.empty,
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,
seeds = base ^. #seeds,
checkoutOutputs = base ^. #checkoutOutputs,
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,
checkoutPlan = plan ^. #checkoutPlan,
checkoutOutputs = plan ^. #checkoutOutputs,
manifestPreparation = plan ^. #manifestPreparation
}
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,
seeds = manifest ^. #seeds,
checkoutOutputs = manifest ^. #checkoutOutputs,
blueprintMigrations = manifest ^. #blueprintMigrations
}
-- | Two applications, @one@ and @two@, co-owning @shared.txt@ with the
-- given recorded mode.
sharedPair :: SharedWriteMode -> (AppliedComposition, AppliedComposition, Manifest)
sharedPair mode = (first, second, manifest)
where
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 mode
manifest = manifestForApplications [first, second] (Map.singleton "shared.txt" record)
namedIds :: Either UpdateError MatchedApplications -> Either UpdateError (Set.Set ApplicationId)
namedIds (Right (MatchedNamed ids)) = Right ids
namedIds (Right other) = error ("expected a named match, got " <> show other)
namedIds (Left err) = Left err
testTime :: UTCTime
testTime = UTCTime (fromGregorian 2026 7 19) 0