ProjectBuilding.hs 56.3 KB
Newer Older
Duncan Coutts's avatar
Duncan Coutts committed
1
2
3
{-# LANGUAGE CPP, BangPatterns, RecordWildCards, NamedFieldPuns,
             DeriveGeneric, DeriveDataTypeable, GeneralizedNewtypeDeriving,
             ScopedTypeVariables #-}
4
5
6
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE NoMonoLocalBinds #-}
{-# LANGUAGE ConstraintKinds #-}
Duncan Coutts's avatar
Duncan Coutts committed
7

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

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

import           Distribution.Client.PackageHash (renderPackageHashInputs)
import           Distribution.Client.RebuildMonad
import           Distribution.Client.ProjectConfig
import           Distribution.Client.ProjectPlanning
33
import           Distribution.Client.ProjectPlanning.Types
Duncan Coutts's avatar
Duncan Coutts committed
34
35

import           Distribution.Client.Types
36
37
                   hiding (BuildOutcomes, BuildOutcome,
                           BuildResult(..), BuildFailure(..))
Duncan Coutts's avatar
Duncan Coutts committed
38
import           Distribution.Client.InstallPlan
39
                   ( GenericInstallPlan, GenericPlanPackage, IsUnit )
Duncan Coutts's avatar
Duncan Coutts committed
40
41
42
43
44
45
46
47
48
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)
49
import           Distribution.Client.SrcDist (allPackageSourceFiles)
Duncan Coutts's avatar
Duncan Coutts committed
50
51
52
53
54
55
56
57
58
59
60
import           Distribution.Client.Utils (removeExistingFile)

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)
61
import qualified Distribution.Simple.Program.HcPkg as HcPkg
Duncan Coutts's avatar
Duncan Coutts committed
62
63
64
65
66
67

import           Distribution.Simple.Utils hiding (matchFileGlob)
import           Distribution.Version
import           Distribution.Verbosity
import           Distribution.Text
import           Distribution.ParseUtils ( showPWarning )
68
import           Distribution.Compat.Graph (IsNode(..))
Duncan Coutts's avatar
Duncan Coutts committed
69
70
71
72
73
74
75
76
77
78
79

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
80
import           Data.Typeable
Duncan Coutts's avatar
Duncan Coutts committed
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
121
122

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).


123
124
125
-- | 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
126
--
127
type BuildStatusMap = Map UnitId BuildStatus
Duncan Coutts's avatar
Duncan Coutts committed
128

129
130
131
-- | The build status for an individual package is the state that the
-- package is in /prior/ to initiating a (re)build.
--
132
133
-- This should not be confused with a 'BuildResult' which is the result
-- /after/ successfully building a package.
Duncan Coutts's avatar
Duncan Coutts committed
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
163
164
--
-- 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.
165
   | BuildStatusUpToDate BuildResult
Duncan Coutts's avatar
Duncan Coutts committed
166

167
168
169
170
171
172
173
buildStatusToString :: BuildStatus -> String
buildStatusToString BuildStatusPreExisting      = "BuildStatusPreExisting"
buildStatusToString BuildStatusDownload         = "BuildStatusDownload"
buildStatusToString (BuildStatusUnpack fp)      = "BuildStatusUnpack " ++ show fp
buildStatusToString (BuildStatusRebuild fp _)   = "BuildStatusRebuild " ++ show fp
buildStatusToString (BuildStatusUpToDate _)     = "BuildStatusUpToDate"

Duncan Coutts's avatar
Duncan Coutts committed
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
-- | 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.
191
192
     -- @Just Nothing@ indicates that we know that no registration is
     -- necessary (e.g., executable.)
Duncan Coutts's avatar
Duncan Coutts committed
193
     --
194
   | BuildStatusBuild (Maybe (Maybe InstalledPackageInfo)) BuildReason
Duncan Coutts's avatar
Duncan Coutts committed
195
196
197
198
199
200
201
202
203
204

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
205
     -- | Changes in files within the package (or first run or corrupt cache)
Duncan Coutts's avatar
Duncan Coutts committed
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
   | 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
223
     --
Duncan Coutts's avatar
Duncan Coutts committed
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
   | 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.
--
241
242
243
rebuildTargetsDryRun :: Verbosity
                     -> DistDirLayout
                     -> ElaboratedSharedConfig
Duncan Coutts's avatar
Duncan Coutts committed
244
245
                     -> ElaboratedInstallPlan
                     -> IO (ElaboratedInstallPlan, BuildStatusMap)
246
rebuildTargetsDryRun verbosity distDirLayout@DistDirLayout{..} shared = \installPlan -> do
Duncan Coutts's avatar
Duncan Coutts committed
247
248
249
250
251
252
253
254

    -- 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
255
    debugNoWrap verbosity $ InstallPlan.showInstallPlan installPlan'
