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,
+  increaseMergedPRTotal,
+  increasePriorityMergedPRTotal,
+  updateTrainSizeGauge,
+ )
 import Parser (ParseResult (..), hoffIgnoreComment, isSuccess, parseMergeCommand, shouldIgnoreComment)
 import Project (
   Approval (..),
@@ -130,6 +136,8 @@ data Action :: Effect where
   GetOpenPullRequests :: Action m (Maybe IntSet)
   GetLatestVersion :: Sha -> Action m (Either TagName Integer)
   GetChangelog :: TagName -> Sha -> Action m (Maybe Text)
+  IncreaseMergeAttemptedMetric :: Priority -> Action m ()
+  IncreasePriorityMergeMetric :: Action m ()
   IncreaseMergeMetric :: Action m ()
   UpdateTrainSizeMetric :: Int -> Action m ()
 
@@ -224,6 +232,12 @@ getProjectConfig = send GetProjectConfig
 registerMergedPR :: Action :> es => Eff es ()
 registerMergedPR = send IncreaseMergeMetric
 
+registerMergeAttemptedPR :: Action :> es => Priority -> Eff es ()
+registerMergeAttemptedPR priority = send $ IncreaseMergeAttemptedMetric priority
+
+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 +307,11 @@ runAction config =
       maybe (Right 0) (\t -> maybeToEither t $ parseVersion t) <$> Git.lastTag sha
     GetChangelog prevTag curHead ->
       Git.shortlog (AsRefSpec prevTag) (AsRefSpec curHead)
+    IncreaseMergeAttemptedMetric priority ->
+      increaseMergeAttemptedPRTotal $ case priority of
+        Normal -> "normal"
+        High -> "high"
+    IncreasePriorityMergeMetric -> increasePriorityMergedPRTotal
     IncreaseMergeMetric -> increaseMergedPRTotal
     UpdateTrainSizeMetric n -> updateTrainSizeGauge n
  where
@@ -513,6 +532,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
@@ -546,6 +566,7 @@ tryPromotePullRequest pullRequest state =
           PushOk -> do
             cleanupTestBranch prId
             registerMergedPR
+            when (priority == High) registerPriorityMergedPR
             currTime <- getDateTime
             pure $
               Pr.updatePullRequests (unspeculateConflictsAfter pullRequest) $

src/Metrics.hs

@@ -8,6 +8,8 @@ module Metrics (
   MetricsOperation (..),
   ProjectMetrics (..),
   runMetrics,
+  increaseMergeAttemptedPRTotal,
+  increasePriorityMergedPRTotal,
   increaseMergedPRTotal,
   updateTrainSizeGauge,
   registerGHCMetrics,
@@ -24,21 +26,32 @@ import Prometheus
 import Prometheus.Metric.GHC (ghcMetrics)
 
 type ProjectLabel = Text
+type PriorityLabel = Text
 
 data ProjectMetrics = ProjectMetrics
   { projectMetricsMergedPR :: Vector ProjectLabel Counter
+  , projectMetricsMergeAttemptedPR :: Vector (ProjectLabel, PriorityLabel) Counter
+  , projectMetricsPriorityMergedPR :: Vector ProjectLabel Counter
   , projectMetricsMergeTrainSize :: Vector ProjectLabel Gauge
   }
 
 data MetricsOperation :: Effect where
   MergeBranch :: MetricsOperation m ()
+  MergeAttemptedBranch :: PriorityLabel -> MetricsOperation m ()
+  PriorityMergeBranch :: MetricsOperation m ()
   UpdateTrainSize :: Int -> MetricsOperation m ()
 
 type instance DispatchOf MetricsOperation = 'Dynamic
 
 increaseMergedPRTotal :: MetricsOperation :> es => Eff es ()
 increaseMergedPRTotal = send MergeBranch
 
+increaseMergeAttemptedPRTotal :: MetricsOperation :> es => PriorityLabel -> Eff es ()
+increaseMergeAttemptedPRTotal priority = send $ MergeAttemptedBranch priority
+
+increasePriorityMergedPRTotal :: MetricsOperation :> es => Eff es ()
+increasePriorityMergedPRTotal = send PriorityMergeBranch
+
 updateTrainSizeGauge :: MetricsOperation :> es => Int -> Eff es ()
 updateTrainSizeGauge n = send $ UpdateTrainSize n
 
@@ -57,6 +70,14 @@ runMetrics metrics label = interpret $ \_ -> \case
     void $
       liftIO $
         incProjectMergedPR metrics label
+  MergeAttemptedBranch priority ->
+    void $
+      liftIO $
+        incProjectMergeAttemptedPR metrics label priority
+  PriorityMergeBranch ->
+    void $
+      liftIO $
+        incProjectPriorityMergedPR metrics label
 
 registerGHCMetrics :: IO ()
 registerGHCMetrics = void $ register ghcMetrics
@@ -74,6 +95,26 @@ registerProjectMetrics =
               )
           )
       )
+    <*> register
+      ( vector
+          ("project", "priority")
+          ( counter
+              ( Info
+                  "hoff_project_merge_attempted_pull_requests"
+                  "Number of 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 +130,14 @@ incProjectMergedPR :: ProjectMetrics -> ProjectLabel -> IO ()
 incProjectMergedPR metrics project =
   withLabel (projectMetricsMergedPR 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 =
+  withLabel (projectMetricsPriorityMergedPR metrics) project incCounter
+
 setProjectMetricMergeTrainSize :: ProjectMetrics -> ProjectLabel -> Int -> IO ()
 setProjectMetricMergeTrainSize metrics project n =
   withLabel (projectMetricsMergeTrainSize metrics) project (\g -> setGauge g (fromIntegral n))

tests/EventLoopSpec.hs

@@ -274,6 +274,8 @@ fakeRunTime = interpret $ \_ -> \case
 fakeRunMetrics :: Eff (MetricsOperation : es) a -> Eff es a
 fakeRunMetrics = interpret $ \_ -> \case
   MergeBranch -> pure ()
+  MergeAttemptedBranch _ -> pure ()
+  PriorityMergeBranch -> pure ()
   UpdateTrainSize _ -> pure ()
 
 fakeRunLogger :: Eff (MonadLoggerEffect : es) a -> Eff es a

tests/Spec.hs

@@ -299,6 +299,8 @@ runActionResults =
           takeResultGetOpenPullRequests
         GetLatestVersion _ -> takeResultGetLatestVersion
         GetChangelog _ _ -> takeResultGetChangelog
+        IncreaseMergeAttemptedMetric _ -> pure ()
+        IncreasePriorityMergeMetric -> pure ()
         IncreaseMergeMetric -> pure ()
         UpdateTrainSizeMetric n -> do
           results <- State.get