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.8.0.0 +version: 0.9.0.0 synopsis: Core library for Seihou project scaffolding description: Core library for Seihou, a composable project scaffolding system. @@ -120,7 +120,7 @@ cryptohash-sha256 >=0.11 && <1, dhall >=1.42 && <2, directory >=1.3 && <2, - effectful-core >=2.4 && <3, + effectful-core >=2.7.1.1 && <3, either >=5 && <6, filepath >=1.4 && <2, generic-lens >=2.2 && <3, @@ -216,7 +216,7 @@ containers >=0.6 && <1, dhall >=1.42 && <2, directory >=1.3 && <2, - effectful-core >=2.4 && <3, + effectful-core >=2.7.1.1 && <3, filepath >=1.4 && <2, generic-lens >=2.2 && <3, hspec >=2.11 && <3, 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 @@ -92,12 +92,25 @@ -- ownership from the prior record and any ownership already on the result. -- The current record's baseline is preserved: EP-65 captures the exact -- post-execution generated content before ownership is attached. +-- +-- @additiveOnly@ can only be weakened here, never strengthened. This run +-- executed only its own application's operations, so its answer covers only +-- its own contributions; when a prior owner survives outside this run, the +-- prior record is the only evidence about that owner's write mode, and a +-- co-owner that rewrites the whole file must keep the path under the +-- ownership closure. This is the @seihou run@ counterpart of the +-- partial-update merge rule in +-- 'Seihou.Engine.UpdateTransaction.prepareCandidateManifest'. attachApplication :: ApplicationId -> Maybe FileRecord -> FileRecord -> FileRecord attachApplication applicationId previous current = current & #applicationIds .~ Set.insert applicationId (Set.union (current ^. #applicationIds) priorApplications) + & #additiveOnly .~ ((current ^. #additiveOnly) && (not partial || priorAdditive)) where priorApplications = maybe Set.empty (^. #applicationIds) previous + retainedOwners = Set.delete applicationId priorApplications + partial = not (Set.null retainedOwners) + priorAdditive = maybe False (^. #additiveOnly) previous varValueToText :: VarValue -> Text varValueToText (VText value) = value 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 @@ -10,6 +10,7 @@ Expr (..), Strategy (..), PatchOp (..), + isAdditivePatchOp, Step (..), Command (..), Dependency (..), @@ -33,6 +34,7 @@ Runnable (..), recipeNameToModuleName, Operation (..), + isAdditiveOperation, ModuleLoadError (..), Manifest (..), ApplicationId (..), @@ -172,6 +174,26 @@ | AppendLineIfAbsent deriving stock (Eq, Show, Generic) +-- | Does this patch operation occupy a slice of the file that no other +-- contributor can disturb? +-- +-- 'AppendLineIfAbsent' filters out lines already present, so it is +-- idempotent and commutative. 'AppendSection' writes a region delimited by +-- the contributing module's own markers, which no other module's region +-- overlaps. Replaying either one on top of a baseline that already holds +-- another owner's content leaves that content byte for byte where it was. +-- +-- 'AppendFile' and 'PrependFile' place bytes relative to whatever is already +-- in the file, so replaying one contributor without the others can reorder +-- the result. They are not additive in this sense. +-- +-- See docs/adr/0012-an-additive-co-write-is-not-a-shared-path-conflict.md. +isAdditivePatchOp :: PatchOp -> Bool +isAdditivePatchOp AppendSection = True +isAdditivePatchOp AppendLineIfAbsent = True +isAdditivePatchOp AppendFile = False +isAdditivePatchOp PrependFile = False + -- | A generation step within a module. data Step = Step { strategy :: !Strategy, @@ -424,6 +446,22 @@ } deriving stock (Eq, Show, Generic) +-- | Does this operation contribute to its destination through an additive, +-- non-overlapping patch? +-- +-- Only a 'PatchFileOp' whose 'PatchOp' satisfies 'isAdditivePatchOp' +-- qualifies. A 'WriteFileOp' or 'CopyFileOp' discards whatever the file +-- already held, so it never does. Operations with no file destination +-- ('CreateDirOp', 'RunCommandOp') are not contributions to a path and +-- answer 'False'; callers group operations by destination first, so they +-- never ask. +isAdditiveOperation :: Operation -> Bool +isAdditiveOperation (PatchFileOp _ _ op' _ _) = isAdditivePatchOp op' +isAdditiveOperation WriteFileOp {} = False +isAdditiveOperation CopyFileOp {} = False +isAdditiveOperation CreateDirOp {} = False +isAdditiveOperation RunCommandOp {} = False + -- | Errors that can occur during module loading and validation. data ModuleLoadError = ModuleNotFound ModuleName [FilePath] @@ -714,7 +752,13 @@ strategy :: !Strategy, generatedAt :: !UTCTime, baseline :: !(Maybe BaselineRef), - applicationIds :: !(Set ApplicationId) + applicationIds :: !(Set ApplicationId), + -- | Does /every/ contribution to this path go through an additive, + -- non-overlapping patch ('isAdditivePatchOp')? When true, reconciling + -- one owner provably cannot disturb another's bytes, so a targeted + -- update need not name every owner. Absent from older manifests, where + -- it decodes as 'False' and the closure keeps being enforced. + additiveOnly :: !Bool } deriving stock (Eq, Show, Generic) 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 @@ -21,6 +21,11 @@ -- (by its qualified name) that produced it. Paths not present in the -- map fall back to the default @moduleName'@ — this preserves single- -- module call-sites and test usage that do not build an ownership map. +-- +-- Each record's @additiveOnly@ is folded across /every/ operation that +-- targets the same destination, so a path a module both writes and patches +-- records 'False'. Only a path reached exclusively through additive patches +-- records 'True'. executePlan :: (Filesystem :> es) => FilePath -> @@ -31,18 +36,36 @@ Eff es (Map FilePath FileRecord) executePlan targetDir ops ownerMap moduleName' now = do let ownerFor dest = Map.findWithDefault moduleName' dest ownerMap - records <- mapM (executeOp targetDir ownerFor now) ops + additiveFor dest = Map.findWithDefault False dest additiveMap + records <- mapM (executeOp targetDir ownerFor additiveFor now) ops pure (Map.fromList [(k, v) | Just (k, v) <- records]) + where + additiveMap = + Map.fromListWith + (&&) + [ (dest, isAdditiveOperation op) + | op <- ops, + Just dest <- [operationDestination op] + ] +-- | The file a generated operation targets, if it targets one at all. +operationDestination :: Operation -> Maybe FilePath +operationDestination (WriteFileOp dest _ _) = Just dest +operationDestination (CopyFileOp _ dest) = Just dest +operationDestination (PatchFileOp dest _ _ _ _) = Just dest +operationDestination CreateDirOp {} = Nothing +operationDestination RunCommandOp {} = Nothing + -- | Execute a single operation and return a FileRecord if a file was written. executeOp :: (Filesystem :> es) => FilePath -> (FilePath -> ModuleName) -> + (FilePath -> Bool) -> UTCTime -> Operation -> Eff es (Maybe (FilePath, FileRecord)) -executeOp targetDir ownerFor now op = case op of +executeOp targetDir ownerFor additiveFor now op = case op of WriteFileOp dest content strat -> do let fullPath = targetDir dest writeFileText fullPath content @@ -53,7 +76,8 @@ strategy = strat, generatedAt = now, baseline = Nothing, - applicationIds = mempty + applicationIds = mempty, + additiveOnly = additiveFor dest } pure (Just (dest, record)) CreateDirOp path -> do @@ -71,7 +95,8 @@ strategy = Copy, generatedAt = now, baseline = Nothing, - applicationIds = mempty + applicationIds = mempty, + additiveOnly = additiveFor dest } pure (Just (dest, record)) RunCommandOp {} -> do @@ -97,7 +122,8 @@ strategy = strat, generatedAt = now, baseline = Nothing, - applicationIds = mempty + applicationIds = mempty, + additiveOnly = additiveFor dest } pure (Just (dest, record)) 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 @@ -53,7 +53,12 @@ generatedContent :: !Text, moduleName :: !ModuleName, strategy :: !Strategy, - applicationIds :: !(Set ApplicationId) + applicationIds :: !(Set ApplicationId), + -- | Does every operation /this run/ contributes to the path go through + -- an additive, non-overlapping patch ('isAdditiveOperation')? This is + -- the candidate's own answer, independent of what the manifest recorded + -- for the owners that are not part of this run. + additiveOnly :: !Bool } deriving stock (Eq, Generic, Show) @@ -252,27 +257,40 @@ directories = Set.fromList [path | CreateDirOp path <- operations] traverse_ validateManagedPath (Map.keys grouped) traverse_ validateManagedPath (Set.toList directories) - traverse_ (validateOwner selected ownerMap manifest) (Map.keys grouped) + traverse_ (validateOwner selected ownerMap manifest) (Map.toList grouped) pure (grouped, directories) +-- | Defence in depth behind the CLI's selection preflight: refuse to write a +-- path an unselected application also owns. +-- +-- A path every owner reaches through an additive, non-overlapping patch is +-- exempt, because replaying one owner's patch on top of the trusted baseline +-- provably leaves the others' bytes where they were. The exemption requires +-- /both/ halves: the manifest's record must say the path was additive-only, +-- and every operation this run contributes to it must still be additive. The +-- second half is what catches a module whose new version changed a shared +-- file from a patch step to a whole-file step — the manifest still says +-- additive, the candidate is not, and the update refuses before writing +-- anything rather than trusting last release's record. +-- +-- See docs/adr/0012-an-additive-co-write-is-not-a-shared-path-conflict.md. validateOwner :: Set ApplicationId -> Map FilePath DesiredFileOwner -> Manifest -> - FilePath -> + (FilePath, [Operation]) -> Either ReconciliationError () -validateOwner selected ownerMap manifest path = case Map.lookup path ownerMap of +validateOwner selected ownerMap manifest (path, pathOperations) = case Map.lookup path ownerMap of Nothing -> Left (MissingDesiredOwner path) Just owner | not ((owner ^. #applicationIds) `Set.isSubsetOf` selected) -> Left (DesiredOwnerOutsideSelection path ((owner ^. #applicationIds) Set.\\ selected)) | otherwise -> case Map.lookup path (manifest ^. #files) of Nothing -> Right () - Just record -> - let unselectedOwners = (record ^. #applicationIds) Set.\\ selected - in if Set.null unselectedOwners - then Right () - else Left (SharedPathRequiresApplications path (record ^. #applicationIds)) + Just record + | Set.null ((record ^. #applicationIds) Set.\\ selected) -> Right () + | record ^. #additiveOnly && all isAdditiveOperation pathOperations -> Right () + | otherwise -> Left (SharedPathRequiresApplications path (record ^. #applicationIds)) validateManagedPath :: FilePath -> Either ReconciliationError () validateManagedPath rawPath = case validateProjectRelativePath (T.pack rawPath) of @@ -355,7 +373,8 @@ generatedContent = generated, moduleName = owner ^. #moduleName, strategy = finalStrategy, - applicationIds = owner ^. #applicationIds + applicationIds = owner ^. #applicationIds, + additiveOnly = all isAdditiveOperation pathOperations } Right DesiredContext 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 @@ -231,25 +231,52 @@ pure (ObservedFile True (Just (hashContent content))) else pure (ObservedFile False Nothing) +-- | Fold the reconciliation result into the manifest's file records. +-- +-- A targeted update plans only the applications it selected, so for a +-- co-owned path the reconciliation result describes a /subset/ of the +-- owners. Everything belonging to an owner outside this update therefore has +-- to survive the write untouched: its ownership, and the recorded facts about +-- the path as a whole. See +-- docs/plans/90-exempt-additive-patch-paths-from-the-shared-ownership-closure.md. prepareCandidateManifest :: UpdateTransaction -> ReconciliationPlan -> Manifest -> IO Manifest prepareCandidateManifest transaction plan manifest = do nextFiles <- foldM applyManifestAction (manifest ^. #files) (Map.toAscList (plan ^. #files)) pure (replaceManifestFiles manifest nextFiles) where + selected = plan ^. #applicationIds applyManifestAction files (path, reconciliation) = case desiredState reconciliation of Just (desired, state) -> do baseline <- writeBaselineBlob (transaction ^. #projectRoot) (state ^. #generatedBaseline) - let record = + let prior = Map.lookup path (manifest ^. #files) + -- Owners this update did not touch. Subtracting the /selection/ + -- rather than the desired set matters: a selected application + -- that stopped writing the path must genuinely lose ownership, + -- while an unselected one must keep it. + retainedOwners = maybe Set.empty (^. #applicationIds) prior Set.\\ selected + partial = not (Set.null retainedOwners) + -- The prior flag summarises every owner, including the ones absent + -- from this run, so a partial update can only weaken it. + priorAdditive = maybe False (^. #additiveOnly) prior + record = FileRecord { hash = state ^. #recordedHash, - moduleName = desired ^. #moduleName, - strategy = desired ^. #strategy, + -- A partial update has no standing to re-credit a path it + -- only partly wrote; keeping the prior attribution also + -- avoids manifest churn between targeted runs. + moduleName = case prior of + Just priorRecord | partial -> priorRecord ^. #moduleName + _ -> desired ^. #moduleName, + strategy = case prior of + Just priorRecord | partial -> priorRecord ^. #strategy + _ -> desired ^. #strategy, generatedAt = manifest ^. #genAt, baseline = Just baseline, - applicationIds = desired ^. #applicationIds + applicationIds = (desired ^. #applicationIds) `Set.union` retainedOwners, + additiveOnly = (desired ^. #additiveOnly) && (not partial || priorAdditive) } pure (Map.insert path record files) - Nothing -> pure (applyOrphanManifestAction (plan ^. #applicationIds) reconciliation files) + Nothing -> pure (applyOrphanManifestAction selected reconciliation files) desiredState :: FileReconciliation -> Maybe (DesiredFile, PlannedFileState) desiredState reconciliation = case reconciliation of @@ -290,7 +317,8 @@ strategy = record ^. #strategy, generatedAt = record ^. #generatedAt, baseline = record ^. #baseline, - applicationIds = owners + applicationIds = owners, + additiveOnly = record ^. #additiveOnly } replaceManifestFiles :: Manifest -> Map FilePath FileRecord -> Manifest 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 @@ -52,6 +52,14 @@ -- (see docs/plans/76-record-portable-artifact-origins-in-the-manifest.md). -- Version-5-and-earlier manifests are not readable directly; see -- docs/plans/79-upgrade-legacy-absolute-path-manifests-in-place.md. +-- +-- Deliberately /not/ bumped from 6 to 7 when 'FileRecord' gained +-- @additiveOnly@. The field is emitted only when true, so a manifest with no +-- additive-only paths is byte-identical to one written before it existed, and +-- a reader that predates it treats every path as requiring the full ownership +-- closure -- the conservative reading. Bumping would make every manifest this +-- release writes unreadable to 0.8.x binaries in exchange for nothing. See +-- docs/plans/90-exempt-additive-patch-paths-from-the-shared-ownership-closure.md. currentManifestVersion :: Int currentManifestVersion = 6 @@ -566,10 +574,19 @@ ] ++ maybe [] (\ref -> ["baseline" .= (ref ^. #unBaselineRef . #unSHA256)]) (fr ^. #baseline) ++ applicationIdsField (fr ^. #applicationIds) + ++ additiveOnlyField (fr ^. #additiveOnly) where applicationIdsField ids | Set.null ids = [] | otherwise = ["applications" .= map (^. #unApplicationId) (Set.toAscList ids)] + -- Emitted only when true, so a manifest with no additive-only paths is + -- byte-identical to one written before the field existed. A reader that + -- predates the field ignores it and keeps enforcing the ownership + -- closure everywhere, which is the conservative behaviour; that is why + -- 'currentManifestVersion' does not move for this field. + additiveOnlyField additive + | additive = ["additiveOnly" .= True] + | otherwise = [] instance FromJSON FileRecord where parseJSON = Aeson.withObject "FileRecord" $ \o -> do @@ -582,6 +599,7 @@ <*> o .: "generatedAt" <*> pure baseline <*> (Set.fromList . map ApplicationId <$> o Aeson..:? "applications" Aeson..!= []) + <*> (o Aeson..:? "additiveOnly" Aeson..!= False) where parseBaselineRef value = case baselineRefFromText value of Just ref -> pure ref 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 @@ -158,8 +158,41 @@ it "unions prior and current ownership and preserves the generated baseline" $ do let priorId = ApplicationId "prior" currentId = ApplicationId "current" - prior = FileRecord (hashContent "old") "module" Template fixedTime Nothing (Set.singleton priorId) - current = FileRecord (hashContent "new") "module" Template fixedTime (Just (BaselineRef (hashContent "generated"))) Set.empty + prior = FileRecord (hashContent "old") "module" Template fixedTime Nothing (Set.singleton priorId) False + current = FileRecord (hashContent "new") "module" Template fixedTime (Just (BaselineRef (hashContent "generated"))) Set.empty False attached = attachApplication currentId (Just prior) current (attached ^. #applicationIds) `shouldBe` Set.fromList [priorId, currentId] (attached ^. #baseline) `shouldBe` Just (BaselineRef (hashContent "generated")) + + it "cannot strengthen additiveOnly while a prior owner survives" $ do + -- This run executed only its own application's operations, so its + -- answer covers only its own contributions. A co-owner that rewrites + -- the whole file must keep the path under the ownership closure. + let priorId = ApplicationId "prior" + currentId = ApplicationId "current" + prior = record (Set.singleton priorId) False + current = record Set.empty True + (attachApplication currentId (Just prior) current ^. #additiveOnly) `shouldBe` False + + it "keeps additiveOnly true when the prior record and this run agree" $ do + let priorId = ApplicationId "prior" + currentId = ApplicationId "current" + (attachApplication currentId (Just (record (Set.singleton priorId) True)) (record Set.empty True) ^. #additiveOnly) + `shouldBe` True + + it "weakens additiveOnly when this run is no longer additive" $ do + let priorId = ApplicationId "prior" + currentId = ApplicationId "current" + (attachApplication currentId (Just (record (Set.singleton priorId) True)) (record Set.empty False) ^. #additiveOnly) + `shouldBe` False + + it "trusts this run's answer when it is the only owner" $ do + let currentId = ApplicationId "current" + prior = record (Set.singleton currentId) False + (attachApplication currentId (Just prior) (record Set.empty True) ^. #additiveOnly) `shouldBe` True + (attachApplication currentId Nothing (record Set.empty True) ^. #additiveOnly) `shouldBe` True + +-- | A file record carrying the given owners and additive-only verdict. +record :: Set.Set ApplicationId -> Bool -> FileRecord +record owners additive = + FileRecord (hashContent "content") "module" Template fixedTime Nothing owners additive 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 @@ -32,7 +32,8 @@ strategy = Template, generatedAt = fixedTime, baseline = Nothing, - applicationIds = mempty + applicationIds = mempty, + additiveOnly = False } runStatus :: PureFS -> Manifest -> [TrackedFile] 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 @@ -33,7 +33,7 @@ (emptyManifest fixedTime) & #modules .~ [AppliedModule (ModuleName "haskell-base") emptyParentVars (LocalOrigin "haskell-base") Nothing fixedTime Nothing] & #vars .~ Map.fromList [(VarName "project.name", "my-app")] - & #files .~ Map.fromList [("README.md", FileRecord (SHA256 "abc123") (ModuleName "haskell-base") Template fixedTime Nothing mempty)] + & #files .~ Map.fromList [("README.md", FileRecord (SHA256 "abc123") (ModuleName "haskell-base") Template fixedTime Nothing mempty False)] spec :: Spec spec = do diff --git a/test/Seihou/Engine/BaselineSpec.hs b/test/Seihou/Engine/BaselineSpec.hs --- a/test/Seihou/Engine/BaselineSpec.hs +++ b/test/Seihou/Engine/BaselineSpec.hs @@ -37,7 +37,8 @@ strategy = Template, generatedAt = fixedTime, baseline = Nothing, - applicationIds = Set.singleton applicationId + applicationIds = Set.singleton applicationId, + additiveOnly = False } initialFS = PureFS (Map.singleton ("/project/" <> path) content) Set.empty ((result, stored), _) = @@ -56,7 +57,7 @@ Map.lookup expectedRef stored `shouldBe` Just content it "returns an error and publishes no reference when a generated file is missing" $ do - let record = FileRecord (hashContent "planned") "module" Template fixedTime Nothing Set.empty + let record = FileRecord (hashContent "planned") "module" Template fixedTime Nothing Set.empty False ((result, stored), _) = runPureEff $ runFilesystemPure (PureFS Map.empty Set.empty) $ @@ -67,7 +68,7 @@ it "stores content that can be read back through the baseline effect" $ do let content = "round trip" - record = FileRecord (hashContent content) "module" Copy fixedTime Nothing Set.empty + record = FileRecord (hashContent content) "module" Copy fixedTime Nothing Set.empty False initialFS = PureFS (Map.singleton "copy.txt" content) Set.empty ((result, readBack), _) = runPureEff $ @@ -86,7 +87,7 @@ it "collects and deduplicates every referenced blob" $ do let first = baselineRefForContent "first" second = baselineRefForContent "second" - mkRecord ref = FileRecord (hashContent "applied") "module" Template fixedTime ref Set.empty + mkRecord ref = FileRecord (hashContent "applied") "module" Template fixedTime ref Set.empty False manifest :: Manifest manifest = ( (emptyManifest fixedTime) diff --git a/test/Seihou/Engine/DiffSpec.hs b/test/Seihou/Engine/DiffSpec.hs --- a/test/Seihou/Engine/DiffSpec.hs +++ b/test/Seihou/Engine/DiffSpec.hs @@ -40,7 +40,8 @@ strategy = Template, generatedAt = fixedTime, baseline = Nothing, - applicationIds = mempty + applicationIds = mempty, + additiveOnly = False } -- | Helper to create a manifest with file records (avoids ambiguous record update). @@ -208,7 +209,8 @@ strategy = Template, generatedAt = fixedTime, baseline = Nothing, - applicationIds = mempty + applicationIds = mempty, + additiveOnly = False } manifest = manifestWithFiles (Map.singleton "other.txt" record) planned = [("new.txt", "new content", modName, Nothing)] @@ -237,7 +239,8 @@ strategy = Copy, generatedAt = fixedTime, baseline = Nothing, - applicationIds = mempty + applicationIds = mempty, + additiveOnly = False } manifest = manifestWithFiles @@ -270,7 +273,8 @@ strategy = Template, generatedAt = fixedTime, baseline = Nothing, - applicationIds = mempty + applicationIds = mempty, + additiveOnly = False } manifest = manifestWithFiles (Map.singleton "shared.txt" otherRecord) -- active module wants to write to same path owned by inactive module @@ -293,7 +297,8 @@ strategy = Template, generatedAt = fixedTime, baseline = Nothing, - applicationIds = mempty + applicationIds = mempty, + additiveOnly = False } manifest = manifestWithFiles 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 @@ -176,6 +176,55 @@ let content = (fs ^. #files) Map.! "/project/.gitignore" content `shouldBe` "node_modules/\n.claude/\n" + describe "executePlan additiveOnly" $ do + it "records an additive patch as additive-only" $ do + let ops = [PatchFileOp ".gitignore" "/result\n" AppendLineIfAbsent Template modName] + (records, _) = runExecFS emptyFS ops + ((records Map.! ".gitignore") ^. #additiveOnly) `shouldBe` True + + it "records an appended section as additive-only" $ do + let ops = [PatchFileOp ".gitignore" "/dist\n" AppendSection Template modName] + (records, _) = runExecFS emptyFS ops + ((records Map.! ".gitignore") ^. #additiveOnly) `shouldBe` True + + it "does not record a position-dependent patch as additive-only" $ do + -- AppendFile and PrependFile place bytes relative to whatever is + -- already in the file, so replaying one owner can reorder the result. + let appendOps = [PatchFileOp "notes.md" "tail\n" AppendFile Template modName] + prependOps = [PatchFileOp "notes.md" "head\n" PrependFile Template modName] + ((fst (runExecFS emptyFS appendOps) Map.! "notes.md") ^. #additiveOnly) `shouldBe` False + ((fst (runExecFS emptyFS prependOps) Map.! "notes.md") ^. #additiveOnly) `shouldBe` False + + it "does not record a whole-file write as additive-only" $ do + let ops = [WriteFileOp "README.md" "# Title\n" Template] + (records, _) = runExecFS emptyFS ops + ((records Map.! "README.md") ^. #additiveOnly) `shouldBe` False + + it "does not record a copied file as additive-only" $ do + let initial = PureFS (Map.singleton "/source/file.txt" "copied") mempty + ops = [CopyFileOp "/source/file.txt" "dest.txt"] + (records, _) = runExecFS initial ops + ((records Map.! "dest.txt") ^. #additiveOnly) `shouldBe` False + + it "folds the flag across every operation targeting one destination" $ do + -- A path this module both writes and patches is not additive-only, and + -- the patch arriving last must not hide the write. + let ops = + [ WriteFileOp ".gitignore" "/dist\n" Template, + PatchFileOp ".gitignore" "/result\n" AppendLineIfAbsent Template modName + ] + (records, _) = runExecFS emptyFS ops + ((records Map.! ".gitignore") ^. #additiveOnly) `shouldBe` False + + it "keeps one destination's write mode out of another's record" $ do + let ops = + [ WriteFileOp "README.md" "# Title\n" Template, + PatchFileOp ".gitignore" "/result\n" AppendLineIfAbsent Template modName + ] + (records, _) = runExecFS emptyFS ops + ((records Map.! "README.md") ^. #additiveOnly) `shouldBe` False + ((records Map.! ".gitignore") ^. #additiveOnly) `shouldBe` True + describe "dryRunPlan" $ do it "formats WriteFileOp" $ do let result = dryRunPlan [WriteFileOp "README.md" "content" Template] diff --git a/test/Seihou/Engine/MigrateSpec.hs b/test/Seihou/Engine/MigrateSpec.hs --- a/test/Seihou/Engine/MigrateSpec.hs +++ b/test/Seihou/Engine/MigrateSpec.hs @@ -58,7 +58,7 @@ mkManifest entries = (emptyManifest fixedTime) & #modules .~ [AppliedModule {name = modName, parentVars = emptyParentVars, origin = LocalOrigin "demo", moduleVersion = Just "1.0.0", appliedAt = fixedTime, removal = Nothing}] - & #files .~ Map.fromList [(path, FileRecord {hash = hashContent content, moduleName = modName, strategy = Template, generatedAt = fixedTime, baseline = Nothing, applicationIds = mempty}) | (path, content) <- entries] + & #files .~ Map.fromList [(path, FileRecord {hash = hashContent content, moduleName = modName, strategy = Template, generatedAt = fixedTime, baseline = Nothing, applicationIds = mempty, additiveOnly = False}) | (path, content) <- entries] -- | Build an in-memory filesystem from (path, content) pairs. mkFS :: [(FilePath, Text)] -> PureFS 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 @@ -136,6 +136,88 @@ cleanMerge result `shouldBe` Left (SharedPathRequiresApplications "shared.txt" (Set.singleton appB)) + it "lets a targeted update through an additive-only shared path" $ do + -- Replaying appA's append on top of the trusted baseline leaves appB's + -- lines where they were, so the closure has nothing to protect here. + let baseline = baselineRefForContent "/dist\n/result\n" + prior = additiveRecord "/dist\n/result\n" (Just baseline) [appA, appB] + manifest = withFile ".gitignore" prior empty + result = + planWith + (Map.singleton ".gitignore" "/dist\n/result\n") + Map.empty + (Map.singleton baseline "/dist\n/result\n") + manifest + [appA] + [patch "/dist-newstyle" "mod-a"] + (owners ".gitignore" [appA]) + cleanMerge + case result of + Left err -> expectationFailure ("expected the plan to be accepted, got " <> show err) + Right reconciliation -> do + Map.keys (reconciliation ^. #files) `shouldBe` [".gitignore"] + case (reconciliation ^. #files) Map.! ".gitignore" of + FileUpdate desired _ _ _ -> do + -- appB's line survives the replay byte for byte. + (desired ^. #generatedContent) `shouldBe` "/dist\n/result\n/dist-newstyle\n" + (desired ^. #additiveOnly) `shouldBe` True + other -> expectationFailure ("expected a file update, got " <> show other) + + it "refuses an additive-only shared path when the candidate writes the whole file" $ do + -- The manifest still says additive, but this module's new version + -- replaced its patch step with a whole-file step. The candidate's own + -- operations settle it, before anything is written. + let baseline = baselineRefForContent "/dist\n/result\n" + prior = additiveRecord "/dist\n/result\n" (Just baseline) [appA, appB] + manifest = withFile ".gitignore" prior empty + result = + planWith + (Map.singleton ".gitignore" "/dist\n/result\n") + Map.empty + (Map.singleton baseline "/dist\n/result\n") + manifest + [appA] + [WriteFileOp ".gitignore" "/dist-newstyle\n" Template] + (owners ".gitignore" [appA]) + cleanMerge + result `shouldBe` Left (SharedPathRequiresApplications ".gitignore" (Set.fromList [appA, appB])) + + it "refuses an additive-only shared path when the candidate adds a position-dependent patch" $ do + let baseline = baselineRefForContent "/dist\n/result\n" + prior = additiveRecord "/dist\n/result\n" (Just baseline) [appA, appB] + manifest = withFile ".gitignore" prior empty + result = + planWith + (Map.singleton ".gitignore" "/dist\n/result\n") + Map.empty + (Map.singleton baseline "/dist\n/result\n") + manifest + [appA] + [ patch "/dist-newstyle" "mod-a", + PatchFileOp ".gitignore" "/tail\n" AppendFile Template "mod-a" + ] + (owners ".gitignore" [appA]) + cleanMerge + result `shouldBe` Left (SharedPathRequiresApplications ".gitignore" (Set.fromList [appA, appB])) + + it "refuses a shared path the manifest does not record as additive-only" $ do + -- A manifest written before the field existed reads as False, and must + -- keep requiring every owner regardless of how additive this run is. + let baseline = baselineRefForContent "/dist\n/result\n" + prior = record "/dist\n/result\n" (Just baseline) [appA, appB] + manifest = withFile ".gitignore" prior empty + result = + planWith + (Map.singleton ".gitignore" "/dist\n/result\n") + Map.empty + (Map.singleton baseline "/dist\n/result\n") + manifest + [appA] + [patch "/dist-newstyle" "mod-a"] + (owners ".gitignore" [appA]) + cleanMerge + result `shouldBe` Left (SharedPathRequiresApplications ".gitignore" (Set.fromList [appA, appB])) + it "rejects control paths before reading or planning" $ do let result = planWith @@ -281,7 +363,21 @@ strategy = Template, generatedAt = fixedTime, baseline = baseline, - applicationIds = Set.fromList owners' + applicationIds = Set.fromList owners', + additiveOnly = False + } + +-- | A record for a path every owner reaches through an additive patch. +additiveRecord :: Text -> Maybe BaselineRef -> [ApplicationId] -> FileRecord +additiveRecord content baseline owners' = + FileRecord + { hash = hashContent content, + moduleName = "owner", + strategy = Template, + generatedAt = fixedTime, + baseline = baseline, + applicationIds = Set.fromList owners', + additiveOnly = True } owners :: FilePath -> [ApplicationId] -> Map.Map FilePath DesiredFileOwner 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 @@ -36,14 +36,14 @@ mkManifest isRemovable fileContents = (emptyManifest fixedTime) & #modules .~ [AppliedModule {name = modName, parentVars = emptyParentVars, origin = LocalOrigin "test-module", moduleVersion = Nothing, appliedAt = fixedTime, removal = if isRemovable then Just (Removal [] []) else Nothing}] - & #files .~ Map.fromList [(path, FileRecord {hash = hashContent content, moduleName = modName, strategy = Template, generatedAt = fixedTime, baseline = Nothing, applicationIds = mempty}) | (path, content) <- fileContents] + & #files .~ Map.fromList [(path, FileRecord {hash = hashContent content, moduleName = modName, strategy = Template, generatedAt = fixedTime, baseline = Nothing, applicationIds = mempty, additiveOnly = False}) | (path, content) <- fileContents] -- | Helper: create a manifest with a specific removal spec. mkManifestWithRemoval :: Removal -> [(FilePath, Text)] -> Manifest mkManifestWithRemoval removal fileContents = (emptyManifest fixedTime) & #modules .~ [AppliedModule {name = modName, parentVars = emptyParentVars, origin = LocalOrigin "test-module", moduleVersion = Nothing, appliedAt = fixedTime, removal = Just removal}] - & #files .~ Map.fromList [(path, FileRecord {hash = hashContent content, moduleName = modName, strategy = Template, generatedAt = fixedTime, baseline = Nothing, applicationIds = mempty}) | (path, content) <- fileContents] + & #files .~ Map.fromList [(path, FileRecord {hash = hashContent content, moduleName = modName, strategy = Template, generatedAt = fixedTime, baseline = Nothing, applicationIds = mempty, additiveOnly = False}) | (path, content) <- fileContents] -- | Helper: create a PureFS with files. mkFS :: [(FilePath, Text)] -> PureFS @@ -158,7 +158,7 @@ it "preserves files from other modules in manifest" $ do let base = mkManifest True [("mine.txt", "mine")] - otherRec = FileRecord (hashContent "other") otherMod Template fixedTime Nothing mempty + otherRec = FileRecord (hashContent "other") otherMod Template fixedTime Nothing mempty False manifest = Manifest { version = base ^. #version, @@ -341,7 +341,7 @@ it "preserves other modules' files in manifest" $ do let base = mkManifest True [("mine.txt", "mine")] - otherRec = FileRecord (hashContent "other") otherMod Template fixedTime Nothing mempty + otherRec = FileRecord (hashContent "other") otherMod Template fixedTime Nothing mempty False manifest = Manifest { version = base ^. #version, diff --git a/test/Seihou/Engine/UpdateTransactionSpec.hs b/test/Seihou/Engine/UpdateTransactionSpec.hs --- a/test/Seihou/Engine/UpdateTransactionSpec.hs +++ b/test/Seihou/Engine/UpdateTransactionSpec.hs @@ -1,7 +1,7 @@ module Seihou.Engine.UpdateTransactionSpec (tests) where import Control.Exception (throwIO) -import Control.Lens ((^.)) +import Control.Lens ((&), (.~), (^.)) import Control.Monad (unless, when) import Data.ByteString.Lazy qualified as LBS import Data.Foldable (traverse_) @@ -187,6 +187,75 @@ readProject projectRoot "file.txt" `shouldReturn` "user\n" Directory.doesDirectoryExist (transaction ^. #transactionDirectory) `shouldReturn` False + describe "partial update of a co-owned path" $ do + -- A targeted update plans only the applications it selected, so for a + -- co-owned path the reconciliation result describes a subset of the + -- owners. Everything belonging to an unselected owner must survive. + let coOwned additive = + ( ( fileRecord "/dist\n" (Just (baselineRefForContent "/dist\n")) [appA, appB] + & #moduleName + .~ "co-owner" + ) + & #strategy + .~ DhallText + ) + & #additiveOnly + .~ additive + alphaOnly additive = + (desiredFile ".gitignore" "/dist\n/result\n" [appA] & #moduleName .~ "alpha") + & #additiveOnly + .~ additive + runPartial selection prior desired = + withSystemTempDirectory "seihou-update-partial" $ \projectRoot -> do + writeProject projectRoot ".gitignore" "/dist\n" + let state = plannedState "/dist\n/result\n" "/dist\n/result\n" True + plan = + ReconciliationPlan + selection + ( Map.singleton + ".gitignore" + (FileUpdate desired state (observed "/dist\n") (Just prior)) + ) + Set.empty + manifest = manifestWithFiles (Map.singleton ".gitignore" prior) + transaction <- expectRight =<< beginUpdateTransaction projectRoot (Set.singleton ".gitignore") + candidate <- expectRight =<< applyReconciliation transaction plan manifest + pure ((candidate ^. #files) Map.! ".gitignore") + + it "keeps an unselected co-owner in the record" $ do + record <- runPartial (Set.singleton appA) (coOwned True) (alphaOnly True) + (record ^. #applicationIds) `shouldBe` Set.fromList [appA, appB] + + it "keeps the prior attribution when an unselected co-owner survives" $ do + record <- runPartial (Set.singleton appA) (coOwned True) (alphaOnly True) + (record ^. #moduleName) `shouldBe` "co-owner" + (record ^. #strategy) `shouldBe` DhallText + + it "keeps additiveOnly true when both the prior record and the candidate agree" $ do + record <- runPartial (Set.singleton appA) (coOwned True) (alphaOnly True) + (record ^. #additiveOnly) `shouldBe` True + + it "cannot strengthen additiveOnly from a partial update" $ do + -- The prior False may have been set because the unselected co-owner + -- writes the whole file. This run has no evidence about that owner, so + -- flipping the flag open here would let a later update through unsafely. + record <- runPartial (Set.singleton appA) (coOwned False) (alphaOnly True) + (record ^. #additiveOnly) `shouldBe` False + + it "weakens additiveOnly when the candidate is no longer additive" $ do + record <- runPartial (Set.singleton appA) (coOwned True) (alphaOnly False) + (record ^. #additiveOnly) `shouldBe` False + + it "re-credits the path and trusts the candidate once every owner is selected" $ do + -- Subtracting the selection rather than the desired set matters here: + -- appA stopped writing the path but was part of this update, so it + -- genuinely loses ownership and the candidate's own answer stands. + record <- runPartial (Set.fromList [appA, appB]) (coOwned False) (alphaOnly True) + (record ^. #applicationIds) `shouldBe` Set.singleton appA + (record ^. #moduleName) `shouldBe` "alpha" + (record ^. #strategy) `shouldBe` Template + (record ^. #additiveOnly) `shouldBe` True + describe "rollback and recovery" $ do it "rolls every earlier mutation back after an injected failure" $ withSystemTempDirectory "seihou-update-rollback" $ \projectRoot -> do @@ -388,7 +457,8 @@ strategy = Template, generatedAt = fixedTime, baseline = baseline, - applicationIds = Set.fromList owners + applicationIds = Set.fromList owners, + additiveOnly = False } desiredFile :: FilePath -> Text -> [ApplicationId] -> DesiredFile @@ -398,7 +468,8 @@ generatedContent = content, moduleName = "owner", strategy = Template, - applicationIds = Set.fromList owners + applicationIds = Set.fromList owners, + additiveOnly = False } plannedState :: Text -> Text -> Bool -> PlannedFileState 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 @@ -148,6 +148,7 @@ fixedTime (Just (BaselineRef (hashContent "flake"))) (Set.singleton (ApplicationId "app")) + False ) & #applications %~ map (withCommandReceipts (Map.singleton receiptFingerprint receipt)) @@ -351,7 +352,7 @@ let m :: Manifest m = ( (emptyManifest fixedTime) - & #files .~ Map.fromList [("README.md", FileRecord {hash = SHA256 "abc123", moduleName = ModuleName "haskell-base", strategy = Template, generatedAt = fixedTime, baseline = Nothing, applicationIds = mempty}), ("my-app.cabal", FileRecord {hash = SHA256 "def456", moduleName = ModuleName "haskell-base", strategy = DhallText, generatedAt = fixedTime, baseline = Nothing, applicationIds = mempty})] + & #files .~ Map.fromList [("README.md", FileRecord {hash = SHA256 "abc123", moduleName = ModuleName "haskell-base", strategy = Template, generatedAt = fixedTime, baseline = Nothing, applicationIds = mempty, additiveOnly = False}), ("my-app.cabal", FileRecord {hash = SHA256 "def456", moduleName = ModuleName "haskell-base", strategy = DhallText, generatedAt = fixedTime, baseline = Nothing, applicationIds = mempty, additiveOnly = False})] ) manifestFromJSON (manifestToJSON m) `shouldBe` Right m @@ -372,10 +373,10 @@ files = Map.fromList [ ( "README.md", - FileRecord (SHA256 "aaa") (ModuleName "haskell-base") Template fixedTime Nothing mempty + FileRecord (SHA256 "aaa") (ModuleName "haskell-base") Template fixedTime Nothing mempty False ), ( "LICENSE", - FileRecord (SHA256 "bbb") (ModuleName "haskell-base") Copy fixedTime Nothing mempty + FileRecord (SHA256 "bbb") (ModuleName "haskell-base") Copy fixedTime Nothing mempty False ) ], applications = [], @@ -388,7 +389,7 @@ it "roundtrips all strategy types" $ do let strategies = [Copy, Template, DhallText, Structured] makeRecord s = - FileRecord (SHA256 "hash") (ModuleName "mod") s fixedTime Nothing mempty + FileRecord (SHA256 "hash") (ModuleName "mod") s fixedTime Nothing mempty False m :: Manifest m = ( (emptyManifest fixedTime) @@ -501,7 +502,8 @@ strategy = Template, generatedAt = fixedTime, baseline = Just (BaselineRef (hashContent "generated baseline")), - applicationIds = Set.fromList [appId1, appId2] + applicationIds = Set.fromList [appId1, appId2], + additiveOnly = False } manifest = ( (emptyManifest fixedTime) @@ -662,7 +664,7 @@ commandReceipts = Map.empty, appliedAt = fixedTime } - fileRecord = FileRecord (SHA256 "hash") "base" Template fixedTime Nothing mempty + fileRecord = FileRecord (SHA256 "hash") "base" Template fixedTime Nothing mempty False recipe = AppliedRecipe "recipe" (LocalOrigin "recipe") (Just "1.0.0") fixedTime normalBlueprint = AppliedBlueprint "payments" (LocalOrigin "payments") (Just "0.4.0") fixedTime [] False Nothing Nothing seed = @@ -704,6 +706,51 @@ case manifestFromJSON json of Right _ -> expectationFailure "a version-1 manifest should not decode directly" Left err -> err `shouldSatisfy` isInfixOf "seihou manifest upgrade" + + describe "additive-only file records" $ do + let additiveRecord additive = + FileRecord + { hash = SHA256 "aaa", + moduleName = ModuleName "nix-haskell-flake", + strategy = Template, + generatedAt = fixedTime, + baseline = Nothing, + applicationIds = Set.fromList [ApplicationId "app-one", ApplicationId "app-two"], + additiveOnly = additive + } + manifestWith additive = + (emptyManifest fixedTime) & #files .~ Map.singleton ".gitignore" (additiveRecord additive) + recordKeys manifest = case Aeson.decode (manifestToJSON manifest) of + Just (Aeson.Object top) -> case KeyMap.lookup "files" top of + Just (Aeson.Object files) -> case KeyMap.lookup ".gitignore" files of + Just (Aeson.Object record) -> map Key.toText (KeyMap.keys record) + _ -> [] + _ -> [] + _ -> [] + + it "roundtrips a record whose additiveOnly is true" $ do + manifestFromJSON (manifestToJSON (manifestWith True)) `shouldBe` Right (manifestWith True) + + it "roundtrips a record whose additiveOnly is false" $ do + manifestFromJSON (manifestToJSON (manifestWith False)) `shouldBe` Right (manifestWith False) + + it "emits the additiveOnly key only when the flag is true" $ do + recordKeys (manifestWith True) `shouldContain` ["additiveOnly"] + recordKeys (manifestWith False) `shouldNotContain` ["additiveOnly"] + + it "decodes a record with no additiveOnly key as not additive-only" $ do + -- A manifest written before the field existed must keep every shared + -- path under the ownership closure, so the absent key must fail closed. + let json = + "{\"version\":6,\"generatedAt\":\"2026-03-01T10:30:00Z\",\"modules\":[]" + <> ",\"variables\":{},\"applications\":[],\"files\":{\".gitignore\":{\"hash\":\"aaa\"" + <> ",\"module\":\"nix-haskell-flake\",\"strategy\":\"template\"" + <> ",\"generatedAt\":\"2026-03-01T10:30:00Z\"}}}" + case manifestFromJSON json of + Left err -> expectationFailure ("expected the manifest to decode, got: " <> err) + Right decoded -> case Map.lookup ".gitignore" (decoded ^. #files) of + Nothing -> expectationFailure "expected a .gitignore record" + Just decodedRecord -> (decodedRecord ^. #additiveOnly) `shouldBe` False describe "version checking" $ do it "rejects manifests with version higher than current" $ do