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 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 Crypto.Hash (Digest, MD5) import Data.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' template , category = "development" , name = "universal-ctags" , reupload = Just [] , 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' template , category = "development" , name = "composer" , reupload = Nothing , 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' template , category = "network" , name = "jitsi-meet-desktop" , reupload = Nothing , 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' template , category = "development" , name = "php82" , reupload = Nothing , 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' template , category = "system" , name = "kitty" , reupload = Just [RawCommand "go" ["mod", "vendor"]] , 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' template , category = "system" , name = "rdiff-backup" , reupload = Just mempty , 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' template , category = "network" , name = "webex" , reupload = Nothing , 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' template , category = "libraries" , name = "librsync" , reupload = Just mempty , downloaders = [] } , 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' template , category = "development" , name = "dmd" , reupload = Nothing , 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' template , category = "development" , name = "d-tools" , reupload = Just [] , downloaders = let dubArguments = GhArguments{ owner = "dlang", name = "dub", transform = Nothing} latestDub = latestGitHub dubArguments pure dubTemplate = Package.DownloadTemplate $ Package.StaticPlaceholder "https://codeload.github.com/dlang/dub/tar.gz/v" :| [Package.VersionPlaceholder] in [Package.Updater latestDub dubTemplate] } ] up2Date :: SlackBuilderT () up2Date = for_ autoUpdatable go where go package = getAndLogLatest package >>= mapM_ (updatePackageIfRequired package) >> liftIO (putStrLn "") getAndLogLatest Package{ latest = Package.Updater getLatest _, name } = liftIO (putStrLn $ Text.unpack name <> ": Retreiving the latest version.") >> getLatest 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 (URI, Digest MD5) updateDownload package (Package.Updater updater downloadTemplate) = updater >>= renderAndDownload package downloadTemplate . fromJust renderAndDownload :: Package -> Package.DownloadTemplate -> Text -> SlackBuilderT (URI, Digest MD5) renderAndDownload Package{..} downloadTemplate version = do let packagePath = category <> "/" <> name 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 liftIO $ putStrLn $ "Downloading " <> Text.unpack (URI.render uri') <> " to " <> tarball <> "." checksum <- fromJust <$> download uri' tarball download' <- handleReupload uri' relativeTarball downloadFileName pure (download', checksum) where handleReupload uri' relativeTarball downloadFileName = do repository' <- SlackBuilderT $ asks repository case reupload of Just [] -> uploadTarball relativeTarball downloadFileName Just commands -> 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 Nothing -> pure uri' 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 } updatePackage :: Package -> PackageInfo -> Text -> SlackBuilderT () updatePackage package@Package{..} info version = do let packagePath = category <> "/" <> name Package.Updater _ downloadTemplate = latest repository' <- SlackBuilderT $ asks repository mainDownload <- renderAndDownload package downloadTemplate version moreDownloads <- traverse (updateDownload package) downloaders let (allDownloads, allChecksums) = unzip $ mainDownload : moreDownloads let infoFilePath = repository' Text.unpack packagePath (Text.unpack name <.> "info") package' = info { version = version , downloads = allDownloads , checksums = allChecksums } liftIO $ Text.IO.writeFile infoFilePath $ generate package' updateSlackBuildVersion packagePath version 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 SlackBuildCommand packagePath version -> updateSlackBuildVersion packagePath version >> pure Nothing CommitCommand packagePath version -> commit packagePath version >> pure Nothing ExistsCommand urlPath -> pure . Text.pack . show <$> remoteFileExists urlPath ArchiveCommand repo nameVersion tarball tagPrefix -> cloneAndArchive repo nameVersion tarball tagPrefix >> pure Nothing DownloadCommand url target | Just uri' <- mkURI url -> fmap (Text.pack . show) <$> download uri' target | otherwise -> pure Nothing CloneCommand repo tarball tagPrefix -> fmap (Text.pack . show) <$> clone repo tarball tagPrefix DownloadAndDeployCommand uri' tarball -> fmap (Text.pack . show) <$> downloadAndDeploy uri' tarball Up2DateCommand -> up2Date >> pure Nothing