Commit 63252fb6 authored by Edward Z. Yang's avatar Edward Z. Yang
Browse files

Sandbox support in the test suite.



A bit of trickiness here.  The high points:

    - We need to feed --with-compiler to cabal.config, NOT
      the flag, because sandbox doesn't know how to read in
      compilers except from the global config.  This is
      arguably a bug but I can't be bothered to fix it.

    - We need to NOT provide certain commands when we're
      in sandbox mode; this is controlled by testHaveSandbox.

    - Use withSandbox to start a session in the sandbox.
      It inits the sandbox for you.

Signed-off-by: default avatarEdward Z. Yang <ezyang@cs.stanford.edu>
parent 0ec24958
......@@ -9,6 +9,9 @@ module Test.Cabal.Monad (
-- * The monad
TestM,
runTestM,
-- * Helper functions
programPathM,
requireProgramM,
-- * The test environment
TestEnv(..),
getTestEnv,
......@@ -19,6 +22,8 @@ module Test.Cabal.Monad (
testDistDir,
testPackageDbDir,
testHomeDir,
testSandboxDir,
testSandboxConfigFile,
-- * Skipping tests
skip,
skipIf,
......@@ -36,6 +41,7 @@ import Test.Cabal.Plan
import Distribution.Simple.Compiler (PackageDBStack, PackageDB(..), compilerFlavor)
import Distribution.Simple.Program.Db
import Distribution.Simple.Program
import Distribution.Simple.Configure
( getPersistBuildConfig, configCompilerEx )
import Distribution.Types.LocalBuildInfo
......@@ -183,6 +189,7 @@ runTestM m = do
testShouldFail = False,
testRelativeCurrentDir = ".",
testHavePackageDb = False,
testHaveSandbox = False,
testCabalInstallAsSetup = False,
testCabalProjectFile = "cabal.project",
testPlan = Nothing
......@@ -190,7 +197,7 @@ runTestM m = do
runReaderT (cleanup >> m) env
where
cleanup = do
env <- ask
env <- getTestEnv
onlyIfExists . removeDirectoryRecursive $ testWorkDir env
-- NB: it's important to initialize this ourselves, as
-- the default configuration hardcodes Hackage, which we do
......@@ -198,7 +205,20 @@ runTestM m = do
-- hit Hackage.)
liftIO $ createDirectoryIfMissing True (testHomeDir env </> ".cabal")
-- TODO: This doesn't work on Windows
liftIO $ writeFile (testHomeDir env </> ".cabal" </> "config") ""
ghc_path <- programPathM ghcProgram
liftIO $ writeFile (testHomeDir env </> ".cabal" </> "config")
$ unlines [ "with-compiler: " ++ ghc_path ]
requireProgramM :: Program -> TestM ConfiguredProgram
requireProgramM program = do
env <- getTestEnv
(configured_program, _) <- liftIO $
requireProgram (testVerbosity env) program (testProgramDb env)
return configured_program
programPathM :: Program -> TestM FilePath
programPathM program = do
fmap programPath (requireProgramM program)
-- | Run an IO action, and suppress a "does not exist" error.
onlyIfExists :: MonadIO m => IO () -> m ()
......@@ -248,6 +268,8 @@ data TestEnv = TestEnv
, testRelativeCurrentDir :: FilePath
-- | Says if we've initialized the per-test package DB
, testHavePackageDb :: Bool
-- | Says if we're working in a sandbox
, testHaveSandbox :: Bool
-- | Says if we're testing cabal-install as setup
, testCabalInstallAsSetup :: Bool
-- | Says what cabal.project file to use (probed)
......@@ -293,3 +315,11 @@ testPackageDbDir env = testWorkDir env </> "packagedb"
-- | The absolute prefix where our simulated HOME directory is.
testHomeDir :: TestEnv -> FilePath
testHomeDir env = testWorkDir env </> "home"
-- | The absolute prefix of our sandbox directory
testSandboxDir :: TestEnv -> FilePath
testSandboxDir env = testWorkDir env </> "sandbox"
-- | The sandbox configuration file
testSandboxConfigFile :: TestEnv -> FilePath
testSandboxConfigFile env = testWorkDir env </> "cabal.sandbox.config"
......@@ -78,17 +78,6 @@ runProgramM prog args = do
configured_prog <- requireProgramM prog
runM (programPath configured_prog) args
requireProgramM :: Program -> TestM ConfiguredProgram
requireProgramM program = do
env <- getTestEnv
(configured_program, _) <- liftIO $
requireProgram (testVerbosity env) program (testProgramDb env)
return configured_program
programPathM :: Program -> TestM FilePath
programPathM program = do
fmap programPath (requireProgramM program)
getLocalBuildInfoM :: TestM LocalBuildInfo
getLocalBuildInfoM = do
env <- getTestEnv
......@@ -124,6 +113,9 @@ setup' cmd args = do
-- here will make us error loudly if we try to install
-- into a bad place.
[ "--global"
-- NB: technically unnecessary with Cabal, but
-- definitely needed for Setup, which doesn't
-- respect cabal.config
, "--with-ghc", ghc_path
-- These flags make the test suite run faster
-- Can't do this unless we LD_LIBRARY_PATH correctly
......@@ -217,18 +209,51 @@ packageDBParams dbs = "--package-db=clear"
-- * Running cabal
cabal :: String -> [String] -> TestM ()
cabal "sandbox" _ =
error "Use cabal_sandbox instead"
cabal cmd args = void (cabal' cmd args)
cabal' :: String -> [String] -> TestM Result
cabal' "sandbox" _ =
-- NB: We don't just auto-pass this through, because it's
-- possible that the first argument isn't the sub-sub-command.
-- So make sure the user specifies it correctly.
error "Use cabal_sandbox' instead"
cabal' cmd args = do
env <- getTestEnv
ghc_path <- programPathM ghcProgram
let cabal_args = [ cmd, "-v"
, "--with-ghc", ghc_path
, "--builddir", testWorkDir env
, "--project-file", testCabalProjectFile env ]
let extra_args
| testHaveSandbox env
= [ ]
-- These flags are only understood by some subcommands
-- TODO: Make this tighter
| otherwise
= [ "--builddir", testWorkDir env
, "--project-file", testCabalProjectFile env ]
global_args
| testHaveSandbox env
= [ "--sandbox-config-file", testSandboxConfigFile env ]
| otherwise
= []
cabal_args = global_args
++ [ cmd, "-v" ]
++ extra_args
++ args
cabal_raw' cabal_args
cabal_sandbox :: String -> [String] -> TestM ()
cabal_sandbox cmd args = void $ cabal_sandbox' cmd args
cabal_sandbox' :: String -> [String] -> TestM Result
cabal_sandbox' cmd args = do
env <- getTestEnv
let cabal_args = [ "--sandbox-config-file", testSandboxConfigFile env
, "sandbox", cmd, "-v" ]
++ args
-- TODO: prevent .cabal in HOME from interfering with tests
cabal_raw' cabal_args
cabal_raw' :: [String] -> TestM Result
cabal_raw' cabal_args = do
env <- getTestEnv
r <- liftIO $ run (testVerbosity env)
(Just (testCurrentDir env))
(testEnvironment env)
......@@ -238,6 +263,13 @@ cabal' cmd args = do
record r
requireSuccess r
withSandbox :: TestM a -> TestM a
withSandbox m = do
env0 <- getTestEnv
-- void $ cabal_raw' ["sandbox", "init", "--sandbox", testSandboxDir env0]
cabal_sandbox "init" ["--sandbox", testSandboxDir env0]
withReaderT (\env -> env { testHaveSandbox = True }) m
withProjectFile :: FilePath -> TestM a -> TestM a
withProjectFile fp m =
withReaderT (\env -> env { testCabalProjectFile = fp }) m
......
Supports Markdown
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