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

View File

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

View File

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

View File

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