github 0.20 → 0.21

raw patch · 32 files changed

+687/−441 lines, 32 filesdep +cryptohash-sha1dep +taggeddep −byteabledep −cryptohashdep ~hspecdep ~http-clientPVP ok

version bump matches the API change (PVP)

Dependencies added: cryptohash-sha1, tagged

Dependencies removed: byteable, cryptohash

Dependency ranges changed: hspec, http-client

API changes (from Hackage documentation)

Files

• CHANGELOG.md +23/−0
• github.cabal +84/−77
• spec/GitHub/CommitsSpec.hs +6/−1
• spec/GitHub/IssuesSpec.hs +11/−4
• spec/GitHub/PullRequestsSpec.hs +8/−3
• spec/GitHub/RateLimitSpec.hs +0/−1
• spec/GitHub/SearchSpec.hs +4/−3
• src/GitHub.hs +11/−6
• src/GitHub/Data.hs +2/−0
• src/GitHub/Data/Comments.hs +19/−0
• src/GitHub/Data/Definitions.hs +22/−0
• src/GitHub/Data/GitData.hs +4/−4
• src/GitHub/Data/Issues.hs +11/−8
• src/GitHub/Data/Milestone.hs +46/−0
• src/GitHub/Data/PullRequests.hs +2/−11
• src/GitHub/Data/Request.hs +69/−122
• src/GitHub/Data/Webhooks/Validate.hs +5/−7
• src/GitHub/Endpoints/Activity/Starring.hs +4/−4
• src/GitHub/Endpoints/Gists.hs +2/−2
• src/GitHub/Endpoints/Issues.hs +1/−1
• src/GitHub/Endpoints/Issues/Comments.hs +5/−5
• src/GitHub/Endpoints/Issues/Milestones.hs +34/−0
• src/GitHub/Endpoints/Organizations.hs +7/−1
• src/GitHub/Endpoints/Organizations/Members.hs +2/−2
• src/GitHub/Endpoints/Organizations/Teams.hs +2/−2
• src/GitHub/Endpoints/PullRequests.hs +59/−17
• src/GitHub/Endpoints/PullRequests/Comments.hs +22/−2
• src/GitHub/Endpoints/Repos.hs +6/−0
• src/GitHub/Endpoints/Repos/Collaborators.hs +23/−2
• src/GitHub/Endpoints/Repos/Contents.hs +4/−3
• src/GitHub/Endpoints/Repos/Webhooks.hs +5/−5
• src/GitHub/Request.hs +184/−148

@@ -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

@@ -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: <https://github.com/phadej/github/blob/master/README.md>-license:             BSD3-license-file:        LICENSE-author:              Mike Burns, John Wiegley, Oleg Grenrus-maintainer:          Oleg Grenrus <oleg.grenrus@iki.fi>-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 <oleg.grenrus@iki.fi>+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

@@ -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

@@ -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")       ]

@@ -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 

@@ -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)

@@ -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 

@@ -137,13 +137,14 @@     -- ** Milestone     -- | See <https://developer.github.com/v3/issues/milestones/>     ---    -- Missing endpoints:-    ---    -- * Create a milestone-    -- * Update a milestone-    -- * Delete a milestone     milestonesR,     milestoneR,+    createMilestone,+    createMilestoneR,+    updateMilestone,+    updateMilestoneR,+    deleteMilestone,+    deleteMilestoneR,      -- * Organizations     -- | See <https://developer.github.com/v3/orgs/>@@ -155,6 +156,7 @@     -- * Edit an organization     publicOrganizationsForR,     publicOrganizationR,+    organizationsR,     -- ** Members     -- | See <https://developer.github.com/v3/orgs/members/>     --@@ -191,6 +193,8 @@     -- | See <https://developer.github.com/v3/pulls/>     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 <https://developer.github.com/v3/pulls/reviews/>@@ -251,6 +255,7 @@     -- | See <https://developer.github.com/v3/repos/collaborators/>     collaboratorsOnR,     isCollaboratorOnR,+    addCollaboratorR,      -- ** Comments     -- | See <https://developer.github.com/v3/repos/comments/>

@@ -30,6 +30,8 @@     mkRepoId,     fromUserId,     fromOrganizationId,+    -- * IssueNumber+    IssueNumber (..),     -- * Module re-exports     module GitHub.Auth,     module GitHub.Data.Activities,

@@ -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+               ]

@@ -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 ------------------------------------------------------------------------------- 

@@ -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"

@@ -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

@@ -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

@@ -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)-    ]

@@ -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@ <https://developer.github.com/v3/media/#raw-1>+    | MtDiff     -- ^ @application/vnd.github.v3.diff@ <https://developer.github.com/v3/media/#diff>+    | MtPatch    -- ^ @application/vnd.github.v3.patch@ <https://developer.github.com/v3/media/#patch>+    | MtSha      -- ^ @application/vnd.github.v3.sha@ <https://developer.github.com/v3/media/#sha>+    | MtStar     -- ^ @application/vnd.github.v3.star+json@ <https://developer.github.com/v3/activity/starring/#alternative-response-with-star-creation-timestamps-1>+    | MtRedirect -- ^ <https://developer.github.com/v3/repos/contents/#get-archive-link>+    | 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

