cabal-install-1.24.0.0: Distribution/Client/Sandbox.hs
{-# LANGUAGE CPP #-}
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Client.Sandbox
-- Maintainer : cabal-devel@haskell.org
-- Portability : portable
--
-- UI for the sandboxing functionality.
-----------------------------------------------------------------------------
module Distribution.Client.Sandbox (
sandboxInit,
sandboxDelete,
sandboxAddSource,
sandboxAddSourceSnapshot,
sandboxDeleteSource,
sandboxListSources,
sandboxHcPkg,
dumpPackageEnvironment,
withSandboxBinDirOnSearchPath,
getSandboxConfigFilePath,
loadConfigOrSandboxConfig,
findSavedDistPref,
initPackageDBIfNeeded,
maybeWithSandboxDirOnSearchPath,
WereDepsReinstalled(..),
reinstallAddSourceDeps,
maybeReinstallAddSourceDeps,
SandboxPackageInfo(..),
maybeWithSandboxPackageInfo,
tryGetIndexFilePath,
sandboxBuildDir,
getInstalledPackagesInSandbox,
updateSandboxConfigFileFlag,
updateInstallDirs,
configPackageDB', configCompilerAux', getPersistOrConfigCompiler
) where
import Distribution.Client.Setup
( SandboxFlags(..), ConfigFlags(..), ConfigExFlags(..), InstallFlags(..)
, GlobalFlags(..), defaultConfigExFlags, defaultInstallFlags
, defaultSandboxLocation, withRepoContext )
import Distribution.Client.Sandbox.Timestamp ( listModifiedDeps
, maybeAddCompilerTimestampRecord
, withAddTimestamps
, removeTimestamps )
import Distribution.Client.Config
( SavedConfig(..), defaultUserInstall, loadConfig )
import Distribution.Client.Dependency ( foldProgress )
import Distribution.Client.IndexUtils ( BuildTreeRefType(..) )
import Distribution.Client.Install ( InstallArgs,
makeInstallContext,
makeInstallPlan,
processInstallPlan )
import Distribution.Utils.NubList ( fromNubList )
import Distribution.Client.Sandbox.PackageEnvironment
( PackageEnvironment(..), PackageEnvironmentType(..)
, createPackageEnvironmentFile, classifyPackageEnvironment
, tryLoadSandboxPackageEnvironmentFile, loadUserConfig
, commentPackageEnvironment, showPackageEnvironmentWithComments
, sandboxPackageEnvironmentFile, userPackageEnvironmentFile
, sandboxPackageDBPath )
import Distribution.Client.Sandbox.Types ( SandboxPackageInfo(..)
, UseSandbox(..) )
import Distribution.Client.SetupWrapper
( SetupScriptOptions(..), defaultSetupScriptOptions )
import Distribution.Client.Types ( PackageLocation(..)
, SourcePackage(..) )
import Distribution.Client.Utils ( inDir, tryCanonicalizePath
, tryFindAddSourcePackageDesc)
import Distribution.PackageDescription.Configuration
( flattenPackageDescription )
import Distribution.PackageDescription.Parse ( readPackageDescription )
import Distribution.Simple.Compiler ( Compiler(..), PackageDB(..)
, PackageDBStack )
import Distribution.Simple.Configure ( configCompilerAuxEx
, interpretPackageDbFlags
, getPackageDBContents
, maybeGetPersistBuildConfig
, findDistPrefOrDefault
, findDistPref )
import qualified Distribution.Simple.LocalBuildInfo as LocalBuildInfo
import Distribution.Simple.PreProcess ( knownSuffixHandlers )
import Distribution.Simple.Program ( ProgramConfiguration )
import Distribution.Simple.Setup ( Flag(..), HaddockFlags(..)
, fromFlagOrDefault, flagToMaybe )
import Distribution.Simple.SrcDist ( prepareTree )
import Distribution.Simple.Utils ( die, debug, notice, info, warn
, debugNoWrap, defaultPackageDesc
, intercalate, topHandlerWith
, createDirectoryIfMissingVerbose )
import Distribution.Package ( Package(..) )
import Distribution.System ( Platform )
import Distribution.Text ( display )
import Distribution.Verbosity ( Verbosity, lessVerbose )
import Distribution.Compat.Environment ( lookupEnv, setEnv )
import Distribution.Client.Compat.FilePerms ( setFileHidden )
import qualified Distribution.Client.Sandbox.Index as Index
import Distribution.Simple.PackageIndex ( InstalledPackageIndex )
import qualified Distribution.Simple.PackageIndex as InstalledPackageIndex
import qualified Distribution.Simple.Register as Register
import qualified Data.Map as M
import qualified Data.Set as S
import Data.Either (partitionEithers)
import Control.Exception ( assert, bracket_ )
import Control.Monad ( forM, liftM, liftM2, unless, when )
import Data.Bits ( shiftL, shiftR, xor )
import Data.Char ( ord )
import Data.IORef ( newIORef, writeIORef, readIORef )
import Data.List ( delete
, foldl'
, intersperse
, isPrefixOf
, groupBy )
import Data.Maybe ( fromJust )
#if !MIN_VERSION_base(4,8,0)
import Data.Monoid ( mempty, mappend )
#endif
import Data.Word ( Word32 )
import Numeric ( showHex )
import System.Directory ( canonicalizePath
, createDirectory
, doesDirectoryExist
, doesFileExist
, getCurrentDirectory
, removeDirectoryRecursive
, removeFile
, renameDirectory )
import System.FilePath ( (</>), equalFilePath
, getSearchPath
, searchPathSeparator
, splitSearchPath
, takeDirectory )
--
-- * Constants
--
-- | The name of the sandbox subdirectory where we keep snapshots of add-source
-- dependencies.
snapshotDirectoryName :: FilePath
snapshotDirectoryName = "snapshots"
-- | Non-standard build dir that is used for building add-source deps instead of
-- "dist". Fixes surprising behaviour in some cases (see issue #1281).
sandboxBuildDir :: FilePath -> FilePath
sandboxBuildDir sandboxDir = "dist/dist-sandbox-" ++ showHex sandboxDirHash ""
where
sandboxDirHash = jenkins sandboxDir
-- See http://en.wikipedia.org/wiki/Jenkins_hash_function
jenkins :: String -> Word32
jenkins str = loop_finish $ foldl' loop 0 str
where
loop :: Word32 -> Char -> Word32
loop hash key_i' = hash'''
where
key_i = toEnum . ord $ key_i'
hash' = hash + key_i
hash'' = hash' + (shiftL hash' 10)
hash''' = hash'' `xor` (shiftR hash'' 6)
loop_finish :: Word32 -> Word32
loop_finish hash = hash'''
where
hash' = hash + (shiftL hash 3)
hash'' = hash' `xor` (shiftR hash' 11)
hash''' = hash'' + (shiftL hash'' 15)
--
-- * Basic sandbox functions.
--
-- | If @--sandbox-config-file@ wasn't given on the command-line, set it to the
-- value of the @CABAL_SANDBOX_CONFIG@ environment variable, or else to
-- 'NoFlag'.
updateSandboxConfigFileFlag :: GlobalFlags -> IO GlobalFlags
updateSandboxConfigFileFlag globalFlags =
case globalSandboxConfigFile globalFlags of
Flag _ -> return globalFlags
NoFlag -> do
f' <- fmap (maybe NoFlag Flag) . lookupEnv $ "CABAL_SANDBOX_CONFIG"
return globalFlags { globalSandboxConfigFile = f' }
-- | Return the path to the sandbox config file - either the default or the one
-- specified with @--sandbox-config-file@.
getSandboxConfigFilePath :: GlobalFlags -> IO FilePath
getSandboxConfigFilePath globalFlags = do
let sandboxConfigFileFlag = globalSandboxConfigFile globalFlags
case sandboxConfigFileFlag of
NoFlag -> do pkgEnvDir <- getCurrentDirectory
return (pkgEnvDir </> sandboxPackageEnvironmentFile)
Flag path -> return path
-- | Load the @cabal.sandbox.config@ file (and possibly the optional
-- @cabal.config@). In addition to a @PackageEnvironment@, also return a
-- canonical path to the sandbox. Exit with error if the sandbox directory or
-- the package environment file do not exist.
tryLoadSandboxConfig :: Verbosity -> GlobalFlags
-> IO (FilePath, PackageEnvironment)
tryLoadSandboxConfig verbosity globalFlags = do
path <- getSandboxConfigFilePath globalFlags
tryLoadSandboxPackageEnvironmentFile verbosity path
(globalConfigFile globalFlags)
-- | Return the name of the package index file for this package environment.
tryGetIndexFilePath :: SavedConfig -> IO FilePath
tryGetIndexFilePath config = tryGetIndexFilePath' (savedGlobalFlags config)
-- | The same as 'tryGetIndexFilePath', but takes 'GlobalFlags' instead of
-- 'SavedConfig'.
tryGetIndexFilePath' :: GlobalFlags -> IO FilePath
tryGetIndexFilePath' globalFlags = do
let paths = fromNubList $ globalLocalRepos globalFlags
case paths of
[] -> die $ "Distribution.Client.Sandbox.tryGetIndexFilePath: " ++
"no local repos found. " ++ checkConfiguration
_ -> return $ (last paths) </> Index.defaultIndexFileName
where
checkConfiguration = "Please check your configuration ('"
++ userPackageEnvironmentFile ++ "')."
-- | Try to extract a 'PackageDB' from 'ConfigFlags'. Gives a better error
-- message than just pattern-matching.
getSandboxPackageDB :: ConfigFlags -> IO PackageDB
getSandboxPackageDB configFlags = do
case configPackageDBs configFlags of
[Just sandboxDB@(SpecificPackageDB _)] -> return sandboxDB
-- TODO: should we allow multiple package DBs (e.g. with 'inherit')?
[] ->
die $ "Sandbox package DB is not specified. " ++ sandboxConfigCorrupt
[_] ->
die $ "Unexpected contents of the 'package-db' field. "
++ sandboxConfigCorrupt
_ ->
die $ "Too many package DBs provided. " ++ sandboxConfigCorrupt
where
sandboxConfigCorrupt = "Your 'cabal.sandbox.config' is probably corrupt."
-- | Which packages are installed in the sandbox package DB?
getInstalledPackagesInSandbox :: Verbosity -> ConfigFlags
-> Compiler -> ProgramConfiguration
-> IO InstalledPackageIndex
getInstalledPackagesInSandbox verbosity configFlags comp conf = do
sandboxDB <- getSandboxPackageDB configFlags
getPackageDBContents verbosity comp sandboxDB conf
-- | 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. This
-- will have to wait until the Shell monad is implemented; without it the
-- required changes are too intrusive.
addBinDir :: IO ()
addBinDir = do
mbOldPath <- lookupEnv "PATH"
let newPath = maybe sandboxBin ((++) sandboxBin . (:) searchPathSeparator)
mbOldPath
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
-> IO ()
initPackageDBIfNeeded verbosity configFlags comp conf = do
SpecificPackageDB dbPath <- getSandboxPackageDB configFlags
packageDBExists <- doesDirectoryExist dbPath
unless packageDBExists $
Register.initPackageDB verbosity comp conf dbPath
when packageDBExists $
debug verbosity $ "The package database already exists: " ++ dbPath
-- | Entry point for the 'cabal sandbox dump-pkgenv' command.
dumpPackageEnvironment :: Verbosity -> SandboxFlags -> GlobalFlags -> IO ()
dumpPackageEnvironment verbosity _sandboxFlags globalFlags = do
(sandboxDir, pkgEnv) <- tryLoadSandboxConfig verbosity globalFlags
commentPkgEnv <- commentPackageEnvironment sandboxDir
putStrLn . showPackageEnvironmentWithComments (Just commentPkgEnv) $ pkgEnv
-- | Entry point for the 'cabal sandbox init' command.
sandboxInit :: Verbosity -> SandboxFlags -> GlobalFlags -> IO ()
sandboxInit verbosity sandboxFlags globalFlags = do
-- Warn if there's a 'cabal-dev' sandbox.
isCabalDevSandbox <- liftM2 (&&) (doesDirectoryExist "cabal-dev")
(doesFileExist $ "cabal-dev" </> "cabal.config")
when isCabalDevSandbox $
warn verbosity $
"You are apparently using a legacy (cabal-dev) sandbox. "
++ "Legacy sandboxes may interact badly with native Cabal sandboxes. "
++ "You may want to delete the 'cabal-dev' directory to prevent issues."
-- Create the sandbox directory.
let sandboxDir' = fromFlagOrDefault defaultSandboxLocation
(sandboxLocation sandboxFlags)
createDirectoryIfMissingVerbose verbosity True sandboxDir'
sandboxDir <- tryCanonicalizePath sandboxDir'
setFileHidden sandboxDir
-- Determine which compiler to use (using the value from ~/.cabal/config).
userConfig <- loadConfig verbosity (globalConfigFile globalFlags)
(comp, platform, conf) <- configCompilerAuxEx (savedConfigureFlags userConfig)
-- Create the package environment file.
pkgEnvFile <- getSandboxConfigFilePath globalFlags
createPackageEnvironmentFile verbosity sandboxDir pkgEnvFile comp platform
(_sandboxDir, pkgEnv) <- tryLoadSandboxConfig verbosity globalFlags
let config = pkgEnvSavedConfig pkgEnv
configFlags = savedConfigureFlags config
-- Create the index file if it doesn't exist.
indexFile <- tryGetIndexFilePath config
indexFileExists <- doesFileExist indexFile
if indexFileExists
then notice verbosity $ "Using an existing sandbox located at " ++ sandboxDir
else notice verbosity $ "Creating a new sandbox at " ++ sandboxDir
Index.createEmpty verbosity indexFile
-- Create the package DB for the default compiler.
initPackageDBIfNeeded verbosity configFlags comp conf
maybeAddCompilerTimestampRecord verbosity sandboxDir indexFile
(compilerId comp) platform
-- | Entry point for the 'cabal sandbox delete' command.
sandboxDelete :: Verbosity -> SandboxFlags -> GlobalFlags -> IO ()
sandboxDelete verbosity _sandboxFlags globalFlags = do
(useSandbox, _) <- loadConfigOrSandboxConfig
verbosity
globalFlags { globalRequireSandbox = Flag False }
case useSandbox of
NoSandbox -> warn verbosity "Not in a sandbox."
UseSandbox sandboxDir -> do
curDir <- getCurrentDirectory
pkgEnvFile <- getSandboxConfigFilePath globalFlags
-- Remove the @cabal.sandbox.config@ file, unless it's in a non-standard
-- location.
let isNonDefaultConfigLocation = not $ equalFilePath pkgEnvFile $
curDir </> sandboxPackageEnvironmentFile
if isNonDefaultConfigLocation
then warn verbosity $ "Sandbox config file is in non-default location: '"
++ pkgEnvFile ++ "'.\n Please delete manually."
else removeFile pkgEnvFile
-- Remove the sandbox directory, unless we're using a shared sandbox.
let isNonDefaultSandboxLocation = not $ equalFilePath sandboxDir $
curDir </> defaultSandboxLocation
when isNonDefaultSandboxLocation $
die $ "Non-default sandbox location used: '" ++ sandboxDir
++ "'.\nAssuming a shared sandbox. Please delete '"
++ sandboxDir ++ "' manually."
absSandboxDir <- canonicalizePath sandboxDir
notice verbosity $ "Deleting the sandbox located at " ++ absSandboxDir
removeDirectoryRecursive absSandboxDir
let
pathInsideSandbox = isPrefixOf absSandboxDir
-- Warn the user if deleting the sandbox deleted a package database
-- referenced in the current environment.
checkPackagePaths var = do
let
checkPath path = do
absPath <- canonicalizePath path
(when (pathInsideSandbox absPath) . warn verbosity)
(var ++ " refers to package database " ++ path
++ " inside the deleted sandbox.")
liftM (maybe [] splitSearchPath) (lookupEnv var) >>= mapM_ checkPath
checkPackagePaths "CABAL_SANDBOX_PACKAGE_PATH"
checkPackagePaths "GHC_PACKAGE_PATH"
checkPackagePaths "GHCJS_PACKAGE_PATH"
-- Common implementation of 'sandboxAddSource' and 'sandboxAddSourceSnapshot'.
doAddSource :: Verbosity -> [FilePath] -> FilePath -> PackageEnvironment
-> BuildTreeRefType
-> IO ()
doAddSource verbosity buildTreeRefs sandboxDir pkgEnv refType = do
let savedConfig = pkgEnvSavedConfig pkgEnv
indexFile <- tryGetIndexFilePath savedConfig
-- If we're running 'sandbox add-source' for the first time for this compiler,
-- we need to create an initial timestamp record.
(comp, platform, _) <- configCompilerAuxEx . savedConfigureFlags $ savedConfig
maybeAddCompilerTimestampRecord verbosity sandboxDir indexFile
(compilerId comp) platform
withAddTimestamps sandboxDir $ do
-- Path canonicalisation is done in addBuildTreeRefs, but we do it
-- twice because of the timestamps file.
buildTreeRefs' <- mapM tryCanonicalizePath buildTreeRefs
Index.addBuildTreeRefs verbosity indexFile buildTreeRefs' refType
return buildTreeRefs'
-- | Entry point for the 'cabal sandbox add-source' command.
sandboxAddSource :: Verbosity -> [FilePath] -> SandboxFlags -> GlobalFlags
-> IO ()
sandboxAddSource verbosity buildTreeRefs sandboxFlags globalFlags = do
(sandboxDir, pkgEnv) <- tryLoadSandboxConfig verbosity globalFlags
if fromFlagOrDefault False (sandboxSnapshot sandboxFlags)
then sandboxAddSourceSnapshot verbosity buildTreeRefs sandboxDir pkgEnv
else doAddSource verbosity buildTreeRefs sandboxDir pkgEnv LinkRef
-- | Entry point for the 'cabal sandbox add-source --snapshot' command.
sandboxAddSourceSnapshot :: Verbosity -> [FilePath] -> FilePath
-> PackageEnvironment
-> IO ()
sandboxAddSourceSnapshot verbosity buildTreeRefs sandboxDir pkgEnv = do
let snapshotDir = sandboxDir </> snapshotDirectoryName
-- Use 'D.S.SrcDist.prepareTree' to copy each package's files to our private
-- location.
createDirectoryIfMissingVerbose verbosity True snapshotDir
-- Collect the package descriptions first, so that if some path does not refer
-- to a cabal package, we fail immediately.
pkgs <- forM buildTreeRefs $ \buildTreeRef ->
inDir (Just buildTreeRef) $
return . flattenPackageDescription
=<< readPackageDescription verbosity
=<< defaultPackageDesc verbosity
-- Copy the package sources to "snapshots/$PKGNAME-$VERSION-tmp". If
-- 'prepareTree' throws an error at any point, the old snapshots will still be
-- in consistent state.
tmpDirs <- forM (zip buildTreeRefs pkgs) $ \(buildTreeRef, pkg) ->
inDir (Just buildTreeRef) $ do
let targetDir = snapshotDir </> (display . packageId $ pkg)
targetTmpDir = targetDir ++ "-tmp"
dirExists <- doesDirectoryExist targetTmpDir
when dirExists $
removeDirectoryRecursive targetDir
createDirectory targetTmpDir
prepareTree verbosity pkg Nothing targetTmpDir knownSuffixHandlers
return (targetTmpDir, targetDir)
-- Now rename the "snapshots/$PKGNAME-$VERSION-tmp" dirs to
-- "snapshots/$PKGNAME-$VERSION".
snapshots <- forM tmpDirs $ \(targetTmpDir, targetDir) -> do
dirExists <- doesDirectoryExist targetDir
when dirExists $
removeDirectoryRecursive targetDir
renameDirectory targetTmpDir targetDir
return targetDir
-- Once the packages are copied, just 'add-source' them as usual.
doAddSource verbosity snapshots sandboxDir pkgEnv SnapshotRef
-- | Entry point for the 'cabal sandbox delete-source' command.
sandboxDeleteSource :: Verbosity -> [FilePath] -> SandboxFlags -> GlobalFlags
-> IO ()
sandboxDeleteSource verbosity buildTreeRefs _sandboxFlags globalFlags = do
(sandboxDir, pkgEnv) <- tryLoadSandboxConfig verbosity globalFlags
indexFile <- tryGetIndexFilePath (pkgEnvSavedConfig pkgEnv)
(results, convDict) <-
Index.removeBuildTreeRefs verbosity indexFile buildTreeRefs
let (failedPaths, removedPaths) = partitionEithers results
removedRefs = fmap convDict removedPaths
unless (null removedPaths) $ do
removeTimestamps sandboxDir removedPaths
notice verbosity $ "Success deleting sources: " ++
showL removedRefs ++ "\n\n"
unless (null failedPaths) $ do
let groupedFailures = groupBy errorType failedPaths
mapM_ handleErrors groupedFailures
die $ "The sources with the above errors were skipped. (" ++
showL (fmap getPath failedPaths) ++ ")"
notice verbosity $ "Note: 'sandbox delete-source' only unregisters the " ++
"source dependency, but does not remove the package " ++
"from the sandbox package DB.\n\n" ++
"Use 'sandbox hc-pkg -- unregister' to do that."
where
getPath (Index.ErrNonregisteredSource p) = p
getPath (Index.ErrNonexistentSource p) = p
showPaths f = concat . intersperse " " . fmap (show . f)
showL = showPaths id
showE [] = return ' '
showE errs = showPaths getPath errs
errorType Index.ErrNonregisteredSource{} Index.ErrNonregisteredSource{} =
True
errorType Index.ErrNonexistentSource{} Index.ErrNonexistentSource{} = True
errorType _ _ = False
handleErrors [] = return ()
handleErrors errs@(Index.ErrNonregisteredSource{}:_) =
warn verbosity ("Sources not registered: " ++ showE errs ++ "\n\n")
handleErrors errs@(Index.ErrNonexistentSource{}:_) =
warn verbosity
("Source directory not found for paths: " ++ showE errs ++ "\n"
++ "If you are trying to delete a reference to a removed directory, "
++ "please provide the full absolute path "
++ "(as given by `sandbox list-sources`).\n\n")
-- | Entry point for the 'cabal sandbox list-sources' command.
sandboxListSources :: Verbosity -> SandboxFlags -> GlobalFlags
-> IO ()
sandboxListSources verbosity _sandboxFlags globalFlags = do
(sandboxDir, pkgEnv) <- tryLoadSandboxConfig verbosity globalFlags
indexFile <- tryGetIndexFilePath (pkgEnvSavedConfig pkgEnv)
refs <- Index.listBuildTreeRefs verbosity
Index.ListIgnored Index.LinksAndSnapshots indexFile
when (null refs) $
notice verbosity $ "Index file '" ++ indexFile
++ "' has no references to local build trees."
when (not . null $ refs) $ do
notice verbosity $ "Source dependencies registered "
++ "in the current sandbox ('" ++ sandboxDir ++ "'):\n\n"
mapM_ putStrLn refs
notice verbosity $ "\nTo unregister source dependencies, "
++ "use the 'sandbox delete-source' command."
-- | Entry point for the 'cabal sandbox hc-pkg' command. Invokes the @hc-pkg@
-- tool with provided arguments, restricted to the sandbox.
sandboxHcPkg :: Verbosity -> SandboxFlags -> GlobalFlags -> [String] -> IO ()
sandboxHcPkg verbosity _sandboxFlags globalFlags extraArgs = do
(sandboxDir, pkgEnv) <- tryLoadSandboxConfig verbosity globalFlags
let configFlags = savedConfigureFlags . pkgEnvSavedConfig $ pkgEnv
-- Invoke hc-pkg for the most recently configured compiler (if any),
-- using the right package-db for the compiler (see #1935).
(comp, platform, conf) <- getPersistOrConfigCompiler configFlags
let dir = sandboxPackageDBPath sandboxDir comp platform
dbStack = [GlobalPackageDB, SpecificPackageDB dir]
Register.invokeHcPkg verbosity comp conf dbStack extraArgs
updateInstallDirs :: Flag Bool
-> (UseSandbox, SavedConfig) -> (UseSandbox, SavedConfig)
updateInstallDirs userInstallFlag (useSandbox, savedConfig) =
case useSandbox of
NoSandbox ->
let savedConfig' = savedConfig {
savedConfigureFlags = configureFlags {
configInstallDirs = installDirs
}
}
in (useSandbox, savedConfig')
_ -> (useSandbox, savedConfig)
where
configureFlags = savedConfigureFlags savedConfig
userInstallDirs = savedUserInstallDirs savedConfig
globalInstallDirs = savedGlobalInstallDirs savedConfig
installDirs | userInstall = userInstallDirs
| otherwise = globalInstallDirs
userInstall = fromFlagOrDefault defaultUserInstall
(configUserInstall configureFlags `mappend` userInstallFlag)
-- | Check which type of package environment we're in and return a
-- correctly-initialised @SavedConfig@ and a @UseSandbox@ value that indicates
-- whether we're working in a sandbox.
loadConfigOrSandboxConfig :: Verbosity
-> GlobalFlags -- ^ For @--config-file@ and
-- @--sandbox-config-file@.
-> IO (UseSandbox, SavedConfig)
loadConfigOrSandboxConfig verbosity globalFlags = do
let configFileFlag = globalConfigFile globalFlags
sandboxConfigFileFlag = globalSandboxConfigFile globalFlags
ignoreSandboxFlag = globalIgnoreSandbox globalFlags
pkgEnvDir <- getPkgEnvDir sandboxConfigFileFlag
pkgEnvType <- classifyPackageEnvironment pkgEnvDir sandboxConfigFileFlag
ignoreSandboxFlag
case pkgEnvType of
-- A @cabal.sandbox.config@ file (and possibly @cabal.config@) is present.
SandboxPackageEnvironment -> do
(sandboxDir, pkgEnv) <- tryLoadSandboxConfig verbosity globalFlags
-- ^ Prints an error message and exits on error.
let config = pkgEnvSavedConfig pkgEnv
return (UseSandbox sandboxDir, config)
-- Only @cabal.config@ is present.
UserPackageEnvironment -> do
config <- loadConfig verbosity configFileFlag
userConfig <- loadUserConfig verbosity pkgEnvDir Nothing
let config' = config `mappend` userConfig
dieIfSandboxRequired config'
return (NoSandbox, config')
-- Neither @cabal.sandbox.config@ nor @cabal.config@ are present.
AmbientPackageEnvironment -> do
config <- loadConfig verbosity configFileFlag
let globalConstraintsOpt =
flagToMaybe . globalConstraintsFile . savedGlobalFlags $ config
globalConstraintConfig <-
loadUserConfig verbosity pkgEnvDir globalConstraintsOpt
let config' = config `mappend` globalConstraintConfig
dieIfSandboxRequired config
return (NoSandbox, config')
where
-- Return the path to the package environment directory - either the
-- current directory or the one that @--sandbox-config-file@ resides in.
getPkgEnvDir :: (Flag FilePath) -> IO FilePath
getPkgEnvDir sandboxConfigFileFlag = do
case sandboxConfigFileFlag of
NoFlag -> getCurrentDirectory
Flag path -> tryCanonicalizePath . takeDirectory $ path
-- Die if @--require-sandbox@ was specified and we're not inside a sandbox.
dieIfSandboxRequired :: SavedConfig -> IO ()
dieIfSandboxRequired config = checkFlag flag
where
flag = (globalRequireSandbox . savedGlobalFlags $ config)
`mappend` (globalRequireSandbox globalFlags)
checkFlag (Flag True) =
die $ "'require-sandbox' is set to True, but no sandbox is present. "
++ "Use '--no-require-sandbox' if you want to override "
++ "'require-sandbox' temporarily."
checkFlag (Flag False) = return ()
checkFlag (NoFlag) = return ()
-- | Return the saved \"dist/\" prefix, or the default prefix.
findSavedDistPref :: SavedConfig -> Flag FilePath -> IO FilePath
findSavedDistPref config flagDistPref = do
let defDistPref = useDistPref defaultSetupScriptOptions
flagDistPref' = configDistPref (savedConfigureFlags config)
`mappend` flagDistPref
findDistPref defDistPref flagDistPref'
-- | If we're in a sandbox, call @withSandboxBinDirOnSearchPath@, otherwise do
-- nothing.
maybeWithSandboxDirOnSearchPath :: UseSandbox -> IO a -> IO a
maybeWithSandboxDirOnSearchPath NoSandbox act = act
maybeWithSandboxDirOnSearchPath (UseSandbox sandboxDir) act =
withSandboxBinDirOnSearchPath sandboxDir $ act
-- | Had reinstallAddSourceDeps actually reinstalled any dependencies?
data WereDepsReinstalled = ReinstalledSomeDeps | NoDepsReinstalled
-- | Reinstall those add-source dependencies that have been modified since
-- we've last installed them. Assumes that we're working inside a sandbox.
reinstallAddSourceDeps :: Verbosity
-> ConfigFlags -> ConfigExFlags
-> InstallFlags -> GlobalFlags
-> FilePath
-> IO WereDepsReinstalled
reinstallAddSourceDeps verbosity configFlags' configExFlags
installFlags globalFlags sandboxDir = topHandler' $ do
let sandboxDistPref = sandboxBuildDir sandboxDir
configFlags = configFlags'
{ configDistPref = Flag sandboxDistPref }
haddockFlags = mempty
{ haddockDistPref = Flag sandboxDistPref }
(comp, platform, conf) <- configCompilerAux' configFlags
retVal <- newIORef NoDepsReinstalled
withSandboxPackageInfo verbosity configFlags globalFlags
comp platform conf sandboxDir $ \sandboxPkgInfo ->
unless (null $ modifiedAddSourceDependencies sandboxPkgInfo) $ do
withRepoContext verbosity globalFlags $ \repoContext -> do
let args :: InstallArgs
args = ((configPackageDB' configFlags)
,repoContext
,comp, platform, conf
,UseSandbox sandboxDir, Just sandboxPkgInfo
,globalFlags, configFlags, configExFlags, installFlags
,haddockFlags)
-- This can actually be replaced by a call to 'install', but we use a
-- lower-level API because of layer separation reasons. Additionally, we
-- might want to use some lower-level features this in the future.
withSandboxBinDirOnSearchPath sandboxDir $ do
installContext <- makeInstallContext verbosity args Nothing
installPlan <- foldProgress logMsg die' return =<<
makeInstallPlan verbosity args installContext
processInstallPlan verbosity args installContext installPlan
writeIORef retVal ReinstalledSomeDeps
readIORef retVal
where
die' message = die (message ++ installFailedInSandbox)
-- TODO: use a better error message, remove duplication.
installFailedInSandbox =
"Note: when using a sandbox, all packages are required to have "
++ "consistent dependencies. Try reinstalling/unregistering the "
++ "offending packages or recreating the sandbox."
logMsg message rest = debugNoWrap verbosity message >> rest
topHandler' = topHandlerWith $ \_ -> do
warn verbosity "Couldn't reinstall some add-source dependencies."
-- Here we can't know whether any deps have been reinstalled, so we have
-- to be conservative.
return ReinstalledSomeDeps
-- | Produce a 'SandboxPackageInfo' and feed it to the given action. Note that
-- we don't update the timestamp file here - this is done in
-- 'postInstallActions'.
withSandboxPackageInfo :: Verbosity -> ConfigFlags -> GlobalFlags
-> Compiler -> Platform -> ProgramConfiguration
-> FilePath
-> (SandboxPackageInfo -> IO ())
-> IO ()
withSandboxPackageInfo verbosity configFlags globalFlags
comp platform conf sandboxDir cont = do
-- List all add-source deps.
indexFile <- tryGetIndexFilePath' globalFlags
buildTreeRefs <- Index.listBuildTreeRefs verbosity
Index.DontListIgnored Index.OnlyLinks indexFile
let allAddSourceDepsSet = S.fromList buildTreeRefs
-- List all packages installed in the sandbox.
installedPkgIndex <- getInstalledPackagesInSandbox verbosity
configFlags comp conf
let err = "Error reading sandbox package information."
-- Get the package descriptions for all add-source deps.
depsCabalFiles <- mapM (flip tryFindAddSourcePackageDesc err) buildTreeRefs
depsPkgDescs <- mapM (readPackageDescription verbosity) depsCabalFiles
let depsMap = M.fromList (zip buildTreeRefs depsPkgDescs)
isInstalled pkgid = not . null
. InstalledPackageIndex.lookupSourcePackageId installedPkgIndex $ pkgid
installedDepsMap = M.filter (isInstalled . packageId) depsMap
-- Get the package ids of modified (and installed) add-source deps.
modifiedAddSourceDeps <- listModifiedDeps verbosity sandboxDir
(compilerId comp) platform installedDepsMap
-- 'fromJust' here is safe because 'modifiedAddSourceDeps' are guaranteed to
-- be a subset of the keys of 'depsMap'.
let modifiedDeps = [ (modDepPath, fromJust $ M.lookup modDepPath depsMap)
| modDepPath <- modifiedAddSourceDeps ]
modifiedDepsMap = M.fromList modifiedDeps
assert (all (`S.member` allAddSourceDepsSet) modifiedAddSourceDeps) (return ())
if (null modifiedDeps)
then info verbosity $ "Found no modified add-source deps."
else notice verbosity $ "Some add-source dependencies have been modified. "
++ "They will be reinstalled..."
-- Get the package ids of the remaining add-source deps (some are possibly not
-- installed).
let otherDeps = M.assocs (depsMap `M.difference` modifiedDepsMap)
-- Finally, assemble a 'SandboxPackageInfo'.
cont $ SandboxPackageInfo (map toSourcePackage modifiedDeps)
(map toSourcePackage otherDeps) installedPkgIndex allAddSourceDepsSet
where
toSourcePackage (path, pkgDesc) = SourcePackage
(packageId pkgDesc) pkgDesc (LocalUnpackedPackage path) Nothing
-- | Same as 'withSandboxPackageInfo' if we're inside a sandbox and the
-- identity otherwise.
maybeWithSandboxPackageInfo :: Verbosity -> ConfigFlags -> GlobalFlags
-> Compiler -> Platform -> ProgramConfiguration
-> UseSandbox
-> (Maybe SandboxPackageInfo -> IO ())
-> IO ()
maybeWithSandboxPackageInfo verbosity configFlags globalFlags
comp platform conf useSandbox cont =
case useSandbox of
NoSandbox -> cont Nothing
UseSandbox sandboxDir -> withSandboxPackageInfo verbosity
configFlags globalFlags
comp platform conf sandboxDir
(\spi -> cont (Just spi))
-- | Check if a sandbox is present and call @reinstallAddSourceDeps@ in that
-- case.
maybeReinstallAddSourceDeps :: Verbosity
-> Flag (Maybe Int) -- ^ The '-j' flag
-> ConfigFlags -- ^ Saved configure flags
-- (from dist/setup-config)
-> GlobalFlags
-> (UseSandbox, SavedConfig)
-> IO WereDepsReinstalled
maybeReinstallAddSourceDeps verbosity numJobsFlag configFlags'
globalFlags' (useSandbox, config) = do
case useSandbox of
NoSandbox -> return NoDepsReinstalled
UseSandbox sandboxDir -> do
-- Reinstall the modified add-source deps.
let configFlags = savedConfigureFlags config
`mappendSomeSavedFlags`
configFlags'
configExFlags = defaultConfigExFlags
`mappend` savedConfigureExFlags config
installFlags' = defaultInstallFlags
`mappend` savedInstallFlags config
installFlags = installFlags' {
installNumJobs = installNumJobs installFlags'
`mappend` numJobsFlag
}
globalFlags = savedGlobalFlags config
-- This makes it possible to override things like 'remote-repo-cache'
-- from the command line. These options are hidden, and are only
-- useful for debugging, so this should be fine.
`mappend` globalFlags'
reinstallAddSourceDeps
verbosity configFlags configExFlags
installFlags globalFlags sandboxDir
where
-- NOTE: we can't simply do @sandboxConfigFlags `mappend` savedFlags@
-- because we don't want to auto-enable things like 'library-profiling' for
-- all add-source dependencies even if the user has passed
-- '--enable-library-profiling' to 'cabal configure'. These options are
-- supposed to be set in 'cabal.config'.
mappendSomeSavedFlags :: ConfigFlags -> ConfigFlags -> ConfigFlags
mappendSomeSavedFlags sandboxConfigFlags savedFlags =
sandboxConfigFlags {
configHcFlavor = configHcFlavor sandboxConfigFlags
`mappend` configHcFlavor savedFlags,
configHcPath = configHcPath sandboxConfigFlags
`mappend` configHcPath savedFlags,
configHcPkg = configHcPkg sandboxConfigFlags
`mappend` configHcPkg savedFlags,
configProgramPaths = configProgramPaths sandboxConfigFlags
`mappend` configProgramPaths savedFlags,
configProgramArgs = configProgramArgs sandboxConfigFlags
`mappend` configProgramArgs savedFlags,
-- NOTE: Unconditionally choosing the value from
-- 'dist/setup-config'. Sandbox package DB location may have been
-- changed by 'configure -w'.
configPackageDBs = configPackageDBs savedFlags
-- FIXME: Is this compatible with the 'inherit' feature?
}
--
-- Utils (transitionary)
--
-- FIXME: configPackageDB' and configCompilerAux' don't really belong in this
-- module
--
configPackageDB' :: ConfigFlags -> PackageDBStack
configPackageDB' cfg =
interpretPackageDbFlags userInstall (configPackageDBs cfg)
where
userInstall = fromFlagOrDefault True (configUserInstall cfg)
configCompilerAux' :: ConfigFlags
-> IO (Compiler, Platform, ProgramConfiguration)
configCompilerAux' configFlags =
configCompilerAuxEx configFlags
--FIXME: make configCompilerAux use a sensible verbosity
{ configVerbosity = fmap lessVerbose (configVerbosity configFlags) }
-- | Try to read the most recently configured compiler from the
-- 'localBuildInfoFile', falling back on 'configCompilerAuxEx' if it
-- cannot be read.
getPersistOrConfigCompiler :: ConfigFlags
-> IO (Compiler, Platform, ProgramConfiguration)
getPersistOrConfigCompiler configFlags = do
distPref <- findDistPrefOrDefault (configDistPref configFlags)
mlbi <- maybeGetPersistBuildConfig distPref
case mlbi of
Nothing -> do configCompilerAux' configFlags
Just lbi -> return ( LocalBuildInfo.compiler lbi
, LocalBuildInfo.hostPlatform lbi
, LocalBuildInfo.withPrograms lbi
)