seihou-core 0.10.1.0 → 0.11.0.0

raw patch · 49 files changed

+1734/−234 lines, 49 filesdep +unixPVP ok

version bump matches the API change (PVP)

Dependencies added: unix

API changes (from Hackage documentation)

Files

• seihou-core.cabal +7/−1
• src/Seihou/Composition/Plan.hs +47/−5
• src/Seihou/Composition/Resolve.hs +1/−1
• src/Seihou/Core/Application.hs +1/−0
• src/Seihou/Core/ArtifactIdentity.hs +7/−2
• src/Seihou/Core/CommandFingerprint.hs +18/−0
• src/Seihou/Core/Module.hs +2/−3
• src/Seihou/Core/Path.hs +11/−0
• src/Seihou/Core/Seed.hs +123/−19
• src/Seihou/Core/Types.hs +36/−4
• src/Seihou/Dhall/Eval.hs +13/−14
• src/Seihou/Effect/Filesystem.hs +7/−0
• src/Seihou/Effect/FilesystemInterp.hs +6/−1
• src/Seihou/Effect/FilesystemPure.hs +6/−1
• src/Seihou/Effect/ManifestStore.hs +6/−1
• src/Seihou/Engine/Execute.hs +3/−0
• src/Seihou/Engine/Migrate.hs +37/−3
• src/Seihou/Engine/Plan.hs +25/−7
• src/Seihou/Engine/Preview.hs +1/−0
• src/Seihou/Engine/Reconcile.hs +138/−9
• src/Seihou/Engine/Remove.hs +55/−16
• src/Seihou/Engine/Seed.hs +173/−0
• src/Seihou/Engine/UpdateTransaction.hs +111/−25
• src/Seihou/Filesystem/Exclusive.hs +60/−0
• src/Seihou/Manifest/Types.hs +131/−47
• src/Seihou/Manifest/Upgrade.hs +41/−2
• test/Main.hs +5/−1
• test/Seihou/Composition/PlanSpec.hs +49/−22
• test/Seihou/Core/ApplicationSpec.hs +1/−0
• test/Seihou/Core/ArtifactIdentitySpec.hs +15/−2
• test/Seihou/Core/CommandFingerprintSpec.hs +2/−1
• test/Seihou/Core/SeedSpec.hs +66/−10
• test/Seihou/Core/StatusSpec.hs +8/−0
• test/Seihou/Core/TypesSpec.hs +1/−1
• test/Seihou/Dhall/EvalSpec.hs +22/−0
• test/Seihou/Effect/ManifestStoreSpec.hs +9/−2
• test/Seihou/Engine/CheckoutSpec.hs +1/−1
• test/Seihou/Engine/ExecuteSpec.hs +2/−2
• test/Seihou/Engine/PlanSpec.hs +28/−12
• test/Seihou/Engine/PreviewSpec.hs +4/−4
• test/Seihou/Engine/ReconcileSpec.hs +15/−0
• test/Seihou/Engine/RemoveSpec.hs +26/−3
• test/Seihou/Engine/SeedSpec.hs +92/−0
• test/Seihou/Engine/SeedTransactionSpec.hs +152/−0
• test/Seihou/Engine/ValidateSpec.hs +11/−5
• test/Seihou/Integration/CompositionSpec.hs +5/−5
• test/Seihou/Manifest/TypesSpec.hs +36/−2
• test/Seihou/Manifest/UpgradeSpec.hs +56/−0
• test/native/SeedExclusive.hs +62/−0

@@ -1,6 +1,6 @@ cabal-version: 3.0 name: seihou-core-version: 0.10.1.0+version: 0.11.0.0 synopsis: Core library for Seihou project scaffolding description:   Core library for Seihou, a composable project scaffolding system.@@ -16,6 +16,7 @@ copyright: (c) 2026 Nadeem Bitar category: Development build-type: Simple+extra-source-files: test/native/SeedExclusive.hs  source-repository head   type: git@@ -102,11 +103,13 @@     Seihou.Engine.Reconcile     Seihou.Engine.Remove     Seihou.Engine.Section+    Seihou.Engine.Seed     Seihou.Engine.Template     Seihou.Engine.ThreeWayMerge     Seihou.Engine.TypedDhallText     Seihou.Engine.UpdateTransaction     Seihou.Engine.Validate+    Seihou.Filesystem.Exclusive     Seihou.Interaction.Confirm     Seihou.Interaction.Prompt     Seihou.Manifest.Hash@@ -135,6 +138,7 @@     text >=2.0 && <3,     time >=1.12 && <2,     transformers >=0.6 && <1,+    unix >=2.8 && <2.9,     yaml >=0.11 && <1,  test-suite seihou-core-test@@ -202,6 +206,8 @@     Seihou.Engine.ReconcileSpec     Seihou.Engine.RemoveSpec     Seihou.Engine.SectionSpec+    Seihou.Engine.SeedSpec+    Seihou.Engine.SeedTransactionSpec     Seihou.Engine.TemplateSpec     Seihou.Engine.ThreeWayMergeSpec     Seihou.Engine.UpdateTransactionSpec

@@ -1,11 +1,13 @@ module Seihou.Composition.Plan-  ( compileComposedPlan,+  ( ComposedPlan (..),+    compileComposedPlan,     mergeOperations,     mergeStructuredContent,     deepMergeJSON,   ) where +import Control.Monad (forM_) import Data.Aeson qualified as Aeson import Data.Aeson.Encode.Pretty qualified as AesonPretty import Data.Aeson.KeyMap qualified as KM@@ -19,12 +21,21 @@ import Data.Yaml qualified as Yaml import Seihou.Composition.Instance (ModuleInstance, qualifiedName) import Seihou.Core.Checkout (CheckoutError (..), checkoutClaims, pathsOverlap)+import Seihou.Core.Path (pathsHaveConflictingSpelling, validateCanonicalProjectPath) import Seihou.Core.Types import Seihou.Engine.Plan (compilePlan) import Seihou.Engine.Section (applyTextPatch) import Seihou.Prelude import System.FilePath (takeExtension) +data ComposedPlan = ComposedPlan+  { operations :: ![Operation],+    warnings :: ![CompositionWarning],+    managedOwners :: !(Map FilePath ModuleName),+    seedOwners :: !(Map FilePath (Set ModuleName))+  }+  deriving stock (Eq, Show, Generic)+ -- | Compile plans for all modules in execution order and merge into a -- single operation list. File conflicts are resolved by last-writer-wins -- with 'CompositionWarning' entries for overwritten files.@@ -36,7 +47,7 @@ -- collide on file ownership. compileComposedPlan ::   [(ModuleInstance, Module, FilePath, Map VarName VarValue)] ->-  IO (Either [Text] ([Operation], [CompositionWarning], Map FilePath ModuleName))+  IO (Either [Text] ComposedPlan) compileComposedPlan modules = do   results <- mapM compileOne modules   let (errs, opsPerModule) = partitionResults results@@ -49,7 +60,7 @@       pure $ case checkoutClaims (ApplicationId "composition") ops of         Left err -> Left [err ^. #message]         Right _ | not (null overlaps) -> Left overlaps-        Right _ -> Right (mergeOperations opsPerModule)+        Right _ -> mergeOperations opsPerModule     else pure (Left (concat errs))   where     compileOne (inst, m, dir, vars) = do@@ -81,10 +92,40 @@ -- -- 'CreateDirOp' operations are silently deduplicated. -- 'RunCommandOp' operations are always included.-mergeOperations ::+mergeOperations :: [(ModuleName, [Operation])] -> Either [Text] ComposedPlan+mergeOperations moduleOps = do+  let allOps = concatMap snd moduleOps+      seeds = [op | op@SeedFileOp {} <- allOps]+      claims = Map.fromListWith Set.union [(dest, Set.singleton moduleName) | SeedFileOp {dest, moduleName} <- seeds]+      destinations =+        [(dest, False) | op <- allOps, Just dest <- [destOfOp op]]+          <> [(dest, True) | SeedFileOp {dest} <- seeds]+          <> [(dest, False) | CheckoutOutputOp {dest} <- allOps]+      collisions = ["seed '" <> T.pack path <> "' overlaps a different lifecycle or file destination '" <> T.pack other <> "'" | SeedFileOp {dest = path} <- seeds, (other, isSeed) <- destinations, (pathsOverlap path other || pathsHaveConflictingSpelling path other), not (isSeed && path == other)]+  forM_ seeds $ \SeedFileOp {dest} -> first pure (validateCanonicalProjectPath (T.pack dest))+  if null seeds then Right () else forM_ destinations (\(dest, _) -> first pure (validateCanonicalProjectPath (T.pack dest)))+  if not (null collisions)+    then Left collisions+    else do+      let (ops, warnings, owners) = mergeManagedOperations [(name, filter (\case SeedFileOp {} -> False; _ -> True) operations) | (name, operations) <- moduleOps]+          (selected, seedWarnings) = chooseSeeds Set.empty Map.empty seeds+      Right (ComposedPlan (ops <> selected) (warnings <> seedWarnings) owners claims)+  where+    chooseSeeds _ _ [] = ([], [])+    chooseSeeds seen suppliers (op@SeedFileOp {dest, content, moduleName} : rest)+      | Set.member dest seen =+          let (ops, warnings) = chooseSeeds seen suppliers rest+              extra = case Map.lookup dest suppliers of+                Just (firstContent, supplier) | firstContent /= content -> [SeedContentIgnored dest supplier moduleName]+                _ -> []+           in (ops, extra <> warnings)+      | otherwise = let (ops, warnings) = chooseSeeds (Set.insert dest seen) (Map.insert dest (content, moduleName) suppliers) rest in (op : ops, warnings)+    chooseSeeds seen suppliers (_ : rest) = chooseSeeds seen suppliers rest++mergeManagedOperations ::   [(ModuleName, [Operation])] ->   ([Operation], [CompositionWarning], Map FilePath ModuleName)-mergeOperations moduleOps =+mergeManagedOperations moduleOps =   let tagged = [(name, op) | (name, ops) <- moduleOps, op <- ops]       (result, warnings, owners) = go tagged Map.empty Set.empty [] []    in (reverse result, warnings, owners)@@ -92,6 +133,7 @@     go [] fileOwner _ opsAcc warningsAcc = (opsAcc, warningsAcc, fileOwner)     go ((name, op) : rest) fileOwner seenDirs opsAcc warningsAcc =       case op of+        SeedFileOp {} -> go rest fileOwner seenDirs opsAcc warningsAcc         CheckoutOutputOp {} -> go rest fileOwner seenDirs (op : opsAcc) warningsAcc         CreateDirOp p           | Set.member p seenDirs -> go rest fileOwner seenDirs opsAcc warningsAcc

@@ -50,7 +50,7 @@ loadComposition searchPaths primary additional = runExceptT $ do   (primaryMod, primaryDir) <- ExceptT $ loadModuleWithDir searchPaths primary   let effectiveDeps = primaryMod ^. #dependencies ++ map simpleDep additional-      effectivePrimary = (primaryMod & #dependencies .~ nubOrdBy (^. #module_) effectiveDeps)+      effectivePrimary = (primaryMod & #dependencies .~ nubOrdBy (\dep -> (dep ^. #module_, parentVarsFromDep dep)) effectiveDeps)       primaryInst = primaryInstance primary       loaded = Map.singleton primaryInst (effectivePrimary, primaryDir)       seeds = [(mkInstance (dep ^. #module_) (parentVarsFromDep dep)) | dep <- effectivePrimary ^. #dependencies]

@@ -65,6 +65,7 @@       context = context,       instances = map buildInstance modulesInOrder,       commandReceipts = Map.empty,+      checkoutCommands = [],       appliedAt = now     }   where

@@ -57,11 +57,16 @@ -- @https:\/\/host\/repo@, @https:\/\/host\/repo.git@ and -- @https:\/\/host\/repo\/@ all name the same repository, and a manifest -- written by a developer who typed one of them must not read as a different--- artifact to a developer who typed another.+-- artifact to a developer who typed another. Public GitHub SSH spellings also+-- normalize to HTTPS; no equivalence is inferred for other hosts or paths. normalizeOriginUrl :: Text -> Text normalizeOriginUrl =-  dropTrailingSlashes . dropGitSuffix . dropTrailingSlashes . T.strip+  dropTrailingSlashes . dropGitSuffix . dropTrailingSlashes . githubTransport . T.strip   where+    githubTransport url+      | Just path <- T.stripPrefix "git@github.com:" url = "https://github.com/" <> path+      | Just path <- T.stripPrefix "ssh://git@github.com/" url = "https://github.com/" <> path+      | otherwise = url     dropTrailingSlashes = T.dropWhileEnd (== '/')     dropGitSuffix url = fromMaybe url (T.stripSuffix ".git" url) 

@@ -1,5 +1,8 @@ module Seihou.Core.CommandFingerprint   ( fingerprintCommand,+    checkoutCommandsFromOperations,+    checkoutCommandOperation,+    isCheckoutCommand,   ) where @@ -23,3 +26,18 @@         "occurrence=" <> T.pack (show occurrence)       ] fingerprintCommand _ = Nothing++-- | Capture declarations from the complete compiled plan, even when execution is disabled.+checkoutCommandsFromOperations :: [Operation] -> [CheckoutCommand]+checkoutCommandsFromOperations operations =+  [ CheckoutCommand moduleName occurrence command workDir+  | RunCommandOp {moduleName, occurrence, command, workDir, lifecycle = CheckoutCommandLifecycle} <- operations+  ]++checkoutCommandOperation :: CheckoutCommand -> Operation+checkoutCommandOperation CheckoutCommand {moduleName, occurrence, command, workDir} =+  RunCommandOp {moduleName, occurrence, command, workDir, lifecycle = CheckoutCommandLifecycle}++isCheckoutCommand :: Operation -> Bool+isCheckoutCommand RunCommandOp {lifecycle = CheckoutCommandLifecycle} = True+isCheckoutCommand _ = False

