diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,4 +1,27 @@ -Changes for 0.18 +## Changes for 0.19 + +- Fix issue event type enumeration + [#301](https://github.com/phadej/github/issues/301) +- Include label info in `IssseEvent` + [#302](https://github.com/phadej/github/issues/302) +- Fix `ShowRepo` example + [#306](https://github.com/phadej/github/pull/306) +- Add "Get archive link" API + [#307](https://github.com/phadej/github/pull/307) +- Make "repo" in PullRequestCommit nullable (repository can be gone) + [#311](https://github.com/phadej/github/pull/311) +- Add read-only emails endpoint + [#313](https://github.com/phadej/github/pull/313) +- Organisation membership API + [#312](https://github.com/phadej/github/pull/312) +- Fix isPullRequestMerged and other boolean responses + [#312](https://github.com/phadej/github/pull/312) +- Add `behind` pull request mergeable state + [#308](https://github.com/phadej/github/pull/308) +- Add list organisation invitations endpoint + +## Changes for 0.18 + - Endpoints for deleting issue comments. [#294](https://github.com/phadej/github/pull/294) - Endpoints for (un)starring gists. @@ -12,13 +35,15 @@ - Add requested reviewers field to pull request records. [#292](https://github.com/phadej/github/pull/292) -Changes for 0.17.0 +## Changes for 0.17.0 + - Add `Ord Request` instance - Repository contents - Repository starring endpoints - Pull Request review endpoints -Changes for 0.16.0 +## Changes for 0.16.0 + - Add support for `mergeable_state = "blocked".` - Fix HTTP status code of merge PR - Supports newest versions of dependencies @@ -26,7 +51,7 @@ - release endpoints - forkExistingRepo -Changes for 0.15.0 +## Changes for 0.15.0 - Reworked `PullRequest` (notably `pullRequestsFor`) - Reworked PR and Issue filtering @@ -48,7 +73,7 @@ See [git commit summary](https://github.com/phadej/github/compare/v0.14.1...v0.15.0) -Changes for 0.14.1 +## Changes for 0.14.1 - Add `membersOfWithR`, `listTeamMembersR` - Add related enums: `OrgMemberFilter`, `OrgMemberRole`, `TeamMemberRole` @@ -56,7 +81,7 @@ `RepoPublicity` - Don't require network access for search tests -Changes for 0.14.0 +## Changes for 0.14.0 Large API changes: @@ -67,7 +92,7 @@ - Add `Binary` instances for all data - `GithubOwner` is a `newtype` of `Either User Organization`. There's still `SimpleOwner`. -Changes for 0.5.0: +## Changes for 0.5.0: * OAuth. * New function: `Github.Repos.organizationRepo`, to get the repo for a specific organization. @@ -75,7 +100,7 @@ * Relax the attoparsec version requirements. * The above by [John Wiegley](https://github.com/jwiegley). -Changes for 0.4.1: +## Changes for 0.4.1: * Stop using the uri package. * Use aeson version 0.6.1.0. @@ -83,11 +108,11 @@ * Use http-conduit over 1.8. * Use unordered-containers between 0.2 and 0.3. -Changes for 0.4.0: +## Changes for 0.4.0: * Use http-conduit version 1.4.1.10. -Changes for 0.3.0: +## Changes for 0.3.0: * Re-instantiate the Blobs API. * `repoDescription1` and `repoPushedAt` are a `Maybe GithubDate`. @@ -97,11 +122,11 @@ ever-changing `http-conduit` package. * Features by [Pavel Ryzhov](https://github.com/paulrzcz) and [Simon Hengel](https://github.com/sol). -Changes for 0.2.1: +## Changes for 0.2.1: * Expand the unordered-containers dependency to anything in 0.1.x . -Changes for 0.2.0: +## Changes for 0.2.0: * `milestoneDueOn` and `repoLanguage` are now `Maybe` types. * Introduce `GithubOwner` as the sum type for a `GithubUser` or `GithubOrganization`. Everything that once produced a `GithubUser` now produces a `GithubOwner`. All record accessors have changed their names diff --git a/github.cabal b/github.cabal --- a/github.cabal +++ b/github.cabal @@ -1,5 +1,5 @@ name: github -version: 0.18 +version: 0.19 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.1 +tested-with: GHC==7.8.4, GHC==7.10.3, GHC==8.0.2, GHC==8.2.2 cabal-version: >=1.10 extra-source-files: README.md, @@ -74,10 +74,12 @@ GitHub.Data.Content GitHub.Data.Definitions GitHub.Data.DeployKeys + GitHub.Data.Email GitHub.Data.Events GitHub.Data.Gists GitHub.Data.GitData GitHub.Data.Id + GitHub.Data.Invitation GitHub.Data.Issues GitHub.Data.Milestone GitHub.Data.Name @@ -125,41 +127,46 @@ GitHub.Endpoints.Repos.Webhooks GitHub.Endpoints.Search GitHub.Endpoints.Users + GitHub.Endpoints.Users.Emails GitHub.Endpoints.Users.Followers GitHub.Request - -- Packages needed in order to build this package. - build-depends: base >=4.7 && <4.11, - aeson >=0.7.0.6 && <1.3, - base-compat >=0.9.1 && <0.10, - base16-bytestring >=0.1.1.6 && <0.2, - binary >=0.7.1.0 && <0.10, - binary-orphans >=0.1.0.0 && <0.2, - byteable >=0.1.1 && <0.2, - bytestring >=0.10.4.0 && <0.11, - containers >=0.5.5.1 && <0.6, - cryptohash >=0.11 && <0.12, - deepseq >=1.3.0.2 && <1.5, - 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, - http-types >=0.8.6 && <0.11, - iso8601-time >=0.1.4 && <0.2, - mtl >=2.1.3.1 && <2.3, - network-uri >=2.6.0.3 && <2.7, - semigroups >=0.16.2.2 && <0.19, - text >=1.2.0.6 && <1.3, - time >=1.4 && <1.9, - transformers >=0.3.0.0 && <0.6, - 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, + -- Packages bundles with GHC, mtl and text are also here + build-depends: + base >=4.7 && <4.11, + bytestring >=0.10.4.0 && <0.11, + containers >=0.5.5.1 && <0.6, + 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, + time >=1.4 && <1.10, + transformers >=0.3.0.0 && <0.6 - tls >=1.3.5 + -- other packages + build-depends: + aeson >=0.7.0.6 && <1.3, + base-compat >=0.9.1 && <0.10, + base16-bytestring >=0.1.1.6 && <0.2, + binary >=0.7.1.0 && <0.10, + binary-orphans >=0.1.0.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, + 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 if flag(aeson-compat) build-depends: aeson-compat >=0.3.0.0 && <0.4 diff --git a/spec/GitHub/PullRequestsSpec.hs b/spec/GitHub/PullRequestsSpec.hs --- a/spec/GitHub/PullRequestsSpec.hs +++ b/spec/GitHub/PullRequestsSpec.hs @@ -3,6 +3,7 @@ module GitHub.PullRequestsSpec where import qualified GitHub +import GitHub.Data.Id (Id(Id)) import Prelude () import Prelude.Compat @@ -50,6 +51,13 @@ V.length (GitHub.pullRequestRequestedReviewers pullRequestReviewRequested) `shouldBe` 1 + + describe "checking if a pull request is merged" $ do + it "works" $ withAuth $ \auth -> do + b <- GitHub.executeRequest auth $ GitHub.isPullRequestMergedR "phadej" "github" (Id 14) + b `shouldSatisfy` isRight + fromRightS b `shouldBe` True + where repos = [ ("thoughtbot", "paperclip") diff --git a/src/GitHub.hs b/src/GitHub.hs --- a/src/GitHub.hs +++ b/src/GitHub.hs @@ -158,9 +158,11 @@ -- ** Members -- | See -- - -- Missing endpoints: All except /Members List/ + -- Missing endpoints: All except /Members List/ and /Check Membership/ membersOfR, membersOfWithR, + isMemberOfR, + orgInvitationsR, -- ** Teams -- | See @@ -314,6 +316,17 @@ ownerInfoForR, userInfoCurrentR, + -- ** Emails + -- | See + -- + -- Missing endpoints: + -- + -- * Add email address(es) + -- * Delete email address(es) + -- * Toggle primary email visibility + currentUserEmailsR, + currentUserPublicEmailsR, + -- ** Followers -- | See -- @@ -369,5 +382,6 @@ import GitHub.Endpoints.Repos.Webhooks import GitHub.Endpoints.Search import GitHub.Endpoints.Users +import GitHub.Endpoints.Users.Emails import GitHub.Endpoints.Users.Followers import GitHub.Request diff --git a/src/GitHub/Data.hs b/src/GitHub/Data.hs --- a/src/GitHub/Data.hs +++ b/src/GitHub/Data.hs @@ -37,9 +37,11 @@ module GitHub.Data.Content, module GitHub.Data.Definitions, module GitHub.Data.DeployKeys, + module GitHub.Data.Email, module GitHub.Data.Events, module GitHub.Data.Gists, module GitHub.Data.GitData, + module GitHub.Data.Invitation, module GitHub.Data.Issues, module GitHub.Data.Milestone, module GitHub.Data.Options, @@ -64,10 +66,12 @@ import GitHub.Data.Content import GitHub.Data.Definitions import GitHub.Data.DeployKeys +import GitHub.Data.Email import GitHub.Data.Events import GitHub.Data.Gists import GitHub.Data.GitData import GitHub.Data.Id +import GitHub.Data.Invitation import GitHub.Data.Issues import GitHub.Data.Milestone import GitHub.Data.Name 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 @@ -18,7 +18,7 @@ import GitHub.Data.Id (Id) import GitHub.Data.Name (Name) -import GitHub.Data.URL (URL) +import GitHub.Data.URL (URL (..)) -- | Errors have been tagged according to their source, so you can more easily -- dispatch and handle them. @@ -254,5 +254,5 @@ instance FromJSON IssueLabel where parseJSON = withObject "IssueLabel" $ \o -> IssueLabel <$> o .: "color" - <*> o .: "url" + <*> o .:? "url" .!= URL "" -- in events there aren't URL <*> o .: "name" diff --git a/src/GitHub/Data/Email.hs b/src/GitHub/Data/Email.hs new file mode 100644 --- /dev/null +++ b/src/GitHub/Data/Email.hs @@ -0,0 +1,39 @@ +----------------------------------------------------------------------------- +-- | +-- License : BSD-3-Clause +-- Maintainer : Oleg Grenrus +-- +module GitHub.Data.Email where + +import GitHub.Internal.Prelude +import Prelude () + +data EmailVisibility + = EmailVisibilityPrivate + | EmailVisibilityPublic + deriving (Show, Data, Enum, Bounded, Typeable, Eq, Ord, Generic) + +instance NFData EmailVisibility where rnf = genericRnf +instance Binary EmailVisibility + +instance FromJSON EmailVisibility where + parseJSON (String "private") = pure EmailVisibilityPrivate + parseJSON (String "public") = pure EmailVisibilityPublic + parseJSON _ = fail "Could not build an EmailVisibility" + +data Email = Email + { emailAddress :: !Text + , emailVerified :: !Bool + , emailPrimary :: !Bool + , emailVisibility :: !(Maybe EmailVisibility) + } deriving (Show, Data, Typeable, Eq, Ord, Generic) + +instance NFData Email where rnf = genericRnf +instance Binary Email + +instance FromJSON Email where + parseJSON = withObject "Email" $ \o -> Email + <$> o .: "email" + <*> o .: "verified" + <*> o .: "primary" + <*> o .:? "visibility" diff --git a/src/GitHub/Data/Invitation.hs b/src/GitHub/Data/Invitation.hs new file mode 100644 --- /dev/null +++ b/src/GitHub/Data/Invitation.hs @@ -0,0 +1,57 @@ +----------------------------------------------------------------------------- +-- | +-- License : BSD-3-Clause +-- Maintainer : Oleg Grenrus +-- +module GitHub.Data.Invitation where + +import GitHub.Data.Definitions +import GitHub.Data.Id (Id) +import GitHub.Data.Name (Name) +import GitHub.Internal.Prelude +import Prelude () + +data Invitation = Invitation + { invitationId :: !(Id Invitation) + -- TODO: technically either one should be, maybe both. use `these` ? + , invitationLogin :: !(Maybe (Name User)) + , invitationEmail :: !(Maybe Text) + , invitationRole :: !InvitationRole + , invitationCreatedAt :: !UTCTime + , inviter :: !SimpleUser + } + deriving (Show, Data, Typeable, Eq, Ord, Generic) + +instance NFData Invitation where rnf = genericRnf +instance Binary Invitation + +instance FromJSON Invitation where + parseJSON = withObject "Invitation" $ \o -> Invitation + <$> o .: "id" + <*> o .:? "login" + <*> o .:? "email" + <*> o .: "role" + <*> o .: "created_at" + <*> o .: "inviter" + + +data InvitationRole + = InvitationRoleDirectMember + | InvitationRoleAdmin + | InvitationRoleBillingManager + | InvitationRoleHiringManager + | InvitationRoleReinstate + deriving + (Eq, Ord, Show, Enum, Bounded, Generic, Typeable, Data) + +instance NFData InvitationRole where rnf = genericRnf +instance Binary InvitationRole + +instance FromJSON InvitationRole where + parseJSON = withText "InvirationRole" $ \t -> case t of + "direct_member" -> pure InvitationRoleDirectMember + "admin" -> pure InvitationRoleAdmin + "billing_manager" -> pure InvitationRoleBillingManager + "hiring_manager" -> pure InvitationRoleHiringManager + "reinstate" -> pure InvitationRoleReinstate + _ -> fail $ "Invalid role " ++ show t diff --git a/src/GitHub/Data/Issues.hs b/src/GitHub/Data/Issues.hs --- a/src/GitHub/Data/Issues.hs +++ b/src/GitHub/Data/Issues.hs @@ -21,7 +21,7 @@ , issueEventsUrl :: !URL , issueHtmlUrl :: !(Maybe URL) , issueClosedBy :: !(Maybe SimpleUser) - , issueLabels :: (Vector IssueLabel) + , issueLabels :: !(Vector IssueLabel) , issueNumber :: !Int , issueAssignees :: !(Vector SimpleUser) , issueUser :: !SimpleUser @@ -79,25 +79,35 @@ instance NFData IssueComment where rnf = genericRnf instance Binary IssueComment +-- | See data EventType - = Mentioned -- ^ The actor was @mentioned in an issue body. - | Subscribed -- ^ The actor subscribed to receive notifications for an issue. - | Unsubscribed -- ^ The issue was unsubscribed from by the actor. - | Referenced -- ^ The issue was referenced from a commit message. The commit_id attribute is the commit SHA1 of where that happened. - | Merged -- ^ The issue was merged by the actor. The commit_id attribute is the SHA1 of the HEAD commit that was merged. - | Assigned -- ^ The issue was assigned to the actor. - | Closed -- ^ The issue was closed by the actor. When the commit_id is present, it identifies the commit that closed the issue using “closes / fixes #NN” syntax. - | Reopened -- ^ The issue was reopened by the actor. - | ActorUnassigned -- ^ The issue was unassigned to the actor - | Labeled -- ^ A label was added to the issue. - | Unlabeled -- ^ A label was removed from the issue. - | Milestoned -- ^ The issue was added to a milestone. - | Demilestoned -- ^ The issue was removed from a milestone. - | Renamed -- ^ The issue title was changed. - | Locked -- ^ The issue was locked by the actor. - | Unlocked -- ^ The issue was unlocked by the actor. - | HeadRefDeleted -- ^ The pull request’s branch was deleted. - | HeadRefRestored -- ^ The pull request’s branch was restored. + = Mentioned -- ^ The actor was @mentioned in an issue body. + | Subscribed -- ^ The actor subscribed to receive notifications for an issue. + | Unsubscribed -- ^ The issue was unsubscribed from by the actor. + | Referenced -- ^ The issue was referenced from a commit message. The commit_id attribute is the commit SHA1 of where that happened. + | Merged -- ^ The issue was merged by the actor. The commit_id attribute is the SHA1 of the HEAD commit that was merged. + | Assigned -- ^ The issue was assigned to the actor. + | Closed -- ^ The issue was closed by the actor. When the commit_id is present, it identifies the commit that closed the issue using “closes / fixes #NN” syntax. + | Reopened -- ^ The issue was reopened by the actor. + | ActorUnassigned -- ^ The issue was unassigned to the actor + | Labeled -- ^ A label was added to the issue. + | Unlabeled -- ^ A label was removed from the issue. + | Milestoned -- ^ The issue was added to a milestone. + | Demilestoned -- ^ The issue was removed from a milestone. + | Renamed -- ^ The issue title was changed. + | Locked -- ^ The issue was locked by the actor. + | Unlocked -- ^ The issue was unlocked by the actor. + | HeadRefDeleted -- ^ The pull request’s branch was deleted. + | HeadRefRestored -- ^ The pull request’s branch was restored. + | ReviewRequested -- ^ The actor requested review from the subject on this pull request. + | ReviewDismissed -- ^ The actor dismissed a review from the pull request. + | ReviewRequestRemoved -- ^ The actor removed the review request for the subject on this pull request. + | MarkedAsDuplicate -- ^ A user with write permissions marked an issue as a duplicate of another issue or a pull request as a duplicate of another pull request. + | UnmarkedAsDuplicate -- ^ An issue that a user had previously marked as a duplicate of another issue is no longer considered a duplicate, or a pull request that a user had previously marked as a duplicate of another pull request is no longer considered a duplicate. + | AddedToProject -- ^ The issue was added to a project board. + | MovedColumnsInProject -- ^ The issue was moved between columns in a project board. + | RemovedFromProject -- ^ The issue was removed from a project board. + | ConvertedNoteToIssue -- ^ The issue was created by converting a note in a project board to an issue. deriving (Show, Data, Enum, Bounded, Typeable, Eq, Ord, Generic) instance NFData EventType where rnf = genericRnf @@ -112,11 +122,12 @@ , issueEventCreatedAt :: !UTCTime , issueEventId :: !Int , issueEventIssue :: !(Maybe Issue) + , issueEventLabel :: !(Maybe IssueLabel) } deriving (Show, Data, Typeable, Eq, Ord, Generic) instance NFData IssueEvent where rnf = genericRnf -instance Binary IssueEvent +instance Binary IssueEvent instance FromJSON IssueEvent where parseJSON = withObject "Event" $ \o -> IssueEvent @@ -127,27 +138,38 @@ <*> o .: "created_at" <*> o .: "id" <*> o .:? "issue" + <*> o .:? "label" instance FromJSON EventType where - parseJSON (String "closed") = pure Closed - parseJSON (String "reopened") = pure Reopened - parseJSON (String "subscribed") = pure Subscribed - parseJSON (String "merged") = pure Merged - parseJSON (String "referenced") = pure Referenced - parseJSON (String "mentioned") = pure Mentioned - parseJSON (String "assigned") = pure Assigned - parseJSON (String "unsubscribed") = pure Unsubscribed - parseJSON (String "unassigned") = pure ActorUnassigned - parseJSON (String "labeled") = pure Labeled - parseJSON (String "unlabeled") = pure Unlabeled - parseJSON (String "milestoned") = pure Milestoned - parseJSON (String "demilestoned") = pure Demilestoned - parseJSON (String "renamed") = pure Renamed - parseJSON (String "locked") = pure Locked - parseJSON (String "unlocked") = pure Unlocked - parseJSON (String "head_ref_deleted") = pure HeadRefDeleted - parseJSON (String "head_ref_restored") = pure HeadRefRestored - parseJSON _ = fail "Could not build an EventType" + parseJSON = withText "EventType" $ \t -> case t of + "closed" -> pure Closed + "reopened" -> pure Reopened + "subscribed" -> pure Subscribed + "merged" -> pure Merged + "referenced" -> pure Referenced + "mentioned" -> pure Mentioned + "assigned" -> pure Assigned + "unassigned" -> pure ActorUnassigned + "labeled" -> pure Labeled + "unlabeled" -> pure Unlabeled + "milestoned" -> pure Milestoned + "demilestoned" -> pure Demilestoned + "renamed" -> pure Renamed + "locked" -> pure Locked + "unlocked" -> pure Unlocked + "head_ref_deleted" -> pure HeadRefDeleted + "head_ref_restored" -> pure HeadRefRestored + "review_requested" -> pure ReviewRequested + "review_dismissed" -> pure ReviewDismissed + "review_request_removed" -> pure ReviewRequestRemoved + "marked_as_duplicate" -> pure MarkedAsDuplicate + "unmarked_as_duplicate" -> pure UnmarkedAsDuplicate + "added_to_project" -> pure AddedToProject + "moved_columns_in_project" -> pure MovedColumnsInProject + "removed_from_project" -> pure RemovedFromProject + "converted_note_to_issue" -> pure ConvertedNoteToIssue + "unsubscribed" -> pure Unsubscribed -- not in api docs list + _ -> fail $ "Unknown EventType " ++ show t instance FromJSON IssueComment where parseJSON = withObject "IssueComment" $ \o -> IssueComment 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 @@ -96,6 +96,7 @@ | StateDirty | StateUnstable | StateBlocked + | StateBehind deriving (Eq, Ord, Show, Enum, Bounded, Generic, Typeable, Data) @@ -105,6 +106,7 @@ toJSON StateDirty = String "dirty" toJSON StateUnstable = String "unstable" toJSON StateBlocked = String "blocked" + toJSON StateBehind = String "behind" instance FromJSON MergeableState where parseJSON (String "unknown") = pure StateUnknown @@ -112,6 +114,7 @@ parseJSON (String "dirty") = pure StateDirty parseJSON (String "unstable") = pure StateUnstable parseJSON (String "blocked") = pure StateBlocked + parseJSON (String "behind") = pure StateBehind parseJSON v = typeMismatch "MergeableState" v instance NFData MergeableState where rnf = genericRnf diff --git a/src/GitHub/Data/PullRequests.hs b/src/GitHub/Data/PullRequests.hs --- a/src/GitHub/Data/PullRequests.hs +++ b/src/GitHub/Data/PullRequests.hs @@ -136,7 +136,7 @@ , pullRequestCommitRef :: !Text , pullRequestCommitSha :: !Text , pullRequestCommitUser :: !SimpleUser - , pullRequestCommitRepo :: !Repo + , pullRequestCommitRepo :: !(Maybe Repo) } deriving (Show, Data, Typeable, Eq, Ord, Generic) 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 @@ -14,6 +14,7 @@ import GitHub.Data.Definitions import GitHub.Data.Id (Id) import GitHub.Data.Name (Name) +import GitHub.Data.Request (IsPathPart (..)) import GitHub.Data.URL (URL) import GitHub.Internal.Prelude import Prelude () @@ -257,3 +258,13 @@ mapKey f = HM.fromList . map (first f) . HM.toList #endif #endif + +data ArchiveFormat + = ArchiveFormatTarball -- ^ ".tar.gz" format + | ArchiveFormatZipball -- ^ ".zip" format + deriving (Show, Eq, Ord, Enum, Bounded, Typeable, Data, Generic) + +instance IsPathPart ArchiveFormat where + toPathPart af = case af of + ArchiveFormatTarball -> "tarball" + ArchiveFormatZipball -> "zipball" 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 @@ -36,6 +36,7 @@ import qualified Data.Text as T import qualified Network.HTTP.Types as Types import qualified Network.HTTP.Types.Method as Method +import Network.URI (URI) ------------------------------------------------------------------------------ -- Auxillary types ------------------------------------------------------------------------------ @@ -141,6 +142,7 @@ SimpleQuery :: FromJSON a => SimpleRequest k a -> Request k a StatusQuery :: StatusMap a -> SimpleRequest k () -> Request k a HeaderQuery :: FromJSON a => Types.RequestHeaders -> SimpleRequest k a -> Request k a + RedirectQuery :: SimpleRequest k () -> Request k URI deriving (Typeable) data SimpleRequest (k :: RW) a where @@ -158,7 +160,7 @@ statusOnlyOk :: StatusMap Bool statusOnlyOk = - [ (202, True) + [ (204, True) , (404, False) ] @@ -218,6 +220,8 @@ . showsPrec (appPrec + 1) m . showString " " . showsPrec (appPrec + 1) req + RedirectQuery req -> showString "Redirect " + . showsPrec (appPrec + 1) req where appPrec = 10 :: Int @@ -248,4 +252,7 @@ hashWithSalt salt (HeaderQuery h req) = salt `hashWithSalt` (2 :: Int) `hashWithSalt` h + `hashWithSalt` req + hashWithSalt salt (RedirectQuery req) = + salt `hashWithSalt` (3 :: Int) `hashWithSalt` req 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 @@ -10,6 +10,10 @@ membersOf', membersOfR, membersOfWithR, + isMemberOf, + isMemberOf', + isMemberOfR, + orgInvitationsR, module GitHub.Data, ) where @@ -54,3 +58,31 @@ OrgMemberRoleAll -> "all" OrgMemberRoleAdmin -> "admin" OrgMemberRoleMember -> "member" + +-- | Check if a user is a member of an organization, +-- | with or without authentication. +-- +-- > isMemberOf' (Just $ OAuth "token") "phadej" "haskell-infra" +isMemberOf' :: Maybe Auth -> Name User -> Name Organization -> IO (Either Error Bool) +isMemberOf' auth user org = + executeRequestMaybe auth $ isMemberOfR user org + +-- | Check if a user is a member of an organization, +-- | without authentication. +-- +-- > isMemberOf "phadej" "haskell-infra" +isMemberOf :: Name User -> Name Organization -> IO (Either Error Bool) +isMemberOf = isMemberOf' Nothing + +-- | Check if a user is a member of an organization. +-- +-- See +isMemberOfR :: Name User -> Name Organization -> Request k Bool +isMemberOfR user org = StatusQuery statusOnlyOk $ + Query [ "orgs", toPathPart org, "members", toPathPart user ] [] + +-- | List pending organization invitations +-- +-- See +orgInvitationsR :: Name Organization -> FetchCount -> Request 'RA (Vector Invitation) +orgInvitationsR org = pagedQuery ["orgs", toPathPart org, "invitations"] [] diff --git a/src/GitHub/Endpoints/Repos.hs b/src/GitHub/Endpoints/Repos.hs --- a/src/GitHub/Endpoints/Repos.hs +++ b/src/GitHub/Endpoints/Repos.hs @@ -136,14 +136,14 @@ -- | Details on a specific repo, given the owner and repo name. -- --- > userRepo "mike-burns" "github" +-- > repository "mike-burns" "github" repository :: Name Owner -> Name Repo -> IO (Either Error Repo) repository = repository' Nothing -- | Details on a specific repo, given the owner and repo name. -- With authentication. -- --- > userRepo' (Just (BasicAuth (user, password))) "mike-burns" "github" +-- > repository' (Just (BasicAuth (user, password))) "mike-burns" "github" repository' :: Maybe Auth -> Name Owner -> Name Repo -> IO (Either Error Repo) repository' auth user repo = executeRequestMaybe auth $ repositoryR user repo diff --git a/src/GitHub/Endpoints/Repos/Contents.hs b/src/GitHub/Endpoints/Repos/Contents.hs --- a/src/GitHub/Endpoints/Repos/Contents.hs +++ b/src/GitHub/Endpoints/Repos/Contents.hs @@ -13,6 +13,9 @@ readmeFor, readmeFor', readmeForR, + archiveFor, + archiveFor', + archiveForR, -- ** Create createFile, @@ -34,7 +37,9 @@ import GitHub.Request import Prelude () +import Data.Maybe (maybeToList) import qualified Data.Text.Encoding as TE +import Network.URI (URI) -- | The contents of a file or directory in a repo, given the repo owner, name, and path to the file -- @@ -78,6 +83,31 @@ readmeForR :: Name Owner -> Name Repo -> Request k Content readmeForR user repo = query ["repos", toPathPart user, toPathPart repo, "readme"] [] + +-- | The archive of a repo, given the repo owner, name, and archive type +-- +-- > archiveFor "thoughtbot" "paperclip" ArchiveFormatTarball Nothing +archiveFor :: Name Owner -> Name Repo -> ArchiveFormat -> Maybe Text -> IO (Either Error URI) +archiveFor = archiveFor' Nothing + +-- | The archive of a repo, given the repo owner, name, and archive type +-- With Authentication +-- +-- > archiveFor' (Just (BasicAuth (user, password))) "thoughtbot" "paperclip" ArchiveFormatTarball Nothing +archiveFor' :: Maybe Auth -> Name Owner -> Name Repo -> ArchiveFormat -> Maybe Text -> IO (Either Error URI) +archiveFor' auth user repo path ref = + executeRequestMaybe auth $ archiveForR user repo path ref + +archiveForR + :: Name Owner + -> Name Repo + -> ArchiveFormat -- ^ The type of archive to retrieve + -> Maybe Text -- ^ Git commit + -> Request k URI +archiveForR user repo format ref = + RedirectQuery $ Query path [] + where + path = ["repos", toPathPart user, toPathPart repo, toPathPart format] <> maybeToList ref -- | Create a file. createFile diff --git a/src/GitHub/Endpoints/Users/Emails.hs b/src/GitHub/Endpoints/Users/Emails.hs new file mode 100644 --- /dev/null +++ b/src/GitHub/Endpoints/Users/Emails.hs @@ -0,0 +1,45 @@ +----------------------------------------------------------------------------- +-- | +-- License : BSD-3-Clause +-- Maintainer : Oleg Grenrus +-- +-- The user emails API as described on +-- . +module GitHub.Endpoints.Users.Emails ( + currentUserEmails', + currentUserEmailsR, + currentUserPublicEmails', + currentUserPublicEmailsR, + module GitHub.Data, + ) where + +import GitHub.Data +import GitHub.Internal.Prelude +import GitHub.Request +import Prelude () + +-- | List email addresses for the authenticated user. +-- +-- > currentUserEmails' (OAuth "token") +currentUserEmails' :: Auth -> IO (Either Error (Vector Email)) +currentUserEmails' auth = + executeRequest auth $ currentUserEmailsR FetchAll + +-- | List email addresses. +-- See +currentUserEmailsR :: FetchCount -> Request 'RA (Vector Email) +currentUserEmailsR = + pagedQuery ["user", "emails"] [] + +-- | List public email addresses for the authenticated user. +-- +-- > currentUserPublicEmails' (OAuth "token") +currentUserPublicEmails' :: Auth -> IO (Either Error (Vector Email)) +currentUserPublicEmails' auth = + executeRequest auth $ currentUserPublicEmailsR FetchAll + +-- | List public email addresses. +-- See +currentUserPublicEmailsR :: FetchCount -> Request 'RA (Vector Email) +currentUserPublicEmailsR = + pagedQuery ["user", "public_emails"] [] diff --git a/src/GitHub/Request.hs b/src/GitHub/Request.hs --- a/src/GitHub/Request.hs +++ b/src/GitHub/Request.hs @@ -59,6 +59,7 @@ import Control.Monad.Error (MonadError (..)) #endif +import Control.Monad (when) import Control.Monad.Catch (MonadCatch (..), MonadThrow) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Except (ExceptT (..), runExceptT) @@ -67,13 +68,13 @@ import Network.HTTP.Client (HttpException (..), Manager, RequestBody (..), Response (..), - applyBasicAuth, httpLbs, method, newManager, requestBody, - requestHeaders, setQueryString) + applyBasicAuth, getUri, httpLbs, method, newManager, redirectCount, + requestBody, requestHeaders, setQueryString, setRequestIgnoreStatus) import Network.HTTP.Client.TLS (tlsManagerSettings) import Network.HTTP.Link.Parser (parseLinkHeaderBS) import Network.HTTP.Link.Types (Link (..), LinkParam (..), href, linkParams) import Network.HTTP.Types (Method, RequestHeaders, Status (..)) -import Network.URI (URI) +import Network.URI (URI, parseURIReference, relativeTo) #if !MIN_VERSION_http_client(0,5,0) import qualified Control.Exception as E @@ -82,6 +83,7 @@ import qualified Data.ByteString.Lazy as LBS import qualified Data.Text as T +import qualified Data.Text.Encoding as TE import qualified Data.Vector as V import qualified Network.HTTP.Client as HTTP import qualified Network.HTTP.Client.Internal as HTTP @@ -125,6 +127,9 @@ performHttpReq httpReq (StatusQuery sm _) = do res <- httpLbs' httpReq parseStatus sm . responseStatus $ res + performHttpReq httpReq (RedirectQuery _) = do + res <- httpLbs' httpReq + parseRedirect (getUri httpReq) res performHttpReq' :: FromJSON b => HTTP.Request -> SimpleRequest k b -> ExceptT Error IO b performHttpReq' httpReq Query {} = do @@ -172,6 +177,9 @@ performHttpReq httpReq (StatusQuery sm _) = do res <- httpLbs' httpReq parseStatus sm . responseStatus $ res + performHttpReq httpReq (RedirectQuery _) = do + res <- httpLbs' httpReq + parseRedirect (getUri httpReq) res performHttpReq' :: FromJSON b => HTTP.Request -> SimpleRequest 'RO b -> ExceptT Error IO b performHttpReq' httpReq Query {} = do @@ -222,6 +230,9 @@ HeaderQuery h req -> do req' <- makeHttpSimpleRequest auth req return $ req' { requestHeaders = h <> requestHeaders req' } + RedirectQuery req -> do + req' <- makeHttpSimpleRequest auth req + return $ setRequestIgnoreStatus $ req' { redirectCount = 0 } makeHttpSimpleRequest :: MonadThrow m @@ -327,6 +338,24 @@ maybe err return $ lookup sci m where err = throwError $ JsonError $ "invalid status: " <> T.pack (show sci) + +-- | Helper for handling of 'RequestRedirect'. +-- +-- @ +-- parseRedirect :: 'Response' 'LBS.ByteString' -> 'Either' 'Error' a +-- @ +parseRedirect :: MonadError Error m => URI -> Response LBS.ByteString -> m URI +parseRedirect originalUri rsp = do + let status = responseStatus rsp + when (statusCode status /= 302) $ + throwError $ ParseError $ "invalid status: " <> T.pack (show status) + loc <- maybe noLocation return $ lookup "Location" $ responseHeaders rsp + case parseURIReference $ T.unpack $ TE.decodeUtf8 loc of + Nothing -> throwError $ ParseError $ + "location header does not contain a URI: " <> T.pack (show loc) + Just uri -> return $ uri `relativeTo` originalUri + where + noLocation = throwError $ ParseError "no location header in response" -- | Helper for making paginated requests. Responses, @a@ are combined monoidally. --