Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP

Loading…

Add tests for withSandboxBinDirOnSearchPath #1

Closed
wants to merge 2 commits into from

3 participants

@sol

No description provided.

@23Skidoo
Owner

Can you submit this as a pull request for the main Cabal repo once my patch is accepted? I'm not sure how the others feel about the hspec dependency.

@23Skidoo 23Skidoo closed this
@23Skidoo
Owner

Johan has merged my patch into Cabal master, please submit a pull request for the main Cabal repo.

@sol

@tibbe Is hspec fine with you?

@tibbe

@sol Does it integrate with test-framework? If it's really a better fit for the test, sure. But lets not introduce another test framework just because.

@23Skidoo
Owner

Committed to HEAD in modified form: haskell/cabal@043bbd9

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
This page is out of date. Refresh to see the latest.
View
2  cabal-install/.ghci
@@ -1 +1 @@
-:set -idist/build/autogen -optP-include -optPdist/build/autogen/cabal_macros.h
+:set -idist/build/autogen -optP-include -optPdist/build/autogen/cabal_macros.h -itest -DTEST
View
61 cabal-install/Distribution/Client/Sandbox.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Client.Sandbox
@@ -8,6 +9,9 @@
-----------------------------------------------------------------------------
module Distribution.Client.Sandbox (
+#ifdef TEST
+ withSandboxBinDirOnSearchPath,
+#endif
sandboxInit,
sandboxDelete,
sandboxAddSource,
@@ -46,18 +50,24 @@ import Distribution.Simple.Setup ( Flag(..), toFlag
, BuildFlags(..), HaddockFlags(..)
, buildCommand, fromFlagOrDefault )
import Distribution.Simple.Utils ( die, debug, notice, info
+ , intercalate
, createDirectoryIfMissingVerbose )
import Distribution.Verbosity ( Verbosity, lessVerbose )
+import Distribution.Compat.SetEnv ( setEnv )
import qualified Distribution.Client.Index as Index
import qualified Distribution.Simple.Register as Register
+import Control.Exception ( bracket_ )
import Control.Monad ( unless, when )
import Data.Monoid ( mappend, mempty )
+import Data.List ( delete )
import System.Directory ( canonicalizePath
, doesDirectoryExist
, getCurrentDirectory
, removeDirectoryRecursive
, removeFile )
-import System.FilePath ( (</>) )
+import System.Environment ( getEnv )
+import System.FilePath ( (</>), getSearchPath
+ , searchPathSeparator )
-- | Load the default package environment file. In addition to a
@@ -85,6 +95,29 @@ tryGetIndexFilePath pkgEnv = do
_ -> die $ "Distribution.Client.Sandbox.tryGetIndexFilePath: " ++
"too many local repos found"
+-- | Temporarily add $SANDBOX_DIR/bin to $PATH.
+withSandboxBinDirOnSearchPath :: FilePath -> IO a -> IO a
+withSandboxBinDirOnSearchPath sandboxDir = bracket_ addBinDir rmBinDir
+ where
+ -- TODO: Instead of modifying the global process state, it'd be better to
+ -- set the environment individually for each subprocess invocation. Will
+ -- have to wait until the Shell monad is implemented, because otherwise the
+ -- change will be too intrusive.
+ addBinDir :: IO ()
+ addBinDir = do
+ oldPath <- getEnv "PATH"
+ let newPath = sandboxBin ++ (searchPathSeparator:oldPath)
+ setEnv "PATH" newPath
+
+ rmBinDir :: IO ()
+ rmBinDir = do
+ oldPath <- getSearchPath
+ let newPath = intercalate [searchPathSeparator]
+ (delete sandboxBin oldPath)
+ setEnv "PATH" newPath
+
+ sandboxBin = sandboxDir </> "bin"
+
-- | Initialise a package DB for this compiler if it doesn't exist.
initPackageDBIfNeeded :: Verbosity -> ConfigFlags
-> Compiler -> ProgramConfiguration
@@ -177,15 +210,16 @@ sandboxConfigure verbosity
let configFlags'' = setPackageDB sandboxDir comp configFlags'
initPackageDBIfNeeded verbosity configFlags'' comp conf
- configure verbosity
- (configPackageDB' configFlags'') (globalRepos globalFlags')
- comp conf configFlags'' configExFlags' extraArgs
+ withSandboxBinDirOnSearchPath sandboxDir $
+ configure verbosity
+ (configPackageDB' configFlags'') (globalRepos globalFlags')
+ comp conf configFlags'' configExFlags' extraArgs
-- | Entry point for the 'cabal sandbox-build' command.
sandboxBuild :: Verbosity -> SandboxFlags -> BuildFlags -> [String] -> IO ()
sandboxBuild verbosity _sandboxFlags buildFlags' extraArgs = do
-- Check that the sandbox exists.
- _ <- tryLoadSandboxConfig verbosity
+ (sandboxDir, _) <- tryLoadSandboxConfig verbosity
let setupScriptOptions = defaultSetupScriptOptions {
useDistPref = fromFlagOrDefault
@@ -195,8 +229,10 @@ sandboxBuild verbosity _sandboxFlags buildFlags' extraArgs = do
buildFlags = buildFlags' {
buildVerbosity = toFlag verbosity
}
- setupWrapper verbosity setupScriptOptions Nothing
- (buildCommand defaultProgramConfiguration) (const buildFlags) extraArgs
+
+ withSandboxBinDirOnSearchPath sandboxDir $
+ setupWrapper verbosity setupScriptOptions Nothing
+ (buildCommand defaultProgramConfiguration) (const buildFlags) extraArgs
-- | Entry point for the 'cabal sandbox-install' command.
sandboxInstall :: Verbosity -> SandboxFlags -> ConfigFlags -> ConfigExFlags
@@ -234,11 +270,12 @@ sandboxInstall verbosity _sandboxFlags configFlags configExFlags
let configFlags'' = setPackageDB sandboxDir comp configFlags'
initPackageDBIfNeeded verbosity configFlags'' comp conf
- install verbosity
- (configPackageDB' configFlags'') (globalRepos globalFlags')
- comp conf
- globalFlags' configFlags'' configExFlags' installFlags' haddockFlags
- targets
+ withSandboxBinDirOnSearchPath sandboxDir $
+ install verbosity
+ (configPackageDB' configFlags'') (globalRepos globalFlags')
+ comp conf
+ globalFlags' configFlags'' configExFlags' installFlags' haddockFlags
+ targets
configPackageDB' :: ConfigFlags -> PackageDBStack
configPackageDB' cfg =
View
9 cabal-install/cabal-install.cabal
@@ -146,3 +146,12 @@ Executable cabal
else
build-depends: unix >= 1.0 && < 2.7
c-sources: cbits/getnumcores.c
+
+test-suite spec
+ type: exitcode-stdio-1.0
+ ghc-options: -Wall -threaded
+ cpp-options: -DTEST
+ hs-source-dirs: . test
+ main-is: Spec.hs
+ build-depends: base
+ , hspec >= 1.3
View
24 cabal-install/test/Distribution/Client/SandboxSpec.hs
@@ -0,0 +1,24 @@
+module Distribution.Client.SandboxSpec (main, spec) where
+
+import Test.Hspec
+
+import Distribution.Client.Sandbox
+
+import Control.Applicative
+import System.FilePath (getSearchPath)
+
+main :: IO ()
+main = hspec spec
+
+spec :: Spec
+spec = do
+ describe "withSandboxBinDirOnSearchPath" $ do
+ it "temporarily adds $SANDBOX_DIR/bin to $PATH" $ do
+ withSandboxBinDirOnSearchPath "foo" $ do
+ r <- getSearchPath
+ r `shouldSatisfy` elem "foo/bin"
+
+ it "restores the original PATH after executing the action" $ do
+ r <- getSearchPath
+ withSandboxBinDirOnSearchPath "foo" (pure ())
+ getSearchPath `shouldReturn` r
View
1  cabal-install/test/Spec.hs
@@ -0,0 +1 @@
+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
Something went wrong with that request. Please try again.