module Main (main) where import Control.Exception (bracket) import Control.Monad (forM_) import Data.Aeson (Value (..), decode) import Data.Aeson.KeyMap qualified as KM import Data.ByteString.Lazy.Char8 qualified as LBS8 import Data.Map.Strict qualified as Map import Data.Set qualified as Set import Data.Text (Text) import Data.Text qualified as T import Data.Time (UTCTime (..), addUTCTime, fromGregorian, nominalDay) import Oglyad.App (runApp) import Oglyad.Check (checkNames, parseCheckName) import Oglyad.Check.BuildLag qualified as BuildLag import Oglyad.Check.Drift qualified as Drift import Oglyad.Check.DuplicateName qualified as DuplicateName import Oglyad.Check.FedoraOverlap qualified as FedoraOverlap import Oglyad.Check.Stale qualified as Stale import Oglyad.Ignore import Oglyad.Process (childEnv, run) import Oglyad.Report (Report (..), renderJson, renderMarkdown, renderText) import Oglyad.Source.Monorepo (PkgDir (..), findPackageDirs, hclString, lastCommits, macroFingerprint, specFingerprint) import Oglyad.Source.Repodata (RpmEntry (..), decompressAndParse, fetchRepo, latestBySource, parsePrimary, srpmName) import Oglyad.Source.Rhai (parseUpdateRhai) import Oglyad.Types import Oglyad.Version import System.Directory (createDirectoryIfMissing, createDirectoryLink, createFileLink) import System.Environment (lookupEnv, setEnv, unsetEnv) import System.FilePath (()) import System.IO.Temp (withSystemTempDirectory) import System.Process.Typed (byteStringInput, proc, readProcess, runProcess_, setEnv, setStdin) import Test.Hspec import Test.QuickCheck main :: IO () main = hspec $ do describe "parseEVR" $ do it "parses version-release" $ parseEVR "1.2.3-1.fc44" `shouldBe` Just (EVR 0 "1.2.3" "1.fc44") it "parses an epoch" $ parseEVR "2:1.0-3" `shouldBe` Just (EVR 2 "1.0" "3") it "treats (none) as epoch 0" $ parseEVR "(none):1.0-3" `shouldBe` Just (EVR 0 "1.0" "3") it "rejects a missing release" $ parseEVR "1.0" `shouldBe` Nothing -- vectors from rpm's tests/rpmvercmp.at describe "rpmvercmp" $ do mapM_ vercmpCase [ ("1.0", "1.0", EQ), ("1.0", "2.0", LT), ("2.0.1", "2.0", GT), ("2.0.1a", "2.0.1", GT), ("5.5p1", "5.5p2", LT), ("5.5p10", "5.5p1", GT), ("10xyz", "10.1xyz", LT), ("xyz10", "xyz10.1", LT), ("xyz.4", "8", LT), ("1.05", "1.5", EQ), ("2.0", "2_0", EQ), ("2a", "2.0", LT), ("1.0~rc1", "1.0", LT), ("1.0~rc1", "1.0~rc2", LT), ("1.0~rc1~git123", "1.0~rc1", LT), ("1.0^", "1.0", GT), ("1.0^git1", "1.01", LT), ("1.0^git1~pre", "1.0^git1", LT), ("1.0~rc1^git1", "1.0~rc1", GT), ("1.0^git1", "1.0^git2", LT), ("1.0^20160101", "1.0.1", LT) ] it "is reflexive" $ property $ \(V a) -> rpmvercmp a a == EQ it "is antisymmetric" $ property $ \(V a) (V b) -> rpmvercmp a b == flipOrd (rpmvercmp b a) describe "normalizeVersion" $ do it "drops a leading v" $ normalizeVersion "v1.2.3" `shouldBe` "1.2.3" it "drops a name prefix" $ normalizeVersion "jq-1.7.1" `shouldBe` "1.7.1" it "drops a monorepo tag prefix" $ normalizeVersion "v2/v1.0.28" `shouldBe` "1.0.28" it "turns dashes into dots like anda" $ normalizeVersion "2024-01-05" `shouldBe` "2024.01.05" it "spells prereleases with a tilde" $ normalizeVersion "6.0.0-alpha1" `shouldBe` "6.0.0~alpha1" describe "compareUpstream" $ do mapM_ (\(up, spec, o) -> it (T.unpack up <> " vs spec " <> T.unpack spec) $ compareUpstream up spec `shouldBe` o) [ ("v1.3.0", "1.2.0", GT), ("v1.2.0", "1.2.0", EQ), ("1.2.0", "1.3.0", LT), ("6.0.0-alpha1", "6.0.0~alpha1", EQ), ("6.0.0", "6.0.0~alpha1", GT), ("0.4.2", "0.4~2", EQ), ("2026-07-27", "20260727", EQ), ("2.005R", "2.005", EQ), ("3.17.0-ogc1", "3.17.0^1", EQ), ("6.7.3", "v6.7.3", EQ), ("0.42.0", "0.41.0^20261031.9e2ed65", GT), -- a snapshot taken after the release it's based on isn't drift ("0.41.0", "0.41.0^20261031.9e2ed65", EQ) ] describe "srpmName" $ do it "strips version and release" $ srpmName "zed-0.190.0-1.fc44.src.rpm" `shouldBe` Just "zed" it "keeps dashes in the name" $ srpmName "python-foo-bar-1.0-2.fc44.src.rpm" `shouldBe` Just "python-foo-bar" describe "parsePrimary" $ do let entries = either (const []) id (parsePrimary primaryFixture) firstOf f = map f (take 1 entries) it "finds every package" $ map rpmName entries `shouldBe` ["zed", "zed-cli"] it "reads the EVR" $ firstOf rpmEVR `shouldBe` [EVR 0 "0.190.0" "1.fc44"] it "reads the build time" $ firstOf rpmBuildTime `shouldBe` [posix 1794200000] it "reads the source rpm" $ firstOf rpmSourceRpm `shouldBe` [Just "zed-0.190.0-1.fc44.src.rpm"] it "groups binaries by source package" $ Map.keys (latestBySource entries) `shouldBe` ["zed"] it "rejects garbage" $ parsePrimary "" `shouldSatisfy` isLeft it "decompresses zstd through the zstd command" $ do -- the same fixture, compressed by the real zstd tool (_, compressed, _) <- readProcess (setStdin (byteStringInput primaryFixture) (proc "zstd" ["-c", "-q"])) r <- decompressAndParse "repodata/abc-primary.xml.zst" compressed fmap (map rpmName) r `shouldBe` Right ["zed", "zed-cli"] forM_ [("gzip", ".gz"), ("xz", ".xz")] $ \(tool, ext) -> it ("decompresses " <> tool <> " through the " <> tool <> " command") $ do (_, compressed, _) <- readProcess (setStdin (byteStringInput primaryFixture) (proc tool ["-c", "-q"])) r <- decompressAndParse ("repodata/abc-primary.xml" <> T.pack ext) compressed fmap (map rpmName) r `shouldBe` Right ["zed", "zed-cli"] it "reports corrupt zstd instead of crashing" $ do r <- decompressAndParse "repodata/abc-primary.xml.zst" "definitely not zstd" r `shouldSatisfy` isLeft describe "hclString" $ do let hcl = "project pkg {\n rpm {\n spec = \"zed.spec\"\n }\n labels {\n subrepo = \"extras\"\n }\n}\n" it "finds the spec" $ hclString "spec" hcl `shouldBe` Just "zed.spec" it "finds the subrepo" $ hclString "subrepo" hcl `shouldBe` Just "extras" it "doesn't match key prefixes" $ hclString "sub" hcl `shouldBe` Nothing describe "parseUpdateRhai" $ do it "understands gh()" $ parseUpdateRhai "rpm.version(gh(\"zed-industries/zed\"));\n" `shouldBe` GitHub "zed-industries/zed" it "understands two-arg helpers" $ parseUpdateRhai "rpm.version(gitea(\"gitea.com\", \"gitea/tea\"));" `shouldBe` Gitea "gitea.com" "gitea/tea" it "maps codeberg to gitea" $ parseUpdateRhai "rpm.version(codeberg(\"a/b\"))" `shouldBe` Gitea "codeberg.org" "a/b" it "follows let bindings" $ parseUpdateRhai "let v = gh_tag(\"x/y\");\nif v.len > 0 {\n rpm.version(v);\n}" `shouldBe` GitHubTag "x/y" it "follows rpm.global(\"ver\", ...)" $ parseUpdateRhai nightly `shouldBe` GitHub "OpenTabletDriver/OpenTabletDriver" it "spots commit tracking" $ parseUpdateRhai "rpm.global(\"commit\", gh_commit(\"a/b\"));\nif rpm.changed() { rpm.release(); }" `shouldBe` CommitTracked it "keeps raw backtick regexes intact" $ parseUpdateRhai "let v = gh_tag(\"a/b\");\nif `[\\d.]+-beta\\.\\d+`.find_all(v).len == 0 {\n rpm.version(v);\n}" `shouldBe` GitHubTag "a/b" it "follows variables through other calls" $ parseUpdateRhai "let tag = gh_tag(\"x/ghidra\");\nlet v = find(`Ghidra_([\\d.]+)_build`, tag, 1);\nrpm.version(v);" `shouldBe` GitHubTag "x/ghidra" it "marks distro-following versions as derived" $ parseUpdateRhai "import \"andax/bump_extras.rhai\" as bump;\nrpm.version(bump::madoguchi(\"zig-master\", labels.branch));" `shouldBe` Derived "bump::madoguchi" it "ignores comments" $ parseUpdateRhai "// gh(\"wrong/one\")\nrpm.version(pypi(\"west\"));" `shouldBe` PyPI "west" it "falls back to Unknown" $ parseUpdateRhai "let x = get(\"https://example.com\").json();\nrpm.version(x.version);" `shouldSatisfy` isUnknown describe "drift check" $ do it "warns when upstream is newer" $ severities (Drift.check snapshot (pkg {pkgUpstreamVer = Just "v1.3.0"})) `shouldBe` [Warn] it "is quiet when versions match" $ Drift.check snapshot (pkg {pkgUpstreamVer = Just "v1.2.0"}) `shouldBe` [] it "ignores snapshots ahead of the last release" $ Drift.check snapshot (pkg {pkgSpecEVR = Just (EVR 0 "1.2.0^20261101git1234abc" "1.fc44"), pkgUpstreamVer = Just "1.2.0"}) `shouldBe` [] it "is quiet without upstream data" $ Drift.check snapshot pkg `shouldBe` [] describe "fedora-overlap check" $ do let withFedora = snapshot {snapFedora = Set.singleton "zed"} it "warns when Fedora ships the same package" $ severities (FedoraOverlap.check withFedora pkg) `shouldBe` [Warn] it "ignores packages in subrepos" $ FedoraOverlap.check withFedora (pkg {pkgSubrepo = Just "multimedia"}) `shouldBe` [] it "is quiet when Fedora doesn't have it" $ FedoraOverlap.check snapshot pkg `shouldBe` [] describe "duplicate-name check" $ do let other = pkg {pkgPath = "anda/devs/zed/nightly"} twoOf a b = snapshot {snapPackages = Map.fromList [(pkgPath a, a), (pkgPath b, b)]} it "flags two dirs building the same name into one repo" $ severities (DuplicateName.check (twoOf pkg other) pkg) `shouldBe` [Warn] it "allows the same name in different subrepos" $ DuplicateName.check (twoOf pkg other {pkgSubrepo = Just "extras"}) pkg `shouldBe` [] it "is quiet for unique names" $ DuplicateName.check snapshot pkg `shouldBe` [] describe "report" $ do let f path = Finding "build-lag" "zed" (Just path) Warn "x" it "shows the directory when a name is ambiguous" $ renderText Info (report [f "anda/a", f "anda/b"]) `shouldSatisfy` T.isInfixOf "zed (anda/a): x" it "keeps it short otherwise" $ renderText Info (report [f "anda/a"]) `shouldSatisfy` T.isInfixOf "zed: x" it "counts ignored findings in the summary" $ renderText Info ((report [f "anda/a"]) {rIgnored = [f "anda/b"]}) `shouldSatisfy` T.isInfixOf "(1 ignored)" it "wraps json in a versioned envelope" $ do let o = case decode (renderJson (report [f "anda/a"])) of Just (Object x) -> x _ -> KM.empty KM.lookup "schema" o `shouldBe` Just (Number 1) KM.lookup "summary" o `shouldSatisfy` maybe False (\case Object s -> KM.lookup "warn" s == Just (Number 1); _ -> False) KM.lookup "findings" o `shouldSatisfy` maybe False (\case Array a -> length a == 1; _ -> False) it "escapes pipes in markdown tables" $ renderMarkdown Info (report [(f "anda/a") {fMessage = "a|b"}]) `shouldSatisfy` T.isInfixOf "a\\|b" it "folds info findings away in markdown" $ renderMarkdown Info (report [(f "anda/a") {fSeverity = Info}]) `shouldSatisfy` T.isInfixOf "
Info (1)" describe "ignores" $ do let f check path name = Finding check name (Just path) Warn "x" dup = f "duplicate-name" "anda/langs/zig/master-bootstrap" "zig-master" lag = f "build-lag" "anda/devs/zed/stable" "zed" file rules = IgnoreFile rules rule check target = IgnoreRule check target "because" apply rules labels = applyIgnores checkNames checkNames (file rules) (Map.fromList labels) it "parses a valid file" $ parseIgnoreFile checkNames "{\"ignore\": [{\"check\": \"stale\", \"package\": \"zed\", \"reason\": \"fine\"}]}" `shouldBe` Right (file [IgnoreRule "stale" (ByName "zed") "fine"]) forM_ [ ("an empty reason", "{\"ignore\": [{\"check\": \"stale\", \"package\": \"zed\", \"reason\": \" \"}]}"), ("an unknown check", "{\"ignore\": [{\"check\": \"stael\", \"package\": \"zed\", \"reason\": \"x\"}]}"), ("both path and package", "{\"ignore\": [{\"check\": \"stale\", \"package\": \"zed\", \"path\": \"anda/x\", \"reason\": \"x\"}]}") ] $ \(what, raw) -> it ("rejects " <> what) $ parseIgnoreFile checkNames raw `shouldSatisfy` either (const True) (const False) it "ignores by path" $ do let Applied {..} = apply [rule "duplicate-name" (ByPath "anda/langs/zig/master-bootstrap")] [] [dup, lag] (apKept, apIgnored, apProblems) `shouldBe` ([lag], [dup], []) it "ignores by package name" $ do let Applied {..} = apply [rule "build-lag" (ByName "zed")] [] [dup, lag] (apKept, apIgnored) `shouldBe` ([dup], [lag]) it "ignores by anda.hcl label" $ do let Applied {..} = apply [] [("anda/langs/zig/master-bootstrap", ["duplicate-name"])] [dup, lag] (apKept, apIgnored) `shouldBe` ([lag], [dup]) it "only matches the named check" $ do let Applied {..} = apply [rule "stale" (ByName "zed")] [] [lag] apKept `shouldBe` [lag] it "reports entries that match nothing" $ do let Applied {..} = apply [rule "stale" (ByName "gone")] [] [lag] map fCheck apProblems `shouldBe` ["unused-ignore"] it "doesn't call entries unused when their check didn't run" $ do let Applied {..} = applyIgnores checkNames ["build-lag"] (file [rule "stale" (ByName "gone")]) Map.empty [lag] apProblems `shouldBe` [] it "flags unknown check names in labels" $ do let Applied {..} = apply [] [("anda/x", ["stael"])] [] map fSeverity apProblems `shouldBe` [Warn] describe "build-lag check" $ do it "says never published when the repo was fetched" $ severities (BuildLag.check snapshot pkg) `shouldBe` [Error] it "stays quiet when the repo fetch failed" $ BuildLag.check snapshot pkg {pkgRepoChecked = False} `shouldBe` [] describe "child processes" $ do it "never get secrets from our environment" $ do let env = childEnv [("PATH", "/usr/bin"), ("HOME", "/home/x"), ("GITHUB_TOKEN", "secret"), ("GH_TOKEN", "secret"), ("AWS_SECRET_ACCESS_KEY", "s"), ("LC_ALL", "C")] map fst env `shouldMatchList` ["GIT_TERMINAL_PROMPT", "PATH", "HOME", "LC_ALL"] it "can't read GITHUB_TOKEN even when spec-like code asks for it" $ withEnv "GITHUB_TOKEN" "oglyad-test-secret" $ do r <- run "sh" ["-c", "env"] r `shouldSatisfy` either (const False) (not . T.isInfixOf "oglyad-test-secret") describe "filesystem edge cases" $ do it "fingerprints a package with a dangling symlink instead of crashing" $ withSystemTempDirectory "oglyad-fp" $ \root -> do createDirectoryIfMissing True (root "anda/a") writeFile (root "anda/a/a.spec") "Name: a" createFileLink "does-not-exist" (root "anda/a/broken") key <- specFingerprint "m" ".fc44" root "anda/a" T.length key `shouldBe` 64 it "doesn't follow a symlink loop" $ withSystemTempDirectory "oglyad-loop" $ \root -> do createDirectoryIfMissing True (root "anda/a") writeFile (root "anda/a/anda.hcl") "project pkg {}" createDirectoryLink ".." (root "anda/a/loop") dirs <- findPackageDirs root map (fmap pdPath) dirs `shouldBe` [Right "anda/a"] _ <- specFingerprint "m" ".fc44" root "anda/a" pure () describe "parseCheckName" $ do it "accepts known checks" $ parseCheckName "build-lag" `shouldBe` Right "build-lag" it "rejects typos instead of silently running nothing" $ parseCheckName "buildlag" `shouldSatisfy` either (const True) (const False) describe "failure handling" $ do it "turns a missing executable into a Left" $ do r <- run "oglyad-definitely-not-a-real-command" [] r `shouldSatisfy` either (const True) (const False) it "turns an unreachable repo into a Left instead of throwing" $ do -- port 9 (discard) on loopback: refused immediately, no network needed r <- runApp (snapConfig snapshot) (fetchRepo "http://127.0.0.1:9/repo") r `shouldSatisfy` either (const True) (const False) describe "macroFingerprint" $ it "changes when ~/.rpmmacros changes" $ withSystemTempDirectory "oglyad-home" $ \home -> withEnv "HOME" home $ withEnv "XDG_CONFIG_HOME" (home ".config") $ do fpBefore <- macroFingerprint writeFile (home ".rpmmacros") "%dist .fc99\n" fpAfter <- macroFingerprint fpAfter `shouldNotBe` fpBefore describe "lastCommits" $ it "reads commit times, including UTC ones git prints with a Z" $ withSystemTempDirectory "oglyad-git" $ \repo -> do let git env args = runProcess_ . System.Process.Typed.setEnv (env <> [("GIT_CONFIG_GLOBAL", "/dev/null"), ("GIT_CONFIG_NOSYSTEM", "1")]) $ proc "git" (["-C", repo, "-c", "user.name=t", "-c", "user.email=t@t", "-c", "commit.gpgsign=false"] <> args) commitAt date dir = do createDirectoryIfMissing True (repo dir) writeFile (repo dir "anda.hcl") date git [] ["add", "-A"] git [("GIT_COMMITTER_DATE", date), ("GIT_AUTHOR_DATE", date)] ["commit", "-q", "-m", dir] git [] ["init", "-q"] commitAt "2026-01-02T03:04:05Z" "anda/a" commitAt "2026-02-03T04:05:06+08:00" "anda/b" m <- lastCommits repo ["anda/a", "anda/b"] Map.lookup "anda/a" m `shouldBe` Just (UTCTime (fromGregorian 2026 1 2) (3 * 3600 + 4 * 60 + 5)) Map.lookup "anda/b" m `shouldBe` Just (UTCTime (fromGregorian 2026 2 2) (20 * 3600 + 5 * 60 + 6)) describe "stale check" $ do let built daysAgo = Just (RepoBuild (EVR 0 "1.2.0" "1.fc44") (addUTCTime (negate (daysAgo * nominalDay)) now)) it "is quiet for recent builds" $ Stale.check snapshot (pkg {pkgRepoBuild = built 10}) `shouldBe` [] it "notes old builds" $ severities (Stale.check snapshot (pkg {pkgRepoBuild = built 400})) `shouldBe` [Info] it "warns when old and upstream moved on" $ severities (Stale.check snapshot (pkg {pkgRepoBuild = built 400, pkgUpstreamVer = Just "1.3.0"})) `shouldBe` [Warn] where nightly = "rpm.global(\"commit\", gh_commit(\"OpenTabletDriver/OpenTabletDriver\"));\n\ \if rpm.changed() {\n\ \ let v = gh(\"OpenTabletDriver/OpenTabletDriver\");\n\ \ v.crop(1);\n\ \ rpm.global(\"ver\", v);\n\ \}\n" isLeft = either (const True) (const False) isUnknown = \case Unknown _ -> True; _ -> False vercmpCase :: (Text, Text, Ordering) -> Spec vercmpCase (a, b, o) = it (T.unpack a <> " vs " <> T.unpack b) $ do rpmvercmp a b `shouldBe` o rpmvercmp b a `shouldBe` flipOrd o flipOrd :: Ordering -> Ordering flipOrd = compare EQ severities :: [Finding] -> [Severity] severities = map fSeverity -- * fixtures now :: UTCTime now = UTCTime (fromGregorian 2026 11 9) 0 posix :: Integer -> UTCTime posix s = addUTCTime (fromIntegral s) (UTCTime (fromGregorian 1970 1 1) 0) pkg :: Package pkg = Package { pkgName = "zed", pkgPath = "anda/devs/zed/stable", pkgSubrepo = Nothing, pkgSpecEVR = Just (EVR 0 "1.2.0" "1.fc44"), pkgRepoBuild = Nothing, pkgLastCommit = Nothing, pkgUpstream = Just (GitHub "zed-industries/zed"), pkgUpstreamVer = Nothing, pkgUpstreamErr = Nothing, pkgRepoChecked = True } snapshot :: Snapshot snapshot = Snapshot { snapPackages = Map.singleton (pkgPath pkg) pkg, snapFedora = Set.empty, snapNow = now, snapConfig = Config { cfgMonorepo = ".", cfgTerraRepo = "", cfgFedoraRepos = [], cfgRelease = 44, cfgDist = ".fc44", cfgStaleAfter = 180 * nominalDay, cfgUpstream = False, cfgCacheFor = 0, cfgConcurrency = 1, cfgGitHubToken = Nothing }, snapHead = Nothing, snapIgnoreLabels = Map.empty } report :: [Finding] -> Report report fs = Report { rVersion = "0", rGenerated = now, rMonorepoHead = Just "abc", rTerraRepo = "https://repos.fyralabs.com/terra44", rUpstream = False, rFindings = fs, rIgnored = [] } primaryFixture :: LBS8.ByteString primaryFixture = "\n\ \\n\ \\n\ \ zed\n\ \ x86_64\n\ \ \n\ \ an editor & more\n\ \ \n\ \\n\ \ zed-cli\n\ \ x86_64\n\ \ \n\ \ \n\ \\n" -- | version-ish strings: digits, letters and the separators rpm cares about newtype V = V Text deriving stock (Show) instance Arbitrary V where arbitrary = V . T.pack <$> listOf (elements "0123456789abz.~^_") shrink (V t) = V . T.pack <$> shrink (T.unpack t) -- | set an environment variable for the duration of an action withEnv :: String -> String -> IO a -> IO a withEnv key val act = bracket (lookupEnv key <* System.Environment.setEnv key val) (maybe (unsetEnv key) (System.Environment.setEnv key)) (const act)