Finish off the external commands feature

mpickering · mpickering · commit 56a8cb6a8fd9 · 2023-11-07T12:34:14.000Z
* 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 haskell#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 haskell#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 haskell#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 haskell#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.
diff --git 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
@@ -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
@@ -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,31 @@ 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
@@ -196,8 +196,9 @@ import Distribution.Simple.Command
   , commandAddAction
   , commandFromSpec
   , commandShowOptions
-  , commandsRun
   , hiddenCommand
+  , commandsRunWithFallback
+  , defaultCommandFallback
   )
 import Distribution.Simple.Compiler (PackageDBStack)
 import Distribution.Simple.Configure
@@ -213,7 +214,7 @@ import Distribution.Simple.Program
   ( configureAllKnownPrograms
   , defaultProgramDb
   , getProgramInvocationOutput
-  , simpleProgramInvocation
+  , simpleProgramInvocation, findProgramOnSearchPath, defaultProgramSearchPath
   )
 import Distribution.Simple.Program.Db (reconfigurePrograms)
 import qualified Distribution.Simple.Setup as Cabal
@@ -250,7 +251,7 @@ import System.Directory
   , getCurrentDirectory
   , withCurrentDirectory
   )
-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 <- 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
@@ -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
@@ -18,9 +18,22 @@ 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
+
+      -- 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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
diff --git a/doc/external-commands.rst b/doc/external-commands.rst
