seihou-cli 0.8.0.0 → 0.9.0.0
raw patch · 22 files changed
+831/−92 lines, 22 filesdep ~baikaidep ~baikai-claudedep ~baikai-kit
Dependency ranges changed: baikai, baikai-claude, baikai-kit, baikai-openai, effectful-core, seihou-core
Files
- help/update.md +20/−3
- seihou-cli.cabal +15/−15
- src-exe/Seihou/CLI/AgentLaunchExec.hs +15/−6
- src-exe/Seihou/CLI/AgentRun.hs +2/−1
- src-exe/Seihou/CLI/Commands.hs +25/−4
- src-exe/Seihou/CLI/Kit.hs +4/−3
- src-exe/Seihou/CLI/Run.hs +2/−1
- src-exe/Seihou/CLI/Status.hs +5/−2
- src-exe/Seihou/CLI/Update.hs +2/−1
- src/Seihou/CLI/StatusRender.hs +79/−16
- src/Seihou/CLI/Update.hs +16/−4
- src/Seihou/CLI/Update/Render.hs +17/−3
- src/Seihou/CLI/Update/Selection.hs +74/−7
- src/Seihou/CLI/Update/Types.hs +9/−1
- test/Seihou/CLI/AgentCompletionSpec.hs +5/−5
- test/Seihou/CLI/AgentTraceSpec.hs +15/−0
- test/Seihou/CLI/MigrateSpec.hs +2/−2
- test/Seihou/CLI/StatusSpec.hs +60/−1
- test/Seihou/CLI/UpdateE2ESpec.hs +111/−1
- test/Seihou/CLI/UpdateFixture.hs +20/−3
- test/Seihou/CLI/UpdateRenderSpec.hs +23/−2
- test/Seihou/CLI/UpdateSpec.hs +310/−11
help/update.md view
@@ -32,9 +32,26 @@ recorded application. Repeat TARGET to select several applications. With no target, every recorded application is selected. - A targeted update stops if an unselected application also owns a path the- selected applications would change. Name every required owner or run the- no-target form; Seihou will not guess how to reconstruct an omitted layer.+ When a path the selected applications would change is also owned by an+ unselected one, Seihou asks whether every owner reaches that path through an+ additive, non-overlapping patch. `append-line-if-absent` and+ `append-section` occupy disjoint slices of a file, so replaying one owner+ leaves the others' lines untouched and the update proceeds -- the ordinary+ case for `.gitignore`.++ Otherwise the update stops, because regenerating the file for one owner+ would discard another's content. That covers any path an owner writes+ wholesale, and the position-dependent `append-file` / `prepend-file`+ patches. A manifest written before Seihou recorded this distinction has no+ answer and is treated conservatively. One no-target update records it: a+ missing answer counts as pending work even when nothing else has changed,+ and writing it down touches no project file.++ When the refusal is genuine, name every required owner, run the no-target+ form, or pass `--include-shared-owners` to expand the selection to exactly+ the owners required. Each added application is reported. Seihou will not+ guess how to reconstruct an omitted layer, and never broadens a named+ selection without being asked. SAVED INPUTS
seihou-cli.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.0 name: seihou-cli-version: 0.8.0.0+version: 0.9.0.0 synopsis: CLI for Seihou project scaffolding description: Command-line interface for Seihou, a composable project scaffolding@@ -113,20 +113,20 @@ aeson >=2.1 && <3, aeson-pretty >=0.8 && <1, ansi-terminal >=1.1 && <2,- baikai ^>=0.4.1.0,- baikai-claude ^>=0.4.0.0,- baikai-openai ^>=0.4.0.0,+ baikai ^>=0.7.0.0,+ baikai-claude ^>=0.7.0.0,+ baikai-openai ^>=0.7.0.0, base >=4.18 && <5, bytestring >=0.11 && <1, containers >=0.6 && <1, directory >=1.3 && <2,- effectful-core >=2.4 && <3,+ effectful-core >=2.7.1.1 && <3, file-embed >=0.0.15 && <1, filepath >=1.4 && <2, generic-lens >=2.2 && <3, lens >=5.2 && <6, process >=1.6 && <2,- seihou-core ^>=0.8.0.0,+ seihou-core ^>=0.9.0.0, streamly-core >=0.3 && <0.5, temporary >=1.3 && <2, text >=2.0 && <3,@@ -194,15 +194,15 @@ aeson >=2.1 && <3, aeson-pretty >=0.8 && <1, ansi-terminal >=1.1 && <2,- baikai ^>=0.4.1.0,- baikai-claude ^>=0.4.0.0,- baikai-kit ^>=0.1.0.2,- baikai-openai ^>=0.4.0.0,+ baikai ^>=0.7.0.0,+ baikai-claude ^>=0.7.0.0,+ baikai-kit ^>=0.2.0.1,+ baikai-openai ^>=0.7.0.0, base >=4.18 && <5, bytestring >=0.11 && <1, containers >=0.6 && <1, directory >=1.3 && <2,- effectful-core >=2.4 && <3,+ effectful-core >=2.7.1.1 && <3, file-embed >=0.0.15 && <1, filepath >=1.4 && <2, generic-lens >=2.2 && <3,@@ -211,7 +211,7 @@ optparse-applicative >=0.18 && <1, process >=1.6 && <2, seihou-cli-internal,- seihou-core ^>=0.8.0.0,+ seihou-core ^>=0.9.0.0, temporary >=1.3 && <2, text >=2.0 && <3, time >=1.12 && <2,@@ -279,19 +279,19 @@ build-depends: aeson >=2.1 && <3,- baikai ^>=0.4.1.0,+ baikai ^>=0.7.0.0, base >=4.18 && <5, bytestring >=0.11 && <1, containers >=0.6 && <1, directory >=1.3 && <2,- effectful-core >=2.4 && <3,+ effectful-core >=2.7.1.1 && <3, filepath >=1.4 && <2, generic-lens >=2.2 && <3, hspec >=2.11 && <3, lens >=5.2 && <6, process >=1.6 && <2, seihou-cli-internal,- seihou-core ^>=0.8.0.0,+ seihou-core ^>=0.9.0.0, streamly-core >=0.3 && <0.5, tasty >=1.4 && <2, tasty-hspec >=1.2 && <2,
src-exe/Seihou/CLI/AgentLaunchExec.hs view
@@ -5,6 +5,7 @@ ) where +import Baikai.Agent (AgentRenderError, renderAgentRenderError) import Baikai.Interactive ( CodexApprovalPolicy (CodexApprovalOnRequest), CodexSandboxMode (CodexWorkspaceWrite),@@ -71,8 +72,8 @@ exitFailure Just _ -> do cwd <- getCurrentDirectory- InteractiveLaunchResult {exitCode} <-- launchClaudeInteractive+ launchExitCode+ =<< launchClaudeInteractive defaultClaudeInteractiveConfig -- InteractiveLaunchRequest comes from baikai and has no Generic instance, -- so these fields have no labels. Record update syntax is the only option.@@ -84,7 +85,6 @@ extraDirs = addDirs, safety = ClaudeAllowedTools (map T.pack tools) }- pure exitCode launchCodex :: [FilePath] -> Maybe Text -> Maybe ThinkingLevel -> Text -> Maybe Text -> IO ExitCode launchCodex addDirs model effortLevel systemPrompt initialPrompt = do@@ -96,8 +96,8 @@ exitFailure Just _ -> do cwd <- getCurrentDirectory- InteractiveLaunchResult {exitCode} <-- launchCodexInteractive+ launchExitCode+ =<< launchCodexInteractive defaultCodexInteractiveConfig -- InteractiveLaunchRequest comes from baikai and has no Generic instance, -- so these fields have no labels. Record update syntax is the only option.@@ -109,7 +109,16 @@ extraDirs = addDirs, safety = CodexSandbox CodexWorkspaceWrite CodexApprovalOnRequest }- pure exitCode++-- | The launched session's exit code. A 'Left' means baikai refused to render+-- the launch (the provider cannot honor the requested safety policy), so no+-- process ran.+launchExitCode :: Either AgentRenderError InteractiveLaunchResult -> IO ExitCode+launchExitCode = \case+ Right InteractiveLaunchResult {exitCode} -> pure exitCode+ Left err -> do+ TIO.putStrLn ("Error: " <> renderAgentRenderError err)+ exitFailure promptOrEmpty :: Maybe Text -> Text promptOrEmpty = maybe "" id
src-exe/Seihou/CLI/AgentRun.hs view
@@ -463,7 +463,8 @@ strategy = Template, generatedAt = now, baseline = Nothing,- applicationIds = mempty+ applicationIds = mempty,+ additiveOnly = False } ) | (c, KeepCurrent) <- conflictResolved
src-exe/Seihou/CLI/Commands.hs view
@@ -184,7 +184,12 @@ -- itself records — so the only downgrade it can produce is an -- upstream that moved backwards. This flag is the escape hatch for -- pinning to such a version deliberately.- allowDowngrade :: !Bool+ allowDowngrade :: !Bool,+ -- | When 'True', a named selection is expanded to the applications the+ -- shared-path ownership closure still requires, reporting each one that+ -- was added. Without it a partial selection is refused rather than+ -- silently broadened.+ includeSharedOwners :: !Bool } deriving stock (Eq, Show, Generic) @@ -298,7 +303,10 @@ deriving stock (Eq, Show, Generic) data StatusOpts = StatusOpts- { statusCheckUpdates :: !Bool+ { statusCheckUpdates :: !Bool,+ -- | Print the blueprint's stored prompt in full instead of the bounded+ -- one-line slice the summary shows by default.+ statusFullPrompt :: !Bool } deriving stock (Eq, Show, Generic) @@ -705,6 +713,10 @@ pretty ("versions available from their source repository. This requires network" :: String), pretty ("access and will clone each source repo shallowly." :: String), line,+ pretty ("The blueprint's stored prompt is collapsed to one line and truncated" :: String),+ pretty ("so it cannot dominate the summary. Use --full-prompt to print it in" :: String),+ pretty ("full; .seihou/manifest.json always holds the whole of it." :: String),+ line, pretty ("When an applied module's installed copy has advanced past the manifest's" :: String), pretty ("recorded version, status reports the pending migration count under that" :: String), pretty ("module's line. Recorded applications recommend 'seihou update <target>';" :: String),@@ -722,6 +734,10 @@ <> short 'u' <> help "Check installed modules for available updates (requires network)" )+ <*> switch+ ( long "full-prompt"+ <> help "Print the blueprint's stored prompt in full instead of truncating it"+ ) diffInfo :: ParserInfo Command diffInfo =@@ -903,8 +919,12 @@ ( long "allow-downgrade" <> help "Accept a candidate artifact older than the version recorded in .seihou/manifest.json" )+ <*> switch+ ( long "include-shared-owners"+ <> help "Also update applications that co-own a selected path"+ ) where- makeUpdateOpts targets vars dryRun json reconfigure force (runAll, noCommands) commit commitMessage allowDowngrade =+ makeUpdateOpts targets vars dryRun json reconfigure force (runAll, noCommands) commit commitMessage allowDowngrade includeSharedOwners = UpdateOpts { targets = targets, vars = vars,@@ -916,7 +936,8 @@ noCommands = noCommands, commit = commit, commitMessage = commitMessage,- allowDowngrade = allowDowngrade+ allowDowngrade = allowDowngrade,+ includeSharedOwners = includeSharedOwners } updateCommandFlags = flag' (True, False) (long "run-all-commands" <> help "Run every generated command, including unchanged ones")
src-exe/Seihou/CLI/Kit.hs view
@@ -9,13 +9,14 @@ import Baikai.Interactive (InteractiveProvider (..)) import Baikai.Kit.Command qualified as Kit import Baikai.Kit.Config (KitConfig (..), KitScope (..))+import Baikai.Kit.Install (OverwritePolicy) import Options.Applicative (Parser) import Seihou.Prelude data KitCommand = KitList | KitInstall !Text !KitScope- | KitUpdate !(Maybe Text)+ | KitUpdate !(Maybe Text) !OverwritePolicy | KitUninstall !Text !KitScope | KitStatus deriving stock (Eq, Show)@@ -38,7 +39,7 @@ fromShared = \case Kit.KitList -> KitList Kit.KitInstall name scope -> KitInstall name scope- Kit.KitUpdate name -> KitUpdate name+ Kit.KitUpdate name policy -> KitUpdate name policy Kit.KitUninstall name scope -> KitUninstall name scope Kit.KitStatus -> KitStatus @@ -46,6 +47,6 @@ toShared = \case KitList -> Kit.KitList KitInstall name scope -> Kit.KitInstall name scope- KitUpdate name -> Kit.KitUpdate name+ KitUpdate name policy -> Kit.KitUpdate name policy KitUninstall name scope -> Kit.KitUninstall name scope KitStatus -> Kit.KitStatus
src-exe/Seihou/CLI/Run.hs view
@@ -395,7 +395,8 @@ strategy = Template, generatedAt = now, baseline = Nothing,- applicationIds = mempty+ applicationIds = mempty,+ additiveOnly = False } ) | (c, KeepCurrent) <- conflictResolved
src-exe/Seihou/CLI/Status.hs view
@@ -12,7 +12,7 @@ import Seihou.CLI.Outdated (checkInstalledModulesForUpdates) import Seihou.CLI.PendingMigrations (detectPendingMigrations) import Seihou.CLI.Shared (logIO)-import Seihou.CLI.StatusRender (formatArtifactChecks, formatStatus)+import Seihou.CLI.StatusRender (PromptDisplay (..), formatArtifactChecks, formatStatusWith) import Seihou.CLI.Style (useColor) import Seihou.CLI.VersionCompare (OutdatedEntry (..)) import Seihou.Core.Module (defaultSearchPaths, discoverAllModules)@@ -55,7 +55,10 @@ then fetchUpdateEntries else pure Nothing pendings <- detectPendingMigrations manifest Nothing- TIO.putStr (formatStatus colorEnabled manifest tracked mEntries pendings)+ let promptDisplay+ | opts ^. #statusFullPrompt = PromptFull+ | otherwise = PromptTruncated+ TIO.putStr (formatStatusWith promptDisplay colorEnabled manifest tracked mEntries pendings) -- Report, never fail: a stale or mismatched module makes 'seihou run' -- refuse, and this is where a developer finds out before that happens. -- Any IO failure while checking is swallowed for the same reason.
src-exe/Seihou/CLI/Update.hs view
@@ -70,7 +70,8 @@ then RunAllCommands else if opts ^. #noCommands then DisableCommands else RunChangedCommands, dryRun = opts ^. #dryRun,- allowDowngrade = opts ^. #allowDowngrade+ allowDowngrade = opts ^. #allowDowngrade,+ includeSharedOwners = opts ^. #includeSharedOwners } handlePlanned :: Bool -> UpdateOpts -> Either Service.UpdateError Service.UpdatePlan -> IO ()
src/Seihou/CLI/StatusRender.hs view
@@ -1,8 +1,10 @@ module Seihou.CLI.StatusRender ( formatStatus,+ formatStatusWith, formatArtifactChecks, formatBlueprintMigrations, ModuleAdvice (..),+ PromptDisplay (..), ) where @@ -51,7 +53,17 @@ | AdviceProjectUpdateAll deriving stock (Eq, Show) --- | Render the full @seihou status@ output as a single 'Text' value.+-- | Whether the @Prompt:@ line shows a bounded one-line slice of the blueprint's+-- stored prompt or the whole of it. @seihou status@ renders 'PromptTruncated';+-- @seihou status --full-prompt@ renders 'PromptFull'. Either way the manifest+-- keeps the whole prompt.+data PromptDisplay+ = PromptTruncated+ | PromptFull+ deriving stock (Eq, Show)++-- | Render the full @seihou status@ output as a single 'Text' value, with the+-- default, bounded blueprint prompt. -- -- @color@ controls ANSI styling; pass 'False' for plain text (used by -- the test suite).@@ -62,11 +74,23 @@ Maybe [OutdatedEntry] -> [(ModuleName, MigrationPlan)] -> Text-formatStatus color manifest tracked mEntries pendings =+formatStatus = formatStatusWith PromptTruncated++-- | As 'formatStatus', but with explicit control over how much of the+-- blueprint's stored prompt the @Prompt:@ line shows.+formatStatusWith ::+ PromptDisplay ->+ Bool ->+ Manifest ->+ [TrackedFile] ->+ Maybe [OutdatedEntry] ->+ [(ModuleName, MigrationPlan)] ->+ Text+formatStatusWith display color manifest tracked mEntries pendings = T.unlines $ ["Seihou Status:", ""] ++ recipeSection manifest- ++ blueprintSection manifest+ ++ blueprintSection display manifest ++ formatBlueprintMigrations (manifest ^. #blueprintMigrations) ++ appliedSection color manifest mEntries pendings ++ trackedSection color tracked@@ -101,9 +125,12 @@ -- Header line: name, optional @vX.Y.Z@, and the applied timestamp. -- Baseline line: comma-separated baseline module names, or one of the -- two empty-baseline placeholders.--- Prompt line: present only when the user passed a positional prompt.-blueprintSection :: Manifest -> [Text]-blueprintSection manifest = case manifest ^. #blueprint of+-- Prompt line: present only when the user passed a positional prompt. The+-- stored prompt is collapsed to one line and bounded at 'promptWidth' so a+-- multi-paragraph instruction cannot push the rest of the summary off the+-- screen; @.seihou/manifest.json@ keeps the whole of it.+blueprintSection :: PromptDisplay -> Manifest -> [Text]+blueprintSection display manifest = case manifest ^. #blueprint of Nothing -> [] Just ab -> let header =@@ -116,7 +143,7 @@ baselineLine = " Baseline: " <> renderBaseline ab promptLines = case ab ^. #userPrompt of Nothing -> []- Just p -> [" Prompt: \"" <> p <> "\""]+ Just p -> renderPrompt display p in [header, baselineLine] ++ promptLines ++ [""] -- | Render durable agent-guided migration receipts. An empty ledger adds no@@ -149,15 +176,8 @@ -- `seihou status` is a scannable summary, so a long reason is truncated -- rather than wrapped; the manifest keeps the whole of it. renderReason MigrationApplied = ""- renderReason (MigrationNotApplicable reason) = " -- " <> truncateReason reason-- truncateReason reason- | T.length oneLine <= reasonWidth = oneLine- | otherwise = T.take (reasonWidth - 1) oneLine <> "…"- where- oneLine = T.unwords (T.words reason)-- reasonWidth = 60+ renderReason (MigrationNotApplicable reason) =+ " -- " <> truncateForSummary reasonWidth reason -- | Render the baseline body for the blueprint section. Three cases: -- @--no-baseline@ was passed, the blueprint declared no baseline at@@ -426,6 +446,49 @@ statusColor TfsUnchanged = dim statusColor TfsModified = yellow statusColor TfsDeleted = red++-- | The @Prompt:@ line(s) for a stored prompt. The truncated form is one quoted+-- line; the full form is a bare header followed by the prompt's own lines, each+-- indented under it. The full form is deliberately not quoted: a prompt may+-- contain a @"@ and nothing escapes it, so quotes would not tell a reader where+-- the value ends, while the indentation does.+renderPrompt :: PromptDisplay -> Text -> [Text]+renderPrompt PromptTruncated p =+ [" Prompt: \"" <> truncateForSummary promptWidth p <> "\""]+renderPrompt PromptFull p =+ " Prompt:" : map (" " <>) (T.lines p)++-- | Collapse every run of internal whitespace to a single space and cut the+-- result to @width@ characters, marking a cut with a trailing ellipsis.+--+-- @seihou status@ is a scannable summary, and the manifest is the record (see+-- docs/adr/0013-status-is-a-bounded-summary-the-manifest-is-the-record.md). Two+-- values the summary renders are unbounded free text kept in full in+-- @.seihou/manifest.json@ — a migration receipt's not-applicable reason and a+-- blueprint's stored user prompt — and this is the single place that decides how+-- much of such a value the summary shows, so the two cannot drift apart.+--+-- The result is never longer than @width@: a cut keeps at most @width - 1@+-- characters and spends the last on the ellipsis. A cut that lands mid-gap has+-- its trailing space stripped, so the output reads @\"... already…\"@ rather than+-- @\"... already …\"@.+truncateForSummary :: Int -> Text -> Text+truncateForSummary width text+ | T.length oneLine <= width = oneLine+ | otherwise = T.stripEnd (T.take (width - 1) oneLine) <> "…"+ where+ oneLine = T.unwords (T.words text)++-- | How much of a blueprint migration's not-applicable reason the summary+-- shows. The reason is a clause appended to an already-long receipt line.+reasonWidth :: Int+reasonWidth = 60++-- | How much of a blueprint's stored user prompt the summary shows. Wider than+-- 'reasonWidth' because a prompt is a whole instruction on a line of its own+-- rather than a trailing clause.+promptWidth :: Int+promptWidth = 72 applyColor :: Bool -> (Text -> Text) -> Text -> Text applyColor True f = f
src/Seihou/CLI/Update.hs view
@@ -428,10 +428,14 @@ Manifest -> UTCTime -> IO (Either UpdateError ([AppliedComposition], [UpdateWarning]))-selectAndSeedLegacy request projectRoot manifest now = case selectApplications (request ^. #selection) manifest of+selectAndSeedLegacy request projectRoot manifest now = case selectApplications policy (request ^. #selection) manifest of Left err -> pure (Left err)- Right (RecordedSelection selected) -> pure (Right (selected, []))- Right (LegacySelection name) -> seedLegacyApplication request projectRoot manifest now name+ Right (RecordedSelection selected, warnings) -> pure (Right (selected, warnings))+ Right (LegacySelection name, _) -> seedLegacyApplication request projectRoot manifest now name+ where+ policy+ | request ^. #includeSharedOwners = IncludeSharedOwners+ | otherwise = RequireNamedOwners seedLegacyApplication :: UpdateRequest -> FilePath -> Manifest -> UTCTime -> Text -> IO (Either UpdateError ([AppliedComposition], [UpdateWarning]))@@ -1125,7 +1129,15 @@ && all unchangedFile (Map.elems (plan ^. #reconciliation . #files)) && and (zipWith sameApplication (mapMaybe (^. #previous) (plan ^. #plannedApplications)) (plan ^. #applications)) where- unchangedFile FileUnchanged {} = True+ -- A file whose content is unchanged can still carry a manifest record+ -- that is out of date. @additiveOnly@ is the case that matters: a project+ -- whose manifest predates the field has no answer for any path, and+ -- treating that as a no-op would mean the answer is never written, so the+ -- shared-path exemption could never take effect on an existing project.+ -- Recording a fact about applied state is a change to applied state+ -- (ADR 0004), so such a plan is not a deliberate no-op (ADR 0007).+ unchangedFile (FileUnchanged desired _ _ prior) =+ maybe True (\record -> record ^. #additiveOnly == desired ^. #additiveOnly) prior unchangedFile _ = False -- Compare only what the manifest actually records. Anything derived from -- where an artifact happens to sit on this machine would differ between a
src/Seihou/CLI/Update/Render.hs view
@@ -323,7 +323,12 @@ fingerprintText (CommandFingerprint (SHA256 value)) = value warningText :: UpdateWarning -> Text-warningText = T.pack . show+warningText (SelectionExpandedForSharedPath path owner) =+ "also updating "+ <> (owner ^. #unApplicationId)+ <> " because it co-owns "+ <> T.pack path+warningText other = T.pack (show other) errorCode :: UpdateError -> Text errorCode UpdateManifestMissing {} = "manifest_missing"@@ -370,7 +375,11 @@ <> T.pack path <> " is also owned by application(s) " <> T.intercalate ", " (map (^. #unApplicationId) (Set.toAscList required))- <> ". Select every owner or run seihou update with no targets. Selected: "+ <> ", and it is not recorded as written only by additive patches"+ <> " -- either an owner writes the whole file, or the manifest predates that record,"+ <> " in which case one seihou update with no targets will record it."+ <> " Select every owner, pass --include-shared-owners, or run seihou update"+ <> " with no targets. Selected: " <> T.intercalate ", " (map (^. #unApplicationId) (Set.toAscList selected)) errorMessage (UpdateHasUnresolvedPaths paths) = "Resolve these paths before apply: " <> T.intercalate ", " (map T.pack (Set.toAscList paths))@@ -388,7 +397,12 @@ && (summarizeCommandPlan (plan ^. #commandPlan)) ^. #willRun == 0 && all isUnchanged (Map.elems (plan ^. #reconciliation . #files)) where- isUnchanged FileUnchanged {} = True+ -- Kept in step with 'Seihou.CLI.Update.isUpdateNoOp': a file whose bytes+ -- are unchanged still counts as a change when this plan would record a+ -- different @additiveOnly@ than the manifest holds, so @alreadyUpToDate@+ -- does not claim otherwise.+ isUnchanged (FileUnchanged desired _ _ prior) =+ maybe True (\record -> record ^. #additiveOnly == desired ^. #additiveOnly) prior isUnchanged _ = False count :: Int -> Text
src/Seihou/CLI/Update/Selection.hs view
@@ -1,5 +1,6 @@ module Seihou.CLI.Update.Selection ( SelectedApplications (..),+ SelectionPolicy (..), selectApplications, targetName, availableTargets,@@ -19,23 +20,46 @@ | LegacySelection Text deriving stock (Eq, Show) +-- | What to do when a named selection does not satisfy the ownership closure.+data SelectionPolicy+ = -- | Refuse, and tell the user which owners are missing. The default: a+ -- named selection is never broadened without being asked.+ RequireNamedOwners+ | -- | Add the applications the closure requires, reporting each one. Chosen+ -- by @seihou update <target> --include-shared-owners@.+ IncludeSharedOwners+ deriving stock (Eq, Show)+ -- | Select applications in manifest order. Bare module names select every -- recorded application containing that module instance; target names take -- precedence for each requested name.-selectApplications :: UpdateSelection -> Manifest -> Either UpdateError SelectedApplications-selectApplications selection manifest = case selection of+--+-- Returns the warnings the selection produced, which under+-- 'IncludeSharedOwners' name every application the expansion added and the+-- path it was added for.+selectApplications ::+ SelectionPolicy ->+ UpdateSelection ->+ Manifest ->+ Either UpdateError (SelectedApplications, [UpdateWarning])+selectApplications policy selection manifest = case selection of AllRecordedApplications | null (manifest ^. #applications) -> Left NoRecordedApplications- | otherwise -> Right (RecordedSelection (manifest ^. #applications))+ | otherwise -> Right (RecordedSelection (manifest ^. #applications), []) NamedUpdateTargets names+ -- A manifest with no recorded applications has no ownership to close+ -- over, so the policy cannot apply. | null (manifest ^. #applications) -> case nubOrd names of- [name] -> Right (LegacySelection name)+ [name] -> Right (LegacySelection name, []) _ -> Left LegacyUpdateRequiresOneTarget | otherwise -> do- selectedIds <- foldM selectName Set.empty (nubOrd names)- let selected = filter ((`Set.member` selectedIds) . (^. #applicationId)) (manifest ^. #applications)+ namedIds <- foldM selectName Set.empty (nubOrd names)+ let (selectedIds, warnings) = case policy of+ RequireNamedOwners -> (namedIds, [])+ IncludeSharedOwners -> expandToSharedOwners manifest namedIds+ selected = filter ((`Set.member` selectedIds) . (^. #applicationId)) (manifest ^. #applications) ensureOwnershipClosure manifest selectedIds- Right (RecordedSelection selected)+ Right (RecordedSelection selected, warnings) where selectName selected name = let exact = filter ((== name) . targetName) (manifest ^. #applications)@@ -47,10 +71,53 @@ then Left (UpdateTargetNotFound name (availableTargets manifest)) else Right (foldl' (flip (Set.insert . (^. #applicationId))) selected matches) +-- | Grow the selection until it satisfies the ownership closure.+--+-- For every managed path that is /not/ additive-only and whose owners+-- intersect the selection, add all of that path's owners. This has to iterate+-- to a fixed point rather than run once: an application pulled in through one+-- path may co-own a different path with a third application, which then has+-- to come along too.+--+-- Additive-only paths are skipped, because they no longer require the+-- closure; expanding for them would update applications the user did not ask+-- for and did not need.+expandToSharedOwners :: Manifest -> Set ApplicationId -> (Set ApplicationId, [UpdateWarning])+expandToSharedOwners manifest = go []+ where+ go warnings selected =+ case [ (path, owner)+ | (path, record) <- Map.toAscList (manifest ^. #files),+ not (record ^. #additiveOnly),+ not (Set.null (Set.intersection selected (record ^. #applicationIds))),+ owner <- Set.toAscList ((record ^. #applicationIds) Set.\\ selected)+ ] of+ [] -> (selected, reverse warnings)+ additions ->+ go+ ([SelectionExpandedForSharedPath path owner | (path, owner) <- additions] <> warnings)+ (Set.union selected (Set.fromList (map snd additions)))++-- | For every managed path a selected application owns, require that every+-- other owner is selected too — because regenerating a file normally means+-- rewriting all of it, which would discard an unselected owner's content.+--+-- A path whose manifest record says @additiveOnly@ is exempt: every owner+-- reaches it through an additive, non-overlapping patch, so reconciling one+-- of them provably cannot disturb another. This is the preflight, and it runs+-- before any candidate artifact is fetched, so the manifest is the only+-- evidence available here; 'Seihou.Engine.Reconcile.validateOwner' checks the+-- candidate's own operations later, once they are known.+--+-- A @False@ cannot distinguish "an owner writes the whole file" from "this+-- manifest predates the field", so the refusal message names both.+--+-- See docs/adr/0012-an-additive-co-write-is-not-a-shared-path-conflict.md. ensureOwnershipClosure :: Manifest -> Set ApplicationId -> Either UpdateError () ensureOwnershipClosure manifest selected = case [ (path, selectedOwners, missingOwners) | (path, record) <- Map.toAscList (manifest ^. #files),+ not (record ^. #additiveOnly), let selectedOwners = Set.intersection selected (record ^. #applicationIds), let missingOwners = (record ^. #applicationIds) Set.\\ selected, not (Set.null selectedOwners),
src/Seihou/CLI/Update/Types.hs view
@@ -60,7 +60,12 @@ -- than the version @.seihou\/manifest.json@ records, instead of -- failing with 'CandidateDowngrade'. The default is 'False', so an -- update never moves a project backwards by accident.- allowDowngrade :: !Bool+ allowDowngrade :: !Bool,+ -- | When 'True', expand a named selection to the applications the+ -- ownership closure still requires instead of refusing, reporting each+ -- one added. The default is 'False': a named selection is never+ -- broadened without being asked.+ includeSharedOwners :: !Bool } deriving stock (Eq, Generic, Show) @@ -153,6 +158,9 @@ | ArbitraryCommandSideEffectsMayRemain | BaselinePruneFailed Text | RecoveryCleanupDeferred Text+ | -- | @--include-shared-owners@ added this application to the selection+ -- because it co-owns the named path with something the user asked for.+ SelectionExpandedForSharedPath FilePath ApplicationId deriving stock (Eq, Show) data UpdatePlan = UpdatePlan
test/Seihou/CLI/AgentCompletionSpec.hs view
@@ -227,11 +227,11 @@ where registerStub = Baikai.registerApiProvider- Baikai.ApiProvider- { Baikai.apiTag = Baikai.AnthropicMessages,- Baikai.complete = \m _ _ -> respond m,- Baikai.stream = Baikai.liftCompleteToStream (\m _ _ -> respond m)- }+ ( Baikai.apiProviderWith+ Baikai.AnthropicMessages+ (Baikai.liftCompleteToStream (\m _ _ -> respond m))+ (\m _ _ -> respond m)+ ) request = buildAgentCompletionRequestWith (maybe silent id sink)
test/Seihou/CLI/AgentTraceSpec.hs view
@@ -155,6 +155,12 @@ latencyMs = 7913, inputTokens = Just 4211, outputTokens = Just 880,+ cachedInputTokens = Nothing,+ cacheWriteTokens = Nothing,+ reasoningTokens = Nothing,+ totalTokens = Nothing,+ costBasis = Nothing,+ usageAvailability = Nothing, usd = Just 0.0264 } @@ -166,5 +172,14 @@ provider = "anthropic", model = "claude-sonnet-4-6", latencyMs = 120,+ inputTokens = Nothing,+ outputTokens = Nothing,+ cachedInputTokens = Nothing,+ cacheWriteTokens = Nothing,+ reasoningTokens = Nothing,+ totalTokens = Nothing,+ costBasis = Nothing,+ usageAvailability = Nothing,+ usd = Nothing, errorMessage = "invalid x-api-key" }
test/Seihou/CLI/MigrateSpec.hs view
@@ -117,7 +117,7 @@ mkManifest version installedDir entries = (emptyManifest fixedTime) & #modules .~ [AppliedModule {name = modName, parentVars = emptyParentVars, origin = LocalOrigin (modName ^. #unModuleName), moduleVersion = Just version, appliedAt = fixedTime, removal = Nothing}]- & #files .~ Map.fromList [(path, FileRecord {hash = hashContent content, moduleName = modName, strategy = Template, generatedAt = fixedTime, baseline = Nothing, applicationIds = mempty}) | (path, content) <- entries]+ & #files .~ Map.fromList [(path, FileRecord {hash = hashContent content, moduleName = modName, strategy = Template, generatedAt = fixedTime, baseline = Nothing, applicationIds = mempty, additiveOnly = False}) | (path, content) <- entries] defaultOpts :: MigrateOpts defaultOpts =@@ -238,7 +238,7 @@ mkManifestAt fix version entries = (emptyManifest fixedTime) & #modules .~ [AppliedModule {name = ModuleName (fix ^. #modName), parentVars = emptyParentVars, origin = LocalOrigin (fix ^. #modName), moduleVersion = Just version, appliedAt = fixedTime, removal = Nothing}]- & #files .~ Map.fromList [(path, FileRecord {hash = hashContent content, moduleName = ModuleName (fix ^. #modName), strategy = Template, generatedAt = fixedTime, baseline = Nothing, applicationIds = mempty}) | (path, content) <- entries]+ & #files .~ Map.fromList [(path, FileRecord {hash = hashContent content, moduleName = ModuleName (fix ^. #modName), strategy = Template, generatedAt = fixedTime, baseline = Nothing, applicationIds = mempty, additiveOnly = False}) | (path, content) <- entries] withSavedEnv :: String -> Maybe String -> IO () -> IO () withSavedEnv key newVal action = do
test/Seihou/CLI/StatusSpec.hs view
@@ -9,7 +9,12 @@ ( ArtifactCheck (..), ArtifactVerdict (..), )-import Seihou.CLI.StatusRender (formatArtifactChecks, formatStatus)+import Seihou.CLI.StatusRender+ ( PromptDisplay (..),+ formatArtifactChecks,+ formatStatus,+ formatStatusWith,+ ) import Seihou.CLI.VersionCompare ( OutdatedEntry (..), OutdatedStatus (..),@@ -219,6 +224,60 @@ out = formatStatus False manifest [] Nothing [] out `shouldSatisfy` T.isInfixOf "Blueprint: pure-prompt (applied" out `shouldSatisfy` T.isInfixOf " Baseline: (none declared)"++ -- IR-7: a multi-paragraph prompt used to occupy a dozen lines of the+ -- summary. The manifest still holds all of it.+ it "collapses and truncates a long multi-line prompt to a single bounded line" $ do+ let longPrompt =+ "Upgrade this repository to nix-haskell-flake 0.24.0.\n\n\+ \The flake already pins baikai 0.7, so do not re-pin it.\n\+ \Do not commit anything; leave the tree dirty for review."+ manifest =+ withManifestBlueprint+ (Just $ mkBlueprint "upgrade-flake" Nothing [] False (Just longPrompt))+ (mkManifest [])+ out = formatStatus False manifest [] Nothing []+ promptLines = [l | l <- T.lines out, " Prompt: " `T.isPrefixOf` l]+ promptLines+ `shouldBe` [" Prompt: \"Upgrade this repository to nix-haskell-flake 0.24.0. The flake already\x2026\""]+ out `shouldNotSatisfy` T.isInfixOf "leave the tree dirty"++ it "leaves a prompt shorter than the bound untouched and unmarked" $ do+ let manifest =+ withManifestBlueprint+ (Just $ mkBlueprint "short" Nothing [] False (Just "set this up for a payments microservice"))+ (mkManifest [])+ out = formatStatus False manifest [] Nothing []+ out `shouldSatisfy` T.isInfixOf " Prompt: \"set this up for a payments microservice\""+ out `shouldNotSatisfy` T.isInfixOf "\x2026"++ it "collapses internal whitespace in a short multi-line prompt without truncating" $ do+ let manifest =+ withManifestBlueprint+ (Just $ mkBlueprint "wrapped" Nothing [] False (Just "first line\n\n second line"))+ (mkManifest [])+ out = formatStatus False manifest [] Nothing []+ out `shouldSatisfy` T.isInfixOf " Prompt: \"first line second line\""++ it "prints the whole prompt, indented, under --full-prompt" $ do+ let longPrompt = "First paragraph.\nSecond paragraph that is quite long indeed."+ manifest =+ withManifestBlueprint+ (Just $ mkBlueprint "upgrade-flake" Nothing [] False (Just longPrompt))+ (mkManifest [])+ out = formatStatusWith PromptFull False manifest [] Nothing []+ out+ `shouldSatisfy` T.isInfixOf+ " Prompt:\n First paragraph.\n Second paragraph that is quite long indeed."+ out `shouldNotSatisfy` T.isInfixOf "\x2026"++ it "still omits the prompt entirely under --full-prompt when none was supplied" $ do+ let manifest =+ withManifestBlueprint+ (Just $ mkBlueprint "no-prompt" Nothing [] False Nothing)+ (mkManifest [])+ out = formatStatusWith PromptFull False manifest [] Nothing []+ out `shouldNotSatisfy` T.isInfixOf " Prompt:" describe "blueprint migration receipts" $ do it "omits the section for an empty ledger" $ do
test/Seihou/CLI/UpdateE2ESpec.hs view
@@ -6,7 +6,13 @@ import Data.Text qualified as T import Data.Text.IO qualified as TIO import Seihou.CLI.SeihouBinary (seihouBinary)-import Seihou.CLI.UpdateSpec (UpdateFixture (..), prepareUpdateFixture)+import Seihou.CLI.UpdateSpec+ ( CoOwnerWriteMode (..),+ SharedPathFixture (..),+ UpdateFixture (..),+ prepareSharedPathFixture,+ prepareUpdateFixture,+ ) import System.Directory (doesFileExist) import System.Environment (getEnvironment) import System.Exit (ExitCode (..))@@ -132,6 +138,104 @@ forceOut `shouldSatisfy` T.isInfixOf "\"outcome\":\"applied\"" TIO.readFile (fixture ^. #projectFile) `shouldReturn` "candidate accepted\nkeep\nv2\n" + it "updates one owner of an additive shared path and leaves the other's lines intact" $+ withSystemTempDirectory "seihou-update-shared-additive" $ \root -> do+ fixture <- prepareSharedPathFixture CoOwnerAppends root+ binary <- seihouBinary+ (exitCode, stdoutText, stderrText) <- runSeihouShared binary fixture ["update", "alpha", "--json"]+ case exitCode of+ ExitSuccess -> pure ()+ ExitFailure code ->+ expectationFailure+ ("update exited " <> show code <> "\nstdout:\n" <> T.unpack stdoutText <> "\nstderr:\n" <> T.unpack stderrText)+ stdoutText `shouldSatisfy` T.isInfixOf "\"outcome\":\"applied\""+ -- Replaying alpha's append on top of the recorded baseline adds its new+ -- line and leaves beta's /result exactly where it was.+ TIO.readFile (fixture ^. #gitignorePath)+ `shouldReturn` "/dist-newstyle\n/result\n/alpha-v2\n"+ manifestText <- TIO.readFile (fixture ^. #manifestPath)+ -- Both owners are still recorded: a partial update must not quietly+ -- drop the co-owner it did not touch.+ manifestText `shouldSatisfy` T.isInfixOf (fixture ^. #alphaApplicationId . #unApplicationId)+ manifestText `shouldSatisfy` T.isInfixOf (fixture ^. #betaApplicationId . #unApplicationId)+ manifestText `shouldSatisfy` T.isInfixOf "\"additiveOnly\":true"++ it "still refuses a partial selection when a co-owner writes the shared path wholesale" $+ withSystemTempDirectory "seihou-update-shared-wholefile" $ \root -> do+ fixture <- prepareSharedPathFixture CoOwnerWritesWholeFile root+ binary <- seihouBinary+ beforeGitignore <- TIO.readFile (fixture ^. #gitignorePath)+ beforeManifest <- LBS.readFile (fixture ^. #manifestPath)+ (exitCode, stdoutText, _) <- runSeihouShared binary fixture ["update", "alpha", "--json"]+ exitCode `shouldSatisfy` (/= ExitSuccess)+ stdoutText `shouldSatisfy` T.isInfixOf "shared_path_requires_applications"+ TIO.readFile (fixture ^. #gitignorePath) `shouldReturn` beforeGitignore+ LBS.readFile (fixture ^. #manifestPath) `shouldReturn` beforeManifest++ it "updates the co-owner too under --include-shared-owners" $+ withSystemTempDirectory "seihou-update-shared-include" $ \root -> do+ fixture <- prepareSharedPathFixture CoOwnerWritesWholeFile root+ binary <- seihouBinary+ (exitCode, stdoutText, stderrText) <-+ runSeihouShared binary fixture ["update", "alpha", "--include-shared-owners", "--json"]+ case exitCode of+ ExitSuccess -> pure ()+ ExitFailure code ->+ expectationFailure+ ("update exited " <> show code <> "\nstdout:\n" <> T.unpack stdoutText <> "\nstderr:\n" <> T.unpack stderrText)+ stdoutText `shouldSatisfy` T.isInfixOf "\"outcome\":\"applied\""+ -- The expansion is reported, never silent.+ stdoutText `shouldSatisfy` T.isInfixOf "also updating"+ stdoutText `shouldSatisfy` T.isInfixOf "because it co-owns .gitignore"+ stdoutText `shouldSatisfy` T.isInfixOf (fixture ^. #betaApplicationId . #unApplicationId)++ it "records a missing additiveOnly answer instead of reporting nothing to do" $+ withSystemTempDirectory "seihou-update-shared-unrecorded" $ \root -> do+ -- Every project in the wild has a manifest that predates the field. If+ -- an up-to-date project reported "already up to date" and wrote+ -- nothing, the answer would never be recorded and the exemption could+ -- never take effect on an existing project.+ fixture <- prepareSharedPathFixture CoOwnerAppendsUnrecorded root+ binary <- seihouBinary+ beforeGitignore <- TIO.readFile (fixture ^. #gitignorePath)++ -- The targeted update refuses first, as documented for a manifest with+ -- no recorded answer.+ (refusedExit, refusedOut, _) <- runSeihouShared binary fixture ["update", "alpha", "--json"]+ refusedExit `shouldSatisfy` (/= ExitSuccess)+ refusedOut `shouldSatisfy` T.isInfixOf "shared_path_requires_applications"+ refusedOut `shouldSatisfy` T.isInfixOf "manifest predates that record"++ -- Nothing about the sources changed, so the only pending work is the+ -- record itself -- which is still work, not a no-op.+ (exitCode, stdoutText, stderrText) <- runSeihouShared binary fixture ["update", "--json"]+ case exitCode of+ ExitSuccess -> pure ()+ ExitFailure code ->+ expectationFailure+ ("update exited " <> show code <> "\nstdout:\n" <> T.unpack stdoutText <> "\nstderr:\n" <> T.unpack stderrText)+ stdoutText `shouldSatisfy` T.isInfixOf "\"outcome\":\"applied\""+ manifestText <- TIO.readFile (fixture ^. #manifestPath)+ manifestText `shouldSatisfy` T.isInfixOf "\"additiveOnly\":true"+ -- Recording an answer must not touch a single byte of the project.+ TIO.readFile (fixture ^. #gitignorePath) `shouldReturn` beforeGitignore++ -- And now the targeted update the user wanted all along goes through.+ (afterExit, afterOut, afterErr) <- runSeihouShared binary fixture ["update", "alpha", "--json"]+ case afterExit of+ ExitSuccess -> pure ()+ ExitFailure code ->+ expectationFailure+ ("targeted update exited " <> show code <> "\nstdout:\n" <> T.unpack afterOut <> "\nstderr:\n" <> T.unpack afterErr)+ afterOut `shouldNotSatisfy` T.isInfixOf "shared_path_requires_applications"++ it "lists --include-shared-owners in update --help" $ do+ binary <- seihouBinary+ (exitCode, stdoutText, _) <- runProcessText binary ["update", "--help"] Nothing Nothing+ exitCode `shouldBe` ExitSuccess+ stdoutText `shouldSatisfy` T.isInfixOf "--include-shared-owners"+ stdoutText `shouldSatisfy` T.isInfixOf "co-own a selected path"+ it "exposes update and its options through the shared Bash, Zsh, and Fish completion protocol" $ do binary <- seihouBinary (topExit, topOutput, _) <- runProcessText binary ["--bash-completion-enriched", "--bash-completion-index", "0"] Nothing Nothing@@ -163,6 +267,12 @@ script `shouldSatisfy` T.isInfixOf "bash-completion" ) ["bash", "zsh", "fish"]++runSeihouShared :: FilePath -> SharedPathFixture -> [String] -> IO (ExitCode, T.Text, T.Text)+runSeihouShared binary fixture args = do+ inherited <- getEnvironment+ let environment = ("XDG_CONFIG_HOME", fixture ^. #xdgHome) : filter ((/= "XDG_CONFIG_HOME") . fst) inherited+ runProcessText binary args (Just (fixture ^. #projectRoot)) (Just environment) runSeihou :: FilePath -> UpdateFixture -> [String] -> IO (ExitCode, T.Text, T.Text) runSeihou binary fixture args = do
test/Seihou/CLI/UpdateFixture.hs view
@@ -1,11 +1,14 @@ module Seihou.CLI.UpdateFixture ( minimalPlan,+ planWithWarnings, conflictPlan, unavailableConflictPlan, orphanPlan, ) where +import Control.Lens ((&), (.~))+import Data.Generics.Labels () import Data.Map.Strict qualified as Map import Data.Set qualified as Set import Data.Time (UTCTime, defaultTimeLocale, parseTimeOrError)@@ -16,6 +19,7 @@ UpdatePlan (..), UpdateRequest (..), UpdateSelection (..),+ UpdateWarning (..), ) import Seihou.CLI.Update.Types (UpdateSnapshot (..)) import Seihou.Core.Types@@ -28,6 +32,7 @@ ( DesiredFile (..), FileReconciliation (..), ObservedFile (..),+ PlannedFileState (..), ReconciliationPlan (..), ReconciliationReason (..), )@@ -56,7 +61,8 @@ promptPolicy = ForbidPrompts, commandPolicy = RunChangedCommands, dryRun = True,- allowDowngrade = False+ allowDowngrade = False,+ includeSharedOwners = False }, snapshot = UpdateSnapshot@@ -73,6 +79,15 @@ plannedApplications = [] } +-- | The minimal plan, carrying the given warnings.+planWithWarnings :: [UpdateWarning] -> UpdatePlan+planWithWarnings warnings =+ minimalPlan (oneFile (FileUnchanged desired unchangedState (ObservedFile True Nothing) Nothing))+ & #warnings+ .~ warnings+ where+ unchangedState = PlannedFileState "title: generated\nbody: old\n" "title: generated\nbody: old\n" (SHA256 "current") False+ conflictPlan :: UpdatePlan conflictPlan = minimalPlan (oneFile conflict) where@@ -111,7 +126,8 @@ strategy = Template, generatedAt = fixedTime, baseline = Nothing,- applicationIds = Set.empty+ applicationIds = Set.empty,+ additiveOnly = False } "user edit" (ObservedFile True (Just (SHA256 "current")))@@ -124,7 +140,8 @@ generatedContent = "title: generated\nbody: old\n", moduleName = ModuleName "demo", strategy = Template,- applicationIds = Set.empty+ applicationIds = Set.empty,+ additiveOnly = False } oneFile :: FileReconciliation -> ReconciliationPlan
test/Seihou/CLI/UpdateRenderSpec.hs view
@@ -1,15 +1,17 @@ module Seihou.CLI.UpdateRenderSpec (tests) where import Data.List (isInfixOf)+import Data.Set qualified as Set import Data.Text qualified as T-import Seihou.CLI.Update (UpdateError (..))+import Seihou.CLI.Update (UpdateError (..), UpdateWarning (..)) import Seihou.CLI.Update.Render ( encodeUpdateOutput, errorOutput, planOutput, renderUpdateHuman, )-import Seihou.CLI.UpdateFixture (conflictPlan)+import Seihou.CLI.UpdateFixture (conflictPlan, planWithWarnings)+import Seihou.Core.Types (ApplicationId (..)) import Test.Hspec import Test.Tasty import Test.Tasty.Hspec (testSpec)@@ -36,3 +38,22 @@ rendered `shouldSatisfy` isInfixOf "manifest_missing" renderUpdateHuman False (errorOutput (UpdateManifestMissing "manifest")) `shouldSatisfy` T.isInfixOf "Update failed [manifest_missing]"++ it "renders an expanded selection as prose, not a shown constructor" $ do+ let warning = SelectionExpandedForSharedPath ".gitignore" (ApplicationId "master-plan")+ rendered = renderUpdateHuman False (planOutput (planWithWarnings [warning]))+ rendered+ `shouldSatisfy` T.isInfixOf "Warning: also updating master-plan because it co-owns .gitignore"+ rendered `shouldNotSatisfy` T.isInfixOf "SelectionExpandedForSharedPath"++ it "names --include-shared-owners in the shared-path refusal" $ do+ let err =+ SharedPathRequiresApplications+ ".gitignore"+ (Set.singleton (ApplicationId "nix-haskell-flake"))+ (Set.singleton (ApplicationId "master-plan"))+ rendered = renderUpdateHuman False (errorOutput err)+ rendered `shouldSatisfy` T.isInfixOf "Update failed [shared_path_requires_applications]"+ rendered `shouldSatisfy` T.isInfixOf "--include-shared-owners"+ -- The user also needs to know why the exemption did not apply.+ rendered `shouldSatisfy` T.isInfixOf "not recorded as written only by additive patches"
test/Seihou/CLI/UpdateSpec.hs view
@@ -2,6 +2,9 @@ ( tests, UpdateFixture (..), prepareUpdateFixture,+ SharedPathFixture (..),+ CoOwnerWriteMode (..),+ prepareSharedPathFixture, ) where @@ -23,11 +26,19 @@ import Seihou.CLI.Update.Selection import Seihou.CLI.Update.Source import Seihou.CLI.Update.Types+import Seihou.CLI.UpdateFixture (minimalPlan) import Seihou.Composition.Instance (ModuleInstance (..)) import Seihou.Core.Application (mkApplicationId) import Seihou.Core.CommandFingerprint (fingerprintCommand) import Seihou.Core.Migration (Migration (..), MigrationOp (..)) import Seihou.Core.Types+import Seihou.Engine.Reconcile+ ( DesiredFile (..),+ FileReconciliation (..),+ ObservedFile (..),+ PlannedFileState (..),+ ReconciliationPlan (..),+ ) import Seihou.Manifest.Hash (hashContent) import Seihou.Manifest.Types (emptyManifest, manifestFromJSON, manifestToJSON) import System.Directory (createDirectoryIfMissing, doesFileExist, withCurrentDirectory)@@ -50,32 +61,120 @@ second = application (AppliedRecipeTarget "stack") [instanceState "shared"] manifest :: Manifest manifest = manifestForApplications [first, second] Map.empty- selectApplications (NamedUpdateTargets ["shared"]) manifest- `shouldBe` Right (RecordedSelection [first, second])+ selectApplications RequireNamedOwners (NamedUpdateTargets ["shared"]) manifest+ `shouldBe` Right (RecordedSelection [first, second], []) it "keeps manifest order for all applications and deduplicates repeated targets" $ do let first = application (AppliedModuleTarget "one") [instanceState "one"] second = application (AppliedModuleTarget "two") [instanceState "two"] manifest :: Manifest manifest = manifestForApplications [first, second] Map.empty- selectApplications AllRecordedApplications manifest- `shouldBe` Right (RecordedSelection [first, second])- selectApplications (NamedUpdateTargets ["two", "two", "one"]) manifest- `shouldBe` Right (RecordedSelection [first, second])+ selectApplications RequireNamedOwners AllRecordedApplications manifest+ `shouldBe` Right (RecordedSelection [first, second], [])+ selectApplications RequireNamedOwners (NamedUpdateTargets ["two", "two", "one"]) manifest+ `shouldBe` Right (RecordedSelection [first, second], []) it "rejects a partial selection that shares an owned path" $ do let first = application (AppliedModuleTarget "one") [instanceState "one"] second = application (AppliedModuleTarget "two") [instanceState "two"] owners = Set.fromList [first ^. #applicationId, second ^. #applicationId]- record = FileRecord (hashContent "old") "one" Template testTime Nothing owners+ record = FileRecord (hashContent "old") "one" Template testTime Nothing owners False manifest :: Manifest manifest = manifestForApplications [first, second] (Map.singleton "shared.txt" record)- selectApplications (NamedUpdateTargets ["one"]) manifest+ selectApplications RequireNamedOwners (NamedUpdateTargets ["one"]) manifest `shouldBe` Left (SharedPathRequiresApplications "shared.txt" (Set.singleton (first ^. #applicationId)) (Set.singleton (second ^. #applicationId))) + it "accepts a partial selection when the shared path is additive-only" $ do+ -- Every owner reaches the path through an additive, non-overlapping+ -- patch, so reconciling one of them cannot disturb the other's bytes.+ let first = application (AppliedModuleTarget "one") [instanceState "one"]+ second = application (AppliedModuleTarget "two") [instanceState "two"]+ owners = Set.fromList [first ^. #applicationId, second ^. #applicationId]+ record = FileRecord (hashContent "old") "one" Template testTime Nothing owners True+ manifest :: Manifest+ manifest = manifestForApplications [first, second] (Map.singleton ".gitignore" record)+ selectApplications RequireNamedOwners (NamedUpdateTargets ["one"]) manifest+ `shouldBe` Right (RecordedSelection [first], [])++ it "still rejects a partial selection when one shared path is not additive-only" $ do+ -- The exemption is per path: an additive shared path does not excuse a+ -- whole-file one in the same manifest.+ let first = application (AppliedModuleTarget "one") [instanceState "one"]+ second = application (AppliedModuleTarget "two") [instanceState "two"]+ owners = Set.fromList [first ^. #applicationId, second ^. #applicationId]+ additive = FileRecord (hashContent "ignore") "one" Template testTime Nothing owners True+ wholeFile = FileRecord (hashContent "old") "one" Template testTime Nothing owners False+ manifest :: Manifest+ manifest =+ manifestForApplications+ [first, second]+ (Map.fromList [(".gitignore", additive), ("shared.txt", wholeFile)])+ selectApplications RequireNamedOwners (NamedUpdateTargets ["one"]) manifest+ `shouldBe` Left+ ( SharedPathRequiresApplications+ "shared.txt"+ (Set.singleton (first ^. #applicationId))+ (Set.singleton (second ^. #applicationId))+ )++ it "expands a named selection to the owners the closure requires" $ do+ let first = application (AppliedModuleTarget "one") [instanceState "one"]+ second = application (AppliedModuleTarget "two") [instanceState "two"]+ owners = Set.fromList [first ^. #applicationId, second ^. #applicationId]+ record = FileRecord (hashContent "old") "one" Template testTime Nothing owners False+ manifest :: Manifest+ manifest = manifestForApplications [first, second] (Map.singleton "shared.txt" record)+ selectApplications IncludeSharedOwners (NamedUpdateTargets ["one"]) manifest+ `shouldBe` Right+ ( RecordedSelection [first, second],+ [SelectionExpandedForSharedPath "shared.txt" (second ^. #applicationId)]+ )++ it "expands to a fixed point across a chain of shared paths" $ do+ -- One and two share a.txt; two and three share b.txt. Selecting one+ -- pulls in two, which then forces three: a single pass is not enough.+ let first = application (AppliedModuleTarget "one") [instanceState "one"]+ second = application (AppliedModuleTarget "two") [instanceState "two"]+ third = application (AppliedModuleTarget "three") [instanceState "three"]+ pair left right =+ FileRecord+ (hashContent "old")+ "one"+ Template+ testTime+ Nothing+ (Set.fromList [left ^. #applicationId, right ^. #applicationId])+ False+ manifest :: Manifest+ manifest =+ manifestForApplications+ [first, second, third]+ (Map.fromList [("a.txt", pair first second), ("b.txt", pair second third)])+ case selectApplications IncludeSharedOwners (NamedUpdateTargets ["one"]) manifest of+ Left err -> expectationFailure ("expected an expanded selection, got " <> show err)+ Right (selected, warnings) -> do+ selected `shouldBe` RecordedSelection [first, second, third]+ warnings+ `shouldBe` [ SelectionExpandedForSharedPath "a.txt" (second ^. #applicationId),+ SelectionExpandedForSharedPath "b.txt" (third ^. #applicationId)+ ]++ it "does not expand for a shared path that is additive-only" $ do+ -- The path no longer requires the closure, so pulling the co-owner in+ -- would update an application the user neither asked for nor needed.+ let first = application (AppliedModuleTarget "one") [instanceState "one"]+ second = application (AppliedModuleTarget "two") [instanceState "two"]+ owners = Set.fromList [first ^. #applicationId, second ^. #applicationId]+ record = FileRecord (hashContent "old") "one" Template testTime Nothing owners True+ manifest :: Manifest+ manifest = manifestForApplications [first, second] (Map.singleton ".gitignore" record)+ selectApplications IncludeSharedOwners (NamedUpdateTargets ["one"]) manifest+ `shouldBe` Right (RecordedSelection [first], [])+ it "requires one explicit target to seed a legacy manifest" $ do- selectApplications AllRecordedApplications (emptyManifest testTime) `shouldBe` Left NoRecordedApplications- selectApplications (NamedUpdateTargets ["one", "two"]) (emptyManifest testTime)+ selectApplications RequireNamedOwners AllRecordedApplications (emptyManifest testTime)+ `shouldBe` Left NoRecordedApplications+ selectApplications RequireNamedOwners (NamedUpdateTargets ["one", "two"]) (emptyManifest testTime) `shouldBe` Left LegacyUpdateRequiresOneTarget describe "candidate source staging" $ do@@ -202,6 +301,19 @@ Right result -> (result ^. #updatedApplications) `shouldBe` [] LBS.readFile (fixture ^. #manifestPath) `shouldReturn` afterFirstApply + it "is not a no-op when a file's recorded write mode is stale" $ do+ -- A manifest that predates `additiveOnly` has no answer for any path.+ -- If that counted as a no-op, nothing would ever write the answer down+ -- and the shared-path exemption could never take effect on an existing+ -- project. Recording a fact about applied state is a change to applied+ -- state (ADR 0004), so it is not a deliberate no-op (ADR 0007).+ isUpdateNoOp (unchangedFilePlan False True) `shouldBe` False+ isUpdateNoOp (unchangedFilePlan True False) `shouldBe` False++ it "is a no-op when the recorded write mode already agrees" $ do+ isUpdateNoOp (unchangedFilePlan True True) `shouldBe` True+ isUpdateNoOp (unchangedFilePlan False False) `shouldBe` True+ it "rejects a plan when its manifest snapshot changes" $ withSystemTempDirectory "seihou-update-stale" $ \root -> do fixture <- prepareUpdateFixture root@@ -403,6 +515,40 @@ (migrationStage ^. #warnings) `shouldBe` [MigrationCommandNotSimulated "shared" "true"] map (^. #moduleVersion) (migrationStage ^. #manifest . #modules) `shouldBe` [Just "2.0.0", Just "2.0.0"] +-- | A plan whose one file is byte-unchanged on disk, parameterized by the+-- @additiveOnly@ the manifest holds and the one this run would record.+unchangedFilePlan :: Bool -> Bool -> UpdatePlan+unchangedFilePlan priorAdditive desiredAdditive =+ minimalPlan+ ( ReconciliationPlan+ { applicationIds = Set.empty,+ files = Map.singleton ".gitignore" (FileUnchanged desired state observedFile (Just prior)),+ requiredDirectories = Set.empty+ }+ )+ where+ content = "/dist-newstyle\n"+ desired =+ DesiredFile+ { path = ".gitignore",+ generatedContent = content,+ moduleName = "alpha",+ strategy = Template,+ applicationIds = Set.empty,+ additiveOnly = desiredAdditive+ }+ state = PlannedFileState content content (hashContent content) False+ observedFile = ObservedFile True (Just (hashContent content))+ prior =+ FileRecord+ (hashContent content)+ "alpha"+ Template+ testTime+ Nothing+ Set.empty+ priorAdditive+ data UpdateFixture = UpdateFixture { projectRoot :: !FilePath, projectFile :: !FilePath,@@ -459,6 +605,7 @@ testTime (Just baselineRef) (Set.singleton applicationId)+ False manifest = ( (emptyManifest testTime) & #modules .~ [appliedModule]@@ -486,6 +633,157 @@ LBS.writeFile manifestPath (manifestToJSON manifest) pure UpdateFixture {projectRoot, projectFile, manifestPath, xdgHome, installedModule, remote, applicationId} +-- | How the co-owning application @beta@ writes the shared @.gitignore@.+data CoOwnerWriteMode+ = -- | @append-line-if-absent@: beta occupies a disjoint slice of the file,+ -- so the path records @additiveOnly = True@ and a targeted update of+ -- @alpha@ alone is safe.+ CoOwnerAppends+ | -- | A whole-file @template@ step: regenerating the path on alpha's behalf+ -- would discard beta's content, so the path records+ -- @additiveOnly = False@ and stays under the ownership closure.+ CoOwnerWritesWholeFile+ | -- | Beta appends, exactly as 'CoOwnerAppends', but the manifest predates+ -- the @additiveOnly@ record and so has no answer. This models every+ -- project in the wild at the moment the field was introduced. Alpha's+ -- remote is published at the installed version with identical content,+ -- so the /only/ thing a whole-project update has to do is write the+ -- missing record down.+ CoOwnerAppendsUnrecorded+ deriving stock (Eq, Show)++-- | A project whose @.gitignore@ is co-owned by two recorded applications.+data SharedPathFixture = SharedPathFixture+ { projectRoot :: !FilePath,+ gitignorePath :: !FilePath,+ manifestPath :: !FilePath,+ xdgHome :: !FilePath,+ alphaApplicationId :: !ApplicationId,+ betaApplicationId :: !ApplicationId+ }+ deriving stock (Generic)++-- | Build a project where @alpha@ and @beta@ both own @.gitignore@.+--+-- The recorded baseline holds both owners' lines. Alpha's installed module is+-- at 1.0.0 and its remote at 2.0.0 with one extra line, so+-- @seihou update alpha@ has real work to do. Beta is recorded but never+-- updated, which is exactly the partial selection the ownership closure used+-- to refuse.+prepareSharedPathFixture :: CoOwnerWriteMode -> FilePath -> IO SharedPathFixture+prepareSharedPathFixture writeMode root = do+ let projectRoot = root </> "project"+ manifestPath = projectRoot </> ".seihou" </> "manifest.json"+ gitignorePath = projectRoot </> ".gitignore"+ xdgHome = root </> "xdg"+ installedRoot = xdgHome </> "seihou" </> "installed"+ remoteRoot = root </> "remote"+ baselineContent = "/dist-newstyle\n/result\n"+ baselineRef = BaselineRef (hashContent baselineContent)+ alphaTarget = AppliedModuleTarget "alpha"+ betaTarget = AppliedModuleTarget "beta"+ alphaApplicationId = mkApplicationId alphaTarget []+ betaApplicationId = mkApplicationId betaTarget []+ originFor name = RemoteOrigin (T.pack (remoteRoot </> T.unpack name)) name Nothing+ appliedFor name target applicationId version =+ (application target [instanceStateFrom (ModuleName name) (originFor name)])+ { applicationId,+ targetOrigin = originFor name,+ targetVersion = Just version,+ instances = [instanceStateFrom (ModuleName name) (originFor name)]+ }+ betaPatch = case writeMode of+ CoOwnerAppends -> Just "append-line-if-absent"+ CoOwnerAppendsUnrecorded -> Just "append-line-if-absent"+ CoOwnerWritesWholeFile -> Nothing+ -- What alpha's remote publishes. Under 'CoOwnerAppendsUnrecorded' it+ -- matches the installed module exactly, so nothing about the sources+ -- has changed and the only pending work is the manifest record.+ (alphaRemoteVersion, alphaRemoteContent) = case writeMode of+ CoOwnerAppendsUnrecorded -> ("1.0.0", "/dist-newstyle\n")+ _ -> ("2.0.0", "/dist-newstyle\n/alpha-v2\n")+ fileRecord =+ FileRecord+ (hashContent baselineContent)+ "alpha"+ Template+ testTime+ (Just baselineRef)+ (Set.fromList [alphaApplicationId, betaApplicationId])+ (writeMode == CoOwnerAppends)+ manifest =+ ( (emptyManifest testTime)+ & #modules+ .~ [ AppliedModule "alpha" emptyParentVars (originFor "alpha") (Just "1.0.0") testTime Nothing,+ AppliedModule "beta" emptyParentVars (originFor "beta") (Just "1.0.0") testTime Nothing+ ]+ & #files .~ Map.singleton ".gitignore" fileRecord+ & #applications+ .~ [ appliedFor "alpha" alphaTarget alphaApplicationId "1.0.0",+ appliedFor "beta" betaTarget betaApplicationId "1.0.0"+ ]+ )+ -- Install one module and publish the same content as its git remote.+ installModule name version patchOp content = do+ let installed = installedRoot </> T.unpack name+ remote = remoteRoot </> T.unpack name+ createDirectoryIfMissing True (installed </> "files")+ TIO.writeFile (installed </> "module.dhall") (moduleDhallForGitignore name version patchOp)+ TIO.writeFile (installed </> "files" </> "gitignore.tmpl") content+ TIO.writeFile+ (installed </> ".seihou-origin.json")+ ("{\"sourceUrl\":\"" <> T.pack remote <> "\",\"version\":\"" <> version <> "\"}")+ pure installed+ publishRemote name version patchOp content = do+ let remote = remoteRoot </> T.unpack name+ createDirectoryIfMissing True (remote </> "files")+ TIO.writeFile (remote </> "module.dhall") (moduleDhallForGitignore name version patchOp)+ TIO.writeFile (remote </> "files" </> "gitignore.tmpl") content+ callProcess "git" ["-C", remote, "init", "-q"]+ callProcess "git" ["-C", remote, "add", "."]+ callProcess "git" ["-C", remote, "-c", "user.name=Seihou Test", "-c", "user.email=test@example.com", "commit", "-qm", "v" <> T.unpack version]++ _ <- installModule "alpha" "1.0.0" (Just "append-line-if-absent") "/dist-newstyle\n"+ _ <- installModule "beta" "1.0.0" betaPatch "/result\n"+ publishRemote "alpha" alphaRemoteVersion (Just "append-line-if-absent") alphaRemoteContent+ publishRemote "beta" "1.0.0" betaPatch "/result\n"++ createDirectoryIfMissing True (projectRoot </> ".seihou" </> "baselines")+ TIO.writeFile gitignorePath baselineContent+ TIO.writeFile+ (projectRoot </> ".seihou" </> "baselines" </> T.unpack (baselineRef ^. #unBaselineRef . #unSHA256))+ baselineContent+ LBS.writeFile manifestPath (manifestToJSON manifest)+ pure+ SharedPathFixture+ { projectRoot,+ gitignorePath,+ manifestPath,+ xdgHome,+ alphaApplicationId,+ betaApplicationId+ }++-- | A module whose only step contributes to @.gitignore@, either through the+-- given patch operation or, with 'Nothing', as a whole-file template.+moduleDhallForGitignore :: Text -> Text -> Maybe Text -> Text+moduleDhallForGitignore name version patchOp =+ T.unlines+ [ "{ name = \"" <> name <> "\"",+ ", version = Some \"" <> version <> "\"",+ ", description = None Text",+ ", vars = [] : List { name : Text, type : Text, default : Optional Text, description : Optional Text, required : Bool, validation : Optional Text }",+ ", exports = [] : List { var : Text, alias : Optional Text }",+ ", prompts = [] : List { var : Text, text : Text, when : Optional Text, choices : Optional (List Text) }",+ ", steps = [{ strategy = \"template\", src = \"gitignore.tmpl\", dest = \".gitignore\", when = None Text, patch = "+ <> maybe "None Text" (\op -> "Some \"" <> op <> "\"") patchOp+ <> " }]",+ ", commands = [] : List { run : Text, workDir : Optional Text, when : Optional Text }",+ ", dependencies = [] : List Text",+ ", removal = None { steps : List { action : Text, dest : Text, src : Optional Text }, commands : List { run : Text, workDir : Optional Text, when : Optional Text } }",+ "}"+ ]+ prepareRecipeUpdateFixture :: FilePath -> IO RecipeUpdateFixture prepareRecipeUpdateFixture root = do let projectRoot = root </> "project"@@ -570,7 +868,8 @@ promptPolicy = ForbidPrompts, commandPolicy = RunChangedCommands, dryRun,- allowDowngrade = False+ allowDowngrade = False,+ includeSharedOwners = False } moduleDhallWithTemplate :: Text -> Text -> Text -> Text