hydra-report.hs: small formatting changes
This commit is contained in:
(cdep)illabout
parent
ea304f2d78
commit
39d04243e2
|
|
@ -17,6 +17,7 @@ Because step 1) is quite expensive and takes roughly ~5 minutes the result is ca
|
|||
{-# LANGUAGE BlockArguments #-}
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE DerivingStrategies #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE MultiWayIf #-}
|
||||
|
|
@ -36,8 +37,6 @@ import Data.Aeson (
|
|||
encodeFile,
|
||||
)
|
||||
import Data.Foldable (Foldable (toList), foldl')
|
||||
import Data.Function ((&))
|
||||
import Data.Functor ((<&>))
|
||||
import Data.List.NonEmpty (NonEmpty, nonEmpty)
|
||||
import qualified Data.List.NonEmpty as NonEmpty
|
||||
import Data.Map.Strict (Map)
|
||||
|
|
@ -71,7 +70,6 @@ import System.Directory (XdgDirectory (XdgCache), getXdgDirectory)
|
|||
import System.Environment (getArgs)
|
||||
import System.Process (readProcess)
|
||||
import Prelude hiding (id)
|
||||
import qualified Prelude
|
||||
|
||||
newtype JobsetEvals = JobsetEvals
|
||||
{ evals :: Seq Eval
|
||||
|
|
@ -132,30 +130,104 @@ getBuildReports = runReq defaultHttpConfig do
|
|||
|
||||
hydraEvalCommand :: FilePath
|
||||
hydraEvalCommand = "hydra-eval-jobs"
|
||||
|
||||
hydraEvalParams :: [String]
|
||||
hydraEvalParams = ["-I", ".", "pkgs/top-level/release-haskell.nix"]
|
||||
|
||||
handlesCommand :: FilePath
|
||||
handlesCommand = "nix-instantiate"
|
||||
|
||||
handlesParams :: [String]
|
||||
handlesParams = ["--eval", "--strict", "--json", "-"]
|
||||
|
||||
handlesExpression :: String
|
||||
handlesExpression = "with import ./. {}; with lib; zipAttrsWith (_: builtins.head) (mapAttrsToList (_: v: if v ? github then { \"${v.email}\" = v.github; } else {}) (import maintainers/maintainer-list.nix))"
|
||||
|
||||
newtype Maintainers = Maintainers {maintainers :: Maybe Text} deriving (Generic, ToJSON, FromJSON)
|
||||
newtype Maintainers = Maintainers {maintainers :: Text}
|
||||
deriving stock (Generic)
|
||||
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 "robert@example.com")
|
||||
-- , ("bench.x86_64-linux", Maintainers "")
|
||||
-- , ("conduit.x86_64-linux", Maintainers "snoy@man.com, web@ber.com")
|
||||
-- , ("lens.x86_64-darwin", Maintainers "ek@category.com")
|
||||
-- ]
|
||||
-- @@
|
||||
--
|
||||
-- Note that Hydra jobs without maintainers will have an empty string for the
|
||||
-- maintainer list.
|
||||
type HydraJobs = Map Text 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 Text (NonEmpty Text)
|
||||
|
||||
-- | Generate a mapping of Hydra job names to maintainer GitHub handles.
|
||||
getMaintainerMap :: IO MaintainerMap
|
||||
getMaintainerMap = do
|
||||
hydraJobs :: HydraJobs <- get hydraEvalCommand hydraEvalParams "" "Failed to decode hydra-eval-jobs output: "
|
||||
handlesMap :: Map Text Text <- get handlesCommand handlesParams handlesExpression "Failed to decode nix output for lookup of github handles: "
|
||||
pure $ hydraJobs & Map.mapMaybe (nonEmpty . mapMaybe (`Map.lookup` handlesMap) . Text.splitOn ", " . fromMaybe "" . maintainers)
|
||||
where
|
||||
get c p i e = readProcess c p i <&> \x -> either (error . (<> " Raw:'" <> take 1000 x <> "'") . (e <>)) Prelude.id . eitherDecodeStrict' . encodeUtf8 . Text.pack $ x
|
||||
hydraJobs :: HydraJobs <-
|
||||
readJSONProcess hydraEvalCommand hydraEvalParams "" "Failed to decode hydra-eval-jobs output: "
|
||||
handlesMap :: EmailToGitHubHandles <-
|
||||
readJSONProcess handlesCommand handlesParams handlesExpression "Failed to decode nix output for lookup of github handles: "
|
||||
pure $ Map.mapMaybe (nonEmpty . mapMaybe (`Map.lookup` handlesMap) . Text.splitOn ", " . maintainers) hydraJobs
|
||||
|
||||
-- | 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 -- ^ stdin to pass to the process
|
||||
-> String -- ^ String to prefix to JSON-decode error.
|
||||
-> IO a
|
||||
readJSONProcess exe args input err = do
|
||||
output <- readProcess exe args input
|
||||
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 (Show, Eq, Ord)
|
||||
data BuildState
|
||||
= Failed
|
||||
| DependencyFailed
|
||||
| OutputLimitExceeded
|
||||
| Unknown (Maybe Int)
|
||||
| TimedOut
|
||||
| Canceled
|
||||
| HydraFailure
|
||||
| Unfinished
|
||||
| Success
|
||||
deriving stock (Show, Eq, Ord)
|
||||
|
||||
icon :: BuildState -> Text
|
||||
icon = \case
|
||||
|
|
|
|||
Loading…
Reference in New Issue