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