Duncan Coutts's avatar
Duncan Coutts committed
256
257
258
259

    return (installPlan', pkgsBuildStatus)
  where
    dryRunPkg :: ElaboratedPlanPackage
260
              -> [BuildStatus]
Duncan Coutts's avatar
Duncan Coutts committed
261
262
263
264
265
              -> IO BuildStatus
    dryRunPkg (InstallPlan.PreExisting _pkg) _depsBuildStatus =
      return BuildStatusPreExisting

    dryRunPkg (InstallPlan.Configured pkg) depsBuildStatus = do
266
      mloc <- checkFetched (elabPkgSourceLocation pkg)
Duncan Coutts's avatar
Duncan Coutts committed
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
      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
288
                     -> [BuildStatus]
Duncan Coutts's avatar
Duncan Coutts committed
289
290
291
                     -> FilePath
                     -> IO BuildStatus
    dryRunTarballPkg pkg depsBuildStatus tarball =
292
      case elabBuildStyle pkg of
Duncan Coutts's avatar
Duncan Coutts committed
293
294
295
296
297
298
299
300
301
302
303
        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
304
                   -> [BuildStatus]
Duncan Coutts's avatar
Duncan Coutts committed
305
306
307
308
309
310
311
312
313
314
315
316
317
                   -> 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.
318
319
          Right buildResult ->
            return (BuildStatusUpToDate buildResult)
Duncan Coutts's avatar
Duncan Coutts committed
320
321
      where
        packageFileMonitor =
322
          newPackageFileMonitor distDirLayout (elabDistDirParams shared pkg)
Duncan Coutts's avatar
Duncan Coutts committed
323
324
325
326
327
328
329
330
331
332
333


-- | 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
334
  :: forall m ipkg srcpkg b.
335
     (Monad m, IsUnit ipkg, IsUnit srcpkg)
336
337
  => GenericInstallPlan ipkg srcpkg
  -> (GenericPlanPackage ipkg srcpkg ->
338
      [b] -> m b)
339
  -> m (Map UnitId b)
Duncan Coutts's avatar
Duncan Coutts committed
340
341
342
foldMInstallPlanDepOrder plan0 visit =
    go Map.empty (InstallPlan.reverseTopologicalOrder plan0)
  where
343
    go :: Map UnitId b
344
       -> [GenericPlanPackage ipkg srcpkg]
345
       -> m (Map UnitId b)
Duncan Coutts's avatar
Duncan Coutts committed
346
347
348
349
    go !results [] = return results

    go !results (pkg : pkgs) = do
      -- we go in the right order so the results map has entries for all deps
350
      let depresults :: [b]
Duncan Coutts's avatar
Duncan Coutts committed
351
          depresults =
352
353
            map (\ipkgid -> let Just result = Map.lookup ipkgid results
                              in result)
354
                (InstallPlan.depends pkg)
Duncan Coutts's avatar
Duncan Coutts committed
355
      result <- visit pkg depresults
356
      let results' = Map.insert (nodeKey pkg) result results
Duncan Coutts's avatar
Duncan Coutts committed
357
358
359
360
361
362
      go results' pkgs

improveInstallPlanWithUpToDatePackages :: ElaboratedInstallPlan
                                       -> BuildStatusMap
                                       -> ElaboratedInstallPlan
improveInstallPlanWithUpToDatePackages installPlan pkgsBuildStatus =
363
    replaceWithPrePreExisting installPlan
364
      [ (installedUnitId pkg, mipkg)
Duncan Coutts's avatar
Duncan Coutts committed
365
366
      | InstallPlan.Configured pkg
          <- InstallPlan.reverseTopologicalOrder installPlan
367
368
      , let uid = installedUnitId pkg
            Just pkgBuildStatus = Map.lookup uid pkgsBuildStatus
369
      , BuildStatusUpToDate (BuildResult { buildResultLibInfo = mipkg })
370
          <- [pkgBuildStatus]
Duncan Coutts's avatar
Duncan Coutts committed
371
372
      ]
  where
373
    replaceWithPrePreExisting =
374
      foldl' (\plan (uid, mipkg) ->
375
376
377
                -- TODO: A grievous hack.  Better to have a special type
                -- of entry representing pre-existing executables.
                let stub_ipkg = Installed.emptyInstalledPackageInfo {
378
                                    Installed.installedUnitId = uid
379
380
                                }
                    ipkg = fromMaybe stub_ipkg mipkg
381
                in InstallPlan.preexisting uid ipkg plan)
Duncan Coutts's avatar
Duncan Coutts committed
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399


-----------------------------
-- 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 (),
400
       pkgFileMonitorBuild  :: FileMonitor (Set ComponentName) BuildResultMisc,
401
       pkgFileMonitorReg    :: FileMonitor () (Maybe InstalledPackageInfo)
Duncan Coutts's avatar
Duncan Coutts committed
402
403
     }

404
-- | This is all the components of the 'BuildResult' other than the
405
406
-- @['InstalledPackageInfo']@.
--
407
-- We have to split up the 'BuildResult' components since they get produced
408
409
-- at different times (or rather, when different things change).
--
410
type BuildResultMisc = (DocsResult, TestsResult)
411

