Sandbox.hs 33.3 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          ( configCompilerAux
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
import Distribution.Compat.Env                ( lookupEnv, setEnv )
90
import Distribution.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
refold's avatar
refold committed
199
    [p] -> return $ p </> Index.defaultIndexFileName
200
    _   -> die $ "Distribution.Client.Sandbox.tryGetIndexFilePath: " ++
refold's avatar
refold committed
201
202
203
204
205
           "too many local repos found. " ++ checkConfiguration

  where
    checkConfiguration = "Please check your configuration ('"
                         ++ userPackageEnvironmentFile ++ "')."
refold's avatar
refold committed
206

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


227
228
229
230
231
-- | 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
232
    sandboxDB <- getSandboxPackageDB configFlags
233
234
    getPackageDBContents verbosity comp sandboxDB conf

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

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

    sandboxBin = sandboxDir </> "bin"

259
260
261
262
263
-- | 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
264
  SpecificPackageDB dbPath <- getSandboxPackageDB configFlags
265
266
267
268
269
270
  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
271
-- | Entry point for the 'cabal dump-pkgenv' command.
272
273
dumpPackageEnvironment :: Verbosity -> SandboxFlags -> GlobalFlags -> IO ()
dumpPackageEnvironment verbosity _sandboxFlags globalFlags = do
274
  (sandboxDir, pkgEnv) <- tryLoadSandboxConfig verbosity globalFlags
refold's avatar
refold committed
275
  commentPkgEnv        <- commentPackageEnvironment sandboxDir
refold's avatar
refold committed
276
  putStrLn . showPackageEnvironmentWithComments (Just commentPkgEnv) $ pkgEnv
refold's avatar
refold committed
277

refold's avatar
refold committed
278
-- | Entry point for the 'cabal sandbox-init' command.
279
sandboxInit :: Verbosity -> SandboxFlags  -> GlobalFlags -> IO ()
280
sandboxInit verbosity sandboxFlags globalFlags = do
281
282
283
284
285
286
287
288
289
  -- 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'."

290
291
292
293
  -- Create the sandbox directory.
  let sandboxDir' = fromFlagOrDefault defaultSandboxLocation
                    (sandboxLocation sandboxFlags)
  createDirectoryIfMissingVerbose verbosity True sandboxDir'
294
  sandboxDir <- tryCanonicalizePath sandboxDir'
295
  setFileHidden sandboxDir
296
297
298
  notice verbosity $ "Using a sandbox located at " ++ sandboxDir

  -- Determine which compiler to use (using the value from ~/.cabal/config).
299
300
  userConfig <- loadConfig verbosity (globalConfigFile globalFlags) NoFlag
  (comp, platform, _) <- configCompilerAux (savedConfigureFlags userConfig)
301
302

  -- Create the package environment file.
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
303
  pkgEnvFile <- getSandboxConfigFilePath globalFlags
304
  createPackageEnvironmentFile verbosity sandboxDir pkgEnvFile
305
    NoComments comp platform
306
  (_, pkgEnv) <- tryLoadSandboxConfig verbosity globalFlags
307
308

  -- Create the index file if it doesn't exist.
refold's avatar
refold committed
309
  indexFile <- tryGetIndexFilePath (pkgEnvSavedConfig pkgEnv)
310
311
  Index.createEmpty verbosity indexFile

312
313
314
315
  -- We don't create the package DB for the default compiler here: it's created
  -- by demand in 'install' and 'configure'. This way, if you run 'sandbox init'
  -- and then 'configure -w /path/to/nondefault-ghc', you'll end up with a
  -- package DB for only one compiler instead of two.
refold's avatar
refold committed
316

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

327
328
329
330
331
332
      -- 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
333
        then warn verbosity $ "Sandbox config file is in non-default location: '"
334
335
                    ++ pkgEnvFile ++ "'.\n Please delete manually."
        else removeFile pkgEnvFile
336
337

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

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

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

349
-- Common implementation of 'sandboxAddSource' and 'sandboxAddSourceSnapshot'.
350
351
352
353
doAddSource :: Verbosity -> [FilePath] -> FilePath -> PackageEnvironment
               -> BuildTreeRefType
               -> IO ()
doAddSource verbosity buildTreeRefs sandboxDir pkgEnv refType = do
refold's avatar
refold committed
354
355
356
357
358
359
  let savedConfig       = pkgEnvSavedConfig pkgEnv
  indexFile            <- tryGetIndexFilePath savedConfig

  -- If we're running 'sandbox add-source' for the first time for this compiler,
  -- we need to create an initial timestamp record.
  (comp, platform, _) <- configCompilerAux . savedConfigureFlags $ savedConfig
360
361
  maybeAddCompilerTimestampRecord verbosity sandboxDir indexFile
    (compilerId comp) platform
refold's avatar
refold committed
362

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

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

  if fromFlagOrDefault False (sandboxSnapshot sandboxFlags)
    then sandboxAddSourceSnapshot verbosity buildTreeRefs sandboxDir pkgEnv
378
    else doAddSource verbosity buildTreeRefs sandboxDir pkgEnv LinkRef
379
380
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

-- | 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
410
      prepareTree verbosity pkg Nothing targetTmpDir knownSuffixHandlers
411
412
413
414
415
416
417
418
419
420
421
422
      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.
423
  doAddSource verbosity snapshots sandboxDir pkgEnv SnapshotRef
424

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

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

435
436
437
438
-- | Entry point for the 'cabal sandbox list-sources' command.
sandboxListSources :: Verbosity -> SandboxFlags -> GlobalFlags
                      -> IO ()
sandboxListSources verbosity _sandboxFlags globalFlags = do
439
  (sandboxDir, pkgEnv) <- tryLoadSandboxConfig verbosity globalFlags
refold's avatar
refold committed
440
  indexFile            <- tryGetIndexFilePath (pkgEnvSavedConfig pkgEnv)
441

442
443
  refs <- Index.listBuildTreeRefs verbosity
          Index.ListIgnored Index.LinksAndSnapshots indexFile
refold's avatar
refold committed
444
  when (null refs) $
refold's avatar
refold committed
445
    notice verbosity $ "Index file '" ++ indexFile
refold's avatar
refold committed
446
    ++ "' has no references to local build trees."
447
448
449
450
451
452
  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."
453

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

  Register.invokeHcPkg verbosity comp conf dbStack extraArgs

refold's avatar
refold committed
465
466
467
-- | 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.
468
loadConfigOrSandboxConfig :: Verbosity
469
470
471
                             -> GlobalFlags  -- ^ For @--config-file@ and
                                             -- @--sandbox-config-file@.
                             -> Flag Bool    -- ^ Ignored if we're in a sandbox.
refold's avatar
refold committed
472
                             -> IO (UseSandbox, SavedConfig)
473
474
475
476
477
478
479
480
481
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

482
  case pkgEnvType of
483
    -- A @cabal.sandbox.config@ file (and possibly @cabal.config@) is present.
484
    SandboxPackageEnvironment -> do
485
      (sandboxDir, pkgEnv) <- tryLoadSandboxConfig verbosity globalFlags
486
                              -- ^ Prints an error message and exits on error.
refold's avatar
refold committed
487
488
      let config = pkgEnvSavedConfig pkgEnv
      return (UseSandbox sandboxDir, config)
489

490
    -- Only @cabal.config@ is present.
491
    UserPackageEnvironment    -> do
492
      config <- loadConfig verbosity configFileFlag userInstallFlag
493
      userConfig <- loadUserConfig verbosity pkgEnvDir
refold's avatar
refold committed
494
      return (NoSandbox, config `mappend` userConfig)
495

496
497
    -- Neither @cabal.sandbox.config@ nor @cabal.config@ are present.
    AmbientPackageEnvironment -> do
498
      config <- loadConfig verbosity configFileFlag userInstallFlag
refold's avatar
refold committed
499
      return (NoSandbox, config)
500
501
502

-- | If we're in a sandbox, call @withSandboxBinDirOnSearchPath@, otherwise do
-- nothing.
refold's avatar
refold committed
503
504
505
maybeWithSandboxDirOnSearchPath :: UseSandbox -> IO a -> IO a
maybeWithSandboxDirOnSearchPath NoSandbox               act = act
maybeWithSandboxDirOnSearchPath (UseSandbox sandboxDir) act =
506
  withSandboxBinDirOnSearchPath sandboxDir $ act
507

508
-- | Had reinstallAddSourceDeps actually reinstalled any dependencies?
509
data WereDepsReinstalled = ReinstalledSomeDeps | NoDepsReinstalled
510

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

        processInstallPlan verbosity args installContext installPlan
        writeIORef retVal ReinstalledSomeDeps
550
551

  readIORef retVal
552

553
    where
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
554
555
556
557
558
559
560
      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."
561
562
      logMsg message rest = debugNoWrap verbosity message >> rest

563
564
565
566
567
568
      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

569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
-- | 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

585
586
587
588
  -- List all packages installed in the sandbox.
  installedPkgIndex <- getInstalledPackagesInSandbox verbosity
                       configFlags comp conf

589
590
  -- Get the package descriptions for all add-source deps.
  depsCabalFiles <- mapM findPackageDesc buildTreeRefs
591
  depsPkgDescs   <- mapM (readPackageDescription verbosity) depsCabalFiles
592
593
594
595
  let depsMap           = M.fromList (zip buildTreeRefs depsPkgDescs)
      isInstalled pkgid = not . null
        . InstalledPackageIndex.lookupSourcePackageId installedPkgIndex $ pkgid
      installedDepsMap  = M.filter (isInstalled . packageId) depsMap
596
597

  -- Get the package ids of modified (and installed) add-source deps.
598
  modifiedAddSourceDeps <- listModifiedDeps verbosity sandboxDir
599
600
601
602
603
604
                           (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
605

606
607
608
609
610
  assert (all (`S.member` allAddSourceDepsSet) modifiedAddSourceDeps) (return ())
  unless (null modifiedDeps) $
    notice verbosity $ "Some add-source dependencies have been modified. "
                       ++ "They will be reinstalled..."

611
612
  -- Get the package ids of the remaining add-source deps (some are possibly not
  -- installed).
613
  let otherDeps = M.assocs (depsMap `M.difference` modifiedDepsMap)
614

615
616
617
  -- Finally, assemble a 'SandboxPackageInfo'.
  cont $ SandboxPackageInfo (map toSourcePackage modifiedDeps)
    (map toSourcePackage otherDeps) installedPkgIndex allAddSourceDepsSet
618

619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
  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))
