{-# LANGUAGE NoImplicitPrelude   #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings   #-}

{-|
Module      : Stack.Build.Cache
Description : Cache information about previous builds.
License     : BSD-3-Clause

Cache information about previous builds.
-}

module Stack.Build.Cache
  ( tryGetBuildCache
  , tryGetConfigCache
  , tryGetCabalMod
  , tryGetSetupConfigMod
  , tryGetPackageProjectRoot
  , getInstalledExes
  , tryGetFlagCache
  , deleteCaches
  , markExeInstalled
  , markExeNotInstalled
  , writeFlagCache
  , writeBuildCache
  , writeConfigCache
  , writeCabalMod
  , writeSetupConfigMod
  , writePackageProjectRoot
  , TestStatus (..)
  , setTestStatus
  , getTestStatus
  , writePrecompiledCache
  , readPrecompiledCache
  -- Exported for testing

  , BuildFileCache (..)
  ) where

import           Crypto.Hash ( hashWith, SHA256 (..) )
import qualified Data.ByteArray as Mem ( convert )
import           Data.ByteString.Builder ( byteString )
import qualified Data.Map as M
import qualified Data.Set as Set
import qualified Data.Yaml as Yaml
import           Foreign.C.Types ( CTime )
import           Path ( (</>), filename, parent, parseRelFile )
import           Path.IO
                   ( ensureDir, ignoringAbsence, listDir, makeRelative
                   , removeFile
                   )
import           Stack.Constants ( bindirSuffix, relDirInstalledPackages )
import           Stack.Constants.Config
                   ( buildCachesDir, configCabalMod, configPackageProjectRoot
                   , configSetupConfigMod, testSuccessFile
                   )
import           Stack.Prelude
import           Stack.Storage.Project
                   ( ConfigCacheKey, configCacheKey, deactiveConfigCache
                   , loadConfigCache, saveConfigCache
                   )
import           Stack.Storage.User
                   ( PrecompiledCacheKey, loadPrecompiledCache
                   , precompiledCacheKey, savePrecompiledCache
                   )
import           Stack.Types.Cache
                   ( BuildFileCache (..), ConfigCache, ConfigCacheType (..)
                   , FileCache, PrecompiledCache (..)
                   )
import           Stack.Types.CompilerPaths ( cabalVersionL )
import           Stack.Types.ComponentUtils
                   ( StackUnqualCompName, unqualCompToString )
import           Stack.Types.Config ( stackRootL )
import           Stack.Types.ConfigureOpts
                   ( BaseConfigOpts (..), ConfigureOpts (..) )
import           Stack.Types.EnvConfig
                   ( EnvConfig (..), HasEnvConfig (..), actualCompilerVersionL
                   , installationRootDeps, installationRootLocal
                   , platformGhcRelDir
                   )
import           Stack.Types.GhcPkgId ( ghcPkgIdString )
import           Stack.Types.Installed
                   ( InstallLocation (..), Installed (..)
                   , InstalledLibraryInfo (..), foldOnGhcPkgId'
                   )
import           Stack.Types.NamedComponent
                   ( NamedComponent (..), componentCachePath )
import           Stack.Types.SourceMap ( smRelDir )
import           System.PosixCompat.Files
                   ( getFileStatus, modificationTime, setFileTimes )

-- | Directory containing files to mark an executable as installed.

exeInstalledDir ::
     (HasEnvConfig env)
  => InstallLocation
  -> RIO env (Path Abs Dir)
exeInstalledDir :: forall env.
HasEnvConfig env =>
InstallLocation -> RIO env (Path Abs Dir)
exeInstalledDir InstallLocation
Snap = (Path Abs Dir -> Path Rel Dir -> Path Abs Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirInstalledPackages) (Path Abs Dir -> Path Abs Dir)
-> RIO env (Path Abs Dir) -> RIO env (Path Abs Dir)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RIO env (Path Abs Dir)
forall env. HasEnvConfig env => RIO env (Path Abs Dir)
installationRootDeps
exeInstalledDir InstallLocation
Local = (Path Abs Dir -> Path Rel Dir -> Path Abs Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirInstalledPackages) (Path Abs Dir -> Path Abs Dir)
-> RIO env (Path Abs Dir) -> RIO env (Path Abs Dir)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RIO env (Path Abs Dir)
forall env. HasEnvConfig env => RIO env (Path Abs Dir)
installationRootLocal

-- | Get all of the installed executables.

getInstalledExes ::
     (HasEnvConfig env)
  => InstallLocation
  -> RIO env [PackageIdentifier]
getInstalledExes :: forall env.
HasEnvConfig env =>
InstallLocation -> RIO env [PackageIdentifier]
getInstalledExes InstallLocation
loc = do
  dir <- InstallLocation -> RIO env (Path Abs Dir)
forall env.
HasEnvConfig env =>
InstallLocation -> RIO env (Path Abs Dir)
exeInstalledDir InstallLocation
loc
  (_, files) <- liftIO $ handleIO (const $ pure ([], [])) $ listDir dir
  pure $
    concat $
    M.elems $
    -- If there are multiple install records (from a Stack version before

    -- https://github.com/commercialhaskell/stack/issues/2373 was fixed), then

    -- we don't know which is correct - ignore them.

    M.fromListWith (\[PackageIdentifier]
_ [PackageIdentifier]
_ -> []) $
    map (\PackageIdentifier
x -> (PackageIdentifier -> PackageName
pkgName PackageIdentifier
x, [PackageIdentifier
x])) $
    mapMaybe (parsePackageIdentifier . toFilePath . filename) files

-- | Mark the given executable as installed.

markExeInstalled ::
     (HasEnvConfig env)
  => InstallLocation
  -> PackageIdentifier
  -> RIO env ()
markExeInstalled :: forall env.
HasEnvConfig env =>
InstallLocation -> PackageIdentifier -> RIO env ()
markExeInstalled InstallLocation
loc PackageIdentifier
ident = do
  dir <- InstallLocation -> RIO env (Path Abs Dir)
forall env.
HasEnvConfig env =>
InstallLocation -> RIO env (Path Abs Dir)
exeInstalledDir InstallLocation
loc
  ensureDir dir
  ident' <- parseRelFile $ packageIdentifierString ident
  let fp = Path Abs Dir
dir Path Abs Dir -> Path Rel File -> Path Abs File
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
ident'
  -- Remove old install records for this package.

  -- TODO: This is a bit in-efficient. Put all this metadata into one file?

  installed <- getInstalledExes loc
  forM_ (filter (\PackageIdentifier
x -> PackageIdentifier -> PackageName
pkgName PackageIdentifier
ident PackageName -> PackageName -> Bool
forall a. Eq a => a -> a -> Bool
== PackageIdentifier -> PackageName
pkgName PackageIdentifier
x) installed)
        (markExeNotInstalled loc)
  -- TODO consideration for the future: list all of the executables installed,

  -- and invalidate this file in getInstalledExes if they no longer exist

  writeBinaryFileAtomic fp "Installed"

-- | Mark the given executable as not installed.

markExeNotInstalled ::
     (HasEnvConfig env)
  => InstallLocation
  -> PackageIdentifier
  -> RIO env ()
markExeNotInstalled :: forall env.
HasEnvConfig env =>
InstallLocation -> PackageIdentifier -> RIO env ()
markExeNotInstalled InstallLocation
loc PackageIdentifier
ident = do
  dir <- InstallLocation -> RIO env (Path Abs Dir)
forall env.
HasEnvConfig env =>
InstallLocation -> RIO env (Path Abs Dir)
exeInstalledDir InstallLocation
loc
  ident' <- parseRelFile $ packageIdentifierString ident
  liftIO $ ignoringAbsence (removeFile $ dir </> ident')

buildCacheFile ::
     (HasEnvConfig env, MonadReader env m, MonadThrow m)
  => Path Abs Dir
     -- ^ Package directory.

  -> NamedComponent
     -- ^ Package component.

  -> m (Path Abs File)
buildCacheFile :: forall env (m :: * -> *).
(HasEnvConfig env, MonadReader env m, MonadThrow m) =>
Path Abs Dir -> NamedComponent -> m (Path Abs File)
buildCacheFile Path Abs Dir
dir NamedComponent
component = do
  cachesDir <- Path Abs Dir -> m (Path Abs Dir)
forall env (m :: * -> *).
(HasEnvConfig env, MonadReader env m, MonadThrow m) =>
Path Abs Dir -> m (Path Abs Dir)
buildCachesDir Path Abs Dir
dir
  smh <- view $ envConfigL . to (.sourceMapHash)
  smDirName <- smRelDir smh
  cacheFileName <- parseRelFile $ componentCachePath component
  pure $ cachesDir </> smDirName </> cacheFileName

-- | Try to read the dirtiness cache for the given package directory.

tryGetBuildCache ::
     HasEnvConfig env
  => Path Abs Dir
     -- ^ Package directory.

  -> NamedComponent
     -- ^ Package component.

  -> RIO env (Maybe FileCache)
tryGetBuildCache :: forall env.
HasEnvConfig env =>
Path Abs Dir -> NamedComponent -> RIO env (Maybe FileCache)
tryGetBuildCache Path Abs Dir
dir NamedComponent
component = do
  fp <- Path Abs Dir -> NamedComponent -> RIO env (Path Abs File)
forall env (m :: * -> *).
(HasEnvConfig env, MonadReader env m, MonadThrow m) =>
Path Abs Dir -> NamedComponent -> m (Path Abs File)
buildCacheFile Path Abs Dir
dir NamedComponent
component
  ensureDir $ parent fp
  let decode :: MonadIO m => m BuildFileCache
      decode = String -> m BuildFileCache
forall (m :: * -> *) a. (MonadIO m, FromJSON a) => String -> m a
Yaml.decodeFileThrow (Path Abs File -> String
forall b t. Path b t -> String
toFilePath Path Abs File
fp)
  either (const Nothing) (Just . (.fileCache)) <$> liftIO (tryAny decode)

-- | Try to read the Cabal configuration cache for the given package directory.

tryGetConfigCache ::
     HasEnvConfig env
  => Path Abs Dir
     -- ^ Package directory.

  -> RIO env (Maybe ConfigCache)
tryGetConfigCache :: forall env.
HasEnvConfig env =>
Path Abs Dir -> RIO env (Maybe ConfigCache)
tryGetConfigCache Path Abs Dir
dir =
  ConfigCacheKey -> RIO env (Maybe ConfigCache)
forall env.
(HasBuildConfig env, HasLogFunc env) =>
ConfigCacheKey -> RIO env (Maybe ConfigCache)
loadConfigCache (ConfigCacheKey -> RIO env (Maybe ConfigCache))
-> ConfigCacheKey -> RIO env (Maybe ConfigCache)
forall a b. (a -> b) -> a -> b
$ Path Abs Dir -> ConfigCacheType -> ConfigCacheKey
configCacheKey Path Abs Dir
dir ConfigCacheType
ConfigCacheTypeConfig

-- | Try to read the modification time of the Cabal file from the last build.

tryGetCabalMod ::
     HasEnvConfig env
  => Path Abs Dir
     -- ^ Package directory.

  -> RIO env (Maybe CTime)
tryGetCabalMod :: forall env.
HasEnvConfig env =>
Path Abs Dir -> RIO env (Maybe CTime)
tryGetCabalMod Path Abs Dir
dir = do
  fp <- Path Abs File -> String
forall b t. Path b t -> String
toFilePath (Path Abs File -> String)
-> RIO env (Path Abs File) -> RIO env String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Path Abs Dir -> RIO env (Path Abs File)
forall env (m :: * -> *).
(HasEnvConfig env, MonadReader env m, MonadThrow m) =>
Path Abs Dir -> m (Path Abs File)
configCabalMod Path Abs Dir
dir
  tryGetFileMod fp

-- | Try to read the modification time of setup-config file from the last build.

tryGetSetupConfigMod ::
     HasEnvConfig env
  => Path Abs Dir
     -- ^ Package directory.

  -> RIO env (Maybe CTime)
tryGetSetupConfigMod :: forall env.
HasEnvConfig env =>
Path Abs Dir -> RIO env (Maybe CTime)
tryGetSetupConfigMod Path Abs Dir
dir = do
  fp <- Path Abs File -> String
forall b t. Path b t -> String
toFilePath (Path Abs File -> String)
-> RIO env (Path Abs File) -> RIO env String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Path Abs Dir -> RIO env (Path Abs File)
forall env (m :: * -> *).
(HasEnvConfig env, MonadReader env m, MonadThrow m) =>
Path Abs Dir -> m (Path Abs File)
configSetupConfigMod Path Abs Dir
dir
  tryGetFileMod fp

tryGetFileMod :: MonadIO m => FilePath -> m (Maybe CTime)
tryGetFileMod :: forall (m :: * -> *). MonadIO m => String -> m (Maybe CTime)
tryGetFileMod String
fp =
  IO (Maybe CTime) -> m (Maybe CTime)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe CTime) -> m (Maybe CTime))
-> IO (Maybe CTime) -> m (Maybe CTime)
forall a b. (a -> b) -> a -> b
$ (IOException -> Maybe CTime)
-> (FileStatus -> Maybe CTime)
-> Either IOException FileStatus
-> Maybe CTime
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe CTime -> IOException -> Maybe CTime
forall a b. a -> b -> a
const Maybe CTime
forall a. Maybe a
Nothing) (CTime -> Maybe CTime
forall a. a -> Maybe a
Just (CTime -> Maybe CTime)
-> (FileStatus -> CTime) -> FileStatus -> Maybe CTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FileStatus -> CTime
modificationTime) (Either IOException FileStatus -> Maybe CTime)
-> IO (Either IOException FileStatus) -> IO (Maybe CTime)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    IO FileStatus -> IO (Either IOException FileStatus)
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either IOException a)
tryIO (String -> IO FileStatus
getFileStatus String
fp)

