Merge #272: Use reactions for confirmation when appropriate

Approved-by: isomorpheme
Priority: Normal
Auto-deploy: false

Author: OpsBotPrime

nix/haskell-overlay.nix

@@ -1,4 +1,16 @@
 { sources ? import ./sources.nix, pkgs }:
 self: super: {
   hoff = self.callPackage ../hoff.nix { };
+
+  github =
+    pkgs.haskell.lib.compose.appendPatches
+      [
+        # https://github.com/haskell-github/github/pull/509
+        (pkgs.fetchpatch {
+          name = "github.patch";
+          url = "https://github.com/haskell-github/github/commit/623105d3987c4bb4e67d48e5ae36a3af97480be9.patch";
+          sha256 = "sha256-3zRYnrxg9G+druD8o5iejCnTclxd2eg1V7BAO6USjzo=";
+        })
+      ]
+      super.github;
 }

src/EventLoop.hs

@@ -71,7 +71,7 @@ eventFromCommentPayload payload =
   let number = PullRequestId payload.number
       author = payload.author -- TODO: Wrapper type
       body   = payload.body
-      commentAdded = Logic.CommentAdded number author body
+      commentAdded = Logic.CommentAdded number author payload.id body
   in case payload.action of
     Left Github.CommentCreated -> Just commentAdded
     Right Github.ReviewSubmitted -> Just commentAdded

src/Github.hs

@@ -37,7 +37,7 @@ import GHC.Natural (Natural)
 
 import Git (Sha (..), Branch (..), BaseBranch (..), Context)
 import Project (ProjectInfo (..))
-import Types (Body, Username)
+import Types (Body, Username, CommentId (..))
 import Data.Maybe (fromMaybe)
 
 data PullRequestAction
