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.12.0.1 +version: 0.12.1.0 synopsis: Core library for Seihou project scaffolding description: Core library for Seihou, a composable project scaffolding system. 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 @@ -9,6 +9,7 @@ setUpdateTransactionExpectedManifest, completeUpdateTransaction, recoverIncompleteTransactions, + setAsideUnreferencedBaselines, trackedLinkIdentity, adoptTrackedLinks, ) @@ -25,6 +26,7 @@ import Data.Generics.Labels () import Data.List (sortOn) import Data.Map.Strict qualified as Map +import Data.Maybe (isJust) import Data.Set qualified as Set import Data.Text qualified as T import Data.Text.Encoding qualified as TE @@ -42,7 +44,7 @@ import Seihou.Engine.Reconcile import Seihou.Engine.Seed (SeedDecision (..)) import Seihou.Filesystem.Exclusive (createFileExclusiveAnchored) -import Seihou.Manifest.Hash (hashContent) +import Seihou.Manifest.Hash (baselineRefFromText, hashContent) import Seihou.Manifest.Types (manifestFromJSON) import Seihou.Prelude import System.Directory qualified as Directory @@ -85,7 +87,15 @@ newDirectories :: ![FilePath], indexLinks :: !(Map FilePath Text), seedCreations :: !(Map FilePath (Maybe (SHA256, Integer, Integer))), - expectedManifest :: !(Maybe Manifest) + expectedManifest :: !(Maybe Manifest), + -- | Bare name, under @backups/@, of a byte copy of @.seihou/manifest.json@ + -- taken when the transaction began. Absent when the project had no + -- manifest then, and for journals older than version 5. + manifestBackup :: !(Maybe FilePath), + -- | Baseline blob names moved from @.seihou/baselines@ into the + -- transaction's @set-aside-baselines/@ folder. Rollback moves them back; + -- completion deletes them with the transaction directory. + setAsideBaselines :: ![FilePath] } deriving stock (Eq, Generic, Show) @@ -127,13 +137,15 @@ "newDirectories" .= (metadata ^. #newDirectories), "indexLinks" .= (metadata ^. #indexLinks), "seedCreations" .= (metadata ^. #seedCreations), - "expectedManifest" .= (metadata ^. #expectedManifest) + "expectedManifest" .= (metadata ^. #expectedManifest), + "manifestBackup" .= (metadata ^. #manifestBackup), + "setAsideBaselines" .= (metadata ^. #setAsideBaselines) ] instance FromJSON JournalMetadata where parseJSON = Aeson.withObject "JournalMetadata" $ \object -> do version <- object .: "version" - unless (version `elem` [1, 2, 3, 4]) (fail "unsupported transaction journal version") + unless (version `elem` [1, 2, 3, 4, 5]) (fail "unsupported transaction journal version") JournalMetadata <$> pure version <*> object .: "createdAt" @@ -142,6 +154,8 @@ <*> (if version < 3 then pure Map.empty else object .: "indexLinks") <*> (if version < 4 then pure Map.empty else object .: "seedCreations") <*> object .:? "expectedManifest" + <*> (if version < 5 then pure Nothing else object .:? "manifestBackup") + <*> (if version < 5 then pure [] else object .: "setAsideBaselines") beginUpdateTransaction :: FilePath -> Set FilePath -> IO (Either TransactionError UpdateTransaction) beginUpdateTransaction root targets = beginSeedUpdateTransaction root targets Set.empty @@ -153,6 +167,7 @@ result <- try @SomeException $ do let transactionsRoot = projectRoot ".seihou" "transactions" Directory.createDirectoryIfMissing True transactionsRoot + ignoreTransactions transactionsRoot transactionDirectory <- createTempDirectory transactionsRoot "update-" let transaction = UpdateTransaction projectRoot transactionDirectory (Set.fromList safeTargets) initializeJournal transaction seedPaths safeTargets `onException` cleanupDirectory transactionDirectory @@ -176,20 +191,48 @@ pure (JournalEntry relativePath (Just backupName) Nothing) EntryMissing -> pure (JournalEntry relativePath Nothing Nothing) EntryDirectory -> ioError (userError ("transaction target is a directory: " <> relativePath)) + -- The manifest is never a target (validateTransactionPath rejects .seihou/), + -- but an orchestrator may publish it before the transaction commits. A byte + -- copy lets rollback and crash recovery return it to this exact state. + verifySafeParents (transaction ^. #projectRoot) manifestRelativePath + manifestEntry <- runEff $ runFilesystem $ inspectPath (transaction ^. #projectRoot manifestRelativePath) + manifestBackup <- case manifestEntry of + EntryFile -> do + BS.readFile (transaction ^. #projectRoot manifestRelativePath) >>= BS.writeFile (backupDirectory manifestBackupName) + pure (Just manifestBackupName) + EntryMissing -> pure Nothing + _ -> ioError (userError ("transaction manifest is not a regular file: " <> manifestRelativePath)) missingDirectories <- missingParentDirectories (transaction ^. #projectRoot) safeTargets now <- getCurrentTime writeJournal (transaction ^. #transactionDirectory) JournalMetadata - { journalVersion = if Set.null seedPaths then 2 else 4, + { journalVersion = 5, createdAt = now, entries = entries, newDirectories = missingDirectories, indexLinks = Map.empty, seedCreations = Map.empty, - expectedManifest = Nothing + expectedManifest = Nothing, + manifestBackup = manifestBackup, + setAsideBaselines = [] } +-- | Transactions are per-checkout recovery scaffolding, never applied state. +-- A self-ignoring @.gitignore@ keeps a module command that snapshots the +-- project (@git add -A@) from committing a transaction in flight. +ignoreTransactions :: FilePath -> IO () +ignoreTransactions transactionsRoot = do + let ignoreFile = transactionsRoot ".gitignore" + exists <- Directory.doesPathExist ignoreFile + unless exists (TIO.writeFile ignoreFile "*\n") + +manifestRelativePath :: FilePath +manifestRelativePath = ".seihou" "manifest.json" + +manifestBackupName :: FilePath +manifestBackupName = "manifest.json" + -- | Only unchanged HEAD/index symlinks with ordinary index flags can be adopted. -- The checkout planner additionally checks path safety and the candidate target. trackedLinkIdentity :: FilePath -> FilePath -> IO (Maybe Text) @@ -502,7 +545,9 @@ Set.fromList (metadata ^. #newDirectories <> additionalDirectories), indexLinks = metadata ^. #indexLinks, seedCreations = metadata ^. #seedCreations, - expectedManifest = Just candidate + expectedManifest = Just candidate, + manifestBackup = metadata ^. #manifestBackup, + setAsideBaselines = metadata ^. #setAsideBaselines } applyMutations :: (Int -> IO ()) -> UpdateTransaction -> ReconciliationPlan -> IO () @@ -587,6 +632,8 @@ _ -> ioError (userError ("seed creation outcome is uncertain: " <> path <> "; preserve the object outside the destination and retry update --dry-run")) restoreIndexLinks (transaction ^. #projectRoot) (metadata ^. #indexLinks) forM_ (filter (\entry -> Map.notMember (entry ^. #targetPath) (metadata ^. #indexLinks)) (metadata ^. #entries)) (restoreEntry transaction) + traverse_ (restoreManifest transaction) (metadata ^. #manifestBackup) + restoreSetAsideBaselines transaction (metadata ^. #setAsideBaselines) removeNewDirectories (transaction ^. #projectRoot) (metadata ^. #newDirectories) cleanupDirectory (transaction ^. #transactionDirectory) pure $ first (TransactionRollbackFailed . exceptionText) result @@ -615,6 +662,79 @@ atomicWriteText target content _ -> when (current == EntryFile) (Directory.removeFile target) +baselinesRelativePath :: FilePath +baselinesRelativePath = ".seihou" "baselines" + +setAsideBaselinesDirectory :: UpdateTransaction -> FilePath +setAsideBaselinesDirectory transaction = transaction ^. #transactionDirectory "set-aside-baselines" + +-- | Move every valid baseline blob that @keep@ does not reference out of +-- @.seihou/baselines@ and into the transaction, so that before the transaction +-- commits the baseline store already holds exactly what the published +-- manifest references. A command that snapshots the project then captures no +-- blob that pruning would delete afterwards. The names are journaled before +-- any blob moves; rollback and crash recovery move them back. +setAsideUnreferencedBaselines :: UpdateTransaction -> Set BaselineRef -> IO (Either TransactionError ()) +setAsideUnreferencedBaselines transaction keep = do + result <- try @SomeException $ do + let root = transaction ^. #projectRoot + baselineDirectory = root baselinesRelativePath + verifySafeParents root (baselinesRelativePath "blob") + exists <- Directory.doesDirectoryExist baselineDirectory + names <- if exists then Directory.listDirectory baselineDirectory else pure [] + removable <- filterMIO (isUnreferencedBlob baselineDirectory) names + unless (null removable) $ do + metadata <- readJournal (transaction ^. #transactionDirectory) >>= either (ioError . userError . show) pure + writeJournal (transaction ^. #transactionDirectory) (metadata & #setAsideBaselines .~ removable) + Directory.createDirectoryIfMissing True (setAsideBaselinesDirectory transaction) + forM_ removable $ \name -> Directory.renamePath (baselineDirectory name) (setAsideBaselinesDirectory transaction name) + pure $ first (\err -> TransactionApplyFailed (exceptionText err) Nothing) result + where + isUnreferencedBlob baselineDirectory name = case baselineRefFromText (T.pack name) of + Nothing -> pure False + Just ref + | Set.member ref keep -> pure False + | otherwise -> do + entry <- runEff $ runFilesystem $ inspectPath (baselineDirectory name) + if entry /= EntryFile + then pure False + else (== ref ^. #unBaselineRef) . hashContent <$> TIO.readFile (baselineDirectory name) + +-- | Move set-aside blobs back. Blobs are content-addressed, so one already +-- present at its name (or one a crash never moved) needs nothing. +restoreSetAsideBaselines :: UpdateTransaction -> [FilePath] -> IO () +restoreSetAsideBaselines transaction names = forM_ names $ \name -> do + let root = transaction ^. #projectRoot + setAside = setAsideBaselinesDirectory transaction name + target = root baselinesRelativePath name + verifySafeParents root (baselinesRelativePath name) + setAsideEntry <- runEff $ runFilesystem $ inspectPath setAside + current <- runEff $ runFilesystem $ inspectPath target + when (setAsideEntry == EntryFile && current == EntryMissing) $ do + Directory.createDirectoryIfMissing True (root baselinesRelativePath) + Directory.renamePath setAside target + +-- | Return @.seihou/manifest.json@ to the bytes it held when the transaction +-- began, through a temporary file renamed over the final path. +restoreManifest :: UpdateTransaction -> FilePath -> IO () +restoreManifest transaction backupName = do + let root = transaction ^. #projectRoot + target = root manifestRelativePath + tempPath = target <> ".tmp" + backupPath = transaction ^. #transactionDirectory "backups" backupName + verifySafeParents root manifestRelativePath + seihouDirectory <- runEff $ runFilesystem $ inspectPath (root ".seihou") + unless (seihouDirectory == EntryDirectory) (ioError (userError "refusing to restore the manifest: .seihou is not a real directory")) + current <- runEff $ runFilesystem $ inspectPath target + case current of + EntryDirectory -> ioError (userError ("refusing to restore the manifest over a directory: " <> target)) + EntrySymlink _ -> Directory.removeDirectoryLink target + _ -> pure () + backupEntry <- runEff $ runFilesystem $ inspectPath backupPath + unless (backupEntry == EntryFile) (ioError (userError "transaction manifest backup is not a real file")) + BS.readFile backupPath >>= BS.writeFile tempPath + Directory.renamePath tempPath target + -- | Recovery must not traverse a substituted parent. Check from the root down. verifySafeParents :: FilePath -> FilePath -> IO () verifySafeParents root path = go (reverse (relativeParents path)) @@ -662,7 +782,9 @@ newDirectories = metadata ^. #newDirectories, indexLinks = metadata ^. #indexLinks, seedCreations = metadata ^. #seedCreations, - expectedManifest = Just expected + expectedManifest = Just expected, + manifestBackup = metadata ^. #manifestBackup, + setAsideBaselines = metadata ^. #setAsideBaselines } result <- try @SomeException (writeJournal (transaction ^. #transactionDirectory) updated) pure $ first (\err -> TransactionApplyFailed (exceptionText err) Nothing) result @@ -748,6 +870,8 @@ (Left "index adoption paths must have journaled symlink snapshots") traverse_ (validateJournalEntry . (^. #targetPath)) (metadata ^. #entries) traverse_ validateBackupName [name | JournalEntry _ (Just name) _ <- metadata ^. #entries] + traverse_ validateBackupName (metadata ^. #manifestBackup) + traverse_ validateBaselineName (metadata ^. #setAsideBaselines) traverse_ (first renderTransactionPathError . validateTransactionPath) (metadata ^. #newDirectories) pure metadata where @@ -758,6 +882,9 @@ validateBackupName name | takeFileName name == name && name /= "." && name /= ".." = Right () | otherwise = Left ("invalid backup filename: " <> T.pack name) + validateBaselineName name + | isJust (baselineRefFromText (T.pack name)) && takeFileName name == name = Right () + | otherwise = Left ("invalid set-aside baseline name: " <> T.pack name) renderTransactionPathError :: TransactionError -> Text renderTransactionPathError (InvalidTransactionPath path reason) = T.pack path <> ": " <> reason 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 @@ -5,6 +5,7 @@ import Control.Monad (unless, when) import Data.Aeson qualified as Aeson import Data.Aeson.KeyMap qualified as KeyMap +import Data.ByteString qualified as BS import Data.ByteString.Lazy qualified as LBS import Data.Foldable (traverse_) import Data.Generics.Labels () @@ -490,6 +491,130 @@ Directory.doesDirectoryExist transactionDirectory `shouldReturn` False Directory.doesDirectoryExist quarantineDirectory `shouldReturn` True + describe "manifest snapshot" $ do + let manifestFile projectRoot = projectRoot ".seihou" "manifest.json" + -- Deliberately not what manifestToJSON would emit, so only a byte copy + -- (never a decode and re-encode) can reproduce it. + unusualBytes = "{\n \"hand\" : \"formatted\"\n}\n\n" :: BS.ByteString + filePlan = + ReconciliationPlan + (Set.singleton appA) + (Map.singleton "file.txt" (FileUpdate (desiredFile "file.txt" "new\n" [appA]) (plannedState "new\n" "new\n" True) (observed "old\n") Nothing)) + Set.empty + prepareProject projectRoot = do + writeProject projectRoot "file.txt" "old\n" + Directory.createDirectoryIfMissing True (projectRoot ".seihou") + BS.writeFile (manifestFile projectRoot) unusualBytes + readJournalObject transaction = do + Right (Aeson.Object object) <- Aeson.eitherDecode <$> LBS.readFile (transaction ^. #transactionDirectory "journal.json") + pure object + + it "journals a byte copy of the manifest in a version-5 journal" $ + withSystemTempDirectory "seihou-update-manifest-journal" $ \projectRoot -> do + prepareProject projectRoot + transaction <- expectRight =<< beginUpdateTransaction projectRoot (Set.singleton "file.txt") + object <- readJournalObject transaction + KeyMap.lookup "version" object `shouldBe` Just (Aeson.Number 5) + KeyMap.lookup "manifestBackup" object `shouldBe` Just (Aeson.String "manifest.json") + BS.readFile (transaction ^. #transactionDirectory "backups" "manifest.json") `shouldReturn` unusualBytes + + it "restores the manifest byte for byte on rollback" $ + withSystemTempDirectory "seihou-update-manifest-rollback" $ \projectRoot -> do + prepareProject projectRoot + transaction <- expectRight =<< beginUpdateTransaction projectRoot (Set.singleton "file.txt") + candidate <- expectRight =<< applyReconciliation transaction filePlan (manifestWithFiles Map.empty) + LBS.writeFile (manifestFile projectRoot) (manifestToJSON candidate) + rollbackUpdateTransaction transaction `shouldReturn` Right () + readProject projectRoot "file.txt" `shouldReturn` "old\n" + BS.readFile (manifestFile projectRoot) `shouldReturn` unusualBytes + Directory.doesDirectoryExist (transaction ^. #transactionDirectory) `shouldReturn` False + + it "restores the manifest when recovering a transaction whose published manifest is not the marker" $ + withSystemTempDirectory "seihou-update-manifest-recover" $ \projectRoot -> do + prepareProject projectRoot + transaction <- expectRight =<< beginUpdateTransaction projectRoot (Set.singleton "file.txt") + candidate <- expectRight =<< applyReconciliation transaction filePlan (manifestWithFiles Map.empty) + -- An orchestrator published a manifest before its commit marker, then crashed. + LBS.writeFile (manifestFile projectRoot) (manifestToJSON (candidate & #vars .~ Map.singleton "published" "early")) + recoverIncompleteTransactions projectRoot `shouldReturn` [Right ()] + readProject projectRoot "file.txt" `shouldReturn` "old\n" + BS.readFile (manifestFile projectRoot) `shouldReturn` unusualBytes + Directory.doesDirectoryExist (transaction ^. #transactionDirectory) `shouldReturn` False + + it "leaves a committed manifest alone" $ + withSystemTempDirectory "seihou-update-manifest-committed" $ \projectRoot -> do + prepareProject projectRoot + transaction <- expectRight =<< beginUpdateTransaction projectRoot (Set.singleton "file.txt") + candidate <- expectRight =<< applyReconciliation transaction filePlan (manifestWithFiles Map.empty) + LBS.writeFile (manifestFile projectRoot) (manifestToJSON candidate) + recoverIncompleteTransactions projectRoot `shouldReturn` [Right ()] + readProject projectRoot "file.txt" `shouldReturn` "new\n" + LBS.readFile (manifestFile projectRoot) `shouldReturn` manifestToJSON candidate + + it "recovers a version-4 journal without a manifest copy as before" $ + withSystemTempDirectory "seihou-update-manifest-v4" $ \projectRoot -> do + prepareProject projectRoot + transaction <- expectRight =<< beginUpdateTransaction projectRoot (Set.singleton "file.txt") + object <- readJournalObject transaction + let legacy = KeyMap.insert "version" (Aeson.Number 4) (KeyMap.delete "manifestBackup" object) + LBS.writeFile (transaction ^. #transactionDirectory "journal.json") (Aeson.encode (Aeson.Object legacy)) + writeProject projectRoot "file.txt" "interrupted\n" + BS.writeFile (manifestFile projectRoot) "{}" + recoverIncompleteTransactions projectRoot `shouldReturn` [Right ()] + readProject projectRoot "file.txt" `shouldReturn` "old\n" + BS.readFile (manifestFile projectRoot) `shouldReturn` "{}" + + describe "set-aside baselines" $ do + let baselineDirectory projectRoot = projectRoot ".seihou" "baselines" + writeBlob projectRoot content = do + let ref = baselineRefForContent content + Directory.createDirectoryIfMissing True (baselineDirectory projectRoot) + TIO.writeFile (baselineDirectory projectRoot refName ref) content + pure ref + blobExists projectRoot ref = Directory.doesFileExist (baselineDirectory projectRoot refName ref) + + it "sets aside only valid unreferenced blobs and moves them back on rollback" $ + withSystemTempDirectory "seihou-update-set-aside-rollback" $ \projectRoot -> do + writeProject projectRoot "file.txt" "old\n" + kept <- writeBlob projectRoot "kept\n" + stale <- writeBlob projectRoot "stale\n" + TIO.writeFile (baselineDirectory projectRoot "not-a-blob") "junk\n" + transaction <- expectRight =<< beginUpdateTransaction projectRoot (Set.singleton "file.txt") + setAsideUnreferencedBaselines transaction (Set.singleton kept) `shouldReturn` Right () + blobExists projectRoot kept `shouldReturn` True + blobExists projectRoot stale `shouldReturn` False + Directory.doesFileExist (baselineDirectory projectRoot "not-a-blob") `shouldReturn` True + rollbackUpdateTransaction transaction `shouldReturn` Right () + blobExists projectRoot stale `shouldReturn` True + TIO.readFile (baselineDirectory projectRoot refName stale) `shouldReturn` "stale\n" + + it "moves set-aside blobs back when recovering an uncommitted transaction" $ + withSystemTempDirectory "seihou-update-set-aside-recover" $ \projectRoot -> do + writeProject projectRoot "file.txt" "old\n" + stale <- writeBlob projectRoot "stale\n" + transaction <- expectRight =<< beginUpdateTransaction projectRoot (Set.singleton "file.txt") + setAsideUnreferencedBaselines transaction Set.empty `shouldReturn` Right () + blobExists projectRoot stale `shouldReturn` False + recoverIncompleteTransactions projectRoot `shouldReturn` [Right ()] + blobExists projectRoot stale `shouldReturn` True + + it "discards set-aside blobs when the transaction completes" $ + withSystemTempDirectory "seihou-update-set-aside-complete" $ \projectRoot -> do + writeProject projectRoot "file.txt" "old\n" + stale <- writeBlob projectRoot "stale\n" + transaction <- expectRight =<< beginUpdateTransaction projectRoot (Set.singleton "file.txt") + setAsideUnreferencedBaselines transaction Set.empty `shouldReturn` Right () + completeUpdateTransaction transaction `shouldReturn` Right () + blobExists projectRoot stale `shouldReturn` False + Directory.doesDirectoryExist (transaction ^. #transactionDirectory) `shouldReturn` False + + it "keeps transactions out of git with a self-ignoring .gitignore" $ + withSystemTempDirectory "seihou-update-transactions-ignored" $ \projectRoot -> do + writeProject projectRoot "file.txt" "old\n" + _ <- expectRight =<< beginUpdateTransaction projectRoot (Set.singleton "file.txt") + TIO.readFile (projectRoot ".seihou" "transactions" ".gitignore") `shouldReturn` "*\n" + recoverIncompleteTransactions projectRoot `shouldReturn` [Right ()] + describe "path validation" $ do it "rejects traversal, absolute, Git, and Seihou targets" $ withSystemTempDirectory "seihou-update-validation" $ \projectRoot -> do @@ -545,7 +670,7 @@ readProject projectRoot "edited.txt" `shouldReturn` "user orphan\n" Map.member "safe.txt" (candidate ^. #files) `shouldBe` False Map.member "edited.txt" (candidate ^. #files) `shouldBe` True - Directory.listDirectory (projectRoot ".seihou" "transactions") `shouldReturn` [] + Directory.listDirectory (projectRoot ".seihou" "transactions") `shouldReturn` [".gitignore"] fixedTime :: UTCTime fixedTime = parseTimeOrError True defaultTimeLocale "%Y-%m-%dT%H:%M:%SZ" "2026-07-19T12:00:00Z"