Sandbox.hs 33.5 KB
Newer Older
refold's avatar
refold committed
1
2
3
4
5
6
7
8
9
10
-----------------------------------------------------------------------------
-- |
-- Module      :  Distribution.Client.Sandbox
-- Maintainer  :  cabal-devel@haskell.org
-- Portability :  portable
--
-- UI for the sandboxing functionality.
-----------------------------------------------------------------------------

module Distribution.Client.Sandbox (
refold's avatar
refold committed
11
    sandboxInit,
refold's avatar
refold committed
12
    sandboxDelete,
refold's avatar
refold committed
13
    sandboxAddSource,
14
    sandboxAddSourceSnapshot,
15
    sandboxDeleteSource,
16
    sandboxListSources,
refold's avatar
refold committed
17
    sandboxHcPkg,
18
    dumpPackageEnvironment,
19
20
    withSandboxBinDirOnSearchPath,

Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
21
    getSandboxConfigFilePath,
refold's avatar
refold committed
22
23
    loadConfigOrSandboxConfig,
    initPackageDBIfNeeded,
24
    maybeWithSandboxDirOnSearchPath,
25

26
    WereDepsReinstalled(..),
27
28
    reinstallAddSourceDeps,
    maybeReinstallAddSourceDeps,
refold's avatar
refold committed
29

30
31
32
    SandboxPackageInfo(..),
    maybeWithSandboxPackageInfo,

refold's avatar
refold committed
33
    tryGetIndexFilePath,
34
    sandboxBuildDir,
35
    getInstalledPackagesInSandbox,
refold's avatar
refold committed
36

refold's avatar
refold committed
37
38
    -- FIXME: move somewhere else
    configPackageDB', configCompilerAux'
refold's avatar
refold committed
39
40
41
  ) where

import Distribution.Client.Setup
42
43
44
  ( SandboxFlags(..), ConfigFlags(..), ConfigExFlags(..), InstallFlags(..)
  , GlobalFlags(..), defaultConfigExFlags, defaultInstallFlags
  , defaultSandboxLocation, globalRepos )
45
46
import Distribution.Client.Sandbox.Timestamp  ( listModifiedDeps
                                              , maybeAddCompilerTimestampRecord
refold's avatar
refold committed
47
                                              , withAddTimestamps
48
                                              , withRemoveTimestamps )
refold's avatar
refold committed
49
import Distribution.Client.Config             ( SavedConfig(..), loadConfig )
50
import Distribution.Client.Dependency         ( foldProgress )
51
import Distribution.Client.IndexUtils         ( BuildTreeRefType(..) )
52
53
54
import Distribution.Client.Install            ( InstallArgs,
                                                makeInstallContext,
                                                makeInstallPlan,
55
                                                processInstallPlan )
56
import Distribution.Client.Sandbox.PackageEnvironment
57
  ( PackageEnvironment(..), IncludeComments(..), PackageEnvironmentType(..)
58
59
  , createPackageEnvironmentFile, classifyPackageEnvironment
  , tryLoadSandboxPackageEnvironmentFile, loadUserConfig
60
  , commentPackageEnvironment, showPackageEnvironmentWithComments
61
  , sandboxPackageEnvironmentFile, userPackageEnvironmentFile )
62
63
64
65
import Distribution.Client.Sandbox.Types      ( SandboxPackageInfo(..)
                                              , UseSandbox(..) )
import Distribution.Client.Types              ( PackageLocation(..)
                                              , SourcePackage(..) )
66
67
68
69
import Distribution.Client.Utils              ( inDir, tryCanonicalizePath )
import Distribution.PackageDescription.Configuration
                                              ( flattenPackageDescription )
import Distribution.PackageDescription.Parse  ( readPackageDescription )
refold's avatar
refold committed
70
import Distribution.Simple.Compiler           ( Compiler(..), PackageDB(..)
refold's avatar
refold committed
71
                                              , PackageDBStack )
72
import Distribution.Simple.Configure          ( configCompilerAuxEx
73
74
                                              , interpretPackageDbFlags
                                              , getPackageDBContents )
75
import Distribution.Simple.PreProcess         ( knownSuffixHandlers )
refold's avatar
refold committed
76
import Distribution.Simple.Program            ( ProgramConfiguration )
77
78
import Distribution.Simple.Setup              ( Flag(..), HaddockFlags(..)
                                              , fromFlagOrDefault )
