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 Control.Monad.Trans.Reader (asks)
import Control.Monad.IO.Class (MonadIO(..))
import Control.Applicative (Applicative(liftA2))
import Data.Char (isAlpha)
data PackageOwner = PackageOwner
{ owner :: Text
@ -66,8 +68,25 @@ data MatchToken
| OneOfMatchToken [Char]
deriving (Eq, Show)
-- | Removes the leading "v" from the version string and returns the result if
-- it looks like a version.
-- | Matches a string (for example a version name or CVS tag) against a pattern.
-- 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 fullPattern input =
case Text.foldl' go (Just startState) input of
@ -207,6 +226,7 @@ instance Aeson.FromJSON GhData where
data GhVariables = GhVariables
{ name :: Text
, owner :: Text
, prefix :: Maybe Text
} deriving (Eq, Show)
$(deriveJSON defaultOptions ''GhVariables)
@ -226,11 +246,14 @@ latestGitHub PackageOwner{..} pattern' = do
ghToken' <- SlackBuilderT $ asks ghToken
ghResponse <- runReq defaultHttpConfig $
let uri = https "api.github.com" /: "graphql"
prefix = Text.takeWhile isAlpha
$ Text.filter (liftA2 (&&) (/= ')') (/= '(')) pattern'
query = GhQuery
{ query = githubQuery
, variables = GhVariables
{ owner = owner
, name = name
, prefix = if Text.null prefix then Nothing else Just $ prefix <> "*"
}
}
authorizationHeader = header "authorization"
@ -242,15 +265,16 @@ latestGitHub PackageOwner{..} pattern' = do
$ refs
$ (getField @"repository" :: GhData -> GhRepository)
$ responseBody ghResponse
refs' = Vector.reverse
$ Vector.catMaybes
refs' = Vector.catMaybes
$ match pattern' . getField @"name" <$> ghNodes
pure $ refs' !? 0
where
githubQuery =
"query ($name: String!, $owner: String!) {\n\
"query ($name: String!, $owner: String!, $prefix: String) {\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\
\ id,\n\
\ name\n\