{-# LANGUAGE NoImplicitPrelude     #-}
{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE OverloadedStrings     #-}

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

  , BuildCache (..)
  ) 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.Text as T
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.Build
                   ( BuildCache (..), ConfigCache, FileCacheInfo
                   , InstallLocation (..), Installed (..), PrecompiledCache (..)
                   )
import           Stack.Types.Cache ( ConfigCacheType (..) )
import           Stack.Types.CompilerPaths ( cabalVersionL )
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 ( GhcPkgId, ghcPkgIdString )
import           Stack.Types.NamedComponent ( NamedComponent (..) )
import           Stack.Types.SourceMap ( smRelDir )
import           System.PosixCompat.Files
                   ( modificationTime, getFileStatus, 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 = (forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirInstalledPackages) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall env. HasEnvConfig env => RIO env (Path Abs Dir)
installationRootDeps
exeInstalledDir InstallLocation
Local = (forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirInstalledPackages) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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
  Path Abs Dir
dir <- forall env.
HasEnvConfig env =>
InstallLocation -> RIO env (Path Abs Dir)
exeInstalledDir InstallLocation
loc
  ([Path Abs Dir]
_, [Path Abs File]
files) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
MonadUnliftIO m =>
(IOException -> m a) -> m a -> m a
handleIO (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], [])) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) b.
MonadIO m =>
Path b Dir -> m ([Path Abs Dir], [Path Abs File])
listDir Path Abs Dir
dir
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$
    forall k a. Map k a -> [a]
M.elems forall a b. (a -> b) -> a -> b
$
    -- 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.

    forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith (\[PackageIdentifier]
_ [PackageIdentifier]
_ -> []) forall a b. (a -> b) -> a -> b
$
    forall a b. (a -> b) -> [a] -> [b]
map (\PackageIdentifier
x -> (PackageIdentifier -> PackageName
pkgName PackageIdentifier
x, [PackageIdentifier
x])) forall a b. (a -> b) -> a -> b
$
    forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (String -> Maybe PackageIdentifier
parsePackageIdentifier forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b t. Path b t -> String
toFilePath forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b. Path b File -> Path Rel File
filename) [Path Abs File]
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
  Path Abs Dir
dir <- forall env.
HasEnvConfig env =>
InstallLocation -> RIO env (Path Abs Dir)
exeInstalledDir InstallLocation
loc
  forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir Path Abs Dir
dir
  Path Rel File
ident' <- forall (m :: * -> *). MonadThrow m => String -> m (Path Rel File)
parseRelFile forall a b. (a -> b) -> a -> b
$ PackageIdentifier -> String
packageIdentifierString PackageIdentifier
ident
  let fp :: Path Abs File
fp = Path Abs Dir
dir 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?

  [PackageIdentifier]
installed <- forall env.
HasEnvConfig env =>
InstallLocation -> RIO env [PackageIdentifier]
getInstalledExes InstallLocation
loc
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall a. (a -> Bool) -> [a] -> [a]
filter (\PackageIdentifier
x -> PackageIdentifier -> PackageName
pkgName PackageIdentifier
ident forall a. Eq a => a -> a -> Bool
== PackageIdentifier -> PackageName
pkgName PackageIdentifier
x) [PackageIdentifier]
installed)
        (forall env.
HasEnvConfig env =>
InstallLocation -> PackageIdentifier -> RIO env ()
markExeNotInstalled InstallLocation
loc)
  -- TODO consideration for the future: list all of the executables installed,

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

  forall (m :: * -> *) absrel.
MonadIO m =>
Path absrel File -> Builder -> m ()
writeBinaryFileAtomic Path Abs File
fp Builder
"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
  Path Abs Dir
dir <- forall env.
HasEnvConfig env =>
InstallLocation -> RIO env (Path Abs Dir)
exeInstalledDir InstallLocation
loc
  Path Rel File
