{-# LANGUAGE NoImplicitPrelude     #-}
{-# LANGUAGE ConstraintKinds       #-}
{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE ScopedTypeVariables   #-}

-- | 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           Stack.Prelude
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
import           Path.IO
import           Stack.Constants
import           Stack.Constants.Config
import           Stack.Storage.Project
import           Stack.Storage.User
import           Stack.Types.Build
import           Stack.Types.Cache
import           Stack.Types.Config
import           Stack.Types.GhcPkgId
import           Stack.Types.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 (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` 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 (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` 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 (m :: * -> *) a. Monad m => a -> m a
return ([], [])) 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 (m :: * -> *) a. Monad m => a -> m a
return 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 (m :: * -> *) a. Monad m => a -> m a
return 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 (m :: * -> *) a. Monad m => a -> m a
return 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 (m :: * -> *) a. Monad m => a -> m a
return 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 :: * -> *).
(MonadReader env m, HasEnvConfig env, 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 (m :: * -> *) a. Monad m => a -> m a
return 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 (m :: * -> *) a. Monad m => a -> m a
return 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 b t. Path b Dir -> Path Rel t -> Path b t
</>)
      forall (m :: * -> *) a. Monad m => a -> m a
return 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
        }