diff --git a/cabal-install/src/Distribution/Client/Init/NonInteractive/Heuristics.hs b/cabal-install/src/Distribution/Client/Init/NonInteractive/Heuristics.hs index 138f9684553..e6838aa2e45 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 ee7d7cbe0c3..3e4566a1302 100644 --- a/cabal-install/src/Distribution/Client/Init/Types.hs +++ b/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 @@ 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] @@ -357,6 +359,7 @@ instance Interactive IO where listFilesInside = P.listFilesInside listFilesRecursive = P.listFilesRecursive +<<<<<<< HEAD putStr = P.putStr putStrLn = P.putStrLn createDirectory = P.createDirectory @@ -366,6 +369,44 @@ instance Interactive IO where 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 @@ 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 00000000000..9a143a9375c --- /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 00000000000..4c98f751c57 --- /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 00000000000..237d2c857b0 --- /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. + +}