seihou-core 0.12.0.1 → 0.12.1.0
raw patch · 3 files changed
+262/−10 lines, 3 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
+ Seihou.Engine.UpdateTransaction: setAsideUnreferencedBaselines :: UpdateTransaction -> Set BaselineRef -> IO (Either TransactionError ())
Files
- seihou-core.cabal +1/−1
- src/Seihou/Engine/UpdateTransaction.hs +135/−8
- test/Seihou/Engine/UpdateTransactionSpec.hs +126/−1
seihou-core.cabal view
@@ -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.
src/Seihou/Engine/UpdateTransaction.hs view
@@ -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
test/Seihou/Engine/UpdateTransactionSpec.hs view
@@ -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"