{-# 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
, setTestBuilt
, unsetTestBuilt
, checkTestBuilt
, setBenchBuilt
, unsetBenchBuilt
, checkBenchBuilt
, 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 = get' dir >>= decodeFileOrFailDeep . toFilePath
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 (toFilePath 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 =
flagCacheFile gid >>= decodeFileOrFailDeep . toFilePath
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 (toFilePath 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)
setTestBuilt :: (MonadIO m, MonadLogger m, MonadThrow m, MonadReader env m, HasConfig env, HasEnvConfig env)
=> Path Abs Dir
-> m ()
setTestBuilt dir =
writeCache
dir
testBuiltFile
True
unsetTestBuilt :: (MonadIO m, MonadLogger m, MonadThrow m, MonadReader env m, HasConfig env, HasEnvConfig env)
=> Path Abs Dir
-> m ()
unsetTestBuilt dir =
writeCache
dir
testBuiltFile
False
checkTestBuilt :: (MonadIO m, MonadLogger m, MonadThrow m, MonadReader env m, HasConfig env, HasEnvConfig env)
=> Path Abs Dir
-> m Bool
checkTestBuilt dir =
liftM
(fromMaybe False)
(tryGetCache testBuiltFile dir)
setBenchBuilt :: (MonadIO m, MonadLogger m, MonadThrow m, MonadReader env m, HasConfig env, HasEnvConfig env)
=> Path Abs Dir
-> m ()
setBenchBuilt dir =
writeCache
dir
benchBuiltFile
True
unsetBenchBuilt :: (MonadIO m, MonadLogger m, MonadThrow m, MonadReader env m, HasConfig env, HasEnvConfig env)
=> Path Abs Dir
-> m ()
unsetBenchBuilt dir =
writeCache
dir
benchBuiltFile
False
checkBenchBuilt :: (MonadIO m, MonadLogger m, MonadThrow m, MonadReader env m, HasConfig env, HasEnvConfig env)
=> Path Abs Dir
-> m Bool
checkBenchBuilt dir =
liftM
(fromMaybe False)
(tryGetCache benchBuiltFile dir)
precompiledCacheFile :: (MonadThrow m, MonadReader env m, HasEnvConfig env)
=> PackageIdentifier
-> ConfigureOpts
-> m (Path Abs File)
precompiledCacheFile pkgident copts = do
ec <- asks getEnvConfig
compiler <- parseRelDir $ T.unpack $ compilerVersionName $ envConfigCompilerVersion ec
cabal <- parseRelDir $ versionString $ envConfigCabalVersion ec
pkg <- parseRelDir $ packageIdentifierString pkgident
copts' <- parseRelFile $ S8.unpack $ B16.encode $ SHA256.hashlazy $ Binary.encode $ coNoDirs copts
return $ getStackRoot ec
</> $(mkRelDir "precompiled")
</> compiler
</> cabal
</> pkg
</> copts'
writePrecompiledCache :: (MonadThrow m, MonadReader env m, HasEnvConfig env, MonadIO m)
=> BaseConfigOpts
-> PackageIdentifier
-> ConfigureOpts
-> Maybe GhcPkgId
-> Set Text
-> m ()
writePrecompiledCache baseConfigOpts pkgident copts mghcPkgId exes = do
file <- precompiledCacheFile pkgident copts
createTree $ parent file
mlibpath <-
case mghcPkgId of
Nothing -> return Nothing
Just 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 (toFilePath file) PrecompiledCache
{ pcLibrary = mlibpath
, pcExes = exes'
}
readPrecompiledCache :: (MonadThrow m, MonadReader env m, HasEnvConfig env, MonadIO m)
=> PackageIdentifier
-> ConfigureOpts
-> m (Maybe PrecompiledCache)
readPrecompiledCache pkgident copts = do
file <- precompiledCacheFile pkgident copts
decodeFileOrFailDeep $ toFilePath file