diff options
| author | Eugen Wissner <belka@caraus.de> | 2024-03-19 11:34:19 +0100 |
|---|---|---|
| committer | Eugen Wissner <belka@caraus.de> | 2024-03-19 11:34:19 +0100 |
| commit | bc3ba48d851f4f46f0ab33547efa39fa1fb0414a (patch) | |
| tree | 530c32bea8c2034da4506c461673a6b6205423c9 /src | |
| parent | 3d81917627188cdbd8809729ecde7e20e21a1a43 (diff) | |
| download | slackbuilder-bc3ba48d851f4f46f0ab33547efa39fa1fb0414a.tar.gz | |
Recognize + in sematnic tags
Diffstat (limited to 'src')
| -rw-r--r-- | src/Main.hs | 243 | ||||
| -rw-r--r-- | src/SlackBuilder/LatestVersionCheck.hs | 192 | ||||
| -rw-r--r-- | src/SlackBuilder/Update.hs | 262 |
3 files changed, 269 insertions, 428 deletions
diff --git a/src/Main.hs b/src/Main.hs index fb3a814..b51d4cd 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -7,66 +7,28 @@ module Main ) where import Data.Char (isNumber) -import Control.Applicative (Applicative(liftA2)) +import Control.Applicative (Applicative(..)) import Data.List.NonEmpty (NonEmpty(..)) -import qualified Data.List.NonEmpty as NonEmpty import Control.Monad.Catch (MonadThrow(..)) import Control.Monad.IO.Class (MonadIO(..)) -import Data.Maybe (fromJust, fromMaybe) import qualified Data.Map as Map import Options.Applicative (execParser) import SlackBuilder.CommandLine import SlackBuilder.Config import SlackBuilder.Trans import SlackBuilder.LatestVersionCheck +import SlackBuilder.Update import qualified Toml -import qualified Data.ByteString as ByteString import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Text.IO as Text.IO -import Control.Monad.Trans.Reader (ReaderT(..), asks) -import SlackBuilder.Download -import SlackBuilder.Package (PackageDescription(..), PackageUpdateData(..)) +import Control.Monad.Trans.Reader (ReaderT(..)) +import SlackBuilder.Package (PackageDescription(..)) import qualified SlackBuilder.Package as Package -import Text.URI (URI(..), mkURI) import Text.URI.QQ (uri) -import Data.Foldable (Foldable(..), for_, find) -import qualified Text.URI as URI -import System.FilePath - ( (</>) - , (<.>) - , dropExtension - , takeBaseName - , splitFileName - , takeDirectory - , takeFileName - , dropTrailingPathSeparator - ) -import SlackBuilder.Info -import Text.Megaparsec (parse, errorBundlePretty) +import Data.Foldable (for_, find) import GHC.Records (HasField(..)) -import System.Process - ( CmdSpec(..) - , CreateProcess(..) - , StdStream(..) - , withCreateProcess - , waitForProcess - ) -import System.Console.ANSI - ( setSGR - , SGR(..) - , ColorIntensity(..) - , Color(..) - , ConsoleLayer(..) - ) -import System.Directory (listDirectory, doesDirectoryExist, withCurrentDirectory, removeDirectoryRecursive) -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 +import System.Process (CmdSpec(..)) autoUpdatable :: [PackageDescription] autoUpdatable = @@ -180,7 +142,7 @@ autoUpdatable = : Package.VersionPlaceholder : [Package.StaticPlaceholder ".tar.gz"] in Package.Updater - { detectLatest = latestGitHub ghArguments $ Text.stripPrefix "v" + { detectLatest = latestGitHub ghArguments stableTagTransform , getVersion = reuploadWithTemplate template [] , is64 = False } @@ -314,197 +276,6 @@ check = for_ autoUpdatable go >>= mapM_ checkUpdateAvailability >> liftIO (putStrLn "") -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 main :: IO () main = do 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 |
