diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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= ` +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//` | 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` release tag | +| project | spec | builds | +| ------------ | ------------------------------------ | ------------------------------------------------------------- | +| `oglyad` | [`oglyad.spec`](oglyad.spec) | the `v` release tag | | `oglyad-git` | [`oglyad-git.spec`](oglyad-git.spec) | the checked-out commit, versioned `^.` | ```sh diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -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) $ diff --git a/oglyad.cabal b/oglyad.cabal --- a/oglyad.cabal +++ b/oglyad.cabal @@ -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 diff --git a/src/Oglyad/Check/Drift.hs b/src/Oglyad/Check/Drift.hs --- a/src/Oglyad/Check/Drift.hs +++ b/src/Oglyad/Check/Drift.hs @@ -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")] + _ -> [] diff --git a/src/Oglyad/Check/NoAutoupdate.hs b/src/Oglyad/Check/NoAutoupdate.hs --- a/src/Oglyad/Check/NoAutoupdate.hs +++ b/src/Oglyad/Check/NoAutoupdate.hs @@ -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 _ -> [] diff --git a/src/Oglyad/Check/UnparsedRhai.hs b/src/Oglyad/Check/UnparsedRhai.hs --- a/src/Oglyad/Check/UnparsedRhai.hs +++ b/src/Oglyad/Check/UnparsedRhai.hs @@ -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' [] = "" diff --git a/src/Oglyad/Collect.hs b/src/Oglyad/Collect.hs --- a/src/Oglyad/Collect.hs +++ b/src/Oglyad/Collect.hs @@ -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 = []} diff --git a/src/Oglyad/Ignore.hs b/src/Oglyad/Ignore.hs --- a/src/Oglyad/Ignore.hs +++ b/src/Oglyad/Ignore.hs @@ -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, diff --git a/src/Oglyad/Process.hs b/src/Oglyad/Process.hs --- a/src/Oglyad/Process.hs +++ b/src/Oglyad/Process.hs @@ -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 diff --git a/src/Oglyad/Regex.hs b/src/Oglyad/Regex.hs new file mode 100644 --- /dev/null +++ b/src/Oglyad/Regex.hs @@ -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...), (?...)), 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) diff --git a/src/Oglyad/Release.hs b/src/Oglyad/Release.hs new file mode 100644 --- /dev/null +++ b/src/Oglyad/Release.hs @@ -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} diff --git a/src/Oglyad/Report.hs b/src/Oglyad/Report.hs --- a/src/Oglyad/Report.hs +++ b/src/Oglyad/Report.hs @@ -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 diff --git a/src/Oglyad/Source/Anda.hs b/src/Oglyad/Source/Anda.hs new file mode 100644 --- /dev/null +++ b/src/Oglyad/Source/Anda.hs @@ -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 —— " 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)" diff --git a/src/Oglyad/Source/Cache.hs b/src/Oglyad/Source/Cache.hs --- a/src/Oglyad/Source/Cache.hs +++ b/src/Oglyad/Source/Cache.hs @@ -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, diff --git a/src/Oglyad/Source/Monorepo.hs b/src/Oglyad/Source/Monorepo.hs --- a/src/Oglyad/Source/Monorepo.hs +++ b/src/Oglyad/Source/Monorepo.hs @@ -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 diff --git a/src/Oglyad/Source/Rhai.hs b/src/Oglyad/Source/Rhai.hs --- a/src/Oglyad/Source/Rhai.hs +++ b/src/Oglyad/Source/Rhai.hs @@ -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 -> diff --git a/src/Oglyad/Source/RhaiEval.hs b/src/Oglyad/Source/RhaiEval.hs new file mode 100644 --- /dev/null +++ b/src/Oglyad/Source/RhaiEval.hs @@ -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 diff --git a/src/Oglyad/Source/Upstream.hs b/src/Oglyad/Source/Upstream.hs --- a/src/Oglyad/Source/Upstream.hs +++ b/src/Oglyad/Source/Upstream.hs @@ -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 diff --git a/src/Oglyad/Types.hs b/src/Oglyad/Types.hs --- a/src/Oglyad/Types.hs +++ b/src/Oglyad/Types.hs @@ -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 diff --git a/src/Oglyad/Version.hs b/src/Oglyad/Version.hs --- a/src/Oglyad/Version.hs +++ b/src/Oglyad/Version.hs @@ -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) diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -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 "<(.+?)>" "" `shouldBe` Just [Just "", 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 "
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 = []