Recognize + in sematnic tags
This commit is contained in:
parent
3d81917627
commit
bc3ba48d85
@ -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
|
||||
|
Loading…
Reference in New Issue
Block a user