Implement using reactions for confirmation in most cases

isomorpheme · isomorpheme · commit b0b517121c98 · 2024-09-11T11:59:54.000+02:00
diff --git a/src/Logic.hs b/src/Logic.hs
@@ -1152,79 +1152,116 @@ proceedUntilFixedPoint state = do
     then return state
     else proceedUntilFixedPoint newState
 
--- Describe the status of the pull request.
-describeStatus :: BaseBranch -> PullRequestId -> PullRequest -> ProjectState -> Text
-describeStatus (BaseBranch projectBaseBranchName) prId pr state = case Pr.classifyPullRequest pr of
-  PrStatusAwaitingApproval -> "Pull request awaiting approval."
+-- | Feedback on a successfully parsed command.
+data Feedback
+  = -- | Leave a comment.
+    CommentFeedback Text
+  | -- | Leave only a reaction.
+    ReactionFeedback ReactableId GithubApi.ReactionContent
+
+-- | Determine what kind of feedback to leave based on the status of a PR.
+feedbackOnStatus :: BaseBranch -> PullRequestId -> PullRequest -> ProjectState -> Feedback
+feedbackOnStatus (BaseBranch projectBaseBranchName) prId pr state = case Pr.classifyPullRequest pr of
+  PrStatusAwaitingApproval -> CommentFeedback "Pull request awaiting approval."
   PrStatusApproved ->
     let
-      Approval (Username approvedBy) _source approvalType _position retriedBy priority = fromJust $ Pr.approval pr
+      Approval (Username approvedBy) source approvalType _position retriedBy priority = fromJust $ Pr.approval pr
 
       approvalCommand = Pr.displayMergeCommand (Approve approvalType)
       retriedByMsg = case retriedBy of
         Just user -> format " (retried by @{})" [user]
         Nothing -> mempty
-      queuePositionMsg = case Pr.getQueuePosition prId state of
+      queuePosition = Pr.getQueuePosition prId state
+      queuePositionMsg = case queuePosition of
         0 -> "rebasing now"
         1 -> "waiting for rebase behind one pull request"
         n -> format "waiting for rebase behind {} pull requests" [n]
       priorityMsg = case priority of
         Normal -> mempty
         High -> " with high priority"
-    in format "Pull request approved for {}{} by @{}{}, {}." [approvalCommand, priorityMsg, approvedBy, retriedByMsg, queuePositionMsg]
+     in
+      case (queuePosition, source) of
+        (0, Just reactable) -> ReactionFeedback reactable GithubApi.PlusOne
+        _ ->
+          CommentFeedback $
+            format
+              "Pull request approved for {}{} by @{}{}, {}."
+              [approvalCommand, priorityMsg, approvedBy, retriedByMsg, queuePositionMsg]
   PrStatusOutdated ->
     let BaseBranch baseBranchName = Pr.baseBranch pr
-    in format "Push to {} detected, rebasing again." [baseBranchName]
-  PrStatusBuildPending -> let Sha sha = fromJust $ Pr.integrationSha pr
-                              train   = takeWhile (/= prId) $ Pr.unfailedIntegratedPullRequests state
-                              len     = length train
-                              prs     = if len == 1 then "PR" else "PRs"
-                          in case train of
-                             []    -> Text.concat ["Rebased as ", sha, ", waiting for CI …"]
-                             (_:_) -> Text.concat [ "Speculatively rebased as ", sha
-                                                  , " behind ", Text.pack $ show len
-                                                  , " other ", prs
-                                                  , ", waiting for CI …"
-                                                  ]
-  PrStatusBuildStarted url -> Text.concat ["[CI job :yellow_circle:](", url, ") started."]
-  PrStatusAwaitingPromotion -> "The PR is waiting to be pushed to the target branch"
-  PrStatusIntegrated -> "The build succeeded."
+     in CommentFeedback $ format "Push to {} detected, rebasing again." [baseBranchName]
+  PrStatusBuildPending ->
+    let Sha sha = fromJust $ Pr.integrationSha pr
+        train = takeWhile (/= prId) $ Pr.unfailedIntegratedPullRequests state
+        len = length train
+        prs = if len == 1 then "PR" else "PRs"
+     in CommentFeedback $ case train of
+          [] -> Text.concat ["Rebased as ", sha, ", waiting for CI …"]
+          (_ : _) ->
+            Text.concat
+              [ "Speculatively rebased as "
+              , sha
+              , " behind "
+              , Text.pack $ show len
+              , " other "
+              , prs
+              , ", waiting for CI …"
+              ]
+  PrStatusBuildStarted url -> CommentFeedback $ Text.concat ["[CI job :yellow_circle:](", url, ") started."]
+  PrStatusAwaitingPromotion -> CommentFeedback $ "The PR is waiting to be pushed to the target branch"
+  PrStatusIntegrated -> CommentFeedback $ "The build succeeded."
   PrStatusIncorrectBaseBranch ->
     let BaseBranch baseBranchName = Pr.baseBranch pr
