diff --git a/CHANGELOG.md b/CHANGELOG.md
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -1,3 +1,20 @@
+## Changes for 0.30
+
+_2025-05-09, Andreas Abel, Peace edition_
+
+- Organization membership endpoint (Domen Kožar, PR [#487](https://github.com/haskell-github/github/pull/487)).
+- Allow JWT as an authentication method (Tom Sydney Kerckhove, PR [#497](https://github.com/haskell-github/github/pull/497)).
+- Support pagination (Tom McLaughlin, PR [#503](https://github.com/haskell-github/github/pull/503)).
+- Initial subset of Reactions endpoints (Dan Rijks, PR [#509](https://github.com/haskell-github/github/pull/509)).
+- Fix `getNotifications` (maralorn, PR [#511](https://github.com/haskell-github/github/pull/511)).
+- Add missing `name` field to `WorkflowJobs` `Job` type (Hugh Davidson, PR [#518](https://github.com/haskell-github/github/pull/518)).
+- Add `StateReasonDuplicate` to `IssueStateReason` (PR [#523](https://github.com/haskell-github/github/pull/523)).
+- Drop support for GHC 8.0 and below.
+- Drop dependency `time-compat`.
+
+Tested with GHC 8.2 - 9.12.2.
+
+
## Changes for 0.29
_2023-06-24, Andreas Abel, Midsommar edition_
diff --git a/github.cabal b/github.cabal
--- a/github.cabal
+++ b/github.cabal
@@ -1,6 +1,6 @@
cabal-version: 2.4
name: github
-version: 0.29
+version: 0.30
synopsis: Access to the GitHub API, v3.
category: Network
description:
@@ -30,8 +30,11 @@
Copyright 2012-2013 Mike Burns, Copyright 2013-2015 John Wiegley, Copyright 2016-2021 Oleg Grenrus
tested-with:
- GHC == 9.6.2
- GHC == 9.4.5
+ GHC == 9.12.2
+ GHC == 9.10.2
+ GHC == 9.8.4
+ GHC == 9.6.7
+ GHC == 9.4.8
GHC == 9.2.8
GHC == 9.0.2
GHC == 8.10.7
@@ -39,9 +42,6 @@
GHC == 8.6.5
GHC == 8.4.4
GHC == 8.2.2
- GHC == 8.0.2
- GHC == 7.10.3
- GHC == 7.8.4
extra-doc-files:
README.md
@@ -63,11 +63,9 @@
default-language: Haskell2010
ghc-options:
-Wall
- if impl(ghc >= 8.0)
- ghc-options:
- -Wcompat
- -Wno-star-is-type
- -- The star-is-type warning cannot be sensiblity addressed while supporting GHC 7.
+ -Wcompat
+ -Wno-star-is-type
+ -- The star-is-type warning cannot be sensiblity addressed while supporting GHC 7.
hs-source-dirs: src
default-extensions:
DataKinds
@@ -119,6 +117,7 @@
GitHub.Data.PublicSSHKeys
GitHub.Data.PullRequests
GitHub.Data.RateLimit
+ GitHub.Data.Reactions
GitHub.Data.Releases
GitHub.Data.Repos
GitHub.Data.Request
@@ -159,6 +158,7 @@
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
@@ -185,26 +185,26 @@
-- Packages bundles with GHC, mtl and text are also here
build-depends:
- base >=4.7 && <5
+ base >=4.10 && <5
, binary >=0.7.1.0 && <0.11
- , bytestring >=0.10.4.0 && <0.12
- , containers >=0.5.5.1 && <0.7
- , deepseq >=1.3.0.2 && <1.5
+ , bytestring >=0.10.4.0 && <0.13
+ , containers >=0.5.5.1 && <1
+ , deepseq >=1.3.0.2 && <1.6
+ , exceptions >=0.10.2 && <0.11
, mtl >=2.1.3.1 && <2.2 || >=2.2.1 && <2.4
- , text >=1.2.0.6 && <2.1
- , time-compat >=1.9.2.2 && <1.10
+ , text >=1.2.0.6 && <2.2
+ , time >=1.8.0.2 && <2
, transformers >=0.3.0.0 && <0.7
-- other packages
build-depends:
- aeson >=1.4.0.0 && <1.6 || >=2.0.1.0 && <2.2
- , base-compat >=0.11.1 && <0.14
+ aeson >=1.4.0.0 && <1.6 || >=2.0.1.0 && <2.3
+ , base-compat >=0.11.1 && <1
, base16-bytestring >=0.1.1.6 && <1.1
, binary-instances >=1 && <1.1
, cryptohash-sha1 >=0.11.100.1 && <0.12
, deepseq-generics >=0.2.0.0 && <0.3
- , exceptions >=0.10.2 && <0.11
- , hashable >=1.2.7.0 && <1.5
+ , hashable >=1.2.7.0 && <2
, http-client >=0.5.12 && <0.8
, http-link-header >=1.0.3.1 && <1.3
, http-types >=0.12.3 && <0.13
@@ -226,9 +226,6 @@
http-client-tls >=0.3.5.3 && <0.4
, tls >=1.4.1
- if !impl(ghc >=8.0)
- build-depends: semigroups >=0.18.5 && <0.20
-
test-suite github-test
default-language: Haskell2010
type: exitcode-stdio-1.0
@@ -267,6 +264,7 @@
, file-embed
, github
, hspec >=2.6.1 && <2.12
+ , http-client
, tagged
, text
, unordered-containers
diff --git a/spec/GitHub/IssuesSpec.hs b/spec/GitHub/IssuesSpec.hs
--- a/spec/GitHub/IssuesSpec.hs
+++ b/spec/GitHub/IssuesSpec.hs
@@ -6,13 +6,14 @@
import Prelude ()
import Prelude.Compat
-import Data.Either.Compat (isRight)
-import Data.Foldable (for_)
-import Data.String (fromString)
-import System.Environment (lookupEnv)
-import Test.Hspec
- (Spec, describe, expectationFailure, it, pendingWith, shouldSatisfy)
+import Data.Either.Compat (isRight)
+import Data.Foldable (for_)
+import Data.String (fromString)
+import Network.HTTP.Client (newManager, responseBody)
+import System.Environment (lookupEnv)
+import Test.Hspec (Spec, describe, expectationFailure, it, pendingWith, shouldSatisfy)
+
fromRightS :: Show a => Either a b -> b
fromRightS (Right b) = b
fromRightS (Left a) = error $ "Expected a Right and got a Left" ++ show a
@@ -38,6 +39,25 @@
cms <- GitHub.executeRequest auth $
GitHub.commentsR owner repo (GitHub.issueNumber i) 1
cms `shouldSatisfy` isRight
+
+ describe "issuesForRepoR paged" $ do
+ it "works" $ withAuth $ \auth -> for_ repos $ \(owner, repo) -> do
+ mgr <- newManager GitHub.tlsManagerSettings
+ ret <- GitHub.executeRequestWithMgrAndRes mgr auth $
+ GitHub.issuesForRepoR owner repo mempty (GitHub.FetchPage (GitHub.PageParams (Just 2) (Just 1)))
+
+ case ret of
+ Left e ->
+ expectationFailure . show $ e
+ Right res -> do
+ let issues = responseBody res
+ length issues `shouldSatisfy` (<= 2)
+
+ for_ issues $ \i -> do
+ cms <- GitHub.executeRequest auth $
+ GitHub.commentsR owner repo (GitHub.issueNumber i) 1
+ cms `shouldSatisfy` isRight
+
describe "issueR" $ do
it "fetches issue #428" $ withAuth $ \auth -> do
resIss <- GitHub.executeRequest auth $
diff --git a/src/GitHub.hs b/src/GitHub.hs
--- a/src/GitHub.hs
+++ b/src/GitHub.hs
@@ -173,6 +173,7 @@
membersOfWithR,
isMemberOfR,
orgInvitationsR,
+ orgMembershipR,
-- ** Outside Collaborators
-- | See
--
@@ -285,6 +286,15 @@
commitR,
diffR,
+ -- ** Reactions
+ -- | See
+ issueReactionsR,
+ createIssueReactionR,
+ deleteIssueReactionR,
+ commentReactionsR,
+ createCommentReactionR,
+ deleteCommentReactionR,
+
-- ** Contents
-- | See
contentsForR,
@@ -514,6 +524,7 @@
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
diff --git a/src/GitHub/Auth.hs b/src/GitHub/Auth.hs
--- a/src/GitHub/Auth.hs
+++ b/src/GitHub/Auth.hs
@@ -1,5 +1,7 @@
module GitHub.Auth (
Auth (..),
+ Token,
+ JWTToken,
AuthMethod,
endpoint,
setAuthRequest
@@ -9,14 +11,17 @@
import Prelude ()
import qualified Data.ByteString as BS
+import qualified Data.Text.Encoding as TE
import qualified Network.HTTP.Client as HTTP
type Token = BS.ByteString
+type JWTToken = Text
-- | The Github auth data type
data Auth
= BasicAuth BS.ByteString BS.ByteString -- ^ Username and password
| OAuth Token -- ^ OAuth token
+ | JWT JWTToken -- ^ JWT Token
| EnterpriseOAuth Text Token -- ^ Custom endpoint and OAuth token
deriving (Show, Data, Typeable, Eq, Ord, Generic)
@@ -40,10 +45,12 @@
instance AuthMethod Auth where
endpoint (BasicAuth _ _) = Nothing
endpoint (OAuth _) = Nothing
+ endpoint (JWT _) = Nothing
endpoint (EnterpriseOAuth e _) = Just e
setAuthRequest (BasicAuth u p) = HTTP.applyBasicAuth u p
setAuthRequest (OAuth t) = setAuthHeader $ "token " <> t
+ setAuthRequest (JWT t) = setAuthHeader $ "Bearer " <> TE.encodeUtf8 t
setAuthRequest (EnterpriseOAuth _ t) = setAuthHeader $ "token " <> t
setAuthHeader :: BS.ByteString -> HTTP.Request -> HTTP.Request
diff --git a/src/GitHub/Data.hs b/src/GitHub/Data.hs
--- a/src/GitHub/Data.hs
+++ b/src/GitHub/Data.hs
@@ -1,5 +1,3 @@
-{-# LANGUAGE CPP #-}
-
-- |
-- This module re-exports the @GitHub.Data.@ and "GitHub.Auth" submodules.
@@ -57,6 +55,7 @@
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,
@@ -99,6 +98,7 @@
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
diff --git a/src/GitHub/Data/Actions/WorkflowJobs.hs b/src/GitHub/Data/Actions/WorkflowJobs.hs
--- a/src/GitHub/Data/Actions/WorkflowJobs.hs
+++ b/src/GitHub/Data/Actions/WorkflowJobs.hs
@@ -47,6 +47,7 @@
, jobConclusion :: !Text
, jobStartedAt :: !UTCTime
, jobCompletedAt :: !UTCTime
+ , jobName :: !(Name Job)
, jobSteps :: !(Vector JobStep)
, jobRunCheckUrl :: !URL
, jobLabels :: !(Vector Text)
@@ -84,6 +85,7 @@
<*> o .: "conclusion"
<*> o .: "started_at"
<*> o .: "completed_at"
+ <*> o .: "name"
<*> o .: "steps"
<*> o .: "check_run_url"
<*> o .: "labels"
diff --git a/src/GitHub/Data/Activities.hs b/src/GitHub/Data/Activities.hs
--- a/src/GitHub/Data/Activities.hs
+++ b/src/GitHub/Data/Activities.hs
@@ -26,7 +26,7 @@
data Subject = Subject
{ subjectTitle :: !Text
- , subjectURL :: !URL
+ , subjectURL :: !(Maybe URL)
, subjectLatestCommentURL :: !(Maybe URL)
-- https://developer.github.com/v3/activity/notifications/ doesn't indicate
-- what the possible values for this field are.
@@ -46,13 +46,18 @@
<*> o .: "type"
data NotificationReason
- = AssignReason
+ = ApprovalRequestedReason
+ | AssignReason
| AuthorReason
| CommentReason
+ | CiActivityReason
| InvitationReason
| ManualReason
+ | MemberFeatureRequestedReason
| MentionReason
| ReviewRequestedReason
+ | SecurityAlertReason
+ | SecurityAdvisoryCreditReason
| StateChangeReason
| SubscribedReason
| TeamMentionReason
@@ -63,17 +68,22 @@
instance FromJSON NotificationReason where
parseJSON = withText "NotificationReason" $ \t -> case T.toLower t of
- "assign" -> pure AssignReason
- "author" -> pure AuthorReason
- "comment" -> pure CommentReason
- "invitation" -> pure InvitationReason
- "manual" -> pure ManualReason
- "mention" -> pure MentionReason
- "review_requested" -> pure ReviewRequestedReason
- "state_change" -> pure StateChangeReason
- "subscribed" -> pure SubscribedReason
- "team_mention" -> pure TeamMentionReason
- _ -> fail $ "Unknown NotificationReason " ++ show t
+ "approval_requested" -> pure ApprovalRequestedReason
+ "assign" -> pure AssignReason
+ "author" -> pure AuthorReason
+ "comment" -> pure CommentReason
+ "ci_activity" -> pure CiActivityReason
+ "invitation" -> pure InvitationReason
+ "manual" -> pure ManualReason
+ "member_feature_requested" -> pure MemberFeatureRequestedReason
+ "mention" -> pure MentionReason
+ "review_requested" -> pure ReviewRequestedReason
+ "security_alert" -> pure SecurityAlertReason
+ "security_advisory_credit" -> pure SecurityAdvisoryCreditReason
+ "state_change" -> pure StateChangeReason
+ "subscribed" -> pure SubscribedReason
+ "team_mention" -> pure TeamMentionReason
+ _ -> fail $ "Unknown NotificationReason " ++ show t
data Notification = Notification
-- XXX: The notification id field type IS in fact string. Not sure why gh
diff --git a/src/GitHub/Data/Definitions.hs b/src/GitHub/Data/Definitions.hs
--- a/src/GitHub/Data/Definitions.hs
+++ b/src/GitHub/Data/Definitions.hs
@@ -233,6 +233,63 @@
-- | Count of elements
type Count = Int
+
+
+data MembershipRole
+ = MembershipRoleMember
+ | MembershipRoleAdmin
+ | MembershipRoleBillingManager
+ deriving
+ (Eq, Ord, Show, Enum, Bounded, Generic, Typeable, Data)
+
+instance NFData MembershipRole where rnf = genericRnf
+instance Binary MembershipRole
+
+instance FromJSON MembershipRole where
+ parseJSON = withText "MembershipRole" $ \t -> case T.toLower t of
+ "member" -> pure MembershipRoleMember
+ "admin" -> pure MembershipRoleAdmin
+ "billing_manager" -> pure MembershipRoleBillingManager
+ _ -> fail $ "Unknown MembershipRole: " <> T.unpack t
+
+data MembershipState
+ = MembershipPending
+ | MembershipActive
+ deriving (Show, Data, Typeable, Eq, Ord, Generic)
+
+instance NFData MembershipState where rnf = genericRnf
+instance Binary MembershipState
+
+instance FromJSON MembershipState where
+ parseJSON = withText "MembershipState" $ \t -> case T.toLower t of
+ "active" -> pure MembershipActive
+ "pending" -> pure MembershipPending
+ _ -> fail $ "Unknown MembershipState: " <> T.unpack t
+
+
+data Membership = Membership
+ { membershipUrl :: !URL
+ , membershipState :: !MembershipState
+ , membershipRole :: !MembershipRole
+ , membershipOrganizationUrl :: !URL
+ , membershipOrganization :: !SimpleOrganization
+ , membershipUser :: !SimpleUser
+ }
+ deriving (Show, Data, Typeable, Eq, Ord, Generic)
+
+instance NFData Membership where rnf = genericRnf
+instance Binary Membership
+
+instance FromJSON Membership where
+ parseJSON = withObject "Membership" $ \o -> Membership
+ <$> o .: "url"
+ <*> o .: "state"
+ <*> o .: "role"
+ <*> o .: "organization_url"
+ <*> o .: "organization"
+ <*> o .: "user"
+
+
-------------------------------------------------------------------------------
-- IssueNumber
-------------------------------------------------------------------------------
diff --git a/src/GitHub/Data/Name.hs b/src/GitHub/Data/Name.hs
--- a/src/GitHub/Data/Name.hs
+++ b/src/GitHub/Data/Name.hs
@@ -1,4 +1,3 @@
-{-# LANGUAGE CPP #-}
module GitHub.Data.Name (
Name(..),
mkName,
@@ -8,10 +7,8 @@
import Prelude ()
import GitHub.Internal.Prelude
-#if MIN_VERSION_aeson(1,0,0)
import Data.Aeson.Types
(FromJSONKey (..), ToJSONKey (..), fromJSONKeyCoerce, toJSONKeyText)
-#endif
newtype Name entity = N Text
deriving (Eq, Ord, Show, Generic, Typeable, Data)
@@ -38,7 +35,6 @@
instance IsString (Name entity) where
fromString = N . fromString
-#if MIN_VERSION_aeson(1,0,0)
-- | @since 0.15.0.0
instance ToJSONKey (Name entity) where
toJSONKey = toJSONKeyText untagName
@@ -46,4 +42,3 @@
-- | @since 0.15.0.0
instance FromJSONKey (Name entity) where
fromJSONKey = fromJSONKeyCoerce
-#endif
diff --git a/src/GitHub/Data/Options.hs b/src/GitHub/Data/Options.hs
--- a/src/GitHub/Data/Options.hs
+++ b/src/GitHub/Data/Options.hs
@@ -122,6 +122,7 @@
-- | 'GitHub.Data.Issues.Issue' state reason
data IssueStateReason
= StateReasonCompleted
+ | StateReasonDuplicate
| StateReasonNotPlanned
| StateReasonReopened
deriving
@@ -130,12 +131,14 @@
instance ToJSON IssueStateReason where
toJSON = String . \case
StateReasonCompleted -> "completed"
+ StateReasonDuplicate -> "duplicate"
StateReasonNotPlanned -> "not_planned"
StateReasonReopened -> "reopened"
instance FromJSON IssueStateReason where
parseJSON = withText "IssueStateReason" $ \t -> case T.toLower t of
"completed" -> pure StateReasonCompleted
+ "duplicate" -> pure StateReasonDuplicate
"not_planned" -> pure StateReasonNotPlanned
"reopened" -> pure StateReasonReopened
_ -> fail $ "Unknown IssueStateReason: " <> T.unpack t
diff --git a/src/GitHub/Data/RateLimit.hs b/src/GitHub/Data/RateLimit.hs
--- a/src/GitHub/Data/RateLimit.hs
+++ b/src/GitHub/Data/RateLimit.hs
@@ -3,7 +3,7 @@
import GitHub.Internal.Prelude
import Prelude ()
-import Data.Time.Clock.System.Compat (SystemTime (..))
+import Data.Time.Clock.System (SystemTime (..))
import qualified Data.ByteString.Char8 as BS8
import qualified Network.HTTP.Client as HTTP
diff --git a/src/GitHub/Data/Reactions.hs b/src/GitHub/Data/Reactions.hs
new file mode 100644
--- /dev/null
+++ b/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
+
+-- |
+--
+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"
diff --git a/src/GitHub/Data/Repos.hs b/src/GitHub/Data/Repos.hs
--- a/src/GitHub/Data/Repos.hs
+++ b/src/GitHub/Data/Repos.hs
@@ -1,6 +1,4 @@
-{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
-#define UNSAFE 1
-- |
-- This module also exports
@@ -19,13 +17,7 @@
import qualified Data.HashMap.Strict as HM
import qualified Data.Text as T
-#if MIN_VERSION_aeson(1,0,0)
import Data.Aeson.Types (FromJSONKey (..), fromJSONKeyCoerce)
-#else
-#ifdef UNSAFE
-import Unsafe.Coerce (unsafeCoerce)
-#endif
-#endif
data Repo = Repo
{ repoId :: !(Id Repo)
@@ -383,22 +375,8 @@
instance ToJSON Language where
toJSON = toJSON . getLanguage
-#if MIN_VERSION_aeson(1,0,0)
instance FromJSONKey Language where
fromJSONKey = fromJSONKeyCoerce
-#else
-instance FromJSON a => FromJSON (HM.HashMap Language a) where
- parseJSON = fmap mapKeyLanguage . parseJSON
- where
- mapKeyLanguage :: HM.HashMap Text a -> HM.HashMap Language a
-#ifdef UNSAFE
- mapKeyLanguage = unsafeCoerce
-#else
- mapKeyLanguage = mapKey Language
- mapKey :: (Eq k2, Hashable k2) => (k1 -> k2) -> HM.HashMap k1 a -> HM.HashMap k2 a
- mapKey f = HM.fromList . map (first f) . HM.toList
-#endif
-#endif
data ArchiveFormat
= ArchiveFormatTarball -- ^ ".tar.gz" format
diff --git a/src/GitHub/Data/Request.hs b/src/GitHub/Data/Request.hs
--- a/src/GitHub/Data/Request.hs
+++ b/src/GitHub/Data/Request.hs
@@ -1,4 +1,3 @@
-{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
@@ -15,6 +14,8 @@
CommandMethod(..),
toMethod,
FetchCount(..),
+ PageParams(..),
+ PageLinks(..),
MediaType (..),
Paths,
IsPathPart(..),
@@ -30,6 +31,7 @@
import qualified Data.ByteString.Lazy as LBS
import qualified Data.Text as T
import qualified Network.HTTP.Types.Method as Method
+import Network.URI (URI)
------------------------------------------------------------------------------
-- Path parts
@@ -75,7 +77,10 @@
-- | 'PagedQuery' returns just some results, using this data we can specify how
-- many pages we want to fetch.
-data FetchCount = FetchAtLeast !Word | FetchAll
+data FetchCount =
+ FetchAtLeast !Word
+ | FetchAll
+ | FetchPage PageParams
deriving (Eq, Ord, Read, Show, Generic, Typeable)
@@ -96,6 +101,37 @@
instance Hashable FetchCount
instance Binary FetchCount
instance NFData FetchCount where rnf = genericRnf
+
+-------------------------------------------------------------------------------
+-- PageParams
+-------------------------------------------------------------------------------
+
+-- | Params for specifying the precise page and items per page.
+data PageParams = PageParams {
+ pageParamsPerPage :: Maybe Int
+ , pageParamsPage :: Maybe Int
+ }
+ deriving (Eq, Ord, Read, Show, Generic, Typeable)
+
+instance Hashable PageParams
+instance Binary PageParams
+instance NFData PageParams where rnf = genericRnf
+
+-------------------------------------------------------------------------------
+-- PageLinks
+-------------------------------------------------------------------------------
+
+-- | 'PagedQuery' returns just some results, using this data we can specify how
+-- many pages we want to fetch.
+data PageLinks = PageLinks {
+ pageLinksPrev :: Maybe URI
+ , pageLinksNext :: Maybe URI
+ , pageLinksLast :: Maybe URI
+ , pageLinksFirst :: Maybe URI
+ }
+ deriving (Eq, Ord, Show, Generic, Typeable)
+
+instance NFData PageLinks where rnf = genericRnf
-------------------------------------------------------------------------------
-- MediaType
diff --git a/src/GitHub/Endpoints/Issues.hs b/src/GitHub/Endpoints/Issues.hs
--- a/src/GitHub/Endpoints/Issues.hs
+++ b/src/GitHub/Endpoints/Issues.hs
@@ -1,5 +1,3 @@
-{-# LANGUAGE CPP #-}
-
-- |
-- The issues API as described on .
diff --git a/src/GitHub/Endpoints/Organizations/Members.hs b/src/GitHub/Endpoints/Organizations/Members.hs
--- a/src/GitHub/Endpoints/Organizations/Members.hs
+++ b/src/GitHub/Endpoints/Organizations/Members.hs
@@ -7,6 +7,7 @@
membersOfWithR,
isMemberOfR,
orgInvitationsR,
+ orgMembershipR,
module GitHub.Data,
) where
@@ -48,3 +49,10 @@
-- See
orgInvitationsR :: Name Organization -> FetchCount -> Request 'RA (Vector Invitation)
orgInvitationsR org = pagedQuery ["orgs", toPathPart org, "invitations"] []
+
+-- | Get user membership information in an organization
+--
+-- See
+orgMembershipR :: Name User -> Name Organization -> Request 'RA Membership
+orgMembershipR user org =
+ Query [ "orgs", toPathPart org, "memberships", toPathPart user ] []
diff --git a/src/GitHub/Endpoints/Reactions.hs b/src/GitHub/Endpoints/Reactions.hs
new file mode 100644
--- /dev/null
+++ b/src/GitHub/Endpoints/Reactions.hs
@@ -0,0 +1,60 @@
+-- |
+-- The Reactions API as described at
+-- .
+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
+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
+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
+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
+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
+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]
diff --git a/src/GitHub/Endpoints/Repos/Comments.hs b/src/GitHub/Endpoints/Repos/Comments.hs
--- a/src/GitHub/Endpoints/Repos/Comments.hs
+++ b/src/GitHub/Endpoints/Repos/Comments.hs
@@ -1,5 +1,3 @@
-{-# LANGUAGE CPP #-}
-
-- |
-- The repo commits API as described on
-- .
diff --git a/src/GitHub/Endpoints/Repos/Commits.hs b/src/GitHub/Endpoints/Repos/Commits.hs
--- a/src/GitHub/Endpoints/Repos/Commits.hs
+++ b/src/GitHub/Endpoints/Repos/Commits.hs
@@ -1,5 +1,3 @@
-{-# LANGUAGE CPP #-}
-
-- |
-- The repo commits API as described on
-- .
diff --git a/src/GitHub/Internal/Prelude.hs b/src/GitHub/Internal/Prelude.hs
--- a/src/GitHub/Internal/Prelude.hs
+++ b/src/GitHub/Internal/Prelude.hs
@@ -1,5 +1,4 @@
{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE CPP #-}
-- |
-- This module may change between minor releases. Do not rely on its contents.
@@ -24,7 +23,7 @@
import Data.Semigroup as X (Semigroup (..))
import Data.String as X (IsString (..))
import Data.Text as X (Text, pack, unpack)
-import Data.Time.Compat as X (UTCTime)
+import Data.Time as X (UTCTime)
import Data.Time.ISO8601 as X (formatISO8601)
import Data.Vector as X (Vector)
import GHC.Generics as X (Generic)
diff --git a/src/GitHub/Request.hs b/src/GitHub/Request.hs
--- a/src/GitHub/Request.hs
+++ b/src/GitHub/Request.hs
@@ -54,6 +54,7 @@
ParseResponse (..),
makeHttpRequest,
parseStatus,
+ parsePageLinks,
StatusMap,
getNextUrl,
performPagedRequest,
@@ -79,6 +80,7 @@
import Control.Monad.Trans.Except (ExceptT (..), runExceptT)
import Data.Aeson (eitherDecode)
import Data.List (find)
+import Data.Maybe (fromMaybe)
import Data.Tagged (Tagged (..))
import Data.Version (showVersion)
@@ -87,13 +89,14 @@
httpLbs, method, newManager, redirectCount, requestBody, requestHeaders,
setQueryString, setRequestIgnoreStatus)
import Network.HTTP.Link.Parser (parseLinkHeaderBS)
-import Network.HTTP.Link.Types (LinkParam (..), href, linkParams)
+import Network.HTTP.Link.Types (Link(..), LinkParam (..), href, linkParams)
import Network.HTTP.Types (Method, RequestHeaders, Status (..))
import Network.URI
(URI, escapeURIString, isUnescapedInURIComponent, parseURIReference,
relativeTo)
import qualified Data.ByteString as BS
+import Data.ByteString.Builder (intDec, toLazyByteString)
import qualified Data.ByteString.Lazy as LBS
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
@@ -199,11 +202,6 @@
manager <- newManager tlsManagerSettings
executeRequestWithMgr manager auth req
-lessFetchCount :: Int -> FetchCount -> Bool
-lessFetchCount _ FetchAll = True
-lessFetchCount i (FetchAtLeast j) = i < fromIntegral j
-
-
-- | Like 'executeRequest' but with provided 'Manager'.
executeRequestWithMgr
:: (AuthMethod am, ParseResponse mt a)
@@ -235,10 +233,13 @@
res <- httpLbs' httpReq
(<$ res) <$> unTagged (parseResponse httpReq res :: Tagged mt (ExceptT Error IO b))
- performHttpReq httpReq (PagedQuery _ _ l) =
- unTagged (performPagedRequest httpLbs' predicate httpReq :: Tagged mt (ExceptT Error IO (HTTP.Response b)))
- where
- predicate v = lessFetchCount (length v) l
+ performHttpReq httpReq (PagedQuery _ _ (FetchPage _)) = do
+ (res, _pageLinks) <- unTagged (performPerPageRequest httpLbs' httpReq :: Tagged mt (ExceptT Error IO (HTTP.Response b, PageLinks)))
+ return res
+ performHttpReq httpReq (PagedQuery _ _ FetchAll) =
+ unTagged (performPagedRequest httpLbs' (const True) httpReq :: Tagged mt (ExceptT Error IO (HTTP.Response b)))
+ performHttpReq httpReq (PagedQuery _ _ (FetchAtLeast j)) =
+ unTagged (performPagedRequest httpLbs' (\v -> length v < fromIntegral j) httpReq :: Tagged mt (ExceptT Error IO (HTTP.Response b)))
performHttpReq httpReq (Command _ _ _) = do
res <- httpLbs' httpReq
@@ -456,7 +457,7 @@
$ setReqHeaders
. unTagged (modifyRequest :: Tagged mt (HTTP.Request -> HTTP.Request))
. maybe id setAuthRequest auth
- . setQueryString qs
+ . setQueryString (qs <> extraQueryItems)
$ req
PagedQuery paths qs _ -> do
req <- parseUrl' $ url paths
@@ -464,7 +465,7 @@
$ setReqHeaders
. unTagged (modifyRequest :: Tagged mt (HTTP.Request -> HTTP.Request))
. maybe id setAuthRequest auth
- . setQueryString qs
+ . setQueryString (qs <> extraQueryItems)
$ req
Command m paths body -> do
req <- parseUrl' $ url paths
@@ -496,6 +497,14 @@
setBody :: LBS.ByteString -> HTTP.Request -> HTTP.Request
setBody body req = req { requestBody = RequestBodyLBS body }
+ extraQueryItems :: [(BS.ByteString, Maybe BS.ByteString)]
+ extraQueryItems = case r of
+ PagedQuery _ _ (FetchPage pp) -> catMaybes [
+ (\page -> ("page", Just (LBS.toStrict $ toLazyByteString $ intDec page))) <$> pageParamsPage pp
+ , (\perPage -> ("per_page", Just (LBS.toStrict $ toLazyByteString $ intDec perPage))) <$> pageParamsPerPage pp
+ ]
+ _ -> []
+
-- | Query @Link@ header with @rel=next@ from the request headers.
getNextUrl :: HTTP.Response a -> Maybe URI
getNextUrl req = do
@@ -541,6 +550,35 @@
m <- unTagged (parseResponse req' res' :: Tagged mt (m a))
go (acc <> m) res' req'
(_, _) -> return (acc <$ res)
+
+-- | Helper for requesting a single page, as specified by 'PageParams'.
+--
+-- This parses and returns the 'PageLinks' alongside the HTTP response.
+performPerPageRequest
+ :: forall a m mt. (ParseResponse mt a, MonadCatch m, MonadError Error m)
+ => (HTTP.Request -> m (HTTP.Response LBS.ByteString)) -- ^ `httpLbs` analogue
+ -> HTTP.Request -- ^ initial request
+ -> Tagged mt (m (HTTP.Response a, PageLinks))
+performPerPageRequest httpLbs' initReq = Tagged $ do
+ res <- httpLbs' initReq
+ m <- unTagged (parseResponse initReq res :: Tagged mt (m a))
+ return (m <$ res, parsePageLinks res)
+
+-- | Parse the 'PageLinks' from an HTTP response, where the information is
+-- encoded in the Link header.
+parsePageLinks :: HTTP.Response a -> PageLinks
+parsePageLinks res = PageLinks {
+ pageLinksPrev = linkToUri <$> find (elem (Rel, "prev") . linkParams) links
+ , pageLinksNext = linkToUri <$> find (elem (Rel, "next") . linkParams) links
+ , pageLinksLast = linkToUri <$> find (elem (Rel, "last") . linkParams) links
+ , pageLinksFirst = linkToUri <$> find (elem (Rel, "first") . linkParams) links
+ }
+ where
+ links :: [Link URI]
+ links = fromMaybe [] (lookup "Link" (responseHeaders res) >>= parseLinkHeaderBS)
+
+ linkToUri :: Link URI -> URI
+ linkToUri (Link uri _) = uri
-------------------------------------------------------------------------------
-- Internal