@@ -316,7 +316,7 @@  -- Rule 9: Command text must be non-empty and workDir must be safe checkCommandSafety :: Module -> [Text]-checkCommandSafety m = concatMap checkCmd (m ^. #commands)+checkCommandSafety m = concatMap checkCmd (m ^. #commands) <> ["Removal.commands cannot declare checkout setup" | removal <- maybeToList (m ^. #removal), command <- removal ^. #commands, command ^. #lifecycle == CheckoutCommandLifecycle]   where     checkCmd c = checkEmptyRun c <> checkWorkDir (c ^. #workDir) @@ -580,7 +580,7 @@     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]+        <> ["step writing '" <> s ^. #dest <> "' is a seed but uses an unsupported strategy; seeds support copy, template, and dhall-text" | s ^. #strategy `notElem` [Copy, Template, DhallText]]     mixed =       [ "steps writing '" <> dest <> "' mix the seed and managed lifecycles; use one lifecycle per destination"       | dest <- Set.toAscList (Set.fromList (map (^. #dest) seedSteps)),@@ -590,7 +590,6 @@       [ "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       ]

@@ -1,6 +1,7 @@ module Seihou.Core.Path   ( validateProjectRelativePath,     validateCanonicalProjectPath,+    pathsHaveConflictingSpelling,   ) where @@ -40,3 +41,13 @@     || 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 ()++-- | Refuse case aliases in the portable output namespace, including conflicting+-- ancestor spellings, before any filesystem object is created.+pathsHaveConflictingSpelling :: FilePath -> FilePath -> Bool+pathsHaveConflictingSpelling a b = go (T.splitOn "/" (T.pack a)) (T.splitOn "/" (T.pack b))+  where+    go (x : xs) (y : ys)+      | x == y = go xs ys+      | otherwise = T.toCaseFold x == T.toCaseFold y+    go _ _ = False

@@ -1,39 +1,143 @@ module Seihou.Core.Seed-  ( mergeSeedRecord,-    dropSeedOwner,-    seedsOwnedByModule,+  ( seedApplicationIds,+    mergeSeedRecord,+    dropSeedOwners,+    seedClaimsFor,+    replaceSelectedSeedClaims,+    SeedOwnershipError (..),+    renderSeedOwnershipError,     ManifestInvariantError (..),+    renderManifestInvariantError,     validateManifestInvariants,   ) where +import Control.Monad (forM_, unless, when) import Data.Generics.Labels () import Data.Map.Strict qualified as Map import Data.Set qualified as Set+import Data.Text qualified as T+import Seihou.Composition.Instance (ModuleInstance (..), qualifiedName)+import Seihou.Core.Checkout (pathsOverlap)+import Seihou.Core.Path (pathsHaveConflictingSpelling, validateCanonicalProjectPath) 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+seedApplicationIds :: SeedRecord -> Set ApplicationId+seedApplicationIds record = case record ^. #ownership of+  LegacySeedOwners apps -> apps+  KnownSeedOwners owners -> Map.keysSet owners++data SeedOwnershipError+  = SeedOwnershipUnresolved FilePath (Set ApplicationId)+  | SeedClaimsOutsideSelection FilePath (Set ApplicationId)+  deriving stock (Eq, Show, Generic)++renderSeedOwnershipError :: SeedOwnershipError -> Text+renderSeedOwnershipError = \case+  SeedOwnershipUnresolved path apps ->+    "seed '"+      <> T.pack path+      <> "' needs exact recorded module evidence for applications "+      <> T.intercalate ", " (map (^. #unApplicationId) (Set.toAscList apps))+      <> "; restore access to their recorded releases and retry the command"+  SeedClaimsOutsideSelection path _ -> "seed claims for '" <> T.pack path <> "' include an unselected application"++-- | Union claims, retaining the original supplier, outcome and time. Callers+-- validate the combined manifest after attaching its recorded applications.+mergeSeedRecord :: FilePath -> SeedRecord -> Manifest -> Either SeedOwnershipError Manifest+mergeSeedRecord path receipt manifest = do+  combined <- case Map.lookup path (manifest ^. #seeds) of+    Nothing -> Right receipt+    Just old -> do+      owners <- case (old ^. #ownership, receipt ^. #ownership) of+        (KnownSeedOwners a, KnownSeedOwners b) -> Right (KnownSeedOwners (Map.unionWith Set.union a b))+        (LegacySeedOwners a, LegacySeedOwners b) -> Right (LegacySeedOwners (a <> b))+        _ -> Left (SeedOwnershipUnresolved path (seedApplicationIds old <> seedApplicationIds receipt))+      Right (old & #ownership .~ owners)+  pure (manifest & #seeds %~ Map.insert path combined)++dropSeedOwners :: Map ApplicationId (Set ModuleName) -> FilePath -> Manifest -> Either SeedOwnershipError Manifest+dropSeedOwners departing path manifest = case Map.lookup path (manifest ^. #seeds) of+  Nothing -> Right manifest+  Just receipt -> do+    retained <- case receipt ^. #ownership of+      LegacySeedOwners apps+        | Set.null (apps `Set.intersection` Map.keysSet departing) -> Right (Just receipt)+        | otherwise -> Left (SeedOwnershipUnresolved path apps)+      KnownSeedOwners owners ->+        let rest = Map.mapMaybeWithKey (\app names -> nonempty (names `Set.difference` Map.findWithDefault Set.empty app departing)) owners+         in Right (if Map.null rest then Nothing else Just (receipt & #ownership .~ KnownSeedOwners rest))+    pure (manifest & #seeds %~ Map.update (const retained) path)++seedClaimsFor :: ApplicationId -> ModuleName -> Manifest -> Either SeedOwnershipError (Map FilePath SeedRecord)+seedClaimsFor app name manifest = Map.traverseMaybeWithKey select (manifest ^. #seeds)   where-    merge new old = old & #applicationIds %~ Set.union (new ^. #applicationIds)+    select path receipt = case receipt ^. #ownership of+      LegacySeedOwners apps+        | Set.member app apps -> Left (SeedOwnershipUnresolved path apps)+        | otherwise -> Right Nothing+      KnownSeedOwners owners -> Right (if Set.member name (Map.findWithDefault Set.empty app owners) then Just receipt else Nothing) -dropSeedOwner :: Set ApplicationId -> FilePath -> Manifest -> Manifest-dropSeedOwner departing path = #seeds %~ Map.update dropOwners path+-- | Replace the complete claim set of selected applications in one pass.+-- A surviving receipt keeps its original settlement even when every old+-- selected claim was replaced. Unknown unselected claims are preserved.+replaceSelectedSeedClaims :: Set ApplicationId -> Map FilePath SeedRecord -> Manifest -> Either SeedOwnershipError Manifest+replaceSelectedSeedClaims selected incoming manifest = do+  forM_ (Map.toAscList incoming) $ \(path, receipt) -> do+    unless (seedApplicationIds receipt `Set.isSubsetOf` selected) $+      Left (SeedClaimsOutsideSelection path (seedApplicationIds receipt Set.\\ selected))+    case receipt ^. #ownership of+      LegacySeedOwners apps -> Left (SeedOwnershipUnresolved path apps)+      KnownSeedOwners _ -> Right ()+  records <- Map.traverseMaybeWithKey replace (Map.union (manifest ^. #seeds) incoming)+  pure (manifest & #seeds .~ records)   where-    dropOwners record =-      let retained = (record ^. #applicationIds) `Set.difference` departing-       in if Set.null retained then Nothing else Just (record & #applicationIds .~ retained)+    replace path _ = case Map.lookup path (manifest ^. #seeds) of+      Nothing -> Right (Map.lookup path incoming)+      Just old -> case old ^. #ownership of+        LegacySeedOwners apps+          | not (Set.null (apps `Set.intersection` selected)) || Map.member path incoming -> Left (SeedOwnershipUnresolved path apps)+          | otherwise -> Right (Just old)+        KnownSeedOwners owners ->+          let proposed = case (^. #ownership) <$> Map.lookup path incoming of+                Just (KnownSeedOwners claims) -> claims+                _ -> Map.empty+              rest = Map.unionWith Set.union (Map.withoutKeys owners selected) proposed+           in Right (if Map.null rest then Nothing else Just (old & #ownership .~ KnownSeedOwners rest)) -seedsOwnedByModule :: ModuleName -> Manifest -> Map FilePath SeedRecord-seedsOwnedByModule name manifest = Map.filter ((== name) . (^. #moduleName)) (manifest ^. #seeds)+nonempty :: Set a -> Maybe (Set a)+nonempty names = if Set.null names then Nothing else Just names -data ManifestInvariantError = PathBothManagedAndSeeded FilePath+data ManifestInvariantError+  = PathBothManagedAndSeeded FilePath+  | InvalidSeedPath FilePath Text+  | SeedPathOverlap FilePath FilePath+  | InvalidSeedOwners FilePath Text   deriving stock (Eq, Show, Generic) +renderManifestInvariantError :: ManifestInvariantError -> Text+renderManifestInvariantError = \case+  PathBothManagedAndSeeded path -> "path " <> T.pack path <> " is recorded both as a tracked file and as a seed"+  InvalidSeedPath path reason -> "seed '" <> T.pack path <> "': " <> reason+  SeedPathOverlap path other -> "seed '" <> T.pack path <> "' overlaps output '" <> T.pack other <> "'"+  InvalidSeedOwners path reason -> "seed '" <> T.pack path <> "' " <> reason+ validateManifestInvariants :: Manifest -> Either ManifestInvariantError ()-validateManifestInvariants manifest = case Map.keys (Map.intersection (manifest ^. #files) (manifest ^. #seeds)) of-  path : _ -> Left (PathBothManagedAndSeeded path)-  [] -> Right ()+validateManifestInvariants manifest = do+  forM_ (Map.keys (Map.intersection (manifest ^. #files) (manifest ^. #seeds))) $ \path -> Left (PathBothManagedAndSeeded path)+  forM_ (Map.toAscList (manifest ^. #seeds)) $ \(path, receipt) -> case receipt ^. #ownership of+    -- Preserve historical receipts without pretending they contain exact facts.+    LegacySeedOwners _ -> Right ()+    KnownSeedOwners owners -> do+      first (InvalidSeedPath path) (validateCanonicalProjectPath (T.pack path))+      when (Map.null owners) $ bad path "has no owners"+      forM_ (Map.toAscList owners) $ \(appId, names) -> do+        when (Set.null names) $ bad path "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 path "names an instance outside its owning application"+          _ -> bad path "names an unknown or duplicate application owner"+      forM_ (Map.keys (manifest ^. #files) <> Map.keys (manifest ^. #checkoutOutputs) <> filter (/= path) (Map.keys (manifest ^. #seeds))) $ \other ->+        when (pathsOverlap path other || pathsHaveConflictingSpelling path other) $ Left (SeedPathOverlap path other)+  where+    bad path = Left . InvalidSeedOwners path

@@ -15,10 +15,13 @@     lifecycleToText,     SeedOutcome (..),     SeedRecord (..),+    SeedOwnership (..),     PatchOp (..),     isAdditivePatchOp,     Step (..),     Command (..),+    CommandLifecycle (..),+    CheckoutCommand (..),     Dependency (..),     simpleDep,     depModuleNames,@@ -227,11 +230,16 @@   }   deriving stock (Eq, Show, Generic) +-- | Application commands use success receipts; checkout commands repeat on explicit sync.+data CommandLifecycle = ApplicationCommand | CheckoutCommandLifecycle+  deriving stock (Eq, Ord, Show, Generic)+ -- | A shell command to run after file generation. data Command = Command   { run :: !Text,     workDir :: !(Maybe Text),-    condition :: !(Maybe Expr)+    condition :: !(Maybe Expr),+    lifecycle :: !CommandLifecycle   }   deriving stock (Eq, Show, Generic) @@ -442,7 +450,8 @@  -- | Filesystem operations produced by the generation engine. data Operation-  = CheckoutOutputOp+  = SeedFileOp {dest :: !FilePath, content :: !Text, strategy :: !Strategy, moduleName :: !ModuleName}+  | CheckoutOutputOp       { dest :: !FilePath,         spec :: !CheckoutOutputSpec,         moduleName :: !ModuleName@@ -463,7 +472,8 @@       { command :: !Text,         workDir :: !(Maybe FilePath),         moduleName :: !ModuleName,-        occurrence :: !Int+        occurrence :: !Int,+        lifecycle :: !CommandLifecycle       }   | PatchFileOp       { dest :: !FilePath,@@ -486,6 +496,7 @@ isAdditiveOperation :: Operation -> Bool isAdditiveOperation (PatchFileOp _ _ op' _ _) = isAdditivePatchOp op' isAdditiveOperation CheckoutOutputOp {} = False+isAdditiveOperation SeedFileOp {} = False isAdditiveOperation WriteFileOp {} = False isAdditiveOperation CopyFileOp {} = False isAdditiveOperation CreateDirOp {} = False@@ -586,7 +597,9 @@     -- explicit shared-write evidence introduced by schema 7.     TargetedAdditiveSharedPathUpdate   | SeedReceipts+  | SeedOwnerClaims   | CheckoutLocalOutputs+  | CheckoutLocalCommands   deriving stock (Eq, Ord, Show, Enum, Bounded, Generic)  -- | What the manifest knows about how the owners of a path write it.@@ -702,6 +715,16 @@   }   deriving stock (Eq, Show, Generic) +-- | Resolved repeatable setup, owned by a qualified instance in its application.+-- List order is execution order, never completion history.+data CheckoutCommand = CheckoutCommand+  { moduleName :: !ModuleName,+    occurrence :: !Int,+    command :: !Text,+    workDir :: !(Maybe FilePath)+  }+  deriving stock (Eq, Show, Generic)+ -- | Reproducible state for one module instance in an application. -- -- @origin@ is the module's portable identity. Turning it back into a@@ -727,6 +750,7 @@     context :: !(Maybe Text),     instances :: ![AppliedInstanceState],     commandReceipts :: !(Map CommandFingerprint CommandReceipt),+    checkoutCommands :: ![CheckoutCommand],     appliedAt :: !UTCTime   }   deriving stock (Eq, Show, Generic)@@ -951,6 +975,7 @@ data CompositionWarning   = FileOverwritten FilePath ModuleName ModuleName   | ContentMerged FilePath ModuleName ModuleName+  | SeedContentIgnored FilePath ModuleName ModuleName   deriving stock (Eq, Show, Generic)  -- | Status of a tracked file relative to its manifest hash.@@ -978,10 +1003,17 @@  data SeedRecord = SeedRecord   { moduleName :: !ModuleName,-    applicationIds :: !(Set ApplicationId),+    ownership :: !SeedOwnership,     outcome :: !SeedOutcome,     settledAt :: !UTCTime   }+  deriving stock (Eq, Show, Generic)++-- | Active claims are separate from immutable first-settlement provenance.+-- Older receipts cannot identify which instances contributed to a path.+data SeedOwnership+  = LegacySeedOwners !(Set ApplicationId)+  | KnownSeedOwners !(Map ApplicationId (Set ModuleName))   deriving stock (Eq, Show, Generic)  -- | A typed, portable specification reconstructed in each working copy.

@@ -99,7 +99,7 @@         -- Force lazy decoder thunks that may contain 'error' calls         mapM_ (\v -> evaluate (v ^. #type_)) (m ^. #vars)         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_ (\c -> evaluate (c ^. #lifecycle) >> mapM_ evaluate (c ^. #condition)) ((m ^. #commands) <> concatMap (^. #commands) (m ^. #removal))         mapM_ (\p -> evaluate (p ^. #condition)) (m ^. #prompts)         pure m       Failure e -> throwIO e@@ -711,20 +711,19 @@ -- | Decoder for Command from a Dhall record. -- The @when@ field is parsed via 'parseExpr' into an 'Expr' AST. commandDecoder :: Decoder Command-commandDecoder =-  record-    ( mkCommand-        <$> field "run" strictText-        <*> field "workDir" (maybe strictText)-        <*> field "when" (maybe strictText)-    )+commandDecoder = Decoder decode (expected tagged)   where-    mkCommand run workDir whenText =-      Command-        { run = run,-          workDir = workDir,-          condition = parseWhen whenText-        }+    decode expr@(Dhall.RecordLit fields)+      | DhallMap.member "action" fields && DhallMap.member "run" fields =+          error "Command must contain either action or run, not both"+      | DhallMap.member "action" fields = extract tagged expr+      | otherwise = extract legacy expr+    decode expr = extract tagged expr+    tagged = record (mkTagged <$> field "action" actionDecoder <*> field "workDir" (maybe strictText) <*> field "when" (maybe strictText))+    legacy = record (mkLegacy <$> field "run" strictText <*> field "workDir" (maybe strictText) <*> field "when" (maybe strictText))+    actionDecoder = union (((\text -> (ApplicationCommand, text)) <$> constructor "Apply" strictText) <> ((\text -> (CheckoutCommandLifecycle, text)) <$> constructor "Checkout" strictText))+    mkTagged (lifecycle, run) workDir whenText = Command {run, workDir, lifecycle, condition = parseWhen whenText}+    mkLegacy run workDir whenText = Command {run, workDir, lifecycle = ApplicationCommand, condition = parseWhen whenText}  -- | Parse an optional @when@ expression text into an 'Expr'. -- Returns 'Nothing' for 'Nothing' input, 'Just expr' on success, or calls

@@ -1,6 +1,8 @@ module Seihou.Effect.Filesystem   ( Filesystem (..),     PathEntry (..),+    ExclusiveCreateResult (..),+    createFileExclusive,     inspectPath,     createLink,     removeLink,@@ -20,6 +22,7 @@   ) where +import Seihou.Filesystem.Exclusive (ExclusiveCreateResult (..)) import Seihou.Prelude  -- | A filesystem entry, observed without following its final component.@@ -27,6 +30,7 @@   deriving stock (Eq, Show, Generic)  data Filesystem :: Effect where+  CreateFileExclusive :: FilePath -> Text -> Filesystem m ExclusiveCreateResult   InspectPath :: FilePath -> Filesystem m PathEntry   CreateDirectoryLink :: FilePath -> FilePath -> Filesystem m ()   RemoveLink :: FilePath -> Filesystem m ()@@ -98,3 +102,6 @@  normalizePath :: (Filesystem :> es) => FilePath -> Eff es FilePath normalizePath = send . NormalizePath++createFileExclusive :: (Filesystem :> es) => FilePath -> Text -> Eff es ExclusiveCreateResult+createFileExclusive path content = send (CreateFileExclusive path content)

@@ -1,12 +1,16 @@ module Seihou.Effect.FilesystemInterp   ( runFilesystem,+    createFileExclusiveWith,   ) where  import Control.Exception (IOException, catch, throwIO) import Control.Monad (when)+import Data.ByteString qualified as BS+import Data.Text.Encoding qualified as TE import Data.Text.IO qualified as TIO-import Seihou.Effect.Filesystem (Filesystem (..), PathEntry (..))+import Seihou.Effect.Filesystem (ExclusiveCreateResult (..), Filesystem (..), PathEntry (..))+import Seihou.Filesystem.Exclusive (createFileExclusiveWith) import Seihou.Prelude import System.Directory qualified as Dir import System.IO.Error (isDoesNotExistError)@@ -15,6 +19,7 @@ -- Delegates to System.Directory and Data.Text.IO. runFilesystem :: (IOE :> es) => Eff (Filesystem : es) a -> Eff es a runFilesystem = interpret $ \_ -> \case+  CreateFileExclusive path content -> liftIO (createFileExclusiveWith (\handle -> BS.hPut handle (TE.encodeUtf8 content)) path)   InspectPath path -> liftIO $ do     linked <- Dir.pathIsSymbolicLink path `catch` \(err :: IOException) -> if isDoesNotExistError err then pure False else throwIO err     if linked

@@ -9,7 +9,7 @@ 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 (..), PathEntry (..))+import Seihou.Effect.Filesystem (ExclusiveCreateResult (..), Filesystem (..), PathEntry (..)) import Seihou.Prelude  -- | In-memory filesystem state for testing.@@ -31,6 +31,11 @@   where     handler :: (State PureFS :> es') => EffectHandler Filesystem es'     handler _ = \case+      CreateFileExclusive path content -> do+        fs <- get @PureFS+        if Map.member path (fs ^. #files) || Map.member path (fs ^. #links) || Set.member path (fs ^. #dirs)+          then pure ExclusiveOccupied+          else modify @PureFS (#files %~ Map.insert path content) >> pure ExclusiveCreated       InspectPath path -> do         fs <- get @PureFS         pure $ case Map.lookup path (fs ^. #links) of

@@ -5,7 +5,10 @@   ) where +import Control.Exception (throw)+import Data.Text qualified as T import Seihou.Core.Types (Manifest)+import Seihou.Manifest.Types (manifestEncodingLoss) import Seihou.Prelude  data ManifestStore :: Effect where@@ -18,4 +21,6 @@ readManifest = send ReadManifest  writeManifest :: (ManifestStore :> es) => Manifest -> Eff es ()-writeManifest m = send (WriteManifest m)+writeManifest m = case manifestEncodingLoss m of+  [] -> send (WriteManifest m)+  problems -> throw (userError (T.unpack ("refusing to write invalid manifest: " <> T.intercalate "; " problems)))

@@ -55,6 +55,7 @@ operationDestination (WriteFileOp dest _ _) = Just dest operationDestination (CopyFileOp _ dest) = Just dest operationDestination (PatchFileOp dest _ _ _ _) = Just dest+operationDestination SeedFileOp {} = Nothing operationDestination CheckoutOutputOp {} = Nothing operationDestination CreateDirOp {} = Nothing operationDestination RunCommandOp {} = Nothing@@ -69,6 +70,7 @@   Operation ->   Eff es (Maybe (FilePath, FileRecord)) executeOp targetDir ownerFor modeFor now op = case op of+  SeedFileOp {} -> error "seed operation passed to managed execution"   CheckoutOutputOp {} -> pure Nothing   WriteFileOp dest content strat -> do     let fullPath = targetDir </> dest@@ -139,6 +141,7 @@     else T.unlines (map formatOp ops)   where     formatOp :: Operation -> Text+    formatOp SeedFileOp {dest} = "Seed " <> T.pack dest <> " (create once)"     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

@@ -8,6 +8,7 @@     -- * Engine entry points     classifyMigration,     executeMigration,+    validateSeedMigration,   ) where @@ -15,14 +16,16 @@ import Data.List (nub, sortBy) import Data.Map.Strict qualified as Map import Data.Ord (Down (..))+import Data.Set qualified as Set import Data.Text qualified as T import Data.Time (UTCTime)+import Seihou.Core.Checkout (pathsOverlap) import Seihou.Core.Migration   ( Migration (..),     MigrationOp (..),     MigrationPlan (..),   )-import Seihou.Core.Path (validateProjectRelativePath)+import Seihou.Core.Path (pathsHaveConflictingSpelling, validateProjectRelativePath) import Seihou.Core.Types   ( AppliedModule (..),     FileRecord (..),@@ -45,6 +48,7 @@ import Seihou.Prelude import System.Exit (ExitCode (..)) import System.FilePath (takeDirectory)+import System.FilePath.Posix qualified as P  -- ---------------------------------------------------------------------------- -- Types@@ -106,7 +110,12 @@   Manifest ->   MigrationPlan ->   Eff es (Either MigrationExecError ExecutedMigrationPlan)-classifyMigration manifest plan = do+classifyMigration manifest plan = case validateSeedMigration (Map.keysSet (manifest ^. #seeds)) (concatMap (^. #ops) (plan ^. #steps)) of+  Left err -> pure (Left err)+  Right () -> classifyUnprotectedMigration manifest plan++classifyUnprotectedMigration :: (Filesystem :> es) => Manifest -> MigrationPlan -> Eff es (Either MigrationExecError ExecutedMigrationPlan)+classifyUnprotectedMigration manifest plan = do   opsResult <- traverse (classifyOp manifest) (concatMap (^. #ops) (plan ^. #steps))   pure $ do     ops <- sequence opsResult@@ -204,7 +213,18 @@   -- | New @genAt@ timestamp to stamp on the rewritten manifest.   UTCTime ->   Eff es (Either MigrationExecError Manifest)-executeMigration force plan manifest now = do+executeMigration force plan manifest now = case validateProtectedMutationPaths (Map.keysSet (manifest ^. #seeds)) (concatMap instancePaths (plan ^. #ops)) of+  Left err -> pure (Left err)+  Right () -> executeUnprotectedMigration force plan manifest now+  where+    instancePaths (MoveFileInst source dest _) = [source, dest]+    instancePaths (MoveDirInst source dest) = [source, dest]+    instancePaths (DeleteFileInst path _) = [path]+    instancePaths (DeleteDirInst path) = [path]+    instancePaths RunCommandInst {} = []++executeUnprotectedMigration :: (Filesystem :> es, Process :> es) => Bool -> ExecutedMigrationPlan -> Manifest -> UTCTime -> Eff es (Either MigrationExecError Manifest)+executeUnprotectedMigration force plan manifest now = do   let conflicts =         [ p         | inst <- plan ^. #ops,@@ -367,3 +387,17 @@ isPrefixOfPath [] _ = True isPrefixOfPath _ [] = False isPrefixOfPath (x : xs) (y : ys) = x == y && isPrefixOfPath xs ys++validateSeedMigration :: Set FilePath -> [MigrationOp] -> Either MigrationExecError ()+validateSeedMigration seeds = validateProtectedMutationPaths seeds . concatMap paths+  where+    paths MoveFile {src, dest} = [src, dest]+    paths MoveDir {src, dest} = [src, dest]+    paths DeleteFile {path} = [path]+    paths DeleteDir {path} = [path]+    paths RunCommand {} = []++validateProtectedMutationPaths :: Set FilePath -> [FilePath] -> Either MigrationExecError ()+validateProtectedMutationPaths seeds paths = case [path | path <- paths, seed <- Set.toAscList seeds, pathsOverlap (P.normalise path) (P.normalise seed) || pathsHaveConflictingSpelling (P.normalise path) (P.normalise seed)] of+  path : _ -> Left (MigrationUnsafePath "seed ownership" path "declarative migrations must not mutate a project-owned seed or a path being released to the project; publish a compatible producer migration")+  [] -> Right ()

@@ -20,10 +20,10 @@ import Dhall qualified import Dhall.Core qualified as DhallCore import Dhall.Src (Src)-import Seihou.Core.Checkout (CheckoutError (..), validateCheckoutPaths)+import Seihou.Core.Checkout (CheckoutError (..), pathsOverlap, validateCheckoutPaths) import Seihou.Core.Expr (evalExpr) import Seihou.Core.Module (checkCheckoutSteps, checkSeedSteps)-import Seihou.Core.Path (validateProjectRelativePath)+import Seihou.Core.Path (validateCanonicalProjectPath, validateProjectRelativePath) import Seihou.Core.Types import Seihou.Engine.DhallJSON (dhallExprToJSON) import Seihou.Engine.Template (renderCommand, renderDestPath, renderTemplate, renderTemplateText)@@ -48,7 +48,13 @@   if null allErrors     then case compileCommands modName vars (modul ^. #commands) of       Left cmdErrs -> pure (Left cmdErrs)-      Right cmdOps -> pure (Right (deduplicateDirs (concat allOps) ++ cmdOps))+      Right cmdOps -> do+        let operations = deduplicateDirs (concat allOps) ++ cmdOps+            seedPaths = [dest | SeedFileOp {dest} <- operations]+            bytePaths = [dest | op <- operations, dest <- case op of WriteFileOp {dest} -> [dest]; CopyFileOp {dest} -> [dest]; PatchFileOp {dest} -> [dest]; CheckoutOutputOp {dest} -> [dest]; _ -> []]+            mixed = ["seed '" <> T.pack seed <> "' overlaps another output '" <> T.pack other <> "'" | seed <- seedPaths, other <- bytePaths, pathsOverlap seed other]+            removals = ["removal action targets seed '" <> T.pack seed <> "'" | removal <- maybe [] pure (modul ^. #removal), action <- removal ^. #steps, Right dest <- [renderCommand (action ^. #dest) vars], seed <- seedPaths, pathsOverlap seed (T.unpack dest)]+        pure (if null (mixed <> removals) then Right operations else Left (mixed <> removals))     else pure (Left (concat allErrors))  -- | Compile commands into 'RunCommandOp' operations, interpolating@@ -66,14 +72,15 @@           Left cmdErrs -> let (counts, ops, _) = state in (counts, ops, errs ++ cmdErrs)           Right (runText, commandWorkDir) ->             let (counts, ops, _) = state-                key = (runText, commandWorkDir)+                key = (cmd ^. #lifecycle, runText, if cmd ^. #lifecycle == CheckoutCommandLifecycle then Just (maybe "." id commandWorkDir) else commandWorkDir)                 occurrence = Map.findWithDefault 0 key counts                 operation =                   RunCommandOp                     { command = runText,                       workDir = commandWorkDir,                       moduleName = modName,-                      occurrence = occurrence+                      occurrence = occurrence,+                      lifecycle = cmd ^. #lifecycle                     }              in (Map.insert key (occurrence + 1) counts, ops ++ [operation], errs) @@ -95,7 +102,9 @@             Right renderedWd ->               case validateRenderedCommandWorkDir renderedWd of                 Left err -> Left [err]-                Right safeWd -> Right (runText, Just (T.unpack safeWd))+                Right safeWd -> do+                  if cmd ^. #lifecycle == CheckoutCommandLifecycle && safeWd /= "." then first pure (validateCanonicalProjectPath safeWd) else Right ()+                  Right (runText, Just (T.unpack safeWd))  -- | Compile a single step into operations (or skip it). -- If the step has a patch operation, it produces a 'PatchFileOp'; otherwise@@ -113,7 +122,16 @@         Just expr -> evalExpr vars expr   if not shouldRun     then pure (Right [])-    else case step ^. #patch of+    else do+      compiled <- compileActiveStep+      pure $ compiled >>= if step ^. #lifecycle == Seed then traverseSeed else Right+  where+    traverseSeed ops = traverse convert [op | op <- ops, case op of CreateDirOp {} -> False; _ -> True]+    convert (WriteFileOp dest content strategy) = do+      first pure (validateCanonicalProjectPath (T.pack dest))+      Right (SeedFileOp dest content strategy modName)+    convert _ = Left ["seed step must compile to a supported whole-file write"]+    compileActiveStep = case step ^. #patch of       Just _ -> compilePatchStep baseDir vars modName step       Nothing -> case step ^. #strategy of         Copy -> compileCopyStep baseDir vars step

@@ -73,6 +73,7 @@       annotation = strategyName strat,       module_ = Map.lookup dest ownerMap     }+opToPreview _ _ _ SeedFileOp {dest, moduleName} = FilePreview {status = FsNew, path = dest, annotation = "seed (create once)", module_ = Just moduleName} opToPreview _ _ _ (CheckoutOutputOp dest (DirectorySymlink source) _) = LinkPreview dest source opToPreview _ _ _ (CreateDirOp path) = DirPreview path opToPreview mDiff ownerMap _ (CopyFileOp _ dest) =

@@ -1,6 +1,9 @@ module Seihou.Engine.Reconcile   ( DesiredFileOwner (..),     DesiredFile (..),+    SeedAction (..),+    planSeedReconciliation,+    seedCandidateReceipts,     ReconciliationReason (..),     ObservedFile (..),     PlannedFileState (..),@@ -22,18 +25,22 @@   ) where -import Control.Monad (foldM)+import Control.Monad (foldM, forM, forM_, unless, when) import Data.Foldable (traverse_) import Data.Generics.Labels () import Data.List (foldl') import Data.Map.Strict qualified as Map import Data.Set qualified as Set import Data.Text qualified as T-import Seihou.Core.Path (validateProjectRelativePath)+import Data.Time (UTCTime)+import Seihou.Core.Checkout (pathsOverlap)+import Seihou.Core.Path (pathsHaveConflictingSpelling, validateProjectRelativePath)+import Seihou.Core.Seed (seedApplicationIds) import Seihou.Core.Types hiding (KeepCurrent) import Seihou.Effect.BaselineStore (BaselineError, BaselineStore, readBaseline)-import Seihou.Effect.Filesystem (Filesystem, doesFileExist, readFileText)+import Seihou.Effect.Filesystem (Filesystem, PathEntry (..), doesFileExist, inspectPath, readFileText) import Seihou.Engine.Section (applyTextPatch)+import Seihou.Engine.Seed import Seihou.Engine.ThreeWayMerge (MergeOutcome (..), threeWayMerge) import Seihou.Manifest.Hash (hashContent) import Seihou.Prelude@@ -64,7 +71,9 @@   deriving stock (Eq, Generic, Show)  data ReconciliationReason-  = MissingTrustedBaseline+  = AdoptingSeedFile+  | AdoptingMissingSeedFile+  | MissingTrustedBaseline   | CurrentFileMissing   | MergeDriverUnavailable Text   | OverlappingEdits@@ -96,8 +105,24 @@   }   deriving stock (Eq, Generic, Show) +-- | Metadata-only seed actions carry neither bytes nor content snapshots.+-- Only creation carries a candidate payload. Supplier is explicit; claims may+-- include multiple qualified instances per application.+data SeedAction = SeedAction+  { path :: !FilePath,+    supplier :: !ModuleName,+    claims :: !(Map ApplicationId (Set ModuleName)),+    decision :: !SeedDecision,+    newContent :: !(Maybe Text)+  }+  deriving stock (Eq, Show, Generic)+ data FileReconciliation-  = FileCreate DesiredFile PlannedFileState ObservedFile+  = FileSeedCreate SeedAction PathEntry+  | FileSeedSettle SeedAction+  | FileSeedRelease SeedAction FileRecord+  | FileSeedAbandon FilePath SeedRecord+  | FileCreate DesiredFile PlannedFileState ObservedFile   | FileUpdate DesiredFile PlannedFileState ObservedFile (Maybe FileRecord)   | FileAutoMerge DesiredFile PlannedFileState ObservedFile (Maybe FileRecord)   | FileUnchanged DesiredFile PlannedFileState ObservedFile (Maybe FileRecord)@@ -142,7 +167,11 @@     partial = not (Set.null retainedOwners)  data ReconciliationError-  = InvalidReconciliationPath FilePath Text+  = SeedReconciliationFailed Text+  | SeedReleaseBlockedByOwners FilePath (Set ApplicationId)+  | SeedPathAlsoManaged FilePath+  | InvalidSeedAdoptionChoice FilePath+  | InvalidReconciliationPath FilePath Text   | MissingDesiredOwner FilePath   | DesiredOwnerOutsideSelection FilePath (Set ApplicationId)   | SharedPathRequiresApplications FilePath (Set ApplicationId)@@ -211,6 +240,91 @@         then Right <$> readFileText sourcePath         else pure (Left (CopySourceUnavailable sourcePath)) +-- | Partition lifecycle operations before managed materialization or orphan+-- classification. Seed observation never reads project contents. Across selected+-- applications, operations arrive in recorded application order.+planSeedReconciliation ::+  (Filesystem :> es, BaselineStore :> es, IOE :> es) =>+  FilePath ->+  FilePath ->+  Manifest ->+  Set ApplicationId ->+  [Operation] ->+  Map FilePath DesiredFileOwner ->+  Map FilePath (Map ApplicationId (Set ModuleName)) ->+  Eff es (Either ReconciliationError ReconciliationPlan)+planSeedReconciliation root managedRoot manifest selected operations ownerMap claims = do+  let seedOps = firstSeeds Set.empty operations+      seedPaths = Map.keysSet claims+      managedOps = filter (\case SeedFileOp {} -> False; _ -> True) operations+      checkoutPaths = Set.fromList [dest | CheckoutOutputOp {dest} <- operations]+      managedPaths = Map.keysSet (groupFileOperations managedOps) `Set.union` checkoutPaths+      overlaps a b = pathsOverlap a b || pathsHaveConflictingSpelling a b+      retainedOwners receipt = seedApplicationIds receipt Set.\\ selected+      gate = do+        forM_ (Set.toAscList seedPaths) $ \path -> do+          when (any (overlaps path) (Set.toAscList managedPaths)) (Left (SeedPathAlsoManaged path))+          case Map.lookup path (manifest ^. #files) of+            Just record | not (Set.null (Set.difference (record ^. #applicationIds) selected)) -> Left (SeedReleaseBlockedByOwners path (Set.difference (record ^. #applicationIds) selected))+            _ -> Right ()+        forM_ (Map.toAscList (manifest ^. #seeds)) $ \(path, receipt) ->+          forM_ (Set.toAscList managedPaths) $ \managed ->+            when (overlaps path managed && (Set.member managed checkoutPaths || path /= managed || not (Set.null (retainedOwners receipt)))) (Left (SeedPathAlsoManaged path))+  case gate of+    Left err -> pure (Left err)+    Right () -> do+      seeded <- planSeeds root manifest (Map.map (Set.unions . Map.elems) claims) seedOps+      adoptionEntries <- forM (Set.toAscList (managedPaths `Set.intersection` Map.keysSet (manifest ^. #seeds))) $ \path -> do+        entry <- inspectPath (root </> path)+        pure (path, entry)+      case [path | (path, entry) <- adoptionEntries, entry `notElem` [EntryFile, EntryMissing]] of+        path : _ -> pure (Left (SeedReconciliationFailed ("seed adoption '" <> T.pack path <> "' requires a regular file or absence; move the directory or symlink aside")))+        [] -> case seeded of+          Left errors -> pure (Left (SeedReconciliationFailed (T.intercalate "; " (map (^. #message) errors))))+          Right seedPlans -> do+            managed <- planReconciliation managedRoot (manifest & #files %~ (`Map.withoutKeys` seedPaths)) selected managedOps ownerMap+            pure $ do+              plan <- managed+              let actions = Map.fromList [(planned ^. #dest, action planned) | planned <- seedPlans]+                  abandoned = Map.mapWithKey FileSeedAbandon (Map.filterWithKey (\path receipt -> Set.notMember path seedPaths && Set.notMember path managedPaths && not (Set.null (seedApplicationIds receipt `Set.intersection` selected))) (manifest ^. #seeds))+                  adoptions = foldl' makeAdoption (plan ^. #files) adoptionEntries+              Right (plan & #files .~ Map.unions [actions, adoptions, abandoned] & #requiredDirectories %~ Set.union (Set.fromList [takeDirectory (planned ^. #dest) | planned <- seedPlans, planned ^. #decision == SeedWrite, takeDirectory (planned ^. #dest) /= "."]))+  where+    firstSeeds _ [] = []+    firstSeeds seen (op@SeedFileOp {dest} : rest)+      | Set.member dest seen = firstSeeds seen rest+      | otherwise = op : firstSeeds (Set.insert dest seen) rest+    firstSeeds seen (_ : rest) = firstSeeds seen rest+    action planned =+      let path = planned ^. #dest+          seed = SeedAction path (planned ^. #supplier) (Map.findWithDefault Map.empty path claims) (planned ^. #decision) (if planned ^. #decision == SeedWrite then Just (planned ^. #content) else Nothing)+       in case planned ^. #decision of+            SeedWrite -> FileSeedCreate seed EntryMissing+            SeedReleaseManaged -> case Map.lookup path (manifest ^. #files) of Just record -> FileSeedRelease seed record; Nothing -> FileSeedSettle seed+            _ -> FileSeedSettle seed+    makeAdoption files (path, entry) = Map.adjust (adopt (entry == EntryMissing)) path files+    adopt missing reconciliation = case desiredFor reconciliation of+      Just (desired, current, observed) -> FileConflict desired current "" (if missing then AdoptingMissingSeedFile else AdoptingSeedFile) observed Nothing Nothing+      Nothing -> reconciliation+    desiredFor reconciliation = case reconciliation of+      FileCreate desired _ observed -> Just (desired, "", observed)+      FileUpdate desired state observed _ -> Just (desired, state ^. #appliedContent, observed)+      FileAutoMerge desired state observed _ -> Just (desired, state ^. #appliedContent, observed)+      FileUnchanged desired state observed _ -> Just (desired, state ^. #appliedContent, observed)+      FileConflict desired current _ _ observed _ _ -> Just (desired, current, observed)+      _ -> Nothing++-- | Complete candidate claims, preserving prior settlement on every surviving+-- path. Used once by update's manifest fold, never as a successful preview receipt.+seedCandidateReceipts :: UTCTime -> Manifest -> ReconciliationPlan -> Map FilePath SeedRecord+seedCandidateReceipts now manifest plan = Map.fromList [receipt action | reconciliation <- Map.elems (plan ^. #files), action <- case reconciliation of FileSeedCreate a _ -> [a]; FileSeedSettle a -> [a]; FileSeedRelease a _ -> [a]; _ -> []]+  where+    receipt action =+      let path = action ^. #path+          prior = Map.lookup path (manifest ^. #seeds)+          outcome = case action ^. #decision of SeedWrite -> SeedCreated; SeedReleaseManaged -> SeedReleasedFromManaged; _ -> SeedFoundExisting+       in (path, SeedRecord (maybe (action ^. #supplier) (^. #moduleName) prior) (KnownSeedOwners (action ^. #claims)) (maybe outcome (^. #outcome) prior) (maybe now (^. #settledAt) prior))+ -- | Backend-parametric planner. Tests use maps for disk, copy-source, and -- baseline reads while production supplies effects. The function is read-only. planReconciliationWith ::@@ -262,7 +376,8 @@     baseline :: !(Maybe Text),     priorRecord :: !(Maybe FileRecord),     observed :: !ObservedFile,-    missingTrustedBaseline :: !Bool+    missingTrustedBaseline :: !Bool,+    lineSetPatch :: !Bool   }   deriving stock (Generic) @@ -403,7 +518,8 @@           baseline = trusted,           priorRecord = prior,           observed = observe current,-          missingTrustedBaseline = missing+          missingTrustedBaseline = missing,+          lineSetPatch = all (\case PatchFileOp {op = AppendLineIfAbsent} -> True; _ -> False) pathOperations         }   where     operationPath (operation : _) = case operationDestination operation of@@ -490,6 +606,14 @@            in pure (Right (path, FileUnchanged desired state observed prior))       | current == generated =           pure (Right (path, FileUnchanged desired (unchangedState generated current) observed prior))+      -- Line-set additions commute with project edits, including an append at+      -- the same EOF. Apply only newly declared lines, preserving intentional+      -- removal of older lines. Other patches retain ordinary three-way merge.+      | context ^. #lineSetPatch =+          let additions = filter (\line -> T.stripEnd line `notElem` map T.stripEnd (T.lines baseline)) (T.lines generated)+           in pure $ case applyTextPatch AppendLineIfAbsent (desired ^. #moduleName) "#" current (T.unlines additions) of+                Right merged -> Right (path, fromMerge current (MergeClean merged))+                Left reason -> Left (PatchMaterializationFailed path AppendLineIfAbsent (desired ^. #moduleName) reason)       | otherwise = do           outcome <- mergeContents baseline current generated           pure $ Right (path, fromMerge current outcome)@@ -551,6 +675,7 @@ resolveFileConflict path choice plan = case Map.lookup path (plan ^. #files) of   Nothing -> Left (ReconciliationPathNotFound path)   Just (FileConflict _ _ _ _ _ _ _) | choice == AbortUpdate -> Left (UpdateAborted path)+  Just (FileConflict _ _ _ reason _ _ _) | (reason == AdoptingMissingSeedFile && choice /= AcceptGenerated) || (reason == AdoptingSeedFile && choice == WriteConflictMarkers) -> Left (InvalidSeedAdoptionChoice path)   Just (FileConflict desired current markers reason observed prior _) ->     let applied = case choice of           AcceptGenerated -> (desired ^. #generatedContent)@@ -592,6 +717,10 @@   where     emptySummary = ReconciliationSummary 0 0 0 0 0 0 0 0     count summary reconciliation = case reconciliation of+      FileSeedCreate _ _ -> addCreate summary+      FileSeedRelease _ _ -> addSharedOwnership summary+      FileSeedAbandon _ _ -> addSharedOwnership summary+      FileSeedSettle _ -> addUnchanged summary       FileCreate _ _ _ -> addCreate summary       FileUpdate _ _ _ _ -> addUpdate summary       FileAutoMerge _ _ _ _ -> addMerge summary@@ -625,7 +754,7 @@     }  reconciliationMutationPaths :: ReconciliationPlan -> Set FilePath-reconciliationMutationPaths = Map.keysSet . (^. #files)+reconciliationMutationPaths = Map.keysSet . Map.filter (\case FileSeedSettle {} -> False; FileSeedRelease {} -> False; FileSeedAbandon {} -> False; _ -> True) . (^. #files)  unresolvedPaths :: ReconciliationPlan -> Set FilePath unresolvedPaths plan = Map.keysSet (Map.filter unresolved (plan ^. #files))

@@ -7,6 +7,7 @@     ExecutedRemovalPlan (..),     CheckoutRemovalSelection (..),     selectCheckoutRemoval,+    selectRecordedRemoval,     computeRemovalPlan,     executeRemoval,     buildRemovalOps,@@ -26,13 +27,15 @@ import Data.Time (UTCTime) import Seihou.Composition.Instance (ModuleInstance (..), qualifiedName) import Seihou.Core.Checkout-import Seihou.Core.Path (validateProjectRelativePath)+import Seihou.Core.Path (pathsHaveConflictingSpelling, validateProjectRelativePath)+import Seihou.Core.Seed import Seihou.Core.Types import Seihou.Effect.Filesystem (Filesystem, doesFileExist, readFileText, removeDirectoryIfEmpty, removeFile, writeFileText) import Seihou.Engine.Section (removeSection) import Seihou.Manifest.Hash (hashContent) import Seihou.Prelude import System.FilePath (takeDirectory)+import System.FilePath.Posix qualified as P  -- ============================================================ -- Legacy types (used by current CLI handler, Milestone 4 replaces)@@ -61,7 +64,8 @@  -- | A concrete removal operation ready to execute. data RemovalOp-  = -- | Delete a file, with its current status.+  = KeepSeedOp FilePath+  | -- | Delete a file, with its current status.     DeleteFileOp FilePath RemovalFileStatus   | -- | Strip this module's section markers from a file.     StripSectionOp FilePath@@ -134,7 +138,7 @@   Eff es Manifest executeRemoval manifest plan keepSet now = do   let toDelete = filesToDelete plan keepSet-  mapM_ removeFile toDelete+  mapM_ removeFile (filter (not . protectedSeedPath manifest) toDelete)   cleanupEmptyDirs toDelete   pure (removeFromManifest manifest (plan ^. #targetModule) now) @@ -172,7 +176,13 @@   ModuleName ->   RemovalStep ->   Eff es (Either RemovalError RemovalOp)-buildStepOp manifest _modName step = case step ^. #action of+buildStepOp manifest modName step = case validateRemovalPath (case step ^. #action of RemoveFileAction -> "remove-file destination"; RemoveSectionAction -> "remove-section destination"; RewriteFileAction -> "rewrite-file destination") (step ^. #dest) of+  Left err -> pure (Left err)+  Right path | protectedSeedPath manifest path -> pure (Right (KeepSeedOp path))+  _ -> buildUnprotectedStepOp manifest modName step++buildUnprotectedStepOp :: (Filesystem :> es) => Manifest -> ModuleName -> RemovalStep -> Eff es (Either RemovalError RemovalOp)+buildUnprotectedStepOp manifest _modName step = case step ^. #action of   RemoveFileAction ->     case validateRemovalPath "remove-file destination" (step ^. #dest) of       Left err -> pure (Left err)@@ -193,10 +203,11 @@       Right (RewriteOp dest src)  buildCommandOp :: Command -> Either RemovalError RemovalOp-buildCommandOp command =-  case traverse (validateRemovalPath "remove-command workDir") (command ^. #workDir) of-    Left err -> Left err-    Right safeWorkDir -> Right (RemovalCommandOp (command ^. #run) (fmap T.pack safeWorkDir))+buildCommandOp command+  | command ^. #lifecycle == CheckoutCommandLifecycle = Left (RemovalUnsafePath "remove-command" "" "checkout setup is not a removal command")+  | otherwise = case traverse (validateRemovalPath "remove-command workDir") (command ^. #workDir) of+      Left err -> Left err+      Right safeWorkDir -> Right (RemovalCommandOp (command ^. #run) (fmap T.pack safeWorkDir))  validateRemovalPath :: Text -> Text -> Either RemovalError FilePath validateRemovalPath label path =@@ -233,7 +244,10 @@   Eff es Manifest executeRemovalOps manifest plan keepSet now = do   let modName = (plan ^. #targetModule)-  deletedPaths <- foldM (execOp modName keepSet) [] (plan ^. #ops)+  let protected op = case removalOpDestination op of+        Just path | protectedSeedPath manifest path -> KeepSeedOp path+        _ -> op+  deletedPaths <- foldM (execOp modName keepSet) [] (map protected (plan ^. #ops))   cleanupEmptyDirs deletedPaths   pure (removeFromManifest manifest modName now) @@ -245,6 +259,7 @@   [FilePath] ->   RemovalOp ->   Eff es [FilePath]+execOp _ _ acc KeepSeedOp {} = pure acc execOp _ keepSet acc (DeleteFileOp path status) =   if Set.member path keepSet     then pure acc@@ -274,6 +289,16 @@   -- Commands are executed by the CLI handler, not the engine   pure acc +protectedSeedPath :: Manifest -> FilePath -> Bool+protectedSeedPath manifest path = any (\seed -> pathsOverlap (P.normalise path) (P.normalise seed) || pathsHaveConflictingSpelling (P.normalise path) (P.normalise seed)) (Map.keys (manifest ^. #seeds))++removalOpDestination :: RemovalOp -> Maybe FilePath+removalOpDestination (KeepSeedOp path) = Just path+removalOpDestination (DeleteFileOp path _) = Just path+removalOpDestination (StripSectionOp path) = Just path+removalOpDestination (RewriteOp path _) = Just path+removalOpDestination RemovalCommandOp {} = Nothing+ -- | Guess the comment prefix for a file based on its extension. guessCommentPrefix :: FilePath -> Text guessCommentPrefix path@@ -379,9 +404,13 @@ -- | 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+selectCheckoutRemoval = selectRecordedRemoval++-- | Shared selection for seed, checkout-output and checkout-command ownership.+selectRecordedRemoval :: Manifest -> ModuleName -> Maybe ApplicationId -> Either CheckoutError (Maybe CheckoutRemovalSelection)+selectRecordedRemoval manifest requested selectedApplication = case candidates of   []-    | selectedApplication /= Nothing -> Left (checkoutError "checkout_remove_selection" "no matching checkout-owning instance in the selected application")+    | selectedApplication /= Nothing -> Left (checkoutError "checkout_remove_selection" "no matching recorded owning instance in the selected application")     | otherwise -> Right Nothing   [(app, state, qualified)] -> do     let appId = app ^. #applicationId@@ -396,7 +425,7 @@           | 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)))+               in if null retained then Nothing else Just (other & #instances .~ retained & #commandReceipts %~ Map.filter ((/= qualified) . (^. #moduleName)) & #checkoutCommands %~ filter ((/= qualified) . (^. #moduleName)))         applications = mapMaybe keepApplication (manifest ^. #applications)         files = Map.mapMaybe keepFile (manifest ^. #files)         stillNeeded applied =@@ -405,9 +434,19 @@         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]))+    -- Retiring seed-only metadata does not authorize forgetting managed files.+    case custom of+      Nothing+        | any (\record -> record ^. #moduleName == qualified && Set.member appId (record ^. #applicationIds)) (Map.elems (manifest ^. #files)) ->+            Left (checkoutError "remove_managed_policy_required" "this instance also owns managed files; add a removal specification for those files before removing it")+      _ -> Right ()+    withSeeds <-+      first (checkoutError "seed_owner_evidence_required" . renderSeedOwnershipError) $+        foldM (\current path -> dropSeedOwners selected path current) candidate (Map.keys (manifest ^. #seeds))+    first (checkoutError "seed_declaration_invalid" . renderManifestInvariantError) (validateManifestInvariants withSeeds)+    validateCheckoutRecords withSeeds []+    pure (Just (CheckoutRemovalSelection appId qualified (state ^. #name) custom withSeeds))+  matches -> Left (checkoutError "checkout_remove_ambiguous" ("recorded 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)@@ -416,5 +455,5 @@         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))+        any (\record -> case record ^. #ownership of KnownSeedOwners owners -> Set.member qualified (Map.findWithDefault Set.empty (app ^. #applicationId) owners); LegacySeedOwners apps -> Set.member (app ^. #applicationId) apps) (Map.elems (manifest ^. #seeds)) || any ((== qualified) . (^. #moduleName)) (app ^. #checkoutCommands) || any (\record -> Set.member qualified (Map.findWithDefault Set.empty (app ^. #applicationId) (record ^. #owners))) (Map.elems (manifest ^. #checkoutOutputs))       ]

@@ -0,0 +1,173 @@+module Seihou.Engine.Seed+  ( SeedError (..),+    SeedDecision (..),+    PlannedSeed (..),+    classifySeed,+    seedOperationClaims,+    planSeeds,+    validateSeedRun,+    executeSeeds,+    renderSeedPlan,+  )+where++import Control.Monad (foldM, forM)+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)+import Seihou.Core.Checkout (pathsOverlap)+import Seihou.Core.Path (pathsHaveConflictingSpelling, validateCanonicalProjectPath)+import Seihou.Core.Seed+import Seihou.Core.Types+import Seihou.Effect.Filesystem+import Seihou.Prelude+import System.FilePath.Posix qualified as P++data SeedError = SeedError {code :: !Text, message :: !Text}+  deriving stock (Eq, Show, Generic)++data SeedDecision = SeedWrite | SeedKeepExisting | SeedRespectDeletion | SeedAlreadySettled | SeedReleaseManaged+  deriving stock (Eq, Show, Generic)++data PlannedSeed = PlannedSeed+  { dest :: !FilePath,+    content :: !Text,+    strategy :: !Strategy,+    supplier :: !ModuleName,+    owners :: !(Set ModuleName),+    observed :: !PathEntry,+    decision :: !SeedDecision+  }+  deriving stock (Eq, Show, Generic)++classifySeed :: Maybe SeedRecord -> Maybe FileRecord -> PathEntry -> Either SeedError SeedDecision+classifySeed _ (Just _) _ = Right SeedReleaseManaged+classifySeed (Just _) Nothing EntryMissing = Right SeedRespectDeletion+classifySeed (Just _) Nothing _ = Right SeedAlreadySettled+classifySeed Nothing Nothing EntryMissing = Right SeedWrite+classifySeed Nothing Nothing EntryFile = Right SeedKeepExisting+classifySeed Nothing Nothing _ = Left (SeedError "seed_destination_occupied" "new seed destination is a symlink or directory; move it aside and retry")++seedOperationClaims :: [Operation] -> Map FilePath (Set ModuleName)+seedOperationClaims operations = Map.fromListWith Set.union [(dest, Set.singleton moduleName) | SeedFileOp {dest, moduleName} <- operations]++-- | Lifecycle transitions belong to update; force is never consent. This pure+-- preflight runs before migrations, writes, or publishing new applied metadata.+validateSeedRun :: Manifest -> [Operation] -> Either [SeedError] ()+validateSeedRun manifest operations = case errors of [] -> Right (); _ -> Left errors+  where+    errors =+      [transition path | SeedFileOp {dest = path} <- operations, Map.member path (manifest ^. #files)]+        <> [transition path | op <- operations, Just path <- [managedDestination op], seed <- Map.keys (manifest ^. #seeds), pathsOverlap path seed]+    transition path = SeedError "seed_lifecycle_transition" ("output '" <> T.pack path <> "' changes lifecycle; run seihou update for its recorded application to review the transition")++managedDestination :: Operation -> Maybe FilePath+managedDestination WriteFileOp {dest} = Just dest+managedDestination CopyFileOp {dest} = Just dest+managedDestination PatchFileOp {dest} = Just dest+managedDestination CheckoutOutputOp {dest} = Just dest+managedDestination _ = Nothing++planSeeds :: (Filesystem :> es) => FilePath -> Manifest -> Map FilePath (Set ModuleName) -> [Operation] -> Eff es (Either [SeedError] [PlannedSeed])+planSeeds root manifest claims operations = do+  results <- forM [op | op@SeedFileOp {} <- operations] $ \case+    SeedFileOp {dest, content, strategy, moduleName} -> do+      let overlaps =+            [other | other <- Map.keys (manifest ^. #files), other /= dest, (pathsOverlap dest other || pathsHaveConflictingSpelling dest other)]+              <> [other | other <- Map.keys (manifest ^. #checkoutOutputs), (pathsOverlap dest other || pathsHaveConflictingSpelling dest other)]+              <> [other | other <- Map.keys (manifest ^. #seeds), other /= dest, (pathsOverlap dest other || pathsHaveConflictingSpelling dest other)]+      case first (SeedError "seed_path_invalid") (validateCanonicalProjectPath (T.pack dest)) of+        Left err -> pure (Left err)+        Right () | not (null overlaps) -> pure (Left (SeedError "seed_path_overlap" ("seed '" <> T.pack dest <> "' overlaps retained output '" <> T.pack (head overlaps) <> "'")))+        Right () -> do+          parents <- checkParents root dest False+          case parents of+            Left err -> pure (Left err)+            Right () -> do+              observed <- inspectPath (root </> dest)+              alias <- checkSpelling root dest observed+              pure $ do+                alias+                decision <- first (atPath dest) (classifySeed (Map.lookup dest (manifest ^. #seeds)) (Map.lookup dest (manifest ^. #files)) observed)+                Right (PlannedSeed dest content strategy moduleName (Map.findWithDefault (Set.singleton moduleName) dest claims) observed decision)+    _ -> error "non-seed operation in seed partition"+  pure $ case [err | Left err <- results] of [] -> Right [planned | Right planned <- results]; errors -> Left errors++ancestors :: FilePath -> [FilePath]+ancestors path = reverse (go (P.takeDirectory path))+  where+    go "." = []; go "" = []; go p = p : go (P.takeDirectory p)++atPath :: FilePath -> SeedError -> SeedError+atPath path err = err & #message %~ (("seed '" <> T.pack path <> "': ") <>)++checkSpelling :: (Filesystem :> es) => FilePath -> FilePath -> PathEntry -> Eff es (Either SeedError ())+checkSpelling _ _ EntryMissing = pure (Right ())+checkSpelling root path _ = do+  names <- listDirectory (root </> P.takeDirectory path)+  pure $ if P.takeFileName path `elem` names then Right () else Left (SeedError "seed_native_alias" ("seed path '" <> T.pack path <> "' resolves through a different native spelling"))++-- | Never traverse an unsafe ancestor. Missing parents are created only for an+-- actual exclusive creation attempt, so respecting deletion creates no directories.+checkParents :: (Filesystem :> es) => FilePath -> FilePath -> Bool -> Eff es (Either SeedError ())+checkParents root dest create = go (ancestors dest)+  where+    go [] = pure (Right ())+    go (parent : rest) =+      inspectPath (root </> parent) >>= \case+        EntryDirectory -> do+          spelling <- checkSpelling root parent EntryDirectory+          case spelling of Left err -> pure (Left err); Right () -> go rest+        EntryMissing | create -> createDirectoryIfMissing False (root </> parent) >> go rest+        EntryMissing -> pure (Right ())+        _ -> pure (Left (SeedError "seed_parent_unsafe" ("seed ancestor '" <> T.pack parent <> "' must be a real directory; move the object aside")))++-- | Return the application's complete actual candidate claims; the caller uses+-- replaceSelectedSeedClaims after attaching final application records. No receipt+-- is returned for a failed creation. A partial run may leave a complete new file.+executeSeeds :: (Filesystem :> es) => FilePath -> ApplicationId -> UTCTime -> [PlannedSeed] -> Manifest -> Eff es (Either SeedError (Map FilePath SeedRecord))+executeSeeds root app now plans manifest = foldM apply (Right Map.empty) plans+  where+    apply (Left err) _ = pure (Left err)+    apply (Right records) planned = do+      let path = planned ^. #dest+          decision = planned ^. #decision+      outcome <- case decision of+        SeedWrite -> do+          safe <- checkParents root path True+          case safe of+            Left err -> pure (Left err)+            Right () ->+              createFileExclusive (root </> path) (planned ^. #content) >>= \case+                ExclusiveCreated -> pure (Right SeedCreated)+                ExclusiveFailure reason -> pure (Left (SeedError "seed_creation_failed" ("cannot create seed '" <> T.pack path <> "': " <> reason)))+                ExclusiveOccupied ->+                  inspectPath (root </> path) >>= \case+                    EntryFile -> pure (Right SeedFoundExisting)+                    _ -> pure (Left (SeedError "seed_destination_changed" ("seed '" <> T.pack path <> "' became occupied; move it aside and retry")))+        SeedReleaseManaged -> pure (Left (SeedError "seed_lifecycle_transition" "managed release requires seihou update"))+        SeedKeepExisting -> pure (Right SeedFoundExisting)+        _ -> pure (Right (maybe SeedFoundExisting (^. #outcome) (Map.lookup path (manifest ^. #seeds))))+      pure $ do+        actual <- outcome+        let prior = Map.lookup path (manifest ^. #seeds)+            record = SeedRecord (maybe (planned ^. #supplier) (^. #moduleName) prior) (KnownSeedOwners (Map.singleton app (planned ^. #owners))) actual (maybe now (^. #settledAt) prior)+        Right (Map.insert path record records)++renderSeedPlan :: Bool -> [PlannedSeed] -> Text+renderSeedPlan showContent plans = T.concat (map render plans)+  where+    render planned =+      "  "+        <> action (planned ^. #decision)+        <> " "+        <> T.pack (planned ^. #dest)+        <> " (seed; owned by the project)\n"+        <> if showContent && planned ^. #decision == SeedWrite then T.unlines (map ("    + " <>) (T.lines (planned ^. #content))) else ""+    action SeedWrite = "create once"+    action SeedKeepExisting = "keep existing"+    action SeedRespectDeletion = "keep deleted"+    action SeedAlreadySettled = "keep settled"+    action SeedReleaseManaged = "release to project"

@@ -2,6 +2,7 @@   ( UpdateTransaction (..),     TransactionError (..),     beginUpdateTransaction,+    beginSeedUpdateTransaction,     applyReconciliation,     applyReconciliationWithHook,     rollbackUpdateTransaction,@@ -18,6 +19,7 @@ import Data.Aeson (FromJSON (..), ToJSON (..), (.:), (.:?), (.=)) import Data.Aeson qualified as Aeson import Data.Aeson.Types qualified as Aeson+import Data.ByteString qualified as BS import Data.ByteString.Lazy qualified as LBS import Data.Foldable (traverse_) import Data.Generics.Labels ()@@ -25,17 +27,21 @@ import Data.Map.Strict qualified as Map 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, getCurrentTime) import Seihou.Core.Path (validateProjectRelativePath)+import Seihou.Core.Seed (renderSeedOwnershipError, replaceSelectedSeedClaims) import Seihou.Core.Types import Seihou.Effect.BaselineStore (putBaseline) import Seihou.Effect.BaselineStoreInterp (runBaselineStore)-import Seihou.Effect.Filesystem (PathEntry (..), inspectPath)+import Seihou.Effect.Filesystem (ExclusiveCreateResult (..), PathEntry (..), inspectPath) import Seihou.Effect.FilesystemInterp (runFilesystem) import Seihou.Effect.Process (runProcess) import Seihou.Effect.ProcessInterp (runProcessIO) import Seihou.Engine.Reconcile+import Seihou.Engine.Seed (SeedDecision (..))+import Seihou.Filesystem.Exclusive (createFileExclusiveAnchored) import Seihou.Manifest.Hash (hashContent) import Seihou.Manifest.Types (manifestFromJSON) import Seihou.Prelude@@ -44,6 +50,7 @@ import System.FilePath (splitDirectories, takeDirectory, takeFileName) import System.IO (hClose, hSetEncoding, utf8) import System.IO.Temp (createTempDirectory, openTempFile)+import System.Posix.Files qualified as Posix  data UpdateTransaction = UpdateTransaction   { projectRoot :: !FilePath,@@ -77,6 +84,7 @@     entries :: ![JournalEntry],     newDirectories :: ![FilePath],     indexLinks :: !(Map FilePath Text),+    seedCreations :: !(Map FilePath (Maybe (SHA256, Integer, Integer))),     expectedManifest :: !(Maybe Manifest)   }   deriving stock (Eq, Generic, Show)@@ -118,23 +126,28 @@         "entries" .= (metadata ^. #entries),         "newDirectories" .= (metadata ^. #newDirectories),         "indexLinks" .= (metadata ^. #indexLinks),+        "seedCreations" .= (metadata ^. #seedCreations),         "expectedManifest" .= (metadata ^. #expectedManifest)       ]  instance FromJSON JournalMetadata where   parseJSON = Aeson.withObject "JournalMetadata" $ \object -> do     version <- object .: "version"-    unless (version `elem` [1, 2, 3]) (fail "unsupported transaction journal version")+    unless (version `elem` [1, 2, 3, 4]) (fail "unsupported transaction journal version")     JournalMetadata       <$> pure version       <*> object .: "createdAt"       <*> (mapM (parseJournalEntry version) =<< object .: "entries")       <*> object .: "newDirectories"       <*> (if version < 3 then pure Map.empty else object .: "indexLinks")+      <*> (if version < 4 then pure Map.empty else object .: "seedCreations")       <*> object .:? "expectedManifest"  beginUpdateTransaction :: FilePath -> Set FilePath -> IO (Either TransactionError UpdateTransaction)-beginUpdateTransaction projectRoot targets = case traverse validateTransactionPath (Set.toAscList targets) of+beginUpdateTransaction root targets = beginSeedUpdateTransaction root targets Set.empty++beginSeedUpdateTransaction :: FilePath -> Set FilePath -> Set FilePath -> IO (Either TransactionError UpdateTransaction)+beginSeedUpdateTransaction projectRoot targets seedPaths = case traverse validateTransactionPath (Set.toAscList targets) of   Left err -> pure (Left err)   Right safeTargets -> do     result <- try @SomeException $ do@@ -142,15 +155,15 @@       Directory.createDirectoryIfMissing True transactionsRoot       transactionDirectory <- createTempDirectory transactionsRoot "update-"       let transaction = UpdateTransaction projectRoot transactionDirectory (Set.fromList safeTargets)-      initializeJournal transaction safeTargets `onException` cleanupDirectory transactionDirectory+      initializeJournal transaction seedPaths safeTargets `onException` cleanupDirectory transactionDirectory       pure transaction     pure $ first (TransactionStartFailed . exceptionText) result -initializeJournal :: UpdateTransaction -> [FilePath] -> IO ()-initializeJournal transaction safeTargets = do+initializeJournal :: UpdateTransaction -> Set FilePath -> [FilePath] -> IO ()+initializeJournal transaction seedPaths safeTargets = do   let backupDirectory = transaction ^. #transactionDirectory </> "backups"   Directory.createDirectoryIfMissing True backupDirectory-  entries <- forM (zip [0 :: Int ..] safeTargets) $ \(index, relativePath) -> do+  entries <- forM (zip [0 :: Int ..] (filter (`Set.notMember` seedPaths) safeTargets)) $ \(index, relativePath) -> do     let fullPath = transaction ^. #projectRoot </> relativePath         backupName = show index <> ".txt"         backupPath = backupDirectory </> backupName@@ -168,11 +181,12 @@   writeJournal     (transaction ^. #transactionDirectory)     JournalMetadata-      { journalVersion = 2,+      { journalVersion = if Set.null seedPaths then 2 else 4,         createdAt = now,         entries = entries,         newDirectories = missingDirectories,         indexLinks = Map.empty,+        seedCreations = Map.empty,         expectedManifest = Nothing       } @@ -221,7 +235,7 @@       actual <- trackedLinkIdentity (transaction ^. #projectRoot) path       unless (actual == Just oid) (ioError (userError ("Git index changed for " <> path)))     metadata <- readJournal (transaction ^. #transactionDirectory) >>= either (ioError . userError . show) pure-    writeJournal (transaction ^. #transactionDirectory) (metadata & #journalVersion .~ 3 & #indexLinks .~ links)+    writeJournal (transaction ^. #transactionDirectory) (metadata & #journalVersion %~ max 3 & #indexLinks .~ links)     removed <- gitOutput (transaction ^. #projectRoot) (["update-index", "--force-remove", "--"] <> map T.pack (Map.keys links))     when (removed == Nothing) (ioError (userError "could not adopt tracked links in Git's index"))   pure $ first (\err -> TransactionApplyFailed (exceptionText err) Nothing) result@@ -293,31 +307,46 @@     | not (Set.null unresolved) -> pure (Left (TransactionUnresolvedPaths unresolved))     | otherwise -> verifyObservedFiles transaction plan   where-    unjournaled = Map.keysSet (plan ^. #files) Set.\\ (transaction ^. #targets)+    unjournaled = reconciliationMutationPaths plan Set.\\ (transaction ^. #targets)     unresolved = unresolvedPaths plan  verifyObservedFiles :: UpdateTransaction -> ReconciliationPlan -> IO (Either TransactionError ()) verifyObservedFiles transaction plan = go (Map.toAscList (plan ^. #files))   where     go [] = pure (Right ())+    go ((_, FileSeedSettle {}) : rest) = go rest+    go ((_, FileSeedRelease {}) : rest) = go rest+    go ((_, FileSeedAbandon {}) : rest) = go rest+    go ((path, FileSeedCreate _ _) : rest) = do+      entry <- runEff $ runFilesystem $ inspectPath (transaction ^. #projectRoot </> path)+      if entry == EntryMissing+        then go rest+        else do+          clearPendingSeed transaction path+          pure (Left (TransactionApplyFailed ("seed path became occupied after preview: " <> T.pack path <> "; rerun update to review it") Nothing))     go ((path, reconciliation) : rest) = do       current <- observeDiskFile (transaction ^. #projectRoot </> path)       let planned = reconciliationObservation reconciliation-      if current == planned-        then go rest-        else pure (Left (TransactionStalePlan path planned current))+      case planned of+        Nothing -> go rest+        Just expected | current == expected -> go rest+        Just expected -> pure (Left (TransactionStalePlan path expected current)) -reconciliationObservation :: FileReconciliation -> ObservedFile+reconciliationObservation :: FileReconciliation -> Maybe ObservedFile reconciliationObservation reconciliation = case reconciliation of-  FileCreate _ _ observed -> observed-  FileUpdate _ _ observed _ -> observed-  FileAutoMerge _ _ observed _ -> observed-  FileUnchanged _ _ observed _ -> observed-  FileConflict _ _ _ _ observed _ _ -> observed-  FileDeleteSafe _ _ observed -> observed-  FileOrphanEdited _ _ _ observed _ -> observed-  FileReleaseSharedOwnership _ _ observed -> observed-  FileAlreadyAbsent _ _ observed -> observed+  FileSeedCreate {} -> Nothing+  FileSeedSettle {} -> Nothing+  FileSeedRelease {} -> Nothing+  FileSeedAbandon {} -> Nothing+  FileCreate _ _ observed -> Just observed+  FileUpdate _ _ observed _ -> Just observed+  FileAutoMerge _ _ observed _ -> Just observed+  FileUnchanged _ _ observed _ -> Just observed+  FileConflict _ _ _ _ observed _ _ -> Just observed+  FileDeleteSafe _ _ observed -> Just observed+  FileOrphanEdited _ _ _ observed _ -> Just observed+  FileReleaseSharedOwnership _ _ observed -> Just observed+  FileAlreadyAbsent _ _ observed -> Just observed  observeDiskFile :: FilePath -> IO ObservedFile observeDiskFile path = do@@ -339,7 +368,11 @@ prepareCandidateManifest :: UpdateTransaction -> ReconciliationPlan -> Manifest -> IO Manifest prepareCandidateManifest transaction plan manifest = do   nextFiles <- foldM applyManifestAction (manifest ^. #files) (Map.toAscList (plan ^. #files))-  pure (replaceManifestFiles manifest nextFiles)+  let withFiles = replaceManifestFiles manifest nextFiles+      candidates = seedCandidateReceipts (manifest ^. #genAt) manifest plan+  case replaceSelectedSeedClaims (plan ^. #applicationIds) candidates withFiles of+    Left err -> ioError (userError (T.unpack (renderSeedOwnershipError err)))+    Right candidate -> pure candidate   where     selected = plan ^. #applicationIds     applyManifestAction files (path, reconciliation) = case desiredState reconciliation of@@ -390,6 +423,7 @@   Map FilePath FileRecord ->   Map FilePath FileRecord applyOrphanManifestAction selected reconciliation files = case reconciliation of+  FileSeedRelease action _ -> Map.delete (action ^. #path) files   FileDeleteSafe path _ _ -> Map.delete path files   FileAlreadyAbsent path _ _ -> Map.delete path files   FileReleaseSharedOwnership path record _ ->@@ -467,6 +501,7 @@         sortOn pathDepth . Set.toList $           Set.fromList (metadata ^. #newDirectories <> additionalDirectories),       indexLinks = metadata ^. #indexLinks,+      seedCreations = metadata ^. #seedCreations,       expectedManifest = Just candidate     } @@ -479,6 +514,19 @@   where     applyOne count (path, reconciliation) = case mutationFor reconciliation of       NoMutation -> pure count+      CreateSeedMutation content -> do+        let fullPath = transaction ^. #projectRoot </> path+        verifySafeParents (transaction ^. #projectRoot) path+        markPendingSeed transaction path+        (result, identity) <- createFileExclusiveAnchored (Just (transaction ^. #transactionDirectory </> ("seed-" <> T.unpack (hashContent (T.pack path) ^. #unSHA256)))) (\handle -> BS.hPut handle (TE.encodeUtf8 content)) fullPath+        case (result, identity) of+          (ExclusiveCreated, Just (device, inode)) -> recordCreatedSeed transaction path (hashContent content, device, inode)+          (ExclusiveOccupied, _) -> clearPendingSeed transaction path >> ioError (userError ("seed path became occupied after preview: " <> path <> "; rerun update"))+          (ExclusiveFailure reason, _) -> clearPendingSeed transaction path >> ioError (userError (T.unpack reason))+          _ -> ioError (userError "exclusive creation returned no ownership evidence")+        let next = count + 1+        afterMutation next+        pure next       WriteMutation content -> do         atomicWriteText (transaction ^. #projectRoot </> path) content         let next = count + 1@@ -492,9 +540,10 @@         afterMutation next         pure next -data FileMutation = NoMutation | WriteMutation Text | DeleteMutation+data FileMutation = NoMutation | WriteMutation Text | CreateSeedMutation Text | DeleteMutation  mutationFor :: FileReconciliation -> FileMutation+mutationFor (FileSeedCreate action _) = maybe NoMutation CreateSeedMutation (action ^. #newContent) mutationFor reconciliation = case desiredState reconciliation of   Just (_, state)     | state ^. #writeToDisk -> WriteMutation (state ^. #appliedContent)@@ -519,6 +568,23 @@           unless             (Just current == (EntrySymlink <$> entry ^. #linkTarget))             (ioError (userError ("adopted working link changed during recovery: " <> entry ^. #targetPath)))+        -- Only transaction-owned creations may be removed. A crash before+        -- completion evidence leaves uncertainty explicit and preserves bytes.+        forM_ (Map.toAscList (metadata ^. #seedCreations)) $ \(path, expected) -> do+          verifySafeParents (transaction ^. #projectRoot) path+          let fullPath = transaction ^. #projectRoot </> path+          entry <- runEff $ runFilesystem $ inspectPath fullPath+          case (entry, expected) of+            (EntryMissing, _) -> pure ()+            (EntryFile, Just (digest, device, inode)) -> do+              status <- Posix.getSymbolicLinkStatus fullPath+              let changed = ioError (userError ("created seed changed during recovery: " <> path <> "; preserve it outside the destination and retry update --dry-run"))+              if fromIntegral (Posix.deviceID status) /= device || fromIntegral (Posix.fileID status) /= inode+                then changed+                else do+                  content <- TIO.readFile fullPath+                  if hashContent content == digest then Directory.removeFile fullPath else changed+            _ -> ioError (userError ("seed creation outcome is uncertain: " <> path <> "; preserve the object outside the destination and retry update --dry-run"))         restoreIndexLinks (transaction ^. #projectRoot) (metadata ^. #indexLinks)         forM_ (filter (\entry -> Map.notMember (entry ^. #targetPath) (metadata ^. #indexLinks)) (metadata ^. #entries)) (restoreEntry transaction)         removeNewDirectories (transaction ^. #projectRoot) (metadata ^. #newDirectories)@@ -595,6 +661,7 @@                 entries = metadata ^. #entries,                 newDirectories = metadata ^. #newDirectories,                 indexLinks = metadata ^. #indexLinks,+                seedCreations = metadata ^. #seedCreations,                 expectedManifest = Just expected               }       result <- try @SomeException (writeJournal (transaction ^. #transactionDirectory) updated)@@ -672,6 +739,8 @@  validateJournal :: JournalMetadata -> Either Text JournalMetadata validateJournal metadata = do+  unless (Set.null (Map.keysSet (metadata ^. #seedCreations) `Set.intersection` Set.fromList (map (^. #targetPath) (metadata ^. #entries)))) (Left "seed creations must not also have restoring snapshots")+  traverse_ (first renderTransactionPathError . validateTransactionPath) (Map.keys (metadata ^. #seedCreations))   traverse_ (first renderTransactionPathError . validateTransactionPath) (Map.keys (metadata ^. #indexLinks))   traverse_ validateObjectId (Map.elems (metadata ^. #indexLinks))   unless@@ -773,3 +842,20 @@  exceptionText :: SomeException -> Text exceptionText = T.pack . displayException++-- Completion evidence is temporary recovery state, never a seed receipt hash.+recordCreatedSeed :: UpdateTransaction -> FilePath -> (SHA256, Integer, Integer) -> IO ()+recordCreatedSeed transaction path digest = do+  metadata <- readJournal (transaction ^. #transactionDirectory) >>= either (ioError . userError . show) pure+  writeJournal (transaction ^. #transactionDirectory) (metadata & #journalVersion %~ max 4 & #seedCreations %~ Map.insert path (Just digest))++-- Explicitly failed exclusive publication owns no object at this path.+clearPendingSeed :: UpdateTransaction -> FilePath -> IO ()+clearPendingSeed transaction path = do+  metadata <- readJournal (transaction ^. #transactionDirectory) >>= either (ioError . userError . show) pure+  writeJournal (transaction ^. #transactionDirectory) (metadata & #seedCreations %~ Map.delete path)++markPendingSeed :: UpdateTransaction -> FilePath -> IO ()+markPendingSeed transaction path = do+  metadata <- readJournal (transaction ^. #transactionDirectory) >>= either (ioError . userError . show) pure+  writeJournal (transaction ^. #transactionDirectory) (metadata & #journalVersion %~ max 4 & #seedCreations %~ Map.insert path Nothing)

@@ -0,0 +1,60 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++-- | Native complete-file publication with no replacement. Kept independent of+-- the effect stack so the same implementation can be checked on each host OS.+module Seihou.Filesystem.Exclusive+  ( ExclusiveCreateResult (..),+    createFileExclusiveWith,+    createFileExclusiveWithIdentity,+    createFileExclusiveAnchored,+  )+where++import Control.Exception (IOException, bracket, catch, try)+import Data.Text (Text)+import Data.Text qualified as T+import GHC.Generics (Generic)+import System.Directory (removeFile)+import System.FilePath (takeDirectory)+import System.IO (Handle, hClose, openBinaryTempFile)+import System.IO.Error (isAlreadyExistsError)+import System.Posix.Files qualified as Posix++data ExclusiveCreateResult = ExclusiveCreated | ExclusiveOccupied | ExclusiveFailure Text+  deriving stock (Eq, Show, Generic)++-- | The callback writes only to a private temporary file on the same filesystem.+-- link(2) publishes all bytes at once and fails for every existing entry, including+-- dangling symlinks. Cleanup never removes the public destination.+createFileExclusiveWith :: (Handle -> IO ()) -> FilePath -> IO ExclusiveCreateResult+createFileExclusiveWith writeContent path = fst <$> createFileExclusiveWithIdentity writeContent path++-- | Device/inode evidence comes from the private object, never a later lookup+-- of the public path, so recovery can distinguish an identical replacement.+createFileExclusiveWithIdentity :: (Handle -> IO ()) -> FilePath -> IO (ExclusiveCreateResult, Maybe (Integer, Integer))+createFileExclusiveWithIdentity = createFileExclusiveAnchored Nothing++-- | A transaction may retain a private hard-link anchor until commit/recovery.+-- Keeping the original inode alive prevents inode reuse from making an identical+-- replacement look like this transaction's object.+createFileExclusiveAnchored :: Maybe FilePath -> (Handle -> IO ()) -> FilePath -> IO (ExclusiveCreateResult, Maybe (Integer, Integer))+createFileExclusiveAnchored anchor writeContent path = do+  result <-+    try @IOException $+      bracket+        (openBinaryTempFile (takeDirectory path) ".seihou-seed")+        (\(temporary, handle) -> hClose handle >> (removeFile temporary `catch` \(_ :: IOException) -> pure ()))+        ( \(temporary, handle) -> do+            writeContent handle+            hClose handle+            status <- Posix.getFileStatus temporary+            maybe (pure ()) (Posix.createLink temporary) anchor+            Posix.createLink temporary path+            pure (fromIntegral (Posix.deviceID status), fromIntegral (Posix.fileID status))+        )+  pure $ case result of+    Right identity -> (ExclusiveCreated, Just identity)+    Left err | isAlreadyExistsError err -> (ExclusiveOccupied, Nothing)+    Left err -> (ExclusiveFailure (T.pack (show err)), Nothing)

@@ -16,7 +16,7 @@   ) where -import Control.Monad (unless)+import Control.Monad (forM_, unless, when) import Data.Aeson (FromJSON (..), ToJSON (..), (.:), (.=)) import Data.Aeson qualified as Aeson import Data.Aeson.Key qualified as Key@@ -29,9 +29,12 @@ 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.ArtifactIdentity (sameArtifactIdentity) import Seihou.Core.Checkout (CheckoutError (..), validateCheckoutRecords)-import Seihou.Core.Seed (ManifestInvariantError (..), validateManifestInvariants)+import Seihou.Core.CommandFingerprint (checkoutCommandOperation, fingerprintCommand)+import Seihou.Core.Path (validateCanonicalProjectPath)+import Seihou.Core.Seed (renderManifestInvariantError, seedApplicationIds, validateManifestInvariants) import Seihou.Core.Types import Seihou.Manifest.Hash (baselineRefFromText) import Seihou.Manifest.JSON (decodeManifestValue)@@ -77,7 +80,7 @@ -- change advances this number is -- docs/adr/0014-every-semantic-manifest-change-advances-the-schema-version.md. currentManifestVersion :: ManifestSchemaVersion-currentManifestVersion = ManifestSchemaVersion 9+currentManifestVersion = ManifestSchemaVersion 11  -- | The oldest schema the ordinary decoder reads. Anything older records -- machine-specific absolute paths and must go through the explicit@@ -91,7 +94,9 @@ minimumManifestVersion :: ManifestCapability -> ManifestSchemaVersion minimumManifestVersion TargetedAdditiveSharedPathUpdate = ManifestSchemaVersion 7 minimumManifestVersion SeedReceipts = ManifestSchemaVersion 8+minimumManifestVersion SeedOwnerClaims = ManifestSchemaVersion 11 minimumManifestVersion CheckoutLocalOutputs = ManifestSchemaVersion 9+minimumManifestVersion CheckoutLocalCommands = ManifestSchemaVersion 10  -- | Whether a manifest's schema can express everything a capability needs. -- A decoded schema-6 manifest answers 'False' for@@ -215,11 +220,11 @@         "modules" .= (m ^. #modules),         "variables" .= varsToJSON (m ^. #vars),         "files" .= filesToJSON (m ^. #version) (m ^. #files),-        "applications" .= (m ^. #applications),+        "applications" .= map (applicationToJSON (m ^. #version)) (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]+        ++ ["seeds" .= Map.map (seedToJSON (m ^. #version)) (m ^. #seeds) | m ^. #version >= ManifestSchemaVersion 8]         ++ maybe [] (\r -> ["recipe" .= r]) (m ^. #recipe)         ++ maybe [] (\b -> ["blueprint" .= b]) (m ^. #blueprint) @@ -236,17 +241,17 @@         <*> 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 8 then Map.traverseWithKey (\_ -> parseSeed v) =<< 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..:? "applications" Aeson..!= [] >>= mapM (parseApplication v))         <*> 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")+      Left err -> fail (T.unpack (renderManifestInvariantError err))       Right () -> case validateCheckoutRecords manifest [] of         Left err -> fail (T.unpack (err ^. #message))-        Right () -> pure manifest+        Right () -> validateCheckoutCommands manifest >> pure manifest  -- | Reject a manifest this build cannot read, naming the remedy. --@@ -376,38 +381,53 @@       <*> (varsFromJSON =<< o Aeson..:? "resolvedVars" Aeson..!= Aeson.object [])  instance ToJSON AppliedComposition where-  toJSON composition =-    Aeson.object $-      [ "applicationId" .= (composition ^. #applicationId . #unApplicationId),-        "target" .= (composition ^. #target),-        "targetOrigin" .= (composition ^. #targetOrigin),-        "additionalModules" .= map (^. #unModuleName) (composition ^. #additionalModules),-        "instances" .= (composition ^. #instances),-        "appliedAt" .= (composition ^. #appliedAt)-      ]-        ++ maybe [] (\v -> ["targetVersion" .= v]) (composition ^. #targetVersion)-        ++ maybe [] (\v -> ["namespace" .= v]) (composition ^. #namespace)-        ++ maybe [] (\v -> ["context" .= v]) (composition ^. #context)-        ++ commandReceiptsField (composition ^. #commandReceipts)-    where-      commandReceiptsField receipts-        | Map.null receipts = []-        | otherwise = ["commandReceipts" .= commandReceiptsToJSON receipts]+  toJSON = applicationToJSON currentManifestVersion +applicationToJSON :: ManifestSchemaVersion -> AppliedComposition -> Aeson.Value+applicationToJSON schema composition =+  Aeson.object $+    [ "applicationId" .= (composition ^. #applicationId . #unApplicationId),+      "target" .= (composition ^. #target),+      "targetOrigin" .= (composition ^. #targetOrigin),+      "additionalModules" .= map (^. #unModuleName) (composition ^. #additionalModules),+      "instances" .= (composition ^. #instances),+      "appliedAt" .= (composition ^. #appliedAt)+    ]+      ++ maybe [] (\v -> ["targetVersion" .= v]) (composition ^. #targetVersion)+      ++ maybe [] (\v -> ["namespace" .= v]) (composition ^. #namespace)+      ++ maybe [] (\v -> ["context" .= v]) (composition ^. #context)+      ++ ["checkoutCommands" .= map checkoutCommandToJSON (composition ^. #checkoutCommands) | schema >= ManifestSchemaVersion 10]+      ++ commandReceiptsField (composition ^. #commandReceipts)+  where+    commandReceiptsField receipts+      | Map.null receipts = []+      | otherwise = ["commandReceipts" .= commandReceiptsToJSON receipts]+ instance FromJSON AppliedComposition where-  parseJSON = Aeson.withObject "AppliedComposition" $ \o ->-    AppliedComposition-      <$> (ApplicationId <$> o .: "applicationId")-      <*> o .: "target"-      <*> o .: "targetOrigin"-      <*> o Aeson..:? "targetVersion"-      <*> (map ModuleName <$> o Aeson..:? "additionalModules" Aeson..!= [])-      <*> o Aeson..:? "namespace"-      <*> o Aeson..:? "context"-      <*> o Aeson..:? "instances" Aeson..!= []-      <*> (commandReceiptsFromJSON =<< o Aeson..:? "commandReceipts" Aeson..!= Aeson.object [])-      <*> o .: "appliedAt"+  parseJSON = parseApplication currentManifestVersion +parseApplication :: ManifestSchemaVersion -> Aeson.Value -> Aeson.Parser AppliedComposition+parseApplication schema = Aeson.withObject "AppliedComposition" $ \o -> do+  commands <-+    if schema >= ManifestSchemaVersion 10+      then o .: "checkoutCommands" >>= mapM parseCheckoutCommand+      else do+        legacy <- o Aeson..:? "checkoutCommands" Aeson..!= ([] :: [Aeson.Value])+        unless (null legacy) (fail "checkout commands require manifest schema 10")+        pure []+  AppliedComposition+    <$> (ApplicationId <$> o .: "applicationId")+    <*> o .: "target"+    <*> o .: "targetOrigin"+    <*> o Aeson..:? "targetVersion"+    <*> (map ModuleName <$> o Aeson..:? "additionalModules" Aeson..!= [])+    <*> o Aeson..:? "namespace"+    <*> o Aeson..:? "context"+    <*> o Aeson..:? "instances" Aeson..!= []+    <*> (commandReceiptsFromJSON =<< o Aeson..:? "commandReceipts" Aeson..!= Aeson.object [])+    <*> pure commands+    <*> o .: "appliedAt"+ instance ToJSON CommandReceipt where   toJSON receipt =     Aeson.object $@@ -618,11 +638,13 @@ parseRemovalActionText other = fail ("unknown removal action: " <> T.unpack other)  parseRemovalCommandJSON :: Aeson.Value -> Aeson.Parser Command-parseRemovalCommandJSON = Aeson.withObject "RemovalCommand" $ \o ->+parseRemovalCommandJSON = Aeson.withObject "RemovalCommand" $ \o -> do+  unless (all (`elem` ["run", "workDir"]) (KM.keys o)) (fail "removal commands only support application execution")   Command     <$> o .: "run"     <*> o Aeson..:? "workDir"     <*> pure Nothing+    <*> pure ApplicationCommand  -- | Encode a file record in the representation of the given schema. --@@ -759,22 +781,38 @@ 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+seedToJSON :: ManifestSchemaVersion -> SeedRecord -> Aeson.Value+seedToJSON version record =+  Aeson.object $     [ "module" .= (record ^. #moduleName . #unModuleName),-      "applications" .= map (^. #unApplicationId) (Set.toAscList (record ^. #applicationIds)),       "outcome" .= seedOutcomeToText (record ^. #outcome),       "settledAt" .= (record ^. #settledAt)     ]+      <> if version < minimumManifestVersion SeedOwnerClaims+        then ["applications" .= map (^. #unApplicationId) (Set.toAscList (seedApplicationIds record))]+        else+          [ "ownership" .= case record ^. #ownership of+              LegacySeedOwners apps ->+                Aeson.object+                  ["kind" .= ("legacy-applications" :: Text), "applications" .= map (^. #unApplicationId) (Set.toAscList apps)]+              KnownSeedOwners owners ->+                Aeson.object+                  ["kind" .= ("instances" :: Text), "owners" .= Map.mapKeys (^. #unApplicationId) (Map.map (map (^. #unModuleName) . Set.toAscList) owners)]+          ]  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+parseSeed :: ManifestSchemaVersion -> Aeson.Value -> Aeson.Parser SeedRecord+parseSeed version = Aeson.withObject "seed receipt" $ \o -> do+  ownership <-+    if version < minimumManifestVersion SeedOwnerClaims+      then LegacySeedOwners . Set.fromList . map ApplicationId <$> o .: "applications"+      else do+        when (KM.member "applications" o) (fail "seed receipt must not duplicate ownership with applications")+        o .: "ownership" >>= parseSeedOwnership   outcome <-     o .: "outcome" >>= \case       "created" -> pure SeedCreated@@ -783,14 +821,33 @@       (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 ownership     <*> pure outcome     <*> o .: "settledAt" +parseSeedOwnership :: Aeson.Value -> Aeson.Parser SeedOwnership+parseSeedOwnership = Aeson.withObject "seed ownership" $ \o -> do+  kind <- o .: "kind" :: Aeson.Parser Text+  case kind of+    "legacy-applications" -> do+      unless (Set.fromList (KM.keys o) == Set.fromList ["kind", "applications"]) (fail "legacy seed ownership requires exactly kind and applications")+      LegacySeedOwners . Set.fromList . map ApplicationId <$> o .: "applications"+    "instances" -> do+      unless (Set.fromList (KM.keys o) == Set.fromList ["kind", "owners"]) (fail "seed instance ownership requires exactly kind and owners")+      raw <- o .: "owners" :: Aeson.Parser (Map Text [Text])+      forM_ (Map.elems raw) $ \names -> unless (length names == Set.size (Set.fromList names)) (fail "duplicate seed instance owner")+      pure (KnownSeedOwners (Map.mapKeys ApplicationId (Map.map (Set.fromList . map ModuleName) raw)))+    other -> fail ("unknown seed ownership kind: " <> T.unpack other)+ -- | 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))]+  either (pure . renderManifestInvariantError) (const []) (validateManifestInvariants manifest)+    <> ["seed owner claims require manifest schema 11" | not (manifestSupports SeedOwnerClaims manifest), any (\r -> case r ^. #ownership of KnownSeedOwners _ -> True; _ -> False) (Map.elems (manifest ^. #seeds))]+    <> either (pure . T.pack) (const []) (Aeson.parseEither (const (validateCheckoutCommands manifest)) Aeson.Null)+    <> ["removal commands cannot declare checkout setup" | applied <- manifest ^. #modules, removal <- maybe [] pure (applied ^. #removal), any ((== CheckoutCommandLifecycle) . (^. #lifecycle)) (removal ^. #commands)]+    <> ["checkout commands require manifest schema 10" | manifest ^. #version < ManifestSchemaVersion 10, any (not . null . (^. #checkoutCommands)) (manifest ^. #applications)]+    <> ["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@@ -816,3 +873,30 @@         )   owners <- o .: "owners" :: Aeson.Parser (Map Text [Text])   pure (CheckoutOutputRecord spec (Map.mapKeys ApplicationId (Map.map (Set.fromList . map ModuleName) owners)))++checkoutCommandToJSON :: CheckoutCommand -> Aeson.Value+checkoutCommandToJSON CheckoutCommand {moduleName, occurrence, command, workDir} =+  Aeson.object ["kind" .= ("shell" :: Text), "module" .= (moduleName ^. #unModuleName), "occurrence" .= occurrence, "command" .= command, "workDir" .= workDir]++parseCheckoutCommand :: Aeson.Value -> Aeson.Parser CheckoutCommand+parseCheckoutCommand = Aeson.withObject "checkout command" $ \o -> do+  unless (Set.fromList (KM.keys o) == Set.fromList ["kind", "module", "occurrence", "command", "workDir"]) (fail "checkout command requires exactly kind, module, occurrence, command and workDir")+  kind <- o .: "kind" :: Aeson.Parser Text+  unless (kind == "shell") (fail ("unknown checkout command kind: " <> T.unpack kind))+  CheckoutCommand <$> (ModuleName <$> o .: "module") <*> o .: "occurrence" <*> o .: "command" <*> o .: "workDir"++validateCheckoutCommands :: Manifest -> Aeson.Parser ()+validateCheckoutCommands manifest = do+  let applications = manifest ^. #applications+      ids = map (^. #applicationId) applications+  unless (length ids == Set.size (Set.fromList ids)) (fail "duplicate application IDs")+  forM_ applications $ \application -> do+    let commands = application ^. #checkoutCommands+        identities = map (fingerprintCommand . checkoutCommandOperation) commands+        owners = Set.fromList [qualifiedName (ModuleInstance (i ^. #name) (i ^. #parentVars)) | i <- application ^. #instances]+    unless (length identities == Set.size (Set.fromList identities)) (fail "duplicate checkout command identity")+    forM_ commands $ \command -> do+      unless (Set.member (command ^. #moduleName) owners) (fail "unknown checkout command instance owner")+      unless (command ^. #occurrence >= 0 && not (T.null (T.strip (command ^. #command)))) (fail "invalid checkout command occurrence or empty shell text")+      forM_ (command ^. #workDir) $ \path ->+        unless (path == ".") $ either (fail . T.unpack) pure (validateCanonicalProjectPath (T.pack path))

@@ -33,7 +33,7 @@   ) where -import Control.Monad (foldM, unless)+import Control.Monad (foldM, forM, unless, when) import Data.Aeson qualified as Aeson import Data.Aeson.Key qualified as Key import Data.Aeson.KeyMap qualified as KeyMap@@ -58,6 +58,8 @@     MakeSharedWriteEvidenceExplicit   | AddEmptySeedReceipts   | AddEmptyCheckoutOutputs+  | MakeSeedOwnershipExplicit+  | AddEmptyCheckoutCommands   deriving stock (Eq, Ord, Show, Enum, Bounded, Generic)  -- | Whether a step may be staged automatically.@@ -117,7 +119,9 @@     step 5 ConvertMachineLocalPaths "portable artifact origins",     step 6 MakeSharedWriteEvidenceExplicit "explicit shared-write evidence",     step 7 AddEmptySeedReceipts "seed receipts",-    step 8 AddEmptyCheckoutOutputs "checkout outputs"+    step 8 AddEmptyCheckoutOutputs "checkout outputs",+    step 9 AddEmptyCheckoutCommands "repeatable checkout commands",+    step 10 MakeSeedOwnershipExplicit "explicit seed instance ownership"   ]   where     step from stepAction =@@ -129,6 +133,8 @@ upgradeStepKind MakeSharedWriteEvidenceExplicit = LosslessUpgrade upgradeStepKind AddEmptySeedReceipts = LosslessUpgrade upgradeStepKind AddEmptyCheckoutOutputs = LosslessUpgrade+upgradeStepKind AddEmptyCheckoutCommands = LosslessUpgrade+upgradeStepKind MakeSeedOwnershipExplicit = LosslessUpgrade  -- | The contiguous steps from @source@ to @target@. Planning from a version -- to itself is an empty path.@@ -184,6 +190,20 @@     Left (StepVersionMismatch upgradeStep actual)   transformed <- case upgradeStep ^. #action of     StampVersion -> Right document+    MakeSeedOwnershipExplicit -> first (MalformedDocument actual) (makeSeedOwnershipExplicit document)+    AddEmptyCheckoutCommands -> case document of+      Aeson.Object fields -> do+        applications <- case KeyMap.lookup "applications" fields of+          Nothing -> Right []+          Just value -> first (MalformedDocument actual . T.pack) (Aeson.fromJSON value & \case Aeson.Error err -> Left err; Aeson.Success xs -> Right (xs :: [Aeson.Value]))+        upgraded <- forM applications $ \case+          Aeson.Object app -> case KeyMap.lookup "checkoutCommands" app of+            Nothing -> Right (Aeson.Object (KeyMap.insert "checkoutCommands" (Aeson.toJSON ([] :: [Aeson.Value])) app))+            Just (Aeson.Array xs) | null xs -> Right (Aeson.Object app)+            _ -> Left (MalformedDocument actual "schema 9 cannot contain checkout commands")+          _ -> Left (MalformedDocument actual "application must be an object")+        Right (Aeson.Object (KeyMap.insert "applications" (Aeson.toJSON upgraded) fields))+      _ -> Left (MalformedDocument actual "manifest must be an object")     AddEmptyCheckoutOutputs -> case document of       Aeson.Object fields -> case KeyMap.lookup "checkoutOutputs" fields of         Nothing -> Right (Aeson.Object (KeyMap.insert "checkoutOutputs" (Aeson.object []) fields))@@ -280,3 +300,22 @@   MalformedDocument v reason -> "the schema-" <> showVersion v <> " manifest is malformed: " <> reason   where     showVersion (ManifestSchemaVersion v) = T.pack (show v)++-- | Wrap the old evidence without inventing instance claims. Unknown members+-- survive at every level; malformed old ownership cannot acquire a new stamp.+makeSeedOwnershipExplicit :: Aeson.Value -> Either Text Aeson.Value+makeSeedOwnershipExplicit (Aeson.Object fields) = case KeyMap.lookup "seeds" fields of+  Just (Aeson.Object seeds) -> do+    converted <- KeyMap.traverseWithKey convert seeds+    pure (Aeson.Object (KeyMap.insert "seeds" (Aeson.Object converted) fields))+  _ -> Left "seeds must be an object"+  where+    convert _ (Aeson.Object receipt) = do+      when (KeyMap.member "ownership" receipt) (Left "schema 10 seed cannot contain ownership")+      apps <- case KeyMap.lookup "applications" receipt of+        Just value | Aeson.Success (_ :: [Text]) <- Aeson.fromJSON value -> Right value+        _ -> Left "seed applications must be an array of application IDs"+      let ownership = Aeson.object ["kind" Aeson..= ("legacy-applications" :: Text), "applications" Aeson..= apps]+      pure (Aeson.Object (KeyMap.insert "ownership" ownership (KeyMap.delete "applications" receipt)))+    convert _ _ = Left "seed receipt must be an object"+makeSeedOwnershipExplicit _ = Left "manifest must be an object"

@@ -52,6 +52,8 @@ import Seihou.Engine.ReconcileSpec qualified as ReconcileSpec import Seihou.Engine.RemoveSpec qualified as RemoveSpec import Seihou.Engine.SectionSpec qualified as SectionSpec+import Seihou.Engine.SeedSpec qualified as SeedEngine+import Seihou.Engine.SeedTransactionSpec qualified as SeedTransaction import Seihou.Engine.TemplateSpec qualified as TemplateSpec import Seihou.Engine.ThreeWayMergeSpec qualified as ThreeWayMergeSpec import Seihou.Engine.UpdateTransactionSpec qualified as UpdateTransactionSpec@@ -140,4 +142,6 @@   manifestUpgradeTests <- ManifestUpgradeSpec.tests   promptTests <- PromptSpec.tests   confirmTests <- ConfirmSpec.tests-  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])+  seedTransactionTests <- SeedTransaction.tests+  seedEngineTests <- SeedEngine.tests+  defaultMain (testGroup "seihou-core" [seedTransactionTests, seedEngineTests, 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,8 +1,13 @@ module Seihou.Composition.PlanSpec (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 Seihou.Composition.Plan import Seihou.Core.Types+import Seihou.Prelude import Test.Hspec import Test.Tasty import Test.Tasty.Hspec (testSpec)@@ -12,18 +17,40 @@  spec :: Spec spec = do+  describe "seed composition" $ do+    it "keeps the first supplier in execution order and every qualified claimant" $ do+      let first = SeedFileOp "start.txt" "first" Copy "z[first]"+          second = SeedFileOp "start.txt" "second" Copy "a[second]"+      Right composed <- pure (mergeOperations [("z[first]", [first]), ("a[second]", [second])])+      composed ^. #operations `shouldBe` [first]+      composed ^. #managedOwners `shouldBe` Map.empty+      composed ^. #seedOwners `shouldBe` Map.singleton "start.txt" (Set.fromList ["z[first]", "a[second]"])+      composed ^. #warnings `shouldBe` [SeedContentIgnored "start.txt" "z[first]" "a[second]"]+    it "refuses mixed lifecycle and ancestor collisions in either order" $ do+      let seed = SeedFileOp "start.txt" "seed" Copy "seed"+          conflicts = [WriteFileOp "start.txt" "managed" Copy, WriteFileOp "START.TXT" "alias" Copy, PatchFileOp "start.txt" "patch" AppendFile Template "patcher", CheckoutOutputOp "start.txt" (DirectorySymlink "config") "checkout", WriteFileOp "start.txt/child" "managed" Copy, SeedFileOp "start.txt/child" "nested" Copy "other"]+      mapM_+        ( \op -> do+            mergeOperations [("seed", [seed]), ("other", [op])] `shouldSatisfy` isLeft+            mergeOperations [("other", [op]), ("seed", [seed])] `shouldSatisfy` isLeft+        )+        conflicts++    it "refuses conflicting parent spellings before creating either seed" $ do+      mergeOperations [("a", [SeedFileOp "Sources/a" "a" Copy "a"]), ("b", [SeedFileOp "sources/b" "b" Copy "b"])] `shouldSatisfy` isLeft+   describe "mergeOperations" $ do     it "preserves all operations when no files overlap" $ do       let aOps = [CreateDirOp "src", WriteFileOp "src/A.hs" "module A" Template]           bOps = [CreateDirOp "lib", WriteFileOp "lib/B.hs" "module B" Template]-          (ops, warnings, _) = mergeOperations [("mod-a", aOps), ("mod-b", bOps)]+          Right ComposedPlan {operations = ops, warnings} = mergeOperations [("mod-a", aOps), ("mod-b", bOps)]       length ops `shouldBe` 4       warnings `shouldBe` []      it "last-writer-wins when two modules write same file" $ do       let aOps = [WriteFileOp "README.md" "from A" Template]           bOps = [WriteFileOp "README.md" "from B" Template]-          (ops, warnings, _) = mergeOperations [("mod-a", aOps), ("mod-b", bOps)]+          Right ComposedPlan {operations = ops, warnings} = mergeOperations [("mod-a", aOps), ("mod-b", bOps)]       -- Only B's version should remain       length (filter isWriteOp ops) `shouldBe` 1       case filter isWriteOp ops of@@ -41,21 +68,21 @@     it "deduplicates CreateDirOp silently" $ do       let aOps = [CreateDirOp "src"]           bOps = [CreateDirOp "src"]-          (ops, warnings, _) = mergeOperations [("mod-a", aOps), ("mod-b", bOps)]+          Right ComposedPlan {operations = ops, warnings} = mergeOperations [("mod-a", aOps), ("mod-b", bOps)]       length ops `shouldBe` 1       warnings `shouldBe` []      it "keeps all RunCommandOp operations" $ do-      let aOps = [RunCommandOp "echo hello" Nothing "module-a" 0]-          bOps = [RunCommandOp "echo world" Nothing "module-b" 0]-          (ops, warnings, _) = mergeOperations [("mod-a", aOps), ("mod-b", bOps)]+      let aOps = [RunCommandOp "echo hello" Nothing "module-a" 0 ApplicationCommand]+          bOps = [RunCommandOp "echo world" Nothing "module-b" 0 ApplicationCommand]+          Right ComposedPlan {operations = ops, warnings} = mergeOperations [("mod-a", aOps), ("mod-b", bOps)]       length ops `shouldBe` 2       warnings `shouldBe` []      it "handles CopyFileOp overlapping with WriteFileOp" $ do       let aOps = [WriteFileOp "config.yaml" "generated" Template]           bOps = [CopyFileOp "files/config.yaml" "config.yaml"]-          (ops, warnings, _) = mergeOperations [("mod-a", aOps), ("mod-b", bOps)]+          Right ComposedPlan {operations = ops, warnings} = mergeOperations [("mod-a", aOps), ("mod-b", bOps)]       length warnings `shouldBe` 1       -- B's CopyFileOp should be the winner       case filter (\op -> destOfOp' op == Just "config.yaml") ops of@@ -66,7 +93,7 @@       let aOps = [WriteFileOp "README.md" "from A" Template]           bOps = [WriteFileOp "README.md" "from B" Template]           cOps = [WriteFileOp "README.md" "from C" Template]-          (ops, warnings, _) = mergeOperations [("a", aOps), ("b", bOps), ("c", cOps)]+          Right ComposedPlan {operations = ops, warnings} = mergeOperations [("a", aOps), ("b", bOps), ("c", cOps)]       -- Only C's version should remain       case filter isWriteOp ops of         [WriteFileOp _ content _] -> content `shouldBe` "from C"@@ -75,7 +102,7 @@       length warnings `shouldBe` 2      it "handles empty module operations" $ do-      let (ops, warnings, _) = mergeOperations [("a", []), ("b", [])]+      let Right ComposedPlan {operations = ops, warnings} = mergeOperations [("a", []), ("b", [])]       ops `shouldBe` []       warnings `shouldBe` [] @@ -83,7 +110,7 @@     it "PatchFileOp AppendFile merges with existing WriteFileOp" $ do       let aOps = [WriteFileOp "README.md" "# Title\n" Template]           bOps = [PatchFileOp "README.md" "extra line\n" AppendFile Template "mod-b"]-          (ops, warnings, _) = mergeOperations [("mod-a", aOps), ("mod-b", bOps)]+          Right ComposedPlan {operations = ops, warnings} = mergeOperations [("mod-a", aOps), ("mod-b", bOps)]       -- Should be a single merged WriteFileOp       case filter isWriteOp ops of         [WriteFileOp _ content _] -> do@@ -101,7 +128,7 @@     it "PatchFileOp AppendSection adds section markers and merges" $ do       let aOps = [WriteFileOp "README.md" "# Title\n" Template]           bOps = [PatchFileOp "README.md" "section content\n" AppendSection Template "mod-b"]-          (ops, _, _) = mergeOperations [("mod-a", aOps), ("mod-b", bOps)]+          Right ComposedPlan {operations = ops} = mergeOperations [("mod-a", aOps), ("mod-b", bOps)]       case filter isWriteOp ops of         [WriteFileOp _ content _] -> do           T.isInfixOf "# Title" content `shouldBe` True@@ -112,7 +139,7 @@     it "PatchFileOp PrependFile prepends content" $ do       let aOps = [WriteFileOp "README.md" "# Title\n" Template]           bOps = [PatchFileOp "README.md" "header\n" PrependFile Template "mod-b"]-          (ops, _, _) = mergeOperations [("mod-a", aOps), ("mod-b", bOps)]+          Right ComposedPlan {operations = ops} = mergeOperations [("mod-a", aOps), ("mod-b", bOps)]       case filter isWriteOp ops of         [WriteFileOp _ content _] -> do           -- header should appear before Title@@ -123,7 +150,7 @@      it "PatchFileOp targeting nonexistent file is preserved as PatchFileOp" $ do       let bOps = [PatchFileOp "new.txt" "content\n" AppendFile Template "mod-b"]-          (ops, _, _) = mergeOperations [("mod-b", bOps)]+          Right ComposedPlan {operations = ops} = mergeOperations [("mod-b", bOps)]       -- PatchFileOp with no existing target is preserved so the execution       -- engine can merge with the on-disk file and the diff engine avoids       -- false conflict classification.@@ -133,7 +160,7 @@       let aOps = [WriteFileOp "README.md" "# Title\n" Template]           bOps = [PatchFileOp "README.md" "from B\n" AppendSection Template "mod-b"]           cOps = [PatchFileOp "README.md" "from C\n" AppendSection Template "mod-c"]-          (ops, warnings, _) = mergeOperations [("mod-a", aOps), ("mod-b", bOps), ("mod-c", cOps)]+          Right ComposedPlan {operations = ops, warnings} = mergeOperations [("mod-a", aOps), ("mod-b", bOps), ("mod-c", cOps)]       case filter isWriteOp ops of         [WriteFileOp _ content _] -> do           T.isInfixOf "# Title" content `shouldBe` True@@ -148,14 +175,14 @@     it "ContentMerged warning is generated for patch merge" $ do       let aOps = [WriteFileOp "f.txt" "base\n" Template]           bOps = [PatchFileOp "f.txt" "added\n" AppendFile Template "mod-b"]-          (_, warnings, _) = mergeOperations [("mod-a", aOps), ("mod-b", bOps)]+          Right ComposedPlan {warnings} = mergeOperations [("mod-a", aOps), ("mod-b", bOps)]       any isContentMerged warnings `shouldBe` True       any isFileOverwritten warnings `shouldBe` False      it "PatchFileOp AppendLineIfAbsent deduplicates lines during merge" $ do       let aOps = [WriteFileOp ".gitignore" "node_modules/\n.env\n" Template]           bOps = [PatchFileOp ".gitignore" ".env\n.claude/\n" AppendLineIfAbsent Template "mod-b"]-          (ops, warnings, _) = mergeOperations [("mod-a", aOps), ("mod-b", bOps)]+          Right ComposedPlan {operations = ops, warnings} = mergeOperations [("mod-a", aOps), ("mod-b", bOps)]       case filter isWriteOp ops of         [WriteFileOp _ content _] -> do           content `shouldBe` "node_modules/\n.env\n.claude/\n"@@ -166,7 +193,7 @@     it "two Structured WriteFileOps for same JSON dest get deep-merged" $ do       let aOps = [WriteFileOp "config.json" "{\"name\": \"foo\"}\n" Structured]           bOps = [WriteFileOp "config.json" "{\"extra\": true}\n" Structured]-          (ops, warnings, _) = mergeOperations [("mod-a", aOps), ("mod-b", bOps)]+          Right ComposedPlan {operations = ops, warnings} = mergeOperations [("mod-a", aOps), ("mod-b", bOps)]       case filter isWriteOp ops of         [WriteFileOp _ content _] -> do           T.isInfixOf "name" content `shouldBe` True@@ -179,7 +206,7 @@     it "disjoint JSON keys are combined" $ do       let aOps = [WriteFileOp "out.json" "{\"a\": 1}\n" Structured]           bOps = [WriteFileOp "out.json" "{\"b\": 2}\n" Structured]-          (ops, _, _) = mergeOperations [("mod-a", aOps), ("mod-b", bOps)]+          Right ComposedPlan {operations = ops} = mergeOperations [("mod-a", aOps), ("mod-b", bOps)]       case filter isWriteOp ops of         [WriteFileOp _ content _] -> do           T.isInfixOf "\"a\"" content `shouldBe` True@@ -189,7 +216,7 @@     it "overlapping scalar keys use right-biased merge" $ do       let aOps = [WriteFileOp "out.json" "{\"x\": 1}\n" Structured]           bOps = [WriteFileOp "out.json" "{\"x\": 2}\n" Structured]-          (ops, _, _) = mergeOperations [("mod-a", aOps), ("mod-b", bOps)]+          Right ComposedPlan {operations = ops} = mergeOperations [("mod-a", aOps), ("mod-b", bOps)]       case filter isWriteOp ops of         [WriteFileOp _ content _] ->           -- Right-biased: B's value wins@@ -199,7 +226,7 @@     it "nested objects are merged recursively" $ do       let aOps = [WriteFileOp "out.json" "{\"obj\": {\"a\": 1}}\n" Structured]           bOps = [WriteFileOp "out.json" "{\"obj\": {\"b\": 2}}\n" Structured]-          (ops, _, _) = mergeOperations [("mod-a", aOps), ("mod-b", bOps)]+          Right ComposedPlan {operations = ops} = mergeOperations [("mod-a", aOps), ("mod-b", bOps)]       case filter isWriteOp ops of         [WriteFileOp _ content _] -> do           T.isInfixOf "\"a\"" content `shouldBe` True@@ -209,14 +236,14 @@     it "non-Structured WriteFileOps still use last-writer-wins" $ do       let aOps = [WriteFileOp "README.md" "from A" Template]           bOps = [WriteFileOp "README.md" "from B" Template]-          (_, warnings, _) = mergeOperations [("mod-a", aOps), ("mod-b", bOps)]+          Right ComposedPlan {warnings} = mergeOperations [("mod-a", aOps), ("mod-b", bOps)]       any isFileOverwritten warnings `shouldBe` True       any isContentMerged warnings `shouldBe` False      it "YAML structured merge works" $ do       let aOps = [WriteFileOp "config.yaml" "name: foo\n" Structured]           bOps = [WriteFileOp "config.yaml" "extra: true\n" Structured]-          (ops, warnings, _) = mergeOperations [("mod-a", aOps), ("mod-b", bOps)]+          Right ComposedPlan {operations = ops, warnings} = mergeOperations [("mod-a", aOps), ("mod-b", bOps)]       case filter isWriteOp ops of         [WriteFileOp _ content _] -> do           T.isInfixOf "name" content `shouldBe` True

@@ -69,6 +69,7 @@       context = Nothing,       instances = [],       commandReceipts = Map.empty,+      checkoutCommands = [],       appliedAt = fixedTime     } 

@@ -3,7 +3,7 @@ import Control.Monad (forM_) import Data.Text (Text) import Data.Text qualified as T-import Seihou.Core.ArtifactIdentity (isMachineLocalOriginUrl)+import Seihou.Core.ArtifactIdentity (isMachineLocalOriginUrl, normalizeOriginUrl) import Test.Hspec import Test.Tasty import Test.Tasty.Hspec (testSpec)@@ -39,7 +39,7 @@   ]  spec :: Spec-spec =+spec = do   describe "isMachineLocalOriginUrl" $ do     forM_ machineLocal $ \url ->       it ("treats " <> T.unpack url <> " as machine-local") $@@ -47,3 +47,16 @@     forM_ remote $ \url ->       it ("treats " <> T.unpack url <> " as reachable from other machines") $         isMachineLocalOriginUrl url `shouldBe` False++  describe "normalizeOriginUrl" $ do+    it "recognizes public GitHub SSH and HTTPS transports as the same repository" $+      map+        normalizeOriginUrl+        [ "git@github.com:shinzui/seihou-modules.git",+          "ssh://git@github.com/shinzui/seihou-modules.git/",+          "https://github.com/shinzui/seihou-modules/"+        ]+        `shouldBe` replicate 3 "https://github.com/shinzui/seihou-modules"+    it "keeps different repositories and hosts distinct" $ do+      normalizeOriginUrl "git@github.com:other/seihou-modules.git" `shouldNotBe` normalizeOriginUrl "https://github.com/shinzui/seihou-modules"+      normalizeOriginUrl "git@git.example:shinzui/seihou-modules.git" `shouldNotBe` normalizeOriginUrl "https://git.example/shinzui/seihou-modules"

@@ -16,7 +16,8 @@     { command = command,       workDir = workDir,       moduleName = moduleName,-      occurrence = occurrence+      occurrence = occurrence,+      lifecycle = ApplicationCommand     }  spec :: Spec

@@ -1,5 +1,6 @@ module Seihou.Core.SeedSpec (tests) where +import Control.Monad (forM_) import Data.Either (isLeft) import Data.Generics.Labels () import Data.Map.Strict qualified as Map@@ -23,17 +24,72 @@ 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+      a = ApplicationId "a"+      b = ApplicationId "b"+      claims app names = KnownSeedOwners (Map.singleton app (Set.fromList names))+      first = SeedRecord "demo" (LegacySeedOwners (Set.singleton a)) SeedCreated now+      second = SeedRecord "demo" (LegacySeedOwners (Set.singleton b)) SeedFoundExisting now+      Right manifest = mergeSeedRecord "CHANGELOG.md" first (emptyManifest now) >>= mergeSeedRecord "CHANGELOG.md" second+      application app =+        AppliedComposition+          app+          (AppliedModuleTarget "demo")+          (LocalOrigin "demo")+          Nothing+          []+          Nothing+          Nothing+          [AppliedInstanceState name emptyParentVars (LocalOrigin (name ^. #unModuleName)) Nothing Map.empty | name <- ["demo", "second"]]+          Map.empty+          []+          now+      exact = first & #ownership .~ claims a ["demo", "second"]+      known = emptyManifest now & #applications .~ map application [a, b] & #seeds .~ Map.singleton "CHANGELOG.md" exact+  it "preserves the first settlement while merging legacy 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+    seedApplicationIds receipt `shouldBe` Set.fromList [a, b]+  it "removes the supplier without erasing a second seeder in the application" $ do+    Right one <- pure (dropSeedOwners (Map.singleton a (Set.singleton "demo")) "CHANGELOG.md" known)+    let Just receipt = Map.lookup "CHANGELOG.md" (one ^. #seeds)+    receipt ^. #ownership `shouldBe` claims a ["second"]+    receipt ^. #moduleName `shouldBe` "demo"+    Right lastGone <- pure (dropSeedOwners (Map.singleton a (Set.singleton "second")) "CHANGELOG.md" one)+    lastGone ^. #seeds `shouldBe` Map.empty+  it "unions exact claims idempotently and associatively across applications" $ do+    let receipt = second & #ownership .~ claims b ["demo"]+    Right merged <- pure (mergeSeedRecord "CHANGELOG.md" receipt known)+    mergeSeedRecord "CHANGELOG.md" exact merged `shouldBe` Right merged+    mergeSeedRecord "CHANGELOG.md" receipt merged `shouldBe` Right merged+    Right reverseMerged <- pure (mergeSeedRecord "CHANGELOG.md" exact (known & #seeds .~ Map.singleton "CHANGELOG.md" receipt))+    fmap (^. #ownership) (Map.lookup "CHANGELOG.md" (merged ^. #seeds)) `shouldBe` fmap (^. #ownership) (Map.lookup "CHANGELOG.md" (reverseMerged ^. #seeds))+    validateManifestInvariants merged `shouldBe` Right ()+  it "replaces selected claims without resetting settlement or losing unrelated owners" $ do+    Right shared <- pure (mergeSeedRecord "CHANGELOG.md" (second & #ownership .~ claims b ["demo"]) known)+    let candidate = second & #ownership .~ claims a ["second"] & #moduleName .~ "second"+    Right replaced <- pure (replaceSelectedSeedClaims (Set.singleton a) (Map.singleton "CHANGELOG.md" candidate) shared)+    let Just receipt = Map.lookup "CHANGELOG.md" (replaced ^. #seeds)+    receipt ^. #moduleName `shouldBe` "demo"+    receipt ^. #outcome `shouldBe` SeedCreated+    receipt ^. #ownership `shouldBe` KnownSeedOwners (Map.fromList [(a, Set.singleton "second"), (b, Set.singleton "demo")])+    Right retired <- pure (replaceSelectedSeedClaims (Set.singleton a) Map.empty replaced)+    fmap (^. #ownership) (Map.lookup "CHANGELOG.md" (retired ^. #seeds)) `shouldBe` Just (claims b ["demo"])+    replaceSelectedSeedClaims (Set.singleton a) (Map.singleton "CHANGELOG.md" (second & #ownership .~ claims b ["demo"])) known `shouldSatisfy` isLeft+  it "never subtracts unresolved legacy claims or mixes exact and unknown facts" $ do+    dropSeedOwners (Map.singleton a (Set.singleton "demo")) "CHANGELOG.md" manifest `shouldSatisfy` isLeft+    mergeSeedRecord "CHANGELOG.md" exact manifest `shouldSatisfy` isLeft+    replaceSelectedSeedClaims (Set.singleton a) Map.empty manifest `shouldSatisfy` isLeft+    replaceSelectedSeedClaims (Set.singleton (ApplicationId "unrelated")) Map.empty manifest `shouldBe` Right manifest+  it "round trips known claims and reports downgrade loss" $ do+    manifestFromJSON (manifestToJSON known) `shouldBe` Right known+    manifestEncodingLoss (known & #version .~ ManifestSchemaVersion 10) `shouldContain` ["seed owner claims require manifest schema 11"]+  it "validates exact paths and owner references" $ do+    forM_ ["../escape", "/absolute", "./alias", "a//b", ".seihou/private"] $ \path ->+      validateManifestInvariants (known & #seeds .~ Map.singleton path exact) `shouldSatisfy` isLeft+    forM_ [KnownSeedOwners Map.empty, claims a [], claims (ApplicationId "missing") ["demo"], claims a ["missing"]] $ \owners ->+      validateManifestInvariants (known & #seeds .~ Map.singleton "a" (exact & #ownership .~ owners)) `shouldSatisfy` isLeft+    let file = FileRecord (SHA256 "hash") "demo" Copy now Nothing Set.empty SharedWriteUnknown+    validateManifestInvariants (known & #files .~ Map.singleton "CHANGELOG.md/child" file) `shouldSatisfy` isLeft   it "round trips receipts without hashes or baselines" $ do     manifestFromJSON (manifestToJSON manifest) `shouldBe` Right manifest   it "rejects a managed/seed collision at decoding" $ do@@ -53,7 +109,7 @@           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 <> " }] }"+                "in S.Module::{ name = \"demo\", version = Some \"1.0\" } // { steps = [S.Step::{ strategy = \"template\", src = \"a\", dest = \"b\" }" <> (if T.null field then "" else " // { " <> T.drop 2 field <> " }") <> "] }"               ]       TIO.writeFile (dir </> "module.dhall") (source "")       Right old <- evalModuleFromFile (dir </> "module.dhall")

@@ -3,6 +3,7 @@ import Control.Lens ((&), (.~), (^.)) import Data.Generics.Labels () import Data.Map.Strict qualified as Map+import Data.Set qualified as Set import Data.Text (Text) import Data.Time (UTCTime, defaultTimeLocale, parseTimeOrError) import Effectful@@ -42,6 +43,13 @@  spec :: Spec spec = do+  it "never reads seed bytes or treats deliberate deletion as drift" $ do+    let receipt = SeedRecord modName (LegacySeedOwners Set.empty) SeedCreated fixedTime+        manifest = emptyManifest fixedTime & #seeds .~ Map.fromList [("unreadable.txt", receipt), ("deleted.txt", receipt)]+        (tracked, after) = runPureEff $ runFilesystemPure emptyFS $ computeTrackedFileStatuses manifest+    tracked `shouldBe` []+    after `shouldBe` emptyFS+   describe "computeTrackedFileStatuses" $ do     it "classifies a file matching its manifest hash as TfsUnchanged" $ do       let content = "# Hello World"

@@ -134,7 +134,7 @@       src `shouldBe` "a.txt"      it "supports RunCommandOp" $ do-      let RunCommandOp {command} = RunCommandOp {command = "git init", workDir = Nothing, moduleName = "test", occurrence = 0}+      let RunCommandOp {command} = RunCommandOp {command = "git init", workDir = Nothing, moduleName = "test", occurrence = 0, lifecycle = ApplicationCommand}       command `shouldBe` "git init"    describe "Expr" $ do

@@ -1,9 +1,11 @@ module Seihou.Dhall.EvalSpec (tests) where  import Control.Lens ((^.))+import Control.Monad (forM_) import Data.Generics.Labels () import Data.Map.Strict qualified as Map import Data.Text qualified as T+import Data.Text.IO qualified as TIO import Seihou.Core.Types import Seihou.Dhall.Eval (evalDhallExpr, evalModuleFromFile, evalRecipeFromFile) import System.Directory (createDirectoryIfMissing)@@ -57,6 +59,26 @@       result <- evalDhallExpr "{ name = \"my-project\", version = \"0.1.0\" }"       Map.lookup "name" result `shouldBe` Just "my-project"       Map.lookup "version" result `shouldBe` Just "0.1.0"++  describe "command lifecycle decoding" $ do+    let source command = T.replace "commands = [] : List { run : Text, workDir : Optional Text, when : Optional Text }" ("commands = [" <> command <> "]") (T.pack (moduleWithVar "value" "text" "None Text"))+        action variant = "{ action = < Apply : Text | Checkout : Text >." <> variant <> " \"echo setup\", workDir = None Text, when = None Text }"+    forM_ [("Apply", ApplicationCommand), ("Checkout", CheckoutCommandLifecycle)] $ \(variant, lifecycle) ->+      it ("decodes tagged " <> T.unpack variant <> " commands") $+        withSystemTempDirectory "command-decoder" $ \directory -> do+          let file = directory </> "module.dhall"+          TIO.writeFile file (source (action variant))+          result <- evalModuleFromFile file+          case result of+            Right modul -> map (^. #lifecycle) (modul ^. #commands) `shouldBe` [lifecycle]+            Left err -> expectationFailure (show err)+    forM_ ["{ run = \"echo legacy\", action = < Apply : Text | Checkout : Text >.Checkout \"echo setup\", workDir = None Text, when = None Text }", "{ action = < Unknown : Text >.Unknown \"echo setup\", workDir = None Text, when = None Text }"] $ \bad ->+      it "rejects ambiguous or unknown tagged commands inside the module exception boundary" $+        withSystemTempDirectory "command-decoder-invalid" $ \directory -> do+          let file = directory </> "module.dhall"+          TIO.writeFile file (source bad)+          result <- evalModuleFromFile file+          result `shouldSatisfy` either (const True) (const False)    describe "evalModuleFromFile" $ do     it "decodes the haskell-base fixture module" $ do

@@ -1,5 +1,6 @@ module Seihou.Effect.ManifestStoreSpec (tests) where +import Control.Exception (evaluate) import Control.Lens ((&), (.~), (^.)) import Data.Generics.Labels () import Data.Map.Strict qualified as Map@@ -14,7 +15,7 @@ import Seihou.Effect.ManifestStore (readManifest, writeManifest) import Seihou.Effect.ManifestStoreInterp (runManifestStore) import Seihou.Effect.ManifestStorePure (runManifestStorePure)-import Seihou.Manifest.Types (emptyManifest)+import Seihou.Manifest.Types (currentManifestVersion, emptyManifest) import System.Directory (doesFileExist) import System.FilePath ((</>)) import System.IO.Temp (withSystemTempDirectory)@@ -61,6 +62,12 @@             writeManifest sampleManifest       finalState `shouldBe` Just sampleManifest +  describe "write validation" $ do+    it "refuses lossy exact ownership before writing any bytes" $ do+      let receipt = SeedRecord "haskell-base" (KnownSeedOwners (Map.singleton (ApplicationId "app") (Set.singleton "haskell-base"))) SeedCreated fixedTime+          invalid = sampleManifest & #version .~ ManifestSchemaVersion 10 & #seeds .~ Map.singleton "seed.txt" receipt+      evaluate (runPureEff (runManifestStorePure Nothing (writeManifest invalid))) `shouldThrow` anyIOException+   describe "real interpreter (via pure filesystem)" $ do     it "returns Right Nothing when manifest file does not exist" $ do       let manifestPath = ".seihou/manifest.json"@@ -88,7 +95,7 @@                 runManifestStore manifestPath (writeManifest sampleManifest)                 c <- readFileText manifestPath                 pure ((), c)-      T.isInfixOf "\"version\":9" content `shouldBe` True+      T.isInfixOf ("\"version\":" <> T.pack (show (currentManifestVersion ^. #unManifestSchemaVersion))) content `shouldBe` True       T.isInfixOf "haskell-base" content `shouldBe` True       T.isInfixOf "my-app" content `shouldBe` True 

@@ -37,7 +37,7 @@ 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+    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

@@ -90,7 +90,7 @@       Map.lookup "/project/src/Main.hs" (fs ^. #files) `shouldBe` Just "module Main where"      it "skips RunCommandOp" $ do-      let ops = [RunCommandOp "echo hello" Nothing modName 0]+      let ops = [RunCommandOp "echo hello" Nothing modName 0 ApplicationCommand]           (records, _) = runExecFS emptyFS ops       Map.size records `shouldBe` 0 @@ -241,7 +241,7 @@       T.isInfixOf "copy" result `shouldBe` True      it "formats RunCommandOp" $ do-      let result = dryRunPlan [RunCommandOp "echo hello" Nothing modName 0]+      let result = dryRunPlan [RunCommandOp "echo hello" Nothing modName 0 ApplicationCommand]       T.isInfixOf "run" result `shouldBe` True      it "returns message for empty plan" $ do

@@ -6,6 +6,7 @@ import Data.Text qualified as T import Data.Text.Encoding qualified as T import Data.Yaml qualified as Yaml+import Seihou.Core.CommandFingerprint (fingerprintCommand) import Seihou.Core.Module (loadModule) import Seihou.Core.Types import Seihou.Engine.Plan@@ -728,6 +729,21 @@             T.isInfixOf "Structured" (errs !! 0) `shouldBe` True           Right _ -> expectationFailure "Expected Left" +    it "keeps checkout occurrences separate without invalidating application fingerprints" $ do+      let ordinary = Command "echo {{value}}" Nothing Nothing ApplicationCommand+          checkout = Command "echo {{value}}" Nothing Nothing CheckoutCommandLifecycle+          disabled = Command "never" Nothing (Just (ExprLit False)) CheckoutCommandLifecycle+          modul commands = Module "test" Nothing Nothing [] [] [] [] commands [] Nothing []+          values = Map.singleton "value" (VText "resolved")+      plain <- compilePlan "." (modul [ordinary, ordinary]) values+      mixed <- compilePlan "." (modul [checkout, ordinary, disabled, ordinary, checkout]) values+      case (plain, mixed) of+        (Right old, Right operations) -> do+          [(lifecycle, occurrence) | RunCommandOp {lifecycle, occurrence} <- operations] `shouldBe` [(CheckoutCommandLifecycle, 0), (ApplicationCommand, 0), (ApplicationCommand, 1), (CheckoutCommandLifecycle, 1)]+          map fingerprintCommand [operation | operation@RunCommandOp {lifecycle = ApplicationCommand} <- operations] `shouldBe` map fingerprintCommand old+          [command | RunCommandOp {command} <- operations] `shouldBe` replicate 4 "echo resolved"+        other -> expectationFailure (show other)+     it "compiles unconditional command to RunCommandOp" $ do       withFixture [("data.txt", "content")] $ \baseDir -> do         let modul =@@ -739,7 +755,7 @@                   exports = [],                   prompts = [],                   steps = [Step Copy "data.txt" "data.txt" Nothing Nothing Managed],-                  commands = [Command "echo hello" Nothing Nothing],+                  commands = [Command "echo hello" Nothing Nothing ApplicationCommand],                   dependencies = [],                   removal = Nothing,                   migrations = []@@ -765,9 +781,9 @@                   prompts = [],                   steps = [],                   commands =-                    [ Command "echo same" Nothing Nothing,-                      Command "echo other" Nothing Nothing,-                      Command "echo same" Nothing Nothing+                    [ Command "echo same" Nothing Nothing ApplicationCommand,+                      Command "echo other" Nothing Nothing ApplicationCommand,+                      Command "echo same" Nothing Nothing ApplicationCommand                     ],                   dependencies = [],                   removal = Nothing,@@ -792,7 +808,7 @@                   exports = [],                   prompts = [],                   steps = [Step Copy "data.txt" "data.txt" Nothing Nothing Managed],-                  commands = [Command "echo skip" Nothing (Just (ExprLit False))],+                  commands = [Command "echo skip" Nothing (Just (ExprLit False)) ApplicationCommand],                   dependencies = [],                   removal = Nothing,                   migrations = []@@ -816,7 +832,7 @@                   exports = [],                   prompts = [],                   steps = [Step Copy "data.txt" "data.txt" Nothing Nothing Managed],-                  commands = [Command "echo yes" Nothing (Just (ExprIsSet "name"))],+                  commands = [Command "echo yes" Nothing (Just (ExprIsSet "name")) ApplicationCommand],                   dependencies = [],                   removal = Nothing,                   migrations = []@@ -840,7 +856,7 @@                   exports = [],                   prompts = [],                   steps = [Step Copy "data.txt" "data.txt" Nothing Nothing Managed],-                  commands = [Command "echo post" Nothing Nothing],+                  commands = [Command "echo post" Nothing Nothing ApplicationCommand],                   dependencies = [],                   removal = Nothing,                   migrations = []@@ -873,7 +889,7 @@                   exports = [],                   prompts = [],                   steps = [Step Copy "data.txt" "data.txt" Nothing Nothing Managed],-                  commands = [Command "npm install" (Just "subdir") Nothing],+                  commands = [Command "npm install" (Just "subdir") Nothing ApplicationCommand],                   dependencies = [],                   removal = Nothing,                   migrations = []@@ -898,7 +914,7 @@                   exports = [],                   prompts = [],                   steps = [Step Copy "data.txt" "data.txt" Nothing Nothing Managed],-                  commands = [Command "echo {{name}}" Nothing Nothing],+                  commands = [Command "echo {{name}}" Nothing Nothing ApplicationCommand],                   dependencies = [],                   removal = Nothing,                   migrations = []@@ -923,7 +939,7 @@                   exports = [],                   prompts = [],                   steps = [Step Copy "data.txt" "data.txt" Nothing Nothing Managed],-                  commands = [Command "cabal build" (Just "{{name}}") Nothing],+                  commands = [Command "cabal build" (Just "{{name}}") Nothing ApplicationCommand],                   dependencies = [],                   removal = Nothing,                   migrations = []@@ -948,7 +964,7 @@                   exports = [],                   prompts = [],                   steps = [],-                  commands = [Command "cabal build" (Just "{{project.name}}") Nothing],+                  commands = [Command "cabal build" (Just "{{project.name}}") Nothing ApplicationCommand],                   dependencies = [],                   removal = Nothing,                   migrations = []@@ -973,7 +989,7 @@                   exports = [],                   prompts = [],                   steps = [Step Copy "data.txt" "data.txt" Nothing Nothing Managed],-                  commands = [Command "echo {{missing}}" Nothing Nothing],+                  commands = [Command "echo {{missing}}" Nothing Nothing ApplicationCommand],                   dependencies = [],                   removal = Nothing,                   migrations = []

@@ -117,7 +117,7 @@         _ -> expectationFailure "Expected DirPreview"      it "produces CommandPreview for RunCommandOp" $ do-      let ops = [RunCommandOp "cabal build" Nothing modName 0]+      let ops = [RunCommandOp "cabal build" Nothing modName 0 ApplicationCommand]           result = buildPreview ops Nothing Map.empty       length result `shouldBe` 1       case head result of@@ -128,9 +128,9 @@      it "shows command ownership only when identical text has multiple owners" $ do       let ops =-            [ RunCommandOp "cabal build" Nothing modName 0,-              RunCommandOp "cabal build" Nothing modName2 0,-              RunCommandOp "cabal test" Nothing modName 0+            [ RunCommandOp "cabal build" Nothing modName 0 ApplicationCommand,+              RunCommandOp "cabal build" Nothing modName2 0 ApplicationCommand,+              RunCommandOp "cabal test" Nothing modName 0 ApplicationCommand             ]           result = buildPreview ops Nothing Map.empty       result

@@ -39,6 +39,21 @@             other -> expectationFailure ("expected one update, got " <> show other)         Left err -> expectationFailure (show err) +    it "adds newly declared ignore lines without conflicting with user appends or restoring deleted old lines" $ do+      let base = ".claude/\n.agents/\n"+          current = ".claude/\n.mina/\n# user rules\ndist-newstyle/\n"+          ref = baselineRefForContent base+          manifest = withFile ".gitignore" (record base (Just ref) [appA]) empty+          operations = [patch ".claude/\n.agents/\n.codex/" "owner"]+          result = planWith (Map.singleton ".gitignore" current) Map.empty (Map.singleton ref base) manifest [appA] operations (owners ".gitignore" [appA]) (\_ _ _ -> error "line additions must not invoke diff3")+      case result of+        Right reconciliation -> case (reconciliation ^. #files) Map.! ".gitignore" of+          FileAutoMerge _ state _ _ -> do+            state ^. #appliedContent `shouldBe` current <> ".codex/\n"+            state ^. #generatedBaseline `shouldBe` base <> ".codex/\n"+          other -> expectationFailure (show other)+        Left err -> expectationFailure (show err)+     it "replays a patch after a complete write" $ do       let operations =             [ WriteFileOp "README.md" "generated\n" Template,

@@ -79,6 +79,29 @@  spec :: Spec spec = do+  describe "seed preservation and exact selection" $ do+    let appId = ApplicationId "a"+        app = AppliedComposition appId (AppliedModuleTarget modName) (LocalOrigin "test-module") Nothing [] Nothing Nothing [AppliedInstanceState name emptyParentVars (LocalOrigin text) Nothing Map.empty | (name, text) <- [(modName, "test-module"), (otherMod, "other-module")]] Map.empty [] fixedTime+        receipt = SeedRecord modName (KnownSeedOwners (Map.singleton appId (Set.fromList [modName, otherMod]))) SeedCreated fixedTime+        manifest = mkManifest False [] & #applications .~ [app] & #seeds .~ Map.singleton "seed.txt" receipt+    it "retires a no-spec instance without losing a co-seeder or original supplier" $ do+      Right (Just selection) <- pure (selectRecordedRemoval manifest modName Nothing)+      let candidate = selection ^. #candidateManifest+      fmap (^. #ownership) (Map.lookup "seed.txt" (candidate ^. #seeds)) `shouldBe` Just (KnownSeedOwners (Map.singleton appId (Set.singleton otherMod)))+      fmap (^. #moduleName) (Map.lookup "seed.txt" (candidate ^. #seeds)) `shouldBe` Just modName+    it "keeps every declarative removal form without needing to read seed content" $ do+      let removal = Removal [RemovalStep action "seed.txt" (Just "rewrite.dhall") | action <- [RemoveFileAction, RemoveSectionAction, RewriteFileAction]] []+      Right plan <- pure (runBuildOps emptyFS manifest modName removal)+      plan ^. #ops `shouldBe` replicate 3 (KeepSeedOp "seed.txt")+    it "defends direct supplied operations, including path aliases, at execution too" $ do+      let fs = mkFS [("seed.txt", "project bytes")]+          plan = ExecutedRemovalPlan modName [DeleteFileOp "seed.txt" RFSafe, StripSectionOp "./seed.txt", RewriteOp "seed.txt" "rewrite.dhall"]+          (_, after) = runExecOps fs manifest plan Set.empty+      after ^. #files `shouldBe` fs ^. #files+    it "refuses unresolved legacy subtraction rather than guessing from supplier" $ do+      let legacy = manifest & #seeds .~ Map.singleton "seed.txt" (receipt & #ownership .~ LegacySeedOwners (Set.singleton appId))+      selectRecordedRemoval legacy modName Nothing `shouldSatisfy` either (const True) (const False)+   describe "computeRemovalPlan" $ do     it "returns ModuleNotApplied when module is not in manifest" $ do       let manifest = emptyManifest fixedTime@@ -239,7 +262,7 @@         Right plan -> (plan ^. #ops) `shouldBe` [StripSectionOp ".gitignore"]      it "builds RemovalCommandOp for removal commands" $ do-      let removal = Removal [] [Command "cabal clean" Nothing Nothing]+      let removal = Removal [] [Command "cabal clean" Nothing Nothing ApplicationCommand]           manifest = mkManifestWithRemoval removal []           result = runBuildOps emptyFS manifest modName removal       case result of@@ -261,7 +284,7 @@       Map.member "../outside" (fs ^. #files) `shouldBe` True      it "rejects a removal command workDir with a parent directory segment" $ do-      let removal = Removal [] [Command "echo unsafe" (Just "../outside") Nothing]+      let removal = Removal [] [Command "echo unsafe" (Just "../outside") Nothing ApplicationCommand]           manifest = mkManifestWithRemoval removal []           result = runBuildOps emptyFS manifest modName removal       result@@ -276,7 +299,7 @@       let removal =             Removal               [RemovalStep RemoveFileAction "a.txt" Nothing, RemovalStep RemoveSectionAction ".gitignore" Nothing]-              [Command "echo done" Nothing Nothing]+              [Command "echo done" Nothing Nothing ApplicationCommand]           manifest = mkManifestWithRemoval removal [("a.txt", "aaa")]           fs = mkFS [("a.txt", "aaa"), (".gitignore", "stuff")]           result = runBuildOps fs manifest modName removal

@@ -0,0 +1,92 @@+module Seihou.Engine.SeedSpec (tests) where++import Control.Monad (forM_)+import Data.ByteString qualified as BS+import Data.Either (isLeft)+import Data.Generics.Labels ()+import Data.Map.Strict qualified as Map+import Data.Set qualified as Set+import Data.Text.IO qualified as TIO+import Data.Time (UTCTime (..), fromGregorian)+import Effectful (runPureEff)+import Seihou.Core.Types+import Seihou.Effect.Filesystem+import Seihou.Effect.FilesystemInterp (createFileExclusiveWith, runFilesystem)+import Seihou.Effect.FilesystemPure+import Seihou.Engine.Seed+import Seihou.Manifest.Types (emptyManifest)+import Seihou.Prelude+import System.Directory qualified as D+import System.IO.Temp (withSystemTempDirectory)+import Test.Hspec+import Test.Tasty+import Test.Tasty.Hspec (testSpec)++tests :: IO TestTree+tests = testSpec "seed planning and exclusive creation" $ do+  let now = UTCTime (fromGregorian 2026 10 26) 0+      receipt = SeedRecord "supplier" (KnownSeedOwners (Map.singleton (ApplicationId "a") (Set.singleton "supplier"))) SeedCreated now+      managed = FileRecord (SHA256 "hash") "supplier" Copy now Nothing Set.empty SharedWriteUnknown+      operation = SeedFileOp "nested/start.txt" "starter\n" Copy "supplier"+      claims = Map.singleton "nested/start.txt" (Set.fromList ["supplier", "second"])+  it "uses one decision tree for every observed entry and lifecycle" $ do+    classifySeed Nothing Nothing EntryMissing `shouldBe` Right SeedWrite+    classifySeed Nothing Nothing EntryFile `shouldBe` Right SeedKeepExisting+    forM_ [EntryDirectory, EntrySymlink "missing"] $ \entry -> classifySeed Nothing Nothing entry `shouldSatisfy` isLeft+    forM_ [EntryMissing, EntryFile, EntryDirectory, EntrySymlink "missing"] $ \entry -> do+      classifySeed (Just receipt) Nothing entry `shouldBe` Right (if entry == EntryMissing then SeedRespectDeletion else SeedAlreadySettled)+      classifySeed Nothing (Just managed) entry `shouldBe` Right SeedReleaseManaged+  it "uses an explicit root, records every claimant, and never hashes a seed" $ do+    let ((planned, created), fs) = runPureEff $ runFilesystemPure emptyFS $ do+          result <- planSeeds "/project" (emptyManifest now) claims [operation]+          let Right planned = result+          created <- executeSeeds "/project" (ApplicationId "a") now planned (emptyManifest now)+          pure (planned, created)+    map (^. #supplier) planned `shouldBe` ["supplier"]+    fs ^. #files `shouldBe` Map.singleton "/project/nested/start.txt" "starter\n"+    fmap (fmap (^. #ownership)) created `shouldBe` Right (Map.singleton "nested/start.txt" (KnownSeedOwners (Map.singleton (ApplicationId "a") (Set.fromList ["supplier", "second"]))))+  it "does not read, repair, or create parents for a settled deleted seed" $ do+    let manifest = emptyManifest now & #seeds .~ Map.singleton "nested/start.txt" receipt+        ((planned, result), fs) = runPureEff $ runFilesystemPure emptyFS $ do+          result <- planSeeds "/project" manifest claims [operation]+          let Right planned = result+          executed <- executeSeeds "/project" (ApplicationId "a") now planned manifest+          pure (planned, executed)+    map (^. #decision) planned `shouldBe` [SeedRespectDeletion]+    result `shouldSatisfy` either (const False) (const True)+    fs `shouldBe` emptyFS+  it "refuses lifecycle transitions even when managed content is missing" $ do+    validateSeedRun (emptyManifest now & #files .~ Map.singleton "nested/start.txt" managed) [operation] `shouldSatisfy` isLeft+    validateSeedRun (emptyManifest now & #seeds .~ Map.singleton "nested/start.txt" receipt) [WriteFileOp "nested/start.txt" "replacement" Copy] `shouldSatisfy` isLeft+  it "publishes complete bytes once and cannot replace files, directories or dangling links" $+    withSystemTempDirectory "seed-exclusive" $ \root -> do+      runEff (runFilesystem (createFileExclusive (root </> "file") "complete\n")) `shouldReturn` ExclusiveCreated+      runEff (runFilesystem (createFileExclusive (root </> "file") "replacement\n")) `shouldReturn` ExclusiveOccupied+      TIO.readFile (root </> "file") `shouldReturn` "complete\n"+      D.createDirectory (root </> "dir")+      D.createFileLink "missing" (root </> "link")+      forM_ ["dir", "link"] $ \path -> runEff (runFilesystem (createFileExclusive (root </> path) "replacement")) `shouldReturn` ExclusiveOccupied+      D.getSymbolicLinkTarget (root </> "link") `shouldReturn` "missing"+  it "cleans a failed partial private write without exposing a destination" $+    withSystemTempDirectory "seed-partial" $ \root -> do+      let failWriting handle = BS.hPut handle "partial" >> ioError (userError "injected write failure")+      result <- createFileExclusiveWith failWriting (root </> "seed")+      result `shouldSatisfy` (\case ExclusiveFailure _ -> True; _ -> False)+      D.listDirectory root `shouldReturn` []+  it "keeps a file appearing after preview and refuses a newly appearing link" $+    withSystemTempDirectory "seed-race" $ \root -> do+      Right planned <- runEff $ runFilesystem $ planSeeds root (emptyManifest now) claims [operation]+      D.createDirectory (root </> "nested")+      TIO.writeFile (root </> "nested/start.txt") "concurrent owner\n"+      Right actual <- runEff $ runFilesystem $ executeSeeds root (ApplicationId "a") now planned (emptyManifest now)+      fmap (^. #outcome) (Map.lookup "nested/start.txt" actual) `shouldBe` Just SeedFoundExisting+      TIO.readFile (root </> "nested/start.txt") `shouldReturn` "concurrent owner\n"+      D.removeFile (root </> "nested/start.txt")+      D.createFileLink "missing" (root </> "nested/start.txt")+      runEff (runFilesystem (executeSeeds root (ApplicationId "a") now planned (emptyManifest now))) >>= (`shouldSatisfy` isLeft)+  it "does not traverse a symlink parent" $+    withSystemTempDirectory "seed-parent" $ \root -> do+      D.createDirectory (root </> "elsewhere")+      D.createDirectoryLink "elsewhere" (root </> "nested")+      runEff (runFilesystem (planSeeds root (emptyManifest now) claims [operation])) >>= (`shouldSatisfy` isLeft)+      D.listDirectory (root </> "elsewhere") `shouldReturn` []

@@ -0,0 +1,152 @@+module Seihou.Engine.SeedTransactionSpec (tests) where++import Control.Exception (IOException)+import Data.Either (isLeft)+import Data.Generics.Labels ()+import Data.Map.Strict qualified as Map+import Data.Set qualified as Set+import Data.Text.IO qualified as TIO+import Data.Time (UTCTime (..), fromGregorian)+import Seihou.Core.Migration qualified as Migration+import Seihou.Core.Types hiding (KeepCurrent)+import Seihou.Effect.BaselineStorePure (runBaselineStorePure)+import Seihou.Effect.Filesystem (PathEntry (..))+import Seihou.Effect.FilesystemInterp (runFilesystem)+import Seihou.Engine.Migrate (validateSeedMigration)+import Seihou.Engine.Reconcile+import Seihou.Engine.Seed (SeedDecision (..))+import Seihou.Engine.UpdateTransaction+import Seihou.Manifest.Hash (baselineRefForContent, hashContent)+import Seihou.Manifest.Types (emptyManifest)+import Seihou.Prelude+import System.Directory qualified as D+import System.IO.Temp (withSystemTempDirectory)+import Test.Hspec+import Test.Tasty+import Test.Tasty.Hspec (testSpec)++tests :: IO TestTree+tests = testSpec "seed update transactions" $ do+  let now = UTCTime (fromGregorian 2026 10 26) 0+      appId = ApplicationId "app"+      app = AppliedComposition appId (AppliedModuleTarget "seeder") (LocalOrigin "seeder") Nothing [] Nothing Nothing [AppliedInstanceState "seeder" emptyParentVars (LocalOrigin "seeder") Nothing Map.empty] Map.empty [] now+      manifest = emptyManifest now & #applications .~ [app]+      claims = Map.singleton appId (Set.singleton "seeder")+      createAction = SeedAction "seed.txt" "seeder" claims SeedWrite (Just "seed bytes\n")+      createPlan = ReconciliationPlan (Set.singleton appId) (Map.singleton "seed.txt" (FileSeedCreate createAction EntryMissing)) Set.empty+      begin root = beginSeedUpdateTransaction root (reconciliationMutationPaths createPlan) (Set.singleton "seed.txt")+      receipt = SeedRecord "seeder" (KnownSeedOwners claims) SeedCreated now+      priorSeed = manifest & #seeds .~ Map.singleton "seed.txt" receipt+      managedOwners = Map.singleton "seed.txt" (DesiredFileOwner "seeder" (Set.singleton appId))+      plan root prior ops owners seedClaims =+        fmap fst $+          runEff $+            runFilesystem $+              runBaselineStorePure Map.empty $+                planSeedReconciliation root root prior (Set.singleton appId) ops owners seedClaims+  it "requires explicit adoption of equal seed bytes and records keep-current against the generated baseline" $+    withSystemTempDirectory "seed-adoption" $ \root -> do+      TIO.writeFile (root </> "seed.txt") "project bytes\n"+      Right pending <- plan root priorSeed [WriteFileOp "seed.txt" "candidate bytes\n" Copy] managedOwners Map.empty+      unresolvedPaths pending `shouldBe` Set.singleton "seed.txt"+      Right kept <- pure (resolveFileConflict "seed.txt" KeepCurrent pending)+      Right transaction <- beginSeedUpdateTransaction root (reconciliationMutationPaths kept) Set.empty+      Right final <- applyReconciliation transaction kept priorSeed+      final ^. #seeds `shouldBe` Map.empty+      fmap (^. #hash) (Map.lookup "seed.txt" (final ^. #files)) `shouldBe` Just (hashContent "project bytes\n")+      fmap (^. #baseline) (Map.lookup "seed.txt" (final ^. #files)) `shouldBe` Just (Just (baselineRefForContent "candidate bytes\n"))+      TIO.readFile (root </> "seed.txt") `shouldReturn` "project bytes\n"+      completeUpdateTransaction transaction `shouldReturn` Right ()+  it "offers only explicit recreation for a missing seed and accepts generated bytes" $+    withSystemTempDirectory "seed-adopt-missing" $ \root -> do+      Right pending <- plan root priorSeed [WriteFileOp "seed.txt" "candidate bytes\n" Copy] managedOwners Map.empty+      resolveFileConflict "seed.txt" KeepCurrent pending `shouldSatisfy` isLeft+      resolveFileConflict "seed.txt" WriteConflictMarkers pending `shouldSatisfy` isLeft+      Right accepted <- pure (resolveFileConflict "seed.txt" AcceptGenerated pending)+      Right transaction <- beginSeedUpdateTransaction root (reconciliationMutationPaths accepted) Set.empty+      Right final <- applyReconciliation transaction accepted priorSeed+      final ^. #seeds `shouldBe` Map.empty+      TIO.readFile (root </> "seed.txt") `shouldReturn` "candidate bytes\n"+      completeUpdateTransaction transaction `shouldReturn` Right ()+  it "preserves unselected seed claims when the selected application retires its claim" $+    withSystemTempDirectory "seed-partial-retirement" $ \root -> do+      let other = app & #applicationId .~ ApplicationId "other"+          sharedClaims = Map.insert (ApplicationId "other") (Set.singleton "seeder") claims+          prior = priorSeed & #applications %~ (<> [other]) & #seeds .~ Map.singleton "seed.txt" (receipt & #ownership .~ KnownSeedOwners sharedClaims)+      D.createDirectory (root </> "seed.txt")+      Right pending <- plan root prior [] Map.empty Map.empty+      reconciliationMutationPaths pending `shouldBe` Set.empty+      Right transaction <- beginSeedUpdateTransaction root Set.empty Set.empty+      Right final <- applyReconciliation transaction pending prior+      fmap (^. #ownership) (Map.lookup "seed.txt" (final ^. #seeds)) `shouldBe` Just (KnownSeedOwners (Map.delete appId sharedClaims))+      D.doesDirectoryExist (root </> "seed.txt") `shouldReturn` True+      completeUpdateTransaction transaction `shouldReturn` Right ()+  it "does not grant release over an unselected managed owner, even with additive certification" $+    withSystemTempDirectory "seed-release-owner" $ \root -> do+      let record = FileRecord (hashContent "generated") "seeder" Copy now Nothing (Set.fromList [appId, ApplicationId "other"]) SharedWriteAdditiveOnly+      result <- plan root (manifest & #files .~ Map.singleton "seed.txt" record) [SeedFileOp "seed.txt" "seed" Copy "seeder"] Map.empty (Map.singleton "seed.txt" claims)+      result `shouldBe` Left (SeedReleaseBlockedByOwners "seed.txt" (Set.singleton (ApplicationId "other")))+  it "guards every declarative migration source, destination, ancestor and portable alias" $ do+    let protected = Set.singleton "nested/seed.txt"+        ops = [Migration.MoveFile "nested/seed.txt" "elsewhere", Migration.MoveFile "elsewhere" "nested/seed.txt", Migration.MoveDir "nested" "other", Migration.MoveDir "other" "nested", Migration.DeleteFile "nested/seed.txt", Migration.DeleteDir "nested", Migration.DeleteFile "NESTED/seed.txt"]+    mapM_ (\op -> validateSeedMigration protected [op] `shouldSatisfy` isLeft) ops+    validateSeedMigration protected [Migration.DeleteFile "unrelated"] `shouldBe` Right ()+  it "releases edited managed files without reading or restoring project bytes" $+    withSystemTempDirectory "seed-release-transaction" $ \root -> do+      let record = FileRecord (hashContent "generated") "seeder" Copy now Nothing (Set.singleton appId) SharedWriteRequiresOwnershipClosure+          prior = manifest & #files .~ Map.singleton "seed.txt" record+          action = SeedAction "seed.txt" "seeder" claims SeedReleaseManaged Nothing+          plan = ReconciliationPlan (Set.singleton appId) (Map.singleton "seed.txt" (FileSeedRelease action record)) Set.empty+      -- A directory cannot be read as text or journaled as an ordinary file;+      -- metadata release still preserves this project-owned replacement.+      D.createDirectory (root </> "seed.txt")+      Right transaction <- beginSeedUpdateTransaction root (reconciliationMutationPaths plan) Set.empty+      Right candidate <- applyReconciliation transaction plan prior+      candidate ^. #files `shouldBe` Map.empty+      fmap (^. #outcome) (Map.lookup "seed.txt" (candidate ^. #seeds)) `shouldBe` Just SeedReleasedFromManaged+      rollbackUpdateTransaction transaction `shouldReturn` Right ()+      D.doesDirectoryExist (root </> "seed.txt") `shouldReturn` True+  it "does not resurrect a missing managed path on release" $+    withSystemTempDirectory "seed-release-missing" $ \root -> do+      let record = FileRecord (hashContent "generated") "seeder" Copy now Nothing (Set.singleton appId) SharedWriteRequiresOwnershipClosure+          action = SeedAction "seed.txt" "seeder" claims SeedReleaseManaged Nothing+          plan = ReconciliationPlan (Set.singleton appId) (Map.singleton "seed.txt" (FileSeedRelease action record)) Set.empty+      Right transaction <- beginSeedUpdateTransaction root Set.empty Set.empty+      Right _ <- applyReconciliation transaction plan (manifest & #files .~ Map.singleton "seed.txt" record)+      D.doesPathExist (root </> "seed.txt") `shouldReturn` False+      rollbackUpdateTransaction transaction `shouldReturn` Right ()+  it "aborts a creation that became occupied without restoring over the new object" $+    withSystemTempDirectory "seed-stale" $ \root -> do+      Right transaction <- begin root+      TIO.writeFile (root </> "seed.txt") "concurrent project file\n"+      result <- applyReconciliation transaction createPlan manifest+      result `shouldSatisfy` isLeft+      TIO.readFile (root </> "seed.txt") `shouldReturn` "concurrent project file\n"+      recoverIncompleteTransactions root >>= (`shouldSatisfy` all (== Right ()))+  it "rolls back only an unchanged seed actually created by the transaction" $+    withSystemTempDirectory "seed-rollback" $ \root -> do+      Right transaction <- begin root+      result <- applyReconciliationWithHook (\_ -> ioError (userError "injected failure")) transaction createPlan manifest+      result `shouldSatisfy` isLeft+      D.doesPathExist (root </> "seed.txt") `shouldReturn` False+  it "recovers completed creation evidence after restart" $+    withSystemTempDirectory "seed-restart" $ \root -> do+      Right transaction <- begin root+      Right _ <- applyReconciliation transaction createPlan manifest+      TIO.readFile (root </> "seed.txt") `shouldReturn` "seed bytes\n"+      recoverIncompleteTransactions root >>= (`shouldSatisfy` all (== Right ()))+      D.doesPathExist (root </> "seed.txt") `shouldReturn` False+  it "preserves later edits and identical replacement objects during failed rollback" $+    mapM_+      ( \replace -> withSystemTempDirectory "seed-rollback-project-edit" $ \root -> do+          Right transaction <- begin root+          let change _ = do+                if replace then D.removeFile (root </> "seed.txt") else pure ()+                TIO.writeFile (root </> "seed.txt") (if replace then "seed bytes\n" else "project edit\n")+                ioError (userError "injected failure")+          result <- applyReconciliationWithHook change transaction createPlan manifest+          result `shouldSatisfy` isLeft+          D.doesFileExist (root </> "seed.txt") `shouldReturn` True+          TIO.readFile (root </> "seed.txt") `shouldReturn` (if replace then "seed bytes\n" else "project edit\n")+      )+      [False, True]

@@ -1,6 +1,6 @@ module Seihou.Engine.ValidateSpec (tests) where -import Control.Lens ((^.))+import Control.Lens ((&), (.~), (^.)) import Data.Generics.Labels () import Data.Text qualified as T import Seihou.Core.Types@@ -461,11 +461,17 @@       reportHasErrors report `shouldBe` True    describe "command safety" $ do+    it "rejects repeatable setup in removal commands" $ do+      let modul = goodModule & #removal .~ Just (Removal [] [Command "echo setup" Nothing Nothing CheckoutCommandLifecycle])+      withSystemTempDirectory "seihou-removal-checkout" $ \baseDir -> do+        report <- buildReport False baseDir modul+        hasFailedCheck "Command safety" (report ^. #checks) `shouldBe` True+     it "passes for valid commands" $ do       withSystemTempDirectory "seihou-validate" $ \tmpDir -> do         createDirectoryIfMissing True (tmpDir </> "files")         writeFile (tmpDir </> "files" </> "README.md.tpl") "stub"-        let m = withCommands [Command "echo hello" Nothing Nothing] goodModule+        let m = withCommands [Command "echo hello" Nothing Nothing ApplicationCommand] goodModule         report <- buildReport False tmpDir m         hasPassedCheck "Command safety" (report ^. #checks) `shouldBe` True @@ -473,7 +479,7 @@       withSystemTempDirectory "seihou-validate" $ \tmpDir -> do         createDirectoryIfMissing True (tmpDir </> "files")         writeFile (tmpDir </> "files" </> "README.md.tpl") "stub"-        let m = withCommands [Command "  " Nothing Nothing] goodModule+        let m = withCommands [Command "  " Nothing Nothing ApplicationCommand] goodModule         report <- buildReport False tmpDir m         hasFailedCheck "Command safety" (report ^. #checks) `shouldBe` True @@ -481,7 +487,7 @@       withSystemTempDirectory "seihou-validate" $ \tmpDir -> do         createDirectoryIfMissing True (tmpDir </> "files")         writeFile (tmpDir </> "files" </> "README.md.tpl") "stub"-        let m = withCommands [Command "echo hi" (Just "/usr/local") Nothing] goodModule+        let m = withCommands [Command "echo hi" (Just "/usr/local") Nothing ApplicationCommand] goodModule         report <- buildReport False tmpDir m         hasFailedCheck "Command safety" (report ^. #checks) `shouldBe` True @@ -489,6 +495,6 @@       withSystemTempDirectory "seihou-validate" $ \tmpDir -> do         createDirectoryIfMissing True (tmpDir </> "files")         writeFile (tmpDir </> "files" </> "README.md.tpl") "stub"-        let m = withCommands [Command "echo hi" (Just "../escape") Nothing] goodModule+        let m = withCommands [Command "echo hi" (Just "../escape") Nothing ApplicationCommand] goodModule         report <- buildReport False tmpDir m         hasFailedCheck "Command safety" (report ^. #checks) `shouldBe` True

@@ -8,7 +8,7 @@ import Data.Text qualified as T import Seihou.Composition.Graph (buildGraph, topoSort) import Seihou.Composition.Instance (ModuleInstance (..), primaryInstance)-import Seihou.Composition.Plan (compileComposedPlan)+import Seihou.Composition.Plan (ComposedPlan (..), compileComposedPlan) import Seihou.Composition.Resolve (loadComposition, resolveComposedVariables) import Seihou.Core.Types import System.FilePath ((</>))@@ -129,7 +129,7 @@               planResult <- compileComposedPlan quads               case planResult of                 Left errs -> expectationFailure $ "Plan failed: " ++ show errs-                Right (ops, warnings, _) -> do+                Right ComposedPlan {operations = ops, warnings} -> do                   -- Should have operations for shell.nix, flake.nix, README.md,                   -- src/Lib.hs, LICENSE, *.cabal, cabal.project, Makefile (+ dirs)                   let writeOps = [d | WriteFileOp d _ _ <- ops]@@ -155,7 +155,7 @@               planResult <- compileComposedPlan quads               case planResult of                 Left errs -> expectationFailure $ "Plan failed: " ++ show errs-                Right (ops, warnings, _) -> do+                Right ComposedPlan {operations = ops, warnings} -> do                   -- Find the merged README.md                   let readmeOps = [content | WriteFileOp dest content _ <- ops, dest == "README.md"]                   length readmeOps `shouldBe` 1@@ -184,7 +184,7 @@               planResult <- compileComposedPlan quads               case planResult of                 Left errs -> expectationFailure $ "Plan failed: " ++ show errs-                Right (ops, warnings, _) -> do+                Right ComposedPlan {operations = ops, warnings} -> do                   -- Find the merged config.json                   let configOps = [content | WriteFileOp dest content _ <- ops, dest == "config.json"]                   length configOps `shouldBe` 1@@ -245,7 +245,7 @@               planResult <- compileComposedPlan quads               case planResult of                 Left errs -> expectationFailure $ "Plan failed: " ++ show errs-                Right (ops, _, _) -> do+                Right ComposedPlan {operations = ops} -> do                   let writeDests = [d | WriteFileOp d _ _ <- ops]                   elem "out/leaf.txt" writeDests `shouldBe` True                   elem "out/diamond.txt" writeDests `shouldBe` True

@@ -107,6 +107,7 @@                      }                  ],                commandReceipts = Map.empty,+               checkoutCommands = [],                appliedAt = fixedTime              }          ]@@ -123,7 +124,7 @@ 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)+    & #seeds .~ Map.singleton "CHANGELOG.md" (SeedRecord "haskell-base" (KnownSeedOwners (Map.singleton (ApplicationId "app") (Set.singleton "docs"))) SeedCreated fixedTime)     & #modules       .~ [ AppliedModule              { name = ModuleName "haskell-base",@@ -135,7 +136,7 @@                  Just                    ( Removal                        [RemovalStep RemoveFileAction "flake.nix" (Just "files/flake.nix")]-                       [Command "cabal clean" (Just "backend") Nothing]+                       [Command "cabal clean" (Just "backend") Nothing ApplicationCommand]                    )              }          ]@@ -193,6 +194,7 @@       context = composition ^. #context,       instances = composition ^. #instances,       commandReceipts = receipts,+      checkoutCommands = [],       appliedAt = composition ^. #appliedAt     } @@ -263,6 +265,35 @@       encoded `shouldSatisfy` not . isInfixOf "\"source\""       encoded `shouldSatisfy` not . isInfixOf "\"targetSource\"" +  describe "checkout command codec" $ do+    let command = CheckoutCommand "demo" 0 "mkdir -p .local/setup" Nothing+        application commands = AppliedComposition (ApplicationId "setup") (AppliedModuleTarget "demo") (ProjectOrigin "modules/demo") (Just "1") [] Nothing Nothing [AppliedInstanceState "demo" emptyParentVars (ProjectOrigin "modules/demo") (Just "1") Map.empty] Map.empty commands fixedTime+        manifest commands = emptyManifest fixedTime & #applications .~ [application commands]+        mutateApp transform value = case value of+          Aeson.Object fields -> case KeyMap.lookup "applications" fields of+            Just (Aeson.Array apps) -> Aeson.Object (KeyMap.insert "applications" (Aeson.Array (fmap (\case Aeson.Object obj -> Aeson.Object (transform obj); other -> other) apps)) fields)+            _ -> value+          other -> other+        decoded transform = manifestFromJSON (Aeson.encode (mutateApp transform (Aeson.toJSON (manifest [command]))))+        rejected result = result `shouldSatisfy` either (const True) (const False)+    it "roundtrips resolved setup with no completion receipts" $ do+      manifestFromJSON (manifestToJSON (manifest [command])) `shouldBe` Right (manifest [command])+    it "requires a list at schema 10, even when empty" $ do+      rejected (decoded (KeyMap.delete "checkoutCommands"))+      rejected (decoded (KeyMap.insert "checkoutCommands" Aeson.Null))+    it "refuses unknown kinds, missing fields, owners, duplicate identities and duplicate applications" $ do+      let wire = KeyMap.fromList [("kind", Aeson.String "shell"), ("module", Aeson.String "demo"), ("occurrence", Aeson.toJSON (0 :: Int)), ("command", Aeson.String "echo setup"), ("workDir", Aeson.Null)]+      forM_ [KeyMap.insert "kind" (Aeson.String "unknown") wire, KeyMap.delete "workDir" wire, KeyMap.insert "module" (Aeson.String "missing") wire, KeyMap.insert "occurrence" (Aeson.toJSON (-1 :: Int)) wire] $ \bad -> rejected (decoded (KeyMap.insert "checkoutCommands" (Aeson.toJSON [Aeson.Object bad])))+      rejected (manifestFromJSON (manifestToJSON (manifest [command, command])))+      rejected (manifestFromJSON (manifestToJSON (manifest [] & #applications .~ [application [], application []])))+    it "keeps legacy encodings empty and reports downgrade loss" $ do+      let old = manifest [] & #version .~ ManifestSchemaVersion 9+      manifestFromJSON (manifestToJSON old) `shouldBe` Right old+      LBS8.unpack (manifestToJSON old) `shouldNotSatisfy` isInfixOf "checkoutCommands"+      manifestEncodingLoss (manifest [command] & #version .~ ManifestSchemaVersion 9) `shouldSatisfy` (not . null)+      let smuggled = mutateApp (KeyMap.insert "checkoutCommands" (Aeson.toJSON [Aeson.object ["kind" Aeson..= ("shell" :: T.Text)]])) (Aeson.toJSON old)+      rejected (manifestFromJSON (Aeson.encode smuggled))+   describe "emptyManifest" $ do     it "creates a manifest with the current version" $ do       let m = emptyManifest fixedTime@@ -486,6 +517,7 @@                     AppliedInstanceState (ModuleName "link-skill") pv2 (LocalOrigin "link-skill") (Just "1") (Map.singleton (VarName "skill.name") "master-plan")                   ],                 commandReceipts = Map.singleton fingerprint receipt,+                checkoutCommands = [],                 appliedAt = fixedTime               }           application2 =@@ -499,6 +531,7 @@                 context = Nothing,                 instances = [],                 commandReceipts = Map.empty,+                checkoutCommands = [],                 appliedAt = fixedTime2               }           fileRecord =@@ -668,6 +701,7 @@                 context = Nothing,                 instances = [],                 commandReceipts = Map.empty,+                checkoutCommands = [],                 appliedAt = fixedTime               }           fileRecord = FileRecord (SHA256 "hash") "base" Template fixedTime Nothing mempty SharedWriteUnknown

@@ -7,6 +7,7 @@ import Data.Aeson.KeyMap qualified as KeyMap import Data.Generics.Labels () import Data.Map.Strict qualified as Map+import Data.Set qualified as Set import Data.Text qualified as T import Seihou.Core.Types import Seihou.Manifest.Types@@ -97,6 +98,61 @@       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 10 -> 11 seed ownership step" $ do+    let legacy apps extra =+          Aeson.object+            ( [ "module" Aeson..= ("first" :: String),+                "applications" Aeson..= apps,+                "outcome" Aeson..= ("created" :: String),+                "settledAt" Aeson..= ("2026-03-01T10:30:00Z" :: String)+              ]+                <> extra+            )+        document receipt = case upgradeDocumentLosslessly (v 10) schema6Document of+          Right (_, Aeson.Object top) -> Aeson.Object (KeyMap.insert "seeds" (Aeson.object ["CHANGELOG.md" Aeson..= receipt]) top)+          _ -> error "invalid fixture"+    it "preserves application-only uncertainty and unknown fields losslessly" $ do+      let old = document (legacy (["a", "b"] :: [String]) ["futureKey" Aeson..= True])+      Right (steps, upgraded) <- pure (upgradeDocumentLosslessly (v 11) old)+      map (^. #action) steps `shouldBe` [MakeSeedOwnershipExplicit]+      map (upgradeStepKind . (^. #action)) steps `shouldBe` [LosslessUpgrade]+      case upgraded of+        Aeson.Object top -> do+          KeyMap.lookup "producerOwned" top `shouldBe` Just (Aeson.object ["keep" Aeson..= True])+          KeyMap.lookup "checkoutOutputs" top `shouldBe` Just (Aeson.object [])+          case KeyMap.lookup "seeds" top of+            Just (Aeson.Object seeds) -> case KeyMap.lookup "CHANGELOG.md" seeds of+              Just (Aeson.Object receipt) -> do+                KeyMap.lookup "applications" receipt `shouldBe` Nothing+                KeyMap.lookup "futureKey" receipt `shouldBe` Just (Aeson.Bool True)+                KeyMap.lookup "ownership" receipt `shouldBe` Just (Aeson.object ["kind" Aeson..= ("legacy-applications" :: String), "applications" Aeson..= (["a", "b"] :: [String])])+              _ -> expectationFailure "missing receipt"+            _ -> expectationFailure "missing seeds"+        _ -> expectationFailure "not an object"+      Right decoded <- pure (manifestFromJSON (Aeson.encode upgraded))+      fmap (^. #ownership) (Map.lookup "CHANGELOG.md" (decoded ^. #seeds)) `shouldBe` Just (LegacySeedOwners (Set.fromList [ApplicationId "a", ApplicationId "b"]))+      manifestFromJSON (manifestToJSON decoded) `shouldBe` Right decoded+    it "preserves the old representation on every supported seed schema" $+      forM_ [8, 9, 10] $ \version -> do+        let old = setDocumentSchemaVersion (v version) (document (legacy (["a"] :: [String]) []))+        Right decoded <- pure (manifestFromJSON (Aeson.encode old))+        manifestFromJSON (manifestToJSON decoded) `shouldBe` Right decoded+        fmap (^. #ownership) (Map.lookup "CHANGELOG.md" (decoded ^. #seeds)) `shouldBe` Just (LegacySeedOwners (Set.singleton (ApplicationId "a")))+    it "rejects malformed legacy owners without stamping" $+      forM_ [Aeson.Bool True, Aeson.String "a", Aeson.toJSON [False]] $ \apps ->+        upgradeDocumentLosslessly (v 11) (document (legacy apps [])) `shouldSatisfy` either (const True) (const False)+    it "rejects unknown ownership kinds and duplicate authoritative fields" $ do+      let malformed = [Aeson.object ["kind" Aeson..= ("future" :: String)], Aeson.object ["kind" Aeson..= ("instances" :: String), "owners" Aeson..= True]]+      forM_ malformed $ \ownership -> do+        let raw = setDocumentSchemaVersion (v 11) (document (legacy (["a"] :: [String]) ["ownership" Aeson..= ownership]))+        manifestFromJSON (Aeson.encode raw) `shouldSatisfy` either (const True) (const False)++    it "requires valid tagged ownership without relying on duplicate field rejection" $ do+      let receipt ownership = Aeson.object ["module" Aeson..= ("first" :: String), "outcome" Aeson..= ("created" :: String), "settledAt" Aeson..= ("2026-03-01T10:30:00Z" :: String), "ownership" Aeson..= ownership]+          malformed = [Aeson.object ["kind" Aeson..= ("future" :: String)], Aeson.object ["kind" Aeson..= ("instances" :: String), "owners" Aeson..= True], Aeson.object ["kind" Aeson..= ("instances" :: String), "owners" Aeson..= Aeson.object []], Aeson.object ["kind" Aeson..= ("instances" :: String), "owners" Aeson..= Aeson.object ["a" Aeson..= (["x", "x"] :: [String])]]]+      forM_ malformed $ \ownership ->+        manifestFromJSON (Aeson.encode (setDocumentSchemaVersion (v 11) (document (receipt ownership)))) `shouldSatisfy` either (const True) (const False)    describe "the 7 -> 8 step" $ do     it "preserves unrelated raw fields and adds seed receipts" $ do

@@ -0,0 +1,62 @@+{-# LANGUAGE ImportQualifiedPost #-}++-- Run with: runghc -XGHC2024 -iseihou-core/src seihou-core/test/native/SeedExclusive.hs+-- Uses only GHC boot libraries, so the exact native implementation can also be+-- tested in a clean Linux compiler container without the application dependency graph.+import Control.Concurrent (forkIO, newEmptyMVar, putMVar, takeMVar)+import Control.Exception (bracket)+import Control.Monad (forM, forM_, unless)+import Data.ByteString.Char8 qualified as BS+import Seihou.Filesystem.Exclusive+import System.Directory qualified as D+import System.FilePath ((</>))+import System.IO (hClose, openBinaryTempFile)+import System.Posix.Files qualified as Posix++check condition message = unless condition (ioError (userError message))++main :: IO ()+main = bracket setup D.removeDirectoryRecursive $ \root -> do+  let path = root </> "seed"+      publish text = createFileExclusiveWith (\handle -> BS.hPutStr handle (BS.pack text)) path+  publish "complete bytes\n" >>= \result -> check (result == ExclusiveCreated) "initial creation failed"+  publish "replacement" >>= \result -> check (result == ExclusiveOccupied) "replaced an existing file"+  BS.readFile path >>= \bytes -> check (bytes == BS.pack "complete bytes\n") "changed project bytes"+  D.removeFile path+  D.createFileLink "missing" path+  publish "replacement" >>= \result -> check (result == ExclusiveOccupied) "replaced a dangling symlink"+  D.getSymbolicLinkTarget path >>= \target -> check (target == "missing") "changed link target"+  D.removeFile path+  D.createDirectory path+  publish "replacement" >>= \result -> check (result == ExclusiveOccupied) "replaced a directory"+  D.removeDirectory path+  failed <- createFileExclusiveWith (\handle -> BS.hPutStr handle (BS.pack "partial") >> ioError (userError "injected write failure")) path+  check (case failed of ExclusiveFailure _ -> True; _ -> False) "partial failure was not reported"+  D.listDirectory root >>= \names -> check (null names) "partial write left a public or private entry"+  forM_ [1 .. 10 :: Int] $ \_ -> do+    results <- forM [1 .. 8 :: Int] $ \n -> do+      completed <- newEmptyMVar+      _ <- forkIO (publish (show n) >>= putMVar completed)+      pure completed+    outcomes <- mapM takeMVar results+    check (length (filter (== ExclusiveCreated) outcomes) == 1) "concurrent publication had multiple or no winners"+    check (length (filter (== ExclusiveOccupied) outcomes) == 7) "concurrent publication reported an unexpected error"+    D.removeFile path+  let anchor = root </> "private-anchor"+  (anchored, identity) <- createFileExclusiveAnchored (Just anchor) (\handle -> BS.hPutStr handle (BS.pack "same bytes")) path+  check (anchored == ExclusiveCreated) "anchored publication failed"+  status <- Posix.getFileStatus anchor+  check (identity == Just (fromIntegral (Posix.deviceID status), fromIntegral (Posix.fileID status))) "anchor does not retain creation identity"+  D.removeFile path+  BS.writeFile path (BS.pack "same bytes")+  replacement <- Posix.getFileStatus path+  check (Posix.fileID replacement /= Posix.fileID status) "identical replacement reused the anchored inode"+  putStrLn "Native exclusive seed creation passed: complete bytes, occupied paths, partial failure and concurrent creators."+  where+    setup = do+      tmp <- D.getTemporaryDirectory+      (path, handle) <- openBinaryTempFile tmp "seed-exclusive-native"+      hClose handle+      D.removeFile path+      D.createDirectory path+      pure path