Merge pull request #10531 from haskell/mergify/bp/3.14/pr-10486

Backport #10486: Catch exception if git is not installed

cabal-install/src/Distribution/Client/Init/NonInteractive/Heuristics.hs

@@ -165,14 +165,14 @@ guessAuthorEmail = guessGitInfo "user.email"
 
 guessGitInfo :: Interactive m => String -> m (Maybe String)
 guessGitInfo target = do
-  localInfo <- readProcessWithExitCode "git" ["config", "--local", target] ""
-  if null $ snd' localInfo
-    then do
-      globalInfo <- readProcessWithExitCode "git" ["config", "--global", target] ""
-      case fst' globalInfo of
-        ExitSuccess -> return $ Just (trim $ snd' globalInfo)
-        _ -> return Nothing
-    else return $ Just (trim $ snd' localInfo)
-  where
-    fst' (x, _, _) = x
-    snd' (_, x, _) = x
+  localInfo <- maybeReadProcessWithExitCode "git" ["config", "--local", target] ""
+  case localInfo of
+    Nothing -> return Nothing
+    Just (_, localStdout, _) ->
+      if null localStdout
+        then do
+          globalInfo <- maybeReadProcessWithExitCode "git" ["config", "--global", target] ""
+          case globalInfo of
+            Just (ExitSuccess, globalStdout, _) -> return $ Just (trim globalStdout)
+            _ -> return Nothing
+        else return $ Just (trim localStdout)

cabal-install/src/Distribution/Client/Init/Types.hs

@@ -3,6 +3,7 @@
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE TypeApplications #-}
 
 -- |
 -- Module      :  Distribution.Client.Init.Types
@@ -346,6 +347,7 @@ class Monad m => Interactive m where
   doesFileExist :: FilePath -> m Bool
   canonicalizePathNoThrow :: FilePath -> m FilePath
   readProcessWithExitCode :: FilePath -> [String] -> String -> m (ExitCode, String, String)
+  maybeReadProcessWithExitCode :: FilePath -> [String] -> String -> m (Maybe (ExitCode, String, String))
   getEnvironment :: m [(String, String)]
   getCurrentYear :: m Integer
   listFilesInside :: (FilePath -> m Bool) -> FilePath -> m [FilePath]
@@ -389,6 +391,7 @@ instance Interactive PromptIO where
   doesFileExist = liftIO <$> P.doesFileExist
   canonicalizePathNoThrow = liftIO <$> P.canonicalizePathNoThrow
   readProcessWithExitCode a b c = liftIO $ Process.readProcessWithExitCode a b c
+  maybeReadProcessWithExitCode a b c = liftIO $ (Just <$> Process.readProcessWithExitCode a b c) `P.catch` const @_ @IOError (pure Nothing)
   getEnvironment = liftIO P.getEnvironment
   getCurrentYear = liftIO P.getCurrentYear
   listFilesInside test dir = do
@@ -438,6 +441,7 @@ instance Interactive PurePrompt where
   readProcessWithExitCode !_ !_ !_ = do
     input <- pop
     return (ExitSuccess, input, "")
+  maybeReadProcessWithExitCode a b c = Just <$> readProcessWithExitCode a b c
   getEnvironment = fmap (map read) popList
   getCurrentYear = fmap read pop
   listFilesInside pred' !_ = do

cabal-testsuite/PackageTests/Init/init-without-git.out

@@ -0,0 +1 @@
+# cabal init

cabal-testsuite/PackageTests/Init/init-without-git.test.hs

@@ -0,0 +1,22 @@
+import Test.Cabal.Prelude
+import System.Directory
+import System.FilePath
+import Distribution.Simple.Utils
+import Distribution.Verbosity
+
+-- Test cabal init when git is not installed
+main = do
+  skipIfWindows "Might fail on windows."
+  tmp <- getTemporaryDirectory
+  withTempDirectory normal tmp "bin" $
+    \bin -> cabalTest $
+      do
+        ghc_path <- programPathM ghcProgram
+        cabal_path <- programPathM cabalProgram
+        withSymlink ghc_path (bin </> "ghc") . withSymlink cabal_path (bin </> "cabal") .
+          withEnv [("PATH", Just bin)] $ do
+            cwd <- fmap testSourceCopyDir getTestEnv
+
+            void . withDirectory cwd $ do
+              cabalWithStdin "init" ["-i"]
+                "2\n\n5\n\n\n2\n\n\n\n\n\n\n\n\n\n"

changelog.d/pr-10486

@@ -0,0 +1,12 @@
+synopsis: Fix a bug that causes `cabal init` to crash if `git` is not installed
+packages: cabal-install
+prs: #10486
+issues: #10484 #8478
+significance:
+
+description: {
+
+- `cabal init` tries to use `git config` to guess the user's name and email.
+  It no longer crashes if there is no executable named `git` on $PATH.
+
+}