Sandbox.hs 34.8 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,
36
    updateSandboxConfigFileFlag,
refold's avatar
refold committed
37

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

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


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

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

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

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

158
159
160
161
162
163
164
165
166
167
168
-- | If @--sandbox-config-file@ wasn't given on the command-line, set it to the
-- value of the @CABAL_SANDBOX_CONFIG@ environment variable, or else to
-- 'NoFlag'.
updateSandboxConfigFileFlag :: GlobalFlags -> IO GlobalFlags
updateSandboxConfigFileFlag globalFlags =
  case globalSandboxConfigFile globalFlags of
    Flag _ -> return globalFlags
    NoFlag -> do
      f' <- fmap (fromMaybe NoFlag . fmap Flag) . lookupEnv
            $ "CABAL_SANDBOX_CONFIG"
      return globalFlags { globalSandboxConfigFile = f' }
169
170
171

-- | 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
172
173
getSandboxConfigFilePath :: GlobalFlags -> IO FilePath
getSandboxConfigFilePath globalFlags = do
174
175
176
177
178
179
180
181
182
183
184
  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
185
                        -> IO (FilePath, PackageEnvironment)
186
tryLoadSandboxConfig verbosity globalFlags = do
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
187
  path <- getSandboxConfigFilePath globalFlags
188
189
  tryLoadSandboxPackageEnvironmentFile verbosity path
    (globalConfigFile globalFlags)
refold's avatar
refold committed
190

191
-- | Return the name of the package index file for this package environment.
refold's avatar
refold committed
192
tryGetIndexFilePath :: SavedConfig -> IO FilePath
193
194
195
196
197
198
199
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
200
  case paths of
201
    []  -> die $ "Distribution.Client.Sandbox.tryGetIndexFilePath: " ++
refold's avatar
refold committed
202
           "no local repos found. " ++ checkConfiguration
203
    _   -> return $ (last paths) </> Index.defaultIndexFileName
refold's avatar
refold committed
204
205
206
  where
    checkConfiguration = "Please check your configuration ('"
                         ++ userPackageEnvironmentFile ++ "')."
refold's avatar
refold committed
207

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


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

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

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

    sandboxBin = sandboxDir </> "bin"

260
261
262
263
264
-- | 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
265
  SpecificPackageDB dbPath <- getSandboxPackageDB configFlags
266
267
268
269
270
271
  packageDBExists <- doesDirectoryExist dbPath
  unless packageDBExists $
    Register.initPackageDB verbosity comp conf dbPath
  when packageDBExists $
    debug verbosity $ "The package database already exists: " ++ dbPath

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

279
-- | Entry point for the 'cabal sandbox init' command.
280
sandboxInit :: Verbosity -> SandboxFlags  -> GlobalFlags -> IO ()
281
sandboxInit verbosity sandboxFlags globalFlags = do
282
  -- Warn if there's a 'cabal-dev' sandbox.
283
284
285
  isCabalDevSandbox <- liftM2 (&&) (doesDirectoryExist "cabal-dev")
                       (doesFileExist $ "cabal-dev" </> "cabal.config")
  when isCabalDevSandbox $
286
    warn verbosity $
287
    "You are apparently using a legacy (cabal-dev) sandbox. "
288
289
    ++ "Legacy sandboxes may interact badly with native Cabal sandboxes. "
    ++ "You may want to delete the 'cabal-dev' directory to prevent issues."
290

291
292
293
294
  -- Create the sandbox directory.
  let sandboxDir' = fromFlagOrDefault defaultSandboxLocation
                    (sandboxLocation sandboxFlags)
  createDirectoryIfMissingVerbose verbosity True sandboxDir'
295
  sandboxDir <- tryCanonicalizePath sandboxDir'
296
  setFileHidden sandboxDir
297
298

  -- Determine which compiler to use (using the value from ~/.cabal/config).
299
  userConfig <- loadConfig verbosity (globalConfigFile globalFlags) NoFlag
300
  (comp, platform, conf) <- configCompilerAuxEx (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
307
308
  (_sandboxDir, pkgEnv) <- tryLoadSandboxConfig verbosity globalFlags
  let config      = pkgEnvSavedConfig pkgEnv
      configFlags = savedConfigureFlags config
309
310

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

318
319
320
321
  -- 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
322

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

333
334
335
336
337
338
      -- 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
339
        then warn verbosity $ "Sandbox config file is in non-default location: '"
340
341
                    ++ pkgEnvFile ++ "'.\n Please delete manually."
        else removeFile pkgEnvFile
342
343

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

347
      when isNonDefaultSandboxLocation $
348
        die $ "Non-default sandbox location used: '" ++ sandboxDir
349
        ++ "'.\nAssuming a shared sandbox. Please delete '"
350
351
352
353
        ++ sandboxDir ++ "' manually."

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

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

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

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

  if fromFlagOrDefault False (sandboxSnapshot sandboxFlags)
    then sandboxAddSourceSnapshot verbosity buildTreeRefs sandboxDir pkgEnv
384
    else doAddSource verbosity buildTreeRefs sandboxDir pkgEnv LinkRef
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
412
413
414
415

-- | 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
416
      prepareTree verbosity pkg Nothing targetTmpDir knownSuffixHandlers
417
418
419
420
421
422
423
424
425
426
427
428
      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.
429
  doAddSource verbosity snapshots sandboxDir pkgEnv SnapshotRef
430

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

refold's avatar
refold committed
438
  withRemoveTimestamps sandboxDir $ do
439
    Index.removeBuildTreeRefs verbosity indexFile buildTreeRefs
440

Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
441
442
443
444
  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."
445

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

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

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

  Register.invokeHcPkg verbosity comp conf dbStack extraArgs

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

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

500
    -- Only @cabal.config@ is present.
501
    UserPackageEnvironment    -> do
502
      config <- loadConfig verbosity configFileFlag userInstallFlag
503
      userConfig <- loadUserConfig verbosity pkgEnvDir
504
505
506
      let config' = config `mappend` userConfig
      dieIfSandboxRequired config'
      return (NoSandbox, config')
507

508
509
    -- Neither @cabal.sandbox.config@ nor @cabal.config@ are present.
    AmbientPackageEnvironment -> do
510
      config <- loadConfig verbosity configFileFlag userInstallFlag
511
      dieIfSandboxRequired config
refold's avatar
refold committed
512
      return (NoSandbox, config)
513

514
  where
515
516
517
518
519
520
521
522
523
    -- Return the path to the package environment directory - either the
    -- current directory or the one that @--sandbox-config-file@ resides in.
    getPkgEnvDir :: (Flag FilePath) -> IO FilePath
    getPkgEnvDir sandboxConfigFileFlag = do
      case sandboxConfigFileFlag of
        NoFlag    -> getCurrentDirectory
        Flag path -> tryCanonicalizePath . takeDirectory $ path

    -- Die if @--require-sandbox@ was specified and we're not inside a sandbox.
524
525
526
527
528
529
530
531
532
533
    dieIfSandboxRequired :: SavedConfig -> IO ()
    dieIfSandboxRequired config = checkFlag flag
      where
        flag = (globalRequireSandbox . savedGlobalFlags $ config)
               `mappend` (globalRequireSandbox globalFlags)
        checkFlag (Flag True)  =
          die $ "'require-sandbox' is set to True, but no sandbox is present."
        checkFlag (Flag False) = return ()
        checkFlag (NoFlag)     = return ()

534
535
-- | If we're in a sandbox, call @withSandboxBinDirOnSearchPath@, otherwise do
-- nothing.
refold's avatar
refold committed
536
537
538
maybeWithSandboxDirOnSearchPath :: UseSandbox -> IO a -> IO a
maybeWithSandboxDirOnSearchPath NoSandbox               act = act
maybeWithSandboxDirOnSearchPath (UseSandbox sandboxDir) act =
539
  withSandboxBinDirOnSearchPath sandboxDir $ act
540

541
-- | Had reinstallAddSourceDeps actually reinstalled any dependencies?
542
data WereDepsReinstalled = ReinstalledSomeDeps | NoDepsReinstalled
543

544
-- | Reinstall those add-source dependencies that have been modified since
545
546
547
548
549
-- we've last installed them. Assumes that we're working inside a sandbox.
reinstallAddSourceDeps :: Verbosity
                          -> ConfigFlags  -> ConfigExFlags
                          -> InstallFlags -> GlobalFlags
                          -> FilePath
550
                          -> IO WereDepsReinstalled
551
reinstallAddSourceDeps verbosity configFlags' configExFlags
552
                       installFlags globalFlags sandboxDir = topHandler' $ do
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
  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
578
        installPlan    <- foldProgress logMsg die' return =<<
579
580
581
582
                          makeInstallPlan verbosity args installContext

        processInstallPlan verbosity args installContext installPlan
        writeIORef retVal ReinstalledSomeDeps
583
584

  readIORef retVal
585

586
    where
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
587
588
589
590
591
592
593
      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."
594
595
      logMsg message rest = debugNoWrap verbosity message >> rest

596
597
598
599
600
601
      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

602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
-- | 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

618
619
620
621
  -- List all packages installed in the sandbox.
  installedPkgIndex <- getInstalledPackagesInSandbox verbosity
                       configFlags comp conf

622
  -- Get the package descriptions for all add-source deps.
623
  depsCabalFiles <- mapM tryFindPackageDesc buildTreeRefs
624
  depsPkgDescs   <- mapM (readPackageDescription verbosity) depsCabalFiles
625
626
627
628
  let depsMap           = M.fromList (zip buildTreeRefs depsPkgDescs)
      isInstalled pkgid = not . null
        . InstalledPackageIndex.lookupSourcePackageId installedPkgIndex $ pkgid
      installedDepsMap  = M.filter (isInstalled . packageId) depsMap
629
630

  -- Get the package ids of modified (and installed) add-source deps.
631
  modifiedAddSourceDeps <- listModifiedDeps verbosity sandboxDir
632
633
634
635
636
637
                           (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
638

639
  assert (all (`S.member` allAddSourceDepsSet) modifiedAddSourceDeps) (return ())
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
640
641
642
643
  if (null modifiedDeps)
    then info   verbosity $ "Found no modified add-source deps."
    else notice verbosity $ "Some add-source dependencies have been modified. "
                            ++ "They will be reinstalled..."
644

645
646
  -- Get the package ids of the remaining add-source deps (some are possibly not
  -- installed).
647
  let otherDeps = M.assocs (depsMap `M.difference` modifiedDepsMap)
648

649
650
651
  -- Finally, assemble a 'SandboxPackageInfo'.
  cont $ SandboxPackageInfo (map toSourcePackage modifiedDeps)
    (map toSourcePackage otherDeps) installedPkgIndex allAddSourceDepsSet
652

653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
  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))
672

673
674
-- | Check if a sandbox is present and call @reinstallAddSourceDeps@ in that
-- case.
675
676
677
678
679
maybeReinstallAddSourceDeps :: Verbosity
                               -> Flag (Maybe Int) -- ^ The '-j' flag
                               -> ConfigFlags      -- ^ Saved configure flags
                                                   -- (from dist/setup-config)
                               -> GlobalFlags
680
681
                               -> IO (UseSandbox, SavedConfig
                                     ,WereDepsReinstalled)
682
maybeReinstallAddSourceDeps verbosity numJobsFlag configFlags' globalFlags' = do
683
684
685
686
687
688
689
  (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags'
                          (configUserInstall configFlags')
  case useSandbox of
    NoSandbox             -> return (NoSandbox, config, NoDepsReinstalled)
    UseSandbox sandboxDir -> do
      -- Reinstall the modified add-source deps.
      let configFlags    = savedConfigureFlags config
690
691
                           `mappendSomeSavedFlags`
                           configFlags'
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
          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
708
      return (UseSandbox sandboxDir, config, depsReinstalled)
refold's avatar
refold committed
709

710
711
  where

712
713
714
715
716
    -- 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'.
717
    mappendSomeSavedFlags :: ConfigFlags -> ConfigFlags -> ConfigFlags
718
719
720
721
722
723
724
725
726
727
728
    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
729
                             `mappend` configProgramArgs savedFlags
730
731
732
733
        -- 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?
734
        }
735

refold's avatar
refold committed
736
737
738
739
740
741
742
--
-- Utils (transitionary)
--
-- FIXME: configPackageDB' and configCompilerAux' don't really belong in this
-- module
--

743
744
configPackageDB' :: ConfigFlags -> PackageDBStack
configPackageDB' cfg =
refold's avatar
refold committed
745
746
    interpretPackageDbFlags userInstall (configPackageDBs cfg)
  where
747
    userInstall = fromFlagOrDefault True (configUserInstall cfg)
refold's avatar
refold committed
748
749
750
751

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