diff --git a/src/Logic.hs b/src/Logic.hs index 9ca3c155..2dbdbaf3 100644 --- a/src/Logic.hs +++ b/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) $ diff --git a/src/Metrics.hs b/src/Metrics.hs index af2bf991..64e1d180 100644 --- a/src/Metrics.hs +++ b/src/Metrics.hs @@ -8,6 +8,8 @@ module Metrics ( MetricsOperation (..), ProjectMetrics (..), runMetrics, + increaseMergeAttemptedPRTotal, + increasePriorityMergedPRTotal, increaseMergedPRTotal, updateTrainSizeGauge, registerGHCMetrics, @@ -24,14 +26,19 @@ 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 @@ -39,6 +46,12 @@ 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)) diff --git a/tests/EventLoopSpec.hs b/tests/EventLoopSpec.hs index 97771b5a..19ae95c8 100644 --- a/tests/EventLoopSpec.hs +++ b/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 diff --git a/tests/Spec.hs b/tests/Spec.hs index 54dd9962..5a88a33c 100644 --- a/tests/Spec.hs +++ b/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