diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Main.hs | 421 | ||||
| -rw-r--r-- | src/SlackBuilder/CommandLine.hs | 58 | ||||
| -rw-r--r-- | src/SlackBuilder/Updater.hs | 158 |
3 files changed, 637 insertions, 0 deletions
diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 index 0000000..535b655 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,421 @@ +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 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) + +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 + , 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 + , 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 + , 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 + , 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 + , 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) + , ("DSCANNER", Package.Updater latestDscanner $ cloneFromGit dscannerURI "v") + , ("DCD", Package.Updater latestDcd $ cloneFromGit dcdURI "v") + ] + } + ] + +up2Date :: SlackBuilderT () +up2Date = for_ autoUpdatable go + where + go package = getAndLogLatest package + >>= mapM_ (updatePackageIfRequired package) + >> liftIO (putStrLn "") + getAndLogLatest Package{ latest = Package.Updater{ detectLatest }, name } + = liftIO (putStrLn $ Text.unpack name <> ": Retreiving the latest version.") + >> detectLatest + +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 (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 -> Text -> Text -> SlackBuilderT Package.Download +downloadWithTemplate downloadTemplate 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 False + +reuploadWithTemplate :: Package.DownloadTemplate -> [CmdSpec] -> Text -> Text -> SlackBuilderT Package.Download +reuploadWithTemplate downloadTemplate commands packagePath version = do + Package.Download{ download = uri', md5sum = checksum } <- downloadWithTemplate downloadTemplate 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 -> PackageInfo -> Text -> SlackBuilderT () +updatePackage package@Package{..} info version = do + let packagePath = category <> "/" <> name + + repository' <- SlackBuilderT $ asks repository + mainDownload <- renderAndDownload package version + moreDownloads <- traverse (updateDownload package) downloaders + let allDownloads = 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 + } + 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 _packageName -> do + repository' <- SlackBuilderT $ asks repository + categories <- liftIO $ findCategory repository' + liftIO $ print $ splitFileName . makeRelative repository' <$> categories + pure Nothing + CloneCommand repo tarball tagPrefix -> fmap (Text.pack . show) + <$> clone repo tarball tagPrefix + Up2DateCommand -> up2Date >> pure Nothing diff --git a/src/SlackBuilder/CommandLine.hs b/src/SlackBuilder/CommandLine.hs new file mode 100644 index 0000000..7cfe747 --- /dev/null +++ b/src/SlackBuilder/CommandLine.hs @@ -0,0 +1,58 @@ +module SlackBuilder.CommandLine + ( GhArguments(..) + , SlackBuilderCommand(..) + , PackagistArguments(..) + , TextArguments(..) + , slackBuilderParser + ) where + +import Data.Text (Text) +import Options.Applicative + ( Parser + , ParserInfo(..) + , metavar + , argument + , str + , info + , fullDesc + , subparser + , command, + ) + +data SlackBuilderCommand + = CategoryCommand Text + | CloneCommand Text Text Text + | Up2DateCommand + +data PackagistArguments = PackagistArguments + { vendor :: Text + , name :: Text + } deriving (Eq, Show) + +data GhArguments = GhArguments + { owner :: Text + , name :: Text + , transform :: Maybe Text + } deriving (Eq, Show) + +data TextArguments = TextArguments + { versionPicker :: Text -> Text + , textURL :: Text + } + +slackBuilderParser :: ParserInfo SlackBuilderCommand +slackBuilderParser = info slackBuilderCommand fullDesc + +slackBuilderCommand :: Parser SlackBuilderCommand +slackBuilderCommand = subparser + $ command "category" (info categoryCommand mempty) + <> command "clone" (info cloneCommand mempty) + <> command "up2date" (info up2DateCommand mempty) + where + categoryCommand = CategoryCommand + <$> argument str (metavar "PKGNAM") + cloneCommand = CloneCommand + <$> argument str (metavar "REPO") + <*> argument str (metavar "TARBALL") + <*> argument str (metavar "TAG_PREFIX") + up2DateCommand = pure Up2DateCommand diff --git a/src/SlackBuilder/Updater.hs b/src/SlackBuilder/Updater.hs new file mode 100644 index 0000000..1ebf7fe --- /dev/null +++ b/src/SlackBuilder/Updater.hs @@ -0,0 +1,158 @@ +module SlackBuilder.Updater + ( latestGitHub + , latestPackagist + , latestText + ) where + +import SlackBuilder.Config +import qualified Data.Aeson as Aeson +import Data.Aeson ((.:)) +import Data.Aeson.TH (defaultOptions, deriveJSON) +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HashMap +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text.Encoding +import Data.Vector (Vector, (!?)) +import qualified Data.Vector as Vector +import Network.HTTP.Req + ( header + , runReq + , defaultHttpConfig + , req + , GET(..) + , https + , jsonResponse + , NoReqBody(..) + , (/:) + , responseBody + , useHttpsURI + , bsResponse + , POST(..) + , ReqBodyJson(..) + ) +import Text.URI (mkURI) +import SlackBuilder.CommandLine +import SlackBuilder.Trans +import qualified Data.Aeson.KeyMap as KeyMap +import GHC.Records (HasField(..)) +import Control.Monad.Trans.Reader (asks) +import Control.Monad.IO.Class (MonadIO(..)) + +newtype PackagistPackage = PackagistPackage + { version :: Text + } deriving (Eq, Show) + +$(deriveJSON defaultOptions ''PackagistPackage) + +newtype PackagistResponse = PackagistResponse + { packages :: HashMap Text (Vector PackagistPackage) + } deriving (Eq, Show) + +$(deriveJSON defaultOptions ''PackagistResponse) + +newtype GhRefNode = GhRefNode + { name :: Text + } deriving (Eq, Show) + +$(deriveJSON defaultOptions ''GhRefNode) + +newtype GhRef = GhRef + { nodes :: Vector GhRefNode + } deriving (Eq, Show) + +$(deriveJSON defaultOptions ''GhRef) + +newtype GhRepository = GhRepository + { refs :: GhRef + } deriving (Eq, Show) + +$(deriveJSON defaultOptions ''GhRepository) + +newtype GhData = GhData + { repository :: GhRepository + } deriving (Eq, Show) + +instance Aeson.FromJSON GhData where + parseJSON (Aeson.Object keyMap) + | Just data' <- KeyMap.lookup "data" keyMap = + GhData <$> Aeson.withObject "GhData" (.: "repository") data' + parseJSON _ = fail "data key not found in the response" + +data GhVariables = GhVariables + { name :: Text + , owner :: Text + } deriving (Eq, Show) + +$(deriveJSON defaultOptions ''GhVariables) + +data GhQuery = GhQuery + { query :: Text + , variables :: GhVariables + } deriving (Eq, Show) + +$(deriveJSON defaultOptions ''GhQuery) + +latestPackagist :: PackagistArguments -> SlackBuilderT (Maybe Text) +latestPackagist PackagistArguments{..} = do + packagistResponse <- runReq defaultHttpConfig $ + let uri = https "repo.packagist.org" /: "p2" + /: vendor + /: name <> ".json" + in req GET uri NoReqBody jsonResponse mempty + let packagistPackages = packages $ responseBody packagistResponse + fullName = Text.intercalate "/" [vendor, name] + + pure $ HashMap.lookup fullName packagistPackages + >>= fmap (version . fst) . Vector.uncons + +latestText :: TextArguments -> SlackBuilderT (Maybe Text) +latestText TextArguments{..} = do + uri <- liftIO $ useHttpsURI <$> mkURI textURL + packagistResponse <- traverse (runReq defaultHttpConfig . go . fst) uri + + pure $ versionPicker . Text.Encoding.decodeUtf8 . responseBody + <$> packagistResponse + where + go uri = req GET uri NoReqBody bsResponse mempty + +latestGitHub + :: GhArguments + -> (Text -> Maybe Text) + -> SlackBuilderT (Maybe Text) +latestGitHub GhArguments{..} versionTransform = do + ghToken' <- SlackBuilderT $ asks ghToken + ghResponse <- runReq defaultHttpConfig $ + let uri = https "api.github.com" /: "graphql" + query = GhQuery + { query = githubQuery + , variables = GhVariables + { owner = owner + , name = name + } + } + authorizationHeader = header "authorization" + $ Text.Encoding.encodeUtf8 + $ "Bearer " <> ghToken' + in req POST uri (ReqBodyJson query) jsonResponse + $ authorizationHeader <> header "User-Agent" "SlackBuilder" + let ghNodes = nodes + $ refs + $ (getField @"repository" :: GhData -> GhRepository) + $ responseBody ghResponse + refs' = Vector.reverse + $ Vector.catMaybes + $ versionTransform . getField @"name" <$> ghNodes + pure $ refs' !? 0 + where + githubQuery = + "query ($name: String!, $owner: String!) {\n\ + \ repository(name: $name, owner: $owner) {\n\ + \ refs(last: 10, refPrefix: \"refs/tags/\", orderBy: { field: TAG_COMMIT_DATE, direction: ASC }) {\n\ + \ nodes {\n\ + \ id,\n\ + \ name\n\ + \ }\n\ + \ }\n\ + \ }\n\ + \}" |