slackbuilder/src/Main.hs

{- 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 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, fromMaybe)
import qualified Data.Map as Map
import Options.Applicative (execParser)
import SlackBuilder.CommandLine
import SlackBuilder.Config
import SlackBuilder.Trans
import SlackBuilder.LatestVersionCheck
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 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 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

autoUpdatable :: [PackageDescription]
autoUpdatable =
    [ PackageDescription
        { latest =
            let ghArguments = PackageOwner{ owner = "universal-ctags", name = "ctags" }
                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
                { detectLatest = latestGitHub ghArguments stableTagTransform
                , getVersion = reuploadWithTemplate template []
                , is64 = False
                }
        , name = "universal-ctags"
        , downloaders = mempty
        }
    , PackageDescription
        { latest =
            let packagistArguments = PackageOwner{ owner = "composer", name = "composer" }
                template = Package.DownloadTemplate
                    $ Package.StaticPlaceholder "https://getcomposer.org/download/"
                    :| [Package.VersionPlaceholder, Package.StaticPlaceholder "/composer.phar"]
             in Package.Updater
                { detectLatest = latestPackagist packagistArguments
                , getVersion = downloadWithTemplate template
                , is64 = False
                }
        , name = "composer"
        , downloaders = mempty
        }
    , PackageDescription
        { latest =
            let ghArguments = PackageOwner
                    { owner = "jitsi"
                    , name = "jitsi-meet-electron"
                    }
                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
                { detectLatest = latestGitHub ghArguments $ Text.stripPrefix "v"
                , getVersion = downloadWithTemplate template
                , is64 = True
                }
        , name = "jitsi-meet-desktop"
        , downloaders = mempty
        }
    , PackageDescription
        { latest =
            let ghArguments = PackageOwner
                    { owner = "php"
                    , name = "php-src"
                    }
                checkVersion x
                    | not $ Text.isInfixOf "RC" x
                    , Text.isPrefixOf "php-8.2." x = Text.stripPrefix "php-" x
                    | otherwise = Nothing
                template = Package.DownloadTemplate
                    $ Package.StaticPlaceholder "https://www.php.net/distributions/php-"
                    :| Package.VersionPlaceholder
                    : [Package.StaticPlaceholder ".tar.xz"]
             in Package.Updater
                { detectLatest = latestGitHub ghArguments checkVersion
                , getVersion = downloadWithTemplate template
                , is64 = False
                }
        , name = "php82"
        , downloaders = mempty
        }
    , PackageDescription
        { latest =
            let ghArguments = PackageOwner
                    { owner = "kovidgoyal"
                    , name = "kitty"
                    }
                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
                { detectLatest = latestGitHub ghArguments stableTagTransform
                , getVersion = reuploadWithTemplate template [RawCommand "go" ["mod", "vendor"]]
                , is64 = False
                }
        , name = "kitty"
        , downloaders = mempty
        }
    , PackageDescription
        { latest =
            let ghArguments = PackageOwner
                    { owner = "rdiff-backup"
                    , name = "rdiff-backup"
                    }
                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
                { detectLatest = latestGitHub ghArguments $ Text.stripPrefix "v"
                , getVersion = reuploadWithTemplate template []
                , is64 = False
                }
        , name = "rdiff-backup"
        , downloaders = mempty
        }
    , PackageDescription
        { 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
                    }
                template = Package.DownloadTemplate $ pure
                    $ Package.StaticPlaceholder
                        "https://binaries.webex.com/WebexDesktop-Ubuntu-Official-Package/Webex.deb"
             in Package.Updater
                { detectLatest = latestText textArguments
                , getVersion = downloadWithTemplate template
                , is64 = True
                }
        , name = "webex"
        , downloaders = mempty
        }
    , PackageDescription
        { latest =
            let ghArguments = PackageOwner
                    { owner = "librsync"
                    , name = "librsync"
                    }
                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
                { detectLatest = latestGitHub ghArguments $ Text.stripPrefix "v"
                , getVersion = reuploadWithTemplate template []
                , is64 = True
                }
        , name = "librsync"
        , downloaders = mempty
        }
    , PackageDescription
        { latest =
            let textArguments = TextArguments
                    { textURL = "https://downloads.dlang.org/releases/LATEST"
                    , versionPicker = Text.strip
                    }
                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
                { detectLatest = latestText textArguments
                , getVersion = downloadWithTemplate template
                , is64 = False
                }
        , name = "dmd"
        , downloaders = mempty
        }
    , PackageDescription
        { latest =
            let textArguments = TextArguments
                    { textURL = "https://downloads.dlang.org/releases/LATEST"
                    , versionPicker = Text.strip
                    }
                template = Package.DownloadTemplate
                    $ Package.StaticPlaceholder "https://codeload.github.com/dlang/tools/tar.gz/v"
                    :| [Package.VersionPlaceholder]
             in Package.Updater
                { detectLatest = latestText textArguments
                , getVersion = reuploadWithTemplate template []
                , is64 = False
                }
        , name = "d-tools"
        , downloaders =
            let dubArguments = PackageOwner{ owner = "dlang", name = "dub" }
                dscannerArguments = PackageOwner{ owner = "dlang-community", name = "D-Scanner" }
                dcdArguments = PackageOwner{ owner = "dlang-community", name = "DCD" }
                latestDub = Package.Updater
                    { detectLatest = latestGitHub dubArguments stableTagTransform
                    , getVersion = downloadWithTemplate dubTemplate
                    , is64 = False
                    }
                latestDscanner = Package.Updater
                    { detectLatest = latestGitHub dscannerArguments stableTagTransform
                    , getVersion = cloneFromGit dscannerURI "v"
                    , is64 = False
                    }
                dcdURI = [uri|https://github.com/dlang-community/DCD.git|]
                latestDcd = Package.Updater
                    { detectLatest = latestGitHub dcdArguments stableTagTransform
                    , getVersion = cloneFromGit dcdURI "v"
                    , is64 = False
                    }
                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|]
             in Map.fromList
                [ ("DUB", latestDub)
                , ("DSCANNER", latestDscanner)
                , ("DCD", latestDcd)
                ]
        }
    ]

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
        >> liftIO (putStrLn "")

check :: SlackBuilderT ()
check = for_ autoUpdatable go
  where
    go package = getAndLogLatest package
        >>= 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
    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
        CheckCommand -> check >> pure Nothing
        Up2DateCommand packageName -> up2Date packageName >> pure Nothing