diff options
author | maralorn <malte.brandy@maralorn.de> | 2021-05-11 02:31:06 +0200 |
---|---|---|
committer | GitHub <noreply@github.com> | 2021-05-11 02:31:06 +0200 |
commit | 881d2af5ee33ade5635e39fb3ad37bd2175ab58a (patch) | |
tree | a8a82fdeda012f0a8d9fb9e7cd7ade5f21135222 /maintainers | |
parent | f19193cd8ac6a76bb1469307d2bca291a36e0c69 (diff) | |
parent | 2a11ad94c62ba6c6ab29e0a7398ea7a0b4093d6b (diff) |
Merge pull request #122286 from NixOS/haskell-updates
Diffstat (limited to 'maintainers')
4 files changed, 379 insertions, 6 deletions
diff --git a/maintainers/scripts/haskell/hydra-report.hs b/maintainers/scripts/haskell/hydra-report.hs new file mode 100755 index 0000000000000..471447e60d578 --- /dev/null +++ b/maintainers/scripts/haskell/hydra-report.hs @@ -0,0 +1,321 @@ +#! /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 quite expensive and takes roughly ~5 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 #-} +{-# OPTIONS_GHC -Wall #-} + +import Control.Monad (forM_, (<=<)) +import Control.Monad.Trans (MonadIO (liftIO)) +import Data.Aeson ( + FromJSON, + ToJSON, + decodeFileStrict', + eitherDecodeStrict', + encodeFile, + ) +import Data.Foldable (Foldable (toList), 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.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, + header, + https, + jsonResponse, + req, + responseBody, + responseTimeout, + runReq, + (/:), + ) +import System.Directory (XdgDirectory (XdgCache), getXdgDirectory) +import System.Environment (getArgs) +import System.Process (readProcess) +import Prelude hiding (id) +import qualified Prelude + +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 + { id :: Int + , jobsetevalinputs :: JobsetEvalInputs + } + deriving (Generic, ToJSON, FromJSON, Show) + +data Build = Build + { job :: Text + , buildstatus :: Maybe 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 + evalMay <- Seq.lookup 0 . evals <$> myReq (https "hydra.nixos.org" /: "jobset" /: "nixpkgs" /: "haskell-updates" /: "evals") mempty + eval@Eval{id} <- maybe (liftIO $ fail "No Evalution found") pure evalMay + liftIO . putStrLn $ "Fetching evaluation " <> show id <> " from Hydra. This might take a few minutes..." + buildReports :: Seq Build <- myReq (https "hydra.nixos.org" /: "eval" /: showT id /: "builds") (responseTimeout 600000000) + liftIO do + fileName <- reportFileName + putStrLn $ "Finished fetching all builds from Hydra, saving report as " <> fileName + now <- getCurrentTime + encodeFile fileName (eval, now, buildReports) + where + myReq query option = responseBody <$> req GET query NoReqBody jsonResponse (header "User-Agent" "hydra-report.hs/v1 (nixpkgs;maintainers/scripts/haskell)" <> option) + +hydraEvalCommand :: FilePath +hydraEvalCommand = "hydra-eval-jobs" +hydraEvalParams :: [String] +hydraEvalParams = ["-I", ".", "pkgs/top-level/release-haskell.nix"] +handlesCommand :: FilePath +handlesCommand = "nix-instantiate" +handlesParams :: [String] +handlesParams = ["--eval", "--strict", "--json", "-"] +handlesExpression :: String +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 :: Maybe 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 ", " . fromMaybe "" . maintainers) + where + get c p i e = readProcess c p i <&> \x -> either (error . (<> " Raw:'" <> take 1000 x <> "'") . (e <>)) Prelude.id . eitherDecodeStrict' . encodeUtf8 . Text.pack $ x + +-- BuildStates are sorted by subjective importance/concerningness +data BuildState = Failed | DependencyFailed | OutputLimitExceeded | Unknown (Maybe Int) | TimedOut | Canceled | 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 + TimedOut -> ":hourglass::no_entry_sign:" + Canceled -> ":no_entry_sign:" + Unfinished -> ":hourglass_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} = Map.singleton name (Table (Map.singleton (set, Platform system) (BuildResult state id)), maintainers) + where + state :: BuildState + state = case (finished, buildstatus) of + (0, _) -> Unfinished + (_, Just 0) -> Success + (_, Just 4) -> Canceled + (_, Just 7) -> TimedOut + (_, Just 2) -> DependencyFailed + (_, Just 1) -> Failed + (_, Just 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 :: Int -> Text -> (Table Text Platform BuildResult, Text) -> [Text] +printJob evalId name (Table mapping, maintainers) = + if length sets <= 1 + then map printSingleRow sets + else ["- [ ] " <> makeJobSearchLink "" name <> " " <> maintainers] <> map printRow sets + where + printRow set = " - " <> printState set <> " " <> makeJobSearchLink set (if Text.null set then "toplevel" else set) + printSingleRow set = "- [ ] " <> printState set <> " " <> makeJobSearchLink set (makePkgName set) <> " " <> maintainers + makePkgName set = (if Text.null set then "" else set <> ".") <> name + printState set = Text.intercalate " " $ map (\pf -> maybe "" (label pf) $ Map.lookup (set, pf) mapping) platforms + makeJobSearchLink set linkLabel= makeSearchLink evalId linkLabel (makePkgName set <> ".") -- Append '.' to the search query to prevent e.g. "hspec." matching "hspec-golden.x86_64-linux" + 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 <> ")" + +makeSearchLink :: Int -> Text -> Text -> Text +makeSearchLink evalId linkLabel query = "[" <> linkLabel <> "](" <> "https://hydra.nixos.org/eval/" <> showT evalId <> "?filter=" <> query <> ")" + +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 (\(_, platform) (BuildResult buildstate _) -> Map.singleton (platform, buildstate) (Sum 1)) mapping) + +details :: Text -> [Text] -> [Text] +details summary content = ["<details><summary>" <> summary <> " </summary>", ""] <> content <> ["</details>", ""] + +printBuildSummary :: Eval -> UTCTime -> StatusSummary -> Text +printBuildSummary + Eval{id, jobsetevalinputs = JobsetEvalInputs{nixpkgs = Nixpkgs{revision}}} + fetchTime + summary = + Text.unlines $ + headline <> 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 -> makeSearchLink id (platform x <> " " <> platformIcon x) ("." <> platform x)) (\x -> showT x <> " " <> icon x) showT (statusToNumSummary summary) + headline = + [ "### [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 predicate = Map.filter (predicate . foldl' min Success . fmap state . fst) summary + fails = jobsByState (== Failed) + failedDeps = jobsByState (== DependencyFailed) + unknownErr = jobsByState (\x -> x > DependencyFailed && x < TimedOut) + 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 heading list = if null list then mempty else [heading] <> list + optionalHideableList heading list = if null list then mempty else [heading] <> details (showT (length list) <> " job(s)") list + maintainedList = showMaintainedBuild <=< Map.toList . withMaintainer + unmaintainedList = showBuild <=< Map.toList . withoutMaintainer + showBuild (name, table) = printJob id name (table, "") + showMaintainedBuild (name, (table, maintainers)) = printJob id 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 + (Just 1, ["haskellPackages", name, "x86_64-linux"]) -> putStrLn $ " - " <> Text.unpack name + _ -> pure () diff --git a/maintainers/scripts/haskell/mark-broken.sh b/maintainers/scripts/haskell/mark-broken.sh new file mode 100755 index 0000000000000..ddf2b1243b1b2 --- /dev/null +++ b/maintainers/scripts/haskell/mark-broken.sh @@ -0,0 +1,45 @@ +#! /usr/bin/env nix-shell +#! nix-shell -i bash -p coreutils git -I nixpkgs=. + +# This script uses the data pulled with +# maintainers/scripts/haskell/hydra-report.hs get-report to produce a list of +# failing builds that get written to the hackage2nix config. Then +# hackage-packages.nix gets regenerated and transitive-broken packages get +# marked as dont-distribute in the config as well. +# This should disable builds for most failing jobs in the haskell-updates jobset. + +set -euo pipefail + +broken_config="pkgs/development/haskell-modules/configuration-hackage2nix/broken.yaml" + +tmpfile=$(mktemp) +trap "rm ${tmpfile}" 0 + +echo "Remember that you need to manually run 'maintainers/scripts/haskell/hydra-report.hs get-report' sometime before running this script." +echo "Generating a list of broken builds and displaying for manual confirmation ..." +maintainers/scripts/haskell/hydra-report.hs mark-broken-list | sort -i > $tmpfile + +$EDITOR $tmpfile + +tail -n +3 "$broken_config" >> "$tmpfile" + +cat > "$broken_config" << EOF +broken-packages: + # These packages don't compile. +EOF + +sort -iu "$tmpfile" >> "$broken_config" +maintainers/scripts/haskell/regenerate-hackage-packages.sh +maintainers/scripts/haskell/regenerate-transitive-broken-packages.sh +maintainers/scripts/haskell/regenerate-hackage-packages.sh + +if [[ "${1:-}" == "--do-commit" ]]; then +git add $broken_config +git add pkgs/development/haskell-modules/configuration-hackage2nix/transitive-broken.yaml +git add pkgs/development/haskell-modules/hackage-packages.nix +git commit -F - << EOF +hackage2nix: Mark failing builds broken + +This commit has been generated by maintainers/scripts/haskell/mark-broken.sh +EOF +fi diff --git a/maintainers/scripts/haskell/regenerate-transitive-broken-packages.sh b/maintainers/scripts/haskell/regenerate-transitive-broken-packages.sh index ed03ef5eb6af8..64ec998bf6b17 100755 --- a/maintainers/scripts/haskell/regenerate-transitive-broken-packages.sh +++ b/maintainers/scripts/haskell/regenerate-transitive-broken-packages.sh @@ -1,3 +1,15 @@ #! /usr/bin/env nix-shell #! nix-shell -i bash -p coreutils nix gnused -I nixpkgs=. -echo -e $(nix-instantiate --eval --strict maintainers/scripts/haskell/transitive-broken-packages.nix) | sed 's/\"//' > pkgs/development/haskell-modules/configuration-hackage2nix/transitive-broken.yaml + +config_file=pkgs/development/haskell-modules/configuration-hackage2nix/transitive-broken.yaml + +cat > $config_file << EOF +# This file is automatically generated by +# maintainers/scripts/haskell/regenerate-transitive-broken-packages.sh +# It is supposed to list all haskellPackages that cannot evaluate because they +# depend on a dependency marked as broken. +dont-distribute-packages: +EOF + +echo "Regenerating list of transitive broken packages ..." +echo -e $(nix-instantiate --eval --strict maintainers/scripts/haskell/transitive-broken-packages.nix) | sed 's/\"//' | sort -i >> $config_file diff --git a/maintainers/scripts/haskell/transitive-broken-packages.nix b/maintainers/scripts/haskell/transitive-broken-packages.nix index 3ddadea216f67..d4ddaa9576587 100644 --- a/maintainers/scripts/haskell/transitive-broken-packages.nix +++ b/maintainers/scripts/haskell/transitive-broken-packages.nix @@ -12,10 +12,5 @@ let (getEvaluating (nixpkgs { config.allowBroken = true; }).haskellPackages); in '' - # This file is automatically generated by - # maintainers/scripts/haskell/regenerate-transitive-broken-packages.sh - # It is supposed to list all haskellPackages that cannot evaluate because they - # depend on a dependency marked as broken. - dont-distribute-packages: ${lib.concatMapStringsSep "\n" (x: " - ${x}") brokenDeps} '' |