-- | Try to read the project root from the last build of a package.

tryGetPackageProjectRoot ::
     HasEnvConfig env
  => Path Abs Dir
  -> RIO env (Maybe ByteString)
tryGetPackageProjectRoot :: forall env.
HasEnvConfig env =>
Path Abs Dir -> RIO env (Maybe ByteString)
tryGetPackageProjectRoot Path Abs Dir
dir = do
  fp <- Path Abs File -> String
forall b t. Path b t -> String
toFilePath (Path Abs File -> String)
-> RIO env (Path Abs File) -> RIO env String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Path Abs Dir -> RIO env (Path Abs File)
forall env (m :: * -> *).
(HasEnvConfig env, MonadReader env m, MonadThrow m) =>
Path Abs Dir -> m (Path Abs File)
configPackageProjectRoot Path Abs Dir
dir
  tryReadFileBinary fp

tryReadFileBinary :: MonadIO m => FilePath -> m (Maybe ByteString)
tryReadFileBinary :: forall (m :: * -> *). MonadIO m => String -> m (Maybe ByteString)
tryReadFileBinary String
fp =
  IO (Maybe ByteString) -> m (Maybe ByteString)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe ByteString) -> m (Maybe ByteString))
-> IO (Maybe ByteString) -> m (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ (IOException -> Maybe ByteString)
-> (ByteString -> Maybe ByteString)
-> Either IOException ByteString
-> Maybe ByteString
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe ByteString -> IOException -> Maybe ByteString
forall a b. a -> b -> a
const Maybe ByteString
forall a. Maybe a
Nothing) ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (Either IOException ByteString -> Maybe ByteString)
-> IO (Either IOException ByteString) -> IO (Maybe ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    IO ByteString -> IO (Either IOException ByteString)
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either IOException a)
tryIO (String -> IO ByteString
forall (m :: * -> *). MonadIO m => String -> m ByteString
readFileBinary String
fp)