412
413
newPackageFileMonitor :: DistDirLayout -> DistDirParams -> PackageFileMonitor
newPackageFileMonitor DistDirLayout{distPackageCacheFile} dparams =
Duncan Coutts's avatar
Duncan Coutts committed
414
415
    PackageFileMonitor {
      pkgFileMonitorConfig =
416
        newFileMonitor (distPackageCacheFile dparams "config"),
Duncan Coutts's avatar
Duncan Coutts committed
417
418
419

      pkgFileMonitorBuild =
        FileMonitor {
420
          fileMonitorCacheFile = distPackageCacheFile dparams "build",
Duncan Coutts's avatar
Duncan Coutts committed
421
422
423
424
425
426
          fileMonitorKeyValid  = \componentsToBuild componentsAlreadyBuilt ->
            componentsToBuild `Set.isSubsetOf` componentsAlreadyBuilt,
          fileMonitorCheckIfOnlyValueChanged = True
        },

      pkgFileMonitorReg =
427
        newFileMonitor (distPackageCacheFile dparams "registration")
Duncan Coutts's avatar
Duncan Coutts committed
428
429
430
431
432
433
434
435
436
437
    }

-- | 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)
438
439
packageFileMonitorKeyValues elab =
    (elab_config, buildComponents)
Duncan Coutts's avatar
Duncan Coutts committed
440
441
442
443
444
445
446
447
  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.
    --
448
449
450
451
452
453
    elab_config =
        elab {
            elabBuildTargets = [],
            elabReplTarget    = Nothing,
            elabBuildHaddocks = False
        }
Duncan Coutts's avatar
Duncan Coutts committed
454
455
456
457
458

    -- 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.
    --
459
    buildComponents = elabBuildTargetWholeComponents elab
Duncan Coutts's avatar
Duncan Coutts committed
460
461
462
463
464
465
466

-- | Do all the checks on whether a package has changed and thus needs either
-- rebuilding or reconfiguring and rebuilding.
--
checkPackageFileMonitorChanged :: PackageFileMonitor
                               -> ElaboratedConfiguredPackage
                               -> FilePath
467
                               -> [BuildStatus]
468
                               -> IO (Either BuildStatusRebuild BuildResult)
Duncan Coutts's avatar
Duncan Coutts committed
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
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.
484
        | any buildStatusRequiresBuild depsBuildStatus -> do
Duncan Coutts's avatar
Duncan Coutts committed
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
            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

522
              (MonitorUnchanged buildResult _, MonitorUnchanged mipkg _) ->
523
524
525
                  return $ Right BuildResult {
                    buildResultDocs    = docsResult,
                    buildResultTests   = testsResult,
526
                    buildResultLogFile = Nothing,
527
                    buildResultLibInfo = mipkg
528
                  }
529
                where
530
                  (docsResult, testsResult) = buildResult
Duncan Coutts's avatar
Duncan Coutts committed
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
  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]
554
                              -> BuildResultMisc
Duncan Coutts's avatar
Duncan Coutts committed
555
556
557
                              -> IO ()
updatePackageBuildFileMonitor PackageFileMonitor{pkgFileMonitorBuild}
                              srcdir timestamp pkg pkgBuildStatus
558
                              allSrcFiles buildResult =
Duncan Coutts's avatar
Duncan Coutts committed
559
    updateFileMonitor pkgFileMonitorBuild srcdir (Just timestamp)
560
                      (map monitorFileHashed allSrcFiles)
561
                      buildComponents' buildResult
Duncan Coutts's avatar
Duncan Coutts committed
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
  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
580
                            -> Maybe InstalledPackageInfo
Duncan Coutts's avatar
Duncan Coutts committed
581
582
                            -> IO ()
updatePackageRegFileMonitor PackageFileMonitor{pkgFileMonitorReg}
583
                            srcdir mipkg =
Duncan Coutts's avatar
Duncan Coutts committed
584
    updateFileMonitor pkgFileMonitorReg srcdir Nothing
585
                      [] () mipkg
Duncan Coutts's avatar
Duncan Coutts committed
586
587
588
589
590
591
592
593
594
595

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


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

596
597
598
599
600
601
602
603
604
605
606
607
608
609
-- | 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,
610
       buildResultLogFile :: Maybe FilePath,
611
612
613
614
615
616
617
618
619
       -- | If the build was for a library, this field will be @Just@;
       -- otherwise, it will be @Nothing@.  What about internal
       -- libraries?  This never occurs, because a build result is either
       -- for a per-component build (in which case there won't
       -- be multiple libraries), or a package with no internal
       -- libraries (internal libraries with Custom setups are NOT
       -- supported, and even if they were supported, we could
       -- assume the Cabal library version was recent enough to
       -- support per-component build.).
620
       buildResultLibInfo :: Maybe InstalledPackageInfo
621
622
623
624
625
     }
  deriving Show

-- | Information arising from the failure to build a single package.
--
626
627
628
629
data BuildFailure = BuildFailure {
       buildFailureLogFile :: Maybe FilePath,
       buildFailureReason  :: BuildFailureReason
     }
630
631
632
  deriving (Show, Typeable)

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

634
635
-- | Detail on the reason that a package failed to build.
--
636
data BuildFailureReason = DependentFailed PackageId
637
638
639
640
                        | DownloadFailed  SomeException
                        | UnpackFailed    SomeException
                        | ConfigureFailed SomeException
                        | BuildFailed     SomeException
641
642
                        | ReplFailed      SomeException
                        | HaddocksFailed  SomeException
643
644
645
646
                        | TestsFailed     SomeException
                        | InstallFailed   SomeException
  deriving Show

