Add initial subset of Reactions endpoints

Author: isomorpheme

github.cabal

@@ -117,6 +117,7 @@ library
     GitHub.Data.PublicSSHKeys
     GitHub.Data.PullRequests
     GitHub.Data.RateLimit
+    GitHub.Data.Reactions
     GitHub.Data.Releases
     GitHub.Data.Repos
     GitHub.Data.Request
@@ -157,6 +158,7 @@ library
     GitHub.Endpoints.PullRequests.Comments
     GitHub.Endpoints.PullRequests.Reviews
     GitHub.Endpoints.RateLimit
+    GitHub.Endpoints.Reactions
     GitHub.Endpoints.Repos
     GitHub.Endpoints.Repos.Collaborators
     GitHub.Endpoints.Repos.Comments

src/GitHub.hs

@@ -285,6 +285,15 @@ module GitHub (
     commitR,
     diffR,
 
+    -- ** Reactions
+    -- | See <https://docs.github.com/en/rest/reactions/reactions?apiVersion=2022-11-28>
+    issueReactionsR,
+    createIssueReactionR,
+    deleteIssueReactionR,
+    commentReactionsR,
+    createCommentReactionR,
+    deleteCommentReactionR,
+
     -- ** Contents
     -- | See <https://developer.github.com/v3/repos/contents/>
     contentsForR,
@@ -514,6 +523,7 @@ import GitHub.Endpoints.Organizations.Teams
 import GitHub.Endpoints.PullRequests
 import GitHub.Endpoints.PullRequests.Comments
 import GitHub.Endpoints.PullRequests.Reviews
+import GitHub.Endpoints.Reactions
 import GitHub.Endpoints.RateLimit
 import GitHub.Endpoints.Repos
 import GitHub.Endpoints.Repos.Collaborators

src/GitHub/Data.hs

@@ -55,6 +55,7 @@ module GitHub.Data (
     module GitHub.Data.PullRequests,
     module GitHub.Data.RateLimit,
     module GitHub.Data.Releases,
+    module GitHub.Data.Reactions,
     module GitHub.Data.Repos,
     module GitHub.Data.Request,
     module GitHub.Data.Reviews,
@@ -97,6 +98,7 @@ import GitHub.Data.PublicSSHKeys
 import GitHub.Data.PullRequests
 import GitHub.Data.RateLimit
 import GitHub.Data.Releases
+import GitHub.Data.Reactions
 import GitHub.Data.Repos
 import GitHub.Data.Request
 import GitHub.Data.Reviews

src/GitHub/Data/Reactions.hs

@@ -0,0 +1,78 @@
+{-# LANGUAGE InstanceSigs #-}
+module GitHub.Data.Reactions where
+
+import qualified Data.Text as T
+import GitHub.Data.Id (Id)
+import GitHub.Data.Definitions (SimpleUser)
+import GitHub.Internal.Prelude
+import Prelude ()
+
+data Reaction = Reaction
+  { reactionId :: Id Reaction
+  , reactionUser :: !(Maybe SimpleUser)
+  , reactionContent :: !ReactionContent
+  , reactionCreatedAt :: !UTCTime
+  }
+  deriving (Show, Data, Typeable, Eq, Ord, Generic)
+
+instance NFData Reaction where rnf = genericRnf
+instance Binary Reaction
+
+data NewReaction = NewReaction
+  { newReactionContent :: !ReactionContent
+  }
+  deriving (Show, Data, Typeable, Eq, Ord, Generic)
+
+instance NFData NewReaction where rnf = genericRnf
+instance Binary NewReaction
+
+-- |
+-- <https://docs.github.com/en/rest/reactions/reactions?apiVersion=2022-11-28#about-reactions>
+data ReactionContent
+  = PlusOne
+  | MinusOne
+  | Laugh
+  | Confused
+  | Heart
+  | Hooray
+  | Rocket
+  | Eyes
+  deriving (Show, Data, Typeable, Eq, Ord, Enum, Bounded, Generic)
+
+instance NFData ReactionContent where rnf = genericRnf
+instance Binary ReactionContent
+
+-- JSON instances
+
+instance FromJSON Reaction where
+  parseJSON = withObject "Reaction" $ \o ->
+    Reaction
+      <$> o .: "id"
+      <*> o .:? "user"
+      <*> o .: "content"
+      <*> o .: "created_at"
+
+instance ToJSON NewReaction where
+  toJSON (NewReaction content) = object ["content" .= content]
+
+instance FromJSON ReactionContent where
+  parseJSON = withText "ReactionContent" $ \case
+    "+1" -> pure PlusOne
+    "-1" -> pure MinusOne
+    "laugh" -> pure Laugh
+    "confused" -> pure Confused
+    "heart" -> pure Heart
+    "hooray" -> pure Hooray
+    "rocket" -> pure Rocket
+    "eyes" -> pure Eyes
+    t -> fail $ "Unknown ReactionContent: " <> T.unpack t
+
+instance ToJSON ReactionContent where
+  toJSON PlusOne = String "+1"
+  toJSON MinusOne = String "-1"
+  toJSON Laugh = String "laugh"
+  toJSON Confused = String "confused"
+  toJSON Heart = String "heart"
+  toJSON Hooray = String "hooray"
+  toJSON Rocket = String "rocket"
+  toJSON Eyes = String "eyes"

src/GitHub/Endpoints/Reactions.hs

@@ -0,0 +1,60 @@
+-- |
+-- The Reactions API as described at
+-- <https://docs.github.com/en/rest/reactions/reactions?apiVersion=2022-11-28>.
+module GitHub.Endpoints.Reactions (
+  issueReactionsR,
+  createIssueReactionR,
+  deleteIssueReactionR,
+  commentReactionsR,
+  createCommentReactionR,
+  deleteCommentReactionR,
+  module GitHub.Data,
+) where
+
+import GitHub.Data
+import GitHub.Internal.Prelude
+import Prelude ()
+
+-- | List reactions for an issue.
+-- See <https://docs.github.com/en/rest/reactions/reactions?apiVersion=2022-11-28#list-reactions-for-an-issue>
+issueReactionsR :: Name Owner -> Name Repo -> Id Issue -> FetchCount -> Request k (Vector Reaction)
+issueReactionsR owner repo iid =
+  pagedQuery ["repos", toPathPart owner, toPathPart repo, "issues", toPathPart iid, "reactions"] []
+
+-- | Create reaction for an issue comment.
+-- See <https://docs.github.com/en/rest/reactions/reactions?apiVersion=2022-11-28#create-reaction-for-an-issue>
+createIssueReactionR :: Name Owner -> Name Repo -> Id Issue -> ReactionContent -> Request 'RW Reaction
+createIssueReactionR owner repo iid content =
+    command Post parts (encode $ NewReaction content)
+  where
+    parts = ["repos", toPathPart owner, toPathPart repo, "issues", toPathPart iid, "reactions"]
+
+-- | Delete an issue comment reaction.
+-- See <https://docs.github.com/en/rest/reactions/reactions?apiVersion=2022-11-28#delete-an-issue-reaction>
+deleteIssueReactionR :: Name Owner -> Name Repo -> Id Issue -> Id Reaction -> GenRequest 'MtUnit 'RW ()
+deleteIssueReactionR owner repo iid rid =
+    Command Delete parts mempty
+  where
+    parts = ["repos", toPathPart owner, toPathPart repo, "issues", toPathPart iid, "reactions", toPathPart rid]
+
+-- | List reactions for an issue comment.
+-- See <https://docs.github.com/en/rest/reactions/reactions?apiVersion=2022-11-28#list-reactions-for-an-issue-comment>
+commentReactionsR :: Name Owner -> Name Repo -> Id Comment -> FetchCount -> Request k (Vector Reaction)
+commentReactionsR owner repo cid =
+  pagedQuery ["repos", toPathPart owner, toPathPart repo, "issues", "comments", toPathPart cid, "reactions"] []
+
+-- | Create reaction for an issue comment.
+-- See https://docs.github.com/en/rest/reactions/reactions?apiVersion=2022-11-28#create-reaction-for-an-issue-comment
+createCommentReactionR :: Name Owner -> Name Repo -> Id Comment -> ReactionContent -> Request 'RW Reaction
+createCommentReactionR owner repo cid content =
+    command Post parts (encode $ NewReaction content)
+  where
+    parts = ["repos", toPathPart owner, toPathPart repo, "issues", "comments", toPathPart cid, "reactions"]
+
+-- | Delete an issue comment reaction.
+-- See <https://docs.github.com/en/rest/reactions/reactions?apiVersion=2022-11-28#delete-an-issue-comment-reaction>
+deleteCommentReactionR :: Name Owner -> Name Repo -> Id Comment -> Id Reaction -> GenRequest 'MtUnit 'RW ()
+deleteCommentReactionR owner repo cid rid =
+    Command Delete parts mempty
+  where
+    parts = ["repos", toPathPart owner, toPathPart repo, "issues", "comments", toPathPart cid, "reactions", toPathPart rid]