-- | Write the dirtiness cache for this package's files.

writeBuildCache ::
     HasEnvConfig env
  => Path Abs Dir
     -- ^ Package directory.

  -> NamedComponent
     -- ^ Package component.

  -> FileCache
     -- ^ File cache.

  -> RIO env ()
writeBuildCache :: forall env.
HasEnvConfig env =>
Path Abs Dir -> NamedComponent -> FileCache -> RIO env ()
writeBuildCache Path Abs Dir
dir NamedComponent
component FileCache
fileCache = do
  fp <- Path Abs File -> String
forall b t. Path b t -> String
toFilePath (Path Abs File -> String)
-> RIO env (Path Abs File) -> RIO env String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Path Abs Dir -> NamedComponent -> RIO env (Path Abs File)
forall env (m :: * -> *).
(HasEnvConfig env, MonadReader env m, MonadThrow m) =>
Path Abs Dir -> NamedComponent -> m (Path Abs File)
buildCacheFile Path Abs Dir
dir NamedComponent
component
  liftIO $ Yaml.encodeFile fp BuildFileCache { fileCache }

-- | Write the given Cabal configuration cache for the given package directory.

writeConfigCache ::
     HasEnvConfig env
  => Path Abs Dir
     -- ^ Package directory.

  -> ConfigCache
     -- ^ Cabal configuration cache.

  -> RIO env ()