ident' <- forall (m :: * -> *). MonadThrow m => String -> m (Path Rel File)
parseRelFile forall a b. (a -> b) -> a -> b
$ PackageIdentifier -> String
packageIdentifierString PackageIdentifier
ident
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. (MonadIO m, MonadCatch m) => m a -> m ()
ignoringAbsence (forall (m :: * -> *) b. MonadIO m => Path b File -> m ()
removeFile forall a b. (a -> b) -> a -> b
$ Path Abs Dir
dir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
ident')

buildCacheFile :: (HasEnvConfig env, MonadReader env m, MonadThrow m)
               => Path Abs Dir
               -> NamedComponent
               -> 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
  Path Abs Dir
cachesDir <- forall (m :: * -> *) env.
(MonadThrow m, MonadReader env m, HasEnvConfig env) =>
Path Abs Dir -> m (Path Abs Dir)
buildCachesDir Path Abs Dir
dir
  SourceMapHash
smh <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasEnvConfig env => Lens' env EnvConfig
envConfigLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to EnvConfig -> SourceMapHash
envConfigSourceMapHash
  Path Rel Dir
smDirName <- forall (m :: * -> *).
MonadThrow m =>
SourceMapHash -> m (Path Rel Dir)
smRelDir SourceMapHash
smh
  let nonLibComponent :: String -> Text -> String
nonLibComponent String
prefix Text
name = String
prefix forall a. Semigroup a => a -> a -> a
<> String
"-" forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
name
  Path Rel File
cacheFileName <- forall (m :: * -> *). MonadThrow m => String -> m (Path Rel File)
parseRelFile forall a b. (a -> b) -> a -> b
$ case NamedComponent
component of
    NamedComponent
CLib -> String
"lib"
    CInternalLib Text
name -> String -> Text -> String
nonLibComponent String
"internal-lib" Text
name
    CExe Text
name -> String -> Text -> String
nonLibComponent String
"exe" Text
name
    CTest Text
name -> String -> Text -> String
nonLibComponent String
"test" Text
name
    CBench Text
name -> String -> Text -> String
nonLibComponent String
"bench" Text
name
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Path Abs Dir
cachesDir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
smDirName forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
cacheFileName

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

tryGetBuildCache :: HasEnvConfig env
                 => Path Abs Dir
                 -> NamedComponent
                 -> RIO env (Maybe (Map FilePath FileCacheInfo))
tryGetBuildCache :: forall env.
HasEnvConfig env =>
Path Abs Dir
-> NamedComponent -> RIO env (Maybe (Map String FileCacheInfo))
tryGetBuildCache Path Abs Dir
dir NamedComponent
component = do
  Path Abs File
fp <- 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
  forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir forall a b. (a -> b) -> a -> b
$ forall b t. Path b t -> Path b Dir
parent Path Abs File
fp
  forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. BuildCache -> Map String FileCacheInfo
buildCacheTimes) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
tryAny (forall (m :: * -> *) a. (MonadIO m, FromJSON a) => String -> m a
Yaml.decodeFileThrow (forall b t. Path b t -> String
toFilePath Path Abs File
fp)))

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

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

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

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

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

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

tryGetFileMod :: MonadIO m => FilePath -> m (Maybe CTime)
tryGetFileMod :: forall (m :: * -> *). MonadIO m => String -> m (Maybe CTime)
tryGetFileMod String
fp =
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. FileStatus -> CTime
modificationTime) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    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
  String
fp <- forall b t. Path b t -> String
toFilePath forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) env.
(MonadThrow m, MonadReader env m, HasEnvConfig env) =>
Path Abs Dir -> m (Path Abs File)
configPackageProjectRoot Path Abs Dir
dir
  forall (m :: * -> *). MonadIO m => String -> m (Maybe ByteString)
tryReadFileBinary String
fp

