Merge pull request #10590 from 9999years/vcs-submodules

VCS: Don't run submodule commands unless necessary

Author: mergify[bot]

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

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
@@ -518,22 +526,25 @@ 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"] ++ verboseArg
-      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
 
       -- If we want a particular branch or tag, fetch it.
       ref <- case srpBranch `mplus` srpTag of
@@ -581,9 +592,13 @@ vcsGit =
              , "--"
              ]
 
-      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 ()

cabal-install/tests/UnitTests/Distribution/Client/VCS.hs

@@ -923,10 +923,7 @@ vcsTestDriverGit
                   , mkVcsTmpDir = tmpDir
                   }
       , vcsAddSubmodule = \_ source dest -> do
-          destExists <-
-            (||)
-              <$> doesFileExist (repoRoot </> dest)
-              <*> doesDirectoryExist (repoRoot </> dest)
+          destExists <- doesPathExist $ repoRoot </> dest
           when destExists $ gitQuiet ["rm", "--force", 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.
@@ -995,16 +992,23 @@ vcsTestDriverGit
       verboseArg = ["--quiet" | verbosity < Verbosity.normal]
 
       submoduleGitDir path = repoRoot </> ".git" </> "modules" </> path
+
+      dotGitModulesPath = repoRoot </> ".git" </> "modules"
+      gitModulesPath = repoRoot </> ".gitmodules"
+
       deinitAndRemoveCachedSubmodules = do
-        gitQuiet ["submodule", "deinit", "--force", "--all"]
-        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
-        gitQuiet ["submodule", "sync", "--recursive"]
-        gitQuiet ["submodule", "update", "--init", "--recursive", "--force"]
-        -- Note: We need to manually add `verboseArg` here so that the embedded `git clean` command includes it as well.
-        gitQuiet $ ["submodule", "foreach", "--recursive", "git clean -ffxdq"] ++ verboseArg
+        gitModulesExists <- doesFileExist gitModulesPath
+        when gitModulesExists $ do
+          gitQuiet ["submodule", "sync", "--recursive"]
+          gitQuiet ["submodule", "update", "--init", "--recursive", "--force"]
+          -- Note: We need to manually add `verboseArg` here so that the embedded `git clean` command includes it as well.
+          gitQuiet $ ["submodule", "foreach", "--recursive", "git clean -ffxdq"] ++ verboseArg
         gitQuiet ["clean", "-ffxdq"]
 
 type MTimeChange = Int

changelog.d/pr-10590

@@ -0,0 +1,14 @@
+---
+synopsis: "Don't run submodule commands unless necessary"
+packages: [cabal-install]
+prs: 10590
+---
+
+When `cabal` clones a Git repo for a `source-repository-package` listed in a
+`cabal.project`, it will run various commands to check out the correct
+revision, initialize submodules if they're present, and so on.
+
+Now, `cabal` will avoid running `git submodule` commands unless the cloned
+repository contains a `.gitmodules` file. This will declutter `cabal`'s debug
+output by running fewer commands.
+