writeConfigCache :: forall env.
HasEnvConfig env =>
Path Abs Dir -> ConfigCache -> RIO env ()
writeConfigCache Path Abs Dir
dir =
  ConfigCacheKey -> ConfigCache -> RIO env ()
forall env.
(HasBuildConfig env, HasLogFunc env) =>
ConfigCacheKey -> ConfigCache -> RIO env ()
saveConfigCache (Path Abs Dir -> ConfigCacheType -> ConfigCacheKey
configCacheKey Path Abs Dir
dir ConfigCacheType
ConfigCacheTypeConfig)

-- | See 'tryGetCabalMod'

writeCabalMod ::
     HasEnvConfig env
  => Path Abs Dir
     -- ^ Package directory.

  -> CTime
  -> RIO env ()
writeCabalMod :: forall env. HasEnvConfig env => Path Abs Dir -> CTime -> RIO env ()
writeCabalMod Path Abs Dir
dir CTime
x = do
  fp <- Path Abs Dir -> RIO env (Path Abs File)
forall env (m :: * -> *).
(HasEnvConfig env, MonadReader env m, MonadThrow m) =>
Path Abs Dir -> m (Path Abs File)
configCabalMod Path Abs Dir
dir
  writeBinaryFileAtomic fp "Just used for its modification time"
  liftIO $ setFileTimes (toFilePath fp) x x

