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