diff options
Diffstat (limited to 'app')
| -rw-r--r-- | app/Main.hs | 421 | ||||
| -rw-r--r-- | app/SlackBuilder/CommandLine.hs | 58 | ||||
| -rw-r--r-- | app/SlackBuilder/Updater.hs | 158 |
3 files changed, 0 insertions, 637 deletions
diff --git a/app/Main.hs b/app/Main.hs deleted file mode 100644 index 535b655..0000000 --- a/app/Main.hs +++ /dev/null @@ -1,421 +0,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.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/app/SlackBuilder/CommandLine.hs b/app/SlackBuilder/CommandLine.hs deleted file mode 100644 index 7cfe747..0000000 --- a/app/SlackBuilder/CommandLine.hs +++ /dev/null @@ -1,58 +0,0 @@ -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/app/SlackBuilder/Updater.hs b/app/SlackBuilder/Updater.hs deleted file mode 100644 index 1ebf7fe..0000000 --- a/app/SlackBuilder/Updater.hs +++ /dev/null @@ -1,158 +0,0 @@ -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\ - \}" |