-- | See 'tryGetSetupConfigMod'

writeSetupConfigMod ::
     HasEnvConfig env
  => Path Abs Dir
  -> Maybe CTime
  -> RIO env ()
writeSetupConfigMod :: forall env.
HasEnvConfig env =>
Path Abs Dir -> Maybe CTime -> RIO env ()
writeSetupConfigMod Path Abs Dir
dir Maybe CTime
Nothing = do
  fp <- Path Abs Dir -> RIO env (Path Abs File)
forall env (m :: * -> *).
(HasEnvConfig env, MonadReader env m, MonadThrow m) =>
Path Abs Dir -> m (Path Abs File)
configSetupConfigMod Path Abs Dir
dir
  ignoringAbsence $ removeFile fp
writeSetupConfigMod Path Abs Dir
dir (Just CTime
x) = do
  fp <- Path Abs Dir -> RIO env (Path Abs File)
forall env (m :: * -> *).
(HasEnvConfig env, MonadReader env m, MonadThrow m) =>
Path Abs Dir -> m (Path Abs File)
configSetupConfigMod Path Abs Dir
dir
  writeBinaryFileAtomic fp "Just used for its modification time"
  liftIO $ setFileTimes (toFilePath fp) x x

-- | See 'tryGetPackageProjectRoot'.

writePackageProjectRoot ::
     HasEnvConfig env
  => Path Abs Dir
  -> ByteString
  -> RIO env ()
writePackageProjectRoot :: forall env.
HasEnvConfig env =>
Path Abs Dir -> ByteString -> RIO env ()
writePackageProjectRoot Path Abs Dir
dir ByteString
projectRoot = do
  fp <- Path Abs Dir -> RIO env (Path Abs File)
forall env (m :: * -> *).
(HasEnvConfig env, MonadReader env m, MonadThrow m) =>
Path Abs Dir -> m (Path Abs File)
configPackageProjectRoot Path Abs Dir
dir
  writeBinaryFileAtomic fp (byteString projectRoot)

-- | Delete the Cabal configuration cache for the given package directory.

deleteCaches ::
     HasEnvConfig env
  => Path Abs Dir
     -- ^ Package directory.

  -> RIO env ()
deleteCaches :: forall env. HasEnvConfig env => Path Abs Dir -> RIO env ()
deleteCaches Path Abs Dir
dir =
  {- FIXME confirm that this is acceptable to remove
  bfp <- buildCacheFile dir
  removeFileIfExists bfp
  -}
  ConfigCacheKey -> RIO env ()
forall env. HasBuildConfig env => ConfigCacheKey -> RIO env ()
deactiveConfigCache (ConfigCacheKey -> RIO env ()) -> ConfigCacheKey -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Path Abs Dir -> ConfigCacheType -> ConfigCacheKey
configCacheKey Path Abs Dir
dir ConfigCacheType
ConfigCacheTypeConfig

-- | For the given installed item, yields the key used to retrieve a record from

-- the library Cabal flag cache or executable Cabal flag cache.

flagCacheKey :: (HasEnvConfig env) => Installed -> RIO env ConfigCacheKey
flagCacheKey :: forall env. HasEnvConfig env => Installed -> RIO env ConfigCacheKey
flagCacheKey Installed
installed = do
  installationRoot <- RIO env (Path Abs Dir)
forall env. HasEnvConfig env => RIO env (Path Abs Dir)
installationRootLocal
  case installed of
    Library PackageIdentifier
_ InstalledLibraryInfo
installedInfo -> do
      let gid :: GhcPkgId
gid = InstalledLibraryInfo
installedInfo.ghcPkgId
      ConfigCacheKey -> RIO env ConfigCacheKey
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ConfigCacheKey -> RIO env ConfigCacheKey)
-> ConfigCacheKey -> RIO env ConfigCacheKey
forall a b. (a -> b) -> a -> b
$ Path Abs Dir -> ConfigCacheType -> ConfigCacheKey
configCacheKey Path Abs Dir
installationRoot (GhcPkgId -> ConfigCacheType
ConfigCacheTypeFlagLibrary GhcPkgId
gid)
    Executable PackageIdentifier
ident -> ConfigCacheKey -> RIO env ConfigCacheKey
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ConfigCacheKey -> RIO env ConfigCacheKey)
-> ConfigCacheKey -> RIO env ConfigCacheKey
forall a b. (a -> b) -> a -> b
$
      Path Abs Dir -> ConfigCacheType -> ConfigCacheKey
