diff options
Diffstat (limited to 'src/Main.hs')
| -rw-r--r-- | src/Main.hs | 243 |
1 files changed, 7 insertions, 236 deletions
diff --git a/src/Main.hs b/src/Main.hs index fb3a814..b51d4cd 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -7,66 +7,28 @@ module Main ) where import Data.Char (isNumber) -import Control.Applicative (Applicative(liftA2)) +import Control.Applicative (Applicative(..)) 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 SlackBuilder.Update 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 Control.Monad.Trans.Reader (ReaderT(..)) +import SlackBuilder.Package (PackageDescription(..)) 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 Data.Foldable (for_, find) 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 +import System.Process (CmdSpec(..)) autoUpdatable :: [PackageDescription] autoUpdatable = @@ -180,7 +142,7 @@ autoUpdatable = : Package.VersionPlaceholder : [Package.StaticPlaceholder ".tar.gz"] in Package.Updater - { detectLatest = latestGitHub ghArguments $ Text.stripPrefix "v" + { detectLatest = latestGitHub ghArguments stableTagTransform , getVersion = reuploadWithTemplate template [] , is64 = False } @@ -314,197 +276,6 @@ check = for_ autoUpdatable go >>= 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 |