Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Already on GitHub? Sign in to your account

Add tests for withSandboxBinDirOnSearchPath #1

Closed
wants to merge 2 commits into
from
Jump to file or symbol
Failed to load files and symbols.
+84 −13
Split
View
@@ -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
@@ -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 =
@@ -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
@@ -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
@@ -0,0 +1 @@
+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}