configCacheKey Path Abs Dir
installationRoot (PackageIdentifier -> ConfigCacheType
ConfigCacheTypeFlagExecutable PackageIdentifier
ident)

-- | Loads the Cabal flag cache for the given installed extra-deps.

tryGetFlagCache ::
     HasEnvConfig env
  => Installed
  -> RIO env (Maybe ConfigCache)
tryGetFlagCache :: forall env.
HasEnvConfig env =>
Installed -> RIO env (Maybe ConfigCache)
tryGetFlagCache Installed
gid = do
  key <- Installed -> RIO env ConfigCacheKey
forall env. HasEnvConfig env => Installed -> RIO env ConfigCacheKey
flagCacheKey Installed
gid
  loadConfigCache key

-- | Write the Cabal flag cache for the given installed extra-deps.

writeFlagCache ::
     HasEnvConfig env
  => Installed
  -> ConfigCache
  -> RIO env ()
writeFlagCache :: forall env.
HasEnvConfig env =>
Installed -> ConfigCache -> RIO env ()
writeFlagCache Installed
gid ConfigCache
cache = do
  key <- Installed -> RIO env ConfigCacheKey
forall env. HasEnvConfig env => Installed -> RIO env ConfigCacheKey
flagCacheKey Installed
gid
  saveConfigCache key cache

successBS, failureBS, unknownBS :: IsString s => s
successBS :: forall s. IsString s => s
successBS = s
"success"
failureBS :: forall s. IsString s => s
failureBS = s
"failure"
unknownBS :: forall s. IsString s => s
unknownBS = s
"unknown"

-- | Status of test suite(s).

data TestStatus
  = TSSuccess
    -- ^ The test suite(s) succeeded.

  | TSFailure
    -- ^ One or more test suites failed.

  | TSUnknown
    -- ^ The outcome of the test suite(s) is unknown.


-- | Mark test suite status.

setTestStatus ::
     HasEnvConfig env
  => Path Abs Dir
     -- ^ Package directory.

  -> TestStatus
     -- ^ The status of the test suite(s).

  -> RIO env ()
setTestStatus :: forall env.
HasEnvConfig env =>
Path Abs Dir -> TestStatus -> RIO env ()
setTestStatus Path Abs Dir
dir TestStatus
status = do
  fp <- Path Abs Dir -> RIO env (Path Abs File)
forall env (m :: * -> *).
(HasEnvConfig env, MonadReader env m, MonadThrow m) =>
Path Abs Dir -> m (Path Abs File)
testSuccessFile Path Abs Dir
dir
  writeBinaryFileAtomic fp $
    case status of
      TestStatus
TSSuccess -> Builder
forall s. IsString s => s
successBS
      TestStatus
TSFailure -> Builder
forall s. IsString s => s
failureBS
      TestStatus
TSUnknown -> Builder
forall s. IsString s => s
unknownBS

-- | Check if the test suite(s) already passed.

getTestStatus ::
     HasEnvConfig env
  => Path Abs Dir
     -- ^ Package directory.

  -> RIO env TestStatus
getTestStatus :: forall env. HasEnvConfig env => Path Abs Dir -> RIO env TestStatus
getTestStatus Path Abs Dir
dir = do
  fp <- Path Abs Dir -> RIO env (Path Abs File)
forall env (m :: * -> *).
(HasEnvConfig env, MonadReader env m, MonadThrow m) =>
Path Abs Dir -> m (Path Abs File)
testSuccessFile Path Abs Dir
dir
  -- we could ensure the file is the right size first, but we're not expected an

  -- attack from the user's filesystem

  tryIO (readFileBinary $ toFilePath fp) <&> \case
    Right ByteString
bs
      | ByteString
bs ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
forall s. IsString s => s
successBS -> TestStatus
TSSuccess
      | ByteString
bs ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
forall s. IsString s => s
failureBS -> TestStatus
TSFailure
    Either IOException ByteString
_ -> TestStatus
TSUnknown

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

-- Precompiled Cache

--

-- Idea is simple: cache information about packages built in other snapshots,

-- and then for identical matches (same flags, config options, dependencies)

-- just copy over the executables and reregister the libraries.

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


-- | The key containing information on the given package/configuration

-- combination. The key contains a hash of the non-directory configure

-- options for quick lookup if there's a match.

--

-- We only pay attention to non-directory options. We don't want to avoid a

-- cache hit just because it was installed in a different directory.

