path: root/app/Main.hs

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