diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,14 @@ +## Changes for 0.20 + +- Add ratelimit endpoint + [#315](https://github.com/phadej/github/pull/315) +- Add some deployment endoints + [#330](https://github.com/phadej/github/pull/330) +- Add webhook installation events + [#329](https://github.com/phadej/github/pull/330) +- Tigthen lower bounds (also remove aeson-compat dep) + [#332](https://github.com/phadej/github/pull/332) + ## Changes for 0.19 - Fix issue event type enumeration diff --git a/github.cabal b/github.cabal --- a/github.cabal +++ b/github.cabal @@ -1,5 +1,5 @@ name: github -version: 0.19 +version: 0.20 synopsis: Access to the GitHub API, v3. description: The GitHub API provides programmatic access to the full @@ -25,7 +25,7 @@ copyright: Copyright 2012-2013 Mike Burns, Copyright 2013-2015 John Wiegley, Copyright 2016 Oleg Grenrus category: Network build-type: Simple -tested-with: GHC==7.8.4, GHC==7.10.3, GHC==8.0.2, GHC==8.2.2 +tested-with: GHC==7.8.4, GHC==7.10.3, GHC==8.0.2, GHC==8.2.2, GHC==8.4.3, GHC==8.6.1 cabal-version: >=1.10 extra-source-files: README.md, @@ -38,11 +38,6 @@ fixtures/user-organizations.json, fixtures/user.json -flag aeson-compat - description: Whether to use aeson-compat or aeson-extra - default: True - manual: False - source-repository head type: git location: git://github.com/phadej/github.git @@ -64,6 +59,7 @@ GADTs KindSignatures StandaloneDeriving + RecordWildCards exposed-modules: GitHub GitHub.Internal.Prelude @@ -74,6 +70,7 @@ GitHub.Data.Content GitHub.Data.Definitions GitHub.Data.DeployKeys + GitHub.Data.Deployments GitHub.Data.Email GitHub.Data.Events GitHub.Data.Gists @@ -85,6 +82,7 @@ GitHub.Data.Name GitHub.Data.Options GitHub.Data.PullRequests + GitHub.Data.RateLimit GitHub.Data.Releases GitHub.Data.Repos GitHub.Data.Request @@ -115,12 +113,14 @@ GitHub.Endpoints.PullRequests GitHub.Endpoints.PullRequests.Reviews GitHub.Endpoints.PullRequests.Comments + GitHub.Endpoints.RateLimit GitHub.Endpoints.Repos GitHub.Endpoints.Repos.Collaborators GitHub.Endpoints.Repos.Comments GitHub.Endpoints.Repos.Commits GitHub.Endpoints.Repos.Contents GitHub.Endpoints.Repos.DeployKeys + GitHub.Endpoints.Repos.Deployments GitHub.Endpoints.Repos.Forks GitHub.Endpoints.Repos.Releases GitHub.Endpoints.Repos.Statuses @@ -133,9 +133,10 @@ -- Packages bundles with GHC, mtl and text are also here build-depends: - base >=4.7 && <4.11, + base >=4.7 && <4.13, + binary >=0.7.1.0 && <0.11, bytestring >=0.10.4.0 && <0.11, - containers >=0.5.5.1 && <0.6, + containers >=0.5.5.1 && <0.7, deepseq >=1.3.0.2 && <1.5, mtl (>=2.1.3.1 && <2.2) || (>=2.2.1 && <2.3), text >=1.2.0.6 && <1.3, @@ -144,34 +145,28 @@ -- other packages build-depends: - aeson >=0.7.0.6 && <1.3, - base-compat >=0.9.1 && <0.10, + aeson >=1.4.0.0 && <1.5, + base-compat >=0.10.4 && <0.11, base16-bytestring >=0.1.1.6 && <0.2, - binary >=0.7.1.0 && <0.10, - binary-orphans >=0.1.0.0 && <0.2, + binary-orphans >=0.1.8.0 && <0.2, byteable >=0.1.1 && <0.2, - cryptohash >=0.11 && <0.12, - deepseq-generics >=0.1.1.2 && <0.3, - exceptions >=0.8.0.2 && <0.9, - hashable >=1.2.3.3 && <1.3, - http-client >=0.4.8.1 && <0.6, - http-client-tls >=0.2.2 && <0.4, - http-link-header >=1.0.1 && <1.1, + cryptohash >=0.11.9 && <0.12, + deepseq-generics >=0.2.0.0 && <0.3, + exceptions >=0.10.0 && <0.11, + hashable >=1.2.7.0 && <1.3, + http-client >=0.5.12 && <0.6, + http-client-tls >=0.3.5.3 && <0.4, + http-link-header >=1.0.3.1 && <1.1, http-types >=0.12.1 && <0.13, - iso8601-time >=0.1.4 && <0.2, - network-uri >=2.6.0.3 && <2.7, - semigroups >=0.16.2.2 && <0.19, - transformers-compat >=0.4.0.3 && <0.6, - unordered-containers >=0.2 && <0.3, - vector >=0.10.12.3 && <0.13, - vector-instances >=3.3.0.1 && <3.5, - - tls >=1.3.5 + iso8601-time >=0.1.5 && <0.2, + network-uri >=2.6.1.0 && <2.7, + semigroups >=0.18.5 && <0.19, + transformers-compat >=0.6 && <0.7, + unordered-containers >=0.2.9.0 && <0.3, + vector >=0.12.0.1 && <0.13, + vector-instances >=3.4 && <3.5, - if flag(aeson-compat) - build-depends: aeson-compat >=0.3.0.0 && <0.4 - else - build-depends: aeson-extra >=0.2.0.0 && <0.3 + tls >=1.4.1 test-suite github-test default-language: Haskell2010 @@ -182,28 +177,25 @@ other-modules: GitHub.ActivitySpec GitHub.CommitsSpec - GitHub.OrganizationsSpec + GitHub.EventsSpec GitHub.IssuesSpec - GitHub.PullRequestsSpec + GitHub.OrganizationsSpec GitHub.PullRequestReviewsSpec + GitHub.PullRequestsSpec + GitHub.RateLimitSpec GitHub.ReleasesSpec GitHub.ReposSpec GitHub.SearchSpec GitHub.UsersSpec - GitHub.EventsSpec main-is: Spec.hs ghc-options: -Wall - build-tool-depends: hspec-discover:hspec-discover + build-tool-depends: hspec-discover:hspec-discover >=2.5.6 && <2.6 build-depends: base, base-compat, + aeson, bytestring, github, vector, unordered-containers, file-embed, - hspec - if flag(aeson-compat) - build-depends: aeson-compat - else - build-depends: aeson-extra - + hspec >= 2.5.6 && <2.6 diff --git a/spec/GitHub/OrganizationsSpec.hs b/spec/GitHub/OrganizationsSpec.hs --- a/spec/GitHub/OrganizationsSpec.hs +++ b/spec/GitHub/OrganizationsSpec.hs @@ -3,19 +3,18 @@ module GitHub.OrganizationsSpec where import GitHub.Auth (Auth (..)) -import GitHub.Data (SimpleOrganization (..), - SimpleOwner (..), - SimpleTeam (..)) +import GitHub.Data + (SimpleOrganization (..), SimpleOwner (..), SimpleTeam (..)) import GitHub.Endpoints.Organizations (publicOrganizationsFor') import GitHub.Endpoints.Organizations.Members (membersOf') -import Data.Aeson.Compat (eitherDecodeStrict) +import Data.Aeson (eitherDecodeStrict) import Data.Either.Compat (isRight) import Data.FileEmbed (embedFile) import Data.String (fromString) import System.Environment (lookupEnv) -import Test.Hspec (Spec, describe, it, pendingWith, shouldBe, - shouldSatisfy) +import Test.Hspec + (Spec, describe, it, pendingWith, shouldBe, shouldSatisfy) fromRightS :: Show a => Either a b -> b fromRightS (Right b) = b diff --git a/spec/GitHub/PullRequestReviewsSpec.hs b/spec/GitHub/PullRequestReviewsSpec.hs --- a/spec/GitHub/PullRequestReviewsSpec.hs +++ b/spec/GitHub/PullRequestReviewsSpec.hs @@ -2,16 +2,16 @@ module GitHub.PullRequestReviewsSpec where import qualified GitHub -import GitHub.Data.Id (Id(Id)) +import GitHub.Data.Id (Id (Id)) 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, it, pendingWith, shouldSatisfy) +import Data.Either.Compat (isRight) +import Data.Foldable (for_) +import Data.String (fromString) +import System.Environment (lookupEnv) +import Test.Hspec (Spec, describe, it, pendingWith, shouldSatisfy) withAuth :: (GitHub.Auth -> IO ()) -> IO () withAuth action = do diff --git a/spec/GitHub/PullRequestsSpec.hs b/spec/GitHub/PullRequestsSpec.hs --- a/spec/GitHub/PullRequestsSpec.hs +++ b/spec/GitHub/PullRequestsSpec.hs @@ -3,20 +3,21 @@ module GitHub.PullRequestsSpec where import qualified GitHub -import GitHub.Data.Id (Id(Id)) +import GitHub.Data.Id (Id (Id)) import Prelude () import Prelude.Compat -import Data.Aeson.Compat (eitherDecodeStrict) -import Data.ByteString (ByteString) -import Data.Either.Compat (isRight) -import Data.FileEmbed (embedFile) -import Data.Foldable (for_) -import Data.String (fromString) -import qualified Data.Vector as V -import System.Environment (lookupEnv) -import Test.Hspec (Spec, describe, it, pendingWith, shouldBe, shouldSatisfy) +import Data.Aeson (eitherDecodeStrict) +import Data.ByteString (ByteString) +import Data.Either.Compat (isRight) +import Data.FileEmbed (embedFile) +import Data.Foldable (for_) +import Data.String (fromString) +import qualified Data.Vector as V +import System.Environment (lookupEnv) +import Test.Hspec + (Spec, describe, it, pendingWith, shouldBe, shouldSatisfy) fromRightS :: Show a => Either a b -> b fromRightS (Right b) = b diff --git a/spec/GitHub/RateLimitSpec.hs b/spec/GitHub/RateLimitSpec.hs new file mode 100644 --- /dev/null +++ b/spec/GitHub/RateLimitSpec.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE OverloadedStrings #-} +module GitHub.RateLimitSpec where + +import qualified GitHub + +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, 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 + +withAuth :: (GitHub.Auth -> IO ()) -> IO () +withAuth action = do + mtoken <- lookupEnv "GITHUB_TOKEN" + case mtoken of + Nothing -> pendingWith "no GITHUB_TOKEN" + Just token -> action (GitHub.OAuth $ fromString token) + +spec :: Spec +spec = describe "rateLimitR" $ + it "works" $ withAuth $ \auth -> do + cs <- GitHub.executeRequest auth GitHub.rateLimitR + cs `shouldSatisfy` isRight diff --git a/spec/GitHub/SearchSpec.hs b/spec/GitHub/SearchSpec.hs --- a/spec/GitHub/SearchSpec.hs +++ b/spec/GitHub/SearchSpec.hs @@ -2,10 +2,10 @@ {-# LANGUAGE TemplateHaskell #-} module GitHub.SearchSpec where -import Prelude () +import Prelude () import Prelude.Compat -import Data.Aeson.Compat (eitherDecodeStrict) +import Data.Aeson (eitherDecodeStrict) import Data.FileEmbed (embedFile) import Data.Proxy (Proxy (..)) import Data.String (fromString) @@ -14,7 +14,7 @@ import qualified Data.Vector as V -import GitHub.Data (Auth (..), Issue (..), mkId, IssueState (..)) +import GitHub.Data (Auth (..), Issue (..), IssueState (..), mkId) import GitHub.Endpoints.Search (SearchResult (..), searchIssues') fromRightS :: Show a => Either a b -> b diff --git a/spec/GitHub/UsersSpec.hs b/spec/GitHub/UsersSpec.hs --- a/spec/GitHub/UsersSpec.hs +++ b/spec/GitHub/UsersSpec.hs @@ -2,20 +2,20 @@ {-# LANGUAGE TemplateHaskell #-} module GitHub.UsersSpec where -import Data.Aeson.Compat (eitherDecodeStrict) +import Data.Aeson (eitherDecodeStrict) import Data.Either.Compat (isLeft, isRight) import Data.FileEmbed (embedFile) import Data.String (fromString) import System.Environment (lookupEnv) -import Test.Hspec (Spec, describe, it, pendingWith, shouldBe, - shouldSatisfy) +import Test.Hspec + (Spec, describe, it, pendingWith, shouldBe, shouldSatisfy) import qualified GitHub -import GitHub.Data (Auth (..), Organization (..), - User (..), fromOwner) -import GitHub.Endpoints.Users (ownerInfoForR, userInfoCurrent', - userInfoFor') +import GitHub.Data + (Auth (..), Organization (..), User (..), fromOwner) +import GitHub.Endpoints.Users + (ownerInfoForR, userInfoCurrent', userInfoFor') import GitHub.Endpoints.Users.Followers (usersFollowedByR, usersFollowingR) import GitHub.Request (executeRequest) diff --git a/src/GitHub.hs b/src/GitHub.hs --- a/src/GitHub.hs +++ b/src/GitHub.hs @@ -259,7 +259,7 @@ -- -- * Create a commit comment -- * Update a commit comment - -- * Delete a commit comment + -- * Delete a commit comment commentsForR, commitCommentsForR, commitCommentForR, @@ -271,6 +271,18 @@ commitR, diffR, + -- ** Deployments + -- | See + -- + -- Missing endpoints: + -- * Get a single deployment + -- * Update a deployment + -- * Get a single deployment status + deploymentsWithOptionsForR, + createDeploymentR, + deploymentStatusesForR, + createDeploymentStatusR, + -- ** Forks -- | See -- @@ -345,6 +357,10 @@ statusesForR, statusForR, + -- ** Rate Limit + -- | See + rateLimitR, + -- * Data definitions module GitHub.Data, -- * Request handling @@ -370,12 +386,14 @@ import GitHub.Endpoints.Organizations.Members import GitHub.Endpoints.Organizations.Teams import GitHub.Endpoints.PullRequests -import GitHub.Endpoints.PullRequests.Reviews import GitHub.Endpoints.PullRequests.Comments +import GitHub.Endpoints.PullRequests.Reviews +import GitHub.Endpoints.RateLimit import GitHub.Endpoints.Repos import GitHub.Endpoints.Repos.Collaborators import GitHub.Endpoints.Repos.Comments import GitHub.Endpoints.Repos.Commits +import GitHub.Endpoints.Repos.Deployments import GitHub.Endpoints.Repos.Forks import GitHub.Endpoints.Repos.Releases import GitHub.Endpoints.Repos.Statuses diff --git a/src/GitHub/Data.hs b/src/GitHub/Data.hs --- a/src/GitHub/Data.hs +++ b/src/GitHub/Data.hs @@ -37,6 +37,7 @@ module GitHub.Data.Content, module GitHub.Data.Definitions, module GitHub.Data.DeployKeys, + module GitHub.Data.Deployments, module GitHub.Data.Email, module GitHub.Data.Events, module GitHub.Data.Gists, @@ -46,6 +47,7 @@ module GitHub.Data.Milestone, module GitHub.Data.Options, module GitHub.Data.PullRequests, + module GitHub.Data.RateLimit, module GitHub.Data.Releases, module GitHub.Data.Repos, module GitHub.Data.Request, @@ -66,6 +68,7 @@ import GitHub.Data.Content import GitHub.Data.Definitions import GitHub.Data.DeployKeys +import GitHub.Data.Deployments import GitHub.Data.Email import GitHub.Data.Events import GitHub.Data.Gists @@ -77,6 +80,7 @@ import GitHub.Data.Name import GitHub.Data.Options import GitHub.Data.PullRequests +import GitHub.Data.RateLimit import GitHub.Data.Releases import GitHub.Data.Repos import GitHub.Data.Request diff --git a/src/GitHub/Data/Deployments.hs b/src/GitHub/Data/Deployments.hs new file mode 100644 --- /dev/null +++ b/src/GitHub/Data/Deployments.hs @@ -0,0 +1,205 @@ +{-# LANGUAGE LambdaCase #-} + +module GitHub.Data.Deployments + ( DeploymentQueryOption (..) + , renderDeploymentQueryOption + + , Deployment (..) + , CreateDeployment (..) + + , DeploymentStatus (..) + , DeploymentStatusState (..) + , CreateDeploymentStatus (..) + ) where + +import Control.Arrow (second) + +import Data.ByteString (ByteString) +import Data.Maybe (catMaybes) +import Data.Text (Text) +import Data.Time.Clock (UTCTime) +import Data.Vector (Vector) + +import GitHub.Data.Definitions (SimpleUser) +import GitHub.Data.Id (Id) +import GitHub.Data.Name (Name) +import GitHub.Data.URL (URL) +import GitHub.Internal.Prelude + +import qualified Data.Aeson as JSON +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text + +data DeploymentQueryOption + = DeploymentQuerySha !Text + | DeploymentQueryRef !Text + | DeploymentQueryTask !Text + | DeploymentQueryEnvironment !Text + deriving (Show, Data, Typeable, Eq, Ord, Generic) + +instance NFData DeploymentQueryOption where rnf = genericRnf +instance Binary DeploymentQueryOption + +renderDeploymentQueryOption :: DeploymentQueryOption -> (ByteString, ByteString) +renderDeploymentQueryOption = + second Text.encodeUtf8 . \case + DeploymentQuerySha sha -> ("sha", sha) + DeploymentQueryRef ref -> ("ref", ref) + DeploymentQueryTask task -> ("task", task) + DeploymentQueryEnvironment env -> ("environment", env) + +data Deployment a = Deployment + { deploymentUrl :: !URL + , deploymentId :: !(Id (Deployment a)) + , deploymentSha :: !(Name (Deployment a)) + , deploymentRef :: !Text + , deploymentTask :: !Text + , deploymentPayload :: !(Maybe a) + , deploymentEnvironment :: !Text + , deploymentDescription :: !Text + , deploymentCreator :: !SimpleUser + , deploymentCreatedAt :: !UTCTime + , deploymentUpdatedAt :: !UTCTime + , deploymentStatusesUrl :: !URL + , deploymentRepositoryUrl :: !URL + } deriving (Show, Data, Typeable, Eq, Ord, Generic) + +instance NFData a => NFData (Deployment a) where rnf = genericRnf +instance Binary a => Binary (Deployment a) + +instance FromJSON a => FromJSON (Deployment a) where + parseJSON = withObject "GitHub Deployment" $ \o -> + Deployment + <$> o .: "url" + <*> o .: "id" + <*> o .: "sha" + <*> o .: "ref" + <*> o .: "task" + <*> o .:? "payload" + <*> o .: "environment" + <*> o .: "description" + <*> o .: "creator" + <*> o .: "created_at" + <*> o .: "updated_at" + <*> o .: "statuses_url" + <*> o .: "repository_url" + +data CreateDeployment a = CreateDeployment + { createDeploymentRef :: !Text + -- ^ Required. The ref to deploy. This can be a branch, tag, or SHA. + , createDeploymentTask :: !(Maybe Text) + -- ^ Specifies a task to execute (e.g., deploy or deploy:migrations). + -- Default: deploy + , createDeploymentAutoMerge :: !(Maybe Bool) + -- ^ Attempts to automatically merge the default branch into the requested + -- ref, if it is behind the default branch. Default: true + , createDeploymentRequiredContexts :: !(Maybe (Vector Text)) + -- ^ The status contexts to verify against commit status checks. If this + -- parameter is omitted, then all unique contexts will be verified before a + -- deployment is created. To bypass checking entirely pass an empty array. + -- Defaults to all unique contexts. + , createDeploymentPayload :: !(Maybe a) + -- ^ JSON payload with extra information about the deployment. Default: "" + , createDeploymentEnvironment :: !(Maybe Text) + -- ^ Name for the target deployment environment (e.g., production, staging, + -- qa). Default: production + , createDeploymentDescription :: !(Maybe Text) + -- ^ Short description of the deployment. Default: "" + } deriving (Show, Data, Typeable, Eq, Ord, Generic) + +instance NFData a => NFData (CreateDeployment a) where rnf = genericRnf +instance Binary a => Binary (CreateDeployment a) + +instance ToJSON a => ToJSON (CreateDeployment a) where + toJSON x = + JSON.object $ catMaybes + [ Just ("ref" .= createDeploymentRef x) + , ("task" .=) <$> createDeploymentTask x + , ("auto_merge" .=) <$> createDeploymentAutoMerge x + , ("required_contexts" .=) <$> createDeploymentRequiredContexts x + , ("payload" .=) <$> createDeploymentPayload x + , ("environment" .=) <$> createDeploymentEnvironment x + , ("description" .=) <$> createDeploymentDescription x + ] + +data DeploymentStatus = DeploymentStatus + { deploymentStatusUrl :: !URL + , deploymentStatusId :: !(Id DeploymentStatus) + , deploymentStatusState :: !DeploymentStatusState + , deploymentStatusCreator :: !SimpleUser + , deploymentStatusDescription :: !Text + , deploymentStatusTargetUrl :: !URL + , deploymentStatusCreatedAt :: !UTCTime + , deploymentStatusUpdatedAt :: !UTCTime + , deploymentStatusDeploymentUrl :: !URL + , deploymentStatusRepositoryUrl :: !URL + } deriving (Show, Data, Typeable, Eq, Ord, Generic) + +instance NFData DeploymentStatus where rnf = genericRnf +instance Binary DeploymentStatus + +instance FromJSON DeploymentStatus where + parseJSON = withObject "GitHub DeploymentStatus" $ \o -> + DeploymentStatus + <$> o .: "url" + <*> o .: "id" + <*> o .: "state" + <*> o .: "creator" + <*> o .: "description" + <*> o .: "target_url" + <*> o .: "created_at" + <*> o .: "updated_at" + <*> o .: "deployment_url" + <*> o .: "repository_url" + +data DeploymentStatusState + = DeploymentStatusError + | DeploymentStatusFailure + | DeploymentStatusPending + | DeploymentStatusSuccess + | DeploymentStatusInactive + deriving (Show, Data, Typeable, Eq, Ord, Generic) + +instance NFData DeploymentStatusState where rnf = genericRnf +instance Binary DeploymentStatusState + +instance ToJSON DeploymentStatusState where + toJSON = \case + DeploymentStatusError -> "error" + DeploymentStatusFailure -> "failure" + DeploymentStatusPending -> "pending" + DeploymentStatusSuccess -> "success" + DeploymentStatusInactive -> "inactive" + +instance FromJSON DeploymentStatusState where + parseJSON = withText "GitHub DeploymentStatusState" $ \case + "error" -> pure DeploymentStatusError + "failure" -> pure DeploymentStatusFailure + "pending" -> pure DeploymentStatusPending + "success" -> pure DeploymentStatusSuccess + "inactive" -> pure DeploymentStatusInactive + x -> fail $ "Unknown deployment status: " ++ Text.unpack x + +data CreateDeploymentStatus = CreateDeploymentStatus + { createDeploymentStatusState :: !DeploymentStatusState + -- ^ Required. The state of the status. Can be one of error, failure, + -- pending, or success. + , createDeploymentStatusTargetUrl :: !(Maybe Text) -- TODO: should this be URL? + -- ^ The target URL to associate with this status. This URL should contain + -- output to keep the user updated while the task is running or serve as + -- historical information for what happened in the deployment. Default: "" + , createDeploymentStatusDescription :: !(Maybe Text) + -- ^ A short description of the status. Maximum length of 140 characters. + -- Default: "" + } deriving (Show, Data, Typeable, Eq, Ord, Generic) + +instance NFData CreateDeploymentStatus where rnf = genericRnf +instance Binary CreateDeploymentStatus + +instance ToJSON CreateDeploymentStatus where + toJSON x = + JSON.object $ catMaybes + [ Just ("state" .= createDeploymentStatusState x) + , ("target_url" .=) <$> createDeploymentStatusTargetUrl x + , ("description" .=) <$> createDeploymentStatusDescription x + ] diff --git a/src/GitHub/Data/RateLimit.hs b/src/GitHub/Data/RateLimit.hs new file mode 100644 --- /dev/null +++ b/src/GitHub/Data/RateLimit.hs @@ -0,0 +1,43 @@ +----------------------------------------------------------------------------- +-- | +-- License : BSD-3-Clause +-- Maintainer : Oleg Grenrus +-- +module GitHub.Data.RateLimit where + +import GitHub.Internal.Prelude +import Prelude () + +data Limits = Limits + { limitsMax :: !Int + , limitsRemaining :: !Int + , limitsReset :: !Int -- TODO: change to proper type + } + deriving (Show, Data, Typeable, Eq, Ord, Generic) + +instance NFData Limits where rnf = genericRnf +instance Binary Limits + +instance FromJSON Limits where + parseJSON = withObject "Limits" $ \obj -> Limits + <$> obj .: "limit" + <*> obj .: "remaining" + <*> obj .: "reset" + +data RateLimit = RateLimit + { rateLimitCore :: Limits + , rateLimitSearch :: Limits + , rateLimitGraphQL :: Limits + } + deriving (Show, Data, Typeable, Eq, Ord, Generic) + +instance NFData RateLimit where rnf = genericRnf +instance Binary RateLimit + +instance FromJSON RateLimit where + parseJSON = withObject "RateLimit" $ \obj -> do + resources <- obj .: "resources" + RateLimit + <$> resources .: "core" + <*> resources .: "search" + <*> resources .: "graphql" 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 @@ -37,6 +37,7 @@ import qualified Network.HTTP.Types as Types import qualified Network.HTTP.Types.Method as Method import Network.URI (URI) + ------------------------------------------------------------------------------ -- Auxillary types ------------------------------------------------------------------------------ diff --git a/src/GitHub/Data/Webhooks.hs b/src/GitHub/Data/Webhooks.hs --- a/src/GitHub/Data/Webhooks.hs +++ b/src/GitHub/Data/Webhooks.hs @@ -38,6 +38,8 @@ | WebhookDeploymentStatusEvent | WebhookForkEvent | WebhookGollumEvent + | WebhookInstallationEvent + | WebhookInstallationRepositoriesEvent | WebhookIssueCommentEvent | WebhookIssuesEvent | WebhookMemberEvent @@ -110,6 +112,8 @@ parseJSON (String "deployment_status") = pure WebhookDeploymentStatusEvent parseJSON (String "fork") = pure WebhookForkEvent parseJSON (String "gollum") = pure WebhookGollumEvent + parseJSON (String "installation") = pure WebhookInstallationEvent + parseJSON (String "installation_repositories") = pure WebhookInstallationRepositoriesEvent parseJSON (String "issue_comment") = pure WebhookIssueCommentEvent parseJSON (String "issues") = pure WebhookIssuesEvent parseJSON (String "member") = pure WebhookMemberEvent @@ -134,6 +138,8 @@ toJSON WebhookDeploymentStatusEvent = String "deployment_status" toJSON WebhookForkEvent = String "fork" toJSON WebhookGollumEvent = String "gollum" + toJSON WebhookInstallationEvent = String "installation" + toJSON WebhookInstallationRepositoriesEvent = String "installation_repositories" toJSON WebhookIssueCommentEvent = String "issue_comment" toJSON WebhookIssuesEvent = String "issues" toJSON WebhookMemberEvent = String "member" diff --git a/src/GitHub/Endpoints/RateLimit.hs b/src/GitHub/Endpoints/RateLimit.hs new file mode 100644 --- /dev/null +++ b/src/GitHub/Endpoints/RateLimit.hs @@ -0,0 +1,33 @@ +----------------------------------------------------------------------------- +-- | +-- License : BSD-3-Clause +-- Maintainer : Oleg Grenrus +-- +-- The Github RateLimit API, as described at +-- . +module GitHub.Endpoints.RateLimit ( + rateLimitR, + rateLimit, + rateLimit', + module GitHub.Data, + ) where + +import GitHub.Data +import GitHub.Internal.Prelude +import GitHub.Request +import Prelude () + +-- | Get your current rate limit status (Note: Accessing this endpoint does not count against your rate limit.) +-- With authentication. +rateLimit' :: Maybe Auth -> IO (Either Error RateLimit) +rateLimit' auth = executeRequestMaybe auth rateLimitR + +-- | Get your current rate limit status (Note: Accessing this endpoint does not count against your rate limit.) +-- Without authentication. +rateLimit :: IO (Either Error RateLimit) +rateLimit = rateLimit' Nothing + +-- | Get your current rate limit status. +-- +rateLimitR :: Request k RateLimit +rateLimitR = query ["rate_limit"] [] diff --git a/src/GitHub/Endpoints/Repos/Deployments.hs b/src/GitHub/Endpoints/Repos/Deployments.hs new file mode 100644 --- /dev/null +++ b/src/GitHub/Endpoints/Repos/Deployments.hs @@ -0,0 +1,74 @@ +-- | The deployments API, as described at +module GitHub.Endpoints.Repos.Deployments + ( deploymentsWithOptionsForR + , createDeploymentR + + , deploymentStatusesForR + , createDeploymentStatusR + + , module GitHub.Data + ) where + +import Control.Arrow (second) + +import Data.Vector (Vector) + +import GitHub.Data +import GitHub.Internal.Prelude + +-- | List deployments. +-- See +deploymentsWithOptionsForR + :: FromJSON a + => Name Owner + -> Name Repo + -> FetchCount + -> [DeploymentQueryOption] + -> Request 'RA (Vector (Deployment a)) +deploymentsWithOptionsForR owner repo limit opts = + pagedQuery (deployPaths owner repo) + (map (second Just . renderDeploymentQueryOption) opts) + limit + +-- | Create a deployment. +-- See +createDeploymentR + :: ( ToJSON a + , FromJSON a + ) + => Name Owner + -> Name Repo + -> CreateDeployment a + -> Request 'RW (Deployment a) +createDeploymentR owner repo = + command Post (deployPaths owner repo) . encode + +-- | List deployment statuses. +-- See +deploymentStatusesForR + :: Name Owner + -> Name Repo + -> Id (Deployment a) + -> FetchCount + -> Request 'RA (Vector DeploymentStatus) +deploymentStatusesForR owner repo deploy = + pagedQuery (statusesPaths owner repo deploy) [] + +-- | Create a deployment status. +-- See +createDeploymentStatusR + :: Name Owner + -> Name Repo + -> Id (Deployment a) + -> CreateDeploymentStatus + -> Request 'RW DeploymentStatus +createDeploymentStatusR owner repo deploy = + command Post (statusesPaths owner repo deploy) . encode + +statusesPaths :: Name Owner -> Name Repo -> Id (Deployment a) -> Paths +statusesPaths owner repo deploy = + deployPaths owner repo ++ [toPathPart deploy, "statuses"] + +deployPaths :: Name Owner -> Name Repo -> Paths +deployPaths owner repo = + ["repos", toPathPart owner, toPathPart repo, "deployments"] 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 @@ -37,7 +37,7 @@ import Control.Applicative ((<|>)) import Control.DeepSeq (NFData (..)) import Control.DeepSeq.Generics (genericRnf) -import Data.Aeson.Compat +import Data.Aeson (FromJSON (..), Object, ToJSON (..), Value (..), encode, object, withObject, withText, (.!=), (.:), (.:?), (.=)) import Data.Aeson.Types (typeMismatch) diff --git a/src/GitHub/Request.hs b/src/GitHub/Request.hs --- a/src/GitHub/Request.hs +++ b/src/GitHub/Request.hs @@ -1,8 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE StandaloneDeriving #-} ----------------------------------------------------------------------------- -- | -- License : BSD-3-Clause @@ -53,17 +51,13 @@ import GitHub.Internal.Prelude import Prelude () -#if MIN_VERSION_mtl(2,2,0) -import Control.Monad.Except (MonadError (..)) -#else -import Control.Monad.Error (MonadError (..)) -#endif +import Control.Monad.Error.Class (MonadError (..)) import Control.Monad (when) import Control.Monad.Catch (MonadCatch (..), MonadThrow) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Except (ExceptT (..), runExceptT) -import Data.Aeson.Compat (eitherDecode) +import Data.Aeson (eitherDecode) import Data.List (find) import Network.HTTP.Client @@ -76,11 +70,6 @@ import Network.HTTP.Types (Method, RequestHeaders, Status (..)) import Network.URI (URI, parseURIReference, relativeTo) -#if !MIN_VERSION_http_client(0,5,0) -import qualified Control.Exception as E -import Network.HTTP.Types (ResponseHeaders) -#endif - import qualified Data.ByteString.Lazy as LBS import qualified Data.Text as T import qualified Data.Text.Encoding as TE @@ -96,11 +85,7 @@ executeRequest :: Auth -> Request k a -> IO (Either Error a) executeRequest auth req = do manager <- newManager tlsManagerSettings - x <- executeRequestWithMgr manager auth req -#if !MIN_VERSION_http_client(0, 4, 18) - closeManager manager -#endif - pure x + executeRequestWithMgr manager auth req lessFetchCount :: Int -> FetchCount -> Bool lessFetchCount _ FetchAll = True @@ -151,11 +136,7 @@ executeRequest' ::Request 'RO a -> IO (Either Error a) executeRequest' req = do manager <- newManager tlsManagerSettings - x <- executeRequestWithMgr' manager req -#if !MIN_VERSION_http_client(0, 4, 18) - closeManager manager -#endif - pure x + executeRequestWithMgr' manager req -- | Like 'executeRequestWithMgr' but without authentication. executeRequestWithMgr' @@ -267,11 +248,7 @@ $ req where parseUrl' :: MonadThrow m => Text -> m HTTP.Request -#if MIN_VERSION_http_client(0,4,30) parseUrl' = HTTP.parseRequest . T.unpack -#else - parseUrl' = HTTP.parseUrl . T.unpack -#endif url :: Paths -> Text url paths = baseUrl <> "/" <> T.intercalate "/" paths @@ -393,14 +370,8 @@ setCheckStatus :: Maybe (StatusMap a) -> HTTP.Request -> HTTP.Request -#if MIN_VERSION_http_client(0,5,0) setCheckStatus sm req = req { HTTP.checkResponse = successOrMissing sm } -#else -setCheckStatus sm req = req { HTTP.checkStatus = successOrMissing sm } -#endif - -#if MIN_VERSION_http_client(0,5,0) successOrMissing :: Maybe (StatusMap a) -> HTTP.Request -> HTTP.Response HTTP.BodyReader -> IO () successOrMissing sm _req res | check = pure () @@ -410,13 +381,6 @@ HTTP.throwHttp $ HTTP.StatusCodeException res' (LBS.toStrict chunk) where Status sci _ = HTTP.responseStatus res -#else -successOrMissing :: Maybe (StatusMap a) -> Status -> ResponseHeaders -> HTTP.CookieJar -> Maybe E.SomeException -successOrMissing sm s@(Status sci _) hs cookiejar - | check = Nothing - | otherwise = Just $ E.toException $ StatusCodeException s hs cookiejar - where -#endif check = case sm of Nothing -> 200 <= sci && sci < 300 Just sm' -> sci `elem` map fst sm'