Cache.hs

{-# LANGUAGE DeriveGeneric         #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TemplateHaskell       #-}
{-# LANGUAGE TupleSections         #-}
{-# LANGUAGE ConstraintKinds       #-}
-- | Cache information about previous builds
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

-- | Directory containing files to mark an executable as installed
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

-- | Get all of the installed executables
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

-- | Mark the given executable as installed
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'
    -- TODO consideration for the future: list all of the executables
    -- installed, and invalidate this file in getInstalledExes if they no
    -- longer exist
    liftIO $ writeFile fp "Installed"

-- | Mark the given executable as not 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')

-- | Stored on disk to know whether the flags have changed or any
-- files have changed.
data BuildCache = BuildCache
    { buildCacheTimes :: !(Map FilePath FileCacheInfo)
      -- ^ Modification times of files.
    }
    deriving (Generic)
instance Binary BuildCache
instance HasStructuralInfo BuildCache
instance HasSemanticVersion BuildCache
instance NFData BuildCache

-- | Try to read the dirtiness cache for the given package directory.
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

-- | Try to read the dirtiness cache for the given package directory.
tryGetConfigCache :: (MonadIO m, MonadReader env m, HasConfig env, MonadThrow m, MonadLogger m, HasEnvConfig env)
                  => Path Abs Dir -> m (Maybe ConfigCache)
tryGetConfigCache = tryGetCache configCacheFile

-- | Try to read the mod time of the cabal file from the last build
tryGetCabalMod :: (MonadIO m, MonadReader env m, HasConfig env, MonadThrow m, MonadLogger m, HasEnvConfig env)
               => Path Abs Dir -> m (Maybe ModTime)
tryGetCabalMod = tryGetCache configCabalMod

-- | Try to load a cache.
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

-- | Write the dirtiness cache for this package's files.
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
         })

-- | Write the dirtiness cache for this package's configuration.
writeConfigCache :: (MonadIO m, MonadReader env m, HasConfig env, MonadThrow m, MonadLogger m, HasEnvConfig env)
                => Path Abs Dir
                -> ConfigCache
                -> m ()
writeConfigCache dir = writeCache dir configCacheFile

-- | See 'tryGetCabalMod'
writeCabalMod :: (MonadIO m, MonadReader env m, HasConfig env, MonadThrow m, MonadLogger m, HasEnvConfig env)
              => Path Abs Dir
              -> ModTime
              -> m ()
writeCabalMod dir = writeCache dir configCabalMod

-- | Delete the caches for the project.
deleteCaches :: (MonadIO m, MonadReader env m, HasConfig env, MonadLogger m, MonadThrow m, HasEnvConfig env)
             => Path Abs Dir -> m ()
deleteCaches dir = do
    {- FIXME confirm that this is acceptable to remove
    bfp <- buildCacheFile dir
    removeFileIfExists bfp
    -}
    cfp <- configCacheFile dir
    removeFileIfExists cfp

-- | Write to a cache.
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

-- | Loads the flag cache for the given installed extra-deps
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

-- | Mark a test suite as having succeeded
setTestSuccess :: (MonadIO m, MonadLogger m, MonadThrow m, MonadReader env m, HasConfig env, HasEnvConfig env)
               => Path Abs Dir
               -> m ()
setTestSuccess dir =
    writeCache
        dir
        testSuccessFile
        True

-- | Mark a test suite as not having succeeded
unsetTestSuccess :: (MonadIO m, MonadLogger m, MonadThrow m, MonadReader env m, HasConfig env, HasEnvConfig env)
                 => Path Abs Dir
                 -> m ()
unsetTestSuccess dir =
    writeCache
        dir
        testSuccessFile
        False

-- | Check if the test suite already passed
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)

-- | Mark a test suite as having built
setTestBuilt :: (MonadIO m, MonadLogger m, MonadThrow m, MonadReader env m, HasConfig env, HasEnvConfig env)
               => Path Abs Dir
               -> m ()
setTestBuilt dir =
    writeCache
        dir
        testBuiltFile
        True

-- | Mark a test suite as not having built
unsetTestBuilt :: (MonadIO m, MonadLogger m, MonadThrow m, MonadReader env m, HasConfig env, HasEnvConfig env)
                 => Path Abs Dir
                 -> m ()
unsetTestBuilt dir =
    writeCache
        dir
        testBuiltFile
        False

-- | Check if the test suite already built
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)

-- | Mark a bench suite as having built
setBenchBuilt :: (MonadIO m, MonadLogger m, MonadThrow m, MonadReader env m, HasConfig env, HasEnvConfig env)
               => Path Abs Dir
               -> m ()
setBenchBuilt dir =
    writeCache
        dir
        benchBuiltFile
        True

-- | Mark a bench suite as not having built
unsetBenchBuilt :: (MonadIO m, MonadLogger m, MonadThrow m, MonadReader env m, HasConfig env, HasEnvConfig env)
                 => Path Abs Dir
                 -> m ()
unsetBenchBuilt dir =
    writeCache
        dir
        benchBuiltFile
        False

-- | Check if the bench suite already built
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)

--------------------------------------
-- Precompiled Cache
--
-- Idea is simple: cache information about packages built in other snapshots,
-- and then for identical matches (same flags, config options, dependencies)
-- just copy over the executables and reregister the libraries.
--------------------------------------

-- | The file containing information on the given package/configuration
-- combination. The filename contains a hash of the non-directory configure
-- options for quick lookup if there's a match.
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

    -- We only pay attention to non-directory options. We don't want to avoid a
    -- cache hit just because it was installed in a different directory.
    copts' <- parseRelFile $ S8.unpack $ B16.encode $ SHA256.hashlazy $ Binary.encode $ coNoDirs copts

    return $ getStackRoot ec
         </> $(mkRelDir "precompiled")
         </> compiler
         </> cabal
         </> pkg
         </> copts'

-- | Write out information about a newly built package
writePrecompiledCache :: (MonadThrow m, MonadReader env m, HasEnvConfig env, MonadIO m)
                      => BaseConfigOpts
                      -> PackageIdentifier
                      -> ConfigureOpts
                      -> Maybe GhcPkgId -- ^ library
                      -> Set Text -- ^ executables
                      -> 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'
        }

-- | Check the cache for a precompiled package matching the given
-- configuration.
readPrecompiledCache :: (MonadThrow m, MonadReader env m, HasEnvConfig env, MonadIO m)
                     => PackageIdentifier -- ^ target package
                     -> ConfigureOpts
                     -> m (Maybe PrecompiledCache)
readPrecompiledCache pkgident copts = do
    file <- precompiledCacheFile pkgident copts
    decodeFileOrFailDeep $ toFilePath file