diff --git a/seihou-core.cabal b/seihou-core.cabal --- a/seihou-core.cabal +++ b/seihou-core.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: seihou-core -version: 0.10.0.0 +version: 0.10.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/Checkout.hs b/src/Seihou/Engine/Checkout.hs --- a/src/Seihou/Engine/Checkout.hs +++ b/src/Seihou/Engine/Checkout.hs @@ -76,7 +76,7 @@ if gitRoot == Nothing then pure (False, []) else do - (code, _, _) <- runProcess "git" ["check-ignore", "-q", "--", "./" <> T.pack dest] (Just root) + (code, _, _) <- runProcess "git" ["check-ignore", "--no-index", "-q", "--", "./" <> T.pack dest] (Just root) pure $ case code of ExitSuccess -> (True, []) ExitFailure 1 -> (False, []) 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 @@ -8,6 +8,8 @@ setUpdateTransactionExpectedManifest, completeUpdateTransaction, recoverIncompleteTransactions, + trackedLinkIdentity, + adoptTrackedLinks, ) where @@ -31,11 +33,14 @@ import Seihou.Effect.BaselineStoreInterp (runBaselineStore) import Seihou.Effect.Filesystem (PathEntry (..), inspectPath) import Seihou.Effect.FilesystemInterp (runFilesystem) +import Seihou.Effect.Process (runProcess) +import Seihou.Effect.ProcessInterp (runProcessIO) import Seihou.Engine.Reconcile import Seihou.Manifest.Hash (hashContent) import Seihou.Manifest.Types (manifestFromJSON) import Seihou.Prelude import System.Directory qualified as Directory +import System.Exit (ExitCode (..)) import System.FilePath (splitDirectories, takeDirectory, takeFileName) import System.IO (hClose, hSetEncoding, utf8) import System.IO.Temp (createTempDirectory, openTempFile) @@ -71,6 +76,7 @@ createdAt :: !UTCTime, entries :: ![JournalEntry], newDirectories :: ![FilePath], + indexLinks :: !(Map FilePath Text), expectedManifest :: !(Maybe Manifest) } deriving stock (Eq, Generic, Show) @@ -111,18 +117,20 @@ "createdAt" .= (metadata ^. #createdAt), "entries" .= (metadata ^. #entries), "newDirectories" .= (metadata ^. #newDirectories), + "indexLinks" .= (metadata ^. #indexLinks), "expectedManifest" .= (metadata ^. #expectedManifest) ] instance FromJSON JournalMetadata where parseJSON = Aeson.withObject "JournalMetadata" $ \object -> do version <- object .: "version" - unless (version `elem` [1, 2]) (fail "unsupported transaction journal version") + unless (version `elem` [1, 2, 3]) (fail "unsupported transaction journal version") JournalMetadata <$> pure version <*> object .: "createdAt" <*> (mapM (parseJournalEntry version) =<< object .: "entries") <*> object .: "newDirectories" + <*> (if version < 3 then pure Map.empty else object .: "indexLinks") <*> object .:? "expectedManifest" beginUpdateTransaction :: FilePath -> Set FilePath -> IO (Either TransactionError UpdateTransaction) @@ -164,9 +172,74 @@ createdAt = now, entries = entries, newDirectories = missingDirectories, + indexLinks = Map.empty, expectedManifest = Nothing } +-- | 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) +trackedLinkIdentity root path = do + indexed <- gitOutput root ["ls-files", "--stage", "-z", "--", literal path] + headed <- gitOutput root ["ls-tree", "-z", "HEAD", "--", literal path] + flags <- gitOutput root ["ls-files", "-v", "-z", "--", literal path] + working <- runEff $ runFilesystem $ inspectPath (root path) + let identity = do + record <- indexed + let (prefix, suffix) = T.breakOn "\t" record + case T.words prefix of + ["120000", oid, "0"] | suffix == "\t" <> T.pack path <> "\0" -> Just oid + _ -> Nothing + blob <- case identity of + Nothing -> pure Nothing + Just oid -> gitOutput root ["cat-file", "blob", oid] + pure $ do + oid <- identity + if headed == Just ("120000 blob " <> oid <> "\t" <> T.pack path <> "\0") + && flags == Just ("H " <> T.pack path <> "\0") + && (case working of EntrySymlink target -> blob == Just (T.pack target); _ -> False) + then Just oid + else Nothing + +literal :: FilePath -> Text +literal path = ":(literal)" <> T.pack path + +gitOutput :: FilePath -> [Text] -> IO (Maybe Text) +gitOutput root args = do + (code, out, _) <- runEff $ runProcessIO $ runProcess "git" args (Just root) + pure (if code == ExitSuccess then Just out else Nothing) + +-- | Journal the exact entries before removing any of them. Recovery restores +-- just these paths, preserving unrelated staging and linked-worktree indexes. +adoptTrackedLinks :: UpdateTransaction -> Map FilePath Text -> IO (Either TransactionError ()) +adoptTrackedLinks _ links | Map.null links = pure (Right ()) +adoptTrackedLinks transaction links = do + result <- try @SomeException $ do + forM_ (Map.toAscList links) $ \(path, oid) -> do + either (ioError . userError . show) (const (pure ())) (validateTransactionPath path) + unless (path `Set.member` (transaction ^. #targets)) (ioError (userError "unjournaled adoption path")) + actual <- trackedLinkIdentity (transaction ^. #projectRoot) path + unless (actual == Just oid) (ioError (userError ("Git index changed for " <> path))) + metadata <- readJournal (transaction ^. #transactionDirectory) >>= either (ioError . userError . show) pure + writeJournal (transaction ^. #transactionDirectory) (metadata & #journalVersion .~ 3 & #indexLinks .~ links) + removed <- gitOutput (transaction ^. #projectRoot) (["update-index", "--force-remove", "--"] <> map T.pack (Map.keys links)) + when (removed == Nothing) (ioError (userError "could not adopt tracked links in Git's index")) + pure $ first (\err -> TransactionApplyFailed (exceptionText err) Nothing) result + +restoreIndexLinks :: FilePath -> Map FilePath Text -> IO () +restoreIndexLinks root links = do + -- Preflight the whole set before restoring any entry. A later user edit is + -- preserved and leaves the journal available for deliberate recovery. + missing <- fmap concat $ forM (Map.toAscList links) $ \(path, oid) -> do + current <- gitOutput root ["ls-files", "--stage", "-z", "--", literal path] + unless + (current `elem` [Just "", Just ("120000 " <> oid <> " 0\t" <> T.pack path <> "\0")]) + (ioError (userError ("Git index changed during recovery for " <> path))) + pure [(path, oid) | current == Just ""] + forM_ missing $ \(path, oid) -> do + restored <- gitOutput root ["update-index", "--add", "--cacheinfo", "120000", oid, T.pack path] + when (restored == Nothing) (ioError (userError ("cannot restore Git index entry " <> path))) + missingParentDirectories :: FilePath -> [FilePath] -> IO [FilePath] missingParentDirectories projectRoot paths = do let candidates = @@ -393,6 +466,7 @@ newDirectories = sortOn pathDepth . Set.toList $ Set.fromList (metadata ^. #newDirectories <> additionalDirectories), + indexLinks = metadata ^. #indexLinks, expectedManifest = Just candidate } @@ -438,7 +512,15 @@ Right metadata -> do result <- try @SomeException $ do forM_ (metadata ^. #entries) (verifySafeParents (transaction ^. #projectRoot) . (^. #targetPath)) - forM_ (metadata ^. #entries) (restoreEntry transaction) + -- Adoption never writes the working link. Preserve a later edit rather + -- than restoring a snapshot over something this transition did not own. + forM_ (metadata ^. #entries) $ \entry -> when (Map.member (entry ^. #targetPath) (metadata ^. #indexLinks)) $ do + current <- runEff $ runFilesystem $ inspectPath (transaction ^. #projectRoot entry ^. #targetPath) + unless + (Just current == (EntrySymlink <$> entry ^. #linkTarget)) + (ioError (userError ("adopted working link changed during recovery: " <> entry ^. #targetPath))) + restoreIndexLinks (transaction ^. #projectRoot) (metadata ^. #indexLinks) + forM_ (filter (\entry -> Map.notMember (entry ^. #targetPath) (metadata ^. #indexLinks)) (metadata ^. #entries)) (restoreEntry transaction) removeNewDirectories (transaction ^. #projectRoot) (metadata ^. #newDirectories) cleanupDirectory (transaction ^. #transactionDirectory) pure $ first (TransactionRollbackFailed . exceptionText) result @@ -512,6 +594,7 @@ createdAt = metadata ^. #createdAt, entries = metadata ^. #entries, newDirectories = metadata ^. #newDirectories, + indexLinks = metadata ^. #indexLinks, expectedManifest = Just expected } result <- try @SomeException (writeJournal (transaction ^. #transactionDirectory) updated) @@ -589,11 +672,19 @@ validateJournal :: JournalMetadata -> Either Text JournalMetadata validateJournal metadata = do + traverse_ (first renderTransactionPathError . validateTransactionPath) (Map.keys (metadata ^. #indexLinks)) + traverse_ validateObjectId (Map.elems (metadata ^. #indexLinks)) + unless + (Map.keysSet (metadata ^. #indexLinks) `Set.isSubsetOf` Set.fromList [entry ^. #targetPath | entry <- metadata ^. #entries, entry ^. #linkTarget /= Nothing]) + (Left "index adoption paths must have journaled symlink snapshots") traverse_ (validateJournalEntry . (^. #targetPath)) (metadata ^. #entries) traverse_ validateBackupName [name | JournalEntry _ (Just name) _ <- metadata ^. #entries] traverse_ (first renderTransactionPathError . validateTransactionPath) (metadata ^. #newDirectories) pure metadata where + validateObjectId oid + | T.length oid `elem` [40, 64] && T.all (`elem` ("0123456789abcdef" :: String)) oid = Right () + | otherwise = Left "invalid Git object id in checkout adoption journal" validateJournalEntry path = first renderTransactionPathError (validateTransactionPath path) validateBackupName name | takeFileName name == name && name /= "." && name /= ".." = Right () diff --git a/src/Seihou/Prelude.hs b/src/Seihou/Prelude.hs --- a/src/Seihou/Prelude.hs +++ b/src/Seihou/Prelude.hs @@ -44,6 +44,7 @@ where import "base" Data.Bifunctor (first) + -- Every record type in the project derives Generic, both because the house -- style requires it and because generic-lens synthesises #label lenses from -- the Generic representation. Re-exporting it here keeps the derive clauses @@ -54,6 +55,7 @@ import "effectful-core" Effectful (Dispatch (Dynamic), DispatchOf, Eff, Effect, IOE, MonadIO, liftIO, runEff, type (:>), type (:>>)) import "effectful-core" Effectful.Dispatch.Dynamic (EffectHandler, HasCallStack, interpret, reinterpret, send) import "filepath" System.FilePath (()) + -- Re-export the whole lens API. PackageImports pins the package so that -- `Control.Lens` unambiguously means the `lens` package's module. -- 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 @@ -98,7 +98,7 @@ cmd == "git" && case args of ["rev-parse", "--show-toplevel"] -> True ["ls-files", "--cached", "-z"] -> True - ["check-ignore", "-q", "--", path] -> "./" `T.isPrefixOf` path + ["check-ignore", "--no-index", "-q", "--", path] -> "./" `T.isPrefixOf` path _ -> False ) it "creates portable links and converges without following their contents" $ withFixture $ \root -> do 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 @@ -19,12 +19,15 @@ import Seihou.Effect.BaselineStore (putBaseline) import Seihou.Effect.BaselineStoreInterp (runBaselineStore) import Seihou.Effect.FilesystemInterp (runFilesystem) +import Seihou.Effect.Process (runProcess) +import Seihou.Effect.ProcessInterp (runProcessIO) import Seihou.Engine.Reconcile import Seihou.Engine.UpdateTransaction import Seihou.Manifest.Hash (baselineRefForContent, hashContent) import Seihou.Manifest.Types (emptyManifest, manifestToJSON) import System.Directory (findExecutable) import System.Directory qualified as Directory +import System.Exit (ExitCode (..)) import System.FilePath (takeDirectory, ()) import System.IO.Temp (withSystemTempDirectory) import Test.Hspec @@ -36,6 +39,77 @@ spec :: Spec spec = do + describe "tracked checkout-link adoption recovery" $ do + let git root args = do + (code, out, err) <- runEff $ runProcessIO $ runProcess "git" args (Just root) + unless (code == ExitSuccess) (expectationFailure (T.unpack err)) + pure out + prepare root = do + _ <- git root ["init", "-q"] + Directory.createDirectoryLink "missing-target" (root "discovery") + TIO.writeFile (root "unrelated") "committed\n" + _ <- git root ["add", "."] + _ <- git root ["-c", "user.name=Test", "-c", "user.email=test@example.invalid", "commit", "-qm", "test: initial links"] + TIO.writeFile (root "unrelated") "staged edit\n" + _ <- git root ["add", "unrelated"] + Just oid <- trackedLinkIdentity root "discovery" + pure oid + it "recovers an interrupted adoption without changing unrelated staging" $ + withSystemTempDirectory "adoption-recovery" $ \root -> do + oid <- prepare root + before <- git root ["ls-files", "--stage", "-z"] + Right transaction <- beginUpdateTransaction root (Set.singleton "discovery") + adoptTrackedLinks transaction (Map.singleton "discovery" oid) `shouldReturn` Right () + git root ["ls-files", "--", "discovery"] `shouldReturn` "" + Directory.getSymbolicLinkTarget (root "discovery") `shouldReturn` "missing-target" + recoverIncompleteTransactions root `shouldReturn` [Right ()] + git root ["ls-files", "--stage", "-z"] `shouldReturn` before + it "refuses modified working links and changed index entries" $ + withSystemTempDirectory "adoption-stale" $ \root -> do + oid <- prepare root + Directory.removeDirectoryLink (root "discovery") + Directory.createDirectoryLink "user-target" (root "discovery") + trackedLinkIdentity root "discovery" `shouldReturn` Nothing + Right transaction <- beginUpdateTransaction root (Set.singleton "discovery") + refused <- adoptTrackedLinks transaction (Map.singleton "discovery" oid) + refused `shouldSatisfy` \case Left {} -> True; _ -> False + _ <- git root ["add", "-f", "discovery"] + trackedLinkIdentity root "discovery" `shouldReturn` Nothing + it "keeps an adoption when the final manifest was published before interruption" $ + withSystemTempDirectory "adoption-committed" $ \root -> do + oid <- prepare root + Right transaction <- beginUpdateTransaction root (Set.singleton "discovery") + adoptTrackedLinks transaction (Map.singleton "discovery" oid) `shouldReturn` Right () + let manifest = emptyManifest fixedTime + setUpdateTransactionExpectedManifest transaction manifest `shouldReturn` Right () + LBS.writeFile (root ".seihou/manifest.json") (manifestToJSON manifest) + recoverIncompleteTransactions root `shouldReturn` [Right ()] + git root ["ls-files", "--", "discovery"] `shouldReturn` "" + Directory.getSymbolicLinkTarget (root "discovery") `shouldReturn` "missing-target" + it "preserves a later working-link edit during recovery" $ + withSystemTempDirectory "adoption-working-conflict" $ \root -> do + oid <- prepare root + Right transaction <- beginUpdateTransaction root (Set.singleton "discovery") + adoptTrackedLinks transaction (Map.singleton "discovery" oid) `shouldReturn` Right () + Directory.removeDirectoryLink (root "discovery") + Directory.createDirectoryLink "user-target" (root "discovery") + recovered <- rollbackUpdateTransaction transaction + recovered `shouldSatisfy` \case Left TransactionRollbackFailed {} -> True; _ -> False + git root ["ls-files", "--", "discovery"] `shouldReturn` "" + Directory.getSymbolicLinkTarget (root "discovery") `shouldReturn` "user-target" + it "preserves a later staged edit instead of overwriting it during recovery" $ + withSystemTempDirectory "adoption-recovery-conflict" $ \root -> do + oid <- prepare root + Right transaction <- beginUpdateTransaction root (Set.singleton "discovery") + adoptTrackedLinks transaction (Map.singleton "discovery" oid) `shouldReturn` Right () + Directory.removeDirectoryLink (root "discovery") + Directory.createDirectoryLink "user-target" (root "discovery") + _ <- git root ["add", "discovery"] + before <- git root ["ls-files", "--stage", "-z"] + recovered <- rollbackUpdateTransaction transaction + recovered `shouldSatisfy` \case Left TransactionRollbackFailed {} -> True; _ -> False + git root ["ls-files", "--stage", "-z"] `shouldReturn` before + Directory.getSymbolicLinkTarget (root "discovery") `shouldReturn` "user-target" describe "literal symlink journal snapshots" $ do it "restores a dangling target without traversing it" $ withSystemTempDirectory "checkout-journal" $ \root -> do Directory.createDirectoryLink "missing-old-target" (root "local-link") diff --git a/test/Seihou/Integration/ModuleLoadSpec.hs b/test/Seihou/Integration/ModuleLoadSpec.hs --- a/test/Seihou/Integration/ModuleLoadSpec.hs +++ b/test/Seihou/Integration/ModuleLoadSpec.hs @@ -4,6 +4,7 @@ import Data.Generics.Labels () import Data.Map.Strict qualified as Map import Effectful + -- Re-use the real loader for end-to-end tests import Seihou.Core.Module (loadModule) import Seihou.Core.Types