UnpackedPackage.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -Wno-redundant-constraints #-}

-- | This module exposes functions to build and register unpacked packages.
--
-- Mainly, unpacked packages are either:
--  * Built and registered in-place
--  * Built and installed
--
-- The two cases differ significantly for there to be a distinction.
-- For instance, we only care about file monitoring and re-building when dealing
-- with "inplace" registered packages, whereas for installed packages we don't.
module Distribution.Client.ProjectBuilding.UnpackedPackage
  ( buildInplaceUnpackedPackage
  , buildAndInstallUnpackedPackage

    -- ** Auxiliary definitions
  , buildAndRegisterUnpackedPackage
  , PackageBuildingPhase

    -- ** Utilities
  , annotateFailure
  , annotateFailureNoLog
  ) where

import Distribution.Client.Compat.Prelude
import Prelude ()

import Distribution.Client.PackageHash (renderPackageHashInputs)
import Distribution.Client.ProjectBuilding.Types
import Distribution.Client.ProjectConfig
import Distribution.Client.ProjectConfig.Types
import Distribution.Client.ProjectPlanning
import Distribution.Client.ProjectPlanning.Types
import Distribution.Client.RebuildMonad
import Distribution.Client.Store

import Distribution.Client.DistDirLayout
import Distribution.Client.FileMonitor
import Distribution.Client.JobControl
import Distribution.Client.Setup
  ( CommonSetupFlags
  , filterBenchmarkFlags
  , filterBuildFlags
  , filterConfigureFlags
  , filterCopyFlags
  , filterHaddockArgs
  , filterHaddockFlags
  , filterRegisterFlags
  , filterReplFlags
  , filterTestFlags
  )
import Distribution.Client.SetupWrapper
import Distribution.Client.SourceFiles
import Distribution.Client.SrcDist (allPackageSourceFiles)
import qualified Distribution.Client.Tar as Tar
import Distribution.Client.Types hiding
  ( BuildFailure (..)
  , BuildOutcome
  , BuildOutcomes
  , BuildResult (..)
  )
import Distribution.Client.Utils
  ( ProgressPhase (..)
  , progressMessage
  )

import Distribution.Compat.Lens
import Distribution.InstalledPackageInfo (InstalledPackageInfo)
import qualified Distribution.InstalledPackageInfo as Installed
import Distribution.Package
import qualified Distribution.PackageDescription as PD
import Distribution.Simple.BuildPaths (haddockDirName)
import Distribution.Simple.Command (CommandUI)
import Distribution.Simple.Compiler
  ( PackageDBStackCWD
  , coercePackageDBStack
  )
import qualified Distribution.Simple.Configure as Cabal
import qualified Distribution.Simple.InstallDirs as InstallDirs
import Distribution.Simple.LocalBuildInfo
  ( ComponentName (..)
  , LibraryName (..)
  )
import qualified Distribution.Simple.LocalBuildInfo as Cabal
import Distribution.Simple.PackageIndex (InstalledPackageIndex)
import qualified Distribution.Simple.PackageIndex as PackageIndex
import Distribution.Simple.Program
import qualified Distribution.Simple.Register as Cabal
import qualified Distribution.Simple.Setup as Cabal
import Distribution.Types.BuildType
import Distribution.Types.PackageDescription.Lens (componentModules)

import Distribution.Client.Errors
import Distribution.Simple.Utils
import Distribution.System (Platform (..))
import Distribution.Utils.Path hiding
  ( (<.>)
  , (</>)
  )
import Distribution.Verbosity (setVerbosityHandles)
import Distribution.Version

import Distribution.Client.ProjectBuilding.PackageFileMonitor

import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.Lazy.Char8 as LBS.Char8
import qualified Data.List.NonEmpty as NE

import Control.Concurrent.STM (TVar, atomically, modifyTVar)
import Control.Exception (ErrorCall, Handler (..), SomeAsyncException, assert, catches, onException)
import Data.IORef (newIORef, readIORef, writeIORef)
import System.Directory (canonicalizePath, createDirectoryIfMissing, doesDirectoryExist, listDirectory)
import System.FilePath (dropDrive, normalise, takeDirectory, (<.>), (</>))
import System.IO (Handle, IOMode (AppendMode), withFile)
import System.Semaphore (SemaphoreIdentifier)

import GHC.Stack
import Web.Browser (openBrowser)

