Use consistent directory for cloning repositories

... with submodules.
2024-01-04 09:36:11 +01:00
parent a25655c2b2
commit 7edb811dc2
4 changed files with 75 additions and 62 deletions
--- a/lib/SlackBuilder/Download.hs
+++ b/lib/SlackBuilder/Download.hs
@@ -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"
-        [ "-C"
-        , nameVersion'
-        , "checkout"
-        , Text.unpack $ tagPrefix <> version
-        ]
-    liftIO $ callProcess "git"
-        [ "-C"
-        , nameVersion'
-        , "submodule"
-        , "update"
-        , "--init"
-        , "--recursive"
-        ]
-
-    liftIO $ callProcess "tar"
-        [ "Jcvf"
-        , repository' </> tarball
-        , nameVersion'
-        ]
-    liftIO $ callProcess "rm" ["-rf", nameVersion']
+    repositoryTarballPath <- relativeToRepository tarballPath
+    repositoryArchivePath <- relativeToRepository $ tarballPath <.> "tar.xz"
+    liftIO
+        $ callProcess "rm" ["-rf", repositoryTarballPath]
+        >> callProcess "git"
+            [ "clone"
+            , Text.unpack repo
+            , repositoryTarballPath
+            ]
+        >> callProcess "git"
+            [ "-C"
+            , repositoryTarballPath
+            , "checkout"
+            , Text.unpack $ tagPrefix <> version
+            ]
+        >> callProcess "git"
+            [ "-C"
+            , repositoryTarballPath
+            , "submodule"
+            , "update"
+            , "--init"
+            , "--recursive"
+            ]
+        >> callProcess "tar"
+            ["Jcvf"
+            , repositoryArchivePath
+            , repositoryTarballPath
+            ]
+        >> 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,)
--- a/lib/SlackBuilder/Trans.hs
+++ b/lib/SlackBuilder/Trans.hs
@@ -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
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -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
--- a/src/SlackBuilder/LatestVersionCheck.hs
+++ b/src/SlackBuilder/LatestVersionCheck.hs
@@ -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