@@ -82,11 +82,15 @@ data PullRequestPayload = PullRequestPayload {
 
 data CommentPayload = CommentPayload {
   action     :: Either CommentAction ReviewAction, -- Corresponds to "action".
-  owner      :: Text,     -- Corresponds to "repository.owner.login".
-  repository :: Text,     -- Corresponds to "repository.name".
-  number     :: Int,      -- Corresponds to "issue.number" or "pull_request.number".
-  author     :: Username, -- Corresponds to "sender.login".
-  body       :: Text      -- Corresponds to "comment.body" or "review.body".
+  owner      :: Text,            -- Corresponds to "repository.owner.login".
+  repository :: Text,            -- Corresponds to "repository.name".
+  number     :: Int,             -- Corresponds to "issue.number" or "pull_request.number".
+  author     :: Username,        -- Corresponds to "sender.login".
+  id         :: Maybe CommentId, -- Corresponds to "comment.id".
+                                 -- Can be absent if we actually received a review,
+                                 -- because those have separate IDs from ordinary issue
+                                 -- comments.
+  body       :: Text             -- Corresponds to "comment.body" or "review.body".
 } deriving (Eq, Show)
 
 data CommitStatusPayload = CommitStatusPayload {
@@ -169,6 +173,10 @@ instance FromJSON CommentPayload where
       <*> (getNested v ["issue", "number"]
         <|> getNested v ["pull_request", "number"])
       <*> getNested v ["sender", "login"]
+      <*> (getNested v ["comment", "id"]
+        -- If we couldn't get a comment ID, we likely got a review, which does have an ID,
+        -- but we can't treat that as a comment ID for API requests.
+        <|> pure Nothing)
       <*> (getNested v ["comment", "body"]
         <|> fromMaybe "" <$> getNested v ["review", "body"])
   parseJSON nonObject = typeMismatch "(issue_comment | pull_request_review) payload" nonObject

src/GithubApi.hs

@@ -17,10 +17,12 @@ module GithubApi
 (
   GithubOperation (..),
   PullRequest (..),
+  ReactionContent(..),
   getOpenPullRequests,
   getPullRequest,
   hasPushAccess,
   leaveComment,
+  addReaction,
   runGithub,
   runGithubReadOnly,
 )
@@ -32,13 +34,16 @@ import Effectful (Dispatch (Dynamic), DispatchOf, Eff, Effect, IOE, (:>))
 import Effectful.Dispatch.Dynamic (interpret, send, interpose)
 import Data.IntSet (IntSet)
 import Data.Text (Text)
+import GitHub.Data.Reactions (ReactionContent(..))
 
 import qualified Data.IntSet as IntSet
 import qualified Data.Vector as Vector
+import qualified GitHub.Data.Id as Github3
 import qualified GitHub.Data.Name as Github3
 import qualified GitHub.Data.Options as Github3
 import qualified GitHub.Endpoints.Issues.Comments as Github3
 import qualified GitHub.Endpoints.PullRequests as Github3
+import qualified GitHub.Endpoints.Reactions as Github3
 import qualified GitHub.Endpoints.Repos.Collaborators as Github3
 import qualified GitHub.Request as Github3
 import qualified Network.HTTP.Client as Http
@@ -48,7 +53,7 @@ import Format (format)
 import Git (BaseBranch (..), Branch (..), Sha (..))
 import MonadLoggerEffect (MonadLoggerEffect)
 import Project (ProjectInfo)
-import Types (PullRequestId (..), Username (..))
+import Types (PullRequestId (..), Username (..), CommentId (..), ReactableId (..))
 
 import qualified Project
 
@@ -64,6 +69,7 @@ data PullRequest = PullRequest
 
 data GithubOperation :: Effect where
   LeaveComment :: PullRequestId -> Text -> GithubOperation m ()
+  AddReaction :: ReactableId -> ReactionContent -> GithubOperation m ()
   HasPushAccess :: Username -> GithubOperation m Bool
   GetPullRequest :: PullRequestId -> GithubOperation m (Maybe PullRequest)
   GetOpenPullRequests :: GithubOperation m (Maybe IntSet)
@@ -73,6 +79,9 @@ type instance DispatchOf GithubOperation = 'Dynamic
 leaveComment :: GithubOperation :> es => PullRequestId -> Text -> Eff es ()
 leaveComment pr remoteBranch = send $ LeaveComment pr remoteBranch
 
+addReaction :: GithubOperation :> es => ReactableId -> ReactionContent -> Eff es ()
+addReaction id' reaction = send $ AddReaction id' reaction
+
 hasPushAccess :: GithubOperation :> es => Username -> Eff es Bool
 hasPushAccess username = send $ HasPushAccess username
 
@@ -119,6 +128,26 @@ runGithub auth projectInfo =
         Right _ -> logInfoN $ format "Posted comment on {}#{}: {}"
                                      (Project.repository projectInfo, pr, body)
 
+    AddReaction reactableId reaction -> do
+      let
+        createReactionR project owner =
+          case reactableId of
+            OnIssueComment (CommentId commentId) -> Github3.createCommentReactionR project owner (Github3.Id commentId)
+            OnPullRequest (PullRequestId prId) -> Github3.createIssueReactionR project owner (Github3.Id prId)
+
+      result <- liftIO $ Github3.github auth $ createReactionR
+        (Github3.N $ Project.owner projectInfo)
+        (Github3.N $ Project.repository projectInfo)
+        reaction
+
+      case result of
+        Left err -> logWarnN $ format "Failed to add reaction: {}" [show err]
+        Right _ ->
+          logInfoN $
+            format
+              "Added reaction in {} on {}: {}"
+              (Project.repository projectInfo, reactableId, show reaction)
+
     HasPushAccess (Username username) -> do
       result <- liftIO $ Github3.github auth $ Github3.collaboratorPermissionOnR
         (Github3.N $ Project.owner projectInfo)
@@ -196,3 +225,5 @@ runGithubReadOnly auth projectInfo = runGithub auth projectInfo . augmentedGithu
       -- These operations have side effects, we fake them.
       LeaveComment pr body ->
         logInfoN $ format "Would have posted comment on {}: {}" (show pr, body)
+      AddReaction reactableId reaction ->
+        logInfoN $ format "Would have added reaction on {}: {}" (reactableId, show reaction)