seihou-core 0.9.0.0 → 0.10.0.0

raw patch · 49 files changed

+2537/−349 lines, 49 filesdep ~aesondep ~processPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: aeson, process

API changes (from Hackage documentation)

Files

• seihou-core.cabal +14/−3
• src/Seihou/Composition/Plan.hs +11/−1
• src/Seihou/Core/Application.hs +7/−3
• src/Seihou/Core/ArtifactIdentity.hs +30/−0
• src/Seihou/Core/ArtifactOriginDetect.hs +16/−6
• src/Seihou/Core/Checkout.hs +202/−0
• src/Seihou/Core/Module.hs +52/−7
• src/Seihou/Core/Path.hs +13/−0
• src/Seihou/Core/Seed.hs +39/−0
• src/Seihou/Core/Types.hs +133/−9
• src/Seihou/Dhall/Eval.hs +21/−12
• src/Seihou/Effect/Filesystem.hs +25/−0
• src/Seihou/Effect/FilesystemInterp.hs +16/−1
• src/Seihou/Effect/FilesystemPure.hs +24/−4
• src/Seihou/Engine/Checkout.hs +239/−0
• src/Seihou/Engine/Execute.hs +15/−10
• src/Seihou/Engine/Plan.hs +12/−1
• src/Seihou/Engine/Preview.hs +4/−0
• src/Seihou/Engine/Reconcile.hs +21/−1
• src/Seihou/Engine/Remove.hs +62/−1
• src/Seihou/Engine/UpdateTransaction.hs +80/−27
• src/Seihou/Engine/Validate.hs +7/−2
• src/Seihou/Manifest/JSON.hs +30/−0
• src/Seihou/Manifest/Types.hs +236/−76
• src/Seihou/Manifest/Upgrade.hs +282/−0
• test/Main.hs +11/−1
• test/Seihou/Core/ApplicationSpec.hs +29/−19
• test/Seihou/Core/ArtifactIdentitySpec.hs +49/−0
• test/Seihou/Core/ArtifactOriginDetectSpec.hs +10/−0
• test/Seihou/Core/CheckoutSpec.hs +95/−0
• test/Seihou/Core/ModuleSpec.hs +7/−6
• test/Seihou/Core/SeedSpec.hs +71/−0
• test/Seihou/Core/StatusSpec.hs +4/−3
• test/Seihou/Effect/FilesystemSpec.hs +1/−1
• test/Seihou/Effect/ManifestStoreSpec.hs +3/−3
• test/Seihou/Engine/BaselineSpec.hs +7/−7
• test/Seihou/Engine/CheckoutSpec.hs +213/−0
• test/Seihou/Engine/DiffSpec.hs +20/−15
• test/Seihou/Engine/ExecuteSpec.hs +17/−17
• test/Seihou/Engine/MigrateSpec.hs +2/−2
• test/Seihou/Engine/PlanSpec.hs +35/−35
• test/Seihou/Engine/ReconcileSpec.hs +4/−2
• test/Seihou/Engine/RemoveSpec.hs +9/−5
• test/Seihou/Engine/UpdateTransactionSpec.hs +68/−20
• test/Seihou/Engine/ValidateSpec.hs +8/−7
• test/Seihou/Integration/ExecutionSpec.hs +3/−1
• test/Seihou/Integration/GenerationSpec.hs +1/−1
• test/Seihou/Manifest/TypesSpec.hs +105/−40
• test/Seihou/Manifest/UpgradeSpec.hs +174/−0

@@ -1,6 +1,6 @@ cabal-version: 3.0 name: seihou-core-version: 0.9.0.0+version: 0.10.0.0 synopsis: Core library for Seihou project scaffolding description:   Core library for Seihou, a composable project scaffolding system.@@ -44,6 +44,7 @@     Seihou.Core.ArtifactOriginDetect     Seihou.Core.ArtifactRef     Seihou.Core.Blueprint+    Seihou.Core.Checkout     Seihou.Core.CommandFingerprint     Seihou.Core.CommandVar     Seihou.Core.Context@@ -56,6 +57,7 @@     Seihou.Core.Registry     Seihou.Core.Scaffold     Seihou.Core.SchemaUpgrade+    Seihou.Core.Seed     Seihou.Core.Status     Seihou.Core.Types     Seihou.Core.Variable@@ -89,6 +91,7 @@     Seihou.Effect.ProcessInterp     Seihou.Effect.ProcessPure     Seihou.Engine.Baseline+    Seihou.Engine.Checkout     Seihou.Engine.Conflict     Seihou.Engine.DhallJSON     Seihou.Engine.Diff@@ -107,11 +110,13 @@     Seihou.Interaction.Confirm     Seihou.Interaction.Prompt     Seihou.Manifest.Hash+    Seihou.Manifest.JSON     Seihou.Manifest.Types+    Seihou.Manifest.Upgrade     Seihou.Prelude    build-depends:-    aeson >=2.1 && <3,+    aeson >=2.1.2 && <3,     aeson-pretty >=0.8 && <1,     base >=4.18 && <5,     base16-bytestring >=1.0 && <2,@@ -152,9 +157,11 @@     Seihou.Composition.ResolveSpec     Seihou.Core.AgentPromptSpec     Seihou.Core.ApplicationSpec+    Seihou.Core.ArtifactIdentitySpec     Seihou.Core.ArtifactOriginDetectSpec     Seihou.Core.ArtifactRefSpec     Seihou.Core.BlueprintSpec+    Seihou.Core.CheckoutSpec     Seihou.Core.CommandFingerprintSpec     Seihou.Core.CommandVarSpec     Seihou.Core.ContextSpec@@ -170,6 +177,7 @@     Seihou.Core.RegistrySyncSpec     Seihou.Core.ScaffoldSpec     Seihou.Core.SchemaUpgradeSpec+    Seihou.Core.SeedSpec     Seihou.Core.StatusSpec     Seihou.Core.TypesSpec     Seihou.Core.VariableSpec@@ -184,6 +192,7 @@     Seihou.Effect.LoggerSpec     Seihou.Effect.ManifestStoreSpec     Seihou.Engine.BaselineSpec+    Seihou.Engine.CheckoutSpec     Seihou.Engine.ConflictSpec     Seihou.Engine.DiffSpec     Seihou.Engine.ExecuteSpec@@ -208,9 +217,10 @@     Seihou.Interaction.ConfirmSpec     Seihou.Interaction.PromptSpec     Seihou.Manifest.TypesSpec+    Seihou.Manifest.UpgradeSpec    build-depends:-    aeson >=2.1 && <3,+    aeson >=2.1.2 && <3,     base >=4.18 && <5,     bytestring >=0.11 && <1,     containers >=0.6 && <1,@@ -221,6 +231,7 @@     generic-lens >=2.2 && <3,     hspec >=2.11 && <3,     lens >=5.2 && <6,+    process >=1.6 && <1.7,     seihou-core,     tasty >=1.4 && <2,     tasty-hspec >=1.2 && <2,

