From c3b810900e71ebf14fe740e63e4d91778023bcea Mon Sep 17 00:00:00 2001 From: Matthew Pickering <matthewtpickering@gmail.com> 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 <cmd>` is interpreted as `cabal-<cmd> --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 | 106 ++++++++++-------- cabal-install/src/Distribution/Client/Main.hs | 34 +++++- .../src/Distribution/Client/SavedFlags.hs | 1 - .../ExternalCommand/cabal.test.hs | 5 + .../ExternalCommand/setup-test/AAAA.hs | 5 +- .../ExternalCommandEnv/cabal.test.hs | 2 +- .../ExternalCommandHelp/cabal.out | 4 - .../ExternalCommandHelp/cabal.test.hs | 2 +- .../ExternalCommandHelp/setup-test/AAAA.hs | 2 +- .../ExternalCommandSetup/setup.cabal.hs | 6 +- .../ExternalCommandSetup/setup.out | 19 +--- doc/external-commands.rst | 18 ++- 14 files changed, 120 insertions(+), 88 deletions(-) diff --git a/Cabal/src/Distribution/Make.hs b/Cabal/src/Distribution/Make.hs index aaa63a94bdb..82334d550f0 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 0649a085260..c52a02c0f96 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 dc2be1a698b..094706344e0 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,61 @@ commandAddAction command action = let flags = mkflags (commandDefaultFlags command) in action flags args -commandsRun - :: CommandUI a +-- 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 +692,32 @@ 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 = + -- TODO: Does not support external commands + 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 c7772434060..7875ba5bf3c 100644 --- a/cabal-install/src/Distribution/Client/Main.hs +++ b/cabal-install/src/Distribution/Client/Main.hs @@ -196,8 +196,9 @@ import Distribution.Simple.Command , commandAddAction , commandFromSpec , commandShowOptions - , commandsRun , hiddenCommand + , commandsRunWithFallback + , defaultCommandFallback ) import Distribution.Simple.Compiler (PackageDBStack) import Distribution.Simple.Configure @@ -248,9 +249,9 @@ import Distribution.Compat.ResponseFile import System.Directory ( doesFileExist , getCurrentDirectory - , withCurrentDirectory + , withCurrentDirectory, findExecutable ) -import System.Environment (getProgName) +import System.Environment (getProgName, getEnvironment, getExecutablePath) import System.FilePath ( dropExtension , splitExtension @@ -265,6 +266,7 @@ import System.IO , stderr , stdout ) +import System.Process (createProcess, env, proc) -- | Entry point -- @@ -323,9 +325,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 @@ -336,7 +337,6 @@ mainWorker args = do printVersion | fromFlagOrDefault False (globalNumericVersion globalFlags) -> printNumericVersion - CommandDelegate -> pure () CommandHelp help -> printCommandHelp help CommandList opts -> printOptionsList opts CommandErrors errs -> do @@ -355,6 +355,28 @@ mainWorker args = do warnIfAssertionsAreEnabled action globalFlags where + delegateToExternal :: [Command Action] + -> String + -> [String] + -> IO (CommandParse Action) + delegateToExternal commands' name cmdArgs = do + mCommand <- findExecutable $ "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 5fa417a8578..1a598a58fd7 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 850c8bfbcec..91223bbaaff 100644 --- a/cabal-testsuite/PackageTests/ExternalCommand/cabal.test.hs +++ b/cabal-testsuite/PackageTests/ExternalCommand/cabal.test.hs @@ -18,9 +18,14 @@ main = do let newpath = takeDirectory exe_path ++ ":" ++ path let new_env = (("PATH", Just newpath) : (testEnvironment env)) withEnv new_env $ 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 + 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 5bee0ebbef1..c2d121c9a39 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 891c9e43d4b..c8b0958dbfa 100644 --- a/cabal-testsuite/PackageTests/ExternalCommandEnv/cabal.test.hs +++ b/cabal-testsuite/PackageTests/ExternalCommandEnv/cabal.test.hs @@ -10,7 +10,7 @@ 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 diff --git a/cabal-testsuite/PackageTests/ExternalCommandHelp/cabal.out b/cabal-testsuite/PackageTests/ExternalCommandHelp/cabal.out index 0a3edf696f9..1c4c24db55c 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-<GHCVER> -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 a3a8acfa5c7..7d676a936d9 100644 --- a/cabal-testsuite/PackageTests/ExternalCommandHelp/cabal.test.hs +++ b/cabal-testsuite/PackageTests/ExternalCommandHelp/cabal.test.hs @@ -10,7 +10,7 @@ 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 diff --git a/cabal-testsuite/PackageTests/ExternalCommandHelp/setup-test/AAAA.hs b/cabal-testsuite/PackageTests/ExternalCommandHelp/setup-test/AAAA.hs index 10fe05988d8..dd139b905da 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 7de624d4530..05e316d8efd 100644 --- a/cabal-testsuite/PackageTests/ExternalCommandSetup/setup.cabal.hs +++ b/cabal-testsuite/PackageTests/ExternalCommandSetup/setup.cabal.hs @@ -1,7 +1,7 @@ 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" [] @@ -11,7 +11,7 @@ main = setupTest $ expectBroken 9403 $ do 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 + 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 index e234d5e2a48..6600ad3ca2f 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... +Preprocessing executable 'cabal-aaaa' for aaaa-0.1.0.0... +Building executable 'cabal-aaaa' for aaaa-0.1.0.0... # Setup copy -Installing executable aaaa in <PATH> +Installing executable cabal-aaaa in <PATH> Warning: The directory <ROOT>/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 +# cabal-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 <PATH> -# Setup register -Registering library for custom-0.1.0.0... +# Setup aaaa diff --git a/doc/external-commands.rst b/doc/external-commands.rst index 047d8f4dca0..e72495aa160 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``. +``cabal-install`` 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. +If you execute ``cabal <cmd>``, ``cabal-install`` will search the path for an executable named ``cabal-<cmd>`` 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 <cmd>`` is invoked, then ``cabal-<cmd> <cmd> --help`` will be called so +your external command can display a help message. For ideas or existing external commands, visit `this Discourse thread <https://discourse.haskell.org/t/an-external-command-system-for-cabal-what-would-you-do-with-it/7114>`_.