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..2da6486cba6 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 9114102f2bf..dc196a66864 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 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.out b/cabal-testsuite/PackageTests/ExternalCommand/cabal.out new file mode 100644 index 00000000000..1c4c24db55c --- /dev/null +++ b/cabal-testsuite/PackageTests/ExternalCommand/cabal.out @@ -0,0 +1,8 @@ +# cabal v2-build +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) +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... diff --git a/cabal-testsuite/PackageTests/ExternalCommand/cabal.project b/cabal-testsuite/PackageTests/ExternalCommand/cabal.project new file mode 100644 index 00000000000..1a33bb5a25e --- /dev/null +++ b/cabal-testsuite/PackageTests/ExternalCommand/cabal.project @@ -0,0 +1 @@ +packages: setup-test/ diff --git a/cabal-testsuite/PackageTests/ExternalCommand/cabal.test.hs b/cabal-testsuite/PackageTests/ExternalCommand/cabal.test.hs new file mode 100644 index 00000000000..d9535b60507 --- /dev/null +++ b/cabal-testsuite/PackageTests/ExternalCommand/cabal.test.hs @@ -0,0 +1,47 @@ +import Test.Cabal.Prelude +import qualified System.Process as Process +import Control.Concurrent (threadDelay) +import System.Directory (removeFile) +import Control.Exception (catch, throwIO) +import System.IO.Error (isDoesNotExistError) +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" + 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 + configured_prog <- requireProgramM cabalProgram + env <- getTestEnv + r <- liftIO $ runAction (testVerbosity env) + (Just (testCurrentDir env)) + (testEnvironment env) + (programPath configured_prog) + args + Nothing + action + recordLog r + requireSuccess r diff --git a/cabal-testsuite/PackageTests/ExternalCommand/setup-test/AAAA.hs b/cabal-testsuite/PackageTests/ExternalCommand/setup-test/AAAA.hs new file mode 100644 index 00000000000..c2d121c9a39 --- /dev/null +++ b/cabal-testsuite/PackageTests/ExternalCommand/setup-test/AAAA.hs @@ -0,0 +1,5 @@ +module Main where + +import System.Environment + +main = getArgs >>= print diff --git a/cabal-testsuite/PackageTests/ExternalCommand/setup-test/CHANGELOG.md b/cabal-testsuite/PackageTests/ExternalCommand/setup-test/CHANGELOG.md new file mode 100644 index 00000000000..7ae8ff6113d --- /dev/null +++ b/cabal-testsuite/PackageTests/ExternalCommand/setup-test/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for setup-test + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/cabal-testsuite/PackageTests/ExternalCommand/setup-test/LICENSE b/cabal-testsuite/PackageTests/ExternalCommand/setup-test/LICENSE new file mode 100644 index 00000000000..cd8ad2ac8ae --- /dev/null +++ b/cabal-testsuite/PackageTests/ExternalCommand/setup-test/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2023, Matthew Pickering + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Matthew Pickering nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/cabal-testsuite/PackageTests/ExternalCommand/setup-test/setup-test.cabal b/cabal-testsuite/PackageTests/ExternalCommand/setup-test/setup-test.cabal new file mode 100644 index 00000000000..8deb0577a16 --- /dev/null +++ b/cabal-testsuite/PackageTests/ExternalCommand/setup-test/setup-test.cabal @@ -0,0 +1,25 @@ +cabal-version: 3.0 +name: setup-test +version: 0.1.0.0 +-- synopsis: +-- description: +license: BSD-3-Clause +license-file: LICENSE +author: Matthew Pickering +maintainer: matthewtpickering@gmail.com +-- copyright: +build-type: Simple +extra-doc-files: CHANGELOG.md +-- extra-source-files: + +common warnings + ghc-options: -Wall + +executable cabal-aaaa + import: warnings + main-is: AAAA.hs + -- other-modules: + -- other-extensions: + build-depends: base + hs-source-dirs: . + default-language: Haskell2010 diff --git a/cabal-testsuite/PackageTests/ExternalCommandEnv/cabal.out b/cabal-testsuite/PackageTests/ExternalCommandEnv/cabal.out new file mode 100644 index 00000000000..1c4c24db55c --- /dev/null +++ b/cabal-testsuite/PackageTests/ExternalCommandEnv/cabal.out @@ -0,0 +1,8 @@ +# cabal v2-build +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) +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... diff --git a/cabal-testsuite/PackageTests/ExternalCommandEnv/cabal.project b/cabal-testsuite/PackageTests/ExternalCommandEnv/cabal.project new file mode 100644 index 00000000000..1a33bb5a25e --- /dev/null +++ b/cabal-testsuite/PackageTests/ExternalCommandEnv/cabal.project @@ -0,0 +1 @@ +packages: setup-test/ diff --git a/cabal-testsuite/PackageTests/ExternalCommandEnv/cabal.test.hs b/cabal-testsuite/PackageTests/ExternalCommandEnv/cabal.test.hs new file mode 100644 index 00000000000..4344076398a --- /dev/null +++ b/cabal-testsuite/PackageTests/ExternalCommandEnv/cabal.test.hs @@ -0,0 +1,36 @@ +import Test.Cabal.Prelude +import qualified System.Process as Process +import Control.Concurrent (threadDelay) +import System.Directory (removeFile) +import Control.Exception (catch, throwIO) +import System.IO.Error (isDoesNotExistError) +import qualified Data.Time.Clock as Time +import qualified Data.Time.Format as Time +import Data.Maybe +import System.Environment + +main = do + cabalTest $ do + res <- cabalWithStdin "v2-build" ["all"] "" + exe_path <- withPlan $ planExePath "setup-test" "cabal-aaaa" + env <- getTestEnv + 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 + + +cabal_raw_action :: [String] -> (Process.ProcessHandle -> IO ()) -> TestM Result +cabal_raw_action args action = do + configured_prog <- requireProgramM cabalProgram + env <- getTestEnv + r <- liftIO $ runAction (testVerbosity env) + (Just (testCurrentDir env)) + (testEnvironment env) + (programPath configured_prog) + args + Nothing + action + recordLog r + requireSuccess r diff --git a/cabal-testsuite/PackageTests/ExternalCommandEnv/setup-test/AAAA.hs b/cabal-testsuite/PackageTests/ExternalCommandEnv/setup-test/AAAA.hs new file mode 100644 index 00000000000..99af61e9c03 --- /dev/null +++ b/cabal-testsuite/PackageTests/ExternalCommandEnv/setup-test/AAAA.hs @@ -0,0 +1,11 @@ +module Main where + +import System.Environment +import System.Process + +main = do + cabal_proc <- getEnv "CABAL" + other_var <- getEnv "OTHER_VAR" + putStrLn ("OTHER_VAR is set to: " ++ other_var) + callProcess cabal_proc ["--version"] + diff --git a/cabal-testsuite/PackageTests/ExternalCommandEnv/setup-test/CHANGELOG.md b/cabal-testsuite/PackageTests/ExternalCommandEnv/setup-test/CHANGELOG.md new file mode 100644 index 00000000000..7ae8ff6113d --- /dev/null +++ b/cabal-testsuite/PackageTests/ExternalCommandEnv/setup-test/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for setup-test + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/cabal-testsuite/PackageTests/ExternalCommandEnv/setup-test/LICENSE b/cabal-testsuite/PackageTests/ExternalCommandEnv/setup-test/LICENSE new file mode 100644 index 00000000000..cd8ad2ac8ae --- /dev/null +++ b/cabal-testsuite/PackageTests/ExternalCommandEnv/setup-test/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2023, Matthew Pickering + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Matthew Pickering nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/cabal-testsuite/PackageTests/ExternalCommandEnv/setup-test/setup-test.cabal b/cabal-testsuite/PackageTests/ExternalCommandEnv/setup-test/setup-test.cabal new file mode 100644 index 00000000000..a5feea69112 --- /dev/null +++ b/cabal-testsuite/PackageTests/ExternalCommandEnv/setup-test/setup-test.cabal @@ -0,0 +1,25 @@ +cabal-version: 3.0 +name: setup-test +version: 0.1.0.0 +-- synopsis: +-- description: +license: BSD-3-Clause +license-file: LICENSE +author: Matthew Pickering +maintainer: matthewtpickering@gmail.com +-- copyright: +build-type: Simple +extra-doc-files: CHANGELOG.md +-- extra-source-files: + +common warnings + ghc-options: -Wall + +executable cabal-aaaa + import: warnings + main-is: AAAA.hs + -- other-modules: + -- other-extensions: + build-depends: base, process + hs-source-dirs: . + default-language: Haskell2010 diff --git a/cabal-testsuite/PackageTests/ExternalCommandHelp/cabal.out b/cabal-testsuite/PackageTests/ExternalCommandHelp/cabal.out new file mode 100644 index 00000000000..1c4c24db55c --- /dev/null +++ b/cabal-testsuite/PackageTests/ExternalCommandHelp/cabal.out @@ -0,0 +1,8 @@ +# cabal v2-build +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) +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... diff --git a/cabal-testsuite/PackageTests/ExternalCommandHelp/cabal.project b/cabal-testsuite/PackageTests/ExternalCommandHelp/cabal.project new file mode 100644 index 00000000000..1a33bb5a25e --- /dev/null +++ b/cabal-testsuite/PackageTests/ExternalCommandHelp/cabal.project @@ -0,0 +1 @@ +packages: setup-test/ diff --git a/cabal-testsuite/PackageTests/ExternalCommandHelp/cabal.test.hs b/cabal-testsuite/PackageTests/ExternalCommandHelp/cabal.test.hs new file mode 100644 index 00000000000..96e69bbbd6e --- /dev/null +++ b/cabal-testsuite/PackageTests/ExternalCommandHelp/cabal.test.hs @@ -0,0 +1,33 @@ +import Test.Cabal.Prelude +import qualified System.Process as Process +import Control.Concurrent (threadDelay) +import System.Directory (removeFile) +import Control.Exception (catch, throwIO) +import System.IO.Error (isDoesNotExistError) +import qualified Data.Time.Clock as Time +import qualified Data.Time.Format as Time +import Data.Maybe +import System.Environment + +main = do + cabalTest $ do + res <- cabalWithStdin "v2-build" ["all"] "" + exe_path <- withPlan $ planExePath "setup-test" "cabal-aaaa" + addToPath (takeDirectory exe_path) $ do + res <- cabal_raw_action ["help", "aaaa"] (\h -> () <$ Process.waitForProcess h) + assertOutputContains "I am helping with the aaaa command" res + + +cabal_raw_action :: [String] -> (Process.ProcessHandle -> IO ()) -> TestM Result +cabal_raw_action args action = do + configured_prog <- requireProgramM cabalProgram + env <- getTestEnv + r <- liftIO $ runAction (testVerbosity env) + (Just (testCurrentDir env)) + (testEnvironment env) + (programPath configured_prog) + args + Nothing + action + recordLog r + requireSuccess r diff --git a/cabal-testsuite/PackageTests/ExternalCommandHelp/setup-test/AAAA.hs b/cabal-testsuite/PackageTests/ExternalCommandHelp/setup-test/AAAA.hs new file mode 100644 index 00000000000..dd139b905da --- /dev/null +++ b/cabal-testsuite/PackageTests/ExternalCommandHelp/setup-test/AAAA.hs @@ -0,0 +1,9 @@ +module Main where + +import System.Environment + +main = do + args <- getArgs + case args of + ["aaaa" , "--help"] -> putStrLn "I am helping with the aaaa command" + _ -> putStrLn "aaaa" diff --git a/cabal-testsuite/PackageTests/ExternalCommandHelp/setup-test/CHANGELOG.md b/cabal-testsuite/PackageTests/ExternalCommandHelp/setup-test/CHANGELOG.md new file mode 100644 index 00000000000..7ae8ff6113d --- /dev/null +++ b/cabal-testsuite/PackageTests/ExternalCommandHelp/setup-test/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for setup-test + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/cabal-testsuite/PackageTests/ExternalCommandHelp/setup-test/LICENSE b/cabal-testsuite/PackageTests/ExternalCommandHelp/setup-test/LICENSE new file mode 100644 index 00000000000..cd8ad2ac8ae --- /dev/null +++ b/cabal-testsuite/PackageTests/ExternalCommandHelp/setup-test/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2023, Matthew Pickering + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Matthew Pickering nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/cabal-testsuite/PackageTests/ExternalCommandHelp/setup-test/setup-test.cabal b/cabal-testsuite/PackageTests/ExternalCommandHelp/setup-test/setup-test.cabal new file mode 100644 index 00000000000..8deb0577a16 --- /dev/null +++ b/cabal-testsuite/PackageTests/ExternalCommandHelp/setup-test/setup-test.cabal @@ -0,0 +1,25 @@ +cabal-version: 3.0 +name: setup-test +version: 0.1.0.0 +-- synopsis: +-- description: +license: BSD-3-Clause +license-file: LICENSE +author: Matthew Pickering +maintainer: matthewtpickering@gmail.com +-- copyright: +build-type: Simple +extra-doc-files: CHANGELOG.md +-- extra-source-files: + +common warnings + ghc-options: -Wall + +executable cabal-aaaa + import: warnings + main-is: AAAA.hs + -- other-modules: + -- other-extensions: + build-depends: base + hs-source-dirs: . + default-language: Haskell2010 diff --git a/cabal-testsuite/PackageTests/ExternalCommandSetup/aaaa/LICENSE b/cabal-testsuite/PackageTests/ExternalCommandSetup/aaaa/LICENSE new file mode 100644 index 00000000000..e69de29bb2d diff --git a/cabal-testsuite/PackageTests/ExternalCommandSetup/aaaa/Main.hs b/cabal-testsuite/PackageTests/ExternalCommandSetup/aaaa/Main.hs new file mode 100644 index 00000000000..b3fcf560699 --- /dev/null +++ b/cabal-testsuite/PackageTests/ExternalCommandSetup/aaaa/Main.hs @@ -0,0 +1,3 @@ +module Main where + +main = putStrLn "aaaa" diff --git a/cabal-testsuite/PackageTests/ExternalCommandSetup/aaaa/aaaa.cabal b/cabal-testsuite/PackageTests/ExternalCommandSetup/aaaa/aaaa.cabal new file mode 100644 index 00000000000..cafeabd5855 --- /dev/null +++ b/cabal-testsuite/PackageTests/ExternalCommandSetup/aaaa/aaaa.cabal @@ -0,0 +1,22 @@ +cabal-version: 3.0 +name: aaaa +version: 0.1.0.0 +license: BSD-3-Clause +license-file: LICENSE +author: Matthew Pickering +maintainer: matthewtpickering@gmail.com +build-type: Simple +extra-doc-files: CHANGELOG.md +-- extra-source-files: + +common warnings + ghc-options: -Wall + +executable cabal-aaaa + import: warnings + main-is: Main.hs + -- other-modules: + -- other-extensions: + build-depends: base + hs-source-dirs: . + default-language: Haskell2010 diff --git a/cabal-testsuite/PackageTests/ExternalCommandSetup/custom/CHANGELOG.md b/cabal-testsuite/PackageTests/ExternalCommandSetup/custom/CHANGELOG.md new file mode 100644 index 00000000000..063fef7c698 --- /dev/null +++ b/cabal-testsuite/PackageTests/ExternalCommandSetup/custom/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for custom + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/cabal-testsuite/PackageTests/ExternalCommandSetup/custom/LICENSE b/cabal-testsuite/PackageTests/ExternalCommandSetup/custom/LICENSE new file mode 100644 index 00000000000..cd8ad2ac8ae --- /dev/null +++ b/cabal-testsuite/PackageTests/ExternalCommandSetup/custom/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2023, Matthew Pickering + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Matthew Pickering nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/cabal-testsuite/PackageTests/ExternalCommandSetup/custom/Setup.hs b/cabal-testsuite/PackageTests/ExternalCommandSetup/custom/Setup.hs new file mode 100644 index 00000000000..e8efd11bddb --- /dev/null +++ b/cabal-testsuite/PackageTests/ExternalCommandSetup/custom/Setup.hs @@ -0,0 +1,3 @@ +module Main where +import Distribution.Simple +main = defaultMain diff --git a/cabal-testsuite/PackageTests/ExternalCommandSetup/custom/custom.cabal b/cabal-testsuite/PackageTests/ExternalCommandSetup/custom/custom.cabal new file mode 100644 index 00000000000..0dbc609439b --- /dev/null +++ b/cabal-testsuite/PackageTests/ExternalCommandSetup/custom/custom.cabal @@ -0,0 +1,29 @@ +cabal-version: 3.0 +name: custom +version: 0.1.0.0 +-- synopsis: +-- description: +license: BSD-3-Clause +license-file: LICENSE +author: Matthew Pickering +maintainer: matthewtpickering@gmail.com +-- copyright: +build-type: Custom +extra-doc-files: CHANGELOG.md +-- extra-source-files: + +common warnings + ghc-options: -Wall + +custom-setup + build-depends: base, Cabal + +library + import: warnings + exposed-modules: MyLib + -- other-modules: + -- other-extensions: + build-depends: base + hs-source-dirs: src + default-language: Haskell2010 + diff --git a/cabal-testsuite/PackageTests/ExternalCommandSetup/setup.cabal.hs b/cabal-testsuite/PackageTests/ExternalCommandSetup/setup.cabal.hs new file mode 100644 index 00000000000..d6bea04003f --- /dev/null +++ b/cabal-testsuite/PackageTests/ExternalCommandSetup/setup.cabal.hs @@ -0,0 +1,14 @@ +import Test.Cabal.Prelude +import System.Environment + +main = setupTest $ do + withPackageDb $ do + withDirectory "aaaa" $ setup_install [] + r <- runInstalledExe' "cabal-aaaa" [] + env <- getTestEnv + let exe_path = testPrefixDir env "bin" + 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 new file mode 100644 index 00000000000..6600ad3ca2f --- /dev/null +++ b/cabal-testsuite/PackageTests/ExternalCommandSetup/setup.out @@ -0,0 +1,13 @@ +# 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 757a71aefb7..c95a55988f8 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) }) @@ -358,15 +368,21 @@ runPlanExe pkg_name cname args = void $ runPlanExe' pkg_name cname args runPlanExe' :: String {- package name -} -> String {- component name -} -> [String] -> TestM Result runPlanExe' pkg_name cname args = do + exePath <- planExePath pkg_name cname + defaultRecordMode RecordAll $ do + recordHeader [pkg_name, cname] + runM exePath args Nothing + +planExePath :: String {- package name -} -> String {- component name -} + -> TestM FilePath +planExePath pkg_name cname = do Just plan <- testPlan `fmap` getTestEnv let distDirOrBinFile = planDistDir plan (mkPackageName pkg_name) (CExeName (mkUnqualComponentName cname)) exePath = case distDirOrBinFile of DistDir dist_dir -> dist_dir "build" cname cname BinFile bin_file -> bin_file - defaultRecordMode RecordAll $ do - recordHeader [pkg_name, cname] - runM exePath args Nothing + return exePath ------------------------------------------------------------------------ -- * Running ghc-pkg 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 ``, ``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 `_.