-    in format "Merge rejected: the base branch of this pull request must be set to {}. It is currently set to {}."
-              [projectBaseBranchName, baseBranchName]
-  PrStatusWrongFixups -> "Pull request cannot be integrated as it contains fixup commits that do not belong to any other commits."
-  PrStatusEmptyRebase -> "Empty rebase. \
-                         \ Have the changes already been merged into the target branch? \
-                         \ Aborting."
+     in CommentFeedback $
+          format
+            "Merge rejected: the base branch of this pull request must be set to {}. It is currently set to {}."
+            [projectBaseBranchName, baseBranchName]
+  PrStatusWrongFixups ->
+    CommentFeedback "Pull request cannot be integrated as it contains fixup commits that do not belong to any other commits."
+  PrStatusEmptyRebase ->
+    CommentFeedback
+      "Empty rebase. \
+      \ Have the changes already been merged into the target branch? \
+      \ Aborting."
   PrStatusFailedConflict ->
     let
       BaseBranch targetBranchName = Pr.baseBranch pr
       Branch prBranchName = Pr.branch pr
-    in Text.concat
-      [ "Failed to rebase, please rebase manually using\n\n"
-      , "    git fetch && git rebase --interactive --autosquash origin/"
-      , targetBranchName
-      , " "
-      , prBranchName
-      ]
+     in
+      CommentFeedback $
+        Text.concat
+          [ "Failed to rebase, please rebase manually using\n\n"
+          , "    git fetch && git rebase --interactive --autosquash origin/"
+          , targetBranchName
+          , " "
+          , prBranchName
+          ]
   -- The following is not actually shown to the user
   -- as it is never set with needsFeedback=True,
   -- but here in case we decide to show it.
-  PrStatusSpeculativeConflict -> "Failed to speculatively rebase. \
-                                 \ I will retry rebasing automatically when the queue clears."
-  PrStatusFailedBuild url -> case Pr.unfailedIntegratedPullRequestsBefore pr state of
-    -- On Fridays the retry command is also `retry on friday`. We currently
-    -- don't have that information here. Is that worth including?
-    [] -> format "The {}.\n\n\
-                 \If this is the result of a flaky test, \
-                 \then tag me again with the `retry` command.  \
-                 \Otherwise, push a new commit and tag me again."
-                 [markdownLink "build failed :x:" url]
-    trainBefore -> format "Speculative {}. \
-                          \ I will automatically retry after getting build results for {}."
-                          [ markdownLink "build failed :x:" url
-                          , prettyPullRequestIds trainBefore ]
+  PrStatusSpeculativeConflict ->
+    CommentFeedback
+      "Failed to speculatively rebase. \
+      \ I will retry rebasing automatically when the queue clears."
+  PrStatusFailedBuild url ->
+    CommentFeedback $
+      case Pr.unfailedIntegratedPullRequestsBefore pr state of
+        -- On Fridays the retry command is also `retry on friday`. We currently
+        -- don't have that information here. Is that worth including?
+        [] ->
+          format
+            "The {}.\n\n\
+            \If this is the result of a flaky test, \
+            \then tag me again with the `retry` command.  \
+            \Otherwise, push a new commit and tag me again."
+            [markdownLink "build failed :x:" url]
+        trainBefore ->
+          format
+            "Speculative {}. \
+            \ I will automatically retry after getting build results for {}."
+            [ markdownLink "build failed :x:" url
+            , prettyPullRequestIds trainBefore
+            ]
 
 -- Leave a comment with the feedback from 'describeStatus' and set the
 -- 'needsFeedback' flag to 'False'.
@@ -1235,11 +1272,15 @@ leaveFeedback
   -> Eff es ProjectState
 leaveFeedback (prId, pr) state = do
   projectBaseBranch <- getBaseBranch
