diff --git a/.github/workflows/haskell-ci.yml b/.github/workflows/haskell-ci.yml index b5d24eb9..bb4e2c16 100644 --- a/.github/workflows/haskell-ci.yml +++ b/.github/workflows/haskell-ci.yml @@ -8,40 +8,53 @@ # # For more information, see https://github.com/haskell-CI/haskell-ci # -# version: 0.16.4 +# version: 0.19.20250506 # -# REGENDATA ("0.16.4",["--config=cabal.haskell-ci","github","cabal.project"]) +# REGENDATA ("0.19.20250506",["--config=cabal.haskell-ci","github","cabal.project"]) # name: Haskell-CI on: push: branches: - master - - ci* pull_request: branches: - master - - ci* jobs: linux: name: Haskell-CI - Linux - ${{ matrix.compiler }} - runs-on: ubuntu-20.04 + runs-on: ubuntu-24.04 timeout-minutes: 60 container: - image: buildpack-deps:bionic + image: buildpack-deps:jammy continue-on-error: ${{ matrix.allow-failure }} strategy: matrix: include: - - compiler: ghc-9.6.2 + - compiler: ghc-9.12.2 compilerKind: ghc - compilerVersion: 9.6.2 + compilerVersion: 9.12.2 setup-method: ghcup allow-failure: false - - compiler: ghc-9.4.5 + - compiler: ghc-9.10.2 compilerKind: ghc - compilerVersion: 9.4.5 + compilerVersion: 9.10.2 + setup-method: ghcup + allow-failure: false + - compiler: ghc-9.8.4 + compilerKind: ghc + compilerVersion: 9.8.4 + setup-method: ghcup + allow-failure: false + - compiler: ghc-9.6.7 + compilerKind: ghc + compilerVersion: 9.6.7 + setup-method: ghcup + allow-failure: false + - compiler: ghc-9.4.8 + compilerKind: ghc + compilerVersion: 9.4.8 setup-method: ghcup allow-failure: false - compiler: ghc-9.2.8 @@ -62,59 +75,48 @@ jobs: - compiler: ghc-8.8.4 compilerKind: ghc compilerVersion: 8.8.4 - setup-method: hvr-ppa + setup-method: ghcup allow-failure: false - compiler: ghc-8.6.5 compilerKind: ghc compilerVersion: 8.6.5 - setup-method: hvr-ppa + setup-method: ghcup allow-failure: false - compiler: ghc-8.4.4 compilerKind: ghc compilerVersion: 8.4.4 - setup-method: hvr-ppa + setup-method: ghcup allow-failure: false - compiler: ghc-8.2.2 compilerKind: ghc compilerVersion: 8.2.2 - setup-method: hvr-ppa - allow-failure: false - - compiler: ghc-8.0.2 - compilerKind: ghc - compilerVersion: 8.0.2 - setup-method: hvr-ppa - allow-failure: false - - compiler: ghc-7.10.3 - compilerKind: ghc - compilerVersion: 7.10.3 - setup-method: hvr-ppa - allow-failure: false - - compiler: ghc-7.8.4 - compilerKind: ghc - compilerVersion: 7.8.4 - setup-method: hvr-ppa + setup-method: ghcup allow-failure: false fail-fast: false steps: - - name: apt + - name: apt-get install run: | apt-get update - apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5 - if [ "${{ matrix.setup-method }}" = ghcup ]; then - mkdir -p "$HOME/.ghcup/bin" - curl -sL https://downloads.haskell.org/ghcup/0.1.19.2/x86_64-linux-ghcup-0.1.19.2 > "$HOME/.ghcup/bin/ghcup" - chmod a+x "$HOME/.ghcup/bin/ghcup" - "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false) - "$HOME/.ghcup/bin/ghcup" install cabal 3.10.1.0 || (cat "$HOME"/.ghcup/logs/*.* && false) - else - apt-add-repository -y 'ppa:hvr/ghc' - apt-get update - apt-get install -y "$HCNAME" - mkdir -p "$HOME/.ghcup/bin" - curl -sL https://downloads.haskell.org/ghcup/0.1.19.2/x86_64-linux-ghcup-0.1.19.2 > "$HOME/.ghcup/bin/ghcup" - chmod a+x "$HOME/.ghcup/bin/ghcup" - "$HOME/.ghcup/bin/ghcup" install cabal 3.10.1.0 || (cat "$HOME"/.ghcup/logs/*.* && false) - fi + apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5 libnuma-dev + - name: Install GHCup + run: | + mkdir -p "$HOME/.ghcup/bin" + curl -sL https://downloads.haskell.org/ghcup/0.1.50.1/x86_64-linux-ghcup-0.1.50.1 > "$HOME/.ghcup/bin/ghcup" + chmod a+x "$HOME/.ghcup/bin/ghcup" + - name: Install cabal-install + run: | + "$HOME/.ghcup/bin/ghcup" install cabal 3.14.2.0 || (cat "$HOME"/.ghcup/logs/*.* && false) + echo "CABAL=$HOME/.ghcup/bin/cabal-3.14.2.0 -vnormal+nowrap" >> "$GITHUB_ENV" + - name: Install GHC (GHCup) + if: matrix.setup-method == 'ghcup' + run: | + "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false) + HC=$("$HOME/.ghcup/bin/ghcup" whereis ghc "$HCVER") + HCPKG=$(echo "$HC" | sed 's#ghc$#ghc-pkg#') + HADDOCK=$(echo "$HC" | sed 's#ghc$#haddock#') + echo "HC=$HC" >> "$GITHUB_ENV" + echo "HCPKG=$HCPKG" >> "$GITHUB_ENV" + echo "HADDOCK=$HADDOCK" >> "$GITHUB_ENV" env: HCKIND: ${{ matrix.compilerKind }} HCNAME: ${{ matrix.compiler }} @@ -125,28 +127,12 @@ jobs: echo "LANG=C.UTF-8" >> "$GITHUB_ENV" echo "CABAL_DIR=$HOME/.cabal" >> "$GITHUB_ENV" echo "CABAL_CONFIG=$HOME/.cabal/config" >> "$GITHUB_ENV" - HCDIR=/opt/$HCKIND/$HCVER - if [ "${{ matrix.setup-method }}" = ghcup ]; then - HC=$HOME/.ghcup/bin/$HCKIND-$HCVER - echo "HC=$HC" >> "$GITHUB_ENV" - echo "HCPKG=$HOME/.ghcup/bin/$HCKIND-pkg-$HCVER" >> "$GITHUB_ENV" - echo "HADDOCK=$HOME/.ghcup/bin/haddock-$HCVER" >> "$GITHUB_ENV" - echo "CABAL=$HOME/.ghcup/bin/cabal-3.10.1.0 -vnormal+nowrap" >> "$GITHUB_ENV" - else - HC=$HCDIR/bin/$HCKIND - echo "HC=$HC" >> "$GITHUB_ENV" - echo "HCPKG=$HCDIR/bin/$HCKIND-pkg" >> "$GITHUB_ENV" - echo "HADDOCK=$HCDIR/bin/haddock" >> "$GITHUB_ENV" - echo "CABAL=$HOME/.ghcup/bin/cabal-3.10.1.0 -vnormal+nowrap" >> "$GITHUB_ENV" - fi - HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))') echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV" echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV" echo "ARG_BENCH=--enable-benchmarks" >> "$GITHUB_ENV" echo "HEADHACKAGE=false" >> "$GITHUB_ENV" echo "ARG_COMPILER=--$HCKIND --with-compiler=$HC" >> "$GITHUB_ENV" - echo "GHCJSARITH=0" >> "$GITHUB_ENV" env: HCKIND: ${{ matrix.compilerKind }} HCNAME: ${{ matrix.compiler }} @@ -196,7 +182,7 @@ jobs: chmod a+x $HOME/.cabal/bin/cabal-plan cabal-plan --version - name: checkout - uses: actions/checkout@v3 + uses: actions/checkout@v4 with: path: source - name: initial cabal.project for sdist @@ -224,17 +210,18 @@ jobs: touch cabal.project.local echo "packages: ${PKGDIR_github}" >> cabal.project if [ $((HCNUMVER >= 80400)) -ne 0 ] ; then echo "packages: ${PKGDIR_github_samples}" >> cabal.project ; fi - if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then echo "package github" >> cabal.project ; fi - if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then echo " ghc-options: -Werror=missing-methods" >> cabal.project ; fi + echo "package github" >> cabal.project + echo " ghc-options: -Werror=missing-methods" >> cabal.project if [ $((HCNUMVER >= 80400)) -ne 0 ] ; then echo "package github-samples" >> cabal.project ; fi if [ $((HCNUMVER >= 80400)) -ne 0 ] ; then echo " ghc-options: -Werror=missing-methods" >> cabal.project ; fi cat >> cabal.project <> cabal.project.local + $HCPKG list --simple-output --names-only | perl -ne 'for (split /\s+/) { print "constraints: any.$_ installed\n" unless /^(github|github-samples)$/; }' >> cabal.project.local cat cabal.project cat cabal.project.local - name: dump install plan @@ -242,7 +229,7 @@ jobs: $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dry-run all cabal-plan - name: restore cache - uses: actions/cache/restore@v3 + uses: actions/cache/restore@v4 with: key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} path: ~/.cabal/store @@ -274,8 +261,8 @@ jobs: rm -f cabal.project.local $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all - name: save cache - uses: actions/cache/save@v3 if: always() + uses: actions/cache/save@v4 with: key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} path: ~/.cabal/store diff --git a/CHANGELOG.md b/CHANGELOG.md index 0926cfee..45c00f5a 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,20 @@ +## Changes for 0.30 + +_2025-05-09, Andreas Abel, Peace edition_ + +- Organization membership endpoint (Domen Kožar, PR [#487](https://github.com/haskell-github/github/pull/487)). +- Allow JWT as an authentication method (Tom Sydney Kerckhove, PR [#497](https://github.com/haskell-github/github/pull/497)). +- Support pagination (Tom McLaughlin, PR [#503](https://github.com/haskell-github/github/pull/503)). +- Initial subset of Reactions endpoints (Dan Rijks, PR [#509](https://github.com/haskell-github/github/pull/509)). +- Fix `getNotifications` (maralorn, PR [#511](https://github.com/haskell-github/github/pull/511)). +- Add missing `name` field to `WorkflowJobs` `Job` type (Hugh Davidson, PR [#518](https://github.com/haskell-github/github/pull/518)). +- Add `StateReasonDuplicate` to `IssueStateReason` (PR [#523](https://github.com/haskell-github/github/pull/523)). +- Drop support for GHC 8.0 and below. +- Drop dependency `time-compat`. + +Tested with GHC 8.2 - 9.12.2. + + ## Changes for 0.29 _2023-06-24, Andreas Abel, Midsommar edition_ diff --git a/cabal.haskell-ci b/cabal.haskell-ci index a3ce9738..ccddf4a2 100644 --- a/cabal.haskell-ci +++ b/cabal.haskell-ci @@ -1,4 +1,4 @@ -branches: master ci* +branches: master haddock: >=8.6 -- See PR #355: haddocks for GADT constructor arguments only supported from GHC 8.6 jobs-selection: any @@ -10,4 +10,13 @@ jobs-selection: any -- constraint-set text-2.0 -- constraints: text >= 2.0 --- allow-newer: *:text -- allow-newer not supported \ No newline at end of file +-- allow-newer: *:text -- allow-newer not supported + +-- constraint-set containers-0.7 +-- ghc: >= 9 +-- constraints: containers >= 0.7 +-- tests: True +-- run-tests: True + +-- raw-project +-- allow-newer: containers diff --git a/cabal.project b/cabal.project index ed0996f6..be4081d6 100644 --- a/cabal.project +++ b/cabal.project @@ -6,6 +6,7 @@ tests: True constraints: github +openssl constraints: github-samples +openssl +constraints: HsOpenSSL +use-pkg-config constraints: operational -buildExamples -- constraints: text >=2 diff --git a/github.cabal b/github.cabal index 5f94c430..517468bc 100644 --- a/github.cabal +++ b/github.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: github -version: 0.29 +version: 0.30 synopsis: Access to the GitHub API, v3. category: Network description: @@ -30,8 +30,11 @@ copyright: Copyright 2012-2013 Mike Burns, Copyright 2013-2015 John Wiegley, Copyright 2016-2021 Oleg Grenrus tested-with: - GHC == 9.6.2 - GHC == 9.4.5 + GHC == 9.12.2 + GHC == 9.10.2 + GHC == 9.8.4 + GHC == 9.6.7 + GHC == 9.4.8 GHC == 9.2.8 GHC == 9.0.2 GHC == 8.10.7 @@ -39,9 +42,6 @@ tested-with: GHC == 8.6.5 GHC == 8.4.4 GHC == 8.2.2 - GHC == 8.0.2 - GHC == 7.10.3 - GHC == 7.8.4 extra-doc-files: README.md @@ -63,11 +63,9 @@ library default-language: Haskell2010 ghc-options: -Wall - if impl(ghc >= 8.0) - ghc-options: - -Wcompat - -Wno-star-is-type - -- The star-is-type warning cannot be sensiblity addressed while supporting GHC 7. + -Wcompat + -Wno-star-is-type + -- The star-is-type warning cannot be sensiblity addressed while supporting GHC 7. hs-source-dirs: src default-extensions: DataKinds @@ -119,6 +117,7 @@ library GitHub.Data.PublicSSHKeys GitHub.Data.PullRequests GitHub.Data.RateLimit + GitHub.Data.Reactions GitHub.Data.Releases GitHub.Data.Repos GitHub.Data.Request @@ -159,6 +158,7 @@ library GitHub.Endpoints.PullRequests.Comments GitHub.Endpoints.PullRequests.Reviews GitHub.Endpoints.RateLimit + GitHub.Endpoints.Reactions GitHub.Endpoints.Repos GitHub.Endpoints.Repos.Collaborators GitHub.Endpoints.Repos.Comments @@ -185,26 +185,26 @@ library -- Packages bundles with GHC, mtl and text are also here build-depends: - base >=4.7 && <5 + base >=4.10 && <5 , binary >=0.7.1.0 && <0.11 - , bytestring >=0.10.4.0 && <0.12 - , containers >=0.5.5.1 && <0.7 - , deepseq >=1.3.0.2 && <1.5 + , bytestring >=0.10.4.0 && <0.13 + , containers >=0.5.5.1 && <1 + , deepseq >=1.3.0.2 && <1.6 + , exceptions >=0.10.2 && <0.11 , mtl >=2.1.3.1 && <2.2 || >=2.2.1 && <2.4 - , text >=1.2.0.6 && <2.1 - , time-compat >=1.9.2.2 && <1.10 + , text >=1.2.0.6 && <2.2 + , time >=1.8.0.2 && <2 , transformers >=0.3.0.0 && <0.7 -- other packages build-depends: - aeson >=1.4.0.0 && <1.6 || >=2.0.1.0 && <2.2 - , base-compat >=0.11.1 && <0.14 + aeson >=1.4.0.0 && <1.6 || >=2.0.1.0 && <2.3 + , base-compat >=0.11.1 && <1 , base16-bytestring >=0.1.1.6 && <1.1 , binary-instances >=1 && <1.1 , cryptohash-sha1 >=0.11.100.1 && <0.12 , deepseq-generics >=0.2.0.0 && <0.3 - , exceptions >=0.10.2 && <0.11 - , hashable >=1.2.7.0 && <1.5 + , hashable >=1.2.7.0 && <2 , http-client >=0.5.12 && <0.8 , http-link-header >=1.0.3.1 && <1.3 , http-types >=0.12.3 && <0.13 @@ -226,9 +226,6 @@ library http-client-tls >=0.3.5.3 && <0.4 , tls >=1.4.1 - if !impl(ghc >=8.0) - build-depends: semigroups >=0.18.5 && <0.20 - test-suite github-test default-language: Haskell2010 type: exitcode-stdio-1.0 @@ -267,6 +264,7 @@ test-suite github-test , file-embed , github , hspec >=2.6.1 && <2.12 + , http-client , tagged , text , unordered-containers diff --git a/samples/Operational/Operational.hs b/samples/Operational/Operational.hs index cbfc9fb4..1fc7f897 100644 --- a/samples/Operational/Operational.hs +++ b/samples/Operational/Operational.hs @@ -1,7 +1,7 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} + module Main (main) where import Common diff --git a/samples/github-samples.cabal b/samples/github-samples.cabal index c3c6813d..2fd3287a 100644 --- a/samples/github-samples.cabal +++ b/samples/github-samples.cabal @@ -10,8 +10,11 @@ description: Various samples of github package build-type: Simple tested-with: - GHC == 9.6.2 - GHC == 9.4.5 + GHC == 9.12.2 + GHC == 9.10.2 + GHC == 9.8.4 + GHC == 9.6.7 + GHC == 9.4.8 GHC == 9.2.8 GHC == 9.0.2 GHC == 8.10.7 @@ -38,7 +41,7 @@ executable github-operational hs-source-dirs: Operational ghc-options: -Wall -threaded build-depends: - , base >=0 && <5 + , base , base-compat-batteries , github , github-samples @@ -54,7 +57,7 @@ common deps -Wall -threaded build-depends: - , base >=4.8 && <5 + , base , base-compat-batteries , base64-bytestring , github diff --git a/spec/GitHub/IssuesSpec.hs b/spec/GitHub/IssuesSpec.hs index 2a7f5e7b..e673975f 100644 --- a/spec/GitHub/IssuesSpec.hs +++ b/spec/GitHub/IssuesSpec.hs @@ -6,12 +6,13 @@ import qualified GitHub import Prelude () 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, expectationFailure, it, pendingWith, shouldSatisfy) +import Data.Either.Compat (isRight) +import Data.Foldable (for_) +import Data.String (fromString) +import Network.HTTP.Client (newManager, responseBody) +import System.Environment (lookupEnv) +import Test.Hspec (Spec, describe, expectationFailure, it, pendingWith, shouldSatisfy) + fromRightS :: Show a => Either a b -> b fromRightS (Right b) = b @@ -38,6 +39,25 @@ spec = do cms <- GitHub.executeRequest auth $ GitHub.commentsR owner repo (GitHub.issueNumber i) 1 cms `shouldSatisfy` isRight + + describe "issuesForRepoR paged" $ do + it "works" $ withAuth $ \auth -> for_ repos $ \(owner, repo) -> do + mgr <- newManager GitHub.tlsManagerSettings + ret <- GitHub.executeRequestWithMgrAndRes mgr auth $ + GitHub.issuesForRepoR owner repo mempty (GitHub.FetchPage (GitHub.PageParams (Just 2) (Just 1))) + + case ret of + Left e -> + expectationFailure . show $ e + Right res -> do + let issues = responseBody res + length issues `shouldSatisfy` (<= 2) + + for_ issues $ \i -> do + cms <- GitHub.executeRequest auth $ + GitHub.commentsR owner repo (GitHub.issueNumber i) 1 + cms `shouldSatisfy` isRight + describe "issueR" $ do it "fetches issue #428" $ withAuth $ \auth -> do resIss <- GitHub.executeRequest auth $ diff --git a/src/GitHub.hs b/src/GitHub.hs index c3a3d88f..5d323de8 100644 --- a/src/GitHub.hs +++ b/src/GitHub.hs @@ -173,6 +173,7 @@ module GitHub ( membersOfWithR, isMemberOfR, orgInvitationsR, + orgMembershipR, -- ** Outside Collaborators -- | See -- @@ -285,6 +286,15 @@ module GitHub ( commitR, diffR, + -- ** Reactions + -- | See + issueReactionsR, + createIssueReactionR, + deleteIssueReactionR, + commentReactionsR, + createCommentReactionR, + deleteCommentReactionR, + -- ** Contents -- | See contentsForR, @@ -514,6 +524,7 @@ import GitHub.Endpoints.Organizations.Teams import GitHub.Endpoints.PullRequests import GitHub.Endpoints.PullRequests.Comments import GitHub.Endpoints.PullRequests.Reviews +import GitHub.Endpoints.Reactions import GitHub.Endpoints.RateLimit import GitHub.Endpoints.Repos import GitHub.Endpoints.Repos.Collaborators diff --git a/src/GitHub/Auth.hs b/src/GitHub/Auth.hs index ccc2415a..2b41dbf4 100644 --- a/src/GitHub/Auth.hs +++ b/src/GitHub/Auth.hs @@ -1,5 +1,7 @@ module GitHub.Auth ( Auth (..), + Token, + JWTToken, AuthMethod, endpoint, setAuthRequest @@ -9,14 +11,17 @@ import GitHub.Internal.Prelude import Prelude () import qualified Data.ByteString as BS +import qualified Data.Text.Encoding as TE import qualified Network.HTTP.Client as HTTP type Token = BS.ByteString +type JWTToken = Text -- | The Github auth data type data Auth = BasicAuth BS.ByteString BS.ByteString -- ^ Username and password | OAuth Token -- ^ OAuth token + | JWT JWTToken -- ^ JWT Token | EnterpriseOAuth Text Token -- ^ Custom endpoint and OAuth token deriving (Show, Data, Typeable, Eq, Ord, Generic) @@ -40,10 +45,12 @@ instance AuthMethod () where instance AuthMethod Auth where endpoint (BasicAuth _ _) = Nothing endpoint (OAuth _) = Nothing + endpoint (JWT _) = Nothing endpoint (EnterpriseOAuth e _) = Just e setAuthRequest (BasicAuth u p) = HTTP.applyBasicAuth u p setAuthRequest (OAuth t) = setAuthHeader $ "token " <> t + setAuthRequest (JWT t) = setAuthHeader $ "Bearer " <> TE.encodeUtf8 t setAuthRequest (EnterpriseOAuth _ t) = setAuthHeader $ "token " <> t setAuthHeader :: BS.ByteString -> HTTP.Request -> HTTP.Request diff --git a/src/GitHub/Data.hs b/src/GitHub/Data.hs index 20ebe7fd..18fb770d 100644 --- a/src/GitHub/Data.hs +++ b/src/GitHub/Data.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE CPP #-} - -- | -- This module re-exports the @GitHub.Data.@ and "GitHub.Auth" submodules. @@ -57,6 +55,7 @@ module GitHub.Data ( module GitHub.Data.PullRequests, module GitHub.Data.RateLimit, module GitHub.Data.Releases, + module GitHub.Data.Reactions, module GitHub.Data.Repos, module GitHub.Data.Request, module GitHub.Data.Reviews, @@ -99,6 +98,7 @@ import GitHub.Data.PublicSSHKeys import GitHub.Data.PullRequests import GitHub.Data.RateLimit import GitHub.Data.Releases +import GitHub.Data.Reactions import GitHub.Data.Repos import GitHub.Data.Request import GitHub.Data.Reviews diff --git a/src/GitHub/Data/Actions/WorkflowJobs.hs b/src/GitHub/Data/Actions/WorkflowJobs.hs index 9698e3a9..05f28861 100644 --- a/src/GitHub/Data/Actions/WorkflowJobs.hs +++ b/src/GitHub/Data/Actions/WorkflowJobs.hs @@ -47,6 +47,7 @@ data Job = Job , jobConclusion :: !Text , jobStartedAt :: !UTCTime , jobCompletedAt :: !UTCTime + , jobName :: !(Name Job) , jobSteps :: !(Vector JobStep) , jobRunCheckUrl :: !URL , jobLabels :: !(Vector Text) @@ -84,6 +85,7 @@ instance FromJSON Job where <*> o .: "conclusion" <*> o .: "started_at" <*> o .: "completed_at" + <*> o .: "name" <*> o .: "steps" <*> o .: "check_run_url" <*> o .: "labels" diff --git a/src/GitHub/Data/Activities.hs b/src/GitHub/Data/Activities.hs index e03986dc..540241c8 100644 --- a/src/GitHub/Data/Activities.hs +++ b/src/GitHub/Data/Activities.hs @@ -26,7 +26,7 @@ instance FromJSON RepoStarred where data Subject = Subject { subjectTitle :: !Text - , subjectURL :: !URL + , subjectURL :: !(Maybe URL) , subjectLatestCommentURL :: !(Maybe URL) -- https://developer.github.com/v3/activity/notifications/ doesn't indicate -- what the possible values for this field are. @@ -46,13 +46,18 @@ instance FromJSON Subject where <*> o .: "type" data NotificationReason - = AssignReason + = ApprovalRequestedReason + | AssignReason | AuthorReason | CommentReason + | CiActivityReason | InvitationReason | ManualReason + | MemberFeatureRequestedReason | MentionReason | ReviewRequestedReason + | SecurityAlertReason + | SecurityAdvisoryCreditReason | StateChangeReason | SubscribedReason | TeamMentionReason @@ -63,17 +68,22 @@ instance Binary NotificationReason instance FromJSON NotificationReason where parseJSON = withText "NotificationReason" $ \t -> case T.toLower t of - "assign" -> pure AssignReason - "author" -> pure AuthorReason - "comment" -> pure CommentReason - "invitation" -> pure InvitationReason - "manual" -> pure ManualReason - "mention" -> pure MentionReason - "review_requested" -> pure ReviewRequestedReason - "state_change" -> pure StateChangeReason - "subscribed" -> pure SubscribedReason - "team_mention" -> pure TeamMentionReason - _ -> fail $ "Unknown NotificationReason " ++ show t + "approval_requested" -> pure ApprovalRequestedReason + "assign" -> pure AssignReason + "author" -> pure AuthorReason + "comment" -> pure CommentReason + "ci_activity" -> pure CiActivityReason + "invitation" -> pure InvitationReason + "manual" -> pure ManualReason + "member_feature_requested" -> pure MemberFeatureRequestedReason + "mention" -> pure MentionReason + "review_requested" -> pure ReviewRequestedReason + "security_alert" -> pure SecurityAlertReason + "security_advisory_credit" -> pure SecurityAdvisoryCreditReason + "state_change" -> pure StateChangeReason + "subscribed" -> pure SubscribedReason + "team_mention" -> pure TeamMentionReason + _ -> fail $ "Unknown NotificationReason " ++ show t data Notification = Notification -- XXX: The notification id field type IS in fact string. Not sure why gh diff --git a/src/GitHub/Data/Definitions.hs b/src/GitHub/Data/Definitions.hs index 73962f28..456974f7 100644 --- a/src/GitHub/Data/Definitions.hs +++ b/src/GitHub/Data/Definitions.hs @@ -233,6 +233,63 @@ type QueryString = [(BS.ByteString, Maybe BS.ByteString)] -- | Count of elements type Count = Int + + +data MembershipRole + = MembershipRoleMember + | MembershipRoleAdmin + | MembershipRoleBillingManager + deriving + (Eq, Ord, Show, Enum, Bounded, Generic, Typeable, Data) + +instance NFData MembershipRole where rnf = genericRnf +instance Binary MembershipRole + +instance FromJSON MembershipRole where + parseJSON = withText "MembershipRole" $ \t -> case T.toLower t of + "member" -> pure MembershipRoleMember + "admin" -> pure MembershipRoleAdmin + "billing_manager" -> pure MembershipRoleBillingManager + _ -> fail $ "Unknown MembershipRole: " <> T.unpack t + +data MembershipState + = MembershipPending + | MembershipActive + deriving (Show, Data, Typeable, Eq, Ord, Generic) + +instance NFData MembershipState where rnf = genericRnf +instance Binary MembershipState + +instance FromJSON MembershipState where + parseJSON = withText "MembershipState" $ \t -> case T.toLower t of + "active" -> pure MembershipActive + "pending" -> pure MembershipPending + _ -> fail $ "Unknown MembershipState: " <> T.unpack t + + +data Membership = Membership + { membershipUrl :: !URL + , membershipState :: !MembershipState + , membershipRole :: !MembershipRole + , membershipOrganizationUrl :: !URL + , membershipOrganization :: !SimpleOrganization + , membershipUser :: !SimpleUser + } + deriving (Show, Data, Typeable, Eq, Ord, Generic) + +instance NFData Membership where rnf = genericRnf +instance Binary Membership + +instance FromJSON Membership where + parseJSON = withObject "Membership" $ \o -> Membership + <$> o .: "url" + <*> o .: "state" + <*> o .: "role" + <*> o .: "organization_url" + <*> o .: "organization" + <*> o .: "user" + + ------------------------------------------------------------------------------- -- IssueNumber ------------------------------------------------------------------------------- diff --git a/src/GitHub/Data/Name.hs b/src/GitHub/Data/Name.hs index dbc09653..99554287 100644 --- a/src/GitHub/Data/Name.hs +++ b/src/GitHub/Data/Name.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} module GitHub.Data.Name ( Name(..), mkName, @@ -8,10 +7,8 @@ module GitHub.Data.Name ( import Prelude () import GitHub.Internal.Prelude -#if MIN_VERSION_aeson(1,0,0) import Data.Aeson.Types (FromJSONKey (..), ToJSONKey (..), fromJSONKeyCoerce, toJSONKeyText) -#endif newtype Name entity = N Text deriving (Eq, Ord, Show, Generic, Typeable, Data) @@ -38,7 +35,6 @@ instance ToJSON (Name entity) where instance IsString (Name entity) where fromString = N . fromString -#if MIN_VERSION_aeson(1,0,0) -- | @since 0.15.0.0 instance ToJSONKey (Name entity) where toJSONKey = toJSONKeyText untagName @@ -46,4 +42,3 @@ instance ToJSONKey (Name entity) where -- | @since 0.15.0.0 instance FromJSONKey (Name entity) where fromJSONKey = fromJSONKeyCoerce -#endif diff --git a/src/GitHub/Data/Options.hs b/src/GitHub/Data/Options.hs index f1ce58da..bf03c617 100644 --- a/src/GitHub/Data/Options.hs +++ b/src/GitHub/Data/Options.hs @@ -122,6 +122,7 @@ instance Binary IssueState -- | 'GitHub.Data.Issues.Issue' state reason data IssueStateReason = StateReasonCompleted + | StateReasonDuplicate | StateReasonNotPlanned | StateReasonReopened deriving @@ -130,12 +131,14 @@ data IssueStateReason instance ToJSON IssueStateReason where toJSON = String . \case StateReasonCompleted -> "completed" + StateReasonDuplicate -> "duplicate" StateReasonNotPlanned -> "not_planned" StateReasonReopened -> "reopened" instance FromJSON IssueStateReason where parseJSON = withText "IssueStateReason" $ \t -> case T.toLower t of "completed" -> pure StateReasonCompleted + "duplicate" -> pure StateReasonDuplicate "not_planned" -> pure StateReasonNotPlanned "reopened" -> pure StateReasonReopened _ -> fail $ "Unknown IssueStateReason: " <> T.unpack t diff --git a/src/GitHub/Data/RateLimit.hs b/src/GitHub/Data/RateLimit.hs index 2db078af..4e0b549c 100644 --- a/src/GitHub/Data/RateLimit.hs +++ b/src/GitHub/Data/RateLimit.hs @@ -3,7 +3,7 @@ module GitHub.Data.RateLimit where import GitHub.Internal.Prelude import Prelude () -import Data.Time.Clock.System.Compat (SystemTime (..)) +import Data.Time.Clock.System (SystemTime (..)) import qualified Data.ByteString.Char8 as BS8 import qualified Network.HTTP.Client as HTTP diff --git a/src/GitHub/Data/Reactions.hs b/src/GitHub/Data/Reactions.hs new file mode 100644 index 00000000..f5fc3ead --- /dev/null +++ b/src/GitHub/Data/Reactions.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE InstanceSigs #-} +module GitHub.Data.Reactions where + +import qualified Data.Text as T +import GitHub.Data.Id (Id) +import GitHub.Data.Definitions (SimpleUser) +import GitHub.Internal.Prelude +import Prelude () + +data Reaction = Reaction + { reactionId :: Id Reaction + , reactionUser :: !(Maybe SimpleUser) + , reactionContent :: !ReactionContent + , reactionCreatedAt :: !UTCTime + } + deriving (Show, Data, Typeable, Eq, Ord, Generic) + +instance NFData Reaction where rnf = genericRnf +instance Binary Reaction + +data NewReaction = NewReaction + { newReactionContent :: !ReactionContent + } + deriving (Show, Data, Typeable, Eq, Ord, Generic) + +instance NFData NewReaction where rnf = genericRnf +instance Binary NewReaction + +-- | +-- +data ReactionContent + = PlusOne + | MinusOne + | Laugh + | Confused + | Heart + | Hooray + | Rocket + | Eyes + deriving (Show, Data, Typeable, Eq, Ord, Enum, Bounded, Generic) + +instance NFData ReactionContent where rnf = genericRnf +instance Binary ReactionContent + +-- JSON instances + +instance FromJSON Reaction where + parseJSON = withObject "Reaction" $ \o -> + Reaction + <$> o .: "id" + <*> o .:? "user" + <*> o .: "content" + <*> o .: "created_at" + +instance ToJSON NewReaction where + toJSON (NewReaction content) = object ["content" .= content] + +instance FromJSON ReactionContent where + parseJSON = withText "ReactionContent" $ \case + "+1" -> pure PlusOne + "-1" -> pure MinusOne + "laugh" -> pure Laugh + "confused" -> pure Confused + "heart" -> pure Heart + "hooray" -> pure Hooray + "rocket" -> pure Rocket + "eyes" -> pure Eyes + t -> fail $ "Unknown ReactionContent: " <> T.unpack t + +instance ToJSON ReactionContent where + toJSON PlusOne = String "+1" + toJSON MinusOne = String "-1" + toJSON Laugh = String "laugh" + toJSON Confused = String "confused" + toJSON Heart = String "heart" + toJSON Hooray = String "hooray" + toJSON Rocket = String "rocket" + toJSON Eyes = String "eyes" diff --git a/src/GitHub/Data/Repos.hs b/src/GitHub/Data/Repos.hs index 98c254c2..456775b6 100644 --- a/src/GitHub/Data/Repos.hs +++ b/src/GitHub/Data/Repos.hs @@ -1,6 +1,4 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} -#define UNSAFE 1 -- | -- This module also exports @@ -19,13 +17,7 @@ import Prelude () import qualified Data.HashMap.Strict as HM import qualified Data.Text as T -#if MIN_VERSION_aeson(1,0,0) import Data.Aeson.Types (FromJSONKey (..), fromJSONKeyCoerce) -#else -#ifdef UNSAFE -import Unsafe.Coerce (unsafeCoerce) -#endif -#endif data Repo = Repo { repoId :: !(Id Repo) @@ -383,22 +375,8 @@ instance FromJSON Language where instance ToJSON Language where toJSON = toJSON . getLanguage -#if MIN_VERSION_aeson(1,0,0) instance FromJSONKey Language where fromJSONKey = fromJSONKeyCoerce -#else -instance FromJSON a => FromJSON (HM.HashMap Language a) where - parseJSON = fmap mapKeyLanguage . parseJSON - where - mapKeyLanguage :: HM.HashMap Text a -> HM.HashMap Language a -#ifdef UNSAFE - mapKeyLanguage = unsafeCoerce -#else - mapKeyLanguage = mapKey Language - mapKey :: (Eq k2, Hashable k2) => (k1 -> k2) -> HM.HashMap k1 a -> HM.HashMap k2 a - mapKey f = HM.fromList . map (first f) . HM.toList -#endif -#endif data ArchiveFormat = ArchiveFormatTarball -- ^ ".tar.gz" format diff --git a/src/GitHub/Data/Request.hs b/src/GitHub/Data/Request.hs index 445c4223..c8138c1a 100644 --- a/src/GitHub/Data/Request.hs +++ b/src/GitHub/Data/Request.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} @@ -15,6 +14,8 @@ module GitHub.Data.Request ( CommandMethod(..), toMethod, FetchCount(..), + PageParams(..), + PageLinks(..), MediaType (..), Paths, IsPathPart(..), @@ -30,6 +31,7 @@ import GitHub.Internal.Prelude import qualified Data.ByteString.Lazy as LBS import qualified Data.Text as T import qualified Network.HTTP.Types.Method as Method +import Network.URI (URI) ------------------------------------------------------------------------------ -- Path parts @@ -75,7 +77,10 @@ toMethod Delete = Method.methodDelete -- | 'PagedQuery' returns just some results, using this data we can specify how -- many pages we want to fetch. -data FetchCount = FetchAtLeast !Word | FetchAll +data FetchCount = + FetchAtLeast !Word + | FetchAll + | FetchPage PageParams deriving (Eq, Ord, Read, Show, Generic, Typeable) @@ -97,6 +102,37 @@ instance Hashable FetchCount instance Binary FetchCount instance NFData FetchCount where rnf = genericRnf +------------------------------------------------------------------------------- +-- PageParams +------------------------------------------------------------------------------- + +-- | Params for specifying the precise page and items per page. +data PageParams = PageParams { + pageParamsPerPage :: Maybe Int + , pageParamsPage :: Maybe Int + } + deriving (Eq, Ord, Read, Show, Generic, Typeable) + +instance Hashable PageParams +instance Binary PageParams +instance NFData PageParams where rnf = genericRnf + +------------------------------------------------------------------------------- +-- PageLinks +------------------------------------------------------------------------------- + +-- | 'PagedQuery' returns just some results, using this data we can specify how +-- many pages we want to fetch. +data PageLinks = PageLinks { + pageLinksPrev :: Maybe URI + , pageLinksNext :: Maybe URI + , pageLinksLast :: Maybe URI + , pageLinksFirst :: Maybe URI + } + deriving (Eq, Ord, Show, Generic, Typeable) + +instance NFData PageLinks where rnf = genericRnf + ------------------------------------------------------------------------------- -- MediaType ------------------------------------------------------------------------------- diff --git a/src/GitHub/Endpoints/Issues.hs b/src/GitHub/Endpoints/Issues.hs index 9cd7258f..47888dc5 100644 --- a/src/GitHub/Endpoints/Issues.hs +++ b/src/GitHub/Endpoints/Issues.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE CPP #-} - -- | -- The issues API as described on . diff --git a/src/GitHub/Endpoints/Organizations/Members.hs b/src/GitHub/Endpoints/Organizations/Members.hs index 84e52e43..8de82b77 100644 --- a/src/GitHub/Endpoints/Organizations/Members.hs +++ b/src/GitHub/Endpoints/Organizations/Members.hs @@ -7,6 +7,7 @@ module GitHub.Endpoints.Organizations.Members ( membersOfWithR, isMemberOfR, orgInvitationsR, + orgMembershipR, module GitHub.Data, ) where @@ -48,3 +49,10 @@ isMemberOfR user org = -- See orgInvitationsR :: Name Organization -> FetchCount -> Request 'RA (Vector Invitation) orgInvitationsR org = pagedQuery ["orgs", toPathPart org, "invitations"] [] + +-- | Get user membership information in an organization +-- +-- See +orgMembershipR :: Name User -> Name Organization -> Request 'RA Membership +orgMembershipR user org = + Query [ "orgs", toPathPart org, "memberships", toPathPart user ] [] \ No newline at end of file diff --git a/src/GitHub/Endpoints/Reactions.hs b/src/GitHub/Endpoints/Reactions.hs new file mode 100644 index 00000000..a4ec31f7 --- /dev/null +++ b/src/GitHub/Endpoints/Reactions.hs @@ -0,0 +1,60 @@ +-- | +-- The Reactions API as described at +-- . +module GitHub.Endpoints.Reactions ( + issueReactionsR, + createIssueReactionR, + deleteIssueReactionR, + commentReactionsR, + createCommentReactionR, + deleteCommentReactionR, + module GitHub.Data, +) where + +import GitHub.Data +import GitHub.Internal.Prelude +import Prelude () + +-- | List reactions for an issue. +-- See +issueReactionsR :: Name Owner -> Name Repo -> Id Issue -> FetchCount -> Request k (Vector Reaction) +issueReactionsR owner repo iid = + pagedQuery ["repos", toPathPart owner, toPathPart repo, "issues", toPathPart iid, "reactions"] [] + +-- | Create reaction for an issue comment. +-- See +createIssueReactionR :: Name Owner -> Name Repo -> Id Issue -> ReactionContent -> Request 'RW Reaction +createIssueReactionR owner repo iid content = + command Post parts (encode $ NewReaction content) + where + parts = ["repos", toPathPart owner, toPathPart repo, "issues", toPathPart iid, "reactions"] + +-- | Delete an issue comment reaction. +-- See +deleteIssueReactionR :: Name Owner -> Name Repo -> Id Issue -> Id Reaction -> GenRequest 'MtUnit 'RW () +deleteIssueReactionR owner repo iid rid = + Command Delete parts mempty + where + parts = ["repos", toPathPart owner, toPathPart repo, "issues", toPathPart iid, "reactions", toPathPart rid] + +-- | List reactions for an issue comment. +-- See +commentReactionsR :: Name Owner -> Name Repo -> Id Comment -> FetchCount -> Request k (Vector Reaction) +commentReactionsR owner repo cid = + pagedQuery ["repos", toPathPart owner, toPathPart repo, "issues", "comments", toPathPart cid, "reactions"] [] + +-- | Create reaction for an issue comment. +-- See https://docs.github.com/en/rest/reactions/reactions?apiVersion=2022-11-28#create-reaction-for-an-issue-comment +createCommentReactionR :: Name Owner -> Name Repo -> Id Comment -> ReactionContent -> Request 'RW Reaction +createCommentReactionR owner repo cid content = + command Post parts (encode $ NewReaction content) + where + parts = ["repos", toPathPart owner, toPathPart repo, "issues", "comments", toPathPart cid, "reactions"] + +-- | Delete an issue comment reaction. +-- See +deleteCommentReactionR :: Name Owner -> Name Repo -> Id Comment -> Id Reaction -> GenRequest 'MtUnit 'RW () +deleteCommentReactionR owner repo cid rid = + Command Delete parts mempty + where + parts = ["repos", toPathPart owner, toPathPart repo, "issues", "comments", toPathPart cid, "reactions", toPathPart rid] diff --git a/src/GitHub/Endpoints/Repos/Comments.hs b/src/GitHub/Endpoints/Repos/Comments.hs index 371288e3..bd554492 100644 --- a/src/GitHub/Endpoints/Repos/Comments.hs +++ b/src/GitHub/Endpoints/Repos/Comments.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE CPP #-} - -- | -- The repo commits API as described on -- . diff --git a/src/GitHub/Endpoints/Repos/Commits.hs b/src/GitHub/Endpoints/Repos/Commits.hs index 3a10e0a9..1c50c651 100644 --- a/src/GitHub/Endpoints/Repos/Commits.hs +++ b/src/GitHub/Endpoints/Repos/Commits.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE CPP #-} - -- | -- The repo commits API as described on -- . diff --git a/src/GitHub/Internal/Prelude.hs b/src/GitHub/Internal/Prelude.hs index 0419d934..d6efaf39 100644 --- a/src/GitHub/Internal/Prelude.hs +++ b/src/GitHub/Internal/Prelude.hs @@ -1,5 +1,4 @@ {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE CPP #-} -- | -- This module may change between minor releases. Do not rely on its contents. @@ -24,7 +23,7 @@ import Data.Maybe as X (catMaybes) import Data.Semigroup as X (Semigroup (..)) import Data.String as X (IsString (..)) import Data.Text as X (Text, pack, unpack) -import Data.Time.Compat as X (UTCTime) +import Data.Time as X (UTCTime) import Data.Time.ISO8601 as X (formatISO8601) import Data.Vector as X (Vector) import GHC.Generics as X (Generic) diff --git a/src/GitHub/Request.hs b/src/GitHub/Request.hs index c5eb006c..39deb0a6 100644 --- a/src/GitHub/Request.hs +++ b/src/GitHub/Request.hs @@ -54,6 +54,7 @@ module GitHub.Request ( ParseResponse (..), makeHttpRequest, parseStatus, + parsePageLinks, StatusMap, getNextUrl, performPagedRequest, @@ -79,6 +80,7 @@ import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Except (ExceptT (..), runExceptT) import Data.Aeson (eitherDecode) import Data.List (find) +import Data.Maybe (fromMaybe) import Data.Tagged (Tagged (..)) import Data.Version (showVersion) @@ -87,13 +89,14 @@ import Network.HTTP.Client httpLbs, method, newManager, redirectCount, requestBody, requestHeaders, setQueryString, setRequestIgnoreStatus) import Network.HTTP.Link.Parser (parseLinkHeaderBS) -import Network.HTTP.Link.Types (LinkParam (..), href, linkParams) +import Network.HTTP.Link.Types (Link(..), LinkParam (..), href, linkParams) import Network.HTTP.Types (Method, RequestHeaders, Status (..)) import Network.URI (URI, escapeURIString, isUnescapedInURIComponent, parseURIReference, relativeTo) import qualified Data.ByteString as BS +import Data.ByteString.Builder (intDec, toLazyByteString) import qualified Data.ByteString.Lazy as LBS import qualified Data.Text as T import qualified Data.Text.Encoding as TE @@ -199,11 +202,6 @@ executeRequest auth req = withOpenSSL $ do manager <- newManager tlsManagerSettings executeRequestWithMgr manager auth req -lessFetchCount :: Int -> FetchCount -> Bool -lessFetchCount _ FetchAll = True -lessFetchCount i (FetchAtLeast j) = i < fromIntegral j - - -- | Like 'executeRequest' but with provided 'Manager'. executeRequestWithMgr :: (AuthMethod am, ParseResponse mt a) @@ -235,10 +233,13 @@ executeRequestWithMgrAndRes mgr auth req = runExceptT $ do res <- httpLbs' httpReq (<$ res) <$> unTagged (parseResponse httpReq res :: Tagged mt (ExceptT Error IO b)) - performHttpReq httpReq (PagedQuery _ _ l) = - unTagged (performPagedRequest httpLbs' predicate httpReq :: Tagged mt (ExceptT Error IO (HTTP.Response b))) - where - predicate v = lessFetchCount (length v) l + performHttpReq httpReq (PagedQuery _ _ (FetchPage _)) = do + (res, _pageLinks) <- unTagged (performPerPageRequest httpLbs' httpReq :: Tagged mt (ExceptT Error IO (HTTP.Response b, PageLinks))) + return res + performHttpReq httpReq (PagedQuery _ _ FetchAll) = + unTagged (performPagedRequest httpLbs' (const True) httpReq :: Tagged mt (ExceptT Error IO (HTTP.Response b))) + performHttpReq httpReq (PagedQuery _ _ (FetchAtLeast j)) = + unTagged (performPagedRequest httpLbs' (\v -> length v < fromIntegral j) httpReq :: Tagged mt (ExceptT Error IO (HTTP.Response b))) performHttpReq httpReq (Command _ _ _) = do res <- httpLbs' httpReq @@ -456,7 +457,7 @@ makeHttpRequest auth r = case r of $ setReqHeaders . unTagged (modifyRequest :: Tagged mt (HTTP.Request -> HTTP.Request)) . maybe id setAuthRequest auth - . setQueryString qs + . setQueryString (qs <> extraQueryItems) $ req PagedQuery paths qs _ -> do req <- parseUrl' $ url paths @@ -464,7 +465,7 @@ makeHttpRequest auth r = case r of $ setReqHeaders . unTagged (modifyRequest :: Tagged mt (HTTP.Request -> HTTP.Request)) . maybe id setAuthRequest auth - . setQueryString qs + . setQueryString (qs <> extraQueryItems) $ req Command m paths body -> do req <- parseUrl' $ url paths @@ -496,6 +497,14 @@ makeHttpRequest auth r = case r of setBody :: LBS.ByteString -> HTTP.Request -> HTTP.Request setBody body req = req { requestBody = RequestBodyLBS body } + extraQueryItems :: [(BS.ByteString, Maybe BS.ByteString)] + extraQueryItems = case r of + PagedQuery _ _ (FetchPage pp) -> catMaybes [ + (\page -> ("page", Just (LBS.toStrict $ toLazyByteString $ intDec page))) <$> pageParamsPage pp + , (\perPage -> ("per_page", Just (LBS.toStrict $ toLazyByteString $ intDec perPage))) <$> pageParamsPerPage pp + ] + _ -> [] + -- | Query @Link@ header with @rel=next@ from the request headers. getNextUrl :: HTTP.Response a -> Maybe URI getNextUrl req = do @@ -542,6 +551,35 @@ performPagedRequest httpLbs' predicate initReq = Tagged $ do go (acc <> m) res' req' (_, _) -> return (acc <$ res) +-- | Helper for requesting a single page, as specified by 'PageParams'. +-- +-- This parses and returns the 'PageLinks' alongside the HTTP response. +performPerPageRequest + :: forall a m mt. (ParseResponse mt a, MonadCatch m, MonadError Error m) + => (HTTP.Request -> m (HTTP.Response LBS.ByteString)) -- ^ `httpLbs` analogue + -> HTTP.Request -- ^ initial request + -> Tagged mt (m (HTTP.Response a, PageLinks)) +performPerPageRequest httpLbs' initReq = Tagged $ do + res <- httpLbs' initReq + m <- unTagged (parseResponse initReq res :: Tagged mt (m a)) + return (m <$ res, parsePageLinks res) + +-- | Parse the 'PageLinks' from an HTTP response, where the information is +-- encoded in the Link header. +parsePageLinks :: HTTP.Response a -> PageLinks +parsePageLinks res = PageLinks { + pageLinksPrev = linkToUri <$> find (elem (Rel, "prev") . linkParams) links + , pageLinksNext = linkToUri <$> find (elem (Rel, "next") . linkParams) links + , pageLinksLast = linkToUri <$> find (elem (Rel, "last") . linkParams) links + , pageLinksFirst = linkToUri <$> find (elem (Rel, "first") . linkParams) links + } + where + links :: [Link URI] + links = fromMaybe [] (lookup "Link" (responseHeaders res) >>= parseLinkHeaderBS) + + linkToUri :: Link URI -> URI + linkToUri (Link uri _) = uri + ------------------------------------------------------------------------------- -- Internal ------------------------------------------------------------------------------- pFad - Phonifier reborn

Pfad - The Proxy pFad of © 2024 Garber Painting. All rights reserved.

Note: This service is not intended for secure transactions such as banking, social media, email, or purchasing. Use at your own risk. We assume no liability whatsoever for broken pages.


Alternative Proxies:

Alternative Proxy

pFad Proxy

pFad v3 Proxy

pFad v4 Proxy