tryReadFileBinary :: MonadIO m => FilePath -> m (Maybe ByteString)
tryReadFileBinary :: forall (m :: * -> *). MonadIO m => String -> m (Maybe ByteString)
tryReadFileBinary String
fp =
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either IOException a)
tryIO (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
                -> NamedComponent
                -> Map FilePath FileCacheInfo -> RIO env ()
writeBuildCache :: forall env.
HasEnvConfig env =>
Path Abs Dir
-> NamedComponent -> Map String FileCacheInfo -> RIO env ()
writeBuildCache Path Abs Dir
dir NamedComponent
component Map String FileCacheInfo
times = do
  String
fp <- forall b t. Path b t -> String
toFilePath forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. ToJSON a => String -> a -> IO ()
Yaml.encodeFile String
fp BuildCache
    { buildCacheTimes :: Map String FileCacheInfo
buildCacheTimes = Map String FileCacheInfo
times
    }

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

writeConfigCache :: HasEnvConfig env
                => Path Abs Dir
                -> ConfigCache
                -> RIO env ()
writeConfigCache :: forall env.
HasEnvConfig env =>
Path Abs Dir -> ConfigCache -> RIO env ()
writeConfigCache Path Abs Dir
dir =
  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
              -> CTime
              -> RIO env ()
writeCabalMod :: forall env. HasEnvConfig env => Path Abs Dir -> CTime -> RIO env ()
writeCabalMod Path Abs Dir
dir CTime
x = do
  Path Abs File
fp <- forall (m :: * -> *) env.
(MonadThrow m, MonadReader env m, HasEnvConfig env) =>
Path Abs Dir -> m (Path Abs File)
configCabalMod Path Abs Dir
dir
  forall (m :: * -> *) absrel.
MonadIO m =>
Path absrel File -> Builder -> m ()
writeBinaryFileAtomic Path Abs File
fp Builder
"Just used for its modification time"
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> CTime -> CTime -> IO ()
setFileTimes (forall b t. Path b t -> String
toFilePath Path Abs File
fp) CTime
x CTime
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
  Path Abs File
fp <- forall (m :: * -> *) env.
(MonadThrow m, MonadReader env m, HasEnvConfig env) =>
Path Abs Dir -> m (Path Abs File)
configSetupConfigMod Path Abs Dir
dir
  forall (m :: * -> *) a. (MonadIO m, MonadCatch m) => m a -> m ()
ignoringAbsence forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) b. MonadIO m => Path b File -> m ()
removeFile Path Abs File
fp
writeSetupConfigMod Path Abs Dir
dir (Just CTime
x) = do
  Path Abs File
fp <- forall (m :: * -> *) env.
(MonadThrow m, MonadReader env m, HasEnvConfig env) =>
Path Abs Dir -> m (Path Abs File)
configSetupConfigMod Path Abs Dir
dir
  forall (m :: * -> *) absrel.
MonadIO m =>
Path absrel File -> Builder -> m ()
writeBinaryFileAtomic Path Abs File
fp Builder
"Just used for its modification time"
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> CTime -> CTime -> IO ()
setFileTimes (forall b t. Path b t -> String
toFilePath Path Abs File
fp) CTime
x CTime
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
  Path Abs File
fp <- forall (m :: * -> *) env.
(MonadThrow m, MonadReader env m, HasEnvConfig env) =>
Path Abs Dir -> m (Path Abs File)
configPackageProjectRoot Path Abs Dir
dir
  forall (m :: * -> *) absrel.
MonadIO m =>
Path absrel File -> Builder -> m ()
writeBinaryFileAtomic Path Abs File
fp (ByteString -> Builder
byteString ByteString
projectRoot)

-- | Delete the caches for the project.

deleteCaches :: HasEnvConfig env => Path Abs Dir -> 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
  -}
  forall env. HasBuildConfig env => ConfigCacheKey -> RIO env ()
deactiveConfigCache forall a b. (a -> b) -> a -> b
$ Path Abs Dir -> ConfigCacheType -> ConfigCacheKey
configCacheKey Path Abs Dir
dir ConfigCacheType
ConfigCacheTypeConfig

flagCacheKey :: (HasEnvConfig env) => Installed -> RIO env ConfigCacheKey
flagCacheKey :: forall env. HasEnvConfig env => Installed -> RIO env ConfigCacheKey
flagCacheKey Installed
installed = do
  Path Abs Dir
installationRoot <- forall env. HasEnvConfig env => RIO env (Path Abs Dir)
installationRootLocal
  case Installed
installed of
    Library PackageIdentifier
_ GhcPkgId
gid Maybe (Either License License)
_ ->
      forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 ->
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
        Path Abs Dir -> ConfigCacheType -> ConfigCacheKey
configCacheKey
          Path Abs Dir
