oglyad 0.1.1.0 → 0.1.2.0
raw patch · 22 files changed
+2330/−206 lines, 22 files
Files
- CHANGELOG.md +59/−4
- README.md +93/−36
- app/Main.hs +98/−45
- oglyad.cabal +5/−1
- src/Oglyad/Check/Drift.hs +31/−11
- src/Oglyad/Check/NoAutoupdate.hs +1/−1
- src/Oglyad/Check/UnparsedRhai.hs +15/−4
- src/Oglyad/Collect.hs +122/−27
- src/Oglyad/Ignore.hs +11/−5
- src/Oglyad/Process.hs +17/−1
- src/Oglyad/Regex.hs +514/−0
- src/Oglyad/Release.hs +134/−0
- src/Oglyad/Report.hs +48/−15
- src/Oglyad/Source/Anda.hs +112/−0
- src/Oglyad/Source/Cache.hs +2/−1
- src/Oglyad/Source/Monorepo.hs +127/−17
- src/Oglyad/Source/Rhai.hs +61/−15
- src/Oglyad/Source/RhaiEval.hs +537/−0
- src/Oglyad/Source/Upstream.hs +24/−3
- src/Oglyad/Types.hs +31/−4
- src/Oglyad/Version.hs +18/−3
- test/Spec.hs +270/−13
CHANGELOG.md view
@@ -1,5 +1,64 @@ # changelog +## 0.1.2.0++- checks every maintained release by default (today f43, f44, f45 and+ rawhide), as listed by Fedora's Bodhi. `-r`/`--release` takes `43`, `f43`+ or `rawhide` and can be repeated. the default used to be just 44+- each release reads its own terrapkg/packages branch (`origin/f43`,+ `origin/frawhide`) through `git archive`, without touching the checkout.+ `--worktree` checks the checkout as it is against one release, which is+ what oglyad used to do. `--remote` picks the remote+- rawhide uses `terrarawhide`, `.fcrawhide` and Fedora's rawhide repo+- findings are merged across releases and tagged with the releases they+ came up in. messages that only differ by dist tag show `%{dist}`+- json schema 2: `releases` replaces `monorepo_head` and `terra_repo`, and+ each finding lists its `releases`+- an ignore file entry is only reported unused when it matched nothing in+ every release+- upstream answers fetched earlier in the same run are reused, so checking+ four releases asks each upstream once+- `unparsed-rhai` only lists scripts that really look up a version oglyad+ can't follow. kmod packages copying Version from their kmod-common spec,+ scripts that only bump Release or write files, and scripts tracking a+ commit from `get()` are classified as such instead. whether a script sets+ the version is judged by the macros the spec's `Version:` line uses, so+ `%global tag` feeding `Version: %(echo %tag | ...)` still counts+- an update.rhai with only comments in it counts as `no-autoupdate`+- `drift` and `stale` don't compare packages with a `nightly` or+ `quaterdaily` label in anda.hcl against the latest release, since they+ build from a branch head.+ a mangled version is still flagged+- anda.hcl values can be bare (`nightly = 1`) as well as quoted+- with `-u`, update.rhai scripts oglyad can't follow (scraping with `get()`,+ `gh_tags()` filters, `gh_rawfile()`, ...) run under the real anda on a+ throwaway copy of the tree, and the Version left in the spec is compared.+ failing scripts show up as `upstream-error`, and answers are cached like+ upstream ones. anda gets `GITHUB_TOKEN`, since it needs it for GitHub+ helpers+- `drift` replays the version-setting part of update.rhai over the upstream+ value, so guards (`if v.starts_with("cli-v")`, `if v < "5"`), edits+ (`crop`, `pop`, `truncate`, `replace`), `terminate()` and try/catch apply+ before comparing. tags a script would skip no longer show up as drift+- andax's regex helpers (`find`, `find_all`, `sub`) work in that replay,+ through a small engine for Rust's regex dialect that gives the same+ matches and captures as the regex crate+- `drift` treats a snapshot suffix (`^20260805git...`, `.gitfc62ae7`) as part+ of the spec's spelling, so `2.0.0-alpha-1-20250926` matches+ `2.0.0~alpha~1~20250926.gitfc62ae7`+- `drift` warns when update.rhai would produce a version that doesn't start+ with a letter or digit, like `crop(1)` turning `6.0.1` into `.0.1`+- `unparsed-rhai` warns about scripts with unbalanced brackets, which anda+ can't run at all+- `opam()` lookups skip versions that aren't semver, like anda does, so old+ Jane Street versions like `113.24.00` no longer win+- `--help` and `--version` print to stdout instead of stderr, so tools like+ help2man can read them. bad arguments still go to stderr and exit 2++## 0.1.1.0++prepare for release on Hackage+ ## 0.1.0.0 first release.@@ -10,7 +69,3 @@ - `--fail-on` and distinct exit codes for automation - ignore files and `oglyad_ignore` labels in anda.hcl - caching of spec evaluations, repodata, commit times and upstream answers--## 0.1.1.0--prepare for release on Hackage
README.md view
@@ -1,14 +1,16 @@ # oglyad repository metadata and health checker for [Terra](https://terra.fyralabs.com).-"огляд" is Ukrainian for "review" or "inspection".+"огляд" is Ukrainian for "review" or "inspection," but also for a health checkup. ```sh git clone https://github.com/terrapkg/packages ../packages-oglyad -m ../packages # warnings and errors+oglyad -m ../packages # warnings and errors, every maintained release oglyad -m ../packages -v # plus info findings oglyad -m ../packages -u # plus upstream version drift oglyad -m ../packages --fedora # plus overlap with Fedora+oglyad -m ../packages -r 44 -r rawhide # just these releases+oglyad -m ../packages -r rawhide --worktree # your local edits, against rawhide oglyad -m ../packages --only drift --format json ``` @@ -16,25 +18,56 @@ `rpmspec` (rpm-build), `git`, and the `zstd`, `gzip` and `xz` commands. upstream lookups use `GITHUB_TOKEN`, or `gh auth token` when that's unset. +## releases++by default oglyad checks every Fedora release+[Bodhi](https://bodhi.fedoraproject.org/releases/) hasn't archived (the+current ones, a branched one before its release, and rawhide), so branching+and EOL need no changes here. `-r`/`--release` picks releases instead, as+`43`, `f43` or `rawhide`, and can be repeated.++each release is checked against its own Terra repo (`terra43`,+`terrarawhide`) and its own branch of terrapkg/packages (`origin/f43`,+`origin/frawhide`), with that release's `%{dist}` (`.fc43`, `.fcrawhide`)+and `%fedora`. branches are read with `git archive` into+`~/.cache/oglyad/trees`, so your checkout is never touched. nothing is+fetched either, so `git fetch` first if the branches are old. `--remote`+picks a remote other than `origin`.++`--worktree` reads specs from the checkout as it is, local edits included,+and needs exactly one `--release`. `--repo` points one release at a+different Terra repo.++findings from several releases are merged. one that comes up in only some+of them is tagged, like `anki [f44, f45]: ...`, and messages that only+differ by dist tag are merged with `%{dist}` in its place:+`never published (spec is at 26.09.4-1%{dist})`.+ ## output and exit codes `--format` picks `text` (default), `markdown` (made for GitHub job summaries) or `json`. the json is a versioned envelope: ```json-{"schema": 1, "oglyad": "0.1.0.0", "generated": "...", "monorepo_head": "...",+{"schema": 2, "oglyad": "0.1.0.0", "generated": "...",+ "releases": [{"release": "43", "label": "f43", "ref": "origin/f43",+ "commit": "...", "terra_repo": "https://repos.fyralabs.com/terra43"}],+ "upstream": true, "summary": {"error": 0, "warn": 0, "info": 0, "ignored": 0},- "findings": [{"check": "...", "package": "...", "path": "...", "severity": "...", "message": "..."}],+ "findings": [{"check": "...", "package": "...", "path": "...", "severity": "...",+ "message": "...", "releases": ["43", "44"]}], "ignored": [...]} ``` -`schema` changes on any breaking change to the json.+`schema` changes on any breaking change to the json. schema 2 replaced+`monorepo_head` and `terra_repo` with `releases`, and added `releases` to+findings. `ref` is `null` with `--worktree`. -| exit | meaning |-|---|---|-| 0 | ran, nothing at or above `--fail-on` (default `error`, or `warn`, `info`, `never`) |-| 1 | ran, and found something at or above `--fail-on` |-| 2 | couldn't run: bad flags, unreadable ignore file, not a monorepo |+| exit | meaning |+| ---- | ---------------------------------------------------------------------------------- |+| 0 | ran, nothing at or above `--fail-on` (default `error`, or `warn`, `info`, `never`) |+| 1 | ran, and found something at or above `--fail-on` |+| 2 | couldn't run: bad flags, unreadable ignore file, not a monorepo | ## ignoring known findings @@ -48,8 +81,11 @@ ```json { "ignore": [- {"check": "duplicate-name", "path": "anda/langs/zig/master-bootstrap",- "reason": "bootstrap build of zig-master"}+ {+ "check": "duplicate-name",+ "path": "anda/langs/zig/master-bootstrap",+ "reason": "bootstrap build of zig-master"+ } ] } ```@@ -62,25 +98,38 @@ } ``` -file entries that no longer match anything are reported as `unused-ignore`,-so exceptions don't outlive their reason. `--no-ignores` shows everything.+file entries that no longer match anything in any checked release are+reported as `unused-ignore`, so exceptions don't outlive their reason. `--no-ignores` shows everything. [`ignores.json`](ignores.json) is the file the nightly report uses. ## checks -| check | severity | what it means |-|---|---|---|-| `build-lag` | error / warn / info | never published, merged but not built, or the repo is newer than your checkout |-| `drift` | warn | upstream released something newer than the spec (`-u`) |-| `duplicate-name` | warn | two directories build the same package name into the same repo, so they overwrite each other |-| `stale` | info, warn with `-u` | last build is older than `--stale-days`, warn if upstream also moved on |-| `upstream-error` | warn | the upstream from update.rhai 404s or fails, so `anda update` is failing too |-| `fedora-overlap` | warn | Fedora ships the same source package (`--fedora`). subrepos are exempt |-| `no-autoupdate` | info | no update.rhai |-| `unparsed-rhai` | info | update.rhai does something oglyad can't follow, like custom scraping |-| `collect` | error | rpmspec failed, a repo couldn't be fetched, or an upstream rate-limited us (warn) |-| `unused-ignore` | info / warn | an ignore entry matches nothing, or an `oglyad_ignore` label names an unknown check |+| check | severity | what it means |+| ---------------- | ---------------------------------------- | ---------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- |+| `build-lag` | error / warn / info | never published, merged but not built, or the repo is newer than your checkout |+| `drift` | warn | upstream released something newer than the spec (`-u`). scripts oglyad can't follow on its own are run with the real anda, see below. packages with a `nightly` or `quaterdaily` label build from a branch head, so they're only checked for a mangled version, not held to the latest release |+| `duplicate-name` | warn | two directories build the same package name into the same repo, so they overwrite each other |+| `stale` | info, warn with `-u` | last build is older than `--stale-days`, warn if upstream also moved on |+| `upstream-error` | warn | the upstream from update.rhai 404s or fails, so `anda update` is failing too |+| `fedora-overlap` | warn | Fedora ships the same source package (`--fedora`). subrepos are exempt |+| `no-autoupdate` | info | no update.rhai, or one with only comments in it |+| `unparsed-rhai` | info, warn when anda can't run it either | update.rhai looks a version up in a way oglyad can't follow, like custom scraping, and anda didn't answer for it (no `-u`, or anda isn't installed). scripts that only bump Release, track a commit, or copy Version from another spec aren't listed |+| `collect` | error | rpmspec failed, a repo couldn't be fetched, or an upstream rate-limited us (warn) |+| `unused-ignore` | info / warn | an ignore entry matches nothing, or an `oglyad_ignore` label names an unknown check | +### scripts oglyad can't follow++oglyad reads most update.rhai scripts itself: it finds the helper the version+comes from (`gh`, `pypi`, `crates`, ...), asks that upstream, and replays the+script's guards and edits over the answer, regexes included. scripts that do+more than that, like scraping a page with `get()` and `find()`, filtering+`gh_tags()`, or reading a file with `gh_rawfile()`, go to the real anda+instead. with `-u` and `anda` on the PATH, oglyad copies the release's tree+to a throwaway directory, runs `anda update --labels branch=<f43> <project>`+for each of those, and reads the Version rpmspec sees in the rewritten spec.+a script that throws shows up as `upstream-error`. answers are cached like+upstream ones.+ ## how it works ```@@ -107,12 +156,14 @@ everything lives in `~/.cache/oglyad`. -| file | reused while |-|---|---|-| `specs.fcNN.json` | the package dir's files, the dist tag, and rpm's whole macro state (`rpm --showrc`) are unchanged |-| `commits.json` | HEAD hasn't moved |-| `repodata-*.json` | the repo's primary.xml checksum is unchanged |-| `upstream.json` | younger than `--cache-hours` (default 6), successes only. entries unused for 30 days are dropped |+| file | reused while |+| ------------------- | ------------------------------------------------------------------------------------------------------------------------------------ |+| `specs.fcNN.json` | the package dir's files, the dist tag, and rpm's whole macro state (`rpm --showrc`) are unchanged |+| `commits.fcNN.json` | the release's commit hasn't moved |+| `repodata-*.json` | the repo's primary.xml checksum is unchanged |+| `upstream.json` | younger than `--cache-hours` (default 6), or fetched earlier in the same run. successes only. entries unused for 30 days are dropped |+| `anda.fcNN.json` | like `upstream.json`, keyed by the package dir's files instead of the upstream |+| `trees/<commit>/` | extracted release branches, one per commit. ones unused for a week are deleted | a run with warm caches takes about 0.4s. a cold run takes about 5s, almost all of it in rpmspec. `--fedora` adds about 8s and peaks around 200MB of@@ -127,6 +178,11 @@ secrets in oglyad's environment never reach them, but code running as your user can still read your files. +the one exception is anda. with `-u`, update.rhai scripts oglyad can't follow+run under the real anda, which refuses GitHub helpers without+`GITHUB_TOKEN`, so anda gets the token. those scripts can run shell commands+with `sh()`, and those commands see the token too. use a read-only token.+ **don't run oglyad on untrusted code, like an unmerged pull request, with credentials around.** the nightly report only checks out terrapkg/packages' default branch, and its token is read-only and expires with the job.@@ -139,7 +195,8 @@ [`report.yml`](.github/workflows/report.yml) runs every night in Terra's builder image (`ghcr.io/terrapkg/builder:f45`), so specs evaluate with the same macros Terra builds with. it builds `oglyad-git` with anda, checks-terrapkg/packages' default branch with `-u --fedora`, writes the markdown+every maintained release's branch of terrapkg/packages with `-u --fedora`,+writes the markdown report to the run's summary, and keeps the markdown and json for 30 days. caches carry over between nights. @@ -147,9 +204,9 @@ built the same way as anda itself. [`anda.hcl`](anda.hcl) has two projects: -| project | spec | builds |-|---|---|---|-| `oglyad` | [`oglyad.spec`](oglyad.spec) | the `v<version>` release tag |+| project | spec | builds |+| ------------ | ------------------------------------ | ------------------------------------------------------------- |+| `oglyad` | [`oglyad.spec`](oglyad.spec) | the `v<version>` release tag | | `oglyad-git` | [`oglyad-git.spec`](oglyad-git.spec) | the checked-out commit, versioned `<version>^<date>.<commit>` | ```sh
app/Main.hs view
@@ -5,20 +5,24 @@ module Main (main) where import Control.Exception (SomeException, try)-import Control.Monad (unless, when)+import Control.Monad (forM, unless, when) import Data.ByteString qualified as BS import Data.ByteString.Lazy qualified as LBS+import Data.List (nub)+import Data.Maybe (isJust) import Data.Text (Text) import Data.Text qualified as T-import Data.Time (getCurrentTime)+import Data.Time (UTCTime, getCurrentTime) import GHC.Conc (getNumProcessors) import GHC.IO.Encoding (setFileSystemEncoding, setForeignEncoding, setLocaleEncoding, utf8)-import Oglyad.App (oglyadVersion, runApp)+import Oglyad.App (HttpError (..), httpGetE, oglyadVersion, runApp) import Oglyad.Check (checkNames, parseCheckName, runChecks) import Oglyad.Collect (buildSnapshot) import Oglyad.Ignore (Applied (..), IgnoreFile (..), applyIgnores, parseIgnoreFile) import Oglyad.Process (run)-import Oglyad.Report (Format (..), Report (..), render)+import Oglyad.Release+import Oglyad.Report (Format (..), ReleaseInfo (..), Report (..), render)+import Oglyad.Source.Monorepo (pruneTrees) import Oglyad.Types import Options.Applicative import System.Directory (doesDirectoryExist)@@ -34,7 +38,12 @@ exitUsage = ExitFailure 2 data Opts = Opts- { optConfig :: Maybe Text -> Int -> Config,+ { -- | token, cores, run start, spec ref, release+ optConfig :: Maybe Text -> Int -> UTCTime -> Maybe Text -> Release -> Config,+ optReleases :: [ReleaseArg],+ optRemote :: Text,+ optWorktree :: Bool,+ optRepo :: Maybe Text, optOnly :: [Text], optFormat :: Format, optMinSev :: Severity,@@ -47,6 +56,10 @@ optsP :: Parser Opts optsP = do optConfig <- configP+ optReleases <- many (option (eitherReader parseReleaseArg) (long "release" <> short 'r' <> metavar "RELEASE" <> help "release to check: 43, f43 or rawhide. repeatable. default: every release Fedora's Bodhi hasn't archived"))+ optRemote <- strOption (long "remote" <> metavar "NAME" <> value "origin" <> showDefault <> help "git remote whose release branches (f43, frawhide, ...) hold each release's specs. nothing is fetched, run git fetch yourself")+ optWorktree <- switch (long "worktree" <> help "read specs from the checkout as it is, local edits included, instead of the release branch. needs exactly one --release")+ optRepo <- optional (strOption (long "repo" <> metavar "URL" <> help "Terra repo base url (default: https://repos.fyralabs.com/terraN). needs exactly one --release")) optOnly <- many (option (eitherReader parseCheckName) (long "only" <> metavar "CHECK" <> help ("run only this check, repeatable. one of: " <> names))) optFormat <- option (eitherReader format) (long "format" <> short 'f' <> metavar "FORMAT" <> help "text (default), json, or markdown")@@ -73,36 +86,55 @@ "never" -> Right Nothing other -> Left ("unknown level " <> show other <> ", expected error, warn, info or never") -configP :: Parser (Maybe Text -> Int -> Config)+configP :: Parser (Maybe Text -> Int -> UTCTime -> Maybe Text -> Release -> Config) configP = do cfgMonorepo <- strOption (long "monorepo" <> short 'm' <> metavar "DIR" <> value "." <> showDefault <> help "checkout of terrapkg/packages")- release <- option auto (long "release" <> short 'r' <> metavar "N" <> value (44 :: Int) <> showDefault <> help "Fedora/Terra release to check")- terraRepo <- optional (strOption (long "repo" <> metavar "URL" <> help "Terra repo base url (default: https://repos.fyralabs.com/terraN)"))- fedora <- switch (long "fedora" <> help "also check for overlap with Fedora's release and updates repos (downloads ~60MB)")+ fedora <- switch (long "fedora" <> help "also check for overlap with Fedora's release and updates repos (downloads ~60MB per release)") extraFedora <- many (strOption (long "fedora-repo" <> metavar "URL" <> help "extra repo base url to check for overlap, repeatable")) staleDays <- option auto (long "stale-days" <> metavar "N" <> value (180 :: Int) <> showDefault <> help "builds older than this count as stale") cfgUpstream <- switch (long "upstream" <> short 'u' <> help "query upstream APIs for version drift") cacheHours <- option auto (long "cache-hours" <> metavar "N" <> value (6 :: Int) <> showDefault <> help "reuse upstream answers younger than this, 0 to always refetch") jobs <- optional (option auto (long "jobs" <> short 'j' <> metavar "N" <> help "parallel jobs (default: number of cores)"))- pure $ \cfgGitHubToken cores ->- let r = T.pack (show release)- fedoraRepos =- [ "https://dl.fedoraproject.org/pub/fedora/linux/releases/" <> r <> "/Everything/x86_64/os",- "https://dl.fedoraproject.org/pub/fedora/linux/updates/" <> r <> "/Everything/x86_64"- ]- in Config- { cfgTerraRepo = maybe ("https://repos.fyralabs.com/terra" <> r) id terraRepo,- cfgFedoraRepos = (if fedora then fedoraRepos else []) <> extraFedora,- cfgRelease = release,- cfgDist = ".fc" <> r,- cfgStaleAfter = fromIntegral (staleDays * 86400),- cfgCacheFor = fromIntegral (cacheHours * 3600),- cfgConcurrency = maybe cores id jobs,- ..- }+ pure $ \cfgGitHubToken cores cfgRunStart cfgSpecRef rel ->+ Config+ { cfgTerraRepo = terraRepoFor rel,+ cfgFedoraRepos = (if fedora then fedoraReposFor rel else []) <> extraFedora,+ cfgRelease = relVersion rel,+ cfgDist = releaseDist rel,+ cfgBranch = releaseBranch rel,+ cfgStaleAfter = fromIntegral (staleDays * 86400),+ cfgCacheFor = fromIntegral (cacheHours * 3600),+ cfgConcurrency = maybe cores id jobs,+ ..+ } --- | GITHUB_TOKEN, or whatever the gh cli is logged in with. the token is only--- ever sent to api.github.com, and never passed to child processes+-- | turn --release arguments into releases, asking Bodhi for the+-- maintained ones when none were given, and for rawhide's number when+-- rawhide was asked for+resolveReleases :: (Release -> Config) -> [ReleaseArg] -> IO [Release]+resolveReleases mk args+ | null args = bodhi >>= either (\e -> runError ("can't ask Bodhi which releases are maintained: " <> e <> ". pass --release to pick them")) pure+ | otherwise = nub <$> mapM resolve args+ where+ resolve = \case+ NumberedArg n -> pure (Release (T.pack (show n)) n)+ RawhideArg ->+ bodhi >>= \case+ Right rels | r : _ <- filter isRawhide rels -> pure r+ Right _ -> runError "Bodhi didn't list a rawhide release"+ Left e -> runError ("can't ask Bodhi for rawhide's version: " <> e <> ". pass numbered releases instead")+ -- runApp wants a config. none of it matters for one http request+ bodhi = runApp (mk (Release "rawhide" 0)) $ do+ body <- httpGetE bodhiReleasesUrl+ pure $ case body of+ Left (HttpFailed e) -> Left e+ Left (RateLimited e) -> Left e+ Right b -> parseBodhiReleases b+ runError msg = hPutStrLn stderr ("oglyad: " <> T.unpack msg) >> exitWith exitUsage++-- | GITHUB_TOKEN, or whatever the gh cli is logged in with. oglyad itself+-- only sends it to api.github.com. the one child process that gets it is+-- anda (see Oglyad.Source.Anda), since its GitHub helpers need it githubToken :: IO (Maybe Text) githubToken = lookupEnv "GITHUB_TOKEN" >>= \case@@ -121,10 +153,11 @@ (optsP <**> helper <**> simpleVersioner ("oglyad " <> T.unpack oglyadVersion)) (fullDesc <> progDesc "repository metadata and health checker for Terra") case execParserPure defaultPrefs pinfo args of- Failure f -> do- let (msg, code) = renderFailure f prog- hPutStrLn stderr msg- exitWith (if code == ExitSuccess then ExitSuccess else exitUsage)+ Failure f -> case renderFailure f prog of+ -- --help and --version are output, not errors, so they go to stdout+ -- (help2man and friends read them from there)+ (msg, ExitSuccess) -> putStrLn msg >> exitWith ExitSuccess+ (msg, _) -> hPutStrLn stderr msg >> exitWith exitUsage other -> handleParseResult other usageError :: String -> IO a@@ -145,29 +178,49 @@ case raw of Left (e :: SomeException) -> usageError ("can't read ignore file " <> path <> ": " <> show e) Right bytes -> either (\e -> usageError (path <> ": " <> e)) pure (parseIgnoreFile checkNames bytes)+ when (optWorktree && length optReleases /= 1) $+ usageError "--worktree checks the working tree against one release, so it needs exactly one --release"+ when (isJust optRepo && length optReleases /= 1) $+ usageError "--repo names one Terra repo, so it needs exactly one --release" token <- githubToken cores <- getNumProcessors- let cfg = optConfig token cores- hasAnda <- doesDirectoryExist (cfgMonorepo cfg </> "anda")+ start <- getCurrentTime+ let specRef rel = if optWorktree then Nothing else Just (optRemote <> "/" <> releaseBranch rel)+ mkCfg rel =+ let c = optConfig token cores start (specRef rel) rel+ in maybe c (\url -> c {cfgTerraRepo = url}) optRepo+ hasAnda <- doesDirectoryExist (cfgMonorepo (mkCfg (Release "rawhide" 0)) </> "anda") unless hasAnda $- usageError (cfgMonorepo cfg <> " doesn't look like a terrapkg/packages checkout (no anda/ directory). point -m at one")+ usageError (cfgMonorepo (mkCfg (Release "rawhide" 0)) <> " doesn't look like a terrapkg/packages checkout (no anda/ directory). point -m at one")+ releases <- resolveReleases mkCfg optReleases - (snap, collectFindings) <- runApp cfg buildSnapshot- now <- getCurrentTime let ran = if null optOnly then checkNames else optOnly- findings = collectFindings <> runChecks optOnly snap- Applied {..}- | optNoIgnores = Applied findings [] []- | otherwise = applyIgnores checkNames ran ignores (snapIgnoreLabels snap) findings+ perRelease <- forM releases $ \rel -> do+ let cfg = mkCfg rel+ hPutStrLn stderr ("oglyad: checking " <> T.unpack (releaseLabel rel) <> " from " <> maybe "the working tree" T.unpack (cfgSpecRef cfg))+ (snap, collectFindings) <- runApp cfg buildSnapshot+ let findings = collectFindings <> runChecks optOnly snap+ applied+ | optNoIgnores = Applied findings [] [] []+ | otherwise = applyIgnores checkNames ran ignores (snapIgnoreLabels snap) findings+ relInfo = ReleaseInfo (relName rel) (releaseLabel rel) (cfgSpecRef cfg) (snapHead snap) (cfgTerraRepo cfg)+ pure (rel, relInfo, applied)+ -- extracted trees for commits nothing checks anymore are just disk space+ unless optWorktree $+ pruneTrees [c | (_, ReleaseInfo {riCommit = Just c}, _) <- perRelease]++ now <- getCurrentTime+ let merged f = mergeFindings [(rel, f a) | (rel, _, a) <- perRelease]+ -- an ignore entry is only unused if no release needed it+ unused = [f | f <- merged apUnused, length (fReleases f) == length releases] report = Report { rVersion = oglyadVersion, rGenerated = now,- rMonorepoHead = snapHead snap,- rTerraRepo = cfgTerraRepo cfg,- rUpstream = cfgUpstream cfg,- rFindings = apKept <> apProblems,- rIgnored = apIgnored+ rReleases = [ri | (_, ri, _) <- perRelease],+ rUpstream = any (\(rel, _, _) -> cfgUpstream (mkCfg rel)) perRelease,+ rFindings = merged apKept <> merged apProblems <> unused,+ rIgnored = merged apIgnored } LBS.putStr (render optFormat optMinSev report) when (maybe False (\level -> any ((>= level) . fSeverity) (rFindings report)) optFailOn) $
oglyad.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.0 name: oglyad-version: 0.1.1.0+version: 0.1.2.0 synopsis: repository metadata and health checker for Terra description: oglyad checks a terrapkg/packages checkout against Terra's published@@ -68,11 +68,15 @@ Oglyad.Collect Oglyad.Ignore Oglyad.Process+ Oglyad.Regex+ Oglyad.Release Oglyad.Report+ Oglyad.Source.Anda Oglyad.Source.Cache Oglyad.Source.Monorepo Oglyad.Source.Repodata Oglyad.Source.Rhai+ Oglyad.Source.RhaiEval Oglyad.Source.Upstream Oglyad.Types Oglyad.Version
src/Oglyad/Check/Drift.hs view
@@ -1,14 +1,25 @@ -- | upstream has a newer version than the spec module Oglyad.Check.Drift (check, drift) where +import Data.Char (isAlphaNum) import Data.Text (Text) import Data.Text qualified as T import Oglyad.Types import Oglyad.Version (compareUpstream) --- | (upstream version, spec version, how upstream compares)+-- | (upstream version, spec version, how upstream compares), for packages+-- whose version is meant to follow upstream releases. nightlies (a `nightly`+-- or `quaterdaily` label in anda.hcl) build from a branch head and only+-- borrow the last release as a base, so the newest release isn't something+-- they lag behind. `weekly` isn't one of them: those are mostly releases+-- (fonts, nvidia) checked less often drift :: Package -> Maybe (Text, Text, Ordering)-drift Package {..} = do+drift p+ | pkgNightly p = Nothing+ | otherwise = compared p++compared :: Package -> Maybe (Text, Text, Ordering)+compared Package {..} = do up <- T.strip <$> pkgUpstreamVer spec <- evrVersion <$> pkgSpecEVR pure (up, spec, compareUpstream up spec)@@ -16,14 +27,23 @@ -- pkgUpstreamVer is only populated with --upstream, so this check is silent -- by default check :: Check-check _ p = case drift p of- Just (up, spec, GT) -> [finding' Warn ("upstream has " <> up <> ", spec is at " <> spec)]- Just (up, spec, LT)- -- spec ahead of upstream. snapshots (Version: 1.2^20251101git...) built- -- after the 1.2 release always look like this and are fine. anything else- -- usually means a tag that normalizes badly- | T.any (== '^') spec -> []- | otherwise -> [finding' Info ("spec " <> spec <> " is ahead of upstream " <> up <> ", check tag normalization")]- _ -> []+check _ p = case compared p of+ -- usually a crop(1) meant for a "v" prefix on a tag that doesn't have one,+ -- which turns 6.0.1 into .0.1. a bug in the script, nightly or not+ Just (up, _, _)+ | maybe True (not . isAlphaNum . fst) (T.uncons up) ->+ [finding' Warn ("update.rhai would set the version to \"" <> up <> "\", which doesn't start with a letter or digit")]+ _ -> case drift p of+ Just r -> compareFindings r+ Nothing -> [] where finding' = finding "drift" p+ compareFindings = \case+ (up, spec, GT) -> [finding' Warn ("upstream has " <> up <> ", spec is at " <> spec)]+ (up, spec, LT)+ -- spec ahead of upstream. snapshots (Version: 1.2^20251101git...)+ -- built after the 1.2 release always look like this and are fine.+ -- anything else usually means a tag that normalizes badly+ | T.any (== '^') spec -> []+ | otherwise -> [finding' Info ("spec " <> spec <> " is ahead of upstream " <> up <> ", check tag normalization")]+ _ -> []
src/Oglyad/Check/NoAutoupdate.hs view
@@ -5,5 +5,5 @@ check :: Check check _ p@Package {..} = case pkgUpstream of- Nothing -> [finding "no-autoupdate" p Info "no update.rhai, updates are manual"]+ Nothing -> [finding "no-autoupdate" p Info "no update.rhai (or only comments in it), updates are manual"] Just _ -> []
src/Oglyad/Check/UnparsedRhai.hs view
@@ -2,14 +2,25 @@ -- to-do list for Oglyad.Source.Rhai module Oglyad.Check.UnparsedRhai (check) where +import Data.Maybe (isJust) import Data.Text qualified as T+import Oglyad.Source.Rhai (balanced, tokenize) import Oglyad.Types check :: Check-check _ p@Package {..} = case pkgUpstream of- Just (Unknown raw) ->- [finding "unparsed-rhai" p Info ("can't parse update.rhai: " <> T.take 80 (head' (T.lines raw)))]- _ -> []+check _ p@Package {..} =+ broken <> case pkgUpstream of+ -- anda ran it for us, so there's an answer (or an upstream-error)+ Just (Unknown _) | isJust pkgUpstreamVer || isJust pkgUpstreamErr -> []+ Just (Unknown raw) ->+ [finding "unparsed-rhai" p Info ("can't parse update.rhai: " <> T.take 80 (head' (T.lines raw)))]+ _ -> [] where+ -- not our parser's limits but a script Rhai itself rejects, so+ -- `anda update` fails on it every run+ broken = case tokenize <$> pkgRhai of+ Just (Just toks)+ | not (balanced toks) -> [finding "unparsed-rhai" p Warn "update.rhai has unbalanced brackets, so anda can't run it"]+ _ -> [] head' (l : _) = l head' [] = ""
src/Oglyad/Collect.hs view
@@ -16,10 +16,12 @@ import Data.Text qualified as T import Data.Time (UTCTime, diffUTCTime, getCurrentTime, nominalDay) import Oglyad.App (App, Env (..), HttpError (..), forConcurrentlyN, note)+import Oglyad.Source.Anda (projectNames, updateProject, withScratchCopy) import Oglyad.Source.Cache (CacheEntry (..), UpstreamCache, loadJson, lookupFresh, saveJson) import Oglyad.Source.Monorepo import Oglyad.Source.Repodata (fetchRepo)-import Oglyad.Source.Rhai (parseUpdateRhai)+import Oglyad.Source.Rhai (parseUpdateRhaiWith, tokenize)+import Oglyad.Source.RhaiEval (Simulated (..), simulateVersion) import Oglyad.Source.Upstream (latestVersion) import Oglyad.Types import System.Directory (findExecutable, makeAbsolute)@@ -34,8 +36,15 @@ buildSnapshot = do cfg@Config {..} <- asks envConfig now <- liftIO getCurrentTime- (dirErrs, dirs) <- partitionEithers <$> liftIO (findPackageDirs cfgMonorepo)- hd <- liftIO (headCommit cfgMonorepo)+ -- specs come from a release branch extracted into the cache, or straight+ -- from the working tree with --worktree+ tree <- liftIO $ case cfgSpecRef of+ Nothing -> Right . (cfgMonorepo,"HEAD",) <$> headCommit cfgMonorepo+ Just ref -> fmap (\(dir, sha) -> (dir, sha, Just sha)) <$> checkoutRef cfgMonorepo ref+ let (root, logRef, hd, treeErrs) = case tree of+ Right (r, l, h) -> (Just r, l, h, [])+ Left err -> (Nothing, "HEAD", Nothing, [collectErr (maybe "monorepo" id cfgSpecRef) err])+ (dirErrs, dirs) <- partitionEithers <$> liftIO (maybe (pure []) findPackageDirs root) -- the main repo, every subrepo some package asked for, and Fedora let terraRepos =@@ -45,7 +54,7 @@ ((specErrs, pkgs0), (terra, fedora)) <- liftIO $ concurrently- (runReaderT (readPackages dirs) env)+ (runReaderT (readPackages (maybe cfgMonorepo id root) logRef hd dirs) env) (runReaderT (fetchRepos terraRepos cfgFedoraRepos) env) let (repoErrs, repos) = partitionEithers terra@@ -57,7 +66,10 @@ } | p <- pkgs0 ]- (upErrs, pkgs) <- if cfgUpstream then withUpstreams now pkgs1 else pure ([], pkgs1)+ (upErrs, pkgs2) <- if cfgUpstream then withUpstreams now pkgs1 else pure ([], pkgs1)+ (andaErrs, pkgs) <- case root of+ Just r | cfgUpstream -> withAnda r now pkgs2+ _ -> pure ([], pkgs2) let snap = Snapshot@@ -72,7 +84,7 @@ [ (collectErr (T.pack path) ("can't read package dir: " <> err)) {fPath = Just (T.pack path)} | (path, err) <- dirErrs ]- pure (snap, unreadable <> specErrs <> repoErrs <> upErrs)+ pure (snap, treeErrs <> unreadable <> specErrs <> repoErrs <> upErrs <> andaErrs) -- | every repo at once. Terra failures become findings, Fedora ones just mean -- no overlap data@@ -87,18 +99,19 @@ Right url -> Right . either (const Map.empty) id <$> fetchRepo url pure (partitionEithers results) --- | evaluate every spec, reusing cached evaluations for unchanged packages-readPackages :: [PkgDir] -> App ([Finding], [Package])-readPackages dirs = do+-- | evaluate every spec under root, reusing cached evaluations for unchanged+-- packages. logRef and hd say which commit's history to read commit times from+readPackages :: FilePath -> Text -> Maybe Text -> [PkgDir] -> App ([Finding], [Package])+readPackages root0 logRef hd dirs = do Config {..} <- asks envConfig- root <- liftIO (makeAbsolute cfgMonorepo)+ root <- liftIO (makeAbsolute root0) -- one cache file per dist, so cron jobs checking different releases don't -- keep evicting each other's entries let cacheFile = "specs" <> T.unpack cfgDist <> ".json" (commits, (macros, cache)) <- liftIO $ concurrently- (commitTimes cfgMonorepo (map pdPath dirs))+ (commitTimes cfgMonorepo logRef hd cfgDist (map pdPath dirs)) ((,) <$> macroFingerprint <*> (fromMaybe Map.empty <$> loadJson cacheFile)) keyed <- forConcurrentlyN cfgConcurrency dirs $ \d -> liftIO $ do key <- specFingerprint macros cfgDist root (pdPath d)@@ -124,8 +137,8 @@ ] (errs, pkgs) = partitionEithers $- [toPackage commits d (Just i) | Evaluated _ d i <- results]- <> [toPackage commits d Nothing | NoSpec d <- results]+ [toPackage commits k d (Just i) | Evaluated k d i <- results]+ <> [toPackage commits "" d Nothing | NoSpec d <- results] pure (missing <> errs, pkgs) -- | what happened to one package dir's spec@@ -134,21 +147,22 @@ | NoSpec PkgDir | Skipped --- | last commit per package dir, reused as long as HEAD hasn't moved.--- uncommitted changes can't change any "last commit", so HEAD is the whole key-commitTimes :: FilePath -> [FilePath] -> IO (Map FilePath UTCTime)-commitTimes root dirs = do- hd <- headCommit root- cached <- loadJson "commits.json"+-- | last commit per package dir, reused as long as the commit hasn't moved.+-- uncommitted changes can't change any "last commit", so the commit is the+-- whole key. one cache file per dist, since each release reads its own branch+commitTimes :: FilePath -> Text -> Maybe Text -> Text -> [FilePath] -> IO (Map FilePath UTCTime)+commitTimes mono ref hd dist dirs = do+ let file = "commits" <> T.unpack dist <> ".json"+ cached <- loadJson file case (hd, cached) of (Just h, Just (h', m)) | h == h', all (`Map.member` m) dirs -> pure m _ -> do- m <- lastCommits root dirs- mapM_ (\h -> saveJson "commits.json" (h, m)) hd+ m <- lastCommits mono ref dirs+ mapM_ (\h -> saveJson file (h, m)) hd pure m -toPackage :: Map FilePath UTCTime -> PkgDir -> Maybe (Either Text SpecInfo) -> Either Finding Package-toPackage commits PkgDir {..} = \case+toPackage :: Map FilePath UTCTime -> Text -> PkgDir -> Maybe (Either Text SpecInfo) -> Either Finding Package+toPackage commits key PkgDir {..} = \case Nothing -> Left (pathErr "no spec file found") Just (Left err) -> Left (pathErr ("rpmspec failed: " <> firstLine err)) Just (Right SpecInfo {..}) ->@@ -157,16 +171,24 @@ { pkgName = siName, pkgPath = pdPath, pkgSubrepo = pdSubrepo,+ pkgNightly = pdNightly,+ pkgSpecPath = pdSpec,+ pkgFingerprint = key, pkgSpecEVR = Just siEVR, pkgRepoBuild = Nothing, pkgLastCommit = Map.lookup pdPath commits,- pkgUpstream = parseUpdateRhai <$> pdUpdateRhai,+ -- an update.rhai with nothing but comments in it updates nothing+ pkgUpstream = parseUpdateRhaiWith pdVersionMacros <$> (pdUpdateRhai >>= nonEmpty),+ pkgRhai = pdUpdateRhai, pkgUpstreamVer = Nothing, pkgUpstreamErr = Nothing, pkgRepoChecked = False } where firstLine t = let l = T.takeWhile (/= '\n') t in if T.null l then "(no output)" else l+ nonEmpty script = case tokenize script of+ Just [] -> Nothing+ _ -> Just script pathErr msg = (collectErr (T.pack pdPath) msg) {fPath = Just (T.pack pdPath)} -- | fill in upstream versions, from the cache when it's fresh enough.@@ -181,7 +203,10 @@ note "no GITHUB_TOKEN (or `gh auth token`), GitHub lookups will hit the 60/hour limit fast" cache <- liftIO (fromMaybe Map.empty <$> loadJson "upstream.json") :: App UpstreamCache let wanted = [p | p <- pkgs, Just src <- [pkgUpstream p], lookable src]- fresh p = pkgUpstream p >>= \src -> lookupFresh cfgCacheFor now src cache+ -- anything fetched since this run started is fresh, so checking several+ -- releases asks each upstream once even with --cache-hours 0+ maxAge = max cfgCacheFor (diffUTCTime now cfgRunStart)+ fresh p = pkgUpstream p >>= \src -> lookupFresh maxAge now src cache (crates, others) = partition (isCrates . pkgUpstream) wanted lookup1 p = case (fresh p, pkgUpstream p) of (Just e, _) -> pure (pkgPath p, either (Left . HttpFailed) Right (ceResult e))@@ -219,7 +244,7 @@ pure ( rateErr, [ case Map.lookup (pkgPath p) byPath of- Just (Right v) -> p {pkgUpstreamVer = Just v}+ Just (Right v) -> p {pkgUpstreamVer = replay p v} Just (Left (HttpFailed e)) -> p {pkgUpstreamErr = Just e} -- rate limits are reported once above, not as a broken upstream Just (Left (RateLimited _)) -> p@@ -228,8 +253,17 @@ ] ) where+ -- run the script's guards and edits over the raw value, so a tag the+ -- script would skip (or crop) doesn't show up as drift+ replay p v = case (pkgUpstream p, pkgRhai p) of+ (Just src, Just script) -> case simulateVersion src v script of+ Sets v' -> Just v'+ NoUpdate -> Nothing+ CantTell -> Just v+ _ -> Just v lookable = \case CommitTracked -> False+ NoVersion -> False Derived _ -> False Unknown _ -> False _ -> True@@ -237,5 +271,66 @@ Just (Crates _ _) -> True _ -> False +-- | run the real anda for scripts oglyad couldn't follow, on a throwaway+-- copy of the tree, and read the Version it leaves in each spec. results are+-- cached like upstream answers, keyed by the package's fingerprint+withAnda :: FilePath -> UTCTime -> [Package] -> App ([Finding], [Package])+withAnda root now pkgs = do+ Config {..} <- asks envConfig+ let wanted = [p | p@Package {pkgUpstream = Just (Unknown _), pkgSpecPath = Just _} <- pkgs]+ cacheFile = "anda" <> T.unpack cfgDist <> ".json"+ maxAge = max cfgCacheFor (diffUTCTime now cfgRunStart)+ cache <- liftIO (fromMaybe Map.empty <$> loadJson cacheFile) :: App (Map Text CacheEntry)+ let fresh p = case Map.lookup (pkgFingerprint p) cache of+ Just e | diffUTCTime now (ceFetched e) <= maxAge -> Just e+ _ -> Nothing+ misses = [p | p <- wanted, isNothing (fresh p)]+ hasAnda <- liftIO (isJust <$> findExecutable "anda")+ (problems, ran) <-+ if+ | null misses -> pure ([], Map.empty)+ | not hasAnda -> do+ note ("anda not found, so " <> show (length misses) <> " update.rhai scripts oglyad can't follow are skipped")+ pure ([], Map.empty)+ | otherwise -> do+ note ("running anda update for " <> show (length wanted) <> " scripts oglyad can't follow, " <> show (length wanted - length misses) <> " cached")+ env <- ask+ r <- liftIO $ withScratchCopy root $ \copy ->+ projectNames copy >>= \case+ Left e -> pure (Left e)+ Right names -> fmap Right . flip runReaderT env . forConcurrentlyN cfgConcurrency misses $ \p ->+ liftIO $+ (pkgPath p,) <$> case (Map.lookup (pkgPath p) names, pkgSpecPath p) of+ (Just name, Just spec) ->+ updateProject copy cfgGitHubToken cfgBranch name >>= \case+ Left e -> pure (Left e)+ Right () ->+ either (Left . ("rpmspec failed on the updated spec: " <>)) (Right . evrVersion . siEVR)+ <$> querySpec cfgRelease cfgDist (copy </> spec)+ _ -> pure (Left "anda doesn't list this project")+ pure $ case join' r of+ Left e -> ([(collectErr "anda" e) {fSeverity = Warn}], Map.empty)+ Right xs -> ([], Map.fromList xs)+ let answer p = maybe (Map.lookup (pkgPath p) ran) (Just . ceResult) (fresh p)+ new =+ Map.fromList+ [ (pkgFingerprint p, CacheEntry now (Right v))+ | p <- misses,+ Just (Right v) <- [Map.lookup (pkgPath p) ran]+ ]+ recent = Map.filter (\e -> diffUTCTime now (ceFetched e) < 30 * nominalDay) cache+ liftIO (saveJson cacheFile (new <> recent))+ pure+ ( problems,+ [ case answer p of+ Just (Right v) -> p {pkgUpstreamVer = Just v}+ Just (Left e) -> p {pkgUpstreamErr = Just ("update.rhai failed under anda: " <> e)}+ Nothing -> p+ | p <- pkgs+ ]+ )+ where+ join' = either Left id+ collectErr :: Text -> Text -> Finding-collectErr what msg = Finding {fCheck = "collect", fPackage = what, fPath = Nothing, fSeverity = Error, fMessage = msg}+collectErr what msg = Finding {fCheck = "collect", fPackage = what, fPath = Nothing, fSeverity = Error, fMessage = msg, fReleases = []}
src/Oglyad/Ignore.hs view
@@ -77,8 +77,11 @@ apKept :: [Finding], -- | findings an ignore matched apIgnored :: [Finding],- -- | problems with the ignores themselves: unused file entries, unknown- -- check names in anda.hcl labels+ -- | ignore file entries that matched nothing. kept apart from apProblems+ -- because with several releases, an entry is only unused if it matched+ -- nothing in any of them+ apUnused :: [Finding],+ -- | unknown check names in anda.hcl labels apProblems :: [Finding] } @@ -91,7 +94,8 @@ Applied { apKept = kept, apIgnored = ignored,- apProblems = unused <> badLabels+ apUnused = unused,+ apProblems = badLabels } where (ignored, kept) = partition isIgnored findings@@ -109,7 +113,8 @@ fPackage = describe (irTarget r), fPath = case irTarget r of ByPath p -> Just p; ByName _ -> Nothing, fSeverity = Info,- fMessage = "ignore file entry for " <> irCheck r <> " matches nothing anymore, remove it"+ fMessage = "ignore file entry for " <> irCheck r <> " matches nothing anymore, remove it",+ fReleases = [] } | r <- rules, irCheck r `elem` ran,@@ -121,7 +126,8 @@ fPackage = T.pack path, fPath = Just (T.pack path), fSeverity = Warn,- fMessage = "oglyad_ignore in anda.hcl names unknown check " <> c+ fMessage = "oglyad_ignore in anda.hcl names unknown check " <> c,+ fReleases = [] } | (path, cs) <- Map.toList labels, c <- cs,
src/Oglyad/Process.hs view
@@ -2,6 +2,7 @@ -- leaking secrets module Oglyad.Process ( run,+ runCapture, childEnv, ) where@@ -15,7 +16,7 @@ import Data.Text.Encoding qualified as TE import System.Environment (getEnvironment) import System.Exit (ExitCode (..))-import System.Process.Typed (nullStream, proc, readProcess, setEnv, setStdin)+import System.Process.Typed (nullStream, proc, readProcess, setEnv, setStdin, setWorkingDir) import System.Timeout (timeout) -- | run a command and return its stdout. a missing executable, a non-zero@@ -34,6 +35,21 @@ Right Nothing -> Left (T.pack cmd <> " timed out after 5 minutes") Right (Just (ExitSuccess, out, _)) -> Right (decode out) Right (Just (ExitFailure _, _, err)) -> Left (T.strip (decode err))+ where+ decode = TE.decodeUtf8Lenient . LBS.toStrict++-- | like 'run', but in a working directory, with extra variables on top of+-- the allowlist, and handing back the exit code, stdout and stderr even when+-- the command succeeded. only for tools that need something the allowlist+-- leaves out, like anda needing GITHUB_TOKEN+runCapture :: FilePath -> [(String, String)] -> FilePath -> [String] -> IO (Either Text (ExitCode, Text, Text))+runCapture dir extra cmd args = do+ env <- (extra <>) . filter ((`notElem` map fst extra) . fst) . childEnv <$> getEnvironment+ r <- try (timeout (5 * 60 * 1_000_000) (readProcess (setWorkingDir dir (setEnv env (setStdin nullStream (proc cmd args))))))+ pure $ case r of+ Left (e :: IOException) -> Left (T.pack cmd <> ": " <> T.pack (show e))+ Right Nothing -> Left (T.pack cmd <> " timed out after 5 minutes")+ Right (Just (code, out, err)) -> Right (code, decode out, decode err) where decode = TE.decodeUtf8Lenient . LBS.toStrict
+ src/Oglyad/Regex.hs view
@@ -0,0 +1,514 @@+-- | a regex engine for the dialect of Rust's regex crate, which andax's+-- find(), find_all() and sub() use (andax/fns/kokoro.rs in FyraLabs/anda).+--+-- it works the way Rust's BoundedBacktracker does: compile to a Thompson+-- NFA shaped like regex-automata's compiler builds it, then backtrack with a+-- visited set of (state, position) pairs. the visited set keeps it linear+-- time, and it's also what decides which captures win when a repeated group+-- can match empty, so mirroring the NFA shape gets the same answers as Rust.+-- it was checked against the real crate on every regex in terrapkg/packages+-- and ~300k fuzzed ones, with identical matches and captures.+--+-- supported: literals and escapes, ., classes with ranges, negation and+-- [:posix:] names, \d \w \s and their negations, \b \B \A \z, ^ $, groups+-- ((...), (?:...), (?P<name>...), (?<name>...)), alternation, * + ? {n}+-- {n,} {n,m} and their lazy forms, and the i, m and s flags. anything else+-- is a compile error, which callers treat as "can't tell"+module Oglyad.Regex+ ( Regex,+ compile,+ captures,+ capturesAll,+ replaceAll,+ )+where++import Control.Applicative ((<|>))+import Control.Monad.ST (runST)+import Data.Char (GeneralCategory (..), generalCategory, isAlphaNum, isAsciiLower, isAsciiUpper, isDigit, isHexDigit, isPunctuation, isSpace, isSymbol, toLower, toUpper)+import Data.IntMap.Strict (IntMap)+import Data.IntMap.Strict qualified as IM+import Data.Text (Text)+import Data.Text qualified as T+import Data.Vector qualified as V+import Data.Vector.Unboxed qualified as VU+import Data.Vector.Unboxed.Mutable qualified as MVU+import Text.Read (readMaybe)++data Node+ = -- | one character+ One (Char -> Bool)+ | -- | ^ and $, True for multi-line+ LineStart Bool+ | LineEnd Bool+ | -- | \b, False for \B+ WordBoundary Bool+ | Group (Maybe Int) Node+ | Alt [Node]+ | Seq [Node]+ | -- | min, max, greedy+ Repeat Int (Maybe Int) Bool Node++data Regex = Regex+ { reProg :: Prog,+ reGroups :: Int,+ reNames :: [(Text, Int)]+ }++data Flags = Flags {fI, fM, fS :: Bool}++-- * parsing++-- | parser state: input left, groups numbered so far, names seen+data St = St {stIn :: String, stGroups :: Int, stNames :: [(Text, Int)]}++type Parse a = St -> Either Text (a, St)++compile :: Text -> Either Text Regex+compile src = do+ (node, st) <- alternation (Flags False False False) (St (T.unpack src) 0 [])+ case stIn st of+ [] -> Right (Regex (toProg (stGroups st) node) (stGroups st) (stNames st))+ c : _ -> Left ("unexpected " <> T.singleton c)++-- | a|b|c, up to a ')' or the end. (?flags) partway through applies to the+-- rest of the group, alternatives included, like Rust+alternation :: Flags -> Parse Node+alternation flags st0 = go flags st0 []+ where+ go fl st acc = do+ ((node, fl'), st') <- sequence' fl st []+ case stIn st' of+ '|' : rest -> go fl' st' {stIn = rest} (node : acc)+ _ -> Right (alt (reverse (node : acc)), st')+ alt [n] = n+ alt ns = Alt ns++sequence' :: Flags -> St -> [Node] -> Either Text ((Node, Flags), St)+sequence' fl st acc = case stIn st of+ [] -> done+ '|' : _ -> done+ ')' : _ -> done+ -- a bare flag group changes the flags for what follows+ '(' : '?' : rest+ | (fs, ')' : rest') <- span (`elem` ("imsxUR-" :: String)) rest,+ not (null fs) -> do+ fl' <- setFlags fl fs+ sequence' fl' st {stIn = rest'} acc+ _ -> do+ (atom, st1) <- atomP fl st+ (node, st2) <- quantifier atom st1+ sequence' fl st2 (node : acc)+ where+ done = Right ((Seq (reverse acc), fl), st)++setFlags :: Flags -> String -> Either Text Flags+setFlags fl0 = go True fl0+ where+ go _ fl [] = Right fl+ go on fl (c : cs) = case c of+ '-' -> go False fl cs+ 'i' -> go on fl {fI = on} cs+ 'm' -> go on fl {fM = on} cs+ 's' -> go on fl {fS = on} cs+ _ -> Left ("unsupported flag " <> T.singleton c)++quantifier :: Node -> Parse Node+quantifier atom st = case stIn st of+ '*' : rest -> lazy 0 Nothing rest+ '+' : rest -> lazy 1 Nothing rest+ '?' : rest -> lazy 0 (Just 1) rest+ '{' : rest+ | (a, rest1) <- span isDigit rest,+ not (null a) ->+ case rest1 of+ '}' : rest2 -> bounded a (Just a) rest2+ ',' : '}' : rest2 -> bounded a Nothing rest2+ ',' : rest2+ | (b, '}' : rest3) <- span isDigit rest2, not (null b) -> bounded a (Just b) rest3+ _ -> Left "bad repetition"+ _ -> Right (atom, st)+ where+ bounded a b rest = case (readMaybe a, traverse readMaybe b) of+ (Just lo, Just hi) | maybe True (>= lo) hi -> lazy lo hi rest+ _ -> Left "bad repetition"+ lazy lo hi = \case+ '?' : rest -> Right (Repeat lo hi False atom, st {stIn = rest})+ rest -> Right (Repeat lo hi True atom, st {stIn = rest})++atomP :: Flags -> Parse Node+atomP fl st = case stIn st of+ '(' : '?' : ':' : rest -> group Nothing st {stIn = rest}+ '(' : '?' : 'P' : '<' : rest -> named rest+ '(' : '?' : '<' : rest -> named rest+ '(' : '?' : _ -> Left "unsupported group"+ '(' : rest ->+ let n = stGroups st + 1+ in group (Just n) st {stIn = rest, stGroups = n}+ '[' : rest -> do+ (p, rest') <- classP fl rest+ Right (One p, st {stIn = rest'})+ '.' : rest -> Right (One (\c -> fS fl || c /= '\n'), st {stIn = rest})+ '^' : rest -> Right (LineStart (fM fl), st {stIn = rest})+ '$' : rest -> Right (LineEnd (fM fl), st {stIn = rest})+ '\\' : rest -> do+ (node, rest') <- escape fl rest+ Right (node, st {stIn = rest'})+ c : rest+ | c `elem` ("*+?{" :: String) -> Left "repetition with nothing to repeat"+ | otherwise -> Right (One (charEq fl c), st {stIn = rest})+ [] -> Left "unexpected end"+ where+ group idx s = do+ (inner, s') <- alternation fl s+ case stIn s' of+ ')' : rest -> Right (Group idx inner, s' {stIn = rest})+ _ -> Left "unclosed group"+ named rest = case span (\c -> isAlphaNum c || c == '_') rest of+ (name, '>' : rest')+ | not (null name) ->+ let n = stGroups st + 1+ in group (Just n) st {stIn = rest', stGroups = n, stNames = (T.pack name, n) : stNames st}+ _ -> Left "bad group name"++charEq :: Flags -> Char -> Char -> Bool+charEq fl c+ | fI fl = \x -> toLower x == toLower c || toUpper x == toUpper c+ | otherwise = (== c)++-- | an escape outside a class+escape :: Flags -> String -> Either Text (Node, String)+escape fl = \case+ 'b' : rest -> Right (WordBoundary True, rest)+ 'B' : rest -> Right (WordBoundary False, rest)+ 'A' : rest -> Right (LineStart False, rest)+ 'z' : rest -> Right (LineEnd False, rest)+ s -> do+ (p, rest) <- classEscape fl s+ Right (One p, rest)++-- | an escape that stands for one character or a class of them+classEscape :: Flags -> String -> Either Text (Char -> Bool, String)+classEscape fl = \case+ 'd' : rest -> Right (isDigit', rest)+ 'D' : rest -> Right (not . isDigit', rest)+ 'w' : rest -> Right (isWord, rest)+ 'W' : rest -> Right (not . isWord, rest)+ 's' : rest -> Right (isSpace, rest)+ 'S' : rest -> Right (not . isSpace, rest)+ 'n' : rest -> lit '\n' rest+ 't' : rest -> lit '\t' rest+ 'r' : rest -> lit '\r' rest+ 'f' : rest -> lit '\f' rest+ 'v' : rest -> lit '\v' rest+ 'x' : a : b : rest | isHexDigit a && isHexDigit b, Just n <- readMaybe ("0x" <> [a, b]) -> lit (toEnum n) rest+ c : rest+ | isPunctuation c || isSymbol c || c == ' ' -> lit c rest+ _ -> Left "unsupported escape"+ where+ lit c rest = Right (charEq fl c, rest)++-- | Rust's \d is Unicode-aware, and isDigit is ASCII-only+isDigit' :: Char -> Bool+isDigit' c = generalCategory c == DecimalNumber++isWord :: Char -> Bool+isWord c = isAlphaNum c || c == '_'++-- | the inside of [...], given what's after the '['+classP :: Flags -> String -> Either Text (Char -> Bool, String)+classP fl s0 = do+ let (negated, s1) = case s0 of+ '^' : r -> (True, r)+ r -> (False, r)+ -- a ']' right at the start is a literal+ (items, rest) <- case s1 of+ ']' : r -> go [charEq fl ']'] r+ r -> go [] r+ let p c = any ($ c) items+ Right (if negated then not . p else p, rest)+ where+ go acc = \case+ ']' : rest -> Right (acc, rest)+ '[' : ':' : rest+ | (name, ':' : ']' : rest') <- span isAsciiLower rest -> do+ p <- posix name+ go (p : acc) rest'+ '[' : _ -> Left "nested classes aren't supported"+ '&' : '&' : _ -> Left "class operations aren't supported"+ '-' : '-' : _ -> Left "class operations aren't supported"+ '~' : '~' : _ -> Left "class operations aren't supported"+ s -> do+ (lo, rest) <- single s+ case (lo, rest) of+ (Left c, '-' : rest') | take 1 rest' /= "]" -> do+ (hi, rest'') <- single rest'+ case hi of+ Left d | c <= d -> go (range c d : acc) rest''+ _ -> Left "bad class range"+ (Left c, _) -> go (charEq fl c : acc) rest+ (Right p, _) -> go (p : acc) rest+ -- one class item: Left for a plain character (which can start a range),+ -- Right for an escape like \d+ single = \case+ '\\' : rest -> case rest of+ c : rest' | isPunctuation c || isSymbol c || c == ' ' -> Right (Left c, rest')+ 'n' : rest' -> Right (Left '\n', rest')+ 't' : rest' -> Right (Left '\t', rest')+ _ -> do+ (p, rest') <- classEscape fl rest+ Right (Right p, rest')+ c : rest -> Right (Left c, rest)+ [] -> Left "unclosed class"+ range lo hi+ | fI fl = \c -> any (\x -> lo <= x && x <= hi) [c, toLower c, toUpper c]+ | otherwise = \c -> lo <= c && c <= hi+ posix = \case+ "alnum" -> Right isAlphaNumAscii+ "alpha" -> Right (\c -> isAsciiLower c || isAsciiUpper c)+ "digit" -> Right isDigit+ "lower" -> Right isAsciiLower+ "upper" -> Right isAsciiUpper+ "space" -> Right (`elem` (" \t\n\r\f\v" :: String))+ "xdigit" -> Right isHexDigit+ "punct" -> Right (\c -> c < '\x80' && (isPunctuation c || isSymbol c))+ _ -> Left "unknown posix class"+ isAlphaNumAscii c = isDigit c || isAsciiLower c || isAsciiUpper c++-- * compiling to an NFA++data Look = AtLineStart Bool | AtLineEnd Bool | AtWordBoundary Bool++data State+ = SChar (Char -> Bool) !Int+ | -- | alternatives in preference order+ SUnion [Int]+ | -- | record the position in a capture slot+ SCapture !Int !Int+ | SLook Look !Int+ | SMatch++data Prog = Prog+ { progStates :: V.Vector State,+ progStart :: Int,+ -- | two per group, group 0 being the whole match+ progSlots :: Int+ }++-- | NFA under construction: the next free id and the states so far+type Build = (Int, IntMap State)++new :: State -> Build -> (Int, Build)+new st (n, m) = (n, (n + 1, IM.insert n st m))++-- | reserve a state to fill in later, for loops+reserve :: Build -> (Int, Build)+reserve (n, m) = (n, (n + 1, m))++fill :: Int -> State -> Build -> Build+fill i st (n, m) = (n, IM.insert i st m)++toProg :: Int -> Node -> Prog+toProg groups node =+ let (matchId, b1) = new SMatch (0, IM.empty)+ (end0, b2) = new (SCapture 1 matchId) b1+ (body, b3) = nfa node end0 b2+ (start, (n, states)) = new (SCapture 0 body) b3+ in Prog (V.generate n (states IM.!)) start (2 * (groups + 1))++-- | compile a node that continues to `next`, returning its start state.+-- the repetition shapes follow regex-automata's thompson compiler+-- (c_at_least, c_bounded, c_zero_or_one), since the visited set makes the+-- shape observable+nfa :: Node -> Int -> Build -> (Int, Build)+nfa node next b = case node of+ One p -> new (SChar p next) b+ LineStart multi -> new (SLook (AtLineStart multi) next) b+ LineEnd multi -> new (SLook (AtLineEnd multi) next) b+ WordBoundary want -> new (SLook (AtWordBoundary want) next) b+ Group Nothing inner -> nfa inner next b+ Group (Just g) inner ->+ let (close, b1) = new (SCapture (2 * g + 1) next) b+ (body, b2) = nfa inner close b1+ in new (SCapture (2 * g) body) b2+ Seq ns -> foldr (\n k nx bb -> let (s, bb') = k nx bb in nfa n s bb') (,) ns next b+ Alt ns ->+ let (starts, b1) = foldr (\n (acc, bb) -> let (s, bb') = nfa n next bb in (s : acc, bb')) ([], b) ns+ in new (SUnion starts) b1+ Repeat lo hi greedy inner -> case hi of+ Just 1+ | lo == 0 ->+ let (x, b1) = nfa inner next b+ in new (SUnion (order x next)) b1+ Just m+ | lo == m -> copies lo next b+ | otherwise ->+ -- the optional copies nest: once one is skipped, the rest are too+ let (opt, b1) = foldr (\_ (nx, bb) -> let (x, bb') = nfa inner nx bb in new (SUnion (order x next)) bb') (next, b) [1 .. m - lo]+ in copies' lo opt b1+ Nothing+ | lo == 0 && minLen inner > 0 ->+ let (u, b1) = reserve b+ (x, b2) = nfa inner u b1+ in (u, fill u (SUnion (order x next)) b2)+ | lo == 0 ->+ -- x* where x can match empty is compiled as (x+)?, which keeps+ -- the preference order right (rust-lang/regex#779)+ let (plus, b1) = reserve b+ (x, b2) = nfa inner plus b1+ b3 = fill plus (SUnion (order x next)) b2+ in new (SUnion (order x next)) b3+ | otherwise ->+ -- n-1 copies, then one more that loops+ let (u, b1) = reserve b+ (x, b2) = nfa inner u b1+ b3 = fill u (SUnion (order x next)) b2+ in copies' (lo - 1) x b3+ where+ order x nx = if greedy then [x, nx] else [nx, x]+ copies n nx bb = copies' n nx bb+ copies' n nx bb = foldr (\_ (s, bb') -> nfa inner s bb') (nx, bb) [1 .. n]++-- | the shortest match a node can make, to tell whether x* can loop on+-- nothing+minLen :: Node -> Int+minLen = \case+ One _ -> 1+ LineStart _ -> 0+ LineEnd _ -> 0+ WordBoundary _ -> 0+ Group _ n -> minLen n+ Seq ns -> sum (map minLen ns)+ Alt ns -> if null ns then 0 else minimum (map minLen ns)+ Repeat lo _ _ n -> lo * minLen n++-- * matching++-- | positions the visited set can track before we give up. Rust switches to+-- another engine past its limit. we only ever see version strings, so a+-- refusal here is fine+visitedLimit :: Int+visitedLimit = 20000000++data Frame = Step !Int !Int | Restore !Int !Int++-- | the first match starting at or after a position, as capture slots.+-- the visited set lives for the whole search, like Rust's: a (state,+-- position) that failed from one start fails from every later one too+searchFrom :: Regex -> VU.Vector Char -> Int -> Either Text (Maybe (VU.Vector Int))+searchFrom re input from+ | V.length states * width > visitedLimit = Left "text too long for the regex engine"+ | otherwise = Right $ runST $ do+ visited <- MVU.replicate (V.length states * width) False+ slots <- MVU.replicate (progSlots prog) (-1)+ let tryAt at+ | at > len = pure Nothing+ | otherwise =+ run [Step (progStart prog) at] >>= \case+ Nothing -> tryAt (at + 1)+ found -> pure found+ run = \case+ [] -> pure Nothing+ Restore slot old : rest -> MVU.write slots slot old >> run rest+ Step sid at : rest -> step sid at rest+ step sid at rest = do+ let key = sid * width + at+ seen <- MVU.read visited key+ if seen+ then run rest+ else do+ MVU.write visited key True+ case states V.! sid of+ SChar p nx+ | at < len && p (input VU.! at) -> step nx (at + 1) rest+ | otherwise -> run rest+ SUnion [] -> run rest+ SUnion (x : xs) -> step x at (map (`Step` at) xs <> rest)+ SCapture slot nx -> do+ old <- MVU.read slots slot+ MVU.write slots slot at+ step nx at (Restore slot old : rest)+ SLook l nx+ | look l at -> step nx at rest+ | otherwise -> run rest+ SMatch -> Just <$> VU.freeze slots+ tryAt from+ where+ prog = reProg re+ states = progStates prog+ len = VU.length input+ width = len + 1+ look l at = case l of+ AtLineStart multi -> at == 0 || (multi && input VU.! (at - 1) == '\n')+ AtLineEnd multi -> at == len || (multi && input VU.! at == '\n')+ AtWordBoundary want -> (wordAt (at - 1) /= wordAt at) == want+ wordAt i = i >= 0 && i < len && isWord (input VU.! i)++-- | (start, end, slots) of a match+type Match = (Int, Int, VU.Vector Int)++toMatch :: VU.Vector Int -> Match+toMatch slots = (slots VU.! 0, slots VU.! 1, slots)++-- | every non-overlapping match, like Rust's captures_iter. an empty match+-- right where the previous one ended is skipped+matches :: Regex -> VU.Vector Char -> Either Text [Match]+matches re input = go 0 Nothing+ where+ go from lastEnd+ | from > VU.length input = Right []+ | otherwise =+ searchFrom re input from >>= \case+ Nothing -> Right []+ Just slots -> case toMatch slots of+ (s, e, _)+ | s == e && Just e == lastEnd -> go (s + 1) lastEnd+ m@(s, e, _) -> (m :) <$> go (if s == e then e + 1 else e) (Just e)++-- | group texts for one match, group 0 first. Nothing for groups that+-- didn't take part+groupsOf :: Regex -> VU.Vector Char -> Match -> [Maybe Text]+groupsOf re input (_, _, slots) =+ [ if a >= 0 && b >= 0 then Just (T.pack (VU.toList (VU.slice a (b - a) input))) else Nothing+ | g <- [0 .. reGroups re],+ let a = slots VU.! (2 * g)+ b = slots VU.! (2 * g + 1)+ ]++chars :: Text -> VU.Vector Char+chars = VU.fromList . T.unpack++-- | the first match, like Rust's Regex::captures. Left when the text is+-- too long for the engine+captures :: Regex -> Text -> Either Text (Maybe [Maybe Text])+captures re t = fmap (groupsOf re input . toMatch) <$> searchFrom re input 0+ where+ input = chars t++capturesAll :: Regex -> Text -> Either Text [[Maybe Text]]+capturesAll re t = map (groupsOf re input) <$> matches re input+ where+ input = chars t++-- | Rust's replace_all: $1, ${1}, $name and ${name} expand to groups (empty+-- when missing), $$ is a dollar sign. $name takes the longest run of+-- letters, digits and underscores, so "$1a" is the group named "1a"+replaceAll :: Regex -> Text -> Text -> Either Text Text+replaceAll re rep t = T.concat . go 0 <$> matches re input+ where+ input = chars t+ slice a b = T.pack (VU.toList (VU.slice a (b - a) input))+ go pos [] = [slice pos (VU.length input)]+ go pos (m@(s, e, _) : ms) = slice pos s : expand (groupsOf re input m) : go e ms+ expand groups = T.pack (expandS groups (T.unpack rep))+ expandS groups = \case+ [] -> []+ '$' : '$' : rest -> '$' : expandS groups rest+ '$' : '{' : rest+ | (name, '}' : rest') <- span (/= '}') rest, not (null name) -> lookupGroup groups name <> expandS groups rest'+ '$' : rest+ | (name, rest') <- span (\c -> isAlphaNum c || c == '_') rest, not (null name) -> lookupGroup groups name <> expandS groups rest'+ c : rest -> c : expandS groups rest+ lookupGroup groups name =+ let idx = readMaybe name <|> lookup (T.pack name) (reNames re)+ in maybe "" T.unpack (idx >>= \i -> if i < length groups then groups !! i else Nothing)
+ src/Oglyad/Release.hs view
@@ -0,0 +1,134 @@+-- | which Fedora/Terra releases to check, and everything that follows from+-- one: the Terra repo, the %{dist} tag, the terrapkg/packages branch and the+-- Fedora repos. also merges findings from several releases into one report+module Oglyad.Release+ ( Release (..),+ isRawhide,+ releaseLabel,+ releaseDist,+ releaseBranch,+ terraRepoFor,+ fedoraReposFor,+ parseReleaseArg,+ ReleaseArg (..),+ bodhiReleasesUrl,+ parseBodhiReleases,+ mergeFindings,+ )+where++import Data.Aeson (Value (..), eitherDecode)+import Data.Aeson.KeyMap qualified as KM+import Data.ByteString.Lazy qualified as LBS+import Data.Char (isDigit)+import Data.Containers.ListUtils (nubOrd)+import Data.List (nub, sortOn)+import Data.Map.Strict qualified as Map+import Data.Text (Text)+import Data.Text qualified as T+import Data.Vector qualified as V+import Oglyad.Types (Finding (..))+import Text.Read (readMaybe)++-- | a Fedora release Terra builds for. rawhide keeps its number too, since+-- %fedora still needs one when evaluating specs+data Release = Release+ { -- | "43", or "rawhide"+ relName :: Text,+ -- | the number %fedora expands to+ relVersion :: Int+ }+ deriving stock (Eq, Show)++isRawhide :: Release -> Bool+isRawhide r = relName r == "rawhide"++-- | how releases are spelled in output: f43, rawhide. matches the+-- terrapkg/packages branch names minus rawhide's "f"+releaseLabel :: Release -> Text+releaseLabel r = if isRawhide r then "rawhide" else "f" <> relName r++-- | rawhide builds use .fcrawhide, not .fc46. terrapkg/packages' bootstrap+-- workflow rewrites macros.dist to do it+releaseDist :: Release -> Text+releaseDist r = ".fc" <> relName r++-- | the terrapkg/packages branch for a release: f43, frawhide+releaseBranch :: Release -> Text+releaseBranch r = "f" <> relName r++terraRepoFor :: Release -> Text+terraRepoFor r = "https://repos.fyralabs.com/terra" <> relName r++-- | Fedora's own repos, for the overlap check. rawhide has no updates repo+fedoraReposFor :: Release -> [Text]+fedoraReposFor r+ | isRawhide r = ["https://dl.fedoraproject.org/pub/fedora/linux/development/rawhide/Everything/x86_64/os"]+ | otherwise =+ [ "https://dl.fedoraproject.org/pub/fedora/linux/releases/" <> relName r <> "/Everything/x86_64/os",+ "https://dl.fedoraproject.org/pub/fedora/linux/updates/" <> relName r <> "/Everything/x86_64"+ ]++-- | what --release accepts, before we know rawhide's number+data ReleaseArg = NumberedArg Int | RawhideArg+ deriving stock (Eq, Show)++-- | 43, f43, rawhide or frawhide+parseReleaseArg :: String -> Either String ReleaseArg+parseReleaseArg raw = case dropF raw of+ "rawhide" -> Right RawhideArg+ n+ | not (null n), all isDigit n, Just v <- readMaybe n -> Right (NumberedArg v)+ _ -> Left ("unknown release " <> show raw <> ", expected a number like 43, f43, or rawhide")+ where+ dropF ('f' : rest) = rest+ dropF s = s++-- | every Fedora release Bodhi hasn't archived. that's the current ones, a+-- branched one before its release, and rawhide+bodhiReleasesUrl :: Text+bodhiReleasesUrl = "https://bodhi.fedoraproject.org/releases/?exclude_archived=true&rows_per_page=100"++-- | the maintained Fedora releases in a Bodhi /releases/ response, oldest+-- first with rawhide last. ELN, containers and flatpaks are skipped: only+-- names like F43 count+parseBodhiReleases :: LBS.ByteString -> Either Text [Release]+parseBodhiReleases body = do+ v <- either (Left . ("bad json from Bodhi: " <>) . T.pack) Right (eitherDecode body)+ rels <- case v of+ Object o | Just (Array rs) <- KM.lookup "releases" o -> Right (V.toList rs)+ _ -> Left "no releases in Bodhi's answer"+ let found =+ [ Release (if branch == "rawhide" then "rawhide" else ver) n+ | Object r <- rels,+ Just (String name) <- [KM.lookup "name" r],+ Just ('F', digits) <- [T.uncons name],+ not (T.null digits),+ T.all isDigit digits,+ Just (String ver) <- [KM.lookup "version" r],+ Just n <- [readMaybe (T.unpack ver)],+ Just (String branch) <- [KM.lookup "branch" r]+ ]+ case found of+ [] -> Left "Bodhi listed no Fedora releases"+ _ -> Right (sortOn (\r -> (isRawhide r, relVersion r)) found)++-- | one list of findings out of each release's. a finding that comes up the+-- same way in several releases is shown once, with fReleases naming them.+-- "the same way" ignores the dist tag, so build-lag's+-- "spec is at 1.2-1.fc43" and "spec is at 1.2-1.fc44" merge into+-- "spec is at 1.2-1%{dist}"+mergeFindings :: [(Release, [Finding])] -> [Finding]+mergeFindings perRelease =+ [ merged k f (r : map snd rest)+ | k <- nubOrd (map fst tagged),+ Just ((f, r) : rest) <- [Map.lookup k grouped]+ ]+ where+ tagged = [(keyOf r f, (f, relName r)) | (r, fs) <- perRelease, f <- fs]+ keyOf r f = (fCheck f, fPackage f, fPath f, fSeverity f, T.replace (releaseDist r) "%{dist}" (fMessage f))+ -- members stay in the order the releases were given+ grouped = Map.fromListWith (flip (<>)) [(k, [x]) | (k, x) <- tagged]+ merged (_, _, _, _, generic) f rels = case nub rels of+ [single] -> f {fReleases = [single]}+ many -> f {fReleases = many, fMessage = generic}
src/Oglyad/Report.hs view
@@ -2,6 +2,7 @@ -- GitHub job summaries module Oglyad.Report ( Report (..),+ ReleaseInfo (..), Format (..), render, renderText,@@ -29,13 +30,25 @@ data Report = Report { rVersion :: Text, rGenerated :: UTCTime,- rMonorepoHead :: Maybe Text,- rTerraRepo :: Text,+ -- | every release this run checked, in order+ rReleases :: [ReleaseInfo], rUpstream :: Bool, rFindings :: [Finding], rIgnored :: [Finding] } +-- | what one release was checked against+data ReleaseInfo = ReleaseInfo+ { -- | "43", "rawhide", as findings' fReleases spell it+ riName :: Text,+ -- | "f43", "rawhide", for people+ riLabel :: Text,+ -- | the git ref the specs came from, Nothing for the working tree+ riRef :: Maybe Text,+ riCommit :: Maybe Text,+ riTerraRepo :: Text+ }+ render :: Format -> Severity -> Report -> LBS.ByteString render fmt minSev r = case fmt of Text -> utf8 (renderText minSev r)@@ -47,7 +60,7 @@ -- * text renderText :: Severity -> Report -> Text-renderText minSev Report {..} =+renderText minSev r@Report {..} = T.unlines (map line (shown minSev rFindings) <> ["", summaryLine rFindings rIgnored]) where amb = ambiguousNames rFindings@@ -55,6 +68,7 @@ T.justifyLeft 6 ' ' (sevText fSeverity) <> T.justifyLeft 16 ' ' fCheck <> label amb f+ <> releaseTag r f <> ": " <> fMessage @@ -73,11 +87,19 @@ renderJson Report {..} = encode $ object- [ "schema" .= (1 :: Int),+ [ "schema" .= (2 :: Int), "oglyad" .= rVersion, "generated" .= rGenerated,- "monorepo_head" .= rMonorepoHead,- "terra_repo" .= rTerraRepo,+ "releases"+ .= [ object+ [ "release" .= riName,+ "label" .= riLabel,+ "ref" .= riRef,+ "commit" .= riCommit,+ "terra_repo" .= riTerraRepo+ ]+ | ReleaseInfo {..} <- rReleases+ ], "upstream" .= rUpstream, "summary" .= object@@ -97,7 +119,8 @@ "package" .= fPackage, "path" .= fPath, "severity" .= toJSON fSeverity,- "message" .= fMessage+ "message" .= fMessage,+ "releases" .= fReleases ] -- * markdown@@ -105,18 +128,20 @@ -- | sized for a GitHub job summary: counts first, errors and warnings in -- full, info folded away renderMarkdown :: Severity -> Report -> Text-renderMarkdown minSev Report {..} =+renderMarkdown minSev r@Report {..} = T.unlines $ [ "# oglyad report", "", T.intercalate " · "- [ T.pack (formatTime defaultTimeLocale "%Y-%m-%d %H:%M UTC" rGenerated),- "terrapkg/packages " <> maybe "(unknown commit)" (\h -> "`" <> T.take 10 h <> "`") rMonorepoHead,- rTerraRepo,- if rUpstream then "upstream checks on" else "upstream checks off",- "oglyad " <> rVersion- ],+ ( [T.pack (formatTime defaultTimeLocale "%Y-%m-%d %H:%M UTC" rGenerated)]+ <> [ riLabel <> " " <> maybe "(unknown commit)" (\h -> "`" <> T.take 10 h <> "`") riCommit+ | ReleaseInfo {..} <- rReleases+ ]+ <> [ if rUpstream then "upstream checks on" else "upstream checks off",+ "oglyad " <> rVersion+ ]+ ), "", "**" <> summaryLine rFindings rIgnored <> "**", "",@@ -139,7 +164,7 @@ let heading = title <> " (" <> tshow (length fs) <> ")" table = ["", "| package | check | message |", "|---|---|---|"]- <> [ "| " <> cell (label amb f) <> " | `" <> fCheck f <> "` | " <> cell (fMessage f) <> " |"+ <> [ "| " <> cell (label amb f <> releaseTag r f) <> " | `" <> fCheck f <> "` | " <> cell (fMessage f) <> " |" | f <- fs ] in if folded@@ -158,6 +183,14 @@ label :: Set.Set Text -> Finding -> Text label ambiguous Finding {..} = fPackage <> maybe "" (\path -> if fPackage `Set.member` ambiguous then " (" <> path <> ")" else "") fPath++-- | " [f43, f44]" for a finding that only some of the checked releases+-- have. nothing when it's in all of them, or only one release was checked+releaseTag :: Report -> Finding -> Text+releaseTag Report {rReleases} Finding {fReleases}+ | length rReleases <= 1 = ""+ | all (`elem` fReleases) (map riName rReleases) = ""+ | otherwise = " [" <> T.intercalate ", " [riLabel ri | ri <- rReleases, riName ri `elem` fReleases] <> "]" -- | names that show up with more than one directory ambiguousNames :: [Finding] -> Set.Set Text
+ src/Oglyad/Source/Anda.hs view
@@ -0,0 +1,112 @@+-- | running the real andax on update.rhai scripts oglyad can't follow on its+-- own, like ones that scrape a page with get() and find().+--+-- anda rewrites specs in place, so it runs on a throwaway copy of the tree.+-- afterwards rpmspec reads the copy's spec, and whatever Version it says now+-- is what `anda update` would have set+module Oglyad.Source.Anda+ ( withScratchCopy,+ projectNames,+ updateProject,+ scriptErrors,+ stripAnsi,+ )+where++import Control.Exception (SomeException, finally, try)+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Maybe (listToMaybe, mapMaybe)+import Data.Text (Text)+import Data.Text qualified as T+import Oglyad.Process (run, runCapture)+import Oglyad.Source.Cache (cacheDir)+import System.Directory (createDirectory, createDirectoryIfMissing, removeFile, removePathForcibly)+import System.Exit (ExitCode (..))+import System.FilePath (takeDirectory, (</>))+import System.IO (hClose, openBinaryTempFile)++-- | run an action on a copy of a tree (minus .git) that's deleted afterwards+withScratchCopy :: FilePath -> (FilePath -> IO a) -> IO (Either Text a)+withScratchCopy root act = do+ base <- (</> "anda-work") <$> cacheDir+ createDirectoryIfMissing True base+ (tar, h) <- openBinaryTempFile base "tree.tar"+ hClose h+ let dir = tar <> ".d"+ cleanup = quietly (removeFile tar) >> quietly (removePathForcibly dir)+ ( do+ packed <- run "tar" ["-C", root, "--exclude=./.git", "-cf", tar, "."]+ unpacked <- case packed of+ Left e -> pure (Left e)+ Right _ -> createDirectory dir >> run "tar" ["-xf", tar, "-C", dir]+ quietly (removeFile tar)+ case unpacked of+ Left e -> pure (Left ("can't copy the tree for anda: " <> e))+ Right _ -> Right <$> act dir+ )+ `finally` cleanup+ where+ quietly :: IO () -> IO ()+ quietly a = () <$ (try a :: IO (Either SomeException ()))++-- | package directory to anda project name, from `anda list`, which prints+-- lines like "anda/apps/foo/pkg (apps/foo)"+projectNames :: FilePath -> IO (Either Text (Map FilePath Text))+projectNames copy = do+ r <- runCapture copy [("NO_COLOR", "1")] "anda" ["list"]+ pure $ case r of+ Left e -> Left e+ Right (ExitFailure _, _, err) -> Left ("anda list failed: " <> lastLine err)+ Right (ExitSuccess, out, _) -> Right (Map.fromList (mapMaybe entry (T.lines (stripAnsi out))))+ where+ entry l = case T.breakOn " (" (T.strip l) of+ (path, rest)+ | Just name <- T.stripSuffix ")" (T.drop 2 rest),+ not (T.null path),+ not (T.null name) ->+ Just (takeDirectory (T.unpack path), name)+ _ -> Nothing++-- | `anda update` one project in the copy. anda reports a failing script+-- only in its log and still exits 0, so the log is where errors come from.+-- the script gets GITHUB_TOKEN, since anda refuses gh() without one+updateProject :: FilePath -> Maybe Text -> Text -> Text -> IO (Either Text ())+updateProject copy token branch name = do+ let env = ("NO_COLOR", "1") : [("GITHUB_TOKEN", T.unpack t) | Just t <- [token]]+ r <- runCapture copy env "anda" ["-v", "update", "--labels", "branch=" <> T.unpack branch, T.unpack name]+ pure $ case r of+ Left e -> Left e+ Right (ExitFailure _, _, err) -> Left (failure (stripAnsi err))+ Right (ExitSuccess, _, err) -> case scriptErrors (stripAnsi err) of+ [] -> Right ()+ e : _ -> Left e+ where+ -- color-eyre reports look like "Error:\n 0: Project not found: x"+ failure err = maybe (lastLine err) T.strip (listToMaybe [T.drop 3 l' | l <- T.lines err, let l' = T.stripStart l, "0: " `T.isPrefixOf` l'])++-- | what went wrong in each script exception in anda's -v log: andax logs+-- "ERROR andax::run: Script Exception —— <project>" and then the reason on a+-- line starting with "├─═"+scriptErrors :: Text -> [Text]+scriptErrors = go . T.lines+ where+ go = \case+ [] -> []+ l : rest+ | "Script Exception" `T.isInfixOf` l ->+ case [T.strip (T.drop 1 (snd (T.breakOn "═" r))) | r <- take 5 rest, "├─═" `T.isInfixOf` r] of+ msg : _ -> msg : go rest+ [] -> "script exception" : go rest+ | otherwise -> go rest++-- | drop ANSI color codes, which color-eyre writes even with NO_COLOR set+stripAnsi :: Text -> Text+stripAnsi t = case T.breakOn "\ESC[" t of+ (pre, "") -> pre+ (pre, rest) -> pre <> stripAnsi (T.drop 1 (T.dropWhile (\c -> c /= 'm' && c /= 'K') (T.drop 2 rest)))++lastLine :: Text -> Text+lastLine t = case reverse (filter (not . T.null) (map T.strip (T.lines t))) of+ l : _ -> l+ [] -> "(no output)"
src/Oglyad/Source/Cache.hs view
@@ -1,7 +1,8 @@ -- | small json caches under $XDG_CACHE_HOME/oglyad, so reruns skip work that -- can't have changed: spec evaluation, repodata parsing and upstream lookups module Oglyad.Source.Cache- ( loadJson,+ ( cacheDir,+ loadJson, saveJson, CacheEntry (..), UpstreamCache,
src/Oglyad/Source/Monorepo.hs view
@@ -4,36 +4,42 @@ SpecInfo (..), findPackageDirs, hclString,+ versionMacros, querySpec, lastCommits, headCommit,+ checkoutRef,+ pruneTrees, specFingerprint, macroFingerprint, ) where -import Control.Exception (IOException, try)-import Control.Monad (filterM, foldM, forM)+import Control.Exception (IOException, SomeException, finally, try)+import Control.Monad (filterM, foldM, forM, forM_) import Crypto.Hash.SHA256 qualified as SHA256 import Data.Aeson (FromJSON, ToJSON) import Data.ByteString qualified as BS import Data.ByteString.Base16 qualified as B16+import Data.Char (isAlphaNum, isSpace) import Data.List (sort) import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map-import Data.Maybe (listToMaybe)+import Data.Maybe (isJust, listToMaybe) import Data.Set qualified as Set import Data.Text (Text) import Data.Text qualified as T import Data.Text.Encoding qualified as TE import Data.Text.Read qualified as TR-import Data.Time (UTCTime)+import Data.Time (UTCTime, diffUTCTime, getCurrentTime, nominalDay) import Data.Time.Clock.POSIX (posixSecondsToUTCTime) import GHC.Generics (Generic) import Oglyad.Process (run)+import Oglyad.Source.Cache (cacheDir) import Oglyad.Version (EVR, parseEVR)-import System.Directory (doesDirectoryExist, doesFileExist, getSymbolicLinkTarget, listDirectory, pathIsSymbolicLink)+import System.Directory (createDirectory, createDirectoryIfMissing, doesDirectoryExist, doesFileExist, getModificationTime, getSymbolicLinkTarget, listDirectory, pathIsSymbolicLink, removeFile, removePathForcibly, renameDirectory, setModificationTime) import System.FilePath (takeDirectory, takeExtension, (</>))+import System.IO (hClose, openBinaryTempFile) -- | a directory with an anda.hcl in it data PkgDir = PkgDir@@ -45,8 +51,15 @@ pdSubrepo :: Maybe Text, -- | file contents pdUpdateRhai :: Maybe Text,+ -- | macros the spec's Version: line uses, like ["tag"] for+ -- `Version: %(echo %tag | sed ...)`. Nothing when there's no spec or no+ -- Version: line to read+ pdVersionMacros :: Maybe [Text], -- | `oglyad_ignore = "check, other-check"` from the labels block- pdIgnores :: [Text]+ pdIgnores :: [Text],+ -- | has a `nightly = N` or `quaterdaily = N` label, so it builds from a+ -- branch head on a schedule rather than from releases+ pdNightly :: Bool } deriving stock (Eq, Show) @@ -57,7 +70,6 @@ deriving stock (Eq, Show, Generic) deriving anyclass (ToJSON, FromJSON) --- | walk anda/ and return every project directory -- | walk anda/ and return every project directory. a directory that can't be -- read comes back as a Left with the reason, instead of ending the walk. -- symlinked directories aren't followed, so a link loop can't hang the walk@@ -87,25 +99,54 @@ fallback = listToMaybe [e | e <- entries, takeExtension e == ".spec"] hasRhai <- doesFileExist (abs' </> "update.rhai") rhai <- if hasRhai then Just <$> readText (abs' </> "update.rhai") else pure Nothing+ let spec = maybe fallback Just fromHcl+ specText <- case spec of+ Just f -> either (\(_ :: IOException) -> Nothing) Just <$> try (readText (abs' </> f))+ Nothing -> pure Nothing pure PkgDir { pdPath = rel,- pdSpec = (rel </>) <$> maybe fallback Just fromHcl,+ pdSpec = (rel </>) <$> spec, pdSubrepo = hclString "subrepo" hcl, pdUpdateRhai = rhai,- pdIgnores = maybe [] (filter (not . T.null) . map T.strip . T.splitOn ",") (hclString "oglyad_ignore" hcl)+ pdVersionMacros = specText >>= versionMacros,+ pdIgnores = maybe [] (filter (not . T.null) . map T.strip . T.splitOn ",") (hclString "oglyad_ignore" hcl),+ pdNightly = any (isJust . (`hclString` hcl)) ["nightly", "quaterdaily"] } --- | pull the first `key = "value"` out of anda.hcl without a real HCL parser.--- every anda.hcl in the monorepo is simple enough for this to hold up+-- | the macro names a spec's Version: line refers to, read from the raw+-- text: %name, %{name}, %{?name} and %{!?name:...} all count. rpmspec+-- would expand them away, and what we want is which ones an update.rhai+-- would have to set to change the version+versionMacros :: Text -> Maybe [Text]+versionMacros spec = case [T.strip v | l <- T.lines spec, Just v <- [stripTag l]] of+ v : _ -> Just (names v)+ [] -> Nothing+ where+ stripTag l = case T.breakOn ":" l of+ (tag, rest) | T.toLower (T.strip tag) == "version", not (T.null rest) -> Just (T.drop 1 rest)+ _ -> Nothing+ names t = case T.breakOn "%" t of+ (_, "") -> []+ (_, rest) ->+ let after = T.dropWhile (`elem` ("{?!" :: String)) (T.drop 1 rest)+ (name, more) = T.span (\c -> isAlphaNum c || c == '_') after+ in [name | not (T.null name)] <> names more++-- | the value of `key = "value"` (or a bare `key = 1`) anywhere in an+-- anda.hcl. good enough for the flat labels and rpm blocks anda uses hclString :: Text -> Text -> Maybe Text hclString key hcl = listToMaybe- [ T.takeWhile (/= '"') (T.drop 1 (T.dropWhile (/= '"') rest))+ [ v | l <- map T.strip (T.lines hcl), Just rest <- [T.stripPrefix key l],- "=" `T.isPrefixOf` T.stripStart rest,- "\"" `T.isInfixOf` rest+ Just afterEq <- [T.stripPrefix "=" (T.stripStart rest)],+ let raw = T.stripStart afterEq+ v = case T.stripPrefix "\"" raw of+ Just quoted -> T.takeWhile (/= '"') quoted+ Nothing -> T.takeWhile (\c -> not (isSpace c) && c /= '#') raw,+ not (T.null v) ] -- | a directory that isn't a symlink@@ -156,11 +197,11 @@ -- ~25s of cpu. one pass listing every changed file per commit takes ~0.5s, -- and since git lists newest commits first, the first time we see a path -- under a dir is that dir's last commit-lastCommits :: FilePath -> [FilePath] -> IO (Map FilePath UTCTime)-lastCommits root dirs = do+lastCommits :: FilePath -> Text -> [FilePath] -> IO (Map FilePath UTCTime)+lastCommits root ref dirs = do out <- run "git" $- ["-C", root, "-c", "core.quotePath=false", "log", "--format=@%ct", "--name-only", "--no-renames", "HEAD", "--", "anda"]+ ["-C", root, "-c", "core.quotePath=false", "log", "--format=@%ct", "--name-only", "--no-renames", T.unpack ref, "--", "anda"] -- not a git checkout (or no git at all) just means no commit times pure (either (const Map.empty) (go Nothing Map.empty . T.lines) out) where@@ -186,6 +227,75 @@ -- | the commit HEAD points at, if this is a git checkout headCommit :: FilePath -> IO (Maybe Text) headCommit root = either (const Nothing) (Just . T.strip) <$> run "git" ["-C", root, "rev-parse", "HEAD"]++-- | the whole tree of a git ref, extracted under the cache dir and keyed by+-- commit, so each commit gets extracted once. the checkout itself is never+-- touched: no checkout, no worktree, no fetch. returns the directory and the+-- commit+checkoutRef :: FilePath -> Text -> IO (Either Text (FilePath, Text))+checkoutRef mono ref = do+ rev <- run "git" ["-C", mono, "rev-parse", "--verify", "--quiet", T.unpack ref <> "^{commit}"]+ case T.strip <$> rev of+ Left _ -> pure (Left ("no " <> ref <> " in " <> T.pack mono <> ", does it need a git fetch?"))+ Right sha -> do+ trees <- (</> "trees") <$> cacheDir+ let dir = trees </> T.unpack sha+ done <- doesDirectoryExist dir+ if done+ then do+ -- mark it used, so pruneTrees knows it's still wanted+ now <- getCurrentTime+ _ <- try (setModificationTime dir now) :: IO (Either IOException ())+ pure (Right (dir, sha))+ else do+ createDirectoryIfMissing True trees+ -- extract next to the final spot and rename, so a run that dies+ -- halfway never leaves a partial tree that looks finished+ (tar, h) <- openBinaryTempFile trees (T.unpack sha <> ".tar")+ hClose h+ let tmp = tar <> ".d"+ r <-+ ( do+ archived <- run "git" ["-C", mono, "archive", "--format=tar", "-o", tar, T.unpack sha]+ extracted <- case archived of+ Left e -> pure (Left e)+ Right _ -> createDirectory tmp >> run "tar" ["-xf", tar, "-C", tmp]+ case extracted of+ Left e -> pure (Left ("can't extract " <> ref <> ": " <> e))+ Right _ -> do+ moved <- try (renameDirectory tmp dir)+ -- another run may have finished the same commit first+ case moved of+ Left (_ :: IOException) -> removePathForcibly tmp+ Right () -> pure ()+ pure (Right (dir, sha))+ )+ `finally` (try' (removeFile tar) >> try' (removePathForcibly tmp))+ pure r+ where+ try' :: IO () -> IO ()+ try' act = () <$ (try act :: IO (Either SomeException ()))++-- | delete extracted trees nothing has used in a week, other than these.+-- a week rather than right away, so checking one release doesn't throw out+-- the trees the next full run needs+pruneTrees :: [Text] -> IO ()+pruneTrees keep = do+ trees <- (</> "trees") <$> cacheDir+ now <- getCurrentTime+ listed <- try (listDirectory trees)+ case listed of+ Left (_ :: IOException) -> pure ()+ Right names -> forM_ names $ \n -> do+ let path = trees </> n+ used <- try (getModificationTime path) :: IO (Either IOException UTCTime)+ case used of+ Right t+ | length n == 40,+ T.pack n `notElem` keep,+ diffUTCTime now t > 7 * nominalDay ->+ () <$ (try (removePathForcibly path) :: IO (Either IOException ()))+ _ -> pure () -- | a hash of everything that can change what rpmspec says about a package: -- the files in its directory and any subdirectories like patches/ (but not
src/Oglyad/Source/Rhai.hs view
@@ -14,8 +14,11 @@ -- 'Unknown', and the unparsed-rhai check lists those module Oglyad.Source.Rhai ( parseUpdateRhai,+ parseUpdateRhaiWith, Token (..), tokenize,+ sourceCall,+ balanced, ) where @@ -35,17 +38,34 @@ | TStr Text | TNum Text | TSym Char+ | -- | a backtick string with ${...} in it, which Rhai interpolates+ TTmpl Text deriving stock (Eq, Show) type Parser = Parsec Void Text parseUpdateRhai :: Text -> UpstreamSource-parseUpdateRhai src = case tokenize src of+parseUpdateRhai = parseUpdateRhaiWith Nothing++-- | like 'parseUpdateRhai', also knowing which macros the spec's Version:+-- line uses (see 'Oglyad.Source.Monorepo.versionMacros'). a script that+-- sets none of them, and not ver or version either, doesn't track an+-- upstream version at all+parseUpdateRhaiWith :: Maybe [Text] -> Text -> UpstreamSource+parseUpdateRhaiWith macros src = case tokenize src of Nothing -> Unknown (T.strip src) Just toks -> case resolveVersion toks of Just s -> s Nothing | hasCommitCall toks -> CommitTracked+ -- a commit from somewhere else, like get(...).json().sha. only when+ -- the script sets no version, since plenty record the commit of the+ -- release they just scraped+ | null (versionExprs toks), not (null (globalExprs ["commit"] toks)) -> CommitTracked+ | Just ms <- macros,+ null (versionExprs toks),+ null (globalExprs ms toks) ->+ NoVersion -- no rpm.version we could follow, but the script only ever calls one -- source helper, so that's almost certainly it | [s] <- nub (allSources toks) -> s@@ -64,15 +84,16 @@ L.lexeme sc $ choice [ TStr <$> quoted '"',- TStr <$> raw, -- template strings, ${} left as-is+ raw, TStr <$> quoted '\'', -- char literals TIdent <$> takeWhile1P (Just "identifier") (\c -> isAlphaNum c || c == '_'), TNum <$> takeWhile1P (Just "number") isDigit, TSym <$> satisfy (not . isSpace) ] where- -- backtick strings are raw in Rhai, so regexes like `[\d.]+` stay intact- raw = char '`' *> takeWhileP Nothing (/= '`') <* char '`'+ -- backtick strings are raw in Rhai, so regexes like `[\d.]+` stay intact.+ -- they interpolate ${...} though, so those get their own token+ raw = (\t -> if "${" `T.isInfixOf` t then TTmpl t else TStr t) <$> (char '`' *> takeWhileP Nothing (/= '`') <* char '`') -- in quoted strings a backslash escapes whatever follows it. we only care -- about the text being roughly right, so unknown escapes are kept as-is quoted q = T.pack <$> (char q *> manyTill (escaped <|> anySingle) (char q))@@ -82,6 +103,21 @@ 't' -> '\t' c -> c +-- | do the brackets pair up? Rhai won't run a script where they don't, so+-- this catches a broken update.rhai without a real parser+balanced :: [Token] -> Bool+balanced = go []+ where+ go stack = \case+ [] -> null stack+ TSym c : ts+ | Just close <- lookup c pairs -> go (close : stack) ts+ | c `elem` (")]}" :: String) -> case stack of+ s : rest | s == c -> go rest ts+ _ -> False+ _ : ts -> go stack ts+ pairs = [('(', ')'), ('[', ']'), ('{', '}')]+ -- * analysis -- | follow rpm.version(...) / rpm.global("ver", ...) back to a source helper@@ -90,20 +126,24 @@ -- | every expression handed to something that sets the package version versionExprs :: [Token] -> [[Token]]-versionExprs = \case+versionExprs toks = go toks <> globalExprs ["ver", "version"] toks+ where+ go = \case+ [] -> []+ -- rpm.version(EXPR)+ TIdent "rpm" : TSym '.' : TIdent "version" : TSym '(' : rest -> takeBalanced rest : go rest+ _ : rest -> go rest++-- | every expression a script hands to rpm.global(KEY, ...) or+-- rpm.define(KEY, ...) for one of these keys+globalExprs :: [Text] -> [Token] -> [[Token]]+globalExprs keys = \case [] -> []- TIdent "rpm" : TSym '.' : TIdent "version" : TSym '(' : rest ->- argsOf rest <> versionExprs rest TIdent "rpm" : TSym '.' : TIdent f : TSym '(' : TStr key : TSym ',' : rest | f `elem` ["global", "define"],- key `elem` ["ver", "version"] ->- argsOf' rest <> versionExprs rest- _ : rest -> versionExprs rest- where- -- rpm.version(EXPR)- argsOf rest = [takeBalanced rest]- -- rpm.global("ver", EXPR), we're already past the comma- argsOf' rest = [takeBalanced rest]+ key `elem` keys ->+ takeBalanced rest : globalExprs keys rest+ _ : rest -> globalExprs keys rest -- | tokens up to the ')' that closes the call we're inside takeBalanced :: [Token] -> [Token]@@ -128,6 +168,12 @@ -- bump::madoguchi(...) or nvidia::nvidia_driver_version() TIdent m : TSym ':' : TSym ':' : TIdent f : TSym '(' : _ -> Just (Derived (m <> "::" <> f)) TIdent f : TSym '(' : _ | f `elem` derivedHelpers -> Just (Derived f)+ -- kmod packages copy Version from their kmod-common sibling with+ -- sh("cat anda/.../x.spec | grep Version ...")+ TIdent "sh" : TSym '(' : TStr cmd : _+ | "cat " `T.isPrefixOf` T.stripStart cmd,+ ".spec" `T.isInfixOf` cmd ->+ Just (Derived "another spec in the repo") -- some other call like find(`regex`, tag, 1): the version comes from -- whichever argument we can trace back to a source TIdent _ : TSym '(' : rest ->
+ src/Oglyad/Source/RhaiEval.hs view
@@ -0,0 +1,537 @@+-- | runs the version-setting part of an update.rhai against an upstream value+-- we already fetched, so guards like `if v.starts_with("cli-v")` and edits like+-- `v.crop(5)` apply before drift compares it with the spec.+--+-- it understands a small slice of Rhai: let, assignment, if/else, try/catch,+-- terminate(), rpm.version / rpm.global("ver", ...), the string methods update+-- scripts use, andax's regex helpers (find, find_all, sub), template strings,+-- + and indexing. anything else that touches a value we need gives up with+-- 'CantTell', and drift falls back to the raw upstream value+module Oglyad.Source.RhaiEval+ ( Simulated (..),+ simulateVersion,+ )+where++import Control.Applicative ((<|>))+import Data.Char (isAlphaNum, isDigit)+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Maybe (isJust)+import Data.Text (Text)+import Data.Text qualified as T+import Oglyad.Regex qualified as Re+import Oglyad.Source.Rhai (Token (..), balanced, sourceCall, tokenize)+import Oglyad.Types (UpstreamSource)+import Text.Read (readMaybe)++data Simulated+ = -- | the script would set Version to this+ Sets Text+ | -- | the script finishes (or calls terminate()) without setting Version,+ -- so `anda update` wouldn't touch the spec for this upstream value+ NoUpdate+ | -- | the script does something we don't model+ CantTell+ deriving stock (Eq, Show)++-- | what Version the script would set, given the value its source helper+-- returns. the source is the one 'Oglyad.Source.Rhai.parseUpdateRhai' found.+-- any other helper call evaluates to an unknown value+simulateVersion :: UpstreamSource -> Text -> Text -> Simulated+simulateVersion src upstream script = case tokenize script of+ Just toks+ | balanced toks,+ Just prog <- stmts toks ->+ case exec (src, upstream) emptyEnv prog of+ Right env -> outcome env+ Left (Terminated env) -> outcome env+ -- an error nothing caught fails the whole `anda update` run. we+ -- can't say much about what the spec would look like then+ Left (Thrown _) -> CantTell+ Left GiveUp -> CantTell+ _ -> CantTell+ where+ -- rpm.version wins over rpm.global("ver", ...), since some scripts set the+ -- global to the raw tag and Version to a cleaned-up spelling of it+ outcome env = maybe NoUpdate Sets (envVersion env <|> envGlobal env)++-- * syntax++data Value = VStr Text | VNum Int | VBool Bool | VArr [Value] | VUnit+ deriving stock (Eq, Show)++data Expr+ = Lit Value+ | -- | a backtick string with ${...} to fill in+ Tmpl Text+ | Var Text+ | Src UpstreamSource+ | Call Text [Expr]+ | Method Expr Text [Expr]+ | Index Expr Expr+ | Not Expr+ | Bin Text Expr Expr+ | -- | rpm.changed(). we're asking "what if upstream moved", so it's true+ Changed+ | -- | an expression we couldn't parse. only fatal if something needs it+ Unparsed+ deriving stock (Show)++data Stmt+ = Let Text Expr+ | -- | v.crop(1); and friends, which change v in place+ Mutate Text Text [Expr]+ | -- | True for rpm.version, False for rpm.global("ver", ...)+ SetVersion Bool Expr+ | If Expr [Stmt] [Stmt]+ | Try [Stmt] [Stmt]+ | Terminate+ | -- | rpm.release(), print(...), and other calls that can't change Version+ Ignored+ | -- | an expression on its own, like find(...) used as a guard inside try+ ExprStmt Expr [Token]+ | -- | a statement we don't understand, kept so we can see what it touches+ Opaque [Token]+ | -- | `rpm.f = ...`, which rewrites the whole spec and can change Version+ -- in ways we can't follow+ RewritesSpec+ deriving stock (Show)++-- * parsing++stmts :: [Token] -> Maybe [Stmt]+stmts = \case+ [] -> Just []+ TSym ';' : rest -> stmts rest+ toks -> do+ (s, rest) <- stmt toks+ (s :) <$> stmts rest++stmt :: [Token] -> Maybe (Stmt, [Token])+stmt = \case+ TIdent "if" : rest -> ifStmt rest+ TIdent "try" : TSym '{' : rest -> do+ (body, rest1) <- block rest+ case rest1 of+ TIdent "catch" : rest2 -> do+ let rest3 = case rest2 of+ TSym '(' : TIdent _ : TSym ')' : r -> r+ r -> r+ case rest3 of+ TSym '{' : r -> do+ (handler, rest4) <- block r+ Just (Try body handler, rest4)+ _ -> Nothing+ _ -> Nothing+ toks ->+ let (s, rest) = untilSemi toks+ in Just (simple s, rest)++ifStmt :: [Token] -> Maybe (Stmt, [Token])+ifStmt toks = do+ let (c, rest) = break (== TSym '{') toks+ rest1 <- case rest of+ TSym '{' : r -> Just r+ _ -> Nothing+ (yes, rest2) <- block rest1+ case rest2 of+ TIdent "else" : TIdent "if" : rest3 -> do+ (s, rest4) <- ifStmt rest3+ Just (If (expr c) yes [s], rest4)+ TIdent "else" : TSym '{' : rest3 -> do+ (no, rest4) <- block rest3+ Just (If (expr c) yes no, rest4)+ _ -> Just (If (expr c) yes [], rest2)++-- | the statements inside braces, given the tokens just after the '{'+block :: [Token] -> Maybe ([Stmt], [Token])+block toks = do+ (inner, rest) <- closing toks+ body <- stmts inner+ Just (body, rest)++simple :: [Token] -> Stmt+simple = \case+ [TIdent "terminate", TSym '(', TSym ')'] -> Terminate+ TIdent "let" : TIdent v : TSym '=' : e -> Let v (expr e)+ TIdent "rpm" : TSym '.' : TIdent "version" : TSym '(' : r+ | Just [a] <- argsOnly r -> SetVersion True a+ TIdent "rpm" : TSym '.' : TIdent f : TSym '(' : TStr key : TSym ',' : r+ | f `elem` ["global", "define"],+ key `elem` ["ver", "version"],+ Just [a] <- argsOnly r ->+ SetVersion False a+ TIdent "rpm" : TSym '.' : TIdent "f" : TSym '=' : t : _ | t /= TSym '=' -> RewritesSpec+ TIdent "rpm" : _ -> Ignored+ TIdent "print" : _ -> Ignored+ TIdent v : TSym '.' : TIdent m : TSym '(' : r+ | m `elem` mutators,+ Just as <- argsOnly r ->+ Mutate v m as+ TIdent v : TSym '=' : e@(t : _) | t /= TSym '=' -> Let v (expr e)+ toks -> case expr toks of+ Unparsed -> Opaque toks+ e -> ExprStmt e toks+ where+ -- the arguments of a call that ends the statement+ argsOnly r = case args r of+ Just (as, []) -> Just as+ _ -> Nothing++-- | string methods that change the string they're called on+mutators :: [Text]+mutators = ["crop", "truncate", "pop", "replace", "trim", "make_lower", "make_upper"]++-- | tokens up to a ';' outside any brackets, and what's after it+untilSemi :: [Token] -> ([Token], [Token])+untilSemi = go (0 :: Int)+ where+ go _ [] = ([], [])+ go d (t : ts) = case t of+ TSym ';' | d == 0 -> ([], ts)+ TSym c+ | c `elem` ("([{" :: String) -> cons t (go (d + 1) ts)+ | c `elem` (")]}" :: String) -> cons t (go (d - 1) ts)+ _ -> cons t (go d ts)+ cons t (a, b) = (t : a, b)++-- | given the tokens after an opening bracket, the tokens inside it and the+-- ones after its closing bracket+closing :: [Token] -> Maybe ([Token], [Token])+closing = go (0 :: Int)+ where+ go _ [] = Nothing+ go d (t : ts) = case t of+ TSym c+ | c `elem` (")]}" :: String) -> if d == 0 then Just ([], ts) else cons t (go (d - 1) ts)+ | c `elem` ("([{" :: String) -> cons t (go (d + 1) ts)+ _ -> cons t (go d ts)+ cons t = fmap (\(a, b) -> (t : a, b))++-- | call arguments, given the tokens after the '('+args :: [Token] -> Maybe ([Expr], [Token])+args toks = do+ (inner, rest) <- closing toks+ Just (if null inner then [] else map expr (splitCommas inner), rest)+ where+ splitCommas ts = case go (0 :: Int) ts of+ (a, []) -> [a]+ (a, rest) -> a : splitCommas rest+ go _ [] = ([], [])+ go d (t : ts) = case t of+ TSym ',' | d == 0 -> ([], ts)+ TSym c+ | c `elem` ("([{" :: String) -> cons t (go (d + 1) ts)+ | c `elem` (")]}" :: String) -> cons t (go (d - 1) ts)+ _ -> cons t (go d ts)+ cons t (a, b) = (t : a, b)++-- | a whole expression. leftover tokens mean we misread it+expr :: [Token] -> Expr+expr toks = case orE toks of+ Just (e, []) -> e+ _ -> Unparsed++type P = [Token] -> Maybe (Expr, [Token])++orE, andE, cmpE, addE, unaryE, primary :: P+orE = binLoop andE [("||", [TSym '|', TSym '|'])]+andE = binLoop cmpE [("&&", [TSym '&', TSym '&'])]+cmpE ts = do+ (l, r) <- addE ts+ case [(op, rest) | (op, syms) <- cmpOps, Just rest <- [stripPrefixList syms r]] of+ (op, rest) : _ -> do+ (x, rest') <- addE rest+ Just (Bin op l x, rest')+ [] -> Just (l, r)+ where+ -- two-character operators first, so "<=" isn't read as "<"+ cmpOps =+ [ ("==", [TSym '=', TSym '=']),+ ("!=", [TSym '!', TSym '=']),+ ("<=", [TSym '<', TSym '=']),+ (">=", [TSym '>', TSym '=']),+ ("<", [TSym '<']),+ (">", [TSym '>'])+ ]+addE = binLoop unaryE [("+", [TSym '+'])]+unaryE = \case+ TSym '!' : r -> do+ (e, r') <- unaryE r+ Just (Not e, r')+ ts -> do+ (p, r) <- primary ts+ postfix p r+primary = \case+ TStr s : r -> Just (Lit (VStr s), r)+ TTmpl s : r -> Just (Tmpl s, r)+ TNum n : r -> (\i -> (Lit (VNum i), r)) <$> readMaybe (T.unpack n)+ TIdent "true" : r -> Just (Lit (VBool True), r)+ TIdent "false" : r -> Just (Lit (VBool False), r)+ TIdent "rpm" : TSym '.' : TIdent "changed" : TSym '(' : TSym ')' : r -> Just (Changed, r)+ TSym '(' : r -> do+ (e, r') <- orE r+ case r' of+ TSym ')' : r'' -> Just (e, r'')+ _ -> Nothing+ ts | Just (s, r) <- sourceCall ts -> Just (Src s, r)+ -- the lexer reads digits as identifiers too+ TIdent n : r | T.all isDigit n -> (\i -> (Lit (VNum i), r)) <$> readMaybe (T.unpack n)+ TSym '-' : TIdent n : r | T.all isDigit n -> (\i -> (Lit (VNum (negate i)), r)) <$> readMaybe (T.unpack n)+ TIdent f : TSym '(' : r -> do+ (as, r') <- args r+ Just (Call f as, r')+ TIdent v : r@(t : _) | t /= TSym ':' -> Just (Var v, r)+ [TIdent v] -> Just (Var v, [])+ _ -> Nothing++-- | method calls, properties and indexing: v.crop(1), v.len, caps[1]+postfix :: Expr -> P+postfix e = \case+ TSym '.' : TIdent m : TSym '(' : r -> do+ (as, r') <- args r+ postfix (Method e m as) r'+ TSym '.' : TIdent m : r -> postfix (Method e m []) r+ TSym '[' : r -> do+ (inner, r') <- closing r+ postfix (Index e (expr inner)) r'+ r -> Just (e, r)++binLoop :: P -> [(Text, [Token])] -> P+binLoop next ops ts = next ts >>= uncurry loop+ where+ loop l r = case [(op, rest) | (op, syms) <- ops, Just rest <- [stripPrefixList syms r]] of+ (op, rest) : _ -> do+ (x, rest') <- next rest+ loop (Bin op l x) rest'+ [] -> Just (l, r)++stripPrefixList :: (Eq a) => [a] -> [a] -> Maybe [a]+stripPrefixList [] ys = Just ys+stripPrefixList (x : xs) (y : ys) | x == y = stripPrefixList xs ys+stripPrefixList _ _ = Nothing++-- * evaluation++data Env = Env+ { -- | Nothing is a value we can't know, like another helper's result+ envVars :: Map Text (Maybe Value),+ envVersion :: Maybe Text,+ envGlobal :: Maybe Text+ }++emptyEnv :: Env+emptyEnv = Env Map.empty Nothing Nothing++data Stop+ = Terminated Env+ | -- | a Rhai error, like find() not matching. try/catch can stop it+ Thrown Env+ | GiveUp++-- | why an expression has no value+data NoValue+ = -- | it depends on something we can't see or don't model+ Unknown+ | -- | evaluating it raises a Rhai error+ Throw++type Eval = Either NoValue Value++type Ctx = (UpstreamSource, Text)++exec :: Ctx -> Env -> [Stmt] -> Either Stop Env+exec _ env [] = Right env+exec ctx env (s : ss) = step s >>= \env' -> exec ctx env' ss+ where+ step = \case+ Let v e -> case eval ctx env e of+ Right val -> Right (bind v (Just val))+ Left Unknown -> Right (bind v Nothing)+ Left Throw -> Left (Thrown env)+ Mutate v m as -> case Map.lookup v (envVars env) of+ Just (Just val) -> case traverse (eval ctx env) as >>= mutate val m of+ Right val' -> Right (bind v (Just val'))+ Left Throw -> Left (Thrown env)+ Left Unknown -> Right (bind v Nothing)+ -- mutating something we can't see keeps it unknown+ _ -> Right env+ SetVersion isMain e -> case eval ctx env e of+ Right (VStr t)+ | isMain -> Right env {envVersion = Just t}+ | otherwise -> Right env {envGlobal = Just t}+ Left Throw -> Left (Thrown env)+ _ -> Left GiveUp+ If c yes no -> case eval ctx env c of+ Right (VBool b) -> exec ctx env (if b then yes else no)+ Left Throw -> Left (Thrown env)+ -- a branch we can't decide only matters if it could change Version+ _ | all inert (yes <> no) -> Right env+ _ -> Left GiveUp+ Try body handler -> case exec ctx env body of+ Left (Thrown env') -> exec ctx env' handler+ r -> r+ Terminate -> Left (Terminated env)+ Ignored -> Right env+ ExprStmt e toks -> case eval ctx env e of+ Right _ -> Right env+ Left Throw -> Left (Thrown env)+ -- it might throw. that only matters if it's looking at our values+ Left Unknown+ | touches toks -> Left GiveUp+ | otherwise -> Right env+ Opaque toks+ | touches toks -> Left GiveUp+ | otherwise -> Right env+ RewritesSpec -> Left GiveUp+ bind v val = env {envVars = Map.insert v val (envVars env)}+ touches toks = any known [v | TIdent v <- toks]+ known v = maybe False isJust (Map.lookup v (envVars env))++-- | can this statement affect what Version ends up as?+inert :: Stmt -> Bool+inert = \case+ Ignored -> True+ If _ yes no -> all inert (yes <> no)+ Try body handler -> all inert (body <> handler)+ _ -> False++eval :: Ctx -> Env -> Expr -> Eval+eval ctx@(src, upstream) env = \case+ Lit v -> Right v+ Tmpl t -> VStr <$> template t+ Var v -> maybe (Left Unknown) Right (Map.lookup v (envVars env) >>= id)+ Src s+ | s == src -> Right (VStr upstream)+ | otherwise -> Left Unknown+ Call "print" _ -> Right VUnit+ Call f as -> traverse (eval ctx env) as >>= call f+ -- in Rhai, x.f(a) is f(x, a) for any function+ Method e m as -> do+ val <- eval ctx env e+ vals <- traverse (eval ctx env) as+ method val m vals <> call m (val : vals)+ Index e i -> do+ val <- eval ctx env e+ idx <- eval ctx env i+ index val idx+ Not e ->+ eval ctx env e >>= \case+ VBool b -> Right (VBool (not b))+ _ -> Left Unknown+ Bin op l r -> do+ a <- eval ctx env l+ b <- eval ctx env r+ binop op a b+ Changed -> Right (VBool True)+ Unparsed -> Left Unknown+ where+ -- only ${name} is filled in. anything fancier inside the braces is unknown+ template t = case T.breakOn "${" t of+ (pre, "") -> Right pre+ (pre, rest) -> case T.breakOn "}" (T.drop 2 rest) of+ (name, after)+ | not (T.null after),+ T.all (\c -> isAlphaNum c || c == '_') name -> do+ val <- eval ctx env (Var name)+ shown <- case val of+ VStr s -> Right s+ VNum n -> Right (T.pack (show n))+ _ -> Left Unknown+ ((pre <> shown) <>) <$> template (T.drop 1 after)+ _ -> Left Unknown++-- | andax functions. regexes the engine can't compile are unknown rather+-- than errors, since that's usually our engine's limit and not the script's+call :: Text -> [Value] -> Eval+call f as = case (f, as) of+ ("find", [VStr r, VStr t, VNum g]) -> do+ re <- regex r+ caps <- slow (Re.captures re t) >>= maybe (Left Throw) Right+ if g < 0 || g >= length caps+ then Left Throw+ else maybe (Left Throw) (Right . VStr) (caps !! g)+ ("find_all", [VStr r, VStr t]) -> do+ re <- regex r+ all' <- slow (Re.capturesAll re t)+ Right (VArr [VArr (map (maybe VUnit VStr) caps) | caps <- all'])+ ("sub", [VStr r, VStr rep, VStr t]) -> do+ re <- regex r+ VStr <$> slow (Re.replaceAll re rep t)+ _ -> Left Unknown+ where+ regex = either (const (Left Unknown)) Right . Re.compile+ -- Rust would have answered, we just ran out of patience+ slow = either (const (Left Unknown)) Right++-- | built-in methods that don't change the value they're called on. the+-- in-place ones return the changed string here, which is how scripts like+-- `gh(...).crop(1)` read+method :: Value -> Text -> [Value] -> Eval+method val m as = case (val, m, as) of+ (VStr s, "pop", []) -> Right (VStr (T.takeEnd 1 s))+ (VStr s, "pop", [VNum n]) -> Right (VStr (T.takeEnd n s))+ (VStr s, "starts_with", [VStr p]) -> Right (VBool (p `T.isPrefixOf` s))+ (VStr s, "ends_with", [VStr p]) -> Right (VBool (p `T.isSuffixOf` s))+ (VStr s, "contains", [VStr p]) -> Right (VBool (p `T.isInfixOf` s))+ (VStr s, "len", []) -> Right (VNum (T.length s))+ (VStr s, "is_empty", []) -> Right (VBool (T.null s))+ (VStr s, "to_lower", []) -> Right (VStr (T.toLower s))+ (VStr s, "to_upper", []) -> Right (VStr (T.toUpper s))+ (VArr xs, "len", []) -> Right (VNum (length xs))+ (VArr xs, "is_empty", []) -> Right (VBool (null xs))+ _ -> mutate val m as++-- | what an in-place string method leaves behind, following Rhai's string+-- api (crop keeps from start, truncate keeps the first n, pop drops the end)+mutate :: Value -> Text -> [Value] -> Eval+mutate (VStr s) m as =+ VStr <$> case (m, as) of+ ("crop", [VNum start]) | start >= 0 -> Right (T.drop start s)+ ("crop", [VNum start, VNum len]) | start >= 0 -> Right (T.take len (T.drop start s))+ ("truncate", [VNum n]) -> Right (T.take n s)+ ("pop", []) -> Right (T.dropEnd 1 s)+ ("pop", [VNum n]) -> Right (T.dropEnd n s)+ ("replace", [VStr a, VStr b]) | not (T.null a) -> Right (T.replace a b s)+ ("trim", []) -> Right (T.strip s)+ ("make_lower", []) -> Right (T.toLower s)+ ("make_upper", []) -> Right (T.toUpper s)+ _ -> Left Unknown+mutate _ _ _ = Left Unknown++-- | arrays and strings, with negative indices counting from the end like+-- Rhai. out of range is a Rhai error+index :: Value -> Value -> Eval+index val (VNum i) = case val of+ VArr xs -> pick xs+ VStr s -> VStr . T.singleton <$> pick (T.unpack s)+ _ -> Left Unknown+ where+ pick :: [a] -> Either NoValue a+ pick xs =+ let n = length xs+ j = if i < 0 then n + i else i+ in if j >= 0 && j < n then Right (xs !! j) else Left Throw+index _ _ = Left Unknown++binop :: Text -> Value -> Value -> Eval+binop op a b = case (op, a, b) of+ ("&&", VBool x, VBool y) -> Right (VBool (x && y))+ ("||", VBool x, VBool y) -> Right (VBool (x || y))+ ("+", VStr x, VStr y) -> Right (VStr (x <> y))+ ("+", VStr x, VNum y) -> Right (VStr (x <> T.pack (show y)))+ ("+", VNum x, VStr y) -> Right (VStr (T.pack (show x) <> y))+ ("+", VNum x, VNum y) -> Right (VNum (x + y))+ ("==", _, _) -> Right (VBool (a == b))+ ("!=", _, _) -> Right (VBool (a /= b))+ (_, VStr x, VStr y) -> maybe (Left Unknown) (Right . VBool) (ordOp (compare x y))+ (_, VNum x, VNum y) -> maybe (Left Unknown) (Right . VBool) (ordOp (compare x y))+ _ -> Left Unknown+ where+ ordOp o = case op of+ "<" -> Just (o == LT)+ "<=" -> Just (o /= GT)+ ">" -> Just (o == GT)+ ">=" -> Just (o /= LT)+ _ -> Nothing
src/Oglyad/Source/Upstream.hs view
@@ -3,6 +3,7 @@ -- so oglyad sees exactly what `anda update` would see module Oglyad.Source.Upstream ( latestVersion,+ isSemver, ) where @@ -11,6 +12,7 @@ import Data.Aeson.Key qualified as Key import Data.Aeson.KeyMap qualified as KM import Data.Bifunctor (first)+import Data.Char (isAlphaNum, isDigit) import Data.List (maximumBy) import Data.Text (Text) import Data.Text qualified as T@@ -47,6 +49,7 @@ GitTags url -> first HttpFailed <$> liftIO (gitTags url) Derived how -> pure (Left (HttpFailed ("follows " <> how <> ", not an upstream release"))) CommitTracked -> pure (Left (HttpFailed "tracks a commit, not a version"))+ NoVersion -> pure (Left (HttpFailed "doesn't set a version")) Unknown _ -> pure (Left (HttpFailed "unparsed update.rhai")) where crateKey = \case@@ -71,7 +74,8 @@ walk _ _ = Nothing -- | opam has no "latest" endpoint. anda lists the package's directory in--- ocaml/opam-repository and picks the highest `name.version` entry+-- ocaml/opam-repository and picks the highest `name.version` entry that+-- parses as semver, which skips old schemes like Jane Street's 113.24.00 opam :: Text -> App (Either HttpError Text) opam name = do let url = "https://api.github.com/repos/ocaml/opam-repository/contents/packages/" <> name@@ -83,12 +87,29 @@ [ ver | Object o <- V.toList entries, Just (String n) <- [KM.lookup "name" o],- Just ver <- [T.stripPrefix (name <> ".") n]+ Just ver <- [T.stripPrefix (name <> ".") n],+ isSemver ver ] _ -> [] case versions of [] -> Left (HttpFailed ("no versions listed at " <> url))- _ -> Right (maximumBy rpmvercmp versions)+ _ -> Right (maximumBy (\a b -> rpmvercmp (normalizeVersion a) (normalizeVersion b)) versions)++-- | does this parse with the semver crate after anda's opam cleanup (leading+-- v's dropped, '~' read as '-')? MAJOR.MINOR.PATCH with no leading zeros,+-- then an optional -prerelease and +build+isSemver :: Text -> Bool+isSemver raw =+ let v = T.replace "~" "-" (T.dropWhile (== 'v') raw)+ (noBuild, build) = T.breakOn "+" v+ (core, pre) = T.breakOn "-" noBuild+ numeric p = not (T.null p) && T.all isDigit p && (p == "0" || T.head p /= '0')+ ident p = not (T.null p) && T.all (\c -> isAlphaNum c || c == '-') p+ preIdent p = ident p && (not (T.all isDigit p) || numeric p)+ idents f t = T.null t || all f (T.splitOn "." (T.drop 1 t))+ in case T.splitOn "." core of+ [a, b, c] -> all numeric [a, b, c] && idents preIdent pre && idents ident build+ _ -> False -- | newest tag on a git remote, for forges without a releases api. -- `git ls-remote` speaks the smart http protocol, so nothing gets cloned
src/Oglyad/Types.hs view
@@ -64,6 +64,9 @@ Derived Text | -- | follows a branch head (gh_commit and friends), no version to compare CommitTracked+ | -- | never sets anything the spec's Version: is built from. it only bumps+ -- Release (say, to rebuild when something else changes) or writes files+ NoVersion | -- | raw update.rhai we couldn't make sense of Unknown Text deriving stock (Eq, Ord, Show, Read, Generic)@@ -84,6 +87,14 @@ pkgPath :: FilePath, -- | Terra subrepo from anda.hcl labels, e.g. "extras" pkgSubrepo :: Maybe Text,+ -- | a `nightly` or `quaterdaily` label in anda.hcl: built from a branch+ -- head on a schedule, not from releases+ pkgNightly :: Bool,+ -- | the spec file, relative to the tree it was read from+ pkgSpecPath :: Maybe FilePath,+ -- | hash of everything in the package dir that can change what rpmspec+ -- says, plus the dist and macros. keys caches of anda runs+ pkgFingerprint :: Text, -- | what's merged in git pkgSpecEVR :: Maybe EVR, -- | what's actually published@@ -91,6 +102,8 @@ pkgLastCommit :: Maybe UTCTime, -- | Nothing means no update.rhai pkgUpstream :: Maybe UpstreamSource,+ -- | the update.rhai itself, for replaying it against the upstream value+ pkgRhai :: Maybe Text, -- | only filled in when upstream lookups ran pkgUpstreamVer :: Maybe Text, -- | why the upstream lookup failed, if it did@@ -117,7 +130,10 @@ -- (see the duplicate-name check), so this is what identifies it fPath :: Maybe Text, fSeverity :: Severity,- fMessage :: Text+ fMessage :: Text,+ -- | the releases this showed up in, by name ("43", "rawhide"). empty+ -- until the run stamps it+ fReleases :: [Text] } deriving stock (Eq, Show, Generic) deriving anyclass (ToJSON)@@ -130,25 +146,36 @@ fPackage = pkgName p, fPath = Just (T.pack (pkgPath p)), fSeverity = sev,- fMessage = msg+ fMessage = msg,+ fReleases = [] } data Config = Config { -- | local checkout of terrapkg/packages cfgMonorepo :: FilePath,+ -- | git ref to read specs from, e.g. origin/f43. Nothing reads the+ -- working tree of cfgMonorepo as it is+ cfgSpecRef :: Maybe Text,+ -- | the terrapkg/packages branch name, f43 or frawhide. update.rhai+ -- scripts see it as labels.branch+ cfgBranch :: Text, -- | e.g. https://repos.fyralabs.com/terra44 cfgTerraRepo :: Text, -- | repo base urls to check for overlap cfgFedoraRepos :: [Text],- -- | %{dist} used when evaluating specs, e.g. .fc44- -- | Fedora/Terra release number, e.g. 44+ -- | Fedora/Terra release number, e.g. 44. rawhide has one too cfgRelease :: Int,+ -- | %{dist} used when evaluating specs, e.g. .fc44 or .fcrawhide cfgDist :: Text, cfgStaleAfter :: NominalDiffTime, -- | whether to hit upstream APIs at all cfgUpstream :: Bool, -- | reuse cached upstream answers younger than this cfgCacheFor :: NominalDiffTime,+ -- | when this oglyad run started. upstream answers fetched since then are+ -- reused whatever cfgCacheFor says, so checking four releases asks each+ -- upstream once+ cfgRunStart :: UTCTime, -- | parallel jobs, defaults to the number of cores cfgConcurrency :: Int, cfgGitHubToken :: Maybe Text
src/Oglyad/Version.hs view
@@ -15,7 +15,8 @@ import Data.Aeson (FromJSON, ToJSON) import Data.Char (isAlphaNum, isAsciiLower, isAsciiUpper, isDigit)-import Data.List (find)+import Data.List (find, minimumBy)+import Data.Ord (comparing) import Data.Text (Text) import Data.Text qualified as T import GHC.Generics (Generic)@@ -142,14 +143,16 @@ -- ways packagers respell a version. returns how upstream compares to the spec -- -- * same letters and digits, different punctuation is the same version--- (0.4.2 vs 0.4~2, 2026.07.27 vs 20260727)+-- (0.4.2 vs 0.4~2, 2026.07.27 vs 20260727). a snapshot suffix on the+-- spec (^20260805git..., .gitfc62ae7) doesn't count, since a snapshot of+-- the release upstream just tagged isn't behind it -- * the same leading dotted number with junk after it is the same version -- (2.005R vs 2.005, 3.17.0-ogc1 vs 3.17.0^1), unless one side is a -- prerelease, since 6.0.0 vs 6.0.0~alpha1 is real drift -- * otherwise rpmvercmp decides compareUpstream :: Text -> Text -> Ordering compareUpstream up spec- | squash u == squash s = EQ+ | squash u == squash s || squash u == squash (snapshotBase s) = EQ | not (T.null (core u)) && core u == core s && not (isPre u || isPre s) = EQ | otherwise = rpmvercmp u s where@@ -159,3 +162,15 @@ core = T.dropWhileEnd (== '.') . T.takeWhile (\c -> isDigit c || c == '.') -- a prerelease is never "the same version with junk after it" isPre v = "~" `T.isPrefixOf` T.drop (T.length (core v)) (T.dropWhileEnd (== '.') v)++-- | a version with its snapshot suffix cut off: everything from a '^', or+-- from a git marker like ".git" or "+git". not "~git", since that's a+-- snapshot from before the release, so 2.0~git... really is behind 2.0+--+-- >>> snapshotBase "2.0.0~alpha~1~20250926.gitfc62ae7"+-- "2.0.0~alpha~1~20250926"+snapshotBase :: Text -> Text+snapshotBase v =+ let base = T.takeWhile (/= '^') v+ cuts = [pre | sep <- [".git", "+git", "_git"], let (pre, post) = T.breakOn sep base, not (T.null post)]+ in minimumBy (comparing T.length) (base : cuts)
test/Spec.hs view
@@ -17,12 +17,18 @@ import Oglyad.Check.DuplicateName qualified as DuplicateName import Oglyad.Check.FedoraOverlap qualified as FedoraOverlap import Oglyad.Check.Stale qualified as Stale+import Oglyad.Check.UnparsedRhai qualified as UnparsedRhai 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.Regex qualified as Re+import Oglyad.Release+import Oglyad.Report (ReleaseInfo (..), Report (..), renderJson, renderMarkdown, renderText)+import Oglyad.Source.Anda (scriptErrors, stripAnsi)+import Oglyad.Source.Monorepo (PkgDir (..), checkoutRef, findPackageDirs, hclString, lastCommits, macroFingerprint, specFingerprint, versionMacros) import Oglyad.Source.Repodata (RpmEntry (..), decompressAndParse, fetchRepo, latestBySource, parsePrimary, srpmName)-import Oglyad.Source.Rhai (parseUpdateRhai)+import Oglyad.Source.Rhai (parseUpdateRhai, parseUpdateRhaiWith)+import Oglyad.Source.RhaiEval (Simulated (..), simulateVersion)+import Oglyad.Source.Upstream (isSemver) import Oglyad.Types import Oglyad.Version import System.Directory (createDirectoryIfMissing, createDirectoryLink, createFileLink)@@ -97,9 +103,104 @@ ("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)+ ("0.41.0", "0.41.0^20261031.9e2ed65", EQ),+ -- snapshot suffixes don't stop a respelled version from matching+ ("2.0.0-alpha-1-20250926", "2.0.0~alpha~1~20250926.gitfc62ae7", EQ),+ ("0.4-2", "0.4~2^20260805git.d5d9f60", EQ),+ ("1.3", "1.2^20260101git.abc1234", GT),+ ("1.2", "1.2~rc1^20260101git.abc1234", GT),+ -- a ~git snapshot comes before the release, so it's behind it+ ("2.0", "2.0~git20250101.abc1234", GT) ] + describe "isSemver" $ do+ it "takes plain versions" $ isSemver "v0.17.1" `shouldBe` True+ it "takes prereleases spelled with a tilde" $ isSemver "0.17.0~preview.128" `shouldBe` True+ it "rejects leading zeros, like Jane Street's old scheme" $ isSemver "113.24.00" `shouldBe` False+ it "rejects two-part versions" $ isSemver "1.2" `shouldBe` False++ describe "regex" $ do+ let firstCaps p t = either (const Nothing) (either (const Nothing) id . (`Re.captures` t)) (Re.compile p)+ it "is leftmost-first, like Rust" $+ -- POSIX engines like regex-tdfa take the longest, "ab"+ firstCaps "(a|ab)" "ab" `shouldBe` Just [Just "a", Just "a"]+ it "supports lazy quantifiers" $+ firstCaps "<(.+?)>" "<a><b>" `shouldBe` Just [Just "<a>", Just "a"]+ it "reports groups that didn't take part" $+ firstCaps "(a)|(b)" "b" `shouldBe` Just [Just "b", Nothing, Just "b"]+ it "anchors lines only in multi-line mode" $ do+ firstCaps "(?m)^Version:\\s*(\\S+)$" "Name: x\nVersion: 1.2\n" `shouldBe` Just [Just "Version: 1.2", Just "1.2"]+ firstCaps "^Version" "Name: x\nVersion: 1.2" `shouldBe` Nothing+ it "skips an empty match right after the previous one" $+ (Re.compile "a*" >>= (`Re.capturesAll` "ab")) `shouldBe` Right [[Just "a"], [Just ""]]+ it "expands replacements like Rust" $+ (Re.compile "v(\\d)" >>= \re -> Re.replaceAll re "<$1|${1}x|$1x|$$>" "v1") `shouldBe` Right "<1|1x||$>"+ it "stays linear on patterns that blow up naive backtracking" $+ (Re.compile "^(\\s[.-]?|\\s??(\\D?\\b(a|b)|\\S?\\D??\\.??){2}1??a?){0,}b+(a){2}" >>= (`Re.captures` "v1.2.3-rc1"))+ `shouldBe` Right Nothing+ -- these three came out of fuzzing against the real crate. they only agree+ -- with Rust because the NFA has the same shape and a visited set+ it "takes an empty first iteration of x* like Rust" $+ firstCaps "(a*)?[^a]+?" "v" `shouldBe` Just [Just "v", Just ""]+ it "doesn't loop again after an empty iteration" $+ firstCaps "b??(x*?)*" "xx" `shouldBe` Just [Just "", Just ""]+ it "keeps the last non-empty iteration's captures" $+ firstCaps "(a*){0,}a*" "a" `shouldBe` Just [Just "a", Just "a"]+ it "rejects what it doesn't support" $+ either (const True) (const False) (Re.compile "\\p{Greek}") `shouldBe` True++ describe "simulateVersion" $ do+ let gh = GitHub "a/b"+ sim tag script = simulateVersion gh tag script+ it "passes a plain rpm.version through" $+ sim "v1.2.3" "rpm.version(gh(\"a/b\"));" `shouldBe` Sets "v1.2.3"+ it "skips tags a starts_with guard rejects" $ do+ let script = "let v = gh(\"a/b\");\nif v.starts_with(\"cli-v\") {\n v.crop(5);\n rpm.version(v);\n}"+ sim "desktop-v2026.10.4" script `shouldBe` NoUpdate+ sim "cli-v2026.10.4" script `shouldBe` Sets "2026.10.4"+ it "runs else branches" $ do+ let script = "let ver = gh(\"a/b\");\nif ver.starts_with(\"vm-\") {\n\tver.crop(3);\n\trpm.version(ver);\n} else {\n\tprint(`graalvm: ${ver}?`);\n}"+ sim "jdk-25.0.1" script `shouldBe` NoUpdate+ it "compares strings like Rhai" $ do+ let script = "let v = gh(\"a/b\");\nv.crop(1);\nif v < \"5\" {\n rpm.version(v);\n}"+ sim "v5.4.1" script `shouldBe` NoUpdate+ sim "v4.8.0" script `shouldBe` Sets "4.8.0"+ it "applies pop and replace, preferring rpm.version over the ver global" $ do+ let script = "let v = gh(\"a/b\");\nv.crop(1);\nrpm.global(\"ver\", v);\nif v.ends_with(\"-release\") {\n v.pop(8);\n}\nv.replace(\"-\", \"~\");\nrpm.version(v);"+ sim "v0.0.17-beta-release" script `shouldBe` Sets "0.0.17~beta"+ it "treats rpm.changed() as true and follows truncate" $ do+ let script = "rpm.global(\"commit\", gh_commit(\"a/b\"));\nif rpm.changed() {\n rpm.release();\n let v = gh(\"a/b\");\n v.truncate(6);\n v.crop(1);\n rpm.global(\"ver\", v);\n}"+ sim "v1.0.1-iot-arl-twl-asl-v6.12" script `shouldBe` Sets "1.0.1"+ it "gives up on scripts that rewrite the spec through rpm.f" $+ sim "v1.2.3" "let v = gh(\"a/b\");\nrpm.f = sub(`(?m)^Version:.*$`, \"Version: \" + v, rpm.f);" `shouldBe` CantTell+ it "knows a script that never sets Version won't update" $+ sim "vUDK2018" "let v = gh(\"a/b\");\nrpm.global(\"release_tag\", v);\nv.crop(3);\nrpm.global(\"shortcommit\", v);" `shouldBe` NoUpdate+ it "stops at terminate()" $+ sim "0.4.0" "terminate();\nrpm.version(gh(\"a/b\"));" `shouldBe` NoUpdate+ it "uses find() as a guard inside try" $ do+ let script = "let v = gh(\"a/b\");\ntry {\n\tfind(\"(?m)^v[\\\\d.]+$\", v, 0);\n\trpm.version(v);\n}\ncatch {}"+ sim "v1.3.7-windows-alpha" script `shouldBe` NoUpdate+ sim "v1.3.8" script `shouldBe` Sets "v1.3.8"+ it "extracts with find() groups" $+ sim "Ghidra_11.4_build" "let tag = gh(\"a/b\");\nlet v = find(`Ghidra_([\\d.]+)_build`, tag, 1);\nrpm.version(v);" `shouldBe` Sets "11.4"+ it "counts find_all() matches in method form" $ do+ let script = "let v = gh(\"a/b\");\nif `[\\d.]+-beta\\.\\d+`.find_all(v).len == 0 {\n rpm.version(v);\n}"+ sim "1.2.3-beta.4" script `shouldBe` NoUpdate+ sim "1.2.3" script `shouldBe` Sets "1.2.3"+ it "rewrites with sub() and indexes find_all() results" $ do+ sim "release-1_2_3" "let v = sub(`_`, \".\", gh(\"a/b\"));\nrpm.version(sub(`^release-`, \"\", v));" `shouldBe` Sets "1.2.3"+ sim "v1.2 v1.3" "let m = find_all(`v([\\d.]+)`, gh(\"a/b\"));\nrpm.version(m[-1][1]);" `shouldBe` Sets "1.3"+ it "fills in template strings" $+ sim "pkg-1.2" "let name = \"pkg\";\nlet t = gh(\"a/b\");\nrpm.version(find(`${name}-([\\d.]+)`, t, 1));" `shouldBe` Sets "1.2"+ it "gives up when find() throws with nothing to catch it" $+ sim "nope" "rpm.version(find(`v([\\d.]+)`, gh(\"a/b\"), 1));" `shouldBe` CantTell+ it "gives up on calls it can't model" $+ sim "1.2" "let v = gh(\"a/b\");\nrpm.version(mystery(v));" `shouldBe` CantTell+ it "gives up on scripts with unbalanced brackets" $+ sim "0.2.1" "if rpm.changed() {\n let v = gh(\"a/b\"));\n v.crop(1);\n rpm.global(\"ver\", v);\n}" `shouldBe` CantTell+ it "ignores other helpers that don't feed Version" $+ sim "v0.14.1" "rpm.version(gh(\"a/b\"));\nif rpm.changed() {\n rpm.global(\"drawio_ver\", gh(\"c/d\").crop(1));\n}" `shouldBe` Sets "v0.14.1"+ describe "srpmName" $ do it "strips version and release" $ srpmName "zed-0.190.0-1.fc44.src.rpm" `shouldBe` Just "zed"@@ -135,6 +236,7 @@ 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+ it "reads bare values like nightly = 1" $ hclString "nightly" "labels {\n nightly = 2 # slot\n}\n" `shouldBe` Just "2" describe "parseUpdateRhai" $ do it "understands gh()" $@@ -157,6 +259,51 @@ 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 "follows kmod-common siblings instead of calling them unparsed" $+ parseUpdateRhai "let c = sh(\"cat anda/system/x/kmod-common/x.spec | grep 'Version: ' | sed -E 's/Version: +//'\", #{});\nc.trim();\nrpm.version(c);"+ `shouldBe` Derived "another spec in the repo"+ it "calls a commit set from get() commit tracking" $+ parseUpdateRhai "let json = get(\"https://api.github.com/repos/a/b/commits/main\").json();\nrpm.global(\"commit\", json.sha);"+ `shouldBe` CommitTracked+ it "doesn't call a scraped version commit tracking because it records the commit" $+ parseUpdateRhai "let r = get(\"https://api.github.com/repos/a/b/tags\").json_arr();\nrpm.version(r[0].name);\nif rpm.changed() {\n rpm.global(\"commit\", r[0].commit.sha);\n}"+ `shouldSatisfy` isUnknown+ it "knows a release-bump-only script doesn't set a version" $+ parseUpdateRhaiWith (Just ["fedora", "rhel"]) "import \"andax/bump_extras.rhai\" as bump;\nopen_file(\"RELEASE.txt\", \"w\").write(bump::as_bodhi_ver(labels.branch));\nrpm.release();"+ `shouldBe` NoVersion+ it "counts globals the Version: line uses as setting the version" $ do+ let ente = "let tags = git_tags(\"https://github.com/ente-io/ente\").filter(|t| t.starts_with(\"cli-v\"));\nrpm.global(\"tag\", tags[tags.len - 1]);"+ parseUpdateRhaiWith (Just ["tag"]) ente `shouldSatisfy` isUnknown+ parseUpdateRhaiWith (Just ["other"]) ente `shouldBe` NoVersion+ it "doesn't guess NoVersion without the spec's Version: line" $+ parseUpdateRhai "rpm.release();" `shouldSatisfy` isUnknown++ describe "anda logs" $ do+ it "pulls the reason out of a script exception" $+ scriptErrors+ " 2026-11-09T22:25:38.348511Z ERROR andax::run: Script Exception \8212\8212 lib/libfreeaptx\n\+ \ \9500\9472\9552 Rhai: Syntax error: Expecting ';' to terminate this statement (line 5, position 39)\n\+ \ in andax::run::traceback with proj=\"lib/libfreeaptx\"\n"+ `shouldBe` ["Rhai: Syntax error: Expecting ';' to terminate this statement (line 5, position 39)"]+ it "finds nothing in a clean log" $+ scriptErrors " 2026-11-09T22:25:34Z DEBUG anda_config::config: Reading hcl file: \"anda.hcl\"\n" `shouldBe` []+ it "strips color codes" $+ stripAnsi " 0: \ESC[91mProject not found: x\ESC[0m" `shouldBe` " 0: Project not found: x"++ describe "unparsed-rhai with anda" $+ it "stays quiet once anda answered for the script" $ do+ let unknown = pkg {pkgUpstream = Just (Unknown "let x = get(\"u\");")}+ map fCheck (UnparsedRhai.check snapshot unknown) `shouldBe` ["unparsed-rhai"]+ UnparsedRhai.check snapshot unknown {pkgUpstreamVer = Just "1.3.0"} `shouldBe` []++ describe "versionMacros" $ do+ it "finds %name, %{name} and %{?name}" $+ versionMacros "Name: x\nVersion: %{?fedora:%{fedora}}%{?rhel:%{rhel}}\n" `shouldBe` Just ["fedora", "fedora", "rhel", "rhel"]+ it "finds macros inside shell expansions" $+ versionMacros "%global tag cli-v0.3.0\nVersion: %(echo %tag | sed 's/^cli-v//')\n" `shouldBe` Just ["tag"]+ it "is Nothing without a Version: line" $+ versionMacros "Name: x\n" `shouldBe` Nothing+ it "falls back to Unknown" $ parseUpdateRhai "let x = get(\"https://example.com\").json();\nrpm.version(x.version);" `shouldSatisfy` isUnknown @@ -169,7 +316,20 @@ 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` []+ it "doesn't hold nightlies to the latest stable release" $ do+ let snap = pkg {pkgNightly = True, pkgSpecEVR = Just (EVR 0 "0.41.0^20261031.9e2ed65" "1.fc44"), pkgUpstreamVer = Just "v0.42.0"}+ Drift.check snapshot snap `shouldBe` []+ Drift.drift snap `shouldBe` Nothing+ it "still flags a mangled version on a nightly" $+ severities (Drift.check snapshot (pkg {pkgNightly = True, pkgUpstreamVer = Just ".0.1"})) `shouldBe` [Warn]+ it "warns when update.rhai mangles the version" $+ map fMessage (Drift.check snapshot (pkg {pkgSpecEVR = Just (EVR 0 ".0.1^20261029.git.8ce4f26" "1.fc44"), pkgUpstreamVer = Just ".0.1"}))+ `shouldBe` ["update.rhai would set the version to \".0.1\", which doesn't start with a letter or digit"] + describe "unparsed-rhai check"+ $ it "flags scripts with unbalanced brackets"+ $ severities (UnparsedRhai.check snapshot (pkg {pkgRhai = Just "let v = gh_tag(\"a/b\"));\nrpm.version(v);"})) `shouldBe` [Warn]+ describe "fedora-overlap check" $ do let withFedora = snapshot {snapFedora = Set.singleton "zed"} it "warns when Fedora ships the same package" $@@ -190,7 +350,7 @@ DuplicateName.check snapshot pkg `shouldBe` [] describe "report" $ do- let f path = Finding "build-lag" "zed" (Just path) Warn "x"+ 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" $@@ -201,7 +361,7 @@ 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 "schema" o `shouldBe` Just (Number 2) 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" $@@ -210,7 +370,7 @@ renderMarkdown Info (report [(f "anda/a") {fSeverity = Info}]) `shouldSatisfy` T.isInfixOf "<details><summary>Info (1)" describe "ignores" $ do- let f check path name = Finding check name (Just path) Warn "x"+ 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@@ -227,7 +387,7 @@ $ \(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], [])+ (apKept, apIgnored, apUnused, 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])@@ -239,10 +399,10 @@ apKept `shouldBe` [lag] it "reports entries that match nothing" $ do let Applied {..} = apply [rule "stale" (ByName "gone")] [] [lag]- map fCheck apProblems `shouldBe` ["unused-ignore"]+ map fCheck apUnused `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` []+ apUnused `shouldBe` [] it "flags unknown check names in labels" $ do let Applied {..} = apply [] [("anda/x", ["stael"])] [] map fSeverity apProblems `shouldBe` [Warn]@@ -280,6 +440,18 @@ _ <- specFingerprint "m" ".fc44" root "anda/a" pure () + describe "nightly labels" $+ it "treats nightly and quaterdaily as branch-head builds, not weekly" $+ withSystemTempDirectory "oglyad-labels" $ \root -> do+ let pkgDir name key = do+ createDirectoryIfMissing True (root </> "anda" </> name)+ writeFile (root </> "anda" </> name </> "anda.hcl") ("project pkg {\n labels {\n " <> key <> " = 1\n }\n}\n")+ pkgDir "n" "nightly"+ pkgDir "q" "quaterdaily"+ pkgDir "w" "weekly"+ dirs <- findPackageDirs root+ [(pdPath d, pdNightly d) | Right d <- dirs] `shouldBe` [("anda/n", True), ("anda/q", True), ("anda/w", False)]+ describe "parseCheckName" $ do it "accepts known checks" $ parseCheckName "build-lag" `shouldBe` Right "build-lag" it "rejects typos instead of silently running nothing" $@@ -303,6 +475,74 @@ fpAfter <- macroFingerprint fpAfter `shouldNotBe` fpBefore + describe "releases" $ do+ it "parses --release spellings" $+ map parseReleaseArg ["43", "f44", "rawhide", "frawhide", "el10", ""]+ `shouldBe` [Right (NumberedArg 43), Right (NumberedArg 44), Right RawhideArg, Right RawhideArg, Left "unknown release \"el10\", expected a number like 43, f43, or rawhide", Left "unknown release \"\", expected a number like 43, f43, or rawhide"]+ it "spells rawhide's dist, branch and repos the way Terra does" $ do+ let raw = Release "rawhide" 46+ (releaseDist raw, releaseBranch raw, terraRepoFor raw, releaseLabel raw) `shouldBe` (".fcrawhide", "frawhide", "https://repos.fyralabs.com/terrarawhide", "rawhide")+ fedoraReposFor raw `shouldBe` ["https://dl.fedoraproject.org/pub/fedora/linux/development/rawhide/Everything/x86_64/os"]+ length (fedoraReposFor (Release "43" 43)) `shouldBe` 2+ it "takes Fedora releases from Bodhi, rawhide last" $+ parseBodhiReleases bodhiFixture `shouldBe` Right [Release "43" 43, Release "44" 44, Release "45" 45, Release "rawhide" 46]+ it "complains when Bodhi lists nothing useful" $+ parseBodhiReleases "{\"releases\": []}" `shouldSatisfy` either (const True) (const False)++ describe "mergeFindings" $ do+ let r43 = Release "43" 43+ r44 = Release "44" 44+ lag dist = Finding "build-lag" "zed" (Just "anda/zed") Error ("never published (spec is at 1.2-1" <> dist <> ")") []+ drift = Finding "drift" "zed" (Just "anda/zed") Warn "upstream has 1.3, spec is at 1.2" []+ it "merges findings that only differ by dist" $+ mergeFindings [(r43, [lag ".fc43"]), (r44, [lag ".fc44"])]+ `shouldBe` [(lag "%{dist}") {fReleases = ["43", "44"]}]+ it "keeps the real message for a single release" $+ mergeFindings [(r43, [drift]), (r44, [lag ".fc44"])]+ `shouldBe` [drift {fReleases = ["43"]}, (lag ".fc44") {fReleases = ["44"]}]+ it "tags findings with only the releases that have them" $+ map fReleases (mergeFindings [(r43, [drift]), (r44, [drift, lag ".fc44"])]) `shouldBe` [["43", "44"], ["44"]]++ describe "release tags in reports" $ do+ let infos = [ReleaseInfo n ("f" <> n) Nothing Nothing "" | n <- ["43", "44"]]+ f rels = Finding "drift" "zed" (Just "anda/zed") Warn "x" rels+ two fs = (report fs) {rReleases = infos}+ it "says which releases a finding is in when it isn't all of them" $+ renderText Info (two [f ["44"]]) `shouldSatisfy` T.isInfixOf "zed [f44]: x"+ it "says nothing when it's in every release" $+ renderText Info (two [f ["43", "44"]]) `shouldSatisfy` T.isInfixOf "zed: x"++ describe "checkoutRef" $+ it "extracts a branch without touching the checkout, once per commit" $+ withSystemTempDirectory "oglyad-ref" $ \tmp -> do+ let repo = tmp </> "repo"+ cache = tmp </> "cache"+ git args =+ runProcess_ . System.Process.Typed.setEnv [("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)+ commitFile body = do+ writeFile (repo </> "anda" </> "a" </> "anda.hcl") body+ git ["add", "-A"]+ git ["commit", "-q", "-m", body]+ createDirectoryIfMissing True (repo </> "anda" </> "a")+ git ["init", "-q"]+ commitFile "old"+ git ["branch", "f43"]+ commitFile "new"+ old <- lookupEnv "XDG_CACHE_HOME"+ System.Environment.setEnv "XDG_CACHE_HOME" cache+ r1 <- checkoutRef repo "f43"+ r2 <- checkoutRef repo "f43"+ missing <- checkoutRef repo "f99"+ maybe (unsetEnv "XDG_CACHE_HOME") (System.Environment.setEnv "XDG_CACHE_HOME") old+ case r1 of+ Left e -> expectationFailure (T.unpack e)+ Right (dir, _) -> do+ readFile (dir </> "anda" </> "a" </> "anda.hcl") >>= (`shouldBe` "old")+ readFile (repo </> "anda" </> "a" </> "anda.hcl") >>= (`shouldBe` "new")+ r2 `shouldBe` r1+ missing `shouldSatisfy` either (const True) (const False)+ describe "lastCommits" $ it "reads commit times, including UTC ones git prints with a Z" $ withSystemTempDirectory "oglyad-git" $ \repo -> do@@ -317,7 +557,7 @@ 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"]+ m <- lastCommits repo "HEAD" ["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)) @@ -366,10 +606,14 @@ { pkgName = "zed", pkgPath = "anda/devs/zed/stable", pkgSubrepo = Nothing,+ pkgNightly = False,+ pkgSpecPath = Just "anda/devs/zed/stable/zed.spec",+ pkgFingerprint = "", pkgSpecEVR = Just (EVR 0 "1.2.0" "1.fc44"), pkgRepoBuild = Nothing, pkgLastCommit = Nothing, pkgUpstream = Just (GitHub "zed-industries/zed"),+ pkgRhai = Nothing, pkgUpstreamVer = Nothing, pkgUpstreamErr = Nothing, pkgRepoChecked = True@@ -384,6 +628,8 @@ snapConfig = Config { cfgMonorepo = ".",+ cfgSpecRef = Nothing,+ cfgBranch = "f44", cfgTerraRepo = "", cfgFedoraRepos = [], cfgRelease = 44,@@ -391,6 +637,7 @@ cfgStaleAfter = 180 * nominalDay, cfgUpstream = False, cfgCacheFor = 0,+ cfgRunStart = now, cfgConcurrency = 1, cfgGitHubToken = Nothing },@@ -398,13 +645,23 @@ snapIgnoreLabels = Map.empty } +bodhiFixture :: LBS8.ByteString+bodhiFixture =+ "{\"releases\": [\+ \{\"name\": \"F46\", \"version\": \"46\", \"branch\": \"rawhide\", \"id_prefix\": \"FEDORA\", \"state\": \"pending\"},\+ \{\"name\": \"F44\", \"version\": \"44\", \"branch\": \"f44\", \"id_prefix\": \"FEDORA\", \"state\": \"current\"},\+ \{\"name\": \"F45C\", \"version\": \"45\", \"branch\": \"f45\", \"id_prefix\": \"FEDORA-CONTAINER\", \"state\": \"current\"},\+ \{\"name\": \"ELN\", \"version\": \"eln\", \"branch\": \"eln\", \"id_prefix\": \"FEDORA\", \"state\": \"pending\"},\+ \{\"name\": \"F43\", \"version\": \"43\", \"branch\": \"f43\", \"id_prefix\": \"FEDORA\", \"state\": \"current\"},\+ \{\"name\": \"F45\", \"version\": \"45\", \"branch\": \"f45\", \"id_prefix\": \"FEDORA\", \"state\": \"current\"}\+ \]}"+ report :: [Finding] -> Report report fs = Report { rVersion = "0", rGenerated = now,- rMonorepoHead = Just "abc",- rTerraRepo = "https://repos.fyralabs.com/terra44",+ rReleases = [ReleaseInfo "44" "f44" (Just "origin/f44") (Just "abc") "https://repos.fyralabs.com/terra44"], rUpstream = False, rFindings = fs, rIgnored = []