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 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.

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

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

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
 

cabal-install/src/Distribution/Client/Main.hs

@@ -196,7 +196,8 @@ import Distribution.Simple.Command
   , commandAddAction
   , commandFromSpec
   , commandShowOptions
-  , commandsRun
+  , commandsRunWithFallback
+  , defaultCommandFallback
   , hiddenCommand
   )
 import Distribution.Simple.Compiler (PackageDBStack)
@@ -212,6 +213,8 @@ import Distribution.Simple.PackageDescription (readGenericPackageDescription)
 import Distribution.Simple.Program
   ( configureAllKnownPrograms
   , defaultProgramDb
+  , defaultProgramSearchPath
+  , findProgramOnSearchPath
   , getProgramInvocationOutput
   , simpleProgramInvocation
   )
@@ -250,7 +253,7 @@ import System.Directory
   , getCurrentDirectory
   , withCurrentDirectory
   )
-import System.Environment (getProgName)
+import System.Environment (getEnvironment, getExecutablePath, getProgName)
 import System.FilePath
   ( dropExtension
   , splitExtension
@@ -265,6 +268,7 @@ import System.IO
   , stderr
   , stdout
   )
+import System.Process (createProcess, env, proc)
 
 -- | Entry point
 --
@@ -323,9 +327,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 +339,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 +357,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)

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)

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

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

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

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...

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
 

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"