├── .github └── workflows │ └── haskell-ci.yml ├── .gitignore ├── .stylish-haskell.yaml ├── CHANGELOG.md ├── CONTRIBUTING.md ├── LICENSE ├── README.md ├── Setup.hs ├── cabal.haskell-ci ├── cabal.project ├── fix-whitespace.yaml ├── fixtures ├── actions │ ├── artifact.json │ ├── artifacts-list.json │ ├── cache-list.json │ ├── org-cache-usage.json │ ├── org-public-key.json │ ├── org-secrets-list.json │ ├── repo-cache-usage.json │ ├── selected-repositories-for-secret.json │ ├── workflow-job.json │ ├── workflow-list.json │ └── workflow-runs-list.json ├── issue-search.json ├── list-teams.json ├── members-list.json ├── pull-request-approved-review.json ├── pull-request-opened.json ├── pull-request-pending-review.json ├── pull-request-review-requested.json ├── pull-request-team-review-requested.json ├── user-bot.json ├── user-organizations.json └── user.json ├── github.cabal ├── samples ├── Activity │ └── Starring │ │ ├── StarRepo.hs │ │ └── UnstarRepo.hs ├── Enterprise │ ├── CreateOrganization.hs │ └── RenameOrganization.hs ├── Gists │ ├── Comments │ │ ├── ShowComment.hs │ │ └── ShowComments.hs │ ├── DeleteGist.hs │ ├── ListGists.hs │ ├── ShowGist.hs │ ├── StarGist.hs │ └── UnstarGist.hs ├── GitData │ ├── Blobs │ │ └── GitHashObject.hs │ ├── Commits │ │ └── GitShow.hs │ ├── References │ │ ├── GitCreateReference.hs │ │ ├── GitLsRemote.hs │ │ ├── GitLsRemoteTags.hs │ │ └── GitLsRemoteWithRef.hs │ └── Trees │ │ ├── GitLsTree.hs │ │ └── GitLsTreeRecursively.hs ├── Issues │ ├── Comments │ │ ├── ShowComment.hs │ │ └── ShowComments.hs │ ├── CreateIssue.hs │ ├── EditIssue.hs │ ├── Events │ │ ├── ShowEvent.hs │ │ ├── ShowIssueEvents.hs │ │ └── ShowRepoEvents.hs │ ├── IssueReport │ │ ├── Issues.hs │ │ ├── IssuesEnterprise.hs │ │ └── Report.hs │ ├── Labels │ │ ├── CreateLabels.hs │ │ ├── ShowIssueLabels.hs │ │ ├── ShowLabel.hs │ │ ├── ShowMilestoneLabels.hs │ │ └── ShowRepoLabels.hs │ ├── Milestones │ │ ├── ShowMilestone.hs │ │ └── ShowMilestones.hs │ ├── ShowIssue.hs │ └── ShowRepoIssues.hs ├── LICENSE ├── Operational │ └── Operational.hs ├── Organizations │ ├── Members │ │ └── ShowMembers.hs │ ├── ShowPublicOrganization.hs │ ├── ShowPublicOrganizations.hs │ └── Teams │ │ ├── CreateTeamFor.hs │ │ └── ListTeamsForOrganization.hs ├── Pulls │ ├── Comments │ │ ├── ListComments.hs │ │ └── ShowComment.hs │ ├── Diff.hs │ ├── IsMergedPull.hs │ ├── ListPulls.hs │ ├── MergePull.hs │ ├── ShowCommits.hs │ ├── ShowPull.hs │ └── UpdatePull.hs ├── RateLimit.hs ├── Repos │ ├── Collaborators │ │ ├── IsCollaborator.hs │ │ └── ListCollaborators.hs │ ├── Commits │ │ ├── CommitComment.hs │ │ ├── CommitComments.hs │ │ ├── GitDiff.hs │ │ ├── GitLog.hs │ │ ├── GitShow.hs │ │ └── RepoComments.hs │ ├── Contents.hs │ ├── DeployKeys │ │ ├── CreateDeployKey.hs │ │ ├── DeleteDeployKey.hs │ │ ├── ListDeployKeys.hs │ │ └── ShowDeployKey.hs │ ├── Forks │ │ └── ListForks.hs │ ├── GetReadme.hs │ ├── ListBranches.hs │ ├── ListContributors.hs │ ├── ListContributorsWithAnonymous.hs │ ├── ListLanguages.hs │ ├── ListOrgRepos.hs │ ├── ListTags.hs │ ├── ListUserRepos.hs │ ├── ShowRepo.hs │ ├── Starring │ │ └── ListStarred.hs │ ├── Watching │ │ ├── ListWatched.hs │ │ ├── ListWatchers.hs │ │ └── Unwatch.hs │ └── Webhooks │ │ ├── CreateWebhook.hs │ │ ├── DeleteWebhook.hs │ │ ├── EditWebhook.hs │ │ ├── ListWebhook.hs │ │ ├── ListWebhooks.hs │ │ ├── PingWebhook.hs │ │ └── TestPushWebhook.hs ├── Search │ ├── SearchCode.hs │ ├── SearchIssues.hs │ └── SearchRepos.hs ├── Teams │ ├── DeleteTeam.hs │ ├── EditTeam.hs │ ├── ListRepos.hs │ ├── ListTeamsCurrent.hs │ ├── Memberships │ │ ├── AddTeamMembershipFor.hs │ │ ├── DeleteTeamMembershipFor.hs │ │ └── TeamMembershipInfoFor.hs │ ├── Repos │ │ └── AddOrUpdateTeamRepo.hs │ └── TeamInfoFor.hs ├── Users │ ├── Emails │ │ └── ListEmails.hs │ ├── Followers │ │ ├── Example.hs │ │ ├── ListFollowers.hs │ │ └── ListFollowing.hs │ ├── PublicSSHKeys │ │ ├── CreatePublicSSHKey.hs │ │ ├── DeletePublicSSHKey.hs │ │ ├── ListPublicSSHKeys.hs │ │ └── ShowPublicSSHKey.hs │ ├── ShowUser.hs │ └── ShowUser2.hs ├── github-samples.cabal └── src │ └── Common.hs ├── spec ├── GitHub │ ├── Actions │ │ ├── ArtifactsSpec.hs │ │ ├── CacheSpec.hs │ │ ├── SecretsSpec.hs │ │ ├── WorkflowJobSpec.hs │ │ ├── WorkflowRunsSpec.hs │ │ └── WorkflowSpec.hs │ ├── ActivitySpec.hs │ ├── CommitsSpec.hs │ ├── EventsSpec.hs │ ├── IssuesSpec.hs │ ├── OrganizationsSpec.hs │ ├── PublicSSHKeysSpec.hs │ ├── PullRequestReviewsSpec.hs │ ├── PullRequestsSpec.hs │ ├── RateLimitSpec.hs │ ├── ReleasesSpec.hs │ ├── ReposSpec.hs │ ├── ReviewDecodeSpec.hs │ ├── SearchSpec.hs │ └── UsersSpec.hs └── Spec.hs └── src ├── GitHub.hs └── GitHub ├── Auth.hs ├── Data.hs ├── Data ├── Actions │ ├── Artifacts.hs │ ├── Cache.hs │ ├── Common.hs │ ├── Secrets.hs │ ├── WorkflowJobs.hs │ ├── WorkflowRuns.hs │ └── Workflows.hs ├── Activities.hs ├── Comments.hs ├── Content.hs ├── Definitions.hs ├── DeployKeys.hs ├── Deployments.hs ├── Email.hs ├── Enterprise.hs ├── Enterprise │ └── Organizations.hs ├── Events.hs ├── Gists.hs ├── GitData.hs ├── Id.hs ├── Invitation.hs ├── Issues.hs ├── Milestone.hs ├── Name.hs ├── Options.hs ├── PublicSSHKeys.hs ├── PullRequests.hs ├── RateLimit.hs ├── Reactions.hs ├── Releases.hs ├── Repos.hs ├── Request.hs ├── Reviews.hs ├── Search.hs ├── Statuses.hs ├── Teams.hs ├── URL.hs ├── Webhooks.hs └── Webhooks │ └── Validate.hs ├── Endpoints ├── Actions │ ├── Artifacts.hs │ ├── Cache.hs │ ├── Secrets.hs │ ├── WorkflowJobs.hs │ ├── WorkflowRuns.hs │ └── Workflows.hs ├── Activity │ ├── Events.hs │ ├── Notifications.hs │ ├── Starring.hs │ └── Watching.hs ├── Enterprise │ └── Organizations.hs ├── Gists.hs ├── Gists │ └── Comments.hs ├── GitData │ ├── Blobs.hs │ ├── Commits.hs │ ├── References.hs │ └── Trees.hs ├── Issues.hs ├── Issues │ ├── Comments.hs │ ├── Events.hs │ ├── Labels.hs │ └── Milestones.hs ├── Organizations.hs ├── Organizations │ ├── Members.hs │ ├── OutsideCollaborators.hs │ └── Teams.hs ├── PullRequests.hs ├── PullRequests │ ├── Comments.hs │ └── Reviews.hs ├── RateLimit.hs ├── Reactions.hs ├── Repos.hs ├── Repos │ ├── Collaborators.hs │ ├── Comments.hs │ ├── Commits.hs │ ├── Contents.hs │ ├── DeployKeys.hs │ ├── Deployments.hs │ ├── Forks.hs │ ├── Invitations.hs │ ├── Releases.hs │ ├── Statuses.hs │ └── Webhooks.hs ├── Search.hs ├── Users.hs └── Users │ ├── Emails.hs │ ├── Followers.hs │ └── PublicSSHKeys.hs ├── Enterprise.hs ├── Internal └── Prelude.hs └── Request.hs /.gitignore: -------------------------------------------------------------------------------- 1 | .env 2 | dist 3 | dist-newstyle 4 | /dist* 5 | /tmp 6 | .ghc.environment.* 7 | *swp 8 | .cabal-sandbox 9 | cabal.sandbox.config 10 | *flymake* 11 | *.#* 12 | *~ 13 | *.hi 14 | *.o 15 | *.lock 16 | .stack-work 17 | run.sh 18 | src/hightlight.js 19 | src/style.css 20 | TAGS 21 | .DS_Store 22 | 23 | -------------------------------------------------------------------------------- /.stylish-haskell.yaml: -------------------------------------------------------------------------------- 1 | steps: 2 | - imports: 3 | align: group 4 | list_align: after_alias 5 | long_list_align: new_line 6 | empty_list_align: right_after 7 | list_padding: module_name 8 | - language_pragmas: 9 | style: vertical 10 | remove_redundant: true 11 | - trailing_whitespace: {} 12 | columns: 80 13 | language_extensions: 14 | - MultiParamTypeClasses 15 | - FlexibleContexts 16 | - ExplicitForAll 17 | - DataKinds 18 | -------------------------------------------------------------------------------- /CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | Contributing 2 | ============ 3 | 4 | When adding a new endpoint 5 | -------------------------- 6 | 7 | ```haskell 8 | -- | The title, as in the GitHub API docs. 9 | -- 10 | endpointR :: Request k EndpointResult 11 | endpointR = query ["endpoint"] [] 12 | ``` 13 | 14 | For example: 15 | 16 | ```haskell 17 | -- | Get your current rate limit status. 18 | -- 19 | rateLimitR :: Request k RateLimit 20 | rateLimitR = query ["rate_limit"] [] 21 | ``` 22 | 23 | Also re-export endpoints from the top `GitHub` module. *Note:* only `R` variants, not `IO`. 24 | 25 | Testing 26 | ------- 27 | 28 | When adding new functionality, cover it by a test case in: 29 | 30 | spec/ 31 | 32 | or a demonstration added to: 33 | 34 | samples/github-samples.cabal 35 | 36 | Miscellaneous 37 | ------------- 38 | 39 | * **Don't** edit `CHANGELOG.md`, it will only conflict. 40 | * **Don't** edit package version. 41 | * The codebase is not uniform in style, don't make it worse. 42 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c)2011, Mike Burns 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Mike Burns nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /cabal.haskell-ci: -------------------------------------------------------------------------------- 1 | branches: master 2 | haddock: >=8.6 3 | -- See PR #355: haddocks for GADT constructor arguments only supported from GHC 8.6 4 | jobs-selection: any 5 | 6 | -- Some dependencies do not allow mtl-2.3 yet, so this doesn't pass yet: 7 | -- constraint-set mtl-2.3 8 | -- ghc: >= 8.6 9 | -- constraints: mtl >= 2.3, transformers >= 0.6 10 | 11 | -- constraint-set text-2.0 12 | -- constraints: text >= 2.0 13 | -- allow-newer: *:text -- allow-newer not supported 14 | 15 | -- constraint-set containers-0.7 16 | -- ghc: >= 9 17 | -- constraints: containers >= 0.7 18 | -- tests: True 19 | -- run-tests: True 20 | 21 | -- raw-project 22 | -- allow-newer: containers 23 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: . 2 | packages: samples 3 | 4 | optimization: False 5 | tests: True 6 | 7 | constraints: github +openssl 8 | constraints: github-samples +openssl 9 | constraints: HsOpenSSL +use-pkg-config 10 | constraints: operational -buildExamples 11 | 12 | -- constraints: text >=2 13 | -- allow-newer: *:text 14 | -------------------------------------------------------------------------------- /fix-whitespace.yaml: -------------------------------------------------------------------------------- 1 | # This file contains the project-specific settings for `fix-whitespace` 2 | # 3 | # (get it with `cabal install fix-whitespace`) 4 | # 5 | # a tiny, but useful tool to: 6 | # 7 | # * Remove trailing whitespace. 8 | # * Remove trailing lines containing nothing but whitespace. 9 | # * Ensure that the file ends in a newline character. 10 | # 11 | # By default, fix-whitespace checks every directory under the current working 12 | # directory but no files. This program should be placed under a text-based 13 | # project. 14 | # 15 | # For directories, 16 | # 17 | # 1) excluded-dirs is a black-list of directories, 18 | # 2) included-dirs is a white-list of excluded-dirs 19 | # 20 | # For files, 21 | # 22 | # 3) included-files is a white-list of files, 23 | # 4) excluded-files is a black-list of included-files. 24 | # 25 | # The extended glob pattern can be used to specify file/direcotory names. 26 | # For details, see http://hackage.haskell.org/package/filemanip-0.3.6.3/docs/System-FilePath-GlobPattern.html 27 | # 28 | 29 | excluded-dirs: 30 | - .git 31 | - .stack-work 32 | - "dist*" 33 | - fixtures 34 | 35 | included-dirs: 36 | 37 | # Every matched filename is included unless it is matched by excluded-files. 38 | included-files: 39 | - .authorspellings 40 | - .gitignore 41 | - LICENSE 42 | - cabal.haskell-ci 43 | - cabal.project 44 | - cabal.project.local 45 | - "*.cabal" 46 | - "*.css" 47 | - "*.example" 48 | - "*.hs" 49 | - "*.hs-boot" 50 | - "*.html" 51 | - "*.js" 52 | - "*.json" 53 | - "*.lhs" 54 | - "*.md" 55 | - "*.rst" 56 | - "*.sh" 57 | - "*.txt" 58 | - "*.yaml" 59 | - "*.yml" 60 | 61 | excluded-files: 62 | -------------------------------------------------------------------------------- /fixtures/actions/artifact.json: -------------------------------------------------------------------------------- 1 | { 2 | "id": 416767789, 3 | "node_id": "MDg6QXJ0aWZhY3Q0MTY3Njc3ODk=", 4 | "name": "dist-without-markdown", 5 | "size_in_bytes": 42718, 6 | "url": "https://api.github.com/repos/kote-test-org-actions/actions-api/actions/artifacts/416767789", 7 | "archive_download_url": "https://api.github.com/repos/kote-test-org-actions/actions-api/actions/artifacts/416767789/zip", 8 | "expired": false, 9 | "created_at": "2022-10-29T22:18:21Z", 10 | "updated_at": "2022-10-29T22:18:23Z", 11 | "expires_at": "2023-01-27T22:18:16Z", 12 | "workflow_run": { 13 | "id": 3353148947, 14 | "repository_id": 559365297, 15 | "head_repository_id": 559365297, 16 | "head_branch": "main", 17 | "head_sha": "601593ecb1d8a57a04700fdb445a28d4186b8954" 18 | } 19 | } 20 | -------------------------------------------------------------------------------- /fixtures/actions/artifacts-list.json: -------------------------------------------------------------------------------- 1 | { 2 | "total_count": 23809, 3 | "artifacts": [ 4 | { 5 | "id": 416737084, 6 | "node_id": "MDg6QXJ0aWZhY3Q0MTY3MzcwODQ=", 7 | "name": "doc-html", 8 | "size_in_bytes": 61667543, 9 | "url": "https://api.github.com/repos/python/cpython/actions/artifacts/416737084", 10 | "archive_download_url": "https://api.github.com/repos/python/cpython/actions/artifacts/416737084/zip", 11 | "expired": false, 12 | "created_at": "2022-10-29T20:56:24Z", 13 | "updated_at": "2022-10-29T20:56:25Z", 14 | "expires_at": "2023-01-27T20:50:21Z", 15 | "workflow_run": { 16 | "id": 3352897496, 17 | "repository_id": 81598961, 18 | "head_repository_id": 101955313, 19 | "head_branch": "backport-bfecff5-3.11", 20 | "head_sha": "692cd77975413d71ff0951072df686e6f38711c8" 21 | } 22 | }, 23 | { 24 | "id": 416712612, 25 | "node_id": "MDg6QXJ0aWZhY3Q0MTY3MTI2MTI=", 26 | "name": "doc-html", 27 | "size_in_bytes": 61217330, 28 | "url": "https://api.github.com/repos/python/cpython/actions/artifacts/416712612", 29 | "archive_download_url": "https://api.github.com/repos/python/cpython/actions/artifacts/416712612/zip", 30 | "expired": false, 31 | "created_at": "2022-10-29T19:53:19Z", 32 | "updated_at": "2022-10-29T19:53:20Z", 33 | "expires_at": "2023-01-27T19:49:12Z", 34 | "workflow_run": { 35 | "id": 3352724493, 36 | "repository_id": 81598961, 37 | "head_repository_id": 559335486, 38 | "head_branch": "patch-1", 39 | "head_sha": "62eb88a66d1d35f7701873d8b698a2f8d7e84fa5" 40 | } 41 | } 42 | ] 43 | } 44 | -------------------------------------------------------------------------------- /fixtures/actions/cache-list.json: -------------------------------------------------------------------------------- 1 | { 2 | "total_count": 1, 3 | "actions_caches": [ 4 | { 5 | "id": 1, 6 | "ref": "refs/heads/main", 7 | "key": "cache_key", 8 | "version": "f5f850afdadd47730296d4ffa900de95f6bbafb75dc1e8475df1fa6ae79dcece", 9 | "last_accessed_at": "2022-10-30T00:08:14.223333300Z", 10 | "created_at": "2022-10-30T00:08:14.223333300Z", 11 | "size_in_bytes": 26586 12 | } 13 | ] 14 | } 15 | -------------------------------------------------------------------------------- /fixtures/actions/org-cache-usage.json: -------------------------------------------------------------------------------- 1 | { 2 | "total_active_caches_size_in_bytes": 26586, 3 | "total_active_caches_count": 1 4 | } 5 | -------------------------------------------------------------------------------- /fixtures/actions/org-public-key.json: -------------------------------------------------------------------------------- 1 | { 2 | "key_id": "568250167242549743", 3 | "key": "KHVvOxB765kjkShEgUu27QCzl5XxKz/L20V+KRsWf0w=" 4 | } 5 | -------------------------------------------------------------------------------- /fixtures/actions/org-secrets-list.json: -------------------------------------------------------------------------------- 1 | { 2 | "total_count": 2, 3 | "secrets": [ 4 | { 5 | "name": "TEST_SECRET", 6 | "created_at": "2022-10-31T00:08:12Z", 7 | "updated_at": "2022-10-31T00:08:12Z", 8 | "visibility": "all" 9 | }, 10 | { 11 | "name": "TEST_SELECTED", 12 | "created_at": "2022-10-31T00:08:43Z", 13 | "updated_at": "2022-10-31T00:08:43Z", 14 | "visibility": "selected", 15 | "selected_repositories_url": "https://api.github.com/orgs/kote-test-org-actions/actions/secrets/TEST_SELECTED/repositories" 16 | } 17 | ] 18 | } 19 | -------------------------------------------------------------------------------- /fixtures/actions/repo-cache-usage.json: -------------------------------------------------------------------------------- 1 | { 2 | "full_name": "python/cpython", 3 | "active_caches_size_in_bytes": 55000268087, 4 | "active_caches_count": 171 5 | } 6 | -------------------------------------------------------------------------------- /fixtures/actions/workflow-list.json: -------------------------------------------------------------------------------- 1 | { 2 | "total_count": 1, 3 | "workflows": [ 4 | { 5 | "id": 39065091, 6 | "node_id": "W_kwDOIVc8sc4CVBYD", 7 | "name": "learn-github-actions", 8 | "path": ".github/workflows/make_artifact.yaml", 9 | "state": "active", 10 | "created_at": "2022-10-29T15:17:59.000-07:00", 11 | "updated_at": "2022-10-29T15:17:59.000-07:00", 12 | "url": "https://api.github.com/repos/kote-test-org-actions/actions-api/actions/workflows/39065091", 13 | "html_url": "https://github.com/kote-test-org-actions/actions-api/blob/main/.github/workflows/make_artifact.yaml", 14 | "badge_url": "https://github.com/kote-test-org-actions/actions-api/workflows/learn-github-actions/badge.svg" 15 | } 16 | ] 17 | } 18 | -------------------------------------------------------------------------------- /fixtures/list-teams.json: -------------------------------------------------------------------------------- 1 | [ 2 | { 3 | "id": 1, 4 | "url": "https://api.github.com/teams/1", 5 | "name": "Justice League", 6 | "slug": "justice-league", 7 | "description": "A great team.", 8 | "privacy": "closed", 9 | "permission": "admin", 10 | "members_url": "https://api.github.com/teams/1/members{/member}", 11 | "repositories_url": "https://api.github.com/teams/1/repos" 12 | } 13 | ] 14 | -------------------------------------------------------------------------------- /fixtures/members-list.json: -------------------------------------------------------------------------------- 1 | [ 2 | { 3 | "login": "octocat", 4 | "id": 1, 5 | "avatar_url": "https://github.com/images/error/octocat_happy.gif", 6 | "gravatar_id": "", 7 | "url": "https://api.github.com/users/octocat", 8 | "html_url": "https://github.com/octocat", 9 | "followers_url": "https://api.github.com/users/octocat/followers", 10 | "following_url": "https://api.github.com/users/octocat/following{/other_user}", 11 | "gists_url": "https://api.github.com/users/octocat/gists{/gist_id}", 12 | "starred_url": "https://api.github.com/users/octocat/starred{/owner}{/repo}", 13 | "subscriptions_url": "https://api.github.com/users/octocat/subscriptions", 14 | "organizations_url": "https://api.github.com/users/octocat/orgs", 15 | "repos_url": "https://api.github.com/users/octocat/repos", 16 | "events_url": "https://api.github.com/users/octocat/events{/privacy}", 17 | "received_events_url": "https://api.github.com/users/octocat/received_events", 18 | "type": "User", 19 | "site_admin": false 20 | } 21 | ] 22 | -------------------------------------------------------------------------------- /fixtures/pull-request-approved-review.json: -------------------------------------------------------------------------------- 1 | { 2 | "id": 80, 3 | "node_id": "MDE3OlB1bGxSZXF1ZXN0UmV2aWV3ODA=", 4 | "user": { 5 | "login": "octocat", 6 | "id": 1, 7 | "node_id": "MDQ6VXNlcjE=", 8 | "avatar_url": "https://github.com/images/error/octocat_happy.gif", 9 | "gravatar_id": "", 10 | "url": "https://api.github.com/users/octocat", 11 | "html_url": "https://github.com/octocat", 12 | "followers_url": "https://api.github.com/users/octocat/followers", 13 | "following_url": "https://api.github.com/users/octocat/following{/other_user}", 14 | "gists_url": "https://api.github.com/users/octocat/gists{/gist_id}", 15 | "starred_url": "https://api.github.com/users/octocat/starred{/owner}{/repo}", 16 | "subscriptions_url": "https://api.github.com/users/octocat/subscriptions", 17 | "organizations_url": "https://api.github.com/users/octocat/orgs", 18 | "repos_url": "https://api.github.com/users/octocat/repos", 19 | "events_url": "https://api.github.com/users/octocat/events{/privacy}", 20 | "received_events_url": "https://api.github.com/users/octocat/received_events", 21 | "type": "User", 22 | "site_admin": false 23 | }, 24 | "body": "Here is the body for the review.", 25 | "state": "APPROVED", 26 | "html_url": "https://github.com/octocat/Hello-World/pull/12#pullrequestreview-80", 27 | "pull_request_url": "https://api.github.com/repos/octocat/Hello-World/pulls/12", 28 | "_links": { 29 | "html": { 30 | "href": "https://github.com/octocat/Hello-World/pull/12#pullrequestreview-80" 31 | }, 32 | "pull_request": { 33 | "href": "https://api.github.com/repos/octocat/Hello-World/pulls/12" 34 | } 35 | }, 36 | "submitted_at": "2019-11-17T17:43:43Z", 37 | "commit_id": "ecdd80bb57125d7ba9641ffaa4d7d2c19d3f3091" 38 | } -------------------------------------------------------------------------------- /fixtures/pull-request-pending-review.json: -------------------------------------------------------------------------------- 1 | { 2 | "id": 80, 3 | "node_id": "MDE3OlB1bGxSZXF1ZXN0UmV2aWV3ODA=", 4 | "user": { 5 | "login": "octocat", 6 | "id": 1, 7 | "node_id": "MDQ6VXNlcjE=", 8 | "avatar_url": "https://github.com/images/error/octocat_happy.gif", 9 | "gravatar_id": "", 10 | "url": "https://api.github.com/users/octocat", 11 | "html_url": "https://github.com/octocat", 12 | "followers_url": "https://api.github.com/users/octocat/followers", 13 | "following_url": "https://api.github.com/users/octocat/following{/other_user}", 14 | "gists_url": "https://api.github.com/users/octocat/gists{/gist_id}", 15 | "starred_url": "https://api.github.com/users/octocat/starred{/owner}{/repo}", 16 | "subscriptions_url": "https://api.github.com/users/octocat/subscriptions", 17 | "organizations_url": "https://api.github.com/users/octocat/orgs", 18 | "repos_url": "https://api.github.com/users/octocat/repos", 19 | "events_url": "https://api.github.com/users/octocat/events{/privacy}", 20 | "received_events_url": "https://api.github.com/users/octocat/received_events", 21 | "type": "User", 22 | "site_admin": false 23 | }, 24 | "body": "Here is the body for the review.", 25 | "state": "PENDING", 26 | "html_url": "https://github.com/octocat/Hello-World/pull/12#pullrequestreview-80", 27 | "pull_request_url": "https://api.github.com/repos/octocat/Hello-World/pulls/12", 28 | "_links": { 29 | "html": { 30 | "href": "https://github.com/octocat/Hello-World/pull/12#pullrequestreview-80" 31 | }, 32 | "pull_request": { 33 | "href": "https://api.github.com/repos/octocat/Hello-World/pulls/12" 34 | } 35 | }, 36 | "commit_id": "ecdd80bb57125d7ba9641ffaa4d7d2c19d3f3091" 37 | } -------------------------------------------------------------------------------- /fixtures/user-bot.json: -------------------------------------------------------------------------------- 1 | { 2 | "login": "mike-burns", 3 | "id": 4550, 4 | "avatar_url": "https://avatars.githubusercontent.com/u/4550?v=3", 5 | "gravatar_id": "", 6 | "url": "https://api.github.com/users/mike-burns", 7 | "html_url": "https://github.com/mike-burns", 8 | "followers_url": "https://api.github.com/users/mike-burns/followers", 9 | "following_url": "https://api.github.com/users/mike-burns/following{/other_user}", 10 | "gists_url": "https://api.github.com/users/mike-burns/gists{/gist_id}", 11 | "starred_url": "https://api.github.com/users/mike-burns/starred{/owner}{/repo}", 12 | "subscriptions_url": "https://api.github.com/users/mike-burns/subscriptions", 13 | "organizations_url": "https://api.github.com/users/mike-burns/orgs", 14 | "repos_url": "https://api.github.com/users/mike-burns/repos", 15 | "events_url": "https://api.github.com/users/mike-burns/events{/privacy}", 16 | "received_events_url": "https://api.github.com/users/mike-burns/received_events", 17 | "type": "Bot", 18 | "site_admin": false, 19 | "name": "Mike Burns", 20 | "company": "thoughtbot", 21 | "blog": "http://mike-burns.com/", 22 | "location": "Stockholm, Sweden", 23 | "email": "mburns@thoughtbot.com", 24 | "hireable": true, 25 | "bio": null, 26 | "public_repos": 35, 27 | "public_gists": 32, 28 | "followers": 171, 29 | "following": 0, 30 | "created_at": "2008-04-03T17:54:24Z", 31 | "updated_at": "2015-10-02T16:53:25Z" 32 | } 33 | -------------------------------------------------------------------------------- /fixtures/user-organizations.json: -------------------------------------------------------------------------------- 1 | [ 2 | { 3 | "login": "github", 4 | "id": 1, 5 | "url": "https://api.github.com/orgs/github", 6 | "avatar_url": "https://github.com/images/error/octocat_happy.gif", 7 | "description": "A great organization" 8 | } 9 | ] 10 | -------------------------------------------------------------------------------- /fixtures/user.json: -------------------------------------------------------------------------------- 1 | { 2 | "login": "mike-burns", 3 | "id": 4550, 4 | "avatar_url": "https://avatars.githubusercontent.com/u/4550?v=3", 5 | "gravatar_id": "", 6 | "url": "https://api.github.com/users/mike-burns", 7 | "html_url": "https://github.com/mike-burns", 8 | "followers_url": "https://api.github.com/users/mike-burns/followers", 9 | "following_url": "https://api.github.com/users/mike-burns/following{/other_user}", 10 | "gists_url": "https://api.github.com/users/mike-burns/gists{/gist_id}", 11 | "starred_url": "https://api.github.com/users/mike-burns/starred{/owner}{/repo}", 12 | "subscriptions_url": "https://api.github.com/users/mike-burns/subscriptions", 13 | "organizations_url": "https://api.github.com/users/mike-burns/orgs", 14 | "repos_url": "https://api.github.com/users/mike-burns/repos", 15 | "events_url": "https://api.github.com/users/mike-burns/events{/privacy}", 16 | "received_events_url": "https://api.github.com/users/mike-burns/received_events", 17 | "type": "User", 18 | "site_admin": false, 19 | "name": "Mike Burns", 20 | "company": "thoughtbot", 21 | "blog": "http://mike-burns.com/", 22 | "location": "Stockholm, Sweden", 23 | "email": "mburns@thoughtbot.com", 24 | "hireable": true, 25 | "bio": null, 26 | "public_repos": 35, 27 | "public_gists": 32, 28 | "followers": 171, 29 | "following": 0, 30 | "created_at": "2008-04-03T17:54:24Z", 31 | "updated_at": "2015-10-02T16:53:25Z" 32 | } 33 | -------------------------------------------------------------------------------- /samples/Activity/Starring/StarRepo.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module StarRepo where 3 | 4 | import qualified GitHub.Endpoints.Activity.Starring as GH 5 | 6 | import qualified Data.Text as T 7 | import qualified Data.Text.IO as T 8 | 9 | main :: IO () 10 | main = do 11 | let owner = "haskell-github" 12 | repo = "github" 13 | result <- GH.starRepo (GH.OAuth "your-token") 14 | (GH.mkOwnerName owner) (GH.mkRepoName repo) 15 | case result of 16 | Left err -> putStrLn $ "Error: " ++ show err 17 | Right () -> T.putStrLn $ T.concat ["Starred: ", owner, "/", repo] 18 | -------------------------------------------------------------------------------- /samples/Activity/Starring/UnstarRepo.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module UnstarRepo where 3 | 4 | import qualified GitHub.Endpoints.Activity.Starring as GH 5 | 6 | import qualified Data.Text as T 7 | import qualified Data.Text.IO as T 8 | 9 | main :: IO () 10 | main = do 11 | let owner = "haskell-github" 12 | repo = "github" 13 | result <- GH.unstarRepo (GH.OAuth "your-token") 14 | (GH.mkOwnerName owner) (GH.mkRepoName repo) 15 | case result of 16 | Left err -> putStrLn $ "Error: " ++ show err 17 | Right () -> T.putStrLn $ T.concat ["Unstarred: ", owner, "/", repo] 18 | -------------------------------------------------------------------------------- /samples/Enterprise/CreateOrganization.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module Main (main) where 4 | 5 | import Common 6 | 7 | import qualified GitHub 8 | import qualified GitHub.Enterprise as GitHub 9 | 10 | main :: IO () 11 | main = do 12 | args <- getArgs 13 | result <- case args of 14 | [api_endpoint, token, org_login, org_admin, org_profile_name] -> 15 | GitHub.github 16 | (GitHub.EnterpriseOAuth 17 | (fromString api_endpoint) 18 | (fromString token) 19 | ) 20 | GitHub.createOrganizationR 21 | (GitHub.CreateOrganization 22 | (GitHub.mkOrganizationName $ fromString org_login) 23 | (GitHub.mkUserName $ fromString org_admin) 24 | (Just $ fromString org_profile_name) 25 | ) 26 | _ -> 27 | error "usage: CreateOrganization " 28 | case result of 29 | Left err -> putStrLn $ "Error: " <> tshow err 30 | Right org -> putStrLn $ tshow org 31 | -------------------------------------------------------------------------------- /samples/Enterprise/RenameOrganization.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module Main (main) where 4 | 5 | import Common 6 | 7 | import qualified GitHub 8 | import qualified GitHub.Enterprise as GitHub 9 | 10 | main :: IO () 11 | main = do 12 | args <- getArgs 13 | result <- case args of 14 | [api_endpoint, token, current_name, new_name] -> 15 | GitHub.github 16 | (GitHub.EnterpriseOAuth 17 | (fromString api_endpoint) 18 | (fromString token) 19 | ) 20 | GitHub.renameOrganizationR 21 | (GitHub.mkOrganizationName $ fromString current_name) 22 | (GitHub.RenameOrganization 23 | (GitHub.mkOrganizationName $ fromString new_name) 24 | ) 25 | _ -> 26 | error "usage: RenameOrganization " 27 | case result of 28 | Left err -> putStrLn $ "Error: " <> tshow err 29 | Right x -> putStrLn $ tshow x 30 | -------------------------------------------------------------------------------- /samples/Gists/Comments/ShowComment.hs: -------------------------------------------------------------------------------- 1 | module ShowComment where 2 | 3 | import qualified Github.Gists.Comments as Github 4 | 5 | main = do 6 | possibleComment <- Github.comment "62449" 7 | case possibleComment of 8 | (Left error) -> putStrLn $ "Error: " ++ (show error) 9 | (Right comment) -> putStrLn $ formatComment comment 10 | 11 | formatComment comment = 12 | (Github.githubOwnerLogin $ Github.gistCommentUser comment) ++ "\n" ++ 13 | (formatDate $ Github.gistCommentUpdatedAt comment) ++ "\n\n" ++ 14 | (Github.gistCommentBody comment) 15 | 16 | formatDate = show . Github.fromDate 17 | -------------------------------------------------------------------------------- /samples/Gists/Comments/ShowComments.hs: -------------------------------------------------------------------------------- 1 | module ShowComments where 2 | 3 | import qualified Github.Gists.Comments as Github 4 | import Data.List (intercalate) 5 | 6 | main = do 7 | possibleComments <- Github.commentsOn "1174060" 8 | case possibleComments of 9 | (Left error) -> putStrLn $ "Error: " ++ (show error) 10 | (Right comments) -> putStrLn $ intercalate "\n\n" $ map formatComment comments 11 | 12 | formatComment comment = 13 | (Github.githubOwnerLogin $ Github.gistCommentUser comment) ++ "\n" ++ 14 | (formatDate $ Github.gistCommentUpdatedAt comment) ++ "\n\n" ++ 15 | (Github.gistCommentBody comment) 16 | 17 | formatDate = show . Github.fromDate 18 | -------------------------------------------------------------------------------- /samples/Gists/DeleteGist.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module DeleteGist where 3 | 4 | import qualified GitHub.Data.Name as N 5 | import qualified GitHub.Endpoints.Gists as GH 6 | 7 | import qualified Data.Text as T 8 | import qualified Data.Text.IO as T 9 | 10 | main :: IO () 11 | main = do 12 | let gid = "your-gist-id" 13 | result <- GH.deleteGist (GH.OAuth "your-token") gid 14 | case result of 15 | Left err -> putStrLn $ "Error: " ++ show err 16 | Right () -> T.putStrLn $ T.concat ["Deleted: ", N.untagName gid] 17 | -------------------------------------------------------------------------------- /samples/Gists/ListGists.hs: -------------------------------------------------------------------------------- 1 | module ListGists where 2 | 3 | import qualified Github.Gists as Github 4 | import Data.List (intercalate) 5 | 6 | main = do 7 | possibleGists <- Github.gists "mike-burns" 8 | case possibleGists of 9 | (Left error) -> putStrLn $ "Error: " ++ (show error) 10 | (Right gists) -> putStrLn $ intercalate "\n\n" $ map formatGist gists 11 | 12 | formatGist gist = 13 | (Github.gistId gist) ++ "\n" ++ 14 | (maybe "indescribable" id $ Github.gistDescription gist) ++ "\n" ++ 15 | (Github.gistHtmlUrl gist) 16 | -------------------------------------------------------------------------------- /samples/Gists/ShowGist.hs: -------------------------------------------------------------------------------- 1 | module ShowGist where 2 | 3 | import qualified Github.Gists as Github 4 | import Data.List (intercalate) 5 | 6 | main = do 7 | possibleGist <- Github.gist "23084" 8 | case possibleGist of 9 | (Left error) -> putStrLn $ "Error: " ++ (show error) 10 | (Right gist) -> putStrLn $ formatGist gist 11 | 12 | formatGist gist = 13 | (Github.gistId gist) ++ "\n" ++ 14 | (maybe "indescribable" id $ Github.gistDescription gist) ++ "\n" ++ 15 | (Github.gistHtmlUrl gist) ++ "\n\n" ++ 16 | (intercalate "\n\n" $ map formatGistFile $ Github.gistFiles gist) 17 | 18 | formatGistFile gistFile = 19 | (Github.gistFileFilename gistFile) ++ ":\n" ++ 20 | maybe "[empty]" id (Github.gistFileContent gistFile) 21 | -------------------------------------------------------------------------------- /samples/Gists/StarGist.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module StarGist where 3 | 4 | import qualified GitHub.Data.Name as N 5 | import qualified GitHub.Endpoints.Gists as GH 6 | 7 | import qualified Data.Text as T 8 | import qualified Data.Text.IO as T 9 | 10 | main :: IO () 11 | main = do 12 | let gid = "your-gist-id" 13 | result <- GH.starGist (GH.OAuth "your-token") gid 14 | case result of 15 | Left err -> putStrLn $ "Error: " ++ show err 16 | Right () -> T.putStrLn $ T.concat ["Starred: ", N.untagName gid] 17 | -------------------------------------------------------------------------------- /samples/Gists/UnstarGist.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module UnstarGist where 3 | 4 | import qualified GitHub.Data.Name as N 5 | import qualified GitHub.Endpoints.Gists as GH 6 | 7 | import qualified Data.Text as T 8 | import qualified Data.Text.IO as T 9 | 10 | main :: IO () 11 | main = do 12 | let gid = "your-gist-id" 13 | result <- GH.unstarGist (GH.OAuth "your-token") gid 14 | case result of 15 | Left err -> putStrLn $ "Error: " ++ show err 16 | Right () -> T.putStrLn $ T.concat ["Unstarred: ", N.untagName gid] 17 | -------------------------------------------------------------------------------- /samples/GitData/Blobs/GitHashObject.hs: -------------------------------------------------------------------------------- 1 | module GitHashObject where 2 | 3 | import qualified Github.GitData.Blobs as Github 4 | import Data.List( intercalate) 5 | 6 | main = do 7 | possibleBlob <- Github.blob "mike-burns" "github" "1dc7b1f6e0c7bf1118f3b03195071dd6ea6db9b3" 8 | case possibleBlob of 9 | (Left error) -> putStrLn $ "Error: " ++ (show error) 10 | (Right blob) -> putStrLn $ Github.blobContent blob 11 | -------------------------------------------------------------------------------- /samples/GitData/Commits/GitShow.hs: -------------------------------------------------------------------------------- 1 | module GitShow where 2 | 3 | import qualified Github.GitData.Commits as Github 4 | import Data.Maybe (fromJust) 5 | 6 | main = do 7 | possibleCommit <- Github.commit "thoughtbot" "paperclip" "bc5c51d1ece1ee45f94b056a0f5a1674d7e8cba9" 8 | case possibleCommit of 9 | (Left error) -> putStrLn $ "Error: " ++ (show error) 10 | (Right commit) -> putStrLn $ formatCommit commit 11 | 12 | formatCommit :: Github.GitCommit -> String 13 | formatCommit commit = 14 | "commit " ++ (fromJust $ Github.gitCommitSha commit) ++ 15 | "\nAuthor: " ++ (formatAuthor author) ++ 16 | "\nDate: " ++ (show $ Github.fromDate $ Github.gitUserDate author) ++ 17 | "\n\n\t" ++ (Github.gitCommitMessage commit) ++ "\n" 18 | where author = Github.gitCommitAuthor commit 19 | 20 | formatAuthor :: Github.GitUser -> String 21 | formatAuthor author = 22 | (Github.gitUserName author) ++ " <" ++ (Github.gitUserEmail author) ++ ">" 23 | 24 | -------------------------------------------------------------------------------- /samples/GitData/References/GitCreateReference.hs: -------------------------------------------------------------------------------- 1 | module GitCreateRef where 2 | 3 | import qualified Github.Auth as Auth 4 | import Github.GitData.References 5 | 6 | main :: IO () 7 | main = do 8 | let auth = Auth.OAuth "oauthtoken" 9 | newlyCreatedGitRef <- createReference auth "myrepo" "myowner" NewGitReference { 10 | newGitReferenceRef = "refs/heads/fav_tag" 11 | ,newGitReferenceSha = "aa218f56b14c9653891f9e74264a383fa43fefbd" 12 | } 13 | case newlyCreatedGitRef of 14 | (Left err) -> putStrLn $ "Error: " ++ show err 15 | (Right newRef) -> putStrLn . formatReference $ newRef 16 | 17 | formatReference :: GitReference -> String 18 | formatReference ref = 19 | (gitObjectSha $ gitReferenceObject ref) ++ "\t" ++ (gitReferenceRef ref) 20 | -------------------------------------------------------------------------------- /samples/GitData/References/GitLsRemote.hs: -------------------------------------------------------------------------------- 1 | module GitLsRemote where 2 | 3 | import qualified Github.GitData.References as Github 4 | import Data.List (intercalate) 5 | 6 | main = do 7 | possibleReferences <- Github.references "mike-burns" "github" 8 | case possibleReferences of 9 | (Left error) -> putStrLn $ "Error: " ++ show error 10 | (Right references) -> do 11 | putStrLn "From git@github.com:mike-burns/github.git" 12 | putStrLn $ intercalate "\n" $ map formatReference references 13 | 14 | formatReference reference = 15 | (Github.gitObjectSha $ Github.gitReferenceObject reference) ++ 16 | "\t" ++ (Github.gitReferenceRef reference) 17 | -------------------------------------------------------------------------------- /samples/GitData/References/GitLsRemoteTags.hs: -------------------------------------------------------------------------------- 1 | module GitLsRemoteTags where 2 | 3 | import qualified Github.GitData.References as Github 4 | import Data.List (intercalate) 5 | 6 | main = do 7 | possibleReferences <- Github.namespacedReferences "thoughtbot" "paperclip" "tags" 8 | case possibleReferences of 9 | (Left error) -> putStrLn $ "Error: " ++ show error 10 | (Right references) -> do 11 | putStrLn "From git@github.com:thoughtbot/paperclip.git" 12 | putStrLn $ intercalate "\n" $ map formatReference references 13 | 14 | formatReference reference = 15 | (Github.gitObjectSha $ Github.gitReferenceObject reference) ++ 16 | "\t" ++ (Github.gitReferenceRef reference) 17 | 18 | -------------------------------------------------------------------------------- /samples/GitData/References/GitLsRemoteWithRef.hs: -------------------------------------------------------------------------------- 1 | module GitLsRemoteWithRef where 2 | 3 | import qualified Github.GitData.References as Github 4 | 5 | main = do 6 | possibleReference <- Github.reference "mike-burns" "github" "heads/master" 7 | putStrLn $ either (\e -> "Error: " ++ show e) 8 | formatReference 9 | possibleReference 10 | 11 | formatReference reference = 12 | (Github.gitObjectSha $ Github.gitReferenceObject reference) ++ 13 | "\t" ++ (Github.gitReferenceRef reference) 14 | -------------------------------------------------------------------------------- /samples/GitData/Trees/GitLsTree.hs: -------------------------------------------------------------------------------- 1 | module GitLsTree where 2 | 3 | import qualified Github.GitData.Trees as Github 4 | import Data.List (intercalate) 5 | 6 | main = do 7 | possibleTree <- Github.tree "thoughtbot" "paperclip" "fe114451f7d066d367a1646ca7ac10e689b46844" 8 | case possibleTree of 9 | (Left error) -> putStrLn $ "Error: " ++ show error 10 | (Right tree) -> putStrLn $ formatTree tree 11 | 12 | formatTree tree = 13 | intercalate "\n" $ map formatGitTree $ Github.treeGitTrees tree 14 | 15 | formatGitTree gitTree = 16 | (Github.gitTreeMode gitTree) ++ " " ++ 17 | (Github.gitTreeType gitTree) ++ " " ++ 18 | (Github.gitTreeSha gitTree) ++ "\t" ++ 19 | (Github.gitTreePath gitTree) 20 | -------------------------------------------------------------------------------- /samples/GitData/Trees/GitLsTreeRecursively.hs: -------------------------------------------------------------------------------- 1 | module GitLsTreeRecursively where 2 | 3 | import qualified Github.GitData.Trees as Github 4 | import Data.List (intercalate) 5 | 6 | main = do 7 | possibleTree <- Github.nestedTree "thoughtbot" "paperclip" "fe114451f7d066d367a1646ca7ac10e689b46844" 8 | case possibleTree of 9 | (Left error) -> putStrLn $ "Error: " ++ show error 10 | (Right tree) -> putStrLn $ formatTree tree 11 | 12 | formatTree tree = 13 | intercalate "\n" $ map formatGitTree $ Github.treeGitTrees tree 14 | 15 | formatGitTree gitTree = 16 | (Github.gitTreeMode gitTree) ++ " " ++ 17 | (Github.gitTreeType gitTree) ++ " " ++ 18 | (Github.gitTreeSha gitTree) ++ "\t" ++ 19 | (Github.gitTreePath gitTree) 20 | -------------------------------------------------------------------------------- /samples/Issues/Comments/ShowComment.hs: -------------------------------------------------------------------------------- 1 | module ShowComment where 2 | 3 | import qualified Github.Issues.Comments as Github 4 | 5 | main = do 6 | possibleComment <- Github.comment "thoughtbot" "paperclip" 1468184 7 | putStrLn $ either (\e -> "Error: " ++ show e) 8 | formatComment 9 | possibleComment 10 | 11 | formatComment comment = 12 | (Github.githubOwnerLogin $ Github.issueCommentUser comment) ++ 13 | " commented " ++ 14 | (show $ Github.fromDate $ Github.issueCommentUpdatedAt comment) ++ 15 | "\n" ++ (Github.issueCommentBody comment) 16 | -------------------------------------------------------------------------------- /samples/Issues/Comments/ShowComments.hs: -------------------------------------------------------------------------------- 1 | module ShowComments where 2 | 3 | import qualified Github.Issues.Comments as Github 4 | import Data.List (intercalate) 5 | 6 | main = do 7 | possibleComments <- Github.comments "thoughtbot" "paperclip" 635 8 | case possibleComments of 9 | (Left error) -> putStrLn $ "Error: " ++ show error 10 | (Right issues) -> 11 | putStrLn $ intercalate "\n\n" $ map formatComment issues 12 | 13 | formatComment comment = 14 | (Github.githubOwnerLogin $ Github.issueCommentUser comment) ++ 15 | " commented " ++ 16 | (show $ Github.fromDate $ Github.issueCommentUpdatedAt comment) ++ 17 | "\n" ++ (Github.issueCommentBody comment) 18 | -------------------------------------------------------------------------------- /samples/Issues/CreateIssue.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | import Data.String (fromString) 5 | import qualified Data.Text as Text (unpack) 6 | import qualified Data.Vector as Vector (fromList) 7 | import qualified GitHub.Auth as GitHub 8 | import qualified GitHub.Data.Issues as GitHub 9 | import qualified GitHub.Endpoints.Issues as GitHub 10 | import qualified GitHub.Request as GitHub 11 | 12 | import System.Environment (lookupEnv) 13 | import qualified System.Exit as Exit (die) 14 | 15 | self :: String 16 | self = "github-create-issue" 17 | 18 | main :: IO () 19 | main = do 20 | token <- lookupEnv "GITHUB_TOKEN" >>= \case 21 | Nothing -> die "variable GITHUB_TOKEN not set" 22 | Just token -> return $ fromString token 23 | 24 | let auth = GitHub.OAuth token 25 | newiss = (GitHub.newIssue "A new issue") 26 | { GitHub.newIssueBody = Just "Issue description text goes here" 27 | , GitHub.newIssueLabels = Just $ Vector.fromList ["foo", "bar", "baz"] 28 | } 29 | request = GitHub.createIssueR "haskell-github" "playground" newiss 30 | 31 | GitHub.github auth request >>= \case 32 | Left err -> die $ show err 33 | Right issue -> putStrLn $ formatIssue issue 34 | 35 | die :: String -> IO a 36 | die msg = Exit.die $ concat [ self, ": Error: ", msg ] 37 | 38 | formatIssue :: GitHub.Issue -> String 39 | formatIssue issue = concat 40 | [ formatUser issue 41 | , " opened this issue " 42 | , show $ GitHub.issueCreatedAt issue 43 | , "\n" 44 | , show $ GitHub.issueState issue 45 | , " with " 46 | , show $ GitHub.issueComments issue 47 | , " comments\n\n" 48 | , Text.unpack $ GitHub.issueTitle issue 49 | ] 50 | 51 | formatUser :: GitHub.Issue -> String 52 | formatUser issue = 53 | Text.unpack . GitHub.untagName . GitHub.simpleUserLogin $ GitHub.issueUser issue 54 | -------------------------------------------------------------------------------- /samples/Issues/EditIssue.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module EditIssue where 3 | 4 | import qualified Github.Auth as Github 5 | import qualified Github.Issues as Github 6 | 7 | main = do 8 | let auth = Github.BasicAuth "user" "password" 9 | issueid = 3 10 | edit = Github.editOfIssue { Github.editIssueState = Just "closed" } 11 | possibleIssue <- Github.editIssue auth "thoughtbot" "paperclip" issueid edit 12 | putStrLn $ either (\e -> "Error: " ++ show e) 13 | formatIssue 14 | possibleIssue 15 | 16 | formatIssue issue = 17 | (Github.githubOwnerLogin $ Github.issueUser issue) ++ 18 | " opened this issue " ++ 19 | (show $ Github.fromDate $ Github.issueCreatedAt issue) ++ "\n" ++ 20 | (Github.issueState issue) ++ " with " ++ 21 | (show $ Github.issueComments issue) ++ " comments" ++ "\n\n" ++ 22 | (Github.issueTitle issue) 23 | -------------------------------------------------------------------------------- /samples/Issues/Events/ShowEvent.hs: -------------------------------------------------------------------------------- 1 | module ShowEvents where 2 | 3 | import qualified Github.Issues.Events as Github 4 | import Data.List (intercalate) 5 | import Data.Maybe (fromJust) 6 | 7 | main = do 8 | possibleEvent <- Github.event "thoughtbot" "paperclip" 5335772 9 | case possibleEvent of 10 | (Left error) -> putStrLn $ "Error: " ++ show error 11 | (Right event) -> do 12 | putStrLn $ formatEvent event 13 | 14 | formatEvent event = formatEvent' event (Github.eventType event) 15 | where 16 | formatEvent' event Github.Closed = 17 | "Closed on " ++ createdAt event ++ " by " ++ loginName event ++ 18 | withCommitId event (\commitId -> " in the commit " ++ commitId) 19 | formatEvent' event Github.Reopened = 20 | "Reopened on " ++ createdAt event ++ " by " ++ loginName event 21 | formatEvent' event Github.Subscribed = 22 | loginName event ++ " is subscribed to receive notifications" 23 | formatEvent' event Github.Unsubscribed = 24 | loginName event ++ " is unsubscribed from notifications" 25 | formatEvent' event Github.Merged = 26 | "Issue merged by " ++ loginName event ++ " on " ++ createdAt event ++ 27 | (withCommitId event $ \commitId -> " in the commit " ++ commitId) 28 | formatEvent' event Github.Referenced = 29 | withCommitId event $ \commitId -> 30 | "Issue referenced from " ++ commitId ++ " by " ++ loginName event 31 | formatEvent' event Github.Mentioned = 32 | loginName event ++ " was mentioned in the issue's body" 33 | formatEvent' event Github.Assigned = 34 | "Issue assigned to " ++ loginName event ++ " on " ++ createdAt event 35 | 36 | loginName = Github.githubOwnerLogin . Github.eventActor 37 | createdAt = show . Github.fromDate . Github.eventCreatedAt 38 | withCommitId event f = maybe "" f (Github.eventCommitId event) 39 | -------------------------------------------------------------------------------- /samples/Issues/Events/ShowIssueEvents.hs: -------------------------------------------------------------------------------- 1 | module ShowIssueEvents where 2 | 3 | import qualified Github.Issues.Events as Github 4 | import Data.List (intercalate) 5 | 6 | main = do 7 | possibleEvents <- Github.eventsForIssue "thoughtbot" "paperclip" 49 8 | case possibleEvents of 9 | (Left error) -> putStrLn $ "Error: " ++ show error 10 | (Right events) -> do 11 | putStrLn "Issue #49:\n" 12 | putStrLn $ intercalate "\n" $ map formatEvent events 13 | 14 | formatEvent event = formatEvent' event (Github.eventType event) 15 | where 16 | formatEvent' event Github.Closed = 17 | "Closed on " ++ createdAt event ++ " by " ++ loginName event ++ 18 | withCommitId event (\commitId -> " in the commit " ++ commitId) 19 | formatEvent' event Github.Reopened = 20 | "Reopened on " ++ createdAt event ++ " by " ++ loginName event 21 | formatEvent' event Github.Subscribed = 22 | loginName event ++ " is subscribed to receive notifications" 23 | formatEvent' event Github.Unsubscribed = 24 | loginName event ++ " is unsubscribed from notifications" 25 | formatEvent' event Github.Merged = 26 | "Issue merged by " ++ loginName event ++ " on " ++ createdAt event ++ 27 | (withCommitId event $ \commitId -> " in the commit " ++ commitId) 28 | formatEvent' event Github.Referenced = 29 | withCommitId event $ \commitId -> 30 | "Issue referenced from " ++ commitId ++ " by " ++ loginName event 31 | formatEvent' event Github.Mentioned = 32 | loginName event ++ " was mentioned in the issue's body" 33 | formatEvent' event Github.Assigned = 34 | "Issue assigned to " ++ loginName event ++ " on " ++ createdAt event 35 | 36 | loginName = Github.githubOwnerLogin . Github.eventActor 37 | createdAt = show . Github.fromDate . Github.eventCreatedAt 38 | withCommitId event f = maybe "" f (Github.eventCommitId event) 39 | -------------------------------------------------------------------------------- /samples/Issues/Events/ShowRepoEvents.hs: -------------------------------------------------------------------------------- 1 | module ShowRepoEvents where 2 | 3 | import qualified Github.Issues.Events as Github 4 | import Data.List (intercalate) 5 | import Data.Maybe (fromJust) 6 | 7 | main = do 8 | possibleEvents <- Github.eventsForRepo "thoughtbot" "paperclip" 9 | case possibleEvents of 10 | (Left error) -> putStrLn $ "Error: " ++ show error 11 | (Right events) -> do 12 | putStrLn $ intercalate "\n" $ map formatEvent events 13 | 14 | formatEvent event = 15 | "Issue #" ++ issueNumber event ++ ": " ++ 16 | formatEvent' event (Github.eventType event) 17 | where 18 | formatEvent' event Github.Closed = 19 | "closed on " ++ createdAt event ++ " by " ++ loginName event ++ 20 | withCommitId event (\commitId -> " in the commit " ++ commitId) 21 | formatEvent' event Github.Reopened = 22 | "reopened on " ++ createdAt event ++ " by " ++ loginName event 23 | formatEvent' event Github.Subscribed = 24 | loginName event ++ " is subscribed to receive notifications" 25 | formatEvent' event Github.Unsubscribed = 26 | loginName event ++ " is unsubscribed from notifications" 27 | formatEvent' event Github.Merged = 28 | "merged by " ++ loginName event ++ " on " ++ createdAt event ++ 29 | (withCommitId event $ \commitId -> " in the commit " ++ commitId) 30 | formatEvent' event Github.Referenced = 31 | withCommitId event $ \commitId -> 32 | "referenced from " ++ commitId ++ " by " ++ loginName event 33 | formatEvent' event Github.Mentioned = 34 | loginName event ++ " was mentioned in the issue's body" 35 | formatEvent' event Github.Assigned = 36 | "assigned to " ++ loginName event ++ " on " ++ createdAt event 37 | 38 | loginName = Github.githubOwnerLogin . Github.eventActor 39 | createdAt = show . Github.fromDate . Github.eventCreatedAt 40 | withCommitId event f = maybe "" f (Github.eventCommitId event) 41 | issueNumber = show . Github.issueNumber . fromJust . Github.eventIssue 42 | -------------------------------------------------------------------------------- /samples/Issues/IssueReport/Issues.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Main where 3 | 4 | import qualified Github.Auth as Github 5 | import qualified Github.Issues as Github 6 | import Report 7 | 8 | -- The example requires wl-pprint module "The Wadler/Leijen Pretty Printer" 9 | import Text.PrettyPrint.ANSI.Leijen 10 | 11 | auth :: Maybe Github.Auth 12 | auth = Just $ Github.BasicAuth "yourgithub id" "somepassword" 13 | 14 | mkIssue :: ReportedIssue -> Doc 15 | mkIssue (Issue n t h) = hsep [ 16 | fill 5 (text ("#" ++ (show n))), 17 | fill 50 (text t), 18 | fill 5 (text (show h))] 19 | 20 | vissues :: ([Doc], [Doc], [Doc]) -> Doc 21 | vissues (x, y, z) = hsep [(vcat x), align (vcat y), align (vcat z)] 22 | 23 | mkDoc :: Report -> Doc 24 | mkDoc (Report issues total) = vsep [ 25 | text "Report for the milestone", 26 | (vsep . map mkIssue) issues, 27 | text ("Total hours : " ++ (show total) ++" hours") 28 | ] 29 | 30 | mkFullDoc :: [Github.Issue] -> Doc 31 | mkFullDoc = mkDoc . prepareReport 32 | 33 | -- The public repo is used as private are quite sensitive for this report 34 | -- 35 | -- The main idea is to use labels like 1h, 2h etc for man-hour estimation of issues 36 | -- on private repos for development "on hire" 37 | -- 38 | -- This tool is used to generate report on work done for the customer 39 | -- 40 | main :: IO () 41 | main = do 42 | let limitations = [Github.OnlyClosed, Github.MilestoneId 4] 43 | possibleIssues <- Github.issuesForRepo' auth "paulrzcz" "hquantlib" limitations 44 | case possibleIssues of 45 | (Left err) -> putStrLn $ "Error: " ++ show err 46 | (Right issues) -> putDoc $ mkFullDoc issues 47 | -------------------------------------------------------------------------------- /samples/Issues/IssueReport/IssuesEnterprise.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Main where 3 | 4 | import qualified Github.Auth as Github 5 | import qualified Github.Issues as Github 6 | import Report 7 | 8 | -- The example requires wl-pprint module "The Wadler/Leijen Pretty Printer" 9 | import Text.PrettyPrint.ANSI.Leijen 10 | 11 | auth :: Maybe Github.Auth 12 | auth = Just $ Github.EnterpriseOAuth 13 | "https://github.example.com/api" 14 | "1a79a4d60de6718e8e5b326e338ae533" 15 | 16 | mkIssue :: ReportedIssue -> Doc 17 | mkIssue (Issue n t h) = hsep [ 18 | fill 5 (text ("#" ++ (show n))), 19 | fill 50 (text t), 20 | fill 5 (text (show h))] 21 | 22 | vissues :: ([Doc], [Doc], [Doc]) -> Doc 23 | vissues (x, y, z) = hsep [(vcat x), align (vcat y), align (vcat z)] 24 | 25 | mkDoc :: Report -> Doc 26 | mkDoc (Report issues total) = vsep [ 27 | text "Report for the milestone", 28 | (vsep . map mkIssue) issues, 29 | text ("Total hours : " ++ (show total) ++" hours") 30 | ] 31 | 32 | mkFullDoc :: [Github.Issue] -> Doc 33 | mkFullDoc = mkDoc . prepareReport 34 | 35 | -- The public repo is used as private are quite sensitive for this report 36 | -- 37 | -- The main idea is to use labels like 1h, 2h etc for man-hour estimation of issues 38 | -- on private repos for development "on hire" 39 | -- 40 | -- This tool is used to generate report on work done for the customer 41 | -- 42 | main :: IO () 43 | main = do 44 | let limitations = [Github.OnlyClosed, Github.MilestoneId 4] 45 | possibleIssues <- Github.issuesForRepo' auth "paulrzcz" "hquantlib" limitations 46 | case possibleIssues of 47 | (Left err) -> putStrLn $ "Error: " ++ show err 48 | (Right issues) -> putDoc $ mkFullDoc issues 49 | -------------------------------------------------------------------------------- /samples/Issues/IssueReport/Report.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Report ( 3 | ReportedIssue (..), 4 | Report (..), 5 | prepareReport, 6 | convertLabels 7 | ) where 8 | 9 | import Text.Regex.Posix 10 | import qualified Github.Issues as Github 11 | 12 | data ReportedIssue = Issue { 13 | riNumber :: Int, 14 | riTitle :: String, 15 | riHour :: Double 16 | } deriving (Show) 17 | 18 | data Report = Report { 19 | rIssues :: [ReportedIssue], 20 | rTotal :: Double 21 | } deriving (Show) 22 | 23 | convertIssue :: Github.Issue -> ReportedIssue 24 | convertIssue issue = Issue { 25 | riNumber = Github.issueNumber issue, 26 | riTitle = Github.issueTitle issue, 27 | riHour = convertLabels issue 28 | } 29 | 30 | convertLabels :: Github.Issue -> Double 31 | convertLabels = sumUp . toNames . Github.issueLabels 32 | 33 | prepareReport :: [Github.Issue] -> Report 34 | prepareReport issues = Report { 35 | rIssues = reportedIssues, 36 | rTotal = foldl summator 0 reportedIssues 37 | } where reportedIssues = map convertIssue issues 38 | summator z x = z + (riHour x) 39 | 40 | -- Helper functions to construct a sum of hour labels 41 | 42 | sumUp :: [Maybe Double] -> Double 43 | sumUp = foldl s 0.0 44 | where s z Nothing = z 45 | s z (Just x) = z+x 46 | 47 | toNames :: [Github.IssueLabel] -> [Maybe Double] 48 | toNames = map (toValue . Github.labelName) 49 | 50 | isValue :: String -> Bool 51 | isValue label = (label =~ ("^[0-9]h" :: String)) :: Bool 52 | 53 | convert :: Read a => [Char] -> a 54 | convert label = read $ take len label 55 | where len = (length label) - 1 56 | 57 | toValue :: Read a => String -> Maybe a 58 | toValue label 59 | | isValue label = Just (convert label) 60 | | otherwise = Nothing 61 | 62 | -------------------------------------------------------------------------------- /samples/Issues/Labels/CreateLabels.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module CreateLabels where 3 | 4 | import Data.List (intercalate) 5 | import qualified Github.Auth as Github 6 | import qualified Github.Issues.Labels as Github 7 | main = do 8 | let auth = Github.BasicAuth "user" "password" 9 | possibleLabel <- Github.createLabel auth "thoughtbot" "papperclip" "sample label" "ff00ff" 10 | case possibleLabel of 11 | (Left error) -> putStrLn $ "Error: " ++ show error 12 | (Right label) -> putStrLn . formatLabel $ label 13 | 14 | formatLabel label = Github.labelName label ++ 15 | ", colored " ++ 16 | Github.labelColor label 17 | -------------------------------------------------------------------------------- /samples/Issues/Labels/ShowIssueLabels.hs: -------------------------------------------------------------------------------- 1 | module ShowIssueLabels where 2 | 3 | import qualified Github.Issues.Labels as Github 4 | import Data.List (intercalate) 5 | 6 | main = do 7 | possibleLabels <- Github.labelsOnIssue "thoughtbot" "paperclip" 585 8 | case possibleLabels of 9 | (Left error) -> putStrLn $ "Error: " ++ show error 10 | (Right labels) -> do 11 | putStrLn $ intercalate "\n" $ map formatLabel labels 12 | 13 | formatLabel label = 14 | (Github.labelName label) ++ ", colored " ++ (Github.labelColor label) 15 | -------------------------------------------------------------------------------- /samples/Issues/Labels/ShowLabel.hs: -------------------------------------------------------------------------------- 1 | module ShowLabel where 2 | 3 | import qualified Github.Issues.Labels as Github 4 | 5 | main = do 6 | possibleLabel <- Github.label "thoughtbot" "paperclip" "bug" 7 | case possibleLabel of 8 | (Left error) -> putStrLn $ "Error: " ++ show error 9 | (Right label) -> putStrLn $ formatLabel label 10 | 11 | formatLabel label = 12 | (Github.labelName label) ++ ", colored " ++ (Github.labelColor label) 13 | 14 | -------------------------------------------------------------------------------- /samples/Issues/Labels/ShowMilestoneLabels.hs: -------------------------------------------------------------------------------- 1 | module ShowMilestoneLabels where 2 | 3 | import qualified Github.Issues.Labels as Github 4 | import Data.List (intercalate) 5 | 6 | main = do 7 | possibleLabels <- Github.labelsOnMilestone "thoughtbot" "paperclip" 2 8 | case possibleLabels of 9 | (Left error) -> putStrLn $ "Error: " ++ show error 10 | (Right labels) -> do 11 | putStrLn $ intercalate "\n" $ map formatLabel labels 12 | 13 | formatLabel label = 14 | (Github.labelName label) ++ ", colored " ++ (Github.labelColor label) 15 | 16 | -------------------------------------------------------------------------------- /samples/Issues/Labels/ShowRepoLabels.hs: -------------------------------------------------------------------------------- 1 | module ShowRepoLabels where 2 | 3 | import Data.List (intercalate) 4 | import qualified Github.Issues.Labels as Github 5 | 6 | main = do 7 | possibleLabels <- Github.labelsOnRepo "thoughtbot" "paperclip" 8 | case possibleLabels of 9 | (Left error) -> putStrLn $ "Error: " ++ show error 10 | (Right labels) -> do 11 | putStrLn $ intercalate "\n" $ map formatLabel labels 12 | 13 | formatLabel label = 14 | (Github.labelName label) ++ ", colored " ++ (Github.labelColor label) 15 | -------------------------------------------------------------------------------- /samples/Issues/Milestones/ShowMilestone.hs: -------------------------------------------------------------------------------- 1 | module ShowMilestone where 2 | 3 | import qualified Github.Issues.Milestones as Github 4 | import Data.List (intercalate) 5 | 6 | main = do 7 | possibleMilestone <- Github.milestone "thoughtbot" "paperclip" 2 8 | case possibleMilestone of 9 | (Left error) -> putStrLn $ "Error: " ++ show error 10 | (Right milestone) -> 11 | putStrLn $ formatMilestone milestone 12 | 13 | formatMilestone milestone = 14 | (Github.milestoneTitle milestone) ++ ", as created by " ++ 15 | (loginName milestone) ++ " on " ++ (createdAt milestone) ++ 16 | formatDueOn (Github.milestoneDueOn milestone) ++ " and has the " ++ 17 | (Github.milestoneState milestone) ++ " status" 18 | 19 | formatDueOn Nothing = "" 20 | formatDueOn (Just milestoneDate) = ", is due on " ++ dueOn milestoneDate 21 | 22 | loginName = Github.githubOwnerLogin . Github.milestoneCreator 23 | createdAt = show . Github.fromDate . Github.milestoneCreatedAt 24 | dueOn = show . Github.fromDate 25 | -------------------------------------------------------------------------------- /samples/Issues/Milestones/ShowMilestones.hs: -------------------------------------------------------------------------------- 1 | module ShowMilestones where 2 | 3 | import qualified Github.Issues.Milestones as Github 4 | import Data.List (intercalate) 5 | 6 | main = do 7 | possibleMilestones <- Github.milestones "thoughtbot" "paperclip" 8 | case possibleMilestones of 9 | (Left error) -> putStrLn $ "Error: " ++ show error 10 | (Right milestones) -> 11 | putStrLn $ intercalate "\n\n" $ map formatMilestone milestones 12 | 13 | formatMilestone milestone = 14 | (Github.milestoneTitle milestone) ++ ", as created by " ++ 15 | (loginName milestone) ++ " on " ++ (createdAt milestone) ++ 16 | formatDueOn (Github.milestoneDueOn milestone) ++ " and has the " ++ 17 | (Github.milestoneState milestone) ++ " status" 18 | 19 | formatDueOn Nothing = "" 20 | formatDueOn (Just milestoneDate) = ", is due on " ++ dueOn milestoneDate 21 | 22 | loginName = Github.githubOwnerLogin . Github.milestoneCreator 23 | createdAt = show . Github.fromDate . Github.milestoneCreatedAt 24 | dueOn = show . Github.fromDate 25 | -------------------------------------------------------------------------------- /samples/Issues/ShowIssue.hs: -------------------------------------------------------------------------------- 1 | module ShowIssue where 2 | 3 | import qualified Github.Issues as Github 4 | 5 | main = do 6 | possibleIssue <- Github.issue "thoughtbot" "paperclip" 549 7 | putStrLn $ either (\e -> "Error: " ++ show e) 8 | formatIssue 9 | possibleIssue 10 | 11 | formatIssue issue = 12 | (Github.githubOwnerLogin $ Github.issueUser issue) ++ 13 | " opened this issue " ++ 14 | (show $ Github.fromDate $ Github.issueCreatedAt issue) ++ "\n" ++ 15 | (Github.issueState issue) ++ " with " ++ 16 | (show $ Github.issueComments issue) ++ " comments" ++ "\n\n" ++ 17 | (Github.issueTitle issue) 18 | -------------------------------------------------------------------------------- /samples/Issues/ShowRepoIssues.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | import Data.Foldable (toList) 5 | import Data.List (intercalate) 6 | import Data.Vector (Vector) 7 | 8 | import qualified GitHub as Github 9 | 10 | main :: IO () 11 | main = do 12 | let filt = Github.stateClosed <> Github.optionsMentioned "mike-burns" <> Github.optionsAssignee "jyurek" 13 | printIssues =<< do 14 | Github.github' $ Github.issuesForRepoR "thoughtbot" "paperclip" filt Github.FetchAll 15 | 16 | printIssues =<< do 17 | Github.github' $ Github.issuesForRepoR "haskell-github" "playground" Github.stateClosed Github.FetchAll 18 | 19 | printIssues :: Either Github.Error (Vector Github.Issue) -> IO () 20 | printIssues = \case 21 | Left err -> 22 | putStrLn $ "Error: " ++ show err 23 | Right issues -> 24 | putStrLn $ intercalate "\n\n" $ map formatIssue $ toList issues 25 | 26 | formatIssue :: Github.Issue -> String 27 | formatIssue issue = concat 28 | 29 | [ show $ Github.simpleUserLogin $ Github.issueUser issue 30 | , " opened this issue " 31 | , show $ Github.issueCreatedAt issue 32 | , ".\n" 33 | 34 | , "It is currently " 35 | , show $ Github.issueState issue 36 | , maybe "" (\ r -> " with reason " ++ show r) $ Github.issueStateReason issue 37 | , " with " 38 | , show $ Github.issueComments issue 39 | , " comments.\n\n" 40 | 41 | , show $ Github.issueTitle issue 42 | ] 43 | -------------------------------------------------------------------------------- /samples/LICENSE: -------------------------------------------------------------------------------- 1 | ../LICENSE -------------------------------------------------------------------------------- /samples/Operational/Operational.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | 5 | module Main (main) where 6 | 7 | import Common 8 | import Prelude () 9 | 10 | import Control.Exception (throw) 11 | import Control.Monad.IO.Class (liftIO) 12 | import Control.Monad.Operational (Program, ProgramViewT (..), singleton, view) 13 | import Control.Monad.Trans.Except (ExceptT (..), runExceptT) 14 | import Network.HTTP.Client (Manager, newManager, responseBody) 15 | 16 | import qualified GitHub as GH 17 | 18 | data R a where 19 | R :: FromJSON a => GH.Request 'GH.RA a -> R a 20 | 21 | type GithubMonad a = Program R a 22 | 23 | runMonad :: GH.AuthMethod auth => Manager -> auth -> GithubMonad a -> ExceptT GH.Error IO a 24 | runMonad mgr auth m = case view m of 25 | Return a -> return a 26 | R req :>>= k -> do 27 | res <- ExceptT $ GH.executeRequestWithMgrAndRes mgr auth req 28 | liftIO $ print $ GH.limitsFromHttpResponse res 29 | runMonad mgr auth (k (responseBody res)) 30 | 31 | githubRequest :: FromJSON a => GH.Request 'GH.RA a -> GithubMonad a 32 | githubRequest = singleton . R 33 | 34 | main :: IO () 35 | main = GH.withOpenSSL $ do 36 | manager <- newManager GH.tlsManagerSettings 37 | auth' <- getAuth 38 | case auth' of 39 | Nothing -> do 40 | (owner, rl) <- runExceptT (runMonad manager () script) >>= either throw return 41 | print owner 42 | print rl 43 | Just auth -> do 44 | (owner, rl) <- runExceptT (runMonad manager auth script) >>= either throw return 45 | print owner 46 | print rl 47 | 48 | script :: Program R (GH.Owner, GH.Limits) 49 | script = do 50 | repo <- githubRequest $ GH.repositoryR "haskell-github" "github" 51 | owner <- githubRequest $ GH.ownerInfoForR (GH.simpleOwnerLogin . GH.repoOwner $ repo) 52 | rl <- githubRequest GH.rateLimitR 53 | return (owner, GH.rateLimitCore rl) 54 | -------------------------------------------------------------------------------- /samples/Organizations/Members/ShowMembers.hs: -------------------------------------------------------------------------------- 1 | module ShowMembers where 2 | 3 | import qualified Github.Organizations.Members as Github 4 | import Data.List (intercalate) 5 | 6 | main = do 7 | possibleMembers <- Github.membersOf "thoughtbot" 8 | case possibleMembers of 9 | (Left error) -> putStrLn $ "Error: " ++ (show error) 10 | (Right members) -> 11 | putStrLn $ intercalate "\n" $ map Github.githubOwnerLogin members 12 | -------------------------------------------------------------------------------- /samples/Organizations/ShowPublicOrganization.hs: -------------------------------------------------------------------------------- 1 | module ShowPublicOrganization where 2 | 3 | import qualified Github.Organizations as Github 4 | 5 | main = do 6 | possibleOrganization <- Github.publicOrganization "thoughtbot" 7 | case possibleOrganization of 8 | (Left error) -> putStrLn $ "Error: " ++ (show error) 9 | (Right organization) -> 10 | putStrLn $ formatOrganization organization 11 | 12 | formatOrganization organization = 13 | (maybe "" (\s -> s ++ "\n") (Github.organizationName organization)) ++ 14 | (Github.organizationHtmlUrl organization) ++ 15 | (maybe "" (\s -> "\n" ++ s) (Github.organizationBlog organization)) 16 | -------------------------------------------------------------------------------- /samples/Organizations/ShowPublicOrganizations.hs: -------------------------------------------------------------------------------- 1 | module ShowPublicOrganizations where 2 | 3 | import qualified Github.Organizations as Github 4 | import Data.List (intercalate) 5 | 6 | main = do 7 | possibleOrganizations <- Github.publicOrganizationsFor "mike-burns" 8 | case possibleOrganizations of 9 | (Left error) -> putStrLn $ "Error: " ++ (show error) 10 | (Right organizations) -> 11 | putStrLn $ intercalate "\n" $ map formatOrganization organizations 12 | 13 | formatOrganization = Github.simpleOrganizationLogin 14 | -------------------------------------------------------------------------------- /samples/Organizations/Teams/CreateTeamFor.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module CreateTeamFor where 4 | 5 | import qualified Github.Auth as Github 6 | import qualified Github.Teams as Github 7 | import System.Environment (getArgs) 8 | 9 | main = do 10 | args <- getArgs 11 | result <- case args of 12 | [token, org, team, desc, repos] -> 13 | Github.createTeamFor' 14 | (Github.OAuth token) 15 | org 16 | (Github.CreateTeam team (Just desc) (read repos :: [String]) Github.PrivacyClosed Github.PermissionPull) 17 | _ -> 18 | error "usage: CreateTeamFor <[\"repos\"]>" 19 | case result of 20 | Left err -> putStrLn $ "Error: " ++ show err 21 | Right team -> putStrLn $ show team 22 | -------------------------------------------------------------------------------- /samples/Organizations/Teams/ListTeamsForOrganization.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module ListTeamsForOrganization where 4 | 5 | import qualified Github.Auth as Github 6 | import qualified Github.Organizations.Teams as Github 7 | import System.Environment (getArgs) 8 | 9 | main = do 10 | args <- getArgs 11 | result <- case args of 12 | [team, token] -> Github.teamsOf' (Just $ Github.OAuth token) team 13 | [team] -> Github.teamsOf team 14 | _ -> error "usage: ListTeamsForOrganization [auth token]" 15 | case result of 16 | Left err -> putStrLn $ "Error: " ++ show err 17 | Right teams -> mapM_ (putStrLn . show) teams 18 | -------------------------------------------------------------------------------- /samples/Pulls/Comments/ListComments.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module ListComments where 3 | 4 | import qualified GitHub.Endpoints.PullRequests.Comments as GitHub 5 | import GitHub.Data.Id (Id(Id)) 6 | import Data.Monoid ((<>)) 7 | import Data.Text (Text, unpack, pack) 8 | import Data.Time.Format 9 | 10 | main :: IO () 11 | main = do 12 | possiblePullRequestComments <- GitHub.pullRequestCommentsIO "thoughtbot" "factory_girl" (Id 256) 13 | case possiblePullRequestComments of 14 | (Left err) -> putStrLn $ "Error: " <> show err 15 | (Right comments) -> putStrLn . unpack $ foldr (\a b -> a <> "\n\n" <> b) "" (formatComment <$> comments) 16 | 17 | formatComment :: GitHub.Comment -> Text 18 | formatComment comment = 19 | "Author: " <> formatAuthor (GitHub.commentUser comment) <> 20 | "\nUpdated: " <> pack (formatTime' (GitHub.commentUpdatedAt comment)) <> 21 | (maybe "" (\u -> "\nURL: " <> GitHub.getUrl u) $ GitHub.commentHtmlUrl comment) <> 22 | "\n\n" <> GitHub.commentBody comment 23 | 24 | formatAuthor :: GitHub.SimpleUser -> Text 25 | formatAuthor user = 26 | GitHub.untagName (GitHub.simpleUserLogin user) <> " (" <> GitHub.getUrl (GitHub.simpleUserUrl user) <> ")" 27 | 28 | formatTime' :: (FormatTime t) => t -> String 29 | formatTime' = formatTime defaultTimeLocale "%T, %F (%Z)" 30 | -------------------------------------------------------------------------------- /samples/Pulls/Comments/ShowComment.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module ShowComment where 3 | 4 | import qualified GitHub.Endpoints.PullRequests.Comments as GitHub 5 | import GitHub.Data.Id (Id(Id)) 6 | import Data.Monoid ((<>)) 7 | import Data.Text (Text, unpack, pack) 8 | import Data.Time.Format 9 | 10 | main :: IO () 11 | main = do 12 | possiblePullRequestComment <- GitHub.pullRequestComment "thoughtbot" "factory_girl" (Id 301819) 13 | case possiblePullRequestComment of 14 | (Left err) -> putStrLn $ "Error: " <> show err 15 | (Right comment) -> putStrLn . unpack $ formatComment comment 16 | 17 | formatComment :: GitHub.Comment -> Text 18 | formatComment comment = 19 | "Author: " <> formatAuthor (GitHub.commentUser comment) <> 20 | "\nUpdated: " <> pack (formatTime' (GitHub.commentUpdatedAt comment)) <> 21 | (maybe "" (\u -> "\nURL: " <> GitHub.getUrl u) $ GitHub.commentHtmlUrl comment) <> 22 | "\n\n" <> GitHub.commentBody comment 23 | 24 | formatAuthor :: GitHub.SimpleUser -> Text 25 | formatAuthor user = 26 | GitHub.untagName (GitHub.simpleUserLogin user) <> " (" <> GitHub.getUrl (GitHub.simpleUserUrl user) <> ")" 27 | 28 | formatTime' :: (FormatTime t) => t -> String 29 | formatTime' = formatTime defaultTimeLocale "%T, %F (%Z)" 30 | -------------------------------------------------------------------------------- /samples/Pulls/Diff.hs: -------------------------------------------------------------------------------- 1 | module Diff where 2 | 3 | import qualified Github.PullRequests as Github 4 | import Data.List 5 | 6 | main = do 7 | possiblePullRequestFiles <- Github.pullRequestFiles "thoughtbot" "paperclip" 575 8 | case possiblePullRequestFiles of 9 | (Left error) -> putStrLn $ "Error: " ++ (show error) 10 | (Right files) -> putStrLn $ intercalate "\n\n" $ map formatFile files 11 | 12 | formatFile file = 13 | Github.fileFilename file ++ "\n" ++ Github.filePatch file 14 | -------------------------------------------------------------------------------- /samples/Pulls/IsMergedPull.hs: -------------------------------------------------------------------------------- 1 | module CheckIfPullMerged where 2 | 3 | import qualified Github.PullRequests as Github 4 | import Github.Auth 5 | 6 | main :: IO () 7 | main = do 8 | mergeResult <- Github.isPullRequestMerged (OAuth "authtoken") "thoughtbot" "paperclip" 575 9 | case mergeResult of 10 | (Left err) -> putStrLn $ "Error: " ++ (show err) 11 | (Right stat) -> putStrLn $ (show stat) 12 | -------------------------------------------------------------------------------- /samples/Pulls/ListPulls.hs: -------------------------------------------------------------------------------- 1 | module ListPulls where 2 | 3 | import qualified Github.PullRequests as Github 4 | import Data.List 5 | 6 | main = do 7 | possiblePullRequests <- Github.pullRequestsFor "thoughtbot" "paperclip" 8 | case possiblePullRequests of 9 | (Left error) -> putStrLn $ "Error: " ++ (show error) 10 | (Right pullRequests) -> 11 | putStrLn $ intercalate "\n\n" $ map formatPullRequest pullRequests 12 | 13 | formatPullRequest pullRequest = 14 | (Github.pullRequestTitle pullRequest) ++ "\n" ++ 15 | (take 80 $ Github.pullRequestBody pullRequest) ++ "\n" ++ 16 | (Github.githubOwnerLogin $ Github.pullRequestUser pullRequest) ++ 17 | " submitted to thoughtbot/paperclip " ++ 18 | (formatDate $ Github.pullRequestCreatedAt pullRequest) ++ 19 | " updated " ++ 20 | (formatDate $ Github.pullRequestUpdatedAt pullRequest) ++ "\n" ++ 21 | (Github.pullRequestHtmlUrl pullRequest) 22 | 23 | formatDate = show . Github.fromDate 24 | -------------------------------------------------------------------------------- /samples/Pulls/MergePull.hs: -------------------------------------------------------------------------------- 1 | module MergePullRequest where 2 | 3 | import qualified Github.PullRequests as Github 4 | import Github.Auth 5 | 6 | main :: IO () 7 | main = do 8 | mergeResult <- Github.mergePullRequest (OAuth "authtoken") "thoughtbot" "paperclip" 575 (Just "Merge message") 9 | case mergeResult of 10 | (Left err) -> putStrLn $ "Error: " ++ (show err) 11 | (Right stat) -> putStrLn $ (show stat) 12 | -------------------------------------------------------------------------------- /samples/Pulls/ShowCommits.hs: -------------------------------------------------------------------------------- 1 | module ShowCommits where 2 | 3 | import qualified Github.PullRequests as Github 4 | import Data.List 5 | import Data.Maybe 6 | 7 | main = do 8 | possiblePullRequestCommits <- Github.pullRequestCommits "thoughtbot" "paperclip" 575 9 | case possiblePullRequestCommits of 10 | (Left error) -> putStrLn $ "Error: " ++ (show error) 11 | (Right commits) -> putStrLn $ intercalate "\n" $ map formatCommit commits 12 | 13 | formatCommit commit = 14 | (formatAuthor $ Github.gitCommitAuthor gitCommit) ++ "\n" ++ 15 | (maybe "unknown SHA" id $ Github.gitCommitSha gitCommit) ++ "\n" ++ 16 | (Github.gitCommitMessage gitCommit) 17 | where gitCommit = Github.commitGitCommit commit 18 | 19 | formatAuthor :: Github.GitUser -> String 20 | formatAuthor author = 21 | (Github.gitUserName author) ++ " <" ++ (Github.gitUserEmail author) ++ ">" 22 | -------------------------------------------------------------------------------- /samples/Pulls/ShowPull.hs: -------------------------------------------------------------------------------- 1 | module ShowPull where 2 | 3 | import qualified Github.PullRequests as Github 4 | import Data.List 5 | 6 | main = do 7 | possiblePullRequest <- Github.pullRequest "thoughtbot" "paperclip" 575 8 | case possiblePullRequest of 9 | (Left error) -> putStrLn $ "Error: " ++ (show error) 10 | (Right pullRequest) -> putStrLn $ formatPullRequest pullRequest 11 | 12 | formatPullRequest p = 13 | (Github.githubOwnerLogin $ Github.detailedPullRequestUser p) ++ 14 | " opened this pull request " ++ 15 | (formatDate $ Github.detailedPullRequestCreatedAt p) ++ "\n" ++ 16 | (Github.detailedPullRequestTitle p) ++ "\n" ++ 17 | (Github.detailedPullRequestBody p) ++ "\n" ++ 18 | (Github.detailedPullRequestState p) ++ "\n" ++ 19 | "+" ++ (show $ Github.detailedPullRequestAdditions p) ++ " additions\n" ++ 20 | "-" ++ (show $ Github.detailedPullRequestDeletions p) ++ " deletions\n" ++ 21 | (show $ Github.detailedPullRequestComments p) ++ " comments\n" ++ 22 | (Github.detailedPullRequestHtmlUrl p) 23 | 24 | formatDate = show . Github.fromDate 25 | -------------------------------------------------------------------------------- /samples/Pulls/UpdatePull.hs: -------------------------------------------------------------------------------- 1 | module MergePullRequest where 2 | 3 | import qualified Github.PullRequests as Github 4 | import Github.Auth 5 | import Github.Data 6 | 7 | main :: IO () 8 | main = do 9 | mergeResult <- Github.updatePullRequest (OAuth "authtoken") "repoOwner" "repoName" 22 EditPullRequest 10 | { editPullRequestTitle = Just "Brand new title" 11 | , editPullRequestBody = Nothing 12 | , editPullRequestState = Just EditPullRequestStateClosed 13 | , editPullRequestBase = Nothing 14 | , editPullRequestMaintainerCanModify = Just True 15 | } 16 | case mergeResult of 17 | (Left err) -> putStrLn $ "Error: " ++ (show err) 18 | (Right dpr) -> putStrLn . show $ dpr 19 | -------------------------------------------------------------------------------- /samples/RateLimit.hs: -------------------------------------------------------------------------------- 1 | module RateLimit where 2 | 3 | import qualified Github.RateLimit as Github 4 | 5 | main = do 6 | x <- Github.rateLimit 7 | print x 8 | -------------------------------------------------------------------------------- /samples/Repos/Collaborators/IsCollaborator.hs: -------------------------------------------------------------------------------- 1 | module IsCollaborator where 2 | 3 | import qualified Github.Repos.Collaborators as Github 4 | import Data.List 5 | 6 | main = do 7 | let userName = "ubuwaits" 8 | possiblyIsCollaborator <- Github.isCollaboratorOn Nothing userName "thoughtbot" "paperclip" 9 | case possiblyIsCollaborator of 10 | (Left error) -> putStrLn $ "Error: " ++ (show error) 11 | (Right True) -> 12 | putStrLn $ userName ++ " is a collaborator on thoughtbot's paperclip" 13 | (Right False) -> 14 | putStrLn $ userName ++ " does not collaborate on thoughtbot's paperclip" 15 | -------------------------------------------------------------------------------- /samples/Repos/Collaborators/ListCollaborators.hs: -------------------------------------------------------------------------------- 1 | module ListCollaborators where 2 | 3 | import qualified Github.Repos.Collaborators as Github 4 | import Data.List 5 | 6 | main = do 7 | possibleCollaborators <- Github.collaboratorsOn "thoughtbot" "paperclip" 8 | case possibleCollaborators of 9 | (Left error) -> putStrLn $ "Error: " ++ (show error) 10 | (Right collaborators) -> 11 | putStrLn $ intercalate "\n" $ map formatAuthor collaborators 12 | 13 | formatAuthor :: Github.Owner -> String 14 | formatAuthor user = 15 | (Github.githubOwnerLogin user) ++ " (" ++ (Github.githubOwnerUrl user) ++ ")" 16 | -------------------------------------------------------------------------------- /samples/Repos/Commits/CommitComment.hs: -------------------------------------------------------------------------------- 1 | module CommitComment where 2 | 3 | import qualified Github.Repos.Commits as Github 4 | import Data.Maybe (maybe) 5 | 6 | main = do 7 | possibleComment <- Github.commitCommentFor "thoughtbot" "paperclip" "669575" 8 | case possibleComment of 9 | (Left error) -> putStrLn $ "Error: " ++ (show error) 10 | (Right comment) -> putStrLn $ formatComment comment 11 | 12 | formatComment :: Github.Comment -> String 13 | formatComment comment = 14 | "Author: " ++ (formatAuthor $ Github.commentUser comment) ++ 15 | "\nUpdated: " ++ (show $ Github.commentUpdatedAt comment) ++ 16 | (maybe "" ("\nURL: "++) $ Github.commentHtmlUrl comment) ++ 17 | "\n\n" ++ (Github.commentBody comment) 18 | 19 | formatAuthor :: Github.Owner -> String 20 | formatAuthor user = 21 | (Github.githubOwnerLogin user) ++ " (" ++ (Github.githubOwnerUrl user) ++ ")" 22 | -------------------------------------------------------------------------------- /samples/Repos/Commits/CommitComments.hs: -------------------------------------------------------------------------------- 1 | module CommitComments where 2 | 3 | import qualified Github.Repos.Commits as Github 4 | import Data.List 5 | import Data.Maybe (maybe) 6 | 7 | main = do 8 | possibleComments <- Github.commitCommentsFor "thoughtbot" "paperclip" "41f685f6e01396936bb8cd98e7cca517e2c7d96b" 9 | case possibleComments of 10 | (Left error) -> putStrLn $ "Error: " ++ (show error) 11 | (Right comments) -> putStrLn $ intercalate "\n\n" $ map formatComment comments 12 | 13 | formatComment :: Github.Comment -> String 14 | formatComment comment = 15 | "Author: " ++ (formatAuthor $ Github.commentUser comment) ++ 16 | "\nUpdated: " ++ (show $ Github.commentUpdatedAt comment) ++ 17 | (maybe "" ("\nURL: "++) $ Github.commentHtmlUrl comment) ++ 18 | "\n\n" ++ (Github.commentBody comment) 19 | 20 | formatAuthor :: Github.Owner -> String 21 | formatAuthor user = 22 | (Github.githubOwnerLogin user) ++ " (" ++ (Github.githubOwnerUrl user) ++ ")" 23 | -------------------------------------------------------------------------------- /samples/Repos/Commits/GitDiff.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | module Main where 5 | 6 | import Common 7 | import qualified GitHub.Endpoints.Repos.Commits as Github 8 | import qualified Data.Text.IO as Text 9 | 10 | main :: IO () 11 | main = do 12 | possibleDiff <- Github.diff "thoughtbot" "paperclip" "41f685f6e01396936bb8cd98e7cca517e2c7d96b" "HEAD" 13 | either (fail . show) (Text.putStrLn . showDiff) possibleDiff 14 | 15 | -- Check special case: when a file only changes file permissions in the commits, GitHub returns a null "sha" field for that file. 16 | -- See https://github.com/scott-fleischman/repo-change-file-permission 17 | diffFillNullSha <- Github.diff "scott-fleischman" "repo-change-file-permission" "80fdf8f83fcd8181411919fbf47394b878c591a0" "77a95bbebeb78f4fb25c6a10c3c940b6fe1caa27" 18 | either (fail . show) (const $ Text.putStrLn "Successfully parsed diff with a file with a null sha") diffFillNullSha 19 | 20 | where 21 | showDiff diff = 22 | foldl (\x y -> x <> "\n\n" <> y) "" $ concatMap (maybe [] pure . Github.filePatch) $ Github.diffFiles diff 23 | -------------------------------------------------------------------------------- /samples/Repos/Commits/GitLog.hs: -------------------------------------------------------------------------------- 1 | module GitLog where 2 | 3 | import qualified Github.Repos.Commits as Github 4 | import Data.List 5 | 6 | main = do 7 | possibleCommits <- Github.commitsFor "thoughtbot" "paperclip" 8 | case possibleCommits of 9 | (Left error) -> putStrLn $ "Error: " ++ (show error) 10 | (Right commits) -> putStrLn $ intercalate "\n\n" $ map formatCommit commits 11 | 12 | formatCommit :: Github.Commit -> String 13 | formatCommit commit = 14 | "commit " ++ (Github.commitSha commit) ++ 15 | "\nAuthor: " ++ (formatAuthor author) ++ 16 | "\nDate: " ++ (show $ Github.fromDate $ Github.gitUserDate author) ++ 17 | "\n\n\t" ++ (Github.gitCommitMessage gitCommit) 18 | where author = Github.gitCommitAuthor gitCommit 19 | gitCommit = Github.commitGitCommit commit 20 | 21 | formatAuthor :: Github.GitUser -> String 22 | formatAuthor author = 23 | (Github.gitUserName author) ++ " <" ++ (Github.gitUserEmail author) ++ ">" 24 | -------------------------------------------------------------------------------- /samples/Repos/Commits/GitShow.hs: -------------------------------------------------------------------------------- 1 | module GitShow where 2 | 3 | import qualified Github.Repos.Commits as Github 4 | import Data.List 5 | 6 | main = do 7 | possibleCommit <- Github.commit "thoughtbot" "paperclip" "bc5c51d1ece1ee45f94b056a0f5a1674d7e8cba9" 8 | case possibleCommit of 9 | (Left error) -> putStrLn $ "Error: " ++ (show error) 10 | (Right commit) -> putStrLn $ formatCommit commit 11 | 12 | formatCommit :: Github.Commit -> String 13 | formatCommit commit = 14 | "commit " ++ (Github.commitSha commit) ++ 15 | "\nAuthor: " ++ (formatAuthor author) ++ 16 | "\nDate: " ++ (show $ Github.fromDate $ Github.gitUserDate author) ++ 17 | "\n\n\t" ++ (Github.gitCommitMessage gitCommit) ++ "\n" ++ 18 | patches 19 | where author = Github.gitCommitAuthor gitCommit 20 | gitCommit = Github.commitGitCommit commit 21 | patches = 22 | intercalate "\n" $ map Github.filePatch $ Github.commitFiles commit 23 | 24 | formatAuthor :: Github.GitUser -> String 25 | formatAuthor author = 26 | (Github.gitUserName author) ++ " <" ++ (Github.gitUserEmail author) ++ ">" 27 | 28 | -------------------------------------------------------------------------------- /samples/Repos/Commits/RepoComments.hs: -------------------------------------------------------------------------------- 1 | module RepoComments where 2 | 3 | import qualified Github.Repos.Commits as Github 4 | import Data.List 5 | import Data.Maybe (maybe) 6 | 7 | main = do 8 | possibleComments <- Github.commentsFor "thoughtbot" "paperclip" 9 | case possibleComments of 10 | (Left error) -> putStrLn $ "Error: " ++ (show error) 11 | (Right comments) -> putStrLn $ intercalate "\n\n" $ map formatComment comments 12 | 13 | formatComment :: Github.Comment -> String 14 | formatComment comment = 15 | "Author: " ++ (formatAuthor $ Github.commentUser comment) ++ 16 | "\nUpdated: " ++ (show $ Github.commentUpdatedAt comment) ++ 17 | (maybe "" ("\nURL: "++) $ Github.commentHtmlUrl comment) ++ 18 | "\n\n" ++ (Github.commentBody comment) 19 | 20 | formatAuthor :: Github.Owner -> String 21 | formatAuthor user = 22 | (Github.githubOwnerLogin user) ++ " (" ++ (Github.githubOwnerUrl user) ++ ")" 23 | -------------------------------------------------------------------------------- /samples/Repos/DeployKeys/CreateDeployKey.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Main (main) where 3 | 4 | import qualified GitHub as GH 5 | import Data.Text (Text) 6 | 7 | main :: IO () 8 | main = do 9 | let auth = GH.OAuth "auth_token" 10 | eDeployKey <- GH.github auth GH.createRepoDeployKeyR "your_owner" "your_repo" newDeployKey 11 | case eDeployKey of 12 | Left err -> putStrLn $ "Error: " ++ show err 13 | Right deployKey -> print deployKey 14 | 15 | newDeployKey :: GH.NewRepoDeployKey 16 | newDeployKey = GH.NewRepoDeployKey publicKey "test-key" True 17 | where 18 | publicKey :: Text 19 | publicKey = "your_public_key" 20 | -------------------------------------------------------------------------------- /samples/Repos/DeployKeys/DeleteDeployKey.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Main (main) where 3 | 4 | import GitHub.Data.Id (Id (..)) 5 | import qualified GitHub.Endpoints.Repos.DeployKeys as DK 6 | import qualified GitHub.Auth as Auth 7 | 8 | main :: IO () 9 | main = do 10 | let auth = Auth.OAuth "auth_token" 11 | eDeployKey <- DK.deleteRepoDeployKey' auth "your_owner" "your_repo" (Id 18530161) 12 | case eDeployKey of 13 | (Left err) -> putStrLn $ "Error: " ++ (show err) 14 | (Right _) -> putStrLn $ "Deleted deploy key!" 15 | -------------------------------------------------------------------------------- /samples/Repos/DeployKeys/ListDeployKeys.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Main (main) where 3 | 4 | import qualified GitHub as GH 5 | import Data.List (intercalate) 6 | import Data.Vector (toList) 7 | 8 | main :: IO () 9 | main = do 10 | let auth = GH.OAuth "auth_token" 11 | eDeployKeys <- GH.github auth GH.deployKeysForR "your_owner" "your_repo" GH.FetchAll 12 | case eDeployKeys of 13 | Left err -> putStrLn $ "Error: " ++ show err 14 | Right deployKeys -> putStrLn $ intercalate "\n" $ map formatRepoDeployKey (toList deployKeys) 15 | 16 | formatRepoDeployKey :: DK.RepoDeployKey -> String 17 | formatRepoDeployKey = show 18 | 19 | -------------------------------------------------------------------------------- /samples/Repos/DeployKeys/ShowDeployKey.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Main (main) where 3 | 4 | import GitHub.Data.Id (Id (..)) 5 | import qualified GitHub.Data.DeployKeys as DK 6 | import qualified GitHub.Endpoints.Repos.DeployKeys as DK 7 | import qualified GitHub.Auth as Auth 8 | 9 | main :: IO () 10 | main = do 11 | let auth = Auth.OAuth "auth_token" 12 | eDeployKey <- DK.deployKeyFor' auth "your_owner" "your_repo" (Id 18528451) 13 | case eDeployKey of 14 | (Left err) -> putStrLn $ "Error: " ++ (show err) 15 | (Right deployKey) -> putStrLn $ formatRepoDeployKey deployKey 16 | 17 | formatRepoDeployKey :: DK.RepoDeployKey -> String 18 | formatRepoDeployKey = show 19 | 20 | -------------------------------------------------------------------------------- /samples/Repos/Forks/ListForks.hs: -------------------------------------------------------------------------------- 1 | module ListForks where 2 | 3 | import qualified Github.Repos.Forks as Github 4 | import Data.List 5 | 6 | main = do 7 | possibleForks <- Github.forksFor "thoughtbot" "paperclip" 8 | putStrLn $ either (("Error: "++) . show) 9 | (intercalate "\n\n" . map formatFork) 10 | possibleForks 11 | 12 | formatFork fork = 13 | (Github.githubOwnerLogin $ Github.repoOwner fork) ++ "\t" ++ 14 | (formatPushedAt $ Github.repoPushedAt fork) ++ "\n" ++ 15 | (formatCloneUrl $ Github.repoCloneUrl fork) 16 | 17 | formatPushedAt Nothing = "" 18 | formatPushedAt (Just pushedAt) = show $ Github.fromDate pushedAt 19 | 20 | formatCloneUrl Nothing = "" 21 | formatCloneUrl (Just cloneUrl) = cloneUrl 22 | -------------------------------------------------------------------------------- /samples/Repos/GetReadme.hs: -------------------------------------------------------------------------------- 1 | module GetReadme where 2 | 3 | import qualified Github.Repos as Github 4 | import Data.List 5 | import Data.Maybe 6 | 7 | main = do 8 | possibleReadme <- Github.readmeFor "jwiegley" "github" 9 | case possibleReadme of 10 | (Left error) -> putStrLn $ "Error: " ++ (show error) 11 | (Right (Github.ContentFile cd)) -> putStrLn $ (show cd) 12 | -------------------------------------------------------------------------------- /samples/Repos/ListBranches.hs: -------------------------------------------------------------------------------- 1 | module ListBranches where 2 | 3 | import qualified Github.Repos as Github 4 | import Data.List 5 | 6 | main = do 7 | possibleBranches <- Github.branchesFor "thoughtbot" "paperclip" 8 | case possibleBranches of 9 | (Left error) -> putStrLn $ "Error: " ++ (show error) 10 | (Right branches) -> 11 | putStrLn $ intercalate "\n" $ map Github.branchName branches 12 | -------------------------------------------------------------------------------- /samples/Repos/ListContributors.hs: -------------------------------------------------------------------------------- 1 | module ListContributors where 2 | 3 | import qualified Github.Repos as Github 4 | import Data.List 5 | 6 | main = do 7 | possibleContributors <- Github.contributors "thoughtbot" "paperclip" 8 | case possibleContributors of 9 | (Left error) -> putStrLn $ "Error: " ++ (show error) 10 | (Right contributors) -> 11 | putStrLn $ intercalate "\n" $ map formatContributor contributors 12 | 13 | formatContributor (Github.KnownContributor contributions _ login _ _ _) = 14 | (show $ contributions) ++ "\t" ++ login 15 | formatContributor (Github.AnonymousContributor contributions name) = 16 | (show $ contributions) ++ "\t" ++ name 17 | -------------------------------------------------------------------------------- /samples/Repos/ListContributorsWithAnonymous.hs: -------------------------------------------------------------------------------- 1 | module ListContributorsWithAnonymous where 2 | 3 | import qualified Github.Repos as Github 4 | import Data.List 5 | 6 | main = do 7 | possibleContributors <- Github.contributorsWithAnonymous "thoughtbot" "paperclip" 8 | case possibleContributors of 9 | (Left error) -> putStrLn $ "Error: " ++ (show error) 10 | (Right contributors) -> 11 | putStrLn $ intercalate "\n" $ map formatContributor contributors 12 | 13 | formatContributor (Github.KnownContributor contributions _ login _ _ _) = 14 | (show $ contributions) ++ "\t" ++ login 15 | formatContributor (Github.AnonymousContributor contributions name) = 16 | (show $ contributions) ++ "\t" ++ name 17 | -------------------------------------------------------------------------------- /samples/Repos/ListLanguages.hs: -------------------------------------------------------------------------------- 1 | module ListLanguages where 2 | 3 | import qualified Github.Repos as Github 4 | import Data.List 5 | 6 | main = do 7 | possibleLanguages <- Github.languagesFor "mike-burns" "ohlaunch" 8 | case possibleLanguages of 9 | (Left error) -> putStrLn $ "Error: " ++ (show error) 10 | (Right languages) -> 11 | putStrLn $ intercalate "\n" $ map formatLanguage languages 12 | 13 | formatLanguage (Github.Language name characterCount) = 14 | name ++ "\t" ++ show characterCount 15 | -------------------------------------------------------------------------------- /samples/Repos/ListOrgRepos.hs: -------------------------------------------------------------------------------- 1 | module ListOrgRepos where 2 | 3 | import qualified Github.Repos as Github 4 | import Data.List 5 | import Data.Maybe 6 | 7 | main = do 8 | possibleRepos <- Github.organizationRepos "thoughtbot" 9 | case possibleRepos of 10 | (Left error) -> putStrLn $ "Error: " ++ (show error) 11 | (Right repos) -> putStrLn $ intercalate "\n\n" $ map formatRepo repos 12 | 13 | formatRepo repo = 14 | (Github.repoName repo) ++ "\t" ++ 15 | (fromMaybe "" $ Github.repoDescription repo) ++ "\n" ++ 16 | (Github.repoHtmlUrl repo) ++ "\n" ++ 17 | (fromMaybe "" $ Github.repoCloneUrl repo) ++ "\t" ++ 18 | (formatDate $ Github.repoUpdatedAt repo) ++ "\n" ++ 19 | formatLanguage (Github.repoLanguage repo) ++ 20 | "watchers: " ++ (show $ Github.repoWatchers repo) ++ "\t" ++ 21 | "forks: " ++ (show $ Github.repoForks repo) 22 | 23 | formatDate (Just date) = show . Github.fromDate $ date 24 | formatDate Nothing = "????" 25 | 26 | formatLanguage (Just language) = "language: " ++ language ++ "\t" 27 | formatLanguage Nothing = "" 28 | -------------------------------------------------------------------------------- /samples/Repos/ListTags.hs: -------------------------------------------------------------------------------- 1 | module ListTags where 2 | 3 | import qualified Github.Repos as Github 4 | import Data.List 5 | 6 | main = do 7 | possibleTags <- Github.tagsFor "thoughtbot" "paperclip" 8 | case possibleTags of 9 | (Left error) -> putStrLn $ "Error: " ++ (show error) 10 | (Right tags) -> 11 | putStrLn $ intercalate "\n" $ map Github.tagName tags 12 | -------------------------------------------------------------------------------- /samples/Repos/ListUserRepos.hs: -------------------------------------------------------------------------------- 1 | module ListUserRepos where 2 | 3 | import qualified Github.Repos as Github 4 | import Data.List 5 | import Data.Maybe 6 | 7 | main = do 8 | possibleRepos <- Github.userRepos "mike-burns" Github.Owner 9 | case possibleRepos of 10 | (Left error) -> putStrLn $ "Error: " ++ (show error) 11 | (Right repos) -> putStrLn $ intercalate "\n\n" $ map formatRepo repos 12 | 13 | formatRepo repo = 14 | (Github.repoName repo) ++ "\t" ++ 15 | (fromMaybe "" $ Github.repoDescription repo) ++ "\n" ++ 16 | (Github.repoHtmlUrl repo) ++ "\n" ++ 17 | (fromMaybe "" $ Github.repoCloneUrl repo) ++ "\t" ++ 18 | (formatDate $ Github.repoUpdatedAt repo) ++ "\n" ++ 19 | formatLanguage (Github.repoLanguage repo) ++ 20 | "watchers: " ++ (show $ Github.repoWatchers repo) ++ "\t" ++ 21 | "forks: " ++ (show $ Github.repoForks repo) 22 | 23 | formatDate (Just date) = show . Github.fromDate $ date 24 | formatDate Nothing = "" 25 | 26 | formatLanguage (Just language) = "language: " ++ language ++ "\t" 27 | formatLanguage Nothing = "" 28 | -------------------------------------------------------------------------------- /samples/Repos/ShowRepo.hs: -------------------------------------------------------------------------------- 1 | module ShowRepo where 2 | 3 | import qualified Github.Repos as Github 4 | import Data.List 5 | import Data.Maybe 6 | 7 | main = do 8 | possibleRepo <- Github.repository "mike-burns" "trylambda" 9 | case possibleRepo of 10 | Left error -> putStrLn $ "Error: " ++ show error 11 | Right repo -> putStrLn $ formatRepo repo 12 | 13 | formatRepo repo = Github.repoName repo ++ "\t" ++ 14 | fromMaybe "" (Github.repoDescription repo) ++ "\n" ++ 15 | Github.repoHtmlUrl repo ++ "\n" ++ 16 | fromMaybe "" (Github.repoCloneUrl repo) ++ "\t" ++ 17 | maybe "" formatDate (Github.repoUpdatedAt repo) ++ "\n" ++ 18 | formatLanguage (Github.repoLanguage repo) ++ 19 | "watchers: " ++ show (Github.repoWatchers repo) ++ "\t" ++ 20 | "forks: " ++ show (Github.repoForks repo) 21 | 22 | formatDate = show . Github.fromDate 23 | 24 | formatLanguage (Just language) = "language: " ++ language ++ "\t" 25 | formatLanguage Nothing = "" 26 | -------------------------------------------------------------------------------- /samples/Repos/Starring/ListStarred.hs: -------------------------------------------------------------------------------- 1 | module ListStarred where 2 | 3 | import qualified Github.Repos.Starring as Github 4 | import Data.List (intercalate) 5 | import Data.Maybe (fromMaybe) 6 | 7 | main = do 8 | possibleRepos <- Github.reposStarredBy Nothing "mike-burns" 9 | putStrLn $ either (("Error: "++) . show) 10 | (intercalate "\n\n" . map formatRepo) 11 | possibleRepos 12 | 13 | formatRepo repo = 14 | (Github.repoName repo) ++ "\t" ++ 15 | (fromMaybe "" $ Github.repoDescription repo) ++ "\n" ++ 16 | (Github.repoHtmlUrl repo) ++ "\n" ++ 17 | (fromMaybe "" $ Github.repoCloneUrl repo) ++ "\t" ++ 18 | (formatDate $ Github.repoUpdatedAt repo) ++ "\n" ++ 19 | formatLanguage (Github.repoLanguage repo) 20 | 21 | formatDate (Just date) = show . Github.fromDate $ date 22 | formatDate Nothing = "" 23 | 24 | formatLanguage (Just language) = "language: " ++ language ++ "\t" 25 | formatLanguage Nothing = "" 26 | -------------------------------------------------------------------------------- /samples/Repos/Watching/ListWatched.hs: -------------------------------------------------------------------------------- 1 | module ListWatched where 2 | 3 | import qualified Github.Repos.Watching as Github 4 | import Data.List (intercalate) 5 | import Data.Maybe (fromMaybe) 6 | 7 | main = do 8 | possibleRepos <- Github.reposWatchedBy "mike-burns" 9 | putStrLn $ either (("Error: "++) . show) 10 | (intercalate "\n\n" . map formatRepo) 11 | possibleRepos 12 | 13 | formatRepo repo = 14 | (Github.repoName repo) ++ "\t" ++ 15 | (fromMaybe "" $ Github.repoDescription repo) ++ "\n" ++ 16 | (Github.repoHtmlUrl repo) ++ "\n" ++ 17 | (fromMaybe "" $ Github.repoCloneUrl repo) ++ "\t" ++ 18 | (formatDate $ Github.repoUpdatedAt repo) ++ "\n" ++ 19 | formatLanguage (Github.repoLanguage repo) ++ 20 | "watchers: " ++ (show $ Github.repoWatchers repo) ++ "\t" ++ 21 | "forks: " ++ (show $ Github.repoForks repo) 22 | 23 | formatDate (Just date) = show . Github.fromDate $ date 24 | formatDate Nothing = "" 25 | 26 | formatLanguage (Just language) = "language: " ++ language ++ "\t" 27 | formatLanguage Nothing = "" 28 | -------------------------------------------------------------------------------- /samples/Repos/Watching/ListWatchers.hs: -------------------------------------------------------------------------------- 1 | module ListWatchers where 2 | 3 | import qualified Github.Repos.Watching as Github 4 | import Data.List (intercalate) 5 | 6 | main = do 7 | possibleWatchers <- Github.watchersFor "doubledrones" "git-annex" 8 | putStrLn $ either (("Error: "++) . show) 9 | (intercalate "\n" . map formatWatcher) 10 | possibleWatchers 11 | 12 | formatWatcher :: Github.Owner -> String 13 | formatWatcher user = 14 | (Github.githubOwnerLogin user) ++ " (" ++ (Github.githubOwnerUrl user) ++ ")" 15 | -------------------------------------------------------------------------------- /samples/Repos/Watching/Unwatch.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Main where 4 | 5 | import qualified GitHub as GH 6 | import qualified Data.Text as T 7 | import qualified Data.Text.IO as T 8 | 9 | main :: IO () 10 | main = do 11 | let auth = GH.BasicAuth "" "" 12 | owner = "haskell-github" 13 | repo = "github" 14 | result <- GH.github auth GH.unwatchRepoR (GH.mkOwnerName owner) (GH.mkRepoName repo) 15 | case result of 16 | Left err -> putStrLn $ "Error: " ++ show err 17 | Right () -> T.putStrLn $ T.concat ["No longer watching: ", owner, "/", repo] 18 | -------------------------------------------------------------------------------- /samples/Repos/Webhooks/CreateWebhook.hs: -------------------------------------------------------------------------------- 1 | module CreateWebhook where 2 | 3 | import Github.Repos.Webhooks 4 | import qualified Github.Auth as Auth 5 | import Github.Data.Definitions 6 | import qualified Data.Map as M 7 | 8 | main :: IO () 9 | main = do 10 | let auth = Auth.OAuth "oauthtoken" 11 | let config = M.fromList [("url", "https://foo3.io"), ("content_type", "application/json"), ("insecure_ssl", "1")] 12 | let webhookDef = NewRepoWebhook { 13 | newRepoWebhookName = "web", 14 | newRepoWebhookConfig = config, 15 | newRepoWebhookEvents = Just [WebhookWildcardEvent], 16 | newRepoWebhookActive = Just True 17 | } 18 | newWebhook <- createRepoWebhook' auth "repoOwner" "repoName" webhookDef 19 | case newWebhook of 20 | (Left err) -> putStrLn $ "Error: " ++ (show err) 21 | (Right webhook) -> putStrLn $ formatRepoWebhook webhook 22 | 23 | formatRepoWebhook :: RepoWebhook -> String 24 | formatRepoWebhook (RepoWebhook _ _ _ name _ _ _ _ _ _) = show name 25 | -------------------------------------------------------------------------------- /samples/Repos/Webhooks/DeleteWebhook.hs: -------------------------------------------------------------------------------- 1 | module DeleteWebhook where 2 | 3 | import Github.Repos.Webhooks 4 | import qualified Github.Auth as Auth 5 | 6 | main :: IO () 7 | main = do 8 | let auth = Auth.OAuth "oauthtoken" 9 | resp <- deleteRepoWebhook' auth "repoOwner" "repoName" 123 10 | case resp of 11 | (Left err) -> putStrLn $ "Error: " ++ (show err) 12 | (Right stat) -> putStrLn $ "Resp: " ++ (show stat) 13 | -------------------------------------------------------------------------------- /samples/Repos/Webhooks/EditWebhook.hs: -------------------------------------------------------------------------------- 1 | module EditWebhook where 2 | 3 | import Github.Repos.Webhooks 4 | import qualified Github.Auth as Auth 5 | import Github.Data.Definitions 6 | 7 | main :: IO () 8 | main = do 9 | let auth = Auth.OAuth "oauthtoken" 10 | let editWebhookDef = EditRepoWebhook { 11 | editRepoWebhookRemoveEvents = Just [WebhookWildcardEvent], 12 | editRepoWebhookAddEvents = Just [WebhookCommitCommentEvent, WebhookGollumEvent], 13 | editRepoWebhookConfig = Nothing, 14 | editRepoWebhookEvents = Nothing, 15 | editRepoWebhookActive = Just True 16 | } 17 | newWebhook <- editRepoWebhook' auth "repoOwner" "repoName" 123 editWebhookDef 18 | case newWebhook of 19 | (Left err) -> putStrLn $ "Error: " ++ (show err) 20 | (Right webhook) -> putStrLn $ formatRepoWebhook webhook 21 | 22 | formatRepoWebhook :: RepoWebhook -> String 23 | formatRepoWebhook (RepoWebhook _ _ _ name _ _ _ _ _ _) = show name 24 | -------------------------------------------------------------------------------- /samples/Repos/Webhooks/ListWebhook.hs: -------------------------------------------------------------------------------- 1 | module ListWebhook where 2 | 3 | import qualified Github.Repos.Webhooks as W 4 | import qualified Github.Auth as Auth 5 | import qualified Github.Data.Definitions as Def 6 | 7 | main :: IO () 8 | main = do 9 | let auth = Auth.OAuth "oauthtoken" 10 | possibleWebhook <- W.webhookFor' auth "repoOwner" "repoName" 123 11 | case possibleWebhook of 12 | (Left err) -> putStrLn $ "Error: " ++ (show err) 13 | (Right webhook) -> putStrLn $ formatRepoWebhook webhook 14 | 15 | formatRepoWebhook :: Def.RepoWebhook -> String 16 | formatRepoWebhook (Def.RepoWebhook _ _ _ name _ _ _ _ _ _) = show name 17 | -------------------------------------------------------------------------------- /samples/Repos/Webhooks/ListWebhooks.hs: -------------------------------------------------------------------------------- 1 | module ListWebhooks where 2 | 3 | import qualified Github.Repos.Webhooks as W 4 | import qualified Github.Auth as Auth 5 | import qualified Github.Data.Definitions as Def 6 | import Data.List 7 | 8 | main :: IO () 9 | main = do 10 | let auth = Auth.OAuth "oauthtoken" 11 | possibleWebhooks <- W.webhooksFor' auth "repoOwner" "repoName" 12 | case possibleWebhooks of 13 | (Left err) -> putStrLn $ "Error: " ++ (show err) 14 | (Right webhooks) -> putStrLn $ intercalate "\n" $ map formatRepoWebhook webhooks 15 | 16 | formatRepoWebhook :: Def.RepoWebhook -> String 17 | formatRepoWebhook (Def.RepoWebhook _ _ _ name _ _ _ _ _ _) = show name 18 | -------------------------------------------------------------------------------- /samples/Repos/Webhooks/PingWebhook.hs: -------------------------------------------------------------------------------- 1 | module PingWebhook where 2 | 3 | import Github.Repos.Webhooks 4 | import qualified Github.Auth as Auth 5 | 6 | main :: IO () 7 | main = do 8 | let auth = Auth.OAuth "oauthtoken" 9 | resp <- pingRepoWebhook' auth "repoOwner" "repoName" 123 10 | case resp of 11 | (Left err) -> putStrLn $ "Error: " ++ (show err) 12 | (Right stat) -> putStrLn $ "Resp: " ++ (show stat) 13 | -------------------------------------------------------------------------------- /samples/Repos/Webhooks/TestPushWebhook.hs: -------------------------------------------------------------------------------- 1 | module TestPushWebhook where 2 | 3 | import Github.Repos.Webhooks 4 | import qualified Github.Auth as Auth 5 | 6 | main :: IO () 7 | main = do 8 | let auth = Auth.OAuth "oauthtoken" 9 | resp <- testPushRepoWebhook' auth "repoOwner" "repoName" 123 10 | case resp of 11 | (Left err) -> putStrLn $ "Error: " ++ (show err) 12 | (Right stat) -> putStrLn $ "Resp: " ++ (show stat) 13 | -------------------------------------------------------------------------------- /samples/Search/SearchCode.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Main where 4 | 5 | import qualified GitHub 6 | import Control.Monad (forM_) 7 | import Data.List (intercalate) 8 | import qualified Data.Text as T 9 | 10 | main :: IO () 11 | main = do 12 | let query = "Code repo:haskell-github/github" 13 | result <- GitHub.github' GitHub.searchCodeR query 1000 14 | case result of 15 | Left e -> putStrLn $ "Error: " ++ show e 16 | Right r -> do 17 | forM_ (GitHub.searchResultResults r) $ \r -> do 18 | putStrLn $ formatCode r 19 | putStrLn "" 20 | putStrLn $ "Count: " ++ show (GitHub.searchResultTotalCount r) 21 | ++ " matches for the query: \"" ++ T.unpack query ++ "\"" 22 | 23 | formatCode :: GitHub.Code -> String 24 | formatCode r = 25 | let fields = [ ("Name", show . GitHub.codeName) 26 | , ("Path", show . GitHub.codePath) 27 | , ("Sha", show . GitHub.codeSha) 28 | , ("URL", show . GitHub.codeHtmlUrl) 29 | ] 30 | in intercalate "\n" $ map fmt fields 31 | where fmt (s,f) = fill 12 (s ++ ":") ++ " " ++ f r 32 | fill n s = s ++ replicate n' ' ' 33 | where n' = max 0 (n - length s) 34 | -------------------------------------------------------------------------------- /samples/Search/SearchIssues.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Main where 3 | 4 | import qualified GitHub 5 | import qualified Data.Text as T 6 | import Control.Monad (forM_) 7 | import Data.Monoid ((<>)) 8 | 9 | main :: IO () 10 | main = do 11 | let query = "build repo:haskell-github/github" 12 | result <- GitHub.github' GitHub.searchIssuesR query 1000 13 | case result of 14 | Left e -> putStrLn $ "Error: " ++ show e 15 | Right r -> do 16 | forM_ (GitHub.searchResultResults r) $ \r -> do 17 | putStrLn $ formatIssue r 18 | putStrLn "" 19 | putStrLn $ "Count: " ++ show (GitHub.searchResultTotalCount r) 20 | ++ " matches for the query: \"" ++ T.unpack query ++ "\"" 21 | 22 | formatIssue :: GitHub.Issue -> String 23 | formatIssue issue = 24 | (show $ GitHub.issueUser issue) <> 25 | " opened this issue " <> 26 | (show $ GitHub.issueCreatedAt issue) <> "\n" <> 27 | (show $ GitHub.issueState issue) <> " with " <> 28 | (show $ GitHub.issueComments issue) <> " comments" <> "\n\n" <> 29 | (T.unpack $ GitHub.issueTitle issue) 30 | -------------------------------------------------------------------------------- /samples/Search/SearchRepos.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Main where 3 | 4 | import qualified GitHub 5 | import Control.Monad (forM_) 6 | import Data.Maybe (fromMaybe) 7 | import Data.Monoid ((<>)) 8 | import Data.List (intercalate) 9 | import System.Environment (getArgs) 10 | import Text.Printf (printf) 11 | import Data.Time.Clock (getCurrentTime, UTCTime(..)) 12 | import Data.Time.LocalTime (utc,utcToLocalTime,localDay) 13 | import Data.Time.Calendar (toGregorian) 14 | import Data.Text (Text) 15 | import qualified Data.Text as T 16 | 17 | main :: IO () 18 | main = do 19 | args <- getArgs 20 | date <- case args of 21 | (x:_) -> return $ T.pack x 22 | _ -> today 23 | let query = ("language:haskell created:>" <> date) :: Text 24 | result <- GitHub.github' GitHub.searchReposR query 1000 25 | case result of 26 | Left e -> putStrLn $ "Error: " ++ show e 27 | Right r -> do 28 | forM_ (GitHub.searchResultResults r) $ \r -> do 29 | putStrLn $ formatRepo r 30 | putStrLn "" 31 | putStrLn $ "Count: " ++ show (GitHub.searchResultTotalCount r) 32 | ++ " Haskell repos created since " ++ T.unpack date 33 | 34 | -- | return today (in UTC) formatted as YYYY-MM-DD 35 | today :: IO Text 36 | today = do 37 | now <- getCurrentTime 38 | let day = localDay $ utcToLocalTime utc now 39 | (y,m,d) = toGregorian day 40 | in return $ T.pack $ printf "%d-%02d-%02d" y m d 41 | 42 | formatRepo :: GitHub.Repo -> String 43 | formatRepo r = 44 | let fields = [ ("Name", show . GitHub.repoName) 45 | ,("URL", show . GitHub.repoHtmlUrl) 46 | ,("Description", show . orEmpty . GitHub.repoDescription) 47 | ,("Created-At", formatMaybeDate . GitHub.repoCreatedAt) 48 | ,("Pushed-At", formatMaybeDate . GitHub.repoPushedAt) 49 | ,("Stars", show . GitHub.repoStargazersCount) 50 | ] 51 | in intercalate "\n" $ map fmt fields 52 | where fmt (s,f) = fill 12 (s ++ ":") ++ " " ++ f r 53 | orEmpty = fromMaybe "" 54 | fill n s = s ++ replicate n' ' ' 55 | where n' = max 0 (n - length s) 56 | 57 | 58 | formatMaybeDate :: Maybe UTCTime -> String 59 | formatMaybeDate = maybe "???" show 60 | -------------------------------------------------------------------------------- /samples/Teams/DeleteTeam.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module Main (main) where 4 | 5 | import Common 6 | 7 | import qualified GitHub 8 | import qualified GitHub.Endpoints.Organizations.Teams as GitHub 9 | 10 | main :: IO () 11 | main = do 12 | args <- getArgs 13 | result <- case args of 14 | [token, team_id] -> GitHub.deleteTeam' (GitHub.OAuth $ fromString token) (GitHub.mkTeamId $ read team_id) 15 | _ -> error "usage: DeleteTeam " 16 | case result of 17 | Left err -> putStrLn $ "Error: " <> tshow err 18 | Right team -> putStrLn $ tshow team 19 | -------------------------------------------------------------------------------- /samples/Teams/EditTeam.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module Main (main) where 4 | 5 | import Common 6 | 7 | import qualified GitHub 8 | 9 | main :: IO () 10 | main = do 11 | args <- getArgs 12 | result <- case args of 13 | [token, team_id, team_name, desc] -> 14 | GitHub.github 15 | (GitHub.OAuth $ fromString token) 16 | GitHub.editTeamR 17 | (GitHub.mkTeamId $ read team_id) 18 | (GitHub.EditTeam (GitHub.mkTeamName $ fromString team_name) (Just $ fromString desc) Nothing Nothing) 19 | _ -> 20 | error "usage: EditTeam " 21 | case result of 22 | Left err -> putStrLn $ "Error: " <> tshow err 23 | Right team -> putStrLn $ tshow team 24 | -------------------------------------------------------------------------------- /samples/Teams/ListRepos.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Main (main) where 3 | 4 | import Common 5 | import Prelude () 6 | 7 | import qualified GitHub as GH 8 | 9 | main :: IO () 10 | main = do 11 | args <- getArgs 12 | possibleRepos <- case args of 13 | [team_id, token] -> GH.github (GH.OAuth $ fromString token) GH.listTeamReposR (GH.mkTeamId $ read team_id) 14 | [team_id] -> GH.github' GH.listTeamReposR (GH.mkTeamId $ read team_id) 15 | _ -> error "usage: TeamListRepos [auth token]" 16 | case possibleRepos of 17 | Left err -> putStrLn $ "Error: " <> tshow err 18 | Right repos -> putStrLn $ tshow repos 19 | -------------------------------------------------------------------------------- /samples/Teams/ListTeamsCurrent.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module Main (main) where 4 | 5 | import Common 6 | 7 | import qualified GitHub as GH 8 | 9 | main :: IO () 10 | main = do 11 | args <- getArgs 12 | result <- case args of 13 | [token] -> GH.github (GH.OAuth $ fromString token) GH.listTeamsCurrentR GH.FetchAll 14 | _ -> error "usage: ListTeamsCurrent " 15 | case result of 16 | Left err -> putStrLn $ "Error: " <> tshow err 17 | Right teams -> mapM_ (putStrLn . tshow) teams 18 | -------------------------------------------------------------------------------- /samples/Teams/Memberships/AddTeamMembershipFor.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module Main (main) where 4 | 5 | import Common 6 | 7 | import qualified GitHub 8 | 9 | main :: IO () 10 | main = do 11 | args <- getArgs 12 | result <- case args of 13 | [token, team_id, username] -> GitHub.github 14 | (GitHub.OAuth $ fromString token) 15 | GitHub.addTeamMembershipForR 16 | (GitHub.mkTeamId $ read team_id) 17 | (GitHub.mkOwnerName $ fromString username) 18 | GitHub.RoleMember 19 | _ -> fail "usage: AddTeamMembershipFor " 20 | case result of 21 | Left err -> putStrLn $ "Error: " <> tshow err 22 | Right team -> putStrLn $ tshow team 23 | -------------------------------------------------------------------------------- /samples/Teams/Memberships/DeleteTeamMembershipFor.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module Main (main) where 4 | 5 | import Common 6 | 7 | import qualified GitHub 8 | import qualified GitHub.Endpoints.Organizations.Teams as GitHub 9 | 10 | main :: IO () 11 | main = do 12 | args <- getArgs 13 | result <- case args of 14 | [token, team_id, username] -> 15 | GitHub.deleteTeamMembershipFor' 16 | (GitHub.OAuth $ fromString token) 17 | (GitHub.mkTeamId $ read team_id) 18 | (GitHub.mkOwnerName $ fromString username) 19 | _ -> 20 | error "usage: DeleteTeamMembershipFor " 21 | case result of 22 | Left err -> putStrLn $ "Error: " <> tshow err 23 | Right team -> putStrLn $ tshow team 24 | -------------------------------------------------------------------------------- /samples/Teams/Memberships/TeamMembershipInfoFor.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module Main (main) where 4 | 5 | import Common 6 | 7 | import qualified GitHub 8 | import qualified GitHub.Endpoints.Organizations.Teams as GitHub 9 | 10 | main :: IO () 11 | main = do 12 | args <- getArgs 13 | result <- case args of 14 | [team_id, username, token] -> 15 | GitHub.teamMembershipInfoFor' (Just $ GitHub.OAuth $ fromString token) (GitHub.mkTeamId $ read team_id) (GitHub.mkOwnerName $ fromString username) 16 | [team_id, username] -> 17 | GitHub.teamMembershipInfoFor (GitHub.mkTeamId $ read team_id) (GitHub.mkOwnerName $ fromString username) 18 | _ -> 19 | error "usage: TeamMembershipInfoFor [token]" 20 | case result of 21 | Left err -> putStrLn $ "Error: " <> tshow err 22 | Right team -> putStrLn $ tshow team 23 | -------------------------------------------------------------------------------- /samples/Teams/Repos/AddOrUpdateTeamRepo.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module Main (main) where 4 | 5 | import Common 6 | 7 | import qualified GitHub 8 | import qualified GitHub.Endpoints.Organizations.Teams as GitHub 9 | 10 | main :: IO () 11 | main = do 12 | args <- getArgs 13 | result <- case args of 14 | [token, team_id, org, repo] -> 15 | GitHub.addOrUpdateTeamRepo' 16 | (GitHub.OAuth $ fromString token) 17 | (GitHub.mkTeamId $ read team_id) 18 | (GitHub.mkOrganizationName $ fromString org) 19 | (GitHub.mkRepoName $ fromString repo) 20 | GitHub.PermissionPull 21 | _ -> 22 | error "usage: AddOrUpdateTeamRepo " 23 | case result of 24 | Left err -> putStrLn $ "Error: " <> tshow err 25 | Right team -> putStrLn $ tshow team 26 | -------------------------------------------------------------------------------- /samples/Teams/TeamInfoFor.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module Main (main) where 4 | 5 | import Common 6 | 7 | import qualified GitHub as GH 8 | 9 | main :: IO () 10 | main = do 11 | args <- getArgs 12 | result <- case args of 13 | [team_id, token] -> GH.github (GH.OAuth $ fromString token) GH.teamInfoForR (GH.mkTeamId $ read team_id) 14 | [team_id] -> GH.github' GH.teamInfoForR (GH.mkTeamId $ read team_id) 15 | _ -> error "usage: TeamInfoFor [auth token]" 16 | case result of 17 | Left err -> putStrLn $ "Error: " <> tshow err 18 | Right team -> putStrLn $ tshow team 19 | -------------------------------------------------------------------------------- /samples/Users/Emails/ListEmails.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Main (main) where 3 | 4 | import Common 5 | import Prelude () 6 | import qualified GitHub.Endpoints.Users.Emails as GitHub 7 | 8 | 9 | main :: IO () 10 | main = do 11 | emails <- GitHub.currentUserEmails' (GitHub.OAuth "token") 12 | putStrLn $ either (("Error: " <>) . tshow) 13 | (foldMap ((<> "\n") . formatEmail)) 14 | emails 15 | 16 | formatEmail :: GitHub.Email -> Text 17 | formatEmail e = GitHub.emailAddress e <> if GitHub.emailPrimary e then " [primary]" else "" 18 | -------------------------------------------------------------------------------- /samples/Users/Followers/Example.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | import Prelude () 5 | import Prelude.Compat 6 | 7 | import Data.Text (Text, pack) 8 | import Data.Text.IO as T (putStrLn) 9 | 10 | import qualified GitHub.Endpoints.Users.Followers as GitHub 11 | 12 | main :: IO () 13 | main = do 14 | possibleUsers <- GitHub.usersFollowing "mike-burns" 15 | T.putStrLn $ either (("Error: " <>) . pack . show) 16 | (foldMap ((<> "\n") . formatUser)) 17 | possibleUsers 18 | 19 | formatUser :: GitHub.SimpleUser -> Text 20 | formatUser = GitHub.untagName . GitHub.simpleUserLogin 21 | -------------------------------------------------------------------------------- /samples/Users/Followers/ListFollowers.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Main (main) where 3 | 4 | import Common 5 | import Prelude () 6 | 7 | import qualified GitHub 8 | 9 | main :: IO () 10 | main = do 11 | auth <- getAuth 12 | possibleUsers <- GitHub.executeRequestMaybe auth $ GitHub.usersFollowingR "mike-burns" GitHub.FetchAll 13 | putStrLn $ either (("Error: " <>) . tshow) 14 | (foldMap ((<> "\n") . formatUser)) 15 | possibleUsers 16 | 17 | formatUser :: GitHub.SimpleUser -> Text 18 | formatUser = GitHub.untagName . GitHub.simpleUserLogin 19 | -------------------------------------------------------------------------------- /samples/Users/Followers/ListFollowing.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Main (main) where 3 | 4 | import Common 5 | import Prelude () 6 | 7 | import qualified GitHub 8 | 9 | main :: IO () 10 | main = do 11 | auth <- getAuth 12 | possibleUsers <- GitHub.executeRequestMaybe auth $ GitHub.usersFollowedByR "mike-burns" GitHub.FetchAll 13 | putStrLn $ either (("Error: " <>) . tshow) 14 | (foldMap ((<> "\n") . formatUser)) 15 | possibleUsers 16 | 17 | formatUser :: GitHub.SimpleUser -> Text 18 | formatUser = GitHub.untagName . GitHub.simpleUserLogin 19 | 20 | -------------------------------------------------------------------------------- /samples/Users/PublicSSHKeys/CreatePublicSSHKey.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Main (main) where 3 | 4 | import qualified GitHub.Data.PublicSSHKeys as PK 5 | import qualified GitHub.Endpoints.Users.PublicSSHKeys as PK 6 | import qualified GitHub.Auth as Auth 7 | 8 | main :: IO () 9 | main = do 10 | let auth = Auth.OAuth "auth_token" 11 | ePublicSSHKey <- PK.createUserPublicSSHKey' auth newPublicSSHKey 12 | case ePublicSSHKey of 13 | Left err -> putStrLn $ "Error: " ++ show err 14 | Right publicSSHKey -> print publicSSHKey 15 | 16 | newPublicSSHKey :: PK.NewPublicSSHKey 17 | newPublicSSHKey = 18 | PK.NewPublicSSHKey 19 | { PK.newPublicSSHKeyKey = "test-key" 20 | , PK.newPublicSSHKeyTitle = "some-name-for-your-key" 21 | } 22 | -------------------------------------------------------------------------------- /samples/Users/PublicSSHKeys/DeletePublicSSHKey.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Main (main) where 3 | 4 | import GitHub.Data.Id (Id (..)) 5 | import qualified GitHub.Endpoints.Users.PublicSSHKeys as PK 6 | import qualified GitHub.Auth as Auth 7 | 8 | main :: IO () 9 | main = do 10 | let auth = Auth.OAuth "auth_token" 11 | ePublicSSHKey <- PK.deleteUserPublicSSHKey' auth (Id 18530161) 12 | case ePublicSSHKey of 13 | (Left err) -> putStrLn $ "Error: " ++ (show err) 14 | (Right _) -> putStrLn $ "Deleted public SSH key!" 15 | -------------------------------------------------------------------------------- /samples/Users/PublicSSHKeys/ListPublicSSHKeys.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Main (main) where 3 | 4 | import qualified GitHub.Endpoints.Users.PublicSSHKeys as PK 5 | import qualified GitHub.Auth as Auth 6 | import Data.List (intercalate) 7 | import Data.Vector (toList) 8 | 9 | main :: IO () 10 | main = do 11 | -- Fetch the SSH public keys of another user 12 | ePublicSSHKeys <- PK.publicSSHKeysFor' "github_name" 13 | case ePublicSSHKeys of 14 | (Left err) -> putStrLn $ "Error: " ++ (show err) 15 | (Right publicSSHKeys) -> putStrLn $ intercalate "\n" $ map show (toList publicSSHKeys) 16 | 17 | -- Fetch my SSH public keys 18 | let auth = Auth.OAuth "auth_token" 19 | eMyPublicSSHKeys <- PK.publicSSHKeys' auth 20 | case eMyPublicSSHKeys of 21 | (Left err) -> putStrLn $ "Error: " ++ (show err) 22 | (Right publicSSHKeys) -> putStrLn $ intercalate "\n" $ map show (toList publicSSHKeys) 23 | 24 | -------------------------------------------------------------------------------- /samples/Users/PublicSSHKeys/ShowPublicSSHKey.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Main (main) where 3 | 4 | import GitHub.Data.Id (Id (..)) 5 | import qualified GitHub.Endpoints.Users.PublicSSHKeys as PK 6 | import qualified GitHub.Auth as Auth 7 | 8 | main :: IO () 9 | main = do 10 | let auth = Auth.OAuth "auth_token" 11 | ePublicSSHKey <- PK.publicSSHKey' auth (Id 18528451) 12 | case ePublicSSHKey of 13 | (Left err) -> putStrLn $ "Error: " ++ (show err) 14 | (Right publicSSHKey) -> putStrLn $ show publicSSHKey 15 | -------------------------------------------------------------------------------- /samples/Users/ShowUser.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Main (main) where 3 | 4 | import Common 5 | import Prelude () 6 | 7 | import Data.Maybe (fromMaybe) 8 | 9 | import qualified GitHub as GH 10 | 11 | main :: IO () 12 | main = do 13 | mauth <- getAuth 14 | possibleUser <- maybe GH.github' GH.github mauth GH.userInfoForR "mike-burns" 15 | putStrLn $ either (("Error: " <>) . tshow) formatUser possibleUser 16 | 17 | formatUser :: GH.User -> Text 18 | formatUser user = 19 | formatName userName login <> "\t" <> fromMaybe "" company <> "\t" <> 20 | fromMaybe "" location <> "\n" <> 21 | fromMaybe "" blog <> "\t" <> "<" <> fromMaybe "" email <> ">" <> "\n" <> 22 | GH.getUrl htmlUrl <> "\t" <> tshow createdAt <> "\n" <> 23 | "hireable: " <> formatHireable (fromMaybe False isHireable) <> "\n\n" <> 24 | fromMaybe "" bio 25 | where 26 | userName = GH.userName user 27 | login = GH.userLogin user 28 | company = GH.userCompany user 29 | location = GH.userLocation user 30 | blog = GH.userBlog user 31 | email = GH.userEmail user 32 | htmlUrl = GH.userHtmlUrl user 33 | createdAt = GH.userCreatedAt user 34 | isHireable = GH.userHireable user 35 | bio = GH.userBio user 36 | 37 | formatName :: Maybe Text -> GH.Name GH.User -> Text 38 | formatName Nothing login = GH.untagName login 39 | formatName (Just name) login = name <> "(" <> GH.untagName login <> ")" 40 | 41 | formatHireable :: Bool -> Text 42 | formatHireable True = "yes" 43 | formatHireable False = "no" 44 | -------------------------------------------------------------------------------- /samples/Users/ShowUser2.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Main (main) where 3 | 4 | import qualified GitHub as GH 5 | 6 | main :: IO () 7 | main = do 8 | possibleUser <- GH.executeRequest' $ GH.userInfoForR "phadej" 9 | print possibleUser 10 | -------------------------------------------------------------------------------- /samples/src/Common.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | module Common ( 3 | -- * Common stuff 4 | getAuth, 5 | tshow, 6 | -- * Re-exports 7 | putStrLn, 8 | getArgs, 9 | Proxy(..), 10 | module GitHub.Internal.Prelude, 11 | ) where 12 | 13 | import GitHub.Internal.Prelude hiding (putStrLn) 14 | 15 | import Data.Proxy (Proxy (..)) 16 | import Data.Text.IO (putStrLn) 17 | import System.Environment (lookupEnv) 18 | import System.Environment (getArgs) 19 | 20 | import qualified Data.Text as T 21 | import qualified GitHub 22 | 23 | getAuth :: IO (Maybe (GitHub.Auth)) 24 | getAuth = do 25 | token <- lookupEnv "GITHUB_TOKEN" 26 | pure (GitHub.OAuth . fromString <$> token) 27 | 28 | tshow :: Show a => a -> Text 29 | tshow = T.pack . show 30 | -------------------------------------------------------------------------------- /spec/GitHub/Actions/CacheSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | module GitHub.Actions.CacheSpec where 4 | 5 | import qualified GitHub as GH 6 | 7 | import Prelude () 8 | import Prelude.Compat 9 | 10 | import Data.Aeson (eitherDecodeStrict) 11 | import Data.ByteString (ByteString) 12 | import Data.FileEmbed (embedFile) 13 | import qualified Data.Vector as V 14 | import Test.Hspec (Spec, describe, it, shouldBe) 15 | 16 | fromRightS :: Show a => Either a b -> b 17 | fromRightS (Right b) = b 18 | fromRightS (Left a) = error $ "Expected a Right and got a Left" ++ show a 19 | 20 | spec :: Spec 21 | spec = do 22 | describe "decoding cache payloads" $ do 23 | it "decodes cache list payload" $ do 24 | V.length (GH.withTotalCountItems cacheList) `shouldBe` 1 25 | it "decodes cache usage for repo" $ do 26 | GH.repositoryCacheUsageFullName repoCacheUsage `shouldBe` "python/cpython" 27 | GH.repositoryCacheUsageActiveCachesSizeInBytes repoCacheUsage `shouldBe` 55000268087 28 | GH.repositoryCacheUsageActiveCachesCount repoCacheUsage `shouldBe` 171 29 | it "decodes cache usage for org" $ do 30 | GH.organizationCacheUsageTotalActiveCachesSizeInBytes orgCacheUsage `shouldBe` 26586 31 | GH.organizationCacheUsageTotalActiveCachesCount orgCacheUsage `shouldBe` 1 32 | 33 | where 34 | cacheList :: GH.WithTotalCount GH.Cache 35 | cacheList = 36 | fromRightS (eitherDecodeStrict cacheListPayload) 37 | 38 | repoCacheUsage :: GH.RepositoryCacheUsage 39 | repoCacheUsage = 40 | fromRightS (eitherDecodeStrict repoCacheUsagePayload) 41 | 42 | orgCacheUsage :: GH.OrganizationCacheUsage 43 | orgCacheUsage = 44 | fromRightS (eitherDecodeStrict orgCacheUsagePayload) 45 | 46 | cacheListPayload :: ByteString 47 | cacheListPayload = $(embedFile "fixtures/actions/cache-list.json") 48 | 49 | repoCacheUsagePayload :: ByteString 50 | repoCacheUsagePayload = $(embedFile "fixtures/actions/repo-cache-usage.json") 51 | 52 | orgCacheUsagePayload :: ByteString 53 | orgCacheUsagePayload = $(embedFile "fixtures/actions/org-cache-usage.json") 54 | -------------------------------------------------------------------------------- /spec/GitHub/Actions/SecretsSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | module GitHub.Actions.SecretsSpec where 4 | 5 | import qualified GitHub as GH 6 | 7 | import Prelude () 8 | import Prelude.Compat 9 | 10 | import Data.Aeson (eitherDecodeStrict) 11 | import Data.ByteString (ByteString) 12 | import Data.FileEmbed (embedFile) 13 | import qualified Data.Vector as V 14 | import Test.Hspec (Spec, describe, it, shouldBe) 15 | 16 | fromRightS :: Show a => Either a b -> b 17 | fromRightS (Right b) = b 18 | fromRightS (Left a) = error $ "Expected a Right and got a Left" ++ show a 19 | 20 | spec :: Spec 21 | spec = do 22 | describe "decoding secrets payloads" $ do 23 | it "decodes selected repo list payload" $ do 24 | V.length (GH.withTotalCountItems repoList) `shouldBe` 1 25 | it "decodes secret list payload" $ do 26 | V.length (GH.withTotalCountItems orgSecretList) `shouldBe` 2 27 | it "decodes public key payload" $ do 28 | GH.publicKeyId orgPublicKey `shouldBe` "568250167242549743" 29 | 30 | where 31 | repoList :: GH.WithTotalCount GH.SelectedRepo 32 | repoList = 33 | fromRightS (eitherDecodeStrict repoListPayload) 34 | 35 | orgSecretList:: GH.WithTotalCount GH.OrganizationSecret 36 | orgSecretList= 37 | fromRightS (eitherDecodeStrict orgSecretListPayload) 38 | 39 | orgPublicKey:: GH.PublicKey 40 | orgPublicKey= 41 | fromRightS (eitherDecodeStrict orgPublicKeyPayload) 42 | 43 | repoListPayload :: ByteString 44 | repoListPayload = $(embedFile "fixtures/actions/selected-repositories-for-secret.json") 45 | 46 | orgSecretListPayload :: ByteString 47 | orgSecretListPayload = $(embedFile "fixtures/actions/org-secrets-list.json") 48 | 49 | orgPublicKeyPayload :: ByteString 50 | orgPublicKeyPayload = $(embedFile "fixtures/actions/org-public-key.json") 51 | -------------------------------------------------------------------------------- /spec/GitHub/Actions/WorkflowJobSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | module GitHub.Actions.WorkflowJobSpec where 4 | 5 | import qualified GitHub as GH 6 | import GitHub.Data.Id 7 | 8 | import Prelude () 9 | import Prelude.Compat 10 | 11 | import Data.Aeson (eitherDecodeStrict) 12 | import Data.ByteString (ByteString) 13 | import Data.FileEmbed (embedFile) 14 | import Test.Hspec (Spec, describe, it, shouldBe) 15 | 16 | fromRightS :: Show a => Either a b -> b 17 | fromRightS (Right b) = b 18 | fromRightS (Left a) = error $ "Expected a Right and got a Left" ++ show a 19 | 20 | spec :: Spec 21 | spec = do 22 | describe "decoding workflow jobs payloads" $ do 23 | it "decodes workflow job" $ do 24 | GH.jobId workflowJob `shouldBe` Id 9183275828 25 | 26 | where 27 | workflowJob:: GH.Job 28 | workflowJob= 29 | fromRightS (eitherDecodeStrict workflowJobPayload) 30 | 31 | workflowJobPayload :: ByteString 32 | workflowJobPayload = $(embedFile "fixtures/actions/workflow-job.json") 33 | -------------------------------------------------------------------------------- /spec/GitHub/Actions/WorkflowRunsSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | module GitHub.Actions.WorkflowRunsSpec where 4 | 5 | import qualified GitHub as GH 6 | 7 | import Prelude () 8 | import Prelude.Compat 9 | 10 | import Data.Aeson (eitherDecodeStrict) 11 | import Data.ByteString (ByteString) 12 | import Data.FileEmbed (embedFile) 13 | import qualified Data.Vector as V 14 | import Test.Hspec (Spec, describe, it, shouldBe) 15 | 16 | fromRightS :: Show a => Either a b -> b 17 | fromRightS (Right b) = b 18 | fromRightS (Left a) = error $ "Expected a Right and got a Left" ++ show a 19 | 20 | spec :: Spec 21 | spec = do 22 | describe "decoding workflow runs payloads" $ do 23 | it "decodes workflow runs list" $ do 24 | V.length (GH.withTotalCountItems workflowRunsList) `shouldBe` 3 25 | 26 | where 27 | workflowRunsList:: GH.WithTotalCount GH.WorkflowRun 28 | workflowRunsList = 29 | fromRightS (eitherDecodeStrict workflowRunsPayload) 30 | 31 | workflowRunsPayload :: ByteString 32 | workflowRunsPayload = $(embedFile "fixtures/actions/workflow-runs-list.json") 33 | -------------------------------------------------------------------------------- /spec/GitHub/Actions/WorkflowSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | module GitHub.Actions.WorkflowSpec where 4 | 5 | import qualified GitHub as GH 6 | 7 | import Prelude () 8 | import Prelude.Compat 9 | 10 | import Data.Aeson (eitherDecodeStrict) 11 | import Data.ByteString (ByteString) 12 | import Data.FileEmbed (embedFile) 13 | import qualified Data.Vector as V 14 | import Test.Hspec (Spec, describe, it, shouldBe) 15 | 16 | fromRightS :: Show a => Either a b -> b 17 | fromRightS (Right b) = b 18 | fromRightS (Left a) = error $ "Expected a Right and got a Left" ++ show a 19 | 20 | spec :: Spec 21 | spec = do 22 | describe "decoding workflow payloads" $ do 23 | it "decodes workflow list" $ do 24 | V.length (GH.withTotalCountItems workflowList) `shouldBe` 1 25 | 26 | where 27 | workflowList:: GH.WithTotalCount GH.Workflow 28 | workflowList = 29 | fromRightS (eitherDecodeStrict workflowPayload) 30 | 31 | workflowPayload :: ByteString 32 | workflowPayload = $(embedFile "fixtures/actions/workflow-list.json") 33 | -------------------------------------------------------------------------------- /spec/GitHub/ActivitySpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module GitHub.ActivitySpec where 3 | 4 | import qualified GitHub 5 | 6 | import GitHub.Auth (Auth (..)) 7 | import GitHub.Endpoints.Activity.Starring (myStarredAcceptStarR) 8 | import GitHub.Endpoints.Activity.Watching (watchersForR) 9 | import GitHub.Request (executeRequest) 10 | 11 | import Data.Either.Compat (isRight) 12 | import Data.String (fromString) 13 | import System.Environment (lookupEnv) 14 | import Test.Hspec (Spec, describe, it, pendingWith, shouldSatisfy) 15 | 16 | import qualified Data.Vector as V 17 | 18 | fromRightS :: Show a => Either a b -> b 19 | fromRightS (Right b) = b 20 | fromRightS (Left a) = error $ "Expected a Right and got a Left" ++ show a 21 | 22 | withAuth :: (Auth -> IO ()) -> IO () 23 | withAuth action = do 24 | mtoken <- lookupEnv "GITHUB_TOKEN" 25 | case mtoken of 26 | Nothing -> pendingWith "no GITHUB_TOKEN" 27 | Just token -> action (OAuth $ fromString token) 28 | 29 | spec :: Spec 30 | spec = do 31 | describe "watchersForR" $ do 32 | it "works" $ withAuth $ \auth -> do 33 | cs <- executeRequest auth $ watchersForR "haskell-github" "github" GitHub.FetchAll 34 | cs `shouldSatisfy` isRight 35 | V.length (fromRightS cs) `shouldSatisfy` (> 10) 36 | describe "myStarredR" $ do 37 | it "works" $ withAuth $ \auth -> do 38 | cs <- executeRequest auth $ myStarredAcceptStarR (GitHub.FetchAtLeast 31) 39 | cs `shouldSatisfy` isRight 40 | fromRightS cs `shouldSatisfy` (\xs -> V.length xs > 30) 41 | -------------------------------------------------------------------------------- /spec/GitHub/EventsSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module GitHub.EventsSpec where 3 | 4 | import Data.Either (isRight) 5 | import Data.String (fromString) 6 | import Prelude () 7 | import Prelude.Compat 8 | import System.Environment (lookupEnv) 9 | import Test.Hspec (Spec, describe, it, shouldSatisfy, 10 | pendingWith) 11 | 12 | import qualified GitHub 13 | import GitHub.Data (Auth(..)) 14 | 15 | fromRightS :: Show a => Either a b -> b 16 | fromRightS (Left xs) = error $ "Should be Right" ++ show xs 17 | fromRightS (Right xs) = xs 18 | 19 | withAuth :: (Auth -> IO ()) -> IO () 20 | withAuth action = do 21 | mtoken <- lookupEnv "GITHUB_TOKEN" 22 | case mtoken of 23 | Nothing -> pendingWith "no GITHUB_TOKEN" 24 | Just token -> action (OAuth $ fromString token) 25 | 26 | spec :: Spec 27 | spec = do 28 | describe "repositoryEventsR" $ do 29 | it "returns non empty list of events" $ shouldSucceed $ 30 | GitHub.repositoryEventsR "haskell-github" "github" 1 31 | describe "userEventsR" $ do 32 | it "returns non empty list of events" $ shouldSucceed $ GitHub.userEventsR "phadej" 1 33 | where shouldSucceed f = withAuth $ \auth -> do 34 | cs <- GitHub.executeRequest auth $ f 35 | cs `shouldSatisfy` isRight 36 | length (fromRightS cs) `shouldSatisfy` (> 1) 37 | -------------------------------------------------------------------------------- /spec/GitHub/OrganizationsSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | module GitHub.OrganizationsSpec where 4 | 5 | import GitHub (FetchCount (..), github) 6 | import GitHub.Auth (Auth (..)) 7 | import GitHub.Data 8 | (SimpleOrganization (..), SimpleOwner (..), SimpleTeam (..)) 9 | import GitHub.Endpoints.Organizations (publicOrganizationsForR) 10 | import GitHub.Endpoints.Organizations.Members (membersOfR) 11 | 12 | import Data.Aeson (eitherDecodeStrict) 13 | import Data.Either.Compat (isRight) 14 | import Data.FileEmbed (embedFile) 15 | import Data.String (fromString) 16 | import System.Environment (lookupEnv) 17 | import Test.Hspec 18 | (Spec, describe, it, pendingWith, shouldBe, shouldSatisfy) 19 | 20 | fromRightS :: Show a => Either a b -> b 21 | fromRightS (Right b) = b 22 | fromRightS (Left a) = error $ "Expected a Right and got a Left" ++ show a 23 | 24 | withAuth :: (Auth -> IO ()) -> IO () 25 | withAuth action = do 26 | mtoken <- lookupEnv "GITHUB_TOKEN" 27 | case mtoken of 28 | Nothing -> pendingWith "no GITHUB_TOKEN" 29 | Just token -> action (OAuth $ fromString token) 30 | 31 | spec :: Spec 32 | spec = do 33 | describe "publicOrganizationsFor'" $ do 34 | it "decodes simple organization json" $ do 35 | let orgs = eitherDecodeStrict $(embedFile "fixtures/user-organizations.json") 36 | simpleOrganizationLogin (head $ fromRightS orgs) `shouldBe` "github" 37 | 38 | it "returns information about the user's organizations" $ withAuth $ \auth -> do 39 | orgs <- github auth publicOrganizationsForR "mike-burns" FetchAll 40 | orgs `shouldSatisfy` isRight 41 | 42 | describe "teamsOf" $ do 43 | it "parse" $ do 44 | let ts = eitherDecodeStrict $(embedFile "fixtures/list-teams.json") 45 | simpleTeamName (head $ fromRightS ts) `shouldBe` "Justice League" 46 | 47 | describe "membersOf" $ do 48 | it "parse" $ do 49 | let ms = eitherDecodeStrict $(embedFile "fixtures/members-list.json") 50 | simpleOwnerLogin (head $ fromRightS ms) `shouldBe` "octocat" 51 | 52 | it "works" $ withAuth $ \auth -> do 53 | ms <- github auth membersOfR "haskell" FetchAll 54 | ms `shouldSatisfy` isRight 55 | -------------------------------------------------------------------------------- /spec/GitHub/PublicSSHKeysSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module GitHub.PublicSSHKeysSpec where 3 | 4 | import GitHub 5 | (Auth (..), FetchCount (..), PublicSSHKey (..),github) 6 | import GitHub.Endpoints.Users.PublicSSHKeys 7 | (publicSSHKeyR, publicSSHKeysR, publicSSHKeysForR) 8 | 9 | import Data.Either.Compat (isRight) 10 | import Data.String (fromString) 11 | import System.Environment (lookupEnv) 12 | import Test.Hspec (Spec, describe, it, pendingWith, shouldSatisfy) 13 | 14 | import qualified Data.Vector as V 15 | 16 | fromRightS :: Show a => Either a b -> b 17 | fromRightS (Right b) = b 18 | fromRightS (Left a) = error $ "Expected a Right and got a Left" ++ show a 19 | 20 | withAuth :: (Auth -> IO ()) -> IO () 21 | withAuth action = do 22 | mtoken <- lookupEnv "GITHUB_TOKEN" 23 | case mtoken of 24 | Nothing -> pendingWith "no GITHUB_TOKEN" 25 | Just token -> action (OAuth $ fromString token) 26 | 27 | spec :: Spec 28 | spec = do 29 | describe "publicSSHKeysFor'" $ do 30 | it "works" $ withAuth $ \auth -> do 31 | keys <- github auth publicSSHKeysForR "phadej" FetchAll 32 | V.length (fromRightS keys) `shouldSatisfy` (> 1) 33 | 34 | describe "publicSSHKeys' and publicSSHKey'" $ do 35 | it "works" $ withAuth $ \auth -> do 36 | keys <- github auth publicSSHKeysR 37 | V.length (fromRightS keys) `shouldSatisfy` (> 1) 38 | 39 | key <- github auth publicSSHKeyR (publicSSHKeyId $ V.head (fromRightS keys)) 40 | key `shouldSatisfy` isRight 41 | -------------------------------------------------------------------------------- /spec/GitHub/PullRequestReviewsSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module GitHub.PullRequestReviewsSpec where 3 | 4 | import qualified GitHub 5 | import GitHub.Data (IssueNumber (IssueNumber)) 6 | 7 | import Prelude () 8 | import Prelude.Compat 9 | 10 | import Data.Either.Compat (isRight) 11 | import Data.Foldable (for_) 12 | import Data.String (fromString) 13 | import System.Environment (lookupEnv) 14 | import Test.Hspec (Spec, describe, it, pendingWith, shouldSatisfy) 15 | 16 | withAuth :: (GitHub.Auth -> IO ()) -> IO () 17 | withAuth action = do 18 | mtoken <- lookupEnv "GITHUB_TOKEN" 19 | case mtoken of 20 | Nothing -> pendingWith "no GITHUB_TOKEN" 21 | Just token -> action (GitHub.OAuth $ fromString token) 22 | 23 | spec :: Spec 24 | spec = do 25 | describe "pullRequestReviewsR" $ do 26 | it "works" $ withAuth $ \auth -> for_ prs $ \(owner, repo, prid) -> do 27 | cs <- GitHub.executeRequest auth $ 28 | GitHub.pullRequestReviewsR owner repo prid GitHub.FetchAll 29 | cs `shouldSatisfy` isRight 30 | where 31 | prs = 32 | [("haskell-github", "github", IssueNumber 268)] 33 | -------------------------------------------------------------------------------- /spec/GitHub/RateLimitSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module GitHub.RateLimitSpec where 3 | 4 | import qualified GitHub 5 | 6 | import Prelude () 7 | import Prelude.Compat 8 | 9 | import Data.Either.Compat (isRight) 10 | import Data.String (fromString) 11 | import System.Environment (lookupEnv) 12 | import Test.Hspec (Spec, describe, it, pendingWith, shouldSatisfy) 13 | 14 | fromRightS :: Show a => Either a b -> b 15 | fromRightS (Right b) = b 16 | fromRightS (Left a) = error $ "Expected a Right and got a Left" ++ show a 17 | 18 | withAuth :: (GitHub.Auth -> IO ()) -> IO () 19 | withAuth action = do 20 | mtoken <- lookupEnv "GITHUB_TOKEN" 21 | case mtoken of 22 | Nothing -> pendingWith "no GITHUB_TOKEN" 23 | Just token -> action (GitHub.OAuth $ fromString token) 24 | 25 | spec :: Spec 26 | spec = describe "rateLimitR" $ 27 | it "works" $ withAuth $ \auth -> do 28 | cs <- GitHub.executeRequest auth GitHub.rateLimitR 29 | cs `shouldSatisfy` isRight 30 | -------------------------------------------------------------------------------- /spec/GitHub/ReleasesSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module GitHub.ReleasesSpec where 3 | 4 | import qualified GitHub 5 | 6 | import GitHub.Auth (Auth (..)) 7 | import GitHub.Endpoints.Repos.Releases 8 | (Release (..), latestReleaseR, releaseByTagNameR, releaseR, releasesR) 9 | import GitHub.Request (executeRequest) 10 | 11 | import Data.Either.Compat (isRight) 12 | import Data.Proxy (Proxy (..)) 13 | import Data.String (fromString) 14 | import System.Environment (lookupEnv) 15 | import Test.Hspec 16 | (Spec, describe, it, pendingWith, shouldBe, shouldSatisfy) 17 | 18 | import qualified Data.Vector as V 19 | 20 | fromRightS :: Show a => Either a b -> b 21 | fromRightS (Right b) = b 22 | fromRightS (Left a) = error $ "Expected a Right and got a Left" ++ show a 23 | 24 | withAuth :: (Auth -> IO ()) -> IO () 25 | withAuth action = do 26 | mtoken <- lookupEnv "GITHUB_TOKEN" 27 | case mtoken of 28 | Nothing -> pendingWith "no GITHUB_TOKEN" 29 | Just token -> action (OAuth $ fromString token) 30 | 31 | spec :: Spec 32 | spec = do 33 | let v154Id = GitHub.mkId (Proxy :: Proxy Release) 5254449 34 | v154Text = "v1.5.4" 35 | describe "releasesR" $ do 36 | it "works" $ withAuth $ \auth -> do 37 | rs <- executeRequest auth $ releasesR "calleerlandsson" "pick" GitHub.FetchAll 38 | rs `shouldSatisfy` isRight 39 | V.length (fromRightS rs) `shouldSatisfy` (> 14) 40 | describe "releaseR" $ do 41 | it "works" $ withAuth $ \auth -> do 42 | rs <- executeRequest auth $ releaseR "calleerlandsson" "pick" v154Id 43 | rs `shouldSatisfy` isRight 44 | releaseTagName (fromRightS rs)`shouldBe` v154Text 45 | describe "latestReleaseR" $ do 46 | it "works" $ withAuth $ \auth -> do 47 | rs <- executeRequest auth $ latestReleaseR "calleerlandsson" "pick" 48 | rs `shouldSatisfy` isRight 49 | describe "releaseByTagNameR" $ do 50 | it "works" $ withAuth $ \auth -> do 51 | rs <- executeRequest auth $ releaseByTagNameR "calleerlandsson" "pick" v154Text 52 | rs `shouldSatisfy` isRight 53 | releaseId (fromRightS rs)`shouldBe` v154Id 54 | -------------------------------------------------------------------------------- /spec/GitHub/ReposSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module GitHub.ReposSpec where 3 | 4 | import GitHub 5 | (Auth (..), FetchCount (..), Repo (..), RepoPublicity (..), github, 6 | repositoryR) 7 | import GitHub.Endpoints.Repos (currentUserReposR, languagesForR, userReposR) 8 | 9 | import Data.Either.Compat (isRight) 10 | import Data.String (fromString) 11 | import System.Environment (lookupEnv) 12 | import Test.Hspec 13 | (Spec, describe, it, pendingWith, shouldBe, shouldSatisfy) 14 | 15 | import qualified Data.HashMap.Strict as HM 16 | 17 | fromRightS :: Show a => Either a b -> b 18 | fromRightS (Right b) = b 19 | fromRightS (Left a) = error $ "Expected a Right and got a Left" ++ show a 20 | 21 | withAuth :: (Auth -> IO ()) -> IO () 22 | withAuth action = do 23 | mtoken <- lookupEnv "GITHUB_TOKEN" 24 | case mtoken of 25 | Nothing -> pendingWith "no GITHUB_TOKEN" 26 | Just token -> action (OAuth $ fromString token) 27 | 28 | spec :: Spec 29 | spec = do 30 | describe "repositoryR" $ do 31 | it "works" $ withAuth $ \auth -> do 32 | er <- github auth repositoryR "haskell-github" "github" 33 | er `shouldSatisfy` isRight 34 | let Right r = er 35 | -- https://github.com/haskell-github/github/pull/219 36 | repoDefaultBranch r `shouldBe` Just "master" 37 | 38 | describe "currentUserRepos" $ do 39 | it "works" $ withAuth $ \auth -> do 40 | cs <- github auth currentUserReposR RepoPublicityAll FetchAll 41 | cs `shouldSatisfy` isRight 42 | 43 | describe "userRepos" $ do 44 | it "works" $ withAuth $ \auth -> do 45 | cs <- github auth userReposR "phadej" RepoPublicityAll FetchAll 46 | cs `shouldSatisfy` isRight 47 | 48 | describe "languagesFor'" $ do 49 | it "works" $ withAuth $ \auth -> do 50 | ls <- github auth languagesForR "haskell-github" "github" 51 | ls `shouldSatisfy` isRight 52 | fromRightS ls `shouldSatisfy` HM.member "Haskell" 53 | -------------------------------------------------------------------------------- /spec/GitHub/ReviewDecodeSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | module GitHub.ReviewDecodeSpec where 4 | 5 | import Data.Aeson (eitherDecodeStrict) 6 | import Data.Either.Compat (isRight) 7 | import Data.FileEmbed (embedFile) 8 | import Test.Hspec 9 | (Spec, describe, it, shouldSatisfy) 10 | 11 | import GitHub.Data (Review) 12 | 13 | spec :: Spec 14 | spec = do 15 | describe "PENDING state" $ do 16 | -- https://docs.github.com/en/rest/reference/pulls#create-a-review-for-a-pull-request 17 | -- > Pull request reviews created in the PENDING state do not include the submitted_at property in the response. 18 | it "decodes review when submitted_at is missing" $ do 19 | let reviewInfo = eitherDecodeStrict $(embedFile "fixtures/pull-request-pending-review.json") :: Either String Review 20 | reviewInfo `shouldSatisfy` isRight 21 | 22 | describe "Other states" $ do 23 | it "decodes review" $ do 24 | let reviewInfo = eitherDecodeStrict $(embedFile "fixtures/pull-request-approved-review.json") :: Either String Review 25 | reviewInfo `shouldSatisfy` isRight 26 | -------------------------------------------------------------------------------- /spec/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | -------------------------------------------------------------------------------- /src/GitHub/Auth.hs: -------------------------------------------------------------------------------- 1 | module GitHub.Auth ( 2 | Auth (..), 3 | Token, 4 | JWTToken, 5 | AuthMethod, 6 | endpoint, 7 | setAuthRequest 8 | ) where 9 | 10 | import GitHub.Internal.Prelude 11 | import Prelude () 12 | 13 | import qualified Data.ByteString as BS 14 | import qualified Data.Text.Encoding as TE 15 | import qualified Network.HTTP.Client as HTTP 16 | 17 | type Token = BS.ByteString 18 | type JWTToken = Text 19 | 20 | -- | The Github auth data type 21 | data Auth 22 | = BasicAuth BS.ByteString BS.ByteString -- ^ Username and password 23 | | OAuth Token -- ^ OAuth token 24 | | JWT JWTToken -- ^ JWT Token 25 | | EnterpriseOAuth Text Token -- ^ Custom endpoint and OAuth token 26 | deriving (Show, Data, Typeable, Eq, Ord, Generic) 27 | 28 | instance NFData Auth where rnf = genericRnf 29 | instance Binary Auth 30 | instance Hashable Auth 31 | 32 | -- | A type class for different authentication methods 33 | -- 34 | -- Note the '()' intance, which doee nothing, i.e. is unauthenticated. 35 | class AuthMethod a where 36 | -- | Custom API endpoint without trailing slash 37 | endpoint :: a -> Maybe Text 38 | -- | A function which sets authorisation on an HTTP request 39 | setAuthRequest :: a -> HTTP.Request -> HTTP.Request 40 | 41 | instance AuthMethod () where 42 | endpoint _ = Nothing 43 | setAuthRequest _ = id 44 | 45 | instance AuthMethod Auth where 46 | endpoint (BasicAuth _ _) = Nothing 47 | endpoint (OAuth _) = Nothing 48 | endpoint (JWT _) = Nothing 49 | endpoint (EnterpriseOAuth e _) = Just e 50 | 51 | setAuthRequest (BasicAuth u p) = HTTP.applyBasicAuth u p 52 | setAuthRequest (OAuth t) = setAuthHeader $ "token " <> t 53 | setAuthRequest (JWT t) = setAuthHeader $ "Bearer " <> TE.encodeUtf8 t 54 | setAuthRequest (EnterpriseOAuth _ t) = setAuthHeader $ "token " <> t 55 | 56 | setAuthHeader :: BS.ByteString -> HTTP.Request -> HTTP.Request 57 | setAuthHeader auth req = 58 | req { HTTP.requestHeaders = ("Authorization", auth) : HTTP.requestHeaders req } 59 | -------------------------------------------------------------------------------- /src/GitHub/Data/Actions/Common.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE KindSignatures #-} 4 | 5 | module GitHub.Data.Actions.Common ( 6 | WithTotalCount(..), 7 | ) where 8 | 9 | import GitHub.Internal.Prelude 10 | import Prelude () 11 | 12 | ------------------------------------------------------------------------------- 13 | -- Common 14 | ------------------------------------------------------------------------------- 15 | 16 | -- | A page of a paginated response. 17 | data WithTotalCount a = WithTotalCount 18 | { withTotalCountItems :: !(Vector a) 19 | -- ^ A snippet of the answer. 20 | , withTotalCountTotalCount :: !Int 21 | -- ^ The total size of the answer. 22 | } 23 | deriving (Show, Data, Typeable, Eq, Ord, Generic) 24 | 25 | -- | Joining two pages of a paginated response. 26 | -- The 'withTotalCountTotalCount' is assumed to be the same in both pages, 27 | -- but this is not checked. 28 | instance Semigroup (WithTotalCount a) where 29 | WithTotalCount items1 count1 <> WithTotalCount items2 _ = 30 | WithTotalCount (items1 <> items2) count1 31 | 32 | instance Foldable WithTotalCount where 33 | foldMap f (WithTotalCount items _) = foldMap f items 34 | -------------------------------------------------------------------------------- /src/GitHub/Data/Actions/Workflows.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE KindSignatures #-} 4 | 5 | module GitHub.Data.Actions.Workflows ( 6 | Workflow(..), 7 | CreateWorkflowDispatchEvent(..), 8 | ) where 9 | 10 | import Prelude () 11 | import GitHub.Internal.Prelude 12 | 13 | import GitHub.Data.Actions.Common (WithTotalCount (WithTotalCount)) 14 | import GitHub.Data.Id (Id) 15 | import GitHub.Data.URL (URL) 16 | 17 | data Workflow = Workflow 18 | { workflowWorkflowId :: !(Id Workflow) 19 | , workflowName :: !Text 20 | , workflowPath :: !Text 21 | , workflowState :: !Text 22 | , workflowCreatedAt :: !UTCTime 23 | , workflowUpdatedAt :: !UTCTime 24 | , workflowUrl :: !URL 25 | , workflowHtmlUrl :: !URL 26 | , workflowBadgeUrl :: !URL 27 | } 28 | deriving (Show, Data, Typeable, Eq, Ord, Generic) 29 | 30 | data CreateWorkflowDispatchEvent a = CreateWorkflowDispatchEvent 31 | { createWorkflowDispatchEventRef :: !Text 32 | , createWorkflowDispatchEventInputs :: !a 33 | } 34 | deriving (Show, Generic) 35 | 36 | instance (NFData a) => NFData (CreateWorkflowDispatchEvent a) where rnf = genericRnf 37 | instance (Binary a) => Binary (CreateWorkflowDispatchEvent a) 38 | 39 | ------------------------------------------------------------------------------- 40 | -- JSON instances 41 | ------------------------------------------------------------------------------- 42 | 43 | instance FromJSON Workflow where 44 | parseJSON = withObject "Workflow" $ \o -> Workflow 45 | <$> o .: "id" 46 | <*> o .: "name" 47 | <*> o .: "path" 48 | <*> o .: "state" 49 | <*> o .: "created_at" 50 | <*> o .: "updated_at" 51 | <*> o .: "url" 52 | <*> o .: "html_url" 53 | <*> o .: "badge_url" 54 | 55 | instance FromJSON (WithTotalCount Workflow) where 56 | parseJSON = withObject "WorkflowList" $ \o -> WithTotalCount 57 | <$> o .: "workflows" 58 | <*> o .: "total_count" 59 | 60 | instance ToJSON a => ToJSON (CreateWorkflowDispatchEvent a) where 61 | toJSON (CreateWorkflowDispatchEvent ref inputs) = 62 | object [ "ref" .= ref, "inputs" .= inputs ] 63 | -------------------------------------------------------------------------------- /src/GitHub/Data/DeployKeys.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- License : BSD-3-Clause 4 | -- Maintainer : Todd Mohney 5 | -- 6 | module GitHub.Data.DeployKeys where 7 | 8 | import GitHub.Data.Id (Id) 9 | import GitHub.Data.URL (URL) 10 | import GitHub.Internal.Prelude 11 | import Prelude () 12 | 13 | data RepoDeployKey = RepoDeployKey 14 | { repoDeployKeyId :: !(Id RepoDeployKey) 15 | , repoDeployKeyKey :: !Text 16 | , repoDeployKeyUrl :: !URL 17 | , repoDeployKeyTitle :: !Text 18 | , repoDeployKeyVerified :: !Bool 19 | , repoDeployKeyCreatedAt :: !UTCTime 20 | , repoDeployKeyReadOnly :: !Bool 21 | } 22 | deriving (Show, Data, Typeable, Eq, Ord, Generic) 23 | 24 | instance FromJSON RepoDeployKey where 25 | parseJSON = withObject "RepoDeployKey" $ \o -> RepoDeployKey 26 | <$> o .: "id" 27 | <*> o .: "key" 28 | <*> o .: "url" 29 | <*> o .: "title" 30 | <*> o .: "verified" 31 | <*> o .: "created_at" 32 | <*> o .: "read_only" 33 | 34 | data NewRepoDeployKey = NewRepoDeployKey 35 | { newRepoDeployKeyKey :: !Text 36 | , newRepoDeployKeyTitle :: !Text 37 | , newRepoDeployKeyReadOnly :: !Bool 38 | } 39 | deriving (Show, Data, Typeable, Eq, Ord, Generic) 40 | 41 | instance ToJSON NewRepoDeployKey where 42 | toJSON (NewRepoDeployKey key title readOnly) = object 43 | [ "key" .= key 44 | , "title" .= title 45 | , "read_only" .= readOnly 46 | ] 47 | 48 | instance FromJSON NewRepoDeployKey where 49 | parseJSON = withObject "RepoDeployKey" $ \o -> NewRepoDeployKey 50 | <$> o .: "key" 51 | <*> o .: "title" 52 | <*> o .: "read_only" 53 | -------------------------------------------------------------------------------- /src/GitHub/Data/Email.hs: -------------------------------------------------------------------------------- 1 | module GitHub.Data.Email where 2 | 3 | import GitHub.Internal.Prelude 4 | import Prelude () 5 | 6 | import qualified Data.Text as T 7 | 8 | data EmailVisibility 9 | = EmailVisibilityPrivate 10 | | EmailVisibilityPublic 11 | deriving (Show, Data, Enum, Bounded, Typeable, Eq, Ord, Generic) 12 | 13 | instance NFData EmailVisibility where rnf = genericRnf 14 | instance Binary EmailVisibility 15 | 16 | instance FromJSON EmailVisibility where 17 | parseJSON = withText "EmailVisibility" $ \t -> case T.toLower t of 18 | "private" -> pure EmailVisibilityPrivate 19 | "public" -> pure EmailVisibilityPublic 20 | _ -> fail $ "Unknown EmailVisibility: " <> T.unpack t 21 | 22 | data Email = Email 23 | { emailAddress :: !Text 24 | , emailVerified :: !Bool 25 | , emailPrimary :: !Bool 26 | , emailVisibility :: !(Maybe EmailVisibility) 27 | } deriving (Show, Data, Typeable, Eq, Ord, Generic) 28 | 29 | instance NFData Email where rnf = genericRnf 30 | instance Binary Email 31 | 32 | instance FromJSON Email where 33 | parseJSON = withObject "Email" $ \o -> Email 34 | <$> o .: "email" 35 | <*> o .: "verified" 36 | <*> o .: "primary" 37 | <*> o .:? "visibility" 38 | -------------------------------------------------------------------------------- /src/GitHub/Data/Enterprise.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- This module re-exports the @GitHub.Data.Enterprise.@ submodules. 3 | 4 | module GitHub.Data.Enterprise ( 5 | -- * Module re-exports 6 | module GitHub.Data.Enterprise.Organizations, 7 | ) where 8 | 9 | import GitHub.Data.Enterprise.Organizations 10 | -------------------------------------------------------------------------------- /src/GitHub/Data/Enterprise/Organizations.hs: -------------------------------------------------------------------------------- 1 | module GitHub.Data.Enterprise.Organizations where 2 | 3 | import GitHub.Data.Definitions 4 | import GitHub.Data.Name (Name) 5 | import GitHub.Data.URL (URL) 6 | import GitHub.Internal.Prelude 7 | import Prelude () 8 | 9 | data CreateOrganization = CreateOrganization 10 | { createOrganizationLogin :: !(Name Organization) 11 | , createOrganizationAdmin :: !(Name User) 12 | , createOrganizationProfileName :: !(Maybe Text) 13 | } 14 | deriving (Show, Data, Typeable, Eq, Ord, Generic) 15 | 16 | instance NFData CreateOrganization where rnf = genericRnf 17 | instance Binary CreateOrganization 18 | 19 | data RenameOrganization = RenameOrganization 20 | { renameOrganizationLogin :: !(Name Organization) 21 | } 22 | deriving (Show, Data, Typeable, Eq, Ord, Generic) 23 | 24 | instance NFData RenameOrganization where rnf = genericRnf 25 | instance Binary RenameOrganization 26 | 27 | data RenameOrganizationResponse = RenameOrganizationResponse 28 | { renameOrganizationResponseMessage :: !Text 29 | , renameOrganizationResponseUrl :: !URL 30 | } 31 | deriving (Show, Data, Typeable, Eq, Ord, Generic) 32 | 33 | instance NFData RenameOrganizationResponse where rnf = genericRnf 34 | instance Binary RenameOrganizationResponse 35 | 36 | -- JSON Instances 37 | 38 | instance ToJSON CreateOrganization where 39 | toJSON (CreateOrganization login admin profileName) = 40 | object $ filter notNull 41 | [ "login" .= login 42 | , "admin" .= admin 43 | , "profile_name" .= profileName 44 | ] 45 | where 46 | notNull (_, Null) = False 47 | notNull (_, _) = True 48 | 49 | instance ToJSON RenameOrganization where 50 | toJSON (RenameOrganization login) = 51 | object 52 | [ "login" .= login 53 | ] 54 | 55 | instance FromJSON RenameOrganizationResponse where 56 | parseJSON = withObject "RenameOrganizationResponse" $ \o -> 57 | RenameOrganizationResponse 58 | <$> o .: "message" 59 | <*> o .: "url" 60 | -------------------------------------------------------------------------------- /src/GitHub/Data/Events.hs: -------------------------------------------------------------------------------- 1 | module GitHub.Data.Events where 2 | 3 | import GitHub.Data.Definitions 4 | import GitHub.Internal.Prelude 5 | import Prelude () 6 | 7 | -- | Events. 8 | -- 9 | -- /TODO:/ 10 | -- 11 | -- * missing repo, org, payload, id 12 | -- 13 | data Event = Event 14 | -- { eventId :: !(Id Event) -- id can be encoded as string. 15 | { eventActor :: !SimpleUser 16 | , eventCreatedAt :: !UTCTime 17 | , eventPublic :: !Bool 18 | } 19 | deriving (Show, Data, Typeable, Eq, Ord, Generic) 20 | 21 | instance NFData Event where rnf = genericRnf 22 | instance Binary Event 23 | 24 | instance FromJSON Event where 25 | parseJSON = withObject "Event" $ \obj -> Event 26 | -- <$> obj .: "id" 27 | <$> obj .: "actor" 28 | <*> obj .: "created_at" 29 | <*> obj .: "public" 30 | -------------------------------------------------------------------------------- /src/GitHub/Data/Id.hs: -------------------------------------------------------------------------------- 1 | module GitHub.Data.Id ( 2 | Id(..), 3 | mkId, 4 | untagId, 5 | ) where 6 | 7 | import GitHub.Internal.Prelude 8 | import Prelude () 9 | 10 | -- | Numeric identifier. 11 | newtype Id entity = Id Int 12 | deriving (Eq, Ord, Show, Generic, Typeable, Data) 13 | 14 | -- | Smart constructor for 'Id'. 15 | mkId :: proxy entity -> Int -> Id entity 16 | mkId _ = Id 17 | 18 | untagId :: Id entity -> Int 19 | untagId (Id name) = name 20 | 21 | instance Hashable (Id entity) 22 | instance Binary (Id entity) 23 | 24 | instance NFData (Id entity) where 25 | rnf (Id s) = rnf s 26 | 27 | instance FromJSON (Id entity) where 28 | parseJSON = fmap Id . parseJSON 29 | 30 | instance ToJSON (Id entity) where 31 | toJSON = toJSON . untagId 32 | -------------------------------------------------------------------------------- /src/GitHub/Data/Name.hs: -------------------------------------------------------------------------------- 1 | module GitHub.Data.Name ( 2 | Name(..), 3 | mkName, 4 | untagName, 5 | ) where 6 | 7 | import Prelude () 8 | import GitHub.Internal.Prelude 9 | 10 | import Data.Aeson.Types 11 | (FromJSONKey (..), ToJSONKey (..), fromJSONKeyCoerce, toJSONKeyText) 12 | 13 | newtype Name entity = N Text 14 | deriving (Eq, Ord, Show, Generic, Typeable, Data) 15 | 16 | -- | Smart constructor for 'Name' 17 | mkName :: proxy entity -> Text -> Name entity 18 | mkName _ = N 19 | 20 | untagName :: Name entity -> Text 21 | untagName (N name) = name 22 | 23 | instance Hashable (Name entity) 24 | instance Binary (Name entity) 25 | 26 | instance NFData (Name entity) where 27 | rnf (N s) = rnf s 28 | 29 | instance FromJSON (Name entity) where 30 | parseJSON = fmap N . parseJSON 31 | 32 | instance ToJSON (Name entity) where 33 | toJSON = toJSON . untagName 34 | 35 | instance IsString (Name entity) where 36 | fromString = N . fromString 37 | 38 | -- | @since 0.15.0.0 39 | instance ToJSONKey (Name entity) where 40 | toJSONKey = toJSONKeyText untagName 41 | 42 | -- | @since 0.15.0.0 43 | instance FromJSONKey (Name entity) where 44 | fromJSONKey = fromJSONKeyCoerce 45 | -------------------------------------------------------------------------------- /src/GitHub/Data/PublicSSHKeys.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- License : BSD-3-Clause 4 | -- Maintainer : Todd Mohney 5 | -- 6 | module GitHub.Data.PublicSSHKeys where 7 | 8 | import GitHub.Data.Id (Id) 9 | import GitHub.Data.URL (URL) 10 | import GitHub.Internal.Prelude 11 | import Prelude () 12 | 13 | data PublicSSHKeyBasic = PublicSSHKeyBasic 14 | { basicPublicSSHKeyId :: !(Id PublicSSHKey) 15 | , basicPublicSSHKeyKey :: !Text 16 | } 17 | deriving (Show, Data, Typeable, Eq, Ord, Generic) 18 | 19 | instance FromJSON PublicSSHKeyBasic where 20 | parseJSON = withObject "PublicSSHKeyBasic" $ \o -> PublicSSHKeyBasic 21 | <$> o .: "id" 22 | <*> o .: "key" 23 | 24 | data PublicSSHKey = PublicSSHKey 25 | { publicSSHKeyId :: !(Id PublicSSHKey) 26 | , publicSSHKeyKey :: !Text 27 | , publicSSHKeyUrl :: !URL 28 | , publicSSHKeyTitle :: !Text 29 | , publicSSHKeyVerified :: !Bool 30 | , publicSSHKeyCreatedAt :: !(Maybe UTCTime) 31 | , publicSSHKeyReadOnly :: !Bool 32 | } 33 | deriving (Show, Data, Typeable, Eq, Ord, Generic) 34 | 35 | instance FromJSON PublicSSHKey where 36 | parseJSON = withObject "PublicSSHKey" $ \o -> PublicSSHKey 37 | <$> o .: "id" 38 | <*> o .: "key" 39 | <*> o .: "url" 40 | <*> o .: "title" 41 | <*> o .: "verified" 42 | <*> o .:? "created_at" 43 | <*> o .: "read_only" 44 | 45 | data NewPublicSSHKey = NewPublicSSHKey 46 | { newPublicSSHKeyKey :: !Text 47 | , newPublicSSHKeyTitle :: !Text 48 | } 49 | deriving (Show, Data, Typeable, Eq, Ord, Generic) 50 | 51 | instance ToJSON NewPublicSSHKey where 52 | toJSON (NewPublicSSHKey key title) = object 53 | [ "key" .= key 54 | , "title" .= title 55 | ] 56 | 57 | instance FromJSON NewPublicSSHKey where 58 | parseJSON = withObject "PublicSSHKey" $ \o -> NewPublicSSHKey 59 | <$> o .: "key" 60 | <*> o .: "title" 61 | -------------------------------------------------------------------------------- /src/GitHub/Data/RateLimit.hs: -------------------------------------------------------------------------------- 1 | module GitHub.Data.RateLimit where 2 | 3 | import GitHub.Internal.Prelude 4 | import Prelude () 5 | 6 | import Data.Time.Clock.System (SystemTime (..)) 7 | 8 | import qualified Data.ByteString.Char8 as BS8 9 | import qualified Network.HTTP.Client as HTTP 10 | 11 | data Limits = Limits 12 | { limitsMax :: !Int 13 | , limitsRemaining :: !Int 14 | , limitsReset :: !SystemTime 15 | } 16 | deriving (Show, {- Data, -} Typeable, Eq, Ord, Generic) 17 | 18 | instance NFData Limits where rnf = genericRnf 19 | instance Binary Limits 20 | 21 | instance FromJSON Limits where 22 | parseJSON = withObject "Limits" $ \obj -> Limits 23 | <$> obj .: "limit" 24 | <*> obj .: "remaining" 25 | <*> fmap (\t -> MkSystemTime t 0) (obj .: "reset") 26 | 27 | data RateLimit = RateLimit 28 | { rateLimitCore :: Limits 29 | , rateLimitSearch :: Limits 30 | , rateLimitGraphQL :: Limits 31 | } 32 | deriving (Show, {- Data, -} Typeable, Eq, Ord, Generic) 33 | 34 | instance NFData RateLimit where rnf = genericRnf 35 | instance Binary RateLimit 36 | 37 | instance FromJSON RateLimit where 38 | parseJSON = withObject "RateLimit" $ \obj -> do 39 | resources <- obj .: "resources" 40 | RateLimit 41 | <$> resources .: "core" 42 | <*> resources .: "search" 43 | <*> resources .: "graphql" 44 | 45 | ------------------------------------------------------------------------------- 46 | -- Extras 47 | ------------------------------------------------------------------------------- 48 | 49 | -- | @since 0.24 50 | limitsFromHttpResponse :: HTTP.Response a -> Maybe Limits 51 | limitsFromHttpResponse res = do 52 | let hdrs = HTTP.responseHeaders res 53 | m <- lookup "X-RateLimit-Limit" hdrs >>= readIntegral 54 | r <- lookup "X-RateLimit-Remaining" hdrs >>= readIntegral 55 | t <- lookup "X-RateLimit-Reset" hdrs >>= readIntegral 56 | return (Limits m r (MkSystemTime t 0)) 57 | where 58 | readIntegral :: Num a => BS8.ByteString -> Maybe a 59 | readIntegral bs = case BS8.readInt bs of 60 | Just (n, bs') | BS8.null bs' -> Just (fromIntegral n) 61 | _ -> Nothing 62 | -------------------------------------------------------------------------------- /src/GitHub/Data/Search.hs: -------------------------------------------------------------------------------- 1 | module GitHub.Data.Search where 2 | 3 | import GitHub.Data.Repos (CodeSearchRepo) 4 | import GitHub.Data.URL (URL) 5 | import GitHub.Internal.Prelude 6 | import Prelude () 7 | 8 | import qualified Data.Vector as V 9 | 10 | data SearchResult' entities = SearchResult 11 | { searchResultTotalCount :: !Int 12 | , searchResultResults :: !entities 13 | } 14 | deriving (Show, Data, Typeable, Eq, Ord, Generic) 15 | 16 | type SearchResult entity = SearchResult' (V.Vector entity) 17 | 18 | instance NFData entities => NFData (SearchResult' entities) where rnf = genericRnf 19 | instance Binary entities => Binary (SearchResult' entities) 20 | 21 | instance (Monoid entities, FromJSON entities) => FromJSON (SearchResult' entities) where 22 | parseJSON = withObject "SearchResult" $ \o -> SearchResult 23 | <$> o .: "total_count" 24 | <*> o .:? "items" .!= mempty 25 | 26 | instance Semigroup res => Semigroup (SearchResult' res) where 27 | (SearchResult count res) <> (SearchResult count' res') = SearchResult (max count count') (res <> res') 28 | 29 | instance Foldable SearchResult' where 30 | foldMap f (SearchResult _count results) = f results 31 | 32 | data Code = Code 33 | { codeName :: !Text 34 | , codePath :: !Text 35 | , codeSha :: !Text 36 | , codeUrl :: !URL 37 | , codeGitUrl :: !URL 38 | , codeHtmlUrl :: !URL 39 | , codeRepo :: !CodeSearchRepo 40 | } 41 | deriving (Show, Data, Typeable, Eq, Ord, Generic) 42 | 43 | instance NFData Code where rnf = genericRnf 44 | instance Binary Code 45 | 46 | instance FromJSON Code where 47 | parseJSON = withObject "Code" $ \o -> Code 48 | <$> o .: "name" 49 | <*> o .: "path" 50 | <*> o .: "sha" 51 | <*> o .: "url" 52 | <*> o .: "git_url" 53 | <*> o .: "html_url" 54 | <*> o .: "repository" 55 | -------------------------------------------------------------------------------- /src/GitHub/Data/URL.hs: -------------------------------------------------------------------------------- 1 | module GitHub.Data.URL ( 2 | URL(..), 3 | getUrl, 4 | ) where 5 | 6 | import GitHub.Internal.Prelude 7 | import Prelude () 8 | 9 | -- | Data representing URLs in responses. 10 | -- 11 | -- /N.B./ syntactical validity is not verified. 12 | newtype URL = URL Text 13 | deriving (Eq, Ord, Show, Generic, Typeable, Data) 14 | 15 | getUrl :: URL -> Text 16 | getUrl (URL url) = url 17 | 18 | instance NFData URL where rnf = genericRnf 19 | instance Binary URL 20 | 21 | instance ToJSON URL where 22 | toJSON (URL url) = toJSON url 23 | 24 | instance FromJSON URL where 25 | parseJSON = withText "URL" (pure . URL) 26 | -------------------------------------------------------------------------------- /src/GitHub/Data/Webhooks/Validate.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Verification of incomming webhook payloads, as described at 3 | -- 4 | 5 | module GitHub.Data.Webhooks.Validate ( 6 | isValidPayload 7 | ) where 8 | 9 | import GitHub.Internal.Prelude 10 | import Prelude () 11 | 12 | import Crypto.Hash.SHA1 (hmac) 13 | import Data.ByteString (ByteString) 14 | 15 | import qualified Data.ByteString.Base16 as Hex 16 | import qualified Data.Text.Encoding as TE 17 | 18 | -- | Validates a given payload against a given HMAC hexdigest using a given 19 | -- secret. 20 | -- Returns 'True' iff the given hash is non-empty and it's a valid signature of 21 | -- the payload. 22 | isValidPayload 23 | :: Text -- ^ the secret 24 | -> Maybe Text -- ^ the hash provided by the remote party 25 | -- in @X-Hub-Signature@ (if any), 26 | -- including the 'sha1=...' prefix 27 | -> ByteString -- ^ the body 28 | -> Bool 29 | isValidPayload secret shaOpt payload = maybe False (sign ==) shaOptBS 30 | where 31 | shaOptBS = TE.encodeUtf8 <$> shaOpt 32 | hexDigest = Hex.encode 33 | hm = hmac (TE.encodeUtf8 secret) payload 34 | sign = "sha1=" <> hexDigest hm 35 | -------------------------------------------------------------------------------- /src/GitHub/Endpoints/Actions/WorkflowJobs.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- The actions API as documented at 3 | -- . 4 | 5 | module GitHub.Endpoints.Actions.WorkflowJobs ( 6 | jobR, 7 | downloadJobLogsR, 8 | jobsForWorkflowRunAttemptR, 9 | jobsForWorkflowRunR, 10 | module GitHub.Data 11 | ) where 12 | 13 | import GitHub.Data 14 | import Network.URI (URI) 15 | import Prelude () 16 | 17 | -- | Get a job for a workflow run. 18 | -- See 19 | jobR 20 | :: Name Owner 21 | -> Name Repo 22 | -> Id Job 23 | -> Request 'RA Job 24 | jobR owner repo job = 25 | Query ["repos", toPathPart owner, toPathPart repo, "actions", "jobs", toPathPart job] [] 26 | 27 | -- | Download job logs for a workflow run. 28 | -- See 29 | downloadJobLogsR 30 | :: Name Owner 31 | -> Name Repo 32 | -> Id Job 33 | -> GenRequest 'MtRedirect 'RO URI 34 | downloadJobLogsR owner repo job = 35 | Query ["repos", toPathPart owner, toPathPart repo, "actions", "jobs", toPathPart job, "logs"] [] 36 | 37 | -- | List jobs for a workflow run attempt. 38 | -- See 39 | jobsForWorkflowRunAttemptR 40 | :: Name Owner 41 | -> Name Repo 42 | -> Id WorkflowRun 43 | -> Id RunAttempt 44 | -> FetchCount 45 | -> GenRequest 'MtJSON 'RA (WithTotalCount Job) 46 | jobsForWorkflowRunAttemptR owner repo run attempt = 47 | PagedQuery ["repos", toPathPart owner, toPathPart repo, "actions", "runs", toPathPart run, "attempts", toPathPart attempt, "jobs"] [] 48 | 49 | -- | List jobs for a workflow run. 50 | -- See 51 | jobsForWorkflowRunR 52 | :: Name Owner 53 | -> Name Repo 54 | -> Id WorkflowRun 55 | -> FetchCount 56 | -> GenRequest 'MtJSON 'RA (WithTotalCount Job) 57 | jobsForWorkflowRunR owner repo run = 58 | PagedQuery ["repos", toPathPart owner, toPathPart repo, "actions", "runs", toPathPart run, "jobs"] [] 59 | -------------------------------------------------------------------------------- /src/GitHub/Endpoints/Activity/Events.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- The events API as described on . 3 | 4 | module GitHub.Endpoints.Activity.Events ( 5 | -- * Events 6 | repositoryEventsR, 7 | userEventsR, 8 | module GitHub.Data, 9 | ) where 10 | 11 | import GitHub.Data 12 | import GitHub.Internal.Prelude 13 | import Prelude () 14 | 15 | -- | List repository events. 16 | -- See 17 | repositoryEventsR :: Name Owner -> Name Repo -> FetchCount -> Request 'RO (Vector Event) 18 | repositoryEventsR user repo = 19 | pagedQuery ["repos", toPathPart user, toPathPart repo, "events"] [] 20 | 21 | -- | List user public events. 22 | -- See 23 | userEventsR :: Name User -> FetchCount -> Request 'RO (Vector Event) 24 | userEventsR user = 25 | pagedQuery ["users", toPathPart user, "events", "public"] [] 26 | -------------------------------------------------------------------------------- /src/GitHub/Endpoints/Activity/Notifications.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- The repo watching API as described on 3 | -- . 4 | 5 | module GitHub.Endpoints.Activity.Notifications ( 6 | getNotificationsR, 7 | markNotificationAsReadR, 8 | markAllNotificationsAsReadR, 9 | ) where 10 | 11 | import GitHub.Data 12 | import GitHub.Internal.Prelude 13 | import Prelude () 14 | 15 | -- | List your notifications. 16 | -- See 17 | getNotificationsR :: FetchCount -> Request 'RA (Vector Notification) 18 | getNotificationsR = pagedQuery ["notifications"] [] 19 | 20 | -- | Mark a thread as read. 21 | -- See 22 | markNotificationAsReadR :: Id Notification -> GenRequest 'MtUnit 'RW () 23 | markNotificationAsReadR nid = Command 24 | Patch 25 | ["notifications", "threads", toPathPart nid] 26 | (encode ()) 27 | 28 | -- | Mark as read. 29 | -- See 30 | markAllNotificationsAsReadR :: GenRequest 'MtUnit 'RW () 31 | markAllNotificationsAsReadR = 32 | Command Put ["notifications"] $ encode emptyObject 33 | -------------------------------------------------------------------------------- /src/GitHub/Endpoints/Activity/Starring.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- The repo starring API as described on 3 | -- . 4 | 5 | module GitHub.Endpoints.Activity.Starring ( 6 | stargazersForR, 7 | reposStarredByR, 8 | myStarredR, 9 | myStarredAcceptStarR, 10 | starRepoR, 11 | unstarRepoR, 12 | module GitHub.Data, 13 | ) where 14 | 15 | import GitHub.Auth 16 | import GitHub.Data 17 | import GitHub.Internal.Prelude 18 | import Prelude () 19 | 20 | -- | List Stargazers. 21 | -- See 22 | stargazersForR :: Name Owner -> Name Repo -> FetchCount -> Request k (Vector SimpleUser) 23 | stargazersForR user repo = 24 | pagedQuery ["repos", toPathPart user, toPathPart repo, "stargazers"] [] 25 | 26 | -- | List repositories being starred. 27 | -- See 28 | reposStarredByR :: Name Owner -> FetchCount -> Request k (Vector Repo) 29 | reposStarredByR user = 30 | pagedQuery ["users", toPathPart user, "starred"] [] 31 | 32 | -- | All the repos starred by the authenticated user. 33 | -- See 34 | myStarredR :: FetchCount -> Request 'RA (Vector Repo) 35 | myStarredR = pagedQuery ["user", "starred"] [] 36 | 37 | -- | All the repos starred by the authenticated user. 38 | -- See 39 | myStarredAcceptStarR :: FetchCount -> GenRequest 'MtStar 'RA (Vector RepoStarred) 40 | myStarredAcceptStarR = PagedQuery ["user", "starred"] [] 41 | 42 | -- | Star a repo by the authenticated user. 43 | -- See 44 | starRepoR :: Name Owner -> Name Repo -> GenRequest 'MtUnit 'RW () 45 | starRepoR user repo = Command Put paths mempty 46 | where 47 | paths = ["user", "starred", toPathPart user, toPathPart repo] 48 | 49 | -- | Unstar a repo by the authenticated user. 50 | -- See 51 | unstarRepoR :: Name Owner -> Name Repo -> GenRequest 'MtUnit 'RW () 52 | unstarRepoR user repo = Command Delete paths mempty 53 | where 54 | paths = ["user", "starred", toPathPart user, toPathPart repo] 55 | -------------------------------------------------------------------------------- /src/GitHub/Endpoints/Activity/Watching.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- The repo watching API as described on 3 | -- . 4 | 5 | module GitHub.Endpoints.Activity.Watching ( 6 | watchersForR, 7 | reposWatchedByR, 8 | unwatchRepoR, 9 | module GitHub.Data, 10 | ) where 11 | 12 | import GitHub.Auth 13 | import GitHub.Data 14 | import GitHub.Internal.Prelude 15 | import Prelude () 16 | 17 | -- | List watchers. 18 | -- See 19 | watchersForR :: Name Owner -> Name Repo -> FetchCount -> Request k (Vector SimpleUser) 20 | watchersForR user repo limit = 21 | pagedQuery ["repos", toPathPart user, toPathPart repo, "watchers"] [] limit 22 | 23 | -- | List repositories being watched. 24 | -- See 25 | reposWatchedByR :: Name Owner -> FetchCount -> Request k (Vector Repo) 26 | reposWatchedByR user = 27 | pagedQuery ["users", toPathPart user, "subscriptions"] [] 28 | 29 | -- | Stop watching repository. 30 | -- See 31 | unwatchRepoR :: Name Owner -> Name Repo -> Request 'RW () 32 | unwatchRepoR owner repo = 33 | command Delete ["repos", toPathPart owner, toPathPart repo, "subscription"] mempty 34 | -------------------------------------------------------------------------------- /src/GitHub/Endpoints/Enterprise/Organizations.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- The GitHub Enterprise orgs API as described on . 3 | 4 | module GitHub.Endpoints.Enterprise.Organizations ( 5 | createOrganizationR, 6 | renameOrganizationR, 7 | module GitHub.Data, 8 | ) where 9 | 10 | import GitHub.Data 11 | import GitHub.Data.Enterprise 12 | import GitHub.Internal.Prelude 13 | import Prelude () 14 | 15 | -- | Create an organization. 16 | -- See 17 | createOrganizationR :: CreateOrganization -> Request 'RW SimpleOrganization 18 | createOrganizationR = 19 | command Post ["admin", "organizations"] . encode 20 | 21 | -- | Rename an organization. 22 | -- See 23 | renameOrganizationR :: Name Organization -> RenameOrganization -> Request 'RW RenameOrganizationResponse 24 | renameOrganizationR org = 25 | command Patch ["admin", "organizations", toPathPart org] . encode 26 | -------------------------------------------------------------------------------- /src/GitHub/Endpoints/Gists.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- The gists API as described at . 3 | 4 | module GitHub.Endpoints.Gists ( 5 | gistsR, 6 | gistR, 7 | createGistR, 8 | starGistR, 9 | unstarGistR, 10 | deleteGistR, 11 | module GitHub.Data, 12 | ) where 13 | 14 | import GitHub.Data 15 | import GitHub.Internal.Prelude 16 | import Prelude () 17 | 18 | -- | List gists. 19 | -- See 20 | gistsR :: Name Owner -> FetchCount -> Request k (Vector Gist) 21 | gistsR user = pagedQuery ["users", toPathPart user, "gists"] [] 22 | 23 | -- | Query a single gist. 24 | -- See 25 | gistR :: Name Gist -> Request k Gist 26 | gistR gid = 27 | query ["gists", toPathPart gid] [] 28 | 29 | -- | Create a new gist 30 | -- See 31 | createGistR :: NewGist -> Request 'RW Gist 32 | createGistR ngist = command Post ["gists"] (encode ngist) 33 | 34 | -- | Star a gist by the authenticated user. 35 | -- See 36 | starGistR :: Name Gist -> GenRequest 'MtUnit 'RW () 37 | starGistR gid = Command Put ["gists", toPathPart gid, "star"] mempty 38 | 39 | -- | Unstar a gist by the authenticated user. 40 | -- See 41 | unstarGistR :: Name Gist -> GenRequest 'MtUnit 'RW () 42 | unstarGistR gid = Command Delete ["gists", toPathPart gid, "star"] mempty 43 | 44 | -- | Delete a gist by the authenticated user. 45 | -- See 46 | deleteGistR :: Name Gist -> GenRequest 'MtUnit 'RW () 47 | deleteGistR gid = Command Delete ["gists", toPathPart gid] mempty 48 | -------------------------------------------------------------------------------- /src/GitHub/Endpoints/Gists/Comments.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- The loving comments people have left on Gists, described on 3 | -- . 4 | 5 | module GitHub.Endpoints.Gists.Comments ( 6 | commentsOnR, 7 | gistCommentR, 8 | module GitHub.Data, 9 | ) where 10 | 11 | import GitHub.Data 12 | import GitHub.Internal.Prelude 13 | import Prelude () 14 | 15 | -- | List comments on a gist. 16 | -- See 17 | commentsOnR :: Name Gist -> FetchCount -> Request k (Vector GistComment) 18 | commentsOnR gid = 19 | pagedQuery ["gists", toPathPart gid, "comments"] [] 20 | 21 | -- | Query a single comment. 22 | -- See 23 | gistCommentR :: Id GistComment -> Request k GistComment 24 | gistCommentR cid = 25 | query ["gists", "comments", toPathPart cid] [] 26 | -------------------------------------------------------------------------------- /src/GitHub/Endpoints/GitData/Blobs.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- The API for dealing with git blobs from Github repos, as described in 3 | -- . 4 | 5 | module GitHub.Endpoints.GitData.Blobs ( 6 | blobR, 7 | module GitHub.Data, 8 | ) where 9 | 10 | import GitHub.Data 11 | import Prelude () 12 | 13 | -- | Query a blob. 14 | -- See 15 | blobR :: Name Owner -> Name Repo -> Name Blob -> Request k Blob 16 | blobR user repo sha = 17 | query ["repos", toPathPart user, toPathPart repo, "git", "blobs", toPathPart sha] [] 18 | -------------------------------------------------------------------------------- /src/GitHub/Endpoints/GitData/Commits.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- The API for underlying git commits of a Github repo, as described on 3 | -- . 4 | 5 | module GitHub.Endpoints.GitData.Commits ( 6 | gitCommitR, 7 | module GitHub.Data, 8 | ) where 9 | 10 | import GitHub.Data 11 | import Prelude () 12 | 13 | -- | Query a commit. 14 | -- See 15 | gitCommitR :: Name Owner -> Name Repo -> Name GitCommit -> Request k GitCommit 16 | gitCommitR user repo sha = 17 | query ["repos", toPathPart user, toPathPart repo, "git", "commits", toPathPart sha] [] 18 | -------------------------------------------------------------------------------- /src/GitHub/Endpoints/GitData/References.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- The underlying git references on a Github repo, exposed for the world to 3 | -- see. The git internals documentation will also prove handy for understanding 4 | -- these. API documentation at . 5 | 6 | module GitHub.Endpoints.GitData.References ( 7 | referenceR, 8 | referencesR, 9 | createReferenceR, 10 | deleteReferenceR, 11 | namespacedReferencesR, 12 | module GitHub.Data, 13 | ) where 14 | 15 | import GitHub.Data 16 | import GitHub.Internal.Prelude 17 | import Prelude () 18 | 19 | -- | A single reference -- | Query a reference. 20 | -- See 21 | referenceR :: Name Owner -> Name Repo -> Name GitReference -> Request k GitReference 22 | referenceR user repo ref = 23 | query ["repos", toPathPart user, toPathPart repo, "git", "refs", toPathPart ref] [] 24 | 25 | -- | Query all References. 26 | -- See 27 | referencesR :: Name Owner -> Name Repo -> FetchCount -> Request k (Vector GitReference) 28 | referencesR user repo = 29 | pagedQuery ["repos", toPathPart user, toPathPart repo, "git", "refs"] [] 30 | 31 | -- | Create a reference. 32 | -- See 33 | createReferenceR :: Name Owner -> Name Repo -> NewGitReference -> Request 'RW GitReference 34 | createReferenceR user repo newRef = 35 | command Post ["repos", toPathPart user, toPathPart repo , "git", "refs"] (encode newRef) 36 | 37 | -- | Delete a reference. 38 | -- See 39 | deleteReferenceR :: Name Owner -> Name Repo -> Name GitReference -> GenRequest 'MtUnit 'RW () 40 | deleteReferenceR user repo ref = 41 | Command Delete ["repos", toPathPart user, toPathPart repo , "git", "refs", toPathPart ref] mempty 42 | 43 | -- | Query namespaced references. 44 | -- See 45 | namespacedReferencesR :: Name Owner -> Name Repo -> Text -> Request k [GitReference] 46 | namespacedReferencesR user repo namespace = 47 | query ["repos", toPathPart user, toPathPart repo, "git", "refs", namespace] [] 48 | -------------------------------------------------------------------------------- /src/GitHub/Endpoints/GitData/Trees.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- The underlying tree of SHA1s and files that make up a git repo. The API is 3 | -- described on . 4 | 5 | module GitHub.Endpoints.GitData.Trees ( 6 | treeR, 7 | nestedTreeR, 8 | module GitHub.Data, 9 | ) where 10 | 11 | import GitHub.Data 12 | import GitHub.Internal.Prelude 13 | import Prelude () 14 | 15 | -- | Query a Tree. 16 | -- See 17 | treeR :: Name Owner -> Name Repo -> Name Tree -> Request k Tree 18 | treeR user repo sha = 19 | query ["repos", toPathPart user, toPathPart repo, "git", "trees", toPathPart sha] [] 20 | 21 | -- | Query a Tree Recursively. 22 | -- See 23 | nestedTreeR :: Name Owner -> Name Repo -> Name Tree -> Request k Tree 24 | nestedTreeR user repo sha = 25 | query ["repos", toPathPart user, toPathPart repo, "git", "trees", toPathPart sha] [("recursive", Just "1")] 26 | -------------------------------------------------------------------------------- /src/GitHub/Endpoints/Issues/Comments.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- The Github issue comments API from 3 | -- . 4 | 5 | module GitHub.Endpoints.Issues.Comments ( 6 | commentR, 7 | commentsR, 8 | createCommentR, 9 | deleteCommentR, 10 | editCommentR, 11 | module GitHub.Data, 12 | ) where 13 | 14 | import GitHub.Data 15 | import GitHub.Internal.Prelude 16 | import Prelude () 17 | 18 | -- | Query a single comment. 19 | -- See 20 | commentR :: Name Owner -> Name Repo -> Id Comment -> Request k IssueComment 21 | commentR user repo cid = 22 | query ["repos", toPathPart user, toPathPart repo, "issues", "comments", toPathPart cid] [] 23 | 24 | -- | List comments on an issue. 25 | -- See 26 | commentsR :: Name Owner -> Name Repo -> IssueNumber -> FetchCount -> Request k (Vector IssueComment) 27 | commentsR user repo iid = 28 | pagedQuery ["repos", toPathPart user, toPathPart repo, "issues", toPathPart iid, "comments"] [] 29 | 30 | -- | Create a comment. 31 | -- See 32 | createCommentR :: Name Owner -> Name Repo -> IssueNumber -> Text -> Request 'RW Comment 33 | createCommentR user repo iss body = 34 | command Post parts (encode $ NewComment body) 35 | where 36 | parts = ["repos", toPathPart user, toPathPart repo, "issues", toPathPart iss, "comments"] 37 | 38 | -- | Edit a comment. 39 | -- See 40 | editCommentR :: Name Owner -> Name Repo -> Id Comment -> Text -> Request 'RW Comment 41 | editCommentR user repo commid body = 42 | command Patch parts (encode $ EditComment body) 43 | where 44 | parts = ["repos", toPathPart user, toPathPart repo, "issues", "comments", toPathPart commid] 45 | 46 | -- | Delete a comment. 47 | -- See 48 | deleteCommentR :: Name Owner -> Name Repo -> Id Comment -> GenRequest 'MtUnit 'RW () 49 | deleteCommentR user repo commid = 50 | Command Delete parts mempty 51 | where 52 | parts = ["repos", toPathPart user, toPathPart repo, "issues", "comments", toPathPart commid] 53 | -------------------------------------------------------------------------------- /src/GitHub/Endpoints/Issues/Events.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- The Github issue events API, which is described on 3 | -- 4 | 5 | module GitHub.Endpoints.Issues.Events ( 6 | eventsForIssueR, 7 | eventsForRepoR, 8 | eventR, 9 | module GitHub.Data, 10 | ) where 11 | 12 | import GitHub.Data 13 | import GitHub.Internal.Prelude 14 | import Prelude () 15 | 16 | -- | List events for an issue. 17 | -- See 18 | eventsForIssueR :: Name Owner -> Name Repo -> Id Issue -> FetchCount -> Request k (Vector IssueEvent) 19 | eventsForIssueR user repo iid = 20 | pagedQuery ["repos", toPathPart user, toPathPart repo, "issues", toPathPart iid, "events"] [] 21 | 22 | -- | List events for a repository. 23 | -- See 24 | eventsForRepoR :: Name Owner -> Name Repo -> FetchCount -> Request k (Vector IssueEvent) 25 | eventsForRepoR user repo = 26 | pagedQuery ["repos", toPathPart user, toPathPart repo, "issues", "events"] [] 27 | 28 | -- | Query a single event. 29 | -- See 30 | eventR :: Name Owner -> Name Repo -> Id IssueEvent -> Request k IssueEvent 31 | eventR user repo eid = 32 | query ["repos", toPathPart user, toPathPart repo, "issues", "events", toPathPart eid] [] 33 | -------------------------------------------------------------------------------- /src/GitHub/Endpoints/Issues/Milestones.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- The milestones API as described on 3 | -- . 4 | 5 | module GitHub.Endpoints.Issues.Milestones ( 6 | milestonesR, 7 | milestoneR, 8 | createMilestoneR, 9 | updateMilestoneR, 10 | deleteMilestoneR, 11 | module GitHub.Data, 12 | ) where 13 | 14 | import GitHub.Data 15 | import GitHub.Internal.Prelude 16 | import Prelude () 17 | 18 | -- | List milestones for a repository. 19 | -- See 20 | milestonesR :: Name Owner -> Name Repo -> FetchCount -> Request k (Vector Milestone) 21 | milestonesR user repo = 22 | pagedQuery ["repos", toPathPart user, toPathPart repo, "milestones"] [] 23 | 24 | -- | Query a single milestone. 25 | -- See 26 | milestoneR :: Name Owner -> Name Repo -> Id Milestone -> Request k Milestone 27 | milestoneR user repo mid = 28 | query ["repos", toPathPart user, toPathPart repo, "milestones", toPathPart mid] [] 29 | 30 | -- | Create a milestone. 31 | -- See 32 | createMilestoneR :: Name Owner -> Name Repo -> NewMilestone -> Request 'RW Milestone 33 | createMilestoneR user repo = 34 | command Post ["repos", toPathPart user, toPathPart repo, "milestones"] . encode 35 | 36 | -- | Update a milestone. 37 | -- See 38 | updateMilestoneR :: Name Owner -> Name Repo -> Id Milestone -> UpdateMilestone -> Request 'RW Milestone 39 | updateMilestoneR user repo mid = 40 | command Patch ["repos", toPathPart user, toPathPart repo, "milestones", toPathPart mid ] . encode 41 | 42 | -- | Delete a milestone. 43 | -- See 44 | deleteMilestoneR :: Name Owner -> Name Repo -> Id Milestone -> GenRequest 'MtUnit 'RW () 45 | deleteMilestoneR user repo mid = 46 | Command Delete 47 | ["repos", toPathPart user, toPathPart repo, "milestones", toPathPart mid] mempty 48 | -------------------------------------------------------------------------------- /src/GitHub/Endpoints/Organizations.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- The orgs API as described on . 3 | 4 | module GitHub.Endpoints.Organizations ( 5 | publicOrganizationsForR, 6 | publicOrganizationR, 7 | organizationsR, 8 | module GitHub.Data, 9 | ) where 10 | 11 | import GitHub.Data 12 | import GitHub.Internal.Prelude 13 | import Prelude () 14 | 15 | -- | List all user organizations. 16 | -- See 17 | organizationsR :: FetchCount -> Request k (Vector SimpleOrganization) 18 | organizationsR = pagedQuery ["user", "orgs"] [] 19 | 20 | -- | List public user organizations. 21 | -- See 22 | publicOrganizationsForR :: Name User -> FetchCount -> Request k (Vector SimpleOrganization) 23 | publicOrganizationsForR user = pagedQuery ["users", toPathPart user, "orgs"] [] 24 | 25 | -- | Query an organization. 26 | -- See 27 | publicOrganizationR :: Name Organization -> Request k Organization 28 | publicOrganizationR reqOrganizationName = query ["orgs", toPathPart reqOrganizationName] [] 29 | -------------------------------------------------------------------------------- /src/GitHub/Endpoints/Organizations/OutsideCollaborators.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- The organization members API as described on 3 | -- . 4 | 5 | module GitHub.Endpoints.Organizations.OutsideCollaborators ( 6 | outsideCollaboratorsR, 7 | ) where 8 | 9 | import GitHub.Data 10 | import GitHub.Internal.Prelude 11 | import Prelude () 12 | 13 | -- | All the users who are outside collaborators of the specified organization. 14 | -- 15 | -- See 16 | outsideCollaboratorsR :: Name Organization -> FetchCount -> Request k (Vector SimpleUser) 17 | outsideCollaboratorsR organization = 18 | pagedQuery ["orgs", toPathPart organization, "outside_collaborators"] [] 19 | -------------------------------------------------------------------------------- /src/GitHub/Endpoints/PullRequests/Comments.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- The pull request review comments API as described at 3 | -- . 4 | 5 | module GitHub.Endpoints.PullRequests.Comments ( 6 | pullRequestCommentsR, 7 | pullRequestCommentR, 8 | createPullCommentR, 9 | createPullCommentReplyR, 10 | module GitHub.Data, 11 | ) where 12 | 13 | import GitHub.Data 14 | import GitHub.Internal.Prelude 15 | import Prelude () 16 | 17 | -- | List comments on a pull request. 18 | -- See 19 | pullRequestCommentsR :: Name Owner -> Name Repo -> IssueNumber -> FetchCount -> Request k (Vector Comment) 20 | pullRequestCommentsR user repo prid = 21 | pagedQuery ["repos", toPathPart user, toPathPart repo, "pulls", toPathPart prid, "comments"] [] 22 | 23 | -- | Query a single comment. 24 | -- See 25 | pullRequestCommentR :: Name Owner -> Name Repo -> Id Comment -> Request k Comment 26 | pullRequestCommentR user repo cid = 27 | query ["repos", toPathPart user, toPathPart repo, "pulls", "comments", toPathPart cid] [] 28 | 29 | -- | Create a comment. 30 | -- 31 | -- See 32 | createPullCommentR :: Name Owner -> Name Repo -> IssueNumber -> Text -> Text -> Int -> Text -> Request 'RW Comment 33 | createPullCommentR user repo iss commit path position body = 34 | command Post parts (encode $ NewPullComment commit path position body) 35 | where 36 | parts = ["repos", toPathPart user, toPathPart repo, "pulls", toPathPart iss, "comments"] 37 | 38 | -- | Create a comment reply. 39 | -- 40 | -- See 41 | createPullCommentReplyR :: Name Owner -> Name Repo -> IssueNumber -> Id Comment -> Text -> Request 'RW Comment 42 | createPullCommentReplyR user repo iss cid body = 43 | command Post parts (encode $ PullCommentReply body) 44 | where 45 | parts = ["repos", toPathPart user, toPathPart repo, "pulls", toPathPart iss 46 | , "comments", toPathPart cid, "replies"] 47 | -------------------------------------------------------------------------------- /src/GitHub/Endpoints/PullRequests/Reviews.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- The reviews API as described on . 3 | 4 | module GitHub.Endpoints.PullRequests.Reviews 5 | ( pullRequestReviewsR 6 | , pullRequestReviewR 7 | , pullRequestReviewCommentsR 8 | , module GitHub.Data 9 | ) where 10 | 11 | import GitHub.Data 12 | import GitHub.Internal.Prelude 13 | import Prelude () 14 | 15 | -- | List reviews for a pull request. 16 | -- See 17 | pullRequestReviewsR 18 | :: Name Owner 19 | -> Name Repo 20 | -> IssueNumber 21 | -> FetchCount 22 | -> Request k (Vector Review) 23 | pullRequestReviewsR owner repo prid = 24 | pagedQuery 25 | [ "repos" 26 | , toPathPart owner 27 | , toPathPart repo 28 | , "pulls" 29 | , toPathPart prid 30 | , "reviews" 31 | ] 32 | [] 33 | 34 | -- | Query a single pull request review. 35 | -- see 36 | pullRequestReviewR 37 | :: Name Owner 38 | -> Name Repo 39 | -> IssueNumber 40 | -> Id Review 41 | -> Request k Review 42 | pullRequestReviewR owner repo prid rid = 43 | query 44 | [ "repos" 45 | , toPathPart owner 46 | , toPathPart repo 47 | , "pulls" 48 | , toPathPart prid 49 | , "reviews" 50 | , toPathPart rid 51 | ] 52 | [] 53 | 54 | -- | Query the comments for a single pull request review. 55 | -- see 56 | pullRequestReviewCommentsR 57 | :: Name Owner 58 | -> Name Repo 59 | -> IssueNumber 60 | -> Id Review 61 | -> Request k [ReviewComment] 62 | pullRequestReviewCommentsR owner repo prid rid = 63 | query 64 | [ "repos" 65 | , toPathPart owner 66 | , toPathPart repo 67 | , "pulls" 68 | , toPathPart prid 69 | , "reviews" 70 | , toPathPart rid 71 | , "comments" 72 | ] 73 | [] 74 | -------------------------------------------------------------------------------- /src/GitHub/Endpoints/RateLimit.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- The Github RateLimit API, as described at 3 | -- . 4 | 5 | module GitHub.Endpoints.RateLimit ( 6 | rateLimitR, 7 | module GitHub.Data, 8 | ) where 9 | 10 | import GitHub.Data 11 | import Prelude () 12 | 13 | -- | Get your current rate limit status. 14 | -- 15 | rateLimitR :: Request k RateLimit 16 | rateLimitR = query ["rate_limit"] [] 17 | -------------------------------------------------------------------------------- /src/GitHub/Endpoints/Repos/Collaborators.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- The repo collaborators API as described on 3 | -- . 4 | 5 | module GitHub.Endpoints.Repos.Collaborators ( 6 | collaboratorsOnR, 7 | collaboratorPermissionOnR, 8 | isCollaboratorOnR, 9 | addCollaboratorR, 10 | module GitHub.Data, 11 | ) where 12 | 13 | import GitHub.Data 14 | import GitHub.Internal.Prelude 15 | import Prelude () 16 | 17 | -- | List collaborators. 18 | -- See 19 | collaboratorsOnR :: Name Owner -> Name Repo -> FetchCount -> Request k (Vector SimpleUser) 20 | collaboratorsOnR user repo = 21 | pagedQuery ["repos", toPathPart user, toPathPart repo, "collaborators"] [] 22 | 23 | -- | Review a user's permission level. 24 | -- 25 | collaboratorPermissionOnR 26 | :: Name Owner -- ^ Repository owner 27 | -> Name Repo -- ^ Repository name 28 | -> Name User -- ^ Collaborator to check permissions of. 29 | -> GenRequest 'MtJSON rw CollaboratorWithPermission 30 | collaboratorPermissionOnR owner repo coll = 31 | query ["repos", toPathPart owner, toPathPart repo, "collaborators", toPathPart coll, "permission"] [] 32 | 33 | -- | Check if a user is a collaborator. 34 | -- See 35 | isCollaboratorOnR 36 | :: Name Owner -- ^ Repository owner 37 | -> Name Repo -- ^ Repository name 38 | -> Name User -- ^ Collaborator? 39 | -> GenRequest 'MtStatus rw Bool 40 | isCollaboratorOnR user repo coll = 41 | Query ["repos", toPathPart user, toPathPart repo, "collaborators", toPathPart coll] [] 42 | 43 | -- | Invite a user as a collaborator. 44 | -- See 45 | addCollaboratorR 46 | :: Name Owner -- ^ Repository owner 47 | -> Name Repo -- ^ Repository name 48 | -> Name User -- ^ Collaborator to add 49 | -> GenRequest 'MtJSON 'RW (Maybe RepoInvitation) 50 | addCollaboratorR owner repo coll = 51 | Command Put ["repos", toPathPart owner, toPathPart repo, "collaborators", toPathPart coll] mempty 52 | -------------------------------------------------------------------------------- /src/GitHub/Endpoints/Repos/Comments.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- The repo commits API as described on 3 | -- . 4 | 5 | module GitHub.Endpoints.Repos.Comments ( 6 | commentsForR, 7 | commitCommentsForR, 8 | commitCommentForR, 9 | module GitHub.Data, 10 | ) where 11 | 12 | import GitHub.Data 13 | import GitHub.Internal.Prelude 14 | import Prelude () 15 | 16 | -- | List commit comments for a repository. 17 | -- See 18 | commentsForR :: Name Owner -> Name Repo -> FetchCount -> Request k (Vector Comment) 19 | commentsForR user repo = 20 | pagedQuery ["repos", toPathPart user, toPathPart repo, "comments"] [] 21 | 22 | -- | List comments for a single commit. 23 | -- See 24 | commitCommentsForR :: Name Owner -> Name Repo -> Name Commit -> FetchCount -> Request k (Vector Comment) 25 | commitCommentsForR user repo sha = 26 | pagedQuery ["repos", toPathPart user, toPathPart repo, "commits", toPathPart sha, "comments"] [] 27 | 28 | -- | Query a single commit comment. 29 | -- See 30 | commitCommentForR :: Name Owner -> Name Repo -> Id Comment -> Request k Comment 31 | commitCommentForR user repo cid = 32 | query ["repos", toPathPart user, toPathPart repo, "comments", toPathPart cid] [] 33 | -------------------------------------------------------------------------------- /src/GitHub/Endpoints/Repos/DeployKeys.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- License : BSD-3-Clause 4 | -- Maintainer : Todd Mohney 5 | -- 6 | -- The deploy keys API, as described at 7 | -- 8 | module GitHub.Endpoints.Repos.DeployKeys ( 9 | -- * Querying deploy keys 10 | deployKeysForR, 11 | deployKeyForR, 12 | 13 | -- ** Create 14 | createRepoDeployKeyR, 15 | 16 | -- ** Delete 17 | deleteRepoDeployKeyR, 18 | ) where 19 | 20 | import GitHub.Data 21 | import GitHub.Internal.Prelude 22 | import Prelude () 23 | 24 | -- | Querying deploy keys. 25 | -- See 26 | deployKeysForR :: Name Owner -> Name Repo -> FetchCount -> Request 'RA (Vector RepoDeployKey) 27 | deployKeysForR user repo = 28 | pagedQuery ["repos", toPathPart user, toPathPart repo, "keys"] [] 29 | 30 | -- | Querying a deploy key. 31 | -- See 32 | deployKeyForR :: Name Owner -> Name Repo -> Id RepoDeployKey -> Request 'RA RepoDeployKey 33 | deployKeyForR user repo keyId = 34 | query ["repos", toPathPart user, toPathPart repo, "keys", toPathPart keyId] [] 35 | 36 | -- | Create a deploy key. 37 | -- See . 38 | createRepoDeployKeyR :: Name Owner -> Name Repo -> NewRepoDeployKey -> Request 'RW RepoDeployKey 39 | createRepoDeployKeyR user repo key = 40 | command Post ["repos", toPathPart user, toPathPart repo, "keys"] (encode key) 41 | 42 | -- | Delete a deploy key. 43 | -- See 44 | deleteRepoDeployKeyR :: Name Owner -> Name Repo -> Id RepoDeployKey -> GenRequest 'MtUnit 'RW () 45 | deleteRepoDeployKeyR user repo keyId = 46 | Command Delete ["repos", toPathPart user, toPathPart repo, "keys", toPathPart keyId] mempty 47 | -------------------------------------------------------------------------------- /src/GitHub/Endpoints/Repos/Forks.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Hot forking action, as described at 3 | -- . 4 | 5 | module GitHub.Endpoints.Repos.Forks ( 6 | forksForR, 7 | module GitHub.Data, 8 | ) where 9 | 10 | import GitHub.Data 11 | import GitHub.Internal.Prelude 12 | import Prelude () 13 | 14 | -- | List forks. 15 | -- See 16 | forksForR :: Name Owner -> Name Repo -> FetchCount -> Request k (Vector Repo) 17 | forksForR user repo = 18 | pagedQuery ["repos", toPathPart user, toPathPart repo, "forks"] [] 19 | -------------------------------------------------------------------------------- /src/GitHub/Endpoints/Repos/Invitations.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- The repo invitations API as described on 3 | -- . 4 | 5 | module GitHub.Endpoints.Repos.Invitations ( 6 | listInvitationsOnR, 7 | listInvitationsForR, 8 | acceptInvitationFromR 9 | ) where 10 | 11 | import GitHub.Data 12 | import GitHub.Internal.Prelude 13 | import Prelude () 14 | 15 | -- | List open invitations of a repository 16 | -- See 17 | listInvitationsOnR :: Name Owner -> Name Repo -> FetchCount -> GenRequest 'MtJSON k (Vector RepoInvitation) 18 | listInvitationsOnR user repo = 19 | PagedQuery ["repos", toPathPart user, toPathPart repo, "invitations"] [] 20 | 21 | -- | List a user's repository invitations 22 | -- See 23 | listInvitationsForR :: FetchCount -> Request k (Vector RepoInvitation) 24 | listInvitationsForR = 25 | pagedQuery ["user", "repository_invitations"] [] 26 | 27 | 28 | -- | Accept a repository invitation 29 | -- See 30 | acceptInvitationFromR :: Id RepoInvitation -> GenRequest 'MtUnit 'RW () 31 | acceptInvitationFromR invId = 32 | Command Patch ["user", "repository_invitations", toPathPart invId] mempty 33 | -------------------------------------------------------------------------------- /src/GitHub/Endpoints/Repos/Releases.hs: -------------------------------------------------------------------------------- 1 | -- The Release API, as described at 2 | -- . 3 | module GitHub.Endpoints.Repos.Releases ( 4 | releasesR, 5 | releaseR, 6 | latestReleaseR, 7 | releaseByTagNameR, 8 | module GitHub.Data, 9 | ) where 10 | 11 | import GitHub.Data 12 | import GitHub.Internal.Prelude 13 | import Prelude () 14 | 15 | -- | List releases for a repository. 16 | -- See 17 | releasesR :: Name Owner -> Name Repo -> FetchCount -> Request k (Vector Release) 18 | releasesR user repo = 19 | pagedQuery ["repos", toPathPart user, toPathPart repo, "releases"] [] 20 | 21 | -- | Get a single release. 22 | -- See 23 | releaseR :: Name Owner -> Name Repo -> Id Release -> Request k Release 24 | releaseR user repo reqReleaseId = 25 | query ["repos", toPathPart user, toPathPart repo, "releases", toPathPart reqReleaseId ] [] 26 | 27 | -- | Get the latest release. 28 | -- See 29 | latestReleaseR :: Name Owner -> Name Repo -> Request k Release 30 | latestReleaseR user repo = 31 | query ["repos", toPathPart user, toPathPart repo, "releases", "latest" ] [] 32 | 33 | -- | Get a release by tag name 34 | -- See 35 | releaseByTagNameR :: Name Owner -> Name Repo -> Text -> Request k Release 36 | releaseByTagNameR user repo reqTagName = 37 | query ["repos", toPathPart user, toPathPart repo, "releases", "tags" , reqTagName ] [] 38 | 39 | {- 40 | -- TODO: implement the following: 41 | https://developer.github.com/v3/repos/releases/#create-a-release 42 | https://developer.github.com/v3/repos/releases/#edit-a-release 43 | https://developer.github.com/v3/repos/releases/#delete-a-release 44 | https://developer.github.com/v3/repos/releases/#list-assets-for-a-release 45 | https://developer.github.com/v3/repos/releases/#upload-a-release-asset 46 | https://developer.github.com/v3/repos/releases/#get-a-single-release-asset 47 | https://developer.github.com/v3/repos/releases/#edit-a-release-asset 48 | https://developer.github.com/v3/repos/releases/#delete-a-release-asset 49 | -} 50 | -------------------------------------------------------------------------------- /src/GitHub/Endpoints/Repos/Statuses.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- The repo statuses API as described on 3 | -- . 4 | 5 | module GitHub.Endpoints.Repos.Statuses ( 6 | createStatusR, 7 | statusesForR, 8 | statusForR, 9 | module GitHub.Data 10 | ) where 11 | 12 | import GitHub.Data 13 | import GitHub.Internal.Prelude 14 | import Prelude () 15 | 16 | -- | Create a new status 17 | -- See 18 | createStatusR :: Name Owner -> Name Repo -> Name Commit -> NewStatus -> Request 'RW Status 19 | createStatusR owner repo sha = 20 | command Post parts . encode 21 | where 22 | parts = ["repos", toPathPart owner, toPathPart repo, "statuses", toPathPart sha] 23 | 24 | -- | All statuses for a commit 25 | -- See 26 | statusesForR :: Name Owner -> Name Repo -> Name Commit -> FetchCount -> Request 'RW (Vector Status) 27 | statusesForR user repo sha = 28 | pagedQuery ["repos", toPathPart user, toPathPart repo, "commits", toPathPart sha, "statuses"] [] 29 | 30 | -- | The combined status for a specific commit 31 | -- See 32 | statusForR :: Name Owner -> Name Repo -> Name Commit -> Request 'RW CombinedStatus 33 | statusForR user repo sha = 34 | query ["repos", toPathPart user, toPathPart repo, "commits", toPathPart sha, "status"] [] 35 | -------------------------------------------------------------------------------- /src/GitHub/Endpoints/Search.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- The Github Search API, as described at 3 | -- . 4 | 5 | module GitHub.Endpoints.Search( 6 | searchReposR, 7 | searchCodeR, 8 | searchIssuesR, 9 | searchUsersR, 10 | module GitHub.Data, 11 | ) where 12 | 13 | import GitHub.Data 14 | import GitHub.Internal.Prelude 15 | import Prelude () 16 | 17 | import qualified Data.Text.Encoding as TE 18 | 19 | -- | Search repositories. 20 | -- See 21 | searchReposR :: Text -> FetchCount -> Request k (SearchResult Repo) 22 | searchReposR searchString = 23 | PagedQuery ["search", "repositories"] [("q", Just $ TE.encodeUtf8 searchString)] 24 | 25 | -- | Search code. 26 | -- See 27 | searchCodeR :: Text -> FetchCount -> Request k (SearchResult Code) 28 | searchCodeR searchString = 29 | PagedQuery ["search", "code"] [("q", Just $ TE.encodeUtf8 searchString)] 30 | 31 | -- | Search issues. 32 | -- See 33 | searchIssuesR :: Text -> FetchCount -> Request k (SearchResult Issue) 34 | searchIssuesR searchString = 35 | PagedQuery ["search", "issues"] [("q", Just $ TE.encodeUtf8 searchString)] 36 | 37 | -- | Search users. 38 | -- See 39 | searchUsersR :: Text -> FetchCount -> Request k (SearchResult SimpleUser) 40 | searchUsersR searchString = 41 | PagedQuery ["search", "users"] [("q", Just $ TE.encodeUtf8 searchString)] 42 | -------------------------------------------------------------------------------- /src/GitHub/Endpoints/Users.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- The Github Users API, as described at 3 | -- . 4 | 5 | module GitHub.Endpoints.Users ( 6 | userInfoForR, 7 | ownerInfoForR, 8 | userInfoCurrentR, 9 | module GitHub.Data, 10 | ) where 11 | 12 | import GitHub.Data 13 | import Prelude () 14 | 15 | -- | Query a single user. 16 | -- See 17 | -- 18 | -- >>> github' userInfoForR "mike-burns" 19 | -- 20 | -- or 21 | -- 22 | -- >>> github userInfoForR (OAuth "github-token") "mike-burns" 23 | -- 24 | userInfoForR :: Name User -> Request k User 25 | userInfoForR user = query ["users", toPathPart user] [] 26 | 27 | -- | Query a single user or an organization. 28 | -- See 29 | ownerInfoForR :: Name Owner -> Request k Owner 30 | ownerInfoForR owner = query ["users", toPathPart owner] [] 31 | 32 | -- | Query the authenticated user. 33 | -- See 34 | userInfoCurrentR :: Request 'RA User 35 | userInfoCurrentR = query ["user"] [] 36 | -------------------------------------------------------------------------------- /src/GitHub/Endpoints/Users/Emails.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- The user emails API as described on 3 | -- . 4 | 5 | module GitHub.Endpoints.Users.Emails ( 6 | currentUserEmailsR, 7 | currentUserPublicEmailsR, 8 | module GitHub.Data, 9 | ) where 10 | 11 | import GitHub.Data 12 | import GitHub.Internal.Prelude 13 | import Prelude () 14 | 15 | -- | List email addresses. 16 | -- See 17 | currentUserEmailsR :: FetchCount -> Request 'RA (Vector Email) 18 | currentUserEmailsR = 19 | pagedQuery ["user", "emails"] [] 20 | 21 | -- | List public email addresses. 22 | -- See 23 | currentUserPublicEmailsR :: FetchCount -> Request 'RA (Vector Email) 24 | currentUserPublicEmailsR = 25 | pagedQuery ["user", "public_emails"] [] 26 | -------------------------------------------------------------------------------- /src/GitHub/Endpoints/Users/Followers.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- The user followers API as described on 3 | -- . 4 | 5 | module GitHub.Endpoints.Users.Followers ( 6 | usersFollowingR, 7 | usersFollowedByR, 8 | module GitHub.Data, 9 | ) where 10 | 11 | import GitHub.Data 12 | import GitHub.Internal.Prelude 13 | import Prelude () 14 | 15 | -- | List followers of a user. 16 | -- See 17 | usersFollowingR :: Name User -> FetchCount -> Request k (Vector SimpleUser) 18 | usersFollowingR user = 19 | pagedQuery ["users", toPathPart user, "followers"] [] 20 | 21 | -- | List users followed by another user. 22 | -- See 23 | usersFollowedByR :: Name User -> FetchCount -> Request k (Vector SimpleUser) 24 | usersFollowedByR user = 25 | pagedQuery ["users", toPathPart user, "following"] [] 26 | -------------------------------------------------------------------------------- /src/GitHub/Endpoints/Users/PublicSSHKeys.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- License : BSD-3-Clause 4 | -- Maintainer : Todd Mohney 5 | -- 6 | -- The public keys API, as described at 7 | -- 8 | module GitHub.Endpoints.Users.PublicSSHKeys ( 9 | -- * Querying public SSH keys 10 | publicSSHKeysR, 11 | publicSSHKeysForR, 12 | publicSSHKeyR, 13 | 14 | -- ** Create 15 | createUserPublicSSHKeyR, 16 | 17 | -- ** Delete 18 | deleteUserPublicSSHKeyR, 19 | ) where 20 | 21 | import GitHub.Data 22 | import GitHub.Internal.Prelude 23 | import Prelude () 24 | 25 | -- | Querying public SSH keys. 26 | -- See 27 | publicSSHKeysForR :: Name Owner -> FetchCount -> Request 'RO (Vector PublicSSHKeyBasic) 28 | publicSSHKeysForR user = 29 | pagedQuery ["users", toPathPart user, "keys"] [] 30 | 31 | -- | Querying the authenticated users' public SSH keys 32 | -- See 33 | publicSSHKeysR :: Request 'RA (Vector PublicSSHKey) 34 | publicSSHKeysR = 35 | query ["user", "keys"] [] 36 | 37 | -- | Querying a public SSH key. 38 | -- See 39 | publicSSHKeyR :: Id PublicSSHKey -> Request 'RA PublicSSHKey 40 | publicSSHKeyR keyId = 41 | query ["user", "keys", toPathPart keyId] [] 42 | 43 | -- | Create a public SSH key. 44 | -- See . 45 | createUserPublicSSHKeyR :: NewPublicSSHKey -> Request 'RW PublicSSHKey 46 | createUserPublicSSHKeyR key = 47 | command Post ["user", "keys"] (encode key) 48 | 49 | -- | Delete a public SSH key. 50 | -- See 51 | deleteUserPublicSSHKeyR :: Id PublicSSHKey -> GenRequest 'MtUnit 'RW () 52 | deleteUserPublicSSHKeyR keyId = 53 | Command Delete ["user", "keys", toPathPart keyId] mempty 54 | -------------------------------------------------------------------------------- /src/GitHub/Enterprise.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- This module re-exports all request constructors and data definitions for 3 | -- working with GitHub Enterprise. 4 | 5 | module GitHub.Enterprise ( 6 | -- * Enterprise Admin 7 | -- | See 8 | 9 | -- ** Organizations 10 | -- | See 11 | createOrganizationR, 12 | renameOrganizationR, 13 | 14 | -- * Data definitions 15 | module GitHub.Data.Enterprise, 16 | ) where 17 | 18 | import GitHub.Data.Enterprise 19 | import GitHub.Endpoints.Enterprise.Organizations 20 | -------------------------------------------------------------------------------- /src/GitHub/Internal/Prelude.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | 3 | -- | 4 | -- This module may change between minor releases. Do not rely on its contents. 5 | 6 | module GitHub.Internal.Prelude ( module X ) where 7 | 8 | import Control.Applicative as X ((<|>)) 9 | import Control.DeepSeq as X (NFData (..)) 10 | import Control.DeepSeq.Generics as X (genericRnf) 11 | import Data.Aeson as X 12 | (FromJSON (..), Object, ToJSON (..), Value (..), encode, object, 13 | withObject, withText, (.!=), (.:), (.:?), (.=)) 14 | import Data.Aeson.Types as X (emptyObject, typeMismatch) 15 | import Data.Binary as X (Binary) 16 | import Data.Binary.Instances as X () 17 | import Data.Data as X (Data, Typeable) 18 | import Data.Foldable as X (toList) 19 | import Data.Hashable as X (Hashable (..)) 20 | import Data.HashMap.Strict as X (HashMap) 21 | import Data.List as X (intercalate) 22 | import Data.Maybe as X (catMaybes) 23 | import Data.Semigroup as X (Semigroup (..)) 24 | import Data.String as X (IsString (..)) 25 | import Data.Text as X (Text, pack, unpack) 26 | import Data.Time as X (UTCTime) 27 | import Data.Time.ISO8601 as X (formatISO8601) 28 | import Data.Vector as X (Vector) 29 | import GHC.Generics as X (Generic) 30 | import Prelude.Compat as X 31 | import Data.Functor.Compat as X ((<&>)) 32 | --------------------------------------------------------------------------------