355 lines
15 KiB
Haskell
355 lines
15 KiB
Haskell
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 (mkURI)
|
|
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 []
|
|
}
|
|
, 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
|
|
}
|
|
, 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
|
|
}
|
|
, 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
|
|
}
|
|
, 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"]]
|
|
}
|
|
, 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
|
|
}
|
|
, 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
|
|
}
|
|
, 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
|
|
}
|
|
, 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
|
|
}
|
|
]
|
|
|
|
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 -> updatePackage package parsedInfoFile version
|
|
Left errorBundle -> liftIO $ putStr $ errorBundlePretty errorBundle
|
|
|
|
updatePackage :: Package -> PackageInfo -> Text -> SlackBuilderT ()
|
|
updatePackage Package{..} info version = do
|
|
let packagePath = category <> "/" <> name
|
|
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")
|
|
package' = info
|
|
{ version = version
|
|
, downloads = [download']
|
|
, checksums = [checksum]
|
|
}
|
|
|
|
liftIO $ Text.IO.writeFile infoFilePath $ generate package'
|
|
updateSlackBuildVersion packagePath version
|
|
|
|
commit packagePath version
|
|
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
|
|
}
|
|
|
|
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
|