638

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

      -- Actually reinstall the modified add-source deps.
      let config         = pkgEnvSavedConfig pkgEnv
658
659
660
          configFlags    = savedConfigureFlags config
                           `mappendSomeSavedFlags`
                           configFlags'
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
          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
678

679
680
  where

681
682
683
684
685
    -- 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'.
686
    mappendSomeSavedFlags :: ConfigFlags -> ConfigFlags -> ConfigFlags
687
688
689
690
691
692
693
694
695
696
697
    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
698
                             `mappend` configProgramArgs savedFlags
699
700
701
702
        -- 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?
703
        }
704

refold's avatar
refold committed
705
706
707
708
709
710
711
--
-- Utils (transitionary)
--
-- FIXME: configPackageDB' and configCompilerAux' don't really belong in this
-- module
--

712
713
configPackageDB' :: ConfigFlags -> PackageDBStack
configPackageDB' cfg =
refold's avatar
refold committed
714
715
    interpretPackageDbFlags userInstall (configPackageDBs cfg)
  where
716
    userInstall = fromFlagOrDefault True (configUserInstall cfg)
refold's avatar
refold committed
717
718
719
720
721
722
723

configCompilerAux' :: ConfigFlags
                   -> IO (Compiler, Platform, ProgramConfiguration)
configCompilerAux' configFlags =
  configCompilerAux configFlags
    --FIXME: make configCompilerAux use a sensible verbosity
    { configVerbosity = fmap lessVerbose (configVerbosity configFlags) }