installationRoot
          (PackageIdentifier -> ConfigCacheType
ConfigCacheTypeFlagExecutable PackageIdentifier
ident)

-- | Loads the 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
  ConfigCacheKey
key <- forall env. HasEnvConfig env => Installed -> RIO env ConfigCacheKey
flagCacheKey Installed
gid
  forall env.
(HasBuildConfig env, HasLogFunc env) =>
ConfigCacheKey -> RIO env (Maybe ConfigCache)
loadConfigCache ConfigCacheKey
key

writeFlagCache :: HasEnvConfig env
               => Installed
               -> ConfigCache
               -> RIO env ()
writeFlagCache :: forall env.
HasEnvConfig env =>
Installed -> ConfigCache -> RIO env ()
writeFlagCache Installed
gid ConfigCache
cache = do
  ConfigCacheKey
key <- forall env. HasEnvConfig env => Installed -> RIO env ConfigCacheKey
flagCacheKey Installed
gid
  forall env.
(HasBuildConfig env, HasLogFunc env) =>
ConfigCacheKey -> ConfigCache -> RIO env ()
saveConfigCache ConfigCacheKey
key ConfigCache
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 a test suite

data TestStatus
  = TSSuccess
  | TSFailure
  | TSUnknown

-- | Mark test suite status

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

-- | Check if the test suite already passed

getTestStatus :: HasEnvConfig env
              => Path Abs Dir
              -> RIO env TestStatus
getTestStatus :: forall env. HasEnvConfig env => Path Abs Dir -> RIO env TestStatus
getTestStatus Path Abs Dir
dir = do
  Path Abs File
fp <- forall (m :: * -> *) env.
(MonadThrow m, MonadReader env m, HasEnvConfig env) =>
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

  Either IOException ByteString
eres <- forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either IOException a)
tryIO (forall (m :: * -> *). MonadIO m => String -> m ByteString
readFileBinary forall a b. (a -> b) -> a -> b
$ forall b t. Path b t -> String
toFilePath Path Abs File
fp)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
    case Either IOException ByteString
eres of
      Right ByteString
bs
        | ByteString
bs forall a. Eq a => a -> a -> Bool
== forall s. IsString s => s
successBS -> TestStatus
TSSuccess
        | ByteString
bs forall a. Eq a => a -> a -> Bool
== 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

                    -> Set GhcPkgId -- ^ dependencies

                    -> RIO env PrecompiledCacheKey
getPrecompiledCacheKey :: forall env.
HasEnvConfig env =>
PackageLocationImmutable
-> ConfigureOpts
-> Bool
-> Set GhcPkgId
-> RIO env PrecompiledCacheKey
getPrecompiledCacheKey PackageLocationImmutable
loc ConfigureOpts
copts Bool
buildHaddocks Set GhcPkgId
installedPackageIDs = do
  ActualCompiler
compiler <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasSourceMap env => SimpleGetter env ActualCompiler
actualCompilerVersionL
  Version
cabalVersion <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasCompiler env => SimpleGetter env Version
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
treeKey <- forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
PackageLocationImmutable -> RIO env TreeKey
getPackageLocationTreeKey PackageLocationImmutable
loc
  let packageKey :: Text
packageKey = Utf8Builder -> Text
utf8BuilderToText forall a b. (a -> b) -> a -> b
$ forall a. Display a => a -> Utf8Builder
display TreeKey
treeKey

  Path Rel Dir
platformGhcDir <- forall env (m :: * -> *).
(HasEnvConfig env, MonadReader env m, MonadThrow m) =>
m (Path Rel Dir)
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.

  -- Unfortunately, earlier Cabals don't have the information, so we must

  -- supplement it with the installed package IDs directly.

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

  let input :: ([String], Set GhcPkgId)
input = (ConfigureOpts -> [String]
coNoDirs ConfigureOpts
copts, Set GhcPkgId
installedPackageIDs)
      optionsHash :: ByteString
optionsHash = forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
Mem.convert forall a b. (a -> b) -> a -> b
$ forall ba alg.
(ByteArrayAccess ba, HashAlgorithm alg) =>
alg -> ba -> Digest alg
hashWith SHA256
SHA256 forall a b. (a -> b) -> a -> b
$ Text -> ByteString
encodeUtf8 forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> Text
tshow ([String], Set GhcPkgId)
input

  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Path Rel Dir
