From a25655c2b24535eb1c8bfce61159d9b37200074f Mon Sep 17 00:00:00 2001 From: Eugen Wissner Date: Mon, 1 Jan 2024 19:44:45 +0100 Subject: Move latest version checker to a separate module --- src/Main.hs | 31 +++--- src/SlackBuilder/CommandLine.hs | 22 +--- src/SlackBuilder/LatestVersionCheck.hs | 187 +++++++++++++++++++++++++++++++++ src/SlackBuilder/Updater.hs | 162 ---------------------------- 4 files changed, 202 insertions(+), 200 deletions(-) create mode 100644 src/SlackBuilder/LatestVersionCheck.hs delete mode 100644 src/SlackBuilder/Updater.hs (limited to 'src') diff --git a/src/Main.hs b/src/Main.hs index 1d7e6d9..e59cae7 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -18,7 +18,7 @@ import Options.Applicative (execParser) import SlackBuilder.CommandLine import SlackBuilder.Config import SlackBuilder.Trans -import SlackBuilder.Updater +import SlackBuilder.LatestVersionCheck import qualified Toml import qualified Data.ByteString as ByteString import Data.Text (Text) @@ -59,8 +59,8 @@ autoUpdatable :: [Package] autoUpdatable = [ Package { latest = - let ghArguments = GhArguments{ owner = "universal-ctags", name = "ctags", transform = Nothing} - latest' = latestGitHub ghArguments pure + let ghArguments = PackageOwner{ owner = "universal-ctags", name = "ctags" } + latest' = latestGitHub ghArguments stableTagTransform templateTail = [ Package.VersionPlaceholder , Package.StaticPlaceholder "/ctags-" @@ -77,7 +77,7 @@ autoUpdatable = } , Package { latest = - let packagistArguments = PackagistArguments{ vendor = "composer", name = "composer" } + let packagistArguments = PackageOwner{ owner = "composer", name = "composer" } latest' = latestPackagist packagistArguments template = Package.DownloadTemplate $ Package.StaticPlaceholder "https://getcomposer.org/download/" @@ -89,10 +89,9 @@ autoUpdatable = } , Package { latest = - let ghArguments = GhArguments + let ghArguments = PackageOwner { owner = "jitsi" , name = "jitsi-meet-electron" - , transform = Nothing } latest' = latestGitHub ghArguments $ Text.stripPrefix "v" template = Package.DownloadTemplate @@ -106,10 +105,9 @@ autoUpdatable = } , Package { latest = - let ghArguments = GhArguments + let ghArguments = PackageOwner { owner = "php" , name = "php-src" - , transform = Nothing } checkVersion x | not $ Text.isInfixOf "RC" x @@ -127,12 +125,11 @@ autoUpdatable = } , Package { latest = - let ghArguments = GhArguments + let ghArguments = PackageOwner { owner = "kovidgoyal" , name = "kitty" - , transform = Nothing } - latest' = latestGitHub ghArguments $ Text.stripPrefix "v" + latest' = latestGitHub ghArguments stableTagTransform templateTail = [ Package.StaticPlaceholder "/kitty-" , Package.VersionPlaceholder @@ -149,10 +146,9 @@ autoUpdatable = } , Package { latest = - let ghArguments = GhArguments + let ghArguments = PackageOwner { owner = "rdiff-backup" , name = "rdiff-backup" - , transform = Nothing } latest' = latestGitHub ghArguments $ Text.stripPrefix "v" template = Package.DownloadTemplate @@ -187,10 +183,9 @@ autoUpdatable = } , Package { latest = - let ghArguments = GhArguments + let ghArguments = PackageOwner { owner = "librsync" , name = "librsync" - , transform = Nothing } latest' = latestGitHub ghArguments $ Text.stripPrefix "v" template = Package.DownloadTemplate @@ -236,9 +231,9 @@ autoUpdatable = , category = "development" , name = "d-tools" , downloaders = - let dubArguments = GhArguments{ owner = "dlang", name = "dub", transform = Nothing} - dscannerArguments = GhArguments{ owner = "dlang-community", name = "D-Scanner", transform = Nothing } - dcdArguments = GhArguments{ owner = "dlang-community", name = "DCD", transform = Nothing } + let dubArguments = PackageOwner{ owner = "dlang", name = "dub" } + dscannerArguments = PackageOwner{ owner = "dlang-community", name = "D-Scanner" } + dcdArguments = PackageOwner{ owner = "dlang-community", name = "DCD" } latestDub = latestGitHub dubArguments pure latestDscanner = latestGitHub dscannerArguments pure latestDcd = latestGitHub dcdArguments pure diff --git a/src/SlackBuilder/CommandLine.hs b/src/SlackBuilder/CommandLine.hs index bbd7bad..7639327 100644 --- a/src/SlackBuilder/CommandLine.hs +++ b/src/SlackBuilder/CommandLine.hs @@ -2,11 +2,9 @@ v. 2.0. If a copy of the MPL was not distributed with this file, You can obtain one at https://mozilla.org/MPL/2.0/. -} +-- | Command line parser. module SlackBuilder.CommandLine - ( GhArguments(..) - , SlackBuilderCommand(..) - , PackagistArguments(..) - , TextArguments(..) + ( SlackBuilderCommand(..) , slackBuilderParser ) where @@ -29,22 +27,6 @@ data SlackBuilderCommand | CheckCommand | Up2DateCommand (Maybe Text) -data PackagistArguments = PackagistArguments - { vendor :: Text - , name :: Text - } deriving (Eq, Show) - -data GhArguments = GhArguments - { owner :: Text - , name :: Text - , transform :: Maybe Text - } deriving (Eq, Show) - -data TextArguments = TextArguments - { versionPicker :: Text -> Text - , textURL :: Text - } - slackBuilderParser :: ParserInfo SlackBuilderCommand slackBuilderParser = info slackBuilderCommand fullDesc diff --git a/src/SlackBuilder/LatestVersionCheck.hs b/src/SlackBuilder/LatestVersionCheck.hs new file mode 100644 index 0000000..a66d2c7 --- /dev/null +++ b/src/SlackBuilder/LatestVersionCheck.hs @@ -0,0 +1,187 @@ +{- This Source Code Form is subject to the terms of the Mozilla Public License, + v. 2.0. If a copy of the MPL was not distributed with this file, You can + obtain one at https://mozilla.org/MPL/2.0/. -} + +-- | This module contains implementations to check the latest version of a +-- package hosted by a specific service. +module SlackBuilder.LatestVersionCheck + ( PackageOwner(..) + , TextArguments(..) + , latestGitHub + , latestPackagist + , latestText + , stableTagTransform + ) where + +import SlackBuilder.Config +import qualified Data.Aeson as Aeson +import Data.Aeson ((.:)) +import Data.Aeson.TH (defaultOptions, deriveJSON) +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HashMap +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text.Encoding +import Data.Vector (Vector, (!?)) +import qualified Data.Vector as Vector +import Network.HTTP.Req + ( header + , runReq + , defaultHttpConfig + , req + , GET(..) + , https + , jsonResponse + , NoReqBody(..) + , (/:) + , responseBody + , useHttpsURI + , bsResponse + , POST(..) + , ReqBodyJson(..) + ) +import Text.URI (mkURI) +import SlackBuilder.Trans +import qualified Data.Aeson.KeyMap as KeyMap +import GHC.Records (HasField(..)) +import Control.Monad.Trans.Reader (asks) +import Control.Monad.IO.Class (MonadIO(..)) + +data PackageOwner = PackageOwner + { owner :: Text + , name :: Text + } deriving (Eq, Show) + +-- | Removes the leading "v" from the version string and returns the result if +-- it looks like a version. +stableTagTransform :: Text -> Maybe Text +stableTagTransform = Text.stripPrefix "v" + +-- * Packagist + +newtype PackagistPackage = PackagistPackage + { version :: Text + } deriving (Eq, Show) + +$(deriveJSON defaultOptions ''PackagistPackage) + +newtype PackagistResponse = PackagistResponse + { packages :: HashMap Text (Vector PackagistPackage) + } deriving (Eq, Show) + +$(deriveJSON defaultOptions ''PackagistResponse) + +latestPackagist :: PackageOwner -> SlackBuilderT (Maybe Text) +latestPackagist PackageOwner{..} = do + packagistResponse <- runReq defaultHttpConfig $ + let uri = https "repo.packagist.org" /: "p2" + /: owner + /: name <> ".json" + in req GET uri NoReqBody jsonResponse mempty + let packagistPackages = packages $ responseBody packagistResponse + fullName = Text.intercalate "/" [owner, name] + + pure $ HashMap.lookup fullName packagistPackages + >>= fmap (version . fst) . Vector.uncons + +-- * Remote text file + +data TextArguments = TextArguments + { versionPicker :: Text -> Text + , textURL :: Text + } + +latestText :: TextArguments -> SlackBuilderT (Maybe Text) +latestText TextArguments{..} = do + uri <- liftIO $ useHttpsURI <$> mkURI textURL + packagistResponse <- traverse (runReq defaultHttpConfig . go . fst) uri + + pure $ versionPicker . Text.Encoding.decodeUtf8 . responseBody + <$> packagistResponse + where + go uri = req GET uri NoReqBody bsResponse mempty + +-- * GitHub + +newtype GhRefNode = GhRefNode + { name :: Text + } deriving (Eq, Show) + +$(deriveJSON defaultOptions ''GhRefNode) + +newtype GhRef = GhRef + { nodes :: Vector GhRefNode + } deriving (Eq, Show) + +$(deriveJSON defaultOptions ''GhRef) + +newtype GhRepository = GhRepository + { refs :: GhRef + } deriving (Eq, Show) + +$(deriveJSON defaultOptions ''GhRepository) + +newtype GhData = GhData + { repository :: GhRepository + } deriving (Eq, Show) + +instance Aeson.FromJSON GhData where + parseJSON (Aeson.Object keyMap) + | Just data' <- KeyMap.lookup "data" keyMap = + GhData <$> Aeson.withObject "GhData" (.: "repository") data' + parseJSON _ = fail "data key not found in the response" + +data GhVariables = GhVariables + { name :: Text + , owner :: Text + } deriving (Eq, Show) + +$(deriveJSON defaultOptions ''GhVariables) + +data GhQuery = GhQuery + { query :: Text + , variables :: GhVariables + } deriving (Eq, Show) + +$(deriveJSON defaultOptions ''GhQuery) + +latestGitHub + :: PackageOwner + -> (Text -> Maybe Text) + -> SlackBuilderT (Maybe Text) +latestGitHub PackageOwner{..} versionTransform = do + ghToken' <- SlackBuilderT $ asks ghToken + ghResponse <- runReq defaultHttpConfig $ + let uri = https "api.github.com" /: "graphql" + query = GhQuery + { query = githubQuery + , variables = GhVariables + { owner = owner + , name = name + } + } + authorizationHeader = header "authorization" + $ Text.Encoding.encodeUtf8 + $ "Bearer " <> ghToken' + in req POST uri (ReqBodyJson query) jsonResponse + $ authorizationHeader <> header "User-Agent" "SlackBuilder" + let ghNodes = nodes + $ refs + $ (getField @"repository" :: GhData -> GhRepository) + $ responseBody ghResponse + refs' = Vector.reverse + $ Vector.catMaybes + $ versionTransform . getField @"name" <$> ghNodes + pure $ refs' !? 0 + where + githubQuery = + "query ($name: String!, $owner: String!) {\n\ + \ repository(name: $name, owner: $owner) {\n\ + \ refs(last: 10, refPrefix: \"refs/tags/\", orderBy: { field: TAG_COMMIT_DATE, direction: ASC }) {\n\ + \ nodes {\n\ + \ id,\n\ + \ name\n\ + \ }\n\ + \ }\n\ + \ }\n\ + \}" diff --git a/src/SlackBuilder/Updater.hs b/src/SlackBuilder/Updater.hs deleted file mode 100644 index 0b87d90..0000000 --- a/src/SlackBuilder/Updater.hs +++ /dev/null @@ -1,162 +0,0 @@ -{- This Source Code Form is subject to the terms of the Mozilla Public License, - v. 2.0. If a copy of the MPL was not distributed with this file, You can - obtain one at https://mozilla.org/MPL/2.0/. -} - -module SlackBuilder.Updater - ( latestGitHub - , latestPackagist - , latestText - ) where - -import SlackBuilder.Config -import qualified Data.Aeson as Aeson -import Data.Aeson ((.:)) -import Data.Aeson.TH (defaultOptions, deriveJSON) -import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as HashMap -import Data.Text (Text) -import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text.Encoding -import Data.Vector (Vector, (!?)) -import qualified Data.Vector as Vector -import Network.HTTP.Req - ( header - , runReq - , defaultHttpConfig - , req - , GET(..) - , https - , jsonResponse - , NoReqBody(..) - , (/:) - , responseBody - , useHttpsURI - , bsResponse - , POST(..) - , ReqBodyJson(..) - ) -import Text.URI (mkURI) -import SlackBuilder.CommandLine -import SlackBuilder.Trans -import qualified Data.Aeson.KeyMap as KeyMap -import GHC.Records (HasField(..)) -import Control.Monad.Trans.Reader (asks) -import Control.Monad.IO.Class (MonadIO(..)) - -newtype PackagistPackage = PackagistPackage - { version :: Text - } deriving (Eq, Show) - -$(deriveJSON defaultOptions ''PackagistPackage) - -newtype PackagistResponse = PackagistResponse - { packages :: HashMap Text (Vector PackagistPackage) - } deriving (Eq, Show) - -$(deriveJSON defaultOptions ''PackagistResponse) - -newtype GhRefNode = GhRefNode - { name :: Text - } deriving (Eq, Show) - -$(deriveJSON defaultOptions ''GhRefNode) - -newtype GhRef = GhRef - { nodes :: Vector GhRefNode - } deriving (Eq, Show) - -$(deriveJSON defaultOptions ''GhRef) - -newtype GhRepository = GhRepository - { refs :: GhRef - } deriving (Eq, Show) - -$(deriveJSON defaultOptions ''GhRepository) - -newtype GhData = GhData - { repository :: GhRepository - } deriving (Eq, Show) - -instance Aeson.FromJSON GhData where - parseJSON (Aeson.Object keyMap) - | Just data' <- KeyMap.lookup "data" keyMap = - GhData <$> Aeson.withObject "GhData" (.: "repository") data' - parseJSON _ = fail "data key not found in the response" - -data GhVariables = GhVariables - { name :: Text - , owner :: Text - } deriving (Eq, Show) - -$(deriveJSON defaultOptions ''GhVariables) - -data GhQuery = GhQuery - { query :: Text - , variables :: GhVariables - } deriving (Eq, Show) - -$(deriveJSON defaultOptions ''GhQuery) - -latestPackagist :: PackagistArguments -> SlackBuilderT (Maybe Text) -latestPackagist PackagistArguments{..} = do - packagistResponse <- runReq defaultHttpConfig $ - let uri = https "repo.packagist.org" /: "p2" - /: vendor - /: name <> ".json" - in req GET uri NoReqBody jsonResponse mempty - let packagistPackages = packages $ responseBody packagistResponse - fullName = Text.intercalate "/" [vendor, name] - - pure $ HashMap.lookup fullName packagistPackages - >>= fmap (version . fst) . Vector.uncons - -latestText :: TextArguments -> SlackBuilderT (Maybe Text) -latestText TextArguments{..} = do - uri <- liftIO $ useHttpsURI <$> mkURI textURL - packagistResponse <- traverse (runReq defaultHttpConfig . go . fst) uri - - pure $ versionPicker . Text.Encoding.decodeUtf8 . responseBody - <$> packagistResponse - where - go uri = req GET uri NoReqBody bsResponse mempty - -latestGitHub - :: GhArguments - -> (Text -> Maybe Text) - -> SlackBuilderT (Maybe Text) -latestGitHub GhArguments{..} versionTransform = do - ghToken' <- SlackBuilderT $ asks ghToken - ghResponse <- runReq defaultHttpConfig $ - let uri = https "api.github.com" /: "graphql" - query = GhQuery - { query = githubQuery - , variables = GhVariables - { owner = owner - , name = name - } - } - authorizationHeader = header "authorization" - $ Text.Encoding.encodeUtf8 - $ "Bearer " <> ghToken' - in req POST uri (ReqBodyJson query) jsonResponse - $ authorizationHeader <> header "User-Agent" "SlackBuilder" - let ghNodes = nodes - $ refs - $ (getField @"repository" :: GhData -> GhRepository) - $ responseBody ghResponse - refs' = Vector.reverse - $ Vector.catMaybes - $ versionTransform . getField @"name" <$> ghNodes - pure $ refs' !? 0 - where - githubQuery = - "query ($name: String!, $owner: String!) {\n\ - \ repository(name: $name, owner: $owner) {\n\ - \ refs(last: 10, refPrefix: \"refs/tags/\", orderBy: { field: TAG_COMMIT_DATE, direction: ASC }) {\n\ - \ nodes {\n\ - \ id,\n\ - \ name\n\ - \ }\n\ - \ }\n\ - \ }\n\ - \}" -- cgit v1.2.3