Reduce number of fetched tags by using a prefix

1 files changed, 30 insertions, 6 deletions

diff --git a/lib/SlackBuilder/LatestVersionCheck.hs b/lib/SlackBuilder/LatestVersionCheck.hs
index 82142e6..ad8d6b8 100644
--- a/lib/SlackBuilder/LatestVersionCheck.hs
+++ b/lib/SlackBuilder/LatestVersionCheck.hs
@@ -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\