{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} ----------------------------------------------------------------------------- -- | -- 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, getPersistOrConfigCompiler ) where import Prelude () import Distribution.Client.Compat.Prelude import Distribution.Client.Setup ( SandboxFlags(..), ConfigFlags(..), ConfigExFlags(..), InstallFlags(..) , GlobalFlags(..), configCompilerAux', configPackageDB' , 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(..) ) import Distribution.Client.Utils ( inDir, tryCanonicalizePath , tryFindAddSourcePackageDesc) import Distribution.PackageDescription.Configuration ( flattenPackageDescription ) import Distribution.PackageDescription.Parsec ( readGenericPackageDescription ) import Distribution.Simple.Compiler ( Compiler(..), PackageDB(..) ) import Distribution.Simple.Configure ( configCompilerAuxEx , getPackageDBContents , maybeGetPersistBuildConfig , findDistPrefOrDefault , findDistPref ) import qualified Distribution.Simple.LocalBuildInfo as LocalBuildInfo import Distribution.Simple.PreProcess ( knownSuffixHandlers ) import Distribution.Simple.Program ( ProgramDb ) import Distribution.Simple.Setup ( Flag(..), HaddockFlags(..) , fromFlagOrDefault, flagToMaybe ) import Distribution.Simple.SrcDist ( prepareTree ) import Distribution.Simple.Utils ( die', debug, notice, info, warn , debugNoWrap, defaultPackageDesc , topHandlerWith , createDirectoryIfMissingVerbose ) import Distribution.Package ( Package(..) ) import Distribution.System ( Platform ) import Distribution.Text ( display ) import Distribution.Verbosity ( Verbosity ) 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 Distribution.Solver.Types.SourcePackage 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, mapM, mapM_ ) import Data.Bits ( shiftL, shiftR, xor ) import Data.IORef ( newIORef, writeIORef, readIORef ) import Data.List ( delete , groupBy ) import Data.Maybe ( fromJust ) 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 :: Verbosity -> SavedConfig -> IO FilePath tryGetIndexFilePath verbosity config = tryGetIndexFilePath' verbosity (savedGlobalFlags config) -- | The same as 'tryGetIndexFilePath', but takes 'GlobalFlags' instead of -- 'SavedConfig'. tryGetIndexFilePath' :: Verbosity -> GlobalFlags -> IO FilePath tryGetIndexFilePath' verbosity globalFlags = do let paths = fromNubList $ globalLocalRepos globalFlags case paths of [] -> die' verbosity $ "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 :: Verbosity -> ConfigFlags -> IO PackageDB getSandboxPackageDB verbosity configFlags = do case configPackageDBs configFlags of [Just sandboxDB@(SpecificPackageDB _)] -> return sandboxDB -- TODO: should we allow multiple package DBs (e.g. with 'inherit')? [] -> die' verbosity $ "Sandbox package DB is not specified. " ++ sandboxConfigCorrupt [_] -> die' verbosity $ "Unexpected contents of the 'package-db' field. " ++ sandboxConfigCorrupt _ -> die' verbosity $ "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 -> ProgramDb -> IO InstalledPackageIndex getInstalledPackagesInSandbox verbosity configFlags comp progdb = do sandboxDB <- getSandboxPackageDB verbosity configFlags getPackageDBContents verbosity comp sandboxDB progdb -- | 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 -> ProgramDb -> IO () initPackageDBIfNeeded verbosity configFlags comp progdb = do SpecificPackageDB dbPath <- getSandboxPackageDB verbosity configFlags packageDBExists <- doesDirectoryExist dbPath unless packageDBExists $ Register.initPackageDB verbosity comp progdb 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, progdb) <- 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 verbosity 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 progdb 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' verbosity $ "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 verbosity 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 verbosity 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 =<< readGenericPackageDescription 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 verbosity (pkgEnvSavedConfig pkgEnv) (results, convDict) <- Index.removeBuildTreeRefs verbosity indexFile buildTreeRefs let (failedPaths, removedPaths) = partitionEithers results removedRefs = fmap convDict removedPaths unless (null removedPaths) $ do removeTimestamps verbosity sandboxDir removedPaths notice verbosity $ "Success deleting sources: " ++ showL removedRefs ++ "\n\n" unless (null failedPaths) $ do let groupedFailures = groupBy errorType failedPaths mapM_ handleErrors groupedFailures die' verbosity $ "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 verbosity (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, progdb) <- getPersistOrConfigCompiler configFlags let dir = sandboxPackageDBPath sandboxDir comp platform dbStack = [GlobalPackageDB, SpecificPackageDB dir] Register.invokeHcPkg verbosity comp progdb 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' verbosity $ "'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, progdb) <- configCompilerAux' configFlags retVal <- newIORef NoDepsReinstalled withSandboxPackageInfo verbosity configFlags globalFlags comp platform progdb sandboxDir $ \sandboxPkgInfo -> unless (null $ modifiedAddSourceDependencies sandboxPkgInfo) $ do withRepoContext verbosity globalFlags $ \repoContext -> do let args :: InstallArgs args = ((configPackageDB' configFlags) ,repoContext ,comp, platform, progdb ,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' verbosity (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 -> ProgramDb -> FilePath -> (SandboxPackageInfo -> IO ()) -> IO () withSandboxPackageInfo verbosity configFlags globalFlags comp platform progdb sandboxDir cont = do -- List all add-source deps. indexFile <- tryGetIndexFilePath' verbosity 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 progdb let err = "Error reading sandbox package information." -- Get the package descriptions for all add-source deps. depsCabalFiles <- mapM (flip (tryFindAddSourcePackageDesc verbosity) err) buildTreeRefs depsPkgDescs <- mapM (readGenericPackageDescription 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 -> ProgramDb -> UseSandbox -> (Maybe SandboxPackageInfo -> IO ()) -> IO () maybeWithSandboxPackageInfo verbosity configFlags globalFlags comp platform progdb useSandbox cont = case useSandbox of NoSandbox -> cont Nothing UseSandbox sandboxDir -> withSandboxPackageInfo verbosity configFlags globalFlags comp platform progdb 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) -- -- | 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, ProgramDb) 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 )