oglyad-0.1.3.1: app/Main.hs

{-# LANGUAGE ApplicativeDo #-}

-- ApplicativeDo lets configP use do-notation even though optparse's Parser
-- is only an Applicative, not a Monad
module Main (main) where

import Control.Exception (SomeException, try)
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.Text (Text)
import Data.Text qualified as T
import Data.Time (UTCTime, getCurrentTime)
import GHC.Conc (getNumProcessors)
import GHC.IO.Encoding (setFileSystemEncoding, setForeignEncoding, setLocaleEncoding, utf8)
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.Release
import Oglyad.Report (Format (..), ReleaseInfo (..), Report (..), render)
import Oglyad.Source.Monorepo (pruneTrees)
import Oglyad.Types
import Options.Applicative
import System.Directory (doesDirectoryExist)
import System.Environment (getArgs, getProgName, lookupEnv)
import System.Exit (ExitCode (..), exitWith)
import System.FilePath ((</>))
import System.IO (hPutStrLn, hSetEncoding, stderr, stdout)

-- | exit codes, so cron jobs and CI can tell "found problems" apart from
-- "couldn't run"
exitFindings, exitUsage :: ExitCode
exitFindings = ExitFailure 1
exitUsage = ExitFailure 2

data Opts = Opts
  { -- | 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,
    optRepo :: Maybe Text,
    optOnly :: [Text],
    optFormat :: Format,
    optMinSev :: Severity,
    -- | Nothing means never fail on findings
    optFailOn :: Maybe Severity,
    optIgnoreFile :: Maybe FilePath,
    optNoIgnores :: Bool
  }

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, 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 ("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")
      <|> flag' Json (long "json" <> help "same as --format json")
      <|> pure Text
  optMinSev <-
    flag' Info (long "verbose" <> short 'v' <> help "show info findings too")
      <|> pure Warn
  optFailOn <- option (eitherReader failOn) (long "fail-on" <> metavar "LEVEL" <> value (Just Error) <> help "exit 1 if any finding is at least this severe: error (default), warn, info, or never")
  optIgnoreFile <- optional (strOption (long "ignore-file" <> metavar "FILE" <> help "json file of known findings to ignore, see README"))
  optNoIgnores <- switch (long "no-ignores" <> help "report everything, ignoring the ignore file and anda.hcl oglyad_ignore labels")
  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
      "markdown" -> Right Markdown
      other -> Left ("unknown format " <> show other <> ", expected text, json or markdown")
    failOn = \case
      "error" -> Right (Just Error)
      "warn" -> Right (Just Warn)
      "info" -> Right (Just Info)
      "never" -> Right Nothing
      other -> Left ("unknown level " <> show other <> ", expected error, warn, info or never")

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, 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 distro rel ->
    Config
      { cfgRoot = distroRoot distro,
        cfgRepoName = repoName distro rel,
        cfgRepoUrl = repoUrlFor defaultRepoUrl rel,
        cfgFedoraRepos = (if fedora then fedoraReposFor rel else []) <> extraFedora,
        cfgRelease = relVersion rel,
        cfgDist = releaseDist distro rel,
        cfgBranch = releaseBranch distro rel,
        cfgStaleAfter = fromIntegral (staleDays * 86400),
        cfgCacheFor = fromIntegral (cacheHours * 3600),
        cfgConcurrency = maybe cores id jobs,
        ..
      }

-- | 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
    Just t | not (null t) -> pure (Just (T.pack t))
    _ -> either (const Nothing) (nonEmpty . T.strip) <$> run "gh" ["auth", "token"]
  where
    nonEmpty t = if T.null t then Nothing else Just t

-- | like execParser, but bad arguments exit with 'exitUsage' instead of 1
parseOpts :: IO Opts
parseOpts = do
  args <- getArgs
  prog <- getProgName
  let pinfo =
        info
          (optsP <**> helper <**> simpleVersioner ("oglyad " <> T.unpack oglyadVersion))
          (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
      -- (help2man and friends read them from there)
      (msg, ExitSuccess) -> putStrLn msg >> exitWith ExitSuccess
      (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

main :: IO ()
main = do
  -- cron and CI often run under LANG=C. specs, anda.hcl and rpmspec errors
  -- contain non-ascii text, which would crash text IO in a C locale
  mapM_ ($ utf8) [setLocaleEncoding, setFileSystemEncoding, setForeignEncoding]
  mapM_ (`hSetEncoding` utf8) [stdout, stderr]

  Opts {..} <- parseOpts
  ignores <- case optIgnoreFile of
    Nothing -> pure (IgnoreFile [])
    Just path -> do
      raw <- try (BS.readFile path)
      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 (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 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) 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
  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) (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 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 =
        Report
          { 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
          }
  LBS.putStr (render optFormat optMinSev report)
  when (maybe False (\level -> any ((>= level) . fSeverity) (rFindings report)) optFailOn) $
    exitWith exitFindings