@@ -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

@@ -71,8 +71,8 @@  -- | All the repos starred by the authenticated user. -- See <https://developer.github.com/v3/activity/starring/#alternative-response-with-star-creation-timestamps-1>-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 <https://developer.github.com/v3/activity/starring/#star-a-repository>-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] 

@@ -70,8 +70,8 @@  -- | Star a gist by the authenticated user. -- See <https://developer.github.com/v3/gists/#star-a-gist>-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. --

@@ -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.

@@ -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 <https://developer.github.com/v3/issues/comments/#list-comments-on-an-issue>-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 <https://developer.github.com/v3/issues/comments/#create-a-comment>-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

@@ -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 <https://developer.github.com/v3/issues/milestones/#create-a-milestone>+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 <https://developer.github.com/v3/issues/milestones/#update-a-milestone>+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 <https://developer.github.com/v3/issues/milestones/#delete-a-milestone>+deleteMilestoneR :: Name Owner -> Name Repo -> Id Milestone -> Request 'RW ()+deleteMilestoneR user repo mid =+    command Delete+        ["repos", toPathPart user, toPathPart repo, "milestones", toPathPart mid] mempty

@@ -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 <https://developer.github.com/v3/orgs/#list-your-organizations>+organizationsR :: FetchCount -> Request k (Vector SimpleOrganization)+organizationsR = pagedQuery ["user", "orgs"] []++-- | List public user organizations. -- See <https://developer.github.com/v3/orgs/#list-user-organizations> publicOrganizationsForR :: Name User -> FetchCount -> Request k (Vector SimpleOrganization) publicOrganizationsForR user = pagedQuery ["users", toPathPart user, "orgs"] []

@@ -77,8 +77,8 @@ -- | Check if a user is a member of an organization. -- -- See <https://developer.github.com/v3/orgs/members/#check-membership>-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

@@ -168,9 +168,9 @@  -- | Add or update a team repository. -- See <https://developer.github.com/v3/orgs/teams/#add-or-update-team-repository>-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

@@ -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 <https://developer.github.com/v3/pulls/#get-a-single-pull-request>+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 <https://developer.github.com/v3/pulls/#get-a-single-pull-request>+pullRequestDiff :: Name Owner -> Name Repo -> IssueNumber -> IO (Either Error ByteString)+pullRequestDiff = pullRequestDiff' Nothing++-- | Query a single pull request to obtain the diff+-- See <https://developer.github.com/v3/pulls/#get-a-single-pull-request>+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 <https://developer.github.com/v3/pulls/#get-a-single-pull-request>+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 <https://developer.github.com/v3/pulls/#get-a-single-pull-request>+pullRequestPatch :: Name Owner -> Name Repo -> IssueNumber -> IO (Either Error ByteString)+pullRequestPatch = pullRequestPatch' Nothing++-- | Query a single pull request to obtain the patch+-- See <https://developer.github.com/v3/pulls/#get-a-single-pull-request>+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 <https://developer.github.com/v3/pulls/#get-a-single-pull-request>-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 <https://developer.github.com/v3/pulls/#update-a-pull-request> 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 <https://developer.github.com/v3/pulls/#list-commits-on-a-pull-request>-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 <https://developer.github.com/v3/pulls/#list-pull-requests-files>-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 <https://developer.github.com/v3/pulls/#get-if-a-pull-request-has-been-merged>-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"]

@@ -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 <https://developer.github.com/v3/pulls/comments/#list-comments-on-a-pull-request>-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 <https://developer.github.com/v3/pulls/comments/#create-a-comment>+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"]

@@ -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 <https://developer.github.com/v3/repos/forks/#create-a-fork>

@@ -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 <https://developer.github.com/v3/repos/collaborators/#add-user-as-a-collaborator>+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

@@ -98,14 +98,15 @@ archiveFor' auth user repo path ref =     executeRequestMaybe auth $ archiveForR user repo path ref +-- | Get archive link.+-- See <https://developer.github.com/v3/repos/contents/#get-archive-link> 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 

@@ -1,4 +1,4 @@------------------------------------------------------------------------------+ ----------------------------------------------------------------------------- -- | -- License     :  BSD-3-Clause -- Maintainer  :  Oleg Grenrus <oleg.grenrus@iki.fi>@@ -83,8 +83,8 @@  -- | Test a push hook. -- See <https://developer.github.com/v3/repos/hooks/#test-a-push-hook>-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 <https://developer.github.com/v3/repos/hooks/#ping-a-hook>-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 ())

@@ -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