From 0afcf0cf6ffe582ce6624e0bc1520acd55dbdfc6 Mon Sep 17 00:00:00 2001 From: Tom McLaughlin Date: Fri, 23 Feb 2024 19:12:46 -0800 Subject: [PATCH 1/4] Enable per-page querying --- github.cabal | 1 + spec/GitHub/IssuesSpec.hs | 32 ++++++++++++++++---- src/GitHub/Data/Request.hs | 39 +++++++++++++++++++++++- src/GitHub/Request.hs | 62 ++++++++++++++++++++++++++++++-------- 4 files changed, 115 insertions(+), 19 deletions(-) diff --git a/github.cabal b/github.cabal index cde8b8ff..e4a906e5 100644 --- a/github.cabal +++ b/github.cabal @@ -268,6 +268,7 @@ test-suite github-test , file-embed , github , hspec >=2.6.1 && <2.12 + , http-client , tagged , text , unordered-containers 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/Data/Request.hs b/src/GitHub/Data/Request.hs index 445c4223..c9cc7a76 100644 --- a/src/GitHub/Data/Request.hs +++ b/src/GitHub/Data/Request.hs @@ -15,6 +15,8 @@ module GitHub.Data.Request ( CommandMethod(..), toMethod, FetchCount(..), + PageParams(..), + PageLinks(..), MediaType (..), Paths, IsPathPart(..), @@ -30,6 +32,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 +78,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 +103,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/Request.hs b/src/GitHub/Request.hs index c5eb006c..332d1124 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 (BS.toStrict $ toLazyByteString $ intDec page))) <$> pageParamsPage pp + , (\perPage -> ("per_page", Just (BS.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 ------------------------------------------------------------------------------- From 772b9f1039663c96db77dc14570fbffd6e833e17 Mon Sep 17 00:00:00 2001 From: Tom McLaughlin Date: Wed, 20 Mar 2024 18:43:17 -0700 Subject: [PATCH 2/4] Fix search endpoints by controlling URL escaping --- src/GitHub/Data/Definitions.hs | 2 +- src/GitHub/Data/Options.hs | 12 ++++++------ src/GitHub/Data/Request.hs | 4 ++++ src/GitHub/Endpoints/GitData/Trees.hs | 2 +- src/GitHub/Endpoints/Organizations/Members.hs | 2 +- src/GitHub/Endpoints/Organizations/Teams.hs | 2 +- src/GitHub/Endpoints/Repos.hs | 16 +++++++++------- src/GitHub/Endpoints/Repos/Commits.hs | 13 +++++++------ src/GitHub/Endpoints/Repos/Contents.hs | 2 +- src/GitHub/Endpoints/Repos/Deployments.hs | 2 +- src/GitHub/Endpoints/Search.hs | 8 ++++---- src/GitHub/Internal/Prelude.hs | 5 +++-- src/GitHub/Request.hs | 12 ++++++------ 13 files changed, 45 insertions(+), 37 deletions(-) diff --git a/src/GitHub/Data/Definitions.hs b/src/GitHub/Data/Definitions.hs index 73962f28..353e5e12 100644 --- a/src/GitHub/Data/Definitions.hs +++ b/src/GitHub/Data/Definitions.hs @@ -228,7 +228,7 @@ data OrgMemberRole deriving (Show, Eq, Ord, Enum, Bounded, Typeable, Data, Generic) -- | Request query string -type QueryString = [(BS.ByteString, Maybe BS.ByteString)] +type QueryString = [(BS.ByteString, [EscapeItem])] -- | Count of elements type Count = Int diff --git a/src/GitHub/Data/Options.hs b/src/GitHub/Data/Options.hs index f1ce58da..98c24bbc 100644 --- a/src/GitHub/Data/Options.hs +++ b/src/GitHub/Data/Options.hs @@ -368,7 +368,7 @@ pullRequestOptionsToQueryString (PullRequestOptions st head_ base sort dir) = , mk "base" <$> base' ] where - mk k v = (k, Just v) + mk k v = (k, [QE v]) state' = case st of Nothing -> "all" Just StateOpen -> "open" @@ -465,7 +465,7 @@ issueOptionsToQueryString (IssueOptions filt st labels sort dir since) = , mk "since" <$> since' ] where - mk k v = (k, Just v) + mk k v = (k, [QE v]) filt' = case filt of IssueFilterAssigned -> "assigned" IssueFilterCreated -> "created" @@ -617,7 +617,7 @@ issueRepoOptionsToQueryString IssueRepoOptions {..} = , mk "mentioned" <$> mentioned' ] where - mk k v = (k, Just v) + mk k v = (k, [QE v]) filt f x = case x of FilterAny -> Just "*" FilterNone -> Just "none" @@ -745,7 +745,7 @@ artifactOptionsToQueryString (ArtifactOptions name) = [ mk "name" <$> name' ] where - mk k v = (k, Just v) + mk k v = (k, [QE v]) name' = fmap TE.encodeUtf8 name ------------------------------------------------------------------------------- @@ -795,7 +795,7 @@ cacheOptionsToQueryString (CacheOptions ref key sort dir) = , mk "directions" <$> direction' ] where - mk k v = (k, Just v) + mk k v = (k, [QE v]) sort' = sort <&> \case SortCacheCreatedAt -> "created_at" SortCacheLastAccessedAt -> "last_accessed_at" @@ -899,7 +899,7 @@ workflowRunOptionsToQueryString (WorkflowRunOptions actor branch event status cr , mk "head_sha" <$> headSha' ] where - mk k v = (k, Just v) + mk k v = (k, [QE v]) actor' = fmap TE.encodeUtf8 actor branch' = fmap TE.encodeUtf8 branch event' = fmap TE.encodeUtf8 event diff --git a/src/GitHub/Data/Request.hs b/src/GitHub/Data/Request.hs index c9cc7a76..5d183fca 100644 --- a/src/GitHub/Data/Request.hs +++ b/src/GitHub/Data/Request.hs @@ -221,6 +221,10 @@ deriving instance Eq (GenRequest rw mt a) deriving instance Ord (GenRequest rw mt a) deriving instance Show (GenRequest rw mt a) +instance Hashable EscapeItem where + hashWithSalt salt (QN x) = hashWithSalt salt x + hashWithSalt salt (QE x) = hashWithSalt salt x + instance Hashable (GenRequest rw mt a) where hashWithSalt salt (Query ps qs) = salt `hashWithSalt` (0 :: Int) diff --git a/src/GitHub/Endpoints/GitData/Trees.hs b/src/GitHub/Endpoints/GitData/Trees.hs index 4bdf389b..2f6b1098 100644 --- a/src/GitHub/Endpoints/GitData/Trees.hs +++ b/src/GitHub/Endpoints/GitData/Trees.hs @@ -22,4 +22,4 @@ treeR user repo sha = -- See nestedTreeR :: Name Owner -> Name Repo -> Name Tree -> Request k Tree nestedTreeR user repo sha = - query ["repos", toPathPart user, toPathPart repo, "git", "trees", toPathPart sha] [("recursive", Just "1")] + query ["repos", toPathPart user, toPathPart repo, "git", "trees", toPathPart sha] [("recursive", [QE "1"])] diff --git a/src/GitHub/Endpoints/Organizations/Members.hs b/src/GitHub/Endpoints/Organizations/Members.hs index 84e52e43..4ec707d7 100644 --- a/src/GitHub/Endpoints/Organizations/Members.hs +++ b/src/GitHub/Endpoints/Organizations/Members.hs @@ -26,7 +26,7 @@ membersOfR organization = -- See membersOfWithR :: Name Organization -> OrgMemberFilter -> OrgMemberRole -> FetchCount -> Request k (Vector SimpleUser) membersOfWithR org f r = - pagedQuery ["orgs", toPathPart org, "members"] [("filter", Just f'), ("role", Just r')] + pagedQuery ["orgs", toPathPart org, "members"] [("filter", [QE f']), ("role", [QE r'])] where f' = case f of OrgMemberFilter2faDisabled -> "2fa_disabled" diff --git a/src/GitHub/Endpoints/Organizations/Teams.hs b/src/GitHub/Endpoints/Organizations/Teams.hs index af8c8b36..a2039031 100644 --- a/src/GitHub/Endpoints/Organizations/Teams.hs +++ b/src/GitHub/Endpoints/Organizations/Teams.hs @@ -57,7 +57,7 @@ deleteTeamR tid = -- See listTeamMembersR :: Id Team -> TeamMemberRole -> FetchCount -> Request 'RA (Vector SimpleUser) listTeamMembersR tid r = - pagedQuery ["teams", toPathPart tid, "members"] [("role", Just r')] + pagedQuery ["teams", toPathPart tid, "members"] [("role", [QE r'])] where r' = case r of TeamMemberRoleAll -> "all" diff --git a/src/GitHub/Endpoints/Repos.hs b/src/GitHub/Endpoints/Repos.hs index 85c8b639..d5f58c21 100644 --- a/src/GitHub/Endpoints/Repos.hs +++ b/src/GitHub/Endpoints/Repos.hs @@ -28,16 +28,18 @@ module GitHub.Endpoints.Repos ( module GitHub.Data, ) where +import qualified Data.ByteString as BS import GitHub.Data import GitHub.Internal.Prelude import Prelude () -repoPublicityQueryString :: RepoPublicity -> QueryString -repoPublicityQueryString RepoPublicityAll = [("type", Just "all")] -repoPublicityQueryString RepoPublicityOwner = [("type", Just "owner")] -repoPublicityQueryString RepoPublicityMember = [("type", Just "member")] -repoPublicityQueryString RepoPublicityPublic = [("type", Just "public")] -repoPublicityQueryString RepoPublicityPrivate = [("type", Just "private")] + +repoPublicityQueryString :: RepoPublicity -> [(BS.ByteString, [EscapeItem])] +repoPublicityQueryString RepoPublicityAll = [("type", [QE "all"])] +repoPublicityQueryString RepoPublicityOwner = [("type", [QE "owner"])] +repoPublicityQueryString RepoPublicityMember = [("type", [QE "member"])] +repoPublicityQueryString RepoPublicityPublic = [("type", [QE "public"])] +repoPublicityQueryString RepoPublicityPrivate = [("type", [QE "private"])] -- | List your repositories. -- See @@ -112,7 +114,7 @@ contributorsR contributorsR user repo anon = pagedQuery ["repos", toPathPart user, toPathPart repo, "contributors"] qs where - qs | anon = [("anon", Just "true")] + qs | anon = [("anon", [QE "true"])] | otherwise = [] -- | List languages. diff --git a/src/GitHub/Endpoints/Repos/Commits.hs b/src/GitHub/Endpoints/Repos/Commits.hs index 3a10e0a9..32814cb5 100644 --- a/src/GitHub/Endpoints/Repos/Commits.hs +++ b/src/GitHub/Endpoints/Repos/Commits.hs @@ -21,12 +21,13 @@ import qualified Data.ByteString as BS import qualified Data.Text as T import qualified Data.Text.Encoding as TE -renderCommitQueryOption :: CommitQueryOption -> (BS.ByteString, Maybe BS.ByteString) -renderCommitQueryOption (CommitQuerySha sha) = ("sha", Just $ TE.encodeUtf8 sha) -renderCommitQueryOption (CommitQueryPath path) = ("path", Just $ TE.encodeUtf8 path) -renderCommitQueryOption (CommitQueryAuthor author) = ("author", Just $ TE.encodeUtf8 author) -renderCommitQueryOption (CommitQuerySince date) = ("since", Just $ TE.encodeUtf8 . T.pack $ formatISO8601 date) -renderCommitQueryOption (CommitQueryUntil date) = ("until", Just $ TE.encodeUtf8 . T.pack $ formatISO8601 date) + +renderCommitQueryOption :: CommitQueryOption -> (BS.ByteString, [EscapeItem]) +renderCommitQueryOption (CommitQuerySha sha) = ("sha", [QE $ TE.encodeUtf8 sha]) +renderCommitQueryOption (CommitQueryPath path) = ("path", [QE $ TE.encodeUtf8 path]) +renderCommitQueryOption (CommitQueryAuthor author) = ("author", [QE $ TE.encodeUtf8 author]) +renderCommitQueryOption (CommitQuerySince date) = ("since", [QE $ TE.encodeUtf8 . T.pack $ formatISO8601 date]) +renderCommitQueryOption (CommitQueryUntil date) = ("until", [QE $ TE.encodeUtf8 . T.pack $ formatISO8601 date]) -- | List commits on a repository. -- See diff --git a/src/GitHub/Endpoints/Repos/Contents.hs b/src/GitHub/Endpoints/Repos/Contents.hs index 00d2c632..a0b38343 100644 --- a/src/GitHub/Endpoints/Repos/Contents.hs +++ b/src/GitHub/Endpoints/Repos/Contents.hs @@ -37,7 +37,7 @@ contentsForR contentsForR user repo path ref = query ["repos", toPathPart user, toPathPart repo, "contents", path] qs where - qs = maybe [] (\r -> [("ref", Just . TE.encodeUtf8 $ r)]) ref + qs = maybe [] (\r -> [("ref", [QE . TE.encodeUtf8 $ r])]) ref readmeForR :: Name Owner -> Name Repo -> Request k Content readmeForR user repo = diff --git a/src/GitHub/Endpoints/Repos/Deployments.hs b/src/GitHub/Endpoints/Repos/Deployments.hs index 39724771..250b1a05 100644 --- a/src/GitHub/Endpoints/Repos/Deployments.hs +++ b/src/GitHub/Endpoints/Repos/Deployments.hs @@ -25,7 +25,7 @@ deploymentsWithOptionsForR -> Request 'RA (Vector (Deployment a)) deploymentsWithOptionsForR owner repo limit opts = pagedQuery (deployPaths owner repo) - (map (second Just . renderDeploymentQueryOption) opts) + (map (second (\x -> [QE x]) . renderDeploymentQueryOption) opts) limit -- | Create a deployment. diff --git a/src/GitHub/Endpoints/Search.hs b/src/GitHub/Endpoints/Search.hs index 06ddd373..91f6e137 100644 --- a/src/GitHub/Endpoints/Search.hs +++ b/src/GitHub/Endpoints/Search.hs @@ -20,22 +20,22 @@ import qualified Data.Text.Encoding as TE -- See searchReposR :: Text -> FetchCount -> Request k (SearchResult Repo) searchReposR searchString = - PagedQuery ["search", "repositories"] [("q", Just $ TE.encodeUtf8 searchString)] + PagedQuery ["search", "repositories"] [("q", [QN $ TE.encodeUtf8 searchString])] -- | Search code. -- See searchCodeR :: Text -> FetchCount -> Request k (SearchResult Code) searchCodeR searchString = - PagedQuery ["search", "code"] [("q", Just $ TE.encodeUtf8 searchString)] + PagedQuery ["search", "code"] [("q", [QN $ TE.encodeUtf8 searchString])] -- | Search issues. -- See searchIssuesR :: Text -> FetchCount -> Request k (SearchResult Issue) searchIssuesR searchString = - PagedQuery ["search", "issues"] [("q", Just $ TE.encodeUtf8 searchString)] + PagedQuery ["search", "issues"] [("q", [QN $ TE.encodeUtf8 searchString])] -- | Search users. -- See searchUsersR :: Text -> FetchCount -> Request k (SearchResult SimpleUser) searchUsersR searchString = - PagedQuery ["search", "users"] [("q", Just $ TE.encodeUtf8 searchString)] + PagedQuery ["search", "users"] [("q", [QN $ TE.encodeUtf8 searchString])] diff --git a/src/GitHub/Internal/Prelude.hs b/src/GitHub/Internal/Prelude.hs index 0419d934..7c493b7f 100644 --- a/src/GitHub/Internal/Prelude.hs +++ b/src/GitHub/Internal/Prelude.hs @@ -17,8 +17,9 @@ import Data.Binary as X (Binary) import Data.Binary.Instances as X () import Data.Data as X (Data, Typeable) import Data.Foldable as X (toList) -import Data.Hashable as X (Hashable (..)) +import Data.Functor.Compat as X ((<&>)) import Data.HashMap.Strict as X (HashMap) +import Data.Hashable as X (Hashable (..)) import Data.List as X (intercalate) import Data.Maybe as X (catMaybes) import Data.Semigroup as X (Semigroup (..)) @@ -28,5 +29,5 @@ import Data.Time.Compat as X (UTCTime) import Data.Time.ISO8601 as X (formatISO8601) import Data.Vector as X (Vector) import GHC.Generics as X (Generic) +import Network.HTTP.Types as X (EscapeItem(..)) import Prelude.Compat as X -import Data.Functor.Compat as X ((<&>)) diff --git a/src/GitHub/Request.hs b/src/GitHub/Request.hs index 332d1124..3ee68854 100644 --- a/src/GitHub/Request.hs +++ b/src/GitHub/Request.hs @@ -87,7 +87,7 @@ import Data.Version (showVersion) import Network.HTTP.Client (HttpException (..), Manager, RequestBody (..), Response (..), getUri, httpLbs, method, newManager, redirectCount, requestBody, requestHeaders, - setQueryString, setRequestIgnoreStatus) + setQueryStringPartialEscape, setRequestIgnoreStatus) import Network.HTTP.Link.Parser (parseLinkHeaderBS) import Network.HTTP.Link.Types (Link(..), LinkParam (..), href, linkParams) import Network.HTTP.Types (Method, RequestHeaders, Status (..)) @@ -457,7 +457,7 @@ makeHttpRequest auth r = case r of $ setReqHeaders . unTagged (modifyRequest :: Tagged mt (HTTP.Request -> HTTP.Request)) . maybe id setAuthRequest auth - . setQueryString (qs <> extraQueryItems) + . setQueryStringPartialEscape (qs <> extraQueryItems) $ req PagedQuery paths qs _ -> do req <- parseUrl' $ url paths @@ -465,7 +465,7 @@ makeHttpRequest auth r = case r of $ setReqHeaders . unTagged (modifyRequest :: Tagged mt (HTTP.Request -> HTTP.Request)) . maybe id setAuthRequest auth - . setQueryString (qs <> extraQueryItems) + . setQueryStringPartialEscape (qs <> extraQueryItems) $ req Command m paths body -> do req <- parseUrl' $ url paths @@ -497,11 +497,11 @@ 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 :: [(BS.ByteString, [EscapeItem])] extraQueryItems = case r of PagedQuery _ _ (FetchPage pp) -> catMaybes [ - (\page -> ("page", Just (BS.toStrict $ toLazyByteString $ intDec page))) <$> pageParamsPage pp - , (\perPage -> ("per_page", Just (BS.toStrict $ toLazyByteString $ intDec perPage))) <$> pageParamsPerPage pp + (\page -> ("page", [QE (BS.toStrict $ toLazyByteString $ intDec page)])) <$> pageParamsPage pp + , (\perPage -> ("per_page", [QE (BS.toStrict $ toLazyByteString $ intDec perPage)])) <$> pageParamsPerPage pp ] _ -> [] From 01be3c1168c81dc45123fb08e2904b8cc958a5e4 Mon Sep 17 00:00:00 2001 From: Tom McLaughlin Date: Wed, 4 Jun 2025 06:07:00 -0700 Subject: [PATCH 3/4] Bump a couple bounds --- github.cabal | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/github.cabal b/github.cabal index e4a906e5..77dee74e 100644 --- a/github.cabal +++ b/github.cabal @@ -200,12 +200,12 @@ library -- other packages build-depends: aeson >=1.4.0.0 && <1.6 || >=2.0.1.0 && <2.3 - , base-compat >=0.11.1 && <0.14 + , base-compat >=0.11.1 && <0.15 , 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 - , hashable >=1.2.7.0 && <1.5 + , hashable >=1.2.7.0 && <1.6 , http-client >=0.5.12 && <0.8 , http-link-header >=1.0.3.1 && <1.3 , http-types >=0.12.3 && <0.13 From a1db0c511f1b3af37d8509bf005c07a5152049f9 Mon Sep 17 00:00:00 2001 From: Tom McLaughlin Date: Tue, 16 Sep 2025 14:57:05 -0700 Subject: [PATCH 4/4] Fix Job type to make some fields optional --- src/GitHub/Data/Actions/WorkflowJobs.hs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/GitHub/Data/Actions/WorkflowJobs.hs b/src/GitHub/Data/Actions/WorkflowJobs.hs index 9698e3a9..dc651c3b 100644 --- a/src/GitHub/Data/Actions/WorkflowJobs.hs +++ b/src/GitHub/Data/Actions/WorkflowJobs.hs @@ -7,11 +7,11 @@ module GitHub.Data.Actions.WorkflowJobs ( Job(..), ) where -import Prelude () import GitHub.Internal.Prelude (Applicative ((<*>)), Data, Eq, FromJSON (parseJSON), Generic, Integer, - Ord, Show, Text, Typeable, UTCTime, Vector, withObject, ($), (.:), + Maybe, Ord, Show, Text, Typeable, UTCTime, Vector, withObject, ($), (.:), (<$>)) +import Prelude () import GitHub.Data.Id (Id) import GitHub.Data.Name (Name) @@ -50,10 +50,10 @@ data Job = Job , jobSteps :: !(Vector JobStep) , jobRunCheckUrl :: !URL , jobLabels :: !(Vector Text) - , jobRunnerId :: !Integer - , jobRunnerName :: !Text - , jobRunnerGroupId :: !Integer - , jobRunnerGroupName :: !Text + , jobRunnerId :: !(Maybe Integer) + , jobRunnerName :: !(Maybe Text) + , jobRunnerGroupId :: !(Maybe Integer) + , jobRunnerGroupName :: !(Maybe Text) } deriving (Show, Data, Typeable, Eq, Ord, Generic)