Skip to content

Commit

Permalink
Finish off the external commands feature
Browse files Browse the repository at this point in the history
* 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.
  • Loading branch information
mpickering authored and Mikolaj committed Nov 24, 2023
1 parent 7fb1ca6 commit d8ebb81
Show file tree
Hide file tree
Showing 15 changed files with 144 additions and 108 deletions.
2 changes: 0 additions & 2 deletions Cabal/src/Distribution/Make.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -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
Expand Down
2 changes: 0 additions & 2 deletions Cabal/src/Distribution/Simple.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -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
Expand Down
102 changes: 54 additions & 48 deletions Cabal/src/Distribution/Simple/Command.hs
Original file line number Diff line number Diff line change
Expand Up @@ -47,6 +47,8 @@ module Distribution.Simple.Command

-- ** Running commands
, commandsRun
, commandsRunWithFallback
, defaultCommandFallback

-- * Option Fields
, OptionField (..)
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand All @@ -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)
Expand All @@ -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

Expand Down
33 changes: 28 additions & 5 deletions cabal-install/src/Distribution/Client/Main.hs
Original file line number Diff line number Diff line change
Expand Up @@ -205,7 +205,8 @@ import Distribution.Simple.Command
, commandAddAction
, commandFromSpec
, commandShowOptions
, commandsRun
, commandsRunWithFallback
, defaultCommandFallback
, hiddenCommand
)
import Distribution.Simple.Compiler (PackageDBStack)
Expand All @@ -221,6 +222,8 @@ import Distribution.Simple.PackageDescription (readGenericPackageDescription)
import Distribution.Simple.Program
( configureAllKnownPrograms
, defaultProgramDb
, defaultProgramSearchPath
, findProgramOnSearchPath
, getProgramInvocationOutput
, simpleProgramInvocation
)
Expand Down Expand Up @@ -261,7 +264,7 @@ import System.Directory
, getCurrentDirectory
, withCurrentDirectory
)
import System.Environment (getProgName)
import System.Environment (getEnvironment, getExecutablePath, getProgName)
import System.FilePath
( dropExtension
, splitExtension
Expand All @@ -276,6 +279,7 @@ import System.IO
, stderr
, stdout
)
import System.Process (createProcess, env, proc)

-- | Entry point
--
Expand Down Expand Up @@ -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
Expand All @@ -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
Expand All @@ -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)
Expand Down
1 change: 0 additions & 1 deletion cabal-install/src/Distribution/Client/SavedFlags.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand Down
20 changes: 15 additions & 5 deletions cabal-testsuite/PackageTests/ExternalCommand/cabal.test.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
Original file line number Diff line number Diff line change
@@ -1,4 +1,5 @@
module Main where

main = do
putStrLn "aaaa"
import System.Environment

main = getArgs >>= print
9 changes: 3 additions & 6 deletions cabal-testsuite/PackageTests/ExternalCommandEnv/cabal.test.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
4 changes: 0 additions & 4 deletions cabal-testsuite/PackageTests/ExternalCommandHelp/cabal.out
Original file line number Diff line number Diff line change
Expand Up @@ -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...
Original file line number Diff line number Diff line change
Expand Up @@ -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

Expand Down
Original file line number Diff line number Diff line change
Expand Up @@ -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"
Loading

0 comments on commit d8ebb81

Please sign in to comment.