{-# LANGUAGE CPP #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleContexts #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Stack.Build.Cache
( tryGetBuildCache
, tryGetConfigCache
, tryGetCabalMod
, getInstalledExes
, tryGetFlagCache
, deleteCaches
, markExeInstalled
, markExeNotInstalled
, writeFlagCache
, writeBuildCache
, writeConfigCache
, writeCabalMod
, setTestSuccess
, unsetTestSuccess
, checkTestSuccess
, writePrecompiledCache
, readPrecompiledCache
, BuildCache(..)
) where
import Stack.Prelude
import Crypto.Hash (hashWith, SHA256(..))
import Control.Monad.Trans.Maybe
import qualified Data.ByteArray as Mem (convert)
import qualified Data.ByteString.Base64.URL as B64URL
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as S8
#ifdef mingw32_HOST_OS
import Data.Char (ord)
#endif
import qualified Data.Map as M
import qualified Data.Set as Set
import qualified Data.Store as Store
import Data.Store.VersionTagged
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import Path
import Path.IO
import Stack.Constants.Config
import Stack.Types.Build
import Stack.Types.BuildPlan
import Stack.Types.Compiler
import Stack.Types.Config
import Stack.Types.GhcPkgId
import Stack.Types.NamedComponent
import Stack.Types.Package
import Stack.Types.PackageIdentifier
import Stack.Types.Version
import qualified System.FilePath as FP
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, MonadThrow 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 $ B.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
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
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 </> cacheFileName
tryGetBuildCache :: HasEnvConfig env
=> Path Abs Dir
-> NamedComponent
-> RIO env (Maybe (Map FilePath FileCacheInfo))
tryGetBuildCache dir component = liftM (fmap buildCacheTimes) . $(versionedDecodeFile buildCacheVC) =<< buildCacheFile dir component
tryGetConfigCache :: HasEnvConfig env
=> Path Abs Dir -> RIO env (Maybe ConfigCache)
tryGetConfigCache dir = $(versionedDecodeFile configCacheVC) =<< configCacheFile dir
tryGetCabalMod :: HasEnvConfig env
=> Path Abs Dir -> RIO env (Maybe ModTime)
tryGetCabalMod dir = $(versionedDecodeFile modTimeVC) =<< configCabalMod dir
writeBuildCache :: HasEnvConfig env
=> Path Abs Dir
-> NamedComponent
-> Map FilePath FileCacheInfo -> RIO env ()
writeBuildCache dir component times = do
fp <- buildCacheFile dir component
$(versionedEncodeFile buildCacheVC) fp BuildCache
{ buildCacheTimes = times
}
writeConfigCache :: HasEnvConfig env
=> Path Abs Dir
-> ConfigCache
-> RIO env ()
writeConfigCache dir x = do
fp <- configCacheFile dir
$(versionedEncodeFile configCacheVC) fp x
writeCabalMod :: HasEnvConfig env
=> Path Abs Dir
-> ModTime
-> RIO env ()
writeCabalMod dir x = do
fp <- configCabalMod dir
$(versionedEncodeFile modTimeVC) fp x
deleteCaches :: (MonadIO m, MonadReader env m, HasEnvConfig env, MonadThrow m)
=> Path Abs Dir -> m ()
deleteCaches dir = do
cfp <- configCacheFile dir
liftIO $ 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 :: HasEnvConfig env
=> Installed
-> RIO env (Maybe ConfigCache)
tryGetFlagCache gid = do
fp <- flagCacheFile gid
$(versionedDecodeFile configCacheVC) fp
writeFlagCache :: HasEnvConfig env
=> Installed
-> ConfigCache
-> RIO env ()
writeFlagCache gid cache = do
file <- flagCacheFile gid
ensureDir (parent file)
$(versionedEncodeFile configCacheVC) file cache
setTestSuccess :: HasEnvConfig env
=> Path Abs Dir
-> RIO env ()
setTestSuccess dir = do
fp <- testSuccessFile dir
$(versionedEncodeFile testSuccessVC) fp True
unsetTestSuccess :: HasEnvConfig env
=> Path Abs Dir
-> RIO env ()
unsetTestSuccess dir = do
fp <- testSuccessFile dir
$(versionedEncodeFile testSuccessVC) fp False
checkTestSuccess :: HasEnvConfig env
=> Path Abs Dir
-> RIO env Bool
checkTestSuccess dir =
liftM
(fromMaybe False)
($(versionedDecodeFile testSuccessVC) =<< testSuccessFile dir)
precompiledCacheFile :: HasEnvConfig env
=> PackageLocationIndex FilePath
-> ConfigureOpts
-> Set GhcPkgId
-> RIO env (Maybe (Path Abs File))
precompiledCacheFile loc copts installedPackageIDs = do
ec <- view envConfigL
compiler <- view actualCompilerVersionL >>= parseRelDir . compilerVersionString
cabal <- view cabalVersionL >>= parseRelDir . versionString
let mpkgRaw =
case loc of
PLIndex pir -> Just $ packageIdentifierRevisionString pir
PLOther other -> case other of
PLFilePath _ -> assert False Nothing
PLArchive a -> fmap
(\h -> T.unpack (staticSHA256ToText h) ++ archiveSubdirs a)
(archiveHash a)
PLRepo r -> Just $ T.unpack (repoCommit r) ++ repoSubdirs r
forM mpkgRaw $ \pkgRaw -> do
platformRelDir <- platformGhcRelDir
let precompiledDir =
view stackRootL ec
</> $(mkRelDir "precompiled")
</> platformRelDir
</> compiler
</> cabal
pkg <-
case parseRelDir pkgRaw of
Just x -> return x
Nothing -> parseRelDir
$ T.unpack
$ TE.decodeUtf8
$ B64URL.encode
$ TE.encodeUtf8
$ T.pack pkgRaw
let input = (coNoDirs copts, installedPackageIDs)
hashPath <- parseRelFile $ S8.unpack $ B64URL.encode
$ Mem.convert $ hashWith SHA256 $ Store.encode input
let longPath = precompiledDir </> pkg </> hashPath
if pathTooLong (toFilePath longPath) then do
shortPkg <- shaPath pkg
shortHash <- shaPath hashPath
return $ precompiledDir </> shortPkg </> shortHash
else
return longPath
writePrecompiledCache :: HasEnvConfig env
=> BaseConfigOpts
-> PackageLocationIndex FilePath
-> ConfigureOpts
-> Set GhcPkgId
-> Installed
-> [GhcPkgId]
-> Set Text
-> RIO env ()
writePrecompiledCache baseConfigOpts loc copts depIDs mghcPkgId sublibs exes = do
mfile <- precompiledCacheFile loc copts depIDs
forM_ mfile $ \file -> do
ensureDir (parent file)
ec <- view envConfigL
let stackRootRelative = makeRelative (view stackRootL ec)
mlibpath <- case mghcPkgId of
Executable _ -> return Nothing
Library _ ipid _ -> liftM Just $ pathFromPkgId stackRootRelative ipid
sublibpaths <- mapM (pathFromPkgId stackRootRelative) sublibs
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
, pcSubLibs = sublibpaths
, pcExes = exes'
}
where
pathFromPkgId stackRootRelative ipid = do
ipid' <- parseRelFile $ ghcPkgIdString ipid ++ ".conf"
relPath <- stackRootRelative $ bcoSnapDB baseConfigOpts </> ipid'
return $ toFilePath relPath
readPrecompiledCache :: forall env. HasEnvConfig env
=> PackageLocationIndex FilePath
-> ConfigureOpts
-> Set GhcPkgId
-> RIO env (Maybe PrecompiledCache)
readPrecompiledCache loc copts depIDs = runMaybeT $
MaybeT (precompiledCacheFile loc copts depIDs) >>=
MaybeT . $(versionedDecodeFile precompiledCacheVC) >>=
lift . mkAbs
where
mkAbs :: PrecompiledCache -> RIO env PrecompiledCache
mkAbs pc0 = do
stackRoot <- view stackRootL
let mkAbs' = (toFilePath stackRoot FP.</>)
return PrecompiledCache
{ pcLibrary = mkAbs' <$> pcLibrary pc0
, pcSubLibs = mkAbs' <$> pcSubLibs pc0
, pcExes = mkAbs' <$> pcExes pc0
}
pathTooLong :: FilePath -> Bool
#ifdef mingw32_HOST_OS
pathTooLong path = utf16StringLength path >= win32MaxPath
where
win32MaxPath = 260
utf16StringLength :: String -> Integer
utf16StringLength = sum . map utf16CharLength
where
utf16CharLength c | ord c < 0x10000 = 1
| otherwise = 2
#else
pathTooLong _ = False
#endif