{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleContexts #-}
module Stack.Build.Cache
( tryGetBuildCache
, tryGetConfigCache
, tryGetCabalMod
, tryGetSetupConfigMod
, getInstalledExes
, tryGetFlagCache
, deleteCaches
, markExeInstalled
, markExeNotInstalled
, writeFlagCache
, writeBuildCache
, writeConfigCache
, writeCabalMod
, TestStatus (..)
, setTestStatus
, getTestStatus
, writePrecompiledCache
, readPrecompiledCache
, BuildCache(..)
) where
import Stack.Prelude
import Crypto.Hash (hashWith, SHA256(..))
import qualified Data.ByteArray as Mem (convert)
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)
exeInstalledDir :: (HasEnvConfig env)
=> InstallLocation -> RIO env (Path Abs Dir)
exeInstalledDir Snap = (</> relDirInstalledPackages) `liftM` installationRootDeps
exeInstalledDir Local = (</> relDirInstalledPackages) `liftM` installationRootLocal
getInstalledExes :: (HasEnvConfig env)
=> InstallLocation -> RIO env [PackageIdentifier]
getInstalledExes loc = do
dir <- exeInstalledDir loc
(_, files) <- liftIO $ handleIO (const $ return ([], [])) $ listDir dir
return $
concat $
M.elems $
M.fromListWith (\_ _ -> []) $
map (\x -> (pkgName x, [x])) $
mapMaybe (parsePackageIdentifier . toFilePath . filename) files
markExeInstalled :: (HasEnvConfig env)
=> InstallLocation -> PackageIdentifier -> RIO env ()
markExeInstalled loc ident = do
dir <- exeInstalledDir loc
ensureDir dir
ident' <- parseRelFile $ packageIdentifierString ident
let fp = dir </> ident'
installed <- getInstalledExes loc
forM_ (filter (\x -> pkgName ident == pkgName x) installed)
(markExeNotInstalled loc)
writeBinaryFileAtomic fp "Installed"
markExeNotInstalled :: (HasEnvConfig env)
=> InstallLocation -> PackageIdentifier -> RIO env ()
markExeNotInstalled loc ident = do
dir <- exeInstalledDir loc
ident' <- parseRelFile $ packageIdentifierString ident
liftIO $ ignoringAbsence (removeFile $ dir </> ident')
buildCacheFile :: (HasEnvConfig env, MonadReader env m, MonadThrow m)
=> Path Abs Dir
-> NamedComponent
-> m (Path Abs File)
buildCacheFile dir component = do
cachesDir <- buildCachesDir dir
smh <- view $ envConfigL.to envConfigSourceMapHash
smDirName <- smRelDir smh
let nonLibComponent prefix name = prefix <> "-" <> T.unpack name
cacheFileName <- parseRelFile $ case component of
CLib -> "lib"
CInternalLib name -> nonLibComponent "internal-lib" name
CExe name -> nonLibComponent "exe" name
CTest name -> nonLibComponent "test" name
CBench name -> nonLibComponent "bench" name
return $ cachesDir </> smDirName </> cacheFileName
tryGetBuildCache :: HasEnvConfig env
=> Path Abs Dir
-> NamedComponent
-> RIO env (Maybe (Map FilePath FileCacheInfo))
tryGetBuildCache dir component = do
fp <- buildCacheFile dir component
ensureDir $ parent fp
either (const Nothing) (Just . buildCacheTimes) <$>
liftIO (tryAny (Yaml.decodeFileThrow (toFilePath fp)))
tryGetConfigCache :: HasEnvConfig env
=> Path Abs Dir -> RIO env (Maybe ConfigCache)
tryGetConfigCache dir =
loadConfigCache $ configCacheKey dir ConfigCacheTypeConfig
tryGetCabalMod :: HasEnvConfig env
=> Path Abs Dir -> RIO env (Maybe CTime)
tryGetCabalMod dir = do
fp <- toFilePath <$> configCabalMod dir
tryGetFileMod fp
tryGetSetupConfigMod :: HasEnvConfig env
=> Path Abs Dir -> RIO env (Maybe CTime)
tryGetSetupConfigMod dir = do
fp <- toFilePath <$> configSetupConfigMod dir
tryGetFileMod fp
tryGetFileMod :: MonadIO m => FilePath -> m (Maybe CTime)
tryGetFileMod fp =
liftIO $ either (const Nothing) (Just . modificationTime) <$>
tryIO (getFileStatus fp)
writeBuildCache :: HasEnvConfig env
=> Path Abs Dir
-> NamedComponent
-> Map FilePath FileCacheInfo -> RIO env ()
writeBuildCache dir component times = do
fp <- toFilePath <$> buildCacheFile dir component
liftIO $ Yaml.encodeFile fp BuildCache
{ buildCacheTimes = times
}
writeConfigCache :: HasEnvConfig env
=> Path Abs Dir
-> ConfigCache
-> RIO env ()
writeConfigCache dir =
saveConfigCache (configCacheKey dir ConfigCacheTypeConfig)
writeCabalMod :: HasEnvConfig env
=> Path Abs Dir
-> CTime
-> RIO env ()
writeCabalMod dir x = do
fp <- configCabalMod dir
writeBinaryFileAtomic fp "Just used for its modification time"
liftIO $ setFileTimes (toFilePath fp) x x
deleteCaches :: HasEnvConfig env => Path Abs Dir -> RIO env ()
deleteCaches dir
= deactiveConfigCache $ configCacheKey dir ConfigCacheTypeConfig
flagCacheKey :: (HasEnvConfig env) => Installed -> RIO env ConfigCacheKey
flagCacheKey installed = do
installationRoot <- installationRootLocal
case installed of
Library _ gid _ ->
return $
configCacheKey installationRoot (ConfigCacheTypeFlagLibrary gid)
Executable ident ->
return $
configCacheKey
installationRoot
(ConfigCacheTypeFlagExecutable ident)
tryGetFlagCache :: HasEnvConfig env
=> Installed
-> RIO env (Maybe ConfigCache)
tryGetFlagCache gid = do
key <- flagCacheKey gid
loadConfigCache key
writeFlagCache :: HasEnvConfig env
=> Installed
-> ConfigCache
-> RIO env ()
writeFlagCache gid cache = do
key <- flagCacheKey gid
saveConfigCache key cache
successBS, failureBS, unknownBS :: IsString s => s
successBS = "success"
failureBS = "failure"
unknownBS = "unknown"
data TestStatus = TSSuccess | TSFailure | TSUnknown
setTestStatus :: HasEnvConfig env
=> Path Abs Dir
-> TestStatus
-> RIO env ()
setTestStatus dir status = do
fp <- testSuccessFile dir
writeBinaryFileAtomic fp $
case status of
TSSuccess -> successBS
TSFailure -> failureBS
TSUnknown -> unknownBS
getTestStatus :: HasEnvConfig env
=> Path Abs Dir
-> RIO env TestStatus
getTestStatus dir = do
fp <- testSuccessFile dir
eres <- tryIO (readFileBinary $ toFilePath fp)
pure $
case eres of
Right bs
| bs == successBS -> TSSuccess
| bs == failureBS -> TSFailure
_ -> TSUnknown
getPrecompiledCacheKey :: HasEnvConfig env
=> PackageLocationImmutable
-> ConfigureOpts
-> Bool
-> Set GhcPkgId
-> RIO env PrecompiledCacheKey
getPrecompiledCacheKey loc copts buildHaddocks installedPackageIDs = do
compiler <- view actualCompilerVersionL
cabalVersion <- view cabalVersionL
treeKey <- getPackageLocationTreeKey loc
let packageKey = utf8BuilderToText $ display treeKey
platformGhcDir <- platformGhcRelDir
let input = (coNoDirs copts, installedPackageIDs)
optionsHash = Mem.convert $ hashWith SHA256 $ encodeUtf8 $ tshow input
return $ precompiledCacheKey platformGhcDir compiler cabalVersion packageKey optionsHash buildHaddocks
writePrecompiledCache :: HasEnvConfig env
=> BaseConfigOpts
-> PackageLocationImmutable
-> ConfigureOpts
-> Bool
-> Set GhcPkgId
-> Installed
-> [GhcPkgId]
-> Set Text
-> RIO env ()
writePrecompiledCache baseConfigOpts loc copts buildHaddocks depIDs mghcPkgId sublibs exes = do
key <- getPrecompiledCacheKey loc copts buildHaddocks depIDs
ec <- view envConfigL
let stackRootRelative = makeRelative (view stackRootL ec)
mlibpath <- case mghcPkgId of
Executable _ -> return Nothing
Library _ ipid _ -> Just <$> pathFromPkgId stackRootRelative ipid
sublibpaths <- mapM (pathFromPkgId stackRootRelative) sublibs
exes' <- forM (Set.toList exes) $ \exe -> do
name <- parseRelFile $ T.unpack exe
stackRootRelative $ bcoSnapInstallRoot baseConfigOpts </> bindirSuffix </> name
let precompiled = PrecompiledCache
{ pcLibrary = mlibpath
, pcSubLibs = sublibpaths
, pcExes = exes'
}
savePrecompiledCache key precompiled
when buildHaddocks $ do
key' <- getPrecompiledCacheKey loc copts False depIDs
savePrecompiledCache key' precompiled
where
pathFromPkgId stackRootRelative ipid = do
ipid' <- parseRelFile $ ghcPkgIdString ipid ++ ".conf"
stackRootRelative $ bcoSnapDB baseConfigOpts </> ipid'
readPrecompiledCache :: forall env. HasEnvConfig env
=> PackageLocationImmutable
-> ConfigureOpts
-> Bool
-> Set GhcPkgId
-> RIO env (Maybe (PrecompiledCache Abs))
readPrecompiledCache loc copts buildHaddocks depIDs = do
key <- getPrecompiledCacheKey loc copts buildHaddocks depIDs
mcache <- loadPrecompiledCache key
maybe (pure Nothing) (fmap Just . mkAbs) mcache
where
mkAbs :: PrecompiledCache Rel -> RIO env (PrecompiledCache Abs)
mkAbs pc0 = do
stackRoot <- view stackRootL
let mkAbs' = (stackRoot </>)
return PrecompiledCache
{ pcLibrary = mkAbs' <$> pcLibrary pc0
, pcSubLibs = mkAbs' <$> pcSubLibs pc0
, pcExes = mkAbs' <$> pcExes pc0
}