pyrox.dev
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
8The purpose of this script is
9
101) download the state of the nixpkgs/haskell-updates job from hydra (with get-report)
112) print a summary of the state suitable for pasting into a github comment (with ping-maintainers)
123) print a list of broken packages suitable for pasting into configuration-hackage2nix.yaml
13
14Because 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
33import Control.Monad (forM_, forM, (<=<))
34import Control.Monad.Trans (MonadIO (liftIO))
35import Data.Aeson (
36 FromJSON,
37 FromJSONKey,
38 ToJSON,
39 decodeFileStrict',
40 eitherDecodeStrict',
41 encodeFile,
42 )
43import Data.Foldable (Foldable (toList), foldl')
44import Data.List.NonEmpty (NonEmpty, nonEmpty)
45import qualified Data.List.NonEmpty as NonEmpty
46import Data.Map.Strict (Map)
47import qualified Data.Map.Strict as Map
48import Data.Maybe (fromMaybe, mapMaybe, isNothing)
49import Data.Monoid (Sum (Sum, getSum))
50import Data.Sequence (Seq)
51import qualified Data.Sequence as Seq
52import Data.Set (Set)
53import qualified Data.Set as Set
54import Data.Text (Text)
55import qualified Data.Text as Text
56import Data.Text.Encoding (encodeUtf8)
57import qualified Data.Text.IO as Text
58import Data.Time (defaultTimeLocale, formatTime, getCurrentTime)
59import Data.Time.Clock (UTCTime)
60import GHC.Generics (Generic)
61import 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 )
79import System.Directory (XdgDirectory (XdgCache), getXdgDirectory)
80import System.Environment (getArgs)
81import System.Exit (die)
82import System.Process (readProcess)
83import Prelude hiding (id)
84import Data.List (sortOn)
85import Control.Concurrent.Async (concurrently)
86import Control.Exception (evaluate)
87import qualified Data.IntMap.Lazy as IntMap
88import qualified Data.IntSet as IntSet
89import Data.Bifunctor (second)
90import Data.Data (Proxy)
91import Data.ByteString (ByteString)
92import qualified Data.ByteString.Char8 as ByteString
93import Distribution.Simple.Utils (safeLast, fromUTF8BS)
94
95newtype JobsetEvals = JobsetEvals
96 { evals :: Seq Eval
97 }
98 deriving stock (Generic, Show)
99 deriving anyclass (ToJSON, FromJSON)
100
101newtype Nixpkgs = Nixpkgs {revision :: Text}
102 deriving stock (Generic, Show)
103 deriving anyclass (ToJSON, FromJSON)
104
105newtype JobsetEvalInputs = JobsetEvalInputs {nixpkgs :: Nixpkgs}
106 deriving stock (Generic, Show)
107 deriving anyclass (ToJSON, FromJSON)
108
109data 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"@
123newtype 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'.
132data 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
156data HydraSlownessWorkaroundFlag = HydraSlownessWorkaround | NoHydraSlownessWorkaround
157data RequestLogsFlag = RequestLogs | NoRequestLogs
158
159usage :: IO a
160usage = die "Usage: get-report [--slow] [EVAL-ID] | ping-maintainers | mark-broken-list [--no-request-logs] | eval-info"
161
162main :: IO ()
163main = 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
174reportFileName :: IO FilePath
175reportFileName = getXdgDirectory XdgCache "haskell-updates-build-report.json"
176
177showT :: Show a => a -> Text
178showT = Text.pack . show
179
180getBuildReports :: HydraSlownessWorkaroundFlag -> [String] -> IO ()
181getBuildReports 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
196getEvalBuilds :: HydraSlownessWorkaroundFlag -> Eval -> Req (Seq Build)
197getEvalBuilds NoHydraSlownessWorkaround Eval{id} =
198 hydraJSONQuery mempty ["eval", showT id, "builds"]
199getEvalBuilds HydraSlownessWorkaround Eval{builds} = do
200 forM builds $ \buildId -> do
201 liftIO $ putStrLn $ "Querying build " <> show buildId
202 hydraJSONQuery mempty [ "build", showT buildId ]
203
204hydraQuery :: HttpResponse a => Proxy a -> Option 'Https -> [Text] -> Req (HttpResponseBody a)
205hydraQuery 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
215hydraJSONQuery :: FromJSON a => Option 'Https -> [Text] -> Req a
216hydraJSONQuery = hydraQuery jsonResponse
217
218hydraPlainQuery :: [Text] -> Req ByteString
219hydraPlainQuery = hydraQuery bsResponse mempty
220
221hydraEvalCommand :: FilePath
222hydraEvalCommand = "hydra-eval-jobs"
223
224hydraEvalParams :: [String]
225hydraEvalParams = ["-I", ".", "pkgs/top-level/release-haskell.nix"]
226
227nixExprCommand :: FilePath
228nixExprCommand = "nix-instantiate"
229
230nixExprParams :: [String]
231nixExprParams = ["--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@.
239newtype 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.
258type 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-- @@
271type 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-- @@
283type MaintainerMap = Map JobName (NonEmpty Text)
284
285-- | Information about a package which lists its dependencies and whether the
286-- package is marked broken.
287data 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.
296type 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).
300type 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.
304calculateReverseDependencies :: DependencyMap -> ReverseDependencyMap
305calculateReverseDependencies 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.
336getMaintainerMap :: IO MaintainerMap
337getMaintainerMap = 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.
353getDependencyMap :: IO DependencyMap
354getDependencyMap =
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.
364readJSONProcess
365 :: FromJSON a
366 => FilePath -- ^ Filename of executable.
367 -> [String] -- ^ Arguments
368 -> String -- ^ String to prefix to JSON-decode error.
369 -> IO a
370readJSONProcess 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
378data 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
390icon :: BuildState -> Text
391icon = \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
402platformIcon :: Platform -> Text
403platformIcon (Platform x) = case x of
404 "x86_64-linux" -> "🐧"
405 "aarch64-linux" -> "📱"
406 "x86_64-darwin" -> "🍎"
407 "aarch64-darwin" -> "🍏"
408 _ -> x
409
410platformIsOS :: OS -> Platform -> Bool
411platformIsOS 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.
434newtype 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.
452newtype PkgSet = PkgSet Text
453 deriving stock (Generic, Show)
454 deriving newtype (Eq, FromJSON, FromJSONKey, Ord, ToJSON)
455
456data BuildResult = BuildResult {state :: BuildState, id :: Int} deriving (Show, Eq, Ord)
457newtype Platform = Platform {platform :: Text} deriving (Show, Eq, Ord)
458data SummaryEntry = SummaryEntry {
459 summaryBuilds :: Table PkgSet Platform BuildResult,
460 summaryMaintainers :: Set Text,
461 summaryReverseDeps :: Int,
462 summaryUnbrokenReverseDeps :: Int
463}
464type StatusSummary = Map PkgName SummaryEntry
465
466data OS = Linux | Darwin
467
468newtype Table row col a = Table (Map (row, col) a)
469
470singletonTable :: row -> col -> a -> Table row col a
471singletonTable row col a = Table $ Map.singleton (row, col) a
472
473unionTable :: (Ord row, Ord col) => Table row col a -> Table row col a -> Table row col a
474unionTable (Table l) (Table r) = Table $ Map.union l r
475
476filterWithKeyTable :: (row -> col -> a -> Bool) -> Table row col a -> Table row col a
477filterWithKeyTable f (Table t) = Table $ Map.filterWithKey (\(r,c) a -> f r c a) t
478
479nullTable :: Table row col a -> Bool
480nullTable (Table t) = Map.null t
481
482instance (Ord row, Ord col, Semigroup a) => Semigroup (Table row col a) where
483 Table l <> Table r = Table (Map.unionWith (<>) l r)
484instance (Ord row, Ord col, Semigroup a) => Monoid (Table row col a) where
485 mempty = Table Map.empty
486instance Functor (Table row col) where
487 fmap f (Table a) = Table (fmap f a)
488instance Foldable (Table row col) where
489 foldMap f (Table a) = foldMap f a
490
491getBuildState :: Build -> BuildState
492getBuildState 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
503combineStatusSummaries :: Seq StatusSummary -> StatusSummary
504combineStatusSummaries = 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
510buildToPkgNameAndSet :: Build -> (PkgName, PkgSet)
511buildToPkgNameAndSet 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
525buildToStatusSummary :: MaintainerMap -> ReverseDependencyMap -> Build -> StatusSummary
526buildToStatusSummary 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
543readBuildReports :: IO (Eval, UTCTime, Seq Build)
544readBuildReports = do
545 file <- reportFileName
546 fromMaybe (error $ "Could not decode " <> file) <$> decodeFileStrict' file
547
548sep :: Text
549sep = " | "
550joinTable :: [Text] -> Text
551joinTable t = sep <> Text.intercalate sep t <> sep
552
553type NumSummary = Table Platform BuildState Int
554
555printTable :: (Ord rows, Ord cols) => Text -> (rows -> Text) -> (cols -> Text) -> (entries -> Text) -> Table rows cols entries -> [Text]
556printTable 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
563printJob :: Int -> PkgName -> (Table PkgSet Platform BuildResult, Text) -> [Text]
564printJob 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
595makeSearchLink :: Int -> Text -> Text -> Text
596makeSearchLink evalId linkLabel query = "[" <> linkLabel <> "](" <> "https://hydra.nixos.org/eval/" <> showT evalId <> "?filter=" <> query <> ")"
597
598statusToNumSummary :: StatusSummary -> NumSummary
599statusToNumSummary = fmap getSum . foldMap (fmap Sum . jobTotals)
600
601jobTotals :: SummaryEntry -> Table Platform BuildState Int
602jobTotals (summaryBuilds -> Table mapping) = getSum <$> Table (Map.foldMapWithKey (\(_, platform) (BuildResult buildstate _) -> Map.singleton (platform, buildstate) (Sum 1)) mapping)
603
604details :: Text -> [Text] -> [Text]
605details summary content = ["<details><summary>" <> summary <> " </summary>", ""] <> content <> ["</details>", ""]
606
607evalLine :: Eval -> UTCTime -> Text
608evalLine 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
621printBuildSummary :: Eval -> UTCTime -> StatusSummary -> [(PkgName, Int)] -> Text
622printBuildSummary 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
781printEvalInfo :: IO ()
782printEvalInfo = do
783 (eval, fetchTime, _) <- readBuildReports
784 putStrLn (Text.unpack $ evalLine eval fetchTime)
785
786printMaintainerPing :: IO ()
787printMaintainerPing = 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
801printMarkBrokenList :: RequestLogsFlag -> IO ()
802printMarkBrokenList 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-}
821probableErrorCause :: ByteString -> Maybe String
822probableErrorCause "Setup: Encountered missing or private dependencies:" = Just "dependency missing"
823probableErrorCause "running tests" = Just "test failure"
824probableErrorCause build_line | ByteString.isPrefixOf "Building" build_line = Just ("failure building " <> fromUTF8BS (fst $ ByteString.breakSubstring " for" $ ByteString.drop 9 build_line))
825probableErrorCause build_line | ByteString.isSuffixOf "Phase" build_line = Just ("failure in " <> fromUTF8BS build_line)
826probableErrorCause _ = Nothing