1{-# LANGUAGE CPP #-} 2{-# LANGUAGE FlexibleContexts #-} 3----------------------------------------------------------------------------- 4-- | 5-- Module : Distribution.Client.Sandbox 6-- Maintainer : cabal-devel@haskell.org 7-- Portability : portable 8-- 9-- UI for the sandboxing functionality. 10----------------------------------------------------------------------------- 11 12module Distribution.Client.Sandbox ( 13 sandboxInit, 14 sandboxDelete, 15 sandboxAddSource, 16 sandboxAddSourceSnapshot, 17 sandboxDeleteSource, 18 sandboxListSources, 19 sandboxHcPkg, 20 dumpPackageEnvironment, 21 withSandboxBinDirOnSearchPath, 22 23 getSandboxConfigFilePath, 24 loadConfigOrSandboxConfig, 25 findSavedDistPref, 26 initPackageDBIfNeeded, 27 maybeWithSandboxDirOnSearchPath, 28 29 WereDepsReinstalled(..), 30 reinstallAddSourceDeps, 31 maybeReinstallAddSourceDeps, 32 33 SandboxPackageInfo(..), 34 maybeWithSandboxPackageInfo, 35 36 tryGetIndexFilePath, 37 sandboxBuildDir, 38 getInstalledPackagesInSandbox, 39 updateSandboxConfigFileFlag, 40 updateInstallDirs, 41 42 getPersistOrConfigCompiler 43 ) where 44 45import Prelude () 46import Distribution.Client.Compat.Prelude 47import Distribution.Utils.Generic(safeLast) 48 49import Distribution.Client.Setup 50 ( SandboxFlags(..), ConfigFlags(..), ConfigExFlags(..), InstallFlags(..) 51 , GlobalFlags(..), configCompilerAux', configPackageDB' 52 , defaultConfigExFlags, defaultInstallFlags 53 , defaultSandboxLocation, withRepoContext ) 54import Distribution.Client.Sandbox.Timestamp ( listModifiedDeps 55 , maybeAddCompilerTimestampRecord 56 , withAddTimestamps 57 , removeTimestamps ) 58import Distribution.Client.Config 59 ( SavedConfig(..), defaultUserInstall, loadConfig ) 60import Distribution.Client.Dependency ( foldProgress ) 61import Distribution.Client.IndexUtils ( BuildTreeRefType(..) ) 62import Distribution.Client.Install ( InstallArgs, 63 makeInstallContext, 64 makeInstallPlan, 65 processInstallPlan ) 66import Distribution.Utils.NubList ( fromNubList ) 67 68import Distribution.Client.Sandbox.PackageEnvironment 69 ( PackageEnvironment(..), PackageEnvironmentType(..) 70 , createPackageEnvironmentFile, classifyPackageEnvironment 71 , tryLoadSandboxPackageEnvironmentFile, loadUserConfig 72 , commentPackageEnvironment, showPackageEnvironmentWithComments 73 , sandboxPackageEnvironmentFile, userPackageEnvironmentFile 74 , sandboxPackageDBPath ) 75import Distribution.Client.Sandbox.Types ( SandboxPackageInfo(..) 76 , UseSandbox(..) ) 77import Distribution.Client.SetupWrapper 78 ( SetupScriptOptions(..), defaultSetupScriptOptions ) 79import Distribution.Client.Types ( PackageLocation(..) ) 80import Distribution.Client.Utils ( inDir, tryCanonicalizePath 81 , tryFindAddSourcePackageDesc) 82import Distribution.PackageDescription.Configuration 83 ( flattenPackageDescription ) 84import Distribution.PackageDescription.Parsec ( readGenericPackageDescription ) 85import Distribution.Simple.Compiler ( Compiler(..), PackageDB(..) ) 86import Distribution.Simple.Configure ( configCompilerAuxEx 87 , getPackageDBContents 88 , maybeGetPersistBuildConfig 89 , findDistPrefOrDefault 90 , findDistPref ) 91import qualified Distribution.Simple.LocalBuildInfo as LocalBuildInfo 92import Distribution.Simple.PreProcess ( knownSuffixHandlers ) 93import Distribution.Simple.Program ( ProgramDb ) 94import Distribution.Simple.Setup ( Flag(..), HaddockFlags(..) 95 , emptyTestFlags, emptyBenchmarkFlags 96 , fromFlagOrDefault, flagToMaybe ) 97import Distribution.Simple.SrcDist ( prepareTree ) 98import Distribution.Simple.Utils ( die', debug, notice, info, warn 99 , debugNoWrap, defaultPackageDesc 100 , topHandlerWith 101 , createDirectoryIfMissingVerbose ) 102import Distribution.Package ( Package(..) ) 103import Distribution.System ( Platform ) 104import Distribution.Deprecated.Text ( display ) 105import Distribution.Verbosity ( Verbosity ) 106import Distribution.Compat.Environment ( lookupEnv, setEnv ) 107import Distribution.Client.Compat.FilePerms ( setFileHidden ) 108import qualified Distribution.Client.Sandbox.Index as Index 109import Distribution.Simple.PackageIndex ( InstalledPackageIndex ) 110import qualified Distribution.Simple.PackageIndex as InstalledPackageIndex 111import qualified Distribution.Simple.Register as Register 112 113import Distribution.Solver.Types.SourcePackage 114 115import qualified Data.Map as M 116import qualified Data.Set as S 117import Data.Either (partitionEithers) 118import Control.Exception ( assert, bracket_ ) 119import Control.Monad ( forM, mapM, mapM_ ) 120import Data.Bits ( shiftL, shiftR, xor ) 121import Data.IORef ( newIORef, writeIORef, readIORef ) 122import Data.List ( delete 123 , groupBy ) 124import Data.Maybe ( fromJust ) 125import Numeric ( showHex ) 126import System.Directory ( canonicalizePath 127 , createDirectory 128 , doesDirectoryExist 129 , doesFileExist 130 , getCurrentDirectory 131 , removeDirectoryRecursive 132 , removeFile 133 , renameDirectory ) 134import System.FilePath ( (</>), equalFilePath 135 , getSearchPath 136 , searchPathSeparator 137 , splitSearchPath 138 , takeDirectory ) 139 140-- 141-- * Constants 142-- 143 144-- | The name of the sandbox subdirectory where we keep snapshots of add-source 145-- dependencies. 146snapshotDirectoryName :: FilePath 147snapshotDirectoryName = "snapshots" 148 149-- | Non-standard build dir that is used for building add-source deps instead of 150-- "dist". Fixes surprising behaviour in some cases (see issue #1281). 151sandboxBuildDir :: FilePath -> FilePath 152sandboxBuildDir sandboxDir = "dist/dist-sandbox-" ++ showHex sandboxDirHash "" 153 where 154 sandboxDirHash = jenkins sandboxDir 155 156 -- See http://en.wikipedia.org/wiki/Jenkins_hash_function 157 jenkins :: String -> Word32 158 jenkins str = loop_finish $ foldl' loop 0 str 159 where 160 loop :: Word32 -> Char -> Word32 161 loop hash key_i' = hash''' 162 where 163 key_i = toEnum . ord $ key_i' 164 hash' = hash + key_i 165 hash'' = hash' + (shiftL hash' 10) 166 hash''' = hash'' `xor` (shiftR hash'' 6) 167 168 loop_finish :: Word32 -> Word32 169 loop_finish hash = hash''' 170 where 171 hash' = hash + (shiftL hash 3) 172 hash'' = hash' `xor` (shiftR hash' 11) 173 hash''' = hash'' + (shiftL hash'' 15) 174 175-- 176-- * Basic sandbox functions. 177-- 178 179-- | If @--sandbox-config-file@ wasn't given on the command-line, set it to the 180-- value of the @CABAL_SANDBOX_CONFIG@ environment variable, or else to 181-- 'NoFlag'. 182updateSandboxConfigFileFlag :: GlobalFlags -> IO GlobalFlags 183updateSandboxConfigFileFlag globalFlags = 184 case globalSandboxConfigFile globalFlags of 185 Flag _ -> return globalFlags 186 NoFlag -> do 187 f' <- fmap (maybe NoFlag Flag) . lookupEnv $ "CABAL_SANDBOX_CONFIG" 188 return globalFlags { globalSandboxConfigFile = f' } 189 190-- | Return the path to the sandbox config file - either the default or the one 191-- specified with @--sandbox-config-file@. 192getSandboxConfigFilePath :: GlobalFlags -> IO FilePath 193getSandboxConfigFilePath globalFlags = do 194 let sandboxConfigFileFlag = globalSandboxConfigFile globalFlags 195 case sandboxConfigFileFlag of 196 NoFlag -> do pkgEnvDir <- getCurrentDirectory 197 return (pkgEnvDir </> sandboxPackageEnvironmentFile) 198 Flag path -> return path 199 200-- | Load the @cabal.sandbox.config@ file (and possibly the optional 201-- @cabal.config@). In addition to a @PackageEnvironment@, also return a 202-- canonical path to the sandbox. Exit with error if the sandbox directory or 203-- the package environment file do not exist. 204tryLoadSandboxConfig :: Verbosity -> GlobalFlags 205 -> IO (FilePath, PackageEnvironment) 206tryLoadSandboxConfig verbosity globalFlags = do 207 path <- getSandboxConfigFilePath globalFlags 208 tryLoadSandboxPackageEnvironmentFile verbosity path 209 (globalConfigFile globalFlags) 210 211-- | Return the name of the package index file for this package environment. 212tryGetIndexFilePath :: Verbosity -> SavedConfig -> IO FilePath 213tryGetIndexFilePath verbosity config = tryGetIndexFilePath' verbosity (savedGlobalFlags config) 214 215-- | The same as 'tryGetIndexFilePath', but takes 'GlobalFlags' instead of 216-- 'SavedConfig'. 217tryGetIndexFilePath' :: Verbosity -> GlobalFlags -> IO FilePath 218tryGetIndexFilePath' verbosity globalFlags = do 219 let paths = fromNubList $ globalLocalRepos globalFlags 220 case safeLast paths of 221 Nothing -> die' verbosity $ "Distribution.Client.Sandbox.tryGetIndexFilePath: " ++ 222 "no local repos found. " ++ checkConfiguration 223 Just lp -> return $ lp </> Index.defaultIndexFileName 224 where 225 checkConfiguration = "Please check your configuration ('" 226 ++ userPackageEnvironmentFile ++ "')." 227 228-- | Try to extract a 'PackageDB' from 'ConfigFlags'. Gives a better error 229-- message than just pattern-matching. 230getSandboxPackageDB :: Verbosity -> ConfigFlags -> IO PackageDB 231getSandboxPackageDB verbosity configFlags = do 232 case configPackageDBs configFlags of 233 [Just sandboxDB@(SpecificPackageDB _)] -> return sandboxDB 234 -- TODO: should we allow multiple package DBs (e.g. with 'inherit')? 235 236 [] -> 237 die' verbosity $ "Sandbox package DB is not specified. " ++ sandboxConfigCorrupt 238 [_] -> 239 die' verbosity $ "Unexpected contents of the 'package-db' field. " 240 ++ sandboxConfigCorrupt 241 _ -> 242 die' verbosity $ "Too many package DBs provided. " ++ sandboxConfigCorrupt 243 244 where 245 sandboxConfigCorrupt = "Your 'cabal.sandbox.config' is probably corrupt." 246 247 248-- | Which packages are installed in the sandbox package DB? 249getInstalledPackagesInSandbox :: Verbosity -> ConfigFlags 250 -> Compiler -> ProgramDb 251 -> IO InstalledPackageIndex 252getInstalledPackagesInSandbox verbosity configFlags comp progdb = do 253 sandboxDB <- getSandboxPackageDB verbosity configFlags 254 getPackageDBContents verbosity comp sandboxDB progdb 255 256-- | Temporarily add $SANDBOX_DIR/bin to $PATH. 257withSandboxBinDirOnSearchPath :: FilePath -> IO a -> IO a 258withSandboxBinDirOnSearchPath sandboxDir = bracket_ addBinDir rmBinDir 259 where 260 -- TODO: Instead of modifying the global process state, it'd be better to 261 -- set the environment individually for each subprocess invocation. This 262 -- will have to wait until the Shell monad is implemented; without it the 263 -- required changes are too intrusive. 264 addBinDir :: IO () 265 addBinDir = do 266 mbOldPath <- lookupEnv "PATH" 267 let newPath = maybe sandboxBin ((++) sandboxBin . (:) searchPathSeparator) 268 mbOldPath 269 setEnv "PATH" newPath 270 271 rmBinDir :: IO () 272 rmBinDir = do 273 oldPath <- getSearchPath 274 let newPath = intercalate [searchPathSeparator] 275 (delete sandboxBin oldPath) 276 setEnv "PATH" newPath 277 278 sandboxBin = sandboxDir </> "bin" 279 280-- | Initialise a package DB for this compiler if it doesn't exist. 281initPackageDBIfNeeded :: Verbosity -> ConfigFlags 282 -> Compiler -> ProgramDb 283 -> IO () 284initPackageDBIfNeeded verbosity configFlags comp progdb = do 285 SpecificPackageDB dbPath <- getSandboxPackageDB verbosity configFlags 286 packageDBExists <- doesDirectoryExist dbPath 287 unless packageDBExists $ 288 Register.initPackageDB verbosity comp progdb dbPath 289 when packageDBExists $ 290 debug verbosity $ "The package database already exists: " ++ dbPath 291 292-- | Entry point for the 'cabal sandbox dump-pkgenv' command. 293dumpPackageEnvironment :: Verbosity -> SandboxFlags -> GlobalFlags -> IO () 294dumpPackageEnvironment verbosity _sandboxFlags globalFlags = do 295 (sandboxDir, pkgEnv) <- tryLoadSandboxConfig verbosity globalFlags 296 commentPkgEnv <- commentPackageEnvironment sandboxDir 297 putStrLn . showPackageEnvironmentWithComments (Just commentPkgEnv) $ pkgEnv 298 299-- | Entry point for the 'cabal sandbox init' command. 300sandboxInit :: Verbosity -> SandboxFlags -> GlobalFlags -> IO () 301sandboxInit verbosity sandboxFlags globalFlags = do 302 -- Warn if there's a 'cabal-dev' sandbox. 303 isCabalDevSandbox <- liftM2 (&&) (doesDirectoryExist "cabal-dev") 304 (doesFileExist $ "cabal-dev" </> "cabal.config") 305 when isCabalDevSandbox $ 306 warn verbosity $ 307 "You are apparently using a legacy (cabal-dev) sandbox. " 308 ++ "Legacy sandboxes may interact badly with native Cabal sandboxes. " 309 ++ "You may want to delete the 'cabal-dev' directory to prevent issues." 310 311 -- Create the sandbox directory. 312 let sandboxDir' = fromFlagOrDefault defaultSandboxLocation 313 (sandboxLocation sandboxFlags) 314 createDirectoryIfMissingVerbose verbosity True sandboxDir' 315 sandboxDir <- tryCanonicalizePath sandboxDir' 316 setFileHidden sandboxDir 317 318 -- Determine which compiler to use (using the value from ~/.cabal/config). 319 userConfig <- loadConfig verbosity (globalConfigFile globalFlags) 320 (comp, platform, progdb) <- configCompilerAuxEx (savedConfigureFlags userConfig) 321 322 -- Create the package environment file. 323 pkgEnvFile <- getSandboxConfigFilePath globalFlags 324 createPackageEnvironmentFile verbosity sandboxDir pkgEnvFile comp platform 325 (_sandboxDir, pkgEnv) <- tryLoadSandboxConfig verbosity globalFlags 326 let config = pkgEnvSavedConfig pkgEnv 327 configFlags = savedConfigureFlags config 328 329 -- Create the index file if it doesn't exist. 330 indexFile <- tryGetIndexFilePath verbosity config 331 indexFileExists <- doesFileExist indexFile 332 if indexFileExists 333 then notice verbosity $ "Using an existing sandbox located at " ++ sandboxDir 334 else notice verbosity $ "Creating a new sandbox at " ++ sandboxDir 335 Index.createEmpty verbosity indexFile 336 337 -- Create the package DB for the default compiler. 338 initPackageDBIfNeeded verbosity configFlags comp progdb 339 maybeAddCompilerTimestampRecord verbosity sandboxDir indexFile 340 (compilerId comp) platform 341 342-- | Entry point for the 'cabal sandbox delete' command. 343sandboxDelete :: Verbosity -> SandboxFlags -> GlobalFlags -> IO () 344sandboxDelete verbosity _sandboxFlags globalFlags = do 345 (useSandbox, _) <- loadConfigOrSandboxConfig 346 verbosity 347 globalFlags { globalRequireSandbox = Flag False } 348 case useSandbox of 349 NoSandbox -> warn verbosity "Not in a sandbox." 350 UseSandbox sandboxDir -> do 351 curDir <- getCurrentDirectory 352 pkgEnvFile <- getSandboxConfigFilePath globalFlags 353 354 -- Remove the @cabal.sandbox.config@ file, unless it's in a non-standard 355 -- location. 356 let isNonDefaultConfigLocation = not $ equalFilePath pkgEnvFile $ 357 curDir </> sandboxPackageEnvironmentFile 358 359 if isNonDefaultConfigLocation 360 then warn verbosity $ "Sandbox config file is in non-default location: '" 361 ++ pkgEnvFile ++ "'.\n Please delete manually." 362 else removeFile pkgEnvFile 363 364 -- Remove the sandbox directory, unless we're using a shared sandbox. 365 let isNonDefaultSandboxLocation = not $ equalFilePath sandboxDir $ 366 curDir </> defaultSandboxLocation 367 368 when isNonDefaultSandboxLocation $ 369 die' verbosity $ "Non-default sandbox location used: '" ++ sandboxDir 370 ++ "'.\nAssuming a shared sandbox. Please delete '" 371 ++ sandboxDir ++ "' manually." 372 373 absSandboxDir <- canonicalizePath sandboxDir 374 notice verbosity $ "Deleting the sandbox located at " ++ absSandboxDir 375 removeDirectoryRecursive absSandboxDir 376 377 let 378 pathInsideSandbox = isPrefixOf absSandboxDir 379 380 -- Warn the user if deleting the sandbox deleted a package database 381 -- referenced in the current environment. 382 checkPackagePaths var = do 383 let 384 checkPath path = do 385 absPath <- canonicalizePath path 386 (when (pathInsideSandbox absPath) . warn verbosity) 387 (var ++ " refers to package database " ++ path 388 ++ " inside the deleted sandbox.") 389 liftM (maybe [] splitSearchPath) (lookupEnv var) >>= mapM_ checkPath 390 391 checkPackagePaths "CABAL_SANDBOX_PACKAGE_PATH" 392 checkPackagePaths "GHC_PACKAGE_PATH" 393 checkPackagePaths "GHCJS_PACKAGE_PATH" 394 395-- Common implementation of 'sandboxAddSource' and 'sandboxAddSourceSnapshot'. 396doAddSource :: Verbosity -> [FilePath] -> FilePath -> PackageEnvironment 397 -> BuildTreeRefType 398 -> IO () 399doAddSource verbosity buildTreeRefs sandboxDir pkgEnv refType = do 400 let savedConfig = pkgEnvSavedConfig pkgEnv 401 indexFile <- tryGetIndexFilePath verbosity savedConfig 402 403 -- If we're running 'sandbox add-source' for the first time for this compiler, 404 -- we need to create an initial timestamp record. 405 (comp, platform, _) <- configCompilerAuxEx . savedConfigureFlags $ savedConfig 406 maybeAddCompilerTimestampRecord verbosity sandboxDir indexFile 407 (compilerId comp) platform 408 409 withAddTimestamps verbosity sandboxDir $ do 410 -- Path canonicalisation is done in addBuildTreeRefs, but we do it 411 -- twice because of the timestamps file. 412 buildTreeRefs' <- mapM tryCanonicalizePath buildTreeRefs 413 Index.addBuildTreeRefs verbosity indexFile buildTreeRefs' refType 414 return buildTreeRefs' 415 416-- | Entry point for the 'cabal sandbox add-source' command. 417sandboxAddSource :: Verbosity -> [FilePath] -> SandboxFlags -> GlobalFlags 418 -> IO () 419sandboxAddSource verbosity buildTreeRefs sandboxFlags globalFlags = do 420 (sandboxDir, pkgEnv) <- tryLoadSandboxConfig verbosity globalFlags 421 422 if fromFlagOrDefault False (sandboxSnapshot sandboxFlags) 423 then sandboxAddSourceSnapshot verbosity buildTreeRefs sandboxDir pkgEnv 424 else doAddSource verbosity buildTreeRefs sandboxDir pkgEnv LinkRef 425 426-- | Entry point for the 'cabal sandbox add-source --snapshot' command. 427sandboxAddSourceSnapshot :: Verbosity -> [FilePath] -> FilePath 428 -> PackageEnvironment 429 -> IO () 430sandboxAddSourceSnapshot verbosity buildTreeRefs sandboxDir pkgEnv = do 431 let snapshotDir = sandboxDir </> snapshotDirectoryName 432 433 -- Use 'D.S.SrcDist.prepareTree' to copy each package's files to our private 434 -- location. 435 createDirectoryIfMissingVerbose verbosity True snapshotDir 436 437 -- Collect the package descriptions first, so that if some path does not refer 438 -- to a cabal package, we fail immediately. 439 pkgs <- forM buildTreeRefs $ \buildTreeRef -> 440 inDir (Just buildTreeRef) $ 441 return . flattenPackageDescription 442 =<< readGenericPackageDescription verbosity 443 =<< defaultPackageDesc verbosity 444 445 -- Copy the package sources to "snapshots/$PKGNAME-$VERSION-tmp". If 446 -- 'prepareTree' throws an error at any point, the old snapshots will still be 447 -- in consistent state. 448 tmpDirs <- forM (zip buildTreeRefs pkgs) $ \(buildTreeRef, pkg) -> 449 inDir (Just buildTreeRef) $ do 450 let targetDir = snapshotDir </> (display . packageId $ pkg) 451 targetTmpDir = targetDir ++ "-tmp" 452 dirExists <- doesDirectoryExist targetTmpDir 453 when dirExists $ 454 removeDirectoryRecursive targetDir 455 createDirectory targetTmpDir 456 prepareTree verbosity pkg Nothing targetTmpDir knownSuffixHandlers 457 return (targetTmpDir, targetDir) 458 459 -- Now rename the "snapshots/$PKGNAME-$VERSION-tmp" dirs to 460 -- "snapshots/$PKGNAME-$VERSION". 461 snapshots <- forM tmpDirs $ \(targetTmpDir, targetDir) -> do 462 dirExists <- doesDirectoryExist targetDir 463 when dirExists $ 464 removeDirectoryRecursive targetDir 465 renameDirectory targetTmpDir targetDir 466 return targetDir 467 468 -- Once the packages are copied, just 'add-source' them as usual. 469 doAddSource verbosity snapshots sandboxDir pkgEnv SnapshotRef 470 471-- | Entry point for the 'cabal sandbox delete-source' command. 472sandboxDeleteSource :: Verbosity -> [FilePath] -> SandboxFlags -> GlobalFlags 473 -> IO () 474sandboxDeleteSource verbosity buildTreeRefs _sandboxFlags globalFlags = do 475 (sandboxDir, pkgEnv) <- tryLoadSandboxConfig verbosity globalFlags 476 indexFile <- tryGetIndexFilePath verbosity (pkgEnvSavedConfig pkgEnv) 477 478 (results, convDict) <- 479 Index.removeBuildTreeRefs verbosity indexFile buildTreeRefs 480 481 let (failedPaths, removedPaths) = partitionEithers results 482 removedRefs = fmap convDict removedPaths 483 484 unless (null removedPaths) $ do 485 removeTimestamps verbosity sandboxDir removedPaths 486 487 notice verbosity $ "Success deleting sources: " ++ 488 showL removedRefs ++ "\n\n" 489 490 unless (null failedPaths) $ do 491 let groupedFailures = groupBy errorType failedPaths 492 mapM_ handleErrors groupedFailures 493 die' verbosity $ "The sources with the above errors were skipped. (" ++ 494 showL (fmap getPath failedPaths) ++ ")" 495 496 notice verbosity $ "Note: 'sandbox delete-source' only unregisters the " ++ 497 "source dependency, but does not remove the package " ++ 498 "from the sandbox package DB.\n\n" ++ 499 "Use 'sandbox hc-pkg -- unregister' to do that." 500 where 501 getPath (Index.ErrNonregisteredSource p) = p 502 getPath (Index.ErrNonexistentSource p) = p 503 504 showPaths f = concat . intersperse " " . fmap (show . f) 505 506 showL = showPaths id 507 508 showE [] = return ' ' 509 showE errs = showPaths getPath errs 510 511 errorType Index.ErrNonregisteredSource{} Index.ErrNonregisteredSource{} = 512 True 513 errorType Index.ErrNonexistentSource{} Index.ErrNonexistentSource{} = True 514 errorType _ _ = False 515 516 handleErrors [] = return () 517 handleErrors errs@(Index.ErrNonregisteredSource{}:_) = 518 warn verbosity ("Sources not registered: " ++ showE errs ++ "\n\n") 519 handleErrors errs@(Index.ErrNonexistentSource{}:_) = 520 warn verbosity 521 ("Source directory not found for paths: " ++ showE errs ++ "\n" 522 ++ "If you are trying to delete a reference to a removed directory, " 523 ++ "please provide the full absolute path " 524 ++ "(as given by `sandbox list-sources`).\n\n") 525 526-- | Entry point for the 'cabal sandbox list-sources' command. 527sandboxListSources :: Verbosity -> SandboxFlags -> GlobalFlags 528 -> IO () 529sandboxListSources verbosity _sandboxFlags globalFlags = do 530 (sandboxDir, pkgEnv) <- tryLoadSandboxConfig verbosity globalFlags 531 indexFile <- tryGetIndexFilePath verbosity (pkgEnvSavedConfig pkgEnv) 532 533 refs <- Index.listBuildTreeRefs verbosity 534 Index.ListIgnored Index.LinksAndSnapshots indexFile 535 when (null refs) $ 536 notice verbosity $ "Index file '" ++ indexFile 537 ++ "' has no references to local build trees." 538 when (not . null $ refs) $ do 539 notice verbosity $ "Source dependencies registered " 540 ++ "in the current sandbox ('" ++ sandboxDir ++ "'):\n\n" 541 mapM_ putStrLn refs 542 notice verbosity $ "\nTo unregister source dependencies, " 543 ++ "use the 'sandbox delete-source' command." 544 545-- | Entry point for the 'cabal sandbox hc-pkg' command. Invokes the @hc-pkg@ 546-- tool with provided arguments, restricted to the sandbox. 547sandboxHcPkg :: Verbosity -> SandboxFlags -> GlobalFlags -> [String] -> IO () 548sandboxHcPkg verbosity _sandboxFlags globalFlags extraArgs = do 549 (sandboxDir, pkgEnv) <- tryLoadSandboxConfig verbosity globalFlags 550 let configFlags = savedConfigureFlags . pkgEnvSavedConfig $ pkgEnv 551 -- Invoke hc-pkg for the most recently configured compiler (if any), 552 -- using the right package-db for the compiler (see #1935). 553 (comp, platform, progdb) <- getPersistOrConfigCompiler configFlags 554 let dir = sandboxPackageDBPath sandboxDir comp platform 555 dbStack = [GlobalPackageDB, SpecificPackageDB dir] 556 Register.invokeHcPkg verbosity comp progdb dbStack extraArgs 557 558updateInstallDirs :: Flag Bool 559 -> (UseSandbox, SavedConfig) -> (UseSandbox, SavedConfig) 560updateInstallDirs userInstallFlag (useSandbox, savedConfig) = 561 case useSandbox of 562 NoSandbox -> 563 let savedConfig' = savedConfig { 564 savedConfigureFlags = configureFlags { 565 configInstallDirs = installDirs 566 } 567 } 568 in (useSandbox, savedConfig') 569 _ -> (useSandbox, savedConfig) 570 where 571 configureFlags = savedConfigureFlags savedConfig 572 userInstallDirs = savedUserInstallDirs savedConfig 573 globalInstallDirs = savedGlobalInstallDirs savedConfig 574 installDirs | userInstall = userInstallDirs 575 | otherwise = globalInstallDirs 576 userInstall = fromFlagOrDefault defaultUserInstall 577 (configUserInstall configureFlags `mappend` userInstallFlag) 578 579-- | Check which type of package environment we're in and return a 580-- correctly-initialised @SavedConfig@ and a @UseSandbox@ value that indicates 581-- whether we're working in a sandbox. 582loadConfigOrSandboxConfig :: Verbosity 583 -> GlobalFlags -- ^ For @--config-file@ and 584 -- @--sandbox-config-file@. 585 -> IO (UseSandbox, SavedConfig) 586loadConfigOrSandboxConfig verbosity globalFlags = do 587 let configFileFlag = globalConfigFile globalFlags 588 sandboxConfigFileFlag = globalSandboxConfigFile globalFlags 589 ignoreSandboxFlag = globalIgnoreSandbox globalFlags 590 591 pkgEnvDir <- getPkgEnvDir sandboxConfigFileFlag 592 pkgEnvType <- classifyPackageEnvironment pkgEnvDir sandboxConfigFileFlag 593 ignoreSandboxFlag 594 case pkgEnvType of 595 -- A @cabal.sandbox.config@ file (and possibly @cabal.config@) is present. 596 SandboxPackageEnvironment -> do 597 (sandboxDir, pkgEnv) <- tryLoadSandboxConfig verbosity globalFlags 598 -- Prints an error message and exits on error. 599 let config = pkgEnvSavedConfig pkgEnv 600 return (UseSandbox sandboxDir, config) 601 602 -- Only @cabal.config@ is present. 603 UserPackageEnvironment -> do 604 config <- loadConfig verbosity configFileFlag 605 userConfig <- loadUserConfig verbosity pkgEnvDir Nothing 606 let config' = config `mappend` userConfig 607 dieIfSandboxRequired config' 608 return (NoSandbox, config') 609 610 -- Neither @cabal.sandbox.config@ nor @cabal.config@ are present. 611 AmbientPackageEnvironment -> do 612 config <- loadConfig verbosity configFileFlag 613 let globalConstraintsOpt = 614 flagToMaybe . globalConstraintsFile . savedGlobalFlags $ config 615 globalConstraintConfig <- 616 loadUserConfig verbosity pkgEnvDir globalConstraintsOpt 617 let config' = config `mappend` globalConstraintConfig 618 dieIfSandboxRequired config 619 return (NoSandbox, config') 620 621 where 622 -- Return the path to the package environment directory - either the 623 -- current directory or the one that @--sandbox-config-file@ resides in. 624 getPkgEnvDir :: (Flag FilePath) -> IO FilePath 625 getPkgEnvDir sandboxConfigFileFlag = do 626 case sandboxConfigFileFlag of 627 NoFlag -> getCurrentDirectory 628 Flag path -> tryCanonicalizePath . takeDirectory $ path 629 630 -- Die if @--require-sandbox@ was specified and we're not inside a sandbox. 631 dieIfSandboxRequired :: SavedConfig -> IO () 632 dieIfSandboxRequired config = checkFlag flag 633 where 634 flag = (globalRequireSandbox . savedGlobalFlags $ config) 635 `mappend` (globalRequireSandbox globalFlags) 636 checkFlag (Flag True) = 637 die' verbosity $ "'require-sandbox' is set to True, but no sandbox is present. " 638 ++ "Use '--no-require-sandbox' if you want to override " 639 ++ "'require-sandbox' temporarily." 640 checkFlag (Flag False) = return () 641 checkFlag (NoFlag) = return () 642 643-- | Return the saved \"dist/\" prefix, or the default prefix. 644findSavedDistPref :: SavedConfig -> Flag FilePath -> IO FilePath 645findSavedDistPref config flagDistPref = do 646 let defDistPref = useDistPref defaultSetupScriptOptions 647 flagDistPref' = configDistPref (savedConfigureFlags config) 648 `mappend` flagDistPref 649 findDistPref defDistPref flagDistPref' 650 651-- | If we're in a sandbox, call @withSandboxBinDirOnSearchPath@, otherwise do 652-- nothing. 653maybeWithSandboxDirOnSearchPath :: UseSandbox -> IO a -> IO a 654maybeWithSandboxDirOnSearchPath NoSandbox act = act 655maybeWithSandboxDirOnSearchPath (UseSandbox sandboxDir) act = 656 withSandboxBinDirOnSearchPath sandboxDir $ act 657 658-- | Had reinstallAddSourceDeps actually reinstalled any dependencies? 659data WereDepsReinstalled = ReinstalledSomeDeps | NoDepsReinstalled 660 661-- | Reinstall those add-source dependencies that have been modified since 662-- we've last installed them. Assumes that we're working inside a sandbox. 663reinstallAddSourceDeps :: Verbosity 664 -> ConfigFlags -> ConfigExFlags 665 -> InstallFlags -> GlobalFlags 666 -> FilePath 667 -> IO WereDepsReinstalled 668reinstallAddSourceDeps verbosity configFlags' configExFlags 669 installFlags globalFlags sandboxDir = topHandlerWith errorMsg $ do 670 let sandboxDistPref = sandboxBuildDir sandboxDir 671 configFlags = configFlags' 672 { configDistPref = Flag sandboxDistPref } 673 haddockFlags = mempty 674 { haddockDistPref = Flag sandboxDistPref } 675 (comp, platform, progdb) <- configCompilerAux' configFlags 676 retVal <- newIORef NoDepsReinstalled 677 678 withSandboxPackageInfo verbosity configFlags globalFlags 679 comp platform progdb sandboxDir $ \sandboxPkgInfo -> 680 unless (null $ modifiedAddSourceDependencies sandboxPkgInfo) $ do 681 682 withRepoContext verbosity globalFlags $ \repoContext -> do 683 let args :: InstallArgs 684 args = ((configPackageDB' configFlags) 685 ,repoContext 686 ,comp, platform, progdb 687 ,UseSandbox sandboxDir, Just sandboxPkgInfo 688 ,globalFlags, configFlags, configExFlags, installFlags 689 ,haddockFlags, emptyTestFlags, emptyBenchmarkFlags) 690 691 -- This can actually be replaced by a call to 'install', but we use a 692 -- lower-level API because of layer separation reasons. Additionally, we 693 -- might want to use some lower-level features this in the future. 694 withSandboxBinDirOnSearchPath sandboxDir $ do 695 installContext <- makeInstallContext verbosity args Nothing 696 installPlan <- foldProgress logMsg die'' return =<< 697 makeInstallPlan verbosity args installContext 698 699 processInstallPlan verbosity args installContext installPlan 700 writeIORef retVal ReinstalledSomeDeps 701 702 readIORef retVal 703 704 where 705 die'' message = die' verbosity (message ++ installFailedInSandbox) 706 -- TODO: use a better error message, remove duplication. 707 installFailedInSandbox = 708 "Note: when using a sandbox, all packages are required to have " 709 ++ "consistent dependencies. Try reinstalling/unregistering the " 710 ++ "offending packages or recreating the sandbox." 711 logMsg message rest = debugNoWrap verbosity message >> rest 712 713 errorMsg :: a -> IO WereDepsReinstalled 714 errorMsg _ = do 715 warn verbosity "Couldn't reinstall some add-source dependencies." 716 -- Here we can't know whether any deps have been reinstalled, so we have 717 -- to be conservative. 718 return ReinstalledSomeDeps 719 720-- | Produce a 'SandboxPackageInfo' and feed it to the given action. Note that 721-- we don't update the timestamp file here - this is done in 722-- 'postInstallActions'. 723withSandboxPackageInfo :: Verbosity -> ConfigFlags -> GlobalFlags 724 -> Compiler -> Platform -> ProgramDb 725 -> FilePath 726 -> (SandboxPackageInfo -> IO ()) 727 -> IO () 728withSandboxPackageInfo verbosity configFlags globalFlags 729 comp platform progdb sandboxDir cont = do 730 -- List all add-source deps. 731 indexFile <- tryGetIndexFilePath' verbosity globalFlags 732 buildTreeRefs <- Index.listBuildTreeRefs verbosity 733 Index.DontListIgnored Index.OnlyLinks indexFile 734 let allAddSourceDepsSet = S.fromList buildTreeRefs 735 736 -- List all packages installed in the sandbox. 737 installedPkgIndex <- getInstalledPackagesInSandbox verbosity 738 configFlags comp progdb 739 let err = "Error reading sandbox package information." 740 -- Get the package descriptions for all add-source deps. 741 depsCabalFiles <- mapM (flip (tryFindAddSourcePackageDesc verbosity) err) buildTreeRefs 742 depsPkgDescs <- mapM (readGenericPackageDescription verbosity) depsCabalFiles 743 let depsMap = M.fromList (zip buildTreeRefs depsPkgDescs) 744 isInstalled pkgid = not . null 745 . InstalledPackageIndex.lookupSourcePackageId installedPkgIndex $ pkgid 746 installedDepsMap = M.filter (isInstalled . packageId) depsMap 747 748 -- Get the package ids of modified (and installed) add-source deps. 749 modifiedAddSourceDeps <- listModifiedDeps verbosity sandboxDir 750 (compilerId comp) platform installedDepsMap 751 -- 'fromJust' here is safe because 'modifiedAddSourceDeps' are guaranteed to 752 -- be a subset of the keys of 'depsMap'. 753 let modifiedDeps = [ (modDepPath, fromJust $ M.lookup modDepPath depsMap) 754 | modDepPath <- modifiedAddSourceDeps ] 755 modifiedDepsMap = M.fromList modifiedDeps 756 757 assert (all (`S.member` allAddSourceDepsSet) modifiedAddSourceDeps) (return ()) 758 if (null modifiedDeps) 759 then info verbosity $ "Found no modified add-source deps." 760 else notice verbosity $ "Some add-source dependencies have been modified. " 761 ++ "They will be reinstalled..." 762 763 -- Get the package ids of the remaining add-source deps (some are possibly not 764 -- installed). 765 let otherDeps = M.assocs (depsMap `M.difference` modifiedDepsMap) 766 767 -- Finally, assemble a 'SandboxPackageInfo'. 768 cont $ SandboxPackageInfo (map toSourcePackage modifiedDeps) 769 (map toSourcePackage otherDeps) installedPkgIndex allAddSourceDepsSet 770 771 where 772 toSourcePackage (path, pkgDesc) = SourcePackage 773 (packageId pkgDesc) pkgDesc (LocalUnpackedPackage path) Nothing 774 775-- | Same as 'withSandboxPackageInfo' if we're inside a sandbox and the 776-- identity otherwise. 777maybeWithSandboxPackageInfo :: Verbosity -> ConfigFlags -> GlobalFlags 778 -> Compiler -> Platform -> ProgramDb 779 -> UseSandbox 780 -> (Maybe SandboxPackageInfo -> IO ()) 781 -> IO () 782maybeWithSandboxPackageInfo verbosity configFlags globalFlags 783 comp platform progdb useSandbox cont = 784 case useSandbox of 785 NoSandbox -> cont Nothing 786 UseSandbox sandboxDir -> withSandboxPackageInfo verbosity 787 configFlags globalFlags 788 comp platform progdb sandboxDir 789 (\spi -> cont (Just spi)) 790 791-- | Check if a sandbox is present and call @reinstallAddSourceDeps@ in that 792-- case. 793maybeReinstallAddSourceDeps :: Verbosity 794 -> Flag (Maybe Int) -- ^ The '-j' flag 795 -> ConfigFlags -- ^ Saved configure flags 796 -- (from dist/setup-config) 797 -> GlobalFlags 798 -> (UseSandbox, SavedConfig) 799 -> IO WereDepsReinstalled 800maybeReinstallAddSourceDeps verbosity numJobsFlag configFlags' 801 globalFlags' (useSandbox, config) = do 802 case useSandbox of 803 NoSandbox -> return NoDepsReinstalled 804 UseSandbox sandboxDir -> do 805 -- Reinstall the modified add-source deps. 806 let configFlags = savedConfigureFlags config 807 `mappendSomeSavedFlags` 808 configFlags' 809 configExFlags = defaultConfigExFlags 810 `mappend` savedConfigureExFlags config 811 installFlags' = defaultInstallFlags 812 `mappend` savedInstallFlags config 813 installFlags = installFlags' { 814 installNumJobs = installNumJobs installFlags' 815 `mappend` numJobsFlag 816 } 817 globalFlags = savedGlobalFlags config 818 -- This makes it possible to override things like 'remote-repo-cache' 819 -- from the command line. These options are hidden, and are only 820 -- useful for debugging, so this should be fine. 821 `mappend` globalFlags' 822 reinstallAddSourceDeps 823 verbosity configFlags configExFlags 824 installFlags globalFlags sandboxDir 825 826 where 827 828 -- NOTE: we can't simply do @sandboxConfigFlags `mappend` savedFlags@ 829 -- because we don't want to auto-enable things like 'library-profiling' for 830 -- all add-source dependencies even if the user has passed 831 -- '--enable-library-profiling' to 'cabal configure'. These options are 832 -- supposed to be set in 'cabal.config'. 833 mappendSomeSavedFlags :: ConfigFlags -> ConfigFlags -> ConfigFlags 834 mappendSomeSavedFlags sandboxConfigFlags savedFlags = 835 sandboxConfigFlags { 836 configHcFlavor = configHcFlavor sandboxConfigFlags 837 `mappend` configHcFlavor savedFlags, 838 configHcPath = configHcPath sandboxConfigFlags 839 `mappend` configHcPath savedFlags, 840 configHcPkg = configHcPkg sandboxConfigFlags 841 `mappend` configHcPkg savedFlags, 842 configProgramPaths = configProgramPaths sandboxConfigFlags 843 `mappend` configProgramPaths savedFlags, 844 configProgramArgs = configProgramArgs sandboxConfigFlags 845 `mappend` configProgramArgs savedFlags, 846 -- NOTE: Unconditionally choosing the value from 847 -- 'dist/setup-config'. Sandbox package DB location may have been 848 -- changed by 'configure -w'. 849 configPackageDBs = configPackageDBs savedFlags 850 -- FIXME: Is this compatible with the 'inherit' feature? 851 } 852 853-- 854-- Utils (transitionary) 855-- 856 857-- | Try to read the most recently configured compiler from the 858-- 'localBuildInfoFile', falling back on 'configCompilerAuxEx' if it 859-- cannot be read. 860getPersistOrConfigCompiler :: ConfigFlags 861 -> IO (Compiler, Platform, ProgramDb) 862getPersistOrConfigCompiler configFlags = do 863 distPref <- findDistPrefOrDefault (configDistPref configFlags) 864 mlbi <- maybeGetPersistBuildConfig distPref 865 case mlbi of 866 Nothing -> do configCompilerAux' configFlags 867 Just lbi -> return ( LocalBuildInfo.compiler lbi 868 , LocalBuildInfo.hostPlatform lbi 869 , LocalBuildInfo.withPrograms lbi 870 ) 871