hydra-report.hs: small formatting changes

This commit is contained in:
(cdep)illabout 2021-05-15 15:53:19 +09:00
parent ea304f2d78
commit 39d04243e2
No known key found for this signature in database
GPG key ID: 462E0C03D11422F4

View file

@ -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