-> ActualCompiler
-> Version
-> Text
-> ByteString
-> Bool
-> PrecompiledCacheKey
precompiledCacheKey Path Rel Dir
platformGhcDir ActualCompiler
compiler Version
cabalVersion Text
packageKey ByteString
optionsHash Bool
buildHaddocks

-- | Write out information about a newly built package

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

                      -> Set GhcPkgId -- ^ dependencies

                      -> Installed -- ^ library

                      -> [GhcPkgId] -- ^ sublibraries, in the GhcPkgId format

                      -> Set Text -- ^ executables

                      -> RIO env ()
writePrecompiledCache :: forall env.
HasEnvConfig env =>
BaseConfigOpts
-> PackageLocationImmutable
-> ConfigureOpts
-> Bool
-> Set GhcPkgId
-> Installed
-> [GhcPkgId]
-> Set Text
-> RIO env ()
writePrecompiledCache BaseConfigOpts
baseConfigOpts PackageLocationImmutable
loc ConfigureOpts
copts Bool
buildHaddocks Set GhcPkgId
depIDs Installed
mghcPkgId [GhcPkgId]
sublibs Set Text
exes = do
  PrecompiledCacheKey
key <- forall env.
HasEnvConfig env =>
PackageLocationImmutable
-> ConfigureOpts
-> Bool
-> Set GhcPkgId
-> RIO env PrecompiledCacheKey
getPrecompiledCacheKey PackageLocationImmutable
loc ConfigureOpts
copts Bool
buildHaddocks Set GhcPkgId
depIDs
  EnvConfig
ec <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasEnvConfig env => Lens' env EnvConfig
envConfigL
  let stackRootRelative :: Path Abs File -> RIO env (RelPath (Path Abs File))
stackRootRelative = forall path (m :: * -> *).
(AnyPath path, MonadThrow m) =>
Path Abs Dir -> path -> m (RelPath path)
makeRelative (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall s. HasConfig s => Lens' s (Path Abs Dir)
stackRootL EnvConfig
ec)
  Maybe (Path Rel File)
mlibpath <- case Installed
mghcPkgId of
    Executable PackageIdentifier
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
    Library PackageIdentifier
_ GhcPkgId
ipid Maybe (Either License License)
_ -> forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {m :: * -> *} {b}.
MonadThrow m =>
(Path Abs File -> m b) -> GhcPkgId -> m b
pathFromPkgId Path Abs File -> RIO env (RelPath (Path Abs File))
stackRootRelative GhcPkgId
ipid
  [Path Rel File]
sublibpaths <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall {m :: * -> *} {b}.
MonadThrow m =>
(Path Abs File -> m b) -> GhcPkgId -> m b
pathFromPkgId Path Abs File -> RIO env (RelPath (Path Abs File))
stackRootRelative) [GhcPkgId]
sublibs
  [Path Rel File]
exes' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (forall a. Set a -> [a]
Set.toList Set Text
exes) forall a b. (a -> b) -> a -> b
$ \Text
exe -> do
    Path Rel File
name <- forall (m :: * -> *). MonadThrow m => String -> m (Path Rel File)
parseRelFile forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
exe
    Path Abs File -> RIO env (RelPath (Path Abs File))
stackRootRelative forall a b. (a -> b) -> a -> b
$ BaseConfigOpts -> Path Abs Dir
bcoSnapInstallRoot BaseConfigOpts
baseConfigOpts forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
bindirSuffix forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
name
  let precompiled :: PrecompiledCache Rel
precompiled = PrecompiledCache
        { pcLibrary :: Maybe (Path Rel File)
pcLibrary = Maybe (Path Rel File)
mlibpath
        , pcSubLibs :: [Path Rel File]
pcSubLibs = [Path Rel File]
sublibpaths
        , pcExes :: [Path Rel File]
pcExes = [Path Rel File]
exes'
        }
  forall env.
