module Stack.Build.Cache
( tryGetBuildCache
, tryGetConfigCache
, tryGetCabalMod
, getInstalledExes
, tryGetFlagCache
, deleteCaches
, markExeInstalled
, markExeNotInstalled
, writeFlagCache
, writeBuildCache
, writeConfigCache
, writeCabalMod
, setTestSuccess
, unsetTestSuccess
, checkTestSuccess
, writePrecompiledCache
, readPrecompiledCache
, BuildCache(..)
) where
import Control.Applicative
import Control.DeepSeq (NFData)
import Control.Exception.Safe (handleIO, tryAnyDeep)
import Control.Monad (liftM)
import Control.Monad.Catch (MonadThrow, MonadCatch)
import Control.Monad.IO.Class
import Control.Monad.Logger (MonadLogger, logDebug)
import Control.Monad.Reader (MonadReader)
import Control.Monad.Trans.Control (MonadBaseControl)
import Crypto.Hash (hashWith, SHA256(..))
import Data.Binary (Binary (..))
import qualified Data.Binary as Binary
import Data.Binary.Tagged (HasStructuralInfo, HasSemanticVersion)
import qualified Data.Binary.Tagged as BinaryTagged
import qualified Data.ByteArray as Mem (convert)
import qualified Data.ByteArray.Encoding as Mem (convertToBase, Base(Base16))
import qualified Data.ByteString.Base64.URL as B64URL
import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy as LBS
import Data.Foldable (forM_)
import Data.Map (Map)
import qualified Data.Map as M
import Data.Maybe (fromMaybe, mapMaybe)
import Data.Monoid ((<>))
import Data.Set (Set)
import qualified Data.Set as Set
import qualified Data.Store as Store
import Data.Store.VersionTagged
import Data.Text (Text)
import qualified Data.Text as T
import Data.Traversable (forM)
import Path
import Path.IO
import Prelude
import Stack.Constants
import Stack.Types.Build
import Stack.Types.Compiler
import Stack.Types.Config
import Stack.Types.GhcPkgId
import Stack.Types.Package
import Stack.Types.PackageIdentifier
import Stack.Types.Version
import qualified System.FilePath as FilePath
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 ([], [])) $ listDir dir
return $
concat $
M.elems $
M.fromListWith (\_ _ -> []) $
map (\x -> (packageIdentifierName x, [x])) $
mapMaybe (parsePackageIdentifierFromString . toFilePath . filename) files
markExeInstalled :: (MonadReader env m, HasEnvConfig env, MonadIO m, MonadCatch m)
=> InstallLocation -> PackageIdentifier -> m ()
markExeInstalled loc ident = do
dir <- exeInstalledDir loc
ensureDir dir
ident' <- parseRelFile $ packageIdentifierString ident
let fp = toFilePath $ dir </> ident'
installed <- getInstalledExes loc
forM_ (filter (\x -> packageIdentifierName ident == packageIdentifierName x) installed)
(markExeNotInstalled loc)
liftIO $ writeFile fp "Installed"
markExeNotInstalled :: (MonadReader env m, HasEnvConfig env, MonadIO m, MonadCatch m)
=> InstallLocation -> PackageIdentifier -> m ()
markExeNotInstalled loc ident = do
dir <- exeInstalledDir loc
ident' <- parseRelFile $ packageIdentifierString ident
ignoringAbsence (removeFile $ dir </> ident')
tryGetBuildCache :: (MonadIO m, MonadReader env m, MonadThrow m, MonadLogger m, HasEnvConfig env, MonadBaseControl IO m)
=> Path Abs Dir -> m (Maybe (Map FilePath FileCacheInfo))
tryGetBuildCache dir = liftM (fmap buildCacheTimes) . $(versionedDecodeFile buildCacheVC) =<< buildCacheFile dir
tryGetConfigCache :: (MonadIO m, MonadReader env m, MonadThrow m, HasEnvConfig env, MonadBaseControl IO m, MonadLogger m)
=> Path Abs Dir -> m (Maybe ConfigCache)
tryGetConfigCache dir = $(versionedDecodeFile configCacheVC) =<< configCacheFile dir
tryGetCabalMod :: (MonadIO m, MonadReader env m, MonadThrow m, HasEnvConfig env, MonadBaseControl IO m, MonadLogger m)
=> Path Abs Dir -> m (Maybe ModTime)
tryGetCabalMod dir = $(versionedDecodeFile modTimeVC) =<< configCabalMod dir
writeBuildCache :: (MonadIO m, MonadReader env m, MonadThrow m, HasEnvConfig env, MonadLogger m)
=> Path Abs Dir -> Map FilePath FileCacheInfo -> m ()
writeBuildCache dir times = do
fp <- buildCacheFile dir
$(versionedEncodeFile buildCacheVC) fp BuildCache
{ buildCacheTimes = times
}
writeConfigCache :: (MonadIO m, MonadReader env m, MonadThrow m, HasEnvConfig env, MonadLogger m)
=> Path Abs Dir
-> ConfigCache
-> m ()
writeConfigCache dir x = do
fp <- configCacheFile dir
$(versionedEncodeFile configCacheVC) fp x
writeCabalMod :: (MonadIO m, MonadReader env m, MonadThrow m, HasEnvConfig env, MonadLogger m)
=> Path Abs Dir
-> ModTime
-> m ()
writeCabalMod dir x = do
fp <- configCabalMod dir
$(versionedEncodeFile modTimeVC) fp x
deleteCaches :: (MonadIO m, MonadReader env m, MonadCatch m, HasEnvConfig env)
=> Path Abs Dir -> m ()
deleteCaches dir = do
cfp <- configCacheFile dir
ignoringAbsence (removeFile cfp)
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, MonadBaseControl IO m, MonadLogger m)
=> Installed
-> m (Maybe ConfigCache)
tryGetFlagCache gid = do
fp <- flagCacheFile gid
$(versionedDecodeFile configCacheVC) fp
writeFlagCache :: (MonadIO m, MonadReader env m, HasEnvConfig env, MonadThrow m, MonadLogger m)
=> Installed
-> ConfigCache
-> m ()
writeFlagCache gid cache = do
file <- flagCacheFile gid
ensureDir (parent file)
$(versionedEncodeFile configCacheVC) file cache
setTestSuccess :: (MonadIO m, MonadThrow m, MonadReader env m, HasEnvConfig env, MonadLogger m)
=> Path Abs Dir
-> m ()
setTestSuccess dir = do
fp <- testSuccessFile dir
$(versionedEncodeFile testSuccessVC) fp True
unsetTestSuccess :: (MonadIO m, MonadThrow m, MonadReader env m, HasEnvConfig env, MonadLogger m)
=> Path Abs Dir
-> m ()
unsetTestSuccess dir = do
fp <- testSuccessFile dir
$(versionedEncodeFile testSuccessVC) fp False
checkTestSuccess :: (MonadIO m, MonadThrow m, MonadReader env m, HasEnvConfig env, MonadBaseControl IO m, MonadLogger m)
=> Path Abs Dir
-> m Bool
checkTestSuccess dir =
liftM
(fromMaybe False)
($(versionedDecodeFile testSuccessVC) =<< testSuccessFile dir)
precompiledCacheFile :: (MonadThrow m, MonadReader env m, HasEnvConfig env, MonadLogger m)
=> PackageIdentifier
-> ConfigureOpts
-> Set GhcPkgId
-> m (Path Abs File, m (Path Abs File))
precompiledCacheFile pkgident copts installedPackageIDs = do
ec <- view envConfigL
compiler <- view actualCompilerVersionL >>= parseRelDir . compilerVersionString
cabal <- view cabalVersionL >>= parseRelDir . versionString
pkg <- parseRelDir $ packageIdentifierString pkgident
platformRelDir <- platformGhcRelDir
let input = (coNoDirs copts, installedPackageIDs)
let oldHash = Mem.convertToBase Mem.Base16 $ hashWith SHA256 $ LBS.toStrict $
if view cabalVersionL ec >= $(mkVersion "1.22")
then Binary.encode (coNoDirs copts)
else Binary.encode input
hashToPath hash = do
hashPath <- parseRelFile $ S8.unpack hash
return $ view stackRootL ec
</> $(mkRelDir "precompiled")
</> platformRelDir
</> compiler
</> cabal
</> pkg
</> hashPath
$logDebug $ "Precompiled cache input = " <> T.pack (show input)
newPath <- hashToPath $ B64URL.encode $ Mem.convert $ hashWith SHA256 $ Store.encode input
return (newPath, hashToPath oldHash)
writePrecompiledCache :: (MonadThrow m, MonadReader env m, HasEnvConfig env, MonadIO m, MonadLogger m)
=> BaseConfigOpts
-> PackageIdentifier
-> ConfigureOpts
-> Set GhcPkgId
-> Installed
-> Set Text
-> m ()
writePrecompiledCache baseConfigOpts pkgident copts depIDs mghcPkgId exes = do
(file, _) <- precompiledCacheFile pkgident copts depIDs
ensureDir (parent file)
ec <- view envConfigL
let stackRootRelative = makeRelative (view stackRootL ec)
mlibpath <-
case mghcPkgId of
Executable _ -> return Nothing
Library _ ipid -> liftM Just $ do
ipid' <- parseRelFile $ ghcPkgIdString ipid ++ ".conf"
relPath <- stackRootRelative $ bcoSnapDB baseConfigOpts </> ipid'
return $ toFilePath relPath
exes' <- forM (Set.toList exes) $ \exe -> do
name <- parseRelFile $ T.unpack exe
relPath <- stackRootRelative $ bcoSnapInstallRoot baseConfigOpts </> bindirSuffix </> name
return $ toFilePath relPath
$(versionedEncodeFile precompiledCacheVC) file PrecompiledCache
{ pcLibrary = mlibpath
, pcExes = exes'
}
readPrecompiledCache :: (MonadThrow m, MonadReader env m, HasEnvConfig env, MonadIO m, MonadLogger m, MonadBaseControl IO m)
=> PackageIdentifier
-> ConfigureOpts
-> Set GhcPkgId
-> m (Maybe PrecompiledCache)
readPrecompiledCache pkgident copts depIDs = do
ec <- view envConfigL
let toAbsPath path = do
if FilePath.isAbsolute path
then path
else toFilePath (view stackRootL ec) FilePath.</> path
let toAbsPC pc =
PrecompiledCache
{ pcLibrary = fmap toAbsPath (pcLibrary pc)
, pcExes = map toAbsPath (pcExes pc)
}
(file, getOldFile) <- precompiledCacheFile pkgident copts depIDs
mres <- $(versionedDecodeFile precompiledCacheVC) file
case mres of
Just res -> return (Just $ toAbsPC res)
Nothing -> do
oldFile <- getOldFile
mpc <- fmap toAbsPC <$> binaryDecodeFileOrFailDeep oldFile
forM_ mpc ($(versionedEncodeFile precompiledCacheVC) file)
return mpc
binaryDecodeFileOrFailDeep :: (BinarySchema a, MonadIO m)
=> Path loc File
-> m (Maybe a)
binaryDecodeFileOrFailDeep fp = liftIO $ fmap (either (const Nothing) id) $ tryAnyDeep $ do
eres <- BinaryTagged.taggedDecodeFileOrFail (toFilePath fp)
case eres of
Left _ -> return Nothing
Right x -> return (Just x)
type BinarySchema a = (Binary a, NFData a, HasStructuralInfo a, HasSemanticVersion a)