Merge pull request haskell#9412 from mpickering/wip/external-commands…

…-fixes

Finish off external commands feature

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

@@ -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)

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

@@ -0,0 +1,8 @@
+# cabal v2-build
+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)
+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...

cabal-testsuite/PackageTests/ExternalCommand/cabal.project

@@ -0,0 +1 @@
+packages: setup-test/

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

cabal-testsuite/PackageTests/ExternalCommand/setup-test/AAAA.hs

@@ -0,0 +1,5 @@
+module Main where
+
+import System.Environment
+
+main = getArgs >>= print

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.

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.