Duncan Coutts's avatar
Duncan Coutts committed
647
648
-- | Build things for real.
--
Edward Z. Yang's avatar
Edward Z. Yang committed
649
-- It requires the 'BuildStatusMap' gathered by 'rebuildTargetsDryRun'.
Duncan Coutts's avatar
Duncan Coutts committed
650
651
652
653
654
655
656
--
rebuildTargets :: Verbosity
               -> DistDirLayout
               -> ElaboratedInstallPlan
               -> ElaboratedSharedConfig
               -> BuildStatusMap
               -> BuildTimeSettings
657
               -> IO BuildOutcomes
Duncan Coutts's avatar
Duncan Coutts committed
658
659
660
rebuildTargets verbosity
               distDirLayout@DistDirLayout{..}
               installPlan
661
662
663
664
               sharedPackageConfig@ElaboratedSharedConfig {
                 pkgConfigCompiler      = compiler,
                 pkgConfigCompilerProgs = progdb
               }
Duncan Coutts's avatar
Duncan Coutts committed
665
               pkgsBuildStatus
666
667
668
669
               buildSettings@BuildTimeSettings{
                 buildSettingNumJobs,
                 buildSettingKeepGoing
               } = do
Duncan Coutts's avatar
Duncan Coutts committed
670
671
672

    -- Concurrency control: create the job controller and concurrency limits
    -- for downloading, building and installing.
673
674
675
    jobControl    <- if isParallelBuild
                       then newParallelJobControl buildSettingNumJobs
                       else newSerialJobControl
676
    registerLock  <- newLock -- serialise registration
Duncan Coutts's avatar
Duncan Coutts committed
677
678
679
    cacheLock     <- newLock -- serialise access to setup exe cache
                             --TODO: [code cleanup] eliminate setup exe cache

680
681
    createDirectoryIfMissingVerbose verbosity True distBuildRootDirectory
    createDirectoryIfMissingVerbose verbosity True distTempDirectory
682
    mapM_ (createPackageDBIfMissing verbosity compiler progdb) packageDBsToUse
Duncan Coutts's avatar
Duncan Coutts committed
683
684
685
686
687
688
689

    -- 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...
690
691
      InstallPlan.execute jobControl keepGoing
                          (BuildFailure Nothing . DependentFailed . packageId)
692
                          installPlan $ \pkg ->
693
        handle (return . Left) $ fmap Right $ --TODO: review exception handling
Duncan Coutts's avatar
Duncan Coutts committed
694

695
696
        let uid = installedUnitId pkg
            Just pkgBuildStatus = Map.lookup uid pkgsBuildStatus in
Duncan Coutts's avatar
Duncan Coutts committed
697
698
699
700
701

        rebuildTarget
          verbosity
          distDirLayout
          buildSettings downloadMap
702
          registerLock cacheLock
Duncan Coutts's avatar
Duncan Coutts committed
703
704
705
706
707
          sharedPackageConfig
          pkg
          pkgBuildStatus
  where
    isParallelBuild = buildSettingNumJobs >= 2
708
    keepGoing       = buildSettingKeepGoing
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
709
    withRepoCtx     = projectConfigWithBuilderRepoContext verbosity
Duncan Coutts's avatar
Duncan Coutts committed
710
                        buildSettings
711
712
713
    packageDBsToUse = -- all the package dbs we may need to create
      (Set.toList . Set.fromList)
        [ pkgdb
714
715
716
717
        | InstallPlan.Configured elab <- InstallPlan.toList installPlan
        , (pkgdb:_) <- map reverse [ elabBuildPackageDBStack elab,
                                     elabRegisterPackageDBStack elab,
                                     elabSetupPackageDBStack elab ]
718
        ]
Duncan Coutts's avatar
Duncan Coutts committed
719
720
721
722
723
724

-- | Given all the context and resources, (re)build an individual package.
--
rebuildTarget :: Verbosity
              -> DistDirLayout
              -> BuildTimeSettings
Duncan Coutts's avatar
Duncan Coutts committed
725
              -> AsyncFetchMap
726
              -> Lock -> Lock
Duncan Coutts's avatar
Duncan Coutts committed
727
728
729
              -> ElaboratedSharedConfig
              -> ElaboratedReadyPackage
              -> BuildStatus
730
              -> IO BuildResult
Duncan Coutts's avatar
Duncan Coutts committed
731
732
733
rebuildTarget verbosity
              distDirLayout@DistDirLayout{distBuildDirectory}
              buildSettings downloadMap
734
              registerLock cacheLock
Duncan Coutts's avatar
Duncan Coutts committed
735
              sharedPackageConfig
736
              rpkg@(ReadyPackage pkg)
Duncan Coutts's avatar
Duncan Coutts committed
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
              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
752
        downsrcloc <- annotateFailureNoLog DownloadFailed $
753
                        waitAsyncPackageDownload verbosity downloadMap pkg
Duncan Coutts's avatar
Duncan Coutts committed
754
755
756
757
758
759
760
761
        case downsrcloc of
          DownloadedTarball tarball -> unpackTarballPhase tarball
          --TODO: [nice to have] git/darcs repos etc


    unpackTarballPhase tarball =
        withTarballLocalDirectory
          verbosity distDirLayout tarball
