diff --git a/Cabal/src/Distribution/Simple/Program/Run.hs b/Cabal/src/Distribution/Simple/Program/Run.hs index 88afef0af91..c5839b6e0d0 100644 --- a/Cabal/src/Distribution/Simple/Program/Run.hs +++ b/Cabal/src/Distribution/Simple/Program/Run.hs @@ -61,6 +61,7 @@ data ProgramInvocation = ProgramInvocation , progInvokeInputEncoding :: IOEncoding -- ^ TODO: remove this, make user decide when constructing 'progInvokeInput'. , progInvokeOutputEncoding :: IOEncoding + , progInvokeWhen :: IO Bool } data IOEncoding @@ -82,6 +83,7 @@ emptyProgramInvocation = , progInvokeInput = Nothing , progInvokeInputEncoding = IOEncodingText , progInvokeOutputEncoding = IOEncodingText + , progInvokeWhen = pure True } simpleProgramInvocation diff --git a/cabal-install/src/Distribution/Client/VCS.hs b/cabal-install/src/Distribution/Client/VCS.hs index 029e190a790..e9ad52a2e10 100644 --- a/cabal-install/src/Distribution/Client/VCS.hs +++ b/cabal-install/src/Distribution/Client/VCS.hs @@ -96,6 +96,7 @@ import qualified Data.List as List import qualified Data.Map as Map import System.Directory ( doesDirectoryExist + , doesFileExist , removeDirectoryRecursive , removePathForcibly ) @@ -468,11 +469,18 @@ vcsGit = [programInvocation prog cloneArgs] -- And if there's a tag, we have to do that in a second step: ++ [git (resetArgs tag) | tag <- maybeToList (srpTag repo)] - ++ [ git (["submodule", "sync", "--recursive"] ++ verboseArg) - , git (["submodule", "update", "--init", "--force", "--recursive"] ++ verboseArg) + ++ [ whenGitModulesExists $ git $ ["submodule", "sync", "--recursive"] ++ verboseArg + , whenGitModulesExists $ git $ ["submodule", "update", "--init", "--force", "--recursive"] ++ verboseArg ] where git args = (programInvocation prog args){progInvokeCwd = Just destdir} + + gitModulesPath = destdir ".gitmodules" + whenGitModulesExists invocation = + invocation + { progInvokeWhen = doesFileExist gitModulesPath + } + cloneArgs = ["clone", srcuri, destdir] ++ branchArgs @@ -516,29 +524,38 @@ vcsGit = -- is needed because sometimes `git submodule sync` does not actually -- update the submodule source URL. Detailed description here: -- https://git.coop/-/snippets/85 - git localDir ["submodule", "deinit", "--force", "--all"] - let gitModulesDir = localDir ".git" "modules" - gitModulesExists <- doesDirectoryExist gitModulesDir - when gitModulesExists $ + let dotGitModulesPath = localDir ".git" "modules" + gitModulesPath = localDir ".gitmodules" + + -- Remove any `.git/modules` if they exist. + dotGitModulesExists <- doesDirectoryExist dotGitModulesPath + when dotGitModulesExists $ do + git localDir $ ["submodule", "deinit", "--force", "--all"] ++ verboseArg if buildOS == Windows then do -- Windows can't delete some git files #10182 void $ Process.createProcess_ "attrib" $ Process.shell $ - "attrib -s -h -r " <> gitModulesDir <> "\\*.* /s /d" + "attrib -s -h -r " <> dotGitModulesPath <> "\\*.* /s /d" catch - (removePathForcibly gitModulesDir) - (\e -> if isPermissionError e then removePathForcibly gitModulesDir else throw e) - else removeDirectoryRecursive gitModulesDir + (removePathForcibly dotGitModulesPath) + (\e -> if isPermissionError e then removePathForcibly dotGitModulesPath else throw e) + else removeDirectoryRecursive dotGitModulesPath + when (resetTarget /= "HEAD") $ do git localDir fetchArgs -- first fetch the tag if needed git localDir setTagArgs git localDir resetArgs -- only then reset to the commit - git localDir $ ["submodule", "sync", "--recursive"] ++ verboseArg - git localDir $ ["submodule", "update", "--force", "--init", "--recursive"] ++ verboseArg - git localDir $ ["submodule", "foreach", "--recursive"] ++ verboseArg ++ ["git clean -ffxdq"] + + -- We need to check if `.gitmodules` exists _after_ the `git reset` call. + gitModulesExists <- doesFileExist gitModulesPath + when gitModulesExists $ do + git localDir $ ["submodule", "sync", "--recursive"] ++ verboseArg + git localDir $ ["submodule", "update", "--force", "--init", "--recursive"] ++ verboseArg + git localDir $ ["submodule", "foreach", "--recursive"] ++ verboseArg ++ ["git clean -ffxdq"] + git localDir $ ["clean", "-ffxdq"] where git :: FilePath -> [String] -> IO () diff --git a/cabal-install/tests/UnitTests/Distribution/Client/VCS.hs b/cabal-install/tests/UnitTests/Distribution/Client/VCS.hs index a76dd39b082..496e83a975f 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/VCS.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/VCS.hs @@ -874,10 +874,7 @@ vcsTestDriverGit verbosity vcs submoduleDir repoRoot = , vcsSubmoduleDriver = pure . vcsTestDriverGit verbosity vcs' submoduleDir . (submoduleDir ) , vcsAddSubmodule = \_ source dest -> do - destExists <- - (||) - <$> doesFileExist (repoRoot dest) - <*> doesDirectoryExist (repoRoot dest) + destExists <- doesPathExist $ repoRoot dest when destExists $ git ["rm", "-f", dest] -- If there is an old submodule git dir with the same name, remove it. -- It most likely has a different URL and `git submodule add` will fai. @@ -923,15 +920,22 @@ vcsTestDriverGit verbosity vcs submoduleDir repoRoot = git' = getProgramInvocationOutput verbosity . gitInvocation verboseArg = ["--quiet" | verbosity < Verbosity.normal] submoduleGitDir path = repoRoot ".git" "modules" path + + dotGitModulesPath = repoRoot ".git" "modules" + gitModulesPath = repoRoot ".gitmodules" + deinitAndRemoveCachedSubmodules = do - git $ ["submodule", "deinit", "--force", "--all"] ++ verboseArg - let gitModulesDir = repoRoot ".git" "modules" - gitModulesExists <- doesDirectoryExist gitModulesDir - when gitModulesExists $ removeDirectoryRecursive gitModulesDir + dotGitModulesExists <- doesDirectoryExist dotGitModulesPath + when dotGitModulesExists $ do + git $ ["submodule", "deinit", "--force", "--all"] ++ verboseArg + removeDirectoryRecursive dotGitModulesPath + updateSubmodulesAndCleanup = do - git $ ["submodule", "sync", "--recursive"] ++ verboseArg - git $ ["submodule", "update", "--init", "--recursive", "--force"] ++ verboseArg - git $ ["submodule", "foreach", "--recursive"] ++ verboseArg ++ ["git clean -ffxdq"] + gitModulesExists <- doesFileExist gitModulesPath + when gitModulesExists $ do + git $ ["submodule", "sync", "--recursive"] ++ verboseArg + git $ ["submodule", "update", "--init", "--recursive", "--force"] ++ verboseArg + git $ ["submodule", "foreach", "--recursive", "git clean -ffxdq"] ++ verboseArg git $ ["clean", "-ffxdq"] ++ verboseArg type MTimeChange = Int