ProjectBuilding.hs 57 KB
Newer Older
Duncan Coutts's avatar
Duncan Coutts committed
1
2
3
4
{-# LANGUAGE CPP, BangPatterns, RecordWildCards, NamedFieldPuns,
             DeriveGeneric, DeriveDataTypeable, GeneralizedNewtypeDeriving,
             ScopedTypeVariables #-}

Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
5
-- |
Duncan Coutts's avatar
Duncan Coutts committed
6
7
--
module Distribution.Client.ProjectBuilding (
8
    -- * Dry run phase
Duncan Coutts's avatar
Duncan Coutts committed
9
10
11
12
13
14
    BuildStatus(..),
    BuildStatusMap,
    BuildStatusRebuild(..),
    BuildReason(..),
    MonitorChangedReason(..),
    rebuildTargetsDryRun,
15
16

    -- * Build phase
17
18
19
    BuildOutcome,
    BuildOutcomes,
    BuildResult(..),
20
    BuildFailure(..),
21
    BuildFailureReason(..),
Duncan Coutts's avatar
Duncan Coutts committed
22
23
24
25
26
27
28
29
30
    rebuildTargets
  ) where

import           Distribution.Client.PackageHash (renderPackageHashInputs)
import           Distribution.Client.RebuildMonad
import           Distribution.Client.ProjectConfig
import           Distribution.Client.ProjectPlanning

import           Distribution.Client.Types
31
32
                   hiding (BuildOutcomes, BuildOutcome,
                           BuildResult(..), BuildFailure(..))
Duncan Coutts's avatar
Duncan Coutts committed
33
34
35
36
37
38
39
40
41
42
43
import           Distribution.Client.InstallPlan
                   ( GenericInstallPlan, GenericPlanPackage )
import qualified Distribution.Client.InstallPlan as InstallPlan
import           Distribution.Client.DistDirLayout
import           Distribution.Client.FileMonitor
import           Distribution.Client.SetupWrapper
import           Distribution.Client.JobControl
import           Distribution.Client.FetchUtils
import           Distribution.Client.GlobalFlags (RepoContext)
import qualified Distribution.Client.Tar as Tar
import           Distribution.Client.Setup (filterConfigureFlags)
44
import           Distribution.Client.SrcDist (allPackageSourceFiles)
Duncan Coutts's avatar
Duncan Coutts committed
45
46
import           Distribution.Client.Utils (removeExistingFile)

47
48
49
50
import qualified Distribution.Solver.Types.ComponentDeps as CD
import           Distribution.Solver.Types.ComponentDeps (ComponentDeps)
import           Distribution.Solver.Types.PackageFixedDeps

Duncan Coutts's avatar
Duncan Coutts committed
51
52
53
54
55
56
57
58
59
import           Distribution.Package hiding (InstalledPackageId, installedPackageId)
import           Distribution.InstalledPackageInfo (InstalledPackageInfo)
import qualified Distribution.InstalledPackageInfo as Installed
import           Distribution.Simple.Program
import qualified Distribution.Simple.Setup as Cabal
import           Distribution.Simple.Command (CommandUI)
import qualified Distribution.Simple.Register as Cabal
import qualified Distribution.Simple.InstallDirs as InstallDirs
import           Distribution.Simple.LocalBuildInfo (ComponentName)
60
import qualified Distribution.Simple.Program.HcPkg as HcPkg
Duncan Coutts's avatar
Duncan Coutts committed
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77

import           Distribution.Simple.Utils hiding (matchFileGlob)
import           Distribution.Version
import           Distribution.Verbosity
import           Distribution.Text
import           Distribution.ParseUtils ( showPWarning )

import           Data.Map (Map)
import qualified Data.Map as Map
import           Data.Set (Set)
import qualified Data.Set as Set
import qualified Data.ByteString.Lazy as LBS

import           Control.Monad
import           Control.Exception
import           Data.List
import           Data.Maybe
78
import           Data.Typeable
Duncan Coutts's avatar
Duncan Coutts committed
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120

import           System.FilePath
import           System.IO
import           System.Directory


------------------------------------------------------------------------------
-- * Overall building strategy.
------------------------------------------------------------------------------
--
-- We start with an 'ElaboratedInstallPlan' that has already been improved by
-- reusing packages from the store. So the remaining packages in the
-- 'InstallPlan.Configured' state are ones we either need to build or rebuild.
--
-- First, we do a preliminary dry run phase where we work out which packages
-- we really need to (re)build, and for the ones we do need to build which
-- build phase to start at.


------------------------------------------------------------------------------
-- * Dry run: what bits of the 'ElaboratedInstallPlan' will we execute?
------------------------------------------------------------------------------

-- We split things like this for a couple reasons. Firstly we need to be able
-- to do dry runs, and these need to be reasonably accurate in terms of
-- letting users know what (and why) things are going to be (re)built.
--
-- Given that we need to be able to do dry runs, it would not be great if
-- we had to repeat all the same work when we do it for real. Not only is
-- it duplicate work, but it's duplicate code which is likely to get out of
-- sync. So we do things only once. We preserve info we discover in the dry
-- run phase and rely on it later when we build things for real. This also
-- somewhat simplifies the build phase. So this way the dry run can't so
-- easily drift out of sync with the real thing since we're relying on the
-- info it produces.
--
-- An additional advantage is that it makes it easier to debug rebuild
-- errors (ie rebuilding too much or too little), since all the rebuild
-- decisions are made without making any state changes at the same time
-- (that would make it harder to reproduce the problem sitation).


121
122
123
-- | The 'BuildStatus' of every package in the 'ElaboratedInstallPlan'.
--
-- This is used as the result of the dry-run of building an install plan.
Duncan Coutts's avatar
Duncan Coutts committed
124
125
126
--
type BuildStatusMap = Map InstalledPackageId BuildStatus

127
128
129
-- | The build status for an individual package is the state that the
-- package is in /prior/ to initiating a (re)build.
--
130
131
-- This should not be confused with a 'BuildResult' which is the result
-- /after/ successfully building a package.
Duncan Coutts's avatar
Duncan Coutts committed
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
--
-- It serves two purposes:
--
--  * For dry-run output, it lets us explain to the user if and why a package
--    is going to be (re)built.
--
--  * It tell us what step to start or resume building from, and carries
--    enough information for us to be able to do so.
--
data BuildStatus =

     -- | The package is in the 'InstallPlan.PreExisting' state, so does not
     --   need building.
     BuildStatusPreExisting

     -- | The package has not been downloaded yet, so it will have to be
     --   downloaded, unpacked and built.
   | BuildStatusDownload

     -- | The package has not been unpacked yet, so it will have to be
     --   unpacked and built.
   | BuildStatusUnpack FilePath

     -- | The package exists in a local dir already, and just needs building
     --   or rebuilding. So this can only happen for 'BuildInplaceOnly' style
     --   packages.
   | BuildStatusRebuild FilePath BuildStatusRebuild

     -- | The package exists in a local dir already, and is fully up to date.
     --   So this package can be put into the 'InstallPlan.Installed' state
     --   and it does not need to be built.
163
   | BuildStatusUpToDate BuildResult
Duncan Coutts's avatar
Duncan Coutts committed
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182

-- | For a package that is going to be built or rebuilt, the state it's in now.
--
-- So again, this tells us why a package needs to be rebuilt and what build
-- phases need to be run. The 'MonitorChangedReason' gives us details like
-- which file changed, which is mainly for high verbosity debug output.
--
data BuildStatusRebuild =

     -- | The package configuration changed, so the configure and build phases
     --   needs to be (re)run.
     BuildStatusConfigure (MonitorChangedReason ())

     -- | The configuration has not changed but the build phase needs to be
     -- rerun. We record the reason the (re)build is needed.
     --
     -- The optional registration info here tells us if we've registered the
     -- package already, or if we stil need to do that after building.
     --
183
   | BuildStatusBuild (Maybe [InstalledPackageInfo]) BuildReason
Duncan Coutts's avatar
Duncan Coutts committed
184
185
186
187
188
189
190
191
192
193

data BuildReason =
     -- | The depencencies of this package have been (re)built so the build
     -- phase needs to be rerun.
     --
     -- The optional registration info here tells us if we've registered the
     -- package already, or if we stil need to do that after building.
     --
     BuildReasonDepsRebuilt

Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
194
     -- | Changes in files within the package (or first run or corrupt cache)
Duncan Coutts's avatar
Duncan Coutts committed
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
   | BuildReasonFilesChanged (MonitorChangedReason ())

     -- | An important special case is that no files have changed but the
     -- set of components the /user asked to build/ has changed. We track the
     -- set of components /we have built/, which of course only grows (until
     -- some other change resets it).
     --
     -- The @Set 'ComponentName'@ is the set of components we have built
     -- previously. When we update the monitor we take the union of the ones
     -- we have built previously with the ones the user has asked for this
     -- time and save those. See 'updatePackageBuildFileMonitor'.
     --
   | BuildReasonExtraTargets (Set ComponentName)

     -- | Although we're not going to build any additional targets as a whole,
     -- we're going to build some part of a component or run a repl or any
     -- other action that does not result in additional persistent artifacts.
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
212
     --
Duncan Coutts's avatar
Duncan Coutts committed
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
   | BuildReasonEphemeralTargets

-- | Which 'BuildStatus' values indicate we'll have to do some build work of
-- some sort. In particular we use this as part of checking if any of a
-- package's deps have changed.
--
buildStatusRequiresBuild :: BuildStatus -> Bool
buildStatusRequiresBuild BuildStatusPreExisting = False
buildStatusRequiresBuild BuildStatusUpToDate {} = False
buildStatusRequiresBuild _                      = True

-- | Do the dry run pass. This is a prerequisite of 'rebuildTargets'.
--
-- It gives us the 'BuildStatusMap' and also gives us an improved version of
-- the 'ElaboratedInstallPlan' with packages switched to the
-- 'InstallPlan.Installed' state when we find that they're already up to date.
--
rebuildTargetsDryRun :: DistDirLayout
                     -> ElaboratedInstallPlan
                     -> IO (ElaboratedInstallPlan, BuildStatusMap)
rebuildTargetsDryRun distDirLayout@DistDirLayout{..} = \installPlan -> do

    -- Do the various checks to work out the 'BuildStatus' of each package
    pkgsBuildStatus <- foldMInstallPlanDepOrder installPlan dryRunPkg

    -- For 'BuildStatusUpToDate' packages, improve the plan by marking them as
    -- 'InstallPlan.Installed'.
    let installPlan' = improveInstallPlanWithUpToDatePackages
                         installPlan pkgsBuildStatus

    return (installPlan', pkgsBuildStatus)
  where
    dryRunPkg :: ElaboratedPlanPackage
              -> ComponentDeps [BuildStatus]
              -> IO BuildStatus
    dryRunPkg (InstallPlan.PreExisting _pkg) _depsBuildStatus =
      return BuildStatusPreExisting

    dryRunPkg (InstallPlan.Configured pkg) depsBuildStatus = do
      mloc <- checkFetched (pkgSourceLocation pkg)
      case mloc of
        Nothing -> return BuildStatusDownload

        Just (LocalUnpackedPackage srcdir) ->
          -- For the case of a user-managed local dir, irrespective of the
          -- build style, we build from that directory and put build
          -- artifacts under the shared dist directory.
          dryRunLocalPkg pkg depsBuildStatus srcdir

        -- The three tarball cases are handled the same as each other,
        -- though depending on the build style.
        Just (LocalTarballPackage    tarball) ->
          dryRunTarballPkg pkg depsBuildStatus tarball

        Just (RemoteTarballPackage _ tarball) ->
          dryRunTarballPkg pkg depsBuildStatus tarball

        Just (RepoTarballPackage _ _ tarball) ->
          dryRunTarballPkg pkg depsBuildStatus tarball

    dryRunTarballPkg :: ElaboratedConfiguredPackage
                     -> ComponentDeps [BuildStatus]
                     -> FilePath
                     -> IO BuildStatus
    dryRunTarballPkg pkg depsBuildStatus tarball =
      case pkgBuildStyle pkg of
        BuildAndInstall  -> return (BuildStatusUnpack tarball)
        BuildInplaceOnly -> do
          -- TODO: [nice to have] use a proper file monitor rather than this dir exists test
          exists <- doesDirectoryExist srcdir
          if exists
            then dryRunLocalPkg pkg depsBuildStatus srcdir
            else return (BuildStatusUnpack tarball)
      where
        srcdir = distUnpackedSrcDirectory (packageId pkg)

    dryRunLocalPkg :: ElaboratedConfiguredPackage
                   -> ComponentDeps [BuildStatus]
                   -> FilePath
                   -> IO BuildStatus
    dryRunLocalPkg pkg depsBuildStatus srcdir = do
        -- Go and do lots of I/O, reading caches and probing files to work out
        -- if anything has changed
        change <- checkPackageFileMonitorChanged
                    packageFileMonitor pkg srcdir depsBuildStatus
        case change of
          -- It did change, giving us 'BuildStatusRebuild' info on why
          Left rebuild ->
            return (BuildStatusRebuild srcdir rebuild)

          -- No changes, the package is up to date. Use the saved build results.
304
305
          Right buildResult ->
            return (BuildStatusUpToDate buildResult)
Duncan Coutts's avatar
Duncan Coutts committed
306
307
308
309
310
311
312
313
314
315
316
317
318
319
      where
        packageFileMonitor =
          newPackageFileMonitor distDirLayout (packageId pkg)


-- | A specialised traversal over the packages in an install plan.
--
-- The packages are visited in dependency order, starting with packages with no
-- depencencies. The result for each package is accumulated into a 'Map' and
-- returned as the final result. In addition, when visting a package, the
-- visiting function is passed the results for all the immediate package
-- depencencies. This can be used to propagate information from depencencies.
--
foldMInstallPlanDepOrder
320
  :: forall m ipkg srcpkg b.
Duncan Coutts's avatar
Duncan Coutts committed
321
322
323
     (Monad m,
      HasUnitId ipkg,   PackageFixedDeps ipkg,
      HasUnitId srcpkg, PackageFixedDeps srcpkg)
324
325
  => GenericInstallPlan ipkg srcpkg
  -> (GenericPlanPackage ipkg srcpkg ->
Duncan Coutts's avatar
Duncan Coutts committed
326
327
328
329
330
331
      ComponentDeps [b] -> m b)
  -> m (Map InstalledPackageId b)
foldMInstallPlanDepOrder plan0 visit =
    go Map.empty (InstallPlan.reverseTopologicalOrder plan0)
  where
    go :: Map InstalledPackageId b
332
       -> [GenericPlanPackage ipkg srcpkg]
Duncan Coutts's avatar
Duncan Coutts committed
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
       -> m (Map InstalledPackageId b)
    go !results [] = return results

    go !results (pkg : pkgs) = do
      -- we go in the right order so the results map has entries for all deps
      let depresults :: ComponentDeps [b]
          depresults =
            fmap (map (\ipkgid -> let Just result = Map.lookup ipkgid results
                                   in result))
                 (depends pkg)
      result <- visit pkg depresults
      let results' = Map.insert (installedPackageId pkg) result results
      go results' pkgs

improveInstallPlanWithUpToDatePackages :: ElaboratedInstallPlan
                                       -> BuildStatusMap
                                       -> ElaboratedInstallPlan
improveInstallPlanWithUpToDatePackages installPlan pkgsBuildStatus =
351
352
    replaceWithPrePreExisting installPlan
      [ (installedPackageId pkg, ipkgs)
Duncan Coutts's avatar
Duncan Coutts committed
353
354
355
356
      | InstallPlan.Configured pkg
          <- InstallPlan.reverseTopologicalOrder installPlan
      , let ipkgid = installedPackageId pkg
            Just pkgBuildStatus = Map.lookup ipkgid pkgsBuildStatus
357
358
      , BuildStatusUpToDate (BuildResult { buildResultLibInfo = ipkgs })
          <- [pkgBuildStatus]
Duncan Coutts's avatar
Duncan Coutts committed
359
360
      ]
  where
361
362
363
364
365
366
367
    replaceWithPrePreExisting =
      foldl' (\plan (ipkgid, ipkgs) ->
                case find (\ipkg -> installedPackageId ipkg == ipkgid) ipkgs of
                  Just ipkg -> InstallPlan.preexisting ipkgid ipkg plan
                  Nothing   -> unexpected)
    unexpected =
      error "improveInstallPlanWithUpToDatePackages: dep on non lib package"
Duncan Coutts's avatar
Duncan Coutts committed
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385


-----------------------------
-- Package change detection
--

-- | As part of the dry run for local unpacked packages we have to check if the
-- package config or files have changed. That is the purpose of
-- 'PackageFileMonitor' and 'checkPackageFileMonitorChanged'.
--
-- When a package is (re)built, the monitor must be updated to reflect the new
-- state of the package. Because we sometimes build without reconfiguring the
-- state updates are split into two, one for package config changes and one
-- for other changes. This is the purpose of 'updatePackageConfigFileMonitor'
-- and 'updatePackageBuildFileMonitor'.
--
data PackageFileMonitor = PackageFileMonitor {
       pkgFileMonitorConfig :: FileMonitor ElaboratedConfiguredPackage (),
386
       pkgFileMonitorBuild  :: FileMonitor (Set ComponentName) BuildResultMisc,
387
       pkgFileMonitorReg    :: FileMonitor () [InstalledPackageInfo]
Duncan Coutts's avatar
Duncan Coutts committed
388
389
     }

390
-- | This is all the components of the 'BuildResult' other than the
391
392
-- @['InstalledPackageInfo']@.
--
393
-- We have to split up the 'BuildResult' components since they get produced
394
395
-- at different times (or rather, when different things change).
--
396
type BuildResultMisc = (DocsResult, TestsResult)
397

Duncan Coutts's avatar
Duncan Coutts committed
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
newPackageFileMonitor :: DistDirLayout -> PackageId -> PackageFileMonitor
newPackageFileMonitor DistDirLayout{distPackageCacheFile} pkgid =
    PackageFileMonitor {
      pkgFileMonitorConfig =
        newFileMonitor (distPackageCacheFile pkgid "config"),

      pkgFileMonitorBuild =
        FileMonitor {
          fileMonitorCacheFile = distPackageCacheFile pkgid "build",
          fileMonitorKeyValid  = \componentsToBuild componentsAlreadyBuilt ->
            componentsToBuild `Set.isSubsetOf` componentsAlreadyBuilt,
          fileMonitorCheckIfOnlyValueChanged = True
        },

      pkgFileMonitorReg =
        newFileMonitor (distPackageCacheFile pkgid "registration")
    }

-- | Helper function for 'checkPackageFileMonitorChanged',
-- 'updatePackageConfigFileMonitor' and 'updatePackageBuildFileMonitor'.
--
-- It selects the info from a 'ElaboratedConfiguredPackage' that are used by
-- the 'FileMonitor's (in the 'PackageFileMonitor') to detect value changes.
--
packageFileMonitorKeyValues :: ElaboratedConfiguredPackage
                            -> (ElaboratedConfiguredPackage, Set ComponentName)
packageFileMonitorKeyValues pkg =
    (pkgconfig, buildComponents)
  where
    -- The first part is the value used to guard (re)configuring the package.
    -- That is, if this value changes then we will reconfigure.
    -- The ElaboratedConfiguredPackage consists mostly (but not entirely) of
    -- information that affects the (re)configure step. But those parts that
    -- do not affect the configure step need to be nulled out. Those parts are
    -- the specific targets that we're going to build.
    --
    pkgconfig = pkg {
      pkgBuildTargets  = [],
      pkgReplTarget    = Nothing,
      pkgBuildHaddocks = False
    }

    -- The second part is the value used to guard the build step. So this is
    -- more or less the opposite of the first part, as it's just the info about
    -- what targets we're going to build.
    --
    buildComponents = pkgBuildTargetWholeComponents pkg

-- | Do all the checks on whether a package has changed and thus needs either
-- rebuilding or reconfiguring and rebuilding.
--
checkPackageFileMonitorChanged :: PackageFileMonitor
                               -> ElaboratedConfiguredPackage
                               -> FilePath
                               -> ComponentDeps [BuildStatus]
453
                               -> IO (Either BuildStatusRebuild BuildResult)
Duncan Coutts's avatar
Duncan Coutts committed
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
checkPackageFileMonitorChanged PackageFileMonitor{..}
                               pkg srcdir depsBuildStatus = do
    --TODO: [nice to have] some debug-level message about file changes, like rerunIfChanged
    configChanged <- checkFileMonitorChanged
                       pkgFileMonitorConfig srcdir pkgconfig
    case configChanged of
      MonitorChanged monitorReason ->
          return (Left (BuildStatusConfigure monitorReason'))
        where
          monitorReason' = fmap (const ()) monitorReason

      MonitorUnchanged () _
          -- The configChanged here includes the identity of the dependencies,
          -- so depsBuildStatus is just needed for the changes in the content
          -- of depencencies.
        | any buildStatusRequiresBuild (CD.flatDeps depsBuildStatus) -> do
            regChanged <- checkFileMonitorChanged pkgFileMonitorReg srcdir ()
            let mreg = changedToMaybe regChanged
            return (Left (BuildStatusBuild mreg BuildReasonDepsRebuilt))

        | otherwise -> do
            buildChanged  <- checkFileMonitorChanged
                               pkgFileMonitorBuild srcdir buildComponents
            regChanged    <- checkFileMonitorChanged
                               pkgFileMonitorReg srcdir ()
            let mreg = changedToMaybe regChanged
            case (buildChanged, regChanged) of
              (MonitorChanged (MonitoredValueChanged prevBuildComponents), _) ->
                  return (Left (BuildStatusBuild mreg buildReason))
                where
                  buildReason = BuildReasonExtraTargets prevBuildComponents

              (MonitorChanged monitorReason, _) ->
                  return (Left (BuildStatusBuild mreg buildReason))
                where
                  buildReason    = BuildReasonFilesChanged monitorReason'
                  monitorReason' = fmap (const ()) monitorReason

              (MonitorUnchanged _ _, MonitorChanged monitorReason) ->
                -- this should only happen if the file is corrupt or been
                -- manually deleted. We don't want to bother with another
                -- phase just for this, so we'll reregister by doing a build.
                  return (Left (BuildStatusBuild Nothing buildReason))
                where
                  buildReason    = BuildReasonFilesChanged monitorReason'
                  monitorReason' = fmap (const ()) monitorReason

              (MonitorUnchanged _ _, MonitorUnchanged _ _)
                | pkgHasEphemeralBuildTargets pkg ->
                  return (Left (BuildStatusBuild mreg buildReason))
                where
                  buildReason = BuildReasonEphemeralTargets

507
              (MonitorUnchanged buildResult _, MonitorUnchanged ipkgs _) ->
508
509
510
                  return $ Right BuildResult {
                    buildResultDocs    = docsResult,
                    buildResultTests   = testsResult,
511
                    buildResultLogFile = Nothing,
512
513
                    buildResultLibInfo = ipkgs
                  }
514
                where
515
                  (docsResult, testsResult) = buildResult
Duncan Coutts's avatar
Duncan Coutts committed
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
  where
    (pkgconfig, buildComponents) = packageFileMonitorKeyValues pkg
    changedToMaybe (MonitorChanged     _) = Nothing
    changedToMaybe (MonitorUnchanged x _) = Just x


updatePackageConfigFileMonitor :: PackageFileMonitor
                               -> FilePath
                               -> ElaboratedConfiguredPackage
                               -> IO ()
updatePackageConfigFileMonitor PackageFileMonitor{pkgFileMonitorConfig}
                               srcdir pkg =
    updateFileMonitor pkgFileMonitorConfig srcdir Nothing
                      [] pkgconfig ()
  where
    (pkgconfig, _buildComponents) = packageFileMonitorKeyValues pkg

updatePackageBuildFileMonitor :: PackageFileMonitor
                              -> FilePath
                              -> MonitorTimestamp
                              -> ElaboratedConfiguredPackage
                              -> BuildStatusRebuild
                              -> [FilePath]
539
                              -> BuildResultMisc
Duncan Coutts's avatar
Duncan Coutts committed
540
541
542
                              -> IO ()
updatePackageBuildFileMonitor PackageFileMonitor{pkgFileMonitorBuild}
                              srcdir timestamp pkg pkgBuildStatus
543
                              allSrcFiles buildResult =
Duncan Coutts's avatar
Duncan Coutts committed
544
    updateFileMonitor pkgFileMonitorBuild srcdir (Just timestamp)
545
                      (map monitorFileHashed allSrcFiles)
546
                      buildComponents' buildResult
Duncan Coutts's avatar
Duncan Coutts committed
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
  where
    (_pkgconfig, buildComponents) = packageFileMonitorKeyValues pkg

    -- If the only thing that's changed is that we're now building extra
    -- components, then we can avoid later unnecessary rebuilds by saving the
    -- total set of components that have been built, namely the union of the
    -- existing ones plus the new ones. If files also changed this would be
    -- the wrong thing to do. Note that we rely on the
    -- fileMonitorCheckIfOnlyValueChanged = True mode to get this guarantee
    -- that it's /only/ the value that changed not any files that changed.
    buildComponents' =
      case pkgBuildStatus of
        BuildStatusBuild _ (BuildReasonExtraTargets prevBuildComponents)
          -> buildComponents `Set.union` prevBuildComponents
        _ -> buildComponents

updatePackageRegFileMonitor :: PackageFileMonitor
                            -> FilePath
565
                            -> [InstalledPackageInfo]
Duncan Coutts's avatar
Duncan Coutts committed
566
567
                            -> IO ()
updatePackageRegFileMonitor PackageFileMonitor{pkgFileMonitorReg}
568
                            srcdir ipkgs =
Duncan Coutts's avatar
Duncan Coutts committed
569
    updateFileMonitor pkgFileMonitorReg srcdir Nothing
570
                      [] () ipkgs
Duncan Coutts's avatar
Duncan Coutts committed
571
572
573
574
575
576
577
578
579
580

invalidatePackageRegFileMonitor :: PackageFileMonitor -> IO ()
invalidatePackageRegFileMonitor PackageFileMonitor{pkgFileMonitorReg} =
    removeExistingFile (fileMonitorCacheFile pkgFileMonitorReg)


------------------------------------------------------------------------------
-- * Doing it: executing an 'ElaboratedInstallPlan'
------------------------------------------------------------------------------

581
582
583
584
585
586
587
588
589
590
591
592
593
594
-- | A summary of the outcome for building a whole set of packages.
--
type BuildOutcomes = Map UnitId BuildOutcome

-- | A summary of the outcome for building a single package: either success
-- or failure.
--
type BuildOutcome  = Either BuildFailure BuildResult

-- | Information arising from successfully building a single package.
--
data BuildResult = BuildResult {
       buildResultDocs    :: DocsResult,
       buildResultTests   :: TestsResult,
595
       buildResultLogFile :: Maybe FilePath,
596
597
598
599
600
601
       buildResultLibInfo :: [InstalledPackageInfo]
     }
  deriving Show

-- | Information arising from the failure to build a single package.
--
602
603
604
605
data BuildFailure = BuildFailure {
       buildFailureLogFile :: Maybe FilePath,
       buildFailureReason  :: BuildFailureReason
     }
606
607
608
  deriving (Show, Typeable)

instance Exception BuildFailure
Duncan Coutts's avatar
Duncan Coutts committed
609

610
611
-- | Detail on the reason that a package failed to build.
--
612
data BuildFailureReason = DependentFailed PackageId
613
614
615
616
                        | DownloadFailed  SomeException
                        | UnpackFailed    SomeException
                        | ConfigureFailed SomeException
                        | BuildFailed     SomeException
617
618
                        | ReplFailed      SomeException
                        | HaddocksFailed  SomeException
619
620
621
622
                        | TestsFailed     SomeException
                        | InstallFailed   SomeException
  deriving Show

Duncan Coutts's avatar
Duncan Coutts committed
623
624
-- | Build things for real.
--
Edward Z. Yang's avatar
Edward Z. Yang committed
625
-- It requires the 'BuildStatusMap' gathered by 'rebuildTargetsDryRun'.
Duncan Coutts's avatar
Duncan Coutts committed
626
627
628
629
630
631
632
--
rebuildTargets :: Verbosity
               -> DistDirLayout
               -> ElaboratedInstallPlan
               -> ElaboratedSharedConfig
               -> BuildStatusMap
               -> BuildTimeSettings
633
               -> IO BuildOutcomes
Duncan Coutts's avatar
Duncan Coutts committed
634
635
636
rebuildTargets verbosity
               distDirLayout@DistDirLayout{..}
               installPlan
637
638
639
640
               sharedPackageConfig@ElaboratedSharedConfig {
                 pkgConfigCompiler      = compiler,
                 pkgConfigCompilerProgs = progdb
               }
Duncan Coutts's avatar
Duncan Coutts committed
641
               pkgsBuildStatus
642
643
644
645
               buildSettings@BuildTimeSettings{
                 buildSettingNumJobs,
                 buildSettingKeepGoing
               } = do
Duncan Coutts's avatar
Duncan Coutts committed
646
647
648

    -- Concurrency control: create the job controller and concurrency limits
    -- for downloading, building and installing.
649
650
651
    jobControl    <- if isParallelBuild
                       then newParallelJobControl buildSettingNumJobs
                       else newSerialJobControl
652
    registerLock  <- newLock -- serialise registration
Duncan Coutts's avatar
Duncan Coutts committed
653
654
655
656
657
    cacheLock     <- newLock -- serialise access to setup exe cache
                             --TODO: [code cleanup] eliminate setup exe cache

    createDirectoryIfMissingVerbose verbosity False distBuildRootDirectory
    createDirectoryIfMissingVerbose verbosity False distTempDirectory
658
    mapM_ (createPackageDBIfMissing verbosity compiler progdb) packageDBsToUse
Duncan Coutts's avatar
Duncan Coutts committed
659
660
661
662
663
664
665

    -- Before traversing the install plan, pre-emptively find all packages that
    -- will need to be downloaded and start downloading them.
    asyncDownloadPackages verbosity withRepoCtx
                          installPlan pkgsBuildStatus $ \downloadMap ->

      -- For each package in the plan, in dependency order, but in parallel...
666
667
      InstallPlan.execute jobControl keepGoing
                          (BuildFailure Nothing . DependentFailed . packageId)
668
                          installPlan $ \pkg ->
669
        handle (return . Left) $ fmap Right $ --TODO: review exception handling
Duncan Coutts's avatar
Duncan Coutts committed
670
671
672
673
674
675
676
677

        let ipkgid = installedPackageId pkg
            Just pkgBuildStatus = Map.lookup ipkgid pkgsBuildStatus in

        rebuildTarget
          verbosity
          distDirLayout
          buildSettings downloadMap
678
          registerLock cacheLock
Duncan Coutts's avatar
Duncan Coutts committed
679
680
681
682
683
          sharedPackageConfig
          pkg
          pkgBuildStatus
  where
    isParallelBuild = buildSettingNumJobs >= 2
684
    keepGoing       = buildSettingKeepGoing
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
685
    withRepoCtx     = projectConfigWithBuilderRepoContext verbosity
Duncan Coutts's avatar
Duncan Coutts committed
686
                        buildSettings
687
688
689
690
691
692
693
694
    packageDBsToUse = -- all the package dbs we may need to create
      (Set.toList . Set.fromList)
        [ pkgdb
        | InstallPlan.Configured pkg <- InstallPlan.toList installPlan
        , (pkgdb:_) <- map reverse [ pkgBuildPackageDBStack pkg,
                                     pkgRegisterPackageDBStack pkg,
                                     pkgSetupPackageDBStack pkg ]
        ]
Duncan Coutts's avatar
Duncan Coutts committed
695
696
697
698
699
700

-- | Given all the context and resources, (re)build an individual package.
--
rebuildTarget :: Verbosity
              -> DistDirLayout
              -> BuildTimeSettings
Duncan Coutts's avatar
Duncan Coutts committed
701
              -> AsyncFetchMap
702
              -> Lock -> Lock
Duncan Coutts's avatar
Duncan Coutts committed
703
704
705
              -> ElaboratedSharedConfig
              -> ElaboratedReadyPackage
              -> BuildStatus
706
              -> IO BuildResult
Duncan Coutts's avatar
Duncan Coutts committed
707
708
709
rebuildTarget verbosity
              distDirLayout@DistDirLayout{distBuildDirectory}
              buildSettings downloadMap
710
              registerLock cacheLock
Duncan Coutts's avatar
Duncan Coutts committed
711
              sharedPackageConfig
712
              rpkg@(ReadyPackage pkg)
Duncan Coutts's avatar
Duncan Coutts committed
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
              pkgBuildStatus =

    -- We rely on the 'BuildStatus' to decide which phase to start from:
    case pkgBuildStatus of
      BuildStatusDownload              -> downloadPhase
      BuildStatusUnpack tarball        -> unpackTarballPhase tarball
      BuildStatusRebuild srcdir status -> rebuildPhase status srcdir

      -- TODO: perhaps re-nest the types to make these impossible
      BuildStatusPreExisting {} -> unexpectedState
      BuildStatusUpToDate    {} -> unexpectedState
  where
    unexpectedState = error "rebuildTarget: unexpected package status"

    downloadPhase = do
728
        downsrcloc <- annotateFailure (BuildFailure Nothing . DownloadFailed) $
729
                        waitAsyncPackageDownload verbosity downloadMap pkg
Duncan Coutts's avatar
Duncan Coutts committed
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
        case downsrcloc of
          DownloadedTarball tarball -> unpackTarballPhase tarball
          --TODO: [nice to have] git/darcs repos etc


    unpackTarballPhase tarball =
        withTarballLocalDirectory
          verbosity distDirLayout tarball
          (packageId pkg) (pkgBuildStyle pkg)
          (pkgDescriptionOverride pkg) $

          case pkgBuildStyle pkg of
            BuildAndInstall  -> buildAndInstall
            BuildInplaceOnly -> buildInplace buildStatus
              where
                buildStatus = BuildStatusConfigure MonitorFirstRun

    -- Note that this really is rebuild, not build. It can only happen for
    -- 'BuildInplaceOnly' style packages. 'BuildAndInstall' style packages
    -- would only start from download or unpack phases.
    --
    rebuildPhase buildStatus srcdir =
        assert (pkgBuildStyle pkg == BuildInplaceOnly) $

          buildInplace buildStatus srcdir builddir
      where
        builddir = distBuildDirectory (packageId pkg)

    buildAndInstall srcdir builddir =
        buildAndInstallUnpackedPackage
          verbosity distDirLayout
761
          buildSettings registerLock cacheLock
Duncan Coutts's avatar
Duncan Coutts committed
762
763
764
765
766
767
768
769
770
771
772
          sharedPackageConfig
          rpkg
          srcdir builddir'
      where
        builddir' = makeRelative srcdir builddir
        --TODO: [nice to have] ^^ do this relative stuff better

    buildInplace buildStatus srcdir builddir =
        --TODO: [nice to have] use a relative build dir rather than absolute
        buildInplaceUnpackedPackage
          verbosity distDirLayout
773
          buildSettings registerLock cacheLock
Duncan Coutts's avatar
Duncan Coutts committed
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
          sharedPackageConfig
          rpkg
          buildStatus
          srcdir builddir

--TODO: [nice to have] do we need to use a with-style for the temp files for downloading http
-- packages, or are we going to cache them persistently?

-- | Given the current 'InstallPlan' and 'BuildStatusMap', select all the
-- packages we have to download and fork off an async action to download them.
-- We download them in dependency order so that the one's we'll need
-- first are the ones we will start downloading first.
--
-- The body action is passed a map from those packages (identified by their
-- location) to a completion var for that package. So the body action should
-- lookup the location and use 'waitAsyncPackageDownload' to get the result.
--
asyncDownloadPackages :: Verbosity
Duncan Coutts's avatar
Duncan Coutts committed
792
                      -> ((RepoContext -> IO a) -> IO a)
Duncan Coutts's avatar
Duncan Coutts committed
793
794
                      -> ElaboratedInstallPlan
                      -> BuildStatusMap
Duncan Coutts's avatar
Duncan Coutts committed
795
                      -> (AsyncFetchMap -> IO a)
Duncan Coutts's avatar
Duncan Coutts committed
796
797
798
                      -> IO a
asyncDownloadPackages verbosity withRepoCtx installPlan pkgsBuildStatus body
  | null pkgsToDownload = body Map.empty
Duncan Coutts's avatar
Duncan Coutts committed
799
800
801
  | otherwise           = withRepoCtx $ \repoctx ->
                            asyncFetchPackages verbosity repoctx
                                               pkgsToDownload body
Duncan Coutts's avatar
Duncan Coutts committed
802
  where
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
803
    pkgsToDownload =
Duncan Coutts's avatar
Duncan Coutts committed
804
805
806
807
808
809
810
811
812
813
      [ pkgSourceLocation pkg
      | InstallPlan.Configured pkg
         <- InstallPlan.reverseTopologicalOrder installPlan
      , let ipkgid = installedPackageId pkg
            Just pkgBuildStatus = Map.lookup ipkgid pkgsBuildStatus
      , BuildStatusDownload <- [pkgBuildStatus]
      ]


-- | Check if a package needs downloading, and if so expect to find a download
Duncan Coutts's avatar
Duncan Coutts committed
814
-- in progress in the given 'AsyncFetchMap' and wait on it to finish.
Duncan Coutts's avatar
Duncan Coutts committed
815
816
--
waitAsyncPackageDownload :: Verbosity
Duncan Coutts's avatar
Duncan Coutts committed
817
                         -> AsyncFetchMap
Duncan Coutts's avatar
Duncan Coutts committed
818
819
                         -> ElaboratedConfiguredPackage
                         -> IO DownloadedSourceLocation
Duncan Coutts's avatar
Duncan Coutts committed
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
waitAsyncPackageDownload verbosity downloadMap pkg = do
    pkgloc <- waitAsyncFetchPackage verbosity downloadMap
                                    (pkgSourceLocation pkg)
    case downloadedSourceLocation pkgloc of
      Just loc -> return loc
      Nothing  -> fail "waitAsyncPackageDownload: unexpected source location"

data DownloadedSourceLocation = DownloadedTarball FilePath
                              --TODO: [nice to have] git/darcs repos etc

downloadedSourceLocation :: PackageLocation FilePath
                         -> Maybe DownloadedSourceLocation
downloadedSourceLocation pkgloc =
    case pkgloc of
      RemoteTarballPackage _ tarball -> Just (DownloadedTarball tarball)
      RepoTarballPackage _ _ tarball -> Just (DownloadedTarball tarball)
      _                              -> Nothing
Duncan Coutts's avatar
Duncan Coutts committed
837
838
839
840
841




-- | Ensure that the package is unpacked in an appropriate directory, either
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
842
-- a temporary one or a persistent one under the shared dist directory.
Duncan Coutts's avatar
Duncan Coutts committed
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
--
withTarballLocalDirectory
  :: Verbosity
  -> DistDirLayout
  -> FilePath
  -> PackageId
  -> BuildStyle
  -> Maybe CabalFileText
  -> (FilePath -> FilePath -> IO a)
  -> IO a
withTarballLocalDirectory verbosity distDirLayout@DistDirLayout{..}
                          tarball pkgid buildstyle pkgTextOverride
                          buildPkg  =
      case buildstyle of
        -- In this case we make a temp dir, unpack the tarball to there and
        -- build and install it from that temp dir.
        BuildAndInstall ->
          withTempDirectory verbosity distTempDirectory
                            (display (packageName pkgid)) $ \tmpdir -> do
            unpackPackageTarball verbosity tarball tmpdir
                                 pkgid pkgTextOverride
            let srcdir   = tmpdir </> display pkgid
                builddir = srcdir </> "dist"
            buildPkg srcdir builddir

        -- In this case we make sure the tarball has been unpacked to the
        -- appropriate location under the shared dist dir, and then build it
        -- inplace there
        BuildInplaceOnly -> do
          let srcrootdir = distUnpackedSrcRootDirectory
              srcdir     = distUnpackedSrcDirectory pkgid
              builddir   = distBuildDirectory pkgid
          -- TODO: [nice to have] use a proper file monitor rather than this dir exists test
          exists <- doesDirectoryExist srcdir
          unless exists $ do
            createDirectoryIfMissingVerbose verbosity False srcrootdir
            unpackPackageTarball verbosity tarball srcrootdir
                                 pkgid pkgTextOverride
            moveTarballShippedDistDirectory verbosity distDirLayout
                                            srcrootdir pkgid
          buildPkg srcdir builddir


unpackPackageTarball :: Verbosity -> FilePath -> FilePath
                     -> PackageId -> Maybe CabalFileText
                     -> IO ()
unpackPackageTarball verbosity tarball parentdir pkgid pkgTextOverride =
    --TODO: [nice to have] switch to tar package and catch tar exceptions
891
    annotateFailure (BuildFailure Nothing . UnpackFailed) $ do
Duncan Coutts's avatar
Duncan Coutts committed
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947

      -- Unpack the tarball
      --
      info verbosity $ "Extracting " ++ tarball ++ " to " ++ parentdir ++ "..."
      Tar.extractTarGzFile parentdir pkgsubdir tarball

      -- Sanity check
      --
      exists <- doesFileExist cabalFile
      when (not exists) $
        die $ "Package .cabal file not found in the tarball: " ++ cabalFile

      -- Overwrite the .cabal with the one from the index, when appropriate
      --
      case pkgTextOverride of
        Nothing     -> return ()
        Just pkgtxt -> do
          info verbosity $ "Updating " ++ display pkgname <.> "cabal"
                        ++ " with the latest revision from the index."
          writeFileAtomic cabalFile pkgtxt

  where
    cabalFile = parentdir </> pkgsubdir
                          </> display pkgname <.> "cabal"
    pkgsubdir = display pkgid
    pkgname   = packageName pkgid


-- | This is a bit of a hacky workaround. A number of packages ship
-- pre-processed .hs files in a dist directory inside the tarball. We don't
-- use the standard 'dist' location so unless we move this dist dir to the
-- right place then we'll miss the shipped pre-procssed files. This hacky
-- approach to shipped pre-procssed files ought to be replaced by a proper
-- system, though we'll still need to keep this hack for older packages.
--
moveTarballShippedDistDirectory :: Verbosity -> DistDirLayout
                                -> FilePath -> PackageId -> IO ()
moveTarballShippedDistDirectory verbosity DistDirLayout{distBuildDirectory}
                                parentdir pkgid = do
    distDirExists <- doesDirectoryExist tarballDistDir
    when distDirExists $ do
      debug verbosity $ "Moving '" ++ tarballDistDir ++ "' to '"
                                   ++ targetDistDir ++ "'"
      --TODO: [nice to have] or perhaps better to copy, and use a file monitor
      renameDirectory tarballDistDir targetDistDir
  where
    tarballDistDir = parentdir </> display pkgid </> "dist"
    targetDistDir  = distBuildDirectory pkgid


buildAndInstallUnpackedPackage :: Verbosity
                               -> DistDirLayout
                               -> BuildTimeSettings -> Lock -> Lock
                               -> ElaboratedSharedConfig
                               -> ElaboratedReadyPackage
                               -> FilePath -> FilePath
948
                               -> IO BuildResult
Duncan Coutts's avatar
Duncan Coutts committed
949
950
951
952
953
954
buildAndInstallUnpackedPackage verbosity
                               DistDirLayout{distTempDirectory}
                               BuildTimeSettings {
                                 buildSettingNumJobs,
                                 buildSettingLogFile
                               }
955
                               registerLock cacheLock
Duncan Coutts's avatar
Duncan Coutts committed
956
                               pkgshared@ElaboratedSharedConfig {
957
958
959
                                 pkgConfigPlatform      = platform,
                                 pkgConfigCompiler      = compiler,
                                 pkgConfigCompilerProgs = progdb
Duncan Coutts's avatar
Duncan Coutts committed
960
                               }
961
                               rpkg@(ReadyPackage pkg)
Duncan Coutts's avatar
Duncan Coutts committed
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
                               srcdir builddir = do

    createDirectoryIfMissingVerbose verbosity False builddir
    initLogFile

    --TODO: [code cleanup] deal consistently with talking to older Setup.hs versions, much like
    --      we do for ghc, with a proper options type and rendering step
    --      which will also let us call directly into the lib, rather than always
    --      going via the lib's command line interface, which would also allow
    --      passing data like installed packages, compiler, and program db for a
    --      quicker configure.

    --TODO: [required feature] docs and tests
    --TODO: [required feature] sudo re-exec

    -- Configure phase
    when isParallelBuild $
      notice verbosity $ "Configuring " ++ display pkgid ++ "..."
980
    annotateFailure (BuildFailure mlogFile . ConfigureFailed) $
Duncan Coutts's avatar
Duncan Coutts committed
981
982
983
984
985
      setup configureCommand configureFlags

    -- Build phase
    when isParallelBuild $
      notice verbosity $ "Building " ++ display pkgid ++ "..."
986
    annotateFailure (BuildFailure mlogFile . BuildFailed) $
Duncan Coutts's avatar
Duncan Coutts committed
987
988
989
      setup buildCommand buildFlags

    -- Install phase
990
    ipkgs <-
991
      annotateFailure (BuildFailure mlogFile . InstallFailed) $ do
Duncan Coutts's avatar
Duncan Coutts committed
992
993
994
995
996
997
998
999
1000
      --TODO: [required eventually] need to lock installing this ipkig so other processes don't
      -- stomp on our files, since we don't have ABI compat, not safe to replace

      -- TODO: [required eventually] note that for nix-style installations it is not necessary to do
      -- the 'withWin32SelfUpgrade' dance, but it would be necessary for a
      -- shared bin dir.

      -- Actual installation
      setup Cabal.copyCommand copyFlags
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
1001

Duncan Coutts's avatar
Duncan Coutts committed
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
      LBS.writeFile
        (InstallDirs.prefix (pkgInstallDirs pkg) </> "cabal-hash.txt") $
        (renderPackageHashInputs (packageHashInputs pkgshared pkg))

      -- here's where we could keep track of the installed files ourselves if
      -- we wanted by calling copy to an image dir and then we would make a
      -- manifest and move it to its final location

      --TODO: [nice to have] we should actually have it make an image in store/incomming and
      -- then when it's done, move it to its final location, to reduce problems
      -- with installs failing half-way. Could also register and then move.

      if pkgRequiresRegistration pkg
        then do
1016
          ipkgs <- generateInstalledPackageInfos
Duncan Coutts's avatar
Duncan Coutts committed
1017
1018
1019
          -- We register ourselves rather than via Setup.hs. We need to
          -- grab and modify the InstalledPackageInfo. We decide what
          -- the installed package id is, not the build system.
1020
1021
1022
1023
1024
1025

          -- See Note [Updating installedUnitId]
          let ipkgs' = case ipkgs of
                          -- Case A and B
                          [ipkg] -> [ipkg { Installed.installedUnitId = ipkgid }]
                          -- Case C
1026
1027
1028
1029
1030
1031
1032
                          _      -> ipkgs
          unless (any ((== ipkgid) . Installed.installedUnitId) ipkgs') $
            die $ "the package " ++ display (packageId pkg) ++ " was expected "
               ++ " to produce registeration info for the unit Id "
               ++ display ipkgid ++ " but it actually produced info for "
               ++ intercalate ", "
                    (map (display . Installed.installedUnitId) ipkgs')
1033
1034
          criticalSection registerLock $
            forM_ ipkgs' $ \ipkg' ->
1035
1036
1037
              Cabal.registerPackage verbosity compiler progdb
                                    HcPkg.MultiInstance
                                    (pkgRegisterPackageDBStack pkg) ipkg'
1038
          return ipkgs'
1039
        else return []
Duncan Coutts's avatar
Duncan Coutts committed
1040
1041
1042
1043
1044

    --TODO: [required feature] docs and test phases
    let docsResult  = DocsNotTried
        testsResult = TestsNotTried

1045
1046
1047
    return BuildResult {
       buildResultDocs    = docsResult,
       buildResultTests   = testsResult,
1048
       buildResultLogFile = mlogFile,
1049
1050
       buildResultLibInfo = ipkgs
    }
Duncan Coutts's avatar
Duncan Coutts committed
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065

  where
    pkgid  = packageId rpkg
    ipkgid = installedPackageId rpkg

    isParallelBuild = buildSettingNumJobs >= 2

    configureCommand = Cabal.configureCommand defaultProgramConfiguration
    configureFlags v = flip filterConfigureFlags v $
                       setupHsConfigureFlags rpkg pkgshared
                                             verbosity builddir

    buildCommand     = Cabal.buildCommand defaultProgramConfiguration
    buildFlags   _   = setupHsBuildFlags pkg pkgshared verbosity builddir

1066
1067
1068
1069
    generateInstalledPackageInfos :: IO [InstalledPackageInfo]
    generateInstalledPackageInfos =
      withTempInstalledPackageInfoFiles
        verbosity distTempDirectory $ \pkgConfDest -> do
Duncan Coutts's avatar
Duncan Coutts committed
1070
1071
1072
        let registerFlags _ = setupHsRegisterFlags
                                pkg pkgshared
                                verbosity builddir
1073
                                pkgConfDest
Duncan Coutts's avatar
Duncan Coutts committed
1074
1075
1076
1077
1078
1079
1080
1081
1082
        setup Cabal.registerCommand registerFlags

    copyFlags _ = setupHsCopyFlags pkg pkgshared verbosity builddir

    scriptOptions = setupHsScriptOptions rpkg pkgshared srcdir builddir
                                         isParallelBuild cacheLock

    setup :: CommandUI flags -> (Version -> flags) -> IO ()
    setup cmd flags =
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
1083
      withLogging $ \mLogFileHandle ->
Duncan Coutts's avatar
Duncan Coutts committed
1084
1085
1086
1087
1088
1089
        setupWrapper
          verbosity
          scriptOptions { useLoggingHandle = mLogFileHandle }
          (Just (pkgDescription pkg))
          cmd flags []

1090
    mlogFile :: Maybe FilePath
Duncan Coutts's avatar
Duncan Coutts committed
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
    mlogFile =
      case buildSettingLogFile of
        Nothing        -> Nothing
        Just mkLogFile -> Just (mkLogFile compiler platform pkgid ipkgid)

    initLogFile =
      case mlogFile of
        Nothing      -> return ()
        Just logFile -> do
          createDirectoryIfMissing True (takeDirectory logFile)
          exists <- doesFileExist logFile
          when exists $ removeFile logFile

    withLogging action =
      case mlogFile of
        Nothing      -> action Nothing
        Just logFile -> withFile logFile AppendMode (action . Just)


buildInplaceUnpackedPackage :: Verbosity
                            -> DistDirLayout
1112
                            -> BuildTimeSettings -> Lock -> Lock
Duncan Coutts's avatar
Duncan Coutts committed
1113
1114
1115
1116
                            -> ElaboratedSharedConfig
                            -> ElaboratedReadyPackage
                            -> BuildStatusRebuild
                            -> FilePath -> FilePath
1117
                            -> IO BuildResult
Duncan Coutts's avatar
Duncan Coutts committed
1118
1119
1120
1121
1122
1123
buildInplaceUnpackedPackage verbosity
                            distDirLayout@DistDirLayout {
                              distTempDirectory,
                              distPackageCacheDirectory
                            }
                            BuildTimeSettings{buildSettingNumJobs}
1124
                            registerLock cacheLock
Duncan Coutts's avatar
Duncan Coutts committed
1125
                            pkgshared@ElaboratedSharedConfig {
1126
1127
                              pkgConfigCompiler      = compiler,
                              pkgConfigCompilerProgs = progdb
Duncan Coutts's avatar
Duncan Coutts committed
1128
                            }
1129
                            rpkg@(ReadyPackage pkg)
Duncan Coutts's avatar
Duncan Coutts committed
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
                            buildStatus
                            srcdir builddir = do

        --TODO: [code cleanup] there is duplication between the distdirlayout and the builddir here
        --      builddir is not enough, we also need the per-package cachedir
        createDirectoryIfMissingVerbose verbosity False builddir
        createDirectoryIfMissingVerbose verbosity False (distPackageCacheDirectory pkgid)

        -- Configure phase
        --
        whenReConfigure $ do
1141
          annotateFailure (BuildFailure Nothing . ConfigureFailed) $
1142
            setup configureCommand configureFlags []
Duncan Coutts's avatar
Duncan Coutts committed
1143
1144
1145
1146
1147
1148
1149
1150
          invalidatePackageRegFileMonitor packageFileMonitor
          updatePackageConfigFileMonitor packageFileMonitor srcdir pkg

        -- Build phase
        --
        let docsResult  = DocsNotTried
            testsResult = TestsNotTried

1151
1152
            buildResult :: BuildResultMisc
            buildResult = (docsResult, testsResult)
Duncan Coutts's avatar
Duncan Coutts committed
1153
1154
1155

        whenRebuild $ do
          timestamp <- beginUpdateFileMonitor
1156
          annotateFailure (BuildFailure Nothing . BuildFailed) $
1157
            setup buildCommand buildFlags buildArgs
Duncan Coutts's avatar
Duncan Coutts committed
1158

1159
1160
1161
          --TODO: [required eventually] this doesn't track file
          --non-existence, so we could fail to rebuild if someone
          --adds a new file which changes behavior.
1162
          allSrcFiles <- allPackageSourceFiles verbosity scriptOptions srcdir
Duncan Coutts's avatar
Duncan Coutts committed
1163
1164
1165

          updatePackageBuildFileMonitor packageFileMonitor srcdir timestamp
                                        pkg buildStatus
1166
                                        allSrcFiles buildResult
Duncan Coutts's avatar
Duncan Coutts committed
1167

1168
1169
        ipkgs <- whenReRegister $
                 annotateFailure (BuildFailure Nothing . InstallFailed) $ do
Duncan Coutts's avatar
Duncan Coutts committed
1170
          -- Register locally
1171
          ipkgs <- if pkgRequiresRegistration pkg
Duncan Coutts's avatar
Duncan Coutts committed
1172
            then do
1173
                ipkgs <- generateInstalledPackageInfos
Duncan Coutts's avatar
Duncan Coutts committed
1174
1175
1176
1177
                -- We register ourselves rather than via Setup.hs. We need to
                -- grab and modify the InstalledPackageInfo. We decide what
                -- the installed package id is, not the build system.

1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
                -- Note [Updating installedUnitId]
                -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
                -- This is a bit tricky.  There are three variables we
                -- care about:
                --
                --      1. Does the Setup script we're interfacing with
                --         support --ipid?  (Only if version >= 1.23)
                --         If not, we have to explicitly update the
                --         the UID that was recorded.
                --
                --      2. Does the Setup script we're interfacing with
                --         support internal libraries?  (Only if
                --         version >= 1.25).  If so, there may be
                --         multiple IPIs... and it would be wrong to
                --         update them all to the same UID (you need
                --         to generate derived UIDs for each
                --         subcomponent.)
                --
                --      3. Does GHC require that the IPID be input at
                --         configure time?  (Only if GHC >= 8.0, which
                --         also implies Cabal version >= 1.23, as earlier
                --         Cabal's don't know how to do this properly).
                --         If so, it is IMPERMISSIBLE to update the
                --         UID that was recorded.
                --
                -- This means that there are three situations:
                --
                --   A. Cabal  < 1.23
                --   B. Cabal >= 1.23 && < 1.25
                --   C. Cabal >= 1.25
                --
                -- We consider each in turn:
                --
                --      A. There is only ever one IPI, and we must
                --         update it.
                --
                --      B. There is only ever one IPI, but because
                --         --ipid is supported, the installedUnitId of
                --         this IPI is ipkgid (so it's harmless to
                --         overwrite).
                --
                --      C. There may be multiple IPIs, but because
                --         --ipid is supported they always have the
                --         right installedUnitIds.
                --
                let ipkgs' = case ipkgs of
                                -- Case A and B
                                [ipkg] -> [ipkg { Installed.installedUnitId = ipkgid }]
                                -- Case C
                                _      -> assert (any ((== ipkgid) . Installed.installedUnitId)
                                                      ipkgs) ipkgs
1229
1230
                criticalSection registerLock $
                  forM_ ipkgs' $ \ipkg' ->
1231
1232
1233
1234
1235
1236
1237
1238
1239
                    Cabal.registerPackage verbosity compiler progdb HcPkg.NoMultiInstance
                                          (pkgRegisterPackageDBStack pkg)
                                          ipkg'
                return ipkgs'

           else return []

          updatePackageRegFileMonitor packageFileMonitor srcdir ipkgs
          return ipkgs
Duncan Coutts's avatar
Duncan Coutts committed
1240
1241
1242
1243

        -- Repl phase
        --
        whenRepl $
1244
          annotateFailure (BuildFailure Nothing . ReplFailed) $
Duncan Coutts's avatar
Duncan Coutts committed
1245
1246
1247
1248
          setup replCommand replFlags replArgs

        -- Haddock phase
        whenHaddock $
1249
          annotateFailure (BuildFailure Nothing . HaddocksFailed) $
Duncan Coutts's avatar
Duncan Coutts committed
1250
1251
          setup haddockCommand haddockFlags []

1252
1253
1254
        return BuildResult {
          buildResultDocs    = docsResult,
          buildResultTests   = testsResult,
1255
          buildResultLogFile = Nothing,
1256
1257
          buildResultLibInfo = ipkgs
        }
Duncan Coutts's avatar
Duncan Coutts committed
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285

  where
    pkgid  = packageId rpkg
    ipkgid = installedPackageId rpkg

    isParallelBuild = buildSettingNumJobs >= 2

    packageFileMonitor = newPackageFileMonitor distDirLayout pkgid

    whenReConfigure action = case buildStatus of
      BuildStatusConfigure _ -> action
      _                      -> return ()

    whenRebuild action
      | null (pkgBuildTargets pkg) = return ()
      | otherwise                  = action

    whenRepl action
      | isNothing (pkgReplTarget pkg) = return ()
      | otherwise                     = action

    whenHaddock action
      | pkgBuildHaddocks pkg = action
      | otherwise            = return ()

    whenReRegister  action = case buildStatus of
      BuildStatusConfigure          _ -> action
      BuildStatusBuild Nothing      _ -> action
1286
      BuildStatusBuild (Just ipkgs) _ -> return ipkgs
Duncan Coutts's avatar
Duncan Coutts committed
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317

    configureCommand = Cabal.configureCommand defaultProgramConfiguration
    configureFlags v = flip filterConfigureFlags v $
                       setupHsConfigureFlags rpkg pkgshared
                                             verbosity builddir

    buildCommand     = Cabal.buildCommand defaultProgramConfiguration
    buildFlags   _   = setupHsBuildFlags pkg pkgshared
                                         verbosity builddir
    buildArgs        = setupHsBuildArgs  pkg

    replCommand      = Cabal.replCommand defaultProgramConfiguration
    replFlags _      = setupHsReplFlags pkg pkgshared
                                        verbosity builddir
    replArgs         = setupHsReplArgs  pkg

    haddockCommand   = Cabal.haddockCommand
    haddockFlags _   = setupHsHaddockFlags pkg pkgshared
                                           verbosity builddir

    scriptOptions    = setupHsScriptOptions rpkg pkgshared
                                            srcdir builddir
                                            isParallelBuild cacheLock

    setup :: CommandUI flags -> (Version -> flags) -> [String] -> IO ()
    setup cmd flags args =
      setupWrapper verbosity
                   scriptOptions
                   (Just (pkgDescription pkg))
                   cmd flags args

1318
1319
1320
1321
    generateInstalledPackageInfos :: IO [InstalledPackageInfo]
    generateInstalledPackageInfos =
      withTempInstalledPackageInfoFiles
        verbosity distTempDirectory $ \pkgConfDest -> do
Duncan Coutts's avatar
Duncan Coutts committed
1322
1323
1324
        let registerFlags _ = setupHsRegisterFlags
                                pkg pkgshared
                                verbosity builddir
1325
                                pkgConfDest
Duncan Coutts's avatar
Duncan Coutts committed
1326
1327
1328
1329
        setup Cabal.registerCommand registerFlags []


-- helper
1330
annotateFailure :: (SomeException -> BuildFailure) -> IO a -> IO a
Duncan Coutts's avatar
Duncan Coutts committed
1331
1332
annotateFailure annotate action =
  action `catches`
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
    -- It's not just IOException and ExitCode we have to deal with, there's
    -- lots, including exceptions from the hackage-security and tar packages.
    -- So we take the strategy of catching everything except async exceptions.
    [
#if MIN_VERSION_base(4,7,0)
      Handler $ \async -> throwIO (async :: SomeAsyncException)
#else
      Handler $ \async -> throwIO (async :: AsyncException)
#endif
    , Handler $ \other -> handler (other :: SomeException)
Duncan Coutts's avatar
Duncan Coutts committed
1343
1344
1345
    ]
  where
    handler :: Exception e => e -> IO a
1346
    handler = throwIO . annotate . toException
Duncan Coutts's avatar
Duncan Coutts committed
1347
1348


1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
withTempInstalledPackageInfoFiles :: Verbosity -> FilePath
                                  -> (FilePath -> IO ())
                                  -> IO [InstalledPackageInfo]
withTempInstalledPackageInfoFiles verbosity tempdir action =
    withTempDirectory verbosity tempdir "package-registration-" $ \dir -> do
      -- make absolute since @action@ will often change directory
      abs_dir <- canonicalizePath dir

      let pkgConfDest = abs_dir </> "pkgConf"
      action pkgConfDest

      is_dir <- doesDirectoryExist pkgConfDest
Duncan Coutts's avatar
Duncan Coutts committed
1361

1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
      let notHidden = not . isHidden
          isHidden name = "." `isPrefixOf` name
      if is_dir
        then mapM (readPkgConf pkgConfDest) . sort . filter notHidden
                =<< getDirectoryContents pkgConfDest
        else fmap (:[]) $ readPkgConf "." pkgConfDest
  where
    pkgConfParseFailed :: Installed.PError -> IO a
    pkgConfParseFailed perror =
      die $ "Couldn't parse the output of 'setup register --gen-pkg-config':"
            ++ show perror

    readPkgConf pkgConfDir pkgConfFile = do
      (warns, ipkg) <- withUTF8FileContents (pkgConfDir </> pkgConfFile) $ \pkgConfStr ->
Duncan Coutts's avatar
Duncan Coutts committed
1376
1377
1378
1379
1380
1381
1382
1383
        case Installed.parseInstalledPackageInfo pkgConfStr of
          Installed.ParseFailed perror -> pkgConfParseFailed perror
          Installed.ParseOk warns ipkg -> return (warns, ipkg)

      unless (null warns) $
        warn verbosity $ unlines (map (showPWarning pkgConfFile) warns)

      return ipkg