diff --git a/seihou-core.cabal b/seihou-core.cabal --- a/seihou-core.cabal +++ b/seihou-core.cabal @@ -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 diff --git a/src/Seihou/Composition/Plan.hs b/src/Seihou/Composition/Plan.hs --- a/src/Seihou/Composition/Plan.hs +++ b/src/Seihou/Composition/Plan.hs @@ -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 diff --git a/src/Seihou/Composition/Resolve.hs b/src/Seihou/Composition/Resolve.hs --- a/src/Seihou/Composition/Resolve.hs +++ b/src/Seihou/Composition/Resolve.hs @@ -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] diff --git a/src/Seihou/Core/Application.hs b/src/Seihou/Core/Application.hs --- a/src/Seihou/Core/Application.hs +++ b/src/Seihou/Core/Application.hs @@ -65,6 +65,7 @@ context = context, instances = map buildInstance modulesInOrder, commandReceipts = Map.empty, + checkoutCommands = [], appliedAt = now } where diff --git a/src/Seihou/Core/ArtifactIdentity.hs b/src/Seihou/Core/ArtifactIdentity.hs --- a/src/Seihou/Core/ArtifactIdentity.hs +++ b/src/Seihou/Core/ArtifactIdentity.hs @@ -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) diff --git a/src/Seihou/Core/CommandFingerprint.hs b/src/Seihou/Core/CommandFingerprint.hs --- a/src/Seihou/Core/CommandFingerprint.hs +++ b/src/Seihou/Core/CommandFingerprint.hs @@ -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 diff --git a/src/Seihou/Core/Module.hs b/src/Seihou/Core/Module.hs --- a/src/Seihou/Core/Module.hs +++ b/src/Seihou/Core/Module.hs @@ -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 ] diff --git a/src/Seihou/Core/Path.hs b/src/Seihou/Core/Path.hs --- a/src/Seihou/Core/Path.hs +++ b/src/Seihou/Core/Path.hs @@ -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 diff --git a/src/Seihou/Core/Seed.hs b/src/Seihou/Core/Seed.hs --- a/src/Seihou/Core/Seed.hs +++ b/src/Seihou/Core/Seed.hs @@ -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 diff --git a/src/Seihou/Core/Types.hs b/src/Seihou/Core/Types.hs --- a/src/Seihou/Core/Types.hs +++ b/src/Seihou/Core/Types.hs @@ -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. diff --git a/src/Seihou/Dhall/Eval.hs b/src/Seihou/Dhall/Eval.hs --- a/src/Seihou/Dhall/Eval.hs +++ b/src/Seihou/Dhall/Eval.hs @@ -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 diff --git a/src/Seihou/Effect/Filesystem.hs b/src/Seihou/Effect/Filesystem.hs --- a/src/Seihou/Effect/Filesystem.hs +++ b/src/Seihou/Effect/Filesystem.hs @@ -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) diff --git a/src/Seihou/Effect/FilesystemInterp.hs b/src/Seihou/Effect/FilesystemInterp.hs --- a/src/Seihou/Effect/FilesystemInterp.hs +++ b/src/Seihou/Effect/FilesystemInterp.hs @@ -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 diff --git a/src/Seihou/Effect/FilesystemPure.hs b/src/Seihou/Effect/FilesystemPure.hs --- a/src/Seihou/Effect/FilesystemPure.hs +++ b/src/Seihou/Effect/FilesystemPure.hs @@ -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 diff --git a/src/Seihou/Effect/ManifestStore.hs b/src/Seihou/Effect/ManifestStore.hs --- a/src/Seihou/Effect/ManifestStore.hs +++ b/src/Seihou/Effect/ManifestStore.hs @@ -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))) diff --git a/src/Seihou/Engine/Execute.hs b/src/Seihou/Engine/Execute.hs --- a/src/Seihou/Engine/Execute.hs +++ b/src/Seihou/Engine/Execute.hs @@ -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 diff --git a/src/Seihou/Engine/Migrate.hs b/src/Seihou/Engine/Migrate.hs --- a/src/Seihou/Engine/Migrate.hs +++ b/src/Seihou/Engine/Migrate.hs @@ -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 () diff --git a/src/Seihou/Engine/Plan.hs b/src/Seihou/Engine/Plan.hs --- a/src/Seihou/Engine/Plan.hs +++ b/src/Seihou/Engine/Plan.hs @@ -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 diff --git a/src/Seihou/Engine/Preview.hs b/src/Seihou/Engine/Preview.hs --- a/src/Seihou/Engine/Preview.hs +++ b/src/Seihou/Engine/Preview.hs @@ -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) = diff --git a/src/Seihou/Engine/Reconcile.hs b/src/Seihou/Engine/Reconcile.hs --- a/src/Seihou/Engine/Reconcile.hs +++ b/src/Seihou/Engine/Reconcile.hs @@ -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)) diff --git a/src/Seihou/Engine/Remove.hs b/src/Seihou/Engine/Remove.hs --- a/src/Seihou/Engine/Remove.hs +++ b/src/Seihou/Engine/Remove.hs @@ -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)) ] diff --git a/src/Seihou/Engine/Seed.hs b/src/Seihou/Engine/Seed.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/Engine/Seed.hs @@ -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" diff --git a/src/Seihou/Engine/UpdateTransaction.hs b/src/Seihou/Engine/UpdateTransaction.hs --- a/src/Seihou/Engine/UpdateTransaction.hs +++ b/src/Seihou/Engine/UpdateTransaction.hs @@ -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) diff --git a/src/Seihou/Filesystem/Exclusive.hs b/src/Seihou/Filesystem/Exclusive.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/Filesystem/Exclusive.hs @@ -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) diff --git a/src/Seihou/Manifest/Types.hs b/src/Seihou/Manifest/Types.hs --- a/src/Seihou/Manifest/Types.hs +++ b/src/Seihou/Manifest/Types.hs @@ -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)) diff --git a/src/Seihou/Manifest/Upgrade.hs b/src/Seihou/Manifest/Upgrade.hs --- a/src/Seihou/Manifest/Upgrade.hs +++ b/src/Seihou/Manifest/Upgrade.hs @@ -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" diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -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]) diff --git a/test/Seihou/Composition/PlanSpec.hs b/test/Seihou/Composition/PlanSpec.hs --- a/test/Seihou/Composition/PlanSpec.hs +++ b/test/Seihou/Composition/PlanSpec.hs @@ -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 diff --git a/test/Seihou/Core/ApplicationSpec.hs b/test/Seihou/Core/ApplicationSpec.hs --- a/test/Seihou/Core/ApplicationSpec.hs +++ b/test/Seihou/Core/ApplicationSpec.hs @@ -69,6 +69,7 @@ context = Nothing, instances = [], commandReceipts = Map.empty, + checkoutCommands = [], appliedAt = fixedTime } diff --git a/test/Seihou/Core/ArtifactIdentitySpec.hs b/test/Seihou/Core/ArtifactIdentitySpec.hs --- a/test/Seihou/Core/ArtifactIdentitySpec.hs +++ b/test/Seihou/Core/ArtifactIdentitySpec.hs @@ -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" diff --git a/test/Seihou/Core/CommandFingerprintSpec.hs b/test/Seihou/Core/CommandFingerprintSpec.hs --- a/test/Seihou/Core/CommandFingerprintSpec.hs +++ b/test/Seihou/Core/CommandFingerprintSpec.hs @@ -16,7 +16,8 @@ { command = command, workDir = workDir, moduleName = moduleName, - occurrence = occurrence + occurrence = occurrence, + lifecycle = ApplicationCommand } spec :: Spec diff --git a/test/Seihou/Core/SeedSpec.hs b/test/Seihou/Core/SeedSpec.hs --- a/test/Seihou/Core/SeedSpec.hs +++ b/test/Seihou/Core/SeedSpec.hs @@ -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") diff --git a/test/Seihou/Core/StatusSpec.hs b/test/Seihou/Core/StatusSpec.hs --- a/test/Seihou/Core/StatusSpec.hs +++ b/test/Seihou/Core/StatusSpec.hs @@ -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" diff --git a/test/Seihou/Core/TypesSpec.hs b/test/Seihou/Core/TypesSpec.hs --- a/test/Seihou/Core/TypesSpec.hs +++ b/test/Seihou/Core/TypesSpec.hs @@ -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 diff --git a/test/Seihou/Dhall/EvalSpec.hs b/test/Seihou/Dhall/EvalSpec.hs --- a/test/Seihou/Dhall/EvalSpec.hs +++ b/test/Seihou/Dhall/EvalSpec.hs @@ -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 diff --git a/test/Seihou/Effect/ManifestStoreSpec.hs b/test/Seihou/Effect/ManifestStoreSpec.hs --- a/test/Seihou/Effect/ManifestStoreSpec.hs +++ b/test/Seihou/Effect/ManifestStoreSpec.hs @@ -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 diff --git a/test/Seihou/Engine/CheckoutSpec.hs b/test/Seihou/Engine/CheckoutSpec.hs --- a/test/Seihou/Engine/CheckoutSpec.hs +++ b/test/Seihou/Engine/CheckoutSpec.hs @@ -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 diff --git a/test/Seihou/Engine/ExecuteSpec.hs b/test/Seihou/Engine/ExecuteSpec.hs --- a/test/Seihou/Engine/ExecuteSpec.hs +++ b/test/Seihou/Engine/ExecuteSpec.hs @@ -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 diff --git a/test/Seihou/Engine/PlanSpec.hs b/test/Seihou/Engine/PlanSpec.hs --- a/test/Seihou/Engine/PlanSpec.hs +++ b/test/Seihou/Engine/PlanSpec.hs @@ -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 = [] diff --git a/test/Seihou/Engine/PreviewSpec.hs b/test/Seihou/Engine/PreviewSpec.hs --- a/test/Seihou/Engine/PreviewSpec.hs +++ b/test/Seihou/Engine/PreviewSpec.hs @@ -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 diff --git a/test/Seihou/Engine/ReconcileSpec.hs b/test/Seihou/Engine/ReconcileSpec.hs --- a/test/Seihou/Engine/ReconcileSpec.hs +++ b/test/Seihou/Engine/ReconcileSpec.hs @@ -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, diff --git a/test/Seihou/Engine/RemoveSpec.hs b/test/Seihou/Engine/RemoveSpec.hs --- a/test/Seihou/Engine/RemoveSpec.hs +++ b/test/Seihou/Engine/RemoveSpec.hs @@ -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 diff --git a/test/Seihou/Engine/SeedSpec.hs b/test/Seihou/Engine/SeedSpec.hs new file mode 100644 --- /dev/null +++ b/test/Seihou/Engine/SeedSpec.hs @@ -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` [] diff --git a/test/Seihou/Engine/SeedTransactionSpec.hs b/test/Seihou/Engine/SeedTransactionSpec.hs new file mode 100644 --- /dev/null +++ b/test/Seihou/Engine/SeedTransactionSpec.hs @@ -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] diff --git a/test/Seihou/Engine/ValidateSpec.hs b/test/Seihou/Engine/ValidateSpec.hs --- a/test/Seihou/Engine/ValidateSpec.hs +++ b/test/Seihou/Engine/ValidateSpec.hs @@ -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 diff --git a/test/Seihou/Integration/CompositionSpec.hs b/test/Seihou/Integration/CompositionSpec.hs --- a/test/Seihou/Integration/CompositionSpec.hs +++ b/test/Seihou/Integration/CompositionSpec.hs @@ -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 diff --git a/test/Seihou/Manifest/TypesSpec.hs b/test/Seihou/Manifest/TypesSpec.hs --- a/test/Seihou/Manifest/TypesSpec.hs +++ b/test/Seihou/Manifest/TypesSpec.hs @@ -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 diff --git a/test/Seihou/Manifest/UpgradeSpec.hs b/test/Seihou/Manifest/UpgradeSpec.hs --- a/test/Seihou/Manifest/UpgradeSpec.hs +++ b/test/Seihou/Manifest/UpgradeSpec.hs @@ -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 diff --git a/test/native/SeedExclusive.hs b/test/native/SeedExclusive.hs new file mode 100644 --- /dev/null +++ b/test/native/SeedExclusive.hs @@ -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