762
763
          (packageId pkg) (elabDistDirParams sharedPackageConfig pkg) (elabBuildStyle pkg)
          (elabPkgDescriptionOverride pkg) $
Duncan Coutts's avatar
Duncan Coutts committed
764

765
          case elabBuildStyle pkg of
Duncan Coutts's avatar
Duncan Coutts committed
766
767
768
769
770
771
772
773
774
775
            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 =
776
        assert (elabBuildStyle pkg == BuildInplaceOnly) $
Duncan Coutts's avatar
Duncan Coutts committed
777
778
779

          buildInplace buildStatus srcdir builddir
      where
780
        builddir = distBuildDirectory (elabDistDirParams sharedPackageConfig pkg)
Duncan Coutts's avatar
Duncan Coutts committed
781
782
783
784

    buildAndInstall srcdir builddir =
        buildAndInstallUnpackedPackage
          verbosity distDirLayout
785
          buildSettings registerLock cacheLock
Duncan Coutts's avatar
Duncan Coutts committed
786
787
788
789
790
791
792
793
794
795
796
          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
797
          buildSettings registerLock cacheLock
Duncan Coutts's avatar
Duncan Coutts committed
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
          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
816
                      -> ((RepoContext -> IO a) -> IO a)
Duncan Coutts's avatar
Duncan Coutts committed
817
818
                      -> ElaboratedInstallPlan
                      -> BuildStatusMap
Duncan Coutts's avatar
Duncan Coutts committed
819
                      -> (AsyncFetchMap -> IO a)
Duncan Coutts's avatar
Duncan Coutts committed
820
821
822
                      -> IO a
asyncDownloadPackages verbosity withRepoCtx installPlan pkgsBuildStatus body
  | null pkgsToDownload = body Map.empty
Duncan Coutts's avatar
Duncan Coutts committed
823
824
825
  | otherwise           = withRepoCtx $ \repoctx ->
                            asyncFetchPackages verbosity repoctx
                                               pkgsToDownload body
Duncan Coutts's avatar
Duncan Coutts committed
826
  where
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
827
    pkgsToDownload =
828
      ordNub $
829
830
      [ elabPkgSourceLocation elab
      | InstallPlan.Configured elab
Duncan Coutts's avatar
Duncan Coutts committed
831
         <- InstallPlan.reverseTopologicalOrder installPlan
832
      , let uid = installedUnitId elab
833
            Just pkgBuildStatus = Map.lookup uid pkgsBuildStatus
Duncan Coutts's avatar
Duncan Coutts committed
834
835
836
837
838
      , BuildStatusDownload <- [pkgBuildStatus]
      ]


-- | Check if a package needs downloading, and if so expect to find a download
Duncan Coutts's avatar
Duncan Coutts committed
839
-- in progress in the given 'AsyncFetchMap' and wait on it to finish.
Duncan Coutts's avatar
Duncan Coutts committed
840
841
--
waitAsyncPackageDownload :: Verbosity
Duncan Coutts's avatar
Duncan Coutts committed
842
                         -> AsyncFetchMap
Duncan Coutts's avatar
Duncan Coutts committed
843
844
                         -> ElaboratedConfiguredPackage
                         -> IO DownloadedSourceLocation
845
waitAsyncPackageDownload verbosity downloadMap elab = do
Duncan Coutts's avatar
Duncan Coutts committed
846
    pkgloc <- waitAsyncFetchPackage verbosity downloadMap
847
                                    (elabPkgSourceLocation elab)
Duncan Coutts's avatar
Duncan Coutts committed
848
849
850
851
852
853
854
855
856
857
858
859
860
861
    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
862
863
864
865
866




-- | Ensure that the package is unpacked in an appropriate directory, either
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
867
-- a temporary one or a persistent one under the shared dist directory.
Duncan Coutts's avatar
Duncan Coutts committed
868
869
870
871
872
873
--
withTarballLocalDirectory
  :: Verbosity
  -> DistDirLayout
  -> FilePath
  -> PackageId
874
  -> DistDirParams
Duncan Coutts's avatar
Duncan Coutts committed
875
876
  -> BuildStyle
  -> Maybe CabalFileText
877
878
879
  -> (FilePath -> -- Source directory
      FilePath -> -- Build directory
      IO a)
Duncan Coutts's avatar
Duncan Coutts committed
880
881
  -> IO a
withTarballLocalDirectory verbosity distDirLayout@DistDirLayout{..}
882
                          tarball pkgid dparams buildstyle pkgTextOverride
Duncan Coutts's avatar
Duncan Coutts committed
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
                          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
902
              builddir   = distBuildDirectory dparams
Duncan Coutts's avatar
Duncan Coutts committed
903
904
905
          -- TODO: [nice to have] use a proper file monitor rather than this dir exists test
          exists <- doesDirectoryExist srcdir
          unless exists $ do
906
            createDirectoryIfMissingVerbose verbosity True srcrootdir
Duncan Coutts's avatar
Duncan Coutts committed
907
908
909
            unpackPackageTarball verbosity tarball srcrootdir
                                 pkgid pkgTextOverride
            moveTarballShippedDistDirectory verbosity distDirLayout