-  let message = describeStatus projectBaseBranch prId pr state
-  -- Hoff shouldn't reply to any of its own feedback messages. This can happen
-  -- if external automation causes the bot to issue a merge command to itself.
-  -- In that case the bot may tag itself when the merge gets approved.
-  () <- leaveComment prId $ hoffIgnoreComment <> message
+  case feedbackOnStatus projectBaseBranch prId pr state of
+    CommentFeedback message ->
+      -- Hoff shouldn't reply to any of its own feedback messages. This can happen
+      -- if external automation causes the bot to issue a merge command to itself.
+      -- In that case the bot may tag itself when the merge gets approved.
+      leaveComment prId $ hoffIgnoreComment <> message
+    ReactionFeedback reactable reaction ->
+      addReaction reactable reaction
+
   pure $ Pr.setNeedsFeedback prId False state
 
 -- Run 'leaveFeedback' on all pull requests that need feedback.
diff --git a/tests/Spec.hs b/tests/Spec.hs
@@ -18,7 +18,8 @@
 import Data.Aeson (decode, encode, eitherDecode)
 import Data.ByteString.Lazy (readFile)
 import Data.Either (isRight)
-import Data.Foldable (foldlM)
+import Data.Foldable (foldlM, for_)
+import Data.Function ((&))
 import Data.IntSet (IntSet)
 import Data.List (group)
 import Data.Maybe (fromJust, isNothing)
@@ -767,7 +768,8 @@ main = hspec $ do
 
     it "handles merge command in body of pull request" $ do
       let
-        event = PullRequestOpened (PullRequestId 1) (Branch "p") masterBranch (Sha "e0f") "title" "deckard" (Just "@bot merge")
+        prId = PullRequestId 1
+        event = PullRequestOpened prId (Branch "p") masterBranch (Sha "e0f") "title" "deckard" (Just "@bot merge")
         -- For this test, we assume all integrations and pushes succeed.
         results = defaultResults
           { resultIntegrate = [Right (Sha "b71")] }