@@ -18,6 +18,7 @@ import Data.Text.Lazy.Encoding qualified as TLE import Data.Yaml qualified as Yaml import Seihou.Composition.Instance (ModuleInstance, qualifiedName)+import Seihou.Core.Checkout (CheckoutError (..), checkoutClaims, pathsOverlap) import Seihou.Core.Types import Seihou.Engine.Plan (compilePlan) import Seihou.Engine.Section (applyTextPatch)@@ -40,7 +41,15 @@   results <- mapM compileOne modules   let (errs, opsPerModule) = partitionResults results   if null errs-    then pure (Right (mergeOperations opsPerModule))+    then do+      let ops = concatMap snd opsPerModule+          links = [dest | CheckoutOutputOp {dest} <- ops]+          bytes = [dest | op <- ops, Just dest <- [destOfOp op]]+          overlaps = ["checkout output '" <> T.pack link <> "' overlaps byte-writing output '" <> T.pack path <> "'" | link <- links, path <- bytes, pathsOverlap link path]+      pure $ case checkoutClaims (ApplicationId "composition") ops of+        Left err -> Left [err ^. #message]+        Right _ | not (null overlaps) -> Left overlaps+        Right _ -> Right (mergeOperations opsPerModule)     else pure (Left (concat errs))   where     compileOne (inst, m, dir, vars) = do@@ -83,6 +92,7 @@     go [] fileOwner _ opsAcc warningsAcc = (opsAcc, warningsAcc, fileOwner)     go ((name, op) : rest) fileOwner seenDirs opsAcc warningsAcc =       case op of+        CheckoutOutputOp {} -> go rest fileOwner seenDirs (op : opsAcc) warningsAcc         CreateDirOp p           | Set.member p seenDirs -> go rest fileOwner seenDirs opsAcc warningsAcc           | otherwise -> go rest fileOwner (Set.insert p seenDirs) (op : opsAcc) warningsAcc

@@ -93,7 +93,8 @@ -- The current record's baseline is preserved: EP-65 captures the exact -- post-execution generated content before ownership is attached. ----- @additiveOnly@ can only be weakened here, never strengthened. This run+-- The shared-write mode can only be kept or weakened here, never+-- strengthened ('mergeSharedWriteMode'). This run -- executed only its own application's operations, so its answer covers only -- its own contributions; when a prior owner survives outside this run, the -- prior record is the only evidence about that owner's write mode, and a@@ -105,12 +106,15 @@ attachApplication applicationId previous current =   current     & #applicationIds .~ Set.insert applicationId (Set.union (current ^. #applicationIds) priorApplications)-    & #additiveOnly .~ ((current ^. #additiveOnly) && (not partial || priorAdditive))+    & #sharedWriteMode+      .~ mergeSharedWriteMode+        partial+        ((^. #sharedWriteMode) <$> previous)+        (current ^. #sharedWriteMode == SharedWriteAdditiveOnly)   where     priorApplications = maybe Set.empty (^. #applicationIds) previous     retainedOwners = Set.delete applicationId priorApplications     partial = not (Set.null retainedOwners)-    priorAdditive = maybe False (^. #additiveOnly) previous  varValueToText :: VarValue -> Text varValueToText (VText value) = value

@@ -20,9 +20,11 @@   ( sameArtifactIdentity,     normalizeOriginUrl,     normalizeProjectPath,+    isMachineLocalOriginUrl,   ) where +import Data.Char (isAsciiLower, isAsciiUpper) import Data.Maybe (fromMaybe) import Data.Text qualified as T import Seihou.Core.Types (ArtifactOrigin (..))@@ -75,3 +77,31 @@         then Just (drop (length prefix) path)         else Nothing     dropWhileEnd' p = reverse . dropWhile p . reverse++-- | Whether a recorded origin URL is a path on the machine that recorded it+-- rather than a location every developer can reach.+--+-- @seihou install@ accepts a local checkout, and before plan 98 it stored+-- that path verbatim as the installed copy's @sourceUrl@, which then reached+-- the manifest as a 'RemoteOrigin'. A path means nothing on another machine+-- (docs\/adr\/0001-manifest-is-a-checked-in-machine-independent-artifact.md)+-- and turns into a false origin mismatch on this one as soon as the artifact+-- is reinstalled from its real remote.+--+-- True for text that, once stripped, starts with @\/@, @.\/@, @..\/@, @~@+-- or @file:@, is exactly @.@ or @..@, or is a Windows drive path+-- (@C:\\@ or @C:\/@). False for URLs with a network scheme+-- (@https:\/\/@, @ssh:\/\/@, @git:\/\/@) and for scp-style+-- @user\@host:path@.+isMachineLocalOriginUrl :: Text -> Bool+isMachineLocalOriginUrl raw =+  any (`T.isPrefixOf` url) ["/", "./", "../", "~", "file:"]+    || url == "."+    || url == ".."+    || isDrivePath url+  where+    url = T.strip raw+    isDrivePath text = case T.unpack (T.take 3 text) of+      [letter, ':', sep] -> isDriveLetter letter && (sep == '\\' || sep == '/')+      _ -> False+    isDriveLetter c = isAsciiLower c || isAsciiUpper c

@@ -26,6 +26,7 @@ import Data.ByteString.Lazy qualified as LBS import Data.Generics.Labels () import Data.Text qualified as T+import Seihou.Core.ArtifactIdentity (isMachineLocalOriginUrl) import Seihou.Core.Types (ArtifactOrigin (..)) import Seihou.Prelude import System.Directory (canonicalizePath, doesFileExist)@@ -69,11 +70,18 @@ --      'ProjectOrigin' holding the path relative to @projectRoot@ with --      forward slashes. --   2. Otherwise, if @artifactDir@ contains a readable---      @.seihou-origin.json@ with a @sourceUrl@, the result is a---      'RemoteOrigin' carrying that URL, the directory's base name, and---      the recorded @repoName@.+--      @.seihou-origin.json@ with a @sourceUrl@ that is not a machine-local+--      path, the result is a 'RemoteOrigin' carrying that URL, the+--      directory's base name, and the recorded @repoName@. --   3. Otherwise the result is a 'LocalOrigin' holding the directory's---      base name.+--      base name. This includes a @sourceUrl@ that+--      'isMachineLocalOriginUrl' recognises as a path (an install from a+--      local checkout whose commit seihou could not trace to a published+--      remote): the path is meaningful only on this machine, so recording it+--      would break the manifest for everyone else and turn into a false+--      origin mismatch here once the artifact is reinstalled from its real+--      remote. 'LocalOrigin' says what is actually known — the provenance+--      is not portable. detectArtifactOrigin :: FilePath -> FilePath -> IO ArtifactOrigin detectArtifactOrigin projectRoot artifactDir = do   root <- canonicalizeOr projectRoot@@ -84,8 +92,10 @@       originInfo <- readOriginInfo dir       let name = T.pack (takeFileName dir)       pure $ case originInfo of-        Just info -> RemoteOrigin (info ^. #sourceUrl) name (info ^. #repoName)-        Nothing -> LocalOrigin name+        Just info+          | not (isMachineLocalOriginUrl (info ^. #sourceUrl)) ->+              RemoteOrigin (info ^. #sourceUrl) name (info ^. #repoName)+        _ -> LocalOrigin name  -- | 'canonicalizePath' throws when an intermediate component does not -- exist, which happens in tests and for artifacts that were removed between

@@ -0,0 +1,202 @@+module Seihou.Core.Checkout+  ( CheckoutError (..),+    checkoutError,+    validateCheckoutPaths,+    validateCheckoutRecords,+    mergeCheckoutRecord,+    dropCheckoutOwners,+    checkoutClaims,+    checkoutSource,+    replaceCheckoutApplications,+    CheckoutIntent (..),+    CheckoutPolicy (..),+    CheckoutObservation (..),+    CheckoutAction (..),+    CheckoutEntry (..),+    CheckoutPlan (..),+    planCheckoutOutputs,+    checkoutApplicable,+    expectedTarget,+    pathsOverlap,+  )+where++import Control.Monad (foldM, forM_, unless, when)+import Data.Generics.Labels ()+import Data.Map.Strict qualified as Map+import Data.Maybe (isJust, maybeToList)+import Data.Set qualified as Set+import Data.Text qualified as T+import Seihou.Composition.Instance (ModuleInstance (..), qualifiedName)+import Seihou.Core.Path (validateCanonicalProjectPath)+import Seihou.Core.Types+import Seihou.Effect.Filesystem (PathEntry (..))+import Seihou.Prelude+import System.FilePath.Posix qualified as P++-- | Stable machine code and an actionable human explanation.+data CheckoutError = CheckoutError {code :: !Text, message :: !Text}+  deriving stock (Eq, Show, Generic)++checkoutError :: Text -> Text -> CheckoutError+checkoutError = CheckoutError++checkoutSource :: CheckoutOutputSpec -> FilePath+checkoutSource (DirectorySymlink source) = source++pathsOverlap :: FilePath -> FilePath -> Bool+pathsOverlap a b = a == b || (a <> "/") `isPrefixOf` b || (b <> "/") `isPrefixOf` a+  where+    isPrefixOf x y = T.pack x `T.isPrefixOf` T.pack y++validateCheckoutPaths :: FilePath -> FilePath -> Either CheckoutError ()+validateCheckoutPaths source dest = do+  forM_ [source, dest] $ \path -> first (checkoutError "checkout_path_invalid") (validateCanonicalProjectPath (T.pack path))+  when (pathsOverlap source dest) $ Left (checkoutError "checkout_path_overlap" "source and destination must not overlap")++-- | Validate the entire candidate, including application-local instance ownership.+validateCheckoutRecords :: Manifest -> [FilePath] -> Either CheckoutError ()+validateCheckoutRecords manifest pending = do+  let outputs = manifest ^. #checkoutOutputs+      bytePaths = Map.keys (manifest ^. #files) <> Map.keys (manifest ^. #seeds) <> pending+  forM_ (Map.toAscList outputs) $ \(dest, record) -> do+    validateCheckoutPaths (checkoutSource (record ^. #spec)) dest+    when (Map.null (record ^. #owners)) $ bad dest "has no owners"+    forM_ (Map.toAscList (record ^. #owners)) $ \(appId, names) -> do+      when (Set.null names) $ bad dest "has an empty instance owner set"+      case filter ((== appId) . (^. #applicationId)) (manifest ^. #applications) of+        [app] -> unless (names `Set.isSubsetOf` Set.fromList [qualifiedName (ModuleInstance (state ^. #name) (state ^. #parentVars)) | state <- app ^. #instances]) $ bad dest "names an instance outside its owning application"+        _ -> bad dest "names an unknown or duplicate application owner"+    forM_ bytePaths $ \path -> when (pathsOverlap dest path) $ bad dest ("overlaps managed or seed output '" <> T.pack path <> "'; resolve the lifecycle transition manually")+    forM_ (Map.keys outputs) $ \other -> do+      when (dest /= other && pathsOverlap dest other) $ bad dest ("overlaps checkout destination '" <> T.pack other <> "'")+      when (pathsOverlap (checkoutSource (record ^. #spec)) other) $ bad dest ("source overlaps checkout destination '" <> T.pack other <> "'")+  where+    bad dest reason = Left (checkoutError "checkout_declaration_invalid" ("checkout output '" <> T.pack dest <> "' " <> reason))++mergeCheckoutRecord :: FilePath -> CheckoutOutputRecord -> Map FilePath CheckoutOutputRecord -> Either CheckoutError (Map FilePath CheckoutOutputRecord)+mergeCheckoutRecord dest record records = case Map.lookup dest records of+  Nothing -> Right (Map.insert dest record records)+  Just old | old ^. #spec == record ^. #spec -> Right (Map.insert dest (old & #owners %~ Map.unionWith Set.union (record ^. #owners)) records)+  Just _ -> Left (checkoutError "checkout_owner_conflict" ("checkout owners disagree on '" <> T.pack dest <> "'"))++-- | Replace the selected claims; preserve all unselected application/instance owners.+dropCheckoutOwners :: Map ApplicationId (Set ModuleName) -> Map FilePath CheckoutOutputRecord -> Map FilePath CheckoutOutputRecord+dropCheckoutOwners selected = Map.mapMaybe $ \record ->+  let retained = Map.mapMaybeWithKey (\app names -> let rest = names `Set.difference` Map.findWithDefault Set.empty app selected in if Set.null rest then Nothing else Just rest) (record ^. #owners)+   in if Map.null retained then Nothing else Just (record & #owners .~ retained)++checkoutClaims :: ApplicationId -> [Operation] -> Either CheckoutError (Map FilePath CheckoutOutputRecord)+checkoutClaims app = foldM add Map.empty+  where+    add records CheckoutOutputOp {dest, spec, moduleName} = mergeCheckoutRecord dest (CheckoutOutputRecord spec (Map.singleton app (Set.singleton moduleName))) records+    add records _ = Right records++data CheckoutIntent = Rebuild | Reconcile deriving stock (Eq, Show, Generic)++data CheckoutPolicy = SyncIgnoredOnly | ApplyDeclaration deriving stock (Eq, Show, Generic)++data CheckoutObservation = CheckoutObservation+  { entry :: !PathEntry,+    sourceDirectory :: !Bool,+    problems :: ![CheckoutError],+    gitAvailable :: !Bool,+    ignored :: !Bool+  }+  deriving stock (Eq, Show, Generic)++data CheckoutAction = CreateLink | ReplaceLink | RetireLink | UnchangedLink | AlreadyAbsent | PreserveModified | RefusedLink+  deriving stock (Eq, Ord, Show, Generic)++data CheckoutEntry = CheckoutEntry+  { dest :: !FilePath,+    previous :: !(Maybe CheckoutOutputSpec),+    candidate :: !(Maybe CheckoutOutputSpec),+    observation :: !CheckoutObservation,+    action :: !CheckoutAction,+    errors :: ![CheckoutError],+    warnings :: ![Text]+  }+  deriving stock (Eq, Show, Generic)++newtype CheckoutPlan = CheckoutPlan {entries :: [CheckoutEntry]}+  deriving stock (Eq, Show, Generic)++checkoutApplicable :: CheckoutPlan -> Bool+checkoutApplicable = all (null . (^. #errors)) . (^. #entries)++expectedTarget :: FilePath -> CheckoutOutputSpec -> FilePath+expectedTarget dest (DirectorySymlink source) =+  let parent = P.takeDirectory dest+      depth = if parent == "." then 0 else length (P.splitDirectories parent)+   in P.joinPath (replicate depth ".." <> [source])++planCheckoutOutputs :: CheckoutIntent -> CheckoutPolicy -> Map FilePath CheckoutOutputRecord -> Map FilePath CheckoutOutputRecord -> Map FilePath CheckoutObservation -> CheckoutPlan+planCheckoutOutputs intent policy prior candidate observations = CheckoutPlan (map plan (Set.toAscList (Map.keysSet prior <> Map.keysSet candidate)))+  where+    plan dest =+      let old = (^. #spec) <$> Map.lookup dest prior+          new = (^. #spec) <$> Map.lookup dest candidate+          obs = Map.findWithDefault (CheckoutObservation EntryMissing False [checkoutError "checkout_observation_missing" "output was not observed"] False False) dest observations+          unchanged = intent == Reconcile && old == new+          active = isJust new+          syntax = [err | spec <- maybeToList new <> maybeToList old, Left err <- [validateCheckoutPaths (checkoutSource spec) dest]]+          policyErrors =+            [checkoutError "checkout_git_required" "sync requires a Git working tree" | policy == SyncIgnoredOnly, not (obs ^. #gitAvailable)]+              <> [checkoutError "checkout_not_ignored" "destination must be ignored; add it to .gitignore before running seihou sync" | policy == SyncIgnoredOnly, active, not (obs ^. #ignored)]+          preconditions =+            if unchanged+              then []+              else+                obs ^. #problems+                  <> policyErrors+                  <> [checkoutError "checkout_source_missing" "source must be an existing real project directory; restore it before retrying" | active, not (obs ^. #sourceDirectory)]+          contract = [checkoutError "checkout_rebuild_contract" "rebuild requires identical prior and candidate declarations" | intent == Rebuild, prior /= candidate]+          (proposed, collisions) = classify dest old new (obs ^. #entry) unchanged+          errs = contract <> syntax <> preconditions <> collisions+          warnings =+            ["preserved a modified checkout entry; released its declaration" | proposed == PreserveModified]+              <> ["Git evidence unavailable; applying a declaration before git-init" | not unchanged, policy == ApplyDeclaration, not (obs ^. #gitAvailable)]+              <> ["checkout destination is not ignored; clones require ignore rules for seihou sync" | not unchanged, policy == ApplyDeclaration, obs ^. #gitAvailable, active, not (obs ^. #ignored)]+       in CheckoutEntry dest old new obs (if null errs then proposed else RefusedLink) errs warnings+    classify _ _ _ _ True = (UnchangedLink, [])+    classify dest old Nothing entry _ = case entry of+      EntryMissing -> (AlreadyAbsent, [])+      EntrySymlink target | Just spec <- old, target == expectedTarget dest spec -> (RetireLink, [])+      _ -> (PreserveModified, [])+    classify dest old (Just spec) entry _ = case entry of+      EntryMissing -> (CreateLink, [])+      EntrySymlink target+        | target == expectedTarget dest spec -> (UnchangedLink, [])+        | intent == Rebuild || maybe False ((== target) . expectedTarget dest) old -> (ReplaceLink, [])+        | otherwise -> (RefusedLink, [checkoutError "checkout_link_modified" "link target changed locally; move it aside or restore its recorded target"])+      _ -> (RefusedLink, [checkoutError "checkout_destination_occupied" "destination is a real file or directory; move it aside manually"])++-- | Re-evaluation replaces a selected application's complete declaration set,+-- including dependencies that disappeared or whose conditions became false.+replaceCheckoutApplications :: Manifest -> [(AppliedComposition, [Operation])] -> Either CheckoutError Manifest+replaceCheckoutApplications prior applications = do+  let selected = Set.fromList [app ^. #applicationId | (app, _) <- applications]+      departing = Map.unionsWith Set.union [Map.restrictKeys (record ^. #owners) selected | record <- Map.elems (prior ^. #checkoutOutputs)]+      retained = dropCheckoutOwners departing (prior ^. #checkoutOutputs)+      updateApps apps (app, _) = app : filter ((/= app ^. #applicationId) . (^. #applicationId)) apps+  outputs <- foldM add retained applications+  let candidate = prior & #checkoutOutputs .~ outputs & #applications .~ foldl updateApps (prior ^. #applications) applications+      pending =+        [ dest+        | (_, ops) <- applications,+          op <- ops,+          dest <- case op of+            WriteFileOp {dest} -> [dest]+            CopyFileOp {dest} -> [dest]+            PatchFileOp {dest} -> [dest]+            _ -> []+        ]+  validateCheckoutRecords candidate pending+  forM_ pending $ \path -> forM_ (Map.keys (prior ^. #checkoutOutputs)) $ \old ->+    when (pathsOverlap path old) $ Left (checkoutError "checkout_lifecycle_transition" ("output '" <> T.pack path <> "' overlaps a previous checkout declaration; remove that declaration and resolve the transition manually"))+  pure candidate+  where+    add records (app, ops) = do+      claims <- checkoutClaims (app ^. #applicationId) ops+      foldM (\acc (dest, record) -> mergeCheckoutRecord dest record acc) records (Map.toAscList claims)

@@ -25,6 +25,8 @@     checkSafeDestinations,     checkDestVarRefs,     checkCommandSafety,+    checkSeedSteps,+    checkCheckoutSteps,     isValidModuleName,     extractPlaceholders,     validateProjectRelativePath,@@ -33,8 +35,10 @@  import Data.Generics.Labels () import Data.Map.Strict qualified as Map+import Data.Maybe (isJust, maybeToList) import Data.Set qualified as Set import Data.Text qualified as T+import Seihou.Core.Checkout (CheckoutError (..), validateCheckoutPaths) import Seihou.Core.Path (validateProjectRelativePath) import Seihou.Core.Types import Seihou.Dhall.Eval (evalAgentPromptFromFile, evalBlueprintFromFile, evalModuleFromFile, evalRecipeFromFile)@@ -177,6 +181,8 @@           <> checkSafeDestinations m           <> checkDestVarRefs m           <> checkCommandSafety m+          <> checkSeedSteps m+          <> checkCheckoutSteps m       allErrors = pureErrors <> fileErrors   pure $     if null allErrors@@ -235,13 +241,16 @@ checkFileExistence baseDir m =   concat     <$> mapM-      ( \s -> do-          let p = baseDir </> "files" </> (s ^. #src)-          exists <- doesFileExist p-          pure $-            if exists-              then []-              else ["step source file not found: " <> T.pack (s ^. #src)]+      ( \s ->+          if s ^. #strategy == Symlink+            then pure []+            else do+              let p = baseDir </> "files" </> (s ^. #src)+              exists <- doesFileExist p+              pure $+                if exists+                  then []+                  else ["step source file not found: " <> T.pack (s ^. #src)]       )       (m ^. #steps) @@ -563,3 +572,39 @@     briefLoadError (MissingSourceFile _ _) = "missing source file"     briefLoadError (CircularDependency _) = "circular dependency"     briefLoadError (RegistryEvalError _ _) = "registry eval failed"++-- | A seed creates an entire file and must never be subject to automatic removal.+checkSeedSteps :: Module -> [Text]+checkSeedSteps m = concatMap checkStep seedSteps <> mixed <> removals+  where+    seedSteps = filter ((== Seed) . (^. #lifecycle)) (m ^. #steps)+    checkStep s =+      ["step writing '" <> s ^. #dest <> "' is a seed but has a patch; a seed creates a whole file once and cannot patch one" | isJust (s ^. #patch)]+        <> ["step writing '" <> s ^. #dest <> "' is a seed but uses the structured strategy; seeds support copy, template, and dhall-text" | s ^. #strategy == Structured]+    mixed =+      [ "steps writing '" <> dest <> "' mix the seed and managed lifecycles; use one lifecycle per destination"+      | dest <- Set.toAscList (Set.fromList (map (^. #dest) seedSteps)),+        any (\s -> s ^. #dest == dest && s ^. #lifecycle == Managed) (m ^. #steps)+      ]+    removals =+      [ "removal step deletes '" <> s ^. #dest <> "', which a seed step creates; seihou never deletes seed files"+      | removal <- maybeToList (m ^. #removal),+        r <- removal ^. #steps,+        r ^. #action == RemoveFileAction,+        s <- seedSteps,+        s ^. #dest == r ^. #dest+      ]++-- | Directory links are declarations about the consuming project, not cached files.+checkCheckoutSteps :: Module -> [Text]+checkCheckoutSteps m = concatMap check (m ^. #steps)+  where+    check s+      | s ^. #strategy /= Symlink && s ^. #lifecycle /= Checkout = []+      | otherwise =+          [label s <> "requires strategy symlink and lifecycle checkout together" | s ^. #strategy /= Symlink || s ^. #lifecycle /= Checkout]+            <> [label s <> "cannot carry a patch" | isJust (s ^. #patch)]+            <> [label s <> err ^. #message | Left err <- [validateCheckoutPaths (s ^. #src) (T.unpack (s ^. #dest))]]+            <> [label s <> "source references undeclared variable: " <> name | name <- extractPlaceholders (T.pack (s ^. #src)), name `notElem` map (^. #name . #unVarName) (m ^. #vars)]+            <> [label s <> "has malformed placeholders" | path <- [T.pack (s ^. #src), s ^. #dest], T.count "{{" path /= T.count "}}" path]+    label s = "step writing '" <> s ^. #dest <> "' "

@@ -1,5 +1,6 @@ module Seihou.Core.Path   ( validateProjectRelativePath,+    validateCanonicalProjectPath,   ) where @@ -27,3 +28,15 @@ pathSegments =   filter (not . T.null)     . T.split (\c -> c == '/' || c == '\\')++-- | Checkout declarations use a canonical, portable spelling and reserve metadata.+-- This deliberately strengthens rather than changes the legacy validator above.+validateCanonicalProjectPath :: Text -> Either Text ()+validateCanonicalProjectPath raw = do+  _ <- validateProjectRelativePath raw+  if T.null raw+    || raw /= T.strip raw+    || T.any (\c -> c == '\\' || c == '\0' || c == ':') raw+    || any (\part -> T.null part || part == "." || part == ".." || T.toCaseFold part `elem` [".git", ".seihou"]) (T.splitOn "/" raw)+    then Left ("path must use canonical project-relative components outside .git and .seihou: " <> raw)+    else Right ()

@@ -0,0 +1,39 @@+module Seihou.Core.Seed+  ( mergeSeedRecord,+    dropSeedOwner,+    seedsOwnedByModule,+    ManifestInvariantError (..),+    validateManifestInvariants,+  )+where++import Data.Generics.Labels ()+import Data.Map.Strict qualified as Map+import Data.Set qualified as Set+import Seihou.Core.Types+import Seihou.Prelude++-- | Keep the first settlement; callers must check the final manifest's invariants.+-- Never create a receipt for a managed path.+mergeSeedRecord :: FilePath -> SeedRecord -> Manifest -> Manifest+mergeSeedRecord path receipt = #seeds %~ Map.insertWith merge path receipt+  where+    merge new old = old & #applicationIds %~ Set.union (new ^. #applicationIds)++dropSeedOwner :: Set ApplicationId -> FilePath -> Manifest -> Manifest+dropSeedOwner departing path = #seeds %~ Map.update dropOwners path+  where+    dropOwners record =+      let retained = (record ^. #applicationIds) `Set.difference` departing+       in if Set.null retained then Nothing else Just (record & #applicationIds .~ retained)++seedsOwnedByModule :: ModuleName -> Manifest -> Map FilePath SeedRecord+seedsOwnedByModule name manifest = Map.filter ((== name) . (^. #moduleName)) (manifest ^. #seeds)++data ManifestInvariantError = PathBothManagedAndSeeded FilePath+  deriving stock (Eq, Show, Generic)++validateManifestInvariants :: Manifest -> Either ManifestInvariantError ()+validateManifestInvariants manifest = case Map.keys (Map.intersection (manifest ^. #files) (manifest ^. #seeds)) of+  path : _ -> Left (PathBothManagedAndSeeded path)+  [] -> Right ()

@@ -9,6 +9,12 @@     Prompt (..),     Expr (..),     Strategy (..),+    StepLifecycle (..),+    CheckoutOutputSpec (..),+    CheckoutOutputRecord (..),+    lifecycleToText,+    SeedOutcome (..),+    SeedRecord (..),     PatchOp (..),     isAdditivePatchOp,     Step (..),@@ -37,6 +43,11 @@     isAdditiveOperation,     ModuleLoadError (..),     Manifest (..),+    ManifestSchemaVersion (..),+    ManifestCapability (..),+    SharedWriteMode (..),+    knownSharedWriteMode,+    mergeSharedWriteMode,     ApplicationId (..),     ArtifactOrigin (..),     AppliedTarget (..),@@ -74,6 +85,7 @@ import Control.Lens ((^.)) import Data.Generics.Labels () import Data.Map.Strict (Map)+import Data.Maybe (fromMaybe) import Data.Set (Set) import Data.String (IsString) import Data.Text (Text)@@ -162,6 +174,7 @@   | Template   | DhallText   | Structured+  | Symlink   deriving stock (Eq, Show, Generic)  -- | Patch operations for modifying existing files during composition.@@ -194,13 +207,23 @@ isAdditivePatchOp AppendFile = False isAdditivePatchOp PrependFile = False +-- | Ownership of an output, independent of its materialization strategy.+data StepLifecycle = Managed | Seed | Checkout+  deriving stock (Eq, Ord, Show, Generic)++lifecycleToText :: StepLifecycle -> Text+lifecycleToText Managed = "managed"+lifecycleToText Seed = "seed"+lifecycleToText Checkout = "checkout"+ -- | A generation step within a module. data Step = Step   { strategy :: !Strategy,     src :: !FilePath,     dest :: !Text,     condition :: !(Maybe Expr),-    patch :: !(Maybe PatchOp)+    patch :: !(Maybe PatchOp),+    lifecycle :: !StepLifecycle   }   deriving stock (Eq, Show, Generic) @@ -419,8 +442,13 @@  -- | Filesystem operations produced by the generation engine. data Operation-  = WriteFileOp+  = CheckoutOutputOp       { dest :: !FilePath,+        spec :: !CheckoutOutputSpec,+        moduleName :: !ModuleName+      }+  | WriteFileOp+      { dest :: !FilePath,         content :: !Text,         strategy :: !Strategy       }@@ -457,6 +485,7 @@ -- never ask. isAdditiveOperation :: Operation -> Bool isAdditiveOperation (PatchFileOp _ _ op' _ _) = isAdditivePatchOp op'+isAdditiveOperation CheckoutOutputOp {} = False isAdditiveOperation WriteFileOp {} = False isAdditiveOperation CopyFileOp {} = False isAdditiveOperation CreateDirOp {} = False@@ -521,11 +550,18 @@ -- | Tracks the state of generated files for incremental re-generation -- and conflict detection. Stored at @.seihou/manifest.json@. data Manifest = Manifest-  { version :: !Int,+  { -- | The schema the document was read as, or the schema a producer+    -- asserts it can fully express. Decoding an older supported schema+    -- keeps its version here so 'Seihou.Manifest.Types.manifestSupports'+    -- can tell what the file actually proves; the encoder emits the+    -- representation that belongs to this version.+    version :: !ManifestSchemaVersion,     genAt :: !UTCTime,     modules :: ![AppliedModule],     vars :: !(Map VarName Text),     files :: !(Map FilePath FileRecord),+    seeds :: !(Map FilePath SeedRecord),+    checkoutOutputs :: !(Map FilePath CheckoutOutputRecord),     applications :: ![AppliedComposition],     recipe :: !(Maybe AppliedRecipe),     blueprint :: !(Maybe AppliedBlueprint),@@ -533,6 +569,74 @@   }   deriving stock (Eq, Show, Generic) +-- | The numeric schema of @.seihou/manifest.json@. Every semantic change to+-- the serialized manifest advances it (see+-- docs/adr/0014-every-semantic-manifest-change-advances-the-schema-version.md).+-- It is serialized as a bare integer.+newtype ManifestSchemaVersion = ManifestSchemaVersion {unManifestSchemaVersion :: Int}+  deriving stock (Eq, Ord, Show, Generic)++-- | A feature whose behaviour depends on facts only some manifest schemas+-- can express. Each capability names its minimum schema in exactly one+-- place, 'Seihou.Manifest.Types.minimumManifestVersion', so no command+-- carries its own numeric version comparison.+data ManifestCapability+  = -- | A targeted update may leave an unselected co-owner of a path out of+    -- the selection when the path is certified additive-only. Requires the+    -- explicit shared-write evidence introduced by schema 7.+    TargetedAdditiveSharedPathUpdate+  | SeedReceipts+  | CheckoutLocalOutputs+  deriving stock (Eq, Ord, Show, Enum, Bounded, Generic)++-- | What the manifest knows about how the owners of a path write it.+--+-- Schema 6 recorded this as an optional Boolean whose absence meant both+-- "an owner rewrites the whole file" and "this manifest predates the+-- question". Schema 7 keeps the two apart, so the ownership gate can fail+-- closed on 'SharedWriteUnknown' while still knowing the evidence can be+-- established on demand.+data SharedWriteMode+  = -- | Nobody has established the answer yet. Every path decoded from a+    -- schema-6 record without @additiveOnly: true@ starts here.+    SharedWriteUnknown+  | -- | Every contribution to the path goes through an additive,+    -- non-overlapping patch ('isAdditivePatchOp'), so reconciling one+    -- owner cannot disturb another's bytes.+    SharedWriteAdditiveOnly+  | -- | At least one contribution rewrites or repositions the file, so every+    -- owner must be part of any update that touches the path.+    SharedWriteRequiresOwnershipClosure+  deriving stock (Eq, Ord, Show, Enum, Bounded, Generic)++-- | The mode a plan with complete knowledge of every contribution to a path+-- records.+knownSharedWriteMode :: Bool -> SharedWriteMode+knownSharedWriteMode True = SharedWriteAdditiveOnly+knownSharedWriteMode False = SharedWriteRequiresOwnershipClosure++-- | Combine this run's answer for a path with what the manifest held.+--+-- A run that executed every current owner (@partial = False@) knows the+-- whole answer and records it. A run that left a prior owner out knows only+-- its own contributions: a non-additive contribution of its own settles the+-- path as closure-required, but an additive one says nothing about the+-- retained owners, so the prior mode stands. The prior mode can therefore+-- only be kept or weakened here, never strengthened, and an unknown prior+-- stays unknown rather than being guessed.+mergeSharedWriteMode ::+  -- | Did a prior owner survive outside this run?+  Bool ->+  -- | The prior record's mode, if the path had one.+  Maybe SharedWriteMode ->+  -- | Is every contribution this run made additive?+  Bool ->+  SharedWriteMode+mergeSharedWriteMode partial prior candidateAdditive+  | not candidateAdditive = SharedWriteRequiresOwnershipClosure+  | not partial = SharedWriteAdditiveOnly+  | otherwise = fromMaybe SharedWriteUnknown prior+ -- | Stable identity for one top-level module or recipe application. newtype ApplicationId = ApplicationId {unApplicationId :: Text}   deriving stock (Eq, Ord, Show, Generic)@@ -753,12 +857,10 @@     generatedAt :: !UTCTime,     baseline :: !(Maybe BaselineRef),     applicationIds :: !(Set ApplicationId),-    -- | Does /every/ contribution to this path go through an additive,-    -- non-overlapping patch ('isAdditivePatchOp')? When true, reconciling-    -- one owner provably cannot disturb another's bytes, so a targeted-    -- update need not name every owner. Absent from older manifests, where-    -- it decodes as 'False' and the closure keeps being enforced.-    additiveOnly :: !Bool+    -- | How the owners of this path write it. Only+    -- 'SharedWriteAdditiveOnly' lets a targeted update leave a co-owner out+    -- of its selection; the other two keep the ownership closure enforced.+    sharedWriteMode :: !SharedWriteMode   }   deriving stock (Eq, Show, Generic) @@ -867,5 +969,27 @@   { path :: !FilePath,     moduleName :: !ModuleName,     status :: !TrackedFileStatus+  }+  deriving stock (Eq, Show, Generic)++-- | A seed's first settlement, with no content tracking.+data SeedOutcome = SeedCreated | SeedFoundExisting | SeedReleasedFromManaged+  deriving stock (Eq, Ord, Show, Enum, Bounded, Generic)++data SeedRecord = SeedRecord+  { moduleName :: !ModuleName,+    applicationIds :: !(Set ApplicationId),+    outcome :: !SeedOutcome,+    settledAt :: !UTCTime+  }+  deriving stock (Eq, Show, Generic)++-- | A typed, portable specification reconstructed in each working copy.+data CheckoutOutputSpec = DirectorySymlink FilePath+  deriving stock (Eq, Ord, Show, Generic)++data CheckoutOutputRecord = CheckoutOutputRecord+  { spec :: !CheckoutOutputSpec,+    owners :: !(Map ApplicationId (Set ModuleName))   }   deriving stock (Eq, Show, Generic)

@@ -98,7 +98,7 @@       Success m -> do         -- Force lazy decoder thunks that may contain 'error' calls         mapM_ (\v -> evaluate (v ^. #type_)) (m ^. #vars)-        mapM_ (\s -> evaluate (s ^. #strategy) >> evaluate (s ^. #condition) >> mapM_ evaluate (s ^. #patch)) (m ^. #steps)+        mapM_ (\s -> evaluate (s ^. #lifecycle) >> evaluate (s ^. #strategy) >> evaluate (s ^. #condition) >> mapM_ evaluate (s ^. #patch)) (m ^. #steps)         mapM_ (\c -> mapM_ evaluate (c ^. #condition)) (m ^. #commands)         mapM_ (\p -> evaluate (p ^. #condition)) (m ^. #prompts)         pure m@@ -562,8 +562,9 @@       "template" -> Template       "dhall-text" -> DhallText       "structured" -> Structured+      "symlink" -> Symlink       -- Caught by 'try' in 'evalModuleFromFile'-      other -> error ("Unknown strategy \"" <> T.unpack other <> "\"; expected one of: copy, template, dhall-text, structured")+      other -> error ("Unknown strategy \"" <> T.unpack other <> "\"; expected one of: copy, template, dhall-text, structured, symlink")  -- | Decoder for VarDecl from a Dhall record. --@@ -676,23 +677,31 @@ -- The @patch@ field is an optional patch operation string. stepDecoder :: Decoder Step stepDecoder =-  record-    ( mkStep-        <$> field "strategy" strategyDecoder-        <*> field "src" string-        <*> field "dest" strictText-        <*> field "when" (maybe strictText)-        <*> field "patch" (maybe strictText)-    )+  withDefaults [("lifecycle", noneText)] $+    record+      ( mkStep+          <$> field "strategy" strategyDecoder+          <*> field "src" string+          <*> field "dest" strictText+          <*> field "when" (maybe strictText)+          <*> field "patch" (maybe strictText)+          <*> field "lifecycle" (maybe strictText)+      )   where-    mkStep strat src dest whenText patchText =+    mkStep strat src dest whenText patchText lifecycleText =       Step         { strategy = strat,           src = src,           dest = dest,           condition = parseWhen whenText,-          patch = fmap parsePatchOp patchText+          patch = fmap parsePatchOp patchText,+          lifecycle = parseLifecycle lifecycleText         }+    parseLifecycle Nothing = Managed+    parseLifecycle (Just "managed") = Managed+    parseLifecycle (Just "seed") = Seed+    parseLifecycle (Just "checkout") = Checkout+    parseLifecycle (Just other) = error ("Unknown step lifecycle " <> T.unpack other <> "; expected one of: managed, seed, checkout")     parsePatchOp "append-file" = AppendFile     parsePatchOp "prepend-file" = PrependFile     parsePatchOp "append-section" = AppendSection

@@ -1,5 +1,10 @@ module Seihou.Effect.Filesystem   ( Filesystem (..),+    PathEntry (..),+    inspectPath,+    createLink,+    removeLink,+    normalizePath,     readFileText,     writeFileText,     copyFile,@@ -17,7 +22,15 @@  import Seihou.Prelude +-- | A filesystem entry, observed without following its final component.+data PathEntry = EntryMissing | EntryFile | EntryDirectory | EntrySymlink FilePath+  deriving stock (Eq, Show, Generic)+ data Filesystem :: Effect where+  InspectPath :: FilePath -> Filesystem m PathEntry+  CreateDirectoryLink :: FilePath -> FilePath -> Filesystem m ()+  RemoveLink :: FilePath -> Filesystem m ()+  NormalizePath :: FilePath -> Filesystem m FilePath   ReadFileText :: FilePath -> Filesystem m Text   WriteFileText :: FilePath -> Text -> Filesystem m ()   CopyFile :: FilePath -> FilePath -> Filesystem m ()@@ -73,3 +86,15 @@  removeDirectoryRecursive :: (Filesystem :> es) => FilePath -> Eff es () removeDirectoryRecursive path = send (RemoveDirectoryRecursive path)++inspectPath :: (Filesystem :> es) => FilePath -> Eff es PathEntry+inspectPath = send . InspectPath++createLink :: (Filesystem :> es) => FilePath -> FilePath -> Eff es ()+createLink target path = send (CreateDirectoryLink target path)++removeLink :: (Filesystem :> es) => FilePath -> Eff es ()+removeLink = send . RemoveLink++normalizePath :: (Filesystem :> es) => FilePath -> Eff es FilePath+normalizePath = send . NormalizePath

@@ -3,16 +3,31 @@   ) where +import Control.Exception (IOException, catch, throwIO) import Control.Monad (when) import Data.Text.IO qualified as TIO-import Seihou.Effect.Filesystem (Filesystem (..))+import Seihou.Effect.Filesystem (Filesystem (..), PathEntry (..)) import Seihou.Prelude import System.Directory qualified as Dir+import System.IO.Error (isDoesNotExistError)  -- | Real IO interpreter for the Filesystem effect. -- Delegates to System.Directory and Data.Text.IO. runFilesystem :: (IOE :> es) => Eff (Filesystem : es) a -> Eff es a runFilesystem = interpret $ \_ -> \case+  InspectPath path -> liftIO $ do+    linked <- Dir.pathIsSymbolicLink path `catch` \(err :: IOException) -> if isDoesNotExistError err then pure False else throwIO err+    if linked+      then EntrySymlink <$> Dir.getSymbolicLinkTarget path+      else do+        directory <- Dir.doesDirectoryExist path+        file <- Dir.doesFileExist path+        pure (if directory then EntryDirectory else if file then EntryFile else EntryMissing)+  CreateDirectoryLink target path -> liftIO (Dir.createDirectoryLink target path)+  RemoveLink path -> liftIO $ do+    linked <- Dir.pathIsSymbolicLink path+    if linked then Dir.removeDirectoryLink path else ioError (userError "refusing to unlink a regular entry")+  NormalizePath path -> liftIO (Dir.canonicalizePath path)   ReadFileText path -> liftIO (TIO.readFile path)   WriteFileText path content -> liftIO (TIO.writeFile path content)   CopyFile src dest -> liftIO (Dir.copyFile src dest)

@@ -9,19 +9,20 @@ import Data.Map.Strict qualified as Map import Data.Set qualified as Set import Effectful.State.Static.Local (State, get, modify, put, runState)-import Seihou.Effect.Filesystem (Filesystem (..))+import Seihou.Effect.Filesystem (Filesystem (..), PathEntry (..)) import Seihou.Prelude  -- | In-memory filesystem state for testing. data PureFS = PureFS   { files :: !(Map FilePath Text),-    dirs :: !(Set FilePath)+    dirs :: !(Set FilePath),+    links :: !(Map FilePath FilePath)   }   deriving stock (Eq, Generic, Show)  -- | An empty in-memory filesystem. emptyFS :: PureFS-emptyFS = PureFS Map.empty Set.empty+emptyFS = PureFS Map.empty Set.empty Map.empty  -- | Pure in-memory interpreter for the Filesystem effect. -- Useful for testing without touching the real filesystem.@@ -30,6 +31,21 @@   where     handler :: (State PureFS :> es') => EffectHandler Filesystem es'     handler _ = \case+      InspectPath path -> do+        fs <- get @PureFS+        pure $ case Map.lookup path (fs ^. #links) of+          Just target -> EntrySymlink target+          Nothing+            | Map.member path (fs ^. #files) -> EntryFile+            | Set.member path (fs ^. #dirs) -> EntryDirectory+            | otherwise -> EntryMissing+      CreateDirectoryLink target path -> do+        fs <- get @PureFS+        if Map.member path (fs ^. #links) || Map.member path (fs ^. #files) || Set.member path (fs ^. #dirs)+          then error ("runFilesystemPure: destination exists: " <> path)+          else modify @PureFS (#links %~ Map.insert path target)+      RemoveLink path -> modify @PureFS (#links %~ Map.delete path)+      NormalizePath path -> pure path       ReadFileText path -> do         fs <- get @PureFS         case Map.lookup path (fs ^. #files) of@@ -48,7 +64,7 @@         let prefix = if null path then "" else path <> "/"             filesInDir =               [ drop (length prefix) fp-              | fp <- Map.keys (fs ^. #files),+              | fp <- Map.keys (fs ^. #files) <> Map.keys (fs ^. #links),                 isDirectChild prefix fp               ]             dirsInDir =@@ -114,6 +130,8 @@         .~ renamedFiles         & #dirs         .~ renamedDirs+        & #links+        %~ Map.mapKeys (renameKey src dest)   where     renameKey s d k       | k == s = d@@ -129,6 +147,8 @@       keepDir d = d /= path && not (prefix `isPrefixOfPath` d)    in fs         & #files+        %~ Map.filterWithKey (\k _ -> keepFile k)+        & #links         %~ Map.filterWithKey (\k _ -> keepFile k)         & #dirs         %~ Set.filter keepDir

@@ -0,0 +1,239 @@+module Seihou.Engine.Checkout+  ( observeCheckoutOutputs,+    prepareCheckoutPlan,+    prepareCheckoutApplication,+    applyCheckoutPlan,+    applyCheckoutPlanWithHook,+    rollbackCheckout,+    CheckoutExecution (..),+    CheckoutUndo (..),+    checkoutGitRoot,+    safeCheckoutManifest,+  )+where++import Control.Exception (IOException)+import Control.Monad (foldM, forM, forM_, unless, when)+import Data.Generics.Labels ()+import Data.List (sortOn)+import Data.Map.Strict qualified as Map+import Data.Maybe (maybeToList)+import Data.Set qualified as Set+import Data.Text qualified as T+import Effectful.Exception qualified as E+import Seihou.Core.Checkout+import Seihou.Core.Types+import Seihou.Effect.Filesystem+import Seihou.Effect.Process+import Seihou.Prelude+import System.Exit (ExitCode (..))+import System.FilePath.Posix qualified as P++checkoutGitRoot :: (Filesystem :> es, Process :> es, IOE :> es) => FilePath -> Eff es (Maybe FilePath)+checkoutGitRoot root = do+  result <- E.try @IOException (runProcess "git" ["rev-parse", "--show-toplevel"] (Just root))+  case result of+    Right (ExitSuccess, path, _) -> Just <$> normalizePath (T.unpack (T.stripEnd path))+    _ -> pure Nothing++-- | Inspect metadata before opening it; a manifest must be a real file.+safeCheckoutManifest :: (Filesystem :> es) => FilePath -> Eff es (Either CheckoutError ())+safeCheckoutManifest root = do+  dir <- inspectPath (root </> ".seihou")+  file <- if dir == EntryDirectory then inspectPath (root </> ".seihou/manifest.json") else pure EntryMissing+  pure $+    if dir == EntryDirectory && file == EntryFile+      then Right ()+      else Left (checkoutError "checkout_manifest_unsafe" "require a real .seihou directory and manifest.json file; run seihou run to record declarations, or move symlinked metadata aside")++ancestors :: FilePath -> [FilePath]+ancestors path = reverse (go (P.takeDirectory path))+  where+    go "." = []; go "" = []; go p = p : go (P.takeDirectory p)++-- | Observe entries themselves, never the targets of destination symlinks.+observeCheckoutOutputs :: (Filesystem :> es, Process :> es, IOE :> es) => FilePath -> Map FilePath CheckoutOutputRecord -> Map FilePath CheckoutOutputRecord -> Eff es (Map FilePath CheckoutObservation)+observeCheckoutOutputs root prior candidate = do+  gitRoot <- checkoutGitRoot root+  indexed <- case gitRoot of+    Nothing -> pure (Right [])+    Just _ -> do+      (code, out, _) <- runProcess "git" ["ls-files", "--cached", "-z"] (Just root)+      pure $ if code == ExitSuccess then Right (map T.unpack (filter (not . T.null) (T.splitOn "\0" out))) else Left (checkoutError "checkout_git_unavailable" "cannot inspect Git's index")+  metadataAlias <- inspectPath (root </> ".GIT")+  let nativeOverlap a b = pathsOverlap a b || (metadataAlias /= EntryMissing && pathsOverlap (T.unpack (T.toCaseFold (T.pack a))) (T.unpack (T.toCaseFold (T.pack b))))+  pairs <- forM allPaths $ \dest -> do+    let active = Map.lookup dest candidate+        record = case active of Just r -> r; Nothing -> prior Map.! dest+        source = checkoutSource (record ^. #spec)+    result <- E.try @IOException $ do+      parentProblems <- (<>) <$> checkAncestors (ancestors dest) <*> (if active == Nothing then pure [] else checkAncestors (ancestors source))+      entry <- if null parentProblems then inspectPath (root </> dest) else pure EntryMissing+      sourceEntry <- if active == Nothing || not (null parentProblems) then pure EntryMissing else inspectPath (root </> source)+      sourceAlias <- if active == Nothing || not (null parentProblems) then pure [] else checkSpelling source+      destAlias <- if null parentProblems then checkSpelling dest else pure []+      (ignored, ignoreProblems) <-+        if gitRoot == Nothing+          then pure (False, [])+          else do+            (code, _, _) <- runProcess "git" ["check-ignore", "-q", "--", "./" <> T.pack dest] (Just root)+            pure $ case code of+              ExitSuccess -> (True, [])+              ExitFailure 1 -> (False, [])+              _ -> (False, [checkoutError "checkout_git_unavailable" "cannot inspect ignore rules; check Git configuration"])++      let trackedProblems = case indexed of+            Left err -> [err]+            Right paths -> [checkoutError "checkout_path_tracked" "destination overlaps a tracked path (including an indexed ancestor); change the declaration or untrack it explicitly" | any (nativeOverlap dest) paths]+          aliasClaims =+            [ checkoutError "checkout_native_alias" "checkout declarations have ambiguous case spellings; use distinct portable destinations"+            | any (\other -> other /= dest && T.toCaseFold (T.pack other) == T.toCaseFold (T.pack dest)) allPaths+            ]+      pure (CheckoutObservation entry (sourceEntry == EntryDirectory) (parentProblems <> trackedProblems <> ignoreProblems <> sourceAlias <> destAlias <> aliasClaims <> [checkoutError "checkout_source_not_directory" "source is not a real directory; move the object aside" | active /= Nothing, sourceEntry `notElem` [EntryMissing, EntryDirectory]]) (gitRoot /= Nothing) ignored)+    pure+      ( dest,+        case result of+          Right obs -> obs+          Left err -> CheckoutObservation EntryMissing False [checkoutError "checkout_path_inaccessible" ("cannot inspect '" <> T.pack dest <> "': " <> T.pack (show err))] (gitRoot /= Nothing) False+      )+  pure (Map.fromList pairs)+  where+    allPaths = Set.toAscList (Map.keysSet prior <> Map.keysSet candidate)+    checkAncestors [] = pure []+    checkAncestors (path : rest) =+      inspectPath (root </> path) >>= \case+        EntrySymlink _ -> pure [checkoutError "checkout_parent_symlink" ("ancestor '" <> T.pack path <> "' is a symlink; replace it with a real directory")]+        EntryFile -> pure [checkoutError "checkout_parent_not_directory" ("ancestor '" <> T.pack path <> "' is a file; move it aside")]+        EntryMissing -> pure []+        EntryDirectory -> checkAncestors rest+    -- Native path lookup may accept a different spelling on case-insensitive volumes.+    checkSpelling path = fmap concat $ forM (ancestors path <> [path]) $ \part -> do+      parent <- inspectPath (root </> P.takeDirectory part)+      if parent /= EntryDirectory+        then pure []+        else do+          names <- listDirectory (root </> P.takeDirectory part)+          exists <- inspectPath (root </> part)+          pure [checkoutError "checkout_native_alias" ("path '" <> T.pack part <> "' resolves through a different native spelling") | exists /= EntryMissing, P.takeFileName part `notElem` names]++prepareCheckoutPlan :: (Filesystem :> es, Process :> es, IOE :> es) => CheckoutIntent -> CheckoutPolicy -> FilePath -> Manifest -> Manifest -> [FilePath] -> Eff es (Either CheckoutError CheckoutPlan)+prepareCheckoutPlan intent policy root prior candidate pending = case validateCheckoutRecords candidate pending of+  Left err -> pure (Left err)+  Right () -> do+    observations <- observeCheckoutOutputs root (prior ^. #checkoutOutputs) (candidate ^. #checkoutOutputs)+    pure (Right (planCheckoutOutputs intent policy (prior ^. #checkoutOutputs) (candidate ^. #checkoutOutputs) observations))++-- | An undo entry describes only this attempt's own writes.+data CheckoutUndo = CheckoutUndo+  {dest :: !FilePath, before :: !PathEntry, after :: !PathEntry, parents :: ![FilePath]}+  deriving stock (Eq, Show, Generic)++data CheckoutExecution = CheckoutExecution+  {outcomes :: !(Map FilePath Text), undo :: ![CheckoutUndo], failure :: !(Maybe CheckoutError)}+  deriving stock (Eq, Show, Generic)++rollbackCheckout :: (Filesystem :> es, IOE :> es) => FilePath -> [CheckoutUndo] -> Eff es (Map FilePath Text)+rollbackCheckout root writes =+  Map.fromList+    <$> forM+      writes+      ( \write -> do+          result <- E.try @IOException $ do+            let path = root </> (write ^. #dest)+            parentsSafe <- and <$> mapM (\p -> (== EntryDirectory) <$> inspectPath (root </> p)) (ancestors (write ^. #dest))+            current <- if parentsSafe then inspectPath path else pure EntryFile+            if current /= write ^. #after+              then pure "rollback-conflicted"+              else do+                case current of EntrySymlink _ -> removeLink path; _ -> pure ()+                case write ^. #before of EntrySymlink target -> createLink target path; _ -> pure ()+                forM_ (reverse (write ^. #parents)) (\p -> inspectPath (root </> p) >>= \kind -> when (kind == EntryDirectory) (removeDirectoryIfEmpty (root </> p)))+                pure "rolled-back"+          pure (write ^. #dest, either (const "rollback-conflicted") id result)+      )++-- | Recheck immediately before mutation. Supports a single cooperating writer;+-- portable path checks do not protect against hostile concurrent substitution.+applyCheckoutPlan :: (Filesystem :> es, Process :> es, IOE :> es) => CheckoutPolicy -> FilePath -> CheckoutPlan -> Eff es CheckoutExecution+applyCheckoutPlan = applyCheckoutPlanWithHook (const (pure ()))++-- | Failure injection after each completed link mutation, for rollback contract tests.+applyCheckoutPlanWithHook :: (Filesystem :> es, Process :> es, IOE :> es) => (Int -> Eff es ()) -> CheckoutPolicy -> FilePath -> CheckoutPlan -> Eff es CheckoutExecution+applyCheckoutPlanWithHook afterMutation policy root plan+  | not (checkoutApplicable plan) = pure (CheckoutExecution Map.empty [] (Just (checkoutError "checkout_preflight_refused" "checkout preflight refused; no outputs were changed")))+  | otherwise = go Map.empty [] (plan ^. #entries)+  where+    go outcomes writes [] = pure (CheckoutExecution outcomes writes Nothing)+    go outcomes writes (entry : rest)+      | entry ^. #action `notElem` [CreateLink, ReplaceLink, RetireLink] = go (Map.insert (entry ^. #dest) "unchanged" outcomes) writes rest+      | otherwise = do+          let dest = entry ^. #dest+              toMap spec = Map.singleton dest (CheckoutOutputRecord spec Map.empty)+              old = maybe Map.empty toMap (entry ^. #previous)+              new = maybe Map.empty toMap (entry ^. #candidate)+              expected = maybe EntryMissing (EntrySymlink . expectedTarget dest) (entry ^. #candidate)+          result <- E.try @IOException $ do+            observations <- observeCheckoutOutputs root old new+            let observed = observations Map.! dest+                changed = observed ^. #entry /= entry ^. #observation . #entry+                errors =+                  observed ^. #problems+                    <> [checkoutError "checkout_source_missing" "source directory disappeared" | entry ^. #candidate /= Nothing, not (observed ^. #sourceDirectory)]+                    <> [checkoutError "checkout_not_ignored" "destination is no longer ignored" | policy == SyncIgnoredOnly, entry ^. #candidate /= Nothing, not (observed ^. #ignored)]+                    <> [checkoutError "checkout_git_required" "Git evidence disappeared" | policy == SyncIgnoredOnly, not (observed ^. #gitAvailable)]+            when (changed || not (null errors)) $ E.throwIO (userError ("checkout precondition changed for " <> dest))+            missingParents <- filterM (\p -> (== EntryMissing) <$> inspectPath (root </> p)) (ancestors dest)+            -- Record and undo even a failure after unlink or during parent creation.+            let write = CheckoutUndo dest (observed ^. #entry) expected missingParents+            mutate <- E.try @IOException $ do+              forM_ missingParents (createDirectoryIfMissing False . (root </>))+              case entry ^. #action of+                CreateLink -> createLink (linkText entry) (root </> dest)+                ReplaceLink -> do+                  removeLink (root </> dest)+                  createLink (linkText entry) (root </> dest) `E.onException` createLink (oldText observed) (root </> dest)+                RetireLink -> removeLink (root </> dest)+                _ -> pure ()+            case mutate of+              Left err -> do+                forM_ (reverse missingParents) (\p -> inspectPath (root </> p) >>= \kind -> when (kind == EntryDirectory) (removeDirectoryIfEmpty (root </> p)))+                E.throwIO err+              Right () -> pure write+          case result of+            Right write -> do+              hooked <- E.try @IOException (afterMutation (length writes + 1))+              case hooked of+                Right () -> go (Map.insert dest "applied" outcomes) (write : writes) rest+                Left err -> do+                  reverted <- rollbackCheckout root (write : writes)+                  pure (CheckoutExecution (Map.union reverted outcomes) [] (Just (checkoutError "checkout_apply_failed" (T.pack (show err)))))+            Left err -> do+              reverted <- rollbackCheckout root writes+              pure (CheckoutExecution (Map.insert dest "failed" (Map.union reverted outcomes)) [] (Just (checkoutError "checkout_apply_failed" ("cannot apply '" <> T.pack dest <> "': " <> T.pack (show err) <> "; check symlink permissions and retry"))))+    linkText entry = case entry ^. #candidate of Just spec -> expectedTarget (entry ^. #dest) spec; Nothing -> ""+    oldText observed = case observed ^. #entry of EntrySymlink target -> target; _ -> ""++filterM :: (Monad m) => (a -> m Bool) -> [a] -> m [a]+filterM predicate = foldM (\acc x -> predicate x >>= \keep -> pure (if keep then acc <> [x] else acc)) []++-- | Before ordinary generation, a source directory may be scheduled to appear+-- through deterministic file output. Shell commands cannot satisfy this dependency.+prepareCheckoutApplication :: (Filesystem :> es, Process :> es, IOE :> es) => FilePath -> Manifest -> Manifest -> [Operation] -> Eff es (Either CheckoutError CheckoutPlan)+prepareCheckoutApplication root prior candidate operations = case validateCheckoutRecords candidate bytePaths of+  Left err -> pure (Left err)+  Right () -> do+    observed <- observeCheckoutOutputs root (prior ^. #checkoutOutputs) (candidate ^. #checkoutOutputs)+    let allowGenerated dest obs = case Map.lookup dest (candidate ^. #checkoutOutputs) of+          Just record | any (\path -> T.pack (checkoutSource (record ^. #spec) <> "/") `T.isPrefixOf` T.pack path) bytePaths -> obs & #sourceDirectory .~ True+          _ -> obs+    pure (Right (planCheckoutOutputs Reconcile ApplyDeclaration (prior ^. #checkoutOutputs) (candidate ^. #checkoutOutputs) (Map.mapWithKey allowGenerated observed)))+  where+    bytePaths =+      [ dest+      | op <- operations,+        dest <- case op of+          WriteFileOp {dest} -> [dest]+          CopyFileOp {dest} -> [dest]+          PatchFileOp {dest} -> [dest]+          _ -> []+      ]

@@ -22,10 +22,12 @@ -- map fall back to the default @moduleName'@ — this preserves single- -- module call-sites and test usage that do not build an ownership map. ----- Each record's @additiveOnly@ is folded across /every/ operation that+-- Each record's shared-write mode is folded across /every/ operation that -- targets the same destination, so a path a module both writes and patches--- records 'False'. Only a path reached exclusively through additive patches--- records 'True'.+-- records 'SharedWriteRequiresOwnershipClosure'. Only a path reached+-- exclusively through additive patches records 'SharedWriteAdditiveOnly'.+-- The answer covers this plan's operations only; callers that retain prior+-- owners merge it with 'mergeSharedWriteMode'. executePlan ::   (Filesystem :> es) =>   FilePath ->@@ -36,8 +38,8 @@   Eff es (Map FilePath FileRecord) executePlan targetDir ops ownerMap moduleName' now = do   let ownerFor dest = Map.findWithDefault moduleName' dest ownerMap-      additiveFor dest = Map.findWithDefault False dest additiveMap-  records <- mapM (executeOp targetDir ownerFor additiveFor now) ops+      modeFor dest = knownSharedWriteMode (Map.findWithDefault False dest additiveMap)+  records <- mapM (executeOp targetDir ownerFor modeFor now) ops   pure (Map.fromList [(k, v) | Just (k, v) <- records])   where     additiveMap =@@ -53,6 +55,7 @@ operationDestination (WriteFileOp dest _ _) = Just dest operationDestination (CopyFileOp _ dest) = Just dest operationDestination (PatchFileOp dest _ _ _ _) = Just dest+operationDestination CheckoutOutputOp {} = Nothing operationDestination CreateDirOp {} = Nothing operationDestination RunCommandOp {} = Nothing @@ -61,11 +64,12 @@   (Filesystem :> es) =>   FilePath ->   (FilePath -> ModuleName) ->-  (FilePath -> Bool) ->+  (FilePath -> SharedWriteMode) ->   UTCTime ->   Operation ->   Eff es (Maybe (FilePath, FileRecord))-executeOp targetDir ownerFor additiveFor now op = case op of+executeOp targetDir ownerFor modeFor now op = case op of+  CheckoutOutputOp {} -> pure Nothing   WriteFileOp dest content strat -> do     let fullPath = targetDir </> dest     writeFileText fullPath content@@ -77,7 +81,7 @@               generatedAt = now,               baseline = Nothing,               applicationIds = mempty,-              additiveOnly = additiveFor dest+              sharedWriteMode = modeFor dest             }     pure (Just (dest, record))   CreateDirOp path -> do@@ -96,7 +100,7 @@               generatedAt = now,               baseline = Nothing,               applicationIds = mempty,-              additiveOnly = additiveFor dest+              sharedWriteMode = modeFor dest             }     pure (Just (dest, record))   RunCommandOp {} -> do@@ -123,7 +127,7 @@                   generatedAt = now,                   baseline = Nothing,                   applicationIds = mempty,-                  additiveOnly = additiveFor dest+                  sharedWriteMode = modeFor dest                 }         pure (Just (dest, record)) @@ -136,6 +140,7 @@   where     formatOp :: Operation -> Text     formatOp (WriteFileOp dest _ _) = "  write " <> T.pack dest+    formatOp (CheckoutOutputOp dest (DirectorySymlink source) _) = "  link  " <> T.pack dest <> " -> " <> T.pack source     formatOp (CreateDirOp path) = "  mkdir " <> T.pack path     formatOp (CopyFileOp src dest) = "  copy  " <> T.pack src <> " -> " <> T.pack dest     formatOp RunCommandOp {command = cmd} = "  run   " <> cmd

@@ -20,7 +20,9 @@ import Dhall qualified import Dhall.Core qualified as DhallCore import Dhall.Src (Src)+import Seihou.Core.Checkout (CheckoutError (..), validateCheckoutPaths) import Seihou.Core.Expr (evalExpr)+import Seihou.Core.Module (checkCheckoutSteps, checkSeedSteps) import Seihou.Core.Path (validateProjectRelativePath) import Seihou.Core.Types import Seihou.Engine.DhallJSON (dhallExprToJSON)@@ -38,7 +40,10 @@   IO (Either [Text] [Operation]) compilePlan baseDir modul vars = do   let modName = (modul ^. #name)-  results <- mapM (compileStep baseDir modName vars) (modul ^. #steps)+  results <-+    if null (checkSeedSteps modul <> checkCheckoutSteps modul)+      then mapM (compileStep baseDir modName vars) (modul ^. #steps)+      else pure [Left (checkSeedSteps modul <> checkCheckoutSteps modul)]   let (allErrors, allOps) = partitionResults results   if null allErrors     then case compileCommands modName vars (modul ^. #commands) of@@ -115,6 +120,12 @@         Template -> compileTemplateStep baseDir vars step         DhallText -> compileDhallTextStep baseDir vars step         Structured -> compileStructuredStep baseDir vars step+        Symlink -> pure $ case (renderCommand (T.pack (step ^. #src)) vars, renderCommand (step ^. #dest) vars) of+          (Right source, Right dest) -> case validateCheckoutPaths (T.unpack source) (T.unpack dest) of+            Left err -> Left [err ^. #message]+            Right () -> Right [CheckoutOutputOp (T.unpack dest) (DirectorySymlink (T.unpack source)) modName]+          (Left errors, _) -> Left (map formatPlaceholderError errors)+          (_, Left errors) -> Left (map formatPlaceholderError errors)  -- | Compile a Copy step: read the source file and write it to the destination. compileCopyStep ::

@@ -32,6 +32,7 @@         annotation :: !Text,         module_ :: !(Maybe ModuleName)       }+  | LinkPreview FilePath FilePath   | DirPreview FilePath   | CommandPreview Text (Maybe ModuleName)   | OrphanPreview FilePath ModuleName@@ -72,6 +73,7 @@       annotation = strategyName strat,       module_ = Map.lookup dest ownerMap     }+opToPreview _ _ _ (CheckoutOutputOp dest (DirectorySymlink source) _) = LinkPreview dest source opToPreview _ _ _ (CreateDirOp path) = DirPreview path opToPreview mDiff ownerMap _ (CopyFileOp _ dest) =   FilePreview@@ -128,6 +130,7 @@ renderPlainLine _ other = renderNonFileLine other  renderNonFileLine :: PreviewLine -> Text+renderNonFileLine (LinkPreview dest source) = "    link   " <> T.pack dest <> " -> " <> T.pack source renderNonFileLine (DirPreview path) =   "    mkdir  " <> T.pack path renderNonFileLine (CommandPreview cmd mOwner) =@@ -155,6 +158,7 @@ strategyName Template = "template" strategyName DhallText = "dhall-text" strategyName Structured = "structured"+strategyName Symlink = "symlink"  -- | Format a complete plan view with header, variables, operations, and summary. formatPlanView :: [ModuleName] -> Map VarName VarValue -> [PreviewLine] -> DiffResult -> Text

@@ -18,6 +18,7 @@     reconciliationSummary,     reconciliationMutationPaths,     unresolvedPaths,+    recordedSharedWriteMode,   ) where @@ -121,6 +122,25 @@   }   deriving stock (Eq, Generic, Show) +-- | The shared-write mode an update records for a desired path, given the+-- applications it selected and the path's prior record.+--+-- Owners outside the selection are retained, and when any survive this run+-- knows only its own contributions, so the prior mode can be kept or+-- weakened but never strengthened ('mergeSharedWriteMode'). Both the+-- manifest writer ('Seihou.Engine.UpdateTransaction') and the no-op checks+-- use this one function so they cannot disagree about whether a plan would+-- change the record.+recordedSharedWriteMode :: Set ApplicationId -> DesiredFile -> Maybe FileRecord -> SharedWriteMode+recordedSharedWriteMode selected desired prior =+  mergeSharedWriteMode partial ((^. #sharedWriteMode) <$> prior) (desired ^. #additiveOnly)+  where+    -- Subtracting the /selection/ rather than the desired set matters: a+    -- selected application that stopped writing the path must genuinely lose+    -- ownership, while an unselected one must keep it.+    retainedOwners = maybe Set.empty (^. #applicationIds) prior Set.\\ selected+    partial = not (Set.null retainedOwners)+ data ReconciliationError   = InvalidReconciliationPath FilePath Text   | MissingDesiredOwner FilePath@@ -289,7 +309,7 @@         Nothing -> Right ()         Just record           | Set.null ((record ^. #applicationIds) Set.\\ selected) -> Right ()-          | record ^. #additiveOnly && all isAdditiveOperation pathOperations -> Right ()+          | record ^. #sharedWriteMode == SharedWriteAdditiveOnly && all isAdditiveOperation pathOperations -> Right ()           | otherwise -> Left (SharedPathRequiresApplications path (record ^. #applicationIds))  validateManagedPath :: FilePath -> Either ReconciliationError ()

@@ -5,6 +5,8 @@     RemovalOp (..),     RemovalFileStatus (..),     ExecutedRemovalPlan (..),+    CheckoutRemovalSelection (..),+    selectCheckoutRemoval,     computeRemovalPlan,     executeRemoval,     buildRemovalOps,@@ -16,11 +18,14 @@ import Data.Generics.Labels () import Data.List (nub, sortBy) import Data.Map.Strict qualified as Map+import Data.Maybe (listToMaybe, mapMaybe, maybeToList) import Data.Ord (Down (..)) import Data.Set (Set) import Data.Set qualified as Set import Data.Text qualified as T import Data.Time (UTCTime)+import Seihou.Composition.Instance (ModuleInstance (..), qualifiedName)+import Seihou.Core.Checkout import Seihou.Core.Path (validateProjectRelativePath) import Seihou.Core.Types import Seihou.Effect.Filesystem (Filesystem, doesFileExist, readFileText, removeDirectoryIfEmpty, removeFile, writeFileText)@@ -109,7 +114,10 @@   case findApplied manifest modName of     Nothing -> pure (Left (ModuleNotApplied modName))     Just am-      | Nothing <- am ^. #removal -> pure (Left (ModuleNotRemovable modName))+      | Nothing <- am ^. #removal ->+          if any (\record -> any (Set.member modName) (Map.elems (record ^. #owners))) (Map.elems (manifest ^. #checkoutOutputs))+            then pure (Right (RemovalPlan modName []))+            else pure (Left (ModuleNotRemovable modName))       | otherwise -> do           let ownedFiles = moduleFiles manifest modName           classified <- mapM classifyForRemoval ownedFiles@@ -357,3 +365,56 @@     %~ Map.filter (\rec -> rec ^. #moduleName /= modName)     & #genAt     .~ now++-- | A single recorded application/instance selected for checkout cleanup.+data CheckoutRemovalSelection = CheckoutRemovalSelection+  { applicationId :: !ApplicationId,+    instanceName :: !ModuleName,+    moduleName :: !ModuleName,+    removal :: !(Maybe Removal),+    candidateManifest :: !Manifest+  }+  deriving stock (Eq, Show, Generic)++-- | Resolve a name against recorded qualified instances, never installed modules.+-- Ambiguous bare names and application choices require explicit selection.+selectCheckoutRemoval :: Manifest -> ModuleName -> Maybe ApplicationId -> Either CheckoutError (Maybe CheckoutRemovalSelection)+selectCheckoutRemoval manifest requested selectedApplication = case candidates of+  []+    | selectedApplication /= Nothing -> Left (checkoutError "checkout_remove_selection" "no matching checkout-owning instance in the selected application")+    | otherwise -> Right Nothing+  [(app, state, qualified)] -> do+    let appId = app ^. #applicationId+        selected = Map.singleton appId (Set.singleton qualified)+        outputs = dropCheckoutOwners selected (manifest ^. #checkoutOutputs)+        keepFile record+          | record ^. #moduleName /= qualified || not (Set.member appId (record ^. #applicationIds)) = Just record+          | otherwise =+              let retained = Set.delete appId (record ^. #applicationIds)+               in if Set.null retained then Nothing else Just (record & #applicationIds .~ retained)+        keepApplication other+          | other ^. #applicationId /= appId = Just other+          | otherwise =+              let retained = filter (\instanceState -> qualifiedName (ModuleInstance (instanceState ^. #name) (instanceState ^. #parentVars)) /= qualified) (other ^. #instances)+               in if null retained then Nothing else Just (other & #instances .~ retained & #commandReceipts %~ Map.filter ((/= qualified) . (^. #moduleName)))+        applications = mapMaybe keepApplication (manifest ^. #applications)+        files = Map.mapMaybe keepFile (manifest ^. #files)+        stillNeeded applied =+          any (\other -> any (\instanceState -> instanceState ^. #name == applied ^. #name && instanceState ^. #parentVars == applied ^. #parentVars) (other ^. #instances)) applications+            || any ((== qualifiedName (ModuleInstance (applied ^. #name) (applied ^. #parentVars))) . (^. #moduleName)) (Map.elems files)+        removeSelected applied = applied ^. #name /= state ^. #name || applied ^. #parentVars /= state ^. #parentVars || stillNeeded applied+        candidate = manifest & #checkoutOutputs .~ outputs & #applications .~ applications & #files .~ files & #modules %~ filter removeSelected+        custom = listToMaybe [spec | applied <- manifest ^. #modules, applied ^. #name == state ^. #name, applied ^. #parentVars == state ^. #parentVars, spec <- maybeToList (applied ^. #removal)]+    validateCheckoutRecords candidate []+    pure (Just (CheckoutRemovalSelection appId qualified (state ^. #name) custom candidate))+  matches -> Left (checkoutError "checkout_remove_ambiguous" ("checkout removal is ambiguous; select one recorded instance/application: " <> T.intercalate "; " ["seihou remove " <> qualified ^. #unModuleName <> " --application " <> app ^. #applicationId . #unApplicationId | (app, _, qualified) <- matches]))+  where+    candidates =+      [ (app, state, qualified)+      | app <- manifest ^. #applications,+        maybe True (== app ^. #applicationId) selectedApplication,+        state <- app ^. #instances,+        let qualified = qualifiedName (ModuleInstance (state ^. #name) (state ^. #parentVars)),+        requested == qualified || requested == state ^. #name,+        any (\record -> Set.member qualified (Map.findWithDefault Set.empty (app ^. #applicationId) (record ^. #owners))) (Map.elems (manifest ^. #checkoutOutputs))+      ]

@@ -15,6 +15,7 @@ import Control.Monad (foldM, forM, forM_, unless, when) import Data.Aeson (FromJSON (..), ToJSON (..), (.:), (.:?), (.=)) import Data.Aeson qualified as Aeson+import Data.Aeson.Types qualified as Aeson import Data.ByteString.Lazy qualified as LBS import Data.Foldable (traverse_) import Data.Generics.Labels ()@@ -28,6 +29,7 @@ import Seihou.Core.Types import Seihou.Effect.BaselineStore (putBaseline) import Seihou.Effect.BaselineStoreInterp (runBaselineStore)+import Seihou.Effect.Filesystem (PathEntry (..), inspectPath) import Seihou.Effect.FilesystemInterp (runFilesystem) import Seihou.Engine.Reconcile import Seihou.Manifest.Hash (hashContent)@@ -59,7 +61,8 @@  data JournalEntry = JournalEntry   { targetPath :: !FilePath,-    backupFile :: !(Maybe FilePath)+    backupFile :: !(Maybe FilePath),+    linkTarget :: !(Maybe FilePath)   }   deriving stock (Eq, Generic, Show) @@ -76,12 +79,30 @@   toJSON entry =     Aeson.object       [ "path" .= (entry ^. #targetPath),-        "backup" .= (entry ^. #backupFile)+        "backup" .= (entry ^. #backupFile),+        "target" .= (entry ^. #linkTarget),+        "kind"+          .= ( case (entry ^. #backupFile, entry ^. #linkTarget) of+                 (_, Just _) -> "symlink" :: Text+                 (Just _, _) -> "file"+                 _ -> "absent"+             )       ] -instance FromJSON JournalEntry where-  parseJSON = Aeson.withObject "JournalEntry" $ \object ->-    JournalEntry <$> object .: "path" <*> object .:? "backup"+parseJournalEntry :: Int -> Aeson.Value -> Aeson.Parser JournalEntry+parseJournalEntry version = Aeson.withObject "JournalEntry" $ \object -> do+  path <- object .: "path"+  backup <- object .:? "backup"+  if version == 1+    then pure (JournalEntry path backup Nothing)+    else do+      kind <- object .: "kind" :: Aeson.Parser Text+      target <- object .:? "target"+      case (kind, backup, target) of+        ("absent", Nothing, Nothing) -> pure (JournalEntry path Nothing Nothing)+        ("file", Just _, Nothing) -> pure (JournalEntry path backup Nothing)+        ("symlink", Nothing, Just _) -> pure (JournalEntry path Nothing target)+        _ -> fail "unknown or malformed transaction entry kind"  instance ToJSON JournalMetadata where   toJSON metadata =@@ -96,11 +117,11 @@ instance FromJSON JournalMetadata where   parseJSON = Aeson.withObject "JournalMetadata" $ \object -> do     version <- object .: "version"-    unless (version == 1) (fail "unsupported transaction journal version")+    unless (version `elem` [1, 2]) (fail "unsupported transaction journal version")     JournalMetadata       <$> pure version       <*> object .: "createdAt"-      <*> object .: "entries"+      <*> (mapM (parseJournalEntry version) =<< object .: "entries")       <*> object .: "newDirectories"       <*> object .:? "expectedManifest" @@ -125,18 +146,21 @@     let fullPath = transaction ^. #projectRoot </> relativePath         backupName = show index <> ".txt"         backupPath = backupDirectory </> backupName-    exists <- Directory.doesFileExist fullPath-    if exists-      then do+    verifySafeParents (transaction ^. #projectRoot) relativePath+    entry <- runEff $ runFilesystem $ inspectPath fullPath+    case entry of+      EntrySymlink target -> pure (JournalEntry relativePath Nothing (Just target))+      EntryFile -> do         TIO.readFile fullPath >>= TIO.writeFile backupPath-        pure (JournalEntry relativePath (Just backupName))-      else pure (JournalEntry relativePath Nothing)+        pure (JournalEntry relativePath (Just backupName) Nothing)+      EntryMissing -> pure (JournalEntry relativePath Nothing Nothing)+      EntryDirectory -> ioError (userError ("transaction target is a directory: " <> relativePath))   missingDirectories <- missingParentDirectories (transaction ^. #projectRoot) safeTargets   now <- getCurrentTime   writeJournal     (transaction ^. #transactionDirectory)     JournalMetadata-      { journalVersion = 1,+      { journalVersion = 2,         createdAt = now,         entries = entries,         newDirectories = missingDirectories,@@ -255,9 +279,6 @@             -- while an unselected one must keep it.             retainedOwners = maybe Set.empty (^. #applicationIds) prior Set.\\ selected             partial = not (Set.null retainedOwners)-            -- The prior flag summarises every owner, including the ones absent-            -- from this run, so a partial update can only weaken it.-            priorAdditive = maybe False (^. #additiveOnly) prior             record =               FileRecord                 { hash = state ^. #recordedHash,@@ -273,7 +294,10 @@                   generatedAt = manifest ^. #genAt,                   baseline = Just baseline,                   applicationIds = (desired ^. #applicationIds) `Set.union` retainedOwners,-                  additiveOnly = (desired ^. #additiveOnly) && (not partial || priorAdditive)+                  -- The prior mode summarises every owner, including the ones+                  -- absent from this run, so a partial update can only keep or+                  -- weaken it.+                  sharedWriteMode = recordedSharedWriteMode selected desired prior                 }         pure (Map.insert path record files)       Nothing -> pure (applyOrphanManifestAction selected reconciliation files)@@ -318,7 +342,7 @@       generatedAt = record ^. #generatedAt,       baseline = record ^. #baseline,       applicationIds = owners,-      additiveOnly = record ^. #additiveOnly+      sharedWriteMode = record ^. #sharedWriteMode     }  replaceManifestFiles :: Manifest -> Map FilePath FileRecord -> Manifest@@ -332,6 +356,8 @@       applications = manifest ^. #applications,       recipe = manifest ^. #recipe,       blueprint = manifest ^. #blueprint,+      seeds = manifest ^. #seeds,+      checkoutOutputs = manifest ^. #checkoutOutputs,       blueprintMigrations = manifest ^. #blueprintMigrations     } @@ -411,6 +437,7 @@     Left err -> pure (Left err)     Right metadata -> do       result <- try @SomeException $ do+        forM_ (metadata ^. #entries) (verifySafeParents (transaction ^. #projectRoot) . (^. #targetPath))         forM_ (metadata ^. #entries) (restoreEntry transaction)         removeNewDirectories (transaction ^. #projectRoot) (metadata ^. #newDirectories)         cleanupDirectory (transaction ^. #transactionDirectory)@@ -418,23 +445,49 @@  restoreEntry :: UpdateTransaction -> JournalEntry -> IO () restoreEntry transaction entry = do-  let target = transaction ^. #projectRoot </> (entry ^. #targetPath)-  case entry ^. #backupFile of-    Nothing -> do-      exists <- Directory.doesFileExist target-      when exists (Directory.removeFile target)-    Just backupName -> do+  let root = transaction ^. #projectRoot+      target = root </> (entry ^. #targetPath)+  verifySafeParents root (entry ^. #targetPath)+  current <- runEff $ runFilesystem $ inspectPath target+  -- Never follow a current link while restoring a file snapshot or a link.+  case current of+    EntrySymlink _ -> Directory.removeDirectoryLink target+    EntryDirectory -> ioError (userError ("refusing to restore over directory: " <> target))+    _ -> pure ()+  case (entry ^. #linkTarget, entry ^. #backupFile) of+    (Just link, _) -> do+      when (current == EntryFile) (ioError (userError ("refusing to restore link over a regular file: " <> target)))+      Directory.createDirectoryIfMissing True (takeDirectory target)+      Directory.createDirectoryLink link target+    (_, Just backupName) -> do       let backupPath = transaction ^. #transactionDirectory </> "backups" </> backupName+      backupEntry <- runEff $ runFilesystem $ inspectPath backupPath+      unless (backupEntry == EntryFile) (ioError (userError "transaction backup is not a real file"))       content <- TIO.readFile backupPath       atomicWriteText target content+    _ -> when (current == EntryFile) (Directory.removeFile target) +-- | Recovery must not traverse a substituted parent. Check from the root down.+verifySafeParents :: FilePath -> FilePath -> IO ()+verifySafeParents root path = go (reverse (relativeParents path))+  where+    go [] = pure ()+    go (parent : rest) = do+      entry <- runEff $ runFilesystem $ inspectPath (root </> parent)+      case entry of+        EntrySymlink _ -> ioError (userError ("transaction parent is a symlink: " <> parent))+        EntryFile -> ioError (userError ("transaction parent is not a directory: " <> parent))+        EntryMissing -> pure ()+        EntryDirectory -> go rest+ removeNewDirectories :: FilePath -> [FilePath] -> IO () removeNewDirectories projectRoot = mapM_ removeIfEmpty . reverse . sortOn pathDepth   where     removeIfEmpty relativePath = do       let fullPath = projectRoot </> relativePath-      exists <- Directory.doesDirectoryExist fullPath-      when exists $ do+      verifySafeParents projectRoot relativePath+      entry <- runEff $ runFilesystem $ inspectPath fullPath+      when (entry == EntryDirectory) $ do         contents <- Directory.listDirectory fullPath         when (null contents) (Directory.removeDirectory fullPath) @@ -537,7 +590,7 @@ validateJournal :: JournalMetadata -> Either Text JournalMetadata validateJournal metadata = do   traverse_ (validateJournalEntry . (^. #targetPath)) (metadata ^. #entries)-  traverse_ validateBackupName [name | JournalEntry _ (Just name) <- metadata ^. #entries]+  traverse_ validateBackupName [name | JournalEntry _ (Just name) _ <- metadata ^. #entries]   traverse_ (first renderTransactionPathError . validateTransactionPath) (metadata ^. #newDirectories)   pure metadata   where

@@ -3,6 +3,7 @@     DiagCheck (..),     ValidateReport (..),     buildReport,+    checkSeedSteps,     renderReportPlain,     reportHasErrors,   )@@ -16,7 +17,8 @@ import Data.Text.IO qualified as TIO import Seihou.Core.Expr (exprRefs, parseExpr) import Seihou.Core.Module-  ( checkCommandSafety,+  ( checkCheckoutSteps,+    checkCommandSafety,     checkDependencyNames,     checkDestVarRefs,     checkExportRefs,@@ -24,6 +26,7 @@     checkNameFormat,     checkPromptRefs,     checkSafeDestinations,+    checkSeedSteps,     checkUniqueVars,     checkVersionPresent,     extractPlaceholders,@@ -75,6 +78,8 @@           DiagCheck "Source file existence" DiagError fileErrors,           DiagCheck "Dependency names" DiagError (checkDependencyNames m),           DiagCheck "Safe step destinations" DiagError (checkSafeDestinations m),+          DiagCheck "Checkout steps" DiagError (checkCheckoutSteps m),+          DiagCheck "Seed steps" DiagError (checkSeedSteps m),           DiagCheck "Destination variable references" DiagError (checkDestVarRefs m),           DiagCheck "Command safety" DiagError (checkCommandSafety m)         ]@@ -212,7 +217,7 @@ lintDuplicateDestinations m =   let nonPatchDests = [s ^. #dest | s <- m ^. #steps, isNothing (s ^. #patch)]       dupes = findDuplicates Set.empty Set.empty nonPatchDests-   in map (\d -> "multiple steps write to '" <> d <> "'") dupes+   in map (\d -> "multiple steps write to '" <> d <> "'") [d | d <- dupes, Set.size (Set.fromList [s ^. #lifecycle | s <- m ^. #steps, s ^. #dest == d]) == 1]  findDuplicates :: Set.Set Text -> Set.Set Text -> [Text] -> [Text] findDuplicates _ _ [] = []

@@ -0,0 +1,30 @@+-- | The raw-byte boundary shared by manifest readers and explicit upgrades.+-- Check multiplicity before Aeson turns object members into a map.+module Seihou.Manifest.JSON (decodeManifestValue) where++import Data.Aeson qualified as Aeson+import Data.Aeson.Decoding.ByteString.Lazy (lbsToTokens)+import Data.Aeson.Decoding.Tokens+import Data.Aeson.Key qualified as Key+import Data.ByteString.Lazy qualified as LBS+import Data.Set qualified as Set++-- | Reject duplicate keys, including escaped-equivalent spellings, at any depth.+decodeManifestValue :: LBS.ByteString -> Either String Aeson.Value+decodeManifestValue bytes = check (lbsToTokens bytes) >> Aeson.eitherDecode bytes+  where+    check :: Tokens k String -> Either String k+    check (TkLit _ rest) = Right rest+    check (TkText _ rest) = Right rest+    check (TkNumber _ rest) = Right rest+    check (TkErr err) = Left err+    check (TkArrayOpen array) = checkArray array+    check (TkRecordOpen record) = checkRecord Set.empty record+    checkArray (TkItem value) = check value >>= checkArray+    checkArray (TkArrayEnd rest) = Right rest+    checkArray (TkArrayErr err) = Left err+    checkRecord seen (TkPair key value)+      | Set.member key seen = Left ("duplicate manifest JSON key: " <> show (Key.toText key))+      | otherwise = check value >>= checkRecord (Set.insert key seen)+    checkRecord _ (TkRecordEnd rest) = Right rest+    checkRecord _ (TkRecordErr err) = Left err

@@ -1,6 +1,12 @@ module Seihou.Manifest.Types   ( emptyManifest,+    manifestEncodingLoss,     currentManifestVersion,+    oldestDecodableManifestVersion,+    minimumManifestVersion,+    manifestSupports,+    sharedWriteModeToText,+    sharedWriteModeFromText,     manifestToJSON,     manifestFromJSON,     writeAppliedBlueprint,@@ -10,8 +16,11 @@   ) where +import Control.Monad (unless) import Data.Aeson (FromJSON (..), ToJSON (..), (.:), (.=)) import Data.Aeson qualified as Aeson+import Data.Aeson.Key qualified as Key+import Data.Aeson.KeyMap qualified as KM import Data.Aeson.Types qualified as Aeson import Data.ByteString.Lazy qualified as LBS import Data.Generics.Labels ()@@ -21,8 +30,11 @@ import Data.Text qualified as T import Data.Time (UTCTime) import Seihou.Core.ArtifactIdentity (sameArtifactIdentity)+import Seihou.Core.Checkout (CheckoutError (..), validateCheckoutRecords)+import Seihou.Core.Seed (ManifestInvariantError (..), validateManifestInvariants) import Seihou.Core.Types import Seihou.Manifest.Hash (baselineRefFromText)+import Seihou.Manifest.JSON (decodeManifestValue) import Seihou.Prelude hiding ((.=)) import System.FilePath (takeFileName) @@ -53,16 +65,42 @@ -- Version-5-and-earlier manifests are not readable directly; see -- docs/plans/79-upgrade-legacy-absolute-path-manifests-in-place.md. ----- Deliberately /not/ bumped from 6 to 7 when 'FileRecord' gained--- @additiveOnly@. The field is emitted only when true, so a manifest with no--- additive-only paths is byte-identical to one written before it existed, and--- a reader that predates it treats every path as requiring the full ownership--- closure -- the conservative reading. Bumping would make every manifest this--- release writes unreadable to 0.8.x binaries in exchange for nothing. See--- docs/plans/90-exempt-additive-patch-paths-from-the-shared-ownership-closure.md.-currentManifestVersion :: Int-currentManifestVersion = 6+-- Bumped from 6 to 7 when every 'FileRecord' gained a required+-- @sharedWriteMode@ (see+-- docs/plans/92-define-manifest-schema-capabilities-and-ordered-upgrade-steps.md).+-- Schema 6 carried the same fact as an optional @additiveOnly@ Boolean that+-- was emitted only when true, so an absent key meant both "an owner rewrites+-- the whole file" and "this manifest predates the question". Schema 6 still+-- decodes directly: @additiveOnly: true@ becomes 'SharedWriteAdditiveOnly'+-- and anything else becomes 'SharedWriteUnknown'. The adjacent raw-document+-- step lives in "Seihou.Manifest.Upgrade"; the rule that every semantic+-- change advances this number is+-- docs/adr/0014-every-semantic-manifest-change-advances-the-schema-version.md.+currentManifestVersion :: ManifestSchemaVersion+currentManifestVersion = ManifestSchemaVersion 9 +-- | The oldest schema the ordinary decoder reads. Anything older records+-- machine-specific absolute paths and must go through the explicit+-- @seihou manifest upgrade@ conversion first.+oldestDecodableManifestVersion :: ManifestSchemaVersion+oldestDecodableManifestVersion = ManifestSchemaVersion 6++-- | The oldest schema that can express the facts a capability relies on.+-- This is the only place a feature's manifest requirement is written down;+-- commands ask 'manifestSupports' instead of comparing version numbers.+minimumManifestVersion :: ManifestCapability -> ManifestSchemaVersion+minimumManifestVersion TargetedAdditiveSharedPathUpdate = ManifestSchemaVersion 7+minimumManifestVersion SeedReceipts = ManifestSchemaVersion 8+minimumManifestVersion CheckoutLocalOutputs = ManifestSchemaVersion 9++-- | Whether a manifest's schema can express everything a capability needs.+-- A decoded schema-6 manifest answers 'False' for+-- 'TargetedAdditiveSharedPathUpdate' even though its records carry an+-- explicit 'SharedWriteUnknown', because the file itself does not say so.+manifestSupports :: ManifestCapability -> Manifest -> Bool+manifestSupports capability manifest =+  manifest ^. #version >= minimumManifestVersion capability+ -- | Create an empty manifest with the given timestamp. emptyManifest :: UTCTime -> Manifest emptyManifest now =@@ -75,6 +113,8 @@       applications = [],       recipe = Nothing,       blueprint = Nothing,+      seeds = Map.empty,+      checkoutOutputs = Map.empty,       blueprintMigrations = []     } @@ -93,6 +133,8 @@       applications = m ^. #applications,       recipe = m ^. #recipe,       blueprint = Just ab,+      seeds = m ^. #seeds,+      checkoutOutputs = m ^. #checkoutOutputs,       blueprintMigrations = m ^. #blueprintMigrations     } @@ -115,6 +157,8 @@       applications = manifest ^. #applications,       recipe = manifest ^. #recipe,       blueprint = manifest ^. #blueprint,+      seeds = manifest ^. #seeds,+      checkoutOutputs = manifest ^. #checkoutOutputs,       blueprintMigrations = upsert (manifest ^. #blueprintMigrations)     }   where@@ -159,7 +203,7 @@  -- | Decode a manifest from JSON bytes. manifestFromJSON :: LBS.ByteString -> Either String Manifest-manifestFromJSON = Aeson.eitherDecode+manifestFromJSON bytes = decodeManifestValue bytes >>= Aeson.parseEither parseJSON  -- JSON instances @@ -170,50 +214,66 @@         "generatedAt" .= (m ^. #genAt),         "modules" .= (m ^. #modules),         "variables" .= varsToJSON (m ^. #vars),-        "files" .= filesToJSON (m ^. #files),+        "files" .= filesToJSON (m ^. #version) (m ^. #files),         "applications" .= (m ^. #applications),         "blueprintMigrations" .= (m ^. #blueprintMigrations)       ]+        ++ ["checkoutOutputs" .= Map.map checkoutToJSON (m ^. #checkoutOutputs) | m ^. #version >= ManifestSchemaVersion 9]+        ++ ["seeds" .= Map.map seedToJSON (m ^. #seeds) | m ^. #version >= ManifestSchemaVersion 8]         ++ maybe [] (\r -> ["recipe" .= r]) (m ^. #recipe)         ++ maybe [] (\b -> ["blueprint" .= b]) (m ^. #blueprint) +-- | The version is read and checked before anything else, because the+-- file-record representation depends on it. instance FromJSON Manifest where   parseJSON = Aeson.withObject "Manifest" $ \o -> do     v <- o .: "version"     checkManifestVersion v-    Manifest-      <$> pure v-      <*> o .: "generatedAt"-      <*> o .: "modules"-      <*> (varsFromJSON =<< o .: "variables")-      <*> (filesFromJSON =<< o .: "files")-      <*> o Aeson..:? "applications" Aeson..!= []-      <*> o Aeson..:? "recipe"-      <*> o Aeson..:? "blueprint"-      <*> o Aeson..:? "blueprintMigrations" Aeson..!= []+    manifest <-+      Manifest+        <$> pure v+        <*> o .: "generatedAt"+        <*> o .: "modules"+        <*> (varsFromJSON =<< o .: "variables")+        <*> (filesFromJSON v =<< o .: "files")+        <*> (if v >= ManifestSchemaVersion 8 then Map.traverseWithKey (\_ -> parseSeed) =<< o .: "seeds" else pure Map.empty)+        <*> (if v >= ManifestSchemaVersion 9 then Map.traverseWithKey (\_ -> parseCheckout) =<< o .: "checkoutOutputs" else pure Map.empty)+        <*> o Aeson..:? "applications" Aeson..!= []+        <*> o Aeson..:? "recipe"+        <*> o Aeson..:? "blueprint"+        <*> o Aeson..:? "blueprintMigrations" Aeson..!= []+    case validateManifestInvariants manifest of+      Left (PathBothManagedAndSeeded path) -> fail ("path " <> path <> " is recorded both as a tracked file and as a seed")+      Right () -> case validateCheckoutRecords manifest [] of+        Left err -> fail (T.unpack (err ^. #message))+        Right () -> pure manifest  -- | Reject a manifest this build cannot read, naming the remedy. ----- Compatibility seam: schema-5-and-earlier manifests carry an absolute--- @source@ path in place of the portable @origin@. Decoding those is owned--- by docs/plans/79-upgrade-legacy-absolute-path-manifests-in-place.md; until--- that plan lands an older manifest fails here with a clear message rather--- than being silently misread. The @seihou manifest upgrade@ command the--- message names is delivered by that same plan, so the remedy does not exist--- yet.-checkManifestVersion :: Int -> Aeson.Parser ()+-- Schema-5-and-earlier manifests carry an absolute @source@ path in place of+-- the portable @origin@; converting them is an inference that stays behind+-- the explicit @seihou manifest upgrade@ command+-- (docs/adr/0005-legacy-manifests-convert-through-an-explicit-command.md),+-- so they fail here rather than being silently misread.+checkManifestVersion :: ManifestSchemaVersion -> Aeson.Parser () checkManifestVersion v   | v > currentManifestVersion =       fail "manifest was created by a newer version of seihou"-  | v < 6 =+  | v < oldestDecodableManifestVersion =       fail         ( "this manifest uses schema version "-            <> show v+            <> show (v ^. #unManifestSchemaVersion)             <> ", which records machine-specific absolute paths; run "             <> "'seihou manifest upgrade' to convert it"         )   | otherwise = pure () +instance ToJSON ManifestSchemaVersion where+  toJSON (ManifestSchemaVersion v) = toJSON v++instance FromJSON ManifestSchemaVersion where+  parseJSON value = ManifestSchemaVersion <$> parseJSON value+ instance ToJSON AppliedTarget where   toJSON (AppliedModuleTarget name) =     Aeson.object ["kind" .= ("module" :: Text), "name" .= (name ^. #unModuleName)]@@ -564,47 +624,77 @@     <*> o Aeson..:? "workDir"     <*> pure Nothing -instance ToJSON FileRecord where-  toJSON fr =-    Aeson.object $-      [ "hash" .= (fr ^. #hash . #unSHA256),-        "module" .= (fr ^. #moduleName . #unModuleName),-        "strategy" .= strategyToText (fr ^. #strategy),-        "generatedAt" .= (fr ^. #generatedAt)-      ]-        ++ maybe [] (\ref -> ["baseline" .= (ref ^. #unBaselineRef . #unSHA256)]) (fr ^. #baseline)-        ++ applicationIdsField (fr ^. #applicationIds)-        ++ additiveOnlyField (fr ^. #additiveOnly)-    where-      applicationIdsField ids-        | Set.null ids = []-        | otherwise = ["applications" .= map (^. #unApplicationId) (Set.toAscList ids)]-      -- Emitted only when true, so a manifest with no additive-only paths is-      -- byte-identical to one written before the field existed. A reader that-      -- predates the field ignores it and keeps enforcing the ownership-      -- closure everywhere, which is the conservative behaviour; that is why-      -- 'currentManifestVersion' does not move for this field.-      additiveOnlyField additive-        | additive = ["additiveOnly" .= True]-        | otherwise = []+-- | Encode a file record in the representation of the given schema.+--+-- Schema 7 always emits @sharedWriteMode@, including @unknown@, so absence+-- can never again stand for a value. Schema 6 can only say+-- @additiveOnly: true@; a closure-required path is written without the key+-- and reads back as unknown, which is the fail-closed direction.+fileRecordToJSON :: ManifestSchemaVersion -> FileRecord -> Aeson.Value+fileRecordToJSON schema fr =+  Aeson.object $+    [ "hash" .= (fr ^. #hash . #unSHA256),+      "module" .= (fr ^. #moduleName . #unModuleName),+      "strategy" .= strategyToText (fr ^. #strategy),+      "generatedAt" .= (fr ^. #generatedAt)+    ]+      ++ maybe [] (\ref -> ["baseline" .= (ref ^. #unBaselineRef . #unSHA256)]) (fr ^. #baseline)+      ++ applicationIdsField (fr ^. #applicationIds)+      ++ sharedWriteField (fr ^. #sharedWriteMode)+  where+    applicationIdsField ids+      | Set.null ids = []+      | otherwise = ["applications" .= map (^. #unApplicationId) (Set.toAscList ids)]+    sharedWriteField mode+      | schema >= ManifestSchemaVersion 7 = ["sharedWriteMode" .= sharedWriteModeToText mode]+      | mode == SharedWriteAdditiveOnly = ["additiveOnly" .= True]+      | otherwise = [] -instance FromJSON FileRecord where-  parseJSON = Aeson.withObject "FileRecord" $ \o -> do-    baselineText <- o Aeson..:? "baseline"-    baseline <- traverse parseBaselineRef baselineText-    FileRecord-      <$> (SHA256 <$> o .: "hash")-      <*> (ModuleName <$> o .: "module")-      <*> (strategyFromText =<< o .: "strategy")-      <*> o .: "generatedAt"-      <*> pure baseline-      <*> (Set.fromList . map ApplicationId <$> o Aeson..:? "applications" Aeson..!= [])-      <*> (o Aeson..:? "additiveOnly" Aeson..!= False)-    where-      parseBaselineRef value = case baselineRefFromText value of-        Just ref -> pure ref-        Nothing -> fail "baseline must be a 64-character hexadecimal SHA-256 digest"+-- | Decode a file record in the representation of the given schema.+parseFileRecord :: ManifestSchemaVersion -> Aeson.Value -> Aeson.Parser FileRecord+parseFileRecord schema = Aeson.withObject "FileRecord" $ \o -> do+  baselineText <- o Aeson..:? "baseline"+  baseline <- traverse parseBaselineRef baselineText+  FileRecord+    <$> (SHA256 <$> o .: "hash")+    <*> (ModuleName <$> o .: "module")+    <*> (strategyFromText =<< o .: "strategy")+    <*> o .: "generatedAt"+    <*> pure baseline+    <*> (Set.fromList . map ApplicationId <$> o Aeson..:? "applications" Aeson..!= [])+    <*> parseSharedWrite o+  where+    parseBaselineRef value = case baselineRefFromText value of+      Just ref -> pure ref+      Nothing -> fail "baseline must be a 64-character hexadecimal SHA-256 digest"+    parseSharedWrite o+      | schema >= ManifestSchemaVersion 7 = do+          raw <- o Aeson..:? "sharedWriteMode"+          case raw of+            Nothing -> fail "missing required key \"sharedWriteMode\" (schema 7 records it on every file)"+            Just text -> case sharedWriteModeFromText text of+              Just mode -> pure mode+              Nothing ->+                fail+                  ( "invalid \"sharedWriteMode\" value "+                      <> show text+                      <> "; expected \"unknown\", \"additive-only\", or \"requires-ownership-closure\""+                  )+      | otherwise = do+          -- Version 6 omitted false, so only an explicit true proves anything.+          additive <- o Aeson..:? "additiveOnly" Aeson..!= False+          pure (if additive then SharedWriteAdditiveOnly else SharedWriteUnknown) +-- | The schema-7 wire spelling of a shared-write mode.+sharedWriteModeToText :: SharedWriteMode -> Text+sharedWriteModeToText SharedWriteUnknown = "unknown"+sharedWriteModeToText SharedWriteAdditiveOnly = "additive-only"+sharedWriteModeToText SharedWriteRequiresOwnershipClosure = "requires-ownership-closure"++sharedWriteModeFromText :: Text -> Maybe SharedWriteMode+sharedWriteModeFromText text =+  lookup text [(sharedWriteModeToText mode, mode) | mode <- [minBound .. maxBound]]+ instance ToJSON SHA256 where   toJSON (SHA256 t) = toJSON t @@ -634,13 +724,23 @@  -- Helpers for FilePath-keyed maps -filesToJSON :: Map FilePath FileRecord -> Aeson.Value-filesToJSON = toJSON . Map.mapKeys T.pack+filesToJSON :: ManifestSchemaVersion -> Map FilePath FileRecord -> Aeson.Value+filesToJSON schema = toJSON . Map.map (fileRecordToJSON schema) . Map.mapKeys T.pack -filesFromJSON :: Aeson.Value -> Aeson.Parser (Map FilePath FileRecord)-filesFromJSON v = do-  m <- parseJSON v :: Aeson.Parser (Map Text FileRecord)-  pure (Map.mapKeys T.unpack m)+-- | Each record is parsed under its path, so a malformed record's error+-- names the file it belongs to.+filesFromJSON :: ManifestSchemaVersion -> Aeson.Value -> Aeson.Parser (Map FilePath FileRecord)+filesFromJSON schema v = do+  m <- parseJSON v :: Aeson.Parser (Map Text Aeson.Value)+  records <-+    Map.traverseWithKey+      ( \path value ->+          Aeson.modifyFailure+            (\err -> "file record " <> show path <> ": " <> err)+            (parseFileRecord schema value Aeson.<?> Aeson.Key (Key.fromText path))+      )+      m+  pure (Map.mapKeys T.unpack records)  -- Strategy serialization @@ -649,10 +749,70 @@ strategyToText Template = "template" strategyToText DhallText = "dhall-text" strategyToText Structured = "structured"+strategyToText Symlink = "symlink"  strategyFromText :: Text -> Aeson.Parser Strategy strategyFromText "copy" = pure Copy strategyFromText "template" = pure Template strategyFromText "dhall-text" = pure DhallText strategyFromText "structured" = pure Structured+strategyFromText "symlink" = fail "checkout symlinks cannot be managed file records" strategyFromText other = fail ("unknown strategy: " <> T.unpack other)++seedToJSON :: SeedRecord -> Aeson.Value+seedToJSON record =+  Aeson.object+    [ "module" .= (record ^. #moduleName . #unModuleName),+      "applications" .= map (^. #unApplicationId) (Set.toAscList (record ^. #applicationIds)),+      "outcome" .= seedOutcomeToText (record ^. #outcome),+      "settledAt" .= (record ^. #settledAt)+    ]++seedOutcomeToText :: SeedOutcome -> Text+seedOutcomeToText SeedCreated = "created"+seedOutcomeToText SeedFoundExisting = "found-existing"+seedOutcomeToText SeedReleasedFromManaged = "released-from-managed"++parseSeed :: Aeson.Value -> Aeson.Parser SeedRecord+parseSeed = Aeson.withObject "seed receipt" $ \o -> do+  outcome <-+    o .: "outcome" >>= \case+      "created" -> pure SeedCreated+      "found-existing" -> pure SeedFoundExisting+      "released-from-managed" -> pure SeedReleasedFromManaged+      (other :: Text) -> fail ("unknown seed outcome: " <> T.unpack other <> "; expected created, found-existing, released-from-managed")+  SeedRecord+    <$> (ModuleName <$> o .: "module")+    <*> (Set.fromList . map ApplicationId <$> o .: "applications")+    <*> pure outcome+    <*> o .: "settledAt"++-- | Facts that would be lost if a caller encoded a value at its stated schema.+manifestEncodingLoss :: Manifest -> [Text]+manifestEncodingLoss manifest =+  ["checkout outputs require manifest schema 9" | manifest ^. #version < ManifestSchemaVersion 9, not (Map.null (manifest ^. #checkoutOutputs))]+    <> ["seed receipts require manifest schema 8" | manifest ^. #version < ManifestSchemaVersion 8, not (Map.null (manifest ^. #seeds))]++checkoutToJSON :: CheckoutOutputRecord -> Aeson.Value+checkoutToJSON record =+  Aeson.object+    [ "spec" .= case record ^. #spec of+        DirectorySymlink source -> Aeson.object ["kind" .= ("directory-symlink" :: Text), "source" .= source],+      "owners" .= Map.mapKeys (^. #unApplicationId) (Map.map (map (^. #unModuleName) . Set.toAscList) (record ^. #owners))+    ]++parseCheckout :: Aeson.Value -> Aeson.Parser CheckoutOutputRecord+parseCheckout = Aeson.withObject "checkout output" $ \o -> do+  unless (Set.fromList (KM.keys o) == Set.fromList ["spec", "owners"]) $ fail "checkout output requires exactly spec and owners"+  spec <-+    o .: "spec"+      >>= Aeson.withObject+        "checkout spec"+        ( \fields -> do+            kind <- fields .: "kind" :: Aeson.Parser Text+            unless (kind == "directory-symlink") $ fail ("unknown checkout output kind: " <> T.unpack kind)+            unless (Set.fromList (KM.keys fields) == Set.fromList ["kind", "source"]) $ fail "directory-symlink requires exactly kind and source"+            DirectorySymlink <$> fields .: "source"+        )+  owners <- o .: "owners" :: Aeson.Parser (Map Text [Text])+  pure (CheckoutOutputRecord spec (Map.mapKeys ApplicationId (Map.map (Set.fromList . map ModuleName) owners)))

@@ -0,0 +1,282 @@+-- | The ordered, adjacent schema steps that take a raw+-- @.seihou/manifest.json@ document from any supported schema to a newer one.+--+-- Every semantic manifest change advances the schema and adds exactly one+-- @N -> N + 1@ step here+-- (docs/adr/0014-every-semantic-manifest-change-advances-the-schema-version.md).+-- A path is planned one adjacent step at a time, so a missing step is an+-- error rather than a silent jump, and a document's @version@ only ever+-- names the last step that actually ran.+--+-- Steps work on 'Aeson.Value' rather than 'Manifest' so that keys this build+-- does not model survive. Each step is classified: a lossless step is a+-- deterministic transform implemented here and may be staged by any command+-- that needs it; an inference-bearing step consults machine-local state and+-- is implemented only by the explicit @seihou manifest upgrade@ command in+-- @seihou-cli@ (docs/adr/0005-legacy-manifests-convert-through-an-explicit-command.md).+module Seihou.Manifest.Upgrade+  ( UpgradeStepAction (..),+    UpgradeStepKind (..),+    ManifestUpgradeStep (..),+    ManifestUpgradeError (..),+    oldestUpgradableManifestVersion,+    manifestUpgradeSteps,+    upgradeStepKind,+    planManifestUpgrade,+    planUpgradeWith,+    documentSchemaVersion,+    setDocumentSchemaVersion,+    applyLosslessUpgradeStep,+    upgradeDocumentLosslessly,+    makeSharedWriteEvidenceExplicit,+    renderManifestUpgradeError,+  )+where++import Control.Monad (foldM, unless)+import Data.Aeson qualified as Aeson+import Data.Aeson.Key qualified as Key+import Data.Aeson.KeyMap qualified as KeyMap+import Data.Generics.Labels ()+import Data.Text qualified as T+import Seihou.Core.Types+import Seihou.Manifest.Types (currentManifestVersion, sharedWriteModeToText)+import Seihou.Prelude++-- | What a step does to the document. The kind of each action is fixed by+-- 'upgradeStepKind', so a step cannot be declared lossless while doing+-- inference.+data UpgradeStepAction+  = -- | Only the version changes: every field the newer schema added decodes+    -- from its absence to the same default the older reader assumed.+    StampVersion+  | -- | Schema 5 to 6: machine-local @source@ and @targetSource@ paths+    -- become portable artifact origins. Implemented by the CLI.+    ConvertMachineLocalPaths+  | -- | Schema 6 to 7: the optional @additiveOnly@ Boolean becomes a+    -- required @sharedWriteMode@ on every file record.+    MakeSharedWriteEvidenceExplicit+  | AddEmptySeedReceipts+  | AddEmptyCheckoutOutputs+  deriving stock (Eq, Ord, Show, Enum, Bounded, Generic)++-- | Whether a step may be staged automatically.+data UpgradeStepKind+  = -- | Deterministic and loses nothing; may be staged by a command that+    -- requires the newer schema and committed atomically with its result.+    LosslessUpgrade+  | -- | Consults machine-local state or chooses among plausible answers;+    -- only the explicit, reviewable @seihou manifest upgrade@ runs it.+    InferenceBearingUpgrade+  deriving stock (Eq, Ord, Show, Enum, Bounded, Generic)++-- | One adjacent schema step.+data ManifestUpgradeStep = ManifestUpgradeStep+  { fromVersion :: !ManifestSchemaVersion,+    toVersion :: !ManifestSchemaVersion,+    action :: !UpgradeStepAction,+    -- | A short description for upgrade reports.+    summary :: !Text+  }+  deriving stock (Eq, Show, Generic)++data ManifestUpgradeError+  = -- | The document has no integer @version@, or is not an object.+    UnreadableSchemaVersion Text+  | -- | Older than any schema this build knows how to upgrade.+    SourceVersionUnsupported ManifestSchemaVersion+  | -- | Written by a newer seihou than this one.+    SourceNewerThanBinary ManifestSchemaVersion+  | -- | Asked for a schema this build does not know.+    TargetAboveCurrent ManifestSchemaVersion+  | -- | Asked to go backwards: source, then requested target.+    TargetBelowSource ManifestSchemaVersion ManifestSchemaVersion+  | -- | No step starts at this version.+    MissingUpgradeStep ManifestSchemaVersion+  | -- | A lossless run reached a step only the explicit command may run.+    StepRequiresInference ManifestUpgradeStep+  | -- | A step was applied to a document at a different version.+    StepVersionMismatch ManifestUpgradeStep ManifestSchemaVersion+  | -- | The document did not have the shape its version promises.+    MalformedDocument ManifestSchemaVersion Text+  deriving stock (Eq, Show, Generic)++-- | The oldest schema any step starts from.+oldestUpgradableManifestVersion :: ManifestSchemaVersion+oldestUpgradableManifestVersion = ManifestSchemaVersion 1++-- | Every adjacent step, oldest first. Adding a schema version means adding+-- exactly one entry here; the test suite plans a path from every supported+-- version to 'currentManifestVersion', so a forgotten step fails it.+manifestUpgradeSteps :: [ManifestUpgradeStep]+manifestUpgradeSteps =+  [ step 1 StampVersion "per-instance parent variables",+    step 2 StampVersion "applied blueprint record",+    step 3 StampVersion "reproducible applications and generated baselines",+    step 4 StampVersion "blueprint migration receipts",+    step 5 ConvertMachineLocalPaths "portable artifact origins",+    step 6 MakeSharedWriteEvidenceExplicit "explicit shared-write evidence",+    step 7 AddEmptySeedReceipts "seed receipts",+    step 8 AddEmptyCheckoutOutputs "checkout outputs"+  ]+  where+    step from stepAction =+      ManifestUpgradeStep (ManifestSchemaVersion from) (ManifestSchemaVersion (from + 1)) stepAction++upgradeStepKind :: UpgradeStepAction -> UpgradeStepKind+upgradeStepKind StampVersion = LosslessUpgrade+upgradeStepKind ConvertMachineLocalPaths = InferenceBearingUpgrade+upgradeStepKind MakeSharedWriteEvidenceExplicit = LosslessUpgrade+upgradeStepKind AddEmptySeedReceipts = LosslessUpgrade+upgradeStepKind AddEmptyCheckoutOutputs = LosslessUpgrade++-- | The contiguous steps from @source@ to @target@. Planning from a version+-- to itself is an empty path.+planManifestUpgrade ::+  ManifestSchemaVersion ->+  ManifestSchemaVersion ->+  Either ManifestUpgradeError [ManifestUpgradeStep]+planManifestUpgrade = planUpgradeWith manifestUpgradeSteps currentManifestVersion++-- | 'planManifestUpgrade' over an explicit step table and current version,+-- so the gap check itself can be tested.+planUpgradeWith ::+  [ManifestUpgradeStep] ->+  ManifestSchemaVersion ->+  ManifestSchemaVersion ->+  ManifestSchemaVersion ->+  Either ManifestUpgradeError [ManifestUpgradeStep]+planUpgradeWith steps current source target+  | source > current = Left (SourceNewerThanBinary source)+  | source < oldestUpgradableManifestVersion = Left (SourceVersionUnsupported source)+  | target > current = Left (TargetAboveCurrent target)+  | target < source = Left (TargetBelowSource source target)+  | otherwise = walk source+  where+    walk version+      | version == target = Right []+      | otherwise = case [candidate | candidate <- steps, candidate ^. #fromVersion == version] of+          [found]+            | found ^. #toVersion == nextVersion version -> (found :) <$> walk (nextVersion version)+          _ -> Left (MissingUpgradeStep version)+    nextVersion (ManifestSchemaVersion v) = ManifestSchemaVersion (v + 1)++-- | Read a raw document's top-level @version@.+documentSchemaVersion :: Aeson.Value -> Either ManifestUpgradeError ManifestSchemaVersion+documentSchemaVersion (Aeson.Object fields) = case KeyMap.lookup "version" fields of+  Just value | Aeson.Success v <- Aeson.fromJSON value -> Right (ManifestSchemaVersion v)+  Just _ -> Left (UnreadableSchemaVersion "the \"version\" field is not an integer")+  Nothing -> Left (UnreadableSchemaVersion "the manifest has no \"version\" field")+documentSchemaVersion _ = Left (UnreadableSchemaVersion "the manifest is not a JSON object")++-- | Replace a raw document's top-level @version@, keeping every other key.+setDocumentSchemaVersion :: ManifestSchemaVersion -> Aeson.Value -> Aeson.Value+setDocumentSchemaVersion version (Aeson.Object fields) =+  Aeson.Object (KeyMap.insert "version" (Aeson.toJSON (version ^. #unManifestSchemaVersion)) fields)+setDocumentSchemaVersion _ other = other++-- | Run one lossless step. The document must be at the step's source+-- version; the version is advanced only after the transform succeeds.+applyLosslessUpgradeStep :: ManifestUpgradeStep -> Aeson.Value -> Either ManifestUpgradeError Aeson.Value+applyLosslessUpgradeStep upgradeStep document = do+  actual <- documentSchemaVersion document+  unless (actual == upgradeStep ^. #fromVersion) $+    Left (StepVersionMismatch upgradeStep actual)+  transformed <- case upgradeStep ^. #action of+    StampVersion -> Right document+    AddEmptyCheckoutOutputs -> case document of+      Aeson.Object fields -> case KeyMap.lookup "checkoutOutputs" fields of+        Nothing -> Right (Aeson.Object (KeyMap.insert "checkoutOutputs" (Aeson.object []) fields))+        Just (Aeson.Object _) -> Right document+        _ -> Left (MalformedDocument actual "checkoutOutputs must be an object")+      _ -> Left (MalformedDocument actual "manifest must be an object")+    AddEmptySeedReceipts -> case document of+      Aeson.Object fields -> case KeyMap.lookup "seeds" fields of+        Nothing -> Right (Aeson.Object (KeyMap.insert "seeds" (Aeson.object []) fields))+        Just (Aeson.Object _) -> Right document+        _ -> Left (MalformedDocument actual "seeds must be an object")+      _ -> Left (MalformedDocument actual "cannot add empty seeds: field already exists or document is not an object")+    MakeSharedWriteEvidenceExplicit ->+      first (MalformedDocument actual) (makeSharedWriteEvidenceExplicit document)+    ConvertMachineLocalPaths -> Left (StepRequiresInference upgradeStep)+  pure (setDocumentSchemaVersion (upgradeStep ^. #toVersion) transformed)++-- | Upgrade a raw document to @target@ using lossless steps only. Stops with+-- 'StepRequiresInference' before changing anything if the path crosses an+-- inference-bearing step. Returns the steps that ran with the result.+upgradeDocumentLosslessly ::+  ManifestSchemaVersion ->+  Aeson.Value ->+  Either ManifestUpgradeError ([ManifestUpgradeStep], Aeson.Value)+upgradeDocumentLosslessly target document = do+  source <- documentSchemaVersion document+  steps <- planManifestUpgrade source target+  case [s | s <- steps, upgradeStepKind (s ^. #action) == InferenceBearingUpgrade] of+    blocked : _ -> Left (StepRequiresInference blocked)+    [] -> (steps,) <$> foldM (flip applyLosslessUpgradeStep) document steps++-- | The schema 6 to 7 transform. Every file record gains a required+-- @sharedWriteMode@: an explicit @additiveOnly: true@ becomes+-- @additive-only@, and anything else becomes @unknown@, because schema 6+-- omitted @false@ and absence therefore proves nothing. The old key is+-- removed; every other member at every level is kept.+makeSharedWriteEvidenceExplicit :: Aeson.Value -> Either Text Aeson.Value+makeSharedWriteEvidenceExplicit (Aeson.Object fields) = case KeyMap.lookup "files" fields of+  Just (Aeson.Object records) -> do+    converted <- KeyMap.traverseWithKey convertRecord records+    Right (Aeson.Object (KeyMap.insert "files" (Aeson.Object converted) fields))+  Just _ -> Left "\"files\" is not an object"+  Nothing -> Left "the manifest has no \"files\" object"+  where+    convertRecord path (Aeson.Object record) = do+      mode <- case KeyMap.lookup "additiveOnly" record of+        Nothing -> Right SharedWriteUnknown+        Just (Aeson.Bool True) -> Right SharedWriteAdditiveOnly+        Just (Aeson.Bool False) -> Right SharedWriteUnknown+        Just _ -> Left ("file record " <> Key.toText path <> ": \"additiveOnly\" is not a Boolean")+      Right+        ( Aeson.Object+            ( KeyMap.insert "sharedWriteMode" (Aeson.String (sharedWriteModeToText mode)) $+                KeyMap.delete "additiveOnly" record+            )+        )+    convertRecord path _ = Left ("file record " <> Key.toText path <> " is not an object")+makeSharedWriteEvidenceExplicit _ = Left "the manifest is not a JSON object"++renderManifestUpgradeError :: ManifestUpgradeError -> Text+renderManifestUpgradeError err = case err of+  UnreadableSchemaVersion reason -> "cannot read the manifest schema version: " <> reason+  SourceVersionUnsupported v -> "manifest schema " <> showVersion v <> " is older than any schema seihou can upgrade"+  SourceNewerThanBinary v ->+    "manifest schema "+      <> showVersion v+      <> " was written by a newer seihou; this build understands up to schema "+      <> showVersion currentManifestVersion+  TargetAboveCurrent v ->+    "schema "+      <> showVersion v+      <> " is newer than this build supports (up to "+      <> showVersion currentManifestVersion+      <> ")"+  TargetBelowSource source target ->+    "cannot upgrade from schema " <> showVersion source <> " to the older schema " <> showVersion target+  MissingUpgradeStep v -> "no upgrade step is defined from schema " <> showVersion v+  StepRequiresInference s ->+    "upgrading from schema "+      <> showVersion (s ^. #fromVersion)+      <> " to "+      <> showVersion (s ^. #toVersion)+      <> " ("+      <> s ^. #summary+      <> ") needs review; run 'seihou manifest upgrade'"+  StepVersionMismatch s actual ->+    "the "+      <> showVersion (s ^. #fromVersion)+      <> " -> "+      <> showVersion (s ^. #toVersion)+      <> " step cannot run on a schema-"+      <> showVersion actual+      <> " document"+  MalformedDocument v reason -> "the schema-" <> showVersion v <> " manifest is malformed: " <> reason+  where+    showVersion (ManifestSchemaVersion v) = T.pack (show v)

@@ -7,9 +7,11 @@ import Seihou.Composition.ResolveSpec qualified as ResolveSpec import Seihou.Core.AgentPromptSpec qualified as AgentPromptSpec import Seihou.Core.ApplicationSpec qualified as ApplicationSpec+import Seihou.Core.ArtifactIdentitySpec qualified as ArtifactIdentitySpec import Seihou.Core.ArtifactOriginDetectSpec qualified as ArtifactOriginDetectSpec import Seihou.Core.ArtifactRefSpec qualified as ArtifactRefSpec import Seihou.Core.BlueprintSpec qualified as BlueprintSpec+import Seihou.Core.CheckoutSpec qualified as CheckoutSpec import Seihou.Core.CommandFingerprintSpec qualified as CommandFingerprintSpec import Seihou.Core.CommandVarSpec qualified as CommandVarSpec import Seihou.Core.ContextSpec qualified as ContextSpec@@ -25,6 +27,7 @@ import Seihou.Core.RegistrySyncSpec qualified as RegistrySyncSpec import Seihou.Core.ScaffoldSpec qualified as ScaffoldSpec import Seihou.Core.SchemaUpgradeSpec qualified as SchemaUpgradeSpec+import Seihou.Core.SeedSpec qualified as SeedSpec import Seihou.Core.StatusSpec qualified as StatusSpec import Seihou.Core.TypesSpec qualified as TypesSpec import Seihou.Core.VariableSpec qualified as VariableSpec@@ -39,6 +42,7 @@ import Seihou.Effect.LoggerSpec qualified as LoggerSpec import Seihou.Effect.ManifestStoreSpec qualified as ManifestStoreSpec import Seihou.Engine.BaselineSpec qualified as BaselineSpec+import Seihou.Engine.CheckoutSpec qualified as CheckoutEngineSpec import Seihou.Engine.ConflictSpec qualified as ConflictSpec import Seihou.Engine.DiffSpec qualified as DiffSpec import Seihou.Engine.ExecuteSpec qualified as ExecuteSpec@@ -63,6 +67,7 @@ import Seihou.Interaction.ConfirmSpec qualified as ConfirmSpec import Seihou.Interaction.PromptSpec qualified as PromptSpec import Seihou.Manifest.TypesSpec qualified as ManifestTypesSpec+import Seihou.Manifest.UpgradeSpec qualified as ManifestUpgradeSpec import Test.Tasty  main :: IO ()@@ -74,6 +79,7 @@   resolveTests <- ResolveSpec.tests   agentPromptTests <- AgentPromptSpec.tests   applicationTests <- ApplicationSpec.tests+  artifactIdentityTests <- ArtifactIdentitySpec.tests   artifactOriginDetectTests <- ArtifactOriginDetectSpec.tests   artifactRefTests <- ArtifactRefSpec.tests   blueprintTests <- BlueprintSpec.tests@@ -92,6 +98,9 @@   registryEmitTests <- RegistryEmitSpec.tests   registrySyncTests <- RegistrySyncSpec.tests   scaffoldTests <- ScaffoldSpec.tests+  checkoutEngineTests <- CheckoutEngineSpec.tests+  checkoutTests <- CheckoutSpec.tests+  seedTests <- SeedSpec.tests   schemaUpgradeTests <- SchemaUpgradeSpec.tests   statusTests <- StatusSpec.tests   variableTests <- VariableSpec.tests@@ -128,6 +137,7 @@   integrationTests <- IntegrationSpec.tests   generationTests <- GenerationSpec.tests   manifestTypesTests <- ManifestTypesSpec.tests+  manifestUpgradeTests <- ManifestUpgradeSpec.tests   promptTests <- PromptSpec.tests   confirmTests <- ConfirmSpec.tests-  defaultMain (testGroup "seihou-core" [graphTests, instanceTests, compositionPlanTests, compositionRecipeTests, resolveTests, agentPromptTests, applicationTests, artifactOriginDetectTests, artifactRefTests, blueprintTests, commandFingerprintTests, commandVarTests, typesTests, contextTests, entailmentTests, exprTests, installTests, listTests, migrationTests, moduleTests, recipeTests, registryTests, registryEmitTests, registrySyncTests, scaffoldTests, schemaUpgradeTests, statusTests, variableTests, versionTests, templateTests, threeWayMergeTests, updateTransactionTests, planTests, previewTests, reconcileTests, sectionTests, validateTests, splitFlakeTests, dhallTextFlakeTests, typedDhallTextTests, conditionalTemplateTests, configTests, dhallEvalTests, migrationDecoderTests, configReaderTests, configWriterTests, baselineStoreTests, filesystemTests, loggerTests, manifestStoreTests, conflictTests, baselineTests, diffTests, executeTests, engineMigrateTests, removeTests, compositionTests, executionTests, integrationTests, generationTests, manifestTypesTests, promptTests, confirmTests])+  defaultMain (testGroup "seihou-core" [graphTests, instanceTests, compositionPlanTests, compositionRecipeTests, resolveTests, agentPromptTests, applicationTests, artifactIdentityTests, artifactOriginDetectTests, artifactRefTests, blueprintTests, commandFingerprintTests, commandVarTests, typesTests, contextTests, entailmentTests, exprTests, installTests, listTests, migrationTests, moduleTests, recipeTests, registryTests, registryEmitTests, registrySyncTests, scaffoldTests, checkoutEngineTests, checkoutTests, seedTests, schemaUpgradeTests, statusTests, variableTests, versionTests, templateTests, threeWayMergeTests, updateTransactionTests, planTests, previewTests, reconcileTests, sectionTests, validateTests, splitFlakeTests, dhallTextFlakeTests, typedDhallTextTests, conditionalTemplateTests, configTests, dhallEvalTests, migrationDecoderTests, configReaderTests, configWriterTests, baselineStoreTests, filesystemTests, loggerTests, manifestStoreTests, conflictTests, baselineTests, diffTests, executeTests, engineMigrateTests, removeTests, compositionTests, executionTests, integrationTests, generationTests, manifestTypesTests, manifestUpgradeTests, promptTests, confirmTests])

@@ -1,6 +1,7 @@ module Seihou.Core.ApplicationSpec (tests) where  import Control.Lens ((&), (?~), (^.))+import Control.Monad (forM_) import Data.Generics.Labels () import Data.Map.Strict qualified as Map import Data.Set qualified as Set@@ -158,41 +159,50 @@     it "unions prior and current ownership and preserves the generated baseline" $ do       let priorId = ApplicationId "prior"           currentId = ApplicationId "current"-          prior = FileRecord (hashContent "old") "module" Template fixedTime Nothing (Set.singleton priorId) False-          current = FileRecord (hashContent "new") "module" Template fixedTime (Just (BaselineRef (hashContent "generated"))) Set.empty False+          prior = FileRecord (hashContent "old") "module" Template fixedTime Nothing (Set.singleton priorId) SharedWriteUnknown+          current = FileRecord (hashContent "new") "module" Template fixedTime (Just (BaselineRef (hashContent "generated"))) Set.empty SharedWriteRequiresOwnershipClosure           attached = attachApplication currentId (Just prior) current       (attached ^. #applicationIds) `shouldBe` Set.fromList [priorId, currentId]       (attached ^. #baseline) `shouldBe` Just (BaselineRef (hashContent "generated")) -    it "cannot strengthen additiveOnly while a prior owner survives" $ do+    it "cannot strengthen a closure requirement while a prior owner survives" $ do       -- This run executed only its own application's operations, so its       -- answer covers only its own contributions. A co-owner that rewrites       -- the whole file must keep the path under the ownership closure.       let priorId = ApplicationId "prior"           currentId = ApplicationId "current"-          prior = record (Set.singleton priorId) False-          current = record Set.empty True-      (attachApplication currentId (Just prior) current ^. #additiveOnly) `shouldBe` False+          prior = record (Set.singleton priorId) SharedWriteRequiresOwnershipClosure+          current = record Set.empty SharedWriteAdditiveOnly+      (attachApplication currentId (Just prior) current ^. #sharedWriteMode) `shouldBe` SharedWriteRequiresOwnershipClosure -    it "keeps additiveOnly true when the prior record and this run agree" $ do+    it "keeps unknown evidence unknown while a prior owner survives" $ do+      -- Nothing this run did says how the retained owner writes the path.       let priorId = ApplicationId "prior"           currentId = ApplicationId "current"-      (attachApplication currentId (Just (record (Set.singleton priorId) True)) (record Set.empty True) ^. #additiveOnly)-        `shouldBe` True+      (attachApplication currentId (Just (record (Set.singleton priorId) SharedWriteUnknown)) (record Set.empty SharedWriteAdditiveOnly) ^. #sharedWriteMode)+        `shouldBe` SharedWriteUnknown -    it "weakens additiveOnly when this run is no longer additive" $ do+    it "keeps additive-only when the prior record and this run agree" $ do       let priorId = ApplicationId "prior"           currentId = ApplicationId "current"-      (attachApplication currentId (Just (record (Set.singleton priorId) True)) (record Set.empty False) ^. #additiveOnly)-        `shouldBe` False+      (attachApplication currentId (Just (record (Set.singleton priorId) SharedWriteAdditiveOnly)) (record Set.empty SharedWriteAdditiveOnly) ^. #sharedWriteMode)+        `shouldBe` SharedWriteAdditiveOnly +    it "records a closure requirement when this run is no longer additive" $ do+      let priorId = ApplicationId "prior"+          currentId = ApplicationId "current"+      forM_ [minBound .. maxBound] $ \priorMode ->+        (attachApplication currentId (Just (record (Set.singleton priorId) priorMode)) (record Set.empty SharedWriteRequiresOwnershipClosure) ^. #sharedWriteMode)+          `shouldBe` SharedWriteRequiresOwnershipClosure+     it "trusts this run's answer when it is the only owner" $ do       let currentId = ApplicationId "current"-          prior = record (Set.singleton currentId) False-      (attachApplication currentId (Just prior) (record Set.empty True) ^. #additiveOnly) `shouldBe` True-      (attachApplication currentId Nothing (record Set.empty True) ^. #additiveOnly) `shouldBe` True+      forM_ [minBound .. maxBound] $ \priorMode ->+        (attachApplication currentId (Just (record (Set.singleton currentId) priorMode)) (record Set.empty SharedWriteAdditiveOnly) ^. #sharedWriteMode)+          `shouldBe` SharedWriteAdditiveOnly+      (attachApplication currentId Nothing (record Set.empty SharedWriteAdditiveOnly) ^. #sharedWriteMode) `shouldBe` SharedWriteAdditiveOnly --- | A file record carrying the given owners and additive-only verdict.-record :: Set.Set ApplicationId -> Bool -> FileRecord-record owners additive =-  FileRecord (hashContent "content") "module" Template fixedTime Nothing owners additive+-- | A file record carrying the given owners and shared-write mode.+record :: Set.Set ApplicationId -> SharedWriteMode -> FileRecord+record owners mode =+  FileRecord (hashContent "content") "module" Template fixedTime Nothing owners mode

@@ -0,0 +1,49 @@+module Seihou.Core.ArtifactIdentitySpec (tests) where++import Control.Monad (forM_)+import Data.Text (Text)+import Data.Text qualified as T+import Seihou.Core.ArtifactIdentity (isMachineLocalOriginUrl)+import Test.Hspec+import Test.Tasty+import Test.Tasty.Hspec (testSpec)++tests :: IO TestTree+tests = testSpec "Seihou.Core.ArtifactIdentity" spec++machineLocal :: [Text]+machineLocal =+  [ "/Users/alice/Keikaku/bokuno/seihou-modules",+    "  /srv/modules  ",+    "./modules",+    "../seihou-modules",+    ".",+    "..",+    "~/src/seihou-modules",+    "~",+    "file:///Users/alice/seihou-modules",+    "file:../modules",+    "C:\\src\\modules",+    "c:/src/modules"+  ]++remote :: [Text]+remote =+  [ "https://github.com/shinzui/seihou-modules.git",+    "http://example.com/mods",+    "ssh://git@github.com/shinzui/seihou-modules.git",+    "git://example.com/mods.git",+    "git@github.com:shinzui/seihou-modules.git",+    "github.com:shinzui/seihou-modules",+    "modules"+  ]++spec :: Spec+spec =+  describe "isMachineLocalOriginUrl" $ do+    forM_ machineLocal $ \url ->+      it ("treats " <> T.unpack url <> " as machine-local") $+        isMachineLocalOriginUrl url `shouldBe` True+    forM_ remote $ \url ->+      it ("treats " <> T.unpack url <> " as reachable from other machines") $+        isMachineLocalOriginUrl url `shouldBe` False

@@ -65,6 +65,16 @@         origin <- detectArtifactOrigin projectRoot moduleDir         origin `shouldBe` LocalOrigin "haskell-base" +    it "records an origin installed from a local path as a local origin" $ do+      withRoots $ \projectRoot installedRoot -> do+        let moduleDir = installedRoot </> "nix-haskell-flake"+        createDirectoryIfMissing True moduleDir+        writeFile+          (moduleDir </> ".seihou-origin.json")+          "{\"sourceUrl\":\"/Users/someone/src/modules\",\"repoName\":\"modules\"}"+        origin <- detectArtifactOrigin projectRoot moduleDir+        origin `shouldBe` LocalOrigin "nix-haskell-flake"+     it "falls back to a local origin when there is no metadata file" $ do       withRoots $ \projectRoot installedRoot -> do         let moduleDir = installedRoot </> "scratch-module"

@@ -0,0 +1,95 @@+module Seihou.Core.CheckoutSpec (tests) where++import Control.Monad (forM_)+import Data.Aeson qualified as Aeson+import Data.Either (isLeft)+import Data.Generics.Labels ()+import Data.Map.Strict qualified as Map+import Data.Set qualified as Set+import Data.Text qualified as T+import Data.Time (UTCTime (..), fromGregorian)+import Seihou.Core.Checkout+import Seihou.Core.Types+import Seihou.Effect.Filesystem (PathEntry (..))+import Seihou.Manifest.Types+import Seihou.Manifest.Upgrade+import Seihou.Prelude+import Test.Hspec+import Test.Tasty+import Test.Tasty.Hspec (testSpec)++record :: FilePath -> Text -> CheckoutOutputRecord+record source app = CheckoutOutputRecord (DirectorySymlink source) (Map.singleton (ApplicationId app) (Set.singleton "demo"))++tests :: IO TestTree+tests = testSpec "checkout declarations and planning" $ do+  let dest = ".local/config"+      old = Map.singleton dest (record "config/editor" "a")+      next = Map.singleton dest (record "config/new" "a")+      obs entry = Map.singleton dest (CheckoutObservation entry True [] True True)+      actions intent prior candidate entry = map (^. #action) (planCheckoutOutputs intent SyncIgnoredOnly prior candidate (obs entry) ^. #entries)+  it "rejects portable path escapes, reserved metadata and overlapping paths" $+    forM_ ["", ".", "../escape", "a/../b", "/abs", "C:local", "a\\b", "a//b", "a/./b", "a/", ".GIT/config", ".seihou/x", "a\0b"] $ \source ->+      validateCheckoutPaths source dest `shouldSatisfy` isLeft+  it "rejects source/destination ancestry in either direction" $ do+    validateCheckoutPaths "config" "config/local" `shouldSatisfy` isLeft+    validateCheckoutPaths "config/local" "config" `shouldSatisfy` isLeft+  it "uses canonical relative link text" $ do+    expectedTarget ".local/config" (DirectorySymlink "config/editor") `shouldBe` "../config/editor"+    expectedTarget ".claude/skills/demo" (DirectorySymlink "agents/skills/demo") `shouldBe` "../../agents/skills/demo"+  it "merges agreeing claims associatively, commutatively and idempotently" $ do+    let add a = mergeCheckoutRecord dest (record "config/editor" a)+        merge names = foldl (\acc app -> acc >>= add app) (Right Map.empty) names+    merge ["a", "b", "c"] `shouldBe` merge ["c", "a", "b"]+    merge ["a", "a"] `shouldBe` merge ["a"]+    merge ["a", "b", "c"] `shouldBe` (merge ["a"] >>= add "b" >>= add "c")+  it "refuses conflicting owners regardless of contribution order" $ do+    mergeCheckoutRecord dest (record "other" "b") old `shouldSatisfy` isLeft+    mergeCheckoutRecord dest (record "config/editor" "a") (Map.singleton dest (record "other" "b")) `shouldSatisfy` isLeft+  it "drops only selected owners" $ do+    Right shared <- pure (mergeCheckoutRecord dest (record "config/editor" "b") old)+    dropCheckoutOwners (Map.singleton (ApplicationId "a") (Set.singleton "demo")) shared `shouldBe` Map.singleton dest (record "config/editor" "b")+  it "rebuilds missing and wrong links but preserves correct links" $ do+    actions Rebuild old old EntryMissing `shouldBe` [CreateLink]+    actions Rebuild old old (EntrySymlink "wrong") `shouldBe` [ReplaceLink]+    actions Rebuild old old (EntrySymlink "../config/editor") `shouldBe` [UnchangedLink]+  it "refuses real objects without discarding other classifications" $ do+    let records = Map.insert ".local/second" (record "assets/shared" "a") old+        observations = Map.insert ".local/second" (CheckoutObservation EntryMissing True [] True True) (obs EntryDirectory)+        plan = planCheckoutOutputs Rebuild SyncIgnoredOnly records records observations+    checkoutApplicable plan `shouldBe` False+    map (^. #action) (plan ^. #entries) `shouldBe` [RefusedLink, CreateLink]+  it "does no repair for unchanged declarations or owner-only changes" $ do+    actions Reconcile old old EntryMissing `shouldBe` [UnchangedLink]+    actions Reconcile old (Map.singleton dest (record "config/editor" "b")) (EntrySymlink "edited") `shouldBe` [UnchangedLink]+  it "retires only matching links even with a missing source" $ do+    let observations = Map.singleton dest (CheckoutObservation (EntrySymlink "../config/editor") False [] True False)+    map (^. #action) (planCheckoutOutputs Reconcile ApplyDeclaration old Map.empty observations ^. #entries) `shouldBe` [RetireLink]+    actions Reconcile old Map.empty (EntrySymlink "edited") `shouldBe` [PreserveModified]+    actions Reconcile old Map.empty EntryDirectory `shouldBe` [PreserveModified]+    actions Reconcile old Map.empty EntryMissing `shouldBe` [AlreadyAbsent]+  it "retargets old or already-correct links but refuses third targets" $ do+    actions Reconcile old next (EntrySymlink "../config/editor") `shouldBe` [ReplaceLink]+    actions Reconcile old next (EntrySymlink "../config/new") `shouldBe` [UnchangedLink]+    actions Reconcile old next (EntrySymlink "edited") `shouldBe` [RefusedLink]+  it "rejects a rebuild contract with changed declarations" $+    checkoutApplicable (planCheckoutOutputs Rebuild SyncIgnoredOnly old next (obs EntryMissing)) `shouldBe` False+  it "keeps the warning policy distinct from sync's ignored-only policy" $ do+    let observations = Map.singleton dest (CheckoutObservation EntryMissing True [] False False)+    checkoutApplicable (planCheckoutOutputs Rebuild SyncIgnoredOnly old old observations) `shouldBe` False+    let apply = planCheckoutOutputs Reconcile ApplyDeclaration Map.empty old observations+    checkoutApplicable apply `shouldBe` True+    concatMap (^. #warnings) (apply ^. #entries) `shouldSatisfy` (not . null)+  it "adds schema 9 losslessly without inventing declarations" $ do+    let now = UTCTime (fromGregorian 2026 10 15) 0+        original = emptyManifest now & #version .~ ManifestSchemaVersion 8+    Right (_, document) <- pure (upgradeDocumentLosslessly (ManifestSchemaVersion 9) =<< decode original)+    case manifestFromJSON (encode document) of+      Right result -> Map.null (result ^. #checkoutOutputs) `shouldBe` True+      Left err -> expectationFailure err+  it "rejects duplicate keys before JSON object construction, including escaped-equivalent keys" $ do+    manifestFromJSON "{\"version\":9,\"version\":9}" `shouldSatisfy` isLeft+    manifestFromJSON "{\"version\":9,\"owners\":{\"a\":[],\"\\u0061\":[]}}" `shouldSatisfy` either (T.isInfixOf "duplicate" . T.pack) (const False)+  where+    decode manifest = first (const (MalformedDocument (ManifestSchemaVersion 8) "invalid fixture")) (Aeson.eitherDecode (manifestToJSON manifest))+    encode = Aeson.encode

@@ -40,7 +40,8 @@               src = "README.md.tpl",               dest = "README.md",               condition = Nothing,-              patch = Nothing+              patch = Nothing,+              lifecycle = Managed             }         ],       commands = [],@@ -180,7 +181,7 @@         let bad =               goodModule                 & #steps-                  .~ [Step Template "README.md.tpl" "../etc/passwd" Nothing Nothing]+                  .~ [Step Template "README.md.tpl" "../etc/passwd" Nothing Nothing Managed]         result <- validateModule tmpDir bad         case result of           Left (ValidationError _ errs) ->@@ -195,7 +196,7 @@         let bad =               goodModule                 & #steps-                  .~ [Step Template "README.md.tpl" "/etc/passwd" Nothing Nothing]+                  .~ [Step Template "README.md.tpl" "/etc/passwd" Nothing Nothing Managed]         result <- validateModule tmpDir bad         case result of           Left (ValidationError _ errs) ->@@ -210,7 +211,7 @@         let dotted =               goodModule                 & #steps-                  .~ [Step Template "README.md.tpl" "docs/README.v2.md" Nothing Nothing]+                  .~ [Step Template "README.md.tpl" "docs/README.v2.md" Nothing Nothing Managed]         result <- validateModule tmpDir dotted         case result of           Right m -> (m ^. #name) `shouldBe` "test-module"@@ -223,7 +224,7 @@         let bad =               goodModule                 & #steps-                  .~ [Step Template "README.md.tpl" "src/{{unknown}}/Main.hs" Nothing Nothing]+                  .~ [Step Template "README.md.tpl" "src/{{unknown}}/Main.hs" Nothing Nothing Managed]         result <- validateModule tmpDir bad         case result of           Left (ValidationError _ errs) ->@@ -241,7 +242,7 @@                   vars = [],                   exports = [VarExport {var = "missing", alias = Nothing}],                   prompts = [Prompt {var = "missing", text = "?", condition = Nothing, choices = Nothing}],-                  steps = [Step Template "nonexistent.tpl" "/bad/dest" Nothing Nothing],+                  steps = [Step Template "nonexistent.tpl" "/bad/dest" Nothing Nothing Managed],                   commands = [],                   dependencies = [],                   removal = Nothing,

@@ -0,0 +1,71 @@+module Seihou.Core.SeedSpec (tests) where++import Data.Either (isLeft)+import Data.Generics.Labels ()+import Data.Map.Strict qualified as Map+import Data.Set qualified as Set+import Data.Text qualified as T+import Data.Text.IO qualified as TIO+import Data.Time (UTCTime (..), fromGregorian)+import Seihou.Core.Module (checkSeedSteps)+import Seihou.Core.Seed+import Seihou.Core.Types+import Seihou.Dhall.Eval (evalModuleFromFile)+import Seihou.Manifest.Types+import Seihou.Prelude+import System.Directory (getCurrentDirectory)+import System.FilePath (takeDirectory)+import System.IO.Temp (withSystemTempDirectory)+import Test.Hspec+import Test.Tasty+import Test.Tasty.Hspec (testSpec)++tests :: IO TestTree+tests = testSpec "seed foundations" $ do+  let now = UTCTime (fromGregorian 2026 10 15) 0+      first = SeedRecord "demo" (Set.singleton (ApplicationId "a")) SeedCreated now+      second = SeedRecord "demo" (Set.singleton (ApplicationId "b")) SeedFoundExisting now+      manifest = mergeSeedRecord "CHANGELOG.md" second (mergeSeedRecord "CHANGELOG.md" first (emptyManifest now))+  it "preserves the first settlement while merging owners" $ do+    let Just receipt = Map.lookup "CHANGELOG.md" (manifest ^. #seeds)+    receipt ^. #outcome `shouldBe` SeedCreated+    receipt ^. #applicationIds `shouldBe` Set.fromList [ApplicationId "a", ApplicationId "b"]+  it "releases only selected owners and drops the last claim" $ do+    let one = dropSeedOwner (Set.singleton (ApplicationId "a")) "CHANGELOG.md" manifest+    Map.size (one ^. #seeds) `shouldBe` 1+    Map.null (dropSeedOwner (Set.singleton (ApplicationId "b")) "CHANGELOG.md" one ^. #seeds) `shouldBe` True+  it "round trips receipts without hashes or baselines" $ do+    manifestFromJSON (manifestToJSON manifest) `shouldBe` Right manifest+  it "rejects a managed/seed collision at decoding" $ do+    let file = FileRecord (SHA256 "hash") "demo" Copy now Nothing Set.empty SharedWriteUnknown+        invalid = manifest & #files .~ Map.singleton "CHANGELOG.md" file+    validateManifestInvariants invalid `shouldBe` Left (PathBothManagedAndSeeded "CHANGELOG.md")+    manifestFromJSON (manifestToJSON invalid) `shouldSatisfy` isLeft+  it "keeps schema 7 unchanged and diagnoses seed information loss" $ do+    let old = emptyManifest now & #version .~ ManifestSchemaVersion 7+    manifestFromJSON (manifestToJSON old) `shouldBe` Right old+  it "reports facts an older schema cannot encode" $ do+    manifestEncodingLoss (manifest & #version .~ ManifestSchemaVersion 7) `shouldSatisfy` (not . null)+  it "decodes omitted lifecycle and rejects invalid lifecycle values" $+    withSystemTempDirectory "lifecycle" $ \dir -> do+      cwd <- getCurrentDirectory+      let schema = takeDirectory cwd </> "schema/package.dhall"+          source field =+            T.unlines+              [ "let S = " <> T.pack schema,+                "in S.Module::{ name = \"demo\", version = Some \"1.0\", steps = [S.Step::{ strategy = \"template\", src = \"a\", dest = \"b\"" <> field <> " }] }"+              ]+      TIO.writeFile (dir </> "module.dhall") (source "")+      Right old <- evalModuleFromFile (dir </> "module.dhall")+      map (^. #lifecycle) (old ^. #steps) `shouldBe` [Managed]+      TIO.writeFile (dir </> "module.dhall") (source ", lifecycle = Some \"seed\"")+      Right seed <- evalModuleFromFile (dir </> "module.dhall")+      checkSeedSteps seed `shouldBe` []+      let patched = seed & #steps %~ map (#patch ?~ AppendFile)+      checkSeedSteps patched `shouldSatisfy` (not . null)+      checkSeedSteps (seed & #steps %~ map (#strategy .~ Structured)) `shouldSatisfy` (not . null)+      checkSeedSteps (seed & #steps %~ (<> map (#lifecycle .~ Managed) (seed ^. #steps))) `shouldSatisfy` (not . null)+      checkSeedSteps (seed & #removal ?~ Removal [RemovalStep RemoveFileAction "b" Nothing] []) `shouldSatisfy` (not . null)+      TIO.writeFile (dir </> "module.dhall") (source ", lifecycle = Some \"sede\"")+      invalid <- evalModuleFromFile (dir </> "module.dhall")+      invalid `shouldSatisfy` isLeft

@@ -33,7 +33,7 @@       generatedAt = fixedTime,       baseline = Nothing,       applicationIds = mempty,-      additiveOnly = False+      sharedWriteMode = SharedWriteUnknown     }  runStatus :: PureFS -> Manifest -> [TrackedFile]@@ -49,7 +49,7 @@             ( (emptyManifest fixedTime :: Manifest)                 & #files .~ Map.singleton "README.md" (mkRecord content)             )-          fs = PureFS (Map.singleton "README.md" content) mempty+          fs = PureFS (Map.singleton "README.md" content) mempty Map.empty           result = runStatus fs manifest       length result `shouldBe` 1       ((head result) ^. #path) `shouldBe` "README.md"@@ -63,7 +63,7 @@             ( (emptyManifest fixedTime :: Manifest)                 & #files .~ Map.singleton "README.md" (mkRecord originalContent)             )-          fs = PureFS (Map.singleton "README.md" modifiedContent) mempty+          fs = PureFS (Map.singleton "README.md" modifiedContent) mempty Map.empty           result = runStatus fs manifest       length result `shouldBe` 1       ((head result) ^. #status) `shouldBe` TfsModified@@ -95,6 +95,7 @@                   ]               )               mempty+              Map.empty           result = runStatus fs manifest       length result `shouldBe` 3       -- Results are sorted by path

@@ -48,7 +48,7 @@       exists `shouldBe` True      it "copyFile copies content" $ do-      let initial = PureFS (Map.singleton "src.txt" "source content") Set.empty+      let initial = PureFS (Map.singleton "src.txt" "source content") Set.empty Map.empty           (content, _) = runPure initial $ do             copyFile "src.txt" "dest.txt"             readFileText "dest.txt"

@@ -33,7 +33,7 @@   (emptyManifest fixedTime)     & #modules .~ [AppliedModule (ModuleName "haskell-base") emptyParentVars (LocalOrigin "haskell-base") Nothing fixedTime Nothing]     & #vars .~ Map.fromList [(VarName "project.name", "my-app")]-    & #files .~ Map.fromList [("README.md", FileRecord (SHA256 "abc123") (ModuleName "haskell-base") Template fixedTime Nothing mempty False)]+    & #files .~ Map.fromList [("README.md", FileRecord (SHA256 "abc123") (ModuleName "haskell-base") Template fixedTime Nothing mempty SharedWriteUnknown)]  spec :: Spec spec = do@@ -88,7 +88,7 @@                 runManifestStore manifestPath (writeManifest sampleManifest)                 c <- readFileText manifestPath                 pure ((), c)-      T.isInfixOf "\"version\":6" content `shouldBe` True+      T.isInfixOf "\"version\":9" content `shouldBe` True       T.isInfixOf "haskell-base" content `shouldBe` True       T.isInfixOf "my-app" content `shouldBe` True @@ -104,7 +104,7 @@      it "returns Left for corrupt JSON" $ do       let manifestPath = ".seihou/manifest.json"-          corruptFS = PureFS (Map.fromList [(manifestPath, "{ this is not json }")]) Set.empty+          corruptFS = PureFS (Map.fromList [(manifestPath, "{ this is not json }")]) Set.empty Map.empty           (result, _) =             runPureEff $               runFilesystemPure corruptFS $

@@ -38,9 +38,9 @@                 generatedAt = fixedTime,                 baseline = Nothing,                 applicationIds = Set.singleton applicationId,-                additiveOnly = False+                sharedWriteMode = SharedWriteUnknown               }-          initialFS = PureFS (Map.singleton ("/project/" <> path) content) Set.empty+          initialFS = PureFS (Map.singleton ("/project/" <> path) content) Set.empty Map.empty           ((result, stored), _) =             runPureEff $               runFilesystemPure initialFS $@@ -57,10 +57,10 @@           Map.lookup expectedRef stored `shouldBe` Just content      it "returns an error and publishes no reference when a generated file is missing" $ do-      let record = FileRecord (hashContent "planned") "module" Template fixedTime Nothing Set.empty False+      let record = FileRecord (hashContent "planned") "module" Template fixedTime Nothing Set.empty SharedWriteUnknown           ((result, stored), _) =             runPureEff $-              runFilesystemPure (PureFS Map.empty Set.empty) $+              runFilesystemPure (PureFS Map.empty Set.empty Map.empty) $                 runBaselineStorePure Map.empty $                   recordGeneratedBaselines "/project" (Map.singleton "missing.txt" record)       result `shouldSatisfy` isStoreFailure@@ -68,8 +68,8 @@      it "stores content that can be read back through the baseline effect" $ do       let content = "round trip"-          record = FileRecord (hashContent content) "module" Copy fixedTime Nothing Set.empty False-          initialFS = PureFS (Map.singleton "copy.txt" content) Set.empty+          record = FileRecord (hashContent content) "module" Copy fixedTime Nothing Set.empty SharedWriteUnknown+          initialFS = PureFS (Map.singleton "copy.txt" content) Set.empty Map.empty           ((result, readBack), _) =             runPureEff $               runFilesystemPure initialFS $@@ -87,7 +87,7 @@     it "collects and deduplicates every referenced blob" $ do       let first = baselineRefForContent "first"           second = baselineRefForContent "second"-          mkRecord ref = FileRecord (hashContent "applied") "module" Template fixedTime ref Set.empty False+          mkRecord ref = FileRecord (hashContent "applied") "module" Template fixedTime ref Set.empty SharedWriteUnknown           manifest :: Manifest           manifest =             ( (emptyManifest fixedTime)

@@ -0,0 +1,213 @@+module Seihou.Engine.CheckoutSpec (tests) where++import Control.Monad (forM_, when)+import Data.ByteString.Lazy qualified as LBS+import Data.Either (isLeft)+import Data.Generics.Labels ()+import Data.IORef+import Data.Map.Strict qualified as Map+import Data.Maybe (isJust)+import Data.Set qualified as Set+import Data.Text qualified as T+import Data.Text.Encoding qualified as TE+import Data.Text.IO qualified as TIO+import Data.Time (UTCTime (..), fromGregorian)+import Seihou.Core.Checkout+import Seihou.Core.Module (checkFileExistence, validateModule)+import Seihou.Core.Types+import Seihou.Dhall.Eval (evalModuleFromFile)+import Seihou.Effect.Filesystem+import Seihou.Effect.FilesystemInterp (runFilesystem)+import Seihou.Effect.Process+import Seihou.Effect.ProcessInterp (runProcessIO)+import Seihou.Engine.Checkout+import Seihou.Engine.Plan (compilePlan)+import Seihou.Engine.Remove (CheckoutRemovalSelection (..), selectCheckoutRemoval)+import Seihou.Manifest.Types+import Seihou.Prelude+import System.Directory qualified as D+import System.Exit (ExitCode (..))+import System.IO.Temp (withSystemTempDirectory)+import System.Process (readProcessWithExitCode)+import Test.Hspec+import Test.Tasty+import Test.Tasty.Hspec (testSpec)++fixtureManifest :: Manifest+fixtureManifest = emptyManifest now & #applications .~ [app] & #checkoutOutputs .~ Map.fromList [(dest, record source) | (dest, source) <- [(".local/config", "config/editor"), (".tool/assets", "assets/shared")]]+  where+    now = UTCTime (fromGregorian 2026 10 15) 0+    app = AppliedComposition (ApplicationId "a") (AppliedModuleTarget "demo") (LocalOrigin "demo") (Just "1") [] Nothing Nothing [AppliedInstanceState "demo" emptyParentVars (LocalOrigin "demo") (Just "1") Map.empty] Map.empty now+    record source = CheckoutOutputRecord (DirectorySymlink source) (Map.singleton (ApplicationId "a") (Set.singleton "demo"))++withFixture :: (FilePath -> IO a) -> IO a+withFixture action = withSystemTempDirectory "checkout-contract" $ \temp -> do+  root <- D.canonicalizePath temp+  (code, _, _) <- readProcessWithExitCode "git" ["-C", root, "init", "-q"] ""+  code `shouldBe` ExitSuccess+  forM_ ["config/editor", "assets/shared"] (D.createDirectoryIfMissing True . (root </>))+  TIO.writeFile (root </> ".gitignore") ".local/\n.tool/\n"+  TIO.writeFile (root </> "config/editor/settings") "sentinel"+  action root++prepare root intent old new = runEff $ runFilesystem $ runProcessIO $ prepareCheckoutPlan intent SyncIgnoredOnly root old new []++apply root plan = runEff $ runFilesystem $ runProcessIO $ applyCheckoutPlan SyncIgnoredOnly root plan++tests :: IO TestTree+tests = testSpec "checkout filesystem contract" $ do+  it "requires application selection for ambiguous owners and preserves unselected claims" $ do+    let [app] = fixtureManifest ^. #applications+        second = app & #applicationId .~ ApplicationId "b"+        shared = fixtureManifest & #applications .~ [app, second] & #checkoutOutputs %~ Map.map (#owners %~ Map.insert (ApplicationId "b") (Set.singleton "demo"))+    selectCheckoutRemoval shared "demo" Nothing `shouldSatisfy` isLeft+    Right (Just selected) <- pure (selectCheckoutRemoval shared "demo" (Just (ApplicationId "a")))+    let retained = selected ^. #candidateManifest+    map (^. #applicationId) (retained ^. #applications) `shouldBe` [ApplicationId "b"]+    map (Map.keys . (^. #owners)) (Map.elems (retained ^. #checkoutOutputs)) `shouldBe` [[ApplicationId "b"], [ApplicationId "b"]]+  it "rejects native spelling aliases when the temporary volume is case-insensitive" $ withFixture $ \root -> do+    insensitive <- D.doesDirectoryExist (root </> ".GIT")+    when insensitive $ do+      let aliased = fixtureManifest & #checkoutOutputs %~ Map.adjust (#spec .~ DirectorySymlink "config/Editor") ".local/config"+      Right plan <- prepare root Rebuild aliased aliased+      checkoutApplicable plan `shouldBe` False+      concatMap (map (^. #code) . (^. #errors)) (plan ^. #entries) `shouldContain` ["checkout_native_alias"]+  it "compiles project sources without an installed files source and validates rendered paths" $ withFixture $ \root -> do+    let modul = Module "demo" (Just "1.0.0") Nothing [VarDecl "source" VTText Nothing Nothing True Nothing] [] [] [Step Symlink "{{source}}" ".local/config" Nothing Nothing Checkout] [] [] Nothing []+    checkFileExistence root modul `shouldReturn` []+    compiled <- compilePlan root modul (Map.singleton "source" (VText "config/editor"))+    compiled `shouldBe` Right [CheckoutOutputOp ".local/config" (DirectorySymlink "config/editor") "demo"]+    escaped <- compilePlan root modul (Map.singleton "source" (VText "../outside"))+    escaped `shouldSatisfy` isLeft+    invalid <- validateModule root (modul & #steps %~ map (#lifecycle .~ Managed))+    invalid `shouldSatisfy` isLeft+    skipped <- compilePlan root (modul & #steps %~ map (#condition ?~ ExprLit False)) Map.empty+    skipped `shouldBe` Right []+  it "traces only declared link writes and parent creation, with fixed read-only Git calls" $ withFixture $ \root -> do+    Right plan <- prepare root Rebuild fixtureManifest fixtureManifest+    writes <- newIORef []+    processes <- newIORef []+    applied <- runEff $ tracedFilesystem writes $ tracedProcess processes $ applyCheckoutPlan SyncIgnoredOnly root plan+    applied ^. #failure `shouldBe` Nothing+    actualWrites <- readIORef writes+    Set.fromList actualWrites `shouldBe` Set.fromList [("mkdir", root </> ".local"), ("mkdir", root </> ".tool"), ("link", root </> ".local/config"), ("link", root </> ".tool/assets")]+    actualProcesses <- readIORef processes+    actualProcesses+      `shouldSatisfy` all+        ( \(cmd, args) ->+            cmd == "git" && case args of+              ["rev-parse", "--show-toplevel"] -> True+              ["ls-files", "--cached", "-z"] -> True+              ["check-ignore", "-q", "--", path] -> "./" `T.isPrefixOf` path+              _ -> False+        )+  it "creates portable links and converges without following their contents" $ withFixture $ \root -> do+    Right plan <- prepare root Rebuild fixtureManifest fixtureManifest+    map (^. #action) (plan ^. #entries) `shouldBe` [CreateLink, CreateLink]+    result <- apply root plan+    result ^. #failure `shouldBe` Nothing+    D.getSymbolicLinkTarget (root </> ".local/config") `shouldReturn` "../config/editor"+    TIO.readFile (root </> "config/editor/settings") `shouldReturn` "sentinel"+    Right repeated <- prepare root Rebuild fixtureManifest fixtureManifest+    map (^. #action) (repeated ^. #entries) `shouldBe` [UnchangedLink, UnchangedLink]+  it "repairs dangling wrong links and leaves sentinel target bytes alone" $ withFixture $ \root -> do+    D.createDirectoryIfMissing True (root </> ".local")+    D.createDirectoryLink "../missing" (root </> ".local/config")+    Right plan <- prepare root Rebuild fixtureManifest fixtureManifest+    map (^. #action) (plan ^. #entries) `shouldBe` [ReplaceLink, CreateLink]+    result <- apply root plan+    result ^. #failure `shouldBe` Nothing+  it "refuses every mutation when any destination is a real object" $ withFixture $ \root -> do+    D.createDirectoryIfMissing True (root </> ".local/config")+    TIO.writeFile (root </> ".local/config/sentinel") "keep"+    Right plan <- prepare root Rebuild fixtureManifest fixtureManifest+    checkoutApplicable plan `shouldBe` False+    result <- apply root plan+    result ^. #failure `shouldSatisfy` isJust+    D.doesPathExist (root </> ".tool") `shouldReturn` False+    TIO.readFile (root </> ".local/config/sentinel") `shouldReturn` "keep"+  it "refuses symlink ancestors and missing sources" $ withFixture $ \root -> do+    D.createDirectoryLink "assets" (root </> ".local")+    Right plan <- prepare root Rebuild fixtureManifest fixtureManifest+    checkoutApplicable plan `shouldBe` False+    D.removeDirectoryLink (root </> ".local")+    D.removeDirectory (root </> "assets/shared")+    Right missing <- prepare root Rebuild fixtureManifest fixtureManifest+    checkoutApplicable missing `shouldBe` False+  it "protects ignored tracked paths even when absent on disk" $ withFixture $ \root -> do+    D.createDirectoryIfMissing True (root </> ".local")+    TIO.writeFile (root </> ".local/config") "tracked"+    (code, _, _) <- readProcessWithExitCode "git" ["-C", root, "add", "-f", "--", ".local/config"] ""+    code `shouldBe` ExitSuccess+    D.removeFile (root </> ".local/config")+    Right plan <- prepare root Rebuild fixtureManifest fixtureManifest+    checkoutApplicable plan `shouldBe` False+    concatMap (map (^. #code) . (^. #errors)) (plan ^. #entries) `shouldContain` ["checkout_path_tracked"]+  it "reports unsupported symlink creation without copying source data" $ withFixture $ \root -> do+    Right plan <- prepare root Rebuild fixtureManifest fixtureManifest+    result <- runEff $ unsupportedLinks $ runProcessIO $ applyCheckoutPlan SyncIgnoredOnly root plan+    result ^. #failure `shouldSatisfy` isJust+    case result ^. #failure of+      Just err -> err ^. #message `shouldSatisfy` T.isInfixOf "symlink permissions"+      Nothing -> expectationFailure "expected a creation error"+    D.doesPathExist (root </> ".local") `shouldReturn` False+    TIO.readFile (root </> "config/editor/settings") `shouldReturn` "sentinel"+  it "rolls back an ordinary mid-apply failure and supports retry" $ withFixture $ \root -> do+    Right plan <- prepare root Rebuild fixtureManifest fixtureManifest+    result <- runEff $ runFilesystem $ runProcessIO $ applyCheckoutPlanWithHook (\n -> when (n == 1) (liftIO (ioError (userError "injected")))) SyncIgnoredOnly root plan+    result ^. #failure `shouldSatisfy` isJust+    D.doesPathExist (root </> ".local") `shouldReturn` False+    retried <- apply root plan+    retried ^. #failure `shouldBe` Nothing+  it "retires a dangling last-owner link without checking its source" $ withFixture $ \root -> do+    Right first <- prepare root Rebuild fixtureManifest fixtureManifest+    _ <- apply root first+    D.removeFile (root </> "config/editor/settings")+    D.removeDirectory (root </> "config/editor")+    let candidate = fixtureManifest & #checkoutOutputs %~ Map.delete ".local/config"+    Right retired <- prepare root Reconcile fixtureManifest candidate+    map (^. #action) (retired ^. #entries) `shouldBe` [RetireLink, UnchangedLink]+    result <- apply root retired+    result ^. #failure `shouldBe` Nothing+    D.pathIsSymbolicLink (root </> ".tool/assets") `shouldReturn` True+  it "rejects unknown specs and bad owners at the byte decoding boundary" $ do+    let bytes = manifestToJSON fixtureManifest+    manifestFromJSON bytes `shouldBe` Right fixtureManifest+    manifestFromJSON (replace "directory-symlink" "invented-kind" bytes) `shouldSatisfy` isLeft+    manifestFromJSON (manifestToJSON (fixtureManifest & #applications .~ [])) `shouldSatisfy` isLeft+  where+    replace a b = LBS.fromStrict . TE.encodeUtf8 . T.replace a b . TE.decodeUtf8 . LBS.toStrict++-- These first-order effects can be reissued in an isolated real interpreter.+-- The trace fails on any text read/write, copy, rename or recursive removal.+tracedFilesystem :: (IOE :> es) => IORef [(Text, FilePath)] -> Eff (Filesystem : es) a -> Eff es a+tracedFilesystem trace = interpret $ \_ operation -> do+  case operation of+    CreateDirectoryIfMissing _ path -> liftIO (modifyIORef' trace (("mkdir", path) :))+    CreateDirectoryLink _ path -> liftIO (modifyIORef' trace (("link", path) :))+    RemoveLink path -> liftIO (modifyIORef' trace (("unlink", path) :))+    InspectPath _ -> pure ()+    ListDirectory _ -> pure ()+    NormalizePath _ -> pure ()+    _ -> liftIO (ioError (userError "checkout attempted an unexpected filesystem effect"))+  liftIO $ runEff $ runFilesystem $ reissue operation++reissue :: Filesystem m a -> Eff '[Filesystem, IOE] a+reissue (CreateDirectoryIfMissing parents path) = createDirectoryIfMissing parents path+reissue (CreateDirectoryLink target path) = createLink target path+reissue (RemoveLink path) = removeLink path+reissue (InspectPath path) = inspectPath path+reissue (ListDirectory path) = listDirectory path+reissue (NormalizePath path) = normalizePath path+reissue (RemoveDirectoryIfEmpty path) = removeDirectoryIfEmpty path+reissue _ = liftIO (ioError (userError "unexpected filesystem effect"))++tracedProcess :: (IOE :> es) => IORef [(Text, [Text])] -> Eff (Process : es) a -> Eff es a+tracedProcess trace = interpret $ \_ (RunProcess cmd args root) -> do+  liftIO (modifyIORef' trace ((cmd, args) :))+  liftIO $ runEff $ runProcessIO $ runProcess cmd args root++unsupportedLinks :: (IOE :> es) => Eff (Filesystem : es) a -> Eff es a+unsupportedLinks = interpret $ \_ operation -> case operation of+  CreateDirectoryLink _ _ -> liftIO (ioError (userError "symlink creation unsupported"))+  _ -> liftIO $ runEff $ runFilesystem $ reissue operation

@@ -41,7 +41,7 @@       generatedAt = fixedTime,       baseline = Nothing,       applicationIds = mempty,-      additiveOnly = False+      sharedWriteMode = SharedWriteUnknown     }  -- | Helper to create a manifest with file records (avoids ambiguous record update).@@ -57,6 +57,8 @@           applications = base ^. #applications,           recipe = base ^. #recipe,           blueprint = base ^. #blueprint,+          seeds = base ^. #seeds,+          checkoutOutputs = base ^. #checkoutOutputs,           blueprintMigrations = base ^. #blueprintMigrations         } @@ -75,7 +77,7 @@     it "classifies file in plan + on disk (not in manifest) as Conflict" $ do       let manifest = emptyManifest fixedTime           planned = [("README.md", "# Hello", modName, Nothing)]-          fs = PureFS (Map.singleton "README.md" "existing content") mempty+          fs = PureFS (Map.singleton "README.md" "existing content") mempty Map.empty           result = runDiff fs manifest active planned       length (result ^. #conflicts) `shouldBe` 1       ((head (result ^. #conflicts)) ^. #path) `shouldBe` "README.md"@@ -83,7 +85,7 @@     it "classifies patch op on existing file (not in manifest) as New, not Conflict" $ do       let manifest = emptyManifest fixedTime           planned = [(".gitignore", ".claude/\n", modName, Just AppendSection)]-          fs = PureFS (Map.singleton ".gitignore" ".seihou/\n") mempty+          fs = PureFS (Map.singleton ".gitignore" ".seihou/\n") mempty Map.empty           result = runDiff fs manifest active planned       length (result ^. #conflicts) `shouldBe` 0       length (result ^. #new) `shouldBe` 1@@ -95,7 +97,7 @@           patchContent = "new section"           manifest = manifestWithFiles (Map.singleton "config.txt" (mkRecord originalContent))           planned = [("config.txt", patchContent, modName, Just AppendSection)]-          fs = PureFS (Map.singleton "config.txt" userContent) mempty+          fs = PureFS (Map.singleton "config.txt" userContent) mempty Map.empty           result = runDiff fs manifest active planned       length (result ^. #conflicts) `shouldBe` 0       length (result ^. #modified) `shouldBe` 1@@ -105,7 +107,7 @@       let content = "# Hello World"           manifest = manifestWithFiles (Map.singleton "README.md" (mkRecord content))           planned = [("README.md", content, modName, Nothing)]-          fs = PureFS (Map.singleton "README.md" content) mempty+          fs = PureFS (Map.singleton "README.md" content) mempty Map.empty           result = runDiff fs manifest active planned       length (result ^. #unchanged) `shouldBe` 1       head (result ^. #unchanged) `shouldBe` "README.md"@@ -116,7 +118,7 @@           manifest = manifestWithFiles (Map.singleton "README.md" (mkRecord oldContent))           planned = [("README.md", newContent, modName, Nothing)]           -- Disk matches manifest (user didn't touch it)-          fs = PureFS (Map.singleton "README.md" oldContent) mempty+          fs = PureFS (Map.singleton "README.md" oldContent) mempty Map.empty           result = runDiff fs manifest active planned       length (result ^. #modified) `shouldBe` 1       ((head (result ^. #modified)) ^. #path) `shouldBe` "README.md"@@ -129,7 +131,7 @@           manifest = manifestWithFiles (Map.singleton "README.md" (mkRecord originalContent))           planned = [("README.md", planContent, modName, Nothing)]           -- Disk was modified by user (doesn't match manifest)-          fs = PureFS (Map.singleton "README.md" userContent) mempty+          fs = PureFS (Map.singleton "README.md" userContent) mempty Map.empty           result = runDiff fs manifest active planned       length (result ^. #conflicts) `shouldBe` 1       ((head (result ^. #conflicts)) ^. #path) `shouldBe` "README.md"@@ -142,7 +144,7 @@                 & #files .~ Map.singleton "old-file.txt" (mkRecord content)             )           planned = [] :: [(FilePath, Text, ModuleName, Maybe PatchOp)] -- module no longer produces this file-          fs = PureFS (Map.singleton "old-file.txt" content) mempty+          fs = PureFS (Map.singleton "old-file.txt" content) mempty Map.empty           result = runDiff fs manifest active planned       length (result ^. #orphaned) `shouldBe` 1       ((head (result ^. #orphaned)) ^. #path) `shouldBe` "old-file.txt"@@ -183,6 +185,7 @@             PureFS               (Map.fromList [("unchanged.txt", existingContent), ("orphaned.txt", "orphan")])               mempty+              Map.empty           result = runDiff fs manifest active planned       length (result ^. #new) `shouldBe` 1       length (result ^. #unchanged) `shouldBe` 1@@ -210,12 +213,12 @@                 generatedAt = fixedTime,                 baseline = Nothing,                 applicationIds = mempty,-                additiveOnly = False+                sharedWriteMode = SharedWriteUnknown               }           manifest = manifestWithFiles (Map.singleton "other.txt" record)           planned = [("new.txt", "new content", modName, Nothing)]           activeModules = Set.singleton modName -- "test-module", NOT "other-module"-          fs = PureFS (Map.singleton "other.txt" content) mempty+          fs = PureFS (Map.singleton "other.txt" content) mempty Map.empty           result = runDiff fs manifest activeModules planned       length (result ^. #orphaned) `shouldBe` 0       length (result ^. #new) `shouldBe` 1@@ -225,7 +228,7 @@           manifest = manifestWithFiles (Map.singleton "old.txt" (mkRecord content))           planned = [("new.txt", "new content", modName, Nothing)]           activeModules = Set.singleton modName -- file belongs to active module-          fs = PureFS (Map.singleton "old.txt" content) mempty+          fs = PureFS (Map.singleton "old.txt" content) mempty Map.empty           result = runDiff fs manifest activeModules planned       length (result ^. #orphaned) `shouldBe` 1       ((head (result ^. #orphaned)) ^. #path) `shouldBe` "old.txt"@@ -240,7 +243,7 @@                 generatedAt = fixedTime,                 baseline = Nothing,                 applicationIds = mempty,-                additiveOnly = False+                sharedWriteMode = SharedWriteUnknown               }           manifest =             manifestWithFiles@@ -256,6 +259,7 @@             PureFS               (Map.fromList [("active-old.txt", "active old"), ("other.txt", "other content")])               mempty+              Map.empty           result = runDiff fs manifest activeModules planned       -- active-old.txt is orphaned (active module no longer produces it)       length (result ^. #orphaned) `shouldBe` 1@@ -274,13 +278,13 @@                 generatedAt = fixedTime,                 baseline = Nothing,                 applicationIds = mempty,-                additiveOnly = False+                sharedWriteMode = SharedWriteUnknown               }           manifest = manifestWithFiles (Map.singleton "shared.txt" otherRecord)           -- active module wants to write to same path owned by inactive module           planned = [("shared.txt", "new content from active", modName, Nothing)]           activeModules = Set.singleton modName-          fs = PureFS (Map.singleton "shared.txt" "other content") mempty+          fs = PureFS (Map.singleton "shared.txt" "other content") mempty Map.empty           result = runDiff fs manifest activeModules planned       -- File exists on disk but not in active manifest → Conflict       length (result ^. #conflicts) `shouldBe` 1@@ -298,7 +302,7 @@                 generatedAt = fixedTime,                 baseline = Nothing,                 applicationIds = mempty,-                additiveOnly = False+                sharedWriteMode = SharedWriteUnknown               }           manifest =             manifestWithFiles@@ -320,6 +324,7 @@                   ]               )               mempty+              Map.empty           result = runDiff fs manifest activeModules planned       -- from-a.txt unchanged (active, still produced)       length (result ^. #unchanged) `shouldBe` 1

@@ -95,7 +95,7 @@       Map.size records `shouldBe` 0      it "handles CopyFileOp by reading source and writing dest" $ do-      let initial = PureFS (Map.singleton "/source/file.txt" "copied content") mempty+      let initial = PureFS (Map.singleton "/source/file.txt" "copied content") mempty Map.empty           ops = [CopyFileOp "/source/file.txt" "dest.txt"]           (records, fs) = runExecFS initial ops       Map.member "dest.txt" records `shouldBe` True@@ -126,7 +126,7 @@       (record ^. #strategy) `shouldBe` Structured      it "executes PatchFileOp AppendFile on existing file" $ do-      let initial = PureFS (Map.singleton "/project/README.md" "# Title\n") mempty+      let initial = PureFS (Map.singleton "/project/README.md" "# Title\n") mempty Map.empty           ops = [PatchFileOp "README.md" "extra line\n" AppendFile Template modName]           (records, fs) = runExecFS initial ops       Map.member "README.md" records `shouldBe` True@@ -135,7 +135,7 @@       T.isInfixOf "extra line" content `shouldBe` True      it "executes PatchFileOp PrependFile on existing file" $ do-      let initial = PureFS (Map.singleton "/project/README.md" "# Title\n") mempty+      let initial = PureFS (Map.singleton "/project/README.md" "# Title\n") mempty Map.empty           ops = [PatchFileOp "README.md" "header\n" PrependFile Template modName]           (records, fs) = runExecFS initial ops       Map.member "README.md" records `shouldBe` True@@ -144,7 +144,7 @@       T.isInfixOf "# Title" content `shouldBe` True      it "executes PatchFileOp AppendSection with section markers" $ do-      let initial = PureFS (Map.singleton "/project/README.md" "# Title\n") mempty+      let initial = PureFS (Map.singleton "/project/README.md" "# Title\n") mempty Map.empty           ops = [PatchFileOp "README.md" "section content\n" AppendSection Template modName]           (records, fs) = runExecFS initial ops       Map.member "README.md" records `shouldBe` True@@ -161,7 +161,7 @@       T.isInfixOf "new content" content `shouldBe` True      it "executes PatchFileOp AppendLineIfAbsent, skipping existing lines" $ do-      let initial = PureFS (Map.singleton "/project/.gitignore" "node_modules/\n.env\n") mempty+      let initial = PureFS (Map.singleton "/project/.gitignore" "node_modules/\n.env\n") mempty Map.empty           ops = [PatchFileOp ".gitignore" ".env\n.claude/\n" AppendLineIfAbsent Template modName]           (records, fs) = runExecFS initial ops       Map.member ".gitignore" records `shouldBe` True@@ -169,42 +169,42 @@       content `shouldBe` "node_modules/\n.env\n.claude/\n"      it "executes PatchFileOp AppendLineIfAbsent idempotently" $ do-      let initial = PureFS (Map.singleton "/project/.gitignore" "node_modules/\n.claude/\n") mempty+      let initial = PureFS (Map.singleton "/project/.gitignore" "node_modules/\n.claude/\n") mempty Map.empty           ops = [PatchFileOp ".gitignore" ".claude/\n" AppendLineIfAbsent Template modName]           (records, fs) = runExecFS initial ops       Map.member ".gitignore" records `shouldBe` True       let content = (fs ^. #files) Map.! "/project/.gitignore"       content `shouldBe` "node_modules/\n.claude/\n" -  describe "executePlan additiveOnly" $ do+  describe "executePlan sharedWriteMode" $ do     it "records an additive patch as additive-only" $ do       let ops = [PatchFileOp ".gitignore" "/result\n" AppendLineIfAbsent Template modName]           (records, _) = runExecFS emptyFS ops-      ((records Map.! ".gitignore") ^. #additiveOnly) `shouldBe` True+      ((records Map.! ".gitignore") ^. #sharedWriteMode) `shouldBe` SharedWriteAdditiveOnly      it "records an appended section as additive-only" $ do       let ops = [PatchFileOp ".gitignore" "/dist\n" AppendSection Template modName]           (records, _) = runExecFS emptyFS ops-      ((records Map.! ".gitignore") ^. #additiveOnly) `shouldBe` True+      ((records Map.! ".gitignore") ^. #sharedWriteMode) `shouldBe` SharedWriteAdditiveOnly      it "does not record a position-dependent patch as additive-only" $ do       -- AppendFile and PrependFile place bytes relative to whatever is       -- already in the file, so replaying one owner can reorder the result.       let appendOps = [PatchFileOp "notes.md" "tail\n" AppendFile Template modName]           prependOps = [PatchFileOp "notes.md" "head\n" PrependFile Template modName]-      ((fst (runExecFS emptyFS appendOps) Map.! "notes.md") ^. #additiveOnly) `shouldBe` False-      ((fst (runExecFS emptyFS prependOps) Map.! "notes.md") ^. #additiveOnly) `shouldBe` False+      ((fst (runExecFS emptyFS appendOps) Map.! "notes.md") ^. #sharedWriteMode) `shouldBe` SharedWriteRequiresOwnershipClosure+      ((fst (runExecFS emptyFS prependOps) Map.! "notes.md") ^. #sharedWriteMode) `shouldBe` SharedWriteRequiresOwnershipClosure      it "does not record a whole-file write as additive-only" $ do       let ops = [WriteFileOp "README.md" "# Title\n" Template]           (records, _) = runExecFS emptyFS ops-      ((records Map.! "README.md") ^. #additiveOnly) `shouldBe` False+      ((records Map.! "README.md") ^. #sharedWriteMode) `shouldBe` SharedWriteRequiresOwnershipClosure      it "does not record a copied file as additive-only" $ do-      let initial = PureFS (Map.singleton "/source/file.txt" "copied") mempty+      let initial = PureFS (Map.singleton "/source/file.txt" "copied") mempty Map.empty           ops = [CopyFileOp "/source/file.txt" "dest.txt"]           (records, _) = runExecFS initial ops-      ((records Map.! "dest.txt") ^. #additiveOnly) `shouldBe` False+      ((records Map.! "dest.txt") ^. #sharedWriteMode) `shouldBe` SharedWriteRequiresOwnershipClosure      it "folds the flag across every operation targeting one destination" $ do       -- A path this module both writes and patches is not additive-only, and@@ -214,7 +214,7 @@               PatchFileOp ".gitignore" "/result\n" AppendLineIfAbsent Template modName             ]           (records, _) = runExecFS emptyFS ops-      ((records Map.! ".gitignore") ^. #additiveOnly) `shouldBe` False+      ((records Map.! ".gitignore") ^. #sharedWriteMode) `shouldBe` SharedWriteRequiresOwnershipClosure      it "keeps one destination's write mode out of another's record" $ do       let ops =@@ -222,8 +222,8 @@               PatchFileOp ".gitignore" "/result\n" AppendLineIfAbsent Template modName             ]           (records, _) = runExecFS emptyFS ops-      ((records Map.! "README.md") ^. #additiveOnly) `shouldBe` False-      ((records Map.! ".gitignore") ^. #additiveOnly) `shouldBe` True+      ((records Map.! "README.md") ^. #sharedWriteMode) `shouldBe` SharedWriteRequiresOwnershipClosure+      ((records Map.! ".gitignore") ^. #sharedWriteMode) `shouldBe` SharedWriteAdditiveOnly    describe "dryRunPlan" $ do     it "formats WriteFileOp" $ do

@@ -58,11 +58,11 @@ mkManifest entries =   (emptyManifest fixedTime)     & #modules .~ [AppliedModule {name = modName, parentVars = emptyParentVars, origin = LocalOrigin "demo", moduleVersion = Just "1.0.0", appliedAt = fixedTime, removal = Nothing}]-    & #files .~ Map.fromList [(path, FileRecord {hash = hashContent content, moduleName = modName, strategy = Template, generatedAt = fixedTime, baseline = Nothing, applicationIds = mempty, additiveOnly = False}) | (path, content) <- entries]+    & #files .~ Map.fromList [(path, FileRecord {hash = hashContent content, moduleName = modName, strategy = Template, generatedAt = fixedTime, baseline = Nothing, applicationIds = mempty, sharedWriteMode = SharedWriteUnknown}) | (path, content) <- entries]  -- | Build an in-memory filesystem from (path, content) pairs. mkFS :: [(FilePath, Text)] -> PureFS-mkFS entries = PureFS (Map.fromList entries) Set.empty+mkFS entries = PureFS (Map.fromList entries) Set.empty Map.empty  -- | Single-step plan wrapping the supplied ops. chain1 :: Text -> Text -> [MigrationOp] -> MigrationPlan

@@ -60,7 +60,7 @@                   vars = [],                   exports = [],                   prompts = [],-                  steps = [Step Copy "data.txt" "data.txt" Nothing Nothing],+                  steps = [Step Copy "data.txt" "data.txt" Nothing Nothing Managed],                   commands = [],                   dependencies = [],                   removal = Nothing,@@ -82,7 +82,7 @@                   vars = [],                   exports = [],                   prompts = [],-                  steps = [Step Template "hello.tpl" "hello.txt" Nothing Nothing],+                  steps = [Step Template "hello.tpl" "hello.txt" Nothing Nothing Managed],                   commands = [],                   dependencies = [],                   removal = Nothing,@@ -104,7 +104,7 @@                   vars = [],                   exports = [],                   prompts = [],-                  steps = [Step Copy "data.txt" "data.txt" (Just (ExprLit False)) Nothing],+                  steps = [Step Copy "data.txt" "data.txt" (Just (ExprLit False)) Nothing Managed],                   commands = [],                   dependencies = [],                   removal = Nothing,@@ -126,7 +126,7 @@                   vars = [],                   exports = [],                   prompts = [],-                  steps = [Step Copy "data.txt" "data.txt" (Just (ExprLit True)) Nothing],+                  steps = [Step Copy "data.txt" "data.txt" (Just (ExprLit True)) Nothing Managed],                   commands = [],                   dependencies = [],                   removal = Nothing,@@ -148,7 +148,7 @@                   vars = [],                   exports = [],                   prompts = [],-                  steps = [Step Copy "LICENSE" "LICENSE" (Just (ExprIsSet "license")) Nothing],+                  steps = [Step Copy "LICENSE" "LICENSE" (Just (ExprIsSet "license")) Nothing Managed],                   commands = [],                   dependencies = [],                   removal = Nothing,@@ -177,7 +177,7 @@                   vars = [],                   exports = [],                   prompts = [],-                  steps = [Step Template "pkg.cabal.tpl" "{{name}}.cabal" Nothing Nothing],+                  steps = [Step Template "pkg.cabal.tpl" "{{name}}.cabal" Nothing Nothing Managed],                   commands = [],                   dependencies = [],                   removal = Nothing,@@ -199,7 +199,7 @@                   vars = [],                   exports = [],                   prompts = [],-                  steps = [Step Template "README.md.tpl" "{{project.name}}/README.md" Nothing Nothing],+                  steps = [Step Template "README.md.tpl" "{{project.name}}/README.md" Nothing Nothing Managed],                   commands = [],                   dependencies = [],                   removal = Nothing,@@ -224,7 +224,7 @@                   vars = [],                   exports = [],                   prompts = [],-                  steps = [Step Template "README.md.tpl" "{{project.name}}/README.md" Nothing Nothing],+                  steps = [Step Template "README.md.tpl" "{{project.name}}/README.md" Nothing Nothing Managed],                   commands = [],                   dependencies = [],                   removal = Nothing,@@ -249,7 +249,7 @@                   vars = [],                   exports = [],                   prompts = [],-                  steps = [Step Template "README.md.tpl" "docs/README.v2.md" Nothing Nothing],+                  steps = [Step Template "README.md.tpl" "docs/README.v2.md" Nothing Nothing Managed],                   commands = [],                   dependencies = [],                   removal = Nothing,@@ -271,7 +271,7 @@                   vars = [],                   exports = [],                   prompts = [],-                  steps = [Step Template "Lib.hs.tpl" "src/Lib.hs" Nothing Nothing],+                  steps = [Step Template "Lib.hs.tpl" "src/Lib.hs" Nothing Nothing Managed],                   commands = [],                   dependencies = [],                   removal = Nothing,@@ -295,8 +295,8 @@                   exports = [],                   prompts = [],                   steps =-                    [ Step Template "A.hs.tpl" "src/A.hs" Nothing Nothing,-                      Step Template "B.hs.tpl" "src/B.hs" Nothing Nothing+                    [ Step Template "A.hs.tpl" "src/A.hs" Nothing Nothing Managed,+                      Step Template "B.hs.tpl" "src/B.hs" Nothing Nothing Managed                     ],                   commands = [],                   dependencies = [],@@ -324,7 +324,7 @@                   vars = [],                   exports = [],                   prompts = [],-                  steps = [Step Template "hello.tpl" "hello.txt" Nothing Nothing],+                  steps = [Step Template "hello.tpl" "hello.txt" Nothing Nothing Managed],                   commands = [],                   dependencies = [],                   removal = Nothing,@@ -348,7 +348,7 @@                   vars = [],                   exports = [],                   prompts = [],-                  steps = [Step DhallText "greeting.dhall" "greeting.txt" Nothing Nothing],+                  steps = [Step DhallText "greeting.dhall" "greeting.txt" Nothing Nothing Managed],                   commands = [],                   dependencies = [],                   removal = Nothing,@@ -374,7 +374,7 @@                   vars = [],                   exports = [],                   prompts = [],-                  steps = [Step DhallText "pkg.dhall" "pkg.txt" Nothing Nothing],+                  steps = [Step DhallText "pkg.dhall" "pkg.txt" Nothing Nothing Managed],                   commands = [],                   dependencies = [],                   removal = Nothing,@@ -396,7 +396,7 @@                   vars = [],                   exports = [],                   prompts = [],-                  steps = [Step DhallText "bad.dhall" "out.txt" Nothing Nothing],+                  steps = [Step DhallText "bad.dhall" "out.txt" Nothing Nothing Managed],                   commands = [],                   dependencies = [],                   removal = Nothing,@@ -420,7 +420,7 @@                   vars = [],                   exports = [],                   prompts = [],-                  steps = [Step Structured "data.json.gen" "data.json" Nothing Nothing],+                  steps = [Step Structured "data.json.gen" "data.json" Nothing Nothing Managed],                   commands = [],                   dependencies = [],                   removal = Nothing,@@ -451,7 +451,7 @@                   vars = [],                   exports = [],                   prompts = [],-                  steps = [Step Structured "config.yaml.gen" "config.yaml" Nothing Nothing],+                  steps = [Step Structured "config.yaml.gen" "config.yaml" Nothing Nothing Managed],                   commands = [],                   dependencies = [],                   removal = Nothing,@@ -483,7 +483,7 @@                   vars = [],                   exports = [],                   prompts = [],-                  steps = [Step Structured "bad.gen" "out.json" Nothing Nothing],+                  steps = [Step Structured "bad.gen" "out.json" Nothing Nothing Managed],                   commands = [],                   dependencies = [],                   removal = Nothing,@@ -507,7 +507,7 @@                   vars = [],                   exports = [],                   prompts = [],-                  steps = [Step Structured "data.gen" "output.txt" Nothing Nothing],+                  steps = [Step Structured "data.gen" "output.txt" Nothing Nothing Managed],                   commands = [],                   dependencies = [],                   removal = Nothing,@@ -572,7 +572,7 @@                   vars = [],                   exports = [],                   prompts = [],-                  steps = [Step Template "section.tpl" "README.md" Nothing (Just AppendFile)],+                  steps = [Step Template "section.tpl" "README.md" Nothing (Just AppendFile) Managed],                   commands = [],                   dependencies = [],                   removal = Nothing,@@ -595,7 +595,7 @@                   vars = [],                   exports = [],                   prompts = [],-                  steps = [Step Template "section.tpl" "README.md" Nothing (Just AppendSection)],+                  steps = [Step Template "section.tpl" "README.md" Nothing (Just AppendSection) Managed],                   commands = [],                   dependencies = [],                   removal = Nothing,@@ -619,7 +619,7 @@                   vars = [],                   exports = [],                   prompts = [],-                  steps = [Step Template "conditional.tpl" "out.txt" Nothing Nothing],+                  steps = [Step Template "conditional.tpl" "out.txt" Nothing Nothing Managed],                   commands = [],                   dependencies = [],                   removal = Nothing,@@ -643,7 +643,7 @@                   vars = [],                   exports = [],                   prompts = [],-                  steps = [Step Template "conditional.tpl" "out.txt" Nothing Nothing],+                  steps = [Step Template "conditional.tpl" "out.txt" Nothing Nothing Managed],                   commands = [],                   dependencies = [],                   removal = Nothing,@@ -667,7 +667,7 @@                   vars = [],                   exports = [],                   prompts = [],-                  steps = [Step Template "patch.tpl" "README.md" Nothing (Just AppendFile)],+                  steps = [Step Template "patch.tpl" "README.md" Nothing (Just AppendFile) Managed],                   commands = [],                   dependencies = [],                   removal = Nothing,@@ -691,7 +691,7 @@                   vars = [],                   exports = [],                   prompts = [],-                  steps = [Step Copy "header.txt" "out.txt" Nothing (Just PrependFile)],+                  steps = [Step Copy "header.txt" "out.txt" Nothing (Just PrependFile) Managed],                   commands = [],                   dependencies = [],                   removal = Nothing,@@ -714,7 +714,7 @@                   vars = [],                   exports = [],                   prompts = [],-                  steps = [Step Structured "data.gen" "data.json" Nothing (Just AppendFile)],+                  steps = [Step Structured "data.gen" "data.json" Nothing (Just AppendFile) Managed],                   commands = [],                   dependencies = [],                   removal = Nothing,@@ -738,7 +738,7 @@                   vars = [],                   exports = [],                   prompts = [],-                  steps = [Step Copy "data.txt" "data.txt" Nothing Nothing],+                  steps = [Step Copy "data.txt" "data.txt" Nothing Nothing Managed],                   commands = [Command "echo hello" Nothing Nothing],                   dependencies = [],                   removal = Nothing,@@ -791,7 +791,7 @@                   vars = [],                   exports = [],                   prompts = [],-                  steps = [Step Copy "data.txt" "data.txt" Nothing Nothing],+                  steps = [Step Copy "data.txt" "data.txt" Nothing Nothing Managed],                   commands = [Command "echo skip" Nothing (Just (ExprLit False))],                   dependencies = [],                   removal = Nothing,@@ -815,7 +815,7 @@                   vars = [],                   exports = [],                   prompts = [],-                  steps = [Step Copy "data.txt" "data.txt" Nothing Nothing],+                  steps = [Step Copy "data.txt" "data.txt" Nothing Nothing Managed],                   commands = [Command "echo yes" Nothing (Just (ExprIsSet "name"))],                   dependencies = [],                   removal = Nothing,@@ -839,7 +839,7 @@                   vars = [],                   exports = [],                   prompts = [],-                  steps = [Step Copy "data.txt" "data.txt" Nothing Nothing],+                  steps = [Step Copy "data.txt" "data.txt" Nothing Nothing Managed],                   commands = [Command "echo post" Nothing Nothing],                   dependencies = [],                   removal = Nothing,@@ -872,7 +872,7 @@                   vars = [],                   exports = [],                   prompts = [],-                  steps = [Step Copy "data.txt" "data.txt" Nothing Nothing],+                  steps = [Step Copy "data.txt" "data.txt" Nothing Nothing Managed],                   commands = [Command "npm install" (Just "subdir") Nothing],                   dependencies = [],                   removal = Nothing,@@ -897,7 +897,7 @@                   vars = [],                   exports = [],                   prompts = [],-                  steps = [Step Copy "data.txt" "data.txt" Nothing Nothing],+                  steps = [Step Copy "data.txt" "data.txt" Nothing Nothing Managed],                   commands = [Command "echo {{name}}" Nothing Nothing],                   dependencies = [],                   removal = Nothing,@@ -922,7 +922,7 @@                   vars = [],                   exports = [],                   prompts = [],-                  steps = [Step Copy "data.txt" "data.txt" Nothing Nothing],+                  steps = [Step Copy "data.txt" "data.txt" Nothing Nothing Managed],                   commands = [Command "cabal build" (Just "{{name}}") Nothing],                   dependencies = [],                   removal = Nothing,@@ -972,7 +972,7 @@                   vars = [],                   exports = [],                   prompts = [],-                  steps = [Step Copy "data.txt" "data.txt" Nothing Nothing],+                  steps = [Step Copy "data.txt" "data.txt" Nothing Nothing Managed],                   commands = [Command "echo {{missing}}" Nothing Nothing],                   dependencies = [],                   removal = Nothing,

@@ -352,6 +352,8 @@       applications = manifest ^. #applications,       recipe = manifest ^. #recipe,       blueprint = manifest ^. #blueprint,+      seeds = manifest ^. #seeds,+      checkoutOutputs = manifest ^. #checkoutOutputs,       blueprintMigrations = manifest ^. #blueprintMigrations     } @@ -364,7 +366,7 @@       generatedAt = fixedTime,       baseline = baseline,       applicationIds = Set.fromList owners',-      additiveOnly = False+      sharedWriteMode = SharedWriteUnknown     }  -- | A record for a path every owner reaches through an additive patch.@@ -377,7 +379,7 @@       generatedAt = fixedTime,       baseline = baseline,       applicationIds = Set.fromList owners',-      additiveOnly = True+      sharedWriteMode = SharedWriteAdditiveOnly     }  owners :: FilePath -> [ApplicationId] -> Map.Map FilePath DesiredFileOwner

@@ -36,18 +36,18 @@ mkManifest isRemovable fileContents =   (emptyManifest fixedTime)     & #modules .~ [AppliedModule {name = modName, parentVars = emptyParentVars, origin = LocalOrigin "test-module", moduleVersion = Nothing, appliedAt = fixedTime, removal = if isRemovable then Just (Removal [] []) else Nothing}]-    & #files .~ Map.fromList [(path, FileRecord {hash = hashContent content, moduleName = modName, strategy = Template, generatedAt = fixedTime, baseline = Nothing, applicationIds = mempty, additiveOnly = False}) | (path, content) <- fileContents]+    & #files .~ Map.fromList [(path, FileRecord {hash = hashContent content, moduleName = modName, strategy = Template, generatedAt = fixedTime, baseline = Nothing, applicationIds = mempty, sharedWriteMode = SharedWriteUnknown}) | (path, content) <- fileContents]  -- | Helper: create a manifest with a specific removal spec. mkManifestWithRemoval :: Removal -> [(FilePath, Text)] -> Manifest mkManifestWithRemoval removal fileContents =   (emptyManifest fixedTime)     & #modules .~ [AppliedModule {name = modName, parentVars = emptyParentVars, origin = LocalOrigin "test-module", moduleVersion = Nothing, appliedAt = fixedTime, removal = Just removal}]-    & #files .~ Map.fromList [(path, FileRecord {hash = hashContent content, moduleName = modName, strategy = Template, generatedAt = fixedTime, baseline = Nothing, applicationIds = mempty, additiveOnly = False}) | (path, content) <- fileContents]+    & #files .~ Map.fromList [(path, FileRecord {hash = hashContent content, moduleName = modName, strategy = Template, generatedAt = fixedTime, baseline = Nothing, applicationIds = mempty, sharedWriteMode = SharedWriteUnknown}) | (path, content) <- fileContents]  -- | Helper: create a PureFS with files. mkFS :: [(FilePath, Text)] -> PureFS-mkFS fileContents = PureFS (Map.fromList fileContents) Set.empty+mkFS fileContents = PureFS (Map.fromList fileContents) Set.empty Map.empty  -- | Run computeRemovalPlan in the pure filesystem. runPlan :: PureFS -> Manifest -> ModuleName -> Either RemovalError RemovalPlan@@ -158,7 +158,7 @@      it "preserves files from other modules in manifest" $ do       let base = mkManifest True [("mine.txt", "mine")]-          otherRec = FileRecord (hashContent "other") otherMod Template fixedTime Nothing mempty False+          otherRec = FileRecord (hashContent "other") otherMod Template fixedTime Nothing mempty SharedWriteUnknown           manifest =             Manifest               { version = base ^. #version,@@ -169,6 +169,8 @@                 applications = base ^. #applications,                 recipe = base ^. #recipe,                 blueprint = base ^. #blueprint,+                seeds = base ^. #seeds,+                checkoutOutputs = base ^. #checkoutOutputs,                 blueprintMigrations = base ^. #blueprintMigrations               }           fs = mkFS [("mine.txt", "mine"), ("other.txt", "other")]@@ -341,7 +343,7 @@      it "preserves other modules' files in manifest" $ do       let base = mkManifest True [("mine.txt", "mine")]-          otherRec = FileRecord (hashContent "other") otherMod Template fixedTime Nothing mempty False+          otherRec = FileRecord (hashContent "other") otherMod Template fixedTime Nothing mempty SharedWriteUnknown           manifest =             Manifest               { version = base ^. #version,@@ -352,6 +354,8 @@                 applications = base ^. #applications,                 recipe = base ^. #recipe,                 blueprint = base ^. #blueprint,+                seeds = base ^. #seeds,+                checkoutOutputs = base ^. #checkoutOutputs,                 blueprintMigrations = base ^. #blueprintMigrations               }           fs = mkFS [("mine.txt", "mine"), ("other.txt", "other")]

@@ -3,6 +3,8 @@ import Control.Exception (throwIO) import Control.Lens ((&), (.~), (^.)) import Control.Monad (unless, when)+import Data.Aeson qualified as Aeson+import Data.Aeson.KeyMap qualified as KeyMap import Data.ByteString.Lazy qualified as LBS import Data.Foldable (traverse_) import Data.Generics.Labels ()@@ -34,6 +36,44 @@  spec :: Spec spec = do+  describe "literal symlink journal snapshots" $ do+    it "restores a dangling target without traversing it" $ withSystemTempDirectory "checkout-journal" $ \root -> do+      Directory.createDirectoryLink "missing-old-target" (root </> "local-link")+      Right transaction <- beginUpdateTransaction root (Set.singleton "local-link")+      Directory.removeDirectoryLink (root </> "local-link")+      Directory.createDirectoryLink "missing-new-target" (root </> "local-link")+      restored <- recoverIncompleteTransactions root+      restored `shouldBe` [Right ()]+      Directory.getSymbolicLinkTarget (root </> "local-link") `shouldReturn` "missing-old-target"+    it "retains the version-1 regular-file recovery contract" $ withSystemTempDirectory "legacy-journal" $ \root -> do+      TIO.writeFile (root </> "managed.txt") "before"+      Right transaction <- beginUpdateTransaction root (Set.singleton "managed.txt")+      let journal = transaction ^. #transactionDirectory </> "journal.json"+      Right (Aeson.Object object) <- Aeson.eitherDecode <$> LBS.readFile journal+      let stripEntry (Aeson.Object fields) = Aeson.Object (KeyMap.delete "kind" (KeyMap.delete "target" fields))+          stripEntry other = other+          legacy = KeyMap.mapWithKey (\key value -> case (key, value) of ("version", _) -> Aeson.Number 1; ("entries", Aeson.Array values) -> Aeson.Array (fmap stripEntry values); _ -> value) object+      LBS.writeFile journal (Aeson.encode (Aeson.Object legacy))+      TIO.writeFile (root </> "managed.txt") "after"+      recoverIncompleteTransactions root `shouldReturn` [Right ()]+      TIO.readFile (root </> "managed.txt") `shouldReturn` "before"+    it "rejects an unknown version-2 kind before recovery writes" $ withSystemTempDirectory "unknown-journal" $ \root -> do+      TIO.writeFile (root </> "managed.txt") "before"+      Right transaction <- beginUpdateTransaction root (Set.singleton "managed.txt")+      let journal = transaction ^. #transactionDirectory </> "journal.json"+      bytes <- TIO.readFile journal+      TIO.writeFile journal (T.replace "\"kind\":\"file\"" "\"kind\":\"unknown\"" bytes)+      TIO.writeFile (root </> "managed.txt") "after"+      restored <- rollbackUpdateTransaction transaction+      restored `shouldSatisfy` \case Left TransactionJournalMalformed {} -> True; _ -> False+      TIO.readFile (root </> "managed.txt") `shouldReturn` "after"+    it "removes a newly created dangling link when restoring an absent snapshot" $ withSystemTempDirectory "checkout-journal" $ \root -> do+      Right transaction <- beginUpdateTransaction root (Set.singleton "local-link")+      Directory.createDirectoryLink "missing-target" (root </> "local-link")+      restored <- rollbackUpdateTransaction transaction+      restored `shouldBe` Right ()+      Directory.listDirectory root `shouldReturn` [".seihou"]+   describe "applyReconciliation" $ do     it "writes resolved files and updates baselines, hashes, ownership, and orphans" $       withSystemTempDirectory "seihou-update-transaction" $ \projectRoot -> do@@ -191,7 +231,7 @@     -- A targeted update plans only the applications it selected, so for a     -- co-owned path the reconciliation result describes a subset of the     -- owners. Everything belonging to an unselected owner must survive.-    let coOwned additive =+    let coOwned mode =           ( ( fileRecord "/dist\n" (Just (baselineRefForContent "/dist\n")) [appA, appB]                 & #moduleName                   .~ "co-owner"@@ -199,8 +239,8 @@               & #strategy                 .~ DhallText           )-            & #additiveOnly-              .~ additive+            & #sharedWriteMode+              .~ mode         alphaOnly additive =           (desiredFile ".gitignore" "/dist\n/result\n" [appA] & #moduleName .~ "alpha")             & #additiveOnly@@ -223,38 +263,42 @@             pure ((candidate ^. #files) Map.! ".gitignore")      it "keeps an unselected co-owner in the record" $ do-      record <- runPartial (Set.singleton appA) (coOwned True) (alphaOnly True)+      record <- runPartial (Set.singleton appA) (coOwned SharedWriteAdditiveOnly) (alphaOnly True)       (record ^. #applicationIds) `shouldBe` Set.fromList [appA, appB]      it "keeps the prior attribution when an unselected co-owner survives" $ do-      record <- runPartial (Set.singleton appA) (coOwned True) (alphaOnly True)+      record <- runPartial (Set.singleton appA) (coOwned SharedWriteAdditiveOnly) (alphaOnly True)       (record ^. #moduleName) `shouldBe` "co-owner"       (record ^. #strategy) `shouldBe` DhallText -    it "keeps additiveOnly true when both the prior record and the candidate agree" $ do-      record <- runPartial (Set.singleton appA) (coOwned True) (alphaOnly True)-      (record ^. #additiveOnly) `shouldBe` True+    it "keeps additive-only when both the prior record and the candidate agree" $ do+      record <- runPartial (Set.singleton appA) (coOwned SharedWriteAdditiveOnly) (alphaOnly True)+      (record ^. #sharedWriteMode) `shouldBe` SharedWriteAdditiveOnly -    it "cannot strengthen additiveOnly from a partial update" $ do-      -- The prior False may have been set because the unselected co-owner-      -- writes the whole file. This run has no evidence about that owner, so-      -- flipping the flag open here would let a later update through unsafely.-      record <- runPartial (Set.singleton appA) (coOwned False) (alphaOnly True)-      (record ^. #additiveOnly) `shouldBe` False+    it "cannot strengthen a closure requirement from a partial update" $ do+      -- The unselected co-owner may write the whole file. This run has no+      -- evidence about that owner, so opening the gate here would let a later+      -- update through unsafely.+      record <- runPartial (Set.singleton appA) (coOwned SharedWriteRequiresOwnershipClosure) (alphaOnly True)+      (record ^. #sharedWriteMode) `shouldBe` SharedWriteRequiresOwnershipClosure -    it "weakens additiveOnly when the candidate is no longer additive" $ do-      record <- runPartial (Set.singleton appA) (coOwned True) (alphaOnly False)-      (record ^. #additiveOnly) `shouldBe` False+    it "keeps unknown evidence unknown from a partial update" $ do+      record <- runPartial (Set.singleton appA) (coOwned SharedWriteUnknown) (alphaOnly True)+      (record ^. #sharedWriteMode) `shouldBe` SharedWriteUnknown +    it "records a closure requirement when the candidate is no longer additive" $ do+      record <- runPartial (Set.singleton appA) (coOwned SharedWriteAdditiveOnly) (alphaOnly False)+      (record ^. #sharedWriteMode) `shouldBe` SharedWriteRequiresOwnershipClosure+     it "re-credits the path and trusts the candidate once every owner is selected" $ do       -- Subtracting the selection rather than the desired set matters here:       -- appA stopped writing the path but was part of this update, so it       -- genuinely loses ownership and the candidate's own answer stands.-      record <- runPartial (Set.fromList [appA, appB]) (coOwned False) (alphaOnly True)+      record <- runPartial (Set.fromList [appA, appB]) (coOwned SharedWriteUnknown) (alphaOnly True)       (record ^. #applicationIds) `shouldBe` Set.singleton appA       (record ^. #moduleName) `shouldBe` "alpha"       (record ^. #strategy) `shouldBe` Template-      (record ^. #additiveOnly) `shouldBe` True+      (record ^. #sharedWriteMode) `shouldBe` SharedWriteAdditiveOnly    describe "rollback and recovery" $ do     it "rolls every earlier mutation back after an injected failure" $@@ -350,6 +394,8 @@                   applications = candidate ^. #applications,                   recipe = candidate ^. #recipe,                   blueprint = candidate ^. #blueprint,+                  seeds = candidate ^. #seeds,+                  checkoutOutputs = candidate ^. #checkoutOutputs,                   blueprintMigrations = candidate ^. #blueprintMigrations                 }         setUpdateTransactionExpectedManifest transaction finalManifest `shouldReturn` Right ()@@ -446,6 +492,8 @@           applications = manifest ^. #applications,           recipe = manifest ^. #recipe,           blueprint = manifest ^. #blueprint,+          seeds = manifest ^. #seeds,+          checkoutOutputs = manifest ^. #checkoutOutputs,           blueprintMigrations = manifest ^. #blueprintMigrations         } @@ -458,7 +506,7 @@       generatedAt = fixedTime,       baseline = baseline,       applicationIds = Set.fromList owners,-      additiveOnly = False+      sharedWriteMode = SharedWriteUnknown     }  desiredFile :: FilePath -> Text -> [ApplicationId] -> DesiredFile

@@ -40,7 +40,8 @@               src = "README.md.tpl",               dest = "README.md",               condition = Nothing,-              patch = Nothing+              patch = Nothing,+              lifecycle = Managed             }         ],       commands = [],@@ -62,7 +63,7 @@         ],       exports = [VarExport {var = "nonexistent", alias = Nothing}],       prompts = [Prompt {var = "undeclared", text = "?", condition = Nothing, choices = Nothing}],-      steps = [Step Template "missing.tpl" "/absolute/path" Nothing Nothing],+      steps = [Step Template "missing.tpl" "/absolute/path" Nothing Nothing Managed],       commands = [],       dependencies = [],       removal = Nothing,@@ -222,8 +223,8 @@         writeFile (tmpDir </> "files" </> "b.tpl") "stub"         let m =               withSteps-                [ Step Template "a.tpl" "out.txt" Nothing Nothing,-                  Step Template "b.tpl" "out.txt" Nothing Nothing+                [ Step Template "a.tpl" "out.txt" Nothing Nothing Managed,+                  Step Template "b.tpl" "out.txt" Nothing Nothing Managed                 ]                 goodModule         report <- buildReport True tmpDir m@@ -236,8 +237,8 @@         writeFile (tmpDir </> "files" </> "b.tpl") "stub"         let m =               withSteps-                [ Step Template "a.tpl" "out.txt" Nothing Nothing,-                  Step Template "b.tpl" "out.txt" Nothing (Just AppendFile)+                [ Step Template "a.tpl" "out.txt" Nothing Nothing Managed,+                  Step Template "b.tpl" "out.txt" Nothing (Just AppendFile) Managed                 ]                 goodModule         report <- buildReport True tmpDir m@@ -281,7 +282,7 @@           ]         stepWithCondition cond =           withSteps-            [Step Template "README.md.tpl" "README.md" cond Nothing]+            [Step Template "README.md.tpl" "README.md" cond Nothing Managed]             (withVars baseVars goodModule)      it "flags a bool variable compared against a string literal in a when clause" $ do

@@ -68,6 +68,8 @@           applications = base ^. #applications,           recipe = base ^. #recipe,           blueprint = base ^. #blueprint,+          seeds = base ^. #seeds,+          checkoutOutputs = base ^. #checkoutOutputs,           blueprintMigrations = base ^. #blueprintMigrations         } @@ -170,7 +172,7 @@                 executePlan "" ops Map.empty modName fixedTime           manifest = manifestWithFiles fixedTime records           -- Simulate user editing README.md-          fs2 = PureFS (Map.insert "README.md" "user edit" (fs1 ^. #files)) (fs1 ^. #dirs)+          fs2 = PureFS (Map.insert "README.md" "user edit" (fs1 ^. #files)) (fs1 ^. #dirs) Map.empty           -- Compute diff → should detect conflict           (diff, _) =             runPureEff $

@@ -98,7 +98,7 @@           -- Provide all vars but use an empty var map for IsSet evaluation.           -- The real scenario: license has a default so it's always set.           -- To test the conditional, we use a stripped-down module with only the LICENSE step.-          let licenseStep = Step Copy "LICENSE" "LICENSE" (Just (ExprIsSet "license")) Nothing+          let licenseStep = Step Copy "LICENSE" "LICENSE" (Just (ExprIsSet "license")) Nothing Managed               smallModule = modul & #steps .~ [licenseStep]               vars = Map.empty -- no license variable set           planResult <- compilePlan (fixtures </> "haskell-base") smallModule vars

@@ -50,7 +50,7 @@ -- | Helper to set modules on a Manifest without ambiguous record update. withManifestModules :: [AppliedModule] -> Manifest -> Manifest withManifestModules mods m =-  Manifest (m ^. #version) (m ^. #genAt) mods (m ^. #vars) (m ^. #files) (m ^. #applications) (m ^. #recipe) (m ^. #blueprint) (m ^. #blueprintMigrations)+  Manifest (m ^. #version) (m ^. #genAt) mods (m ^. #vars) (m ^. #files) (m ^. #seeds) (m ^. #checkoutOutputs) (m ^. #applications) (m ^. #recipe) (m ^. #blueprint) (m ^. #blueprintMigrations)  -- | Every string that appears anywhere inside a value keyed @origin@ or -- @targetOrigin@, at any depth.@@ -122,6 +122,8 @@ manifestWithEveryStringPosition :: Manifest manifestWithEveryStringPosition =   manifestWithEveryOriginPosition+    & #checkoutOutputs .~ Map.singleton ".local/shared" (CheckoutOutputRecord (DirectorySymlink "assets/shared") (Map.singleton (ApplicationId "app") (Set.singleton "haskell-base")))+    & #seeds .~ Map.singleton "CHANGELOG.md" (SeedRecord "haskell-base" (Set.singleton (ApplicationId "app")) SeedCreated fixedTime)     & #modules       .~ [ AppliedModule              { name = ModuleName "haskell-base",@@ -148,7 +150,7 @@             fixedTime             (Just (BaselineRef (hashContent "flake")))             (Set.singleton (ApplicationId "app"))-            False+            SharedWriteRequiresOwnershipClosure         )     & #applications       %~ map (withCommandReceipts (Map.singleton receiptFingerprint receipt))@@ -265,7 +267,7 @@     it "creates a manifest with the current version" $ do       let m = emptyManifest fixedTime       (m ^. #version) `shouldBe` currentManifestVersion-      (m ^. #version) `shouldBe` 6+      (m ^. #version) `shouldBe` currentManifestVersion      it "creates a manifest with no modules, vars, or files" $ do       let m = emptyManifest fixedTime@@ -344,6 +346,8 @@                 applications = base ^. #applications,                 recipe = Nothing,                 blueprint = Nothing,+                seeds = Map.empty,+                checkoutOutputs = Map.empty,                 blueprintMigrations = []               }       manifestFromJSON (manifestToJSON m) `shouldBe` Right m@@ -352,7 +356,7 @@       let m :: Manifest           m =             ( (emptyManifest fixedTime)-                & #files .~ Map.fromList [("README.md", FileRecord {hash = SHA256 "abc123", moduleName = ModuleName "haskell-base", strategy = Template, generatedAt = fixedTime, baseline = Nothing, applicationIds = mempty, additiveOnly = False}), ("my-app.cabal", FileRecord {hash = SHA256 "def456", moduleName = ModuleName "haskell-base", strategy = DhallText, generatedAt = fixedTime, baseline = Nothing, applicationIds = mempty, additiveOnly = False})]+                & #files .~ Map.fromList [("README.md", FileRecord {hash = SHA256 "abc123", moduleName = ModuleName "haskell-base", strategy = Template, generatedAt = fixedTime, baseline = Nothing, applicationIds = mempty, sharedWriteMode = SharedWriteUnknown}), ("my-app.cabal", FileRecord {hash = SHA256 "def456", moduleName = ModuleName "haskell-base", strategy = DhallText, generatedAt = fixedTime, baseline = Nothing, applicationIds = mempty, sharedWriteMode = SharedWriteUnknown})]             )       manifestFromJSON (manifestToJSON m) `shouldBe` Right m @@ -373,15 +377,17 @@                 files =                   Map.fromList                     [ ( "README.md",-                        FileRecord (SHA256 "aaa") (ModuleName "haskell-base") Template fixedTime Nothing mempty False+                        FileRecord (SHA256 "aaa") (ModuleName "haskell-base") Template fixedTime Nothing mempty SharedWriteUnknown                       ),                       ( "LICENSE",-                        FileRecord (SHA256 "bbb") (ModuleName "haskell-base") Copy fixedTime Nothing mempty False+                        FileRecord (SHA256 "bbb") (ModuleName "haskell-base") Copy fixedTime Nothing mempty SharedWriteUnknown                       )                     ],                 applications = [],                 recipe = Nothing,                 blueprint = Nothing,+                seeds = Map.empty,+                checkoutOutputs = Map.empty,                 blueprintMigrations = []               }       manifestFromJSON (manifestToJSON m) `shouldBe` Right m@@ -389,7 +395,7 @@     it "roundtrips all strategy types" $ do       let strategies = [Copy, Template, DhallText, Structured]           makeRecord s =-            FileRecord (SHA256 "hash") (ModuleName "mod") s fixedTime Nothing mempty False+            FileRecord (SHA256 "hash") (ModuleName "mod") s fixedTime Nothing mempty SharedWriteUnknown           m :: Manifest           m =             ( (emptyManifest fixedTime)@@ -503,7 +509,7 @@                 generatedAt = fixedTime,                 baseline = Just (BaselineRef (hashContent "generated baseline")),                 applicationIds = Set.fromList [appId1, appId2],-                additiveOnly = False+                sharedWriteMode = SharedWriteUnknown               }           manifest =             ( (emptyManifest fixedTime)@@ -664,7 +670,7 @@                 commandReceipts = Map.empty,                 appliedAt = fixedTime               }-          fileRecord = FileRecord (SHA256 "hash") "base" Template fixedTime Nothing mempty False+          fileRecord = FileRecord (SHA256 "hash") "base" Template fixedTime Nothing mempty SharedWriteUnknown           recipe = AppliedRecipe "recipe" (LocalOrigin "recipe") (Just "1.0.0") fixedTime           normalBlueprint = AppliedBlueprint "payments" (LocalOrigin "payments") (Just "0.4.0") fixedTime [] False Nothing Nothing           seed =@@ -707,8 +713,8 @@         Right _ -> expectationFailure "a version-1 manifest should not decode directly"         Left err -> err `shouldSatisfy` isInfixOf "seihou manifest upgrade" -  describe "additive-only file records" $ do-    let additiveRecord additive =+  describe "shared-write evidence" $ do+    let modeRecord mode =           FileRecord             { hash = SHA256 "aaa",               moduleName = ModuleName "nix-haskell-flake",@@ -716,46 +722,105 @@               generatedAt = fixedTime,               baseline = Nothing,               applicationIds = Set.fromList [ApplicationId "app-one", ApplicationId "app-two"],-              additiveOnly = additive+              sharedWriteMode = mode             }-        manifestWith additive =-          (emptyManifest fixedTime) & #files .~ Map.singleton ".gitignore" (additiveRecord additive)-        recordKeys manifest = case Aeson.decode (manifestToJSON manifest) of+        manifestWith mode =+          (emptyManifest fixedTime) & #files .~ Map.singleton ".gitignore" (modeRecord mode)+        recordObject manifest = case Aeson.decode (manifestToJSON manifest) of           Just (Aeson.Object top) -> case KeyMap.lookup "files" top of             Just (Aeson.Object files) -> case KeyMap.lookup ".gitignore" files of-              Just (Aeson.Object record) -> map Key.toText (KeyMap.keys record)-              _ -> []-            _ -> []-          _ -> []+              Just (Aeson.Object record) -> record+              _ -> KeyMap.empty+            _ -> KeyMap.empty+          _ -> KeyMap.empty+        schemaJson :: Int -> String -> String+        schemaJson version recordTail =+          "{\"version\":"+            <> show version+            <> ",\"generatedAt\":\"2026-03-01T10:30:00Z\",\"modules\":[]"+            <> ",\"variables\":{},\"applications\":[],\"files\":{\".gitignore\":{\"hash\":\"aaa\""+            <> ",\"module\":\"nix-haskell-flake\",\"strategy\":\"template\""+            <> ",\"generatedAt\":\"2026-03-01T10:30:00Z\""+            <> recordTail+            <> "}}}"+        schema6Json = schemaJson 6+        schema7Json = schemaJson 7+        decodedMode json = case manifestFromJSON (LBS8.pack json) of+          Left err -> Left err+          Right decoded -> maybe (Left "no .gitignore record") (Right . (^. #sharedWriteMode)) (Map.lookup ".gitignore" (decoded ^. #files)) -    it "roundtrips a record whose additiveOnly is true" $ do-      manifestFromJSON (manifestToJSON (manifestWith True)) `shouldBe` Right (manifestWith True)+    forM_ [minBound .. maxBound] $ \mode ->+      it ("roundtrips a schema-7 record whose mode is " <> show mode) $+        manifestFromJSON (manifestToJSON (manifestWith mode)) `shouldBe` Right (manifestWith mode) -    it "roundtrips a record whose additiveOnly is false" $ do-      manifestFromJSON (manifestToJSON (manifestWith False)) `shouldBe` Right (manifestWith False)+    it "always emits sharedWriteMode at schema 7, including unknown" $ do+      KeyMap.lookup "sharedWriteMode" (recordObject (manifestWith SharedWriteUnknown))+        `shouldBe` Just (Aeson.String "unknown")+      KeyMap.lookup "sharedWriteMode" (recordObject (manifestWith SharedWriteAdditiveOnly))+        `shouldBe` Just (Aeson.String "additive-only")+      KeyMap.lookup "sharedWriteMode" (recordObject (manifestWith SharedWriteRequiresOwnershipClosure))+        `shouldBe` Just (Aeson.String "requires-ownership-closure")+      KeyMap.member "additiveOnly" (recordObject (manifestWith SharedWriteAdditiveOnly)) `shouldBe` False -    it "emits the additiveOnly key only when the flag is true" $ do-      recordKeys (manifestWith True) `shouldContain` ["additiveOnly"]-      recordKeys (manifestWith False) `shouldNotContain` ["additiveOnly"]+    it "decodes a schema-6 additiveOnly: true as certified additive-only" $+      decodedMode (schema6Json ",\"additiveOnly\":true") `shouldBe` Right SharedWriteAdditiveOnly -    it "decodes a record with no additiveOnly key as not additive-only" $ do-      -- A manifest written before the field existed must keep every shared-      -- path under the ownership closure, so the absent key must fail closed.-      let json =-            "{\"version\":6,\"generatedAt\":\"2026-03-01T10:30:00Z\",\"modules\":[]"-              <> ",\"variables\":{},\"applications\":[],\"files\":{\".gitignore\":{\"hash\":\"aaa\""-              <> ",\"module\":\"nix-haskell-flake\",\"strategy\":\"template\""-              <> ",\"generatedAt\":\"2026-03-01T10:30:00Z\"}}}"-      case manifestFromJSON json of-        Left err -> expectationFailure ("expected the manifest to decode, got: " <> err)-        Right decoded -> case Map.lookup ".gitignore" (decoded ^. #files) of-          Nothing -> expectationFailure "expected a .gitignore record"-          Just decodedRecord -> (decodedRecord ^. #additiveOnly) `shouldBe` False+    it "decodes a schema-6 record with no additiveOnly key as unknown, not as closure-required" $+      -- The version-6 encoder omitted false, so absence proves nothing.+      decodedMode (schema6Json "") `shouldBe` Right SharedWriteUnknown +    it "decodes a schema-6 additiveOnly: false as unknown" $+      decodedMode (schema6Json ",\"additiveOnly\":false") `shouldBe` Right SharedWriteUnknown++    it "keeps the decoded schema-6 version so capability checks see what the file proves" $+      case manifestFromJSON (LBS8.pack (schema6Json "")) of+        Left err -> expectationFailure err+        Right decoded -> do+          (decoded ^. #version) `shouldBe` ManifestSchemaVersion 6+          manifestSupports TargetedAdditiveSharedPathUpdate decoded `shouldBe` False++    it "re-encodes a schema-6 manifest in the schema-6 representation" $ do+      let asSchema6 mode = manifestWith mode & #version .~ ManifestSchemaVersion 6+      KeyMap.lookup "additiveOnly" (recordObject (asSchema6 SharedWriteAdditiveOnly)) `shouldBe` Just (Aeson.Bool True)+      KeyMap.member "sharedWriteMode" (recordObject (asSchema6 SharedWriteAdditiveOnly)) `shouldBe` False+      -- Schema 6 cannot say "closure required"; it fails closed to unknown.+      KeyMap.member "additiveOnly" (recordObject (asSchema6 SharedWriteRequiresOwnershipClosure)) `shouldBe` False++    it "rejects a schema-7 record without sharedWriteMode and names the record and key" $+      case manifestFromJSON (LBS8.pack (schema7Json "")) of+        Right _ -> expectationFailure "a schema-7 record without sharedWriteMode must not decode"+        Left err -> do+          err `shouldSatisfy` isInfixOf ".gitignore"+          err `shouldSatisfy` isInfixOf "sharedWriteMode"++    it "rejects a schema-7 record with an unrecognised sharedWriteMode" $+      case manifestFromJSON (LBS8.pack (schema7Json ",\"sharedWriteMode\":\"maybe\"")) of+        Right _ -> expectationFailure "an unknown sharedWriteMode value must not decode"+        Left err -> do+          err `shouldSatisfy` isInfixOf ".gitignore"+          err `shouldSatisfy` isInfixOf "sharedWriteMode"+          err `shouldSatisfy` isInfixOf "maybe"++    it "does not read a schema-7 additiveOnly key as evidence" $+      case manifestFromJSON (LBS8.pack (schema7Json ",\"additiveOnly\":true")) of+        Right _ -> expectationFailure "schema 7 requires sharedWriteMode even when additiveOnly is present"+        Left err -> err `shouldSatisfy` isInfixOf "sharedWriteMode"++  describe "manifest capabilities" $ do+    it "requires schema 7 for targeted additive shared-path updates" $+      minimumManifestVersion TargetedAdditiveSharedPathUpdate `shouldBe` ManifestSchemaVersion 7++    it "never requires a schema newer than this build" $+      forM_ [minBound .. maxBound] $ \capability ->+        minimumManifestVersion capability `shouldSatisfy` (<= currentManifestVersion)++    it "is supported by a schema-7 manifest" $+      manifestSupports TargetedAdditiveSharedPathUpdate (emptyManifest fixedTime) `shouldBe` True+   describe "version checking" $ do     it "rejects manifests with version higher than current" $ do       let base = emptyManifest fixedTime-          m = Manifest {version = 99, genAt = base ^. #genAt, modules = base ^. #modules, vars = base ^. #vars, files = base ^. #files, applications = base ^. #applications, recipe = Nothing, blueprint = Nothing, blueprintMigrations = []}+          m = Manifest {version = ManifestSchemaVersion 99, genAt = base ^. #genAt, modules = base ^. #modules, vars = base ^. #vars, files = base ^. #files, applications = base ^. #applications, recipe = Nothing, blueprint = Nothing, seeds = Map.empty, checkoutOutputs = Map.empty, blueprintMigrations = []}           result = manifestFromJSON (manifestToJSON m)       case result of         Left err -> err `shouldContain` "newer version"

@@ -0,0 +1,174 @@+module Seihou.Manifest.UpgradeSpec (tests) where++import Control.Lens ((^.))+import Control.Monad (forM_)+import Data.Aeson qualified as Aeson+import Data.Aeson.Key qualified as Key+import Data.Aeson.KeyMap qualified as KeyMap+import Data.Generics.Labels ()+import Data.Map.Strict qualified as Map+import Data.Text qualified as T+import Seihou.Core.Types+import Seihou.Manifest.Types+import Seihou.Manifest.Upgrade+import Test.Hspec+import Test.Tasty+import Test.Tasty.Hspec (testSpec)++tests :: IO TestTree+tests = testSpec "Seihou.Manifest.Upgrade" spec++v :: Int -> ManifestSchemaVersion+v = ManifestSchemaVersion++-- | A schema-6 document with an additive path, a path with no evidence, an+-- explicit false, and keys this build does not model at every level.+schema6Document :: Aeson.Value+schema6Document =+  Aeson.object+    [ "version" Aeson..= (6 :: Int),+      "generatedAt" Aeson..= ("2026-03-01T10:30:00Z" :: String),+      "modules" Aeson..= ([] :: [Aeson.Value]),+      "variables" Aeson..= Aeson.object [],+      "applications" Aeson..= ([] :: [Aeson.Value]),+      "producerOwned" Aeson..= Aeson.object ["keep" Aeson..= True],+      "files"+        Aeson..= Aeson.object+          [ ".gitignore" Aeson..= record [("additiveOnly", Aeson.Bool True), ("applications", Aeson.toJSON ["a" :: String, "b"])],+            "README.md" Aeson..= record [("futureKey", Aeson.String "survives")],+            "flake.nix" Aeson..= record [("additiveOnly", Aeson.Bool False)]+          ]+    ]+  where+    record extra =+      Aeson.Object+        ( KeyMap.fromList+            ( [ ("hash", Aeson.String "aaa"),+                ("module", Aeson.String "base"),+                ("strategy", Aeson.String "template"),+                ("generatedAt", Aeson.String "2026-03-01T10:30:00Z")+              ]+                <> extra+            )+        )++fileField :: String -> Aeson.Key -> Aeson.Value -> Maybe Aeson.Value+fileField path key (Aeson.Object top) = case KeyMap.lookup "files" top of+  Just (Aeson.Object files) -> case KeyMap.lookup (Key.fromString path) files of+    Just (Aeson.Object record) -> KeyMap.lookup key record+    _ -> Nothing+  _ -> Nothing+fileField _ _ _ = Nothing++spec :: Spec+spec = do+  describe "the step registry" $ do+    it "plans a contiguous path from every supported version to the current one" $+      -- ADR 0014's mechanical gap check: a schema bump without its adjacent+      -- step fails here.+      forM_ [oldestUpgradableManifestVersion ^. #unManifestSchemaVersion .. currentManifestVersion ^. #unManifestSchemaVersion] $ \source ->+        case planManifestUpgrade (v source) currentManifestVersion of+          Left err -> expectationFailure ("no path from schema " <> show source <> ": " <> show err)+          Right steps -> do+            map (^. #fromVersion) steps `shouldBe` map v [source .. currentManifestVersion ^. #unManifestSchemaVersion - 1]+            map (^. #toVersion) steps `shouldBe` map v [source + 1 .. currentManifestVersion ^. #unManifestSchemaVersion]++    it "defines exactly one step per source version" $ do+      let sources = map (^. #fromVersion) manifestUpgradeSteps+      length sources `shouldBe` Map.size (Map.fromList [(s, ()) | s <- sources])++    it "returns an empty path from a version to itself" $+      planManifestUpgrade (v 7) (v 7) `shouldBe` Right []++    it "stops at a requested intermediate target" $+      map (^. #toVersion) <$> planManifestUpgrade (v 5) (v 6) `shouldBe` Right [v 6]++    it "reports a missing adjacent step instead of jumping over it" $ do+      let gappy = filter ((/= v 6) . (^. #fromVersion)) manifestUpgradeSteps+      planUpgradeWith gappy (v 7) (v 5) (v 7) `shouldBe` Left (MissingUpgradeStep (v 6))++    it "rejects targets above current and below the source" $ do+      planManifestUpgrade (v 6) (v 99) `shouldBe` Left (TargetAboveCurrent (v 99))+      planManifestUpgrade (v 7) (v 6) `shouldBe` Left (TargetBelowSource (v 7) (v 6))+      planManifestUpgrade (v 99) (v 99) `shouldBe` Left (SourceNewerThanBinary (v 99))+      planManifestUpgrade (v 0) (v 7) `shouldBe` Left (SourceVersionUnsupported (v 0))++    it "classifies the path conversion as inference-bearing and 6 -> 7 as lossless" $ do+      let kindFrom source = upgradeStepKind . (^. #action) <$> lookup (v source) [(s ^. #fromVersion, s) | s <- manifestUpgradeSteps]+      kindFrom 5 `shouldBe` Just InferenceBearingUpgrade+      kindFrom 6 `shouldBe` Just LosslessUpgrade++  describe "the 7 -> 8 step" $ do+    it "preserves unrelated raw fields and adds seed receipts" $ do+      Right (_, upgraded) <- pure (upgradeDocumentLosslessly (v 8) schema6Document)+      documentSchemaVersion upgraded `shouldBe` Right (v 8)+      case upgraded of+        Aeson.Object fields -> do+          KeyMap.lookup "seeds" fields `shouldBe` Just (Aeson.object [])+          KeyMap.lookup "producerOwned" fields `shouldBe` Just (Aeson.object ["keep" Aeson..= True])+        _ -> expectationFailure "expected object"+      case Aeson.fromJSON upgraded :: Aeson.Result Manifest of+        Aeson.Success manifest -> manifestFromJSON (manifestToJSON manifest) `shouldBe` Right manifest+        Aeson.Error err -> expectationFailure err+    it "rejects malformed seed containers before stamping" $ do+      let document = Aeson.object ["version" Aeson..= (7 :: Int), "seeds" Aeson..= False]+      upgradeDocumentLosslessly (v 8) document `shouldSatisfy` either (const True) (const False)++  describe "the 6 -> 7 step" $ do+    let upgraded = upgradeDocumentLosslessly (v 7) schema6Document++    it "maps additiveOnly: true to additive-only and absent or false to unknown" $ do+      (fileField ".gitignore" "sharedWriteMode" . snd <$> upgraded) `shouldBe` Right (Just (Aeson.String "additive-only"))+      (fileField "README.md" "sharedWriteMode" . snd <$> upgraded) `shouldBe` Right (Just (Aeson.String "unknown"))+      (fileField "flake.nix" "sharedWriteMode" . snd <$> upgraded) `shouldBe` Right (Just (Aeson.String "unknown"))++    it "removes the schema-6 key and keeps unrelated members at every level" $ do+      (fileField ".gitignore" "additiveOnly" . snd <$> upgraded) `shouldBe` Right Nothing+      (fileField "README.md" "futureKey" . snd <$> upgraded) `shouldBe` Right (Just (Aeson.String "survives"))+      (fileField ".gitignore" "applications" . snd <$> upgraded) `shouldBe` Right (Just (Aeson.toJSON ["a" :: String, "b"]))+      case snd <$> upgraded of+        Right (Aeson.Object top) -> KeyMap.lookup "producerOwned" top `shouldBe` Just (Aeson.object ["keep" Aeson..= True])+        other -> expectationFailure ("unexpected result: " <> show other)++    it "stamps version 7 and reports the one step it ran" $ do+      (documentSchemaVersion . snd =<< upgraded) `shouldBe` Right (v 7)+      (map (^. #fromVersion) . fst <$> upgraded) `shouldBe` Right [v 6]++    it "produces a document the typed decoder reads and round-trips" $+      case upgraded of+        Left err -> expectationFailure (show err)+        Right (_, document) -> case manifestFromJSON (Aeson.encode document) of+          Left err -> expectationFailure err+          Right manifest -> do+            (manifest ^. #version) `shouldBe` v 7+            fmap (^. #sharedWriteMode) (Map.lookup ".gitignore" (manifest ^. #files)) `shouldBe` Just SharedWriteAdditiveOnly+            fmap (^. #sharedWriteMode) (Map.lookup "README.md" (manifest ^. #files)) `shouldBe` Just SharedWriteUnknown+            manifestSupports TargetedAdditiveSharedPathUpdate manifest `shouldBe` True+            manifestFromJSON (manifestToJSON manifest) `shouldBe` Right manifest++    it "is a no-op from 7 to 7" $+      case upgraded of+        Left err -> expectationFailure (show err)+        Right (_, document) -> upgradeDocumentLosslessly (v 7) document `shouldBe` Right ([], document)++    it "rejects a malformed additiveOnly value" $ do+      let bad = Aeson.object ["version" Aeson..= (6 :: Int), "files" Aeson..= Aeson.object ["x" Aeson..= Aeson.object ["additiveOnly" Aeson..= ("yes" :: String)]]]+      case upgradeDocumentLosslessly (v 7) bad of+        Left (MalformedDocument source _) -> source `shouldBe` v 6+        other -> expectationFailure ("expected a malformed-document error, got " <> show other)++    it "refuses to run on a document at another version" $ do+      let sixToSeven = last manifestUpgradeSteps+          atFive = setDocumentSchemaVersion (v 5) schema6Document+      applyLosslessUpgradeStep sixToSeven atFive `shouldBe` Left (StepVersionMismatch sixToSeven (v 5))++  describe "lossless staging" $ do+    it "refuses to cross the inference-bearing 5 -> 6 conversion" $ do+      let atFive = setDocumentSchemaVersion (v 5) schema6Document+      case upgradeDocumentLosslessly (v 7) atFive of+        Left (StepRequiresInference s) -> (s ^. #fromVersion) `shouldBe` v 5+        other -> expectationFailure ("expected the path conversion to block, got " <> show other)++    it "names the explicit upgrade command when it refuses" $+      forM_ [s | s <- manifestUpgradeSteps, s ^. #fromVersion == v 5] $ \step5 ->+        renderManifestUpgradeError (StepRequiresInference step5) `shouldSatisfy` T.isInfixOf "seihou manifest upgrade"