From d8ebb8146f36ad0809c93940e888fda88dd329e1 Mon Sep 17 00:00:00 2001 From: Matthew Pickering Date: Mon, 6 Nov 2023 11:01:34 +0000 Subject: [PATCH] Finish off the external commands feature * Remove 'CommandDelegate' in favour of abstracting the fallback in 'commandsRun', there is a new variant 'commdandRunWithFallback' which takes a continuation - This restores the modularity between the `Cabal` library and `cabal-install` as now `Cabal` doesn't need to know anything about the external command interface. - Fixes #9403 * Set the $CABAL environment variable to the current executable path - This allows external commands to be implemented by calling $CABAL, which is strongly preferred to linking against the Cabal library as there is no easy way to guantee your tool and `cabal-install` link against the same `Cabal` library. - Fixes #9402 * Pass the name of the argument - This allows external commands to be implemented as symlinks to an executable, and multiple commands can be interpreted by the same executable. - Fixes #9405 * `cabal help ` is interpreted as `cabal- --help` for external commands. - This allows the `help` command to also work for external commands and hence they are better integrated into cabal-install. - Fixes #9404 The tests are updated to test all these additions. These features bring the external command interface up to par with the cargo external command interface. --- Cabal/src/Distribution/Make.hs | 2 - Cabal/src/Distribution/Simple.hs | 2 - Cabal/src/Distribution/Simple/Command.hs | 102 +++++++++++---------- cabal-install/src/Distribution/Client/Main.hs | 33 ++++++- .../src/Distribution/Client/SavedFlags.hs | 1 - .../PackageTests/ExternalCommand/cabal.test.hs | 20 +++- .../ExternalCommand/setup-test/AAAA.hs | 5 +- .../PackageTests/ExternalCommandEnv/cabal.test.hs | 9 +- .../PackageTests/ExternalCommandHelp/cabal.out | 4 - .../PackageTests/ExternalCommandHelp/cabal.test.hs | 8 +- .../ExternalCommandHelp/setup-test/AAAA.hs | 2 +- .../ExternalCommandSetup/setup.cabal.hs | 11 +-- .../PackageTests/ExternalCommandSetup/setup.out | 35 +++---- cabal-testsuite/src/Test/Cabal/Prelude.hs | 16 +++- doc/external-commands.rst | 30 ++++-- 15 files changed, 158 insertions(+), 122 deletions(-) rewrite cabal-testsuite/PackageTests/ExternalCommandSetup/setup.out (65%) rewrite doc/external-commands.rst (63%) diff --git a/Cabal/src/Distribution/Make.hs b/Cabal/src/Distribution/Make.hs index aaa63a94b..82334d550 100644 --- a/Cabal/src/Distribution/Make.hs +++ b/Cabal/src/Distribution/Make.hs @@ -91,7 +91,6 @@ defaultMainHelper :: [String] -> IO () defaultMainHelper args = do command <- commandsRun (globalCommand commands) commands args case command of - CommandDelegate -> pure () CommandHelp help -> printHelp help CommandList opts -> printOptionsList opts CommandErrors errs -> printErrors errs @@ -100,7 +99,6 @@ defaultMainHelper args = do _ | fromFlag (globalVersion flags) -> printVersion | fromFlag (globalNumericVersion flags) -> printNumericVersion - CommandDelegate -> pure () CommandHelp help -> printHelp help CommandList opts -> printOptionsList opts CommandErrors errs -> printErrors errs diff --git a/Cabal/src/Distribution/Simple.hs b/Cabal/src/Distribution/Simple.hs index 0649a0852..c52a02c0f 100644 --- a/Cabal/src/Distribution/Simple.hs +++ b/Cabal/src/Distribution/Simple.hs @@ -170,7 +170,6 @@ defaultMainHelper hooks args = topHandler $ do args' <- expandResponse args command <- commandsRun (globalCommand commands) commands args' case command of - CommandDelegate -> pure () CommandHelp help -> printHelp help CommandList opts -> printOptionsList opts CommandErrors errs -> printErrors errs @@ -179,7 +178,6 @@ defaultMainHelper hooks args = topHandler $ do _ | fromFlag (globalVersion flags) -> printVersion | fromFlag (globalNumericVersion flags) -> printNumericVersion - CommandDelegate -> pure () CommandHelp help -> printHelp help CommandList opts -> printOptionsList opts CommandErrors errs -> printErrors errs diff --git a/Cabal/src/Distribution/Simple/Command.hs b/Cabal/src/Distribution/Simple/Command.hs index dc2be1a69..2da6486cb 100644 --- a/Cabal/src/Distribution/Simple/Command.hs +++ b/Cabal/src/Distribution/Simple/Command.hs @@ -47,6 +47,8 @@ module Distribution.Simple.Command -- ** Running commands , commandsRun + , commandsRunWithFallback + , defaultCommandFallback -- * Option Fields , OptionField (..) @@ -85,15 +87,12 @@ module Distribution.Simple.Command import Distribution.Compat.Prelude hiding (get) import Prelude () -import Control.Exception (try) import qualified Data.Array as Array import qualified Data.List as List import Distribution.Compat.Lens (ALens', (#~), (^#)) import qualified Distribution.GetOpt as GetOpt import Distribution.ReadE import Distribution.Simple.Utils -import System.Directory (findExecutable) -import System.Process (callProcess) data CommandUI flags = CommandUI { commandName :: String @@ -599,13 +598,11 @@ data CommandParse flags | CommandList [String] | CommandErrors [String] | CommandReadyToGo flags - | CommandDelegate instance Functor CommandParse where fmap _ (CommandHelp help) = CommandHelp help fmap _ (CommandList opts) = CommandList opts fmap _ (CommandErrors errs) = CommandErrors errs fmap f (CommandReadyToGo flags) = CommandReadyToGo (f flags) - fmap _ CommandDelegate = CommandDelegate data CommandType = NormalCommand | HiddenCommand data Command action @@ -632,27 +629,62 @@ commandAddAction command action = let flags = mkflags (commandDefaultFlags command) in action flags args +-- Print suggested command if edit distance is < 5 +badCommand :: [Command action] -> String -> CommandParse a +badCommand commands' cname = + case eDists of + [] -> CommandErrors [unErr] + (s : _) -> + CommandErrors + [ unErr + , "Maybe you meant `" ++ s ++ "`?\n" + ] + where + eDists = + map fst . List.sortBy (comparing snd) $ + [ (cname', dist) + | -- Note that this is not commandNames, so close suggestions will show + -- hidden commands + (Command cname' _ _ _) <- commands' + , let dist = editDistance cname' cname + , dist < 5 + ] + unErr = "unrecognised command: " ++ cname ++ " (try --help)" + commandsRun :: CommandUI a -> [Command action] -> [String] -> IO (CommandParse (a, CommandParse action)) commandsRun globalCommand commands args = + commandsRunWithFallback globalCommand commands defaultCommandFallback args + +defaultCommandFallback + :: [Command action] + -> String + -> [String] + -> IO (CommandParse action) +defaultCommandFallback commands' name _cmdArgs = pure $ badCommand commands' name + +commandsRunWithFallback + :: CommandUI a + -> [Command action] + -> ([Command action] -> String -> [String] -> IO (CommandParse action)) + -> [String] + -> IO (CommandParse (a, CommandParse action)) +commandsRunWithFallback globalCommand commands defaultCommand args = case commandParseArgs globalCommand True args of - CommandDelegate -> pure CommandDelegate CommandHelp help -> pure $ CommandHelp help CommandList opts -> pure $ CommandList (opts ++ commandNames) CommandErrors errs -> pure $ CommandErrors errs CommandReadyToGo (mkflags, args') -> case args' of - ("help" : cmdArgs) -> pure $ handleHelpCommand cmdArgs + ("help" : cmdArgs) -> handleHelpCommand flags cmdArgs (name : cmdArgs) -> case lookupCommand name of [Command _ _ action _] -> pure $ CommandReadyToGo (flags, action cmdArgs) _ -> do - mCommand <- findExecutable $ "cabal-" <> name - case mCommand of - Just exec -> callExternal flags exec cmdArgs - Nothing -> pure $ CommandReadyToGo (flags, badCommand name) + final_cmd <- defaultCommand commands' name cmdArgs + return $ CommandReadyToGo (flags, final_cmd) [] -> pure $ CommandReadyToGo (flags, noCommand) where flags = mkflags (commandDefaultFlags globalCommand) @@ -661,55 +693,29 @@ commandsRun globalCommand commands args = [ cmd | cmd@(Command cname' _ _ _) <- commands', cname' == cname ] - callExternal :: a -> String -> [String] -> IO (CommandParse (a, CommandParse action)) - callExternal flags exec cmdArgs = do - result <- try $ callProcess exec cmdArgs - case result of - Left ex -> pure $ CommandErrors ["Error executing external command: " ++ show (ex :: SomeException)] - Right _ -> pure $ CommandReadyToGo (flags, CommandDelegate) - noCommand = CommandErrors ["no command given (try --help)\n"] - -- Print suggested command if edit distance is < 5 - badCommand :: String -> CommandParse a - badCommand cname = - case eDists of - [] -> CommandErrors [unErr] - (s : _) -> - CommandErrors - [ unErr - , "Maybe you meant `" ++ s ++ "`?\n" - ] - where - eDists = - map fst . List.sortBy (comparing snd) $ - [ (cname', dist) - | (Command cname' _ _ _) <- commands' - , let dist = editDistance cname' cname - , dist < 5 - ] - unErr = "unrecognised command: " ++ cname ++ " (try --help)" - commands' = commands ++ [commandAddAction helpCommandUI undefined] commandNames = [name | (Command name _ _ NormalCommand) <- commands'] -- A bit of a hack: support "prog help" as a synonym of "prog --help" -- furthermore, support "prog help command" as "prog command --help" - handleHelpCommand cmdArgs = + handleHelpCommand flags cmdArgs = case commandParseArgs helpCommandUI True cmdArgs of - CommandDelegate -> CommandDelegate - CommandHelp help -> CommandHelp help - CommandList list -> CommandList (list ++ commandNames) - CommandErrors _ -> CommandHelp globalHelp - CommandReadyToGo (_, []) -> CommandHelp globalHelp + CommandHelp help -> pure $ CommandHelp help + CommandList list -> pure $ CommandList (list ++ commandNames) + CommandErrors _ -> pure $ CommandHelp globalHelp + CommandReadyToGo (_, []) -> pure $ CommandHelp globalHelp CommandReadyToGo (_, (name : cmdArgs')) -> case lookupCommand name of [Command _ _ action _] -> case action ("--help" : cmdArgs') of - CommandHelp help -> CommandHelp help - CommandList _ -> CommandList [] - _ -> CommandHelp globalHelp - _ -> badCommand name + CommandHelp help -> pure $ CommandHelp help + CommandList _ -> pure $ CommandList [] + _ -> pure $ CommandHelp globalHelp + _ -> do + fall_back <- defaultCommand commands' name ("--help" : cmdArgs') + return $ CommandReadyToGo (flags, fall_back) where globalHelp = commandHelp globalCommand diff --git a/cabal-install/src/Distribution/Client/Main.hs b/cabal-install/src/Distribution/Client/Main.hs index 9114102f2..dc196a668 100644 --- a/cabal-install/src/Distribution/Client/Main.hs +++ b/cabal-install/src/Distribution/Client/Main.hs @@ -205,7 +205,8 @@ import Distribution.Simple.Command , commandAddAction , commandFromSpec , commandShowOptions - , commandsRun + , commandsRunWithFallback + , defaultCommandFallback , hiddenCommand ) import Distribution.Simple.Compiler (PackageDBStack) @@ -221,6 +222,8 @@ import Distribution.Simple.PackageDescription (readGenericPackageDescription) import Distribution.Simple.Program ( configureAllKnownPrograms , defaultProgramDb + , defaultProgramSearchPath + , findProgramOnSearchPath , getProgramInvocationOutput , simpleProgramInvocation ) @@ -261,7 +264,7 @@ import System.Directory , getCurrentDirectory , withCurrentDirectory ) -import System.Environment (getProgName) +import System.Environment (getEnvironment, getExecutablePath, getProgName) import System.FilePath ( dropExtension , splitExtension @@ -276,6 +279,7 @@ import System.IO , stderr , stdout ) +import System.Process (createProcess, env, proc) -- | Entry point -- @@ -334,9 +338,8 @@ warnIfAssertionsAreEnabled = mainWorker :: [String] -> IO () mainWorker args = do topHandler $ do - command <- commandsRun (globalCommand commands) commands args + command <- commandsRunWithFallback (globalCommand commands) commands delegateToExternal args case command of - CommandDelegate -> pure () CommandHelp help -> printGlobalHelp help CommandList opts -> printOptionsList opts CommandErrors errs -> printErrors errs @@ -347,7 +350,6 @@ mainWorker args = do printVersion | fromFlagOrDefault False (globalNumericVersion globalFlags) -> printNumericVersion - CommandDelegate -> pure () CommandHelp help -> printCommandHelp help CommandList opts -> printOptionsList opts CommandErrors errs -> do @@ -366,6 +368,27 @@ mainWorker args = do warnIfAssertionsAreEnabled action globalFlags where + delegateToExternal + :: [Command Action] + -> String + -> [String] + -> IO (CommandParse Action) + delegateToExternal commands' name cmdArgs = do + mCommand <- findProgramOnSearchPath normal defaultProgramSearchPath ("cabal-" <> name) + case mCommand of + Just (exec, _) -> return (CommandReadyToGo $ \_ -> callExternal exec name cmdArgs) + Nothing -> defaultCommandFallback commands' name cmdArgs + + callExternal :: String -> String -> [String] -> IO () + callExternal exec name cmdArgs = do + cur_env <- getEnvironment + cabal_exe <- getExecutablePath + let new_env = ("CABAL", cabal_exe) : cur_env + result <- try $ createProcess ((proc exec (name : cmdArgs)){env = Just new_env}) + case result of + Left ex -> printErrors ["Error executing external command: " ++ show (ex :: SomeException)] + Right _ -> return () + printCommandHelp help = do pname <- getProgName putStr (help pname) diff --git a/cabal-install/src/Distribution/Client/SavedFlags.hs b/cabal-install/src/Distribution/Client/SavedFlags.hs index 5fa417a85..1a598a58f 100644 --- a/cabal-install/src/Distribution/Client/SavedFlags.hs +++ b/cabal-install/src/Distribution/Client/SavedFlags.hs @@ -51,7 +51,6 @@ readCommandFlags :: FilePath -> CommandUI flags -> IO flags readCommandFlags path command = do savedArgs <- fmap (fromMaybe []) (readSavedArgs path) case (commandParseArgs command True savedArgs) of - CommandDelegate -> error "CommandDelegate Flags evaluated, this should never occur" CommandHelp _ -> throwIO (SavedArgsErrorHelp savedArgs) CommandList _ -> throwIO (SavedArgsErrorList savedArgs) CommandErrors errs -> throwIO (SavedArgsErrorOther savedArgs errs) diff --git a/cabal-testsuite/PackageTests/ExternalCommand/cabal.test.hs b/cabal-testsuite/PackageTests/ExternalCommand/cabal.test.hs index 850c8bfbc..d9535b605 100644 --- a/cabal-testsuite/PackageTests/ExternalCommand/cabal.test.hs +++ b/cabal-testsuite/PackageTests/ExternalCommand/cabal.test.hs @@ -8,19 +8,29 @@ import qualified Data.Time.Clock as Time import qualified Data.Time.Format as Time import Data.Maybe import System.Environment +import System.FilePath main = do cabalTest $ do res <- cabalWithStdin "v2-build" ["all"] "" exe_path <- withPlan $ planExePath "setup-test" "cabal-aaaa" - env <- getTestEnv - path <- liftIO $ getEnv "PATH" - let newpath = takeDirectory exe_path ++ ":" ++ path - let new_env = (("PATH", Just newpath) : (testEnvironment env)) - withEnv new_env $ do + addToPath (takeDirectory exe_path) $ do + -- Test that the thing works at all res <- cabal_raw_action ["aaaa"] (\h -> () <$ Process.waitForProcess h) assertOutputContains "aaaa" res + -- Test that the extra arguments are passed on + res <- cabal_raw_action ["aaaa", "--foobaz"] (\h -> () <$ Process.waitForProcess h) + assertOutputContains "--foobaz" res + + -- Test what happens with "global" flags + res <- cabal_raw_action ["aaaa", "--version"] (\h -> () <$ Process.waitForProcess h) + assertOutputContains "--version" res + + -- Test what happens with "global" flags + res <- cabal_raw_action ["aaaa", "--config-file", "abc"] (\h -> () <$ Process.waitForProcess h) + assertOutputContains "--config-file" res + cabal_raw_action :: [String] -> (Process.ProcessHandle -> IO ()) -> TestM Result cabal_raw_action args action = do diff --git a/cabal-testsuite/PackageTests/ExternalCommand/setup-test/AAAA.hs b/cabal-testsuite/PackageTests/ExternalCommand/setup-test/AAAA.hs index 5bee0ebbe..c2d121c9a 100644 --- a/cabal-testsuite/PackageTests/ExternalCommand/setup-test/AAAA.hs +++ b/cabal-testsuite/PackageTests/ExternalCommand/setup-test/AAAA.hs @@ -1,4 +1,5 @@ module Main where -main = do - putStrLn "aaaa" +import System.Environment + +main = getArgs >>= print diff --git a/cabal-testsuite/PackageTests/ExternalCommandEnv/cabal.test.hs b/cabal-testsuite/PackageTests/ExternalCommandEnv/cabal.test.hs index 891c9e43d..434407639 100644 --- a/cabal-testsuite/PackageTests/ExternalCommandEnv/cabal.test.hs +++ b/cabal-testsuite/PackageTests/ExternalCommandEnv/cabal.test.hs @@ -10,15 +10,12 @@ import Data.Maybe import System.Environment main = do - cabalTest $ expectBroken 9402 $ do + cabalTest $ do res <- cabalWithStdin "v2-build" ["all"] "" exe_path <- withPlan $ planExePath "setup-test" "cabal-aaaa" env <- getTestEnv - path <- liftIO $ getEnv "PATH" - let newpath = takeDirectory exe_path ++ ":" ++ path - let new_env = (("OTHER_VAR", Just "is set") : ("PATH", Just newpath) : (testEnvironment env)) - - withEnv new_env $ do + let new_env = (("OTHER_VAR", Just "is set") : (testEnvironment env)) + withEnv new_env $ addToPath (takeDirectory exe_path) $ do res <- cabal_raw_action ["aaaa"] (\h -> () <$ Process.waitForProcess h) assertOutputContains "cabal-install" res assertOutputContains "is set" res diff --git a/cabal-testsuite/PackageTests/ExternalCommandHelp/cabal.out b/cabal-testsuite/PackageTests/ExternalCommandHelp/cabal.out index 0a3edf696..1c4c24db5 100644 --- a/cabal-testsuite/PackageTests/ExternalCommandHelp/cabal.out +++ b/cabal-testsuite/PackageTests/ExternalCommandHelp/cabal.out @@ -3,10 +3,6 @@ Resolving dependencies... Build profile: -w ghc- -O1 In order, the following will be built: - setup-test-0.1.0.0 (exe:cabal-aaaa) (first run) - - setup-test-0.1.0.0 (exe:setup) (first run) Configuring executable 'cabal-aaaa' for setup-test-0.1.0.0... Preprocessing executable 'cabal-aaaa' for setup-test-0.1.0.0... Building executable 'cabal-aaaa' for setup-test-0.1.0.0... -Configuring executable 'setup' for setup-test-0.1.0.0... -Preprocessing executable 'setup' for setup-test-0.1.0.0... -Building executable 'setup' for setup-test-0.1.0.0... diff --git a/cabal-testsuite/PackageTests/ExternalCommandHelp/cabal.test.hs b/cabal-testsuite/PackageTests/ExternalCommandHelp/cabal.test.hs index a3a8acfa5..96e69bbbd 100644 --- a/cabal-testsuite/PackageTests/ExternalCommandHelp/cabal.test.hs +++ b/cabal-testsuite/PackageTests/ExternalCommandHelp/cabal.test.hs @@ -10,14 +10,10 @@ import Data.Maybe import System.Environment main = do - cabalTest $ expectBroken 9404 $ do + cabalTest $ do res <- cabalWithStdin "v2-build" ["all"] "" exe_path <- withPlan $ planExePath "setup-test" "cabal-aaaa" - env <- getTestEnv - path <- liftIO $ getEnv "PATH" - let newpath = takeDirectory exe_path ++ ":" ++ path - let new_env = (("PATH", Just newpath) : (testEnvironment env)) - withEnv new_env $ do + addToPath (takeDirectory exe_path) $ do res <- cabal_raw_action ["help", "aaaa"] (\h -> () <$ Process.waitForProcess h) assertOutputContains "I am helping with the aaaa command" res diff --git a/cabal-testsuite/PackageTests/ExternalCommandHelp/setup-test/AAAA.hs b/cabal-testsuite/PackageTests/ExternalCommandHelp/setup-test/AAAA.hs index 10fe05988..dd139b905 100644 --- a/cabal-testsuite/PackageTests/ExternalCommandHelp/setup-test/AAAA.hs +++ b/cabal-testsuite/PackageTests/ExternalCommandHelp/setup-test/AAAA.hs @@ -5,5 +5,5 @@ import System.Environment main = do args <- getArgs case args of - ["--help"] -> putStrLn "I am helping with the aaaa command" + ["aaaa" , "--help"] -> putStrLn "I am helping with the aaaa command" _ -> putStrLn "aaaa" diff --git a/cabal-testsuite/PackageTests/ExternalCommandSetup/setup.cabal.hs b/cabal-testsuite/PackageTests/ExternalCommandSetup/setup.cabal.hs index 7de624d45..d6bea0400 100644 --- a/cabal-testsuite/PackageTests/ExternalCommandSetup/setup.cabal.hs +++ b/cabal-testsuite/PackageTests/ExternalCommandSetup/setup.cabal.hs @@ -1,17 +1,14 @@ import Test.Cabal.Prelude import System.Environment -main = setupTest $ expectBroken 9403 $ do +main = setupTest $ do withPackageDb $ do withDirectory "aaaa" $ setup_install [] r <- runInstalledExe' "cabal-aaaa" [] env <- getTestEnv - path <- liftIO $ getEnv "PATH" let exe_path = testPrefixDir env "bin" - let newpath = exe_path ++ ":" ++ path - let new_env = (("PATH", Just newpath) : (testEnvironment env)) - withEnv new_env $ do - res <- withDirectory "custom" $ setup' "aaaa" [] - assertOutputContains "did you mean" res + addToPath exe_path $ do + res <- fails $ withDirectory "custom" $ setup' "aaaa" [] + assertOutputContains "unrecognised command" res diff --git a/cabal-testsuite/PackageTests/ExternalCommandSetup/setup.out b/cabal-testsuite/PackageTests/ExternalCommandSetup/setup.out dissimilarity index 65% index e234d5e2a..6600ad3ca 100644 --- a/cabal-testsuite/PackageTests/ExternalCommandSetup/setup.out +++ b/cabal-testsuite/PackageTests/ExternalCommandSetup/setup.out @@ -1,22 +1,13 @@ -# Setup configure -Configuring aaaa-0.1.0.0... -# Setup build -Preprocessing executable 'aaaa' for aaaa-0.1.0.0... -Building executable 'aaaa' for aaaa-0.1.0.0... -# Setup copy -Installing executable aaaa in -Warning: The directory /setup.dist/usr/bin is not in the system search path. -# Setup register -Package contains no library to register: aaaa-0.1.0.0... -# aaaa -aaaa -# Setup configure -Warning: custom.cabal:19:3: Unknown field: "build-depends" -Configuring custom-0.1.0.0... -# Setup build -Preprocessing library for custom-0.1.0.0... -Building library for custom-0.1.0.0... -# Setup copy -Installing library in -# Setup register -Registering library for custom-0.1.0.0... +# Setup configure +Configuring aaaa-0.1.0.0... +# Setup build +Preprocessing executable 'cabal-aaaa' for aaaa-0.1.0.0... +Building executable 'cabal-aaaa' for aaaa-0.1.0.0... +# Setup copy +Installing executable cabal-aaaa in +Warning: The directory /setup.dist/usr/bin is not in the system search path. +# Setup register +Package contains no library to register: aaaa-0.1.0.0... +# cabal-aaaa +aaaa +# Setup aaaa diff --git a/cabal-testsuite/src/Test/Cabal/Prelude.hs b/cabal-testsuite/src/Test/Cabal/Prelude.hs index 2977a9270..c95a55988 100644 --- a/cabal-testsuite/src/Test/Cabal/Prelude.hs +++ b/cabal-testsuite/src/Test/Cabal/Prelude.hs @@ -60,16 +60,16 @@ import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NE import Data.Maybe (mapMaybe, fromMaybe) import System.Exit (ExitCode (..)) -import System.FilePath ((), takeExtensions, takeDrive, takeDirectory, normalise, splitPath, joinPath, splitFileName, (<.>), dropTrailingPathSeparator) +import System.FilePath import Control.Concurrent (threadDelay) import qualified Data.Char as Char -import System.Directory (canonicalizePath, copyFile, copyFile, doesDirectoryExist, doesFileExist, createDirectoryIfMissing, getDirectoryContents, listDirectory) +import System.Directory import Control.Retry (exponentialBackoff, limitRetriesByCumulativeDelay) import Network.Wait (waitTcpVerbose) +import System.Environment #ifndef mingw32_HOST_OS import Control.Monad.Catch ( bracket_ ) -import System.Directory ( removeFile ) import System.Posix.Files ( createSymbolicLink ) import System.Posix.Resource #endif @@ -113,6 +113,16 @@ withDirectory f = withReaderT withEnv :: [(String, Maybe String)] -> TestM a -> TestM a withEnv e = withReaderT (\env -> env { testEnvironment = testEnvironment env ++ e }) +-- | Prepend a directory to the PATH +addToPath :: FilePath -> TestM a -> TestM a +addToPath exe_dir action = do + env <- getTestEnv + path <- liftIO $ getEnv "PATH" + let newpath = exe_dir ++ [searchPathSeparator] ++ path + let new_env = (("PATH", Just newpath) : (testEnvironment env)) + withEnv new_env action + + -- HACK please don't use me withEnvFilter :: (String -> Bool) -> TestM a -> TestM a withEnvFilter p = withReaderT (\env -> env { testEnvironment = filter (p . fst) (testEnvironment env) }) diff --git a/doc/external-commands.rst b/doc/external-commands.rst dissimilarity index 63% index 047d8f4dc..e72495aa1 100644 --- a/doc/external-commands.rst +++ b/doc/external-commands.rst @@ -1,8 +1,22 @@ -External Commands -================= - -Cabal provides a system for external commands, akin to the ones used by tools like ``git`` or ``cargo``. - -If you execute ``cabal my-custom-command``, Cabal will search the path for an executable named ``cabal-my-custom-command`` and execute it, passing any remaining arguments to this external command. An error will be thrown in case the custom command is not found. - -For ideas or existing external commands, visit `this Discourse thread `_. +External Commands +================= + +``cabal-install`` provides a system for external commands, akin to the ones used by tools like ``git`` or ``cargo``. + +If you execute ``cabal ``, ``cabal-install`` will search the path for an executable named ``cabal-`` and execute it. The name of the command is passed as the first argument and +the remaining arguments are passed afterwards. An error will be thrown in case the custom command is not found. + +The ``$CABAL`` environment variable is set to the path of the ``cabal-install`` executable +which invoked the subcommand. + +It is strongly recommended that you implement your custom commands by calling the +CLI via the ``$CABAL`` variable rather than linking against the ``Cabal`` library. +There is no guarantee that the subcommand will link against the same version of the +``Cabal`` library as ``cabal-install`` so it would lead to unexpected results and +incompatibilities. + +``cabal-install`` can also display the help message of the external command. +When ``cabal help `` is invoked, then ``cabal- --help`` will be called so +your external command can display a help message. + +For ideas or existing external commands, visit `this Discourse thread `_. -- 2.11.4.GIT