getPrecompiledCacheKey ::
     HasEnvConfig env
  => PackageLocationImmutable
  -> ConfigureOpts
  -> Bool -- ^ build haddocks

  -> RIO env PrecompiledCacheKey
getPrecompiledCacheKey :: forall env.
HasEnvConfig env =>
PackageLocationImmutable
-> ConfigureOpts -> Bool -> RIO env PrecompiledCacheKey
getPrecompiledCacheKey PackageLocationImmutable
loc ConfigureOpts
configureOpts Bool
buildHaddocks = do
  compiler <- Getting ActualCompiler env ActualCompiler -> RIO env ActualCompiler
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting ActualCompiler env ActualCompiler
forall env. HasSourceMap env => SimpleGetter env ActualCompiler
SimpleGetter env ActualCompiler
actualCompilerVersionL
  cabalVersion <- view cabalVersionL

  -- The goal here is to come up with a string representing the package location

  -- which is unique. Luckily @TreeKey@s are exactly that!

  treeKey <- getPackageLocationTreeKey loc
  let packageKey = Utf8Builder -> Text
utf8BuilderToText (Utf8Builder -> Text) -> Utf8Builder -> Text
forall a b. (a -> b) -> a -> b
$ TreeKey -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display TreeKey
treeKey

  platformGhcDir <- platformGhcRelDir

  -- In Cabal versions 1.22 and later, the configure options contain the

  -- installed package IDs, which is what we need for a unique hash. See also

  -- issue: https://github.com/commercialhaskell/stack/issues/1103

  let optionsToHash = ConfigureOpts
configureOpts.nonPathRelated
      optionsHash =
        Digest SHA256 -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
Mem.convert (Digest SHA256 -> ByteString) -> Digest SHA256 -> ByteString
forall a b. (a -> b) -> a -> b
$ SHA256 -> ByteString -> Digest SHA256
forall ba alg.
(ByteArrayAccess ba, HashAlgorithm alg) =>
alg -> ba -> Digest alg
hashWith SHA256
SHA256 (ByteString -> Digest SHA256) -> ByteString -> Digest SHA256
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ [String] -> Text
forall a. Show a => a -> Text
tshow [String]
optionsToHash

  pure $ precompiledCacheKey
    platformGhcDir compiler cabalVersion packageKey optionsHash buildHaddocks

-- | Write out information about a newly built package

writePrecompiledCache ::
     HasEnvConfig env
  => BaseConfigOpts
  -> PackageLocationImmutable
  -> ConfigureOpts
  -> Bool -- ^ build haddocks

  -> Installed -- ^ library

  -> Set StackUnqualCompName -- ^ executables

  -> RIO env ()
writePrecompiledCache :: forall env.
HasEnvConfig env =>
BaseConfigOpts
-> PackageLocationImmutable
-> ConfigureOpts
-> Bool
-> Installed
-> Set StackUnqualCompName
-> RIO env ()
writePrecompiledCache
    BaseConfigOpts
baseConfigOpts
    PackageLocationImmutable
loc
    ConfigureOpts
copts
    Bool
buildHaddocks
    Installed
mghcPkgId
    Set StackUnqualCompName
exes
  = do
      key <- PackageLocationImmutable
-> ConfigureOpts -> Bool -> RIO env PrecompiledCacheKey
forall env.
HasEnvConfig env =>
PackageLocationImmutable
-> ConfigureOpts -> Bool -> RIO env PrecompiledCacheKey
getPrecompiledCacheKey PackageLocationImmutable
loc ConfigureOpts
copts Bool
buildHaddocks
      ec <- view envConfigL
      let stackRootRelative = Path Abs Dir -> Path Abs File -> RIO env (RelPath (Path Abs File))
forall path (m :: * -> *).
(AnyPath path, MonadThrow m) =>
Path Abs Dir -> path -> m (RelPath path)
forall (m :: * -> *).
MonadThrow m =>
Path Abs Dir -> Path Abs File -> m (RelPath (Path Abs File))
makeRelative (Getting (Path Abs Dir) EnvConfig (Path Abs Dir)
-> EnvConfig -> Path Abs Dir
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Path Abs Dir) EnvConfig (Path Abs Dir)
forall s. HasConfig s => Lens' s (Path Abs Dir)
Lens' EnvConfig (Path Abs Dir)
stackRootL EnvConfig
ec)
      exes' <- forM (Set.toList exes) $ \StackUnqualCompName
exe -> do
        name <- String -> RIO env (Path Rel File)
