{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ConstraintKinds #-}
module Stack.Build.Cache
( tryGetBuildCache
, tryGetConfigCache
, tryGetCabalMod
, getInstalledExes
, buildCacheTimes
, tryGetFlagCache
, deleteCaches
, markExeInstalled
, markExeNotInstalled
, writeFlagCache
, writeBuildCache
, writeConfigCache
, writeCabalMod
, setTestSuccess
, unsetTestSuccess
, checkTestSuccess
, writePrecompiledCache
, readPrecompiledCache
) where
import Control.Exception.Enclosed (handleIO)
import Control.Monad.Catch (MonadThrow)
import Control.Monad.IO.Class
import Control.Monad.Logger (MonadLogger)
import Control.Monad.Reader
import qualified Crypto.Hash.SHA256 as SHA256
import qualified Data.Binary as Binary (encode)
import Data.Binary.VersionTagged
import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Base16 as B16
import Data.Map (Map)
import Data.Maybe (fromMaybe, mapMaybe)
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Text (Text)
import qualified Data.Text as T
import GHC.Generics (Generic)
import Path
import Path.IO
import Stack.Types.Build
import Stack.Constants
import Stack.Types
exeInstalledDir :: (MonadReader env m, HasEnvConfig env, MonadThrow m)
=> InstallLocation -> m (Path Abs Dir)
exeInstalledDir Snap = (</> $(mkRelDir "installed-packages")) `liftM` installationRootDeps
exeInstalledDir Local = (</> $(mkRelDir "installed-packages")) `liftM` installationRootLocal
getInstalledExes :: (MonadReader env m, HasEnvConfig env, MonadIO m, MonadThrow m)
=> InstallLocation -> m [PackageIdentifier]
getInstalledExes loc = do
dir <- exeInstalledDir loc
(_, files) <- liftIO $ handleIO (const $ return ([], [])) $ listDirectory dir
return $ mapMaybe (parsePackageIdentifierFromString . toFilePath . filename) files
markExeInstalled :: (MonadReader env m, HasEnvConfig env, MonadIO m, MonadThrow m)
=> InstallLocation -> PackageIdentifier -> m ()
markExeInstalled loc ident = do
dir <- exeInstalledDir loc
createTree dir
ident' <- parseRelFile $ packageIdentifierString ident
let fp = toFilePath $ dir </> ident'
liftIO $ writeFile fp "Installed"
markExeNotInstalled :: (MonadReader env m, HasEnvConfig env, MonadIO m, MonadThrow m)
=> InstallLocation -> PackageIdentifier -> m ()
markExeNotInstalled loc ident = do
dir <- exeInstalledDir loc
ident' <- parseRelFile $ packageIdentifierString ident
removeFileIfExists (dir </> ident')
data BuildCache = BuildCache
{ buildCacheTimes :: !(Map FilePath FileCacheInfo)
}
deriving (Generic)
instance Binary BuildCache
instance HasStructuralInfo BuildCache
instance HasSemanticVersion BuildCache
instance NFData BuildCache
tryGetBuildCache :: (MonadIO m, MonadReader env m, HasConfig env, MonadThrow m, MonadLogger m, HasEnvConfig env)
=> Path Abs Dir -> m (Maybe (Map FilePath FileCacheInfo))
tryGetBuildCache = liftM (fmap buildCacheTimes) . tryGetCache buildCacheFile
tryGetConfigCache :: (MonadIO m, MonadReader env m, HasConfig env, MonadThrow m, MonadLogger m, HasEnvConfig env)
=> Path Abs Dir -> m (Maybe ConfigCache)
tryGetConfigCache = tryGetCache configCacheFile
tryGetCabalMod :: (MonadIO m, MonadReader env m, HasConfig env, MonadThrow m, MonadLogger m, HasEnvConfig env)
=> Path Abs Dir -> m (Maybe ModTime)
tryGetCabalMod = tryGetCache configCabalMod
tryGetCache :: (MonadIO m, BinarySchema a)
=> (Path Abs Dir -> m (Path Abs File))
-> Path Abs Dir
-> m (Maybe a)
tryGetCache get' dir = do
fp <- get' dir
decodeFileOrFailDeep fp
writeBuildCache :: (MonadIO m, MonadReader env m, HasConfig env, MonadThrow m, MonadLogger m, HasEnvConfig env)
=> Path Abs Dir -> Map FilePath FileCacheInfo -> m ()
writeBuildCache dir times =
writeCache
dir
buildCacheFile
BuildCache
{ buildCacheTimes = times
}
writeConfigCache :: (MonadIO m, MonadReader env m, HasConfig env, MonadThrow m, MonadLogger m, HasEnvConfig env)
=> Path Abs Dir
-> ConfigCache
-> m ()
writeConfigCache dir = writeCache dir configCacheFile
writeCabalMod :: (MonadIO m, MonadReader env m, HasConfig env, MonadThrow m, MonadLogger m, HasEnvConfig env)
=> Path Abs Dir
-> ModTime
-> m ()
writeCabalMod dir = writeCache dir configCabalMod
deleteCaches :: (MonadIO m, MonadReader env m, HasConfig env, MonadLogger m, MonadThrow m, HasEnvConfig env)
=> Path Abs Dir -> m ()
deleteCaches dir = do
cfp <- configCacheFile dir
removeFileIfExists cfp
writeCache :: (BinarySchema a, MonadIO m)
=> Path Abs Dir
-> (Path Abs Dir -> m (Path Abs File))
-> a
-> m ()
writeCache dir get' content = do
fp <- get' dir
taggedEncodeFile fp content
flagCacheFile :: (MonadIO m, MonadThrow m, MonadReader env m, HasEnvConfig env)
=> Installed
-> m (Path Abs File)
flagCacheFile installed = do
rel <- parseRelFile $
case installed of
Library _ gid -> ghcPkgIdString gid
Executable ident -> packageIdentifierString ident
dir <- flagCacheLocal
return $ dir </> rel
tryGetFlagCache :: (MonadIO m, MonadThrow m, MonadReader env m, HasEnvConfig env)
=> Installed
-> m (Maybe ConfigCache)
tryGetFlagCache gid = do
fp <- flagCacheFile gid
decodeFileOrFailDeep fp
writeFlagCache :: (MonadIO m, MonadReader env m, HasEnvConfig env, MonadThrow m)
=> Installed
-> ConfigCache
-> m ()
writeFlagCache gid cache = do
file <- flagCacheFile gid
liftIO $ do
createTree (parent file)
taggedEncodeFile file cache
setTestSuccess :: (MonadIO m, MonadLogger m, MonadThrow m, MonadReader env m, HasConfig env, HasEnvConfig env)
=> Path Abs Dir
-> m ()
setTestSuccess dir =
writeCache
dir
testSuccessFile
True
unsetTestSuccess :: (MonadIO m, MonadLogger m, MonadThrow m, MonadReader env m, HasConfig env, HasEnvConfig env)
=> Path Abs Dir
-> m ()
unsetTestSuccess dir =
writeCache
dir
testSuccessFile
False
checkTestSuccess :: (MonadIO m, MonadLogger m, MonadThrow m, MonadReader env m, HasConfig env, HasEnvConfig env)
=> Path Abs Dir
-> m Bool
checkTestSuccess dir =
liftM
(fromMaybe False)
(tryGetCache testSuccessFile dir)
precompiledCacheFile :: (MonadThrow m, MonadReader env m, HasEnvConfig env)
=> PackageIdentifier
-> ConfigureOpts
-> Set GhcPkgId
-> m (Path Abs File)
precompiledCacheFile pkgident copts installedPackageIDs = do
ec <- asks getEnvConfig
compiler <- parseRelDir $ compilerVersionString $ envConfigCompilerVersion ec
cabal <- parseRelDir $ versionString $ envConfigCabalVersion ec
pkg <- parseRelDir $ packageIdentifierString pkgident
let cacheInput
| envConfigCabalVersion ec >= $(mkVersion "1.22") =
Binary.encode $ coNoDirs copts
| otherwise =
Binary.encode
( coNoDirs copts
, installedPackageIDs
)
copts' <- parseRelFile $ S8.unpack $ B16.encode $ SHA256.hashlazy cacheInput
return $ getStackRoot ec
</> $(mkRelDir "precompiled")
</> compiler
</> cabal
</> pkg
</> copts'
writePrecompiledCache :: (MonadThrow m, MonadReader env m, HasEnvConfig env, MonadIO m)
=> BaseConfigOpts
-> PackageIdentifier
-> ConfigureOpts
-> Set GhcPkgId
-> Installed
-> Set Text
-> m ()
writePrecompiledCache baseConfigOpts pkgident copts depIDs mghcPkgId exes = do
file <- precompiledCacheFile pkgident copts depIDs
createTree $ parent file
mlibpath <-
case mghcPkgId of
Executable _ -> return Nothing
Library _ ipid -> liftM Just $ do
ipid' <- parseRelFile $ ghcPkgIdString ipid ++ ".conf"
return $ toFilePath $ bcoSnapDB baseConfigOpts </> ipid'
exes' <- forM (Set.toList exes) $ \exe -> do
name <- parseRelFile $ T.unpack exe
return $ toFilePath $ bcoSnapInstallRoot baseConfigOpts </> bindirSuffix </> name
liftIO $ taggedEncodeFile file PrecompiledCache
{ pcLibrary = mlibpath
, pcExes = exes'
}
readPrecompiledCache :: (MonadThrow m, MonadReader env m, HasEnvConfig env, MonadIO m)
=> PackageIdentifier
-> ConfigureOpts
-> Set GhcPkgId
-> m (Maybe PrecompiledCache)
readPrecompiledCache pkgident copts depIDs = do
file <- precompiledCacheFile pkgident copts depIDs
decodeFileOrFailDeep file