Commit fb8914dd authored by Mikhail Glushenkov's avatar Mikhail Glushenkov

Merge pull request #1976 from benarmston/exec-refactor

Refactor exec command to use the ConfiguredProgram abstraction
parents 120011f2 92868c4e
......@@ -5,6 +5,7 @@ cabal-dev/
Cabal/dist/
Cabal/tests/Setup
cabal-install/dist/
cabal-install/tests/PackageTests/*/dist/
.hpc/
*.hi
*.o
......
......@@ -34,6 +34,7 @@ module Distribution.Simple.Program.Db (
knownPrograms,
getProgramSearchPath,
setProgramSearchPath,
modifyProgramSearchPath,
userSpecifyPath,
userSpecifyPaths,
userMaybeSpecifyPath,
......@@ -185,6 +186,16 @@ getProgramSearchPath = progSearchPath
setProgramSearchPath :: ProgramSearchPath -> ProgramDb -> ProgramDb
setProgramSearchPath searchpath db = db { progSearchPath = searchpath }
-- | Modify the current 'ProgramSearchPath' used by the 'ProgramDb'.
-- This will affect programs that are configured from here on, so you
-- should usually modify it before configuring any programs.
--
modifyProgramSearchPath :: (ProgramSearchPath -> ProgramSearchPath)
-> ProgramDb
-> ProgramDb
modifyProgramSearchPath f db =
setProgramSearchPath (f $ getProgramSearchPath db) db
-- |User-specify this path. Basically override any path information
-- for this program in the configuration. If it's not a known
-- program ignore it.
......
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Client.Exec
-- Maintainer : cabal-devel@haskell.org
-- Portability : portable
--
-- Implementation of the 'exec' command. Runs an arbitrary executable in an
-- environment suitable for making use of the sandbox.
-----------------------------------------------------------------------------
module Distribution.Client.Exec ( exec
) where
import Distribution.Client.Sandbox.PackageEnvironment (sandboxPackageDBPath)
import Distribution.Client.Sandbox.Types (UseSandbox (..))
import Distribution.Simple.Compiler (Compiler)
import Distribution.Simple.GHC (ghcGlobalPackageDB)
import Distribution.Simple.Program (ghcProgram, lookupProgram)
import Distribution.Simple.Program.Db (ProgramDb, requireProgram, modifyProgramSearchPath)
import Distribution.Simple.Program.Find (ProgramSearchPathEntry(..))
import Distribution.Simple.Program.Run (programInvocation, runProgramInvocation)
import Distribution.Simple.Program.Types ( simpleProgram, ConfiguredProgram(..) )
import Distribution.Simple.Utils (die)
import Distribution.System (Platform)
import Distribution.Verbosity (Verbosity)
import System.FilePath (searchPathSeparator, (</>))
import Control.Applicative ((<$>))
import Data.Traversable as T
-- | Execute the given command in the package's environment.
--
-- The given command is executed with GHC configured to use the correct
-- package database and with the sandbox bin directory added to the PATH.
exec :: Verbosity
-> UseSandbox
-> Compiler
-> Platform
-> ProgramDb
-> [String]
-> IO ()
exec verbosity useSandbox comp platform programDb extraArgs =
case extraArgs of
(exe:args) -> do
program <- requireProgram' verbosity useSandbox programDb exe
env <- ((++) (programOverrideEnv program)) <$> environmentOverrides
let invocation = programInvocation
program { programOverrideEnv = env }
args
runProgramInvocation verbosity invocation
[] -> die "Please specify an executable to run"
where
environmentOverrides =
case useSandbox of
NoSandbox -> return []
(UseSandbox sandboxDir) ->
sandboxEnvironment verbosity sandboxDir comp platform programDb
-- | Return the package's sandbox environment.
--
-- The environment sets GHC_PACKAGE_PATH so that GHC will use the sandbox.
sandboxEnvironment :: Verbosity
-> FilePath
-> Compiler
-> Platform
-> ProgramDb
-> IO [(String, Maybe String)]
sandboxEnvironment verbosity sandboxDir comp platform programDb = do
mGlobalPackageDb <- T.sequence $ ghcGlobalPackageDB verbosity
<$> lookupProgram ghcProgram programDb
case mGlobalPackageDb of
Nothing -> die "exec only works with GHC"
Just gDb -> return $ overrides gDb
where
overrides gDb = [ ("GHC_PACKAGE_PATH", ghcPackagePath gDb) ]
ghcPackagePath gDb =
let s = sandboxPackageDBPath sandboxDir comp platform
in Just $ prependToSearchPath gDb s
prependToSearchPath path newValue =
newValue ++ [searchPathSeparator] ++ path
-- | Check that a program is configured and available to be run. If
-- a sandbox is available check in the sandbox's directory.
requireProgram' :: Verbosity
-> UseSandbox
-> ProgramDb
-> String
-> IO ConfiguredProgram
requireProgram' verbosity useSandbox programDb exe = do
(program, _) <- requireProgram
verbosity
(simpleProgram exe)
updateSearchPath
return program
where
updateSearchPath =
flip modifyProgramSearchPath programDb $ \searchPath ->
case useSandbox of
NoSandbox -> searchPath
UseSandbox sandboxDir ->
ProgramSearchPathDir (sandboxDir </> "bin") : searchPath
......@@ -1650,8 +1650,27 @@ defaultExecFlags = ExecFlags {
execCommand :: CommandUI ExecFlags
execCommand = CommandUI {
commandName = "exec",
commandSynopsis = "Run a command with the cabal environment",
commandDescription = Nothing,
commandSynopsis = "Execute a command in the context of the package",
commandDescription = Just $ \pname ->
"Execute the given command making the package's installed dependencies\n"
++ "available to GHC. When a sandbox is being used, this causes GHC to\n"
++ "use the sandbox package database as if it had been invoked directly\n"
++ "by cabal. If a sandbox is not being used, GHC is not affected.\n\n"
++ "Any cabal executable packages installed into either the user package\n"
++ "database or into the current package's sandbox (if there is a current\n"
++ "package and sandbox) are available on PATH.\n\n"
++ "Examples:\n"
++ " Install the executable package pandoc into a sandbox and run it:\n"
++ " " ++ pname ++ " sandbox init\n"
++ " " ++ pname ++ " install pandoc\n"
++ " " ++ pname ++ " exec pandoc foo.md\n\n"
++ " Install the executable package hlint into the user package database\n"
++ " and run it:\n"
++ " " ++ pname ++ " install --user hlint\n"
++ " " ++ pname ++ " exec hlint Foo.hs\n\n"
++ " Execute runghc on Foo.hs with runghc configured to use the\n"
++ " sandbox package database (if a sandbox is being used):\n"
++ " " ++ pname ++ " exec runghc Foo.hs\n",
commandUsage = \pname ->
"Usage: " ++ pname ++ " exec [FLAGS] COMMAND [-- [ARGS...]]\n\n"
++ "Flags for exec:",
......
......@@ -65,6 +65,7 @@ import qualified Distribution.Client.List as List
import Distribution.Client.Install (install)
import Distribution.Client.Configure (configure)
import Distribution.Client.Update (update)
import Distribution.Client.Exec (exec)
import Distribution.Client.Fetch (fetch)
import Distribution.Client.Freeze (freeze)
import Distribution.Client.Check as Check (check)
......@@ -80,7 +81,6 @@ import Distribution.Client.Sandbox (sandboxInit
,sandboxListSources
,sandboxHcPkg
,dumpPackageEnvironment
,withSandboxBinDirOnSearchPath
,getSandboxConfigFilePath
,loadConfigOrSandboxConfig
......@@ -97,7 +97,6 @@ import Distribution.Client.Sandbox (sandboxInit
,configPackageDB')
import Distribution.Client.Sandbox.PackageEnvironment
(setPackageDB
,sandboxPackageDBPath
,userPackageEnvironmentFile)
import Distribution.Client.Sandbox.Timestamp (maybeAddCompilerTimestampRecord)
import Distribution.Client.Sandbox.Types (UseSandbox(..), whenUsingSandbox)
......@@ -127,14 +126,11 @@ import Distribution.Simple.Configure
, ConfigStateFileErrorType(..), localBuildInfoFile
, getPersistBuildConfig, tryGetPersistBuildConfig )
import qualified Distribution.Simple.LocalBuildInfo as LBI
import Distribution.Simple.GHC (ghcGlobalPackageDB)
import Distribution.Simple.Program (defaultProgramConfiguration, lookupProgram, ghcProgram)
import Distribution.Simple.Program.Run (getEffectiveEnvironment)
import Distribution.Simple.Program (defaultProgramConfiguration)
import qualified Distribution.Simple.Setup as Cabal
import Distribution.Simple.Utils
( cabalVersion, debug, die, notice, info, topHandler
, findPackageDesc, tryFindPackageDesc , rawSystemExit
, rawSystemExitWithEnv )
( cabalVersion, die, notice, info, topHandler
, findPackageDesc, tryFindPackageDesc )
import Distribution.Text
( display )
import Distribution.Verbosity as Verbosity
......@@ -145,7 +141,7 @@ import qualified Paths_cabal_install (version)
import System.Environment (getArgs, getProgName)
import System.Exit (exitFailure)
import System.FilePath (splitExtension, takeExtension, searchPathSeparator)
import System.FilePath (splitExtension, takeExtension)
import System.IO ( BufferMode(LineBuffering), hSetBuffering
#ifdef mingw32_HOST_OS
, stderr
......@@ -1062,32 +1058,9 @@ execAction execFlags extraArgs globalFlags = do
let verbosity = fromFlag (execVerbosity execFlags)
(useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags
mempty
case extraArgs of
(exec:args) -> do
case useSandbox of
NoSandbox ->
rawSystemExit verbosity exec args
(UseSandbox sandboxDir) -> do
let configFlags = savedConfigureFlags config
(comp, platform, conf) <- configCompilerAux' configFlags
withSandboxBinDirOnSearchPath sandboxDir $ do
menv <- newEnv sandboxDir comp platform conf verbosity
case menv of
Just env -> rawSystemExitWithEnv verbosity exec args env
Nothing -> rawSystemExit verbosity exec args
-- Error handling.
[] -> die $ "Please specify an executable to run"
where
newEnv sandboxDir comp platform conf verbosity = do
let s = sandboxPackageDBPath sandboxDir comp platform
case lookupProgram ghcProgram conf of
Nothing -> do
debug verbosity "sandbox exec only works with GHC"
exitFailure
Just ghcProg -> do
g <- ghcGlobalPackageDB verbosity ghcProg
getEffectiveEnvironment
[("GHC_PACKAGE_PATH", Just $ s ++ [searchPathSeparator] ++ g)]
let configFlags = savedConfigureFlags config
(comp, platform, conf) <- configCompilerAux' configFlags
exec verbosity useSandbox comp platform conf extraArgs
-- | See 'Distribution.Client.Install.withWin32SelfUpgrade' for details.
--
......
......@@ -73,6 +73,7 @@ executable cabal
Distribution.Client.Dependency.Modular.Tree
Distribution.Client.Dependency.Modular.Validate
Distribution.Client.Dependency.Modular.Version
Distribution.Client.Exec
Distribution.Client.Fetch
Distribution.Client.FetchUtils
Distribution.Client.Freeze
......@@ -212,6 +213,7 @@ test-suite package-tests
hs-source-dirs: tests
main-is: PackageTests.hs
other-modules:
PackageTests.Exec.Check
PackageTests.Freeze.Check
PackageTests.PackageTester
build-depends:
......
......@@ -7,6 +7,7 @@ module Main
where
-- Modules from Cabal.
import Distribution.Simple.Program.Builtin (ghcPkgProgram)
import Distribution.Simple.Program.Db (defaultProgramDb, requireProgram)
import Distribution.Simple.Program.Types
( Program(..), simpleProgram, programPath)
......@@ -19,13 +20,15 @@ import System.Directory (getCurrentDirectory, setCurrentDirectory)
import Test.Framework (Test, defaultMain, testGroup)
-- Modules containing the tests.
import qualified PackageTests.Exec.Check
import qualified PackageTests.Freeze.Check
-- List of tests to run. Each test will be called with the path to the
-- cabal binary to use.
tests :: [FilePath -> Test]
tests =
[ testGroup "Freeze" . PackageTests.Freeze.Check.tests
tests :: FilePath -> FilePath -> [Test]
tests cabalPath ghcPkgPath =
[ testGroup "Freeze" $ PackageTests.Freeze.Check.tests cabalPath
, testGroup "Exec" $ PackageTests.Exec.Check.tests cabalPath ghcPkgPath
]
cabalProgram :: Program
......@@ -36,12 +39,15 @@ cabalProgram = (simpleProgram "cabal") {
main :: IO ()
main = do
(cabal, _) <- requireProgram normal cabalProgram defaultProgramDb
(ghcPkg, _) <- requireProgram normal ghcPkgProgram defaultProgramDb
let cabalPath = programPath cabal
ghcPkgPath = programPath ghcPkg
putStrLn $ "Using cabal: " ++ cabalPath
putStrLn $ "Using ghc-pkg: " ++ ghcPkgPath
cwd <- getCurrentDirectory
let runTests = do
setCurrentDirectory "tests"
defaultMain (map ($ cabalPath) tests)
defaultMain $ tests cabalPath ghcPkgPath
-- Change back to the old working directory so that the tests can be
-- repeatedly run in `cabal repl` via `:main`.
runTests `E.finally` setCurrentDirectory cwd
module PackageTests.Exec.Check
( tests
) where
import PackageTests.PackageTester
import Test.Framework as TF (Test)
import Test.Framework.Providers.HUnit (testCase)
import Test.HUnit (assertBool)
import Control.Applicative ((<$>))
import Data.List (intercalate, isInfixOf)
import System.FilePath ((</>))
dir :: FilePath
dir = "PackageTests" </> "Exec"
tests :: FilePath -> FilePath -> [TF.Test]
tests cabalPath ghcPkgPath =
[ testCase "exits with failure if given no argument" $ do
result <- cabal_exec dir [] cabalPath
assertExecFailed result
, testCase "prints error message if given no argument" $ do
result <- cabal_exec dir [] cabalPath
assertExecFailed result
let output = outputText result
expected = "specify an executable to run"
errMsg = "should have requested an executable be specified\n" ++
output
assertBool errMsg $
expected `isInfixOf` (intercalate " " . lines $ output)
, testCase "runs the given command" $ do
result <- cabal_exec dir ["echo", "this", "string"] cabalPath
assertExecSucceeded result
let output = outputText result
expected = "this string"
errMsg = "should have ran the given command\n" ++ output
assertBool errMsg $
expected `isInfixOf` (intercalate " " . lines $ output)
, testCase "can run executables installed in the sandbox" $ do
-- Test that an executable installed into the sandbox can be found.
-- We do this by removing any existing sandbox. Checking that the
-- executable cannot be found. Creating a new sandbox. Installing
-- the executable and checking it can be run.
_ <- assertCleanSucceeded <$> cabal_clean dir [] cabalPath
_ <- assertSandboxSucceeded <$> cabal_sandbox dir ["delete"] cabalPath
assertMyExecutableNotFound cabalPath
_ <- assertSandboxSucceeded <$> cabal_sandbox dir ["init"] cabalPath
_ <- assertInstallSucceeded <$> cabal_install dir [] cabalPath
result <- cabal_exec dir ["my-executable"] cabalPath
assertExecSucceeded result
let output = outputText result
expected = "This is my-executable"
errMsg = "should have found a my-executable\n" ++ output
assertBool errMsg $
expected `isInfixOf` (intercalate " " . lines $ output)
, testCase "adds the sandbox bin directory to the PATH" $ do
_ <- assertCleanSucceeded <$> cabal_clean dir [] cabalPath
_ <- assertSandboxSucceeded <$> cabal_sandbox dir ["delete"] cabalPath
assertMyExecutableNotFound cabalPath
_ <- assertSandboxSucceeded <$> cabal_sandbox dir ["init"] cabalPath
_ <- assertInstallSucceeded <$> cabal_install dir [] cabalPath
result <- cabal_exec dir ["bash", "--", "-c", "my-executable"] cabalPath
assertExecSucceeded result
let output = outputText result
expected = "This is my-executable"
errMsg = "should have found a my-executable\n" ++ output
assertBool errMsg $
expected `isInfixOf` (intercalate " " . lines $ output)
, testCase "configures GHC to use the sandbox" $ do
let libNameAndVersion = "my-0.1"
_ <- assertCleanSucceeded <$> cabal_clean dir [] cabalPath
_ <- assertSandboxSucceeded <$> cabal_sandbox dir ["delete"] cabalPath
_ <- assertSandboxSucceeded <$> cabal_sandbox dir ["init"] cabalPath
_ <- assertInstallSucceeded <$> cabal_install dir [] cabalPath
assertMyLibIsNotAvailableOutsideofSandbox ghcPkgPath libNameAndVersion
result <- cabal_exec dir ["ghc-pkg", "list"] cabalPath
assertExecSucceeded result
let output = outputText result
errMsg = "my library should have been found"
assertBool errMsg $
libNameAndVersion `isInfixOf` (intercalate " " . lines $ output)
-- , testCase "can find executables built from the package" $ do
-- , testCase "configures cabal to use the sandbox" $ do
]
assertMyExecutableNotFound :: FilePath -> IO ()
assertMyExecutableNotFound cabalPath = do
result <- cabal_exec dir ["my-executable"] cabalPath
assertExecFailed result
let output = outputText result
expected = "cabal: The program 'my-executable' is required but it " ++
"could not be found"
errMsg = "should not have found a my-executable\n" ++ output
assertBool errMsg $
expected `isInfixOf` (intercalate " " . lines $ output)
assertMyLibIsNotAvailableOutsideofSandbox :: FilePath -> String -> IO ()
assertMyLibIsNotAvailableOutsideofSandbox ghcPkgPath libNameAndVersion = do
(_, _, output) <- run (Just $ dir) ghcPkgPath ["list"]
assertBool "my library should not have been found" $ not $
libNameAndVersion `isInfixOf` (intercalate " " . lines $ output)
module Foo where
foo :: String
foo = "foo"
module Main where
main :: IO ()
main = do
putStrLn "This is my-executable"
name: my
version: 0.1
license: BSD3
cabal-version: >= 1.2
build-type: Simple
library
exposed-modules: Foo
build-depends: base
executable my-executable
main-is: My.hs
build-depends: base
......@@ -20,14 +20,24 @@ module PackageTests.PackageTester
( Result(..)
-- * Running cabal commands
, cabal_clean
, cabal_exec
, cabal_freeze
, cabal_install
, cabal_sandbox
, run
-- * Test helpers
, assertCleanSucceeded
, assertExecFailed
, assertExecSucceeded
, assertFreezeSucceeded
, assertInstallSucceeded
, assertSandboxSucceeded
) where
import qualified Control.Exception.Extensible as E
import Control.Monad (unless)
import Control.Monad (when, unless)
import Data.Maybe (fromMaybe)
import System.Directory (canonicalizePath, doesFileExist)
import System.Environment (getEnv)
......@@ -47,10 +57,13 @@ import Distribution.Verbosity (Verbosity, flagToVerbosity, normal)
data Success = Failure
-- | ConfigureSuccess
-- | BuildSuccess
-- | InstallSuccess
-- | TestSuccess
-- | BenchSuccess
| CleanSuccess
| ExecSuccess
| FreezeSuccess
| InstallSuccess
| SandboxSuccess
deriving (Eq, Show)
data Result = Result
......@@ -75,12 +88,36 @@ recordRun (cmd, exitCode, exeOutput) thisSucc res =
cmd ++ "\n" ++ exeOutput
}
-- | Run the clean command and return its result.
cabal_clean :: FilePath -> [String] -> FilePath -> IO Result
cabal_clean dir args cabalPath = do
res <- cabal dir (["clean"] ++ args) cabalPath
return $ recordRun res CleanSuccess nullResult
-- | Run the exec command and return its result.
cabal_exec :: FilePath -> [String] -> FilePath -> IO Result
cabal_exec dir args cabalPath = do
res <- cabal dir (["exec"] ++ args) cabalPath
return $ recordRun res ExecSuccess nullResult
-- | Run the freeze command and return its result.
cabal_freeze :: FilePath -> [String] -> FilePath -> IO Result
cabal_freeze dir args cabalPath = do
res <- cabal dir (["freeze"] ++ args) cabalPath
return $ recordRun res FreezeSuccess nullResult
-- | Run the install command and return its result.
cabal_install :: FilePath -> [String] -> FilePath -> IO Result
cabal_install dir args cabalPath = do
res <- cabal dir (["install"] ++ args) cabalPath
return $ recordRun res InstallSuccess nullResult
-- | Run the sandbox command and return its result.
cabal_sandbox :: FilePath -> [String] -> FilePath -> IO Result
cabal_sandbox dir args cabalPath = do
res <- cabal dir (["sandbox"] ++ args) cabalPath
return $ recordRun res SandboxSuccess nullResult
-- | Returns the command that was issued, the return code, and the output text.
cabal :: FilePath -> [String] -> FilePath -> IO (String, ExitCode, String)
cabal dir cabalArgs cabalPath = do
......@@ -118,12 +155,42 @@ run cwd path args = do
------------------------------------------------------------------------
-- * Test helpers
assertCleanSucceeded :: Result -> Assertion
assertCleanSucceeded result = unless (successful result) $
assertFailure $
"expected: \'cabal clean\' should succeed\n" ++
" output: " ++ outputText result
assertExecSucceeded :: Result -> Assertion
assertExecSucceeded result = unless (successful result) $
assertFailure $
"expected: \'cabal exec\' should succeed\n" ++
" output: " ++ outputText result
assertExecFailed :: Result -> Assertion
assertExecFailed result = when (successful result) $
assertFailure $
"expected: \'cabal exec\' should fail\n" ++
" output: " ++ outputText result
assertFreezeSucceeded :: Result -> Assertion
assertFreezeSucceeded result = unless (successful result) $
assertFailure $
"expected: \'cabal freeze\' should succeed\n" ++
" output: " ++ outputText result
assertInstallSucceeded :: Result -> Assertion
assertInstallSucceeded result = unless (successful result) $
assertFailure $
"expected: \'cabal install\' should succeed\n" ++
" output: " ++ outputText result
assertSandboxSucceeded :: Result -> Assertion
assertSandboxSucceeded result = unless (successful result) $
assertFailure $
"expected: \'cabal sandbox\' should succeed\n" ++
" output: " ++ outputText result
------------------------------------------------------------------------
-- Verbosity
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment