diff options
Diffstat (limited to 'src/Main.hs')
| -rw-r--r-- | src/Main.hs | 421 |
1 files changed, 421 insertions, 0 deletions
diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 index 0000000..535b655 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,421 @@ +module Main + ( main + ) where + +import Data.Char (isNumber) +import Control.Applicative (Applicative(liftA2)) +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.List.NonEmpty as NonEmpty +import Control.Monad.IO.Class (MonadIO(..)) +import Data.Maybe (fromJust) +import qualified Data.Map as Map +import Options.Applicative (execParser) +import SlackBuilder.CommandLine +import SlackBuilder.Config +import SlackBuilder.Trans +import SlackBuilder.Updater +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 (Package(..)) +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, makeRelative, splitFileName) +import SlackBuilder.Info +import Text.Megaparsec (parse, errorBundlePretty) +import GHC.Records (HasField(..)) +import System.Process + ( CmdSpec(..) + , CreateProcess(..) + , StdStream(..) + , callProcess + , withCreateProcess + , waitForProcess + ) +import System.Console.ANSI + ( setSGR + , SGR(..) + , ColorIntensity(..) + , Color(..) + , ConsoleLayer(..) + ) +import System.Directory (listDirectory, doesDirectoryExist) +import Control.Monad (filterM) +import Data.List (isPrefixOf, isSuffixOf) + +autoUpdatable :: [Package] +autoUpdatable = + [ Package + { latest = + let ghArguments = GhArguments{ owner = "universal-ctags", name = "ctags", transform = Nothing} + latest' = latestGitHub ghArguments pure + templateTail = + [ Package.VersionPlaceholder + , Package.StaticPlaceholder "/ctags-" + , Package.VersionPlaceholder + , Package.StaticPlaceholder ".tar.gz" + ] + template = Package.DownloadTemplate + $ Package.StaticPlaceholder "https://github.com/universal-ctags/ctags/archive/" + :| templateTail + in Package.Updater latest' $ reuploadWithTemplate template [] + , category = "development" + , name = "universal-ctags" + , downloaders = mempty + } + , Package + { latest = + let packagistArguments = PackagistArguments{ vendor = "composer", name = "composer" } + latest' = latestPackagist packagistArguments + template = Package.DownloadTemplate + $ Package.StaticPlaceholder "https://getcomposer.org/download/" + :| [Package.VersionPlaceholder, Package.StaticPlaceholder "/composer.phar"] + in Package.Updater latest' $ downloadWithTemplate template + , category = "development" + , name = "composer" + , downloaders = mempty + } + , Package + { latest = + let ghArguments = GhArguments + { owner = "jitsi" + , name = "jitsi-meet-electron" + , transform = Nothing + } + latest' = latestGitHub ghArguments $ Text.stripPrefix "v" + template = Package.DownloadTemplate + $ Package.StaticPlaceholder "https://github.com/jitsi/jitsi-meet-electron/releases/download/v" + :| Package.VersionPlaceholder + : [Package.StaticPlaceholder "/jitsi-meet-x86_64.AppImage"] + in Package.Updater latest' $ downloadWithTemplate template + , category = "network" + , name = "jitsi-meet-desktop" + , downloaders = mempty + } + , Package + { latest = + let ghArguments = GhArguments + { owner = "php" + , name = "php-src" + , transform = Nothing + } + checkVersion x + | not $ Text.isInfixOf "RC" x + , Text.isPrefixOf "php-8.2." x = Text.stripPrefix "php-" x + | otherwise = Nothing + latest' = latestGitHub ghArguments checkVersion + template = Package.DownloadTemplate + $ Package.StaticPlaceholder "https://www.php.net/distributions/php-" + :| Package.VersionPlaceholder + : [Package.StaticPlaceholder ".tar.xz"] + in Package.Updater latest' $ downloadWithTemplate template + , category = "development" + , name = "php82" + , downloaders = mempty + } + , Package + { latest = + let ghArguments = GhArguments + { owner = "kovidgoyal" + , name = "kitty" + , transform = Nothing + } + latest' = latestGitHub ghArguments $ Text.stripPrefix "v" + templateTail = + [ Package.StaticPlaceholder "/kitty-" + , Package.VersionPlaceholder + , Package.StaticPlaceholder ".tar.xz" + ] + template = Package.DownloadTemplate + $ Package.StaticPlaceholder "https://github.com/kovidgoyal/kitty/releases/download/v" + :| Package.VersionPlaceholder + : templateTail + in Package.Updater latest' $ reuploadWithTemplate template [RawCommand "go" ["mod", "vendor"]] + , category = "system" + , name = "kitty" + , downloaders = mempty + } + , Package + { latest = + let ghArguments = GhArguments + { owner = "rdiff-backup" + , name = "rdiff-backup" + , transform = Nothing + } + latest' = latestGitHub ghArguments $ Text.stripPrefix "v" + template = Package.DownloadTemplate + $ Package.StaticPlaceholder "https://github.com/rdiff-backup/rdiff-backup/releases/download/v" + :| Package.VersionPlaceholder + : Package.StaticPlaceholder "/rdiff-backup-" + : Package.VersionPlaceholder + : [Package.StaticPlaceholder ".tar.gz"] + in Package.Updater latest' $ reuploadWithTemplate template [] + , category = "system" + , name = "rdiff-backup" + , downloaders = mempty + } + , Package + { latest = + let needle = "Linux—" + textArguments = TextArguments + { textURL = "https://help.webex.com/en-us/article/mqkve8/Webex-App-%7C-Release-notes" + , versionPicker = Text.takeWhile (liftA2 (||) (== '.') isNumber) + . Text.drop (Text.length needle) + . snd + . Text.breakOn needle + } + latest' = latestText textArguments + template = Package.DownloadTemplate $ pure + $ Package.StaticPlaceholder + "https://binaries.webex.com/WebexDesktop-Ubuntu-Official-Package/Webex.deb" + in Package.Updater latest' $ downloadWithTemplate template + , category = "network" + , name = "webex" + , downloaders = mempty + } + , Package + { latest = + let ghArguments = GhArguments + { owner = "librsync" + , name = "librsync" + , transform = Nothing + } + latest' = latestGitHub ghArguments $ Text.stripPrefix "v" + template = Package.DownloadTemplate + $ Package.StaticPlaceholder "https://github.com/librsync/librsync/archive/v" + :| Package.VersionPlaceholder + : Package.StaticPlaceholder "/librsync-" + : Package.VersionPlaceholder + : [Package.StaticPlaceholder ".tar.gz"] + in Package.Updater latest' $ reuploadWithTemplate template [] + , category = "libraries" + , name = "librsync" + , downloaders = mempty + } + , Package + { latest = + let textArguments = TextArguments + { textURL = "https://downloads.dlang.org/releases/LATEST" + , versionPicker = Text.strip + } + latest' = latestText textArguments + template = Package.DownloadTemplate + $ Package.StaticPlaceholder "https://downloads.dlang.org/releases/2.x/" + :| Package.VersionPlaceholder + : Package.StaticPlaceholder "/dmd." + : Package.VersionPlaceholder + : [Package.StaticPlaceholder ".linux.tar.xz"] + in Package.Updater latest' $ downloadWithTemplate template + , category = "development" + , name = "dmd" + , downloaders = mempty + } + , Package + { latest = + let textArguments = TextArguments + { textURL = "https://downloads.dlang.org/releases/LATEST" + , versionPicker = Text.strip + } + latest' = latestText textArguments + template = Package.DownloadTemplate + $ Package.StaticPlaceholder "https://codeload.github.com/dlang/tools/tar.gz/v" + :| [Package.VersionPlaceholder] + in Package.Updater latest' $ reuploadWithTemplate template [] + , 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 } + latestDub = latestGitHub dubArguments pure + latestDscanner = latestGitHub dscannerArguments pure + latestDcd = latestGitHub dcdArguments pure + dubTemplate = Package.DownloadTemplate + $ Package.StaticPlaceholder "https://codeload.github.com/dlang/dub/tar.gz/v" + :| [Package.VersionPlaceholder] + dscannerURI = [uri|https://github.com/dlang-community/D-Scanner.git|] + dcdURI = [uri|https://github.com/dlang-community/DCD.git|] + in Map.fromList + [ ("DUB", Package.Updater latestDub $ downloadWithTemplate dubTemplate) + , ("DSCANNER", Package.Updater latestDscanner $ cloneFromGit dscannerURI "v") + , ("DCD", Package.Updater latestDcd $ cloneFromGit dcdURI "v") + ] + } + ] + +up2Date :: SlackBuilderT () +up2Date = for_ autoUpdatable go + where + go package = getAndLogLatest package + >>= mapM_ (updatePackageIfRequired package) + >> liftIO (putStrLn "") + getAndLogLatest Package{ latest = Package.Updater{ detectLatest }, name } + = liftIO (putStrLn $ Text.unpack name <> ": Retreiving the latest version.") + >> detectLatest + +updatePackageIfRequired :: Package -> Text -> SlackBuilderT () +updatePackageIfRequired package@Package{..} version = do + let packagePath = Text.unpack category </> Text.unpack name </> (Text.unpack 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 + $ name <> " is up to date (Version " <> version <> ")." + setSGR [Reset] + | otherwise -> do + liftIO $ do + setSGR [SetColor Foreground Dull Yellow] + Text.IO.putStrLn + $ "A new version of " + <> name <> " " <> getField @"version" parsedInfoFile + <> " is available (" <> version <> ")." + setSGR [Reset] + updatePackage package parsedInfoFile version + Left errorBundle -> liftIO $ putStr $ errorBundlePretty errorBundle + +updateDownload :: Package -> Package.Updater -> SlackBuilderT (Package.Download, Text) +updateDownload Package{..} Package.Updater{..} = do + latestDownloadVersion <- fromJust <$> detectLatest + result <- getVersion (Text.pack $ Text.unpack category </> Text.unpack name) latestDownloadVersion + pure (result, latestDownloadVersion) + +cloneFromGit :: URI -> Text -> Text -> Text -> SlackBuilderT Package.Download +cloneFromGit repo tagPrefix packagePath version = do + repository' <- SlackBuilderT $ asks repository + let downloadFileName = URI.unRText + $ NonEmpty.last $ snd $ fromJust $ URI.uriPath repo + relativeTarball = Text.unpack packagePath + </> (dropExtension (Text.unpack downloadFileName) <> "-" <> Text.unpack version) + tarball = repository' </> relativeTarball + name' = Text.pack (takeBaseName $ Text.unpack packagePath) + checksum <- clone (URI.render repo) (Text.pack tarball) tagPrefix + uploadCommand (Text.pack relativeTarball) ("/" <> name') + (flip . flip Package.Download) (fromJust checksum) False + <$> liftIO (mkURI $ "https://download.dlackware.com/hosted-sources/" <> name' <> "/" <> downloadFileName) + +downloadWithTemplate :: Package.DownloadTemplate -> Text -> Text -> SlackBuilderT Package.Download +downloadWithTemplate downloadTemplate packagePath version = do + repository' <- SlackBuilderT $ asks repository + uri' <- liftIO $ Package.renderDownloadWithVersion downloadTemplate version + let downloadFileName = URI.unRText + $ NonEmpty.last $ snd $ fromJust $ URI.uriPath uri' + relativeTarball = packagePath <> "/" <> downloadFileName + tarball = repository' </> Text.unpack relativeTarball + checksum <- fromJust <$> download uri' tarball + pure $ Package.Download uri' checksum False + +reuploadWithTemplate :: Package.DownloadTemplate -> [CmdSpec] -> Text -> Text -> SlackBuilderT Package.Download +reuploadWithTemplate downloadTemplate commands packagePath version = do + Package.Download{ download = uri', md5sum = checksum } <- downloadWithTemplate downloadTemplate packagePath version + let downloadFileName = URI.unRText + $ NonEmpty.last $ snd $ fromJust $ URI.uriPath uri' + relativeTarball = packagePath <> "/" <> downloadFileName + download' <- handleReupload relativeTarball downloadFileName + + pure $ Package.Download download' checksum False + where + name' = Text.pack $ takeBaseName $ Text.unpack packagePath + handleReupload relativeTarball downloadFileName = do + repository' <- SlackBuilderT $ asks repository + case commands of + [] -> uploadTarball relativeTarball downloadFileName + _ -> + let tarballPath = repository' </> Text.unpack relativeTarball + packedDirectory = takeBaseName $ dropExtension tarballPath + in liftIO (callProcess "tar" ["xvf", tarballPath]) + >> liftIO (traverse (defaultCreateProcess packedDirectory) commands) + >> liftIO (callProcess "tar" ["Jcvf", tarballPath, packedDirectory]) + >> uploadTarball relativeTarball downloadFileName + uploadTarball relativeTarball downloadFileName + = liftIO (putStrLn $ "Upload the source tarball " <> Text.unpack relativeTarball) + >> uploadCommand relativeTarball ("/" <> name') + >> liftIO (mkURI $ "https://download.dlackware.com/hosted-sources/" <> name' <> "/" <> 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 + } + +renderAndDownload :: Package -> Text -> SlackBuilderT Package.Download +renderAndDownload Package{..} version = do + let packagePath = category <> "/" <> name + Package.Updater _ getVersion = latest + + getVersion packagePath version + +updatePackage :: Package -> PackageInfo -> Text -> SlackBuilderT () +updatePackage package@Package{..} info version = do + let packagePath = category <> "/" <> name + + repository' <- SlackBuilderT $ asks repository + mainDownload <- renderAndDownload package version + moreDownloads <- traverse (updateDownload package) downloaders + let allDownloads = mainDownload : toList (fst <$> moreDownloads) + let infoFilePath = repository' </> Text.unpack packagePath + </> (Text.unpack name <.> "info") + package' = info + { version = version + , downloads = getField @"download" <$> allDownloads + , checksums = getField @"md5sum" <$> allDownloads + } + liftIO $ Text.IO.writeFile infoFilePath $ generate package' + updateSlackBuildVersion packagePath version $ snd <$> moreDownloads + + commit packagePath version + +findCategory :: FilePath -> IO [FilePath] +findCategory currentDirectory = do + contents <- liftIO $ listDirectory currentDirectory + case find (isSuffixOf ".info") contents of + Just _ -> pure [currentDirectory] + Nothing -> do + let contents' = (currentDirectory </>) <$> filter (not . isPrefixOf ".") contents + directories <- filterM doesDirectoryExist contents' + subCategories <- traverse findCategory directories + pure $ concat subCategories + +main :: IO () +main = do + programCommand <- execParser slackBuilderParser + settings <- Toml.decodeFile settingsCodec "config/config.toml" + latestVersion <- flip runReaderT settings + $ runSlackBuilderT + $ executeCommand programCommand + + maybe (pure ()) Text.IO.putStrLn latestVersion + where + executeCommand = \case + CategoryCommand _packageName -> do + repository' <- SlackBuilderT $ asks repository + categories <- liftIO $ findCategory repository' + liftIO $ print $ splitFileName . makeRelative repository' <$> categories + pure Nothing + CloneCommand repo tarball tagPrefix -> fmap (Text.pack . show) + <$> clone repo tarball tagPrefix + Up2DateCommand -> up2Date >> pure Nothing |