diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,32 @@ ## Changes for next +## Changes for 0.22 + +- Type-class for various auth methods + [#365](https://github.com/phadej/github/pull/365) +- Throw on non-200 responses + [#350](https://github.com/phadej/github/pull/350) +- Add extension point for (preview) media types + [#370](https://github.com/phadej/github/pull/370) +- Add missing webhook event types + [#359](https://github.com/phadej/github/pull/359) +- Add invitation endpoint + [#360](https://github.com/phadej/github/pull/360) +- Add notifications endpoints + [#324](https://github.com/phadej/github/pull/324) +- Add ssh keys endpoints + [#363](https://github.com/phadej/github/pull/365) +- Case insensitive enum parsing + [#373](https://github.com/phadej/github/pull/373) +- Don't try parse unitary responses + [#377](https://github.com/phadej/github/issues/377) +- Update dependencies + [#364](https://github.com/phadej/github/pull/364) + [#368](https://github.com/phadej/github/pull/368) + [#369](https://github.com/phadej/github/pull/369) +- Documentation improvements + [#357](https://github.com/phadej/github/pull/357) + ## Changes for 0.21 - Refactor `Request` type. diff --git a/github.cabal b/github.cabal --- a/github.cabal +++ b/github.cabal @@ -1,6 +1,6 @@ cabal-version: >=1.10 name: github -version: 0.21 +version: 0.22 synopsis: Access to the GitHub API, v3. category: Network description: @@ -15,7 +15,7 @@ > > main :: IO () > main = do - > possibleUser <- GH.executeRequest' $ GH.userInfoR "phadej" + > possibleUser <- GH.executeRequest' $ GH.userInfoForR "phadej" > print possibleUser . For more of an overview please see the README: @@ -30,7 +30,7 @@ Copyright 2012-2013 Mike Burns, Copyright 2013-2015 John Wiegley, Copyright 2016-2019 Oleg Grenrus tested-with: - ghc ==7.8.4 || ==7.10.3 || ==8.0.2 || ==8.2.2 || ==8.4.3 || ==8.6.3 + GHC ==7.8.4 || ==7.10.3 || ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.1 extra-source-files: README.md @@ -47,6 +47,11 @@ type: git location: git://github.com/phadej/github.git +flag openssl + description: "Use http-client-openssl" + manual: True + default: False + library default-language: Haskell2010 ghc-options: -Wall @@ -87,6 +92,7 @@ GitHub.Data.Milestone GitHub.Data.Name GitHub.Data.Options + GitHub.Data.PublicSSHKeys GitHub.Data.PullRequests GitHub.Data.RateLimit GitHub.Data.Releases @@ -101,6 +107,7 @@ GitHub.Data.Webhooks.Validate GitHub.Endpoints.Activity.Events GitHub.Endpoints.Activity.Starring + GitHub.Endpoints.Activity.Notifications GitHub.Endpoints.Activity.Watching GitHub.Endpoints.Gists GitHub.Endpoints.Gists.Comments @@ -131,10 +138,12 @@ GitHub.Endpoints.Repos.Releases GitHub.Endpoints.Repos.Statuses GitHub.Endpoints.Repos.Webhooks + GitHub.Endpoints.Repos.Invitations GitHub.Endpoints.Search GitHub.Endpoints.Users GitHub.Endpoints.Users.Emails GitHub.Endpoints.Users.Followers + GitHub.Endpoints.Users.PublicSSHKeys GitHub.Internal.Prelude GitHub.Request @@ -155,32 +164,43 @@ aeson >=1.4.0.0 && <1.5 , base-compat >=0.10.4 && <0.11 , base16-bytestring >=0.1.1.6 && <0.2 - , binary-orphans >=0.1.8.0 && <0.2 + , binary-instances >=1 && <1.1 , cryptohash-sha1 >=0.11.100.1 && <0.12 , deepseq-generics >=0.2.0.0 && <0.3 - , exceptions >=0.10.0 && <0.11 - , hashable >=1.2.7.0 && <1.3 + , exceptions >=0.10.2 && <0.11 + , hashable >=1.2.7.0 && <1.4 , http-client >=0.5.12 && <0.7 - , http-client-tls >=0.3.5.3 && <0.4 , http-link-header >=1.0.3.1 && <1.1 - , http-types >=0.12.1 && <0.13 + , http-types >=0.12.3 && <0.13 , iso8601-time >=0.1.5 && <0.2 , network-uri >=2.6.1.0 && <2.7 - , semigroups >=0.18.5 && <0.19 - , tagged - , tls >=1.4.1 - , transformers-compat >=0.6 && <0.7 - , unordered-containers >=0.2.9.0 && <0.3 + , tagged >=0.8.5 && <0.9 + , transformers-compat >=0.6.5 && <0.7 + , unordered-containers >=0.2.10.0 && <0.3 , vector >=0.12.0.1 && <0.13 , vector-instances >=3.4 && <3.5 + if flag(openssl) + build-depends: + http-client-openssl >=0.3.0.0 && <0.4 + , HsOpenSSL >=0.11.4.16 && <0.12 + , HsOpenSSL-x509-system >=0.1.0.3 && <0.2 + else + build-depends: + http-client-tls >=0.3.5.3 && <0.4 + , tls >=1.4.1 + + if !impl(ghc >= 8.0) + build-depends: + semigroups >=0.18.5 && <0.20 + test-suite github-test default-language: Haskell2010 type: exitcode-stdio-1.0 hs-source-dirs: spec main-is: Spec.hs - ghc-options: -Wall - build-tool-depends: hspec-discover:hspec-discover >=2.6.1 && <2.8 + ghc-options: -Wall -threaded + build-tool-depends: hspec-discover:hspec-discover >=2.7.1 && <2.8 other-extensions: TemplateHaskell other-modules: GitHub.ActivitySpec @@ -189,6 +209,7 @@ GitHub.IssuesSpec GitHub.OrganizationsSpec GitHub.PullRequestReviewsSpec + GitHub.PublicSSHKeysSpec GitHub.PullRequestsSpec GitHub.RateLimitSpec GitHub.ReleasesSpec @@ -203,6 +224,8 @@ , bytestring , file-embed , github + , tagged + , text , hspec >=2.6.1 && <2.8 , unordered-containers , vector diff --git a/spec/GitHub/PublicSSHKeysSpec.hs b/spec/GitHub/PublicSSHKeysSpec.hs new file mode 100644 --- /dev/null +++ b/spec/GitHub/PublicSSHKeysSpec.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +module GitHub.PublicSSHKeysSpec where + +import GitHub + (Auth (..), FetchCount (..), PublicSSHKey (..), executeRequest) +import GitHub.Endpoints.Users.PublicSSHKeys + (publicSSHKey', publicSSHKeys', publicSSHKeysForR) + +import Data.Either.Compat (isRight) +import Data.String (fromString) +import System.Environment (lookupEnv) +import Test.Hspec (Spec, describe, it, pendingWith, shouldSatisfy) + +import qualified Data.Vector as V + +fromRightS :: Show a => Either a b -> b +fromRightS (Right b) = b +fromRightS (Left a) = error $ "Expected a Right and got a Left" ++ show a + +withAuth :: (Auth -> IO ()) -> IO () +withAuth action = do + mtoken <- lookupEnv "GITHUB_TOKEN" + case mtoken of + Nothing -> pendingWith "no GITHUB_TOKEN" + Just token -> action (OAuth $ fromString token) + +spec :: Spec +spec = do + describe "publicSSHKeysFor'" $ do + it "works" $ withAuth $ \auth -> do + keys <- executeRequest auth $ publicSSHKeysForR "phadej" FetchAll + V.length (fromRightS keys) `shouldSatisfy` (> 1) + + describe "publicSSHKeys' and publicSSHKey'" $ do + it "works" $ withAuth $ \auth -> do + keys <- publicSSHKeys' auth + V.length (fromRightS keys) `shouldSatisfy` (> 1) + + key <- publicSSHKey' auth (publicSSHKeyId $ V.head (fromRightS keys)) + key `shouldSatisfy` isRight diff --git a/spec/GitHub/PullRequestsSpec.hs b/spec/GitHub/PullRequestsSpec.hs --- a/spec/GitHub/PullRequestsSpec.hs +++ b/spec/GitHub/PullRequestsSpec.hs @@ -1,21 +1,27 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} module GitHub.PullRequestsSpec where -import qualified GitHub +import qualified GitHub as GH import Prelude () import Prelude.Compat -import Data.Aeson (eitherDecodeStrict) -import Data.ByteString (ByteString) -import Data.Either.Compat (isRight) -import Data.FileEmbed (embedFile) -import Data.Foldable (for_) -import Data.String (fromString) -import qualified Data.Vector as V +import Data.Aeson + (FromJSON (..), eitherDecodeStrict, withObject, (.:)) +import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy.Char8 as LBS8 -import System.Environment (lookupEnv) +import Data.Either.Compat (isRight) +import Data.FileEmbed (embedFile) +import Data.Foldable (for_) +import Data.String (fromString) +import Data.Tagged (Tagged (..)) +import Data.Text (Text) +import qualified Data.Vector as V +import System.Environment (lookupEnv) import Test.Hspec (Spec, describe, it, pendingWith, shouldBe, shouldSatisfy) @@ -23,68 +29,75 @@ fromRightS (Right b) = b fromRightS (Left a) = error $ "Expected a Right and got a Left" ++ show a -withAuth :: (GitHub.Auth -> IO ()) -> IO () +withAuth :: (GH.Auth -> IO ()) -> IO () withAuth action = do mtoken <- lookupEnv "GITHUB_TOKEN" case mtoken of Nothing -> pendingWith "no GITHUB_TOKEN" - Just token -> action (GitHub.OAuth $ fromString token) + Just token -> action (GH.OAuth $ fromString token) spec :: Spec spec = do describe "pullRequestsForR" $ do it "works" $ withAuth $ \auth -> for_ repos $ \(owner, repo) -> do - cs <- GitHub.executeRequest auth $ - GitHub.pullRequestsForR owner repo opts GitHub.FetchAll + cs <- GH.executeRequest auth $ + GH.pullRequestsForR owner repo opts GH.FetchAll cs `shouldSatisfy` isRight describe "pullRequestPatchR" $ it "works" $ withAuth $ \auth -> do - Right patch <- GitHub.executeRequest auth $ - GitHub.pullRequestPatchR "phadej" "github" (GitHub.IssueNumber 349) + Right patch <- GH.executeRequest auth $ + GH.pullRequestPatchR "phadej" "github" (GH.IssueNumber 349) head (LBS8.lines patch) `shouldBe` "From c0e4ad33811be82e1f72ee76116345c681703103 Mon Sep 17 00:00:00 2001" describe "decoding pull request payloads" $ do it "decodes a pull request 'opened' payload" $ do - V.length (GitHub.simplePullRequestRequestedReviewers simplePullRequestOpened) + V.length (GH.simplePullRequestRequestedReviewers simplePullRequestOpened) `shouldBe` 0 - V.length (GitHub.pullRequestRequestedReviewers pullRequestOpened) + V.length (GH.pullRequestRequestedReviewers pullRequestOpened) `shouldBe` 0 it "decodes a pull request 'review_requested' payload" $ do - V.length (GitHub.simplePullRequestRequestedReviewers simplePullRequestReviewRequested) + V.length (GH.simplePullRequestRequestedReviewers simplePullRequestReviewRequested) `shouldBe` 1 - V.length (GitHub.pullRequestRequestedReviewers pullRequestReviewRequested) + V.length (GH.pullRequestRequestedReviewers pullRequestReviewRequested) `shouldBe` 1 describe "checking if a pull request is merged" $ do it "works" $ withAuth $ \auth -> do - b <- GitHub.executeRequest auth $ GitHub.isPullRequestMergedR "phadej" "github" (GitHub.IssueNumber 14) + b <- GH.executeRequest auth $ GH.isPullRequestMergedR "phadej" "github" (GH.IssueNumber 14) b `shouldSatisfy` isRight fromRightS b `shouldBe` True + describe "Draft Pull Request" $ do + it "works" $ withAuth $ \auth -> do + cs <- GH.executeRequest auth $ + draftPullRequestsForR "phadej" "github" opts GH.FetchAll + + cs `shouldSatisfy` isRight + where repos = [ ("thoughtbot", "paperclip") , ("phadej", "github") ] - opts = GitHub.stateClosed + opts = GH.stateClosed - simplePullRequestOpened :: GitHub.SimplePullRequest + simplePullRequestOpened :: GH.SimplePullRequest simplePullRequestOpened = fromRightS (eitherDecodeStrict prOpenedPayload) - pullRequestOpened :: GitHub.PullRequest + pullRequestOpened :: GH.PullRequest pullRequestOpened = fromRightS (eitherDecodeStrict prOpenedPayload) - simplePullRequestReviewRequested :: GitHub.SimplePullRequest + simplePullRequestReviewRequested :: GH.SimplePullRequest simplePullRequestReviewRequested = fromRightS (eitherDecodeStrict prReviewRequestedPayload) - pullRequestReviewRequested :: GitHub.PullRequest + pullRequestReviewRequested :: GH.PullRequest pullRequestReviewRequested = fromRightS (eitherDecodeStrict prReviewRequestedPayload) @@ -93,3 +106,41 @@ prReviewRequestedPayload :: ByteString prReviewRequestedPayload = $(embedFile "fixtures/pull-request-review-requested.json") + +------------------------------------------------------------------------------- +-- Draft Pull Requests +------------------------------------------------------------------------------- + +draftPullRequestsForR + :: GH.Name GH.Owner + -> GH.Name GH.Repo + -> GH.PullRequestMod + -> GH.FetchCount + -> GH.GenRequest ('GH.MtPreview ShadowCat) k (V.Vector DraftPR) +draftPullRequestsForR user repo opts = GH.PagedQuery + ["repos", GH.toPathPart user, GH.toPathPart repo, "pulls"] + (GH.prModToQueryString opts) + +data DraftPR = DraftPR + { dprId :: !(GH.Id GH.PullRequest) + , dprNumber :: !GH.IssueNumber + , dprTitle :: !Text + , dprDraft :: !Bool + } + deriving (Show) + +instance FromJSON DraftPR where + parseJSON = withObject "DraftPR" $ \obj -> DraftPR + <$> obj .: "id" + <*> obj .: "number" + <*> obj .: "title" + <*> obj .: "draft" + +-- | @application/vnd.github.shadow-cat-preview+json@ +data ShadowCat + +instance GH.PreviewAccept ShadowCat where + previewContentType = Tagged "application/vnd.github.shadow-cat-preview+json" + +instance FromJSON a => GH.PreviewParseResponse ShadowCat a where + previewParseResponse _ res = Tagged (GH.parseResponseJSON res) diff --git a/src/GitHub.hs b/src/GitHub.hs --- a/src/GitHub.hs +++ b/src/GitHub.hs @@ -7,7 +7,7 @@ -- this package. -- -- See "GitHub.Request" module for executing 'Request', or other modules --- of this package (e.g. "GitHub.Users") for already composed versions. +-- of this package (e.g. "GitHub.Endpoints.Users") for already composed versions. -- -- The missing endpoints lists show which endpoints we know are missing, there -- might be more. @@ -16,9 +16,16 @@ -- | See -- ** Events - -- | See https://developer.github.com/v3/activity/events/#events + -- | See repositoryEventsR, userEventsR, + + -- ** Notifications + -- | See + getNotificationsR, + markNotificationAsReadR, + markAllNotificationsAsReadR, + -- ** Starring -- | See -- @@ -312,6 +319,19 @@ latestReleaseR, releaseByTagNameR, + -- ** Invitations + -- | See + -- Missing endpoints: + + -- * Delete a repository invitation + -- * Update a repository invitation + -- * Decline a repository invitation + + listInvitationsOnR, + acceptInvitationFromR, + listInvitationsForR, + + -- * Search -- | See -- @@ -374,6 +394,7 @@ import GitHub.Data import GitHub.Endpoints.Activity.Events +import GitHub.Endpoints.Activity.Notifications import GitHub.Endpoints.Activity.Starring import GitHub.Endpoints.Activity.Watching import GitHub.Endpoints.Gists @@ -400,6 +421,7 @@ import GitHub.Endpoints.Repos.Commits import GitHub.Endpoints.Repos.Deployments import GitHub.Endpoints.Repos.Forks +import GitHub.Endpoints.Repos.Invitations import GitHub.Endpoints.Repos.Releases import GitHub.Endpoints.Repos.Statuses import GitHub.Endpoints.Repos.Webhooks diff --git a/src/GitHub/Auth.hs b/src/GitHub/Auth.hs --- a/src/GitHub/Auth.hs +++ b/src/GitHub/Auth.hs @@ -3,24 +3,48 @@ -- License : BSD-3-Clause -- Maintainer : Oleg Grenrus -- -module GitHub.Auth where +module GitHub.Auth ( + Auth (..), + AuthMethod, + endpoint, + setAuthRequest + ) where import GitHub.Internal.Prelude import Prelude () -import qualified Data.ByteString as BS +import qualified Data.ByteString as BS +import qualified Network.HTTP.Client as HTTP type Token = BS.ByteString -- | The Github auth data type data Auth - = BasicAuth BS.ByteString BS.ByteString - | OAuth Token -- ^ token - | EnterpriseOAuth Text -- custom API endpoint without - -- trailing slash - Token -- token + = BasicAuth BS.ByteString BS.ByteString -- ^ Username and password + | OAuth Token -- ^ OAuth token + | EnterpriseOAuth Text Token -- ^ Custom endpoint and OAuth token deriving (Show, Data, Typeable, Eq, Ord, Generic) instance NFData Auth where rnf = genericRnf instance Binary Auth instance Hashable Auth + +-- | A type class for different authentication methods +class AuthMethod a where + -- | Custom API endpoint without trailing slash + endpoint :: a -> Maybe Text + -- | A function which sets authorisation on an HTTP request + setAuthRequest :: a -> HTTP.Request -> HTTP.Request + +instance AuthMethod Auth where + endpoint (BasicAuth _ _) = Nothing + endpoint (OAuth _) = Nothing + endpoint (EnterpriseOAuth e _) = Just e + + setAuthRequest (BasicAuth u p) = HTTP.applyBasicAuth u p + setAuthRequest (OAuth t) = setAuthHeader $ "token " <> t + setAuthRequest (EnterpriseOAuth _ t) = setAuthHeader $ "token " <> t + +setAuthHeader :: BS.ByteString -> HTTP.Request -> HTTP.Request +setAuthHeader auth req = + req { HTTP.requestHeaders = ("Authorization", auth) : HTTP.requestHeaders req } diff --git a/src/GitHub/Data.hs b/src/GitHub/Data.hs --- a/src/GitHub/Data.hs +++ b/src/GitHub/Data.hs @@ -4,7 +4,7 @@ -- License : BSD-3-Clause -- Maintainer : Oleg Grenrus -- --- This module re-exports the @GitHub.Data.@ and "Github.Auth" submodules. +-- This module re-exports the @GitHub.Data.@ and "GitHub.Auth" submodules. module GitHub.Data ( -- * Tagged types -- ** Name @@ -48,6 +48,7 @@ module GitHub.Data.Issues, module GitHub.Data.Milestone, module GitHub.Data.Options, + module GitHub.Data.PublicSSHKeys, module GitHub.Data.PullRequests, module GitHub.Data.RateLimit, module GitHub.Data.Releases, @@ -81,6 +82,7 @@ import GitHub.Data.Milestone import GitHub.Data.Name import GitHub.Data.Options +import GitHub.Data.PublicSSHKeys import GitHub.Data.PullRequests import GitHub.Data.RateLimit import GitHub.Data.Releases diff --git a/src/GitHub/Data/Activities.hs b/src/GitHub/Data/Activities.hs --- a/src/GitHub/Data/Activities.hs +++ b/src/GitHub/Data/Activities.hs @@ -5,10 +5,15 @@ -- module GitHub.Data.Activities where -import GitHub.Data.Repos (Repo) +import GitHub.Data.Id (Id, mkId) +import GitHub.Data.Repos (Repo, RepoRef) +import GitHub.Data.URL (URL) import GitHub.Internal.Prelude + import Prelude () +import qualified Data.Text as T + data RepoStarred = RepoStarred { repoStarredStarredAt :: !UTCTime , repoStarredRepo :: !Repo @@ -23,4 +28,83 @@ parseJSON = withObject "RepoStarred" $ \o -> RepoStarred <$> o .: "starred_at" <*> o .: "repo" + +data Subject = Subject + { subjectTitle :: !Text + , subjectURL :: !URL + , subjectLatestCommentURL :: !(Maybe URL) + -- https://developer.github.com/v3/activity/notifications/ doesn't indicate + -- what the possible values for this field are. + -- TODO: Make an ADT for this. + , subjectType :: !Text + } + deriving (Show, Data, Typeable, Eq, Ord, Generic) + +instance NFData Subject where rnf = genericRnf +instance Binary Subject + +instance FromJSON Subject where + parseJSON = withObject "Subject" $ \o -> Subject + <$> o .: "title" + <*> o .: "url" + <*> o .:? "latest_comment_url" + <*> o .: "type" + +data NotificationReason + = AssignReason + | AuthorReason + | CommentReason + | InvitationReason + | ManualReason + | MentionReason + | ReviewRequestedReason + | StateChangeReason + | SubscribedReason + | TeamMentionReason + deriving (Show, Data, Enum, Bounded, Typeable, Eq, Ord, Generic) + +instance NFData NotificationReason where rnf = genericRnf +instance Binary NotificationReason + +instance FromJSON NotificationReason where + parseJSON = withText "NotificationReason" $ \t -> case T.toLower t of + "assign" -> pure AssignReason + "author" -> pure AuthorReason + "comment" -> pure CommentReason + "invitation" -> pure InvitationReason + "manual" -> pure ManualReason + "mention" -> pure MentionReason + "review_requested" -> pure ReviewRequestedReason + "state_change" -> pure StateChangeReason + "subscribed" -> pure SubscribedReason + "team_mention" -> pure TeamMentionReason + _ -> fail $ "Unknown NotificationReason " ++ show t + +data Notification = Notification + -- XXX: The notification id field type IS in fact string. Not sure why gh + -- chose to do this when all the other ids are Numbers... + { notificationId :: !(Id Notification) + , notificationRepo :: !RepoRef + , notificationSubject :: !Subject + , notificationReason :: !NotificationReason + , notificationUnread :: !Bool + , notificationUpdatedAt :: !(Maybe UTCTime) + , notificationLastReadAt :: !(Maybe UTCTime) + , notificationUrl :: !URL + } + deriving (Show, Data, Typeable, Eq, Ord, Generic) + +instance NFData Notification where rnf = genericRnf +instance Binary Notification + +instance FromJSON Notification where + parseJSON = withObject "Notification" $ \o -> Notification + <$> (mkId undefined . read <$> o .: "id") + <*> o .: "repository" + <*> o .: "subject" + <*> o .: "reason" + <*> o .: "unread" + <*> o .: "updated_at" + <*> o .: "last_read_at" + <*> o .: "url" diff --git a/src/GitHub/Data/Content.hs b/src/GitHub/Data/Content.hs --- a/src/GitHub/Data/Content.hs +++ b/src/GitHub/Data/Content.hs @@ -6,13 +6,15 @@ -- module GitHub.Data.Content where -import Data.Aeson.Types (Pair) -import Data.Maybe (maybe) import GitHub.Data.GitData import GitHub.Data.URL import GitHub.Internal.Prelude import Prelude () +import Data.Aeson.Types (Pair) +import Data.Maybe (maybe) +import qualified Data.Text as T + data Content = ContentFile !ContentFileData | ContentDirectory !(Vector ContentItem) @@ -142,11 +144,10 @@ <*> parseJSON (Object o) instance FromJSON ContentItemType where - parseJSON = withText "ContentItemType" $ \t -> - case t of - "file" -> return ItemFile - "dir" -> return ItemDir - _ -> fail $ "Invalid ContentItemType: " ++ unpack t + parseJSON = withText "ContentItemType" $ \t -> case T.toLower t of + "file" -> pure ItemFile + "dir" -> pure ItemDir + _ -> fail $ "Unknown ContentItemType: " <> T.unpack t instance FromJSON ContentInfo where parseJSON = withObject "ContentInfo" $ \o -> diff --git a/src/GitHub/Data/Definitions.hs b/src/GitHub/Data/Definitions.hs --- a/src/GitHub/Data/Definitions.hs +++ b/src/GitHub/Data/Definitions.hs @@ -134,11 +134,10 @@ -- JSON instances instance FromJSON OwnerType where - parseJSON = withText "Owner type" $ \t -> - case t of - "User" -> pure $ OwnerUser - "Organization" -> pure $ OwnerOrganization - _ -> fail $ "Unknown owner type: " ++ T.unpack t + parseJSON = withText "OwnerType" $ \t -> case T.toLower t of + "user" -> pure $ OwnerUser + "organization" -> pure $ OwnerOrganization + _ -> fail $ "Unknown OwnerType: " <> T.unpack t instance FromJSON SimpleUser where parseJSON = withObject "SimpleUser" $ \obj -> do diff --git a/src/GitHub/Data/Deployments.hs b/src/GitHub/Data/Deployments.hs --- a/src/GitHub/Data/Deployments.hs +++ b/src/GitHub/Data/Deployments.hs @@ -27,8 +27,8 @@ import GitHub.Internal.Prelude import qualified Data.Aeson as JSON -import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text +import qualified Data.Text as T +import qualified Data.Text.Encoding as T data DeploymentQueryOption = DeploymentQuerySha !Text @@ -42,7 +42,7 @@ renderDeploymentQueryOption :: DeploymentQueryOption -> (ByteString, ByteString) renderDeploymentQueryOption = - second Text.encodeUtf8 . \case + second T.encodeUtf8 . \case DeploymentQuerySha sha -> ("sha", sha) DeploymentQueryRef ref -> ("ref", ref) DeploymentQueryTask task -> ("task", task) @@ -172,13 +172,13 @@ DeploymentStatusInactive -> "inactive" instance FromJSON DeploymentStatusState where - parseJSON = withText "GitHub DeploymentStatusState" $ \case + parseJSON = withText "DeploymentStatusState" $ \t -> case T.toLower t of "error" -> pure DeploymentStatusError "failure" -> pure DeploymentStatusFailure "pending" -> pure DeploymentStatusPending "success" -> pure DeploymentStatusSuccess "inactive" -> pure DeploymentStatusInactive - x -> fail $ "Unknown deployment status: " ++ Text.unpack x + _ -> fail $ "Unknown DeploymentStatusState: " <> T.unpack t data CreateDeploymentStatus = CreateDeploymentStatus { createDeploymentStatusState :: !DeploymentStatusState diff --git a/src/GitHub/Data/Email.hs b/src/GitHub/Data/Email.hs --- a/src/GitHub/Data/Email.hs +++ b/src/GitHub/Data/Email.hs @@ -8,6 +8,8 @@ import GitHub.Internal.Prelude import Prelude () +import qualified Data.Text as T + data EmailVisibility = EmailVisibilityPrivate | EmailVisibilityPublic @@ -17,9 +19,10 @@ instance Binary EmailVisibility instance FromJSON EmailVisibility where - parseJSON (String "private") = pure EmailVisibilityPrivate - parseJSON (String "public") = pure EmailVisibilityPublic - parseJSON _ = fail "Could not build an EmailVisibility" + parseJSON = withText "EmailVisibility" $ \t -> case T.toLower t of + "private" -> pure EmailVisibilityPrivate + "public" -> pure EmailVisibilityPublic + _ -> fail $ "Unknown EmailVisibility: " <> T.unpack t data Email = Email { emailAddress :: !Text diff --git a/src/GitHub/Data/Invitation.hs b/src/GitHub/Data/Invitation.hs --- a/src/GitHub/Data/Invitation.hs +++ b/src/GitHub/Data/Invitation.hs @@ -8,9 +8,13 @@ import GitHub.Data.Definitions import GitHub.Data.Id (Id) import GitHub.Data.Name (Name) +import GitHub.Data.Repos (Repo) +import GitHub.Data.URL (URL) import GitHub.Internal.Prelude import Prelude () +import qualified Data.Text as T + data Invitation = Invitation { invitationId :: !(Id Invitation) -- TODO: technically either one should be, maybe both. use `these` ? @@ -48,10 +52,36 @@ instance Binary InvitationRole instance FromJSON InvitationRole where - parseJSON = withText "InvirationRole" $ \t -> case t of + parseJSON = withText "InvitationRole" $ \t -> case T.toLower t of "direct_member" -> pure InvitationRoleDirectMember "admin" -> pure InvitationRoleAdmin "billing_manager" -> pure InvitationRoleBillingManager "hiring_manager" -> pure InvitationRoleHiringManager "reinstate" -> pure InvitationRoleReinstate - _ -> fail $ "Invalid role " ++ show t + _ -> fail $ "Unknown InvitationRole: " <> T.unpack t + +data RepoInvitation = RepoInvitation + { repoInvitationId :: !(Id RepoInvitation) + , repoInvitationInvitee :: !SimpleUser + , repoInvitationInviter :: !SimpleUser + , repoInvitationRepo :: !Repo + , repoInvitationUrl :: !URL + , repoInvitationCreatedAt :: !UTCTime + , repoInvitationPermission :: !Text + , repoInvitationHtmlUrl :: !URL + } + deriving (Show, Data, Typeable, Eq, Ord, Generic) + +instance NFData RepoInvitation where rnf = genericRnf +instance Binary RepoInvitation + +instance FromJSON RepoInvitation where + parseJSON = withObject "RepoInvitation" $ \o -> RepoInvitation + <$> o .: "id" + <*> o .: "invitee" + <*> o .: "inviter" + <*> o .: "repository" + <*> o .: "url" + <*> o .: "created_at" + <*> o .: "permissions" + <*> o .: "html_url" diff --git a/src/GitHub/Data/Issues.hs b/src/GitHub/Data/Issues.hs --- a/src/GitHub/Data/Issues.hs +++ b/src/GitHub/Data/Issues.hs @@ -15,6 +15,8 @@ import GitHub.Internal.Prelude import Prelude () +import qualified Data.Text as T + data Issue = Issue { issueClosedAt :: !(Maybe UTCTime) , issueUpdatedAt :: !UTCTime @@ -141,7 +143,7 @@ <*> o .:? "label" instance FromJSON EventType where - parseJSON = withText "EventType" $ \t -> case t of + parseJSON = withText "EventType" $ \t -> case T.toLower t of "closed" -> pure Closed "reopened" -> pure Reopened "subscribed" -> pure Subscribed @@ -169,7 +171,7 @@ "removed_from_project" -> pure RemovedFromProject "converted_note_to_issue" -> pure ConvertedNoteToIssue "unsubscribed" -> pure Unsubscribed -- not in api docs list - _ -> fail $ "Unknown EventType " ++ show t + _ -> fail $ "Unknown EventType: " <> T.unpack t instance FromJSON IssueComment where parseJSON = withObject "IssueComment" $ \o -> IssueComment diff --git a/src/GitHub/Data/Options.hs b/src/GitHub/Data/Options.hs --- a/src/GitHub/Data/Options.hs +++ b/src/GitHub/Data/Options.hs @@ -82,9 +82,10 @@ toJSON StateClosed = String "closed" instance FromJSON IssueState where - parseJSON (String "open") = pure StateOpen - parseJSON (String "closed") = pure StateClosed - parseJSON v = typeMismatch "IssueState" v + parseJSON = withText "IssueState" $ \t -> case T.toLower t of + "open" -> pure StateOpen + "closed" -> pure StateClosed + _ -> fail $ "Unknown IssueState: " <> T.unpack t instance NFData IssueState where rnf = genericRnf instance Binary IssueState @@ -109,13 +110,14 @@ toJSON StateBehind = String "behind" instance FromJSON MergeableState where - parseJSON (String "unknown") = pure StateUnknown - parseJSON (String "clean") = pure StateClean - parseJSON (String "dirty") = pure StateDirty - parseJSON (String "unstable") = pure StateUnstable - parseJSON (String "blocked") = pure StateBlocked - parseJSON (String "behind") = pure StateBehind - parseJSON v = typeMismatch "MergeableState" v + parseJSON = withText "MergeableState" $ \t -> case T.toLower t of + "unknown" -> pure StateUnknown + "clean" -> pure StateClean + "dirty" -> pure StateDirty + "unstable" -> pure StateUnstable + "blocked" -> pure StateBlocked + "behind" -> pure StateBehind + _ -> fail $ "Unknown MergeableState: " <> T.unpack t instance NFData MergeableState where rnf = genericRnf instance Binary MergeableState diff --git a/src/GitHub/Data/PublicSSHKeys.hs b/src/GitHub/Data/PublicSSHKeys.hs new file mode 100644 --- /dev/null +++ b/src/GitHub/Data/PublicSSHKeys.hs @@ -0,0 +1,60 @@ +----------------------------------------------------------------------------- +-- | +-- License : BSD-3-Clause +-- Maintainer : Todd Mohney +-- +module GitHub.Data.PublicSSHKeys where + +import GitHub.Data.Id (Id) +import GitHub.Data.URL (URL) +import GitHub.Internal.Prelude +import Prelude () + +data PublicSSHKeyBasic = PublicSSHKeyBasic + { basicPublicSSHKeyId :: !(Id PublicSSHKey) + , basicPublicSSHKeyKey :: !Text + } + deriving (Show, Data, Typeable, Eq, Ord, Generic) + +instance FromJSON PublicSSHKeyBasic where + parseJSON = withObject "PublicSSHKeyBasic" $ \o -> PublicSSHKeyBasic + <$> o .: "id" + <*> o .: "key" + +data PublicSSHKey = PublicSSHKey + { publicSSHKeyId :: !(Id PublicSSHKey) + , publicSSHKeyKey :: !Text + , publicSSHKeyUrl :: !URL + , publicSSHKeyTitle :: !Text + , publicSSHKeyVerified :: !Bool + , publicSSHKeyCreatedAt :: !(Maybe UTCTime) + , publicSSHKeyReadOnly :: !Bool + } + deriving (Show, Data, Typeable, Eq, Ord, Generic) + +instance FromJSON PublicSSHKey where + parseJSON = withObject "PublicSSHKey" $ \o -> PublicSSHKey + <$> o .: "id" + <*> o .: "key" + <*> o .: "url" + <*> o .: "title" + <*> o .: "verified" + <*> o .:? "created_at" + <*> o .: "read_only" + +data NewPublicSSHKey = NewPublicSSHKey + { newPublicSSHKeyKey :: !Text + , newPublicSSHKeyTitle :: !Text + } + deriving (Show, Data, Typeable, Eq, Ord, Generic) + +instance ToJSON NewPublicSSHKey where + toJSON (NewPublicSSHKey key title) = object + [ "key" .= key + , "title" .= title + ] + +instance FromJSON NewPublicSSHKey where + parseJSON = withObject "PublicSSHKey" $ \o -> NewPublicSSHKey + <$> o .: "key" + <*> o .: "title" diff --git a/src/GitHub/Data/PullRequests.hs b/src/GitHub/Data/PullRequests.hs --- a/src/GitHub/Data/PullRequests.hs +++ b/src/GitHub/Data/PullRequests.hs @@ -283,19 +283,19 @@ <*> o .: "sender" instance FromJSON PullRequestEventType where - parseJSON (String "opened") = pure PullRequestOpened - parseJSON (String "closed") = pure PullRequestClosed - parseJSON (String "synchronize") = pure PullRequestSynchronized - parseJSON (String "reopened") = pure PullRequestReopened - parseJSON (String "assigned") = pure PullRequestAssigned - parseJSON (String "unassigned") = pure PullRequestUnassigned - parseJSON (String "labeled") = pure PullRequestLabeled - parseJSON (String "unlabeled") = pure PullRequestUnlabeled - parseJSON (String "review_requested") = pure PullRequestReviewRequested - parseJSON (String "review_request_removed") = pure PullRequestReviewRequestRemoved - parseJSON (String "edited") = pure PullRequestEdited - parseJSON (String s) = fail $ "Unknown action type " <> T.unpack s - parseJSON v = typeMismatch "Could not build a PullRequestEventType" v + parseJSON = withText "PullRequestEventType" $ \t -> case T.toLower t of + "opened" -> pure PullRequestOpened + "closed" -> pure PullRequestClosed + "synchronize" -> pure PullRequestSynchronized + "reopened" -> pure PullRequestReopened + "assigned" -> pure PullRequestAssigned + "unassigned" -> pure PullRequestUnassigned + "labeled" -> pure PullRequestLabeled + "unlabeled" -> pure PullRequestUnlabeled + "review_requested" -> pure PullRequestReviewRequested + "review_request_removed" -> pure PullRequestReviewRequestRemoved + "edited" -> pure PullRequestEdited + _ -> fail $ "Unknown PullRequestEventType: " <> T.unpack t instance FromJSON PullRequestReference where parseJSON = withObject "PullRequestReference" $ \o -> PullRequestReference diff --git a/src/GitHub/Data/Request.hs b/src/GitHub/Data/Request.hs --- a/src/GitHub/Data/Request.hs +++ b/src/GitHub/Data/Request.hs @@ -26,7 +26,7 @@ Count, ) where -import GitHub.Data.Definitions (Count, QueryString, IssueNumber, unIssueNumber) +import GitHub.Data.Definitions (Count, IssueNumber, QueryString, unIssueNumber) import GitHub.Data.Id (Id, untagId) import GitHub.Data.Name (Name, untagName) import GitHub.Internal.Prelude @@ -105,17 +105,18 @@ -- MediaType ------------------------------------------------------------------------------- -data MediaType - = MtJSON -- ^ @application/vnd.github.v3+json@ - | MtRaw -- ^ @application/vnd.github.v3.raw@ - | MtDiff -- ^ @application/vnd.github.v3.diff@ - | MtPatch -- ^ @application/vnd.github.v3.patch@ - | MtSha -- ^ @application/vnd.github.v3.sha@ - | MtStar -- ^ @application/vnd.github.v3.star+json@ - | MtRedirect -- ^ - | MtStatus -- ^ Parse status - | MtUnit -- ^ Always succeeds - deriving (Eq, Ord, Read, Show, Enum, Bounded, Typeable, Data, Generic) +data MediaType a + = MtJSON -- ^ @application/vnd.github.v3+json@ + | MtRaw -- ^ @application/vnd.github.v3.raw@ + | MtDiff -- ^ @application/vnd.github.v3.diff@ + | MtPatch -- ^ @application/vnd.github.v3.patch@ + | MtSha -- ^ @application/vnd.github.v3.sha@ + | MtStar -- ^ @application/vnd.github.v3.star+json@ + | MtRedirect -- ^ + | MtStatus -- ^ Parse status + | MtUnit -- ^ Always succeeds + | MtPreview a -- ^ Some other (preview) type; this is an extension point. + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) ------------------------------------------------------------------------------ -- RW @@ -151,7 +152,7 @@ -- * @a@ is the result type -- -- /Note:/ 'Request' is not 'Functor' on purpose. -data GenRequest (mt :: MediaType) (rw :: RW) a where +data GenRequest (mt :: MediaType *) (rw :: RW) a where Query :: Paths -> QueryString -> GenRequest mt rw a PagedQuery :: Paths -> QueryString -> FetchCount -> GenRequest mt rw (Vector a) diff --git a/src/GitHub/Data/Reviews.hs b/src/GitHub/Data/Reviews.hs --- a/src/GitHub/Data/Reviews.hs +++ b/src/GitHub/Data/Reviews.hs @@ -1,12 +1,14 @@ module GitHub.Data.Reviews where -import Data.Text (Text) import GitHub.Data.Definitions (SimpleUser) import GitHub.Data.Id (Id) import GitHub.Data.URL (URL) import GitHub.Internal.Prelude import Prelude () +import Data.Text (Text) +import qualified Data.Text as T + data ReviewState = ReviewStatePending | ReviewStateApproved @@ -21,12 +23,13 @@ instance Binary ReviewState instance FromJSON ReviewState where - parseJSON (String "APPROVED") = pure ReviewStateApproved - parseJSON (String "PENDING") = pure ReviewStatePending - parseJSON (String "DISMISSED") = pure ReviewStateDismissed - parseJSON (String "COMMENTED") = pure ReviewStateCommented - parseJSON (String "CHANGES_REQUESTED") = pure ReviewStateChangesRequested - parseJSON _ = fail "Unexpected ReviewState" + parseJSON = withText "ReviewState" $ \t -> case T.toLower t of + "approved" -> pure ReviewStateApproved + "pending" -> pure ReviewStatePending + "dismissed" -> pure ReviewStateDismissed + "commented" -> pure ReviewStateCommented + "changes_requested" -> pure ReviewStateChangesRequested + _ -> fail $ "Unknown ReviewState: " <> T.unpack t data Review = Review { reviewBody :: !Text diff --git a/src/GitHub/Data/Statuses.hs b/src/GitHub/Data/Statuses.hs --- a/src/GitHub/Data/Statuses.hs +++ b/src/GitHub/Data/Statuses.hs @@ -14,6 +14,7 @@ import GitHub.Data.GitData (Commit) import GitHub.Data.Repos (RepoRef) +import qualified Data.Text as T data StatusState = StatusPending @@ -26,11 +27,12 @@ instance Binary StatusState instance FromJSON StatusState where - parseJSON (String "pending") = pure StatusPending - parseJSON (String "success") = pure StatusSuccess - parseJSON (String "error") = pure StatusError - parseJSON (String "failure") = pure StatusFailure - parseJSON _ = fail "Could not build a StatusState" + parseJSON = withText "StatusState" $ \t -> case T.toLower t of + "pending" -> pure StatusPending + "success" -> pure StatusSuccess + "error" -> pure StatusError + "failure" -> pure StatusFailure + _ -> fail $ "Unknown StatusState: " <> T.unpack t instance ToJSON StatusState where toJSON StatusPending = String "pending" diff --git a/src/GitHub/Data/Teams.hs b/src/GitHub/Data/Teams.hs --- a/src/GitHub/Data/Teams.hs +++ b/src/GitHub/Data/Teams.hs @@ -17,6 +17,8 @@ import GitHub.Internal.Prelude import Prelude () +import qualified Data.Text as T + data Privacy = PrivacyClosed | PrivacySecret @@ -200,42 +202,42 @@ object [ "permission" .= permission ] instance FromJSON Role where - parseJSON = withText "Attribute" $ \attr -> case attr of - "maintainer" -> return RoleMaintainer - "member" -> return RoleMember - _ -> fail $ "Unknown Role: " ++ show attr + parseJSON = withText "Role" $ \t -> case T.toLower t of + "maintainer" -> pure RoleMaintainer + "member" -> pure RoleMember + _ -> fail $ "Unknown Role: " <> T.unpack t instance ToJSON Role where toJSON RoleMaintainer = String "maintainer" toJSON RoleMember = String "member" +instance FromJSON Permission where + parseJSON = withText "Permission" $ \t -> case T.toLower t of + "pull" -> pure PermissionPull + "push" -> pure PermissionPush + "admin" -> pure PermissionAdmin + _ -> fail $ "Unknown Permission: " <> T.unpack t + instance ToJSON Permission where toJSON PermissionPull = "pull" toJSON PermissionPush = "push" toJSON PermissionAdmin = "admin" -instance FromJSON Permission where - parseJSON = withText "Permission Attribute" $ \attr -> case attr of - "pull" -> return PermissionPull - "push" -> return PermissionPush - "admin" -> return PermissionAdmin - _ -> fail $ "Unknown Permission Attribute: " ++ show attr - instance FromJSON Privacy where - parseJSON = withText "Privacy Attribute" $ \attr -> case attr of - "secret" -> return PrivacySecret - "closed" -> return PrivacyClosed - _ -> fail $ "Unknown Privacy Attribute: " ++ show attr + parseJSON = withText "Privacy" $ \t -> case T.toLower t of + "secret" -> pure PrivacySecret + "closed" -> pure PrivacyClosed + _ -> fail $ "Unknown Privacy: " <> T.unpack t instance ToJSON Privacy where toJSON PrivacySecret = String "secret" toJSON PrivacyClosed = String "closed" instance FromJSON ReqState where - parseJSON = withText "ReqState" $ \attr -> case attr of - "active" -> return StateActive - "pending" -> return StatePending - _ -> fail $ "Unknown ReqState: " ++ show attr + parseJSON = withText "ReqState" $ \t -> case T.toLower t of + "active" -> pure StateActive + "pending" -> pure StatePending + _ -> fail $ "Unknown ReqState: " <> T.unpack t instance ToJSON ReqState where toJSON StateActive = String "active" diff --git a/src/GitHub/Data/Webhooks.hs b/src/GitHub/Data/Webhooks.hs --- a/src/GitHub/Data/Webhooks.hs +++ b/src/GitHub/Data/Webhooks.hs @@ -11,6 +11,7 @@ import Prelude () import qualified Data.Map as M +import qualified Data.Text as T data RepoWebhook = RepoWebhook { repoWebhookUrl :: !URL @@ -29,28 +30,56 @@ instance NFData RepoWebhook where rnf = genericRnf instance Binary RepoWebhook +-- | See . data RepoWebhookEvent = WebhookWildcardEvent + | WebhookCheckRunEvent + | WebhookCheckSuiteEvent | WebhookCommitCommentEvent + | WebhookContentReferenceEvent | WebhookCreateEvent | WebhookDeleteEvent + | WebhookDeployKeyEvent | WebhookDeploymentEvent | WebhookDeploymentStatusEvent + | WebhookDownloadEvent + | WebhookFollowEvent | WebhookForkEvent + | WebhookForkApplyEvent + | WebhookGitHubAppAuthorizationEvent + | WebhookGistEvent | WebhookGollumEvent | WebhookInstallationEvent | WebhookInstallationRepositoriesEvent | WebhookIssueCommentEvent | WebhookIssuesEvent + | WebhookLabelEvent + | WebhookMarketplacePurchaseEvent | WebhookMemberEvent + | WebhookMembershipEvent + | WebhookMetaEvent + | WebhookMilestoneEvent + | WebhookOrganizationEvent + | WebhookOrgBlockEvent | WebhookPageBuildEvent | WebhookPingEvent + | WebhookProjectCardEvent + | WebhookProjectColumnEvent + | WebhookProjectEvent | WebhookPublicEvent - | WebhookPullRequestReviewCommentEvent | WebhookPullRequestEvent + | WebhookPullRequestReviewEvent + | WebhookPullRequestReviewCommentEvent | WebhookPushEvent + | WebhookRegistryPackageEvent | WebhookReleaseEvent + | WebhookRepositoryEvent + | WebhookRepositoryImportEvent + | WebhookRepositoryVulnerabilityAlertEvent + | WebhookSecurityAdvisoryEvent + | WebhookStarEvent | WebhookStatusEvent + | WebhookTeamEvent | WebhookTeamAddEvent | WebhookWatchEvent deriving (Show, Data, Typeable, Eq, Ord, Generic) @@ -104,55 +133,110 @@ -- JSON instances instance FromJSON RepoWebhookEvent where - parseJSON (String "*") = pure WebhookWildcardEvent - parseJSON (String "commit_comment") = pure WebhookCommitCommentEvent - parseJSON (String "create") = pure WebhookCreateEvent - parseJSON (String "delete") = pure WebhookDeleteEvent - parseJSON (String "deployment") = pure WebhookDeploymentEvent - parseJSON (String "deployment_status") = pure WebhookDeploymentStatusEvent - parseJSON (String "fork") = pure WebhookForkEvent - parseJSON (String "gollum") = pure WebhookGollumEvent - parseJSON (String "installation") = pure WebhookInstallationEvent - parseJSON (String "installation_repositories") = pure WebhookInstallationRepositoriesEvent - parseJSON (String "issue_comment") = pure WebhookIssueCommentEvent - parseJSON (String "issues") = pure WebhookIssuesEvent - parseJSON (String "member") = pure WebhookMemberEvent - parseJSON (String "page_build") = pure WebhookPageBuildEvent - parseJSON (String "ping") = pure WebhookPingEvent - parseJSON (String "public") = pure WebhookPublicEvent - parseJSON (String "pull_request_review_comment") = pure WebhookPullRequestReviewCommentEvent - parseJSON (String "pull_request") = pure WebhookPullRequestEvent - parseJSON (String "push") = pure WebhookPushEvent - parseJSON (String "release") = pure WebhookReleaseEvent - parseJSON (String "status") = pure WebhookStatusEvent - parseJSON (String "team_add") = pure WebhookTeamAddEvent - parseJSON (String "watch") = pure WebhookWatchEvent - parseJSON _ = fail "Could not build a Webhook event" + parseJSON = withText "RepoWebhookEvent" $ \t -> case T.toLower t of + "*" -> pure WebhookWildcardEvent + "check_run" -> pure WebhookCheckRunEvent + "check_suite" -> pure WebhookCheckSuiteEvent + "commit_comment" -> pure WebhookCommitCommentEvent + "content_reference" -> pure WebhookContentReferenceEvent + "create" -> pure WebhookCreateEvent + "delete" -> pure WebhookDeleteEvent + "deploy_key" -> pure WebhookDeployKeyEvent + "deployment" -> pure WebhookDeploymentEvent + "deployment_status" -> pure WebhookDeploymentStatusEvent + "download" -> pure WebhookDownloadEvent + "follow" -> pure WebhookFollowEvent + "fork" -> pure WebhookForkEvent + "fork_apply" -> pure WebhookForkApplyEvent + "github_app_authorization" -> pure WebhookGitHubAppAuthorizationEvent + "gist" -> pure WebhookGistEvent + "gollum" -> pure WebhookGollumEvent + "installation" -> pure WebhookInstallationEvent + "installation_repositories" -> pure WebhookInstallationRepositoriesEvent + "issue_comment" -> pure WebhookIssueCommentEvent + "issues" -> pure WebhookIssuesEvent + "label" -> pure WebhookLabelEvent + "marketplace_purchase" -> pure WebhookMarketplacePurchaseEvent + "member" -> pure WebhookMemberEvent + "membership" -> pure WebhookMembershipEvent + "meta" -> pure WebhookMetaEvent + "milestone" -> pure WebhookMilestoneEvent + "organization" -> pure WebhookOrganizationEvent + "org_block" -> pure WebhookOrgBlockEvent + "page_build" -> pure WebhookPageBuildEvent + "ping" -> pure WebhookPingEvent + "project_card" -> pure WebhookProjectCardEvent + "project_column" -> pure WebhookProjectColumnEvent + "project" -> pure WebhookProjectEvent + "public" -> pure WebhookPublicEvent + "pull_request" -> pure WebhookPullRequestEvent + "pull_request_review" -> pure WebhookPullRequestReviewEvent + "pull_request_review_comment" -> pure WebhookPullRequestReviewCommentEvent + "push" -> pure WebhookPushEvent + "registry_package" -> pure WebhookRegistryPackageEvent + "release" -> pure WebhookReleaseEvent + "repository" -> pure WebhookRepositoryEvent + "repository_import" -> pure WebhookRepositoryImportEvent + "repository_vulnerability_alert" -> pure WebhookRepositoryVulnerabilityAlertEvent + "security_advisory" -> pure WebhookSecurityAdvisoryEvent + "star" -> pure WebhookStarEvent + "status" -> pure WebhookStatusEvent + "team" -> pure WebhookTeamEvent + "team_add" -> pure WebhookTeamAddEvent + "watch" -> pure WebhookWatchEvent + _ -> fail $ "Unknown RepoWebhookEvent: " <> T.unpack t instance ToJSON RepoWebhookEvent where - toJSON WebhookWildcardEvent = String "*" - toJSON WebhookCommitCommentEvent = String "commit_comment" - toJSON WebhookCreateEvent = String "create" - toJSON WebhookDeleteEvent = String "delete" - toJSON WebhookDeploymentEvent = String "deployment" - toJSON WebhookDeploymentStatusEvent = String "deployment_status" - toJSON WebhookForkEvent = String "fork" - toJSON WebhookGollumEvent = String "gollum" - toJSON WebhookInstallationEvent = String "installation" - toJSON WebhookInstallationRepositoriesEvent = String "installation_repositories" - toJSON WebhookIssueCommentEvent = String "issue_comment" - toJSON WebhookIssuesEvent = String "issues" - toJSON WebhookMemberEvent = String "member" - toJSON WebhookPageBuildEvent = String "page_build" - toJSON WebhookPingEvent = String "ping" - toJSON WebhookPublicEvent = String "public" - toJSON WebhookPullRequestReviewCommentEvent = String "pull_request_review_comment" - toJSON WebhookPullRequestEvent = String "pull_request" - toJSON WebhookPushEvent = String "push" - toJSON WebhookReleaseEvent = String "release" - toJSON WebhookStatusEvent = String "status" - toJSON WebhookTeamAddEvent = String "team_add" - toJSON WebhookWatchEvent = String "watch" + toJSON WebhookWildcardEvent = String "*" + toJSON WebhookCheckRunEvent = String "check_run" + toJSON WebhookCheckSuiteEvent = String "check_suite" + toJSON WebhookCommitCommentEvent = String "commit_comment" + toJSON WebhookContentReferenceEvent = String "content_reference" + toJSON WebhookCreateEvent = String "create" + toJSON WebhookDeleteEvent = String "delete" + toJSON WebhookDeployKeyEvent = String "deploy_key" + toJSON WebhookDeploymentEvent = String "deployment" + toJSON WebhookDeploymentStatusEvent = String "deployment_status" + toJSON WebhookDownloadEvent = String "download" + toJSON WebhookFollowEvent = String "follow" + toJSON WebhookForkEvent = String "fork" + toJSON WebhookForkApplyEvent = String "fork_apply" + toJSON WebhookGitHubAppAuthorizationEvent = String "github_app_authorization" + toJSON WebhookGistEvent = String "gist" + toJSON WebhookGollumEvent = String "gollum" + toJSON WebhookInstallationEvent = String "installation" + toJSON WebhookInstallationRepositoriesEvent = String "installation_repositories" + toJSON WebhookIssueCommentEvent = String "issue_comment" + toJSON WebhookIssuesEvent = String "issues" + toJSON WebhookLabelEvent = String "label" + toJSON WebhookMarketplacePurchaseEvent = String "marketplace_purchase" + toJSON WebhookMemberEvent = String "member" + toJSON WebhookMembershipEvent = String "membership" + toJSON WebhookMetaEvent = String "meta" + toJSON WebhookMilestoneEvent = String "milestone" + toJSON WebhookOrganizationEvent = String "organization" + toJSON WebhookOrgBlockEvent = String "org_block" + toJSON WebhookPageBuildEvent = String "page_build" + toJSON WebhookPingEvent = String "ping" + toJSON WebhookProjectCardEvent = String "project_card" + toJSON WebhookProjectColumnEvent = String "project_column" + toJSON WebhookProjectEvent = String "project" + toJSON WebhookPublicEvent = String "public" + toJSON WebhookPullRequestEvent = String "pull_request" + toJSON WebhookPullRequestReviewEvent = String "pull_request_review" + toJSON WebhookPullRequestReviewCommentEvent = String "pull_request_review_comment" + toJSON WebhookPushEvent = String "push" + toJSON WebhookRegistryPackageEvent = String "registry_package" + toJSON WebhookReleaseEvent = String "release" + toJSON WebhookRepositoryEvent = String "repository" + toJSON WebhookRepositoryImportEvent = String "repository_import" + toJSON WebhookRepositoryVulnerabilityAlertEvent = String "repository_vulnerability_alert" + toJSON WebhookSecurityAdvisoryEvent = String "security_advisory" + toJSON WebhookStarEvent = String "star" + toJSON WebhookStatusEvent = String "status" + toJSON WebhookTeamEvent = String "team" + toJSON WebhookTeamAddEvent = String "team_add" + toJSON WebhookWatchEvent = String "watch" instance FromJSON RepoWebhook where parseJSON = withObject "RepoWebhook" $ \o -> RepoWebhook diff --git a/src/GitHub/Endpoints/Activity/Notifications.hs b/src/GitHub/Endpoints/Activity/Notifications.hs new file mode 100644 --- /dev/null +++ b/src/GitHub/Endpoints/Activity/Notifications.hs @@ -0,0 +1,45 @@ +----------------------------------------------------------------------------- +-- | +-- License : BSD-3-Clause +-- Maintainer : Oleg Grenrus +-- +-- The repo watching API as described on +-- . + +module GitHub.Endpoints.Activity.Notifications where + +import GitHub.Data +import GitHub.Internal.Prelude +import GitHub.Request +import Prelude () + +getNotifications :: Auth -> IO (Either Error (Vector Notification)) +getNotifications auth = + executeRequest auth $ getNotificationsR FetchAll + +-- | List your notifications. +-- See +getNotificationsR :: FetchCount -> Request 'RA (Vector Notification) +getNotificationsR = pagedQuery ["notifications"] [] + +markNotificationAsRead :: Auth -> Id Notification -> IO (Either Error ()) +markNotificationAsRead auth nid = + executeRequest auth $ markNotificationAsReadR nid + +-- | Mark a thread as read. +-- See +markNotificationAsReadR :: Id Notification -> GenRequest 'MtUnit 'RW () +markNotificationAsReadR nid = Command + Patch + ["notifications", "threads", toPathPart nid] + (encode ()) + +markNotificationsAsRead :: Auth -> IO (Either Error ()) +markNotificationsAsRead auth = + executeRequest auth markAllNotificationsAsReadR + +-- | Mark as read. +-- See +markAllNotificationsAsReadR :: GenRequest 'MtUnit 'RW () +markAllNotificationsAsReadR = + Command Put ["notifications"] $ encode emptyObject diff --git a/src/GitHub/Endpoints/Activity/Starring.hs b/src/GitHub/Endpoints/Activity/Starring.hs --- a/src/GitHub/Endpoints/Activity/Starring.hs +++ b/src/GitHub/Endpoints/Activity/Starring.hs @@ -91,7 +91,7 @@ -- | Unstar a repo by the authenticated user. -- See -unstarRepoR :: Name Owner -> Name Repo -> Request 'RW () -unstarRepoR user repo = command Delete paths mempty +unstarRepoR :: Name Owner -> Name Repo -> GenRequest 'MtUnit 'RW () +unstarRepoR user repo = Command Delete paths mempty where paths = ["user", "starred", toPathPart user, toPathPart repo] diff --git a/src/GitHub/Endpoints/Activity/Watching.hs b/src/GitHub/Endpoints/Activity/Watching.hs --- a/src/GitHub/Endpoints/Activity/Watching.hs +++ b/src/GitHub/Endpoints/Activity/Watching.hs @@ -30,7 +30,7 @@ -- | The list of users that are watching the specified Github repo. -- With authentication -- --- > watchersFor' (Just (User (user, password))) "thoughtbot" "paperclip" +-- > watchersFor' (Just $ BasicAuth "github-username" "github-password") "thoughtbot" "paperclip" watchersFor' :: Maybe Auth -> Name Owner -> Name Repo -> IO (Either Error (Vector SimpleUser)) watchersFor' auth user repo = executeRequestMaybe auth $ watchersForR user repo FetchAll @@ -50,7 +50,7 @@ -- | All the public repos watched by the specified user. -- With authentication -- --- > reposWatchedBy' (Just (User (user, password))) "croaky" +-- > reposWatchedBy' (Just $ BasicAuth "github-username" "github-password") "croaky" reposWatchedBy' :: Maybe Auth -> Name Owner -> IO (Either Error (Vector Repo)) reposWatchedBy' auth user = executeRequestMaybe auth $ reposWatchedByR user FetchAll diff --git a/src/GitHub/Endpoints/Gists.hs b/src/GitHub/Endpoints/Gists.hs --- a/src/GitHub/Endpoints/Gists.hs +++ b/src/GitHub/Endpoints/Gists.hs @@ -27,7 +27,7 @@ -- | The list of all gists created by the user -- --- > gists' (Just ("github-username", "github-password")) "mike-burns" +-- > gists' (Just $ BasicAuth "github-username" "github-password") "mike-burns" gists' :: Maybe Auth -> Name Owner -> IO (Either Error (Vector Gist)) gists' auth user = executeRequestMaybe auth $ gistsR user FetchAll @@ -45,7 +45,7 @@ -- | A specific gist, given its id, with authentication credentials -- --- > gist' (Just ("github-username", "github-password")) "225074" +-- > gist' (Just $ BasicAuth "github-username" "github-password") "225074" gist' :: Maybe Auth -> Name Gist -> IO (Either Error Gist) gist' auth gid = executeRequestMaybe auth $ gistR gid @@ -64,7 +64,7 @@ -- | Star a gist by the authenticated user. -- --- > starGist ("github-username", "github-password") "225074" +-- > starGist (BasicAuth "github-username" "github-password") "225074" starGist :: Auth -> Name Gist -> IO (Either Error ()) starGist auth gid = executeRequest auth $ starGistR gid @@ -75,22 +75,22 @@ -- | Unstar a gist by the authenticated user. -- --- > unstarGist ("github-username", "github-password") "225074" +-- > unstarGist (BasicAuth "github-username" "github-password") "225074" unstarGist :: Auth -> Name Gist -> IO (Either Error ()) unstarGist auth gid = executeRequest auth $ unstarGistR gid -- | Unstar a gist by the authenticated user. -- See -unstarGistR :: Name Gist -> Request 'RW () -unstarGistR gid = command Delete ["gists", toPathPart gid, "star"] mempty +unstarGistR :: Name Gist -> GenRequest 'MtUnit 'RW () +unstarGistR gid = Command Delete ["gists", toPathPart gid, "star"] mempty -- | Delete a gist by the authenticated user. -- --- > deleteGist ("github-username", "github-password") "225074" +-- > deleteGist (BasicAuth "github-username" "github-password") "225074" deleteGist :: Auth -> Name Gist -> IO (Either Error ()) deleteGist auth gid = executeRequest auth $ deleteGistR gid -- | Delete a gist by the authenticated user. -- See -deleteGistR :: Name Gist -> Request 'RW () -deleteGistR gid = command Delete ["gists", toPathPart gid] mempty +deleteGistR :: Name Gist -> GenRequest 'MtUnit 'RW () +deleteGistR gid = Command Delete ["gists", toPathPart gid] mempty diff --git a/src/GitHub/Endpoints/GitData/Blobs.hs b/src/GitHub/Endpoints/GitData/Blobs.hs --- a/src/GitHub/Endpoints/GitData/Blobs.hs +++ b/src/GitHub/Endpoints/GitData/Blobs.hs @@ -19,7 +19,7 @@ -- | Query a blob by SHA1. -- --- > blob' (Just ("github-username", "github-password")) "thoughtbot" "paperclip" "bc5c51d1ece1ee45f94b056a0f5a1674d7e8cba9" +-- > blob' (Just $ BasicAuth "github-username" "github-password") "thoughtbot" "paperclip" "bc5c51d1ece1ee45f94b056a0f5a1674d7e8cba9" blob' :: Maybe Auth -> Name Owner -> Name Repo -> Name Blob -> IO (Either Error Blob) blob' auth user repo sha = executeRequestMaybe auth $ blobR user repo sha diff --git a/src/GitHub/Endpoints/GitData/References.hs b/src/GitHub/Endpoints/GitData/References.hs --- a/src/GitHub/Endpoints/GitData/References.hs +++ b/src/GitHub/Endpoints/GitData/References.hs @@ -26,7 +26,7 @@ -- | A single reference by the ref name. -- --- > reference' (Just ("github-username", "github-password")) "mike-burns" "github" "heads/master" +-- > reference' (Just $ BasicAuth "github-username" "github-password") "mike-burns" "github" "heads/master" reference' :: Maybe Auth -> Name Owner -> Name Repo -> Name GitReference -> IO (Either Error GitReference) reference' auth user repo ref = executeRequestMaybe auth $ referenceR user repo ref diff --git a/src/GitHub/Endpoints/GitData/Trees.hs b/src/GitHub/Endpoints/GitData/Trees.hs --- a/src/GitHub/Endpoints/GitData/Trees.hs +++ b/src/GitHub/Endpoints/GitData/Trees.hs @@ -22,7 +22,7 @@ -- | A tree for a SHA1. -- --- > tree (Just ("github-username", "github-password")) "thoughtbot" "paperclip" "fe114451f7d066d367a1646ca7ac10e689b46844" +-- > tree (Just $ BasicAuth "github-username" "github-password") "thoughtbot" "paperclip" "fe114451f7d066d367a1646ca7ac10e689b46844" tree' :: Maybe Auth -> Name Owner -> Name Repo -> Name Tree -> IO (Either Error Tree) tree' auth user repo sha = executeRequestMaybe auth $ treeR user repo sha @@ -41,7 +41,7 @@ -- | A recursively-nested tree for a SHA1. -- --- > nestedTree' (Just ("github-username", "github-password")) "thoughtbot" "paperclip" "fe114451f7d066d367a1646ca7ac10e689b46844" +-- > nestedTree' (Just $ BasicAuth "github-username" "github-password") "thoughtbot" "paperclip" "fe114451f7d066d367a1646ca7ac10e689b46844" nestedTree' :: Maybe Auth -> Name Owner -> Name Repo -> Name Tree -> IO (Either Error Tree) nestedTree' auth user repo sha = executeRequestMaybe auth $ nestedTreeR user repo sha diff --git a/src/GitHub/Endpoints/Issues.hs b/src/GitHub/Endpoints/Issues.hs --- a/src/GitHub/Endpoints/Issues.hs +++ b/src/GitHub/Endpoints/Issues.hs @@ -41,7 +41,7 @@ -- | Details on a specific issue, given the repo owner and name, and the issue -- number.' -- --- > issue' (Just ("github-username", "github-password")) "thoughtbot" "paperclip" "462" +-- > issue' (Just $ BasicAuth "github-username" "github-password") "thoughtbot" "paperclip" "462" issue' :: Maybe Auth -> Name Owner -> Name Repo -> Id Issue -> IO (Either Error Issue) issue' auth user reqRepoName reqIssueNumber = executeRequestMaybe auth $ issueR user reqRepoName reqIssueNumber @@ -62,7 +62,7 @@ -- | All issues for a repo (given the repo owner and name), with optional -- restrictions as described in the 'IssueRepoMod' data type. -- --- > issuesForRepo' (Just ("github-username", "github-password")) "thoughtbot" "paperclip" [NoMilestone, OnlyClosed, Mentions "jyurek", Ascending] +-- > issuesForRepo' (Just $ BasicAuth "github-username" "github-password") "thoughtbot" "paperclip" [NoMilestone, OnlyClosed, Mentions "jyurek", Ascending] issuesForRepo' :: Maybe Auth -> Name Owner -> Name Repo -> IssueRepoMod -> IO (Either Error (Vector Issue)) issuesForRepo' auth user reqRepoName opts = executeRequestMaybe auth $ issuesForRepoR user reqRepoName opts FetchAll @@ -90,7 +90,7 @@ -- | Create a new issue. -- --- > createIssue (User (user, password)) user repo +-- > createIssue (BasicAuth "github-username" "github-password") user repo -- > (newIssue "some_repo") {...} createIssue :: Auth -> Name Owner -> Name Repo -> NewIssue -> IO (Either Error Issue) @@ -110,7 +110,7 @@ -- | Edit an issue. -- --- > editIssue (User (user, password)) user repo issue +-- > editIssue (BasicAuth "github-username" "github-password") user repo issue -- > editOfIssue {...} editIssue :: Auth -> Name Owner -> Name Repo -> Id Issue -> EditIssue -> IO (Either Error Issue) diff --git a/src/GitHub/Endpoints/Issues/Comments.hs b/src/GitHub/Endpoints/Issues/Comments.hs --- a/src/GitHub/Endpoints/Issues/Comments.hs +++ b/src/GitHub/Endpoints/Issues/Comments.hs @@ -46,7 +46,7 @@ -- | All comments on an issue, by the issue's number, using authentication. -- --- > comments' (User (user, password)) "thoughtbot" "paperclip" 635 +-- > comments' (Just $ BasicAuth "github-username" "github-password") "thoughtbot" "paperclip" 635 comments' :: Maybe Auth -> Name Owner -> Name Repo -> IssueNumber -> IO (Either Error (Vector IssueComment)) comments' auth user repo iid = executeRequestMaybe auth $ commentsR user repo iid FetchAll @@ -59,7 +59,7 @@ -- | Create a new comment. -- --- > createComment (User (user, password)) user repo issue +-- > createComment (BasicAuth "github-username" "github-password") user repo issue -- > "some words" createComment :: Auth -> Name Owner -> Name Repo -> IssueNumber -> Text -> IO (Either Error Comment) @@ -76,7 +76,7 @@ -- | Edit a comment. -- --- > editComment (User (user, password)) user repo commentid +-- > editComment (BasicAuth "github-username" "github-password") user repo commentid -- > "new words" editComment :: Auth -> Name Owner -> Name Repo -> Id Comment -> Text -> IO (Either Error Comment) @@ -93,7 +93,7 @@ -- | Delete a comment. -- --- > deleteComment (User (user, password)) user repo commentid +-- > deleteComment (BasicAuth "github-username" "github-password") user repo commentid deleteComment :: Auth -> Name Owner -> Name Repo -> Id Comment -> IO (Either Error ()) deleteComment auth user repo commid = @@ -101,8 +101,8 @@ -- | Delete a comment. -- See -deleteCommentR :: Name Owner -> Name Repo -> Id Comment -> Request 'RW () +deleteCommentR :: Name Owner -> Name Repo -> Id Comment -> GenRequest 'MtUnit 'RW () deleteCommentR user repo commid = - command Delete parts mempty + Command Delete parts mempty where parts = ["repos", toPathPart user, toPathPart repo, "issues", "comments", toPathPart commid] diff --git a/src/GitHub/Endpoints/Issues/Events.hs b/src/GitHub/Endpoints/Issues/Events.hs --- a/src/GitHub/Endpoints/Issues/Events.hs +++ b/src/GitHub/Endpoints/Issues/Events.hs @@ -31,7 +31,7 @@ -- | All events that have happened on an issue, using authentication. -- --- > eventsForIssue' (User (user, password)) "thoughtbot" "paperclip" 49 +-- > eventsForIssue' (Just $ BasicAuth "github-username" "github-password") "thoughtbot" "paperclip" 49 eventsForIssue' :: Maybe Auth -> Name Owner -> Name Repo -> Id Issue -> IO (Either Error (Vector IssueEvent)) eventsForIssue' auth user repo iid = executeRequestMaybe auth $ eventsForIssueR user repo iid FetchAll @@ -50,7 +50,7 @@ -- | All the events for all issues in a repo, using authentication. -- --- > eventsForRepo' (User (user, password)) "thoughtbot" "paperclip" +-- > eventsForRepo' (Just $ BasicAuth "github-username" "github-password") "thoughtbot" "paperclip" eventsForRepo' :: Maybe Auth -> Name Owner -> Name Repo -> IO (Either Error (Vector IssueEvent)) eventsForRepo' auth user repo = executeRequestMaybe auth $ eventsForRepoR user repo FetchAll @@ -69,7 +69,7 @@ -- | Details on a specific event, by the event's ID, using authentication. -- --- > event' (User (user, password)) "thoughtbot" "paperclip" 5335772 +-- > event' (Just $ BasicAuth "github-username" "github-password") "thoughtbot" "paperclip" 5335772 event' :: Maybe Auth -> Name Owner -> Name Repo -> Id IssueEvent -> IO (Either Error IssueEvent) event' auth user repo eid = executeRequestMaybe auth $ eventR user repo eid diff --git a/src/GitHub/Endpoints/Issues/Labels.hs b/src/GitHub/Endpoints/Issues/Labels.hs --- a/src/GitHub/Endpoints/Issues/Labels.hs +++ b/src/GitHub/Endpoints/Issues/Labels.hs @@ -48,7 +48,7 @@ -- | All the labels available to use on any issue in the repo using authentication. -- --- > labelsOnRepo' (Just (User (user password))) "thoughtbot" "paperclip" +-- > labelsOnRepo' (Just $ BasicAuth "github-username" "github-password") "thoughtbot" "paperclip" labelsOnRepo' :: Maybe Auth -> Name Owner -> Name Repo -> IO (Either Error (Vector IssueLabel)) labelsOnRepo' auth user repo = executeRequestMaybe auth $ labelsOnRepoR user repo FetchAll @@ -67,7 +67,7 @@ -- | A label by name using authentication. -- --- > label' (Just (User (user password))) "thoughtbot" "paperclip" "bug" +-- > label' (Just $ BasicAuth "github-username" "github-password") "thoughtbot" "paperclip" "bug" label' :: Maybe Auth -> Name Owner -> Name Repo -> Name IssueLabel -> IO (Either Error IssueLabel) label' auth user repo lbl = executeRequestMaybe auth $ labelR user repo lbl @@ -80,7 +80,7 @@ -- | Create a label -- --- > createLabel (User (user password)) "thoughtbot" "paperclip" "bug" "f29513" +-- > createLabel (BasicAuth "github-username" "github-password") "thoughtbot" "paperclip" "bug" "f29513" createLabel :: Auth -> Name Owner -> Name Repo -> Name IssueLabel -> String -> IO (Either Error IssueLabel) createLabel auth user repo lbl color = executeRequest auth $ createLabelR user repo lbl color @@ -96,7 +96,7 @@ -- | Update a label -- --- > updateLabel (User (user password)) "thoughtbot" "paperclip" "bug" "new-bug" "ff1111" +-- > updateLabel (BasicAuth "github-username" "github-password") "thoughtbot" "paperclip" "bug" "new-bug" "ff1111" updateLabel :: Auth -> Name Owner -> Name Repo @@ -123,16 +123,16 @@ -- | Delete a label -- --- > deleteLabel (User (user password)) "thoughtbot" "paperclip" "bug" +-- > deleteLabel (BasicAuth "github-username" "github-password") "thoughtbot" "paperclip" "bug" deleteLabel :: Auth -> Name Owner -> Name Repo -> Name IssueLabel -> IO (Either Error ()) deleteLabel auth user repo lbl = executeRequest auth $ deleteLabelR user repo lbl -- | Delete a label. -- See -deleteLabelR :: Name Owner -> Name Repo -> Name IssueLabel -> Request 'RW () +deleteLabelR :: Name Owner -> Name Repo -> Name IssueLabel -> GenRequest 'MtUnit 'RW () deleteLabelR user repo lbl = - command Delete ["repos", toPathPart user, toPathPart repo, "labels", toPathPart lbl] mempty + Command Delete ["repos", toPathPart user, toPathPart repo, "labels", toPathPart lbl] mempty -- | The labels on an issue in a repo. -- @@ -142,7 +142,7 @@ -- | The labels on an issue in a repo using authentication. -- --- > labelsOnIssue' (Just (User (user password))) "thoughtbot" "paperclip" (Id 585) +-- > labelsOnIssue' (Just $ BasicAuth "github-username" "github-password") "thoughtbot" "paperclip" (Id 585) labelsOnIssue' :: Maybe Auth -> Name Owner -> Name Repo -> Id Issue -> IO (Either Error (Vector IssueLabel)) labelsOnIssue' auth user repo iid = executeRequestMaybe auth $ labelsOnIssueR user repo iid FetchAll @@ -155,7 +155,7 @@ -- | Add labels to an issue. -- --- > addLabelsToIssue (User (user password)) "thoughtbot" "paperclip" (Id 585) ["Label1" "Label2"] +-- > addLabelsToIssue (BasicAuth "github-username" "github-password") "thoughtbot" "paperclip" (Id 585) ["Label1" "Label2"] addLabelsToIssue :: Foldable f => Auth -> Name Owner @@ -181,20 +181,20 @@ -- | Remove a label from an issue. -- --- > removeLabelFromIssue (User (user password)) "thoughtbot" "paperclip" (Id 585) "bug" +-- > removeLabelFromIssue (BasicAuth "github-username" "github-password") "thoughtbot" "paperclip" (Id 585) "bug" removeLabelFromIssue :: Auth -> Name Owner -> Name Repo -> Id Issue -> Name IssueLabel -> IO (Either Error ()) removeLabelFromIssue auth user repo iid lbl = executeRequest auth $ removeLabelFromIssueR user repo iid lbl -- | Remove a label from an issue. -- See -removeLabelFromIssueR :: Name Owner -> Name Repo -> Id Issue -> Name IssueLabel -> Request 'RW () +removeLabelFromIssueR :: Name Owner -> Name Repo -> Id Issue -> Name IssueLabel -> GenRequest 'MtUnit 'RW () removeLabelFromIssueR user repo iid lbl = - command Delete ["repos", toPathPart user, toPathPart repo, "issues", toPathPart iid, "labels", toPathPart lbl] mempty + Command Delete ["repos", toPathPart user, toPathPart repo, "issues", toPathPart iid, "labels", toPathPart lbl] mempty -- | Replace all labels on an issue. Sending an empty list will remove all labels from the issue. -- --- > replaceAllLabelsForIssue (User (user password)) "thoughtbot" "paperclip" (Id 585) ["Label1" "Label2"] +-- > replaceAllLabelsForIssue (BasicAuth "github-username" "github-password") "thoughtbot" "paperclip" (Id 585) ["Label1" "Label2"] replaceAllLabelsForIssue :: Foldable f => Auth -> Name Owner @@ -222,16 +222,16 @@ -- | Remove all labels from an issue. -- --- > removeAllLabelsFromIssue (User (user password)) "thoughtbot" "paperclip" (Id 585) +-- > removeAllLabelsFromIssue (BasicAuth "github-username" "github-password") "thoughtbot" "paperclip" (Id 585) removeAllLabelsFromIssue :: Auth -> Name Owner -> Name Repo -> Id Issue -> IO (Either Error ()) removeAllLabelsFromIssue auth user repo iid = executeRequest auth $ removeAllLabelsFromIssueR user repo iid -- | Remove all labels from an issue. -- See -removeAllLabelsFromIssueR :: Name Owner -> Name Repo -> Id Issue -> Request 'RW () +removeAllLabelsFromIssueR :: Name Owner -> Name Repo -> Id Issue -> GenRequest 'MtUnit 'RW () removeAllLabelsFromIssueR user repo iid = - command Delete ["repos", toPathPart user, toPathPart repo, "issues", toPathPart iid, "labels"] mempty + Command Delete ["repos", toPathPart user, toPathPart repo, "issues", toPathPart iid, "labels"] mempty -- | All the labels on a repo's milestone given the milestone ID. -- @@ -241,7 +241,7 @@ -- | All the labels on a repo's milestone given the milestone ID using authentication. -- --- > labelsOnMilestone' (Just (User (user password))) "thoughtbot" "paperclip" (Id 2) +-- > labelsOnMilestone' (Just $ BasicAuth "github-username" "github-password") "thoughtbot" "paperclip" (Id 2) labelsOnMilestone' :: Maybe Auth -> Name Owner -> Name Repo -> Id Milestone -> IO (Either Error (Vector IssueLabel)) labelsOnMilestone' auth user repo mid = executeRequestMaybe auth $ labelsOnMilestoneR user repo mid FetchAll diff --git a/src/GitHub/Endpoints/Issues/Milestones.hs b/src/GitHub/Endpoints/Issues/Milestones.hs --- a/src/GitHub/Endpoints/Issues/Milestones.hs +++ b/src/GitHub/Endpoints/Issues/Milestones.hs @@ -33,7 +33,7 @@ -- | All milestones in the repo, using authentication. -- --- > milestones' (User (user, passwordG) "thoughtbot" "paperclip" +-- > milestones' (Just $ BasicAuth "github-username" "github-password") "thoughtbot" "paperclip" milestones' :: Maybe Auth -> Name Owner -> Name Repo -> IO (Either Error (Vector Milestone)) milestones' auth user repo = executeRequestMaybe auth $ milestonesR user repo FetchAll @@ -80,7 +80,7 @@ -- | Delete a milestone. -- See -deleteMilestoneR :: Name Owner -> Name Repo -> Id Milestone -> Request 'RW () +deleteMilestoneR :: Name Owner -> Name Repo -> Id Milestone -> GenRequest 'MtUnit 'RW () deleteMilestoneR user repo mid = - command Delete + Command Delete ["repos", toPathPart user, toPathPart repo, "milestones", toPathPart mid] mempty diff --git a/src/GitHub/Endpoints/Organizations.hs b/src/GitHub/Endpoints/Organizations.hs --- a/src/GitHub/Endpoints/Organizations.hs +++ b/src/GitHub/Endpoints/Organizations.hs @@ -22,7 +22,7 @@ -- | The public organizations for a user, given the user's login, with authorization -- --- > publicOrganizationsFor' (Just ("github-username", "github-password")) "mike-burns" +-- > publicOrganizationsFor' (Just $ BasicAuth "github-username" "github-password") "mike-burns" publicOrganizationsFor' :: Maybe Auth -> Name User -> IO (Either Error (Vector SimpleOrganization)) publicOrganizationsFor' auth org = executeRequestMaybe auth $ publicOrganizationsForR org FetchAll @@ -45,7 +45,7 @@ -- | Details on a public organization. Takes the organization's login. -- --- > publicOrganization' (Just ("github-username", "github-password")) "thoughtbot" +-- > publicOrganization' (Just $ BasicAuth "github-username" "github-password") "thoughtbot" publicOrganization' :: Maybe Auth -> Name Organization -> IO (Either Error Organization) publicOrganization' auth = executeRequestMaybe auth . publicOrganizationR diff --git a/src/GitHub/Endpoints/Organizations/Teams.hs b/src/GitHub/Endpoints/Organizations/Teams.hs --- a/src/GitHub/Endpoints/Organizations/Teams.hs +++ b/src/GitHub/Endpoints/Organizations/Teams.hs @@ -124,9 +124,9 @@ -- | Delete team. -- -- See -deleteTeamR :: Id Team -> Request 'RW () +deleteTeamR :: Id Team -> GenRequest 'MtUnit 'RW () deleteTeamR tid = - command Delete ["teams", toPathPart tid] mempty + Command Delete ["teams", toPathPart tid] mempty -- | List team members. -- @@ -214,9 +214,9 @@ -- | Remove team membership. -- See -deleteTeamMembershipForR :: Id Team -> Name Owner -> Request 'RW () +deleteTeamMembershipForR :: Id Team -> Name Owner -> GenRequest 'MtUnit 'RW () deleteTeamMembershipForR tid user = - command Delete ["teams", toPathPart tid, "memberships", toPathPart user] mempty + Command Delete ["teams", toPathPart tid, "memberships", toPathPart user] mempty -- | List teams for current authenticated user -- diff --git a/src/GitHub/Endpoints/PullRequests.hs b/src/GitHub/Endpoints/PullRequests.hs --- a/src/GitHub/Endpoints/PullRequests.hs +++ b/src/GitHub/Endpoints/PullRequests.hs @@ -106,7 +106,7 @@ -- repo owner and name along with the number assigned to the pull request. -- With authentification. -- --- > pullRequest' (Just ("github-username", "github-password")) "thoughtbot" "paperclip" 562 +-- > pullRequest' (Just $ BasicAuth "github-username" "github-password") "thoughtbot" "paperclip" 562 pullRequest' :: Maybe Auth -> Name Owner -> Name Repo -> IssueNumber -> IO (Either Error PullRequest) pullRequest' auth user repo prid = executeRequestMaybe auth $ pullRequestR user repo prid @@ -160,7 +160,7 @@ -- the number of the pull request. -- With authentification. -- --- > pullRequestCommits' (Just ("github-username", "github-password")) "thoughtbot" "paperclip" 688 +-- > pullRequestCommits' (Just $ BasicAuth "github-username" "github-password") "thoughtbot" "paperclip" 688 pullRequestCommits' :: Maybe Auth -> Name Owner -> Name Repo -> IssueNumber -> IO (Either Error (Vector Commit)) pullRequestCommits' auth user repo prid = executeRequestMaybe auth $ pullRequestCommitsR user repo prid FetchAll @@ -182,7 +182,7 @@ -- name, plus the number assigned to the pull request. -- With authentification. -- --- > pullRequestFiles' (Just ("github-username", "github-password")) "thoughtbot" "paperclip" 688 +-- > pullRequestFiles' (Just $ BasicAuth "github-username" "github-password") "thoughtbot" "paperclip" 688 pullRequestFiles' :: Maybe Auth -> Name Owner -> Name Repo -> IssueNumber -> IO (Either Error (Vector File)) pullRequestFiles' auth user repo prid = executeRequestMaybe auth $ pullRequestFilesR user repo prid FetchAll diff --git a/src/GitHub/Endpoints/PullRequests/Comments.hs b/src/GitHub/Endpoints/PullRequests/Comments.hs --- a/src/GitHub/Endpoints/PullRequests/Comments.hs +++ b/src/GitHub/Endpoints/PullRequests/Comments.hs @@ -48,7 +48,7 @@ -- | Create a new comment. -- --- > createPullComment (User (user, password)) user repo issue commit path position +-- > createPullComment (BasicAuth "github-username" "github-password") user repo issue commit path position -- > "some words" createPullComment :: Auth -> Name Owner -> Name Repo -> IssueNumber -> Text -> Text -> Int -> Text -> IO (Either Error Comment) diff --git a/src/GitHub/Endpoints/PullRequests/Reviews.hs b/src/GitHub/Endpoints/PullRequests/Reviews.hs --- a/src/GitHub/Endpoints/PullRequests/Reviews.hs +++ b/src/GitHub/Endpoints/PullRequests/Reviews.hs @@ -58,7 +58,7 @@ -- | All reviews for a pull request given the repo owner, repo name and the pull -- request id. With authentication. -- --- > pullRequestReviews' (Just ("github-username", "github-password")) "thoughtbot" "paperclip" (Id 101) +-- > pullRequestReviews' (Just $ BasicAuth "github-username" "github-password") "thoughtbot" "paperclip" (Id 101) pullRequestReviews' :: Maybe Auth -> Name Owner @@ -104,8 +104,8 @@ -- | A detailed review on a pull request given the repo owner, repo name, pull -- request id and review id. With authentication. -- --- > pullRequestReview' (Just ("github-username", "github-password")) --- "thoughtbot" "factory_girl" (Id 301819) (Id 332) +-- > pullRequestReview' (Just $ BasicAuth "github-username" "github-password") +-- > "thoughtbot" "factory_girl" (Id 301819) (Id 332) pullRequestReview' :: Maybe Auth -> Name Owner @@ -153,7 +153,7 @@ -- | All comments for a review on a pull request given the repo owner, repo -- name, pull request id and review id. With authentication. -- --- > pullRequestReviewComments' (Just ("github-username", "github-password")) "thoughtbot" "factory_girl" (Id 301819) (Id 332) +-- > pullRequestReviewComments' (Just $ BasicAuth "github-username" "github-password") "thoughtbot" "factory_girl" (Id 301819) (Id 332) pullRequestReviewCommentsIO' :: Maybe Auth -> Name Owner diff --git a/src/GitHub/Endpoints/Repos.hs b/src/GitHub/Endpoints/Repos.hs --- a/src/GitHub/Endpoints/Repos.hs +++ b/src/GitHub/Endpoints/Repos.hs @@ -88,7 +88,7 @@ -- | The repos for a user, by their login. -- With authentication. -- --- > userRepos' (Just (BasicAuth (user, password))) "mike-burns" All +-- > userRepos' (Just $ BasicAuth "github-username" "github-password") "mike-burns" All userRepos' :: Maybe Auth -> Name Owner @@ -114,7 +114,7 @@ -- | The repos for an organization, by the organization name. -- With authentication. -- --- > organizationRepos (Just (BasicAuth (user, password))) "thoughtbot" All +-- > organizationRepos (Just $ BasicAuth "github-username" "github-password") "thoughtbot" All organizationRepos' :: Maybe Auth -> Name Organization @@ -144,7 +144,7 @@ -- | Details on a specific repo, given the owner and repo name. -- With authentication. -- --- > repository' (Just (BasicAuth (user, password))) "mike-burns" "github" +-- > repository' (Just $ BasicAuth "github-username" "github-password") "mike-burns" "github" repository' :: Maybe Auth -> Name Owner -> Name Repo -> IO (Either Error Repo) repository' auth user repo = executeRequestMaybe auth $ repositoryR user repo @@ -224,7 +224,7 @@ -- | The contributors to a repo, given the owner and repo name. -- With authentication. -- --- > contributors' (Just (BasicAuth (user, password))) "thoughtbot" "paperclip" +-- > contributors' (Just $ BasicAuth "github-username" "github-password") "thoughtbot" "paperclip" contributors' :: Maybe Auth -> Name Owner -> Name Repo -> IO (Either Error (Vector Contributor)) contributors' auth user repo = executeRequestMaybe auth $ contributorsR user repo False FetchAll @@ -256,7 +256,7 @@ -- and repo name. -- With authentication. -- --- > contributorsWithAnonymous' (Just (BasicAuth (user, password))) "thoughtbot" "paperclip" +-- > contributorsWithAnonymous' (Just $ BasicAuth "github-username" "github-password") "thoughtbot" "paperclip" contributorsWithAnonymous' :: Maybe Auth -> Name Owner -> Name Repo -> IO (Either Error (Vector Contributor)) contributorsWithAnonymous' auth user repo = executeRequestMaybe auth $ contributorsR user repo True FetchAll @@ -272,7 +272,7 @@ -- characters written in that language. Takes the repo owner and name. -- With authentication. -- --- > languagesFor' (Just (BasicAuth (user, password))) "mike-burns" "ohlaunch" +-- > languagesFor' (Just $ BasicAuth "github-username" "github-password") "mike-burns" "ohlaunch" languagesFor' :: Maybe Auth -> Name Owner -> Name Repo -> IO (Either Error Languages) languagesFor' auth user repo = executeRequestMaybe auth $ languagesForR user repo @@ -292,7 +292,7 @@ -- | The git tags on a repo, given the repo owner and name. -- With authentication. -- --- > tagsFor' (Just (BasicAuth (user, password))) "thoughtbot" "paperclip" +-- > tagsFor' (Just $ BasicAuth "github-username" "github-password") "thoughtbot" "paperclip" tagsFor' :: Maybe Auth -> Name Owner -> Name Repo -> IO (Either Error (Vector Tag)) tagsFor' auth user repo = executeRequestMaybe auth $ tagsForR user repo FetchAll @@ -312,7 +312,7 @@ -- | The git branches on a repo, given the repo owner and name. -- With authentication. -- --- > branchesFor' (Just (BasicAuth (user, password))) "thoughtbot" "paperclip" +-- > branchesFor' (Just $ BasicAuth "github-username" "github-password") "thoughtbot" "paperclip" branchesFor' :: Maybe Auth -> Name Owner -> Name Repo -> IO (Either Error (Vector Branch)) branchesFor' auth user repo = executeRequestMaybe auth $ branchesForR user repo FetchAll @@ -330,6 +330,8 @@ deleteRepo auth user repo = executeRequest auth $ deleteRepoR user repo -deleteRepoR :: Name Owner -> Name Repo -> Request 'RW () +-- | Delete a repository,. +-- See +deleteRepoR :: Name Owner -> Name Repo -> GenRequest 'MtUnit 'RW () deleteRepoR user repo = - command Delete ["repos", toPathPart user, toPathPart repo] mempty + Command Delete ["repos", toPathPart user, toPathPart repo] mempty diff --git a/src/GitHub/Endpoints/Repos/Collaborators.hs b/src/GitHub/Endpoints/Repos/Collaborators.hs --- a/src/GitHub/Endpoints/Repos/Collaborators.hs +++ b/src/GitHub/Endpoints/Repos/Collaborators.hs @@ -68,7 +68,7 @@ -> Name Owner -- ^ Repository owner -> Name Repo -- ^ Repository name -> Name User -- ^ Collaborator to add - -> IO (Either Error ()) + -> IO (Either Error (Maybe RepoInvitation)) addCollaborator auth owner repo coll = executeRequest auth $ addCollaboratorR owner repo coll @@ -78,6 +78,6 @@ :: Name Owner -- ^ Repository owner -> Name Repo -- ^ Repository name -> Name User -- ^ Collaborator to add - -> GenRequest 'MtUnit 'RW () + -> GenRequest 'MtJSON 'RW (Maybe RepoInvitation) addCollaboratorR owner repo coll = Command Put ["repos", toPathPart owner, toPathPart repo, "collaborators", toPathPart coll] mempty diff --git a/src/GitHub/Endpoints/Repos/Commits.hs b/src/GitHub/Endpoints/Repos/Commits.hs --- a/src/GitHub/Endpoints/Repos/Commits.hs +++ b/src/GitHub/Endpoints/Repos/Commits.hs @@ -48,7 +48,7 @@ -- | The commit history for a repo. -- With authentication. -- --- > commitsFor' (Just (BasicAuth (user, password))) "mike-burns" "github" +-- > commitsFor' (Just $ BasicAuth "github-username" "github-password") "mike-burns" "github" commitsFor' :: Maybe Auth -> Name Owner -> Name Repo -> IO (Either Error (Vector Commit)) commitsFor' auth user repo = commitsWithOptionsFor' auth user repo [] @@ -65,7 +65,7 @@ -- query options. -- With authentication. -- --- > commitsWithOptionsFor' (Just (BasicAuth (user, password))) "mike-burns" "github" [CommitQueryAuthor "djeik"] +-- > commitsWithOptionsFor' (Just $ BasicAuth "github-username" "github-password") "mike-burns" "github" [CommitQueryAuthor "djeik"] commitsWithOptionsFor' :: Maybe Auth -> Name Owner -> Name Repo -> [CommitQueryOption] -> IO (Either Error (Vector Commit)) commitsWithOptionsFor' auth user repo opts = executeRequestMaybe auth $ commitsWithOptionsForR user repo FetchAll opts @@ -88,7 +88,7 @@ -- | Details on a specific SHA1 for a repo. -- With authentication. -- --- > commit (Just $ BasicAuth (username, password)) "mike-burns" "github" "9d1a9a361266c3c890b1108ad2fdf52f824b1b81" +-- > commit (Just $ BasicAuth "github-username" "github-password") "mike-burns" "github" "9d1a9a361266c3c890b1108ad2fdf52f824b1b81" commit' :: Maybe Auth -> Name Owner -> Name Repo -> Name Commit -> IO (Either Error Commit) commit' auth user repo sha = executeRequestMaybe auth $ commitR user repo sha diff --git a/src/GitHub/Endpoints/Repos/Contents.hs b/src/GitHub/Endpoints/Repos/Contents.hs --- a/src/GitHub/Endpoints/Repos/Contents.hs +++ b/src/GitHub/Endpoints/Repos/Contents.hs @@ -50,7 +50,7 @@ -- | The contents of a file or directory in a repo, given the repo owner, name, and path to the file -- With Authentication -- --- > contentsFor' (Just (BasicAuth (user, password))) "thoughtbot" "paperclip" "README.md" Nothing +-- > contentsFor' (Just $ BasicAuth "github-username" "github-password") "thoughtbot" "paperclip" "README.md" Nothing contentsFor' :: Maybe Auth -> Name Owner -> Name Repo -> Text -> Maybe Text -> IO (Either Error Content) contentsFor' auth user repo path ref = executeRequestMaybe auth $ contentsForR user repo path ref @@ -75,7 +75,7 @@ -- | The contents of a README file in a repo, given the repo owner and name -- With Authentication -- --- > readmeFor' (Just (BasicAuth (user, password))) "thoughtbot" "paperclip" +-- > readmeFor' (Just $ BasicAuth "github-username" "github-password") "thoughtbot" "paperclip" readmeFor' :: Maybe Auth -> Name Owner -> Name Repo -> IO (Either Error Content) readmeFor' auth user repo = executeRequestMaybe auth $ readmeForR user repo @@ -93,7 +93,7 @@ -- | The archive of a repo, given the repo owner, name, and archive type -- With Authentication -- --- > archiveFor' (Just (BasicAuth (user, password))) "thoughtbot" "paperclip" ArchiveFormatTarball Nothing +-- > archiveFor' (Just $ BasicAuth "github-username" "github-password") "thoughtbot" "paperclip" ArchiveFormatTarball Nothing archiveFor' :: Maybe Auth -> Name Owner -> Name Repo -> ArchiveFormat -> Maybe Text -> IO (Either Error URI) archiveFor' auth user repo path ref = executeRequestMaybe auth $ archiveForR user repo path ref @@ -166,6 +166,6 @@ :: Name Owner -> Name Repo -> DeleteFile - -> Request 'RW () + -> GenRequest 'MtUnit 'RW () deleteFileR user repo body = - command Delete ["repos", toPathPart user, toPathPart repo, "contents", deleteFilePath body] (encode body) + Command Delete ["repos", toPathPart user, toPathPart repo, "contents", deleteFilePath body] (encode body) diff --git a/src/GitHub/Endpoints/Repos/DeployKeys.hs b/src/GitHub/Endpoints/Repos/DeployKeys.hs --- a/src/GitHub/Endpoints/Repos/DeployKeys.hs +++ b/src/GitHub/Endpoints/Repos/DeployKeys.hs @@ -65,6 +65,6 @@ -- | Delete a deploy key. -- See -deleteRepoDeployKeyR :: Name Owner -> Name Repo -> Id RepoDeployKey -> Request 'RW () +deleteRepoDeployKeyR :: Name Owner -> Name Repo -> Id RepoDeployKey -> GenRequest 'MtUnit 'RW () deleteRepoDeployKeyR user repo keyId = - command Delete ["repos", toPathPart user, toPathPart repo, "keys", toPathPart keyId] mempty + Command Delete ["repos", toPathPart user, toPathPart repo, "keys", toPathPart keyId] mempty diff --git a/src/GitHub/Endpoints/Repos/Forks.hs b/src/GitHub/Endpoints/Repos/Forks.hs --- a/src/GitHub/Endpoints/Repos/Forks.hs +++ b/src/GitHub/Endpoints/Repos/Forks.hs @@ -26,7 +26,7 @@ -- | All the repos that are forked off the given repo. -- | With authentication -- --- > forksFor' (Just (User (user, password))) "thoughtbot" "paperclip" +-- > forksFor' (Just $ BasicAuth "github-username" "github-password") "thoughtbot" "paperclip" forksFor' :: Maybe Auth -> Name Owner -> Name Repo -> IO (Either Error (Vector Repo)) forksFor' auth user repo = executeRequestMaybe auth $ forksForR user repo FetchAll diff --git a/src/GitHub/Endpoints/Repos/Invitations.hs b/src/GitHub/Endpoints/Repos/Invitations.hs new file mode 100644 --- /dev/null +++ b/src/GitHub/Endpoints/Repos/Invitations.hs @@ -0,0 +1,35 @@ +----------------------------------------------------------------------------- +-- | +-- License : BSD-3-Clause +-- Maintainer : Oleg Grenrus +-- +-- The repo invitations API as described on +-- . +module GitHub.Endpoints.Repos.Invitations ( + listInvitationsOnR, + listInvitationsForR, + acceptInvitationFromR + ) where + +import GitHub.Data +import GitHub.Internal.Prelude +import Prelude () + +-- | List open invitations of a repository +-- See +listInvitationsOnR :: Name Owner -> Name Repo -> FetchCount -> GenRequest 'MtJSON k (Vector RepoInvitation) +listInvitationsOnR user repo = + PagedQuery ["repos", toPathPart user, toPathPart repo, "invitations"] [] + +-- | List a user's repository invitations +-- See +listInvitationsForR :: FetchCount -> Request k (Vector RepoInvitation) +listInvitationsForR = + pagedQuery ["user", "repository_invitations"] [] + + +-- | Accept a repository invitation +-- See +acceptInvitationFromR :: Id RepoInvitation -> GenRequest 'MtUnit 'RW () +acceptInvitationFromR invId = + Command Patch ["user", "repository_invitations", toPathPart invId] mempty diff --git a/src/GitHub/Endpoints/Repos/Releases.hs b/src/GitHub/Endpoints/Repos/Releases.hs --- a/src/GitHub/Endpoints/Repos/Releases.hs +++ b/src/GitHub/Endpoints/Repos/Releases.hs @@ -29,7 +29,7 @@ -- | All releases for the given repo with authentication. -- --- > releases' (Just (User (user, password))) "calleerlandsson" "pick" +-- > releases' (Just $ BasicAuth "github-username" "github-password") "calleerlandsson" "pick" releases' :: Maybe Auth -> Name Owner -> Name Repo -> IO (Either Error (Vector Release)) releases' auth user repo = executeRequestMaybe auth $ releasesR user repo FetchAll @@ -48,7 +48,7 @@ -- | Query a single release with authentication. -- --- > release' (Just (User (user, password))) "calleerlandsson" "pick" +-- > release' (Just $ BasicAuth "github-username" "github-password") "calleerlandsson" "pick" release' :: Maybe Auth -> Name Owner -> Name Repo -> Id Release -> IO (Either Error Release) release' auth user repo reqReleaseId = executeRequestMaybe auth $ releaseR user repo reqReleaseId @@ -67,7 +67,7 @@ -- | Query latest release with authentication. -- --- > latestRelease' (Just (User (user, password))) "calleerlandsson" "pick" +-- > latestRelease' (Just $ BasicAuth "github-username" "github-password") "calleerlandsson" "pick" latestRelease' :: Maybe Auth -> Name Owner -> Name Repo -> IO (Either Error Release) latestRelease' auth user repo = executeRequestMaybe auth $ latestReleaseR user repo @@ -86,7 +86,7 @@ -- | Query release by tag name with authentication. -- --- > releaseByTagName' (Just (User (user, password))) "calleerlandsson" "pick" +-- > releaseByTagName' (Just $ BasicAuth "github-username" "github-password") "calleerlandsson" "pick" releaseByTagName' :: Maybe Auth -> Name Owner -> Name Repo -> Text -> IO (Either Error Release) releaseByTagName' auth user repo reqTagName = executeRequestMaybe auth $ releaseByTagNameR user repo reqTagName diff --git a/src/GitHub/Endpoints/Repos/Webhooks.hs b/src/GitHub/Endpoints/Repos/Webhooks.hs --- a/src/GitHub/Endpoints/Repos/Webhooks.hs +++ b/src/GitHub/Endpoints/Repos/Webhooks.hs @@ -103,9 +103,9 @@ -- | Delete a hook. -- See -deleteRepoWebhookR :: Name Owner -> Name Repo -> Id RepoWebhook -> Request 'RW () +deleteRepoWebhookR :: Name Owner -> Name Repo -> Id RepoWebhook -> GenRequest 'MtUnit 'RW () deleteRepoWebhookR user repo hookId = - command Delete (createWebhookOpPath user repo hookId Nothing) mempty + Command Delete (createWebhookOpPath user repo hookId Nothing) mempty createBaseWebhookPath :: Name Owner -> Name Repo -> Id RepoWebhook -> Paths createBaseWebhookPath user repo hookId = diff --git a/src/GitHub/Endpoints/Users.hs b/src/GitHub/Endpoints/Users.hs --- a/src/GitHub/Endpoints/Users.hs +++ b/src/GitHub/Endpoints/Users.hs @@ -23,7 +23,7 @@ -- | The information for a single user, by login name. -- With authentification -- --- > userInfoFor' (Just ("github-username", "github-password")) "mike-burns" +-- > userInfoFor' (Just $ BasicAuth "github-username" "github-password") "mike-burns" userInfoFor' :: Maybe Auth -> Name User -> IO (Either Error User) userInfoFor' auth = executeRequestMaybe auth . userInfoForR diff --git a/src/GitHub/Endpoints/Users/PublicSSHKeys.hs b/src/GitHub/Endpoints/Users/PublicSSHKeys.hs new file mode 100644 --- /dev/null +++ b/src/GitHub/Endpoints/Users/PublicSSHKeys.hs @@ -0,0 +1,83 @@ +----------------------------------------------------------------------------- +-- | +-- License : BSD-3-Clause +-- Maintainer : Todd Mohney +-- +-- The public keys API, as described at +-- +module GitHub.Endpoints.Users.PublicSSHKeys ( + -- * Querying public SSH keys + publicSSHKeys', + publicSSHKeysR, + publicSSHKeysFor', + publicSSHKeysForR, + publicSSHKey', + publicSSHKeyR, + + -- ** Create + createUserPublicSSHKey', + createUserPublicSSHKeyR, + + -- ** Delete + deleteUserPublicSSHKey', + deleteUserPublicSSHKeyR, +) where + +import GitHub.Data +import GitHub.Internal.Prelude +import GitHub.Request +import Prelude () + +-- | Querying public SSH keys. +publicSSHKeysFor' :: Name Owner -> IO (Either Error (Vector PublicSSHKeyBasic)) +publicSSHKeysFor' user = + executeRequest' $ publicSSHKeysForR user FetchAll + +-- | Querying public SSH keys. +-- See +publicSSHKeysForR :: Name Owner -> FetchCount -> Request 'RO (Vector PublicSSHKeyBasic) +publicSSHKeysForR user = + pagedQuery ["users", toPathPart user, "keys"] [] + +-- | Querying the authenticated users' public SSH keys +publicSSHKeys' :: Auth -> IO (Either Error (Vector PublicSSHKey)) +publicSSHKeys' auth = + executeRequest auth publicSSHKeysR + +-- | Querying the authenticated users' public SSH keys +-- See +publicSSHKeysR :: Request 'RA (Vector PublicSSHKey) +publicSSHKeysR = + query ["user", "keys"] [] + +-- | Querying a public SSH key +publicSSHKey' :: Auth -> Id PublicSSHKey -> IO (Either Error PublicSSHKey) +publicSSHKey' auth keyId = + executeRequest auth $ publicSSHKeyR keyId + +-- | Querying a public SSH key. +-- See +publicSSHKeyR :: Id PublicSSHKey -> Request 'RA PublicSSHKey +publicSSHKeyR keyId = + query ["user", "keys", toPathPart keyId] [] + +-- | Create a public SSH key +createUserPublicSSHKey' :: Auth -> NewPublicSSHKey -> IO (Either Error PublicSSHKey) +createUserPublicSSHKey' auth key = + executeRequest auth $ createUserPublicSSHKeyR key + +-- | Create a public SSH key. +-- See . +createUserPublicSSHKeyR :: NewPublicSSHKey -> Request 'RW PublicSSHKey +createUserPublicSSHKeyR key = + command Post ["user", "keys"] (encode key) + +deleteUserPublicSSHKey' :: Auth -> Id PublicSSHKey -> IO (Either Error ()) +deleteUserPublicSSHKey' auth keyId = + executeRequest auth $ deleteUserPublicSSHKeyR keyId + +-- | Delete a public SSH key. +-- See +deleteUserPublicSSHKeyR :: Id PublicSSHKey -> GenRequest 'MtUnit 'RW () +deleteUserPublicSSHKeyR keyId = + Command Delete ["user", "keys", toPathPart keyId] mempty diff --git a/src/GitHub/Internal/Prelude.hs b/src/GitHub/Internal/Prelude.hs --- a/src/GitHub/Internal/Prelude.hs +++ b/src/GitHub/Internal/Prelude.hs @@ -4,7 +4,7 @@ -- License : BSD-3-Clause -- Maintainer : Oleg Grenrus -- --- This module may change between minor releases. Do not rely on it contents. +-- This module may change between minor releases. Do not rely on its contents. module GitHub.Internal.Prelude ( module Prelude.Compat, -- * Commonly used types @@ -22,6 +22,7 @@ Semigroup(..), -- * Aeson FromJSON(..), ToJSON(..), Value(..), Object, + emptyObject, encode, withText, withObject, (.:), (.:?), (.!=), (.=), object, typeMismatch, -- * Control.Applicative @@ -40,9 +41,9 @@ import Data.Aeson (FromJSON (..), Object, ToJSON (..), Value (..), encode, object, withObject, withText, (.!=), (.:), (.:?), (.=)) -import Data.Aeson.Types (typeMismatch) +import Data.Aeson.Types (emptyObject, typeMismatch) import Data.Binary (Binary) -import Data.Binary.Orphans () +import Data.Binary.Instances () import Data.Data (Data, Typeable) import Data.Foldable (toList) import Data.Hashable (Hashable (..)) diff --git a/src/GitHub/Request.hs b/src/GitHub/Request.hs --- a/src/GitHub/Request.hs +++ b/src/GitHub/Request.hs @@ -51,6 +51,10 @@ StatusMap, getNextUrl, performPagedRequest, + parseResponseJSON, + -- ** Preview + PreviewAccept (..), + PreviewParseResponse (..), ) where import GitHub.Internal.Prelude @@ -67,10 +71,9 @@ import Data.Tagged (Tagged (..)) import Network.HTTP.Client - (HttpException (..), Manager, RequestBody (..), Response (..), - applyBasicAuth, getUri, httpLbs, method, newManager, redirectCount, - requestBody, requestHeaders, setQueryString, setRequestIgnoreStatus) -import Network.HTTP.Client.TLS (tlsManagerSettings) + (HttpException (..), Manager, RequestBody (..), Response (..), getUri, + httpLbs, method, newManager, redirectCount, requestBody, requestHeaders, + setQueryString, setRequestIgnoreStatus) import Network.HTTP.Link.Parser (parseLinkHeaderBS) import Network.HTTP.Link.Types (Link (..), LinkParam (..), href, linkParams) import Network.HTTP.Types (Method, RequestHeaders, Status (..)) @@ -84,14 +87,43 @@ import qualified Network.HTTP.Client as HTTP import qualified Network.HTTP.Client.Internal as HTTP -import GitHub.Auth (Auth (..)) +#ifdef MIN_VERSION_http_client_tls +import Network.HTTP.Client.TLS (tlsManagerSettings) +#else +import Network.HTTP.Client.OpenSSL (opensslManagerSettings, withOpenSSL) + +import qualified OpenSSL.Session as SSL +import qualified OpenSSL.X509.SystemStore as SSL +#endif + +import GitHub.Auth (Auth, AuthMethod, endpoint, setAuthRequest) import GitHub.Data (Error (..)) import GitHub.Data.PullRequests (MergeResult (..)) import GitHub.Data.Request +#ifdef MIN_VERSION_http_client_tls +withOpenSSL :: IO a -> IO a +withOpenSSL = id +#else +tlsManagerSettings :: HTTP.ManagerSettings +tlsManagerSettings = opensslManagerSettings $ do + ctx <- SSL.context + SSL.contextAddOption ctx SSL.SSL_OP_NO_SSLv2 + SSL.contextAddOption ctx SSL.SSL_OP_NO_SSLv3 + SSL.contextAddOption ctx SSL.SSL_OP_NO_TLSv1 + SSL.contextSetCiphers ctx "ECDHE-ECDSA-AES256-GCM-SHA384:ECDHE-RSA-AES256-GCM-SHA384:ECDHE-ECDSA-CHACHA20-POLY1305:ECDHE-RSA-CHACHA20-POLY1305:ECDHE-ECDSA-AES128-GCM-SHA256:ECDHE-RSA-AES128-GCM-SHA256:ECDHE-ECDSA-AES256-SHA384:ECDHE-RSA-AES256-SHA384:ECDHE-ECDSA-AES128-SHA256:ECDHE-RSA-AES128-SHA256" + SSL.contextLoadSystemCerts ctx + SSL.contextSetVerificationMode ctx $ SSL.VerifyPeer True True Nothing + return ctx +#endif + -- | Execute 'Request' in 'IO' -executeRequest :: ParseResponse mt a => Auth -> GenRequest mt rw a -> IO (Either Error a) -executeRequest auth req = do +executeRequest + :: (AuthMethod am, ParseResponse mt a) + => am + -> GenRequest mt rw a + -> IO (Either Error a) +executeRequest auth req = withOpenSSL $ withOpenSSL $ do manager <- newManager tlsManagerSettings executeRequestWithMgr manager auth req @@ -101,9 +133,9 @@ -- | Like 'executeRequest' but with provided 'Manager'. executeRequestWithMgr - :: ParseResponse mt a + :: (AuthMethod am, ParseResponse mt a) => Manager - -> Auth + -> am -> GenRequest mt rw a -> IO (Either Error a) executeRequestWithMgr mgr auth req = runExceptT $ do @@ -129,7 +161,7 @@ -- | Like 'executeRequest' but without authentication. executeRequest' :: ParseResponse mt a => GenRequest mt 'RO a -> IO (Either Error a) -executeRequest' req = do +executeRequest' req = withOpenSSL $ do manager <- newManager tlsManagerSettings executeRequestWithMgr' manager req @@ -140,7 +172,7 @@ -> GenRequest mt 'RO a -> IO (Either Error a) executeRequestWithMgr' mgr req = runExceptT $ do - httpReq <- makeHttpRequest Nothing req + httpReq <- makeHttpRequest (Nothing :: Maybe Auth) req performHttpReq httpReq req where httpLbs' :: HTTP.Request -> ExceptT Error IO (Response LBS.ByteString) @@ -158,7 +190,11 @@ -- | Helper for picking between 'executeRequest' and 'executeRequest''. -- -- The use is discouraged. -executeRequestMaybe :: ParseResponse mt a => Maybe Auth -> GenRequest mt 'RO a -> IO (Either Error a) +executeRequestMaybe + :: (AuthMethod am, ParseResponse mt a) + => Maybe am + -> GenRequest mt 'RO a + -> IO (Either Error a) executeRequestMaybe = maybe executeRequest' executeRequest -- | Partial function to drop authentication need. @@ -171,15 +207,18 @@ -- Parse response ------------------------------------------------------------------------------- -class Accept (mt :: MediaType) where +class Accept (mt :: MediaType *) where contentType :: Tagged mt BS.ByteString contentType = Tagged "application/json" -- default is JSON modifyRequest :: Tagged mt (HTTP.Request -> HTTP.Request) modifyRequest = Tagged id -class Accept mt => ParseResponse (mt :: MediaType) a where - parseResponse :: MonadError Error m => HTTP.Request -> HTTP.Response LBS.ByteString -> Tagged mt (m a) +class Accept mt => ParseResponse (mt :: MediaType *) a where + parseResponse + :: MonadError Error m + => HTTP.Request -> HTTP.Response LBS.ByteString + -> Tagged mt (m a) ------------------------------------------------------------------------------- -- JSON (+ star) @@ -208,7 +247,7 @@ parseResponse _ res = Tagged (parseResponseJSON res) ------------------------------------------------------------------------------- --- Raw / Diff / Patch / Sha +-- Raw / Diff / Patch / Sha ------------------------------------------------------------------------------- instance Accept 'MtRaw where contentType = Tagged "application/vnd.github.v3.raw" @@ -251,6 +290,29 @@ noLocation = throwError $ ParseError "no location header in response" ------------------------------------------------------------------------------- +-- Extension point +------------------------------------------------------------------------------- + +class PreviewAccept p where + previewContentType :: Tagged ('MtPreview p) BS.ByteString + + previewModifyRequest :: Tagged ('MtPreview p) (HTTP.Request -> HTTP.Request) + previewModifyRequest = Tagged id + +class PreviewAccept p => PreviewParseResponse p a where + previewParseResponse + :: MonadError Error m + => HTTP.Request -> HTTP.Response LBS.ByteString + -> Tagged ('MtPreview p) (m a) + +instance PreviewAccept p => Accept ('MtPreview p) where + contentType = previewContentType + modifyRequest = previewModifyRequest + +instance PreviewParseResponse p a => ParseResponse ('MtPreview p) a where + parseResponse = previewParseResponse + +------------------------------------------------------------------------------- -- Status ------------------------------------------------------------------------------- @@ -293,7 +355,11 @@ -- Unit ------------------------------------------------------------------------------- -instance Accept 'MtUnit +-- | Note: we don't ignore response status. +-- +-- We only accept any response body. +instance Accept 'MtUnit where + instance a ~ () => ParseResponse 'MtUnit a where parseResponse _ _ = Tagged (return ()) @@ -308,8 +374,8 @@ -- status checking is modifying accordingly. -- makeHttpRequest - :: forall mt rw a m. (MonadThrow m, Accept mt) - => Maybe Auth + :: forall am mt rw a m. (AuthMethod am, MonadThrow m, Accept mt) + => Maybe am -> GenRequest mt rw a -> m HTTP.Request makeHttpRequest auth r = case r of @@ -318,7 +384,7 @@ return $ setReqHeaders . unTagged (modifyRequest :: Tagged mt (HTTP.Request -> HTTP.Request)) - . setAuthRequest auth + . maybe id setAuthRequest auth . setQueryString qs $ req PagedQuery paths qs _ -> do @@ -326,7 +392,7 @@ return $ setReqHeaders . unTagged (modifyRequest :: Tagged mt (HTTP.Request -> HTTP.Request)) - . setAuthRequest auth + . maybe id setAuthRequest auth . setQueryString qs $ req Command m paths body -> do @@ -334,21 +400,16 @@ return $ setReqHeaders . unTagged (modifyRequest :: Tagged mt (HTTP.Request -> HTTP.Request)) - . setAuthRequest auth + . maybe id setAuthRequest auth . setBody body . setMethod (toMethod m) $ req where parseUrl' :: MonadThrow m => Text -> m HTTP.Request - parseUrl' = HTTP.parseRequest . T.unpack + parseUrl' = HTTP.parseUrlThrow . T.unpack url :: Paths -> Text - url paths = baseUrl <> "/" <> T.intercalate "/" paths - - baseUrl :: Text - baseUrl = case auth of - Just (EnterpriseOAuth endpoint _) -> endpoint - _ -> "https://api.github.com" + url paths = maybe "https://api.github.com" id (endpoint =<< auth) <> "/" <> T.intercalate "/" paths setReqHeaders :: HTTP.Request -> HTTP.Request setReqHeaders req = req { requestHeaders = reqHeaders <> requestHeaders req } @@ -357,21 +418,11 @@ setMethod m req = req { method = m } reqHeaders :: RequestHeaders - reqHeaders = maybe [] getOAuthHeader auth - <> [("User-Agent", "github.hs/0.21")] -- Version + reqHeaders = [("User-Agent", "github.hs/0.21")] -- Version <> [("Accept", unTagged (contentType :: Tagged mt BS.ByteString))] setBody :: LBS.ByteString -> HTTP.Request -> HTTP.Request setBody body req = req { requestBody = RequestBodyLBS body } - - setAuthRequest :: Maybe Auth -> HTTP.Request -> HTTP.Request - setAuthRequest (Just (BasicAuth user pass)) = applyBasicAuth user pass - setAuthRequest _ = id - - getOAuthHeader :: Auth -> RequestHeaders - getOAuthHeader (OAuth token) = [("Authorization", "token " <> token)] - getOAuthHeader (EnterpriseOAuth _ token) = [("Authorization", "token " <> token)] - getOAuthHeader _ = [] -- | Query @Link@ header with @rel=next@ from the request headers. getNextUrl :: Response a -> Maybe URI