910
                                            srcrootdir pkgid dparams
Duncan Coutts's avatar
Duncan Coutts committed
911
912
913
914
915
916
917
918
          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
919
    annotateFailureNoLog UnpackFailed $ do
Duncan Coutts's avatar
Duncan Coutts committed
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
948
949
950
951
952
953
954
955

      -- 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
956
                                -> FilePath -> PackageId -> DistDirParams -> IO ()
Duncan Coutts's avatar
Duncan Coutts committed
957
moveTarballShippedDistDirectory verbosity DistDirLayout{distBuildDirectory}
958
                                parentdir pkgid dparams = do
Duncan Coutts's avatar
Duncan Coutts committed
959
960
961
962
963
964
965
966
    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"
967
    targetDistDir  = distBuildDirectory dparams
Duncan Coutts's avatar
Duncan Coutts committed
968
969
970
971
972
973
974
975


buildAndInstallUnpackedPackage :: Verbosity
                               -> DistDirLayout
                               -> BuildTimeSettings -> Lock -> Lock
                               -> ElaboratedSharedConfig
                               -> ElaboratedReadyPackage
                               -> FilePath -> FilePath
976
                               -> IO BuildResult
Duncan Coutts's avatar
Duncan Coutts committed
977
978
979
980
981
982
buildAndInstallUnpackedPackage verbosity
                               DistDirLayout{distTempDirectory}
                               BuildTimeSettings {
                                 buildSettingNumJobs,
                                 buildSettingLogFile
                               }
983
                               registerLock cacheLock
Duncan Coutts's avatar
Duncan Coutts committed
984
                               pkgshared@ElaboratedSharedConfig {
985
986
987
                                 pkgConfigPlatform      = platform,
                                 pkgConfigCompiler      = compiler,
                                 pkgConfigCompilerProgs = progdb
Duncan Coutts's avatar
Duncan Coutts committed
988
                               }
989
                               rpkg@(ReadyPackage pkg)
Duncan Coutts's avatar
Duncan Coutts committed
990
991
                               srcdir builddir = do

992
    createDirectoryIfMissingVerbose verbosity True builddir
Duncan Coutts's avatar
Duncan Coutts committed
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
    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

1005
    let dispname = case elabPkgOrComp pkg of
1006
1007
            ElabPackage _ -> display pkgid
            ElabComponent comp -> display pkgid ++ " "
1008
                ++ maybe "custom" display (compComponentName comp)
1009

Duncan Coutts's avatar
Duncan Coutts committed
1010
1011
    -- Configure phase
    when isParallelBuild $
1012
      notice verbosity $ "Configuring " ++ dispname ++ "..."
1013
    annotateFailure mlogFile ConfigureFailed $
1014
      setup' configureCommand configureFlags configureArgs
Duncan Coutts's avatar
Duncan Coutts committed
1015
1016
1017

    -- Build phase
    when isParallelBuild $
1018
      notice verbosity $ "Building " ++ dispname ++ "..."
1019
    annotateFailure mlogFile BuildFailed $
Duncan Coutts's avatar
Duncan Coutts committed
1020
1021
1022
      setup buildCommand buildFlags

    -- Install phase
1023
    mipkg <-
1024
      annotateFailure mlogFile InstallFailed $ do
Duncan Coutts's avatar
Duncan Coutts committed
1025
1026
1027
1028
1029
1030
1031
1032
1033
      --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
1034

Duncan Coutts's avatar
Duncan Coutts committed
1035
      LBS.writeFile
1036
        (InstallDirs.prefix (elabInstallDirs pkg) </> "cabal-hash.txt") $
