From b27fd21d17c229fb8b4bc6a6fef0f79207b90dce Mon Sep 17 00:00:00 2001 From: Yvan Sraka Date: Wed, 21 Jun 2023 15:40:43 +0200 Subject: [PATCH] [cabal-7825] Implement external command system Fix #2349 and #7825 --- Cabal/src/Distribution/Make.hs | 7 ++-- Cabal/src/Distribution/Simple.hs | 5 ++- Cabal/src/Distribution/Simple/Command.hs | 35 ++++++++++++++----- cabal-install/src/Distribution/Client/Main.hs | 7 ++-- .../src/Distribution/Client/SavedFlags.hs | 1 + doc/external-commands.rst | 8 +++++ doc/index.rst | 1 + 7 files changed, 51 insertions(+), 13 deletions(-) create mode 100644 doc/external-commands.rst diff --git a/Cabal/src/Distribution/Make.hs b/Cabal/src/Distribution/Make.hs index 716033e42a3..aaa63a94bdb 100644 --- a/Cabal/src/Distribution/Make.hs +++ b/Cabal/src/Distribution/Make.hs @@ -88,8 +88,10 @@ defaultMainArgs :: [String] -> IO () defaultMainArgs = defaultMainHelper defaultMainHelper :: [String] -> IO () -defaultMainHelper args = - case commandsRun (globalCommand commands) commands args of +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 @@ -98,6 +100,7 @@ defaultMainHelper args = _ | 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 024a445f1dc..0649a085260 100644 --- a/Cabal/src/Distribution/Simple.hs +++ b/Cabal/src/Distribution/Simple.hs @@ -168,7 +168,9 @@ defaultMainWithHooksNoReadArgs hooks pkg_descr = defaultMainHelper :: UserHooks -> Args -> IO () defaultMainHelper hooks args = topHandler $ do args' <- expandResponse args - case commandsRun (globalCommand commands) commands args' of + command <- commandsRun (globalCommand commands) commands args' + case command of + CommandDelegate -> pure () CommandHelp help -> printHelp help CommandList opts -> printOptionsList opts CommandErrors errs -> printErrors errs @@ -177,6 +179,7 @@ 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 f55a510c8bd..dc2be1a698b 100644 --- a/Cabal/src/Distribution/Simple/Command.hs +++ b/Cabal/src/Distribution/Simple/Command.hs @@ -85,12 +85,15 @@ 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 @@ -596,11 +599,13 @@ 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 @@ -631,25 +636,38 @@ commandsRun :: CommandUI a -> [Command action] -> [String] - -> CommandParse (a, CommandParse action) + -> IO (CommandParse (a, CommandParse action)) commandsRun globalCommand commands args = case commandParseArgs globalCommand True args of - CommandHelp help -> CommandHelp help - CommandList opts -> CommandList (opts ++ commandNames) - CommandErrors errs -> CommandErrors errs + 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) -> handleHelpCommand cmdArgs + ("help" : cmdArgs) -> pure $ handleHelpCommand cmdArgs (name : cmdArgs) -> case lookupCommand name of [Command _ _ action _] -> - CommandReadyToGo (flags, action cmdArgs) - _ -> CommandReadyToGo (flags, badCommand name) - [] -> CommandReadyToGo (flags, noCommand) + 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) + [] -> pure $ CommandReadyToGo (flags, noCommand) where flags = mkflags (commandDefaultFlags globalCommand) where lookupCommand cname = [ 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 @@ -679,6 +697,7 @@ commandsRun globalCommand commands args = -- furthermore, support "prog help command" as "prog command --help" handleHelpCommand cmdArgs = case commandParseArgs helpCommandUI True cmdArgs of + CommandDelegate -> CommandDelegate CommandHelp help -> CommandHelp help CommandList list -> CommandList (list ++ commandNames) CommandErrors _ -> CommandHelp globalHelp diff --git a/cabal-install/src/Distribution/Client/Main.hs b/cabal-install/src/Distribution/Client/Main.hs index 6d8c0e187aa..c7772434060 100644 --- a/cabal-install/src/Distribution/Client/Main.hs +++ b/cabal-install/src/Distribution/Client/Main.hs @@ -322,8 +322,10 @@ warnIfAssertionsAreEnabled = -- into IO actions for execution. mainWorker :: [String] -> IO () mainWorker args = do - topHandler $ - case commandsRun (globalCommand commands) commands args of + topHandler $ do + command <- commandsRun (globalCommand commands) commands args + case command of + CommandDelegate -> pure () CommandHelp help -> printGlobalHelp help CommandList opts -> printOptionsList opts CommandErrors errs -> printErrors errs @@ -334,6 +336,7 @@ mainWorker args = do printVersion | fromFlagOrDefault False (globalNumericVersion globalFlags) -> printNumericVersion + CommandDelegate -> pure () CommandHelp help -> printCommandHelp help CommandList opts -> printOptionsList opts CommandErrors errs -> do diff --git a/cabal-install/src/Distribution/Client/SavedFlags.hs b/cabal-install/src/Distribution/Client/SavedFlags.hs index 1a598a58fd7..5fa417a8578 100644 --- a/cabal-install/src/Distribution/Client/SavedFlags.hs +++ b/cabal-install/src/Distribution/Client/SavedFlags.hs @@ -51,6 +51,7 @@ 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/doc/external-commands.rst b/doc/external-commands.rst new file mode 100644 index 00000000000..047d8f4dca0 --- /dev/null +++ b/doc/external-commands.rst @@ -0,0 +1,8 @@ +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 `_. diff --git a/doc/index.rst b/doc/index.rst index b97dd245346..faaa3bac628 100644 --- a/doc/index.rst +++ b/doc/index.rst @@ -18,3 +18,4 @@ Welcome to the Cabal User Guide buildinfo-fields-reference bugs-and-stability nix-integration + external-commands