Recognize + in sematnic tags
This commit is contained in:
		@@ -59,7 +59,7 @@ stableTagTransform :: Text -> Maybe Text
 | 
			
		||||
stableTagTransform = Text.stripPrefix "v" >=> checkForStable
 | 
			
		||||
  where
 | 
			
		||||
    checkForStable tag
 | 
			
		||||
        | '-' `Text.elem` tag = Nothing
 | 
			
		||||
        | Text.any (`elem` ['-', '+']) tag = Nothing
 | 
			
		||||
        | otherwise = Just tag
 | 
			
		||||
 | 
			
		||||
-- * Packagist
 | 
			
		||||
@@ -17,6 +17,7 @@ extra-source-files: CHANGELOG.md
 | 
			
		||||
 | 
			
		||||
common dependencies
 | 
			
		||||
  build-depends:
 | 
			
		||||
    aeson ^>= 2.2.0,
 | 
			
		||||
    base >= 4.16 && < 5,
 | 
			
		||||
    bytestring ^>= 0.11.0,
 | 
			
		||||
    conduit ^>= 1.3.5,
 | 
			
		||||
@@ -38,6 +39,8 @@ common dependencies
 | 
			
		||||
    text ^>= 2.0,
 | 
			
		||||
    tomland ^>= 1.3.3,
 | 
			
		||||
    transformers ^>= 0.5.6,
 | 
			
		||||
    unordered-containers ^>= 0.2.19,
 | 
			
		||||
    vector ^>= 0.13.0,
 | 
			
		||||
    word8 ^>= 0.1.3
 | 
			
		||||
  default-language: Haskell2010
 | 
			
		||||
  default-extensions:
 | 
			
		||||
@@ -59,6 +62,7 @@ library
 | 
			
		||||
    SlackBuilder.Config
 | 
			
		||||
    SlackBuilder.Download
 | 
			
		||||
    SlackBuilder.Info
 | 
			
		||||
    SlackBuilder.LatestVersionCheck
 | 
			
		||||
    SlackBuilder.Package
 | 
			
		||||
    SlackBuilder.Trans
 | 
			
		||||
  hs-source-dirs: lib
 | 
			
		||||
@@ -70,14 +74,11 @@ executable slackbuilder
 | 
			
		||||
 | 
			
		||||
  other-modules:
 | 
			
		||||
    SlackBuilder.CommandLine
 | 
			
		||||
    SlackBuilder.LatestVersionCheck
 | 
			
		||||
    SlackBuilder.Update
 | 
			
		||||
  build-depends:
 | 
			
		||||
    aeson ^>= 2.2.0,
 | 
			
		||||
    ansi-terminal ^>= 1.0,
 | 
			
		||||
    optparse-applicative ^>= 0.18.1,
 | 
			
		||||
    slackbuilder,
 | 
			
		||||
    unordered-containers ^>= 0.2.19,
 | 
			
		||||
    vector ^>= 0.13.0
 | 
			
		||||
    slackbuilder
 | 
			
		||||
  hs-source-dirs: src
 | 
			
		||||
 | 
			
		||||
  ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall
 | 
			
		||||
@@ -89,6 +90,7 @@ test-suite slackbuilder-test
 | 
			
		||||
 | 
			
		||||
  other-modules:
 | 
			
		||||
    SlackBuilder.InfoSpec
 | 
			
		||||
    SlackBuilder.LatestVersionCheckSpec
 | 
			
		||||
    SlackBuilder.PackageSpec
 | 
			
		||||
  hs-source-dirs: tests
 | 
			
		||||
  build-depends:
 | 
			
		||||
 
 | 
			
		||||
							
								
								
									
										243
									
								
								src/Main.hs
									
									
									
									
									
								
							
							
						
						
									
										243
									
								
								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
 | 
			
		||||
 
 | 
			
		||||
							
								
								
									
										262
									
								
								src/SlackBuilder/Update.hs
									
									
									
									
									
										Normal file
									
								
							
							
						
						
									
										262
									
								
								src/SlackBuilder/Update.hs
									
									
									
									
									
										Normal file
									
								
							@@ -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
 | 
			
		||||
@@ -1,3 +1,7 @@
 | 
			
		||||
{- 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.InfoSpec
 | 
			
		||||
    ( spec
 | 
			
		||||
    ) where
 | 
			
		||||
 
 | 
			
		||||
							
								
								
									
										24
									
								
								tests/SlackBuilder/LatestVersionCheckSpec.hs
									
									
									
									
									
										Normal file
									
								
							
							
						
						
									
										24
									
								
								tests/SlackBuilder/LatestVersionCheckSpec.hs
									
									
									
									
									
										Normal file
									
								
							@@ -0,0 +1,24 @@
 | 
			
		||||
{- 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.LatestVersionCheckSpec
 | 
			
		||||
    ( spec
 | 
			
		||||
    ) where
 | 
			
		||||
 | 
			
		||||
import SlackBuilder.LatestVersionCheck
 | 
			
		||||
import Test.Hspec (Spec, describe, it, shouldBe)
 | 
			
		||||
 | 
			
		||||
spec :: Spec
 | 
			
		||||
spec = do
 | 
			
		||||
    describe "stableTagTransform" $ do
 | 
			
		||||
        it "excludes tags with +" $
 | 
			
		||||
            let given = "v2.6.0+unreleased"
 | 
			
		||||
                actual = stableTagTransform given
 | 
			
		||||
             in actual `shouldBe` Nothing
 | 
			
		||||
 | 
			
		||||
        it "recognizes a stable version" $
 | 
			
		||||
            let given = "v2.6.0"
 | 
			
		||||
                actual = stableTagTransform given
 | 
			
		||||
                expected = Just "2.6.0"
 | 
			
		||||
             in actual `shouldBe` expected
 | 
			
		||||
@@ -1,3 +1,7 @@
 | 
			
		||||
{- 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.PackageSpec
 | 
			
		||||
    ( spec
 | 
			
		||||
    ) where 
 | 
			
		||||
 
 | 
			
		||||
		Reference in New Issue
	
	Block a user