aboutsummaryrefslogtreecommitdiff
path: root/src/SlackBuilder
diff options
context:
space:
mode:
Diffstat (limited to 'src/SlackBuilder')
-rw-r--r--src/SlackBuilder/LatestVersionCheck.hs192
-rw-r--r--src/SlackBuilder/Update.hs262
2 files changed, 262 insertions, 192 deletions
diff --git a/src/SlackBuilder/LatestVersionCheck.hs b/src/SlackBuilder/LatestVersionCheck.hs
deleted file mode 100644
index 233ea3c..0000000
--- a/src/SlackBuilder/LatestVersionCheck.hs
+++ /dev/null
@@ -1,192 +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/. -}
-
--- | 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(..))
-import Control.Monad ((>=>))
-
-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" >=> checkForStable
- where
- checkForStable tag
- | '-' `Text.elem` tag = Nothing
- | otherwise = Just tag
-
--- * 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/Update.hs b/src/SlackBuilder/Update.hs
new file mode 100644
index 0000000..008b63d
--- /dev/null
+++ b/src/SlackBuilder/Update.hs
@@ -0,0 +1,262 @@
+{- 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.Update
+ ( checkUpdateAvailability
+ , cloneFromGit
+ , downloadWithTemplate
+ , getAndLogLatest
+ , reuploadWithTemplate
+ , updatePackageIfRequired
+ ) where
+
+import Control.Applicative (Applicative(..))
+import Control.Monad.IO.Class (MonadIO(..))
+import Control.Monad.Trans.Reader (asks)
+import qualified Data.ByteString as ByteString
+import Data.Foldable (Foldable(..), find)
+import qualified Data.List.NonEmpty as NonEmpty
+import Data.Maybe (fromJust, fromMaybe)
+import Data.Text (Text)
+import qualified Data.Text as Text
+import qualified Data.Text.IO as Text.IO
+import GHC.Records (HasField(..))
+import System.FilePath
+ ( (</>)
+ , (<.>)
+ , dropExtension
+ , takeBaseName
+ , splitFileName
+ , takeDirectory
+ , takeFileName
+ , dropTrailingPathSeparator
+ )
+import System.Process
+ ( CmdSpec(..)
+ , CreateProcess(..)
+ , StdStream(..)
+ , withCreateProcess
+ , waitForProcess
+ )
+import SlackBuilder.Config
+import SlackBuilder.Download
+import SlackBuilder.Info
+import SlackBuilder.Package (PackageDescription(..), PackageUpdateData(..))
+import qualified SlackBuilder.Package as Package
+import SlackBuilder.Trans
+import Text.Megaparsec (parse, errorBundlePretty)
+import Text.URI (URI(..), mkURI)
+import qualified Text.URI as URI
+import System.Directory
+ ( listDirectory
+ , doesDirectoryExist
+ , withCurrentDirectory
+ , removeDirectoryRecursive
+ )
+import System.Console.ANSI
+ ( setSGR
+ , SGR(..)
+ , ColorIntensity(..)
+ , Color(..)
+ , ConsoleLayer(..)
+ )
+import Control.Monad (filterM, void)
+import Data.List (isPrefixOf, isSuffixOf, partition)
+import Conduit (runConduitRes, (.|), yield)
+import Data.Functor ((<&>))
+import Data.Bifunctor (Bifunctor(..))
+import Data.Conduit.Tar (tarFilePath)
+import qualified Data.Conduit.Lzma as Lzma
+
+getAndLogLatest :: PackageDescription -> SlackBuilderT (Maybe PackageUpdateData)
+getAndLogLatest description = do
+ let PackageDescription{ latest = Package.Updater{ detectLatest }, name } = description
+ liftIO (putStrLn $ Text.unpack name <> ": Retreiving the latest version.")
+ detectedVersion <- detectLatest
+ category <- fmap Text.pack
+ <$> findCategory (Text.unpack name)
+ pure $ PackageUpdateData description
+ <$> category
+ <*> detectedVersion
+
+checkUpdateAvailability :: PackageUpdateData -> SlackBuilderT (Maybe PackageInfo)
+checkUpdateAvailability PackageUpdateData{..} = do
+ let name' = Text.unpack $ getField @"name" description
+ packagePath = Text.unpack category </> name' </> (name' <.> "info")
+ repository' <- SlackBuilderT $ asks repository
+ infoContents <- liftIO $ ByteString.readFile $ repository' </> packagePath
+
+ case parse parseInfoFile packagePath infoContents of
+ Right parsedInfoFile
+ | version == getField @"version" parsedInfoFile ->
+ liftIO $ do
+ setSGR [SetColor Foreground Dull Green]
+ Text.IO.putStrLn
+ $ getField @"name" description <> " is up to date (Version " <> version <> ")."
+ setSGR [Reset]
+ pure Nothing
+ | otherwise ->
+ liftIO $ do
+ setSGR [SetColor Foreground Dull Yellow]
+ Text.IO.putStr
+ $ "A new version of "
+ <> getField @"name" description
+ <> " " <> getField @"version" parsedInfoFile
+ <> " is available (" <> version <> ")."
+ setSGR [Reset]
+ putStrLn ""
+ pure $ Just parsedInfoFile
+ Left errorBundle -> liftIO (putStr $ errorBundlePretty errorBundle)
+ >> pure Nothing
+
+updatePackageIfRequired :: PackageUpdateData -> SlackBuilderT ()
+updatePackageIfRequired updateData
+ = checkUpdateAvailability updateData
+ >>= mapM_ (updatePackage updateData)
+
+data DownloadUpdated = DownloadUpdated
+ { result :: Package.Download
+ , version :: Text
+ , is64 :: Bool
+ } deriving (Eq, Show)
+
+updateDownload :: Text -> Package.Updater -> SlackBuilderT DownloadUpdated
+updateDownload packagePath Package.Updater{..} = do
+ latestDownloadVersion <- fromJust <$> detectLatest
+ result <- getVersion packagePath latestDownloadVersion
+ pure $ DownloadUpdated
+ { result = result
+ , version = latestDownloadVersion
+ , is64 = is64
+ }
+
+cloneFromGit :: URI -> Text -> Text -> Text -> SlackBuilderT Package.Download
+cloneFromGit repo tagPrefix packagePath version = do
+ let downloadFileName = URI.unRText
+ $ NonEmpty.last $ snd $ fromJust $ URI.uriPath repo
+ relativeTarball = Text.unpack packagePath
+ </> (dropExtension (Text.unpack downloadFileName) <> "-" <> Text.unpack version)
+ (uri', checksum) <- cloneAndUpload (URI.render repo) relativeTarball tagPrefix
+ pure $ Package.Download
+ { md5sum = checksum
+ , download = uri'
+ }
+
+downloadWithTemplate :: Package.DownloadTemplate -> Text -> Text -> SlackBuilderT Package.Download
+downloadWithTemplate downloadTemplate packagePath version = do
+ repository' <- SlackBuilderT $ asks repository
+ uri' <- liftIO $ Package.renderDownloadWithVersion downloadTemplate version
+ checksum <- download uri' $ repository' </> Text.unpack packagePath
+ pure $ Package.Download uri' $ snd checksum
+
+reuploadWithTemplate :: Package.DownloadTemplate -> [CmdSpec] -> Text -> Text -> SlackBuilderT Package.Download
+reuploadWithTemplate downloadTemplate commands packagePath version = do
+ repository' <- SlackBuilderT $ asks repository
+ uri' <- liftIO $ Package.renderDownloadWithVersion downloadTemplate version
+ let downloadFileName = Text.unpack
+ $ URI.unRText
+ $ NonEmpty.last $ snd $ fromJust $ URI.uriPath uri'
+ packagePathRelativeToCurrent = repository' </> Text.unpack packagePath
+
+ (relativeTarball', checksum) <- case commands of
+ [] -> do
+ (downloadedFileName, checksum) <- download uri' packagePathRelativeToCurrent
+ pure (packagePathRelativeToCurrent </> downloadedFileName, checksum)
+ _ -> do
+ changedArchiveRootName <- extractRemote uri' packagePathRelativeToCurrent
+ let relativeTarball = packagePathRelativeToCurrent
+ </> fromMaybe downloadFileName changedArchiveRootName
+ prepareSource relativeTarball
+
+ download' <- handleReupload relativeTarball' downloadFileName
+ pure $ Package.Download download' checksum
+ where
+ name' = Text.pack $ takeBaseName $ Text.unpack packagePath
+ prepareSource tarballPath =
+ liftIO (traverse (defaultCreateProcess tarballPath) commands)
+ >> liftIO (tarCompress tarballPath)
+ <* liftIO (removeDirectoryRecursive tarballPath)
+ tarCompress tarballPath =
+ let archiveBaseFilename = takeFileName tarballPath
+ appendTarExtension = (<.> "tar.xz")
+ in fmap (appendTarExtension tarballPath,)
+ $ withCurrentDirectory (takeDirectory tarballPath)
+ $ runConduitRes $ yield archiveBaseFilename
+ .| void tarFilePath
+ .| Lzma.compress Nothing
+ .| sinkFileAndHash (appendTarExtension archiveBaseFilename)
+ handleReupload relativeTarball downloadFileName = do
+ downloadURL' <- SlackBuilderT $ asks downloadURL
+
+ liftIO $ putStrLn $ "Upload the source tarball " <> relativeTarball
+ uploadCommand relativeTarball ("/" <> name')
+ liftIO $ mkURI $ downloadURL' <> "/" <> name' <> "/" <> Text.pack downloadFileName
+ defaultCreateProcess cwd' cmdSpec
+ = flip withCreateProcess (const . const . const waitForProcess)
+ $ CreateProcess
+ { use_process_jobs = False
+ , std_out = Inherit
+ , std_in = NoStream
+ , std_err = Inherit
+ , new_session = False
+ , env = Nothing
+ , detach_console = False
+ , delegate_ctlc = False
+ , cwd = Just cwd'
+ , create_new_console = False
+ , create_group = False
+ , cmdspec = cmdSpec
+ , close_fds = True
+ , child_user = Nothing
+ , child_group = Nothing
+ }
+
+updatePackage :: PackageUpdateData -> PackageInfo -> SlackBuilderT ()
+updatePackage PackageUpdateData{..} info = do
+ let packagePath = category <> "/" <> getField @"name" description
+ latest' = getField @"latest" description
+
+ repository' <- SlackBuilderT $ asks repository
+ mainDownload <- (, getField @"is64" latest')
+ <$> getField @"getVersion" latest' packagePath version
+ moreDownloads <- traverse (updateDownload packagePath)
+ $ getField @"downloaders" description
+ let (downloads64, allDownloads) = partition snd
+ $ mainDownload
+ : (liftA2 (,) (getField @"result") (getField @"is64") <$> toList moreDownloads)
+ let infoFilePath = repository' </> Text.unpack packagePath
+ </> (Text.unpack (getField @"name" description) <.> "info")
+ package' = info
+ { version = version
+ , downloads = getField @"download" . fst <$> allDownloads
+ , checksums = getField @"md5sum" . fst <$> allDownloads
+ , downloadX64 = getField @"download" . fst <$> downloads64
+ , checksumX64 = getField @"md5sum" . fst <$> downloads64
+ }
+ liftIO $ Text.IO.writeFile infoFilePath $ generate package'
+ updateSlackBuildVersion packagePath version
+ $ getField @"version" <$> moreDownloads
+
+ commit packagePath version
+
+findCategory :: FilePath -> SlackBuilderT (Maybe FilePath)
+findCategory packageName = do
+ repository' <- SlackBuilderT $ asks repository
+ go repository' [] "" <&> fmap fst . find ((packageName ==) . snd)
+ where
+ go currentDirectory found accumulatedDirectory = do
+ let fullDirectory = currentDirectory </> accumulatedDirectory
+ contents <- liftIO $ listDirectory fullDirectory
+ case find (isSuffixOf ".info") contents of
+ Just _ ->
+ let result = first dropTrailingPathSeparator
+ $ splitFileName accumulatedDirectory
+ in pure $ result : found
+ Nothing ->
+ let accumulatedDirectories = (accumulatedDirectory </>)
+ <$> filter (not . isPrefixOf ".") contents
+ directoryFilter = liftIO . doesDirectoryExist
+ . (currentDirectory </>)
+ in filterM directoryFilter accumulatedDirectories
+ >>= traverse (go currentDirectory found) <&> concat
generated by cgit v1.2.3 (git 2.26.2) at 2026-06-30 15:41:52 +0000