diff --git a/help/update.md b/help/update.md --- a/help/update.md +++ b/help/update.md @@ -16,6 +16,18 @@ seihou update master-plan + No separate installation is needed for an existing remote-backed application: + update fetches its remote and dependencies and reuses saved inputs. Review the + preview and accept it. After adoption, fresh clones restore declared links with: + + seihou sync + + An `Adopt link:` preview means update will stop tracking an unchanged matching + symlink in Git while keeping the working link. Accepting stages that removal; + commit it with the manifest. Modified or staged links and regular objects remain + protected. Dry-run/cancellation leave the index untouched; failed or interrupted + uncommitted updates recover the adopted entries without replacing unrelated staging. + Apply every recorded application in manifest order: seihou update diff --git a/seihou-cli.cabal b/seihou-cli.cabal --- a/seihou-cli.cabal +++ b/seihou-cli.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: seihou-cli -version: 0.10.0.0 +version: 0.10.1.0 synopsis: CLI for Seihou project scaffolding description: Command-line interface for Seihou, a composable project scaffolding @@ -135,7 +135,7 @@ generic-lens >=2.2 && <3, lens >=5.2 && <6, process >=1.6 && <2, - seihou-core ^>=0.10.0.0, + seihou-core ^>=0.10.1.0, streamly-core >=0.3 && <0.5, temporary >=1.3 && <2, text >=2.0 && <3, @@ -222,7 +222,7 @@ optparse-applicative >=0.18 && <1, process >=1.6 && <2, seihou-cli-internal, - seihou-core ^>=0.10.0.0, + seihou-core ^>=0.10.1.0, temporary >=1.3 && <2, text >=2.0 && <3, time >=1.12 && <2, @@ -312,7 +312,7 @@ lens >=5.2 && <6, process >=1.6 && <2, seihou-cli-internal, - seihou-core ^>=0.10.0.0, + seihou-core ^>=0.10.1.0, streamly-core >=0.3 && <0.5, tasty >=1.4 && <2, tasty-hspec >=1.2 && <2, diff --git a/src-exe/Seihou/CLI/Commands.hs b/src-exe/Seihou/CLI/Commands.hs --- a/src-exe/Seihou/CLI/Commands.hs +++ b/src-exe/Seihou/CLI/Commands.hs @@ -2371,7 +2371,13 @@ ) syncInfo :: ParserInfo Command -syncInfo = info (syncParser <**> helper) (fullDesc <> progDesc "Rebuild ignored checkout outputs from the manifest") +syncInfo = + info + (syncParser <**> helper) + ( fullDesc + <> progDesc "Restore declared local links for this checkout" + <> footer "Run at the Git working-tree root. No producer installation is needed. If links have not been declared yet, run seihou update TARGET once and commit the resulting manifest; later clones need only seihou sync." + ) where syncParser = Sync diff --git a/src-exe/Seihou/CLI/Sync.hs b/src-exe/Seihou/CLI/Sync.hs --- a/src-exe/Seihou/CLI/Sync.hs +++ b/src-exe/Seihou/CLI/Sync.hs @@ -25,7 +25,5 @@ if opts ^. #json then LBS.putStrLn (A.encode (checkoutReportJSON report)) else do - TIO.putStr (renderCheckoutPlan (opts ^. #dryRun) (report ^. #plan)) - mapM_ TIO.putStrLn (report ^. #notices) - mapM_ (TIO.putStrLn . (^. #message)) (report ^. #execution . #failure) + TIO.putStr (renderCheckoutReport report) if not (checkoutApplicable (report ^. #plan)) || isJust (report ^. #execution . #failure) then exitFailure else pure () diff --git a/src/Seihou/CLI/CheckoutSync.hs b/src/Seihou/CLI/CheckoutSync.hs --- a/src/Seihou/CLI/CheckoutSync.hs +++ b/src/Seihou/CLI/CheckoutSync.hs @@ -3,6 +3,8 @@ runCheckoutSync, checkoutReportJSON, renderCheckoutPlan, + renderCheckoutReport, + checkoutAdoptionNotices, renderCheckoutStatus, checkoutFailureJSON, ) @@ -15,6 +17,7 @@ import Data.Map.Strict qualified as Map import Data.Text qualified as T import Data.Text.Encoding qualified as TE +import Seihou.CLI.ApplicationDisplay (appliedTargetName) import Seihou.Core.Checkout import Seihou.Core.Types import Seihou.Effect.Filesystem hiding (CreateDirectoryLink) @@ -56,12 +59,31 @@ Left err -> pure (Left err) Right plan -> do execution <- if dryRun then pure (CheckoutExecution Map.empty [] Nothing) else applyCheckoutPlan SyncIgnoredOnly root plan - let notices = ["No checkout declarations. Apply a declaring module release once before future clones can use seihou sync." | Map.null (manifest ^. #checkoutOutputs)] + let notices = checkoutAdoptionNotices manifest pure (Right (CheckoutSyncResult root dryRun plan execution notices)) pure $ case result of Left err -> Left (checkoutError "checkout_io_failed" ("cannot inspect checkout: " <> T.pack (displayException err))) Right value -> value +-- | Suggest a check of recorded targets, without claiming that their remotes +-- necessarily contain a declaring release or inferring intent from receipts. +checkoutAdoptionNotices :: Manifest -> [Text] +checkoutAdoptionNotices manifest + | not (Map.null (manifest ^. #checkoutOutputs)) = [] + | null (manifest ^. #applications) = + ["No links are declared in this manifest. Apply a module that declares checkout links, then commit its manifest and source files."] + | otherwise = + [ "No links are declared in this manifest. Sync can restore links after a declaring module update has been adopted.", + "Check for an update using the recorded target below; review its preview before accepting:" + ] + <> map (" seihou update " <>) targets + <> ["Commit the adopted manifest and source files. Future clones need only seihou sync; no producer installation is required."] + where + targets = Map.keys (Map.fromList [(shellWord (appliedTargetName (app ^. #target)), ()) | app <- manifest ^. #applications]) + shellWord word + | T.all (\c -> c `elem` ("abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789-_." :: String)) word = word + | otherwise = "'" <> T.replace "'" "'\\''" word <> "'" + checkoutFailureJSON :: Bool -> CheckoutError -> A.Value checkoutFailureJSON dryRun err = A.object ["mode" A..= mode dryRun, "outputs" A..= ([] :: [A.Value]), "errors" A..= [errorJSON err], "summary" A..= A.object ["planned" A..= counts [], "applied" A..= counts []]] @@ -141,6 +163,52 @@ <> T.concat ["; " <> warning | warning <- entry ^. #warnings] | entry <- plan ^. #entries ] + +renderCheckoutReport :: CheckoutSyncResult -> Text +renderCheckoutReport report = + renderCheckoutPlan (report ^. #dryRun) displayedPlan + <> summary + <> T.unlines (report ^. #notices) + <> T.unlines (map (^. #message) (maybe [] pure (report ^. #execution . #failure))) + where + entries = report ^. #plan . #entries + outcomes = report ^. #execution . #outcomes + -- A failed or rolled-back apply must never print a proposed create as + -- though it succeeded. The summary counts successful mutations only. + displayedPlan = + if report ^. #dryRun + then report ^. #plan + else + CheckoutPlan + [ entry + & #warnings + %~ (<> [outcome | outcome `notElem` ["applied", "unchanged"]]) + & #action + .~ (if outcome `elem` ["applied", "unchanged"] then entry ^. #action else RefusedLink) + | entry <- entries, + let outcome = Map.findWithDefault "not-applied" (entry ^. #dest) outcomes + ] + countAction action = + T.pack + ( show + ( length + [ () + | entry <- entries, + entry ^. #action == action, + report ^. #dryRun || Map.lookup (entry ^. #dest) outcomes `elem` [Just "applied", Just "unchanged"] + ] + ) + ) + summary + | null entries = "" + | otherwise = + (if report ^. #dryRun then "Would sync links: " else "Links: ") + <> countAction CreateLink + <> " created, " + <> countAction ReplaceLink + <> " repaired, " + <> countAction UnchangedLink + <> " unchanged.\n" renderCheckoutStatus :: CheckoutPlan -> Text renderCheckoutStatus plan = diff --git a/src/Seihou/CLI/StatusRender.hs b/src/Seihou/CLI/StatusRender.hs --- a/src/Seihou/CLI/StatusRender.hs +++ b/src/Seihou/CLI/StatusRender.hs @@ -21,12 +21,14 @@ import Data.Time.Format (defaultTimeLocale, formatTime) import Seihou.CLI.ApplicationDisplay (appliedTargetName, parentVarsText) import Seihou.CLI.CheckoutSync (renderCheckoutStatus) -import Seihou.CLI.ManifestGuard (ArtifactCheck, summarizeCheck) +import Seihou.CLI.ManifestGuard (ArtifactCheck (..), ArtifactVerdict (..), summarizeCheck) import Seihou.CLI.Style (dim, green, red, yellow) import Seihou.CLI.VersionCompare ( OutdatedEntry (..), OutdatedStatus (..), ) +import Seihou.Core.ArtifactIdentity (isMachineLocalOriginUrl) +import Seihou.Core.ArtifactRef (ArtifactRefError (..)) import Seihou.Core.Checkout (CheckoutPlan) import Seihou.Core.Migration (MigrationPlan (..)) import Seihou.Core.Types @@ -37,6 +39,7 @@ AppliedModule (..), AppliedRecipe (..), AppliedTarget (..), + ArtifactOrigin (..), Manifest (..), MigrationOutcome (..), ModuleName (..), @@ -269,12 +272,20 @@ -- text when every artifact is healthy, so the section disappears entirely -- rather than printing a reassuring "0 problems". formatArtifactChecks :: Bool -> [ArtifactCheck] -> Text -formatArtifactChecks color checks = case mapMaybe summarizeCheck checks of - [] -> "" - summaries -> - T.unlines $ - ["", applyColor color yellow "Artifacts that differ from what this project records:"] - ++ map (" " <>) summaries +formatArtifactChecks color checks = warnings <> cacheNotice + where + summaries = mapMaybe summarizeCheck (filter (not . remoteCacheMiss) checks) + warnings = case summaries of + [] -> "" + _ -> T.unlines (["", applyColor color yellow "Artifacts that differ from what this project records:"] ++ map (" " <>) summaries) + missing = length (filter remoteCacheMiss checks) + cacheNotice + | missing == 0 = "" + | otherwise = + "\n" <> applyColor color dim ("Remote producer cache: " <> T.pack (show missing) <> " not cached locally (optional). Sync needs no producers; update fetches its remote candidates.") <> "\n" + remoteCacheMiss check = case (check ^. #origin, check ^. #verdict) of + (RemoteOrigin url _ _, ArtifactUnresolvable (ArtifactNotFoundLocally _ _)) -> not (isMachineLocalOriginUrl url) + _ -> False adviceCommand :: ModuleAdvice -> Maybe Text adviceCommand AdviceNone = Nothing diff --git a/src/Seihou/CLI/Update.hs b/src/Seihou/CLI/Update.hs --- a/src/Seihou/CLI/Update.hs +++ b/src/Seihou/CLI/Update.hs @@ -175,7 +175,7 @@ checkoutSetup <- planCheckoutUpdate projectRoot base plannedApplications case checkoutSetup of Left err -> pure (Left err) - Right (checkoutCandidate, checkoutPlan) -> do + Right (checkoutCandidate, checkoutPlan, checkoutAdoptions) -> do evidence <- versionEvidence (request ^. #allowDowngrade) projectRoot catalog selected plannedApplications case evidence of Left err -> pure (Left err) @@ -191,7 +191,7 @@ <> versionWarnings <> map CheckoutWarning (concatMap (^. #warnings) (checkoutPlan ^. #entries)) inputChanges = summarizeInputChanges seedWarnings plannedApplications - transactionTargets = transactionTargetPaths base reconciliation (migrationStage ^. #plans) `Set.union` Set.fromList [entry ^. #dest | entry <- checkoutPlan ^. #entries, entry ^. #action `elem` [CreateLink, ReplaceLink, RetireLink]] + transactionTargets = transactionTargetPaths base reconciliation (migrationStage ^. #plans) `Set.union` Map.keysSet checkoutAdoptions `Set.union` Set.fromList [entry ^. #dest | entry <- checkoutPlan ^. #entries, entry ^. #action `elem` [CreateLink, ReplaceLink, RetireLink]] -- The manifest is observed as it is on disk, before -- any in-memory preparation, so an edit made between -- planning and apply is reported as a stale plan. @@ -221,6 +221,7 @@ reconciliation, checkoutPlan, checkoutOutputs = checkoutCandidate ^. #checkoutOutputs, + checkoutAdoptions, commandPlan, candidateArtifacts = usedArtifacts, warnings, @@ -458,8 +459,11 @@ case backupResult of Left err -> abortUpdate transaction err Right () -> do + adopted <- adoptTrackedLinks transaction (plan ^. #checkoutAdoptions) now <- getCurrentTime - migrated <- runRealMigrations now (planBaseManifest plan) (plan ^. #migrations) + migrated <- case adopted of + Left err -> pure (Left (UpdateTransactionFailed err)) + Right () -> runRealMigrations now (planBaseManifest plan) (plan ^. #migrations) case migrated of Left err -> abortUpdate transaction err Right migratedManifest -> do @@ -836,10 +840,9 @@ -- The manifest records no path, so the already-applied artifact has to be -- located from its recorded origin before its content can be hashed. A - -- resolution failure keeps the existing conservative behaviour of treating - -- the artifact as changed: this produces an advisory warning, not a - -- correctness gate. Aborting on a stale or missing artifact is the job of - -- docs/plans/78-refuse-accidental-module-downgrades-and-origin-mismatches.md. + -- missing installed copy supplies no evidence of a same-version change. + -- Reconciliation still compares candidate output with project baselines; + -- absent cache bytes must not manufacture a content-change warning. compareArtifact name fromVersion toVersion oldOrigin kind = do searchPaths <- defaultSearchPaths resolved <- resolveArtifactOrigin projectRoot searchPaths (definitionFileFor kind) oldOrigin @@ -849,7 +852,7 @@ let candidateHash = (^. #contentHash) <$> Map.lookup (kind, name) (catalog ^. #artifacts) changed = case (oldHashResult, candidateHash) of (Right oldHash, Just newHash) -> oldHash /= newHash - _ -> True + _ -> False pure ( Right VersionChange @@ -991,6 +994,9 @@ stalePlanPaths :: UpdatePlan -> IO (Set FilePath) stalePlanPaths plan = do + indexChecks <- forM (Map.toAscList (plan ^. #checkoutAdoptions)) $ \(path, oid) -> do + current <- trackedLinkIdentity (plan ^. #snapshot . #projectRoot) path + pure [path | current /= Just oid] currentProject <- observePaths (plan ^. #snapshot . #projectRoot) @@ -1003,7 +1009,7 @@ let projectChanges = Map.keysSet (Map.filterWithKey (\path observed -> Map.lookup path currentProject /= Just observed) (plan ^. #snapshot . #observedProjectHashes)) - pure (Set.union projectChanges (Set.fromList (concat candidateChecks))) + pure (Set.union projectChanges (Set.fromList (concat candidateChecks <> concat indexChecks))) planActualReconciliation :: UpdatePlan -> Manifest -> IO (Either UpdateError ReconciliationPlan) planActualReconciliation plan manifest = do @@ -1311,6 +1317,7 @@ skippedDisabled = summary ^. #skippedDisabled }, touchedPaths = touched, + adoptedLinks = Map.keys (plan ^. #checkoutAdoptions), warnings = plan ^. #warnings <> cleanupWarnings <> pruneWarnings } ) @@ -1353,6 +1360,7 @@ fileSummary = reconciliationSummary (plan ^. #reconciliation), commandSummary = CommandSummary 0 0 0, touchedPaths = Set.empty, + adoptedLinks = [], warnings = plan ^. #warnings } @@ -1367,6 +1375,7 @@ -- change to applied state that only this update will publish (ADR 0004), -- so a plan carrying one is never a deliberate no-op (ADR 0007). plan ^. #checkoutOutputs == plan ^. #snapshot . #originalManifest . #checkoutOutputs + && Map.null (plan ^. #checkoutAdoptions) && all ((== UnchangedLink) . (^. #action)) (plan ^. #checkoutPlan . #entries) && isNothing (plan ^. #manifestPreparation) && null (plan ^. #versionChanges) @@ -1420,16 +1429,44 @@ varValueToText (VInt value) = T.pack (show value) varValueToText (VList values) = T.intercalate "," (map varValueToText values) -planCheckoutUpdate :: FilePath -> Manifest -> [PlannedApplication] -> IO (Either UpdateError (Manifest, CheckoutPlan)) +planCheckoutUpdate :: FilePath -> Manifest -> [PlannedApplication] -> IO (Either UpdateError (Manifest, CheckoutPlan, Map FilePath Text)) planCheckoutUpdate root prior applications = case replaceCheckoutApplications prior [(app ^. #candidate, app ^. #operations) | app <- applications] of Left err -> pure (Left (UpdateCheckoutFailed err)) Right candidate -> do planned <- runEff $ runFilesystem $ runProcessIO $ prepareCheckoutApplication root prior candidate (concatMap (^. #operations) applications) + adoptions <- case planned of + Left _ -> pure Map.empty + Right plan -> fmap Map.fromList $ fmap concat $ forM (plan ^. #entries) $ \entry -> + if eligible entry + then do + identity <- trackedLinkIdentity root (entry ^. #dest) + pure [(entry ^. #dest, oid) | Just oid <- [identity]] + else pure [] pure $ do - plan <- first UpdateCheckoutFailed planned - case concatMap (^. #errors) (plan ^. #entries) of - err : _ -> Left (UpdateCheckoutFailed err) - [] -> Right (candidate, plan) + original <- first UpdateCheckoutFailed planned + let observations = + Map.fromList + [ ( entry ^. #dest, + if Map.member (entry ^. #dest) adoptions + then entry ^. #observation & #problems %~ filter ((/= "checkout_path_tracked") . (^. #code)) + else entry ^. #observation + ) + | entry <- original ^. #entries + ] + plan = planCheckoutOutputs Reconcile ApplyDeclaration (prior ^. #checkoutOutputs) (candidate ^. #checkoutOutputs) observations + case [(entry ^. #dest, err) | entry <- plan ^. #entries, err <- entry ^. #errors] of + (path, err) : _ -> Left (UpdateCheckoutFailed (err & #message %~ (("checkout link '" <> T.pack path <> "': ") <>))) + [] -> Right (candidate, plan, adoptions) + where + eligible entry = + entry ^. #previous == Nothing + && entry ^. #observation . #ignored + && entry ^. #observation . #sourceDirectory + && not (null (entry ^. #observation . #problems)) + && all ((== "checkout_path_tracked") . (^. #code)) (entry ^. #observation . #problems) + && case entry ^. #candidate of + Just spec -> entry ^. #observation . #entry == EntrySymlink (expectedTarget (entry ^. #dest) spec) + Nothing -> False applyUpdateCheckout :: UpdatePlan -> Manifest -> Manifest -> IO (Either UpdateError ()) applyUpdateCheckout plan prior filesManifest = runEff $ runFilesystem $ runProcessIO $ do diff --git a/src/Seihou/CLI/Update/Render.hs b/src/Seihou/CLI/Update/Render.hs --- a/src/Seihou/CLI/Update/Render.hs +++ b/src/Seihou/CLI/Update/Render.hs @@ -125,6 +125,7 @@ renderCommands (summarizeCommandPlan (plan ^. #commandPlan)) ] <> T.lines (renderCheckoutPlan True (plan ^. #checkoutPlan)) + <> ["Adopt link: " <> T.pack path <> " (stop tracking in Git; keep working link)" | path <- Map.keys (plan ^. #checkoutAdoptions)] <> conflictLines (plan ^. #reconciliation) <> warningLines (plan ^. #warnings) renderUpdateHuman _ (UpdateAppliedOutput (UpdateResultView result)) = @@ -139,6 +140,7 @@ <> count (result ^. #commandSummary . #skippedDisabled) <> " disabled" ] + <> ["Adopted " <> count (length (result ^. #adoptedLinks)) <> " link(s): Git removals staged; working links kept. Commit with the updated manifest." | not (null (result ^. #adoptedLinks))] <> warningLines (result ^. #warnings) renderUpdateHuman _ (UpdateFailedOutput (UpdateErrorView target err)) = "Update failed [" <> errorCode err <> "]: " <> errorMessage err <> "\n" <> agentUpgradeHint target @@ -158,6 +160,7 @@ "inputs" .= inputValue (plan ^. #inputChanges), "migrations" .= map migrationValue (plan ^. #migrations), "checkout" .= checkoutReportJSON (CheckoutSyncResult (plan ^. #snapshot . #projectRoot) True (plan ^. #checkoutPlan) (CheckoutExecution Map.empty [] Nothing) []), + "checkoutAdoptions" .= Map.keys (plan ^. #checkoutAdoptions), "files" .= map fileValue (Map.toAscList (plan ^. #reconciliation . #files)), "commands" .= map commandValue (plan ^. #commandPlan . #commands), "warnings" .= map warningText (plan ^. #warnings) @@ -176,6 +179,7 @@ "skippedDisabled" .= (result ^. #commandSummary . #skippedDisabled) ], "touchedPaths" .= Set.toAscList (result ^. #touchedPaths), + "adoptedLinks" .= (result ^. #adoptedLinks), "warnings" .= map warningText (result ^. #warnings) ] outputValue (UpdateFailedOutput (UpdateErrorView _ err)) = @@ -734,6 +738,7 @@ planLooksUnchanged :: UpdatePlan -> Bool planLooksUnchanged plan = plan ^. #checkoutOutputs == plan ^. #snapshot . #originalManifest . #checkoutOutputs + && Map.null (plan ^. #checkoutAdoptions) && all ((== UnchangedLink) . (^. #action)) (plan ^. #checkoutPlan . #entries) && isNothing (plan ^. #manifestPreparation) && null (plan ^. #versionChanges) diff --git a/src/Seihou/CLI/Update/Types.hs b/src/Seihou/CLI/Update/Types.hs --- a/src/Seihou/CLI/Update/Types.hs +++ b/src/Seihou/CLI/Update/Types.hs @@ -211,6 +211,7 @@ reconciliation :: !ReconciliationPlan, checkoutPlan :: !CheckoutPlan, checkoutOutputs :: !(Map FilePath CheckoutOutputRecord), + checkoutAdoptions :: !(Map FilePath Text), commandPlan :: !CommandPlan, candidateArtifacts :: ![CandidateArtifact], warnings :: ![UpdateWarning], @@ -235,6 +236,7 @@ fileSummary :: !ReconciliationSummary, commandSummary :: !CommandSummary, touchedPaths :: !(Set FilePath), + adoptedLinks :: ![FilePath], warnings :: ![UpdateWarning] } deriving stock (Eq, Generic, Show) diff --git a/test/Seihou/CLI/CheckoutSyncE2ESpec.hs b/test/Seihou/CLI/CheckoutSyncE2ESpec.hs --- a/test/Seihou/CLI/CheckoutSyncE2ESpec.hs +++ b/test/Seihou/CLI/CheckoutSyncE2ESpec.hs @@ -7,6 +7,7 @@ import Data.ByteString.Lazy qualified as LBS import Data.List (isInfixOf) import Data.Text qualified as T +import Data.Text.Encoding qualified as TE import Data.Text.IO qualified as TIO import Seihou.CLI.SeihouBinary (seihouBinary) import System.Directory qualified as D @@ -35,7 +36,14 @@ snapshot root = do names <- filter (not . null) . splitNul <$> git root ["ls-files", "-z"] - blobs <- mapM (\path -> (path,) <$> BS.readFile (root path)) names + blobs <- + mapM + ( \path -> do + linked <- D.pathIsSymbolicLink (root path) + bytes <- if linked then TE.encodeUtf8 . T.pack <$> D.getSymbolicLinkTarget (root path) else BS.readFile (root path) + pure (path, bytes) + ) + names index <- git root ["ls-files", "--stage", "-z"] pure (blobs, index) where @@ -76,8 +84,132 @@ _ <- git root ["commit", "-qm", "test: record checkout output declarations"] pure (binary, moduleDir) +-- Establish a real old command-producing application, then publish a declaring +-- release. Adoption itself runs in a different, empty personal configuration. +prepareAdoption temp failing = do + binary <- seihouBinary + cwd <- D.getCurrentDirectory + schema <- D.canonicalizePath (takeDirectory cwd "schema") + let root = temp "project" + remote = temp "producer" + initialHome = temp "initial-home" + home = temp "empty-home" + remoteUrl = "https://seihou-fixture.invalid/demo.git" + moduleBody version steps commands = + T.unlines + [ "let S = ./schema/package.dhall in S.Module::{name = \"demo\", version = Some \"" <> version <> "\",", + "steps = " <> steps <> ", commands = " <> commands <> "}" + ] + commit repo message = do + _ <- git repo ["add", "."] + git repo ["-c", "user.name=Test", "-c", "user.email=test@example.invalid", "commit", "-qm", message] + forM_ [root "config/editor", remote "schema", initialHome, home] (D.createDirectoryIfMissing True) + -- Keep the recorded origin portable while Git routes this fixture remote to + -- disk. The adoption home has Git configuration but no producer cache. + forM_ [initialHome, home] $ \gitHome -> do + _ <- git gitHome ["config", "--file", gitHome ".gitconfig", "url." <> remote <> ".insteadOf", remoteUrl] + pure () + files <- D.listDirectory schema + forM_ files $ \file -> if takeExtension file == ".dhall" then D.copyFile (schema file) (remote "schema" file) else pure () + TIO.writeFile + (remote "module.dhall") + ( moduleBody + "1.0.0" + "[] : List S.Step.Type" + "[S.Command::{run = \"mkdir -p .local && ln -s ../config/editor .local/config\"}]" + ) + _ <- git remote ["init", "-q"] + _ <- commit remote "test: publish command producer" + _ <- git root ["init", "-q"] + TIO.writeFile (root ".gitignore") ".local/\n.seihou/transactions/\n" + TIO.writeFile (root "config/editor/sentinel") "tracked source\n" + TIO.writeFile (root "unrelated") "committed\n" + _ <- success binary root initialHome ["install", remoteUrl] + _ <- success binary root initialHome ["run", "demo", "--force"] + D.createDirectoryLink "../config/editor" (root ".local/unrelated") + _ <- git root ["add", "-f", ".local/config", ".local/unrelated"] + _ <- commit root "test: record legacy application and discovery links" + let commands = if failing then "[S.Command::{run = \"exit 42\"}]" else "[] : List S.Command.Type" + TIO.writeFile + (remote "module.dhall") + ( moduleBody + "2.0.0" + "[S.Step::{strategy = \"symlink\", lifecycle = Some \"checkout\", src = \"config/editor\", dest = \".local/config\"}]" + commands + ) + _ <- commit remote "test: publish checkout declarations" + pure (binary, root, home) + tests :: IO TestTree tests = testSpec "manifest-only checkout sync" $ do + it "adopts a tracked link using remote update alone, then syncs a fresh clone" $ + withSystemTempDirectory "checkout-adoption" $ \temp -> do + (binary, root, home) <- prepareAdoption temp False + D.doesDirectoryExist (home "config/seihou/installed") `shouldReturn` False + notice <- success binary root home ["sync"] + notice `shouldSatisfy` isInfixOf "seihou update demo" + TIO.writeFile (root "unrelated") "staged edit\n" + _ <- git root ["add", "unrelated"] + TIO.writeFile (root "unrelated") "unstaged edit\n" + indexBefore <- git root ["ls-files", "--stage", "-z"] + manifestBefore <- BS.readFile (root ".seihou/manifest.json") + dry <- success binary root home ["update", "demo", "--dry-run"] + dry `shouldSatisfy` isInfixOf "Adopt link: .local/config" + git root ["ls-files", "--stage", "-z"] `shouldReturn` indexBefore + BS.readFile (root ".seihou/manifest.json") `shouldReturn` manifestBefore + _ <- success binary root home ["update", "demo"] + git root ["ls-files", "--stage", "-z"] `shouldReturn` indexBefore + BS.readFile (root ".seihou/manifest.json") `shouldReturn` manifestBefore + applied <- success binary root home ["update", "demo", "--json"] + applied `shouldSatisfy` isInfixOf "\"adoptedLinks\":[\".local/config\"]" + git root ["ls-files", "--", ".local/config"] `shouldReturn` "" + git root ["ls-files", "--", ".local/unrelated"] `shouldReturn` ".local/unrelated\n" + git root ["show", ":unrelated"] `shouldReturn` "staged edit\n" + TIO.readFile (root "unrelated") `shouldReturn` "unstaged edit\n" + D.getSymbolicLinkTarget (root ".local/config") `shouldReturn` "../config/editor" + _ <- git root ["add", ".seihou/manifest.json"] + _ <- git root ["-c", "user.name=Test", "-c", "user.email=test@example.invalid", "commit", "-qm", "test: adopt links"] + let clone = temp "clone"; cloneHome = temp "clone-home" + D.createDirectoryIfMissing True cloneHome + _ <- git root ["clone", "-q", root, clone] + before <- snapshot clone + D.doesPathExist (clone ".local/config") `shouldReturn` False + first <- success binary clone cloneHome ["sync"] + first `shouldSatisfy` isInfixOf "Links: 1 created, 0 repaired, 0 unchanged." + second <- success binary clone cloneHome ["sync"] + second `shouldSatisfy` isInfixOf "Links: 0 created, 0 repaired, 1 unchanged." + status <- success binary clone cloneHome ["status"] + status `shouldSatisfy` isInfixOf "Checkout outputs: 1 declared, 0 need attention." + status `shouldSatisfy` isInfixOf "Remote producer cache: 1 not cached locally (optional)" + status `shouldNotSatisfy` isInfixOf "Artifacts that differ" + snapshot clone `shouldReturn` before + D.doesDirectoryExist (cloneHome "config/seihou/installed") `shouldReturn` False + it "restores the original index and working links if an adopted update fails" $ + withSystemTempDirectory "checkout-adoption-failed" $ \temp -> do + (binary, root, home) <- prepareAdoption temp True + before <- snapshot root + (code, _, _) <- invoke binary root home ["update", "demo", "--json"] + code `shouldSatisfy` (/= ExitSuccess) + snapshot root `shouldReturn` before + forM_ ["staged link", "unstaged link", "regular file"] $ \kind -> + it ("protects a " <> kind <> " during adoption") $ + withSystemTempDirectory "checkout-adoption-refused" $ \temp -> do + (binary, root, home) <- prepareAdoption temp False + D.removeDirectoryLink (root ".local/config") + if kind == "regular file" + then TIO.writeFile (root ".local/config") "user bytes" + else D.createDirectoryLink "../other-target" (root ".local/config") + if kind == "staged link" + then do + _ <- git root ["add", "-f", ".local/config"] + -- The working link matches the new declaration, but the index does not. + D.removeDirectoryLink (root ".local/config") + D.createDirectoryLink "../config/editor" (root ".local/config") + else pure () + before <- snapshot root + (code, _, _) <- invoke binary root home ["update", "demo", "--json"] + code `shouldSatisfy` (/= ExitSuccess) + snapshot root `shouldReturn` before forM_ [("agent", "agents/skills/demo", ".claude/skills/demo", "agents/skills/demo", ".agents/skills/demo"), ("editor and assets", "config/editor", ".editor-local/config", "assets/shared", ".tool-local/assets")] $ \(domain, source, destination, secondSource, secondDestination) -> it ("restores " <> domain <> " links in a clean clone without a producer or commands") $ withSystemTempDirectory "checkout-clone" $ \temp -> do diff --git a/test/Seihou/CLI/CheckoutSyncSpec.hs b/test/Seihou/CLI/CheckoutSyncSpec.hs --- a/test/Seihou/CLI/CheckoutSyncSpec.hs +++ b/test/Seihou/CLI/CheckoutSyncSpec.hs @@ -36,6 +36,14 @@ mapM_ (\action -> renderCheckoutPlan True (CheckoutPlan [entry action]) `shouldSatisfy` (not . T.null)) actions let report = checkoutReportJSON (result False (CheckoutPlan [entry CreateLink]) (Map.singleton ".local/config" "rolled-back")) T.pack (show report) `shouldSatisfy` T.isInfixOf "rolled-back" + it "never counts a failed or rolled-back mutation as a created link" $ do + let rendered = renderCheckoutReport (result False (CheckoutPlan [entry CreateLink]) (Map.singleton ".local/config" "rolled-back")) + rendered `shouldSatisfy` T.isInfixOf "0 created" + rendered `shouldSatisfy` T.isInfixOf "rolled-back" + rendered `shouldNotSatisfy` T.isInfixOf "1 created" + it "summarizes proposed dry-run work without claiming writes" $ do + renderCheckoutReport (result True (CheckoutPlan [entry CreateLink]) Map.empty) + `shouldSatisfy` T.isInfixOf "Would sync links: 1 created" it "bounds status to ten sorted paths and supplies the sync remedy" $ do let entries = [entry CreateLink & #dest .~ ("path-" <> show n) | n <- [1 :: Int .. 12]] rendered = renderCheckoutStatus (CheckoutPlan entries) diff --git a/test/Seihou/CLI/StatusSpec.hs b/test/Seihou/CLI/StatusSpec.hs --- a/test/Seihou/CLI/StatusSpec.hs +++ b/test/Seihou/CLI/StatusSpec.hs @@ -19,6 +19,7 @@ ( OutdatedEntry (..), OutdatedStatus (..), ) +import Seihou.Core.ArtifactRef (ArtifactRefError (..)) import Seihou.Core.Migration ( Migration (..), MigrationOp (..), @@ -481,3 +482,29 @@ } formatArtifactChecks False [check] `shouldBe` "" formatArtifactChecks False [] `shouldBe` "" + + it "treats an empty remote producer cache as optional rather than project damage" $ do + let origin = RemoteOrigin "https://example.com/demo.git" "demo" Nothing + missing = ArtifactCheck (ModuleName "demo") origin (ArtifactUnresolvable (ArtifactNotFoundLocally origin [])) + out = formatArtifactChecks False [missing] + out `shouldSatisfy` T.isInfixOf "Remote producer cache: 1 not cached locally (optional)" + out `shouldSatisfy` T.isInfixOf "Sync needs no producers; update fetches its remote candidates." + out `shouldNotSatisfy` T.isInfixOf "Artifacts that differ" + out `shouldNotSatisfy` T.isInfixOf "not installed" + let stale = ArtifactCheck (ModuleName "other") origin (ArtifactStale "2.0.0" "1.0.0") + mixed = formatArtifactChecks False [missing, stale] + mixed `shouldSatisfy` T.isInfixOf "other: this project expects 2.0.0" + mixed `shouldSatisfy` T.isInfixOf "Remote producer cache: 1" + + it "keeps missing project-owned and machine-local producers visible as problems" $ do + let projectOrigin = ProjectOrigin "modules/demo" + localOrigin = RemoteOrigin "/Users/alice/demo" "local" Nothing + checks = + [ ArtifactCheck (ModuleName "demo") projectOrigin (ArtifactUnresolvable (ProjectArtifactMissing projectOrigin "/project/modules/demo")), + ArtifactCheck (ModuleName "local") localOrigin (ArtifactUnresolvable (ArtifactNotFoundLocally localOrigin [])) + ] + out = formatArtifactChecks False checks + out `shouldSatisfy` T.isInfixOf "Artifacts that differ" + out `shouldSatisfy` T.isInfixOf "demo:" + out `shouldSatisfy` T.isInfixOf "seihou manifest repair-origins" + out `shouldNotSatisfy` T.isInfixOf "Remote producer cache" diff --git a/test/Seihou/CLI/UpdateFixture.hs b/test/Seihou/CLI/UpdateFixture.hs --- a/test/Seihou/CLI/UpdateFixture.hs +++ b/test/Seihou/CLI/UpdateFixture.hs @@ -54,6 +54,7 @@ reconciliation, checkoutPlan = CheckoutPlan [], checkoutOutputs = Map.empty, + checkoutAdoptions = Map.empty, commandPlan = CommandPlan [], candidateArtifacts = [], warnings = [], diff --git a/test/Seihou/CLI/UpdateSpec.hs b/test/Seihou/CLI/UpdateSpec.hs --- a/test/Seihou/CLI/UpdateSpec.hs +++ b/test/Seihou/CLI/UpdateSpec.hs @@ -403,6 +403,26 @@ (plan ^. #versionChanges) `shouldSatisfy` any (^. #sameVersionContentChanged) (plan ^. #warnings) `shouldContain` [SameVersionContentChanged "demo"] + it "does not invent same-version content changes when the producer cache is empty" $ + withSystemTempDirectory "seihou-update-empty-cache" $ \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=Test", "-c", "user.email=test@example.invalid", "commit", "-qm", "test: same-version candidate"] + withSavedEnv "XDG_CONFIG_HOME" (Just (root "empty-config")) $ + withCurrentDirectory (fixture ^. #projectRoot) $ do + withProjectUpdate (updateRequest False) $ \case + Left err -> expectationFailure (show err) + Right plan -> do + (plan ^. #warnings) `shouldNotContain` [SameVersionContentChanged "demo"] + (plan ^. #versionChanges) `shouldNotSatisfy` any (^. #sameVersionContentChanged) + isUpdateNoOp plan `shouldBe` False + applied <- applyProjectUpdate plan + applied `shouldSatisfy` \case Right {} -> True; _ -> False + TIO.readFile (fixture ^. #projectFile) `shouldReturn` "hello accepted\nkeep\nv2\n" + it "re-expands a candidate recipe and removes dependencies dropped by it" $ withSystemTempDirectory "seihou-update-recipe" $ \root -> do fixture <- prepareRecipeUpdateFixture root @@ -1242,6 +1262,7 @@ plannedApplications = plan ^. #plannedApplications, checkoutPlan = plan ^. #checkoutPlan, checkoutOutputs = plan ^. #checkoutOutputs, + checkoutAdoptions = plan ^. #checkoutAdoptions, manifestPreparation = plan ^. #manifestPreparation } where