Add attempted merge and hotfix metrics

src/Logic.hs

@@ -79,7 +79,13 @@ import Git (
  )
 
 import GithubApi (GithubOperation)
-import Metrics (MetricsOperation, increaseMergedPRTotal, updateTrainSizeGauge)
+import Metrics (
+  MetricsOperation,
+  increaseMergeAttemptedPRTotal,
+  increaseMergeFailedPRTotal,
+  increaseMergedPRTotal,
+  updateTrainSizeGauge,
+ )
 import Parser (ParseResult (..), hoffIgnoreComment, isSuccess, parseMergeCommand, shouldIgnoreComment)
 import Project (
   Approval (..),
@@ -130,7 +136,9 @@ data Action :: Effect where
   GetOpenPullRequests :: Action m (Maybe IntSet)
   GetLatestVersion :: Sha -> Action m (Either TagName Integer)
   GetChangelog :: TagName -> Sha -> Action m (Maybe Text)
-  IncreaseMergeMetric :: Action m ()
+  IncreaseMergeAttemptedMetric :: Priority -> Action m ()
+  IncreaseMergeFailedMetric :: Priority -> GitIntegrationFailure -> Action m ()
+  IncreaseMergeMetric :: Priority -> Action m ()
   UpdateTrainSizeMetric :: Int -> Action m ()
 
 type instance DispatchOf Action = 'Dynamic
@@ -221,8 +229,14 @@ getBaseBranch = send GetBaseBranch
 getProjectConfig :: RetrieveEnvironment :> es => Eff es ProjectConfiguration
 getProjectConfig = send GetProjectConfig
 
-registerMergedPR :: Action :> es => Eff es ()
-registerMergedPR = send IncreaseMergeMetric
+registerMergedPR :: Action :> es => Priority -> Eff es ()
+registerMergedPR priority = send $ IncreaseMergeMetric priority
+
+registerMergeAttemptedPR :: Action :> es => Priority -> Eff es ()
+registerMergeAttemptedPR priority = send $ IncreaseMergeAttemptedMetric priority
+
+registerMergeFailedPR :: Action :> es => Priority -> GitIntegrationFailure -> Eff es ()
+registerMergeFailedPR priority reason = send $ IncreaseMergeFailedMetric priority reason
 
 triggerTrainSizeUpdate :: Action :> es => ProjectState -> Eff es ()
 triggerTrainSizeUpdate projectState = do
@@ -293,7 +307,27 @@ runAction config =
       maybe (Right 0) (\t -> maybeToEither t $ parseVersion t) <$> Git.lastTag sha
     GetChangelog prevTag curHead ->
       Git.shortlog (AsRefSpec prevTag) (AsRefSpec curHead)
-    IncreaseMergeMetric -> increaseMergedPRTotal
+    IncreaseMergeAttemptedMetric priority ->
+      increaseMergeAttemptedPRTotal $ case priority of
+        Normal -> "normal"
+        High -> "high"
+    IncreaseMergeFailedMetric priority reason ->
+      increaseMergeFailedPRTotal
+        ( case priority of
+            Normal -> "normal"
+            High -> "high"
+        )
+        ( case reason of
+            MergeFailed -> "merge_failed"
+            RebaseFailed -> "rebase_failed"
+            WrongFixups -> "wrong_fixups"
+            EmptyRebase -> "empty_rebase"
+            FailedForcePush _ -> "failed_force_push"
+        )
+    IncreaseMergeMetric priority ->
+      increaseMergedPRTotal $ case priority of
+        Normal -> "normal"
+        High -> "high"
     UpdateTrainSizeMetric n -> updateTrainSizeGauge n
  where
   trainBranch :: [PullRequestId] -> Maybe Git.Branch
@@ -513,6 +547,7 @@ tryPromotePullRequest pullRequest state =
             return (Pr.updatePullRequest prId (\pr' -> pr'{Pr.pausedMessageSent = True}) state)
           _ -> pure state
       else do
+        registerMergeAttemptedPR priority
         pushResult <- case Pr.integrationStatus pullRequest of
           -- If we only need to promote, we can just try pushing.
           Pr.Promote _ sha -> tryPromote sha
@@ -545,7 +580,7 @@ tryPromotePullRequest pullRequest state =
           -- the integration candidate, so we proceed with the next pull request.
           PushOk -> do
             cleanupTestBranch prId
-            registerMergedPR
+            registerMergedPR priority
             currTime <- getDateTime
             pure $
               Pr.updatePullRequests (unspeculateConflictsAfter pullRequest) $
@@ -1175,11 +1210,12 @@ tryIntegratePullRequest pr state =
     do
       result <- tryIntegrate mergeMessage candidate (map Pr.pullRequestId train) $ Pr.alwaysAddMergeCommit approvalType
       case result of
-        Left (IntegrationFailure targetBranch reason) ->
+        Left (IntegrationFailure targetBranch reason) -> do
           -- If integrating failed, perform no further actions but do set the
           -- state to conflicted.
           -- If this is a speculative rebase, we wait before giving feedback.
           -- For WrongFixups, we can report issues right away.
+          registerMergeFailedPR priority reason
           pure $
             Pr.setIntegrationStatus prId (Conflicted targetBranch reason) $
               Pr.setNeedsFeedback prId (null train || reason == WrongFixups) state

src/Metrics.hs

@@ -8,6 +8,8 @@ module Metrics (
   MetricsOperation (..),
   ProjectMetrics (..),
   runMetrics,
+  increaseMergeAttemptedPRTotal,
+  increaseMergeFailedPRTotal,
   increaseMergedPRTotal,
   updateTrainSizeGauge,
   registerGHCMetrics,
@@ -24,20 +26,32 @@ import Prometheus
 import Prometheus.Metric.GHC (ghcMetrics)
 
 type ProjectLabel = Text
+type PriorityLabel = Text
+type ReasonLabel = Text
 
 data ProjectMetrics = ProjectMetrics
-  { projectMetricsMergedPR :: Vector ProjectLabel Counter
+  { projectMetricsMergedPR :: Vector (ProjectLabel, PriorityLabel) Counter
+  , projectMetricsMergeAttemptedPR :: Vector (ProjectLabel, PriorityLabel) Counter
+  , projectMetricsMergeFailedPR :: Vector (ProjectLabel, PriorityLabel, ReasonLabel) Counter
   , projectMetricsMergeTrainSize :: Vector ProjectLabel Gauge
   }
 
 data MetricsOperation :: Effect where
-  MergeBranch :: MetricsOperation m ()
+  MergeBranch :: PriorityLabel -> MetricsOperation m ()
+  MergeAttemptedBranch :: PriorityLabel -> MetricsOperation m ()
+  MergeFailedBranch :: PriorityLabel -> ReasonLabel -> MetricsOperation m ()
   UpdateTrainSize :: Int -> MetricsOperation m ()
 
 type instance DispatchOf MetricsOperation = 'Dynamic
 
-increaseMergedPRTotal :: MetricsOperation :> es => Eff es ()
-increaseMergedPRTotal = send MergeBranch
+increaseMergedPRTotal :: MetricsOperation :> es => PriorityLabel -> Eff es ()
+increaseMergedPRTotal priority = send $ MergeBranch priority
+
+increaseMergeAttemptedPRTotal :: MetricsOperation :> es => PriorityLabel -> Eff es ()
+increaseMergeAttemptedPRTotal priority = send $ MergeAttemptedBranch priority
+
+increaseMergeFailedPRTotal :: MetricsOperation :> es => PriorityLabel -> ReasonLabel -> Eff es ()
+increaseMergeFailedPRTotal priority reason = send $ MergeFailedBranch priority reason
 
 updateTrainSizeGauge :: MetricsOperation :> es => Int -> Eff es ()
 updateTrainSizeGauge n = send $ UpdateTrainSize n
@@ -53,10 +67,18 @@ runMetrics metrics label = interpret $ \_ -> \case
     void $
       liftIO $
         setProjectMetricMergeTrainSize metrics label n
-  MergeBranch ->
+  MergeBranch priority ->
+    void $
+      liftIO $
+        incProjectMergedPR metrics label priority
+  MergeAttemptedBranch priority ->
+    void $
+      liftIO $
+        incProjectMergeAttemptedPR metrics label priority
+  MergeFailedBranch priority reason ->
     void $
       liftIO $
-        incProjectMergedPR metrics label
+        incProjectMergeFailedPR metrics label priority reason
 
 registerGHCMetrics :: IO ()
 registerGHCMetrics = void $ register ghcMetrics
@@ -66,14 +88,34 @@ registerProjectMetrics =
   ProjectMetrics
     <$> register
       ( vector
-          "project"
+          ("project", "priority")
           ( counter
               ( Info
                   "hoff_project_merged_pull_requests"
                   "Number of merged pull requests"
               )
           )
       )
+    <*> register
+      ( vector
+          ("project", "priority")
+          ( counter
+              ( Info
+                  "hoff_project_merge_attempted_pull_requests"
+                  "Number of pull request merges attempted"
+              )
+          )
+      )
+    <*> register
+      ( vector
+          ("project", "priority", "reason")
+          ( counter
+              ( Info
+                  "hoff_project_merge_failed_pull_requests"
+                  "Number of pull request merges that failed"
+              )
+          )
+      )
     <*> register
       ( vector
           "project"
@@ -85,9 +127,17 @@ registerProjectMetrics =
           )
       )
 
-incProjectMergedPR :: ProjectMetrics -> ProjectLabel -> IO ()
-incProjectMergedPR metrics project =
-  withLabel (projectMetricsMergedPR metrics) project incCounter
+incProjectMergedPR :: ProjectMetrics -> ProjectLabel -> PriorityLabel -> IO ()
+incProjectMergedPR metrics project priority =
+  withLabel (projectMetricsMergedPR metrics) (project, priority) incCounter
+
+incProjectMergeAttemptedPR :: ProjectMetrics -> ProjectLabel -> PriorityLabel -> IO ()
+incProjectMergeAttemptedPR metrics project priority =
+  withLabel (projectMetricsMergeAttemptedPR metrics) (project, priority) incCounter
+
+incProjectMergeFailedPR :: ProjectMetrics -> ProjectLabel -> PriorityLabel -> ReasonLabel -> IO ()
+incProjectMergeFailedPR metrics project priority reason =
+  withLabel (projectMetricsMergeFailedPR metrics) (project, priority, reason) incCounter
 
 setProjectMetricMergeTrainSize :: ProjectMetrics -> ProjectLabel -> Int -> IO ()
 setProjectMetricMergeTrainSize metrics project n =

tests/EventLoopSpec.hs

@@ -273,7 +273,9 @@ fakeRunTime = interpret $ \_ -> \case
 
 fakeRunMetrics :: Eff (MetricsOperation : es) a -> Eff es a
 fakeRunMetrics = interpret $ \_ -> \case
-  MergeBranch -> pure ()
+  MergeBranch _ -> pure ()
+  MergeAttemptedBranch _ -> pure ()
+  MergeFailedBranch _ _ -> pure ()
   UpdateTrainSize _ -> pure ()
 
 fakeRunLogger :: Eff (MonadLoggerEffect : es) a -> Eff es a

tests/Spec.hs

@@ -299,7 +299,9 @@ runActionResults =
           takeResultGetOpenPullRequests
         GetLatestVersion _ -> takeResultGetLatestVersion
         GetChangelog _ _ -> takeResultGetChangelog
-        IncreaseMergeMetric -> pure ()
+        IncreaseMergeAttemptedMetric _ -> pure ()
+        IncreaseMergeFailedMetric _ _ -> pure ()
+        IncreaseMergeMetric _ -> pure ()
         UpdateTrainSizeMetric n -> do
           results <- State.get
           State.put $ results{resultTrainSizeUpdates = n : resultTrainSizeUpdates results}