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

@@ -2,6 +2,7 @@
 {-# LANGUAGE DeriveFunctor #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE TypeApplications #-}
 
 -- |
 -- Module      :  Distribution.Client.Init.Types
@@ -320,6 +321,7 @@
   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]
@@ -357,6 +359,7 @@
   listFilesInside = P.listFilesInside
   listFilesRecursive = P.listFilesRecursive
 
+<<<<<<< HEAD
   putStr = P.putStr
   putStrLn = P.putStrLn
   createDirectory = P.createDirectory
@@ -366,6 +369,44 @@
   copyFile = P.copyFile
   renameDirectory = P.renameDirectory
   hFlush = System.IO.hFlush
+=======
+newtype SessionState = SessionState
+  { lastChosenLanguage :: (Maybe String)
+  }
+
+newSessionState :: SessionState
+newSessionState = SessionState{lastChosenLanguage = Nothing}
+
+instance Interactive PromptIO where
+  getLine = liftIO P.getLine
+  readFile = liftIO <$> P.readFile
+  getCurrentDirectory = liftIO P.getCurrentDirectory
+  getHomeDirectory = liftIO P.getHomeDirectory
+  getDirectoryContents = liftIO <$> P.getDirectoryContents
+  listDirectory = liftIO <$> P.listDirectory
+  doesDirectoryExist = liftIO <$> P.doesDirectoryExist
+  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
+    -- test is run within a new env and not the current env
+    -- all usages of listFilesInside are pure functions actually
+    liftIO $ P.listFilesInside (\f -> liftIO $ runPromptIO (test f)) dir
+  listFilesRecursive = liftIO <$> P.listFilesRecursive
+
+  putStr = liftIO <$> P.putStr
+  putStrLn = liftIO <$> P.putStrLn
+  createDirectory = liftIO <$> P.createDirectory
+  removeDirectory = liftIO <$> P.removeDirectoryRecursive
+  writeFile a b = liftIO $ P.writeFile a b
+  removeExistingFile = liftIO <$> P.removeExistingFile
+  copyFile a b = liftIO $ P.copyFile a b
+  renameDirectory a b = liftIO $ P.renameDirectory a b
+  hFlush = liftIO <$> System.IO.hFlush
+>>>>>>> e7bc62be2 (Catch exception if git is not installed (#10486))
   message q severity msg
     | q == silent = pure ()
     | otherwise = putStrLn $ "[" ++ displaySeverity severity ++ "] " ++ msg
@@ -387,6 +428,7 @@
   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.
+
+}