-- | Each unpacked package is processed in the following phases:
--
-- * Configure phase
-- * Build phase
-- * Haddock phase
-- * Install phase (copy + register)
-- * Register phase
-- * Test phase
-- * Bench phase
-- * Repl phase
--
-- Depending on whether we are installing the package or building it inplace,
-- the phases will be carried out differently. For example, when installing,
-- the test, benchmark, and repl phase are ignored.
data PackageBuildingPhase r where
  PBConfigurePhase :: {runConfigure :: IO InLibraryLBI} -> PackageBuildingPhase InLibraryLBI
  PBBuildPhase :: {runBuild :: IO [MonitorFilePath]} -> PackageBuildingPhase ()
  PBHaddockPhase :: {runHaddock :: IO [MonitorFilePath]} -> PackageBuildingPhase ()
  PBReplPhase :: {runRepl :: IO [MonitorFilePath]} -> PackageBuildingPhase ()
  PBInstallPhase
    :: { runCopy :: FilePath -> IO ()
       , runRegister
          :: PackageDBStackCWD
          -> Cabal.RegisterOptions
          -> IO InstalledPackageInfo
       , getInstalledPackageInfo :: IO InstalledPackageInfo
        -- ^ Compute the 'InstalledPackageInfo' from the build output,
        -- without registering with @ghc-pkg@. Deterministic.
       }
    -> PackageBuildingPhase ()
  PBTestPhase :: {runTest :: IO ()} -> PackageBuildingPhase ()
  PBBenchPhase :: {runBench :: IO ()} -> PackageBuildingPhase ()

-- | Structures the phases of building and registering a package amongst others
-- (see t'PackageBuildingPhase'). Delegates logic specific to a certain
-- building style (notably, inplace vs install) to the delegate function that
-- receives as an argument t'PackageBuildingPhase')
buildAndRegisterUnpackedPackage
  :: Verbosity
  -> DistDirLayout
  -> Maybe SemaphoreIdentifier
  -- ^ Whether to pass a semaphore to build process
  -- this is different to BuildTimeSettings because the
  -- name of the semaphore is created freshly each time.
  -> BuildTimeSettings
  -> Lock
  -> Lock
  -> ElaboratedSharedConfig
  -> ElaboratedInstallPlan
  -> ElaboratedReadyPackage
  -> TVar InstalledPackageIndex
  -- ^ Running 'InstalledPackageIndex', updated as @cabal-install@ registers
  -- packages
  -> SymbolicPath CWD (Dir Pkg)
  -> SymbolicPath Pkg (Dir Dist)
  -> Maybe FilePath
  -- ^ The path to an /initialized/ log file
  -> (forall r. PackageBuildingPhase r -> IO r)
  -> IO ()