Duncan Coutts's avatar
Duncan Coutts committed
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
        (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.

1047
      if elabRequiresRegistration pkg
Duncan Coutts's avatar
Duncan Coutts committed
1048
1049
1050
1051
        then do
          -- 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.
1052
          ipkg0 <- generateInstalledPackageInfo
1053
          let ipkg = ipkg0 { Installed.installedUnitId = uid }
1054

1055
          criticalSection registerLock $
1056
1057
              Cabal.registerPackage verbosity compiler progdb
                                    HcPkg.MultiInstance
1058
                                    (elabRegisterPackageDBStack pkg) ipkg
1059
1060
          return (Just ipkg)
        else return Nothing
Duncan Coutts's avatar
Duncan Coutts committed
1061
1062
1063
1064
1065

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

1066
1067
1068
    return BuildResult {
       buildResultDocs    = docsResult,
       buildResultTests   = testsResult,
1069
       buildResultLogFile = mlogFile,
1070
       buildResultLibInfo = mipkg
1071
    }
Duncan Coutts's avatar
Duncan Coutts committed
1072
1073
1074

  where
    pkgid  = packageId rpkg
1075
    uid = installedUnitId rpkg
Duncan Coutts's avatar
Duncan Coutts committed
1076
1077
1078
1079
1080
1081
1082

    isParallelBuild = buildSettingNumJobs >= 2

    configureCommand = Cabal.configureCommand defaultProgramConfiguration
    configureFlags v = flip filterConfigureFlags v $
                       setupHsConfigureFlags rpkg pkgshared
                                             verbosity builddir
1083
    configureArgs    = setupHsConfigureArgs pkg
Duncan Coutts's avatar
Duncan Coutts committed
1084
1085
1086
1087

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

1088
1089
1090
    generateInstalledPackageInfo :: IO InstalledPackageInfo
    generateInstalledPackageInfo =
      withTempInstalledPackageInfoFile
1091
        verbosity distTempDirectory $ \pkgConfDest -> do
Duncan Coutts's avatar
Duncan Coutts committed
1092
1093
1094
        let registerFlags _ = setupHsRegisterFlags
                                pkg pkgshared
                                verbosity builddir
1095
                                pkgConfDest
Duncan Coutts's avatar
Duncan Coutts committed
1096
1097
1098
1099
1100
1101
1102
1103
        setup Cabal.registerCommand registerFlags

    copyFlags _ = setupHsCopyFlags pkg pkgshared verbosity builddir

    scriptOptions = setupHsScriptOptions rpkg pkgshared srcdir builddir
                                         isParallelBuild cacheLock

    setup :: CommandUI flags -> (Version -> flags) -> IO ()
1104
1105
1106
1107
    setup cmd flags = setup' cmd flags []

    setup' :: CommandUI flags -> (Version -> flags) -> [String] -> IO ()
    setup' cmd flags args =
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
1108
      withLogging $ \mLogFileHandle ->
Duncan Coutts's avatar
Duncan Coutts committed
1109
1110
1111
        setupWrapper
          verbosity
          scriptOptions { useLoggingHandle = mLogFileHandle }
1112
          (Just (elabPkgDescription pkg))
1113
          cmd flags args
Duncan Coutts's avatar
Duncan Coutts committed
1114

1115
    mlogFile :: Maybe FilePath
Duncan Coutts's avatar
Duncan Coutts committed
1116
1117
1118
    mlogFile =
      case buildSettingLogFile of
        Nothing        -> Nothing
1119
        Just mkLogFile -> Just (mkLogFile compiler platform pkgid uid)
Duncan Coutts's avatar
Duncan Coutts committed
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136

    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
1137
                            -> BuildTimeSettings -> Lock -> Lock
Duncan Coutts's avatar
Duncan Coutts committed
1138
1139
1140
1141
                            -> ElaboratedSharedConfig
                            -> ElaboratedReadyPackage
                            -> BuildStatusRebuild
                            -> FilePath -> FilePath
1142
                            -> IO BuildResult
Duncan Coutts's avatar
Duncan Coutts committed
1143
1144
1145
1146
1147
1148
buildInplaceUnpackedPackage verbosity
                            distDirLayout@DistDirLayout {
                              distTempDirectory,
                              distPackageCacheDirectory
                            }
                            BuildTimeSettings{buildSettingNumJobs}
1149
                            registerLock cacheLock
Duncan Coutts's avatar
Duncan Coutts committed
1150
                            pkgshared@ElaboratedSharedConfig {
1151
1152
                              pkgConfigCompiler      = compiler,
                              pkgConfigCompilerProgs = progdb
Duncan Coutts's avatar
Duncan Coutts committed
1153
                            }
1154
                            rpkg@(ReadyPackage pkg)
Duncan Coutts's avatar
Duncan Coutts committed
1155
1156
1157
1158
1159
                            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
1160
1161
        createDirectoryIfMissingVerbose verbosity True builddir
        createDirectoryIfMissingVerbose verbosity True (distPackageCacheDirectory dparams)
Duncan Coutts's avatar
Duncan Coutts committed
1162
1163
1164
1165

        -- Configure phase
        --
        whenReConfigure $ do
1166
          annotateFailureNoLog ConfigureFailed $
1167
            setup configureCommand configureFlags configureArgs
Duncan Coutts's avatar
Duncan Coutts committed
1168
1169
1170
1171
1172
1173
1174
1175
          invalidatePackageRegFileMonitor packageFileMonitor
          updatePackageConfigFileMonitor packageFileMonitor srcdir pkg

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

1176
1177
            buildResult :: BuildResultMisc
            buildResult = (docsResult, testsResult)
Duncan Coutts's avatar
Duncan Coutts committed
1178
1179
1180

        whenRebuild $ do
          timestamp <- beginUpdateFileMonitor
1181
          annotateFailureNoLog BuildFailed $
1182
            setup buildCommand buildFlags buildArgs
Duncan Coutts's avatar
Duncan Coutts committed
1183

1184
1185
1186
          --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.
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
          allSrcFiles <-
            let trySdist    = allPackageSourceFiles verbosity scriptOptions srcdir
                -- This is just a hack, to get semi-reasonable file
                -- listings for the monitor
                tryFallback = do
                    warn verbosity $
                        "Couldn't use sdist to compute source files; falling " ++
                        "back on recursive file scan."
                    filter (not . ("dist" `isPrefixOf`))
                        `fmap` getDirectoryContentsRecursive srcdir
            in if elabSetupScriptCliVersion pkg >= Version [1,17] []
                  then do r <- trySdist
                          if null r
                            then tryFallback
                            else return r
                  else tryFallback
Duncan Coutts's avatar
Duncan Coutts committed
1203
1204
1205

          updatePackageBuildFileMonitor packageFileMonitor srcdir timestamp
                                        pkg buildStatus
1206
                                        allSrcFiles buildResult
Duncan Coutts's avatar
Duncan Coutts committed
1207

1208
1209
        -- PURPOSELY omitted: no copy!

1210
        mipkg <- whenReRegister $
1211
                 annotateFailureNoLog InstallFailed $ do
Duncan Coutts's avatar
Duncan Coutts committed
1212
          -- Register locally
1213
          mipkg <- if elabRequiresRegistration pkg
Duncan Coutts's avatar
Duncan Coutts committed
1214
            then do
1215
                ipkg0 <- generateInstalledPackageInfo
Duncan Coutts's avatar
Duncan Coutts committed
1216
1217
1218
                -- 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.
1219
                let ipkg = ipkg0 { Installed.installedUnitId = ipkgid }
1220
                criticalSection registerLock $
1221
                    Cabal.registerPackage verbosity compiler progdb HcPkg.NoMultiInstance
1222
                                          (elabRegisterPackageDBStack pkg)
1223
1224
                                          ipkg
                return (Just ipkg)
1225

1226
           else return Nothing
1227

1228
1229
          updatePackageRegFileMonitor packageFileMonitor srcdir mipkg
          return mipkg
Duncan Coutts's avatar
Duncan Coutts committed
1230
1231
1232
1233

        -- Repl phase
        --
        whenRepl $
1234
          annotateFailureNoLog ReplFailed $
Duncan Coutts's avatar
Duncan Coutts committed
1235
1236
1237
1238
          setup replCommand replFlags replArgs

        -- Haddock phase
        whenHaddock $
1239
          annotateFailureNoLog HaddocksFailed $
Duncan Coutts's avatar
Duncan Coutts committed
1240
1241
          setup haddockCommand haddockFlags []

1242
1243
1244
        return BuildResult {
          buildResultDocs    = docsResult,
          buildResultTests   = testsResult,
1245
          buildResultLogFile = Nothing,
1246
          buildResultLibInfo = mipkg
1247
        }
Duncan Coutts's avatar
Duncan Coutts committed
1248
1249

  where
1250
1251
    ipkgid  = installedUnitId pkg
    dparams = elabDistDirParams pkgshared pkg
Duncan Coutts's avatar
Duncan Coutts committed
1252
1253
1254

    isParallelBuild = buildSettingNumJobs >= 2

1255
    packageFileMonitor = newPackageFileMonitor distDirLayout dparams
Duncan Coutts's avatar
Duncan Coutts committed
1256
1257
1258
1259
1260
1261

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

    whenRebuild action
1262
      | null (elabBuildTargets pkg) = return ()
Duncan Coutts's avatar
Duncan Coutts committed
1263
1264
1265
      | otherwise                  = action

    whenRepl action
1266
      | isNothing (elabReplTarget pkg) = return ()
Duncan Coutts's avatar
Duncan Coutts committed
1267
1268
1269
      | otherwise                     = action

    whenHaddock action
1270
      | elabBuildHaddocks pkg = action
Duncan Coutts's avatar
Duncan Coutts committed
1271
1272
1273
1274
1275
      | otherwise            = return ()

    whenReRegister  action = case buildStatus of
      BuildStatusConfigure          _ -> action
      BuildStatusBuild Nothing      _ -> action
1276
      BuildStatusBuild (Just mipkg) _ -> return mipkg
Duncan Coutts's avatar
Duncan Coutts committed
1277
1278
1279
1280
1281

    configureCommand = Cabal.configureCommand defaultProgramConfiguration
    configureFlags v = flip filterConfigureFlags v $
                       setupHsConfigureFlags rpkg pkgshared
                                             verbosity builddir
1282
    configureArgs    = setupHsConfigureArgs pkg
Duncan Coutts's avatar
Duncan Coutts committed
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305

    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
1306
                   (Just (elabPkgDescription pkg))
Duncan Coutts's avatar
Duncan Coutts committed
1307
1308
                   cmd flags args

1309
1310
1311
    generateInstalledPackageInfo :: IO InstalledPackageInfo
    generateInstalledPackageInfo =
      withTempInstalledPackageInfoFile
1312
        verbosity distTempDirectory $ \pkgConfDest -> do
Duncan Coutts's avatar
Duncan Coutts committed
1313
1314
1315
        let registerFlags _ = setupHsRegisterFlags
                                pkg pkgshared
                                verbosity builddir
1316
                                pkgConfDest
Duncan Coutts's avatar
Duncan Coutts committed
1317
1318
1319
1320
        setup Cabal.registerCommand registerFlags []


-- helper
1321
1322
1323
1324
1325
1326
1327
1328
1329
annotateFailureNoLog :: (SomeException -> BuildFailureReason)
                     -> IO a -> IO a
annotateFailureNoLog annotate action =
  annotateFailure Nothing annotate action

annotateFailure :: Maybe FilePath
                -> (SomeException -> BuildFailureReason)
                -> IO a -> IO a
annotateFailure mlogFile annotate action =
Duncan Coutts's avatar
Duncan Coutts committed
1330
  action `catches`
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
    -- 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
1341
1342
1343
    ]
  where
    handler :: Exception e => e -> IO a