From 30f2bd2d65c144f53e3485cdb4020bd428c9d6a3 Mon Sep 17 00:00:00 2001
From: noiioiu <151288161+noiioiu@users.noreply.github.com>
Date: Tue, 5 Nov 2024 21:33:21 -0600
Subject: [PATCH] Catch exception if git is not installed (#10486)
* Catch exception if git is not installed
* fix formatting
* change type from IO to m
* add maybeReadProcessWithExitCode
* use maybeReadProcessWithExitCode
* disambiguate P.catch
* add TypeApplications pragma
* add missing arguments
* Add changelog entry
* Add test for `cabal init` when `git` is not installed
* Remove withSourceCopyDir from test
* Remove withSourceCopyDir from test
* Remove configure and build from test
* Remove assert
* Skip test on windows
---------
Co-authored-by: noiioiu <noiioiu@cocaine.ninja>
(cherry picked from commit e7bc62be2ed8abbf80431f25a675c38eda786401)
---
.../Client/Init/NonInteractive/Heuristics.hs | 22 +++++++++----------
.../src/Distribution/Client/Init/Types.hs | 4 ++++
.../PackageTests/Init/init-without-git.out | 1 +
.../Init/init-without-git.test.hs | 22 +++++++++++++++++++
changelog.d/pr-10486 | 12 ++++++++++
5 files changed, 50 insertions(+), 11 deletions(-)
create mode 100644 cabal-testsuite/PackageTests/Init/init-without-git.out
create mode 100644 cabal-testsuite/PackageTests/Init/init-without-git.test.hs
create mode 100644 changelog.d/pr-10486
diff --git a/cabal-install/src/Distribution/Client/Init/NonInteractive/Heuristics.hs b/cabal-install/src/Distribution/Client/Init/NonInteractive/Heuristics.hs
index 138f968455..e6838aa2e4 100644
--- a/cabal-install/src/Distribution/Client/Init/NonInteractive/Heuristics.hs
+++ b/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)
diff --git a/cabal-install/src/Distribution/Client/Init/Types.hs b/cabal-install/src/Distribution/Client/Init/Types.hs
index 0887cb54a7..8da7ba2b52 100644
--- a/cabal-install/src/Distribution/Client/Init/Types.hs
+++ b/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
diff --git a/cabal-testsuite/PackageTests/Init/init-without-git.out b/cabal-testsuite/PackageTests/Init/init-without-git.out
new file mode 100644
index 0000000000..9a143a9375
--- /dev/null
+++ b/cabal-testsuite/PackageTests/Init/init-without-git.out
@@ -0,0 +1 @@
+# cabal init
diff --git a/cabal-testsuite/PackageTests/Init/init-without-git.test.hs b/cabal-testsuite/PackageTests/Init/init-without-git.test.hs
new file mode 100644
index 0000000000..4c98f751c5
--- /dev/null
+++ b/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"
diff --git a/changelog.d/pr-10486 b/changelog.d/pr-10486
new file mode 100644
index 0000000000..237d2c857b
--- /dev/null
+++ b/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.
+
+}
--
GitLab