Use consistent directory for cloning repositories
All checks were successful
Build / audit (push) Successful in 16m35s
Build / test (push) Successful in 16m41s

... with submodules.
This commit is contained in:
Eugen Wissner 2024-01-04 09:36:11 +01:00
parent a25655c2b2
commit 7edb811dc2
Signed by: belka
GPG Key ID: A27FDC1E8EE902C0
4 changed files with 75 additions and 62 deletions

View File

@ -3,7 +3,7 @@
obtain one at https://mozilla.org/MPL/2.0/. -}
module SlackBuilder.Download
( clone
( cloneAndUpload
, cloneAndArchive
, commit
, download
@ -25,7 +25,7 @@ import SlackBuilder.Trans
import Control.Monad.Trans.Reader (asks)
import Control.Monad.IO.Class (MonadIO(liftIO))
import System.IO (IOMode(..), withFile)
import System.FilePath ((</>), (<.>), takeBaseName, splitPath, joinPath)
import System.FilePath ((</>), (<.>), takeFileName, takeDirectory)
import System.Process
( CreateProcess(..)
, StdStream(..)
@ -130,46 +130,50 @@ remoteFileExists url = hostedSources url
}
go uri = req HEAD uri NoReqBody ignoreResponse mempty
uploadCommand :: Text -> Text -> SlackBuilderT ()
uploadCommand :: FilePath -> Text -> SlackBuilderT ()
uploadCommand localPath remotePath' = do
remoteRoot <- SlackBuilderT $ asks remotePath
repository' <- SlackBuilderT $ asks repository
localPathFromRepository <- relativeToRepository localPath
liftIO $ callProcess "scp"
[ repository' </> Text.unpack localPath
[ localPathFromRepository
, Text.unpack $ remoteRoot <> remotePath'
]
cloneAndArchive :: Text -> Text -> FilePath -> Text -> SlackBuilderT ()
cloneAndArchive repo nameVersion tarball tagPrefix = do
let (_, version) = Text.breakOnEnd "-" nameVersion
nameVersion' = Text.unpack nameVersion
cloneAndArchive :: Text -> FilePath -> Text -> SlackBuilderT ()
cloneAndArchive repo tarballPath tagPrefix = do
let version = snd $ Text.breakOnEnd "-"
$ Text.pack $ takeFileName tarballPath
repository' <- SlackBuilderT $ asks repository
liftIO $ callProcess "rm" ["-rf", nameVersion']
liftIO $ callProcess "git" ["clone", Text.unpack repo, nameVersion']
liftIO $ callProcess "git"
repositoryTarballPath <- relativeToRepository tarballPath
repositoryArchivePath <- relativeToRepository $ tarballPath <.> "tar.xz"
liftIO
$ callProcess "rm" ["-rf", repositoryTarballPath]
>> callProcess "git"
[ "clone"
, Text.unpack repo
, repositoryTarballPath
]
>> callProcess "git"
[ "-C"
, nameVersion'
, repositoryTarballPath
, "checkout"
, Text.unpack $ tagPrefix <> version
]
liftIO $ callProcess "git"
>> callProcess "git"
[ "-C"
, nameVersion'
, repositoryTarballPath
, "submodule"
, "update"
, "--init"
, "--recursive"
]
liftIO $ callProcess "tar"
>> callProcess "tar"
["Jcvf"
, repository' </> tarball
, nameVersion'
, repositoryArchivePath
, repositoryTarballPath
]
liftIO $ callProcess "rm" ["-rf", nameVersion']
>> callProcess "rm" ["-rf", repositoryTarballPath]
responseBodySource :: MonadIO m => Response BodyReader -> ConduitT i ByteString m ()
responseBodySource = bodyReaderSource . responseBody
@ -193,20 +197,19 @@ download uri target = traverse (runReq defaultHttpConfig . go . fst)
$ responseBodySource response
.| getZipSink (ZipSink (sinkFile target) *> ZipSink sinkHash)
clone :: Text -> Text -> Text -> SlackBuilderT (Maybe (Digest MD5))
clone repo tarball tagPrefix = do
repository' <- SlackBuilderT $ asks repository
let tarballPath = Text.unpack tarball
nameVersion = Text.pack $ takeBaseName tarballPath
remotePath = Text.pack $ joinPath $ ("/" :) $ drop 1 $ splitPath tarballPath
localPath = repository' </> tarballPath
remoteFileExists' <- remoteFileExists remotePath
cloneAndUpload :: Text -> FilePath -> Text -> SlackBuilderT (Maybe (URI, Digest MD5))
cloneAndUpload repo tarballPath tagPrefix = do
localPath <- relativeToRepository $ tarballPath <.> "tar.xz"
let packageName = takeFileName $ takeDirectory tarballPath
remoteArchivePath = Text.cons '/' $ Text.pack
$ packageName </> takeFileName tarballPath <.> "tar.xz"
remoteResultURI <- hostedSources remoteArchivePath
remoteFileExists' <- remoteFileExists remoteArchivePath
if remoteFileExists'
then
hostedSources remotePath >>= flip download localPath
then fmap (remoteResultURI,) <$> download remoteResultURI localPath
else
let go = sourceFile localPath .| sinkHash
in cloneAndArchive repo nameVersion tarballPath tagPrefix
>> uploadCommand tarball remotePath
>> liftIO (runConduitRes go) <&> Just
in cloneAndArchive repo tarballPath tagPrefix
>> uploadCommand localPath remoteArchivePath
>> liftIO (runConduitRes go) <&> Just . (remoteResultURI,)

View File

@ -6,14 +6,16 @@
module SlackBuilder.Trans
( SlackBuilderException(..)
, SlackBuilderT(..)
, relativeToRepository
) where
import Control.Monad.Trans.Reader (ReaderT(..))
import Control.Monad.Trans.Reader (ReaderT(..), asks)
import Data.Text (Text)
import SlackBuilder.Config
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.Catch (MonadCatch(..), MonadThrow(..))
import Control.Exception (Exception(..))
import System.FilePath ((</>))
newtype SlackBuilderException = UpdaterNotFound Text
deriving Show
@ -24,6 +26,10 @@ newtype SlackBuilderT a = SlackBuilderT
{ runSlackBuilderT :: ReaderT Settings IO a
}
relativeToRepository :: FilePath -> SlackBuilderT FilePath
relativeToRepository filePath =
(</> filePath) <$> SlackBuilderT (asks repository)
instance Functor SlackBuilderT
where
fmap f (SlackBuilderT slackBuilderT) = SlackBuilderT $ f <$> slackBuilderT

View File

@ -234,9 +234,9 @@ autoUpdatable =
let dubArguments = PackageOwner{ owner = "dlang", name = "dub" }
dscannerArguments = PackageOwner{ owner = "dlang-community", name = "D-Scanner" }
dcdArguments = PackageOwner{ owner = "dlang-community", name = "DCD" }
latestDub = latestGitHub dubArguments pure
latestDscanner = latestGitHub dscannerArguments pure
latestDcd = latestGitHub dcdArguments pure
latestDub = latestGitHub dubArguments stableTagTransform
latestDscanner = latestGitHub dscannerArguments stableTagTransform
latestDcd = latestGitHub dcdArguments stableTagTransform
dubTemplate = Package.DownloadTemplate
$ Package.StaticPlaceholder "https://codeload.github.com/dlang/dub/tar.gz/v"
:| [Package.VersionPlaceholder]
@ -315,17 +315,16 @@ updateDownload Package{..} Package.Updater{..} = do
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)
(uri', checksum) <- fromJust <$> cloneAndUpload (URI.render repo) relativeTarball tagPrefix
pure $ Package.Download
{ md5sum = checksum
, is64 = False
, download = uri'
}
downloadWithTemplate :: Package.DownloadTemplate -> Bool -> Text -> Text -> SlackBuilderT Package.Download
downloadWithTemplate downloadTemplate is64' packagePath version = do
@ -345,7 +344,7 @@ reuploadWithTemplate downloadTemplate commands packagePath version = do
let downloadFileName = URI.unRText
$ NonEmpty.last $ snd $ fromJust $ URI.uriPath uri'
relativeTarball = packagePath <> "/" <> downloadFileName
download' <- handleReupload relativeTarball downloadFileName
download' <- handleReupload (Text.unpack relativeTarball) downloadFileName
pure $ Package.Download download' checksum False
where
@ -355,14 +354,14 @@ reuploadWithTemplate downloadTemplate commands packagePath version = do
case commands of
[] -> uploadTarball relativeTarball downloadFileName
_ ->
let tarballPath = repository' </> Text.unpack relativeTarball
let tarballPath = repository' </> 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)
= liftIO (putStrLn $ "Upload the source tarball " <> relativeTarball)
>> uploadCommand relativeTarball ("/" <> name')
>> liftIO (mkURI $ "https://download.dlackware.com/hosted-sources/" <> name' <> "/" <> downloadFileName)
defaultCreateProcess cwd' cmdSpec

View File

@ -46,6 +46,7 @@ import qualified Data.Aeson.KeyMap as KeyMap
import GHC.Records (HasField(..))
import Control.Monad.Trans.Reader (asks)
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad ((>=>))
data PackageOwner = PackageOwner
{ owner :: Text
@ -55,7 +56,11 @@ data PackageOwner = PackageOwner
-- | Removes the leading "v" from the version string and returns the result if
-- it looks like a version.
stableTagTransform :: Text -> Maybe Text
stableTagTransform = Text.stripPrefix "v"
stableTagTransform = Text.stripPrefix "v" >=> checkForStable
where
checkForStable tag
| '-' `Text.elem` tag = Nothing
| otherwise = Just tag
-- * Packagist