buildAndRegisterUnpackedPackage
  verbosity
  distDirLayout@DistDirLayout{distTempDirectory}
  maybe_semaphore
  buildTimeSettings@BuildTimeSettings{buildSettingKeepTempFiles}
  registerLock
  cacheLock
  pkgshared@ElaboratedSharedConfig
    { pkgConfigCompiler = compiler
    , pkgConfigCompilerProgs = progdb
    }
  plan
  rpkg@(ReadyPackage pkg)
  ipiTVar
  srcdir
  builddir
  mlogFile
  delegate = do
    -- Configure phase
    mbLBI <-
      delegate $
        PBConfigurePhase $
          annotateFailure mlogFile ConfigureFailed $
            setup
              configureCommand
              Cabal.configCommonFlags
              configureFlags
              configureArgs
              (InLibraryArgs $ InLibraryConfigureArgs pkgshared rpkg ipiTVar)

    -- Build phase
    delegate $
      PBBuildPhase $
        annotateFailure mlogFile BuildFailed $ do
          setup
            buildCommand
            Cabal.buildCommonFlags
            (return . buildFlags)
            buildArgs
            (InLibraryArgs $ InLibraryPostConfigureArgs SBuildPhase mbLBI)

    -- Haddock phase
    whenHaddock $
      delegate $
        PBHaddockPhase $
          annotateFailure mlogFile HaddocksFailed $ do
            setup
              haddockCommand
              Cabal.haddockCommonFlags
              (return . haddockFlags)
              haddockArgs
              (InLibraryArgs $ InLibraryPostConfigureArgs SHaddockPhase mbLBI)

    -- Install phase
    let getIpkg = do
          -- Grab and modify the InstalledPackageInfo. We decide what
          -- the installed package id is, not the build system.
          ipkg0 <- generateInstalledPackageInfo mbLBI
          return ipkg0{Installed.installedUnitId = uid}
    delegate $
      PBInstallPhase
        { runCopy = \destdir ->
            annotateFailure mlogFile InstallFailed $
              setup
                Cabal.copyCommand
                Cabal.copyCommonFlags
                (return . copyFlags destdir)
                copyArgs
                (InLibraryArgs $ InLibraryPostConfigureArgs SCopyPhase mbLBI)
        , runRegister = \pkgDBStack registerOpts ->
            annotateFailure mlogFile InstallFailed $ do
              -- We register ourselves, rather than via Setup.hs.
              ipkg <- getIpkg
              criticalSection registerLock $
                Cabal.registerPackage
                  verbosity
                  compiler
                  progdb
                  Nothing
                  (coercePackageDBStack pkgDBStack)
                  ipkg
                  registerOpts
              return ipkg
        , getInstalledPackageInfo = getIpkg
        }

    -- Test phase
    whenTest $
      delegate $
        PBTestPhase $
          annotateFailure mlogFile TestsFailed $
            setup
              testCommand
              Cabal.testCommonFlags
              (return . testFlags)
              testArgs
              (InLibraryArgs $ InLibraryPostConfigureArgs STestPhase mbLBI)

    -- Bench phase
    whenBench $
      delegate $
        PBBenchPhase $
          annotateFailure mlogFile BenchFailed $
            setup
              benchCommand
              Cabal.benchmarkCommonFlags
              (return . benchFlags)
              benchArgs
              (InLibraryArgs $ InLibraryPostConfigureArgs SBenchPhase mbLBI)

    -- Repl phase
    whenRepl $
      delegate $
        PBReplPhase $
          annotateFailure mlogFile ReplFailed $
            setupInteractive
              replCommand
              Cabal.replCommonFlags
              (return . replFlags)
              replArgs
              (InLibraryArgs $ InLibraryPostConfigureArgs SReplPhase mbLBI)

    return ()
    where
      uid = installedUnitId rpkg

      comp_par_strat = case maybe_semaphore of
        Just sem_ident -> Cabal.toFlag sem_ident
        _ -> Cabal.NoFlag

      whenTest action
        | null (elabTestTargets pkg) = return ()
        | otherwise = action

      whenBench action
        | null (elabBenchTargets pkg) = return ()
        | otherwise = action

      whenRepl action
        | null (elabReplTarget pkg) = return ()
        | otherwise = action

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

      mbWorkDir = useWorkingDir scriptOptions
      commonFlags targets =
        setupHsCommonFlags verbosity mbWorkDir builddir targets buildSettingKeepTempFiles

      configureCommand = Cabal.configureCommand defaultProgramDb
      configureFlags v =
        flip filterConfigureFlags v
          <$> setupHsConfigureFlags
            (fmap makeSymbolicPath . canonicalizePath)
            plan
            rpkg
            pkgshared
            (commonFlags $ configureArgs v)
      configureArgs _ = setupHsConfigureArgs pkg

      buildCommand = Cabal.buildCommand defaultProgramDb
      buildFlags v =
        flip filterBuildFlags v $
          setupHsBuildFlags
            comp_par_strat
            pkg
            pkgshared
            (commonFlags $ buildArgs v)
      buildArgs _ = setupHsBuildArgs pkg

      copyFlags destdir v =
        flip filterCopyFlags v $
          setupHsCopyFlags
            pkg
            pkgshared
            (commonFlags $ buildArgs v)
            destdir
      -- In theory, we could want to copy less things than those that were
      -- built, but instead, we simply copy the targets that were built.
      copyArgs = buildArgs

      testCommand = Cabal.testCommand -- defaultProgramDb
      testFlags v =
        flip filterTestFlags v $
          setupHsTestFlags
            pkg
            (commonFlags $ testArgs v)
      testArgs _ = setupHsTestArgs pkg

      benchCommand = Cabal.benchmarkCommand
      benchFlags v =
        flip filterBenchmarkFlags v $
          setupHsBenchFlags
            pkg
            pkgshared
            (commonFlags $ benchArgs v)
      benchArgs _ = setupHsBenchArgs pkg

      replCommand = Cabal.replCommand defaultProgramDb
      replFlags v =
        flip filterReplFlags v $
          setupHsReplFlags
            pkg
            pkgshared
            (commonFlags $ replArgs v)
      replArgs _ = setupHsReplArgs pkg

      haddockCommand = Cabal.haddockCommand
      haddockFlags v =
        flip filterHaddockFlags v $
          setupHsHaddockFlags
            pkg
            pkgshared
            buildTimeSettings
            (commonFlags $ haddockArgs v)
      haddockArgs v =
        flip filterHaddockArgs v $
          setupHsHaddockArgs pkg

      scriptOptions =
        setupHsScriptOptions
          rpkg
          plan
          pkgshared
          distDirLayout
          srcdir
          builddir
          cacheLock

      setup
        :: (HasCallStack, RightFlagsForPhase flags setupSpec)
        => CommandUI flags
        -> (flags -> CommonSetupFlags)
        -> (Version -> IO flags)
        -> (Version -> [String])
        -> SetupRunnerArgs setupSpec
        -> IO (SetupRunnerRes setupSpec)
      setup cmd getCommonFlags flags args wrapperArgs =
        withLogging $ \mLogFileHandle ->
          setupWrapper
            (setVerbosityHandles mLogFileHandle verbosity)
            scriptOptions
              { useLoggingHandle = mLogFileHandle
              , useExtraEnvOverrides =
                  dataDirsEnvironmentForPlan
                    distDirLayout
                    plan
              }
            (Just (elabPkgDescription pkg))
            cmd
            getCommonFlags
            flags
            args
            wrapperArgs

      setupInteractive
        :: RightFlagsForPhase flags setupSpec
        => CommandUI flags
        -> (flags -> CommonSetupFlags)
        -> (Version -> IO flags)
        -> (Version -> [String])
        -> SetupRunnerArgs setupSpec
        -> IO (SetupRunnerRes setupSpec)
      setupInteractive =
        setupWrapper
          verbosity
          scriptOptions{isInteractive = True}
          (Just (elabPkgDescription pkg))

      generateInstalledPackageInfo :: InLibraryLBI -> IO InstalledPackageInfo
      generateInstalledPackageInfo mbLBI =
        withTempInstalledPackageInfoFile
          verbosity
          distTempDirectory
          $ \pkgConfDest -> do
            let registerFlags v =
                  flip filterRegisterFlags v $
                    setupHsRegisterFlags
                      pkg
                      pkgshared
                      (commonFlags [])
                      pkgConfDest
            setup
              Cabal.registerCommand
              Cabal.registerCommonFlags
              (return . registerFlags)
              (const [])
              (InLibraryArgs $ InLibraryPostConfigureArgs SRegisterPhase mbLBI)

      withLogging :: (Maybe Handle -> IO r) -> IO r
      withLogging action =
        case mlogFile of
          Nothing -> action Nothing
          Just logFile -> withFile logFile AppendMode (action . Just)

