diff options
Diffstat (limited to 'src/SlackBuilder/Update.hs')
| -rw-r--r-- | src/SlackBuilder/Update.hs | 262 |
1 files changed, 262 insertions, 0 deletions
diff --git a/src/SlackBuilder/Update.hs b/src/SlackBuilder/Update.hs new file mode 100644 index 0000000..008b63d --- /dev/null +++ b/src/SlackBuilder/Update.hs @@ -0,0 +1,262 @@ +{- This Source Code Form is subject to the terms of the Mozilla Public License, + v. 2.0. If a copy of the MPL was not distributed with this file, You can + obtain one at https://mozilla.org/MPL/2.0/. -} + +module SlackBuilder.Update + ( checkUpdateAvailability + , cloneFromGit + , downloadWithTemplate + , getAndLogLatest + , reuploadWithTemplate + , updatePackageIfRequired + ) where + +import Control.Applicative (Applicative(..)) +import Control.Monad.IO.Class (MonadIO(..)) +import Control.Monad.Trans.Reader (asks) +import qualified Data.ByteString as ByteString +import Data.Foldable (Foldable(..), find) +import qualified Data.List.NonEmpty as NonEmpty +import Data.Maybe (fromJust, fromMaybe) +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.IO as Text.IO +import GHC.Records (HasField(..)) +import System.FilePath + ( (</>) + , (<.>) + , dropExtension + , takeBaseName + , splitFileName + , takeDirectory + , takeFileName + , dropTrailingPathSeparator + ) +import System.Process + ( CmdSpec(..) + , CreateProcess(..) + , StdStream(..) + , withCreateProcess + , waitForProcess + ) +import SlackBuilder.Config +import SlackBuilder.Download +import SlackBuilder.Info +import SlackBuilder.Package (PackageDescription(..), PackageUpdateData(..)) +import qualified SlackBuilder.Package as Package +import SlackBuilder.Trans +import Text.Megaparsec (parse, errorBundlePretty) +import Text.URI (URI(..), mkURI) +import qualified Text.URI as URI +import System.Directory + ( listDirectory + , doesDirectoryExist + , withCurrentDirectory + , removeDirectoryRecursive + ) +import System.Console.ANSI + ( setSGR + , SGR(..) + , ColorIntensity(..) + , Color(..) + , ConsoleLayer(..) + ) +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 + +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 |