79
import Distribution.Simple.SrcDist            ( prepareTree )
80
import Distribution.Simple.Utils              ( die, debug, notice, warn
81
                                              , debugNoWrap, defaultPackageDesc
82
                                              , findPackageDesc
83
                                              , intercalate, topHandlerWith
refold's avatar
refold committed
84
                                              , createDirectoryIfMissingVerbose )
85
import Distribution.Package                   ( Package(..) )
86
import Distribution.System                    ( Platform )
87
import Distribution.Text                      ( display )
88
import Distribution.Verbosity                 ( Verbosity, lessVerbose )
89
90
import Distribution.Client.Compat.Environment ( lookupEnv, setEnv )
import Distribution.Client.Compat.FilePerms   ( setFileHidden )
91
import qualified Distribution.Client.Sandbox.Index as Index
92
import qualified Distribution.Simple.PackageIndex  as InstalledPackageIndex
93
import qualified Distribution.Simple.Register      as Register
94
import qualified Data.Map                          as M
95
import qualified Data.Set                          as S
96
import Control.Exception                      ( assert, bracket_ )
97
import Control.Monad                          ( forM, liftM2, unless, when )
98
99
import Data.Bits                              ( shiftL, shiftR, xor )
import Data.Char                              ( ord )
100
import Data.IORef                             ( newIORef, writeIORef, readIORef )
101
import Data.List                              ( delete, foldl' )
102
import Data.Maybe                             ( fromJust )
103
import Data.Monoid                            ( mempty, mappend )
104
105
import Data.Word                              ( Word32 )
import Numeric                                ( showHex )
106
107
import System.Directory                       ( createDirectory
                                              , doesDirectoryExist
108
                                              , doesFileExist
109
110
                                              , getCurrentDirectory
                                              , removeDirectoryRecursive
111
112
                                              , removeFile
                                              , renameDirectory )
113
import System.FilePath                        ( (</>), getSearchPath
114
115
                                              , searchPathSeparator
                                              , takeDirectory )
refold's avatar
refold committed
116
117


118
119
120
121
122
123
124
125
126
--
-- * Constants
--

-- | The name of the sandbox subdirectory where we keep snapshots of add-source
-- dependencies.
snapshotDirectoryName :: FilePath
snapshotDirectoryName = "snapshots"

127
128
-- | Non-standard build dir that is used for building add-source deps instead of
-- "dist". Fixes surprising behaviour in some cases (see issue #1281).
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
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)
152

153
154
155
156
--
-- * Basic sandbox functions.
--

157
158
159
160
161
162
163
164
165
166
167
-- | Return the path to the package environment directory - either the current
-- directory or the one that @--sandbox-config-file@ resides in.
getPkgEnvDir :: GlobalFlags -> IO FilePath
getPkgEnvDir globalFlags = do
  let sandboxConfigFileFlag = globalSandboxConfigFile globalFlags
  case sandboxConfigFileFlag of
    NoFlag    -> getCurrentDirectory
    Flag path -> tryCanonicalizePath . takeDirectory $ path

-- | Return the path to the sandbox config file - either the default or the one
-- specified with @--sandbox-config-file@.
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
168
169
getSandboxConfigFilePath :: GlobalFlags -> IO FilePath
getSandboxConfigFilePath globalFlags = do
170
171
172
173
174
175
176
177
178
179
180
  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
181
                        -> IO (FilePath, PackageEnvironment)
182
tryLoadSandboxConfig verbosity globalFlags = do
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
183
  path <- getSandboxConfigFilePath globalFlags
184
185
  tryLoadSandboxPackageEnvironmentFile verbosity path
    (globalConfigFile globalFlags)
refold's avatar
refold committed
186

187
-- | Return the name of the package index file for this package environment.
refold's avatar
refold committed
188
tryGetIndexFilePath :: SavedConfig -> IO FilePath
189
190
191
192
193
194
195
tryGetIndexFilePath config = tryGetIndexFilePath' (savedGlobalFlags config)

-- | The same as 'tryGetIndexFilePath', but takes 'GlobalFlags' instead of
-- 'SavedConfig'.
tryGetIndexFilePath' :: GlobalFlags -> IO FilePath
tryGetIndexFilePath' globalFlags = do
  let paths = globalLocalRepos globalFlags
refold's avatar
refold committed
196
  case paths of
197
    []  -> die $ "Distribution.Client.Sandbox.tryGetIndexFilePath: " ++
refold's avatar
refold committed
198
           "no local repos found. " ++ checkConfiguration
199
    _   -> return $ (last paths) </> Index.defaultIndexFileName
refold's avatar
refold committed
200
201
202
  where
    checkConfiguration = "Please check your configuration ('"
                         ++ userPackageEnvironmentFile ++ "')."
refold's avatar
refold committed
203

Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
-- | 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."


224
225
226
227
228
-- | Which packages are installed in the sandbox package DB?
getInstalledPackagesInSandbox :: Verbosity -> ConfigFlags
                                 -> Compiler -> ProgramConfiguration
                                 -> IO InstalledPackageIndex.PackageIndex
getInstalledPackagesInSandbox verbosity configFlags comp conf = do
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
229
    sandboxDB <- getSandboxPackageDB configFlags
230
231
    getPackageDBContents verbosity comp sandboxDB conf

232
233
234
235
236
237
238
239
240
241
-- | 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
242
243
244
      mbOldPath <- lookupEnv "PATH"
      let newPath = maybe sandboxBin ((++) sandboxBin . (:) searchPathSeparator)
                    mbOldPath
245
246
247
248
249
250
251
252
253
254
255
      setEnv "PATH" newPath

    rmBinDir :: IO ()
    rmBinDir = do
      oldPath <- getSearchPath
      let newPath = intercalate [searchPathSeparator]
                    (delete sandboxBin oldPath)
      setEnv "PATH" newPath

    sandboxBin = sandboxDir </> "bin"

256
257
258
259
260
-- | Initialise a package DB for this compiler if it doesn't exist.
initPackageDBIfNeeded :: Verbosity -> ConfigFlags
                         -> Compiler -> ProgramConfiguration
                         -> IO ()
initPackageDBIfNeeded verbosity configFlags comp conf = do
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
261
  SpecificPackageDB dbPath <- getSandboxPackageDB configFlags
262
263
264
265
266
267
  packageDBExists <- doesDirectoryExist dbPath
  unless packageDBExists $
    Register.initPackageDB verbosity comp conf dbPath
  when packageDBExists $
    debug verbosity $ "The package database already exists: " ++ dbPath

refold's avatar
refold committed
268
-- | Entry point for the 'cabal dump-pkgenv' command.
269
270
dumpPackageEnvironment :: Verbosity -> SandboxFlags -> GlobalFlags -> IO ()
dumpPackageEnvironment verbosity _sandboxFlags globalFlags = do
271
  (sandboxDir, pkgEnv) <- tryLoadSandboxConfig verbosity globalFlags
refold's avatar
refold committed
272
  commentPkgEnv        <- commentPackageEnvironment sandboxDir
refold's avatar
refold committed
273
  putStrLn . showPackageEnvironmentWithComments (Just commentPkgEnv) $ pkgEnv
refold's avatar
refold committed
274

refold's avatar
refold committed
275
-- | Entry point for the 'cabal sandbox-init' command.
276
sandboxInit :: Verbosity -> SandboxFlags  -> GlobalFlags -> IO ()
277
sandboxInit verbosity sandboxFlags globalFlags = do
278
279
280
281
282
283
284
285
286
  -- Check that there is no 'cabal-dev' directory.
  isCabalDevSandbox <- liftM2 (&&) (doesDirectoryExist "cabal-dev")
                       (doesFileExist $ "cabal-dev" </> "cabal.config")
  when isCabalDevSandbox $
    die $
    "You are apparently using a legacy (cabal-dev) sandbox. "
    ++ "To use native cabal sandboxing, please delete the 'cabal-dev' directory "
    ++  "and run 'cabal sandbox init'."

287
288
289
290
  -- Create the sandbox directory.
  let sandboxDir' = fromFlagOrDefault defaultSandboxLocation
                    (sandboxLocation sandboxFlags)
  createDirectoryIfMissingVerbose verbosity True sandboxDir'
291
  sandboxDir <- tryCanonicalizePath sandboxDir'
292
  setFileHidden sandboxDir
293
294

  -- Determine which compiler to use (using the value from ~/.cabal/config).
295
  userConfig <- loadConfig verbosity (globalConfigFile globalFlags) NoFlag
296
  (comp, platform, conf) <- configCompilerAuxEx (savedConfigureFlags userConfig)
297
298

  -- Create the package environment file.
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
299
  pkgEnvFile <- getSandboxConfigFilePath globalFlags
300
  createPackageEnvironmentFile verbosity sandboxDir pkgEnvFile
301
    NoComments comp platform
302
303
304
  (_sandboxDir, pkgEnv) <- tryLoadSandboxConfig verbosity globalFlags
  let config      = pkgEnvSavedConfig pkgEnv
      configFlags = savedConfigureFlags config
305
306

  -- Create the index file if it doesn't exist.
307
  indexFile <- tryGetIndexFilePath config
308
309
310
311
  indexFileExists <- doesFileExist indexFile
  if indexFileExists
    then notice verbosity $ "Using an existing sandbox located at " ++ sandboxDir
    else notice verbosity $ "Creating a new sandbox at " ++ sandboxDir
312
313
  Index.createEmpty verbosity indexFile

314
315
316
317
  -- Create the package DB for the default compiler.
  initPackageDBIfNeeded verbosity configFlags comp conf
  maybeAddCompilerTimestampRecord verbosity sandboxDir indexFile
    (compilerId comp) platform
refold's avatar
refold committed
318

refold's avatar
refold committed
319
320
-- | Entry point for the 'cabal sandbox-delete' command.
sandboxDelete :: Verbosity -> SandboxFlags -> GlobalFlags -> IO ()
321
sandboxDelete verbosity _sandboxFlags globalFlags = do
322
  (useSandbox, _) <- loadConfigOrSandboxConfig verbosity globalFlags mempty
323
324
325
  case useSandbox of
    NoSandbox -> die "Not in a sandbox."
    UseSandbox sandboxDir -> do
326
      curDir     <- getCurrentDirectory
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
327
      pkgEnvFile <- getSandboxConfigFilePath globalFlags
328

329
330
331
332
333
334
      -- Remove the @cabal.sandbox.config@ file, unless it's in a non-standard
      -- location.
      let isNonDefaultConfigLocation =
            pkgEnvFile /= (curDir </> sandboxPackageEnvironmentFile)

      if isNonDefaultConfigLocation
hesselink's avatar
hesselink committed
335
        then warn verbosity $ "Sandbox config file is in non-default location: '"
336
337
                    ++ pkgEnvFile ++ "'.\n Please delete manually."
        else removeFile pkgEnvFile
338
339

      -- Remove the sandbox directory, unless we're using a shared sandbox.
340
341
      let isNonDefaultSandboxLocation =
            sandboxDir /= (curDir </> defaultSandboxLocation)
342

343
      when isNonDefaultSandboxLocation $
344
        die $ "Non-default sandbox location used: '" ++ sandboxDir
345
        ++ "'.\nAssuming a shared sandbox. Please delete '"
346
347
348
349
        ++ sandboxDir ++ "' manually."

      notice verbosity $ "Deleting the sandbox located at " ++ sandboxDir
      removeDirectoryRecursive sandboxDir
refold's avatar
refold committed
350

351
-- Common implementation of 'sandboxAddSource' and 'sandboxAddSourceSnapshot'.
352
353
354
355
doAddSource :: Verbosity -> [FilePath] -> FilePath -> PackageEnvironment
               -> BuildTreeRefType
               -> IO ()
doAddSource verbosity buildTreeRefs sandboxDir pkgEnv refType = do
refold's avatar
refold committed
356
357
358
359
360
  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.
361
  (comp, platform, _) <- configCompilerAuxEx . savedConfigureFlags $ savedConfig
362
363
  maybeAddCompilerTimestampRecord verbosity sandboxDir indexFile
    (compilerId comp) platform
refold's avatar
refold committed
364

refold's avatar
refold committed
365
  withAddTimestamps sandboxDir $ do
366
367
368
    -- FIXME: path canonicalisation is done in addBuildTreeRefs, but we do it
    -- twice because of the timestamps file.
    buildTreeRefs' <- mapM tryCanonicalizePath buildTreeRefs
369
    Index.addBuildTreeRefs verbosity indexFile buildTreeRefs' refType
370
    return buildTreeRefs'
refold's avatar
refold committed
371

372
373
374
375
-- | Entry point for the 'cabal sandbox add-source' command.
sandboxAddSource :: Verbosity -> [FilePath] -> SandboxFlags -> GlobalFlags
                    -> IO ()
sandboxAddSource verbosity buildTreeRefs sandboxFlags globalFlags = do
376
  (sandboxDir, pkgEnv) <- tryLoadSandboxConfig verbosity globalFlags
377
378
379

  if fromFlagOrDefault False (sandboxSnapshot sandboxFlags)
    then sandboxAddSourceSnapshot verbosity buildTreeRefs sandboxDir pkgEnv
380
    else doAddSource verbosity buildTreeRefs sandboxDir pkgEnv LinkRef
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411

-- | 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
refold's avatar
refold committed
412
      prepareTree verbosity pkg Nothing targetTmpDir knownSuffixHandlers
413
414
415
416
417
418
419
420
421
422
423
424
      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.
425
  doAddSource verbosity snapshots sandboxDir pkgEnv SnapshotRef
426

427
428
429
430
-- | Entry point for the 'cabal sandbox delete-source' command.
sandboxDeleteSource :: Verbosity -> [FilePath] -> SandboxFlags -> GlobalFlags
                       -> IO ()
sandboxDeleteSource verbosity buildTreeRefs _sandboxFlags globalFlags = do
431
  (sandboxDir, pkgEnv) <- tryLoadSandboxConfig verbosity globalFlags
432
  indexFile            <- tryGetIndexFilePath (pkgEnvSavedConfig pkgEnv)
433

refold's avatar
refold committed
434
  withRemoveTimestamps sandboxDir $ do
435
    Index.removeBuildTreeRefs verbosity indexFile buildTreeRefs
436

Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
437
438
439
440
  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."
441

442
443
444
445
-- | Entry point for the 'cabal sandbox list-sources' command.
sandboxListSources :: Verbosity -> SandboxFlags -> GlobalFlags
                      -> IO ()
sandboxListSources verbosity _sandboxFlags globalFlags = do
446
  (sandboxDir, pkgEnv) <- tryLoadSandboxConfig verbosity globalFlags
refold's avatar
refold committed
447
  indexFile            <- tryGetIndexFilePath (pkgEnvSavedConfig pkgEnv)
448

449
450
  refs <- Index.listBuildTreeRefs verbosity
          Index.ListIgnored Index.LinksAndSnapshots indexFile
refold's avatar
refold committed
451
  when (null refs) $
refold's avatar
refold committed
452
    notice verbosity $ "Index file '" ++ indexFile
refold's avatar
refold committed
453
    ++ "' has no references to local build trees."
454
455
456
457
458
459
  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."
460

refold's avatar
refold committed
461
462
463
464
-- | Invoke the @hc-pkg@ tool with provided arguments, restricted to the
-- sandbox.
sandboxHcPkg :: Verbosity -> SandboxFlags -> GlobalFlags -> [String] -> IO ()
sandboxHcPkg verbosity _sandboxFlags globalFlags extraArgs = do
465
  (_sandboxDir, pkgEnv) <- tryLoadSandboxConfig verbosity globalFlags
refold's avatar
refold committed
466
  let configFlags = savedConfigureFlags . pkgEnvSavedConfig $ pkgEnv
467
      dbStack     = configPackageDB' configFlags
refold's avatar
refold committed
468
469
470
471
  (comp, _platform, conf) <- configCompilerAux' configFlags

  Register.invokeHcPkg verbosity comp conf dbStack extraArgs

refold's avatar
refold committed
472
473
474
-- | 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.
475
loadConfigOrSandboxConfig :: Verbosity
476
477
478
                             -> GlobalFlags  -- ^ For @--config-file@ and
                                             -- @--sandbox-config-file@.
                             -> Flag Bool    -- ^ Ignored if we're in a sandbox.
refold's avatar
refold committed
479
                             -> IO (UseSandbox, SavedConfig)
480
481
482
483
484
485
486
487
488
loadConfigOrSandboxConfig verbosity globalFlags userInstallFlag = do
  let configFileFlag        = globalConfigFile globalFlags
      sandboxConfigFileFlag = globalSandboxConfigFile globalFlags

  pkgEnvDir  <- getPkgEnvDir globalFlags
  pkgEnvType <- case sandboxConfigFileFlag of
    NoFlag -> classifyPackageEnvironment pkgEnvDir
    Flag _ -> return SandboxPackageEnvironment

489
  case pkgEnvType of
490
    -- A @cabal.sandbox.config@ file (and possibly @cabal.config@) is present.
491
    SandboxPackageEnvironment -> do
492
      (sandboxDir, pkgEnv) <- tryLoadSandboxConfig verbosity globalFlags
493
                              -- ^ Prints an error message and exits on error.
refold's avatar
refold committed
494
495
      let config = pkgEnvSavedConfig pkgEnv
      return (UseSandbox sandboxDir, config)
496

497
    -- Only @cabal.config@ is present.
498
    UserPackageEnvironment    -> do
499
      config <- loadConfig verbosity configFileFlag userInstallFlag
500
      userConfig <- loadUserConfig verbosity pkgEnvDir
refold's avatar
refold committed
501
      return (NoSandbox, config `mappend` userConfig)
502

503
504
    -- Neither @cabal.sandbox.config@ nor @cabal.config@ are present.
    AmbientPackageEnvironment -> do
505
      config <- loadConfig verbosity configFileFlag userInstallFlag
refold's avatar
refold committed
506
      return (NoSandbox, config)
507
508
509

-- | If we're in a sandbox, call @withSandboxBinDirOnSearchPath@, otherwise do
-- nothing.
refold's avatar
refold committed
510
511
512
maybeWithSandboxDirOnSearchPath :: UseSandbox -> IO a -> IO a
maybeWithSandboxDirOnSearchPath NoSandbox               act = act
maybeWithSandboxDirOnSearchPath (UseSandbox sandboxDir) act =
513
  withSandboxBinDirOnSearchPath sandboxDir $ act
514

515
-- | Had reinstallAddSourceDeps actually reinstalled any dependencies?
516
data WereDepsReinstalled = ReinstalledSomeDeps | NoDepsReinstalled
517

518
-- | Reinstall those add-source dependencies that have been modified since
519
520
521
522
523
-- we've last installed them. Assumes that we're working inside a sandbox.
reinstallAddSourceDeps :: Verbosity
                          -> ConfigFlags  -> ConfigExFlags
                          -> InstallFlags -> GlobalFlags
                          -> FilePath
524
                          -> IO WereDepsReinstalled
525
reinstallAddSourceDeps verbosity configFlags' configExFlags
526
                       installFlags globalFlags sandboxDir = topHandler' $ do
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
  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

      let args :: InstallArgs
          args = ((configPackageDB' configFlags)
                 ,(globalRepos globalFlags)
                 ,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
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
552
        installPlan    <- foldProgress logMsg die' return =<<
553
554
555
556
                          makeInstallPlan verbosity args installContext

        processInstallPlan verbosity args installContext installPlan
        writeIORef retVal ReinstalledSomeDeps
557
558

  readIORef retVal
559

560
    where
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
561
562
563
564
565
566
567
      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."
568
569
      logMsg message rest = debugNoWrap verbosity message >> rest

570
571
572
573
574
575
      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

576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
-- | 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

592
593
594
595
  -- List all packages installed in the sandbox.
  installedPkgIndex <- getInstalledPackagesInSandbox verbosity
                       configFlags comp conf

596
597
  -- Get the package descriptions for all add-source deps.
  depsCabalFiles <- mapM findPackageDesc buildTreeRefs
598
  depsPkgDescs   <- mapM (readPackageDescription verbosity) depsCabalFiles
599
600
601
602
  let depsMap           = M.fromList (zip buildTreeRefs depsPkgDescs)
      isInstalled pkgid = not . null
        . InstalledPackageIndex.lookupSourcePackageId installedPkgIndex $ pkgid
      installedDepsMap  = M.filter (isInstalled . packageId) depsMap
603
604

  -- Get the package ids of modified (and installed) add-source deps.
605
  modifiedAddSourceDeps <- listModifiedDeps verbosity sandboxDir
606
607
608
609
610
611
                           (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
612

613
614
615
616
617
  assert (all (`S.member` allAddSourceDepsSet) modifiedAddSourceDeps) (return ())
  unless (null modifiedDeps) $
    notice verbosity $ "Some add-source dependencies have been modified. "
                       ++ "They will be reinstalled..."

618
619
  -- Get the package ids of the remaining add-source deps (some are possibly not
  -- installed).
620
  let otherDeps = M.assocs (depsMap `M.difference` modifiedDepsMap)
621

622
623
624
  -- Finally, assemble a 'SandboxPackageInfo'.
  cont $ SandboxPackageInfo (map toSourcePackage modifiedDeps)
    (map toSourcePackage otherDeps) installedPkgIndex allAddSourceDepsSet
625

626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
  where
    toSourcePackage (path, pkgDesc) = SourcePackage
      (packageId pkgDesc) pkgDesc (LocalUnpackedPackage path) Nothing

-- | Same as 'withSandboxPackageInfo' if we're inside a sandbox and a no-op
-- 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))
645

646
647
-- | Check if a sandbox is present and call @reinstallAddSourceDeps@ in that
-- case.
648
649
650
651
652
maybeReinstallAddSourceDeps :: Verbosity
                               -> Flag (Maybe Int) -- ^ The '-j' flag
                               -> ConfigFlags      -- ^ Saved configure flags
                                                   -- (from dist/setup-config)
                               -> GlobalFlags
653
                               -> IO (UseSandbox, WereDepsReinstalled)
654
maybeReinstallAddSourceDeps verbosity numJobsFlag configFlags' globalFlags' = do
655
656
657
  currentDir <- getCurrentDirectory
  pkgEnvType <- classifyPackageEnvironment currentDir
  case pkgEnvType of
658
659
    AmbientPackageEnvironment -> return (NoSandbox, NoDepsReinstalled)
    UserPackageEnvironment    -> return (NoSandbox, NoDepsReinstalled)
660
    SandboxPackageEnvironment -> do
661
662
663
664
      (sandboxDir, pkgEnv)    <- tryLoadSandboxConfig verbosity globalFlags'

      -- Actually reinstall the modified add-source deps.
      let config         = pkgEnvSavedConfig pkgEnv
665
666
667
          configFlags    = savedConfigureFlags config
                           `mappendSomeSavedFlags`
                           configFlags'
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
          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'
      depsReinstalled <- reinstallAddSourceDeps verbosity
                         configFlags configExFlags installFlags globalFlags
                         sandboxDir
      return (UseSandbox sandboxDir, depsReinstalled)
refold's avatar
refold committed
685

686
687
  where

688
689
690
691
692
    -- 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'.
693
    mappendSomeSavedFlags :: ConfigFlags -> ConfigFlags -> ConfigFlags
694
695
696
697
698
699
700
701
702
703
704
    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
jhenahan's avatar
jhenahan committed
705
                             `mappend` configProgramArgs savedFlags
706
707
708
709
        -- NOTE: We don't touch the @configPackageDBs@ field because
        -- @sandboxConfigFlags@ contains the sandbox location which was set when
        -- creating @cabal.sandbox.config@.
        -- FIXME: Is this compatible with the 'inherit' feature?
710
        }
711

refold's avatar
refold committed
712
713
714
715
716
717
718
--
-- Utils (transitionary)
--
-- FIXME: configPackageDB' and configCompilerAux' don't really belong in this
-- module
--

719
720
configPackageDB' :: ConfigFlags -> PackageDBStack
configPackageDB' cfg =
refold's avatar
refold committed
721
722
    interpretPackageDbFlags userInstall (configPackageDBs cfg)
  where
723
    userInstall = fromFlagOrDefault True (configUserInstall cfg)
refold's avatar
refold committed
724
725
726
727

configCompilerAux' :: ConfigFlags
                   -> IO (Compiler, Platform, ProgramConfiguration)
configCompilerAux' configFlags =
728
  configCompilerAuxEx configFlags
refold's avatar
refold committed
729
730
    --FIXME: make configCompilerAux use a sensible verbosity
    { configVerbosity = fmap lessVerbose (configVerbosity configFlags) }