@@ -776,10 +778,10 @@ main = hspec $ do
 
       actions `shouldBe`
         [ AIsReviewer "deckard"
-        , ALeaveComment (PullRequestId 1) "<!-- Hoff: ignore -->\nPull request approved for merge by @deckard, rebasing now."
+        , AAddReaction (OnPullRequest prId) GithubApi.PlusOne
         , ATryIntegrate "Merge #1: title\n\nApproved-by: deckard\nPriority: Normal\nAuto-deploy: false\n"
-                        (PullRequestId 1, Branch "refs/pull/1/head", Sha "e0f") [] False
-        , ALeaveComment (PullRequestId 1) "<!-- Hoff: ignore -->\nRebased as b71, waiting for CI …"
+                        (prId, Branch "refs/pull/1/head", Sha "e0f") [] False
+        , ALeaveComment prId "<!-- Hoff: ignore -->\nRebased as b71, waiting for CI …"
         ]
       classifiedPullRequestIds state' `shouldBe` ClassifiedPullRequestIds
         { building = [PullRequestId 1]
@@ -790,10 +792,11 @@ main = hspec $ do
 
     it "does not handle merge command in body of reopened pull request" $ do
       let
+        prId = PullRequestId 1
         events =
-          [ PullRequestOpened (PullRequestId 1) (Branch "p") masterBranch (Sha "e0f") "title" "deckard" (Just "@bot merge")
-          , PullRequestClosed (PullRequestId 1)
-          , PullRequestOpened (PullRequestId 1) (Branch "p") masterBranch (Sha "e0f") "title" "deckard" Nothing
+          [ PullRequestOpened prId (Branch "p") masterBranch (Sha "e0f") "title" "deckard" (Just "@bot merge")
+          , PullRequestClosed prId
+          , PullRequestOpened prId (Branch "p") masterBranch (Sha "e0f") "title" "deckard" Nothing
           ]
         -- For this test, we assume all integrations and pushes succeed.
         results = defaultResults
@@ -803,11 +806,11 @@ main = hspec $ do
 
       actions `shouldBe`
         [ AIsReviewer "deckard"
-        , ALeaveComment (PullRequestId 1) "<!-- Hoff: ignore -->\nPull request approved for merge by @deckard, rebasing now."
+        , AAddReaction (OnPullRequest prId) GithubApi.PlusOne
         , ATryIntegrate "Merge #1: title\n\nApproved-by: deckard\nPriority: Normal\nAuto-deploy: false\n"
-                        (PullRequestId 1, Branch "refs/pull/1/head", Sha "e0f") [] False
-        , ALeaveComment (PullRequestId 1) "<!-- Hoff: ignore -->\nRebased as b71, waiting for CI …"
-        , ALeaveComment (PullRequestId 1) "Abandoning this pull request because it was closed."
+                        (prId, Branch "refs/pull/1/head", Sha "e0f") [] False
+        , ALeaveComment prId "<!-- Hoff: ignore -->\nRebased as b71, waiting for CI …"
+        , ALeaveComment prId "Abandoning this pull request because it was closed."
         , ACleanupTestBranch (PullRequestId 1)
         ]
       classifiedPullRequestIds state' `shouldBe` ClassifiedPullRequestIds
@@ -934,6 +937,59 @@ main = hspec $ do
       fromJust (Project.lookupPullRequest prId state') `shouldSatisfy`
         (\pr -> (Project.approval pr >>= Project.approvalSource) == Just (OnPullRequest prId))
 
+    it "adds a reaction to a 'merge' command in the common case" $ do
+      let
+        prId = PullRequestId 1
+        commentId = CommentId 42
+        state = singlePullRequestState prId (Branch "p") masterBranch (Sha "abc1234") "tyrell"
+
+        event = CommentAdded prId "deckard" (Just commentId) "@bot merge"
+
+        results = defaultResults { resultIntegrate = [Right (Sha "def2345")] }
+        (_state', actions) = runActionCustom results $ handleEventTest event state
+
+      actions `shouldContain` [AAddReaction (OnIssueComment commentId) GithubApi.PlusOne]
+
+    it "adds a reaction to a 'retry' command in the common case" $ do
+      let
+        prId = PullRequestId 1
+        mergeCommentId = CommentId 42
+        retryCommentId = CommentId 72
+        state = singlePullRequestState prId (Branch "p") masterBranch (Sha "1b1") "tyrell"
+
+        events =
+          [ CommentAdded prId "deckard" (Just mergeCommentId) "@bot merge"
+          , BuildStatusChanged (Sha "1b3") "default" (Project.BuildFailed (Just "url"))
+          , CommentAdded prId "deckard" (Just retryCommentId) "@bot retry"
+          ]
+
+        results = defaultResults { resultIntegrate = [Right (Sha "1b3"), Right (Sha "00f")] }
+        (_state', actions) = runActionCustom results $ handleEventsTest events state
+
+      actions `shouldContain` [AAddReaction (OnIssueComment retryCommentId) GithubApi.PlusOne]
+
+    it "falls back to an ordinary comment if there are other PRs ahead in the queue" $ do
+      let
+        (prId1, prId2) = (PullRequestId 1, PullRequestId 2)
+        (mergeCommentId1, mergeCommentId2) = (CommentId 111, CommentId 222)
+        state =
+          Project.emptyProjectState
+            & Project.insertPullRequest (PullRequestId 1) (Branch "one") masterBranch (Sha "111") "First PR" (Username "person")
+            & Project.insertPullRequest (PullRequestId 2) (Branch "two") masterBranch (Sha "222") "Second PR" (Username "robot")
+        events =
+          [ CommentAdded prId1 "deckard" (Just mergeCommentId1) "@bot merge"
+          , CommentAdded prId2 "deckard" (Just mergeCommentId2) "@bot merge"
+          ]
+        results = defaultResults { resultIntegrate = [Right (Sha "11f"), Right (Sha "22f")] }
+        (_state', actions) = runActionCustom results $ handleEventsTest events state
+
+      actions `shouldContain` [ALeaveComment prId2 "<!-- Hoff: ignore -->\nPull request approved for merge by @deckard, waiting for rebase behind one pull request."]
+
+      -- We check that we don't add /any/ reaction, not just that we don't add :+1:.
+      let allPossibleReactions = [minBound .. maxBound]
+      for_ allPossibleReactions $ \reaction ->
+        actions `shouldNotContain` [AAddReaction (OnIssueComment mergeCommentId2) reaction]
+
     it "recognizes 'merge and deploy' commands as the proper ApprovedFor value" $ do
       let
         prId = PullRequestId 1
