diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,26 @@ +## Changes for next + +## Changes for 0.21 + +- Refactor `Request` type. + [#349](https://github.com/phadej/github/pull/349) +- Allow `http-client-0.6` + [#344](https://github.com/phadej/github/pull/344) +- Change to use `cryptohash-sha1` (`cryptohash` was used before) +- Add Create milestone endponts + [#337](https://github.com/phadej/github/pull/337) +- Make fileBlobUrl and fileRawUrl are optional + [#339](https://github.com/phadej/github/issues/339) + [#340](https://github.com/phadej/github/pull/340) +- Add organizationsR to request user organizations + [#345](https://github.com/phadej/github/pull/345) +- Add updateMilestoneR, deleteMilestoneR + [#338](https://github.com/phadej/github/pull/338) +- Allow multiple assignees in NewIssue and EditIssue + [#336](https://github.com/phadej/github/pull/336) +- Add `pullRequestPatchR` and `pullRequestDiffR` + [#325](https://github.com/phadej/github/pull/325) + ## Changes for 0.20 - Add ratelimit endpoint diff --git a/github.cabal b/github.cabal --- a/github.cabal +++ b/github.cabal @@ -1,6 +1,8 @@ -name: github -version: 0.20 -synopsis: Access to the GitHub API, v3. +cabal-version: >=1.10 +name: github +version: 0.21 +synopsis: Access to the GitHub API, v3. +category: Network description: The GitHub API provides programmatic access to the full GitHub Web site, from Issues to Gists to repos down to the underlying git data @@ -17,52 +19,56 @@ > print possibleUser . For more of an overview please see the README: -license: BSD3 -license-file: LICENSE -author: Mike Burns, John Wiegley, Oleg Grenrus -maintainer: Oleg Grenrus -homepage: https://github.com/phadej/github -copyright: Copyright 2012-2013 Mike Burns, Copyright 2013-2015 John Wiegley, Copyright 2016 Oleg Grenrus -category: Network -build-type: Simple -tested-with: GHC==7.8.4, GHC==7.10.3, GHC==8.0.2, GHC==8.2.2, GHC==8.4.3, GHC==8.6.1 -cabal-version: >=1.10 + +license: BSD3 +license-file: LICENSE +author: Mike Burns, John Wiegley, Oleg Grenrus +maintainer: Oleg Grenrus +homepage: https://github.com/phadej/github +build-type: Simple +copyright: + 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 + extra-source-files: - README.md, - CHANGELOG.md, - fixtures/issue-search.json, - fixtures/list-teams.json, - fixtures/members-list.json, - fixtures/pull-request-opened.json, - fixtures/pull-request-review-requested.json, - fixtures/user-organizations.json, + README.md + CHANGELOG.md + fixtures/issue-search.json + fixtures/list-teams.json + fixtures/members-list.json + fixtures/pull-request-opened.json + fixtures/pull-request-review-requested.json + fixtures/user-organizations.json fixtures/user.json source-repository head - type: git + type: git location: git://github.com/phadej/github.git -Library - default-language: Haskell2010 - ghc-options: -Wall - hs-source-dirs: src +library + default-language: Haskell2010 + ghc-options: -Wall + hs-source-dirs: src default-extensions: DataKinds DeriveDataTypeable DeriveGeneric OverloadedStrings ScopedTypeVariables + other-extensions: CPP FlexibleContexts FlexibleInstances GADTs KindSignatures + RecordWildCards StandaloneDeriving - RecordWildCards + exposed-modules: GitHub - GitHub.Internal.Prelude GitHub.Auth GitHub.Data GitHub.Data.Activities @@ -111,8 +117,8 @@ GitHub.Endpoints.Organizations.Members GitHub.Endpoints.Organizations.Teams GitHub.Endpoints.PullRequests - GitHub.Endpoints.PullRequests.Reviews GitHub.Endpoints.PullRequests.Comments + GitHub.Endpoints.PullRequests.Reviews GitHub.Endpoints.RateLimit GitHub.Endpoints.Repos GitHub.Endpoints.Repos.Collaborators @@ -129,51 +135,53 @@ GitHub.Endpoints.Users GitHub.Endpoints.Users.Emails GitHub.Endpoints.Users.Followers + GitHub.Internal.Prelude GitHub.Request -- Packages bundles with GHC, mtl and text are also here build-depends: - base >=4.7 && <4.13, - binary >=0.7.1.0 && <0.11, - bytestring >=0.10.4.0 && <0.11, - containers >=0.5.5.1 && <0.7, - deepseq >=1.3.0.2 && <1.5, - mtl (>=2.1.3.1 && <2.2) || (>=2.2.1 && <2.3), - text >=1.2.0.6 && <1.3, - time >=1.4 && <1.10, - transformers >=0.3.0.0 && <0.6 + base >=4.7 && <4.13 + , binary >=0.7.1.0 && <0.11 + , bytestring >=0.10.4.0 && <0.11 + , containers >=0.5.5.1 && <0.7 + , deepseq >=1.3.0.2 && <1.5 + , mtl >=2.1.3.1 && <2.2 || >=2.2.1 && <2.3 + , text >=1.2.0.6 && <1.3 + , time >=1.4 && <1.10 + , transformers >=0.3.0.0 && <0.6 -- other packages build-depends: - 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, - byteable >=0.1.1 && <0.2, - cryptohash >=0.11.9 && <0.12, - deepseq-generics >=0.2.0.0 && <0.3, - exceptions >=0.10.0 && <0.11, - hashable >=1.2.7.0 && <1.3, - http-client >=0.5.12 && <0.6, - http-client-tls >=0.3.5.3 && <0.4, - http-link-header >=1.0.3.1 && <1.1, - http-types >=0.12.1 && <0.13, - iso8601-time >=0.1.5 && <0.2, - network-uri >=2.6.1.0 && <2.7, - semigroups >=0.18.5 && <0.19, - transformers-compat >=0.6 && <0.7, - unordered-containers >=0.2.9.0 && <0.3, - vector >=0.12.0.1 && <0.13, - vector-instances >=3.4 && <3.5, - - tls >=1.4.1 + 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 + , 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 + , 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 + , 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 + , vector >=0.12.0.1 && <0.13 + , vector-instances >=3.4 && <3.5 test-suite github-test - default-language: Haskell2010 - type: exitcode-stdio-1.0 - hs-source-dirs: spec - other-extensions: - TemplateHaskell + 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 + other-extensions: TemplateHaskell other-modules: GitHub.ActivitySpec GitHub.CommitsSpec @@ -187,15 +195,14 @@ GitHub.ReposSpec GitHub.SearchSpec GitHub.UsersSpec - main-is: Spec.hs - ghc-options: -Wall - build-tool-depends: hspec-discover:hspec-discover >=2.5.6 && <2.6 - build-depends: base, - base-compat, - aeson, - bytestring, - github, - vector, - unordered-containers, - file-embed, - hspec >= 2.5.6 && <2.6 + + build-depends: + aeson + , base + , base-compat + , bytestring + , file-embed + , github + , hspec >=2.6.1 && <2.8 + , unordered-containers + , vector diff --git a/spec/GitHub/CommitsSpec.hs b/spec/GitHub/CommitsSpec.hs --- a/spec/GitHub/CommitsSpec.hs +++ b/spec/GitHub/CommitsSpec.hs @@ -5,7 +5,7 @@ import qualified GitHub import GitHub.Auth (Auth (..)) -import GitHub.Endpoints.Repos.Commits (Commit, commitSha, commitsFor', +import GitHub.Endpoints.Repos.Commits (commitSha, commitsFor', commitsForR, diffR, mkCommitName) import GitHub.Request (executeRequest) @@ -59,4 +59,9 @@ it "issue #155" $ withAuth $ \auth -> do d <- executeRequest auth $ diffR "nomeata" "codespeed" (mkCommitName "ghc") (mkCommitName "tobami:master") + d `shouldSatisfy` isRight + + -- diff that includes a commit where a submodule is removed + it "issue #339" $ withAuth $ \auth -> do + d <- executeRequest auth $ diffR "scott-fleischman" "repo-remove-submodule" "d03c152482169d809be9b1eab71dcf64d7405f76" "42cfd732b20cd093534f246e630b309186eb485d" d `shouldSatisfy` isRight diff --git a/spec/GitHub/IssuesSpec.hs b/spec/GitHub/IssuesSpec.hs --- a/spec/GitHub/IssuesSpec.hs +++ b/spec/GitHub/IssuesSpec.hs @@ -10,7 +10,8 @@ import Data.Foldable (for_) import Data.String (fromString) import System.Environment (lookupEnv) -import Test.Hspec (Spec, describe, it, pendingWith, shouldSatisfy) +import Test.Hspec + (Spec, describe, expectationFailure, it, pendingWith, shouldSatisfy) fromRightS :: Show a => Either a b -> b fromRightS (Right b) = b @@ -28,11 +29,17 @@ describe "issuesForRepoR" $ do it "works" $ withAuth $ \auth -> for_ repos $ \(owner, repo) -> do cs <- GitHub.executeRequest auth $ - GitHub.issuesForRepoR owner repo mempty GitHub.FetchAll - cs `shouldSatisfy` isRight + GitHub.issuesForRepoR owner repo mempty GitHub.FetchAll + case cs of + Left e -> + expectationFailure . show $ e + Right cs' -> do + for_ cs' $ \i -> do + cms <- GitHub.executeRequest auth $ + GitHub.commentsR owner repo (GitHub.issueNumber i) 1 + cms `shouldSatisfy` isRight where repos = [ ("thoughtbot", "paperclip") , ("phadej", "github") - , ("haskell", "cabal") ] diff --git a/spec/GitHub/PullRequestsSpec.hs b/spec/GitHub/PullRequestsSpec.hs --- a/spec/GitHub/PullRequestsSpec.hs +++ b/spec/GitHub/PullRequestsSpec.hs @@ -3,7 +3,6 @@ module GitHub.PullRequestsSpec where import qualified GitHub -import GitHub.Data.Id (Id (Id)) import Prelude () import Prelude.Compat @@ -15,6 +14,7 @@ import Data.Foldable (for_) import Data.String (fromString) import qualified Data.Vector as V +import qualified Data.ByteString.Lazy.Char8 as LBS8 import System.Environment (lookupEnv) import Test.Hspec (Spec, describe, it, pendingWith, shouldBe, shouldSatisfy) @@ -38,6 +38,12 @@ GitHub.pullRequestsForR owner repo opts GitHub.FetchAll cs `shouldSatisfy` isRight + describe "pullRequestPatchR" $ + it "works" $ withAuth $ \auth -> do + Right patch <- GitHub.executeRequest auth $ + GitHub.pullRequestPatchR "phadej" "github" (GitHub.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) @@ -55,7 +61,7 @@ describe "checking if a pull request is merged" $ do it "works" $ withAuth $ \auth -> do - b <- GitHub.executeRequest auth $ GitHub.isPullRequestMergedR "phadej" "github" (Id 14) + b <- GitHub.executeRequest auth $ GitHub.isPullRequestMergedR "phadej" "github" (GitHub.IssueNumber 14) b `shouldSatisfy` isRight fromRightS b `shouldBe` True @@ -63,7 +69,6 @@ repos = [ ("thoughtbot", "paperclip") , ("phadej", "github") - , ("haskell", "cabal") ] opts = GitHub.stateClosed diff --git a/spec/GitHub/RateLimitSpec.hs b/spec/GitHub/RateLimitSpec.hs --- a/spec/GitHub/RateLimitSpec.hs +++ b/spec/GitHub/RateLimitSpec.hs @@ -7,7 +7,6 @@ import Prelude.Compat import Data.Either.Compat (isRight) -import Data.Foldable (for_) import Data.String (fromString) import System.Environment (lookupEnv) import Test.Hspec (Spec, describe, it, pendingWith, shouldSatisfy) diff --git a/spec/GitHub/SearchSpec.hs b/spec/GitHub/SearchSpec.hs --- a/spec/GitHub/SearchSpec.hs +++ b/spec/GitHub/SearchSpec.hs @@ -14,7 +14,8 @@ import qualified Data.Vector as V -import GitHub.Data (Auth (..), Issue (..), IssueState (..), mkId) +import GitHub.Data + (Auth (..), Issue (..), IssueNumber (..), IssueState (..), mkId) import GitHub.Endpoints.Search (SearchResult (..), searchIssues') fromRightS :: Show a => Either a b -> b @@ -40,13 +41,13 @@ let issue1 = issues V.! 0 issueId issue1 `shouldBe` mkId (Proxy :: Proxy Issue) 123898390 - issueNumber issue1 `shouldBe` 130 + issueNumber issue1 `shouldBe` IssueNumber 130 issueTitle issue1 `shouldBe` "Make test runner more robust" issueState issue1 `shouldBe` StateClosed let issue2 = issues V.! 1 issueId issue2 `shouldBe` mkId (Proxy :: Proxy Issue) 119694665 - issueNumber issue2 `shouldBe` 127 + issueNumber issue2 `shouldBe` IssueNumber 127 issueTitle issue2 `shouldBe` "Decouple request creation from execution" issueState issue2 `shouldBe` StateOpen diff --git a/src/GitHub.hs b/src/GitHub.hs --- a/src/GitHub.hs +++ b/src/GitHub.hs @@ -137,13 +137,14 @@ -- ** Milestone -- | See -- - -- Missing endpoints: - -- - -- * Create a milestone - -- * Update a milestone - -- * Delete a milestone milestonesR, milestoneR, + createMilestone, + createMilestoneR, + updateMilestone, + updateMilestoneR, + deleteMilestone, + deleteMilestoneR, -- * Organizations -- | See @@ -155,6 +156,7 @@ -- * Edit an organization publicOrganizationsForR, publicOrganizationR, + organizationsR, -- ** Members -- | See -- @@ -191,6 +193,8 @@ -- | See pullRequestsForR, pullRequestR, + pullRequestPatchR, + pullRequestDiffR, createPullRequestR, updatePullRequestR, pullRequestCommitsR, @@ -204,11 +208,11 @@ -- Missing endpoints: -- -- * List comments in a repository - -- * Create a comment -- * Edit a comment -- * Delete a comment pullRequestCommentsR, pullRequestCommentR, + createPullCommentR, -- ** Pull request reviews -- | See @@ -251,6 +255,7 @@ -- | See collaboratorsOnR, isCollaboratorOnR, + addCollaboratorR, -- ** Comments -- | See diff --git a/src/GitHub/Data.hs b/src/GitHub/Data.hs --- a/src/GitHub/Data.hs +++ b/src/GitHub/Data.hs @@ -30,6 +30,8 @@ mkRepoId, fromUserId, fromOrganizationId, + -- * IssueNumber + IssueNumber (..), -- * Module re-exports module GitHub.Auth, module GitHub.Data.Activities, diff --git a/src/GitHub/Data/Comments.hs b/src/GitHub/Data/Comments.hs --- a/src/GitHub/Data/Comments.hs +++ b/src/GitHub/Data/Comments.hs @@ -64,3 +64,22 @@ instance ToJSON EditComment where toJSON (EditComment b) = object [ "body" .= b ] + +data NewPullComment = NewPullComment + { newPullCommentCommit :: !Text + , newPullCommentPath :: !Text + , newPullCommentPosition :: !Int + , newPullCommentBody :: !Text + } + deriving (Show, Data, Typeable, Eq, Ord, Generic) + +instance NFData NewPullComment where rnf = genericRnf +instance Binary NewPullComment + +instance ToJSON NewPullComment where + toJSON (NewPullComment c path pos b) = + object [ "body" .= b + , "commit_id" .= c + , "path" .= path + , "position" .= pos + ] 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 @@ -238,6 +238,28 @@ type Count = Int ------------------------------------------------------------------------------- +-- IssueNumber +------------------------------------------------------------------------------- + +newtype IssueNumber = IssueNumber Int + deriving (Eq, Ord, Show, Generic, Typeable, Data) + +unIssueNumber :: IssueNumber -> Int +unIssueNumber (IssueNumber i) = i + +instance Hashable IssueNumber +instance Binary IssueNumber + +instance NFData IssueNumber where + rnf (IssueNumber s) = rnf s + +instance FromJSON IssueNumber where + parseJSON = fmap IssueNumber . parseJSON + +instance ToJSON IssueNumber where + toJSON = toJSON . unIssueNumber + +------------------------------------------------------------------------------- -- IssueLabel ------------------------------------------------------------------------------- diff --git a/src/GitHub/Data/GitData.hs b/src/GitHub/Data/GitData.hs --- a/src/GitHub/Data/GitData.hs +++ b/src/GitHub/Data/GitData.hs @@ -184,9 +184,9 @@ instance Binary GitUser data File = File - { fileBlobUrl :: !URL + { fileBlobUrl :: !(Maybe URL) , fileStatus :: !Text - , fileRawUrl :: !URL + , fileRawUrl :: !(Maybe URL) , fileAdditions :: !Int , fileSha :: !Text , fileChanges :: !Int @@ -251,9 +251,9 @@ instance FromJSON File where parseJSON = withObject "File" $ \o -> File - <$> o .: "blob_url" + <$> o .:? "blob_url" <*> o .: "status" - <*> o .: "raw_url" + <*> o .:? "raw_url" <*> o .: "additions" <*> o .: "sha" <*> o .: "changes" 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 @@ -13,7 +13,7 @@ import GitHub.Data.PullRequests import GitHub.Data.URL (URL) import GitHub.Internal.Prelude -import Prelude () +import Prelude () data Issue = Issue { issueClosedAt :: !(Maybe UTCTime) @@ -22,7 +22,7 @@ , issueHtmlUrl :: !(Maybe URL) , issueClosedBy :: !(Maybe SimpleUser) , issueLabels :: !(Vector IssueLabel) - , issueNumber :: !Int + , issueNumber :: !IssueNumber , issueAssignees :: !(Vector SimpleUser) , issueUser :: !SimpleUser , issueTitle :: !Text @@ -43,7 +43,7 @@ data NewIssue = NewIssue { newIssueTitle :: !Text , newIssueBody :: !(Maybe Text) - , newIssueAssignee :: !(Maybe Text) + , newIssueAssignees :: !(Vector (Name User)) , newIssueMilestone :: !(Maybe (Id Milestone)) , newIssueLabels :: !(Maybe (Vector (Name IssueLabel))) } @@ -55,7 +55,7 @@ data EditIssue = EditIssue { editIssueTitle :: !(Maybe Text) , editIssueBody :: !(Maybe Text) - , editIssueAssignee :: !(Maybe (Name User)) + , editIssueAssignees :: !(Maybe (Vector (Name User))) , editIssueState :: !(Maybe IssueState) , editIssueMilestone :: !(Maybe (Id Milestone)) , editIssueLabels :: !(Maybe (Vector (Name IssueLabel))) @@ -203,19 +203,22 @@ <*> o .:? "milestone" instance ToJSON NewIssue where - toJSON (NewIssue t b a m ls) = object + toJSON (NewIssue t b a m ls) = object $ filter notNull [ "title" .= t , "body" .= b - , "assignee" .= a + , "assignees" .= a , "milestone" .= m , "labels" .= ls ] + where + notNull (_, Null) = False + notNull (_, _) = True instance ToJSON EditIssue where - toJSON (EditIssue t b a s m ls) = object $ filter notNull $ + toJSON (EditIssue t b a s m ls) = object $ filter notNull [ "title" .= t , "body" .= b - , "assignee" .= a + , "assignees" .= a , "state" .= s , "milestone" .= m , "labels" .= ls diff --git a/src/GitHub/Data/Milestone.hs b/src/GitHub/Data/Milestone.hs --- a/src/GitHub/Data/Milestone.hs +++ b/src/GitHub/Data/Milestone.hs @@ -40,3 +40,49 @@ <*> o .: "url" <*> o .: "created_at" <*> o .: "state" + +data NewMilestone = NewMilestone + { newMilestoneTitle :: !Text + , newMilestoneState :: !Text + , newMilestoneDescription :: !(Maybe Text) + , newMilestoneDueOn :: !(Maybe UTCTime) + } + deriving (Show, Data, Typeable, Eq, Ord, Generic) + +instance NFData NewMilestone where rnf = genericRnf +instance Binary NewMilestone + + +instance ToJSON NewMilestone where + toJSON (NewMilestone title state desc due) = object $ filter notNull + [ "title" .= title + , "state" .= state + , "description" .= desc + , "due_on" .= due + ] + where + notNull (_, Null) = False + notNull (_, _) = True + +data UpdateMilestone = UpdateMilestone + { updateMilestoneTitle :: !(Maybe Text) + , updateMilestoneState :: !(Maybe Text) + , updateMilestoneDescription :: !(Maybe Text) + , updateMilestoneDueOn :: !(Maybe UTCTime) + } + deriving (Show, Data, Typeable, Eq, Ord, Generic) + +instance NFData UpdateMilestone where rnf = genericRnf +instance Binary UpdateMilestone + + +instance ToJSON UpdateMilestone where + toJSON (UpdateMilestone title state desc due) = object $ filter notNull + [ "title" .= title + , "state" .= state + , "description" .= desc + , "due_on" .= due + ] + where + notNull (_, Null) = False + notNull (_, _) = True 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 @@ -14,14 +14,12 @@ PullRequestEventType(..), PullRequestReference(..), MergeResult(..), - statusMerge, ) where import GitHub.Data.Definitions import GitHub.Data.Id (Id) import GitHub.Data.Options (IssueState (..), MergeableState (..)) import GitHub.Data.Repos (Repo) -import GitHub.Data.Request (StatusMap) import GitHub.Data.URL (URL) import GitHub.Internal.Prelude import Prelude () @@ -34,7 +32,7 @@ , simplePullRequestUser :: !SimpleUser , simplePullRequestPatchUrl :: !URL , simplePullRequestState :: !IssueState - , simplePullRequestNumber :: !Int + , simplePullRequestNumber :: !IssueNumber , simplePullRequestHtmlUrl :: !URL , simplePullRequestUpdatedAt :: !UTCTime , simplePullRequestBody :: !(Maybe Text) @@ -59,7 +57,7 @@ , pullRequestUser :: !SimpleUser , pullRequestPatchUrl :: !URL , pullRequestState :: !IssueState - , pullRequestNumber :: !Int + , pullRequestNumber :: !IssueNumber , pullRequestHtmlUrl :: !URL , pullRequestUpdatedAt :: !UTCTime , pullRequestBody :: !(Maybe Text) @@ -319,10 +317,3 @@ | MergeCannotPerform | MergeConflict deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) - -statusMerge :: StatusMap MergeResult -statusMerge = - [ (200, MergeSuccessful) - , (405, MergeCannotPerform) - , (409, MergeConflict) - ] 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 @@ -10,36 +10,33 @@ -- module GitHub.Data.Request ( -- * Request - Request (..), - SimpleRequest (..), + Request, + GenRequest (..), -- * Smart constructors query, pagedQuery, command, -- * Auxiliary types RW(..), - StatusMap, - statusOnlyOk, CommandMethod(..), toMethod, FetchCount(..), + MediaType (..), Paths, IsPathPart(..), QueryString, Count, ) where -import GitHub.Data.Definitions (Count, QueryString) +import GitHub.Data.Definitions (Count, QueryString, IssueNumber, unIssueNumber) import GitHub.Data.Id (Id, untagId) import GitHub.Data.Name (Name, untagName) import GitHub.Internal.Prelude import qualified Data.ByteString.Lazy as LBS import qualified Data.Text as T -import qualified Network.HTTP.Types as Types import qualified Network.HTTP.Types.Method as Method -import Network.URI (URI) ------------------------------------------------------------------------------ --- Auxillary types +-- Path parts ------------------------------------------------------------------------------ type Paths = [Text] @@ -53,39 +50,33 @@ instance IsPathPart (Id a) where toPathPart = T.pack . show . untagId --- | Http method of requests with body. -data CommandMethod a where - Post :: CommandMethod a - Patch :: CommandMethod a - Put :: CommandMethod a - Put' :: CommandMethod () - Delete :: CommandMethod () - deriving (Typeable) +instance IsPathPart IssueNumber where + toPathPart = T.pack . show . unIssueNumber -deriving instance Eq (CommandMethod a) -deriving instance Ord (CommandMethod a) +------------------------------------------------------------------------------- +-- Command Method +------------------------------------------------------------------------------- -instance Show (CommandMethod a) where - showsPrec _ Post = showString "Post" - showsPrec _ Patch = showString "Patch" - showsPrec _ Put = showString "Put" - showsPrec _ Put' = showString "Put'" - showsPrec _ Delete = showString "Delete" +-- | Http method of requests with body. +data CommandMethod + = Post + | Patch + | Put + | Delete + deriving (Eq, Ord, Read, Show, Enum, Bounded, Typeable, Data, Generic) -instance Hashable (CommandMethod a) where - hashWithSalt salt Post = hashWithSalt salt (0 :: Int) - hashWithSalt salt Patch = hashWithSalt salt (1 :: Int) - hashWithSalt salt Put = hashWithSalt salt (2 :: Int) - hashWithSalt salt Put' = hashWithSalt salt (3 :: Int) - hashWithSalt salt Delete = hashWithSalt salt (4 :: Int) +instance Hashable CommandMethod -toMethod :: CommandMethod a -> Method.Method +toMethod :: CommandMethod -> Method.Method toMethod Post = Method.methodPost toMethod Patch = Method.methodPatch toMethod Put = Method.methodPut -toMethod Put' = Method.methodPut toMethod Delete = Method.methodDelete +------------------------------------------------------------------------------- +-- Fetch count +------------------------------------------------------------------------------- + -- | 'PagedQuery' returns just some results, using this data we can specify how -- many pages we want to fetch. data FetchCount = FetchAtLeast !Word | FetchAll @@ -110,15 +101,31 @@ instance Binary FetchCount instance NFData FetchCount where rnf = genericRnf +------------------------------------------------------------------------------- +-- 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) + ------------------------------------------------------------------------------ --- Github request +-- RW ------------------------------------------------------------------------------ -- | Type used as with @DataKinds@ to tag whether requests need authentication -- or aren't read-only. data RW = RO -- ^ /Read-only/, doesn't necessarily requires authentication - | RA -- ^ /Read autenticated/ + | RA -- ^ /Read authenticated/ | RW -- ^ /Read-write/, requires authentication deriving (Eq, Ord, Read, Show, Enum, Bounded, Typeable, Data, Generic) @@ -133,100 +140,54 @@ instance IReadOnly 'RA where iro = ROA -} +------------------------------------------------------------------------------- +-- GitHub Request +------------------------------------------------------------------------------- + -- | Github request data type. -- --- * @k@ describes whether authentication is required. It's required for non-@GET@ requests. +-- * @rw@ describes whether authentication is required. It's required for non-@GET@ requests. +-- * @mt@ describes the media type, i.e. how the response should be interpreted. -- * @a@ is the result type -- -- /Note:/ 'Request' is not 'Functor' on purpose. -data Request (k :: RW) a where - SimpleQuery :: FromJSON a => SimpleRequest k a -> Request k a - StatusQuery :: StatusMap a -> SimpleRequest k () -> Request k a - HeaderQuery :: FromJSON a => Types.RequestHeaders -> SimpleRequest k a -> Request k a - RedirectQuery :: SimpleRequest k () -> Request k URI - deriving (Typeable) +data GenRequest (mt :: MediaType) (rw :: RW) a where + Query :: Paths -> QueryString -> GenRequest mt rw a + PagedQuery :: Paths -> QueryString -> FetchCount -> GenRequest mt rw (Vector a) -data SimpleRequest (k :: RW) a where - Query :: Paths -> QueryString -> SimpleRequest k a - PagedQuery :: Paths -> QueryString -> FetchCount -> SimpleRequest k (Vector a) - Command :: CommandMethod a -> Paths -> LBS.ByteString -> SimpleRequest 'RW a + -- | Command + Command + :: CommandMethod -- ^ command + -> Paths -- ^ path + -> LBS.ByteString -- ^ body + -> GenRequest mt 'RW a deriving (Typeable) -------------------------------------------------------------------------------- --- Status Map -------------------------------------------------------------------------------- - --- TODO: Change to 'Map' ? -type StatusMap a = [(Int, a)] - -statusOnlyOk :: StatusMap Bool -statusOnlyOk = - [ (204, True) - , (404, False) - ] +-- | Most requests ask for @JSON@. +type Request = GenRequest 'MtJSON ------------------------------------------------------------------------------- -- Smart constructors ------------------------------------------------------------------------------- -query :: FromJSON a => Paths -> QueryString -> Request k a -query ps qs = SimpleQuery (Query ps qs) +query :: Paths -> QueryString -> Request mt a +query ps qs = Query ps qs -pagedQuery :: FromJSON a => Paths -> QueryString -> FetchCount -> Request k (Vector a) -pagedQuery ps qs fc = SimpleQuery (PagedQuery ps qs fc) +pagedQuery :: FromJSON a => Paths -> QueryString -> FetchCount -> Request mt (Vector a) +pagedQuery ps qs fc = PagedQuery ps qs fc -command :: FromJSON a => CommandMethod a -> Paths -> LBS.ByteString -> Request 'RW a -command m ps body = SimpleQuery (Command m ps body) +command :: CommandMethod -> Paths -> LBS.ByteString -> Request 'RW a +command m ps body = Command m ps body ------------------------------------------------------------------------------- -- Instances ------------------------------------------------------------------------------- -deriving instance Eq a => Eq (Request k a) -deriving instance Eq a => Eq (SimpleRequest k a) - -deriving instance Ord a => Ord (Request k a) -deriving instance Ord a => Ord (SimpleRequest k a) - -instance Show (SimpleRequest k a) where - showsPrec d r = showParen (d > appPrec) $ case r of - Query ps qs -> showString "Query " - . showsPrec (appPrec + 1) ps - . showString " " - . showsPrec (appPrec + 1) qs - PagedQuery ps qs l -> showString "PagedQuery " - . showsPrec (appPrec + 1) ps - . showString " " - . showsPrec (appPrec + 1) qs - . showString " " - . showsPrec (appPrec + 1) l - Command m ps body -> showString "Command " - . showsPrec (appPrec + 1) m - . showString " " - . showsPrec (appPrec + 1) ps - . showString " " - . showsPrec (appPrec + 1) body - where - appPrec = 10 :: Int - -instance Show (Request k a) where - showsPrec d r = showParen (d > appPrec) $ case r of - SimpleQuery req -> showString "SimpleQuery " - . showsPrec (appPrec + 1) req - StatusQuery m req -> showString "Status " - . showsPrec (appPrec + 1) (map fst m) -- !!! printing only keys - . showString " " - . showsPrec (appPrec + 1) req - HeaderQuery m req -> showString "Header " - . showsPrec (appPrec + 1) m - . showString " " - . showsPrec (appPrec + 1) req - RedirectQuery req -> showString "Redirect " - . showsPrec (appPrec + 1) req - where - appPrec = 10 :: Int +deriving instance Eq (GenRequest rw mt a) +deriving instance Ord (GenRequest rw mt a) +deriving instance Show (GenRequest rw mt a) -instance Hashable (SimpleRequest k a) where +instance Hashable (GenRequest rw mt a) where hashWithSalt salt (Query ps qs) = salt `hashWithSalt` (0 :: Int) `hashWithSalt` ps @@ -242,18 +203,4 @@ `hashWithSalt` ps `hashWithSalt` body -instance Hashable (Request k a) where - hashWithSalt salt (SimpleQuery req) = - salt `hashWithSalt` (0 :: Int) - `hashWithSalt` req - hashWithSalt salt (StatusQuery sm req) = - salt `hashWithSalt` (1 :: Int) - `hashWithSalt` map fst sm - `hashWithSalt` req - hashWithSalt salt (HeaderQuery h req) = - salt `hashWithSalt` (2 :: Int) - `hashWithSalt` h - `hashWithSalt` req - hashWithSalt salt (RedirectQuery req) = - salt `hashWithSalt` (3 :: Int) - `hashWithSalt` req +-- TODO: Binary diff --git a/src/GitHub/Data/Webhooks/Validate.hs b/src/GitHub/Data/Webhooks/Validate.hs --- a/src/GitHub/Data/Webhooks/Validate.hs +++ b/src/GitHub/Data/Webhooks/Validate.hs @@ -12,9 +12,8 @@ import GitHub.Internal.Prelude import Prelude () -import Crypto.Hash (HMAC, SHA1, hmac, hmacGetDigest) -import Data.Byteable (constEqBytes, toBytes) -import Data.ByteString (ByteString) +import Crypto.Hash.SHA1 (hmac) +import Data.ByteString (ByteString) import qualified Data.ByteString.Base16 as Hex import qualified Data.Text.Encoding as TE @@ -30,10 +29,9 @@ -- including the 'sha1=...' prefix -> ByteString -- ^ the body -> Bool -isValidPayload secret shaOpt payload = maybe False (constEqBytes sign) shaOptBS +isValidPayload secret shaOpt payload = maybe False (sign ==) shaOptBS where shaOptBS = TE.encodeUtf8 <$> shaOpt - hexDigest = Hex.encode . toBytes . hmacGetDigest - - hm = hmac (TE.encodeUtf8 secret) payload :: HMAC SHA1 + hexDigest = Hex.encode + hm = hmac (TE.encodeUtf8 secret) payload sign = "sha1=" <> hexDigest hm 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 @@ -71,8 +71,8 @@ -- | All the repos starred by the authenticated user. -- See -myStarredAcceptStarR :: FetchCount -> Request 'RA (Vector RepoStarred) -myStarredAcceptStarR = HeaderQuery [("Accept", "application/vnd.github.v3.star+json")] . PagedQuery ["user", "starred"] [] +myStarredAcceptStarR :: FetchCount -> GenRequest 'MtStar 'RA (Vector RepoStarred) +myStarredAcceptStarR = PagedQuery ["user", "starred"] [] -- | Star a repo by the authenticated user. starRepo :: Auth -> Name Owner -> Name Repo -> IO (Either Error ()) @@ -80,8 +80,8 @@ -- | Star a repo by the authenticated user. -- See -starRepoR :: Name Owner -> Name Repo -> Request 'RW () -starRepoR user repo = command Put' paths mempty +starRepoR :: Name Owner -> Name Repo -> GenRequest 'MtUnit 'RW () +starRepoR user repo = Command Put paths mempty where paths = ["user", "starred", toPathPart user, toPathPart repo] 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 @@ -70,8 +70,8 @@ -- | Star a gist by the authenticated user. -- See -starGistR :: Name Gist -> Request 'RW () -starGistR gid = command Put' ["gists", toPathPart gid, "star"] mempty +starGistR :: Name Gist -> GenRequest 'MtUnit 'RW () +starGistR gid = Command Put ["gists", toPathPart gid, "star"] mempty -- | Unstar a gist by the authenticated user. -- 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 @@ -85,7 +85,7 @@ -- Creating new issues. newIssue :: Text -> NewIssue -newIssue title = NewIssue title Nothing Nothing Nothing Nothing +newIssue title = NewIssue title Nothing mempty Nothing Nothing -- | Create a new 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 @@ -41,19 +41,19 @@ -- | All comments on an issue, by the issue's number. -- -- > comments "thoughtbot" "paperclip" 635 -comments :: Name Owner -> Name Repo -> Id Issue -> IO (Either Error (Vector IssueComment)) +comments :: Name Owner -> Name Repo -> IssueNumber -> IO (Either Error (Vector IssueComment)) comments = comments' Nothing -- | All comments on an issue, by the issue's number, using authentication. -- -- > comments' (User (user, password)) "thoughtbot" "paperclip" 635 -comments' :: Maybe Auth -> Name Owner -> Name Repo -> Id Issue -> IO (Either Error (Vector IssueComment)) +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 -- | List comments on an issue. -- See -commentsR :: Name Owner -> Name Repo -> Id Issue -> FetchCount -> Request k (Vector IssueComment) +commentsR :: Name Owner -> Name Repo -> IssueNumber -> FetchCount -> Request k (Vector IssueComment) commentsR user repo iid = pagedQuery ["repos", toPathPart user, toPathPart repo, "issues", toPathPart iid, "comments"] [] @@ -61,14 +61,14 @@ -- -- > createComment (User (user, password)) user repo issue -- > "some words" -createComment :: Auth -> Name Owner -> Name Repo -> Id Issue -> Text +createComment :: Auth -> Name Owner -> Name Repo -> IssueNumber -> Text -> IO (Either Error Comment) createComment auth user repo iss body = executeRequest auth $ createCommentR user repo iss body -- | Create a comment. -- See -createCommentR :: Name Owner -> Name Repo -> Id Issue -> Text -> Request 'RW Comment +createCommentR :: Name Owner -> Name Repo -> IssueNumber -> Text -> Request 'RW Comment createCommentR user repo iss body = command Post parts (encode $ NewComment body) where 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 @@ -11,6 +11,12 @@ milestonesR, milestone, milestoneR, + createMilestone, + createMilestoneR, + updateMilestone, + updateMilestoneR, + deleteMilestone, + deleteMilestoneR, module GitHub.Data, ) where @@ -50,3 +56,31 @@ milestoneR :: Name Owner -> Name Repo -> Id Milestone -> Request k Milestone milestoneR user repo mid = query ["repos", toPathPart user, toPathPart repo, "milestones", toPathPart mid] [] + +createMilestone :: Auth -> Name Owner -> Name Repo -> NewMilestone -> IO (Either Error Milestone) +createMilestone auth user repo mlstn = executeRequest auth $ createMilestoneR user repo mlstn + +-- | Create a milestone. +-- See +createMilestoneR :: Name Owner -> Name Repo -> NewMilestone -> Request 'RW Milestone +createMilestoneR user repo = + command Post ["repos", toPathPart user, toPathPart repo, "milestones"] . encode + +updateMilestone :: Auth -> Name Owner -> Name Repo -> Id Milestone -> UpdateMilestone -> IO (Either Error Milestone) +updateMilestone auth user repo mid mlstn = executeRequest auth $ updateMilestoneR user repo mid mlstn + +-- | Update a milestone. +-- See +updateMilestoneR :: Name Owner -> Name Repo -> Id Milestone -> UpdateMilestone -> Request 'RW Milestone +updateMilestoneR user repo mid = + command Patch ["repos", toPathPart user, toPathPart repo, "milestones", toPathPart mid ] . encode + +deleteMilestone :: Auth -> Name Owner -> Name Repo -> Id Milestone -> IO (Either Error ()) +deleteMilestone auth user repo mid = executeRequest auth $ deleteMilestoneR user repo mid + +-- | Delete a milestone. +-- See +deleteMilestoneR :: Name Owner -> Name Repo -> Id Milestone -> Request 'RW () +deleteMilestoneR user repo mid = + 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 @@ -11,6 +11,7 @@ publicOrganization, publicOrganization', publicOrganizationR, + organizationsR, module GitHub.Data, ) where @@ -32,7 +33,12 @@ publicOrganizationsFor :: Name User -> IO (Either Error (Vector SimpleOrganization)) publicOrganizationsFor = publicOrganizationsFor' Nothing --- | List user organizations. +-- | List all user organizations. +-- See +organizationsR :: FetchCount -> Request k (Vector SimpleOrganization) +organizationsR = pagedQuery ["user", "orgs"] [] + +-- | List public user organizations. -- See publicOrganizationsForR :: Name User -> FetchCount -> Request k (Vector SimpleOrganization) publicOrganizationsForR user = pagedQuery ["users", toPathPart user, "orgs"] [] diff --git a/src/GitHub/Endpoints/Organizations/Members.hs b/src/GitHub/Endpoints/Organizations/Members.hs --- a/src/GitHub/Endpoints/Organizations/Members.hs +++ b/src/GitHub/Endpoints/Organizations/Members.hs @@ -77,8 +77,8 @@ -- | Check if a user is a member of an organization. -- -- See -isMemberOfR :: Name User -> Name Organization -> Request k Bool -isMemberOfR user org = StatusQuery statusOnlyOk $ +isMemberOfR :: Name User -> Name Organization -> GenRequest 'MtStatus rw Bool +isMemberOfR user org = Query [ "orgs", toPathPart org, "members", toPathPart user ] [] -- | List pending organization invitations 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 @@ -168,9 +168,9 @@ -- | Add or update a team repository. -- See -addOrUpdateTeamRepoR :: Id Team -> Name Organization -> Name Repo -> Permission -> Request 'RW () +addOrUpdateTeamRepoR :: Id Team -> Name Organization -> Name Repo -> Permission -> GenRequest 'MtUnit 'RW () addOrUpdateTeamRepoR tid org repo permission = - command Put' ["teams", toPathPart tid, "repos", toPathPart org, toPathPart repo] (encode $ AddTeamRepoPermission permission) + Command Put ["teams", toPathPart tid, "repos", toPathPart org, toPathPart repo] (encode $ AddTeamRepoPermission permission) -- | Retrieve team mebership information for a user. -- With authentication 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 @@ -12,6 +12,12 @@ pullRequest', pullRequest, pullRequestR, + pullRequestDiff', + pullRequestDiff, + pullRequestDiffR, + pullRequestPatch', + pullRequestPatch, + pullRequestPatchR, createPullRequest, createPullRequestR, updatePullRequest, @@ -33,6 +39,7 @@ import GitHub.Internal.Prelude import GitHub.Request import Prelude () +import Data.ByteString.Lazy (ByteString) -- | All open pull requests for the repo, by owner and repo name. -- @@ -60,12 +67,47 @@ ["repos", toPathPart user, toPathPart repo, "pulls"] (prModToQueryString opts) +-- | Obtain the diff of a pull request +-- See +pullRequestDiff' :: Maybe Auth -> Name Owner -> Name Repo -> IssueNumber -> IO (Either Error ByteString) +pullRequestDiff' auth user repo prid = + executeRequestMaybe auth $ pullRequestDiffR user repo prid + +-- | Obtain the diff of a pull request +-- See +pullRequestDiff :: Name Owner -> Name Repo -> IssueNumber -> IO (Either Error ByteString) +pullRequestDiff = pullRequestDiff' Nothing + +-- | Query a single pull request to obtain the diff +-- See +pullRequestDiffR :: Name Owner -> Name Repo -> IssueNumber -> GenRequest 'MtDiff rw ByteString +pullRequestDiffR user repo prid = + Query ["repos", toPathPart user, toPathPart repo, "pulls", toPathPart prid] [] + +-- | Obtain the patch of a pull request +-- +-- See +pullRequestPatch' :: Maybe Auth -> Name Owner -> Name Repo -> IssueNumber -> IO (Either Error ByteString) +pullRequestPatch' auth user repo prid = + executeRequestMaybe auth $ pullRequestPatchR user repo prid + +-- | Obtain the patch of a pull request +-- See +pullRequestPatch :: Name Owner -> Name Repo -> IssueNumber -> IO (Either Error ByteString) +pullRequestPatch = pullRequestPatch' Nothing + +-- | Query a single pull request to obtain the patch +-- See +pullRequestPatchR :: Name Owner -> Name Repo -> IssueNumber -> GenRequest 'MtPatch rw ByteString +pullRequestPatchR user repo prid = + Query ["repos", toPathPart user, toPathPart repo, "pulls", toPathPart prid] [] + -- | A detailed pull request, which has much more information. This takes the -- 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' :: Maybe Auth -> Name Owner -> Name Repo -> Id PullRequest -> IO (Either Error PullRequest) +pullRequest' :: Maybe Auth -> Name Owner -> Name Repo -> IssueNumber -> IO (Either Error PullRequest) pullRequest' auth user repo prid = executeRequestMaybe auth $ pullRequestR user repo prid @@ -73,12 +115,12 @@ -- repo owner and name along with the number assigned to the pull request. -- -- > pullRequest "thoughtbot" "paperclip" 562 -pullRequest :: Name Owner -> Name Repo -> Id PullRequest -> IO (Either Error PullRequest) +pullRequest :: Name Owner -> Name Repo -> IssueNumber -> IO (Either Error PullRequest) pullRequest = pullRequest' Nothing -- | Query a single pull request. -- See -pullRequestR :: Name Owner -> Name Repo -> Id PullRequest -> Request k PullRequest +pullRequestR :: Name Owner -> Name Repo -> IssueNumber -> Request k PullRequest pullRequestR user repo prid = query ["repos", toPathPart user, toPathPart repo, "pulls", toPathPart prid] [] @@ -100,7 +142,7 @@ command Post ["repos", toPathPart user, toPathPart repo, "pulls"] (encode cpr) -- | Update a pull request -updatePullRequest :: Auth -> Name Owner -> Name Repo -> Id PullRequest -> EditPullRequest -> IO (Either Error PullRequest) +updatePullRequest :: Auth -> Name Owner -> Name Repo -> IssueNumber -> EditPullRequest -> IO (Either Error PullRequest) updatePullRequest auth user repo prid epr = executeRequest auth $ updatePullRequestR user repo prid epr @@ -108,7 +150,7 @@ -- See updatePullRequestR :: Name Owner -> Name Repo - -> Id PullRequest + -> IssueNumber -> EditPullRequest -> Request 'RW PullRequest updatePullRequestR user repo prid epr = @@ -119,7 +161,7 @@ -- With authentification. -- -- > pullRequestCommits' (Just ("github-username", "github-password")) "thoughtbot" "paperclip" 688 -pullRequestCommits' :: Maybe Auth -> Name Owner -> Name Repo -> Id PullRequest -> IO (Either Error (Vector Commit)) +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 @@ -127,12 +169,12 @@ -- the number of the pull request. -- -- > pullRequestCommits "thoughtbot" "paperclip" 688 -pullRequestCommitsIO :: Name Owner -> Name Repo -> Id PullRequest -> IO (Either Error (Vector Commit)) +pullRequestCommitsIO :: Name Owner -> Name Repo -> IssueNumber -> IO (Either Error (Vector Commit)) pullRequestCommitsIO = pullRequestCommits' Nothing -- | List commits on a pull request. -- See -pullRequestCommitsR :: Name Owner -> Name Repo -> Id PullRequest -> FetchCount -> Request k (Vector Commit) +pullRequestCommitsR :: Name Owner -> Name Repo -> IssueNumber -> FetchCount -> Request k (Vector Commit) pullRequestCommitsR user repo prid = pagedQuery ["repos", toPathPart user, toPathPart repo, "pulls", toPathPart prid, "commits"] [] @@ -141,7 +183,7 @@ -- With authentification. -- -- > pullRequestFiles' (Just ("github-username", "github-password")) "thoughtbot" "paperclip" 688 -pullRequestFiles' :: Maybe Auth -> Name Owner -> Name Repo -> Id PullRequest -> IO (Either Error (Vector File)) +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 @@ -149,35 +191,35 @@ -- name, plus the number assigned to the pull request. -- -- > pullRequestFiles "thoughtbot" "paperclip" 688 -pullRequestFiles :: Name Owner -> Name Repo -> Id PullRequest -> IO (Either Error (Vector File)) +pullRequestFiles :: Name Owner -> Name Repo -> IssueNumber -> IO (Either Error (Vector File)) pullRequestFiles = pullRequestFiles' Nothing -- | List pull requests files. -- See -pullRequestFilesR :: Name Owner -> Name Repo -> Id PullRequest -> FetchCount -> Request k (Vector File) +pullRequestFilesR :: Name Owner -> Name Repo -> IssueNumber -> FetchCount -> Request k (Vector File) pullRequestFilesR user repo prid = pagedQuery ["repos", toPathPart user, toPathPart repo, "pulls", toPathPart prid, "files"] [] -- | Check if pull request has been merged. -isPullRequestMerged :: Auth -> Name Owner -> Name Repo -> Id PullRequest -> IO (Either Error Bool) +isPullRequestMerged :: Auth -> Name Owner -> Name Repo -> IssueNumber -> IO (Either Error Bool) isPullRequestMerged auth user repo prid = executeRequest auth $ isPullRequestMergedR user repo prid -- | Query if a pull request has been merged. -- See -isPullRequestMergedR :: Name Owner -> Name Repo -> Id PullRequest -> Request k Bool -isPullRequestMergedR user repo prid = StatusQuery statusOnlyOk $ +isPullRequestMergedR :: Name Owner -> Name Repo -> IssueNumber -> GenRequest 'MtStatus rw Bool +isPullRequestMergedR user repo prid = Query ["repos", toPathPart user, toPathPart repo, "pulls", toPathPart prid, "merge"] [] -- | Merge a pull request. -mergePullRequest :: Auth -> Name Owner -> Name Repo -> Id PullRequest -> Maybe Text -> IO (Either Error MergeResult) +mergePullRequest :: Auth -> Name Owner -> Name Repo -> IssueNumber -> Maybe Text -> IO (Either Error MergeResult) mergePullRequest auth user repo prid commitMessage = executeRequest auth $ mergePullRequestR user repo prid commitMessage -- | Merge a pull request (Merge Button). -- https://developer.github.com/v3/pulls/#merge-a-pull-request-merge-button -mergePullRequestR :: Name Owner -> Name Repo -> Id PullRequest -> Maybe Text -> Request 'RW MergeResult -mergePullRequestR user repo prid commitMessage = StatusQuery statusMerge $ +mergePullRequestR :: Name Owner -> Name Repo -> IssueNumber -> Maybe Text -> GenRequest 'MtStatus 'RW MergeResult +mergePullRequestR user repo prid commitMessage = Command Put paths (encode $ buildCommitMessageMap commitMessage) where paths = ["repos", toPathPart user, toPathPart repo, "pulls", toPathPart prid, "merge"] 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 @@ -10,6 +10,8 @@ pullRequestCommentsR, pullRequestComment, pullRequestCommentR, + createPullComment, + createPullCommentR, module GitHub.Data, ) where @@ -21,13 +23,13 @@ -- | All the comments on a pull request with the given ID. -- -- > pullRequestComments "thoughtbot" "factory_girl" (Id 256) -pullRequestCommentsIO :: Name Owner -> Name Repo -> Id PullRequest -> IO (Either Error (Vector Comment)) +pullRequestCommentsIO :: Name Owner -> Name Repo -> IssueNumber -> IO (Either Error (Vector Comment)) pullRequestCommentsIO user repo prid = executeRequest' $ pullRequestCommentsR user repo prid FetchAll -- | List comments on a pull request. -- See -pullRequestCommentsR :: Name Owner -> Name Repo -> Id PullRequest -> FetchCount -> Request k (Vector Comment) +pullRequestCommentsR :: Name Owner -> Name Repo -> IssueNumber -> FetchCount -> Request k (Vector Comment) pullRequestCommentsR user repo prid = pagedQuery ["repos", toPathPart user, toPathPart repo, "pulls", toPathPart prid, "comments"] [] @@ -43,3 +45,21 @@ pullRequestCommentR :: Name Owner -> Name Repo -> Id Comment -> Request k Comment pullRequestCommentR user repo cid = query ["repos", toPathPart user, toPathPart repo, "pulls", "comments", toPathPart cid] [] + +-- | Create a new comment. +-- +-- > createPullComment (User (user, password)) user repo issue commit path position +-- > "some words" +createPullComment :: Auth -> Name Owner -> Name Repo -> IssueNumber -> Text -> Text -> Int -> Text + -> IO (Either Error Comment) +createPullComment auth user repo iss commit path position body = + executeRequest auth $ createPullCommentR user repo iss commit path position body + +-- | Create a comment. +-- +-- See +createPullCommentR :: Name Owner -> Name Repo -> IssueNumber -> Text -> Text -> Int -> Text -> Request 'RW Comment +createPullCommentR user repo iss commit path position body = + command Post parts (encode $ NewPullComment commit path position body) + where + parts = ["repos", toPathPart user, toPathPart repo, "pulls", toPathPart iss, "comments"] 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 @@ -38,6 +38,7 @@ createRepoR, createOrganizationRepo', createOrganizationRepoR, + forkExistingRepo', forkExistingRepoR, -- ** Edit @@ -166,6 +167,11 @@ createRepoR :: NewRepo -> Request 'RW Repo createRepoR nrepo = command Post ["user", "repos"] (encode nrepo) + +-- | Fork an existing repository. +forkExistingRepo' :: Auth -> Name Owner -> Name Repo -> Maybe (Name Owner) -> IO (Either Error Repo) +forkExistingRepo' auth owner repo morg = + executeRequest auth $ forkExistingRepoR owner repo morg -- | Fork an existing repository. -- See 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 @@ -11,6 +11,8 @@ collaboratorsOnR, isCollaboratorOn, isCollaboratorOnR, + addCollaborator, + addCollaboratorR, module GitHub.Data, ) where @@ -57,6 +59,25 @@ :: Name Owner -- ^ Repository owner -> Name Repo -- ^ Repository name -> Name User -- ^ Collaborator? - -> Request k Bool -isCollaboratorOnR user repo coll = StatusQuery statusOnlyOk $ + -> GenRequest 'MtStatus rw Bool +isCollaboratorOnR user repo coll = Query ["repos", toPathPart user, toPathPart repo, "collaborators", toPathPart coll] [] + +addCollaborator + :: Auth + -> Name Owner -- ^ Repository owner + -> Name Repo -- ^ Repository name + -> Name User -- ^ Collaborator to add + -> IO (Either Error ()) +addCollaborator auth owner repo coll = + executeRequest auth $ addCollaboratorR owner repo coll + +-- | Invite a user as a collaborator. +-- See +addCollaboratorR + :: Name Owner -- ^ Repository owner + -> Name Repo -- ^ Repository name + -> Name User -- ^ Collaborator to add + -> GenRequest 'MtUnit 'RW () +addCollaboratorR owner repo coll = + Command Put ["repos", toPathPart owner, toPathPart repo, "collaborators", toPathPart coll] mempty 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 @@ -98,14 +98,15 @@ archiveFor' auth user repo path ref = executeRequestMaybe auth $ archiveForR user repo path ref +-- | Get archive link. +-- See archiveForR :: Name Owner -> Name Repo -> ArchiveFormat -- ^ The type of archive to retrieve -> Maybe Text -- ^ Git commit - -> Request k URI -archiveForR user repo format ref = - RedirectQuery $ Query path [] + -> GenRequest 'MtRedirect rw URI +archiveForR user repo format ref = Query path [] where path = ["repos", toPathPart user, toPathPart repo, toPathPart format] <> maybeToList ref 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 @@ -1,4 +1,4 @@ ------------------------------------------------------------------------------ + ----------------------------------------------------------------------------- -- | -- License : BSD-3-Clause -- Maintainer : Oleg Grenrus @@ -83,8 +83,8 @@ -- | Test a push hook. -- See -testPushRepoWebhookR :: Name Owner -> Name Repo -> Id RepoWebhook -> Request 'RW Bool -testPushRepoWebhookR user repo hookId = StatusQuery statusOnlyOk $ +testPushRepoWebhookR :: Name Owner -> Name Repo -> Id RepoWebhook -> GenRequest 'MtStatus 'RW Bool +testPushRepoWebhookR user repo hookId = Command Post (createWebhookOpPath user repo hookId $ Just "tests") (encode ()) pingRepoWebhook' :: Auth -> Name Owner -> Name Repo -> Id RepoWebhook -> IO (Either Error Bool) @@ -93,8 +93,8 @@ -- | Ping a hook. -- See -pingRepoWebhookR :: Name Owner -> Name Repo -> Id RepoWebhook -> Request 'RW Bool -pingRepoWebhookR user repo hookId = StatusQuery statusOnlyOk $ +pingRepoWebhookR :: Name Owner -> Name Repo -> Id RepoWebhook -> GenRequest 'MtStatus 'RW Bool +pingRepoWebhookR user repo hookId = Command Post (createWebhookOpPath user repo hookId $ Just "pings") (encode ()) deleteRepoWebhook' :: Auth -> Name Owner -> Name Repo -> Id RepoWebhook -> IO (Either Error ()) diff --git a/src/GitHub/Request.hs b/src/GitHub/Request.hs --- a/src/GitHub/Request.hs +++ b/src/GitHub/Request.hs @@ -1,6 +1,9 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} ----------------------------------------------------------------------------- -- | -- License : BSD-3-Clause @@ -27,7 +30,8 @@ -- > githubRequest = singleton module GitHub.Request ( -- * Types - Request(..), + Request, + GenRequest (..), CommandMethod(..), toMethod, Paths, @@ -40,10 +44,11 @@ executeRequestMaybe, unsafeDropAuthRequirements, -- * Helpers + Accept (..), + ParseResponse (..), makeHttpRequest, - makeHttpSimpleRequest, - parseResponse, parseStatus, + StatusMap, getNextUrl, performPagedRequest, ) where @@ -59,6 +64,7 @@ import Control.Monad.Trans.Except (ExceptT (..), runExceptT) import Data.Aeson (eitherDecode) import Data.List (find) +import Data.Tagged (Tagged (..)) import Network.HTTP.Client (HttpException (..), Manager, RequestBody (..), Response (..), @@ -70,6 +76,7 @@ import Network.HTTP.Types (Method, RequestHeaders, Status (..)) import Network.URI (URI, parseURIReference, relativeTo) +import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS import qualified Data.Text as T import qualified Data.Text.Encoding as TE @@ -77,12 +84,13 @@ import qualified Network.HTTP.Client as HTTP import qualified Network.HTTP.Client.Internal as HTTP -import GitHub.Auth (Auth (..)) -import GitHub.Data (Error (..)) +import GitHub.Auth (Auth (..)) +import GitHub.Data (Error (..)) +import GitHub.Data.PullRequests (MergeResult (..)) import GitHub.Data.Request -- | Execute 'Request' in 'IO' -executeRequest :: Auth -> Request k a -> IO (Either Error a) +executeRequest :: ParseResponse mt a => Auth -> GenRequest mt rw a -> IO (Either Error a) executeRequest auth req = do manager <- newManager tlsManagerSettings executeRequestWithMgr manager auth req @@ -93,9 +101,10 @@ -- | Like 'executeRequest' but with provided 'Manager'. executeRequestWithMgr - :: Manager + :: ParseResponse mt a + => Manager -> Auth - -> Request k a + -> GenRequest mt rw a -> IO (Either Error a) executeRequestWithMgr mgr auth req = runExceptT $ do httpReq <- makeHttpRequest (Just auth) req @@ -104,44 +113,31 @@ httpLbs' :: HTTP.Request -> ExceptT Error IO (Response LBS.ByteString) httpLbs' req' = lift (httpLbs req' mgr) `catch` onHttpException - performHttpReq :: HTTP.Request -> Request k b -> ExceptT Error IO b - performHttpReq httpReq (SimpleQuery sreq) = - performHttpReq' httpReq sreq - performHttpReq httpReq (HeaderQuery _ sreq) = - performHttpReq' httpReq sreq - performHttpReq httpReq (StatusQuery sm _) = do - res <- httpLbs' httpReq - parseStatus sm . responseStatus $ res - performHttpReq httpReq (RedirectQuery _) = do + performHttpReq :: forall rw mt b. ParseResponse mt b => HTTP.Request -> GenRequest mt rw b -> ExceptT Error IO b + performHttpReq httpReq Query {} = do res <- httpLbs' httpReq - parseRedirect (getUri httpReq) res + unTagged (parseResponse httpReq res :: Tagged mt (ExceptT Error IO b)) - performHttpReq' :: FromJSON b => HTTP.Request -> SimpleRequest k b -> ExceptT Error IO b - performHttpReq' httpReq Query {} = do - res <- httpLbs' httpReq - parseResponse res - performHttpReq' httpReq (PagedQuery _ _ l) = - performPagedRequest httpLbs' predicate httpReq + performHttpReq httpReq (PagedQuery _ _ l) = + unTagged (performPagedRequest httpLbs' predicate httpReq :: Tagged mt (ExceptT Error IO b)) where predicate v = lessFetchCount (V.length v) l - performHttpReq' httpReq (Command m _ _) = do - res <- httpLbs' httpReq - case m of - Delete -> pure () - Put' -> pure () - _ -> parseResponse res + performHttpReq httpReq (Command _ _ _) = do + res <- httpLbs' httpReq + unTagged (parseResponse httpReq res :: Tagged mt (ExceptT Error IO b)) -- | Like 'executeRequest' but without authentication. -executeRequest' ::Request 'RO a -> IO (Either Error a) +executeRequest' :: ParseResponse mt a => GenRequest mt 'RO a -> IO (Either Error a) executeRequest' req = do manager <- newManager tlsManagerSettings executeRequestWithMgr' manager req -- | Like 'executeRequestWithMgr' but without authentication. executeRequestWithMgr' - :: Manager - -> Request 'RO a + :: ParseResponse mt a + => Manager + -> GenRequest mt 'RO a -> IO (Either Error a) executeRequestWithMgr' mgr req = runExceptT $ do httpReq <- makeHttpRequest Nothing req @@ -150,40 +146,157 @@ httpLbs' :: HTTP.Request -> ExceptT Error IO (Response LBS.ByteString) httpLbs' req' = lift (httpLbs req' mgr) `catch` onHttpException - performHttpReq :: HTTP.Request -> Request 'RO b -> ExceptT Error IO b - performHttpReq httpReq (SimpleQuery sreq) = - performHttpReq' httpReq sreq - performHttpReq httpReq (HeaderQuery _ sreq) = - performHttpReq' httpReq sreq - performHttpReq httpReq (StatusQuery sm _) = do - res <- httpLbs' httpReq - parseStatus sm . responseStatus $ res - performHttpReq httpReq (RedirectQuery _) = do - res <- httpLbs' httpReq - parseRedirect (getUri httpReq) res - - performHttpReq' :: FromJSON b => HTTP.Request -> SimpleRequest 'RO b -> ExceptT Error IO b - performHttpReq' httpReq Query {} = do + performHttpReq :: forall mt b. ParseResponse mt b => HTTP.Request -> GenRequest mt 'RO b -> ExceptT Error IO b + performHttpReq httpReq Query {} = do res <- httpLbs' httpReq - parseResponse res - performHttpReq' httpReq (PagedQuery _ _ l) = - performPagedRequest httpLbs' predicate httpReq + unTagged (parseResponse httpReq res :: Tagged mt (ExceptT Error IO b)) + performHttpReq httpReq (PagedQuery _ _ l) = + unTagged (performPagedRequest httpLbs' predicate httpReq :: Tagged mt (ExceptT Error IO b)) where predicate v = lessFetchCount (V.length v) l -- | Helper for picking between 'executeRequest' and 'executeRequest''. -- -- The use is discouraged. -executeRequestMaybe :: Maybe Auth -> Request 'RO a -> IO (Either Error a) +executeRequestMaybe :: ParseResponse mt a => Maybe Auth -> GenRequest mt 'RO a -> IO (Either Error a) executeRequestMaybe = maybe executeRequest' executeRequest -- | Partial function to drop authentication need. -unsafeDropAuthRequirements :: Request k' a -> Request k a -unsafeDropAuthRequirements (SimpleQuery (Query ps qs)) = - SimpleQuery (Query ps qs) -unsafeDropAuthRequirements r = +unsafeDropAuthRequirements :: GenRequest mt rw' a -> GenRequest mt rw a +unsafeDropAuthRequirements (Query ps qs) = Query ps qs +unsafeDropAuthRequirements r = error $ "Trying to drop authenatication from" ++ show r +------------------------------------------------------------------------------- +-- Parse response +------------------------------------------------------------------------------- + +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) + +------------------------------------------------------------------------------- +-- JSON (+ star) +------------------------------------------------------------------------------- + +-- | Parse API response. +-- +-- @ +-- parseResponse :: 'FromJSON' a => 'Response' 'LBS.ByteString' -> 'Either' 'Error' a +-- @ +parseResponseJSON :: (FromJSON a, MonadError Error m) => Response LBS.ByteString -> m a +parseResponseJSON res = case eitherDecode (responseBody res) of + Right x -> return x + Left err -> throwError . ParseError . T.pack $ err + +instance Accept 'MtJSON where + contentType = Tagged "application/vnd.github.v3+json" + +instance FromJSON a => ParseResponse 'MtJSON a where + parseResponse _ res = Tagged (parseResponseJSON res) + +instance Accept 'MtStar where + contentType = Tagged "application/vnd.github.v3.star+json" + +instance FromJSON a => ParseResponse 'MtStar a where + parseResponse _ res = Tagged (parseResponseJSON res) + +------------------------------------------------------------------------------- +-- Raw / Diff / Patch / Sha +------------------------------------------------------------------------------- + +instance Accept 'MtRaw where contentType = Tagged "application/vnd.github.v3.raw" +instance Accept 'MtDiff where contentType = Tagged "application/vnd.github.v3.diff" +instance Accept 'MtPatch where contentType = Tagged "application/vnd.github.v3.patch" +instance Accept 'MtSha where contentType = Tagged "application/vnd.github.v3.sha" + +instance a ~ LBS.ByteString => ParseResponse 'MtRaw a where parseResponse _ = Tagged . return . responseBody +instance a ~ LBS.ByteString => ParseResponse 'MtDiff a where parseResponse _ = Tagged . return . responseBody +instance a ~ LBS.ByteString => ParseResponse 'MtPatch a where parseResponse _ = Tagged . return . responseBody +instance a ~ LBS.ByteString => ParseResponse 'MtSha a where parseResponse _ = Tagged . return . responseBody + +------------------------------------------------------------------------------- +-- Redirect +------------------------------------------------------------------------------- + +instance Accept 'MtRedirect where + modifyRequest = Tagged $ \req -> + setRequestIgnoreStatus $ req { redirectCount = 0 } + +instance b ~ URI => ParseResponse 'MtRedirect b where + parseResponse req = Tagged . parseRedirect (getUri req) + +-- | Helper for handling of 'RequestRedirect'. +-- +-- @ +-- parseRedirect :: 'Response' 'LBS.ByteString' -> 'Either' 'Error' a +-- @ +parseRedirect :: MonadError Error m => URI -> Response LBS.ByteString -> m URI +parseRedirect originalUri rsp = do + let status = responseStatus rsp + when (statusCode status /= 302) $ + throwError $ ParseError $ "invalid status: " <> T.pack (show status) + loc <- maybe noLocation return $ lookup "Location" $ responseHeaders rsp + case parseURIReference $ T.unpack $ TE.decodeUtf8 loc of + Nothing -> throwError $ ParseError $ + "location header does not contain a URI: " <> T.pack (show loc) + Just uri -> return $ uri `relativeTo` originalUri + where + noLocation = throwError $ ParseError "no location header in response" + +------------------------------------------------------------------------------- +-- Status +------------------------------------------------------------------------------- + +instance Accept 'MtStatus where + modifyRequest = Tagged setRequestIgnoreStatus + +instance HasStatusMap a => ParseResponse 'MtStatus a where + parseResponse _ = Tagged . parseStatus statusMap . responseStatus + +type StatusMap a = [(Int, a)] + +class HasStatusMap a where + statusMap :: StatusMap a + +instance HasStatusMap Bool where + statusMap = + [ (204, True) + , (404, False) + ] + +instance HasStatusMap MergeResult where + statusMap = + [ (200, MergeSuccessful) + , (405, MergeCannotPerform) + , (409, MergeConflict) + ] + +-- | Helper for handling of 'RequestStatus'. +-- +-- @ +-- parseStatus :: 'StatusMap' a -> 'Status' -> 'Either' 'Error' a +-- @ +parseStatus :: MonadError Error m => StatusMap a -> Status -> m a +parseStatus m (Status sci _) = + maybe err return $ lookup sci m + where + err = throwError $ JsonError $ "invalid status: " <> T.pack (show sci) + +------------------------------------------------------------------------------- +-- Unit +------------------------------------------------------------------------------- + +instance Accept 'MtUnit +instance a ~ () => ParseResponse 'MtUnit a where + parseResponse _ _ = Tagged (return ()) + ------------------------------------------------------------------------------ -- Tools ------------------------------------------------------------------------------ @@ -194,38 +307,17 @@ -- * for 'Status', the 'Request' for underlying 'Request' is created, -- status checking is modifying accordingly. -- --- @ --- parseResponse :: 'Maybe' 'Auth' -> 'Request' k a -> 'Maybe' 'Request' --- @ makeHttpRequest - :: MonadThrow m + :: forall mt rw a m. (MonadThrow m, Accept mt) => Maybe Auth - -> Request k a + -> GenRequest mt rw a -> m HTTP.Request makeHttpRequest auth r = case r of - SimpleQuery req -> - makeHttpSimpleRequest auth req - StatusQuery sm req -> do - req' <- makeHttpSimpleRequest auth req - return $ setCheckStatus (Just sm) req' - HeaderQuery h req -> do - req' <- makeHttpSimpleRequest auth req - return $ req' { requestHeaders = h <> requestHeaders req' } - RedirectQuery req -> do - req' <- makeHttpSimpleRequest auth req - return $ setRequestIgnoreStatus $ req' { redirectCount = 0 } - -makeHttpSimpleRequest - :: MonadThrow m - => Maybe Auth - -> SimpleRequest k a - -> m HTTP.Request -makeHttpSimpleRequest auth r = case r of Query paths qs -> do req <- parseUrl' $ url paths return $ setReqHeaders - . setCheckStatus Nothing + . unTagged (modifyRequest :: Tagged mt (HTTP.Request -> HTTP.Request)) . setAuthRequest auth . setQueryString qs $ req @@ -233,7 +325,7 @@ req <- parseUrl' $ url paths return $ setReqHeaders - . setCheckStatus Nothing + . unTagged (modifyRequest :: Tagged mt (HTTP.Request -> HTTP.Request)) . setAuthRequest auth . setQueryString qs $ req @@ -241,7 +333,7 @@ req <- parseUrl' $ url paths return $ setReqHeaders - . setCheckStatus Nothing + . unTagged (modifyRequest :: Tagged mt (HTTP.Request -> HTTP.Request)) . setAuthRequest auth . setBody body . setMethod (toMethod m) @@ -266,15 +358,15 @@ reqHeaders :: RequestHeaders reqHeaders = maybe [] getOAuthHeader auth - <> [("User-Agent", "github.hs/0.7.4")] - <> [("Accept", "application/vnd.github.preview")] + <> [("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 + setAuthRequest _ = id getOAuthHeader :: Auth -> RequestHeaders getOAuthHeader (OAuth token) = [("Authorization", "token " <> token)] @@ -295,45 +387,6 @@ relNextLinkParam :: (LinkParam, Text) relNextLinkParam = (Rel, "next") --- | Parse API response. --- --- @ --- parseResponse :: 'FromJSON' a => 'Response' 'LBS.ByteString' -> 'Either' 'Error' a --- @ -parseResponse :: (FromJSON a, MonadError Error m) => Response LBS.ByteString -> m a -parseResponse res = case eitherDecode (responseBody res) of - Right x -> return x - Left err -> throwError . ParseError . T.pack $ err - --- | Helper for handling of 'RequestStatus'. --- --- @ --- parseStatus :: 'StatusMap' a -> 'Status' -> 'Either' 'Error' a --- @ -parseStatus :: MonadError Error m => StatusMap a -> Status -> m a -parseStatus m (Status sci _) = - maybe err return $ lookup sci m - where - err = throwError $ JsonError $ "invalid status: " <> T.pack (show sci) - --- | Helper for handling of 'RequestRedirect'. --- --- @ --- parseRedirect :: 'Response' 'LBS.ByteString' -> 'Either' 'Error' a --- @ -parseRedirect :: MonadError Error m => URI -> Response LBS.ByteString -> m URI -parseRedirect originalUri rsp = do - let status = responseStatus rsp - when (statusCode status /= 302) $ - throwError $ ParseError $ "invalid status: " <> T.pack (show status) - loc <- maybe noLocation return $ lookup "Location" $ responseHeaders rsp - case parseURIReference $ T.unpack $ TE.decodeUtf8 loc of - Nothing -> throwError $ ParseError $ - "location header does not contain a URI: " <> T.pack (show loc) - Just uri -> return $ uri `relativeTo` originalUri - where - noLocation = throwError $ ParseError "no location header in response" - -- | Helper for making paginated requests. Responses, @a@ are combined monoidally. -- -- @ @@ -344,14 +397,14 @@ -- -> 'ExceptT' 'Error' 'IO' a -- @ performPagedRequest - :: forall a m. (FromJSON a, Semigroup a, MonadCatch m, MonadError Error m) + :: forall a m mt. (ParseResponse mt a, Semigroup a, MonadCatch m, MonadError Error m) => (HTTP.Request -> m (Response LBS.ByteString)) -- ^ `httpLbs` analogue -> (a -> Bool) -- ^ predicate to continue iteration -> HTTP.Request -- ^ initial request - -> m a -performPagedRequest httpLbs' predicate initReq = do + -> Tagged mt (m a) +performPagedRequest httpLbs' predicate initReq = Tagged $ do res <- httpLbs' initReq - m <- parseResponse res + m <- unTagged (parseResponse initReq res :: Tagged mt (m a)) go m res initReq where go :: a -> Response LBS.ByteString -> HTTP.Request -> m a @@ -360,30 +413,13 @@ (True, Just uri) -> do req' <- HTTP.setUri req uri res' <- httpLbs' req' - m <- parseResponse res' + m <- unTagged (parseResponse req' res' :: Tagged mt (m a)) go (acc <> m) res' req' (_, _) -> return acc ------------------------------------------------------------------------------- -- Internal ------------------------------------------------------------------------------- - - -setCheckStatus :: Maybe (StatusMap a) -> HTTP.Request -> HTTP.Request -setCheckStatus sm req = req { HTTP.checkResponse = successOrMissing sm } - -successOrMissing :: Maybe (StatusMap a) -> HTTP.Request -> HTTP.Response HTTP.BodyReader -> IO () -successOrMissing sm _req res - | check = pure () - | otherwise = do - chunk <- HTTP.brReadSome (HTTP.responseBody res) 1024 - let res' = fmap (const ()) res - HTTP.throwHttp $ HTTP.StatusCodeException res' (LBS.toStrict chunk) - where - Status sci _ = HTTP.responseStatus res - check = case sm of - Nothing -> 200 <= sci && sci < 300 - Just sm' -> sci `elem` map fst sm' onHttpException :: MonadError Error m => HttpException -> m a onHttpException = throwError . HTTPError