(HasConfig env, HasLogFunc env) =>
PrecompiledCacheKey -> PrecompiledCache Rel -> RIO env ()
savePrecompiledCache PrecompiledCacheKey
key PrecompiledCache Rel
precompiled
  -- reuse precompiled cache with haddocks also in case when haddocks are not

  -- required

  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
buildHaddocks forall a b. (a -> b) -> a -> b
$ do
    PrecompiledCacheKey
key' <- forall env.
HasEnvConfig env =>
PackageLocationImmutable
-> ConfigureOpts
-> Bool
-> Set GhcPkgId
-> RIO env PrecompiledCacheKey
getPrecompiledCacheKey PackageLocationImmutable
loc ConfigureOpts
copts Bool
False Set GhcPkgId
depIDs
    forall env.
(HasConfig env, HasLogFunc env) =>
PrecompiledCacheKey -> PrecompiledCache Rel -> RIO env ()
savePrecompiledCache PrecompiledCacheKey
key' PrecompiledCache Rel
precompiled
 where
  pathFromPkgId :: (Path Abs File -> m b) -> GhcPkgId -> m b
pathFromPkgId Path Abs File -> m b
stackRootRelative GhcPkgId
ipid = do
    Path Rel File
ipid' <- forall (m :: * -> *). MonadThrow m => String -> m (Path Rel File)
parseRelFile forall a b. (a -> b) -> a -> b
$ GhcPkgId -> String
ghcPkgIdString GhcPkgId
ipid forall a. [a] -> [a] -> [a]
++ String
".conf"
    Path Abs File -> m b
stackRootRelative forall a b. (a -> b) -> a -> b
$ BaseConfigOpts -> Path Abs Dir
bcoSnapDB BaseConfigOpts
baseConfigOpts forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
ipid'

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

-- configuration.

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

                     -> ConfigureOpts
                     -> Bool -- ^ build haddocks

                     -> Set GhcPkgId -- ^ dependencies

                     -> RIO env (Maybe (PrecompiledCache Abs))
readPrecompiledCache :: forall env.
HasEnvConfig env =>
PackageLocationImmutable
-> ConfigureOpts
-> Bool
-> Set GhcPkgId
-> RIO env (Maybe (PrecompiledCache Abs))
readPrecompiledCache PackageLocationImmutable
loc ConfigureOpts
copts Bool
buildHaddocks Set GhcPkgId
depIDs = do
  PrecompiledCacheKey
key <- forall env.
HasEnvConfig env =>
PackageLocationImmutable
-> ConfigureOpts
-> Bool
-> Set GhcPkgId
-> RIO env PrecompiledCacheKey
getPrecompiledCacheKey PackageLocationImmutable
loc ConfigureOpts
copts Bool
buildHaddocks Set GhcPkgId
depIDs
  Maybe (PrecompiledCache Rel)
mcache <- forall env.
(HasConfig env, HasLogFunc env) =>
PrecompiledCacheKey -> RIO env (Maybe (PrecompiledCache Rel))
loadPrecompiledCache PrecompiledCacheKey
key
  forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrecompiledCache Rel -> RIO env (PrecompiledCache Abs)
mkAbs) Maybe (PrecompiledCache Rel)
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
    Path Abs Dir
stackRoot <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall s. HasConfig s => Lens' s (Path Abs Dir)
stackRootL
    let mkAbs' :: Path Rel t -> Path Abs t
mkAbs' = (Path Abs Dir
stackRoot </>)
    forall (f :: * -> *) a. Applicative f => a -> f a
pure PrecompiledCache
      { pcLibrary :: Maybe (Path Abs File)
pcLibrary = forall {t}. Path Rel t -> Path Abs t
mkAbs' forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall base. PrecompiledCache base -> Maybe (Path base File)
pcLibrary PrecompiledCache Rel
pc0
      , pcSubLibs :: [Path Abs File]
pcSubLibs = forall {t}. Path Rel t -> Path Abs t
mkAbs' forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall base. PrecompiledCache base -> [Path base File]
pcSubLibs PrecompiledCache Rel
pc0
      , pcExes :: [Path Abs File]
pcExes = forall {t}. Path Rel t -> Path Abs t
mkAbs' forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall base. PrecompiledCache base -> [Path base File]
pcExes PrecompiledCache Rel
pc0
      }