maintainers/scripts/haskell/hydra-report.hs

   1 #! /usr/bin/env nix-shell
   2 #! nix-shell -p "haskellPackages.ghcWithPackages (p: [p.aeson p.req])"
   3 #! nix-shell -p hydra
   4 #! nix-shell -i runhaskell
   5
   6 {-
   7
   8 The purpose of this script is
   9
  10 1) download the state of the nixpkgs/haskell-updates job from hydra (with get-report)
  11 2) print a summary of the state suitable for pasting into a github comment (with ping-maintainers)
  12 3) print a list of broken packages suitable for pasting into configuration-hackage2nix.yaml
  13
  14 Because step 1) is quite expensive and takes roughly ~5 minutes the result is cached in a json file in XDG_CACHE.
  15
  16 -}
  17 {-# LANGUAGE BlockArguments #-}
  18 {-# LANGUAGE DeriveAnyClass #-}
  19 {-# LANGUAGE DeriveGeneric #-}
  20 {-# LANGUAGE DerivingStrategies #-}
  21 {-# LANGUAGE DuplicateRecordFields #-}
  22 {-# LANGUAGE FlexibleContexts #-}
  23 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
  24 {-# LANGUAGE LambdaCase #-}
  25 {-# LANGUAGE NamedFieldPuns #-}
  26 {-# LANGUAGE OverloadedStrings #-}
  27 {-# LANGUAGE ScopedTypeVariables #-}
  28 {-# LANGUAGE TupleSections #-}
  29 {-# LANGUAGE ViewPatterns #-}
  30 {-# OPTIONS_GHC -Wall #-}
  31 {-# LANGUAGE DataKinds #-}
  32
  33 import Control.Monad (forM_, forM, (<=<))
  34 import Control.Monad.Trans (MonadIO (liftIO))
  35 import Data.Aeson (
  36    FromJSON,
  37    FromJSONKey,
  38    ToJSON,
  39    decodeFileStrict',
  40    eitherDecodeStrict',
  41    encodeFile,
  42  )
  43 import Data.Foldable (Foldable (toList), foldl')
  44 import Data.List.NonEmpty (NonEmpty, nonEmpty)
  45 import qualified Data.List.NonEmpty as NonEmpty
  46 import Data.Map.Strict (Map)
  47 import qualified Data.Map.Strict as Map
  48 import Data.Maybe (fromMaybe, mapMaybe, isNothing)
  49 import Data.Monoid (Sum (Sum, getSum))
  50 import Data.Sequence (Seq)
  51 import qualified Data.Sequence as Seq
  52 import Data.Set (Set)
  53 import qualified Data.Set as Set
  54 import Data.Text (Text)
  55 import qualified Data.Text as Text
  56 import Data.Text.Encoding (encodeUtf8)
  57 import qualified Data.Text.IO as Text
  58 import Data.Time (defaultTimeLocale, formatTime, getCurrentTime)
  59 import Data.Time.Clock (UTCTime)
  60 import GHC.Generics (Generic)
  61 import Network.HTTP.Req (
  62     GET (GET),
  63     HttpResponse (HttpResponseBody),
  64     NoReqBody (NoReqBody),
  65     Option,
  66     Req,
  67     Scheme (Https),
  68     bsResponse,
  69     defaultHttpConfig,
  70     header,
  71     https,
  72     jsonResponse,
  73     req,
  74     responseBody,
  75     responseTimeout,
  76     runReq,
  77     (/:),
  78  )
  79 import System.Directory (XdgDirectory (XdgCache), getXdgDirectory)
  80 import System.Environment (getArgs)
  81 import System.Exit (die)
  82 import System.Process (readProcess)
  83 import Prelude hiding (id)
  84 import Data.List (sortOn)
  85 import Control.Concurrent.Async (concurrently)
  86 import Control.Exception (evaluate)
  87 import qualified Data.IntMap.Lazy as IntMap
  88 import qualified Data.IntSet as IntSet
  89 import Data.Bifunctor (second)
  90 import Data.Data (Proxy)
  91 import Data.ByteString (ByteString)
  92 import qualified Data.ByteString.Char8 as ByteString
  93 import Distribution.Simple.Utils (safeLast, fromUTF8BS)
  94
  95 newtype JobsetEvals = JobsetEvals
  96    { evals :: Seq Eval
  97    }
  98    deriving stock (Generic, Show)
  99    deriving anyclass (ToJSON, FromJSON)
 100
 101 newtype Nixpkgs = Nixpkgs {revision :: Text}
 102    deriving stock (Generic, Show)
 103    deriving anyclass (ToJSON, FromJSON)
 104
 105 newtype JobsetEvalInputs = JobsetEvalInputs {nixpkgs :: Nixpkgs}
 106    deriving stock (Generic, Show)
 107    deriving anyclass (ToJSON, FromJSON)
 108
 109 data Eval = Eval
 110    { id :: Int
 111    , jobsetevalinputs :: JobsetEvalInputs
 112    , builds :: Seq Int
 113    }
 114    deriving (Generic, ToJSON, FromJSON, Show)
 115
 116 -- | Hydra job name.
 117 --
 118 -- Examples:
 119 -- - @"haskellPackages.lens.x86_64-linux"@
 120 -- - @"haskell.packages.ghc925.cabal-install.aarch64-darwin"@
 121 -- - @"pkgsMusl.haskell.compiler.ghc90.x86_64-linux"@
 122 -- - @"arion.aarch64-linux"@
 123 newtype JobName = JobName { unJobName :: Text }
 124    deriving stock (Generic, Show)
 125    deriving newtype (Eq, FromJSONKey, FromJSON, Ord, ToJSON)
 126
 127 -- | Datatype representing the result of querying the build evals of the
 128 -- haskell-updates Hydra jobset.
 129 --
 130 -- The URL <https://hydra.nixos.org/eval/EVAL_ID/builds> (where @EVAL_ID@ is a
 131 -- value like 1792418) returns a list of 'Build'.
 132 data Build = Build
 133    { job :: JobName
 134    , buildstatus :: Maybe Int
 135      -- ^ Status of the build.  See 'getBuildState' for the meaning of each state.
 136    , finished :: Int
 137      -- ^ Whether or not the build is finished.  @0@ if finished, non-zero otherwise.
 138    , id :: Int
 139    , nixname :: Text
 140      -- ^ Nix name of the derivation.
 141      --
 142      -- Examples:
 143      -- - @"lens-5.2.1"@
 144      -- - @"cabal-install-3.8.0.1"@
 145      -- - @"lens-static-x86_64-unknown-linux-musl-5.1.1"@
 146    , system :: Text
 147      -- ^ System
 148      --
 149      -- Examples:
 150      -- - @"x86_64-linux"@
 151      -- - @"aarch64-darwin"@
 152    , jobsetevals :: Seq Int
 153    }
 154    deriving (Generic, ToJSON, FromJSON, Show)
 155
 156 data HydraSlownessWorkaroundFlag = HydraSlownessWorkaround | NoHydraSlownessWorkaround
 157 data RequestLogsFlag = RequestLogs | NoRequestLogs
 158
 159 usage :: IO a
 160 usage = die "Usage: get-report [--slow] [EVAL-ID] | ping-maintainers | mark-broken-list [--no-request-logs] | eval-info"
 161
 162 main :: IO ()
 163 main = do
 164    args <- getArgs
 165    case args of
 166       "get-report":"--slow":id -> getBuildReports HydraSlownessWorkaround id
 167       "get-report":id -> getBuildReports NoHydraSlownessWorkaround id
 168       ["ping-maintainers"] -> printMaintainerPing
 169       ["mark-broken-list", "--no-request-logs"] -> printMarkBrokenList NoRequestLogs
 170       ["mark-broken-list"] -> printMarkBrokenList RequestLogs
 171       ["eval-info"] -> printEvalInfo
 172       _ -> usage
 173
 174 reportFileName :: IO FilePath
 175 reportFileName = getXdgDirectory XdgCache "haskell-updates-build-report.json"
 176
 177 showT :: Show a => a -> Text
 178 showT = Text.pack . show
 179
 180 getBuildReports :: HydraSlownessWorkaroundFlag -> [String] -> IO ()
 181 getBuildReports opt args = runReq defaultHttpConfig do
 182    eval@Eval{id} <- case args of
 183       [id] -> hydraJSONQuery mempty ["eval", Text.pack id]
 184       [] -> do
 185          evalMay <- Seq.lookup 0 . evals <$> hydraJSONQuery mempty ["jobset", "nixpkgs", "haskell-updates", "evals"]
 186          maybe (liftIO $ fail "No Evaluation found") pure evalMay
 187       _ -> liftIO usage
 188    liftIO . putStrLn $ "Fetching evaluation " <> show id <> " from Hydra. This might take a few minutes..."
 189    buildReports <- getEvalBuilds opt eval
 190    liftIO do
 191       fileName <- reportFileName
 192       putStrLn $ "Finished fetching all builds from Hydra, saving report as " <> fileName
 193       now <- getCurrentTime
 194       encodeFile fileName (eval, now, buildReports)
 195
 196 getEvalBuilds :: HydraSlownessWorkaroundFlag -> Eval -> Req (Seq Build)
 197 getEvalBuilds NoHydraSlownessWorkaround Eval{id} =
 198   hydraJSONQuery mempty ["eval", showT id, "builds"]
 199 getEvalBuilds HydraSlownessWorkaround Eval{builds} = do
 200   forM builds $ \buildId -> do
 201     liftIO $ putStrLn $ "Querying build " <> show buildId
 202     hydraJSONQuery mempty [ "build", showT buildId ]
 203
 204 hydraQuery :: HttpResponse a => Proxy a -> Option 'Https -> [Text] -> Req (HttpResponseBody a)
 205 hydraQuery responseType option query = do
 206   let customHeaderOpt =
 207         header
 208           "User-Agent"
 209           "hydra-report.hs/v1 (nixpkgs;maintainers/scripts/haskell) pls fix https://github.com/NixOS/nixos-org-configurations/issues/270"
 210       customTimeoutOpt = responseTimeout 900_000_000 -- 15 minutes
 211       opts = customHeaderOpt <> customTimeoutOpt <> option
 212       url = foldl' (/:) (https "hydra.nixos.org") query
 213   responseBody <$> req GET url NoReqBody responseType opts
 214
 215 hydraJSONQuery :: FromJSON a => Option 'Https -> [Text] -> Req a
 216 hydraJSONQuery = hydraQuery jsonResponse
 217
 218 hydraPlainQuery :: [Text] -> Req ByteString
 219 hydraPlainQuery = hydraQuery bsResponse mempty
 220
 221 hydraEvalCommand :: FilePath
 222 hydraEvalCommand = "hydra-eval-jobs"
 223
 224 hydraEvalParams :: [String]
 225 hydraEvalParams = ["-I", ".", "pkgs/top-level/release-haskell.nix"]
 226
 227 nixExprCommand :: FilePath
 228 nixExprCommand = "nix-instantiate"
 229
 230 nixExprParams :: [String]
 231 nixExprParams = ["--eval", "--strict", "--json"]
 232
 233 -- | This newtype is used to parse a Hydra job output from @hydra-eval-jobs@.
 234 -- The only field we are interested in is @maintainers@, which is why this
 235 -- is just a newtype.
 236 --
 237 -- Note that there are occasionally jobs that don't have a maintainers
 238 -- field, which is why this has to be @Maybe Text@.
 239 newtype Maintainers = Maintainers { maintainers :: Maybe Text }
 240   deriving stock (Generic, Show)
 241   deriving anyclass (FromJSON, ToJSON)
 242
 243 -- | This is a 'Map' from Hydra job name to maintainer email addresses.
 244 --
 245 -- It has values similar to the following:
 246 --
 247 -- @@
 248 --  fromList
 249 --    [ ("arion.aarch64-linux", Maintainers (Just "robert@example.com"))
 250 --    , ("bench.x86_64-linux", Maintainers (Just ""))
 251 --    , ("conduit.x86_64-linux", Maintainers (Just "snoy@man.com, web@ber.com"))
 252 --    , ("lens.x86_64-darwin", Maintainers (Just "ek@category.com"))
 253 --    ]
 254 -- @@
 255 --
 256 -- Note that Hydra jobs without maintainers will have an empty string for the
 257 -- maintainer list.
 258 type HydraJobs = Map JobName Maintainers
 259
 260 -- | Map of email addresses to GitHub handles.
 261 -- This is built from the file @../../maintainer-list.nix@.
 262 --
 263 -- It has values similar to the following:
 264 --
 265 -- @@
 266 --  fromList
 267 --    [ ("robert@example.com", "rob22")
 268 --    , ("ek@category.com", "edkm")
 269 --    ]
 270 -- @@
 271 type EmailToGitHubHandles = Map Text Text
 272
 273 -- | Map of Hydra jobs to maintainer GitHub handles.
 274 --
 275 -- It has values similar to the following:
 276 --
 277 -- @@
 278 --  fromList
 279 --    [ ("arion.aarch64-linux", ["rob22"])
 280 --    , ("conduit.x86_64-darwin", ["snoyb", "webber"])
 281 --    ]
 282 -- @@
 283 type MaintainerMap = Map JobName (NonEmpty Text)
 284
 285 -- | Information about a package which lists its dependencies and whether the
 286 -- package is marked broken.
 287 data DepInfo = DepInfo {
 288    deps :: Set PkgName,
 289    broken :: Bool
 290 }
 291    deriving stock (Generic, Show)
 292    deriving anyclass (FromJSON, ToJSON)
 293
 294 -- | Map from package names to their DepInfo. This is the data we get out of a
 295 -- nix call.
 296 type DependencyMap = Map PkgName DepInfo
 297
 298 -- | Map from package names to its broken state, number of reverse dependencies (fst) and
 299 -- unbroken reverse dependencies (snd).
 300 type ReverseDependencyMap = Map PkgName (Int, Int)
 301
 302 -- | Calculate the (unbroken) reverse dependencies of a package by transitively
 303 -- going through all packages if it’s a dependency of them.
 304 calculateReverseDependencies :: DependencyMap -> ReverseDependencyMap
 305 calculateReverseDependencies depMap =
 306    Map.fromDistinctAscList $ zip keys (zip (rdepMap False) (rdepMap True))
 307  where
 308     -- This code tries to efficiently invert the dependency map and calculate
 309     -- its transitive closure by internally identifying every pkg with its index
 310     -- in the package list and then using memoization.
 311     keys :: [PkgName]
 312     keys = Map.keys depMap
 313
 314     pkgToIndexMap :: Map PkgName Int
 315     pkgToIndexMap = Map.fromDistinctAscList (zip keys [0..])
 316
 317     depInfos :: [DepInfo]
 318     depInfos = Map.elems depMap
 319
 320     depInfoToIdx :: DepInfo -> (Bool, [Int])
 321     depInfoToIdx DepInfo{broken,deps} =
 322        (broken, mapMaybe (`Map.lookup` pkgToIndexMap) $ Set.toList deps)
 323
 324     intDeps :: [(Int, (Bool, [Int]))]
 325     intDeps = zip [0..] (fmap depInfoToIdx depInfos)
 326
 327     rdepMap onlyUnbroken = IntSet.size <$> IntMap.elems resultList
 328      where
 329        resultList = IntMap.fromDistinctAscList [(i, go i) | i <- [0..length keys - 1]]
 330        oneStepMap = IntMap.fromListWith IntSet.union $ (\(key,(_,deps)) -> (,IntSet.singleton key) <$> deps) <=< filter (\(_, (broken,_)) -> not (broken && onlyUnbroken)) $ intDeps
 331        go pkg = IntSet.unions (oneStep:((resultList IntMap.!) <$> IntSet.toList oneStep))
 332         where oneStep = IntMap.findWithDefault mempty pkg oneStepMap
 333
 334 -- | Generate a mapping of Hydra job names to maintainer GitHub handles. Calls
 335 -- hydra-eval-jobs and the nix script ./maintainer-handles.nix.
 336 getMaintainerMap :: IO MaintainerMap
 337 getMaintainerMap = do
 338    hydraJobs :: HydraJobs <-
 339       readJSONProcess hydraEvalCommand hydraEvalParams "Failed to decode hydra-eval-jobs output: "
 340    handlesMap :: EmailToGitHubHandles <-
 341       readJSONProcess nixExprCommand ("maintainers/scripts/haskell/maintainer-handles.nix":nixExprParams) "Failed to decode nix output for lookup of github handles: "
 342    pure $ Map.mapMaybe (splitMaintainersToGitHubHandles handlesMap) hydraJobs
 343   where
 344    -- Split a comma-spearated string of Maintainers into a NonEmpty list of
 345    -- GitHub handles.
 346    splitMaintainersToGitHubHandles
 347       :: EmailToGitHubHandles -> Maintainers -> Maybe (NonEmpty Text)
 348    splitMaintainersToGitHubHandles handlesMap (Maintainers maint) =
 349       nonEmpty .  mapMaybe (`Map.lookup` handlesMap) .  Text.splitOn ", " $ fromMaybe "" maint
 350
 351 -- | Get the a map of all dependencies of every package by calling the nix
 352 -- script ./dependencies.nix.
 353 getDependencyMap :: IO DependencyMap
 354 getDependencyMap =
 355    readJSONProcess
 356       nixExprCommand
 357       ("maintainers/scripts/haskell/dependencies.nix" : nixExprParams)
 358       "Failed to decode nix output for lookup of dependencies: "
 359
 360 -- | Run a process that produces JSON on stdout and and decode the JSON to a
 361 -- data type.
 362 --
 363 -- If the JSON-decoding fails, throw the JSON-decoding error.
 364 readJSONProcess
 365    :: FromJSON a
 366    => FilePath -- ^ Filename of executable.
 367    -> [String] -- ^ Arguments
 368    -> String -- ^ String to prefix to JSON-decode error.
 369    -> IO a
 370 readJSONProcess exe args err = do
 371    output <- readProcess exe args ""
 372    let eitherDecodedOutput = eitherDecodeStrict' . encodeUtf8 . Text.pack $ output
 373    case eitherDecodedOutput of
 374      Left decodeErr -> error $ err <> decodeErr <> "\nRaw: '" <> take 1000 output <> "'"
 375      Right decodedOutput -> pure decodedOutput
 376
 377 -- BuildStates are sorted by subjective importance/concerningness
 378 data BuildState
 379   = Failed
 380   | DependencyFailed
 381   | OutputLimitExceeded
 382   | Unknown (Maybe Int)
 383   | TimedOut
 384   | Canceled
 385   | HydraFailure
 386   | Unfinished
 387   | Success
 388   deriving stock (Show, Eq, Ord)
 389
 390 icon :: BuildState -> Text
 391 icon = \case
 392    Failed -> "❌"
 393    DependencyFailed -> "❗"
 394    OutputLimitExceeded -> "⚠️"
 395    Unknown x -> "unknown code " <> showT x
 396    TimedOut -> "⌛🚫"
 397    Canceled -> "🚫"
 398    Unfinished -> "⏳"
 399    HydraFailure -> "🚧"
 400    Success -> "✅"
 401
 402 platformIcon :: Platform -> Text
 403 platformIcon (Platform x) = case x of
 404    "x86_64-linux" -> "🐧"
 405    "aarch64-linux" -> "📱"
 406    "x86_64-darwin" -> "🍎"
 407    "aarch64-darwin" -> "🍏"
 408    _ -> x
 409
 410 platformIsOS :: OS -> Platform -> Bool
 411 platformIsOS os (Platform x) = case (os, x) of
 412    (Linux, "x86_64-linux") -> True
 413    (Linux, "aarch64-linux") -> True
 414    (Darwin, "x86_64-darwin") -> True
 415    (Darwin, "aarch64-darwin") -> True
 416    _ -> False
 417
 418
 419 -- | A package name.  This is parsed from a 'JobName'.
 420 --
 421 -- Examples:
 422 --
 423 -- - The 'JobName' @"haskellPackages.lens.x86_64-linux"@ produces the 'PkgName'
 424 --   @"lens"@.
 425 -- - The 'JobName' @"haskell.packages.ghc925.cabal-install.aarch64-darwin"@
 426 --   produces the 'PkgName' @"cabal-install"@.
 427 -- - The 'JobName' @"pkgsMusl.haskell.compiler.ghc90.x86_64-linux"@ produces
 428 --   the 'PkgName' @"ghc90"@.
 429 -- - The 'JobName' @"arion.aarch64-linux"@ produces the 'PkgName' @"arion"@.
 430 --
 431 -- 'PkgName' is also used as a key in 'DependencyMap' and 'ReverseDependencyMap'.
 432 -- In this case, 'PkgName' originally comes from attribute names in @haskellPackages@
 433 -- in Nixpkgs.
 434 newtype PkgName = PkgName Text
 435    deriving stock (Generic, Show)
 436    deriving newtype (Eq, FromJSON, FromJSONKey, Ord, ToJSON)
 437
 438 -- | A package set name.  This is parsed from a 'JobName'.
 439 --
 440 -- Examples:
 441 --
 442 -- - The 'JobName' @"haskellPackages.lens.x86_64-linux"@ produces the 'PkgSet'
 443 --   @"haskellPackages"@.
 444 -- - The 'JobName' @"haskell.packages.ghc925.cabal-install.aarch64-darwin"@
 445 --   produces the 'PkgSet' @"haskell.packages.ghc925"@.
 446 -- - The 'JobName' @"pkgsMusl.haskell.compiler.ghc90.x86_64-linux"@ produces
 447 --   the 'PkgSet' @"pkgsMusl.haskell.compiler"@.
 448 -- - The 'JobName' @"arion.aarch64-linux"@ produces the 'PkgSet' @""@.
 449 --
 450 -- As you can see from the last example, 'PkgSet' can be empty (@""@) for
 451 -- top-level jobs.
 452 newtype PkgSet = PkgSet Text
 453    deriving stock (Generic, Show)
 454    deriving newtype (Eq, FromJSON, FromJSONKey, Ord, ToJSON)
 455
 456 data BuildResult = BuildResult {state :: BuildState, id :: Int} deriving (Show, Eq, Ord)
 457 newtype Platform = Platform {platform :: Text} deriving (Show, Eq, Ord)
 458 data SummaryEntry = SummaryEntry {
 459    summaryBuilds :: Table PkgSet Platform BuildResult,
 460    summaryMaintainers :: Set Text,
 461    summaryReverseDeps :: Int,
 462    summaryUnbrokenReverseDeps :: Int
 463 }
 464 type StatusSummary = Map PkgName SummaryEntry
 465
 466 data OS = Linux | Darwin
 467
 468 newtype Table row col a = Table (Map (row, col) a)
 469
 470 singletonTable :: row -> col -> a -> Table row col a
 471 singletonTable row col a = Table $ Map.singleton (row, col) a
 472
 473 unionTable :: (Ord row, Ord col) => Table row col a -> Table row col a -> Table row col a
 474 unionTable (Table l) (Table r) = Table $ Map.union l r
 475
 476 filterWithKeyTable :: (row -> col -> a -> Bool) -> Table row col a -> Table row col a
 477 filterWithKeyTable f (Table t) = Table $ Map.filterWithKey (\(r,c) a -> f r c a) t
 478
 479 nullTable :: Table row col a -> Bool
 480 nullTable (Table t) = Map.null t
 481
 482 instance (Ord row, Ord col, Semigroup a) => Semigroup (Table row col a) where
 483    Table l <> Table r = Table (Map.unionWith (<>) l r)
 484 instance (Ord row, Ord col, Semigroup a) => Monoid (Table row col a) where
 485    mempty = Table Map.empty
 486 instance Functor (Table row col) where
 487    fmap f (Table a) = Table (fmap f a)
 488 instance Foldable (Table row col) where
 489    foldMap f (Table a) = foldMap f a
 490
 491 getBuildState :: Build -> BuildState
 492 getBuildState Build{finished, buildstatus} = case (finished, buildstatus) of
 493    (0, _) -> Unfinished
 494    (_, Just 0) -> Success
 495    (_, Just 1) -> Failed
 496    (_, Just 2) -> DependencyFailed
 497    (_, Just 3) -> HydraFailure
 498    (_, Just 4) -> Canceled
 499    (_, Just 7) -> TimedOut
 500    (_, Just 11) -> OutputLimitExceeded
 501    (_, i) -> Unknown i
 502
 503 combineStatusSummaries :: Seq StatusSummary -> StatusSummary
 504 combineStatusSummaries = foldl (Map.unionWith unionSummary) Map.empty
 505   where
 506    unionSummary :: SummaryEntry -> SummaryEntry -> SummaryEntry
 507    unionSummary (SummaryEntry lb lm lr lu) (SummaryEntry rb rm rr ru) =
 508       SummaryEntry (unionTable lb rb) (lm <> rm) (max lr rr) (max lu ru)
 509
 510 buildToPkgNameAndSet :: Build -> (PkgName, PkgSet)
 511 buildToPkgNameAndSet Build{job = JobName jobName, system} = (name, set)
 512   where
 513    packageName :: Text
 514    packageName = fromMaybe jobName (Text.stripSuffix ("." <> system) jobName)
 515
 516    splitted :: Maybe (NonEmpty Text)
 517    splitted = nonEmpty $ Text.splitOn "." packageName
 518
 519    name :: PkgName
 520    name = PkgName $ maybe packageName NonEmpty.last splitted
 521
 522    set :: PkgSet
 523    set = PkgSet $ maybe "" (Text.intercalate "." . NonEmpty.init) splitted
 524
 525 buildToStatusSummary :: MaintainerMap -> ReverseDependencyMap -> Build -> StatusSummary
 526 buildToStatusSummary maintainerMap reverseDependencyMap build@Build{job, id, system} =
 527    Map.singleton pkgName summaryEntry
 528   where
 529    (pkgName, pkgSet) = buildToPkgNameAndSet build
 530
 531    maintainers :: Set Text
 532    maintainers = maybe mempty (Set.fromList . toList) (Map.lookup job maintainerMap)
 533
 534    (reverseDeps, unbrokenReverseDeps) =
 535       Map.findWithDefault (0,0) pkgName reverseDependencyMap
 536
 537    buildTable :: Table PkgSet Platform BuildResult
 538    buildTable =
 539       singletonTable pkgSet (Platform system) (BuildResult (getBuildState build) id)
 540
 541    summaryEntry = SummaryEntry buildTable maintainers reverseDeps unbrokenReverseDeps
 542
 543 readBuildReports :: IO (Eval, UTCTime, Seq Build)
 544 readBuildReports = do
 545    file <- reportFileName
 546    fromMaybe (error $ "Could not decode " <> file) <$> decodeFileStrict' file
 547
 548 sep :: Text
 549 sep = " | "
 550 joinTable :: [Text] -> Text
 551 joinTable t = sep <> Text.intercalate sep t <> sep
 552
 553 type NumSummary = Table Platform BuildState Int
 554
 555 printTable :: (Ord rows, Ord cols) => Text -> (rows -> Text) -> (cols -> Text) -> (entries -> Text) -> Table rows cols entries -> [Text]
 556 printTable name showR showC showE (Table mapping) = joinTable <$> (name : map showC cols) : replicate (length cols + sepsInName + 1) "---" : map printRow rows
 557   where
 558    sepsInName = Text.count "|" name
 559    printRow row = showR row : map (\col -> maybe "" showE (Map.lookup (row, col) mapping)) cols
 560    rows = toList $ Set.fromList (fst <$> Map.keys mapping)
 561    cols = toList $ Set.fromList (snd <$> Map.keys mapping)
 562
 563 printJob :: Int -> PkgName -> (Table PkgSet Platform BuildResult, Text) -> [Text]
 564 printJob evalId (PkgName name) (Table mapping, maintainers) =
 565    if length sets <= 1
 566       then map printSingleRow sets
 567       else ["- [ ] " <> makeJobSearchLink (PkgSet "") name <> " " <> maintainers] <> map printRow sets
 568   where
 569    printRow :: PkgSet -> Text
 570    printRow (PkgSet set) =
 571       "  - " <> printState (PkgSet set) <> " " <>
 572       makeJobSearchLink (PkgSet set) (if Text.null set then "toplevel" else set)
 573
 574    printSingleRow set =
 575       "- [ ] " <> printState set <> " " <>
 576       makeJobSearchLink set (makePkgName set) <> " " <> maintainers
 577
 578    makePkgName :: PkgSet -> Text
 579    makePkgName (PkgSet set) = (if Text.null set then "" else set <> ".") <> name
 580
 581    printState set =
 582       Text.intercalate " " $ map (\pf -> maybe "" (label pf) $ Map.lookup (set, pf) mapping) platforms
 583
 584    makeJobSearchLink :: PkgSet -> Text -> Text
 585    makeJobSearchLink set linkLabel = makeSearchLink evalId linkLabel (makePkgName set)
 586
 587    sets :: [PkgSet]
 588    sets = toList $ Set.fromList (fst <$> Map.keys mapping)
 589
 590    platforms :: [Platform]
 591    platforms = toList $ Set.fromList (snd <$> Map.keys mapping)
 592
 593    label pf (BuildResult s i) = "[[" <> platformIcon pf <> icon s <> "]](https://hydra.nixos.org/build/" <> showT i <> ")"
 594
 595 makeSearchLink :: Int -> Text -> Text -> Text
 596 makeSearchLink evalId linkLabel query = "[" <> linkLabel <> "](" <> "https://hydra.nixos.org/eval/" <> showT evalId <> "?filter=" <> query <> ")"
 597
 598 statusToNumSummary :: StatusSummary -> NumSummary
 599 statusToNumSummary = fmap getSum . foldMap (fmap Sum . jobTotals)
 600
 601 jobTotals :: SummaryEntry -> Table Platform BuildState Int
 602 jobTotals (summaryBuilds -> Table mapping) = getSum <$> Table (Map.foldMapWithKey (\(_, platform) (BuildResult buildstate _) -> Map.singleton (platform, buildstate) (Sum 1)) mapping)
 603
 604 details :: Text -> [Text] -> [Text]
 605 details summary content = ["<details><summary>" <> summary <> " </summary>", ""] <> content <> ["</details>", ""]
 606
 607 evalLine :: Eval -> UTCTime -> Text
 608 evalLine Eval{id, jobsetevalinputs = JobsetEvalInputs{nixpkgs = Nixpkgs{revision}}} fetchTime =
 609    "*evaluation ["
 610     <> showT id
 611     <> "](https://hydra.nixos.org/eval/"
 612     <> showT id
 613     <> ") of nixpkgs commit ["
 614     <> Text.take 7 revision
 615     <> "](https://github.com/NixOS/nixpkgs/commits/"
 616     <> revision
 617     <> ") as of "
 618     <> Text.pack (formatTime defaultTimeLocale "%Y-%m-%d %H:%M UTC" fetchTime)
 619     <> "*"
 620
 621 printBuildSummary :: Eval -> UTCTime -> StatusSummary -> [(PkgName, Int)] -> Text
 622 printBuildSummary eval@Eval{id} fetchTime summary topBrokenRdeps =
 623    Text.unlines $
 624       headline <> [""] <> tldr <> (("  * "<>) <$> (errors <> warnings)) <> [""]
 625          <> totals
 626          <> optionalList "#### Maintained Linux packages with build failure" (maintainedList (fails summaryLinux))
 627          <> optionalList "#### Maintained Linux packages with failed dependency" (maintainedList (failedDeps summaryLinux))
 628          <> optionalList "#### Maintained Linux packages with unknown error" (maintainedList (unknownErr summaryLinux))
 629          <> optionalHideableList "#### Maintained Darwin packages with build failure" (maintainedList (fails summaryDarwin))
 630          <> optionalHideableList "#### Maintained Darwin packages with failed dependency" (maintainedList (failedDeps summaryDarwin))
 631          <> optionalHideableList "#### Maintained Darwin packages with unknown error" (maintainedList (unknownErr summaryDarwin))
 632          <> optionalHideableList "#### Unmaintained packages with build failure" (unmaintainedList (fails summary))
 633          <> optionalHideableList "#### Unmaintained packages with failed dependency" (unmaintainedList (failedDeps summary))
 634          <> optionalHideableList "#### Unmaintained packages with unknown error" (unmaintainedList (unknownErr summary))
 635          <> optionalHideableList "#### Top 50 broken packages, sorted by number of reverse dependencies" (brokenLine <$> topBrokenRdeps)
 636          <> ["","*⤴️: The number of packages that depend (directly or indirectly) on this package (if any). If two numbers are shown the first (lower) number considers only packages which currently have enabled hydra jobs, i.e. are not marked broken. The second (higher) number considers all packages.*",""]
 637          <> footer
 638   where
 639    footer = ["*Report generated with [maintainers/scripts/haskell/hydra-report.hs](https://github.com/NixOS/nixpkgs/blob/haskell-updates/maintainers/scripts/haskell/hydra-report.hs)*"]
 640
 641    headline =
 642       [ "### [haskell-updates build report from hydra](https://hydra.nixos.org/jobset/nixpkgs/haskell-updates)"
 643       , evalLine eval fetchTime
 644       ]
 645
 646    totals :: [Text]
 647    totals =
 648       [ "#### Build summary"
 649       , ""
 650       ] <>
 651       printTable
 652          "Platform"
 653          (\x -> makeSearchLink id (platform x <> " " <> platformIcon x) ("." <> platform x))
 654          (\x -> showT x <> " " <> icon x)
 655          showT
 656          numSummary
 657
 658    brokenLine :: (PkgName, Int) -> Text
 659    brokenLine (PkgName name, rdeps) =
 660       "[" <> name <> "](https://packdeps.haskellers.com/reverse/" <> name <>
 661       ") ⤴️ " <> Text.pack (show rdeps) <> "  "
 662
 663    numSummary = statusToNumSummary summary
 664
 665    summaryLinux :: StatusSummary
 666    summaryLinux = withOS Linux summary
 667
 668    summaryDarwin :: StatusSummary
 669    summaryDarwin = withOS Darwin summary
 670
 671    -- Remove all BuildResult from the Table that have Platform that isn't for
 672    -- the given OS.
 673    tableForOS :: OS -> Table PkgSet Platform BuildResult -> Table PkgSet Platform BuildResult
 674    tableForOS os = filterWithKeyTable (\_ platform _ -> platformIsOS os platform)
 675
 676    -- Remove all BuildResult from the StatusSummary that have a Platform that
 677    -- isn't for the given OS.  Completely remove all PkgName from StatusSummary
 678    -- that end up with no BuildResults.
 679    withOS
 680       :: OS
 681       -> StatusSummary
 682       -> StatusSummary
 683    withOS os =
 684       Map.mapMaybe
 685          (\e@SummaryEntry{summaryBuilds} ->
 686             let buildsForOS = tableForOS os summaryBuilds
 687             in if nullTable buildsForOS then Nothing else Just e { summaryBuilds = buildsForOS }
 688          )
 689
 690    jobsByState :: (BuildState -> Bool) -> StatusSummary -> StatusSummary
 691    jobsByState predicate = Map.filter (predicate . worstState)
 692
 693    worstState :: SummaryEntry -> BuildState
 694    worstState = foldl' min Success . fmap state . summaryBuilds
 695
 696    fails :: StatusSummary -> StatusSummary
 697    fails = jobsByState (== Failed)
 698
 699    failedDeps :: StatusSummary -> StatusSummary
 700    failedDeps = jobsByState (== DependencyFailed)
 701
 702    unknownErr :: StatusSummary -> StatusSummary
 703    unknownErr = jobsByState (\x -> x > DependencyFailed && x < TimedOut)
 704
 705    withMaintainer :: StatusSummary -> Map PkgName (Table PkgSet Platform BuildResult, NonEmpty Text)
 706    withMaintainer =
 707       Map.mapMaybe
 708          (\e -> (summaryBuilds e,) <$> nonEmpty (Set.toList (summaryMaintainers e)))
 709
 710    withoutMaintainer :: StatusSummary -> StatusSummary
 711    withoutMaintainer = Map.mapMaybe (\e -> if Set.null (summaryMaintainers e) then Just e else Nothing)
 712
 713    optionalList :: Text -> [Text] -> [Text]
 714    optionalList heading list = if null list then mempty else [heading] <> list
 715
 716    optionalHideableList :: Text -> [Text] -> [Text]
 717    optionalHideableList heading list = if null list then mempty else [heading] <> details (showT (length list) <> " job(s)") list
 718
 719    maintainedList :: StatusSummary -> [Text]
 720    maintainedList = showMaintainedBuild <=< Map.toList . withMaintainer
 721
 722    summaryEntryGetReverseDeps :: SummaryEntry -> (Int, Int)
 723    summaryEntryGetReverseDeps sumEntry =
 724       ( negate $ summaryUnbrokenReverseDeps sumEntry
 725       , negate $ summaryReverseDeps sumEntry
 726       )
 727
 728    sortOnReverseDeps :: [(PkgName, SummaryEntry)] -> [(PkgName, SummaryEntry)]
 729    sortOnReverseDeps = sortOn (\(_, sumEntry) -> summaryEntryGetReverseDeps sumEntry)
 730
 731    unmaintainedList :: StatusSummary -> [Text]
 732    unmaintainedList = showBuild <=< sortOnReverseDeps . Map.toList . withoutMaintainer
 733
 734    showBuild :: (PkgName, SummaryEntry) -> [Text]
 735    showBuild (name, entry) =
 736       printJob
 737          id
 738          name
 739          ( summaryBuilds entry
 740          , Text.pack
 741             ( if summaryReverseDeps entry > 0
 742                then
 743                   " ⤴️ " <> show (summaryUnbrokenReverseDeps entry) <>
 744                   " | " <> show (summaryReverseDeps entry)
 745                else ""
 746             )
 747          )
 748
 749    showMaintainedBuild
 750       :: (PkgName, (Table PkgSet Platform BuildResult, NonEmpty Text)) -> [Text]
 751    showMaintainedBuild (name, (table, maintainers)) =
 752       printJob
 753          id
 754          name
 755          ( table
 756          , Text.intercalate " " (fmap ("@" <>) (toList maintainers))
 757          )
 758
 759    tldr = case (errors, warnings) of
 760             ([],[]) -> ["🟢 **Ready to merge** (if there are no [evaluation errors](https://hydra.nixos.org/jobset/nixpkgs/haskell-updates))"]
 761             ([],_) -> ["🟡 **Potential issues** (and possibly [evaluation errors](https://hydra.nixos.org/jobset/nixpkgs/haskell-updates))"]
 762             _ -> ["🔴 **Branch not mergeable**"]
 763    warnings =
 764       if' (Unfinished > maybe Success worstState maintainedJob) "`maintained` jobset failed." <>
 765       if' (Unfinished == maybe Success worstState mergeableJob) "`mergeable` jobset is not finished." <>
 766       if' (Unfinished == maybe Success worstState maintainedJob) "`maintained` jobset is not finished."
 767    errors =
 768       if' (isNothing mergeableJob) "No `mergeable` job found." <>
 769       if' (isNothing maintainedJob) "No `maintained` job found." <>
 770       if' (Unfinished > maybe Success worstState mergeableJob) "`mergeable` jobset failed." <>
 771       if' (outstandingJobs (Platform "x86_64-linux") > 100) "Too many outstanding jobs on x86_64-linux." <>
 772       if' (outstandingJobs (Platform "aarch64-linux") > 100) "Too many outstanding jobs on aarch64-linux."
 773
 774    if' p e = if p then [e] else mempty
 775
 776    outstandingJobs platform | Table m <- numSummary = Map.findWithDefault 0 (platform, Unfinished) m
 777
 778    maintainedJob = Map.lookup (PkgName "maintained") summary
 779    mergeableJob = Map.lookup (PkgName "mergeable") summary
 780
 781 printEvalInfo :: IO ()
 782 printEvalInfo = do
 783    (eval, fetchTime, _) <- readBuildReports
 784    putStrLn (Text.unpack $ evalLine eval fetchTime)
 785
 786 printMaintainerPing :: IO ()
 787 printMaintainerPing = do
 788    (maintainerMap, (reverseDependencyMap, topBrokenRdeps)) <- concurrently getMaintainerMap do
 789       depMap <- getDependencyMap
 790       rdepMap <- evaluate . calculateReverseDependencies $ depMap
 791       let tops = take 50 . sortOn (negate . snd) . fmap (second fst) . filter (\x -> maybe False broken $ Map.lookup (fst x) depMap) . Map.toList $ rdepMap
 792       pure (rdepMap, tops)
 793    (eval, fetchTime, buildReport) <- readBuildReports
 794    let statusSummaries =
 795           fmap (buildToStatusSummary maintainerMap reverseDependencyMap) buildReport
 796        buildSum :: StatusSummary
 797        buildSum = combineStatusSummaries statusSummaries
 798        textBuildSummary = printBuildSummary eval fetchTime buildSum topBrokenRdeps
 799    Text.putStrLn textBuildSummary
 800
 801 printMarkBrokenList :: RequestLogsFlag -> IO ()
 802 printMarkBrokenList reqLogs = do
 803    (_, fetchTime, buildReport) <- readBuildReports
 804    runReq defaultHttpConfig $ forM_ buildReport \build@Build{job, id} ->
 805       case (getBuildState build, Text.splitOn "." $ unJobName job) of
 806          (Failed, ["haskellPackages", name, "x86_64-linux"]) -> do
 807             -- We use the last probable error cause found in the build log file.
 808             error_message <- fromMaybe "failure" <$>
 809               case reqLogs of
 810                 NoRequestLogs -> pure Nothing
 811                 RequestLogs -> do
 812                   -- Fetch build log from hydra to figure out the cause of the error.
 813                   build_log <- ByteString.lines <$> hydraPlainQuery ["build", showT id, "nixlog", "1", "raw"]
 814                   pure $ safeLast $ mapMaybe probableErrorCause build_log
 815             liftIO $ putStrLn $ "  - " <> Text.unpack name <> " # " <> error_message <> " in job https://hydra.nixos.org/build/" <> show id <> " at " <> formatTime defaultTimeLocale "%Y-%m-%d" fetchTime
 816          _ -> pure ()
 817
 818 {- | This function receives a line from a Nix Haskell builder build log and returns a possible error cause.
 819  | We might need to add other causes in the future if errors happen in unusual parts of the builder.
 820 -}
 821 probableErrorCause :: ByteString -> Maybe String
 822 probableErrorCause "Setup: Encountered missing or private dependencies:" = Just "dependency missing"
 823 probableErrorCause "running tests" = Just "test failure"
 824 probableErrorCause build_line | ByteString.isPrefixOf "Building" build_line = Just ("failure building " <> fromUTF8BS (fst $ ByteString.breakSubstring " for" $ ByteString.drop 9 build_line))
 825 probableErrorCause build_line | ByteString.isSuffixOf "Phase" build_line = Just ("failure in " <> fromUTF8BS build_line)
 826 probableErrorCause _ = Nothing