From 912c7bd20dc0e2a14430ca00037ee81b59608b7b Mon Sep 17 00:00:00 2001 From: Malte Brandy Date: Tue, 4 May 2021 18:16:00 +0200 Subject: [PATCH] maintainers/scripts/haskell/hydra-report.hs: init --- maintainers/scripts/haskell/hydra-report.hs | 306 ++++++++++++++++++++ 1 file changed, 306 insertions(+) create mode 100755 maintainers/scripts/haskell/hydra-report.hs diff --git a/maintainers/scripts/haskell/hydra-report.hs b/maintainers/scripts/haskell/hydra-report.hs new file mode 100755 index 000000000000..20b856c42e37 --- /dev/null +++ b/maintainers/scripts/haskell/hydra-report.hs @@ -0,0 +1,306 @@ +#! /usr/bin/env nix-shell +#! nix-shell -p "haskellPackages.ghcWithPackages (p: [p.aeson p.req])" +#! nix-shell -p hydra-unstable +#! nix-shell -i runhaskell + +{- + +The purpose of this script is + +1) download the state of the nixpkgs/haskell-updates job from hydra (with get-report) +2) print a summary of the state suitable for pasting into a github comment (with ping-maintainers) +3) print a list of broken packages suitable for pasting into configuration-hackage2nix.yaml + +Because step 1) is very expensive and takes roughly ~30 minutes the result is cached in a json file in XDG_CACHE. + +-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} + +import Control.Monad (forM, forM_, (<=<)) +import Control.Monad.Trans (MonadIO (liftIO)) +import Data.Aeson ( + FromJSON, + ToJSON, + decodeFileStrict', + eitherDecodeStrict', + encodeFile, + ) +import qualified Data.ByteString.Char8 as ByteString +import Data.Either (fromRight) +import Data.Foldable (Foldable (toList), fold, foldl') +import Data.Function ((&)) +import Data.Functor ((<&>)) +import Data.List.NonEmpty (NonEmpty, nonEmpty) +import qualified Data.List.NonEmpty as NonEmpty +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Maybe (fromMaybe, mapMaybe) +import Data.Monoid (Sum (Sum, getSum)) +import Data.Semigroup (Min (Min, getMin)) +import Data.Sequence (Seq) +import qualified Data.Sequence as Seq +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Text (Text) +import qualified Data.Text as Text +import Data.Text.Encoding (encodeUtf8) +import Data.Time (defaultTimeLocale, formatTime, getCurrentTime) +import Data.Time.Clock (UTCTime) +import GHC.Generics (Generic) +import Network.HTTP.Req ( + GET (GET), + NoReqBody (NoReqBody), + defaultHttpConfig, + https, + jsonResponse, + req, + responseBody, + runReq, + (/:), + ) +import System.Directory (XdgDirectory (XdgCache), getXdgDirectory) +import System.Environment (getArgs) +import System.Process (readProcess) + +newtype JobsetEvals = JobsetEvals + { evals :: Seq Eval + } + deriving (Generic, ToJSON, FromJSON, Show) + +newtype Nixpkgs = Nixpkgs {revision :: Text} + deriving (Generic, ToJSON, FromJSON, Show) + +newtype JobsetEvalInputs = JobsetEvalInputs {nixpkgs :: Nixpkgs} + deriving (Generic, ToJSON, FromJSON, Show) + +data Eval = Eval + { builds :: Seq Int + , id :: Int + , jobsetevalinputs :: JobsetEvalInputs + } + deriving (Generic, ToJSON, FromJSON, Show) + +data Build = Build + { job :: Text + , buildstatus :: Int + , finished :: Int + , id :: Int + , nixname :: Text + , system :: Text + , jobsetevals :: Seq Int + } + deriving (Generic, ToJSON, FromJSON, Show) + +main :: IO () +main = do + args <- getArgs + case args of + ["get-report"] -> getBuildReports + ["ping-maintainers"] -> printMaintainerPing + ["mark-broken-list"] -> printMarkBrokenList + _ -> putStrLn "Usage: get-report | ping-maintainers | mark-broken-list" + +reportFileName :: IO FilePath +reportFileName = getXdgDirectory XdgCache "haskell-updates-build-report.json" + +showT :: Show a => a -> Text +showT = Text.pack . show + +getBuildReports :: IO () +getBuildReports = runReq defaultHttpConfig $ do + -- GET request http response + now <- liftIO getCurrentTime + r <- req GET (https "hydra.nixos.org" /: "jobset" /: "nixpkgs" /: "haskell-updates" /: "evals") NoReqBody jsonResponse mempty + let eval = Seq.lookup 0 . evals $ (responseBody r :: JobsetEvals) + eval & maybe (liftIO $ putStrLn "No Evalution found") \eval -> do + (buildReports :: Seq Build) <- forM (builds eval) \buildId -> + responseBody <$> req GET (https "hydra.nixos.org" /: "build" /: showT buildId) NoReqBody jsonResponse mempty + fileName <- liftIO reportFileName + liftIO $ encodeFile fileName (eval, now, buildReports) + +hydraEvalCommand = "hydra-eval-jobs" +hydraEvalParams = ["-I", ".", "pkgs/top-level/release-haskell.nix"] +handlesCommand = "nix-instantiate" +handlesParams = ["--eval", "--strict", "--json", "-"] +handlesExpression = "with import ./. {}; with lib; zipAttrsWith (_: builtins.head) (mapAttrsToList (_: v: if v ? github then { \"${v.email}\" = v.github; } else {}) (import maintainers/maintainer-list.nix))" + +newtype Maintainers = Maintainers {maintainers :: Text} deriving (Generic, ToJSON, FromJSON) + +type HydraJobs = Map Text Maintainers +type MaintainerMap = Map Text (NonEmpty Text) + +getMaintainerMap :: IO MaintainerMap +getMaintainerMap = do + hydraJobs :: HydraJobs <- get hydraEvalCommand hydraEvalParams "" "Failed to decode hydra-eval-jobs output: " + handlesMap :: Map Text Text <- get handlesCommand handlesParams handlesExpression "Failed to decode nix output for lookup of github handles: " + pure $ hydraJobs & Map.mapMaybe (nonEmpty . mapMaybe (`Map.lookup` handlesMap) . Text.splitOn ", " . maintainers) + where + get c p i e = readProcess c p i <&> \x -> either (error . (<> "Raw:'" <> x <> "'") . (e <>)) Prelude.id . eitherDecodeStrict' . encodeUtf8 . Text.pack $ x + +-- BuildStates are sorted by subjective importance/concerningness +data BuildState = Failed | DependencyFailed | OutputLimitExceeded | Unknown Int | Aborted | Unfinished | Success deriving (Show, Eq, Ord) + +icon :: BuildState -> Text +icon = \case + Failed -> ":x:" + DependencyFailed -> ":heavy_exclamation_mark:" + OutputLimitExceeded -> ":warning:" + Unknown x -> "unknown code " <> showT x + Aborted -> ":no_entry:" + Unfinished -> ":hourglas_flowing_sand:" + Success -> ":heavy_check_mark:" + +platformIcon :: Platform -> Text +platformIcon (Platform x) = case x of + "x86_64-linux" -> ":penguin:" + "aarch64-linux" -> ":iphone:" + "x86_64-darwin" -> ":apple:" + _ -> x + +data BuildResult = BuildResult {state :: BuildState, id :: Int} deriving (Show, Eq, Ord) +newtype Platform = Platform {platform :: Text} deriving (Show, Eq, Ord) +newtype Table row col a = Table (Map (row, col) a) +type StatusSummary = Map Text (Table Text Platform BuildResult, Set Text) + +instance (Ord row, Ord col, Semigroup a) => Semigroup (Table row col a) where + Table l <> Table r = Table (Map.unionWith (<>) l r) +instance (Ord row, Ord col, Semigroup a) => Monoid (Table row col a) where + mempty = Table Map.empty +instance Functor (Table row col) where + fmap f (Table a) = Table (fmap f a) +instance Foldable (Table row col) where + foldMap f (Table a) = foldMap f a + +buildSummary :: MaintainerMap -> Seq Build -> StatusSummary +buildSummary maintainerMap = foldl (Map.unionWith unionSummary) Map.empty . fmap toSummary + where + unionSummary (Table l, l') (Table r, r') = (Table $ Map.union l r, l' <> r') + toSummary Build{finished, buildstatus, job, id, system, nixname} = Map.singleton name (Table (Map.singleton (set, Platform system) (BuildResult state id)), maintainers) + where + state = case (finished, buildstatus) of + (0, _) -> Unfinished + (_, 0) -> Success + (_, 7) -> Aborted + (_, 2) -> DependencyFailed + (_, 1) -> Failed + (_, 11) -> OutputLimitExceeded + (_, i) -> Unknown i + packageName = fromMaybe job (Text.stripSuffix ("." <> system) job) + splitted = nonEmpty $ Text.splitOn "." packageName + name = maybe packageName NonEmpty.last splitted + set = maybe "" (Text.intercalate "." . NonEmpty.init) splitted + maintainers = maybe mempty (Set.fromList . toList) (Map.lookup job maintainerMap) + +readBuildReports :: IO (Eval, UTCTime, Seq Build) +readBuildReports = do + file <- reportFileName + fromMaybe (error $ "Could not decode " <> file) <$> decodeFileStrict' file + +sep :: Text +sep = " | " +joinTable :: [Text] -> Text +joinTable t = sep <> Text.intercalate sep t <> sep + +type NumSummary = Table Platform BuildState Int + +printTable :: (Ord rows, Ord cols) => Text -> (rows -> Text) -> (cols -> Text) -> (entries -> Text) -> Table rows cols entries -> [Text] +printTable name showR showC showE (Table mapping) = joinTable <$> (name : map showC cols) : replicate (length cols + sepsInName + 1) "---" : map printRow rows + where + sepsInName = Text.count "|" name + printRow row = showR row : map (\col -> maybe "" showE (Map.lookup (row, col) mapping)) cols + rows = toList $ Set.fromList (fst <$> Map.keys mapping) + cols = toList $ Set.fromList (snd <$> Map.keys mapping) + +printJob :: Text -> (Table Text Platform BuildResult, Text) -> [Text] +printJob name (Table mapping, maintainers) = + if length sets <= 1 + then map printSingleRow sets + else ["- [ ] " <> name <> " " <> maintainers] <> map printRow sets + where + printRow set = " - " <> printState set <> " " <> (if Text.null set then "toplevel" else set) + printSingleRow set = "- [ ] " <> printState set <> " " <> (if Text.null set then "" else set <> ".") <> name <> " " <> maintainers + printState set = Text.intercalate " " $ map (\pf -> maybe "" (label pf) $ Map.lookup (set, pf) mapping) platforms + sets = toList $ Set.fromList (fst <$> Map.keys mapping) + platforms = toList $ Set.fromList (snd <$> Map.keys mapping) + label pf (BuildResult s i) = "[[" <> platformIcon pf <> icon s <> "]](https://hydra.nixos.org/build/" <> showT i <> ")" + +statusToNumSummary :: StatusSummary -> NumSummary +statusToNumSummary = fmap getSum . foldMap (fmap Sum . jobTotals) + +jobTotals :: (Table Text Platform BuildResult, a) -> Table Platform BuildState Int +jobTotals (Table mapping, _) = getSum <$> Table (Map.foldMapWithKey (\(set, platform) (BuildResult buildstate _) -> Map.singleton (platform, buildstate) (Sum 1)) mapping) + +details :: Text -> [Text] -> [Text] +details summary content = ["
" <> summary <> " ", ""] <> content <> ["
", ""] + +printBuildSummary :: Eval -> UTCTime -> StatusSummary -> Text +printBuildSummary + Eval{id, jobsetevalinputs = JobsetEvalInputs{nixpkgs = Nixpkgs{revision}}} + fetchTime + summary = + Text.unlines $ + header <> totals + <> optionalList "#### Maintained packages with build failure" (maintainedList fails) + <> optionalList "#### Maintained packages with failed dependency" (maintainedList failedDeps) + <> optionalList "#### Maintained packages with unknown error" (maintainedList unknownErr) + <> optionalHideableList "#### Unmaintained packages with build failure" (unmaintainedList fails) + <> optionalHideableList "#### Unmaintained packages with failed dependency" (unmaintainedList failedDeps) + <> optionalHideableList "#### Unmaintained packages with unknown error" (unmaintainedList unknownErr) + <> footer + where + footer = ["*Report generated with [maintainers/scripts/haskell/hydra-report.hs](https://github.com/NixOS/nixpkgs/blob/haskell-updates/maintainers/scripts/haskell/hydra-report.sh)*"] + totals = + [ "#### Build summary" + , "" + ] + <> printTable "Platform" (\x -> platform x <> " " <> platformIcon x) (\x -> showT x <> " " <> icon x) showT (statusToNumSummary summary) + header = + [ "### [haskell-updates build report from hydra](https://hydra.nixos.org/jobset/nixpkgs/haskell-updates)" + , "*" + <> "evaluation [" + <> showT id + <> "](https://hydra.nixos.org/eval/" + <> showT id + <> ") of nixpkgs commit [" + <> Text.take 7 revision + <> "](https://github.com/NixOS/nixpkgs/commits/" + <> revision + <> ") as of " + <> Text.pack (formatTime defaultTimeLocale "%Y-%m-%d %H:%M UTC" fetchTime) + <> "*" + ] + jobsByState pred = Map.filter (pred . foldl' min Success . fmap state . fst) summary + fails = jobsByState (== Failed) + failedDeps = jobsByState (== DependencyFailed) + unknownErr = jobsByState (\x -> x > DependencyFailed && x < Aborted) + withMaintainer = Map.mapMaybe (\(x, m) -> (x,) <$> nonEmpty (Set.toList m)) + withoutMaintainer = Map.mapMaybe (\(x, m) -> if Set.null m then Just x else Nothing) + optionalList header list = if null list then mempty else [header] <> list + optionalHideableList header list = if null list then mempty else [header] <> details (showT (length list) <> " job(s)") list + maintainedList = showMaintainedBuild <=< Map.toList . withMaintainer + unmaintainedList = showBuild <=< Map.toList . withoutMaintainer + showBuild (name, table) = printJob name (table, "") + showMaintainedBuild (name, (table, maintainers)) = printJob name (table, Text.intercalate " " (fmap ("@" <>) (toList maintainers))) + +printMaintainerPing :: IO () +printMaintainerPing = do + maintainerMap <- getMaintainerMap + (eval, fetchTime, buildReport) <- readBuildReports + putStrLn (Text.unpack (printBuildSummary eval fetchTime (buildSummary maintainerMap buildReport))) + +printMarkBrokenList :: IO () +printMarkBrokenList = do + (_, _, buildReport) <- readBuildReports + forM_ buildReport \Build{buildstatus, job} -> + case (buildstatus, Text.splitOn "." job) of + (1, ["haskellPackages", name, "x86_64-linux"]) -> putStrLn $ " - " <> Text.unpack name + _ -> pure ()