seihou-core 0.10.0.0 → 0.10.1.0

raw patch · 7 files changed

+173/−5 lines, 7 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• seihou-core.cabal +1/−1
• src/Seihou/Engine/Checkout.hs +1/−1
• src/Seihou/Engine/UpdateTransaction.hs +93/−2
• src/Seihou/Prelude.hs +2/−0
• test/Seihou/Engine/CheckoutSpec.hs +1/−1
• test/Seihou/Engine/UpdateTransactionSpec.hs +74/−0
• test/Seihou/Integration/ModuleLoadSpec.hs +1/−0

@@ -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.

@@ -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, [])

@@ -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 ()

@@ -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. --

@@ -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

@@ -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")

@@ -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