oglyad 0.1.2.0 → 0.1.3.1
raw patch · 11 files changed
+315/−93 lines, 11 files
Files
- CHANGELOG.md +13/−0
- README.md +36/−6
- app/Main.hs +44/−23
- oglyad.cabal +1/−1
- src/Oglyad/Collect.hs +6/−8
- src/Oglyad/Release.hs +72/−18
- src/Oglyad/Report.hs +7/−3
- src/Oglyad/Source/Monorepo.hs +10/−9
- src/Oglyad/Source/Repodata.hs +62/−11
- src/Oglyad/Types.hs +20/−5
- test/Spec.hs +44/−9
CHANGELOG.md view
@@ -1,5 +1,18 @@ # changelog +## 0.1.3.0++- checks Ultramarine-Linux/packages too: `-d`/`--distro ultramarine` reads+ `ultramarine/`, the `um43` branches and the `um43` repos with `.um43`+ dist tags. without `--distro`, oglyad picks whichever distro's package+ directory the checkout has+- repos are found through tetsudou's metalinks, like dnf, instead of+ `repos.fyralabs.com` directly. a mirror whose repomd.xml doesn't match the+ metalink's checksums is skipped+- `--repo` takes `{repo}` and `{release}` placeholders, so one url can+ cover every release and subrepo. it can be a metalink or a base url+- json and markdown reports name the distro+ ## 0.1.2.0 - checks every maintained release by default (today f43, f44, f45 and
README.md view
@@ -12,6 +12,7 @@ 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+oglyad -m ../um-packages # Ultramarine-Linux/packages works too ``` from a checkout, `cabal run oglyad -- <args>` and `cabal test`. it needs@@ -35,9 +36,37 @@ 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.+and needs exactly one `--release`. +## distros and repos++oglyad checks any anda monorepo it knows the layout of. `-d`/`--distro`+picks one, and by default it's whichever one's package directory the+checkout has:++| distro | monorepo | packages in | branches | repos | dist |+| ------------- | -------------------------- | -------------- | ------------------- | --------------------------- | --------------------- |+| `terra` | terrapkg/packages | `anda/` | `f43`, `frawhide` | `terra43`, `terra43-extras` | `.fc43`, `.fcrawhide` |+| `ultramarine` | Ultramarine-Linux/packages | `ultramarine/` | `um43`, `umrawhide` | `um43` | `.um43`, `.umrawhide` |++builds are looked up through the same metalink dnf uses,+`https://tetsudou.fyralabs.com/metalink?repo={repo}&arch=x86_64`. oglyad+tries its mirrors by preference and takes the first repomd.xml whose sha256+the metalink lists, so a mirror that hasn't synced yet is skipped.++`--repo` swaps that url for another one. `{repo}` becomes the repo's name+(`terra43`, or `terra43-extras` for a subrepo) and `{release}` the release's+(`43`, `rawhide`). a url with `metalink` in it is read as a metalink, and+anything else as a base url with `repodata/` under it:++```sh+oglyad -m ../packages --repo 'https://repos.fyralabs.com/{repo}' # skip the metalink+oglyad -m ../packages -r 44 --repo https://mirror.example/terra44 # one release's repo+```++a url with neither placeholder only names one release's repo, so it needs+exactly one `--release`. subrepos get `-extras` and so on added to its end.+ 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:@@ -49,9 +78,9 @@ summaries) or `json`. the json is a versioned envelope: ```json-{"schema": 2, "oglyad": "0.1.0.0", "generated": "...",+{"schema": 2, "oglyad": "0.1.0.0", "generated": "...", "distro": "terra", "releases": [{"release": "43", "label": "f43", "ref": "origin/f43",- "commit": "...", "terra_repo": "https://repos.fyralabs.com/terra43"}],+ "commit": "...", "terra_repo": "https://tetsudou.fyralabs.com/metalink?repo=terra43&arch=x86_64"}], "upstream": true, "summary": {"error": 0, "warn": 0, "info": 0, "ignored": 0}, "findings": [{"check": "...", "package": "...", "path": "...", "severity": "...",@@ -61,13 +90,14 @@ `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`.+findings. `ref` is `null` with `--worktree`. `distro` was added later, and+`terra_repo` keeps its name for whichever distro's repo was checked. | 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 |+| 2 | couldn't run: bad flags, unreadable ignore file, not a monorepo oglyad knows | ## ignoring known findings
app/Main.hs view
@@ -5,11 +5,10 @@ module Main (main) where import Control.Exception (SomeException, try)-import Control.Monad (forM, unless, when)+import Control.Monad (filterM, 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 (UTCTime, getCurrentTime)@@ -38,8 +37,10 @@ exitUsage = ExitFailure 2 data Opts = Opts- { -- | token, cores, run start, spec ref, release- optConfig :: Maybe Text -> Int -> UTCTime -> Maybe Text -> Release -> Config,+ { -- | token, cores, run start, spec ref, distro, release+ optConfig :: Maybe Text -> Int -> UTCTime -> Maybe Text -> Distro -> Release -> Config,+ -- | Nothing means tell from the checkout+ optDistro :: Maybe Distro, optReleases :: [ReleaseArg], optRemote :: Text, optWorktree :: Bool,@@ -56,10 +57,11 @@ optsP :: Parser Opts optsP = do optConfig <- configP+ optDistro <- optional (option (eitherReader lookupDistro) (long "distro" <> short 'd' <> metavar "NAME" <> help ("which monorepo -m is: " <> distroNames <> ". default: whichever one's package directory (anda/, ultramarine/) the checkout has"))) 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")+ optRemote <- strOption (long "remote" <> metavar "NAME" <> value "origin" <> showDefault <> help "git remote whose release branches (f43, frawhide, um43, ...) 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"))+ optRepo <- optional (strOption (long "repo" <> metavar "URL" <> help ("metalink or base url of the repo to check builds against. {repo} becomes the repo's name (terra43, terra43-extras) and {release} the release's (43, rawhide). a url with neither names one release's repo, so it needs exactly one --release. default: " <> T.unpack defaultRepoUrl))) 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")@@ -74,6 +76,7 @@ pure Opts {..} where names = T.unpack (T.intercalate ", " checkNames)+ distroNames = T.unpack (T.intercalate ", " (map distroName distros)) format = \case "text" -> Right Text "json" -> Right Json@@ -86,22 +89,24 @@ "never" -> Right Nothing other -> Left ("unknown level " <> show other <> ", expected error, warn, info or never") -configP :: Parser (Maybe Text -> Int -> UTCTime -> Maybe Text -> Release -> Config)+configP :: Parser (Maybe Text -> Int -> UTCTime -> Maybe Text -> Distro -> Release -> Config) configP = do- cfgMonorepo <- strOption (long "monorepo" <> short 'm' <> metavar "DIR" <> value "." <> showDefault <> help "checkout of terrapkg/packages")+ cfgMonorepo <- strOption (long "monorepo" <> short 'm' <> metavar "DIR" <> value "." <> showDefault <> help "checkout of terrapkg/packages, or Ultramarine-Linux/packages with --distro ultramarine") 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 cfgRunStart cfgSpecRef rel ->+ pure $ \cfgGitHubToken cores cfgRunStart cfgSpecRef distro rel -> Config- { cfgTerraRepo = terraRepoFor rel,+ { cfgRoot = distroRoot distro,+ cfgRepoName = repoName distro rel,+ cfgRepoUrl = repoUrlFor defaultRepoUrl rel, cfgFedoraRepos = (if fedora then fedoraReposFor rel else []) <> extraFedora, cfgRelease = relVersion rel,- cfgDist = releaseDist rel,- cfgBranch = releaseBranch rel,+ cfgDist = releaseDist distro rel,+ cfgBranch = releaseBranch distro rel, cfgStaleAfter = fromIntegral (staleDays * 86400), cfgCacheFor = fromIntegral (cacheHours * 3600), cfgConcurrency = maybe cores id jobs,@@ -151,7 +156,7 @@ let pinfo = info (optsP <**> helper <**> simpleVersioner ("oglyad " <> T.unpack oglyadVersion))- (fullDesc <> progDesc "repository metadata and health checker for Terra")+ (fullDesc <> progDesc "repository metadata and health checker for Terra and other anda monorepos") case execParserPure defaultPrefs pinfo args of Failure f -> case renderFailure f prog of -- --help and --version are output, not errors, so they go to stdout@@ -160,6 +165,22 @@ (msg, _) -> hPutStrLn stderr msg >> exitWith exitUsage other -> handleParseResult other +-- | the distro asked for, or the one whose package directory the checkout+-- has. a checkout with none, or with more than one, has to say+pickDistro :: FilePath -> Maybe Distro -> IO Distro+pickDistro mono asked = do+ found <- filterM (doesDirectoryExist . (mono </>) . distroRoot) distros+ case asked of+ Just d+ | d `elem` found -> pure d+ | otherwise -> usageError (mono <> " doesn't look like a " <> T.unpack (distroName d) <> " checkout (no " <> distroRoot d <> "/ directory). point -m at one")+ Nothing -> case found of+ [d] -> pure d+ [] -> usageError (mono <> " doesn't look like an anda monorepo (no " <> roots <> " directory). point -m at a checkout of terrapkg/packages or another, see --distro")+ _ -> usageError (mono <> " has more than one package directory (" <> T.unpack (T.intercalate ", " (map distroName found)) <> "), so pick one with --distro")+ where+ roots = T.unpack (T.intercalate "/, " (map (T.pack . distroRoot) distros)) <> "/"+ usageError :: String -> IO a usageError msg = hPutStrLn stderr ("oglyad: " <> msg) >> exitWith exitUsage @@ -180,18 +201,17 @@ 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"+ when (maybe False (\url -> not (any (`T.isInfixOf` url) ["{repo}", "{release}"])) optRepo && length optReleases /= 1) $+ usageError "--repo without {repo} or {release} in it names one repo, so it needs exactly one --release" token <- githubToken cores <- getNumProcessors start <- getCurrentTime- let specRef rel = if optWorktree then Nothing else Just (optRemote <> "/" <> releaseBranch rel)+ let mono = cfgMonorepo (optConfig token cores start Nothing terra (Release "rawhide" 0))+ distro <- pickDistro mono optDistro+ let specRef rel = if optWorktree then Nothing else Just (optRemote <> "/" <> releaseBranch distro 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 (mkCfg (Release "rawhide" 0)) <> " doesn't look like a terrapkg/packages checkout (no anda/ directory). point -m at one")+ let c = optConfig token cores start (specRef rel) distro rel+ in maybe c (\url -> c {cfgRepoUrl = repoUrlFor url rel}) optRepo releases <- resolveReleases mkCfg optReleases let ran = if null optOnly then checkNames else optOnly@@ -203,14 +223,14 @@ applied | optNoIgnores = Applied findings [] [] [] | otherwise = applyIgnores checkNames ran ignores (snapIgnoreLabels snap) findings- relInfo = ReleaseInfo (relName rel) (releaseLabel rel) (cfgSpecRef cfg) (snapHead snap) (cfgTerraRepo cfg)+ relInfo = ReleaseInfo (relName rel) (releaseLabel rel) (cfgSpecRef cfg) (snapHead snap) (repoUrl cfg Nothing) 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]+ let merged f = mergeFindings distro [(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 =@@ -218,6 +238,7 @@ { rVersion = oglyadVersion, rGenerated = now, rReleases = [ri | (_, ri, _) <- perRelease],+ rDistro = distroName distro, rUpstream = any (\(rel, _, _) -> cfgUpstream (mkCfg rel)) perRelease, rFindings = merged apKept <> merged apProblems <> unused, rIgnored = merged apIgnored
oglyad.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.0 name: oglyad-version: 0.1.2.0+version: 0.1.3.1 synopsis: repository metadata and health checker for Terra description: oglyad checks a terrapkg/packages checkout against Terra's published
src/Oglyad/Collect.hs view
@@ -44,12 +44,10 @@ 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)+ (dirErrs, dirs) <- partitionEithers <$> liftIO (maybe (pure []) (`findPackageDirs` cfgRoot) root) -- the main repo, every subrepo some package asked for, and Fedora- let terraRepos =- (Nothing, cfgTerraRepo)- : [(Just s, cfgTerraRepo <> "-" <> s) | s <- nub (mapMaybe pdSubrepo dirs)]+ let terraRepos = [(s, repoUrl cfg s) | s <- Nothing : nub (map Just (mapMaybe pdSubrepo dirs))] env <- ask ((specErrs, pkgs0), (terra, fedora)) <- liftIO $@@ -111,7 +109,7 @@ (commits, (macros, cache)) <- liftIO $ concurrently- (commitTimes cfgMonorepo logRef hd cfgDist (map pdPath dirs))+ (commitTimes cfgMonorepo cfgRoot 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)@@ -150,14 +148,14 @@ -- | 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+commitTimes :: FilePath -> FilePath -> Text -> Maybe Text -> Text -> [FilePath] -> IO (Map FilePath UTCTime)+commitTimes mono pkgRoot 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 mono ref dirs+ m <- lastCommits mono pkgRoot ref dirs mapM_ (\h -> saveJson file (h, m)) hd pure m
src/Oglyad/Release.hs view
@@ -1,13 +1,21 @@--- | 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+-- | which Fedora releases to check, and everything that follows from one and+-- the distro being checked: the repo, the %{dist} tag, the monorepo branch+-- and the Fedora repos. also merges findings from several releases into one+-- report module Oglyad.Release- ( Release (..),+ ( Distro (..),+ terra,+ ultramarine,+ distros,+ lookupDistro,+ Release (..), isRawhide, releaseLabel, releaseDist, releaseBranch,- terraRepoFor,+ repoName,+ defaultRepoUrl,+ repoUrlFor, fedoraReposFor, parseReleaseArg, ReleaseArg (..),@@ -30,6 +38,40 @@ import Oglyad.Types (Finding (..)) import Text.Read (readMaybe) +-- | an anda monorepo oglyad knows how to check, and how it spells things per+-- release+data Distro = Distro+ { -- | what --distro takes, e.g. "terra"+ distroName :: Text,+ -- | the directory under the monorepo root holding every package, e.g.+ -- "anda" for terrapkg/packages+ distroRoot :: FilePath,+ -- | the repo's name, with the release name appended: terra for terra43+ distroRepo :: Text,+ -- | release branch prefix, f for f43+ distroBranch :: Text,+ -- | %{dist} prefix, .fc for .fc43+ distroDist :: Text+ }+ deriving stock (Eq, Show)++-- | terrapkg/packages+terra :: Distro+terra = Distro "terra" "anda" "terra" "f" ".fc"++-- | Ultramarine-Linux/packages. builds land in um43, umrawhide, with+-- .um43 and .umrawhide dist tags+ultramarine :: Distro+ultramarine = Distro "ultramarine" "ultramarine" "um" "um" ".um"++distros :: [Distro]+distros = [terra, ultramarine]++lookupDistro :: String -> Either String Distro+lookupDistro raw = case [d | d <- distros, distroName d == T.pack raw] of+ d : _ -> Right d+ [] -> Left ("unknown distro " <> show raw <> ", expected one of: " <> T.unpack (T.intercalate ", " (map distroName distros)))+ -- | a Fedora release Terra builds for. rawhide keeps its number too, since -- %fedora still needs one when evaluating specs data Release = Release@@ -43,23 +85,35 @@ 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"+-- | how releases are spelled in output: f43, rawhide. the same for every+-- distro, since they're all built on Fedora's releases 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+-- workflow rewrites macros.dist to do it, and Ultramarine does the same+releaseDist :: Distro -> Release -> Text+releaseDist d r = distroDist d <> relName r --- | the terrapkg/packages branch for a release: f43, frawhide-releaseBranch :: Release -> Text-releaseBranch r = "f" <> relName r+-- | the monorepo branch for a release: f43, frawhide, um43+releaseBranch :: Distro -> Release -> Text+releaseBranch d r = distroBranch d <> relName r -terraRepoFor :: Release -> Text-terraRepoFor r = "https://repos.fyralabs.com/terra" <> relName r+-- | the distro's repo for a release, e.g. terra43 or umrawhide. subrepos+-- add a suffix: terra43-extras+repoName :: Distro -> Release -> Text+repoName d r = distroRepo d <> relName r +-- | where Fyra Labs' repos are, the same metalink dnf uses. {repo} becomes+-- a 'repoName', with any subrepo suffix+defaultRepoUrl :: Text+defaultRepoUrl = "https://tetsudou.fyralabs.com/metalink?repo={repo}&arch=x86_64"++-- | a repo url template for one release, with {release} filled in and+-- {repo} left for 'Oglyad.Types.repoUrl'+repoUrlFor :: Text -> Release -> Text+repoUrlFor url r = T.replace "{release}" (relName r) url+ -- | Fedora's own repos, for the overlap check. rawhide has no updates repo fedoraReposFor :: Release -> [Text] fedoraReposFor r@@ -118,15 +172,15 @@ -- "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 =+mergeFindings :: Distro -> [(Release, [Finding])] -> [Finding]+mergeFindings distro 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))+ keyOf r f = (fCheck f, fPackage f, fPath f, fSeverity f, T.replace (releaseDist distro 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
src/Oglyad/Report.hs view
@@ -32,6 +32,8 @@ rGenerated :: UTCTime, -- | every release this run checked, in order rReleases :: [ReleaseInfo],+ -- | "terra", "ultramarine"+ rDistro :: Text, rUpstream :: Bool, rFindings :: [Finding], rIgnored :: [Finding]@@ -46,7 +48,7 @@ -- | the git ref the specs came from, Nothing for the working tree riRef :: Maybe Text, riCommit :: Maybe Text,- riTerraRepo :: Text+ riRepo :: Text } render :: Format -> Severity -> Report -> LBS.ByteString@@ -90,13 +92,15 @@ [ "schema" .= (2 :: Int), "oglyad" .= rVersion, "generated" .= rGenerated,+ "distro" .= rDistro, "releases" .= [ object [ "release" .= riName, "label" .= riLabel, "ref" .= riRef, "commit" .= riCommit,- "terra_repo" .= riTerraRepo+ -- named for Terra, but it's whichever distro's repo was checked+ "terra_repo" .= riRepo ] | ReleaseInfo {..} <- rReleases ],@@ -130,7 +134,7 @@ renderMarkdown :: Severity -> Report -> Text renderMarkdown minSev r@Report {..} = T.unlines $- [ "# oglyad report",+ [ "# oglyad report: " <> rDistro, "", T.intercalate " · "
src/Oglyad/Source/Monorepo.hs view
@@ -1,4 +1,4 @@--- | reads a local checkout of terrapkg/packages+-- | reads a local checkout of terrapkg/packages, or another anda monorepo module Oglyad.Source.Monorepo ( PkgDir (..), SpecInfo (..),@@ -70,11 +70,12 @@ deriving stock (Eq, Show, Generic) deriving anyclass (ToJSON, FromJSON) --- | 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-findPackageDirs :: FilePath -> IO [Either (FilePath, Text) PkgDir]-findPackageDirs root = go "anda"+-- | walk the package dir (anda/ in terrapkg/packages) 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+findPackageDirs :: FilePath -> FilePath -> IO [Either (FilePath, Text) PkgDir]+findPackageDirs root pkgRoot = go pkgRoot where go rel = do let abs' = root </> rel@@ -197,11 +198,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 -> Text -> [FilePath] -> IO (Map FilePath UTCTime)-lastCommits root ref dirs = do+lastCommits :: FilePath -> FilePath -> Text -> [FilePath] -> IO (Map FilePath UTCTime)+lastCommits root pkgRoot ref dirs = do out <- run "git" $- ["-C", root, "-c", "core.quotePath=false", "log", "--format=@%ct", "--name-only", "--no-renames", T.unpack ref, "--", "anda"]+ ["-C", root, "-c", "core.quotePath=false", "log", "--format=@%ct", "--name-only", "--no-renames", T.unpack ref, "--", pkgRoot] -- 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
src/Oglyad/Source/Repodata.hs view
@@ -1,8 +1,10 @@--- | reads published dnf repodata: repomd.xml → primary.xml.{zst,gz,xz} → packages+-- | reads published dnf repodata: metalink → repomd.xml →+-- primary.xml.{zst,gz,xz} → packages module Oglyad.Source.Repodata ( RpmEntry (..), fetchRepo, decompressAndParse,+ parseMetalink, parseRepomd, parsePrimary, srpmName,@@ -15,14 +17,19 @@ import Control.Exception (SomeException, try) import Control.Monad ((<$!>), (>=>)) import Control.Monad.Reader (liftIO)+import Crypto.Hash.SHA256 qualified as SHA256 import Data.Bifunctor (first)+import Data.ByteString.Base16 qualified as B16 import Data.ByteString.Lazy qualified as LBS import Data.Char (isAlphaNum)+import Data.List (sortOn) import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map import Data.Maybe (mapMaybe)+import Data.Ord (Down (..)) 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.Clock.POSIX (posixSecondsToUTCTime)@@ -37,7 +44,7 @@ import System.IO (Handle) import System.Process.Typed (byteStringInput, createPipe, getStdout, nullStream, proc, setEnv, setStderr, setStdin, setStdout, waitExitCode, withProcessTerm) import Text.XML (Name (..), def, parseLBS)-import Text.XML.Cursor (attribute, attributeIs, element, fromDocument, ($//), (&/))+import Text.XML.Cursor (attribute, attributeIs, content, element, fromDocument, ($/), ($//), (&/)) import Text.XML.Stream.Parse (parseBytes) -- | one binary (or source) rpm from primary.xml@@ -53,16 +60,17 @@ } deriving stock (Eq, Show) --- | builds per source package for a repo, reusing the last parse when the--- repo hasn't changed. repomd.xml is tiny, and the primary.xml href in it--- embeds a checksum, so an unchanged href means unchanged contents+-- | builds per source package for a repo, given its metalink or base url,+-- reusing the last parse when the repo hasn't changed. repomd.xml is tiny,+-- and the primary.xml href in it embeds a checksum, so an unchanged href+-- means unchanged contents fetchRepo :: Text -> App (Either String (Map Text RepoBuild))-fetchRepo base = do- let file = "repodata-" <> T.unpack (T.map (\c -> if isAlphaNum c then c else '_') base) <> ".json"- repomd <- httpGetE (base <> "/repodata/repomd.xml")- case first httpErr repomd >>= parseRepomd of+fetchRepo url = do+ located <- fetchRepomd url+ case located >>= \(base, repomd) -> (base,) <$> parseRepomd repomd of Left err -> pure (Left err)- Right href ->+ Right (base, href) -> do+ let file = "repodata-" <> T.unpack (T.map (\c -> if isAlphaNum c then c else '_') base) <> ".json" liftIO (loadJson file) >>= \case Just (cachedHref, builds) | cachedHref == href -> pure (Right builds) _ -> do@@ -73,6 +81,48 @@ Left _ -> pure () pure r +-- | a repo's repomd.xml, and the base url it came from. a url with+-- "metalink" in it is read like dnf reads one: try its mirrors by+-- preference, and take the first repomd.xml whose sha256 the metalink+-- lists, so a mirror that hasn't synced yet is skipped+fetchRepomd :: Text -> App (Either String (Text, LBS.ByteString))+fetchRepomd url+ | "metalink" `T.isInfixOf` url =+ httpGetE url >>= \r -> case first httpErr r >>= parseMetalink of+ Left err -> pure (Left ("can't read metalink " <> T.unpack url <> ": " <> err))+ Right (_, []) -> pure (Left ("metalink " <> T.unpack url <> " lists no mirrors"))+ Right (hashes, mirrors) -> tryMirrors hashes ("no mirror in " <> T.unpack url) mirrors+ | otherwise = fmap (url,) . first httpErr <$> httpGetE (url <> "/repodata/repomd.xml")+ where+ tryMirrors _ lastErr [] = pure (Left lastErr)+ tryMirrors hashes _ (m : rest) = case T.stripSuffix "/repodata/repomd.xml" m of+ Nothing -> tryMirrors hashes ("metalink mirror " <> T.unpack m <> " isn't a repomd.xml") rest+ Just base ->+ httpGetE m >>= \case+ Left e -> tryMirrors hashes (httpErr e) rest+ Right body+ | null hashes || sha256 body `elem` hashes -> pure (Right (base, body))+ | otherwise -> tryMirrors hashes (T.unpack m <> " doesn't match the metalink's checksum, is the mirror behind?") rest+ sha256 = TE.decodeUtf8 . B16.encode . SHA256.hashlazy++-- | the sha256 hashes a metalink accepts for repomd.xml (the current one and+-- any alternates, which are recent ones mirrors may still serve), and its+-- mirrors' repomd.xml urls, most preferred first+parseMetalink :: LBS.ByteString -> Either String ([Text], [Text])+parseMetalink bs = do+ doc <- first show (parseLBS def bs)+ let cur = fromDocument doc+ hashes = cur $// (element (metalinkNs "hash") >=> attributeIs "type" "sha256") &/ content+ urls =+ [ (pref, T.strip u)+ | el <- cur $// element (metalinkNs "url"),+ let pref = case attribute "preference" el of+ p : _ | Right (n, "") <- TR.decimal p -> n+ _ -> 0 :: Int,+ u <- [T.concat (el $/ content)]+ ]+ Right (map T.strip hashes, map snd (sortOn (Down . fst) urls))+ -- | fetch and parse the primary.xml at a href from repomd.xml fetchPrimaryAt :: Text -> Text -> App (Either String [RpmEntry]) fetchPrimaryAt base href = do@@ -115,10 +165,11 @@ (ExitSuccess, _) -> parsed pure (either (\e -> Left (cmd <> ": " <> show (e :: SomeException))) id r) -repoNs, commonNs, rpmNs :: Text -> Name+repoNs, commonNs, rpmNs, metalinkNs :: Text -> Name repoNs n = Name n (Just "http://linux.duke.edu/metadata/repo") Nothing commonNs n = Name n (Just "http://linux.duke.edu/metadata/common") Nothing rpmNs n = Name n (Just "http://linux.duke.edu/metadata/rpm") Nothing+metalinkNs n = Name n (Just "http://www.metalinker.org/") Nothing -- | find the location of primary.xml in repomd.xml. -- this uses the xml-conduit Cursor api, which builds the whole document in
src/Oglyad/Types.hs view
@@ -9,6 +9,7 @@ finding, Snapshot (..), Config (..),+ repoUrl, Check, ) where@@ -151,21 +152,27 @@ } data Config = Config- { -- | local checkout of terrapkg/packages+ { -- | local checkout of terrapkg/packages, or another anda monorepo cfgMonorepo :: FilePath,+ -- | the directory in it holding every package, e.g. anda+ cfgRoot :: 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+ -- | the monorepo branch name, f43 or frawhide. update.rhai -- scripts see it as labels.branch cfgBranch :: Text,- -- | e.g. https://repos.fyralabs.com/terra44- cfgTerraRepo :: Text,+ -- | the main repo's name, e.g. terra44+ cfgRepoName :: Text,+ -- | where it is: a metalink or a base url, with {repo} where the repo+ -- name goes. without {repo} it's the main repo's url, and subrepos add+ -- -extras to the end of it+ cfgRepoUrl :: Text, -- | repo base urls to check for overlap cfgFedoraRepos :: [Text], -- | Fedora/Terra release number, e.g. 44. rawhide has one too cfgRelease :: Int,- -- | %{dist} used when evaluating specs, e.g. .fc44 or .fcrawhide+ -- | %{dist} used when evaluating specs, e.g. .fc44, .fcrawhide or .um44 cfgDist :: Text, cfgStaleAfter :: NominalDiffTime, -- | whether to hit upstream APIs at all@@ -181,6 +188,14 @@ cfgGitHubToken :: Maybe Text } deriving stock (Show)++-- | the url of the main repo, or of a subrepo like extras+repoUrl :: Config -> Maybe Text -> Text+repoUrl Config {..} sub+ | "{repo}" `T.isInfixOf` cfgRepoUrl = T.replace "{repo}" (cfgRepoName <> suffix) cfgRepoUrl+ | otherwise = cfgRepoUrl <> suffix+ where+ suffix = maybe "" ("-" <>) sub -- | everything a check is allowed to look at, already collected. -- checks never do IO, which is what keeps them trivially testable
test/Spec.hs view
@@ -25,7 +25,7 @@ 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.Repodata (RpmEntry (..), decompressAndParse, fetchRepo, latestBySource, parseMetalink, parsePrimary, srpmName) import Oglyad.Source.Rhai (parseUpdateRhai, parseUpdateRhaiWith) import Oglyad.Source.RhaiEval (Simulated (..), simulateVersion) import Oglyad.Source.Upstream (isSemver)@@ -435,7 +435,7 @@ createDirectoryIfMissing True (root </> "anda/a") writeFile (root </> "anda/a/anda.hcl") "project pkg {}" createDirectoryLink ".." (root </> "anda/a/loop")- dirs <- findPackageDirs root+ dirs <- findPackageDirs root "anda" map (fmap pdPath) dirs `shouldBe` [Right "anda/a"] _ <- specFingerprint "m" ".fc44" root "anda/a" pure ()@@ -449,7 +449,7 @@ pkgDir "n" "nightly" pkgDir "q" "quaterdaily" pkgDir "w" "weekly"- dirs <- findPackageDirs root+ dirs <- findPackageDirs root "anda" [(pdPath d, pdNightly d) | Right d <- dirs] `shouldBe` [("anda/n", True), ("anda/q", True), ("anda/w", False)] describe "parseCheckName" $ do@@ -465,7 +465,15 @@ -- port 9 (discard) on loopback: refused immediately, no network needed r <- runApp (snapConfig snapshot) (fetchRepo "http://127.0.0.1:9/repo") r `shouldSatisfy` either (const True) (const False)+ it "turns an unreachable metalink into a Left too" $ do+ r <- runApp (snapConfig snapshot) (fetchRepo "http://127.0.0.1:9/metalink?repo=terra44")+ r `shouldSatisfy` either (const True) (const False) + describe "metalinks"+ $ it "reads checksums, alternates included, and mirrors by preference"+ $ parseMetalink metalinkFixture+ `shouldBe` Right (["aaa", "bbb"], ["https://fast.example/terra44/repodata/repomd.xml", "https://repos.fyralabs.com/terra44/repodata/repomd.xml"])+ describe "macroFingerprint" $ it "changes when ~/.rpmmacros changes" $ withSystemTempDirectory "oglyad-home" $ \home ->@@ -481,9 +489,19 @@ `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")+ (releaseDist terra raw, releaseBranch terra raw, repoName terra raw, releaseLabel raw) `shouldBe` (".fcrawhide", "frawhide", "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 "spells releases the way Ultramarine does" $ do+ let r44 = Release "44" 44+ (releaseDist ultramarine r44, releaseBranch ultramarine r44, repoName ultramarine r44) `shouldBe` (".um44", "um44", "um44")+ lookupDistro "ultramarine" `shouldBe` Right ultramarine+ lookupDistro "umbrella" `shouldSatisfy` either (const True) (const False)+ it "fills in repo url templates, subrepos included" $ do+ let cfg url = (snapConfig snapshot) {cfgRepoName = "terra44", cfgRepoUrl = repoUrlFor url (Release "44" 44)}+ repoUrl (cfg defaultRepoUrl) (Just "extras") `shouldBe` "https://tetsudou.fyralabs.com/metalink?repo=terra44-extras&arch=x86_64"+ repoUrl (cfg "https://example.com/um{release}/x86_64") Nothing `shouldBe` "https://example.com/um44/x86_64"+ repoUrl (cfg "https://example.com/terra44") (Just "extras") `shouldBe` "https://example.com/terra44-extras" 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" $@@ -495,13 +513,16 @@ 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"])]+ mergeFindings terra [(r43, [lag ".fc43"]), (r44, [lag ".fc44"])] `shouldBe` [(lag "%{dist}") {fReleases = ["43", "44"]}]+ it "merges by the distro's own dist" $+ mergeFindings ultramarine [(r43, [lag ".um43"]), (r44, [lag ".um44"])]+ `shouldBe` [(lag "%{dist}") {fReleases = ["43", "44"]}] it "keeps the real message for a single release" $- mergeFindings [(r43, [drift]), (r44, [lag ".fc44"])]+ mergeFindings terra [(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"]]+ map fReleases (mergeFindings terra [(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"]]@@ -557,7 +578,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 "HEAD" ["anda/a", "anda/b"]+ m <- lastCommits repo "anda" "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)) @@ -628,9 +649,11 @@ snapConfig = Config { cfgMonorepo = ".",+ cfgRoot = "anda", cfgSpecRef = Nothing, cfgBranch = "f44",- cfgTerraRepo = "",+ cfgRepoName = "terra44",+ cfgRepoUrl = defaultRepoUrl, cfgFedoraRepos = [], cfgRelease = 44, cfgDist = ".fc44",@@ -645,6 +668,17 @@ snapIgnoreLabels = Map.empty } +-- | trimmed from tetsudou's answer for terra44, with a second mirror+metalinkFixture :: LBS8.ByteString+metalinkFixture =+ "<?xml version=\"1.0\" encoding=\"utf-8\"?><metalink version=\"3.0\" xmlns=\"http://www.metalinker.org/\" xmlns:mm0=\"http://fedorahosted.org/mirrormanager\" type=\"dynamic\" generator=\"tetsudou\"><files><file name=\"repomd.xml\">\+ \<verification><hash type=\"md5\">x</hash><hash type=\"sha256\">aaa</hash></verification>\+ \<mm0:alternates><mm0:alternate><verification><hash type=\"sha256\">bbb</hash></verification></mm0:alternate></mm0:alternates>\+ \<resources maxconnections=\"1\">\+ \<url type=\"https\" protocol=\"https\" location=\"DE\" preference=\"100\">https://repos.fyralabs.com/terra44/repodata/repomd.xml</url>\+ \<url type=\"https\" protocol=\"https\" location=\"US\" preference=\"200\">https://fast.example/terra44/repodata/repomd.xml</url>\+ \</resources></file></files></metalink>"+ bodhiFixture :: LBS8.ByteString bodhiFixture = "{\"releases\": [\@@ -662,6 +696,7 @@ { rVersion = "0", rGenerated = now, rReleases = [ReleaseInfo "44" "f44" (Just "origin/f44") (Just "abc") "https://repos.fyralabs.com/terra44"],+ rDistro = "terra", rUpstream = False, rFindings = fs, rIgnored = []