slackbuilder/app/Main.hs

module Main
    ( main
    ) where

import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.List.NonEmpty as NonEmpty
import Control.Monad.IO.Class (MonadIO(..))
import Data.Maybe (fromJust, fromMaybe)
import Options.Applicative (execParser)
import SlackBuilder.CommandLine
import SlackBuilder.Config
import SlackBuilder.Trans
import SlackBuilder.Updater
import qualified Toml
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 qualified SlackBuilder.Package as Package
import Text.URI (mkURI, URI)
import Text.URI.QQ (uri)
import Data.Foldable (for_)
import qualified Text.URI as URI
import GHC.Records (HasField(..))
import System.FilePath ((</>), (<.>))

data Package = Package
    { latest :: Package.Updater
    , category :: Text
    , name :: Text
    , homepage :: Maybe URI
    , requires :: [Text]
    , reupload :: Bool
    }

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"
        , homepage = Just [uri|https://ctags.io/|]
        , requires = pure "%README%"
        , reupload = True
        }
    , 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"
        , homepage = Just [uri|https://getcomposer.org/|]
        , requires = mempty
        , reupload = False
        }
    , 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"
        , homepage = Just [uri|https://jitsi.org/|]
        , requires = mempty
        , reupload = False
        }
    ]

up2Date :: SlackBuilderT ()
up2Date = for_ autoUpdatable go
  where
    go package = getAndLogLatest package >>= mapM_ (updatePackage package)
    getAndLogLatest Package{ latest = Package.Updater getLatest _, name }
        = liftIO (putStrLn $ Text.unpack name <> ": Retreiving the latest version.")
        >> getLatest

updatePackage :: Package -> Text -> SlackBuilderT ()
updatePackage Package{..} version = do
    maintainer' <- SlackBuilderT $ asks maintainer
    let packagePath = category <> "/" <> name
        package' = Package.PackageInfo
            { version = version
            , requires = requires
            , path = Text.unpack packagePath
            , homepage = maybe "" URI.render homepage
            , maintainer = Package.Maintainer
                { name = getField @"name" maintainer'
                , email = getField @"email" maintainer'
                }
            }
        Package.Updater _ downloadTemplate = latest

    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
    let infoFilePath = repository' </> Text.unpack packagePath
            </> (Text.unpack name <.> "info")

    liftIO $ Text.IO.writeFile infoFilePath
        $ Package.infoTemplate package' [Package.Download download' checksum False]
    updateSlackBuildVersion packagePath version

    commit packagePath version
  where
    handleReupload uri' relativeTarball downloadFileName
        | reupload = 
            liftIO (putStrLn $ "Upload the source tarball " <> Text.unpack relativeTarball)
            >> uploadCommand relativeTarball ("/" <> name)
            >> liftIO (mkURI $ "https://download.dlackware.com/hosted-sources/" <> name <> "/" <> downloadFileName)
        | otherwise = pure uri'


main :: IO ()
main = do
    programCommand <- execParser slackBuilderParser
    settings <- Toml.decodeFile settingsCodec "config/config.toml"
    latestVersion <- flip runReaderT settings
        $ runSlackBuilderT
        $ executeCommand programCommand

    Text.IO.putStrLn $ fromMaybe "" latestVersion
  where
    executeCommand = \case
        TextCommand textArguments -> latestText textArguments
        GhCommand ghArguments@GhArguments{ transform }
            -> latestGitHub ghArguments $ chooseTransformFunction transform
        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
    chooseTransformFunction (Just "php") = phpTransform
    chooseTransformFunction (Just "rdiff-backup") = Text.stripPrefix "v"
    chooseTransformFunction _ = stripPrefix "v"
    stripPrefix prefix string = Just
        $ fromMaybe string
        $ Text.stripPrefix prefix string
    phpTransform version
        | (majorPrefix, _patchVersion) <- Text.breakOnEnd "." version
        , majorPrefix == "php-8.2." = Just $ Text.drop (Text.length "php-") version
        | otherwise = Nothing