From 11a26e59cc4282b2292730b83433369191134eb2 Mon Sep 17 00:00:00 2001 From: Tijmen de Jong Date: Mon, 20 Apr 2026 13:36:40 +0200 Subject: [PATCH 1/2] Add attempted merge and hotfix metrics --- src/Logic.hs | 27 +++++++++++++++- src/Metrics.hs | 72 ++++++++++++++++++++++++++++++++++++++++++ tests/EventLoopSpec.hs | 3 ++ tests/Spec.hs | 3 ++ 4 files changed, 104 insertions(+), 1 deletion(-) diff --git a/src/Logic.hs b/src/Logic.hs index 9ca3c155..9e65b9ab 100644 --- a/src/Logic.hs +++ b/src/Logic.hs @@ -79,7 +79,14 @@ import Git ( ) import GithubApi (GithubOperation) -import Metrics (MetricsOperation, increaseMergedPRTotal, updateTrainSizeGauge) +import Metrics ( + MetricsOperation, + increaseMergeAttemptedPRTotal, + increaseMergedPRTotal, + increasePriorityMergeAttemptedPRTotal, + increasePriorityMergedPRTotal, + updateTrainSizeGauge, + ) import Parser (ParseResult (..), hoffIgnoreComment, isSuccess, parseMergeCommand, shouldIgnoreComment) import Project ( Approval (..), @@ -130,6 +137,9 @@ data Action :: Effect where GetOpenPullRequests :: Action m (Maybe IntSet) GetLatestVersion :: Sha -> Action m (Either TagName Integer) GetChangelog :: TagName -> Sha -> Action m (Maybe Text) + IncreaseMergeAttemptedMetric :: Action m () + IncreasePriorityMergeAttemptedMetric :: Action m () + IncreasePriorityMergeMetric :: Action m () IncreaseMergeMetric :: Action m () UpdateTrainSizeMetric :: Int -> Action m () @@ -224,6 +234,15 @@ getProjectConfig = send GetProjectConfig registerMergedPR :: Action :> es => Eff es () registerMergedPR = send IncreaseMergeMetric +registerMergeAttemptedPR :: Action :> es => Eff es () +registerMergeAttemptedPR = send IncreaseMergeAttemptedMetric + +registerPriorityMergeAttemptedPR :: Action :> es => Eff es () +registerPriorityMergeAttemptedPR = send IncreasePriorityMergeAttemptedMetric + +registerPriorityMergedPR :: Action :> es => Eff es () +registerPriorityMergedPR = send IncreasePriorityMergeMetric + triggerTrainSizeUpdate :: Action :> es => ProjectState -> Eff es () triggerTrainSizeUpdate projectState = do let n = IntMap.size $ IntMap.filter Pr.isInProgress (Pr.pullRequests projectState) @@ -293,6 +312,9 @@ runAction config = maybe (Right 0) (\t -> maybeToEither t $ parseVersion t) <$> Git.lastTag sha GetChangelog prevTag curHead -> Git.shortlog (AsRefSpec prevTag) (AsRefSpec curHead) + IncreaseMergeAttemptedMetric -> increaseMergeAttemptedPRTotal + IncreasePriorityMergeAttemptedMetric -> increasePriorityMergeAttemptedPRTotal + IncreasePriorityMergeMetric -> increasePriorityMergedPRTotal IncreaseMergeMetric -> increaseMergedPRTotal UpdateTrainSizeMetric n -> updateTrainSizeGauge n where @@ -513,6 +535,8 @@ tryPromotePullRequest pullRequest state = return (Pr.updatePullRequest prId (\pr' -> pr'{Pr.pausedMessageSent = True}) state) _ -> pure state else do + registerMergeAttemptedPR + when (priority == High) registerPriorityMergeAttemptedPR pushResult <- case Pr.integrationStatus pullRequest of -- If we only need to promote, we can just try pushing. Pr.Promote _ sha -> tryPromote sha @@ -546,6 +570,7 @@ tryPromotePullRequest pullRequest state = PushOk -> do cleanupTestBranch prId registerMergedPR + when (priority == High) registerPriorityMergedPR currTime <- getDateTime pure $ Pr.updatePullRequests (unspeculateConflictsAfter pullRequest) $ diff --git a/src/Metrics.hs b/src/Metrics.hs index af2bf991..5b78e7ba 100644 --- a/src/Metrics.hs +++ b/src/Metrics.hs @@ -8,6 +8,9 @@ module Metrics ( MetricsOperation (..), ProjectMetrics (..), runMetrics, + increaseMergeAttemptedPRTotal, + increasePriorityMergeAttemptedPRTotal, + increasePriorityMergedPRTotal, increaseMergedPRTotal, updateTrainSizeGauge, registerGHCMetrics, @@ -27,11 +30,17 @@ type ProjectLabel = Text data ProjectMetrics = ProjectMetrics { projectMetricsMergedPR :: Vector ProjectLabel Counter + , projectMetricsMergeAttemptedPR :: Vector ProjectLabel Counter + , projectMetricsPriorityMergeAttemptedPR :: Vector ProjectLabel Counter + , projectMetricsPriorityMergedPR :: Vector ProjectLabel Counter , projectMetricsMergeTrainSize :: Vector ProjectLabel Gauge } data MetricsOperation :: Effect where MergeBranch :: MetricsOperation m () + MergeAttemptedBranch :: MetricsOperation m () + PriorityMergeAttemptedBranch :: MetricsOperation m () + PriorityMergeBranch :: MetricsOperation m () UpdateTrainSize :: Int -> MetricsOperation m () type instance DispatchOf MetricsOperation = 'Dynamic @@ -39,6 +48,15 @@ type instance DispatchOf MetricsOperation = 'Dynamic increaseMergedPRTotal :: MetricsOperation :> es => Eff es () increaseMergedPRTotal = send MergeBranch +increaseMergeAttemptedPRTotal :: MetricsOperation :> es => Eff es () +increaseMergeAttemptedPRTotal = send MergeAttemptedBranch + +increasePriorityMergeAttemptedPRTotal :: MetricsOperation :> es => Eff es () +increasePriorityMergeAttemptedPRTotal = send PriorityMergeAttemptedBranch + +increasePriorityMergedPRTotal :: MetricsOperation :> es => Eff es () +increasePriorityMergedPRTotal = send PriorityMergeBranch + updateTrainSizeGauge :: MetricsOperation :> es => Int -> Eff es () updateTrainSizeGauge n = send $ UpdateTrainSize n @@ -57,6 +75,18 @@ runMetrics metrics label = interpret $ \_ -> \case void $ liftIO $ incProjectMergedPR metrics label + MergeAttemptedBranch -> + void $ + liftIO $ + incProjectMergeAttemptedPR metrics label + PriorityMergeAttemptedBranch -> + void $ + liftIO $ + incProjectPriorityMergeAttemptedPR metrics label + PriorityMergeBranch -> + void $ + liftIO $ + incProjectPriorityMergedPR metrics label registerGHCMetrics :: IO () registerGHCMetrics = void $ register ghcMetrics @@ -74,6 +104,36 @@ registerProjectMetrics = ) ) ) + <*> register + ( vector + "project" + ( counter + ( Info + "hoff_project_merge_attempted_pull_requests" + "Number of pull request merges attempted" + ) + ) + ) + <*> register + ( vector + "project" + ( counter + ( Info + "hoff_project_priority_merge_attempted_pull_requests" + "Number of priority pull request merges attempted" + ) + ) + ) + <*> register + ( vector + "project" + ( counter + ( Info + "hoff_project_priority_merged_pull_requests" + "Number of merged priority pull requests" + ) + ) + ) <*> register ( vector "project" @@ -89,6 +149,18 @@ incProjectMergedPR :: ProjectMetrics -> ProjectLabel -> IO () incProjectMergedPR metrics project = withLabel (projectMetricsMergedPR metrics) project incCounter +incProjectMergeAttemptedPR :: ProjectMetrics -> ProjectLabel -> IO () +incProjectMergeAttemptedPR metrics project = + withLabel (projectMetricsMergeAttemptedPR metrics) project incCounter + +incProjectPriorityMergeAttemptedPR :: ProjectMetrics -> ProjectLabel -> IO () +incProjectPriorityMergeAttemptedPR metrics project = + withLabel (projectMetricsPriorityMergeAttemptedPR metrics) project incCounter + +incProjectPriorityMergedPR :: ProjectMetrics -> ProjectLabel -> IO () +incProjectPriorityMergedPR metrics project = + withLabel (projectMetricsPriorityMergedPR metrics) project incCounter + setProjectMetricMergeTrainSize :: ProjectMetrics -> ProjectLabel -> Int -> IO () setProjectMetricMergeTrainSize metrics project n = withLabel (projectMetricsMergeTrainSize metrics) project (\g -> setGauge g (fromIntegral n)) diff --git a/tests/EventLoopSpec.hs b/tests/EventLoopSpec.hs index 97771b5a..a4f6a555 100644 --- a/tests/EventLoopSpec.hs +++ b/tests/EventLoopSpec.hs @@ -274,6 +274,9 @@ fakeRunTime = interpret $ \_ -> \case fakeRunMetrics :: Eff (MetricsOperation : es) a -> Eff es a fakeRunMetrics = interpret $ \_ -> \case MergeBranch -> pure () + MergeAttemptedBranch -> pure () + PriorityMergeAttemptedBranch -> pure () + PriorityMergeBranch -> pure () UpdateTrainSize _ -> pure () fakeRunLogger :: Eff (MonadLoggerEffect : es) a -> Eff es a diff --git a/tests/Spec.hs b/tests/Spec.hs index 54dd9962..3fe34e3b 100644 --- a/tests/Spec.hs +++ b/tests/Spec.hs @@ -299,6 +299,9 @@ runActionResults = takeResultGetOpenPullRequests GetLatestVersion _ -> takeResultGetLatestVersion GetChangelog _ _ -> takeResultGetChangelog + IncreaseMergeAttemptedMetric -> pure () + IncreasePriorityMergeAttemptedMetric -> pure () + IncreasePriorityMergeMetric -> pure () IncreaseMergeMetric -> pure () UpdateTrainSizeMetric n -> do results <- State.get From d3854d69b2bc7e003cd3f8dd12d30a6b95a02915 Mon Sep 17 00:00:00 2001 From: Tijmen de Jong Date: Fri, 24 Apr 2026 15:55:01 +0200 Subject: [PATCH 2/2] Make priority a label --- src/Logic.hs | 20 ++++++++----------- src/Metrics.hs | 45 +++++++++++------------------------------- tests/EventLoopSpec.hs | 3 +-- tests/Spec.hs | 3 +-- 4 files changed, 21 insertions(+), 50 deletions(-) diff --git a/src/Logic.hs b/src/Logic.hs index 9e65b9ab..2dbdbaf3 100644 --- a/src/Logic.hs +++ b/src/Logic.hs @@ -83,7 +83,6 @@ import Metrics ( MetricsOperation, increaseMergeAttemptedPRTotal, increaseMergedPRTotal, - increasePriorityMergeAttemptedPRTotal, increasePriorityMergedPRTotal, updateTrainSizeGauge, ) @@ -137,8 +136,7 @@ data Action :: Effect where GetOpenPullRequests :: Action m (Maybe IntSet) GetLatestVersion :: Sha -> Action m (Either TagName Integer) GetChangelog :: TagName -> Sha -> Action m (Maybe Text) - IncreaseMergeAttemptedMetric :: Action m () - IncreasePriorityMergeAttemptedMetric :: Action m () + IncreaseMergeAttemptedMetric :: Priority -> Action m () IncreasePriorityMergeMetric :: Action m () IncreaseMergeMetric :: Action m () UpdateTrainSizeMetric :: Int -> Action m () @@ -234,11 +232,8 @@ getProjectConfig = send GetProjectConfig registerMergedPR :: Action :> es => Eff es () registerMergedPR = send IncreaseMergeMetric -registerMergeAttemptedPR :: Action :> es => Eff es () -registerMergeAttemptedPR = send IncreaseMergeAttemptedMetric - -registerPriorityMergeAttemptedPR :: Action :> es => Eff es () -registerPriorityMergeAttemptedPR = send IncreasePriorityMergeAttemptedMetric +registerMergeAttemptedPR :: Action :> es => Priority -> Eff es () +registerMergeAttemptedPR priority = send $ IncreaseMergeAttemptedMetric priority registerPriorityMergedPR :: Action :> es => Eff es () registerPriorityMergedPR = send IncreasePriorityMergeMetric @@ -312,8 +307,10 @@ runAction config = maybe (Right 0) (\t -> maybeToEither t $ parseVersion t) <$> Git.lastTag sha GetChangelog prevTag curHead -> Git.shortlog (AsRefSpec prevTag) (AsRefSpec curHead) - IncreaseMergeAttemptedMetric -> increaseMergeAttemptedPRTotal - IncreasePriorityMergeAttemptedMetric -> increasePriorityMergeAttemptedPRTotal + IncreaseMergeAttemptedMetric priority -> + increaseMergeAttemptedPRTotal $ case priority of + Normal -> "normal" + High -> "high" IncreasePriorityMergeMetric -> increasePriorityMergedPRTotal IncreaseMergeMetric -> increaseMergedPRTotal UpdateTrainSizeMetric n -> updateTrainSizeGauge n @@ -535,8 +532,7 @@ tryPromotePullRequest pullRequest state = return (Pr.updatePullRequest prId (\pr' -> pr'{Pr.pausedMessageSent = True}) state) _ -> pure state else do - registerMergeAttemptedPR - when (priority == High) registerPriorityMergeAttemptedPR + registerMergeAttemptedPR priority pushResult <- case Pr.integrationStatus pullRequest of -- If we only need to promote, we can just try pushing. Pr.Promote _ sha -> tryPromote sha diff --git a/src/Metrics.hs b/src/Metrics.hs index 5b78e7ba..64e1d180 100644 --- a/src/Metrics.hs +++ b/src/Metrics.hs @@ -9,7 +9,6 @@ module Metrics ( ProjectMetrics (..), runMetrics, increaseMergeAttemptedPRTotal, - increasePriorityMergeAttemptedPRTotal, increasePriorityMergedPRTotal, increaseMergedPRTotal, updateTrainSizeGauge, @@ -27,19 +26,18 @@ import Prometheus import Prometheus.Metric.GHC (ghcMetrics) type ProjectLabel = Text +type PriorityLabel = Text data ProjectMetrics = ProjectMetrics { projectMetricsMergedPR :: Vector ProjectLabel Counter - , projectMetricsMergeAttemptedPR :: Vector ProjectLabel Counter - , projectMetricsPriorityMergeAttemptedPR :: Vector ProjectLabel Counter + , projectMetricsMergeAttemptedPR :: Vector (ProjectLabel, PriorityLabel) Counter , projectMetricsPriorityMergedPR :: Vector ProjectLabel Counter , projectMetricsMergeTrainSize :: Vector ProjectLabel Gauge } data MetricsOperation :: Effect where MergeBranch :: MetricsOperation m () - MergeAttemptedBranch :: MetricsOperation m () - PriorityMergeAttemptedBranch :: MetricsOperation m () + MergeAttemptedBranch :: PriorityLabel -> MetricsOperation m () PriorityMergeBranch :: MetricsOperation m () UpdateTrainSize :: Int -> MetricsOperation m () @@ -48,11 +46,8 @@ type instance DispatchOf MetricsOperation = 'Dynamic increaseMergedPRTotal :: MetricsOperation :> es => Eff es () increaseMergedPRTotal = send MergeBranch -increaseMergeAttemptedPRTotal :: MetricsOperation :> es => Eff es () -increaseMergeAttemptedPRTotal = send MergeAttemptedBranch - -increasePriorityMergeAttemptedPRTotal :: MetricsOperation :> es => Eff es () -increasePriorityMergeAttemptedPRTotal = send PriorityMergeAttemptedBranch +increaseMergeAttemptedPRTotal :: MetricsOperation :> es => PriorityLabel -> Eff es () +increaseMergeAttemptedPRTotal priority = send $ MergeAttemptedBranch priority increasePriorityMergedPRTotal :: MetricsOperation :> es => Eff es () increasePriorityMergedPRTotal = send PriorityMergeBranch @@ -75,14 +70,10 @@ runMetrics metrics label = interpret $ \_ -> \case void $ liftIO $ incProjectMergedPR metrics label - MergeAttemptedBranch -> - void $ - liftIO $ - incProjectMergeAttemptedPR metrics label - PriorityMergeAttemptedBranch -> + MergeAttemptedBranch priority -> void $ liftIO $ - incProjectPriorityMergeAttemptedPR metrics label + incProjectMergeAttemptedPR metrics label priority PriorityMergeBranch -> void $ liftIO $ @@ -106,7 +97,7 @@ registerProjectMetrics = ) <*> register ( vector - "project" + ("project", "priority") ( counter ( Info "hoff_project_merge_attempted_pull_requests" @@ -114,16 +105,6 @@ registerProjectMetrics = ) ) ) - <*> register - ( vector - "project" - ( counter - ( Info - "hoff_project_priority_merge_attempted_pull_requests" - "Number of priority pull request merges attempted" - ) - ) - ) <*> register ( vector "project" @@ -149,13 +130,9 @@ incProjectMergedPR :: ProjectMetrics -> ProjectLabel -> IO () incProjectMergedPR metrics project = withLabel (projectMetricsMergedPR metrics) project incCounter -incProjectMergeAttemptedPR :: ProjectMetrics -> ProjectLabel -> IO () -incProjectMergeAttemptedPR metrics project = - withLabel (projectMetricsMergeAttemptedPR metrics) project incCounter - -incProjectPriorityMergeAttemptedPR :: ProjectMetrics -> ProjectLabel -> IO () -incProjectPriorityMergeAttemptedPR metrics project = - withLabel (projectMetricsPriorityMergeAttemptedPR metrics) project incCounter +incProjectMergeAttemptedPR :: ProjectMetrics -> ProjectLabel -> PriorityLabel -> IO () +incProjectMergeAttemptedPR metrics project priority = + withLabel (projectMetricsMergeAttemptedPR metrics) (project, priority) incCounter incProjectPriorityMergedPR :: ProjectMetrics -> ProjectLabel -> IO () incProjectPriorityMergedPR metrics project = diff --git a/tests/EventLoopSpec.hs b/tests/EventLoopSpec.hs index a4f6a555..19ae95c8 100644 --- a/tests/EventLoopSpec.hs +++ b/tests/EventLoopSpec.hs @@ -274,8 +274,7 @@ fakeRunTime = interpret $ \_ -> \case fakeRunMetrics :: Eff (MetricsOperation : es) a -> Eff es a fakeRunMetrics = interpret $ \_ -> \case MergeBranch -> pure () - MergeAttemptedBranch -> pure () - PriorityMergeAttemptedBranch -> pure () + MergeAttemptedBranch _ -> pure () PriorityMergeBranch -> pure () UpdateTrainSize _ -> pure () diff --git a/tests/Spec.hs b/tests/Spec.hs index 3fe34e3b..5a88a33c 100644 --- a/tests/Spec.hs +++ b/tests/Spec.hs @@ -299,8 +299,7 @@ runActionResults = takeResultGetOpenPullRequests GetLatestVersion _ -> takeResultGetLatestVersion GetChangelog _ _ -> takeResultGetChangelog - IncreaseMergeAttemptedMetric -> pure () - IncreasePriorityMergeAttemptedMetric -> pure () + IncreaseMergeAttemptedMetric _ -> pure () IncreasePriorityMergeMetric -> pure () IncreaseMergeMetric -> pure () UpdateTrainSizeMetric n -> do