Reduce number of fetched tags by using a prefix
All checks were successful
Build / audit (push) Successful in 14m17s
Build / test (push) Successful in 14m20s

This commit is contained in:
Eugen Wissner 2024-03-25 18:36:15 +01:00
parent 7c9c890056
commit 47f27394de
Signed by: belka
GPG Key ID: A27FDC1E8EE902C0

View File

@ -46,6 +46,8 @@ import qualified Data.Aeson.KeyMap as KeyMap
import GHC.Records (HasField(..)) import GHC.Records (HasField(..))
import Control.Monad.Trans.Reader (asks) import Control.Monad.Trans.Reader (asks)
import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.IO.Class (MonadIO(..))
import Control.Applicative (Applicative(liftA2))
import Data.Char (isAlpha)
data PackageOwner = PackageOwner data PackageOwner = PackageOwner
{ owner :: Text { owner :: Text
@ -66,8 +68,25 @@ data MatchToken
| OneOfMatchToken [Char] | OneOfMatchToken [Char]
deriving (Eq, Show) deriving (Eq, Show)
-- | Removes the leading "v" from the version string and returns the result if -- | Matches a string (for example a version name or CVS tag) against a pattern.
-- it looks like a version. -- Returns the matched part of the string or 'Nothing' if there is no match.
--
-- The pattern is just a list of characters with some special characters and
-- sequences.
--
-- * ( ) - The text in parentheses is matched but no saved in the resulting
-- string.
-- * \\d - Matches zero or more digits.
-- * \\. - Matches zero or more digits or dots.
-- * \\\\ - Matches a back slash.
-- * * - Matches everything.
--
-- For example the following expression matches tags like @v1.2.3@, but returns
-- only @1.2.3@.
--
-- @
-- (v)\\.
-- @
match :: Text -> Text -> Maybe Text match :: Text -> Text -> Maybe Text
match fullPattern input = match fullPattern input =
case Text.foldl' go (Just startState) input of case Text.foldl' go (Just startState) input of
@ -207,6 +226,7 @@ instance Aeson.FromJSON GhData where
data GhVariables = GhVariables data GhVariables = GhVariables
{ name :: Text { name :: Text
, owner :: Text , owner :: Text
, prefix :: Maybe Text
} deriving (Eq, Show) } deriving (Eq, Show)
$(deriveJSON defaultOptions ''GhVariables) $(deriveJSON defaultOptions ''GhVariables)
@ -226,11 +246,14 @@ latestGitHub PackageOwner{..} pattern' = do
ghToken' <- SlackBuilderT $ asks ghToken ghToken' <- SlackBuilderT $ asks ghToken
ghResponse <- runReq defaultHttpConfig $ ghResponse <- runReq defaultHttpConfig $
let uri = https "api.github.com" /: "graphql" let uri = https "api.github.com" /: "graphql"
prefix = Text.takeWhile isAlpha
$ Text.filter (liftA2 (&&) (/= ')') (/= '(')) pattern'
query = GhQuery query = GhQuery
{ query = githubQuery { query = githubQuery
, variables = GhVariables , variables = GhVariables
{ owner = owner { owner = owner
, name = name , name = name
, prefix = if Text.null prefix then Nothing else Just $ prefix <> "*"
} }
} }
authorizationHeader = header "authorization" authorizationHeader = header "authorization"
@ -242,15 +265,16 @@ latestGitHub PackageOwner{..} pattern' = do
$ refs $ refs
$ (getField @"repository" :: GhData -> GhRepository) $ (getField @"repository" :: GhData -> GhRepository)
$ responseBody ghResponse $ responseBody ghResponse
refs' = Vector.reverse refs' = Vector.catMaybes
$ Vector.catMaybes
$ match pattern' . getField @"name" <$> ghNodes $ match pattern' . getField @"name" <$> ghNodes
pure $ refs' !? 0 pure $ refs' !? 0
where where
githubQuery = githubQuery =
"query ($name: String!, $owner: String!) {\n\ "query ($name: String!, $owner: String!, $prefix: String) {\n\
\ repository(name: $name, owner: $owner) {\n\ \ repository(name: $name, owner: $owner) {\n\
\ refs(last: 10, refPrefix: \"refs/tags/\", orderBy: { field: TAG_COMMIT_DATE, direction: ASC }) {\n\ \ refs(first: 10, query: $prefix, refPrefix: \"refs/tags/\", orderBy: {\n\
\ field: TAG_COMMIT_DATE, direction: DESC\n\
\ }) {\n\
\ nodes {\n\ \ nodes {\n\
\ id,\n\ \ id,\n\
\ name\n\ \ name\n\