forall (m :: * -> *). MonadThrow m => String -> m (Path Rel File)
parseRelFile (String -> RIO env (Path Rel File))
-> String -> RIO env (Path Rel File)
forall a b. (a -> b) -> a -> b
$ StackUnqualCompName -> String
unqualCompToString StackUnqualCompName
exe
        stackRootRelative $
           baseConfigOpts.snapInstallRoot </> bindirSuffix </> name
      let installedLibToPath Maybe StackUnqualCompName
libName GhcPkgId
ghcPkgId RIO env (PrecompiledCache Rel)
pcAction = do
            libPath <- (Path Abs File -> RIO env (Path Rel File))
-> GhcPkgId -> RIO env (Path Rel File)
pathFromPkgId Path Abs File -> RIO env (Path Rel File)
Path Abs File -> RIO env (RelPath (Path Abs File))
stackRootRelative GhcPkgId
ghcPkgId
            pc <- pcAction
            pure $ case libName of
              Maybe StackUnqualCompName
Nothing -> PrecompiledCache Rel
pc { library = Just libPath }
              Maybe StackUnqualCompName
_ -> PrecompiledCache Rel
pc { subLibs = libPath : pc.subLibs }
      precompiled <- foldOnGhcPkgId'
        installedLibToPath
        mghcPkgId
        ( pure PrecompiledCache
            { library = Nothing
            , subLibs = []
            , exes = exes'
            }
        )
      savePrecompiledCache key precompiled
      -- reuse precompiled cache with haddocks also in case when haddocks are

      -- not required

      when buildHaddocks $ do
        key' <- getPrecompiledCacheKey loc copts False
        savePrecompiledCache key' precompiled
 where
  pathFromPkgId :: (Path Abs File -> RIO env (Path Rel File))
-> GhcPkgId -> RIO env (Path Rel File)
pathFromPkgId Path Abs File -> RIO env (Path Rel File)
stackRootRelative GhcPkgId
ipid = do
    ipid' <- String -> RIO env (Path Rel File)
forall (m :: * -> *). MonadThrow m => String -> m (Path Rel File)
parseRelFile (String -> RIO env (Path Rel File))
-> String -> RIO env (Path Rel File)
forall a b. (a -> b) -> a -> b
$ GhcPkgId -> String
ghcPkgIdString GhcPkgId
ipid String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".conf"
    stackRootRelative $ baseConfigOpts.snapDB </> ipid'

-- | Check the cache for a precompiled package matching the given configuration.

readPrecompiledCache ::
     forall env. HasEnvConfig env
  => PackageLocationImmutable -- ^ target package

  -> ConfigureOpts
  -> Bool -- ^ build haddocks

  -> RIO env (Maybe (PrecompiledCache Abs))
readPrecompiledCache :: forall env.
HasEnvConfig env =>
PackageLocationImmutable
-> ConfigureOpts -> Bool -> RIO env (Maybe (PrecompiledCache Abs))
readPrecompiledCache PackageLocationImmutable
loc ConfigureOpts
copts Bool
buildHaddocks = do
  key <- PackageLocationImmutable
-> ConfigureOpts -> Bool -> RIO env PrecompiledCacheKey
forall env.
HasEnvConfig env =>
PackageLocationImmutable
-> ConfigureOpts -> Bool -> RIO env PrecompiledCacheKey
getPrecompiledCacheKey PackageLocationImmutable
loc ConfigureOpts
copts Bool
buildHaddocks
  mcache <- loadPrecompiledCache key
  maybe (pure Nothing) (fmap Just . mkAbs) mcache
 where
  -- Since commit ed9ccc08f327bad68dd2d09a1851ce0d055c0422, pcLibrary paths are

  -- stored as relative to the Stack root. Therefore, we need to prepend the

  -- Stack root when checking that the file exists. For the older cached paths,

  -- the file will contain an absolute path, which will make `stackRoot </>`

  -- a no-op.

  mkAbs :: PrecompiledCache Rel -> RIO env (PrecompiledCache Abs)
  mkAbs :: PrecompiledCache Rel -> RIO env (PrecompiledCache Abs)
mkAbs PrecompiledCache Rel
pc0 = do
    stackRoot <- Getting (Path Abs Dir) env (Path Abs Dir) -> RIO env (Path Abs Dir)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Path Abs Dir) env (Path Abs Dir)
forall s. HasConfig s => Lens' s (Path Abs Dir)
Lens' env (Path Abs Dir)
stackRootL
    let mkAbs' = (Path Abs Dir
stackRoot Path Abs Dir -> Path Rel File -> Path Abs File
forall b t. Path b Dir -> Path Rel t -> Path b t
</>)
    pure PrecompiledCache
      { library = mkAbs' <$> pc0.library
      , subLibs = mkAbs' <$> pc0.subLibs
      , exes = mkAbs' <$> pc0.exes
      }