commit 7b9403555964f7a7a37008530ab8b53947d5287a
Author: Coder Agent <coder@agents.omni>
Date: Thu Feb 19 14:40:32 2026
Implement hash-based CI test cache invalidation
- add Omni.Bild.getTransitiveDeps for transitive source deps
- compute per-target test hashes from file + transitive deps
- invalidate incremental CI cache by comparing to parent note hashes
- persist hash map in refs/notes/ci note body
Task-Id: t-471
diff --git a/Omni/Bild.hs b/Omni/Bild.hs
index dd268b56..449dc395 100755
--- a/Omni/Bild.hs
+++ b/Omni/Bild.hs
@@ -926,6 +926,26 @@ analyzeOne namespace@(Namespace parts ext) = do
|> Just
|> pure
+-- | Get transitive local source dependencies for a namespace.
+--
+-- Haskell/Python dependencies are resolved from bild's import analysis.
+-- Nix is conservative: all tracked .nix files are considered dependencies.
+getTransitiveDeps :: Namespace -> IO [Namespace]
+getTransitiveDeps ns@(Namespace _ ext) =
+ case ext of
+ Namespace.Nix -> do
+ nixFiles <- Process.readProcess "git" ["ls-files", "*.nix"] ""
+ pure <| (nixFiles |> String.lines /> Namespace.fromRelPath |> catMaybes)
+ _ ->
+ analyzeOne ns +> \case
+ Nothing -> pure []
+ Just Target {srcs} ->
+ srcs
+ |> Set.toList
+ /> Namespace.fromRelPath
+ |> catMaybes
+ |> pure
+
detectHaskellImports :: Analysis -> [Text] -> IO (Set Meta.Dep, Set FilePath)
detectHaskellImports _ contentLines = do
root <- getCoderoot
diff --git a/Omni/Ci.hs b/Omni/Ci.hs
index a662cac2..f75ff199 100755
--- a/Omni/Ci.hs
+++ b/Omni/Ci.hs
@@ -12,8 +12,10 @@ module Omni.Ci (main) where
import Alpha
import qualified Data.Char as Char
import qualified Data.List as List
+import qualified Data.Map as Map
import qualified Data.Text as Text
import qualified Data.Text.IO as Text.IO
+import qualified Omni.Bild as Bild
import qualified Omni.Cli as Cli
import qualified Omni.Log as Log
import qualified Omni.Namespace as Namespace
@@ -27,6 +29,8 @@ import qualified System.Process as Process
main :: IO ()
main = Cli.main <| Cli.Plan parser test pure
+type TestHashCache = Map.Map FilePath Text
+
-- | Options for the ci command
data Options = Options
{ optRerun :: Bool,
@@ -46,8 +50,26 @@ test :: Test.Tree
test =
Test.group
"Omni.Ci"
- [ Test.unit "placeholder test" <| do
- True Test.@=? True
+ [ Test.unit "parseTestHashes parses file/hash pairs" <| do
+ let sampleNote =
+ Text.unlines
+ [ "Test-files: Omni/Foo.hs",
+ "Test-hash: abc123",
+ "Test-files: Omni/Bar.py",
+ "Test-hash: def456"
+ ]
+
+ parseTestHashes sampleNote
+ Test.@=? Map.fromList
+ [ ("Omni/Foo.hs", "abc123"),
+ ("Omni/Bar.py", "def456")
+ ],
+ Test.unit "filesNeedingTests invalidates changed hashes" <| do
+ let previous = Map.fromList [("Omni/Foo.hs", "old"), ("Omni/Bar.py", "same")]
+ let current = Map.fromList [("Omni/Foo.hs", "new"), ("Omni/Bar.py", "same"), ("Omni/Baz.hs", "new")]
+
+ filesNeedingTests False previous current
+ Test.@=? ["Omni/Baz.hs", "Omni/Foo.hs"]
]
runCi :: Options -> IO ()
@@ -60,7 +82,7 @@ runCi Options {..} = do
-- 2. Setup environment
-- We need to ensure timeout is disabled for CI builds
- -- Equivalent to: BILD_ARGS="--time 0 ${BILD_ARGS:-""}"
+ -- Equivalent to: BILD_ARGS="--time 0 ${BILD_ARGS:-\"\"}"
currentBildArgs <- Environment.lookupEnv "BILD_ARGS"
let bildArgs = "--time 0 " <> fromMaybe "" currentBildArgs
Environment.setEnv "BILD_ARGS" bildArgs
@@ -71,21 +93,15 @@ runCi Options {..} = do
user <- readProcess "git" ["config", "--get", "user.name"] "" |> fmap stripNewline
mail <- readProcess "git" ["config", "--get", "user.email"] "" |> fmap stripNewline
- -- 4. Check existing git notes
- -- commit=$(git notes --ref=ci show HEAD || true)
- (exitCode, noteContent, _) <- Process.readProcessWithExitCode "git" ["notes", "--ref=ci", "show", "HEAD"] ""
-
- let alreadyGood = case exitCode of
- Exit.ExitSuccess ->
- let content = Text.pack noteContent
- in ("Lint-is: good" `Text.isInfixOf` content) && ("Test-is: good" `Text.isInfixOf` content)
- _ -> False
+ -- 4. Check existing git note on HEAD
+ headNote <- readGitNote "HEAD"
+ let alreadyGood = maybe False noteIsGood headNote
when (alreadyGood && not optRerun) <| do
Log.pass ["ci", "already verified"]
Exit.exitSuccess
- -- 5. Run Lint
+ -- 5. Setup lint tooling
coderoot <- getCoderoot
let runlint = coderoot </> "_/bin/lint"
let tmpDir = coderoot </> "_/tmp"
@@ -97,31 +113,34 @@ runCi Options {..} = do
Log.info ["ci", "building lint"]
callProcess "bild" [coderoot </> "Omni/Lint.hs"]
- -- Get changed files for linting (always incremental)
- changedFiles <-
- readProcess "git" ["diff", "--name-only", "HEAD~1"] ""
- /> lines
- /> map Text.unpack
- /> filter (not <. null)
+ -- 6. Get files for linting and testing
+ changedFiles <- getChangedFiles
+ allTestTargets <- getAllTestTargets
- -- Get files to test
- filesToTest <-
+ previousHashes <-
if optFull
- then do
- -- Full mode: test all buildable files (slow, but thorough)
- Log.info ["ci", "full mode: testing all buildable files"]
- readProcess "git" ["ls-files"] ""
- /> lines
- /> map Text.unpack
- /> filter (not <. null)
- +> filterM isTestTarget
- else do
- -- Incremental mode: only test changed files (fast)
- filterM isTestTarget changedFiles
+ then pure mempty
+ else readPreviousTestHashes
- Log.info ["ci", "running lint on " <> show (length changedFiles) <> " files"]
+ currentHashes <- computeTestHashes allTestTargets
+
+ let filesToTest = filesNeedingTests (optFull || optRerun) previousHashes currentHashes
+ let cacheHits = length allTestTargets - length filesToTest
- lintResult <- do
+ Log.info ["ci", "running lint on " <> show (length changedFiles) <> " files"]
+ if optFull
+ then Log.info ["ci", "full mode: testing all " <> show (length filesToTest) <> " targets"]
+ else
+ Log.info
+ [ "ci",
+ "incremental mode: "
+ <> show cacheHits
+ <> " cache hits, testing "
+ <> show (length filesToTest)
+ <> " targets"
+ ]
+
+ lintResult <-
if null changedFiles
then pure ("good", "")
else do
@@ -131,16 +150,13 @@ runCi Options {..} = do
Exit.ExitSuccess -> ("good", "")
_ -> ("fail", extractErrorMessage (Text.pack lintStderr))
- -- 6. Run Tests
- Log.info ["ci", "running tests on " <> show (length filesToTest) <> " files"]
-
- testResult <- do
+ -- 7. Run tests for invalidated targets
+ testResult <-
if null filesToTest
then do
- Log.info ["ci", "no buildable files to test, skipping"]
+ Log.info ["ci", "all test hashes hit cache; skipping build/tests"]
pure ("good", "")
else do
- -- Build and test files (disable timeout; some builds are slow)
let testBildArgs = ["--time", "0", "--test"] <> filesToTest
(exitCodeTest, testStdout, testStderr) <-
Process.readProcessWithExitCode "bild" testBildArgs ""
@@ -151,42 +167,41 @@ runCi Options {..} = do
Exit.ExitSuccess -> ("good", "")
_ -> ("fail", extractErrorMessage errorText)
- -- 7. Create Note
- let noteMsg = case (fst lintResult, fst testResult) of
- ("good", "good") ->
- Text.unlines
- [ "Lint-is: " <> fst lintResult,
- "Test-is: " <> fst testResult,
- "Test-by: " <> user <> " <" <> mail <> ">",
- "Test-at: " <> at
+ -- 8. Write note with status + hash cache
+ let hashLines = renderTestHashes currentHashes
+ let summaryLines =
+ [ "Test-total: " <> show (Map.size currentHashes),
+ "Test-ran: " <> show (length filesToTest),
+ "Test-cached: " <> show cacheHits
+ ]
+
+ let noteBody =
+ [ "Lint-is: " <> fst lintResult,
+ "Test-is: " <> fst testResult
+ ]
+ <> filter
+ (not <. Text.null)
+ [ case snd lintResult of
+ "" -> ""
+ err -> "Lint-error: " <> Text.take 300 err,
+ case snd testResult of
+ "" -> ""
+ err -> "Test-error: " <> Text.take 300 err
]
- _ ->
- Text.unlines
- <| filter
- (not <. Text.null)
- [ "Lint-is: " <> fst lintResult,
- "Test-is: " <> fst testResult,
- case snd lintResult of
- "" -> ""
- err -> "Lint-error: " <> Text.take 300 err,
- case snd testResult of
- "" -> ""
- err -> "Test-error: " <> Text.take 300 err,
- "Test-by: " <> user <> " <" <> mail <> ">",
- "Test-at: " <> at
- ]
-
- -- 8. Append Note (only for full CI to avoid false positive cache hits)
- when optFull <| do
- Log.info ["ci", "writing test results to git notes"]
- callProcess "git" ["notes", "--ref=ci", "append", "-m", Text.unpack noteMsg]
+ <> summaryLines
+ <> hashLines
+ <> [ "Test-by: " <> user <> " <" <> mail <> ">",
+ "Test-at: " <> at
+ ]
+
+ let noteMsg = Text.unlines noteBody
+
+ Log.info ["ci", "writing test results to git notes"]
+ writeGitNote noteMsg
-- 9. Exit
if fst lintResult == "good" && fst testResult == "good"
- then do
- unless optFull
- <| Log.info ["ci", "incremental CI passed (use --full for cached results)"]
- Exit.exitSuccess
+ then Exit.exitSuccess
else do
Log.fail ["ci", "verification failed"]
Exit.exitWith (Exit.ExitFailure 1)
@@ -199,8 +214,144 @@ readProcess cmd args input = do
pure (Text.pack out)
callProcess :: FilePath -> [String] -> IO ()
-callProcess cmd args = do
- Process.callProcess cmd args
+callProcess cmd args = Process.callProcess cmd args
+
+readGitNote :: String -> IO (Maybe Text)
+readGitNote obj = do
+ (exitCode, out, _) <- Process.readProcessWithExitCode "git" ["notes", "--ref=ci", "show", obj] ""
+ pure <| case exitCode of
+ Exit.ExitSuccess -> Just (Text.pack out)
+ _ -> Nothing
+
+writeGitNote :: Text -> IO ()
+writeGitNote noteText = do
+ (exitCode, _, err) <-
+ Process.readProcessWithExitCode
+ "git"
+ ["notes", "--ref=ci", "add", "-f", "-F", "-", "HEAD"]
+ (Text.unpack noteText)
+ case exitCode of
+ Exit.ExitSuccess -> pure ()
+ _ -> panic <| "failed to write git note: " <> Text.pack err
+
+noteIsGood :: Text -> Bool
+noteIsGood noteText =
+ ("Lint-is: good" `Text.isInfixOf` noteText)
+ && ("Test-is: good" `Text.isInfixOf` noteText)
+
+getParentCommit :: IO (Maybe String)
+getParentCommit = do
+ (exitCode, out, _) <- Process.readProcessWithExitCode "git" ["rev-parse", "--verify", "HEAD~1"] ""
+ pure <| case exitCode of
+ Exit.ExitSuccess -> Just <| (Text.pack out |> stripNewline |> Text.unpack)
+ _ -> Nothing
+
+readPreviousTestHashes :: IO TestHashCache
+readPreviousTestHashes =
+ getParentCommit +> \case
+ Nothing -> pure mempty
+ Just parent ->
+ readGitNote parent +> \case
+ Nothing -> pure mempty
+ Just noteText ->
+ if "Test-is: good" `Text.isInfixOf` noteText
+ then pure (parseTestHashes noteText)
+ else pure mempty
+
+getChangedFiles :: IO [FilePath]
+getChangedFiles = do
+ (exitCode, out, _) <- Process.readProcessWithExitCode "git" ["diff", "--name-only", "HEAD~1"] ""
+ case exitCode of
+ Exit.ExitSuccess -> pure (parsePathList <| Text.pack out)
+ _ -> do
+ Log.info ["ci", "no HEAD~1 found, linting all tracked files"]
+ readProcess "git" ["ls-files"] "" /> parsePathList
+
+getAllTestTargets :: IO [FilePath]
+getAllTestTargets = do
+ tracked <- readProcess "git" ["ls-files"] "" /> parsePathList
+ filterM isTestTarget tracked /> List.sort
+
+parsePathList :: Text -> [FilePath]
+parsePathList = Text.lines .> map Text.unpack .> filter (not <. null)
+
+computeTestHashes :: [FilePath] -> IO TestHashCache
+computeTestHashes files = do
+ pairs <- forM files <| \path -> do
+ digest <- computeTestHash path
+ pure (path, digest)
+ pure (Map.fromList pairs)
+
+computeTestHash :: FilePath -> IO Text
+computeTestHash path = do
+ hashInputs <- getHashInputs path
+ fileDigests <-
+ forM hashInputs <| \fp -> do
+ digest <- hashFile fp
+ pure (Text.pack fp <> ":" <> digest)
+ hashText (Text.unlines fileDigests)
+
+getHashInputs :: FilePath -> IO [FilePath]
+getHashInputs path =
+ case Namespace.fromRelPath path of
+ Nothing -> pure [path]
+ Just ns -> do
+ deps <- Bild.getTransitiveDeps ns
+ let depPaths = deps /> Namespace.toPath
+ pure <| List.sort <| List.nub (path : depPaths)
+
+hashFile :: FilePath -> IO Text
+hashFile path = do
+ (exitCode, out, err) <- Process.readProcessWithExitCode "sha256sum" [path] ""
+ case exitCode of
+ Exit.ExitSuccess -> pure (extractSha256 <| Text.pack out)
+ _ -> panic <| "sha256sum failed for " <> Text.pack path <> ": " <> Text.pack err
+
+hashText :: Text -> IO Text
+hashText input = do
+ (exitCode, out, err) <- Process.readProcessWithExitCode "sha256sum" [] (Text.unpack input)
+ case exitCode of
+ Exit.ExitSuccess -> pure (extractSha256 <| Text.pack out)
+ _ -> panic <| "sha256sum failed for input: " <> Text.pack err
+
+extractSha256 :: Text -> Text
+extractSha256 = stripNewline .> Text.takeWhile (not <. Char.isSpace)
+
+filesNeedingTests :: Bool -> TestHashCache -> TestHashCache -> [FilePath]
+filesNeedingTests forceRun previous current
+ | forceRun = Map.keys current
+ | otherwise =
+ current
+ |> Map.toList
+ |> filter (\(path, digest) -> Map.lookup path previous /= Just digest)
+ |> map fst
+
+renderTestHashes :: TestHashCache -> [Text]
+renderTestHashes cache =
+ cache
+ |> Map.toList
+ |> concatMap
+ ( \(path, digest) ->
+ [ "Test-files: " <> Text.pack path,
+ "Test-hash: " <> digest
+ ]
+ )
+
+parseTestHashes :: Text -> TestHashCache
+parseTestHashes noteText = go Nothing mempty (Text.lines noteText)
+ where
+ go :: Maybe FilePath -> TestHashCache -> [Text] -> TestHashCache
+ go _ acc [] = acc
+ go pendingFile acc (line : rest) =
+ case Text.stripPrefix "Test-files: " line of
+ Just fp -> go (Just <| Text.unpack <| Text.strip fp) acc rest
+ Nothing ->
+ case Text.stripPrefix "Test-hash: " line of
+ Just digest ->
+ case pendingFile of
+ Just fp -> go Nothing (Map.insert fp (Text.strip digest) acc) rest
+ Nothing -> go Nothing acc rest
+ Nothing -> go pendingFile acc rest
getCoderoot :: IO FilePath
getCoderoot =