--------------------------------------------------------------------------------

-- * Build Inplace

--------------------------------------------------------------------------------

buildInplaceUnpackedPackage
  :: Verbosity
  -> DistDirLayout
  -> Maybe SemaphoreIdentifier
  -> BuildTimeSettings
  -> Lock
  -> Lock
  -> ElaboratedSharedConfig
  -> ElaboratedInstallPlan
  -> ElaboratedReadyPackage
  -> TVar InstalledPackageIndex
  -> BuildStatusRebuild
  -> SymbolicPath CWD (Dir Pkg)
  -> SymbolicPath Pkg (Dir Dist)
  -> IO BuildResult
buildInplaceUnpackedPackage
  verbosity
  distDirLayout@DistDirLayout
    { distPackageCacheDirectory
    , distDirectory
    , distHaddockOutputDir
    }
  maybe_semaphore
  buildSettings@BuildTimeSettings{buildSettingHaddockOpen}
  registerLock
  cacheLock
  pkgshared@ElaboratedSharedConfig{pkgConfigPlatform = Platform _ os}
  plan
  rpkg@(ReadyPackage pkg)
  ipiTVar
  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 True $ interpretSymbolicPath (Just srcdir) builddir
    createDirectoryIfMissingVerbose
      verbosity
      True
      (distPackageCacheDirectory dparams)

    buildAndRegisterUnpackedPackage
      verbosity
      distDirLayout
      maybe_semaphore
      buildSettings
      registerLock
      cacheLock
      pkgshared
      plan
      rpkg
      ipiTVar
      srcdir
      builddir
      Nothing -- no log file for inplace builds!
      $ \case
        PBConfigurePhase{runConfigure} ->
          whenReconfigure $ do
            mbLBI <- runConfigure
            invalidatePackageRegFileMonitor packageFileMonitor
            updatePackageConfigFileMonitor packageFileMonitor (getSymbolicPath srcdir) pkg
            return mbLBI
        PBBuildPhase{runBuild} ->
          whenRebuild $ withFileMonitor runBuild
        PBReplPhase{runRepl} ->
          withFileMonitor runRepl
        PBHaddockPhase{runHaddock} -> do
          withFileMonitor runHaddock
          let haddockTarget = elabHaddockForHackage pkg
          when (haddockTarget == Cabal.ForHackage) $ do
            let dest = distDirectory </> name <.> "tar.gz"
                name = haddockDirName haddockTarget (elabPkgDescription pkg)
                docDir =
                  distBuildDirectory distDirLayout dparams
                    </> "doc"
                    </> "html"
            Tar.createTarGzFile dest docDir name
            notice verbosity $ "Documentation tarball created: " ++ dest

          when (buildSettingHaddockOpen && haddockTarget /= Cabal.ForHackage) $ do
            let dest = docDir </> "index.html"
                name = haddockDirName haddockTarget (elabPkgDescription pkg)
                docDir = case distHaddockOutputDir of
                  Nothing -> distBuildDirectory distDirLayout dparams </> "doc" </> "html" </> name
                  Just dir -> dir
            catch
              (void $ openBrowser dest)
              ( \(_ :: ErrorCall) ->
                  dieWithException verbosity $
                    FindOpenProgramLocationErr $
                      "Unsupported OS: " <> show os
              )
        PBInstallPhase{runCopy = _runCopy, runRegister} -> do
          -- PURPOSELY omitted: no copy!

          whenReRegister $ do
            -- Register locally
            mipkg <-
              if elabRequiresRegistration pkg
                then do
                  ipkg <-
                    runRegister
                      (elabRegisterPackageDBStack pkg)
                      Cabal.defaultRegisterOptions
                  -- Keep the per-project running InstalledPackageIndex up to date.
                  -- See (ProjIPI2) from Note [Per-project InstalledPackageIndex]
                  -- in Distribution.Client.ProjectBuilding.
                  atomically $ modifyTVar ipiTVar (PackageIndex.insert ipkg)
                  return (Just ipkg)
                else return Nothing

            updatePackageRegFileMonitor packageFileMonitor (getSymbolicPath srcdir) mipkg
        PBTestPhase{runTest} -> runTest
        PBBenchPhase{runBench} -> runBench

    return
      BuildResult
        { buildResultDocs = docsResult
        , buildResultTests = testsResult
        , buildResultLogFile = Nothing
        }
    where
      docsResult = DocsNotTried
      testsResult = TestsNotTried
      buildResult :: BuildResultMisc
      buildResult = (docsResult, testsResult)

      dparams = elabDistDirParams pkgshared pkg

      packageFileMonitor = newPackageFileMonitor pkgshared distDirLayout dparams

      withFileMonitor :: IO [MonitorFilePath] -> IO ()
      withFileMonitor runAction = do
        timestamp <- beginUpdateFileMonitor
        monitors' <-
          runAction
            -- Be sure to invalidate the cache if building throws an exception!
            -- If not, we'll abort execution with a stale recompilation cache.
            -- See ghc#24926 for an example of how this can go wrong.
            `onException` invalidatePackageRegFileMonitor packageFileMonitor
        let listSimple =
              execRebuild (getSymbolicPath srcdir) (needElaboratedConfiguredPackage pkg)
            listSdist =
              fmap (map monitorFileHashed) $
                allPackageSourceFiles verbosity (getSymbolicPath srcdir)
            ifNullThen m m' = do
              xs <- m
              if null xs then m' else return xs
        monitors <- case PD.buildType (elabPkgDescription pkg) of
          Simple -> listSimple
          Hooks -> listSdist `ifNullThen` listSimple
          _
            | elabSetupScriptCliVersion pkg >= mkVersion [1, 17] ->
                listSdist `ifNullThen` listSimple
            | otherwise ->
                listSimple

        let dep_monitors =
              map monitorFileHashed $
                elabInplaceDependencyBuildCacheFiles
                  distDirLayout
                  pkgshared
                  plan
                  pkg
        updatePackageBuildFileMonitor
          packageFileMonitor
          (getSymbolicPath srcdir)
          timestamp
          pkg
          buildStatus
          (monitors ++ monitors' ++ dep_monitors)
          buildResult

      whenReconfigure :: IO InLibraryLBI -> IO InLibraryLBI
      whenReconfigure action =
        case buildStatus of
          BuildStatusConfigure _ -> action
          _ -> do
            -- We are skipping reconfiguration, so we recover the
            -- 'LocalBuildInfo' persisted by the previous 'configure'.
            mbOldLBI <- Cabal.tryGetPersistBuildConfig (Just srcdir) builddir
            case mbOldLBI of
              -- #11942: if the previous LocalBuildInfo was written by an
              -- external Setup.hs with an incompatible Cabal library version,
              -- then we must continue to use the external setup method.
              Left Cabal.ConfigStateFileBadVersion{} -> return NotInLibraryNoLBI
              -- Other errors reflect genuine problems: re-throw them.
              Left err -> throwIO err
              Right lbi_wo_programs -> do
                -- Restore info about unconfigured programs, since it is not serialized
                -- TODO: copied from Distribution.Simple.getBuildConfig.
                let lbi =
                      lbi_wo_programs
                        { Cabal.withPrograms =
                            restoreProgramDb
                              builtinPrograms
                              (Cabal.withPrograms lbi_wo_programs)
                        }
                return $ InLibraryLBI lbi

      whenRebuild, whenReRegister :: IO () -> IO ()
      whenRebuild action
        | null (elabBuildTargets pkg)
        , -- NB: we have to build the test/bench suite!
          null (elabTestTargets pkg)
        , null (elabBenchTargets pkg) =
            return ()
        | otherwise = action

      whenReRegister action =
        case buildStatus of
          -- We registered the package already.
          -- No need to update ipiTVar: the InstalledPackageInfo for this package
          -- was picked up at startup.
          -- See Note [Per-project InstalledPackageIndex] in Distribution.Client.ProjectBuilding.
          BuildStatusBuild (Just _) _ ->
            info verbosity "whenReRegister: previously registered"
          -- There is nothing to register
          _
            | null (elabBuildTargets pkg) ->
                info verbosity "whenReRegister: nothing to register"
            | otherwise -> action

--------------------------------------------------------------------------------

-- * Build and Install

--------------------------------------------------------------------------------

buildAndInstallUnpackedPackage
  :: Verbosity
  -> DistDirLayout
  -> StoreDirLayout
  -> Maybe SemaphoreIdentifier
  -- ^ Whether to pass a semaphore to build process
  -- this is different to BuildTimeSettings because the
  -- name of the semaphore is created freshly each time.
  -> BuildTimeSettings
  -> Lock
  -> Lock
  -> ElaboratedSharedConfig
  -> ElaboratedInstallPlan
  -> ElaboratedReadyPackage
  -> TVar InstalledPackageIndex
  -> SymbolicPath CWD (Dir Pkg)
  -> SymbolicPath Pkg (Dir Dist)
  -> IO BuildResult
buildAndInstallUnpackedPackage
  verbosity
  distDirLayout
  storeDirLayout@StoreDirLayout
    { storePackageDBStack
    }
  maybe_semaphore
  buildSettings@BuildTimeSettings{buildSettingNumJobs, buildSettingLogFile}
  registerLock
  cacheLock
  pkgshared@ElaboratedSharedConfig
    { pkgConfigCompiler = compiler
    , pkgConfigPlatform = platform
    }
  plan
  rpkg@(ReadyPackage pkg)
  ipiTVar
  srcdir
  builddir = do
    createDirectoryIfMissingVerbose verbosity True (interpretSymbolicPath (Just srcdir) builddir)

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

    initLogFile

    buildAndRegisterUnpackedPackage
      verbosity
      distDirLayout
      maybe_semaphore
      buildSettings
      registerLock
      cacheLock
      pkgshared
      plan
      rpkg
      ipiTVar
      srcdir
      builddir
      mlogFile
      $ \case
        PBConfigurePhase{runConfigure} -> do
          noticeProgress ProgressStarting
          runConfigure
        PBBuildPhase{runBuild} -> do
          noticeProgress ProgressBuilding
          _monitors <- runBuild
          return ()
        PBHaddockPhase{runHaddock} -> do
          noticeProgress ProgressHaddock
          _monitors <- runHaddock
          return ()
        PBInstallPhase{runCopy, runRegister, getInstalledPackageInfo} -> do
          noticeProgress ProgressInstalling

          -- Create an IORef used to retrieve the InstalledPackageInfo computed
          -- by running "register".
          ipkgRef <- newIORef Nothing

          let registerPkg
                | not (elabRequiresRegistration pkg) =
                    debug verbosity $
                      "registerPkg: elab does NOT require registration for "
                        ++ prettyShow uid
                | otherwise = do
                    assert
                      ( elabRegisterPackageDBStack pkg
                          == storePackageDBStack compiler (elabPackageDbs pkg)
                      )
                      (return ())
                    ipkg <-
                      runRegister
                        (elabRegisterPackageDBStack pkg)
                        Cabal.defaultRegisterOptions
                          { Cabal.registerMultiInstance = True
                          , Cabal.registerSuppressFilesCheck = True
                          }
                    -- Write the InstalledPackageInfo to the IORef
                    writeIORef ipkgRef (Just ipkg)

          -- Actual installation
          void $
            newStoreEntry
              verbosity
              storeDirLayout
              compiler
              uid
              (copyPkgFiles verbosity pkgshared pkg runCopy)
              registerPkg

          -- Keep the per-project running InstalledPackageIndex TVar up to date.
          -- This must run regardless of whether newStoreEntry won or lost the
          -- race (UseNewStoreEntry/UseExistingStoreEntry).
          --
          -- See (ProjIPI2) in Note [Per-project InstalledPackageIndex].
          when (elabRequiresRegistration pkg) $ do
            -- If we won the race, we use the InstalledPackageInfo that was
            -- computed by 'runRegister'. If we lost, then we fall back to
            -- 'getInstalledPackageInfo' which re-runs 'Cabal register'
            -- (takes ~100ms).
            mipkg <- readIORef ipkgRef
            ipkg <- maybe getInstalledPackageInfo return mipkg
            atomically $ modifyTVar ipiTVar (PackageIndex.insert ipkg)

        -- No tests on install
        PBTestPhase{} -> return ()
        -- No bench on install
        PBBenchPhase{} -> return ()
        -- No repl on install
        PBReplPhase{} -> return ()

    -- TODO: [nice to have] we currently rely on Setup.hs copy to do the right
    -- thing. Although we do copy into an image dir and do the move into the
    -- final location ourselves, perhaps we ought to do some sanity checks on
    -- the image dir first.

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

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

    noticeProgress ProgressCompleted

    return
      BuildResult
        { buildResultDocs = docsResult
        , buildResultTests = testsResult
        , buildResultLogFile = mlogFile
        }
    where
      uid = installedUnitId rpkg
      pkgid = packageId rpkg

      dispname :: String
      dispname = case elabPkgOrComp pkg of
        -- Packages built altogether, instead of per component
        ElabPackage ElaboratedPackage{pkgWhyNotPerComponent} ->
          prettyShow pkgid
            ++ " (all, legacy fallback: "
            ++ unwords (map whyNotPerComponent $ NE.toList pkgWhyNotPerComponent)
            ++ ")"
        -- Packages built per component
        ElabComponent comp ->
          prettyShow pkgid
            ++ " ("
            ++ maybe "custom" prettyShow (compComponentName comp)
            ++ ")"

      noticeProgress :: ProgressPhase -> IO ()
      noticeProgress phase =
        when (isParallelBuild buildSettingNumJobs) $
          progressMessage verbosity phase dispname

      mlogFile :: Maybe FilePath
      mlogFile =
        case buildSettingLogFile of
          Nothing -> Nothing
          Just mkLogFile -> Just (mkLogFile compiler platform pkgid uid)

      initLogFile :: IO ()
      initLogFile =
        case mlogFile of
          Nothing -> return ()
          Just logFile -> do
            createDirectoryIfMissing True (takeDirectory logFile)
            removeFileForcibly logFile

-- | The copy part of the installation phase when doing build-and-install
copyPkgFiles
  :: Verbosity
  -> ElaboratedSharedConfig
  -> ElaboratedConfiguredPackage
  -> (FilePath -> IO ())
  -- ^ The 'runCopy' function which invokes ./Setup copy for the
  -- given filepath
  -> FilePath
  -- ^ The temporary dir file path
  -> IO (FilePath, [FilePath])
copyPkgFiles verbosity pkgshared pkg runCopy tmpDir = do
  let tmpDirNormalised = normalise tmpDir
  runCopy tmpDirNormalised
  -- Note that the copy command has put the files into
  -- @$tmpDir/$prefix@ so we need to return this dir so
  -- the store knows which dir will be the final store entry.
  let prefix =
        normalise $
          dropDrive (InstallDirs.prefix (elabInstallDirs pkg))
      entryDir = tmpDirNormalised </> prefix

  -- if there weren't anything to build, it might be that directory is not created
  -- the @setup Cabal.copyCommand@ above might do nothing.
  -- https://github.com/haskell/cabal/issues/4130
  createDirectoryIfMissingVerbose verbosity True entryDir

  let hashFileName = entryDir </> "cabal-hash.txt"
      outPkgHashInputs = renderPackageHashInputs (packageHashInputs pkgshared pkg)

  info verbosity $
    "creating file with the inputs used to compute the package hash: " ++ hashFileName

  LBS.writeFile hashFileName outPkgHashInputs

  debug verbosity "Package hash inputs:"
  traverse_
    (debug verbosity . ("> " ++))
    (lines $ LBS.Char8.unpack outPkgHashInputs)

  -- Ensure that there are no files in `tmpDir`, that are
  -- not in `entryDir`. While this breaks the
  -- prefix-relocatable property of the libraries, it is
  -- necessary on macOS to stay under the load command limit
  -- of the macOS mach-o linker. See also
  -- @PackageHash.hashedInstalledPackageIdVeryShort@.
  --
  -- We also normalise paths to ensure that there are no
  -- different representations for the same path. Like / and
  -- \\ on windows under msys.
  otherFiles <-
    filter (not . isPrefixOf entryDir)
      <$> listFilesRecursive tmpDirNormalised
  -- Here's where we could keep track of the installed files
  -- ourselves if we wanted to by making a manifest of the
  -- files in the tmp dir.
  return (entryDir, otherFiles)
  where
    listFilesRecursive :: FilePath -> IO [FilePath]
    listFilesRecursive path = do
      files <- fmap (path </>) <$> listDirectory path
      allFiles <- for files $ \file -> do
        isDir <- doesDirectoryExist file
        if isDir
          then listFilesRecursive file
          else return [file]
      return (concat allFiles)

--------------------------------------------------------------------------------

-- * Exported Utils

--------------------------------------------------------------------------------

{- FOURMOLU_DISABLE -}
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 =
  action `catches`
    -- 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.
    [
      Handler $ \async -> throwIO (async :: SomeAsyncException)
    , Handler $ \other -> handler (other :: SomeException)
    ]
  where
    handler :: Exception e => e -> IO a
    handler = throwIO . BuildFailure mlogFile . annotate . toException

--------------------------------------------------------------------------------
-- * Other Utils
--------------------------------------------------------------------------------

hasValidHaddockTargets :: ElaboratedConfiguredPackage -> Bool
hasValidHaddockTargets ElaboratedConfiguredPackage{..}
  | not elabBuildHaddocks = False
  | otherwise = any componentHasHaddocks components
  where
    components :: [ComponentTarget]
    components =
      elabBuildTargets
        ++ elabTestTargets
        ++ elabBenchTargets
        ++ elabReplTarget
        ++ elabHaddockTargets

    componentHasHaddocks :: ComponentTarget -> Bool
    componentHasHaddocks (ComponentTarget name _) =
      case name of
        CLibName LMainLibName -> hasHaddocks
        CLibName (LSubLibName _) -> elabHaddockInternal && hasHaddocks
        CFLibName _ -> elabHaddockForeignLibs && hasHaddocks
        CExeName _ -> elabHaddockExecutables && hasHaddocks
        CTestName _ -> elabHaddockTestSuites && hasHaddocks
        CBenchName _ -> elabHaddockBenchmarks && hasHaddocks
      where
        hasHaddocks = not (null (elabPkgDescription ^. componentModules name))

withTempInstalledPackageInfoFile
  :: Verbosity
  -> FilePath
  -> (FilePath -> IO ())
  -> IO InstalledPackageInfo
withTempInstalledPackageInfoFile verbosity tempdir action =
  withTempDirectory tempdir "package-registration-" $ \dir -> do
    -- make absolute since @action@ will often change directory
    abs_dir <- canonicalizePath dir

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

    readPkgConf "." pkgConfDest
  where
    pkgConfParseFailed :: String -> IO a
    pkgConfParseFailed perror =
      dieWithException verbosity $ PkgConfParseFailed perror

    readPkgConf :: FilePath -> FilePath -> IO InstalledPackageInfo
    readPkgConf pkgConfDir pkgConfFile = do
      pkgConfStr <- BS.readFile (pkgConfDir </> pkgConfFile)
      (warns, ipkg) <- case Installed.parseInstalledPackageInfo pkgConfStr of
        Left perrors -> pkgConfParseFailed $ unlines $ NE.toList perrors
        Right (warns, ipkg) -> return (warns, ipkg)

      unless (null warns) $
        warn verbosity $
          unlines warns

      return ipkg