path: root/src/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.Catch (MonadThrow(..))
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, partition)

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 False
        , 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 False
        , 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 False
        , 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 True
        , 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 False
        , 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 False)
                , ("DSCANNER", Package.Updater latestDscanner $ cloneFromGit dscannerURI "v")
                , ("DCD", Package.Updater latestDcd $ cloneFromGit dcdURI "v")
                ]
        }
    ]

up2Date :: Maybe Text -> SlackBuilderT ()
up2Date = \case
    Nothing -> for_ autoUpdatable go
    Just packageName
        | Just foundPackage <- find ((packageName ==) . getField @"name") autoUpdatable ->
            go foundPackage
        | otherwise -> throwM $ UpdaterNotFound packageName
  where
    go package = getAndLogLatest package
        >>= mapM_ (updatePackageIfRequired package)
        >> liftIO (putStrLn "")

check :: SlackBuilderT ()
check = for_ autoUpdatable go
  where
    go package = getAndLogLatest package
        >>= mapM_ (checkUpdateAvailability package)
        >> liftIO (putStrLn "")

getAndLogLatest :: Package -> SlackBuilderT (Maybe Text)
getAndLogLatest Package{ latest = Package.Updater{ detectLatest }, name }
    = liftIO (putStrLn $ Text.unpack name <> ": Retreiving the latest version.")
    >> detectLatest

checkUpdateAvailability :: Package -> Text -> SlackBuilderT (Maybe PackageInfo)
checkUpdateAvailability 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]
                    pure Nothing
            | otherwise ->
                liftIO $ do
                    setSGR [SetColor Foreground Dull Yellow]
                    Text.IO.putStrLn
                        $ "A new version of "
                        <> name <> " " <> getField @"version" parsedInfoFile
                        <> " is available (" <> version <> ")."
                    setSGR [Reset]
                    pure $ Just parsedInfoFile
        Left errorBundle -> liftIO (putStr $ errorBundlePretty errorBundle)
            >> pure Nothing

updatePackageIfRequired :: Package -> Text -> SlackBuilderT ()
updatePackageIfRequired package version
    = checkUpdateAvailability package version
    >>= mapM_ (updatePackage package version)

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 -> Bool -> Text -> Text -> SlackBuilderT Package.Download
downloadWithTemplate downloadTemplate is64' 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 is64'

reuploadWithTemplate :: Package.DownloadTemplate -> [CmdSpec] -> Text -> Text -> SlackBuilderT Package.Download
reuploadWithTemplate downloadTemplate commands packagePath version = do
    Package.Download{ download = uri', md5sum = checksum } <-
        downloadWithTemplate downloadTemplate False 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 -> Text -> PackageInfo -> SlackBuilderT ()
updatePackage package@Package{..} version info = do
    let packagePath = category <> "/" <> name

    repository' <- SlackBuilderT $ asks repository
    mainDownload <- renderAndDownload package version
    moreDownloads <- traverse (updateDownload package) downloaders
    let (downloads64, allDownloads) = partition (getField @"is64")
            $ 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
            , downloadX64 = getField @"download" <$> downloads64
            , checksumX64 = getField @"md5sum" <$> downloads64
            }
    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 -> do
            repository' <- SlackBuilderT $ asks repository
            categories <- liftIO $ findCategory repository'
            liftIO $ print $ splitFileName . makeRelative repository' <$> categories
            pure Nothing
        CheckCommand -> check >> pure Nothing
        Up2DateCommand packageName -> up2Date packageName >> pure Nothing