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.14.0.0 +version: 0.15.0.0 synopsis: Core library for Seihou project scaffolding description: Core library for Seihou, a composable project scaffolding system. 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 @@ -15,6 +15,7 @@ import Data.Text qualified as T import Data.Time (UTCTime) import Seihou.Composition.Instance (ModuleInstance (..)) +import Seihou.Core.Expr (settleRemovalConditions) import Seihou.Core.Types import Seihou.Manifest.Hash (hashContent) @@ -77,7 +78,8 @@ parentVars = inst ^. #parentVars, origin = origin, moduleVersion = modul ^. #version, - resolvedVars = Map.map (varValueToText . (^. #value)) (Map.findWithDefault Map.empty inst resolved) + resolvedVars = Map.map (varValueToText . (^. #value)) (Map.findWithDefault Map.empty inst resolved), + removalPolicy = settleRemovalConditions (Map.map (^. #value) (Map.findWithDefault Map.empty inst resolved)) <$> modul ^. #removal } -- | Replace an existing application in place, or append a newly-applied one. diff --git a/src/Seihou/Core/Expr.hs b/src/Seihou/Core/Expr.hs --- a/src/Seihou/Core/Expr.hs +++ b/src/Seihou/Core/Expr.hs @@ -2,11 +2,13 @@ ( parseExpr, renderExpr, evalExpr, + settleRemovalConditions, exprRefs, ) where import Data.Char (isDigit) +import Data.Generics.Labels () import Data.Map.Strict qualified as Map import Data.Text qualified as T import Seihou.Core.Types @@ -97,6 +99,11 @@ go (ExprNot e) = not (go e) go (ExprIsSet name) = Map.member name vars go (ExprLit b) = b + +-- | Capture the policy while resolved values still retain their declared types. +-- Persist literals, never reinterpret flattened text during a later removal. +settleRemovalConditions :: Map VarName VarValue -> Removal -> Removal +settleRemovalConditions variables spec = spec & #steps %~ map (\step -> step & #condition %~ fmap (ExprLit . evalExpr variables)) -- | Collect the variables an expression references, paired with the literal -- each is compared against via 'Eq' (if any). 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 @@ -301,7 +301,8 @@ data RemovalStep = RemovalStep { action :: !RemovalAction, dest :: !Text, - src :: !(Maybe FilePath) + src :: !(Maybe FilePath), + condition :: !(Maybe Expr) } deriving stock (Eq, Show, Generic) @@ -630,6 +631,7 @@ | SeedReceipts | RecipeInputs | RecipeInheritance + | ConditionalRemovalPolicies | SeedOwnerClaims | CheckoutLocalOutputs | CheckoutLocalCommands @@ -768,7 +770,8 @@ parentVars :: !ParentVars, origin :: !ArtifactOrigin, moduleVersion :: !(Maybe Text), - resolvedVars :: !(Map VarName Text) + resolvedVars :: !(Map VarName Text), + removalPolicy :: !(Maybe Removal) } deriving stock (Eq, Show, Generic) 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 @@ -104,6 +104,7 @@ 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 -> evaluate (c ^. #lifecycle) >> mapM_ evaluate (c ^. #condition)) ((m ^. #commands) <> concatMap (^. #commands) (m ^. #removal)) + mapM_ (\s -> evaluate (s ^. #condition)) (concatMap (^. #steps) (m ^. #removal)) mapM_ (\p -> evaluate (p ^. #condition)) (m ^. #prompts) pure m Failure e -> throwIO e @@ -514,12 +515,14 @@ -- | Decoder for RemovalStep from a Dhall record. removalStepDecoder :: Decoder RemovalStep removalStepDecoder = - record - ( RemovalStep - <$> field "action" removalActionDecoder - <*> field "dest" strictText - <*> field "src" (maybe string) - ) + withDefaults [("when", noneText)] $ + record + ( RemovalStep + <$> field "action" removalActionDecoder + <*> field "dest" strictText + <*> field "src" (maybe string) + <*> (parseWhen <$> field "when" (maybe strictText)) + ) -- | Decoder for RemovalAction from a Dhall Text string. -- 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 @@ -10,16 +10,17 @@ selectRecordedRemoval, computeRemovalPlan, executeRemoval, + settleRemovalConditions, buildRemovalOps, executeRemovalOps, ) where -import Control.Monad (foldM) +import Control.Monad (foldM, forM_, unless, when) import Data.Generics.Labels () import Data.List (nub, sortBy) import Data.Map.Strict qualified as Map -import Data.Maybe (listToMaybe, mapMaybe, maybeToList) +import Data.Maybe (isJust, isNothing, listToMaybe, mapMaybe, maybeToList) import Data.Ord (Down (..)) import Data.Set (Set) import Data.Set qualified as Set @@ -27,6 +28,7 @@ import Data.Time (UTCTime) import Seihou.Composition.Instance (ModuleInstance (..), qualifiedName) import Seihou.Core.Checkout +import Seihou.Core.Expr (settleRemovalConditions) import Seihou.Core.Path (pathsHaveConflictingSpelling, validateProjectRelativePath) import Seihou.Core.Seed import Seihou.Core.Types @@ -146,6 +148,17 @@ -- New step-based removal engine -- ============================================================ +settledCondition :: RemovalStep -> Bool +settledCondition step = case step ^. #condition of + Nothing -> True + Just (ExprLit _) -> True + _ -> False + +enabledStep :: RemovalStep -> Bool +enabledStep step = case step ^. #condition of + Just (ExprLit False) -> False + _ -> True + -- | Build a list of removal operations from declared removal steps. -- Classifies remove-file targets by checking the manifest and disk state. buildRemovalOps :: @@ -157,8 +170,10 @@ buildRemovalOps manifest modName removal = do case findApplied manifest modName of Nothing -> pure (Left (ModuleNotApplied modName)) + Just _ | any (not . settledCondition) (removal ^. #steps) -> pure (Left (RemovalUnsafePath "condition" "when" "unsettled removal policy; run an ordinary update with this runtime first")) Just _ -> do - stepResults <- mapM (buildStepOp manifest modName) (removal ^. #steps) + let active = filter enabledStep (removal ^. #steps) + stepResults <- mapM (buildStepOp manifest modName) active let cmdResults = map buildCommandOp (removal ^. #commands) pure $ do stepOps <- sequence stepResults @@ -408,46 +423,66 @@ -- | 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 recorded owning instance in the selected application") - | otherwise -> Right Nothing - [(app, state, qualified)] -> do - let appId = app ^. #applicationId - selected = Map.singleton appId (Set.singleton qualified) - outputs = dropCheckoutOwners selected (manifest ^. #checkoutOutputs) - keepFile record - | record ^. #moduleName /= qualified || not (Set.member appId (record ^. #applicationIds)) = Just record - | otherwise = - let retained = Set.delete appId (record ^. #applicationIds) - in if Set.null retained then Nothing else Just (record & #applicationIds .~ retained) - keepApplication other - | other ^. #applicationId /= appId = Just other - | otherwise = - let retained = filter (\instanceState -> qualifiedName (ModuleInstance (instanceState ^. #name) (instanceState ^. #parentVars)) /= qualified) (other ^. #instances) - in if null retained then Nothing else Just (other & #instances .~ retained & #commandReceipts %~ Map.filter ((/= qualified) . (^. #moduleName)) & #checkoutCommands %~ filter ((/= qualified) . (^. #moduleName))) - applications = mapMaybe keepApplication (manifest ^. #applications) - files = Map.mapMaybe keepFile (manifest ^. #files) - stillNeeded applied = - any (\other -> any (\instanceState -> instanceState ^. #name == applied ^. #name && instanceState ^. #parentVars == applied ^. #parentVars) (other ^. #instances)) applications - || any ((== qualifiedName (ModuleInstance (applied ^. #name) (applied ^. #parentVars))) . (^. #moduleName)) (Map.elems files) - removeSelected applied = applied ^. #name /= state ^. #name || applied ^. #parentVars /= state ^. #parentVars || stillNeeded applied - candidate = manifest & #checkoutOutputs .~ outputs & #applications .~ applications & #files .~ files & #modules %~ filter removeSelected - custom = listToMaybe [spec | applied <- manifest ^. #modules, applied ^. #name == state ^. #name, applied ^. #parentVars == state ^. #parentVars, spec <- maybeToList (applied ^. #removal)] - -- 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])) +selectRecordedRemoval manifest requested selectedApplication = do + case candidates of + [] + | 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 + rootRemoval = app ^. #target == AppliedModuleTarget (state ^. #name) && null (app ^. #additionalModules) + departing = if rootRemoval then Set.fromList [qualifiedName (ModuleInstance (instanceState ^. #name) (instanceState ^. #parentVars)) | instanceState <- app ^. #instances] else Set.singleton qualified + selected = Map.singleton appId departing + outputs = dropCheckoutOwners selected (manifest ^. #checkoutOutputs) + keepFile record + | not (Set.member (record ^. #moduleName) departing) || not (Set.member appId (record ^. #applicationIds)) = Just record + | otherwise = + let retained = Set.delete appId (record ^. #applicationIds) + in if Set.null retained then Nothing else Just (record & #applicationIds .~ retained) + keepApplication other + | other ^. #applicationId /= appId = Just other + | otherwise = + let retained = filter (\instanceState -> not (Set.member (qualifiedName (ModuleInstance (instanceState ^. #name) (instanceState ^. #parentVars))) departing)) (other ^. #instances) + in if null retained then Nothing else Just (other & #instances .~ retained & #commandReceipts %~ Map.filter (not . (`Set.member` departing) . (^. #moduleName)) & #checkoutCommands %~ filter (not . (`Set.member` departing) . (^. #moduleName))) + applications = mapMaybe keepApplication (manifest ^. #applications) + files = Map.mapMaybe keepFile (manifest ^. #files) + stillNeeded applied = + any (\other -> any (\instanceState -> instanceState ^. #name == applied ^. #name && instanceState ^. #parentVars == applied ^. #parentVars) (other ^. #instances)) applications + || any ((== qualifiedName (ModuleInstance (applied ^. #name) (applied ^. #parentVars))) . (^. #moduleName)) (Map.elems files) + removeSelected applied = not (Set.member (qualifiedName (ModuleInstance (applied ^. #name) (applied ^. #parentVars))) departing) || stillNeeded applied + candidate = manifest & #checkoutOutputs .~ outputs & #applications .~ applications & #files .~ files & #modules %~ filter removeSelected + -- The application records dependency order; a shared module summary + -- can move when another root is run and is not an ordering authority. + retiring = [applied | instanceState <- app ^. #instances, applied <- manifest ^. #modules, applied ^. #name == instanceState ^. #name, applied ^. #parentVars == instanceState ^. #parentVars, not (removeSelected applied)] + stateFor applied = listToMaybe [instanceState | instanceState <- app ^. #instances, instanceState ^. #name == applied ^. #name, instanceState ^. #parentVars == applied ^. #parentVars] + recordedSpec applied = case stateFor applied >>= (^. #removalPolicy) of + Just spec -> Just spec + Nothing -> applied ^. #removal + settle spec = spec & #steps %~ map (\step -> step & #condition .~ Nothing) . filter enabledStep + specs = [settle spec | applied <- reverse retiring, spec <- maybeToList (recordedSpec applied)] + custom = if null specs then Nothing else Just (Removal (concatMap (^. #steps) specs) (concatMap (^. #commands) specs)) + forM_ retiring $ \applied -> do + when (maybe True (isNothing . (^. #removalPolicy)) (stateFor applied) && any (any (isJust . (^. #condition)) . (^. #steps)) (applied ^. #removal)) $ + Left (checkoutError "removal_policy_unknown" "this application has no accepted conditional removal policy; run its ordinary update before removing it") + unless (all (all settledCondition . (^. #steps)) (recordedSpec applied)) $ + Left (checkoutError "removal_policy_unsettled" "removal policy has no typed recorded result; run an ordinary update with this runtime first") + when (recordedSpec applied == Nothing && any (\record -> record ^. #moduleName == qualifiedName (ModuleInstance (applied ^. #name) (applied ^. #parentVars)) && Set.member appId (record ^. #applicationIds)) (Map.elems (manifest ^. #files))) $ + Left (checkoutError "remove_managed_policy_required" "an inherited instance owns managed files without a removal specification; add its removal policy before removing this root") + -- Retiring seed-only metadata does not authorize forgetting managed files. + case custom of + Nothing + | any (\record -> Set.member (record ^. #moduleName) departing && 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 + hasConditionalPolicy state = any (any (isJust . (^. #condition)) . (^. #steps)) (state ^. #removalPolicy) || any (\applied -> applied ^. #name == state ^. #name && applied ^. #parentVars == state ^. #parentVars && any (any (isJust . (^. #condition)) . (^. #steps)) (applied ^. #removal)) (manifest ^. #modules) candidates = [ (app, state, qualified) | app <- manifest ^. #applications, @@ -455,5 +490,5 @@ state <- app ^. #instances, let qualified = qualifiedName (ModuleInstance (state ^. #name) (state ^. #parentVars)), requested == qualified || requested == state ^. #name, - 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)) + (app ^. #target == AppliedModuleTarget (state ^. #name) && null (app ^. #additionalModules)) || hasConditionalPolicy state || 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/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 (forM_, unless, when) +import Control.Monad (forM, forM_, unless, when) import Data.Aeson (FromJSON (..), ToJSON (..), (.:), (.=)) import Data.Aeson qualified as Aeson import Data.Aeson.Key qualified as Key @@ -34,6 +34,7 @@ import Seihou.Core.ArtifactIdentity (isMachineLocalOriginUrl, sameArtifactIdentity) import Seihou.Core.Checkout (CheckoutError (..), validateCheckoutRecords) import Seihou.Core.CommandFingerprint (checkoutCommandOperation, fingerprintCommand) +import Seihou.Core.Expr (renderExpr) import Seihou.Core.Module (isValidModuleName) import Seihou.Core.Path (validateCanonicalProjectPath, validateProjectRelativePath) import Seihou.Core.Seed (renderManifestInvariantError, seedApplicationIds, validateManifestInvariants) @@ -82,8 +83,11 @@ -- change advances this number is -- docs/adr/0014-every-semantic-manifest-change-advances-the-schema-version.md. -- Schema 13 records application recipe-chain evidence; null denotes unknown history. +-- Schema 14 records conditional removal policies and single-root closure retirement. +-- Missing removal conditions remain unconditional; 13 -> 14 adds null instance +-- policies where accepted typed evidence is unknown. currentManifestVersion :: ManifestSchemaVersion -currentManifestVersion = ManifestSchemaVersion 13 +currentManifestVersion = ManifestSchemaVersion 14 -- | The oldest schema the ordinary decoder reads. Anything older records -- machine-specific absolute paths and must go through the explicit @@ -99,6 +103,7 @@ minimumManifestVersion SeedReceipts = ManifestSchemaVersion 8 minimumManifestVersion RecipeInputs = ManifestSchemaVersion 12 minimumManifestVersion RecipeInheritance = ManifestSchemaVersion 13 +minimumManifestVersion ConditionalRemovalPolicies = ManifestSchemaVersion 14 minimumManifestVersion SeedOwnerClaims = ManifestSchemaVersion 11 minimumManifestVersion CheckoutLocalOutputs = ManifestSchemaVersion 9 minimumManifestVersion CheckoutLocalCommands = ManifestSchemaVersion 10 @@ -252,6 +257,7 @@ <*> o Aeson..:? "recipe" <*> o Aeson..:? "blueprint" <*> o Aeson..:? "blueprintMigrations" Aeson..!= [] + unless (manifestSupports ConditionalRemovalPolicies manifest || not (hasConditionalRemoval manifest || hasRemovalPolicy manifest)) $ fail "conditional removal policies require manifest schema 14" case validateManifestInvariants manifest of Left err -> fail (T.unpack (renderManifestInvariantError err)) Right () -> case validateCheckoutRecords manifest [] of @@ -359,19 +365,23 @@ legacyLocalOrigin recordedName = fromMaybe (LocalOrigin recordedName) instance ToJSON AppliedInstanceState where - toJSON state = - Aeson.object $ - [ "name" .= (state ^. #name . #unModuleName), - "origin" .= (state ^. #origin), - "resolvedVars" .= varsToJSON (state ^. #resolvedVars) - ] - ++ parentVarsField (state ^. #parentVars) - ++ maybe [] (\v -> ["version" .= v]) (state ^. #moduleVersion) - where - parentVarsField (ParentVars m) - | Map.null m = [] - | otherwise = ["parentVars" .= parentVarsMapToJSON m] + toJSON = instanceToJSON currentManifestVersion +instanceToJSON :: ManifestSchemaVersion -> AppliedInstanceState -> Aeson.Value +instanceToJSON schema state = + Aeson.object $ + [ "name" .= (state ^. #name . #unModuleName), + "origin" .= (state ^. #origin), + "resolvedVars" .= varsToJSON (state ^. #resolvedVars) + ] + ++ ["removalPolicy" .= fmap removalToJSON (state ^. #removalPolicy) | schema >= ManifestSchemaVersion 14] + ++ parentVarsField (state ^. #parentVars) + ++ maybe [] (\v -> ["version" .= v]) (state ^. #moduleVersion) + where + parentVarsField (ParentVars m) + | Map.null m = [] + | otherwise = ["parentVars" .= parentVarsMapToJSON m] + instance FromJSON AppliedInstanceState where parseJSON = Aeson.withObject "AppliedInstanceState" $ \o -> do mParentVars <- o Aeson..:? "parentVars" @@ -384,6 +394,7 @@ <*> o .: "origin" <*> o Aeson..:? "version" <*> (varsFromJSON =<< o Aeson..:? "resolvedVars" Aeson..!= Aeson.object []) + <*> (o Aeson..:? "removalPolicy" >>= traverse parseRemovalJSON) instance ToJSON AppliedComposition where toJSON = applicationToJSON currentManifestVersion @@ -395,7 +406,7 @@ "target" .= (composition ^. #target), "targetOrigin" .= (composition ^. #targetOrigin), "additionalModules" .= map (^. #unModuleName) (composition ^. #additionalModules), - "instances" .= (composition ^. #instances), + "instances" .= map (instanceToJSON schema) (composition ^. #instances), "appliedAt" .= (composition ^. #appliedAt) ] ++ maybe [] (\v -> ["targetVersion" .= v]) (composition ^. #targetVersion) @@ -428,6 +439,11 @@ when (schema < minimumManifestVersion RecipeInheritance) $ do legacyChain <- o Aeson..:? "recipeChain" :: Aeson.Parser (Maybe Aeson.Value) unless (legacyChain == Nothing) (fail "recipe chain requires manifest schema 13") + rawInstances <- o Aeson..:? "instances" Aeson..!= [] + instances <- forM rawInstances $ \value -> do + when (schema >= minimumManifestVersion ConditionalRemovalPolicies) $ + Aeson.withObject "AppliedInstanceState" (\fields -> unless (KM.member "removalPolicy" fields) (fail "schema 14 instance requires removalPolicy (null for unknown legacy policy)")) value + parseJSON value composition <- AppliedComposition <$> (ApplicationId <$> o .: "applicationId") @@ -437,7 +453,7 @@ <*> (map ModuleName <$> o Aeson..:? "additionalModules" Aeson..!= []) <*> o Aeson..:? "namespace" <*> o Aeson..:? "context" - <*> o Aeson..:? "instances" Aeson..!= [] + <*> pure instances <*> (commandReceiptsFromJSON =<< o Aeson..:? "commandReceipts" Aeson..!= Aeson.object []) <*> pure commands <*> (if schema >= ManifestSchemaVersion 12 then traverse varsFromJSON =<< o .: "recipeInputs" else pure Nothing) @@ -645,6 +661,16 @@ m <- parseJSON v :: Aeson.Parser (Map Text Text) pure (Map.mapKeys VarName m) +-- | All accepted policies, including per-application instance receipts. +recordedRemovals :: Manifest -> [Removal] +recordedRemovals manifest = [spec | applied <- manifest ^. #modules, spec <- maybe [] pure (applied ^. #removal)] <> [spec | app <- manifest ^. #applications, state <- app ^. #instances, spec <- maybe [] pure (state ^. #removalPolicy)] + +hasRemovalPolicy :: Manifest -> Bool +hasRemovalPolicy manifest = or [isJust (state ^. #removalPolicy) | app <- manifest ^. #applications, state <- app ^. #instances] + +hasConditionalRemoval :: Manifest -> Bool +hasConditionalRemoval manifest = or [isJust (step ^. #condition) | applied <- manifest ^. #modules, spec <- maybe [] pure (applied ^. #removal), step <- spec ^. #steps] + -- | Encode a Removal to JSON. removalToJSON :: Removal -> Aeson.Value removalToJSON r = @@ -660,6 +686,7 @@ "dest" .= (s ^. #dest) ] ++ maybe [] (\p -> ["src" .= p]) (s ^. #src) + ++ maybe [] (\expr -> ["when" .= case expr of ExprLit value -> Aeson.Bool value; _ -> Aeson.String (renderExpr expr)]) (s ^. #condition) removalActionToText :: RemovalAction -> Text removalActionToText RemoveFileAction = "remove-file" @@ -685,6 +712,7 @@ <$> (parseRemovalActionText =<< o .: "action") <*> o .: "dest" <*> o Aeson..:? "src" + <*> (fmap ExprLit <$> o Aeson..:? "when") parseRemovalActionText :: Text -> Aeson.Parser RemovalAction parseRemovalActionText "remove-file" = pure RemoveFileAction @@ -903,6 +931,9 @@ <> ["recipe inputs require manifest schema 12" | not (manifestSupports RecipeInputs manifest), any (isJust . (^. #recipeInputs)) (manifest ^. #applications)] <> ["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) + <> ["conditional removal policies must record a typed boolean result" | spec <- recordedRemovals manifest, step <- spec ^. #steps, Just expr <- [step ^. #condition], case expr of ExprLit _ -> False; _ -> True] + <> ["instance removal policies require manifest schema 14" | not (manifestSupports ConditionalRemovalPolicies manifest), hasRemovalPolicy manifest] + <> ["conditional removal policies require manifest schema 14" | not (manifestSupports ConditionalRemovalPolicies manifest), hasConditionalRemoval manifest] <> ["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))] 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, forM, unless, when) +import Control.Monad (foldM, forM, forM_, unless, when) import Data.Aeson qualified as Aeson import Data.Aeson.Key qualified as Key import Data.Aeson.KeyMap qualified as KeyMap @@ -60,6 +60,7 @@ | AddEmptySeedReceipts | AddEmptyCheckoutOutputs | AddUnknownRecipeInputs + | IntroduceConditionalRemoval | AddUnknownRecipeChain | MakeSeedOwnershipExplicit | AddEmptyCheckoutCommands @@ -126,7 +127,8 @@ step 9 AddEmptyCheckoutCommands "repeatable checkout commands", step 10 MakeSeedOwnershipExplicit "explicit seed instance ownership", step 11 AddUnknownRecipeInputs "recipe inputs", - step 12 AddUnknownRecipeChain "recipe inheritance provenance" + step 12 AddUnknownRecipeChain "recipe inheritance provenance", + step 13 IntroduceConditionalRemoval "conditional removal policies and recorded root retirement" ] where step from stepAction = @@ -135,6 +137,7 @@ upgradeStepKind :: UpgradeStepAction -> UpgradeStepKind upgradeStepKind AddUnknownRecipeInputs = LosslessUpgrade upgradeStepKind AddUnknownRecipeChain = LosslessUpgrade +upgradeStepKind IntroduceConditionalRemoval = LosslessUpgrade upgradeStepKind StampVersion = LosslessUpgrade upgradeStepKind ConvertMachineLocalPaths = InferenceBearingUpgrade upgradeStepKind MakeSharedWriteEvidenceExplicit = LosslessUpgrade @@ -196,6 +199,9 @@ unless (actual == upgradeStep ^. #fromVersion) $ Left (StepVersionMismatch upgradeStep actual) transformed <- case upgradeStep ^. #action of + IntroduceConditionalRemoval -> do + validateUnconditionalRemovals actual document + addUnknownRemovalPolicies actual document AddUnknownRecipeChain -> case document of Aeson.Object fields -> do apps <- case KeyMap.lookup "applications" fields of @@ -350,3 +356,60 @@ add (Aeson.Object fields) = Aeson.Object (KeyMap.insert "recipeInputs" Aeson.Null fields) add other = other addInputs other = other + +-- Schema 13 has no conditional-removal evidence. Do not legitimize a future field +-- merely by stamping its document with a newer version; preserve all unrelated keys. +validateUnconditionalRemovals :: ManifestSchemaVersion -> Aeson.Value -> Either ManifestUpgradeError () +validateUnconditionalRemovals version = \case + Aeson.Object fields -> do + modules <- values (fromMaybe (Aeson.Array mempty) (KeyMap.lookup "modules" fields)) + forM_ modules $ \case + Aeson.Object modul -> case KeyMap.lookup "removal" modul of + Nothing -> Right () + Just Aeson.Null -> Right () + Just (Aeson.Object removal) -> do + steps <- values (fromMaybe (Aeson.Array mempty) (KeyMap.lookup "steps" removal)) + forM_ steps $ \case + Aeson.Object step -> case KeyMap.lookup "when" step of + Nothing -> Right () + Just Aeson.Null -> Right () + _ -> bad "schema 13 cannot contain conditional removal policies" + _ -> bad "removal step must be an object" + _ -> bad "removal must be an object" + _ -> bad "module must be an object" + _ -> bad "manifest must be an object" + where + bad :: Text -> Either ManifestUpgradeError a + bad = Left . MalformedDocument version + values value = case Aeson.fromJSON value of + Aeson.Success xs -> Right (xs :: [Aeson.Value]) + Aeson.Error err -> bad (T.pack err) + +-- The old reader never accepted typed per-application policy results. Preserve +-- unknown fields and explicitly record that historical evidence is unavailable. +addUnknownRemovalPolicies :: ManifestSchemaVersion -> Aeson.Value -> Either ManifestUpgradeError Aeson.Value +addUnknownRemovalPolicies version (Aeson.Object fields) = case KeyMap.lookup "applications" fields of + Nothing -> Right (Aeson.Object fields) + Just value -> do + apps <- values value + upgraded <- forM apps $ \case + Aeson.Object app -> case KeyMap.lookup "instances" app of + Nothing -> Right (Aeson.Object app) + Just states -> do + instances <- values states + converted <- forM instances $ \case + Aeson.Object state -> case KeyMap.lookup "removalPolicy" state of + Nothing -> Right (Aeson.Object (KeyMap.insert "removalPolicy" Aeson.Null state)) + Just Aeson.Null -> Right (Aeson.Object state) + _ -> bad "schema 13 cannot contain per-application removal policy evidence" + _ -> bad "instance must be an object" + Right (Aeson.Object (KeyMap.insert "instances" (Aeson.toJSON converted) app)) + _ -> bad "application must be an object" + Right (Aeson.Object (KeyMap.insert "applications" (Aeson.toJSON upgraded) fields)) + where + bad :: Text -> Either ManifestUpgradeError a + bad = Left . MalformedDocument version + values value = case Aeson.fromJSON value of + Aeson.Success xs -> Right (xs :: [Aeson.Value]) + Aeson.Error err -> bad (T.pack err) +addUnknownRemovalPolicies version _ = Left (MalformedDocument version "manifest must be an object") 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 @@ -1,6 +1,6 @@ module Seihou.Core.ApplicationSpec (tests) where -import Control.Lens ((&), (?~), (^.)) +import Control.Lens ((&), (.~), (?~), (^.)) import Control.Monad (forM_) import Data.Generics.Labels () import Data.Map.Strict qualified as Map @@ -115,6 +115,17 @@ map (^. #parentVars) (composition ^. #instances) `shouldBe` [pv1, pv2] map (^. #resolvedVars) (composition ^. #instances) `shouldBe` [Map.singleton "skill.name" "exec-plan", Map.singleton "skill.name" "master-plan"] + + it "settles removal while Boolean and text values retain their declared types" $ do + let inst = ModuleInstance "dep" emptyParentVars + condition = ExprEq (VarName "flag") (VBool True) + policy = Removal [RemovalStep RemoveFileAction "starter.txt" Nothing (Just condition)] [] + modul = mkModule "dep" Nothing & #removal .~ Just policy + build value = buildAppliedComposition moduleTarget (LocalOrigin "root") Nothing [] Nothing Nothing [(inst, modul, LocalOrigin "dep")] (Map.singleton inst (Map.singleton "flag" (mkResolved "flag" value))) fixedTime + expected result = [Just (Removal [RemovalStep RemoveFileAction "starter.txt" Nothing (Just (ExprLit result))] [])] + map (^. #removalPolicy) (build (VBool True) ^. #instances) `shouldBe` expected True + map (^. #removalPolicy) (build (VText "true") ^. #instances) `shouldBe` expected False + map (^. #resolvedVars) (build (VBool True) ^. #instances) `shouldBe` map (^. #resolvedVars) (build (VText "true") ^. #instances) it "keeps identity independent of versions, source paths, and resolved values" $ do let inst = ModuleInstance "dep" emptyParentVars 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 @@ -39,7 +39,7 @@ [] Nothing Nothing - [AppliedInstanceState name emptyParentVars (LocalOrigin (name ^. #unModuleName)) Nothing Map.empty | name <- ["demo", "second"]] + [AppliedInstanceState name emptyParentVars (LocalOrigin (name ^. #unModuleName)) Nothing Map.empty Nothing | name <- ["demo", "second"]] Map.empty [] Nothing @@ -123,7 +123,7 @@ checkSeedSteps patched `shouldSatisfy` (not . null) checkSeedSteps (seed & #steps %~ map (#strategy .~ Structured)) `shouldSatisfy` (not . null) checkSeedSteps (seed & #steps %~ (<> map (#lifecycle .~ Managed) (seed ^. #steps))) `shouldSatisfy` (not . null) - checkSeedSteps (seed & #removal ?~ Removal [RemovalStep RemoveFileAction "b" Nothing] []) `shouldSatisfy` (not . null) + checkSeedSteps (seed & #removal ?~ Removal [RemovalStep RemoveFileAction "b" Nothing Nothing] []) `shouldSatisfy` (not . null) TIO.writeFile (dir "module.dhall") (source ", lifecycle = Some \"sede\"") invalid <- evalModuleFromFile (dir "module.dhall") invalid `shouldSatisfy` isLeft 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 [] Nothing Nothing now + app = AppliedComposition (ApplicationId "a") (AppliedModuleTarget "demo") (LocalOrigin "demo") (Just "1") [] Nothing Nothing [AppliedInstanceState "demo" emptyParentVars (LocalOrigin "demo") (Just "1") Map.empty Nothing] Map.empty [] Nothing Nothing 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/RemoveSpec.hs b/test/Seihou/Engine/RemoveSpec.hs --- a/test/Seihou/Engine/RemoveSpec.hs +++ b/test/Seihou/Engine/RemoveSpec.hs @@ -1,6 +1,6 @@ module Seihou.Engine.RemoveSpec (tests) where -import Control.Lens ((&), (.~), (^.)) +import Control.Lens ((%~), (&), (.~), (^.)) import Data.Generics.Labels () import Data.Map.Strict qualified as Map import Data.Set qualified as Set @@ -81,7 +81,7 @@ 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 [] Nothing Nothing fixedTime + app = AppliedComposition appId (AppliedModuleTarget otherMod) (LocalOrigin "test-module") Nothing [] Nothing Nothing [AppliedInstanceState name emptyParentVars (LocalOrigin text) Nothing Map.empty Nothing | (name, text) <- [(modName, "test-module"), (otherMod, "other-module")]] Map.empty [] Nothing Nothing 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 @@ -90,7 +90,7 @@ 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]] [] + let removal = Removal [RemovalStep action "seed.txt" (Just "rewrite.dhall") Nothing | 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 @@ -102,6 +102,60 @@ 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 "recorded root closure and conditional removal" $ do + let appId = ApplicationId "root" + variables = Map.singleton (VarName "base.starters") "false" + rootApp = AppliedComposition appId (AppliedModuleTarget modName) (LocalOrigin "root") Nothing [] Nothing Nothing [AppliedInstanceState name emptyParentVars (LocalOrigin "fixture") Nothing variables (Just (if name == otherMod then settleRemovalConditions (Map.singleton (VarName "base.starters") (VBool False)) baseSpec else rootSpec)) | name <- [otherMod, modName]] Map.empty [] Nothing Nothing fixedTime + baseSpec = Removal [RemovalStep RemoveFileAction "base.txt" Nothing Nothing, RemovalStep RemoveFileAction "package.json" Nothing (Just (ExprEq (VarName "base.starters") (VBool True)))] [] + rootSpec = Removal [RemovalStep RemoveFileAction "client.txt" Nothing Nothing] [] + applied name spec = AppliedModule name emptyParentVars (LocalOrigin "fixture") Nothing fixedTime (Just spec) + file name owners = FileRecord (hashContent "bytes") name Template fixedTime Nothing owners SharedWriteUnknown + manifest = + (emptyManifest fixedTime) + & #applications .~ [rootApp] + & #modules .~ [applied otherMod (settleRemovalConditions (Map.singleton (VarName "base.starters") (VBool False)) baseSpec), applied modName rootSpec] + & #files .~ Map.fromList [("base.txt", file otherMod (Set.singleton appId)), ("client.txt", file modName (Set.singleton appId))] + & #seeds .~ Map.singleton "package.json" (SeedRecord modName (KnownSeedOwners (Map.singleton appId (Set.singleton modName))) SeedCreated fixedTime) + it "retires an unshared inherited closure and uses recorded per-instance conditions" $ do + Right (Just selected) <- pure (selectRecordedRemoval manifest modName Nothing) + selected ^. #candidateManifest . #applications `shouldBe` [] + selected ^. #candidateManifest . #modules `shouldBe` [] + selected ^. #candidateManifest . #files `shouldBe` Map.empty + fmap (map (^. #dest) . (^. #steps)) (selected ^. #removal) `shouldBe` Just ["client.txt", "base.txt"] + it "uses application dependency order when shared module summaries were reordered" $ do + Right (Just selected) <- pure (selectRecordedRemoval (manifest & #modules %~ reverse) modName Nothing) + fmap (map (^. #dest) . (^. #steps)) (selected ^. #removal) `shouldBe` Just ["client.txt", "base.txt"] + it "selects a recorded managed root even without seed or checkout receipts" $ do + Right (Just selected) <- pure (selectRecordedRemoval (manifest & #seeds .~ Map.empty) modName Nothing) + selected ^. #candidateManifest . #applications `shouldBe` [] + selected ^. #candidateManifest . #modules `shouldBe` [] + it "keeps an inherited module claimed by another application" $ do + let otherId = ApplicationId "survivor" + survivor = rootApp & #applicationId .~ otherId & #target .~ AppliedModuleTarget otherMod & #instances %~ filter ((== otherMod) . (^. #name)) + shared = manifest & #applications %~ (<> [survivor]) & #files %~ Map.adjust (\record -> record & #applicationIds %~ Set.insert otherId) "base.txt" + Right (Just selected) <- pure (selectRecordedRemoval shared modName Nothing) + fmap (map (^. #dest) . (^. #steps)) (selected ^. #removal) `shouldBe` Just ["client.txt"] + map (^. #name) (selected ^. #candidateManifest . #modules) `shouldBe` [otherMod] + Map.keys (selected ^. #candidateManifest . #files) `shouldBe` ["base.txt"] + it "uses the departing application's receipt even when a shared module summary differs" $ do + let laterSummary = manifest & #modules %~ map (\entry -> if entry ^. #name == otherMod then entry & #removal .~ Just (settleRemovalConditions (Map.singleton (VarName "base.starters") (VBool True)) baseSpec) else entry) + Right (Just selected) <- pure (selectRecordedRemoval laterSummary modName Nothing) + fmap (map (^. #dest) . (^. #steps)) (selected ^. #removal) `shouldBe` Just ["client.txt", "base.txt"] + it "requires ordinary adoption when a conditional legacy application has no receipt" $ do + let unknown = manifest & #applications %~ map (\app -> app & #instances %~ map (\state -> state & #removalPolicy .~ Nothing)) + selectRecordedRemoval unknown modName Nothing `shouldSatisfy` either (const True) (const False) + it "preserves type-sensitive conditions and refuses unresolved policy" $ do + let fs = mkFS [("package.json", "bytes"), ("base.txt", "bytes")] + legacy = mkManifestWithRemoval baseSpec [("package.json", "bytes"), ("base.txt", "bytes")] + settle value = settleRemovalConditions (Map.singleton (VarName "base.starters") value) baseSpec + Right yes <- pure (runBuildOps fs legacy modName (settle (VBool True))) + Right no <- pure (runBuildOps fs legacy modName (settle (VBool False))) + Right text <- pure (runBuildOps fs legacy modName (settle (VText "true"))) + length (yes ^. #ops) `shouldBe` 2 + length (no ^. #ops) `shouldBe` 1 + length (text ^. #ops) `shouldBe` 1 + runBuildOps fs legacy modName baseSpec `shouldSatisfy` either (const True) (const False) + describe "computeRemovalPlan" $ do it "returns ModuleNotApplied when module is not in manifest" $ do let manifest = emptyManifest fixedTime @@ -227,7 +281,7 @@ result `shouldBe` Left (ModuleNotApplied modName) it "builds DeleteFileOp with RFSafe for unchanged files" $ do - let removal = Removal [RemovalStep RemoveFileAction "README.md" Nothing] [] + let removal = Removal [RemovalStep RemoveFileAction "README.md" Nothing Nothing] [] manifest = mkManifestWithRemoval removal [("README.md", "hello")] fs = mkFS [("README.md", "hello")] result = runBuildOps fs manifest modName removal @@ -236,7 +290,7 @@ Right plan -> (plan ^. #ops) `shouldBe` [DeleteFileOp "README.md" RFSafe] it "builds DeleteFileOp with RFConflict for modified files" $ do - let removal = Removal [RemovalStep RemoveFileAction "README.md" Nothing] [] + let removal = Removal [RemovalStep RemoveFileAction "README.md" Nothing Nothing] [] manifest = mkManifestWithRemoval removal [("README.md", "original")] fs = mkFS [("README.md", "user changed this")] result = runBuildOps fs manifest modName removal @@ -245,7 +299,7 @@ Right plan -> (plan ^. #ops) `shouldBe` [DeleteFileOp "README.md" RFConflict] it "builds DeleteFileOp with RFGone for already-deleted files" $ do - let removal = Removal [RemovalStep RemoveFileAction "README.md" Nothing] [] + let removal = Removal [RemovalStep RemoveFileAction "README.md" Nothing Nothing] [] manifest = mkManifestWithRemoval removal [("README.md", "hello")] result = runBuildOps emptyFS manifest modName removal case result of @@ -253,7 +307,7 @@ Right plan -> (plan ^. #ops) `shouldBe` [DeleteFileOp "README.md" RFGone] it "builds StripSectionOp for remove-section steps" $ do - let removal = Removal [RemovalStep RemoveSectionAction ".gitignore" Nothing] [] + let removal = Removal [RemovalStep RemoveSectionAction ".gitignore" Nothing Nothing] [] manifest = mkManifestWithRemoval removal [(".gitignore", "content")] fs = mkFS [(".gitignore", "content")] result = runBuildOps fs manifest modName removal @@ -270,7 +324,7 @@ Right plan -> (plan ^. #ops) `shouldBe` [RemovalCommandOp "cabal clean" Nothing] it "rejects a removal step destination with a parent directory segment" $ do - let removal = Removal [RemovalStep RemoveFileAction "../outside" Nothing] [] + let removal = Removal [RemovalStep RemoveFileAction "../outside" Nothing Nothing] [] manifest = mkManifestWithRemoval removal [] fs = mkFS [("../outside", "do not delete")] result = runBuildOps fs manifest modName removal @@ -298,7 +352,7 @@ it "combines steps and commands in order" $ do let removal = Removal - [RemovalStep RemoveFileAction "a.txt" Nothing, RemovalStep RemoveSectionAction ".gitignore" Nothing] + [RemovalStep RemoveFileAction "a.txt" Nothing Nothing, RemovalStep RemoveSectionAction ".gitignore" Nothing Nothing] [Command "echo done" Nothing Nothing ApplicationCommand] manifest = mkManifestWithRemoval removal [("a.txt", "aaa")] fs = mkFS [("a.txt", "aaa"), (".gitignore", "stuff")] @@ -313,7 +367,7 @@ describe "executeRemovalOps" $ do it "deletes files with DeleteFileOp" $ do - let removal = Removal [RemovalStep RemoveFileAction "README.md" Nothing] [] + let removal = Removal [RemovalStep RemoveFileAction "README.md" Nothing Nothing] [] manifest = mkManifestWithRemoval removal [("README.md", "hello")] fs = mkFS [("README.md", "hello")] plan = ExecutedRemovalPlan modName [DeleteFileOp "README.md" RFSafe] @@ -321,7 +375,7 @@ Map.member "README.md" (finalFS ^. #files) `shouldBe` False it "preserves files in keep-set for DeleteFileOp" $ do - let removal = Removal [RemovalStep RemoveFileAction "a.txt" Nothing] [] + let removal = Removal [RemovalStep RemoveFileAction "a.txt" Nothing Nothing] [] manifest = mkManifestWithRemoval removal [("a.txt", "aaa")] fs = mkFS [("a.txt", "modified")] plan = ExecutedRemovalPlan modName [DeleteFileOp "a.txt" RFConflict] @@ -356,7 +410,7 @@ Map.lookup "file.txt" (finalFS ^. #files) `shouldBe` Just content it "removes module from manifest after all steps" $ do - let removal = Removal [RemovalStep RemoveFileAction "a.txt" Nothing] [] + let removal = Removal [RemovalStep RemoveFileAction "a.txt" Nothing Nothing] [] manifest = mkManifestWithRemoval removal [("a.txt", "aaa")] fs = mkFS [("a.txt", "aaa")] plan = ExecutedRemovalPlan modName [DeleteFileOp "a.txt" RFSafe] diff --git a/test/Seihou/Engine/SeedTransactionSpec.hs b/test/Seihou/Engine/SeedTransactionSpec.hs --- a/test/Seihou/Engine/SeedTransactionSpec.hs +++ b/test/Seihou/Engine/SeedTransactionSpec.hs @@ -29,7 +29,7 @@ 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 [] Nothing Nothing now + app = AppliedComposition appId (AppliedModuleTarget "seeder") (LocalOrigin "seeder") Nothing [] Nothing Nothing [AppliedInstanceState "seeder" emptyParentVars (LocalOrigin "seeder") Nothing Map.empty Nothing] Map.empty [] Nothing Nothing now manifest = emptyManifest now & #applications .~ [app] claims = Map.singleton appId (Set.singleton "seeder") createAction = SeedAction "seed.txt" "seeder" claims SeedWrite (Just "seed bytes\n") 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 @@ -96,14 +96,16 @@ parentVars = emptyParentVars, origin = ProjectOrigin ".seihou/modules/docs", moduleVersion = Just "0.1.0", - resolvedVars = Map.empty + resolvedVars = Map.empty, + removalPolicy = Nothing }, AppliedInstanceState { name = ModuleName "scratch", parentVars = emptyParentVars, origin = LocalOrigin "scratch", moduleVersion = Nothing, - resolvedVars = Map.empty + resolvedVars = Map.empty, + removalPolicy = Nothing } ], commandReceipts = Map.empty, @@ -137,7 +139,7 @@ removal = Just ( Removal - [RemovalStep RemoveFileAction "flake.nix" (Just "files/flake.nix")] + [RemovalStep RemoveFileAction "flake.nix" (Just "files/flake.nix") (Just (ExprLit True))] [Command "cabal clean" (Just "backend") Nothing ApplicationCommand] ) } @@ -297,7 +299,7 @@ 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 Nothing Nothing fixedTime + application commands = AppliedComposition (ApplicationId "setup") (AppliedModuleTarget "demo") (ProjectOrigin "modules/demo") (Just "1") [] Nothing Nothing [AppliedInstanceState "demo" emptyParentVars (ProjectOrigin "modules/demo") (Just "1") Map.empty Nothing] Map.empty commands Nothing Nothing fixedTime manifest commands = emptyManifest fixedTime & #applications .~ [application commands] mutateApp transform value = case value of Aeson.Object fields -> case KeyMap.lookup "applications" fields of @@ -337,6 +339,40 @@ (m ^. #files) `shouldBe` Map.empty (m ^. #blueprintMigrations) `shouldBe` [] + describe "conditional removal policy codec" $ do + let policy = Removal [RemovalStep RemoveFileAction "package.json" Nothing (Just (ExprLit True))] [] + applied = AppliedModule (ModuleName "base") emptyParentVars (LocalOrigin "base") Nothing fixedTime (Just policy) + manifest = emptyManifest fixedTime & #modules .~ [applied] + it "roundtrips the condition at schema 14" $ + manifestFromJSON (manifestToJSON manifest) `shouldBe` Right manifest + it "roundtrips per-application policy and rejects missing or unresolved accepted evidence" $ do + let state = AppliedInstanceState "base" emptyParentVars (LocalOrigin "base") Nothing Map.empty (Just policy) + app = AppliedComposition (ApplicationId "base") (AppliedModuleTarget "base") (LocalOrigin "base") Nothing [] Nothing Nothing [state] Map.empty [] Nothing Nothing fixedTime + recorded = manifest & #applications .~ [app] + alterInstances f (Aeson.Object fields) = Aeson.Object (update "applications" (mapArray (alterApp f)) fields) + alterInstances _ value = value + mapArray f (Aeson.Array values) = Aeson.Array (fmap f values) + mapArray _ value = value + alterApp f (Aeson.Object fields) = Aeson.Object (update "instances" (mapArray (\case Aeson.Object fields' -> Aeson.Object (f fields'); value -> value)) fields) + alterApp _ value = value + update key f fields = maybe fields (\value -> KeyMap.insert key (f value) fields) (KeyMap.lookup key fields) + withoutPolicy = alterInstances (KeyMap.delete "removalPolicy") (Aeson.toJSON recorded) + unresolved = recorded & #applications %~ map (\entry -> entry & #instances %~ map (\instanceState -> instanceState & #removalPolicy .~ Just (Removal [RemovalStep RemoveFileAction "starter" Nothing (Just (ExprEq "flag" (VBool True)))] []))) + manifestFromJSON (manifestToJSON recorded) `shouldBe` Right recorded + manifestFromJSON (Aeson.encode withoutPolicy) `shouldSatisfy` either (const True) (const False) + manifestEncodingLoss unresolved `shouldSatisfy` (not . null) + manifestFromJSON (manifestToJSON unresolved) `shouldSatisfy` either (const True) (const False) + + it "rejects conditional evidence in an older schema instead of ignoring it" $ do + let old = manifest & #version .~ ManifestSchemaVersion 13 + manifestEncodingLoss old `shouldSatisfy` (not . null) + manifestFromJSON (manifestToJSON old) `shouldSatisfy` either (const True) (const False) + + it "rejects an unresolved expression instead of reinterpreting saved text" $ do + let unresolved = manifest & #modules %~ map (\entry -> entry & #removal %~ fmap (\spec -> spec & #steps %~ map (\step -> step & #condition .~ Just (ExprEq (VarName "base.starters") (VBool True))))) + manifestEncodingLoss unresolved `shouldSatisfy` (not . null) + manifestFromJSON (manifestToJSON unresolved) `shouldSatisfy` either (const True) (const False) + describe "ArtifactOrigin" $ do it "roundtrips a remote origin carrying a repository name" $ do let origin = RemoteOrigin "https://github.com/shinzui/seihou-modules.git" "haskell-base" (Just "seihou-modules") @@ -543,8 +579,8 @@ namespace = Just "planning", context = Just "work", instances = - [ AppliedInstanceState (ModuleName "link-skill") pv1 (LocalOrigin "link-skill") (Just "1") (Map.singleton (VarName "skill.name") "exec-plan"), - AppliedInstanceState (ModuleName "link-skill") pv2 (LocalOrigin "link-skill") (Just "1") (Map.singleton (VarName "skill.name") "master-plan") + [ AppliedInstanceState (ModuleName "link-skill") pv1 (LocalOrigin "link-skill") (Just "1") (Map.singleton (VarName "skill.name") "exec-plan") Nothing, + AppliedInstanceState (ModuleName "link-skill") pv2 (LocalOrigin "link-skill") (Just "1") (Map.singleton (VarName "skill.name") "master-plan") Nothing ], commandReceipts = Map.singleton fingerprint receipt, checkoutCommands = [], 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 @@ -63,6 +63,21 @@ spec :: Spec spec = do + it "upgrades unconditional schema-13 removal without changing producer fields" $ do + let document = Aeson.object ["version" Aeson..= (13 :: Int), "producerField" Aeson..= True, "modules" Aeson..= [Aeson.object ["removal" Aeson..= Aeson.object ["steps" Aeson..= [Aeson.object ["action" Aeson..= ("remove-file" :: String), "dest" Aeson..= ("package.json" :: String)]]]]]] + case upgradeDocumentLosslessly (v 14) document of + Right (_, upgraded) -> upgraded `shouldBe` setDocumentSchemaVersion (v 14) document + Left err -> expectationFailure (show err) + it "adds unknown instance removal evidence losslessly without manufacturing an outcome" $ do + let state = Aeson.object ["producerInstance" Aeson..= True] + document = Aeson.object ["version" Aeson..= (13 :: Int), "applications" Aeson..= [Aeson.object ["instances" Aeson..= [state], "producerApplication" Aeson..= True]]] + expected = Aeson.object ["version" Aeson..= (14 :: Int), "applications" Aeson..= [Aeson.object ["instances" Aeson..= [Aeson.object ["producerInstance" Aeson..= True, "removalPolicy" Aeson..= Aeson.Null]], "producerApplication" Aeson..= True]]] + fmap snd (upgradeDocumentLosslessly (v 14) document) `shouldBe` Right expected + let forged = Aeson.object ["version" Aeson..= (13 :: Int), "applications" Aeson..= [Aeson.object ["instances" Aeson..= [Aeson.object ["removalPolicy" Aeson..= Aeson.object []]]]]] + upgradeDocumentLosslessly (v 14) forged `shouldSatisfy` either (const True) (const False) + it "refuses conditional evidence in a schema-13 document" $ do + let document = Aeson.object ["version" Aeson..= (13 :: Int), "modules" Aeson..= [Aeson.object ["removal" Aeson..= Aeson.object ["steps" Aeson..= [Aeson.object ["when" Aeson..= ("true" :: String)]]]]]] + upgradeDocumentLosslessly (v 14) document `shouldSatisfy` either (const True) (const False) it "upgrades schema 12 with unknown recipe chain history and preserves unknown raw fields" $ do let document = Aeson.object ["version" Aeson..= (12 :: Int), "futureTop" Aeson..= True, "applications" Aeson..= [Aeson.object ["producerOwned" Aeson..= True]]] case upgradeDocumentLosslessly (v 13) document of