cabal-install/src/Distribution/Client/ProjectBuilding.hs

   1 {-# LANGUAGE BangPatterns #-}
   2 {-# LANGUAGE CPP #-}
   3 {-# LANGUAGE ConstraintKinds #-}
   4 {-# LANGUAGE DataKinds #-}
   5 {-# LANGUAGE NamedFieldPuns #-}
   6 {-# LANGUAGE RecordWildCards #-}
   7 {-# LANGUAGE ScopedTypeVariables #-}
   8 {-# LANGUAGE TypeFamilies #-}
   9 {-# LANGUAGE NoMonoLocalBinds #-}
  10
  11 module Distribution.Client.ProjectBuilding
  12   ( -- * Dry run phase
  13
  14     -- | What bits of the plan will we execute? The dry run does not change
  15     -- anything but tells us what will need to be built.
  16     rebuildTargetsDryRun
  17   , improveInstallPlanWithUpToDatePackages
  18
  19     -- ** Build status
  20
  21     -- | This is the detailed status information we get from the dry run.
  22   , BuildStatusMap
  23   , BuildStatus (..)
  24   , BuildStatusRebuild (..)
  25   , BuildReason (..)
  26   , MonitorChangedReason (..)
  27   , buildStatusToString
  28
  29     -- * Build phase
  30
  31     -- | Now we actually execute the plan.
  32   , rebuildTargets
  33
  34     -- ** Build outcomes
  35
  36     -- | This is the outcome for each package of executing the plan.
  37     -- For each package, did the build succeed or fail?
  38   , BuildOutcomes
  39   , BuildOutcome
  40   , BuildResult (..)
  41   , BuildFailure (..)
  42   , BuildFailureReason (..)
  43   ) where
  44
  45 import Distribution.Client.Compat.Prelude
  46 import Prelude ()
  47
  48 import Distribution.Client.ProjectBuilding.Types
  49 import Distribution.Client.ProjectConfig
  50 import Distribution.Client.ProjectConfig.Types
  51 import Distribution.Client.ProjectPlanning
  52 import Distribution.Client.ProjectPlanning.Types
  53 import Distribution.Client.Store
  54
  55 import Distribution.Client.DistDirLayout
  56 import Distribution.Client.FetchUtils
  57 import Distribution.Client.GlobalFlags (RepoContext)
  58 import Distribution.Client.InstallPlan
  59   ( GenericInstallPlan
  60   , GenericPlanPackage
  61   , IsUnit
  62   )
  63 import qualified Distribution.Client.InstallPlan as InstallPlan
  64 import Distribution.Client.JobControl
  65 import qualified Distribution.Client.Tar as Tar
  66 import Distribution.Client.Types hiding
  67   ( BuildFailure (..)
  68   , BuildOutcome
  69   , BuildOutcomes
  70   , BuildResult (..)
  71   )
  72
  73 import Distribution.Package
  74 import Distribution.Simple.Compiler
  75 import Distribution.Simple.Program
  76 import qualified Distribution.Simple.Register as Cabal
  77
  78 import Distribution.Compat.Graph (IsNode (..))
  79 import Distribution.Simple.Utils
  80 import Distribution.Utils.Path hiding
  81   ( (<.>)
  82   , (</>)
  83   )
  84 import Distribution.Version
  85
  86 import qualified Data.Map as Map
  87 import qualified Data.Set as Set
  88
  89 import qualified Text.PrettyPrint as Disp
  90
  91 import Control.Exception (assert, handle)
  92 import System.Directory (doesDirectoryExist, doesFileExist, renameDirectory)
  93 import System.FilePath (makeRelative, normalise, takeDirectory, (<.>), (</>))
  94 import System.Semaphore (SemaphoreName (..))
  95
  96 import Distribution.Client.Errors
  97 import Distribution.Simple.Flag (fromFlagOrDefault)
  98
  99 import Distribution.Client.ProjectBuilding.PackageFileMonitor
 100 import Distribution.Client.ProjectBuilding.UnpackedPackage (annotateFailureNoLog, buildAndInstallUnpackedPackage, buildInplaceUnpackedPackage)
 101
 102 ------------------------------------------------------------------------------
 103
 104 -- * Overall building strategy.
 105
 106 ------------------------------------------------------------------------------
 107 --
 108 -- We start with an 'ElaboratedInstallPlan' that has already been improved by
 109 -- reusing packages from the store, and pruned to include only the targets of
 110 -- interest and their dependencies. So the remaining packages in the
 111 -- 'InstallPlan.Configured' state are ones we either need to build or rebuild.
 112 --
 113 -- First, we do a preliminary dry run phase where we work out which packages
 114 -- we really need to (re)build, and for the ones we do need to build which
 115 -- build phase to start at.
 116 --
 117 -- We use this to improve the 'ElaboratedInstallPlan' again by changing
 118 -- up-to-date 'InstallPlan.Configured' packages to 'InstallPlan.Installed'
 119 -- so that the build phase will skip them.
 120 --
 121 -- Then we execute the plan, that is actually build packages. The outcomes of
 122 -- trying to build all the packages are collected and returned.
 123 --
 124 -- We split things like this (dry run and execute) for a couple reasons.
 125 -- Firstly we need to be able to do dry runs anyway, and these need to be
 126 -- reasonably accurate in terms of letting users know what (and why) things
 127 -- are going to be (re)built.
 128 --
 129 -- Given that we need to be able to do dry runs, it would not be great if
 130 -- we had to repeat all the same work when we do it for real. Not only is
 131 -- it duplicate work, but it's duplicate code which is likely to get out of
 132 -- sync. So we do things only once. We preserve info we discover in the dry
 133 -- run phase and rely on it later when we build things for real. This also
 134 -- somewhat simplifies the build phase. So this way the dry run can't so
 135 -- easily drift out of sync with the real thing since we're relying on the
 136 -- info it produces.
 137 --
 138 -- An additional advantage is that it makes it easier to debug rebuild
 139 -- errors (ie rebuilding too much or too little), since all the rebuild
 140 -- decisions are made without making any state changes at the same time
 141 -- (that would make it harder to reproduce the problem situation).
 142 --
 143 -- Finally, we can use the dry run build status and the build outcomes to
 144 -- give us some information on the overall status of packages in the project.
 145 -- This includes limited information about the status of things that were
 146 -- not actually in the subset of the plan that was used for the dry run or
 147 -- execution phases. In particular we may know that some packages are now
 148 -- definitely out of date. See "Distribution.Client.ProjectPlanOutput" for
 149 -- details.
 150
 151 ------------------------------------------------------------------------------
 152
 153 -- * Dry run: what bits of the 'ElaboratedInstallPlan' will we execute?
 154
 155 ------------------------------------------------------------------------------
 156
 157 -- Refer to ProjectBuilding.Types for details of these important types:
 158
 159 -- type BuildStatusMap     = ...
 160 -- data BuildStatus        = ...
 161 -- data BuildStatusRebuild = ...
 162 -- data BuildReason        = ...
 163
 164 -- | Do the dry run pass. This is a prerequisite of 'rebuildTargets'.
 165 --
 166 -- It gives us the 'BuildStatusMap'. This should be used with
 167 -- 'improveInstallPlanWithUpToDatePackages' to give an improved version of
 168 -- the 'ElaboratedInstallPlan' with packages switched to the
 169 -- 'InstallPlan.Installed' state when we find that they're already up to date.
 170 rebuildTargetsDryRun
 171   :: DistDirLayout
 172   -> ElaboratedSharedConfig
 173   -> ElaboratedInstallPlan
 174   -> IO BuildStatusMap
 175 rebuildTargetsDryRun distDirLayout@DistDirLayout{..} shared =
 176   -- Do the various checks to work out the 'BuildStatus' of each package
 177   foldMInstallPlanDepOrder dryRunPkg
 178   where
 179     dryRunPkg
 180       :: ElaboratedPlanPackage
 181       -> [BuildStatus]
 182       -> IO BuildStatus
 183     dryRunPkg (InstallPlan.PreExisting _pkg) _depsBuildStatus =
 184       return BuildStatusPreExisting
 185     dryRunPkg (InstallPlan.Installed _pkg) _depsBuildStatus =
 186       return BuildStatusInstalled
 187     dryRunPkg (InstallPlan.Configured pkg) depsBuildStatus = do
 188       mloc <- checkFetched (elabPkgSourceLocation pkg)
 189       case mloc of
 190         Nothing -> return BuildStatusDownload
 191         Just (LocalUnpackedPackage srcdir) ->
 192           -- For the case of a user-managed local dir, irrespective of the
 193           -- build style, we build from that directory and put build
 194           -- artifacts under the shared dist directory.
 195           dryRunLocalPkg pkg depsBuildStatus srcdir
 196         -- The rest cases are all tarball cases are,
 197         -- and handled the same as each other though depending on the build style.
 198         Just (LocalTarballPackage tarball) ->
 199           dryRunTarballPkg pkg depsBuildStatus tarball
 200         Just (RemoteTarballPackage _ tarball) ->
 201           dryRunTarballPkg pkg depsBuildStatus tarball
 202         Just (RepoTarballPackage _ _ tarball) ->
 203           dryRunTarballPkg pkg depsBuildStatus tarball
 204         Just (RemoteSourceRepoPackage _repo tarball) ->
 205           dryRunTarballPkg pkg depsBuildStatus tarball
 206
 207     dryRunTarballPkg
 208       :: ElaboratedConfiguredPackage
 209       -> [BuildStatus]
 210       -> FilePath
 211       -> IO BuildStatus
 212     dryRunTarballPkg pkg depsBuildStatus tarball =
 213       case elabBuildStyle pkg of
 214         BuildAndInstall -> return (BuildStatusUnpack tarball)
 215         BuildInplaceOnly{} -> do
 216           -- TODO: [nice to have] use a proper file monitor rather
 217           -- than this dir exists test
 218           exists <- doesDirectoryExist srcdir
 219           if exists
 220             then dryRunLocalPkg pkg depsBuildStatus srcdir
 221             else return (BuildStatusUnpack tarball)
 222       where
 223         srcdir :: FilePath
 224         srcdir = distUnpackedSrcDirectory (packageId pkg)
 225
 226     dryRunLocalPkg
 227       :: ElaboratedConfiguredPackage
 228       -> [BuildStatus]
 229       -> FilePath
 230       -> IO BuildStatus
 231     dryRunLocalPkg pkg depsBuildStatus srcdir = do
 232       -- Go and do lots of I/O, reading caches and probing files to work out
 233       -- if anything has changed
 234       change <-
 235         checkPackageFileMonitorChanged
 236           packageFileMonitor
 237           pkg
 238           srcdir
 239           depsBuildStatus
 240       case change of
 241         -- It did change, giving us 'BuildStatusRebuild' info on why
 242         Left rebuild ->
 243           return (BuildStatusRebuild srcdir rebuild)
 244         -- No changes, the package is up to date. Use the saved build results.
 245         Right buildResult ->
 246           return (BuildStatusUpToDate buildResult)
 247       where
 248         packageFileMonitor :: PackageFileMonitor
 249         packageFileMonitor =
 250           newPackageFileMonitor
 251             shared
 252             distDirLayout
 253             (elabDistDirParams shared pkg)
 254
 255 -- | A specialised traversal over the packages in an install plan.
 256 --
 257 -- The packages are visited in dependency order, starting with packages with no
 258 -- dependencies. The result for each package is accumulated into a 'Map' and
 259 -- returned as the final result. In addition, when visiting a package, the
 260 -- visiting function is passed the results for all the immediate package
 261 -- dependencies. This can be used to propagate information from dependencies.
 262 foldMInstallPlanDepOrder
 263   :: forall m ipkg srcpkg b
 264    . (Monad m, IsUnit ipkg, IsUnit srcpkg)
 265   => ( GenericPlanPackage ipkg srcpkg
 266        -> [b]
 267        -> m b
 268      )
 269   -> GenericInstallPlan ipkg srcpkg
 270   -> m (Map UnitId b)
 271 foldMInstallPlanDepOrder visit =
 272   go Map.empty . InstallPlan.reverseTopologicalOrder
 273   where
 274     go
 275       :: Map UnitId b
 276       -> [GenericPlanPackage ipkg srcpkg]
 277       -> m (Map UnitId b)
 278     go !results [] = return results
 279     go !results (pkg : pkgs) = do
 280       -- we go in the right order so the results map has entries for all deps
 281       let depresults :: [b]
 282           depresults =
 283             map
 284               ( \ipkgid ->
 285                   let result = Map.findWithDefault (error "foldMInstallPlanDepOrder") ipkgid results
 286                    in result
 287               )
 288               (InstallPlan.depends pkg)
 289       result <- visit pkg depresults
 290       let results' = Map.insert (nodeKey pkg) result results
 291       go results' pkgs
 292
 293 improveInstallPlanWithUpToDatePackages
 294   :: BuildStatusMap
 295   -> ElaboratedInstallPlan
 296   -> ElaboratedInstallPlan
 297 improveInstallPlanWithUpToDatePackages pkgsBuildStatus =
 298   InstallPlan.installed canPackageBeImproved
 299   where
 300     canPackageBeImproved :: ElaboratedConfiguredPackage -> Bool
 301     canPackageBeImproved pkg =
 302       case Map.lookup (installedUnitId pkg) pkgsBuildStatus of
 303         Just BuildStatusUpToDate{} -> True
 304         Just _ -> False
 305         Nothing ->
 306           error $
 307             "improveInstallPlanWithUpToDatePackages: "
 308               ++ prettyShow (packageId pkg)
 309               ++ " not in status map"
 310
 311 ------------------------------------------------------------------------------
 312
 313 -- * Doing it: executing an 'ElaboratedInstallPlan'
 314
 315 ------------------------------------------------------------------------------
 316
 317 -- Refer to ProjectBuilding.Types for details of these important types:
 318
 319 -- type BuildOutcomes = ...
 320 -- type BuildOutcome  = ...
 321 -- data BuildResult   = ...
 322 -- data BuildFailure  = ...
 323 -- data BuildFailureReason = ...
 324
 325 -- | Build things for real.
 326 --
 327 -- It requires the 'BuildStatusMap' gathered by 'rebuildTargetsDryRun'.
 328 rebuildTargets
 329   :: Verbosity
 330   -> ProjectConfig
 331   -> DistDirLayout
 332   -> StoreDirLayout
 333   -> ElaboratedInstallPlan
 334   -> ElaboratedSharedConfig
 335   -> BuildStatusMap
 336   -> BuildTimeSettings
 337   -> IO BuildOutcomes
 338 rebuildTargets
 339   verbosity
 340   ProjectConfig
 341     { projectConfigBuildOnly = config
 342     }
 343   distDirLayout@DistDirLayout{..}
 344   storeDirLayout
 345   installPlan
 346   sharedPackageConfig@ElaboratedSharedConfig
 347     { pkgConfigCompiler = compiler
 348     , pkgConfigCompilerProgs = progdb
 349     }
 350   pkgsBuildStatus
 351   buildSettings@BuildTimeSettings
 352     { buildSettingNumJobs
 353     , buildSettingKeepGoing
 354     }
 355     | fromFlagOrDefault False (projectConfigOfflineMode config) && not (null packagesToDownload) = return offlineError
 356     | otherwise = do
 357         registerLock <- newLock -- serialise registration
 358         cacheLock <- newLock -- serialise access to setup exe cache
 359         -- TODO: [code cleanup] eliminate setup exe cache
 360         info verbosity $
 361           "Executing install plan "
 362             ++ case buildSettingNumJobs of
 363               NumJobs n -> "in parallel using " ++ show n ++ " threads."
 364               UseSem n -> "in parallel using a semaphore with " ++ show n ++ " slots."
 365               Serial -> "serially."
 366
 367         createDirectoryIfMissingVerbose verbosity True distBuildRootDirectory
 368         createDirectoryIfMissingVerbose verbosity True distTempDirectory
 369         traverse_ (createPackageDBIfMissing verbosity compiler progdb) packageDBsToUse
 370
 371         -- Concurrency control: create the job controller and concurrency limits
 372         -- for downloading, building and installing.
 373         withJobControl (newJobControlFromParStrat verbosity compiler buildSettingNumJobs Nothing) $ \jobControl -> do
 374           -- Before traversing the install plan, preemptively find all packages that
 375           -- will need to be downloaded and start downloading them.
 376           asyncDownloadPackages
 377             verbosity
 378             withRepoCtx
 379             installPlan
 380             pkgsBuildStatus
 381             $ \downloadMap ->
 382               -- For each package in the plan, in dependency order, but in parallel...
 383               InstallPlan.execute
 384                 jobControl
 385                 keepGoing
 386                 (BuildFailure Nothing . DependentFailed . packageId)
 387                 installPlan
 388                 $ \pkg ->
 389                   -- TODO: review exception handling
 390                   handle (\(e :: BuildFailure) -> return (Left e)) $ fmap Right $ do
 391                     let uid = installedUnitId pkg
 392                         pkgBuildStatus = Map.findWithDefault (error "rebuildTargets") uid pkgsBuildStatus
 393
 394                     rebuildTarget
 395                       verbosity
 396                       distDirLayout
 397                       storeDirLayout
 398                       (jobControlSemaphore jobControl)
 399                       buildSettings
 400                       downloadMap
 401                       registerLock
 402                       cacheLock
 403                       sharedPackageConfig
 404                       installPlan
 405                       pkg
 406                       pkgBuildStatus
 407     where
 408       keepGoing = buildSettingKeepGoing
 409       withRepoCtx =
 410         projectConfigWithBuilderRepoContext
 411           verbosity
 412           buildSettings
 413       packageDBsToUse =
 414         -- all the package dbs we may need to create
 415         (Set.toList . Set.fromList)
 416           [ pkgdb
 417           | InstallPlan.Configured elab <- InstallPlan.toList installPlan
 418           , pkgdb <-
 419               concat
 420                 [ elabBuildPackageDBStack elab
 421                 , elabRegisterPackageDBStack elab
 422                 , elabSetupPackageDBStack elab
 423                 ]
 424           ]
 425
 426       offlineError :: BuildOutcomes
 427       offlineError = Map.fromList . map makeBuildOutcome $ packagesToDownload
 428         where
 429           makeBuildOutcome :: ElaboratedConfiguredPackage -> (UnitId, BuildOutcome)
 430           makeBuildOutcome
 431             ElaboratedConfiguredPackage
 432               { elabUnitId
 433               , elabPkgSourceId = PackageIdentifier{pkgName, pkgVersion}
 434               } =
 435               ( elabUnitId
 436               , Left
 437                   ( BuildFailure
 438                       { buildFailureLogFile = Nothing
 439                       , buildFailureReason = GracefulFailure $ makeError pkgName pkgVersion
 440                       }
 441                   )
 442               )
 443           makeError :: PackageName -> Version -> String
 444           makeError n v =
 445             "--offline was specified, hence refusing to download the package: "
 446               ++ unPackageName n
 447               ++ " version "
 448               ++ Disp.render (pretty v)
 449
 450       packagesToDownload :: [ElaboratedConfiguredPackage]
 451       packagesToDownload =
 452         [ elab | InstallPlan.Configured elab <- InstallPlan.reverseTopologicalOrder installPlan, isRemote $ elabPkgSourceLocation elab
 453         ]
 454         where
 455           isRemote :: PackageLocation a -> Bool
 456           isRemote (RemoteTarballPackage _ _) = True
 457           isRemote (RepoTarballPackage{}) = True
 458           isRemote (RemoteSourceRepoPackage _ _) = True
 459           isRemote _ = False
 460
 461 -- | Create a package DB if it does not currently exist. Note that this action
 462 -- is /not/ safe to run concurrently.
 463 createPackageDBIfMissing
 464   :: Verbosity
 465   -> Compiler
 466   -> ProgramDb
 467   -> PackageDBCWD
 468   -> IO ()
 469 createPackageDBIfMissing
 470   verbosity
 471   compiler
 472   progdb
 473   (SpecificPackageDB dbPath) = do
 474     exists <- Cabal.doesPackageDBExist dbPath
 475     unless exists $ do
 476       createDirectoryIfMissingVerbose verbosity True (takeDirectory dbPath)
 477       Cabal.createPackageDB verbosity compiler progdb False dbPath
 478 createPackageDBIfMissing _ _ _ _ = return ()
 479
 480 -- | Given all the context and resources, (re)build an individual package.
 481 rebuildTarget
 482   :: Verbosity
 483   -> DistDirLayout
 484   -> StoreDirLayout
 485   -> Maybe SemaphoreName
 486   -> BuildTimeSettings
 487   -> AsyncFetchMap
 488   -> Lock
 489   -> Lock
 490   -> ElaboratedSharedConfig
 491   -> ElaboratedInstallPlan
 492   -> ElaboratedReadyPackage
 493   -> BuildStatus
 494   -> IO BuildResult
 495 rebuildTarget
 496   verbosity
 497   distDirLayout@DistDirLayout{distBuildDirectory}
 498   storeDirLayout
 499   semaphoreName
 500   buildSettings
 501   downloadMap
 502   registerLock
 503   cacheLock
 504   sharedPackageConfig
 505   plan
 506   rpkg@(ReadyPackage pkg)
 507   pkgBuildStatus
 508     -- Technically, doing the --only-download filtering only in this function is
 509     -- not perfect. We could also prune the plan at an earlier stage, like it's
 510     -- done with --only-dependencies. But...
 511     --   * the benefit would be minimal (practically just avoiding to print the
 512     --     "requires build" parts of the plan)
 513     --   * we currently don't have easy access to the BuildStatus of packages
 514     --     in the pruning phase
 515     --   * we still have to check it here to avoid performing successive phases
 516     | buildSettingOnlyDownload buildSettings = do
 517         case pkgBuildStatus of
 518           BuildStatusDownload ->
 519             void $ waitAsyncPackageDownload verbosity downloadMap pkg
 520           _ -> return ()
 521         return $ BuildResult DocsNotTried TestsNotTried Nothing
 522     | otherwise =
 523         -- We rely on the 'BuildStatus' to decide which phase to start from:
 524         case pkgBuildStatus of
 525           BuildStatusDownload -> downloadPhase
 526           BuildStatusUnpack tarball -> unpackTarballPhase tarball
 527           BuildStatusRebuild srcdir status -> rebuildPhase status (makeSymbolicPath srcdir)
 528           -- TODO: perhaps re-nest the types to make these impossible
 529           BuildStatusPreExisting{} -> unexpectedState
 530           BuildStatusInstalled{} -> unexpectedState
 531           BuildStatusUpToDate{} -> unexpectedState
 532     where
 533       unexpectedState = error "rebuildTarget: unexpected package status"
 534
 535       downloadPhase :: IO BuildResult
 536       downloadPhase = do
 537         downsrcloc <-
 538           annotateFailureNoLog DownloadFailed $
 539             waitAsyncPackageDownload verbosity downloadMap pkg
 540         case downsrcloc of
 541           DownloadedTarball tarball -> unpackTarballPhase tarball
 542       -- TODO: [nice to have] git/darcs repos etc
 543
 544       unpackTarballPhase :: FilePath -> IO BuildResult
 545       unpackTarballPhase tarball =
 546         withTarballLocalDirectory
 547           verbosity
 548           distDirLayout
 549           tarball
 550           (packageId pkg)
 551           (elabDistDirParams sharedPackageConfig pkg)
 552           (elabBuildStyle pkg)
 553           (elabPkgDescriptionOverride pkg)
 554           $ case elabBuildStyle pkg of
 555             BuildAndInstall -> buildAndInstall
 556             BuildInplaceOnly{} -> buildInplace buildStatus
 557               where
 558                 buildStatus = BuildStatusConfigure MonitorFirstRun
 559
 560       -- Note that this really is rebuild, not build. It can only happen for
 561       -- 'BuildInplaceOnly' style packages. 'BuildAndInstall' style packages
 562       -- would only start from download or unpack phases.
 563       --
 564       rebuildPhase :: BuildStatusRebuild -> SymbolicPath CWD (Dir Pkg) -> IO BuildResult
 565       rebuildPhase buildStatus srcdir =
 566         assert
 567           (isInplaceBuildStyle $ elabBuildStyle pkg)
 568           buildInplace
 569           buildStatus
 570           srcdir
 571           builddir
 572         where
 573           distdir = distBuildDirectory (elabDistDirParams sharedPackageConfig pkg)
 574           builddir =
 575             makeSymbolicPath $
 576               makeRelative (normalise $ getSymbolicPath srcdir) distdir
 577       -- TODO: [nice to have] ^^ do this relative stuff better
 578
 579       buildAndInstall :: SymbolicPath CWD (Dir Pkg) -> SymbolicPath Pkg (Dir Dist) -> IO BuildResult
 580       buildAndInstall srcdir builddir =
 581         buildAndInstallUnpackedPackage
 582           verbosity
 583           distDirLayout
 584           storeDirLayout
 585           semaphoreName
 586           buildSettings
 587           registerLock
 588           cacheLock
 589           sharedPackageConfig
 590           plan
 591           rpkg
 592           srcdir
 593           builddir
 594
 595       buildInplace :: BuildStatusRebuild -> SymbolicPath CWD (Dir Pkg) -> SymbolicPath Pkg (Dir Dist) -> IO BuildResult
 596       buildInplace buildStatus srcdir builddir =
 597         -- TODO: [nice to have] use a relative build dir rather than absolute
 598         buildInplaceUnpackedPackage
 599           verbosity
 600           distDirLayout
 601           semaphoreName
 602           buildSettings
 603           registerLock
 604           cacheLock
 605           sharedPackageConfig
 606           plan
 607           rpkg
 608           buildStatus
 609           srcdir
 610           builddir
 611
 612 -- TODO: [nice to have] do we need to use a with-style for the temp
 613 -- files for downloading http packages, or are we going to cache them
 614 -- persistently?
 615
 616 -- | Given the current 'InstallPlan' and 'BuildStatusMap', select all the
 617 -- packages we have to download and fork off an async action to download them.
 618 -- We download them in dependency order so that the one's we'll need
 619 -- first are the ones we will start downloading first.
 620 --
 621 -- The body action is passed a map from those packages (identified by their
 622 -- location) to a completion var for that package. So the body action should
 623 -- lookup the location and use 'waitAsyncPackageDownload' to get the result.
 624 asyncDownloadPackages
 625   :: Verbosity
 626   -> ((RepoContext -> IO a) -> IO a)
 627   -> ElaboratedInstallPlan
 628   -> BuildStatusMap
 629   -> (AsyncFetchMap -> IO a)
 630   -> IO a
 631 asyncDownloadPackages verbosity withRepoCtx installPlan pkgsBuildStatus body
 632   | null pkgsToDownload = body Map.empty
 633   | otherwise = withRepoCtx $ \repoctx ->
 634       asyncFetchPackages
 635         verbosity
 636         repoctx
 637         pkgsToDownload
 638         body
 639   where
 640     pkgsToDownload :: [PackageLocation (Maybe FilePath)]
 641     pkgsToDownload =
 642       ordNub $
 643         [ elabPkgSourceLocation elab
 644         | InstallPlan.Configured elab <-
 645             InstallPlan.reverseTopologicalOrder installPlan
 646         , let uid = installedUnitId elab
 647               pkgBuildStatus = Map.findWithDefault (error "asyncDownloadPackages") uid pkgsBuildStatus
 648         , BuildStatusDownload <- [pkgBuildStatus]
 649         ]
 650
 651 -- | Check if a package needs downloading, and if so expect to find a download
 652 -- in progress in the given 'AsyncFetchMap' and wait on it to finish.
 653 waitAsyncPackageDownload
 654   :: Verbosity
 655   -> AsyncFetchMap
 656   -> ElaboratedConfiguredPackage
 657   -> IO DownloadedSourceLocation
 658 waitAsyncPackageDownload verbosity downloadMap elab = do
 659   pkgloc <-
 660     waitAsyncFetchPackage
 661       verbosity
 662       downloadMap
 663       (elabPkgSourceLocation elab)
 664   case downloadedSourceLocation pkgloc of
 665     Just loc -> return loc
 666     Nothing -> fail "waitAsyncPackageDownload: unexpected source location"
 667
 668 data DownloadedSourceLocation = DownloadedTarball FilePath
 669
 670 -- TODO: [nice to have] git/darcs repos etc
 671
 672 downloadedSourceLocation
 673   :: PackageLocation FilePath
 674   -> Maybe DownloadedSourceLocation
 675 downloadedSourceLocation pkgloc =
 676   case pkgloc of
 677     RemoteTarballPackage _ tarball -> Just (DownloadedTarball tarball)
 678     RepoTarballPackage _ _ tarball -> Just (DownloadedTarball tarball)
 679     _ -> Nothing
 680
 681 -- | Ensure that the package is unpacked in an appropriate directory, either
 682 -- a temporary one or a persistent one under the shared dist directory.
 683 withTarballLocalDirectory
 684   :: Verbosity
 685   -> DistDirLayout
 686   -> FilePath
 687   -> PackageId
 688   -> DistDirParams
 689   -> BuildStyle
 690   -> Maybe CabalFileText
 691   -> ( SymbolicPath CWD (Dir Pkg) -- Source directory
 692        -> SymbolicPath Pkg (Dir Dist) -- Build directory
 693        -> IO a
 694      )
 695   -> IO a
 696 withTarballLocalDirectory
 697   verbosity
 698   distDirLayout@DistDirLayout{..}
 699   tarball
 700   pkgid
 701   dparams
 702   buildstyle
 703   pkgTextOverride
 704   buildPkg =
 705     case buildstyle of
 706       -- In this case we make a temp dir (e.g. tmp/src2345/), unpack
 707       -- the tarball to it (e.g. tmp/src2345/foo-1.0/), and for
 708       -- compatibility we put the dist dir within it
 709       -- (i.e. tmp/src2345/foo-1.0/dist/).
 710       --
 711       -- Unfortunately, a few custom Setup.hs scripts do not respect
 712       -- the --builddir flag and always look for it at ./dist/ so
 713       -- this way we avoid breaking those packages
 714       BuildAndInstall ->
 715         let tmpdir = distTempDirectory
 716             builddir = relativeSymbolicPath $ makeRelativePathEx "dist"
 717          in withTempDirectory verbosity tmpdir "src" $ \unpackdir -> do
 718               let srcdir = makeSymbolicPath $ unpackdir </> prettyShow pkgid
 719               unpackPackageTarball
 720                 verbosity
 721                 tarball
 722                 unpackdir
 723                 pkgid
 724                 pkgTextOverride
 725               buildPkg srcdir builddir
 726
 727       -- In this case we make sure the tarball has been unpacked to the
 728       -- appropriate location under the shared dist dir, and then build it
 729       -- inplace there
 730       BuildInplaceOnly{} -> do
 731         let srcrootdir = distUnpackedSrcRootDirectory
 732             srcdir = distUnpackedSrcDirectory pkgid
 733             builddir =
 734               makeSymbolicPath $
 735                 makeRelative (normalise srcdir) $
 736                   distBuildDirectory dparams
 737         -- TODO: [nice to have] ^^ do this relative stuff better
 738         exists <- doesDirectoryExist srcdir
 739         -- TODO: [nice to have] use a proper file monitor rather
 740         -- than this dir exists test
 741         unless exists $ do
 742           createDirectoryIfMissingVerbose verbosity True srcrootdir
 743           unpackPackageTarball
 744             verbosity
 745             tarball
 746             srcrootdir
 747             pkgid
 748             pkgTextOverride
 749           moveTarballShippedDistDirectory
 750             verbosity
 751             distDirLayout
 752             srcrootdir
 753             pkgid
 754             dparams
 755         buildPkg (makeSymbolicPath srcdir) builddir
 756
 757 unpackPackageTarball
 758   :: Verbosity
 759   -> FilePath
 760   -> FilePath
 761   -> PackageId
 762   -> Maybe CabalFileText
 763   -> IO ()
 764 unpackPackageTarball verbosity tarball parentdir pkgid pkgTextOverride =
 765   -- TODO: [nice to have] switch to tar package and catch tar exceptions
 766   annotateFailureNoLog UnpackFailed $ do
 767     -- Unpack the tarball
 768     --
 769     info verbosity $ "Extracting " ++ tarball ++ " to " ++ parentdir ++ "..."
 770     Tar.extractTarGzFile parentdir pkgsubdir tarball
 771
 772     -- Sanity check
 773     --
 774     exists <- doesFileExist cabalFile
 775     unless exists $
 776       dieWithException verbosity $
 777         CabalFileNotFound cabalFile
 778
 779     -- Overwrite the .cabal with the one from the index, when appropriate
 780     --
 781     case pkgTextOverride of
 782       Nothing -> return ()
 783       Just pkgtxt -> do
 784         info verbosity $
 785           "Updating "
 786             ++ prettyShow pkgname <.> "cabal"
 787             ++ " with the latest revision from the index."
 788         writeFileAtomic cabalFile pkgtxt
 789   where
 790     cabalFile :: FilePath
 791     cabalFile =
 792       parentdir
 793         </> pkgsubdir
 794         </> prettyShow pkgname
 795         <.> "cabal"
 796     pkgsubdir = prettyShow pkgid
 797     pkgname = packageName pkgid
 798
 799 -- | This is a bit of a hacky workaround. A number of packages ship
 800 -- pre-processed .hs files in a dist directory inside the tarball. We don't
 801 -- use the standard 'dist' location so unless we move this dist dir to the
 802 -- right place then we'll miss the shipped pre-processed files. This hacky
 803 -- approach to shipped pre-processed files ought to be replaced by a proper
 804 -- system, though we'll still need to keep this hack for older packages.
 805 moveTarballShippedDistDirectory
 806   :: Verbosity
 807   -> DistDirLayout
 808   -> FilePath
 809   -> PackageId
 810   -> DistDirParams
 811   -> IO ()
 812 moveTarballShippedDistDirectory
 813   verbosity
 814   DistDirLayout{distBuildDirectory}
 815   parentdir
 816   pkgid
 817   dparams = do
 818     distDirExists <- doesDirectoryExist tarballDistDir
 819     when distDirExists $ do
 820       debug verbosity $
 821         "Moving '"
 822           ++ tarballDistDir
 823           ++ "' to '"
 824           ++ targetDistDir
 825           ++ "'"
 826       -- TODO: [nice to have] or perhaps better to copy, and use a file monitor
 827       renameDirectory tarballDistDir targetDistDir
 828     where
 829       tarballDistDir = parentdir </> prettyShow pkgid </> "dist"
 830       targetDistDir = distBuildDirectory dparams