From c3605435ed0aa97ec57be3bdaacb07517443270b Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 23 Jun 2019 04:50:42 +0300 Subject: [PATCH] Split up user and project storage (fixes #4893) --- ChangeLog.md | 4 + package.yaml | 3 +- src/Stack/Build/Cache.hs | 3 +- src/Stack/Config.hs | 36 ++-- src/Stack/Docker.hs | 2 +- src/Stack/Nix.hs | 4 +- src/Stack/Runners.hs | 10 +- src/Stack/Setup.hs | 2 +- src/Stack/Storage/Project.hs | 215 ++++++++++++++++++++++ src/Stack/{Storage.hs => Storage/User.hs} | 204 +++----------------- src/Stack/Types/Config.hs | 19 +- src/test/Stack/ConfigSpec.hs | 6 +- 12 files changed, 292 insertions(+), 216 deletions(-) create mode 100644 src/Stack/Storage/Project.hs rename src/Stack/{Storage.hs => Storage/User.hs} (67%) diff --git a/ChangeLog.md b/ChangeLog.md index ac6d6dccb5..6c4408e25f 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -13,6 +13,10 @@ Behavior changes: Other enhancements: +* Move configure information for local packages back to .stack-work to + improve caching. See + [#4893](https://github.com/commercialhaskell/stack/issues/4893). + Bug fixes: * Fix to allow dependencies on specific versions of local git repositories. See [#4862](https://github.com/commercialhaskell/stack/pull/4862) diff --git a/package.yaml b/package.yaml index 83206fa0aa..0eafe4be37 100644 --- a/package.yaml +++ b/package.yaml @@ -229,7 +229,8 @@ library: - Stack.Setup.Installed - Stack.SetupCmd - Stack.SourceMap - - Stack.Storage + - Stack.Storage.Project + - Stack.Storage.User - Stack.Types.Build - Stack.Types.CompilerBuild - Stack.Types.Compiler diff --git a/src/Stack/Build/Cache.hs b/src/Stack/Build/Cache.hs index 3629e3e930..b22a807cd1 100644 --- a/src/Stack/Build/Cache.hs +++ b/src/Stack/Build/Cache.hs @@ -41,7 +41,8 @@ import Path import Path.IO import Stack.Constants import Stack.Constants.Config -import Stack.Storage +import Stack.Storage.Project +import Stack.Storage.User import Stack.Types.Build import Stack.Types.Cache import Stack.Types.Config diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs index 39f6e6f141..ecf669cf51 100644 --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -29,7 +29,7 @@ module Stack.Config ,getInNixShell ,defaultConfigYaml ,getProjectConfig - ,loadBuildConfig + ,withBuildConfig ) where import Control.Monad.Extra (firstJustM) @@ -64,7 +64,8 @@ import Stack.Config.Nix import Stack.Constants import Stack.Build.Haddock (shouldHaddockDeps) import Stack.Lock (lockCachedWanted) -import Stack.Storage (initStorage) +import Stack.Storage.Project (initProjectStorage) +import Stack.Storage.User (initUserStorage) import Stack.SourceMap import Stack.Types.Build import Stack.Types.Compiler @@ -373,9 +374,9 @@ configFromConfigMonoid hsc (maybe HpackBundled HpackCommand $ getFirst configMonoidOverrideHpack) clConnectionCount - (\configPantryConfig -> initStorage + (\configPantryConfig -> initUserStorage (configStackRoot relFileStorage) - (\configStorage -> inner Config {..})) + (\configUserStorage -> inner Config {..})) -- | Get the default location of the local programs directory. getDefaultLocalProgramsBase :: MonadThrow m @@ -448,8 +449,10 @@ loadConfig inner = do -- | Load the build configuration, adds build-specific values to config loaded by @loadConfig@. -- values. -loadBuildConfig :: RIO Config BuildConfig -loadBuildConfig = do +withBuildConfig + :: RIO BuildConfig a + -> RIO Config a +withBuildConfig inner = do config <- ask -- If provided, turn the AbstractResolver from the command line @@ -526,13 +529,20 @@ loadBuildConfig = do wanted <- lockCachedWanted stackYamlFP (projectResolver project) $ fillProjectWanted stackYamlFP config project - return BuildConfig - { bcConfig = config - , bcSMWanted = wanted - , bcExtraPackageDBs = extraPackageDBs - , bcStackYaml = stackYamlFP - , bcCurator = projectCurator project - } + -- Unfortunately redoes getProjectWorkDir, since we don't have a BuildConfig yet + workDir <- view workDirL + let projectStorageFile = parent stackYamlFP workDir relFileStorage + + initProjectStorage projectStorageFile $ \projectStorage -> do + let bc = BuildConfig + { bcConfig = config + , bcSMWanted = wanted + , bcExtraPackageDBs = extraPackageDBs + , bcStackYaml = stackYamlFP + , bcCurator = projectCurator project + , bcProjectStorage = projectStorage + } + runRIO bc inner where getEmptyProject :: Maybe RawSnapshotLocation -> [PackageIdentifierRevision] -> RIO Config Project getEmptyProject mresolver extraDeps = do diff --git a/src/Stack/Docker.hs b/src/Stack/Docker.hs index 16f31eaf43..9faa2e92a5 100644 --- a/src/Stack/Docker.hs +++ b/src/Stack/Docker.hs @@ -49,7 +49,7 @@ import Stack.Config (getInContainer) import Stack.Constants import Stack.Constants.Config import Stack.Setup (ensureDockerStackExe) -import Stack.Storage (loadDockerImageExeCache,saveDockerImageExeCache) +import Stack.Storage.User (loadDockerImageExeCache,saveDockerImageExeCache) import Stack.Types.Version import Stack.Types.Config import Stack.Types.Docker diff --git a/src/Stack/Nix.hs b/src/Stack/Nix.hs index 788f91d17b..7e23c7ffaa 100644 --- a/src/Stack/Nix.hs +++ b/src/Stack/Nix.hs @@ -18,7 +18,7 @@ import Data.Version (showVersion) import Lens.Micro (set) import Path.IO import qualified Paths_stack as Meta -import Stack.Config (getInContainer, loadBuildConfig) +import Stack.Config (getInContainer, withBuildConfig) import Stack.Config.Nix (nixCompiler) import Stack.Constants (platformVariantEnvVar,inNixShellEnvVar,inContainerEnvVar) import Stack.Types.Config @@ -54,7 +54,7 @@ runShellAndExit = do -- -- 2. This function ends up exiting before running other code -- (thus the void return type) - compilerVersion <- view wantedCompilerVersionL <$> loadBuildConfig + compilerVersion <- withBuildConfig $ view wantedCompilerVersionL ghc <- either throwIO return $ nixCompiler compilerVersion let pkgsInConfig = nixPackages (configNix config) diff --git a/src/Stack/Runners.hs b/src/Stack/Runners.hs index 5f42e0ce77..7d666dbad3 100644 --- a/src/Stack/Runners.hs +++ b/src/Stack/Runners.hs @@ -29,7 +29,7 @@ import Stack.DefaultColorWhen (defaultColorWhen) import qualified Stack.Docker as Docker import qualified Stack.Nix as Nix import Stack.Setup -import Stack.Storage (upgradeChecksSince, logUpgradeCheck) +import Stack.Storage.User (upgradeChecksSince, logUpgradeCheck) import Stack.Types.Config import Stack.Types.Docker (dockerEnable) import Stack.Types.Nix (nixEnable) @@ -55,14 +55,6 @@ withDefaultEnvConfig -> RIO Config a withDefaultEnvConfig = withEnvConfig AllowNoTargets defaultBuildOptsCLI --- | Upgrade a 'Config' environment to a 'BuildConfig' environment by --- performing further parsing of project-specific configuration. This --- is intended to be run inside a call to 'withConfig'. -withBuildConfig :: RIO BuildConfig a -> RIO Config a -withBuildConfig inner = do - bconfig <- loadBuildConfig - runRIO bconfig inner - -- | Upgrade a 'Config' environment to an 'EnvConfig' environment by -- performing further parsing of project-specific configuration (like -- 'withBuildConfig') and then setting up a build environment diff --git a/src/Stack/Setup.hs b/src/Stack/Setup.hs index 5ca07b63af..eef5370b16 100644 --- a/src/Stack/Setup.hs +++ b/src/Stack/Setup.hs @@ -81,7 +81,7 @@ import Stack.GhcPkg (createDatabase, getGlobalDB, mkGhcPackagePath, import Stack.Prelude hiding (Display (..)) import Stack.SourceMap import Stack.Setup.Installed -import Stack.Storage (loadCompilerPaths, saveCompilerPaths) +import Stack.Storage.User (loadCompilerPaths, saveCompilerPaths) import Stack.Types.Build import Stack.Types.Compiler import Stack.Types.CompilerBuild diff --git a/src/Stack/Storage/Project.hs b/src/Stack/Storage/Project.hs new file mode 100644 index 0000000000..c3b3865360 --- /dev/null +++ b/src/Stack/Storage/Project.hs @@ -0,0 +1,215 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -Wno-unused-top-binds -Wno-identities #-} + +-- | Work with SQLite database used for caches across a single project. +module Stack.Storage.Project + ( initProjectStorage + , ConfigCacheKey + , configCacheKey + , loadConfigCache + , saveConfigCache + , deactiveConfigCache + ) where + +import qualified Data.ByteString as S +import qualified Data.Set as Set +import Database.Persist.Sql (SqlBackend) +import Database.Persist.Sqlite +import Database.Persist.TH +import qualified Pantry.Internal as SQLite +import Path +import Stack.Prelude hiding (MigrationFailure) +import Stack.Storage.User (updateList, updateSet) +import Stack.Types.Build +import Stack.Types.Cache +import Stack.Types.Config (HasBuildConfig, buildConfigL, bcProjectStorage, ProjectStorage (..)) +import Stack.Types.GhcPkgId + +share [ mkPersist sqlSettings + , mkDeleteCascade sqlSettings + , mkMigrate "migrateAll" + ] + [persistLowerCase| +ConfigCacheParent sql="config_cache" + directory FilePath "default=(hex(randomblob(16)))" + type ConfigCacheType + pkgSrc CachePkgSrc + active Bool + pathEnvVar Text + haddock Bool default=0 + UniqueConfigCacheParent directory type sql="unique_config_cache" + deriving Show + +ConfigCacheDirOption + parent ConfigCacheParentId sql="config_cache_id" + index Int + value String sql="option" + UniqueConfigCacheDirOption parent index + deriving Show + +ConfigCacheNoDirOption + parent ConfigCacheParentId sql="config_cache_id" + index Int + value String sql="option" + UniqueConfigCacheNoDirOption parent index + deriving Show + +ConfigCacheDep + parent ConfigCacheParentId sql="config_cache_id" + value GhcPkgId sql="ghc_pkg_id" + UniqueConfigCacheDep parent value + deriving Show + +ConfigCacheComponent + parent ConfigCacheParentId sql="config_cache_id" + value S.ByteString sql="component" + UniqueConfigCacheComponent parent value + deriving Show +|] + +-- | Initialize the database. +initProjectStorage :: + HasLogFunc env + => Path Abs File -- ^ storage file + -> (ProjectStorage -> RIO env a) + -> RIO env a +initProjectStorage fp f = SQLite.initStorage "Stack" migrateAll fp $ f . ProjectStorage + +-- | Run an action in a database transaction +withProjectStorage :: + (HasBuildConfig env, HasLogFunc env) + => ReaderT SqlBackend (RIO env) a + -> RIO env a +withProjectStorage inner = + flip SQLite.withStorage_ inner =<< view (buildConfigL . to bcProjectStorage . to unProjectStorage) + +-- | Key used to retrieve configuration or flag cache +type ConfigCacheKey = Unique ConfigCacheParent + +-- | Build key used to retrieve configuration or flag cache +configCacheKey :: Path Abs Dir -> ConfigCacheType -> ConfigCacheKey +configCacheKey dir = UniqueConfigCacheParent (toFilePath dir) + +-- | Internal helper to read the 'ConfigCache' +readConfigCache :: + (HasBuildConfig env, HasLogFunc env) + => Entity ConfigCacheParent + -> ReaderT SqlBackend (RIO env) ConfigCache +readConfigCache (Entity parentId ConfigCacheParent {..}) = do + let configCachePkgSrc = configCacheParentPkgSrc + coDirs <- + map (configCacheDirOptionValue . entityVal) <$> + selectList + [ConfigCacheDirOptionParent ==. parentId] + [Asc ConfigCacheDirOptionIndex] + coNoDirs <- + map (configCacheNoDirOptionValue . entityVal) <$> + selectList + [ConfigCacheNoDirOptionParent ==. parentId] + [Asc ConfigCacheNoDirOptionIndex] + let configCacheOpts = ConfigureOpts {..} + configCacheDeps <- + Set.fromList . map (configCacheDepValue . entityVal) <$> + selectList [ConfigCacheDepParent ==. parentId] [] + configCacheComponents <- + Set.fromList . map (configCacheComponentValue . entityVal) <$> + selectList [ConfigCacheComponentParent ==. parentId] [] + let configCachePathEnvVar = configCacheParentPathEnvVar + let configCacheHaddock = configCacheParentHaddock + return ConfigCache {..} + +-- | Load 'ConfigCache' from the database. +loadConfigCache :: + (HasBuildConfig env, HasLogFunc env) + => ConfigCacheKey + -> RIO env (Maybe ConfigCache) +loadConfigCache key = + withProjectStorage $ do + mparent <- getBy key + case mparent of + Nothing -> return Nothing + Just parentEntity@(Entity _ ConfigCacheParent {..}) + | configCacheParentActive -> + Just <$> readConfigCache parentEntity + | otherwise -> return Nothing + +-- | Insert or update 'ConfigCache' to the database. +saveConfigCache :: + (HasBuildConfig env, HasLogFunc env) + => ConfigCacheKey + -> ConfigCache + -> RIO env () +saveConfigCache key@(UniqueConfigCacheParent dir type_) new = + withProjectStorage $ do + mparent <- getBy key + (parentId, mold) <- + case mparent of + Nothing -> + (, Nothing) <$> + insert + ConfigCacheParent + { configCacheParentDirectory = dir + , configCacheParentType = type_ + , configCacheParentPkgSrc = configCachePkgSrc new + , configCacheParentActive = True + , configCacheParentPathEnvVar = configCachePathEnvVar new + , configCacheParentHaddock = configCacheHaddock new + } + Just parentEntity@(Entity parentId _) -> do + old <- readConfigCache parentEntity + update + parentId + [ ConfigCacheParentPkgSrc =. configCachePkgSrc new + , ConfigCacheParentActive =. True + , ConfigCacheParentPathEnvVar =. configCachePathEnvVar new + ] + return (parentId, Just old) + updateList + ConfigCacheDirOption + ConfigCacheDirOptionParent + parentId + ConfigCacheDirOptionIndex + (maybe [] (coDirs . configCacheOpts) mold) + (coDirs $ configCacheOpts new) + updateList + ConfigCacheNoDirOption + ConfigCacheNoDirOptionParent + parentId + ConfigCacheNoDirOptionIndex + (maybe [] (coNoDirs . configCacheOpts) mold) + (coNoDirs $ configCacheOpts new) + updateSet + ConfigCacheDep + ConfigCacheDepParent + parentId + ConfigCacheDepValue + (maybe Set.empty configCacheDeps mold) + (configCacheDeps new) + updateSet + ConfigCacheComponent + ConfigCacheComponentParent + parentId + ConfigCacheComponentValue + (maybe Set.empty configCacheComponents mold) + (configCacheComponents new) + +-- | Mark 'ConfigCache' as inactive in the database. +-- We use a flag instead of deleting the records since, in most cases, the same +-- cache will be written again within in a few seconds (after +-- `cabal configure`), so this avoids unnecessary database churn. +deactiveConfigCache :: HasBuildConfig env => ConfigCacheKey -> RIO env () +deactiveConfigCache (UniqueConfigCacheParent dir type_) = + withProjectStorage $ + updateWhere + [ConfigCacheParentDirectory ==. dir, ConfigCacheParentType ==. type_] + [ConfigCacheParentActive =. False] diff --git a/src/Stack/Storage.hs b/src/Stack/Storage/User.hs similarity index 67% rename from src/Stack/Storage.hs rename to src/Stack/Storage/User.hs index 3289b6be61..63db1b7399 100644 --- a/src/Stack/Storage.hs +++ b/src/Stack/Storage/User.hs @@ -11,15 +11,9 @@ {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wno-unused-top-binds -Wno-identities #-} --- | Work with SQLite database used for caches. -module Stack.Storage - ( initStorage - , withStorage - , ConfigCacheKey - , configCacheKey - , loadConfigCache - , saveConfigCache - , deactiveConfigCache +-- | Work with SQLite database used for caches across an entire user account. +module Stack.Storage.User + ( initUserStorage , PrecompiledCacheKey , precompiledCacheKey , loadPrecompiledCache @@ -30,9 +24,11 @@ module Stack.Storage , saveCompilerPaths , upgradeChecksSince , logUpgradeCheck + -- * Shared utils + , updateList + , updateSet ) where -import qualified Data.ByteString as S import qualified Data.Set as Set import qualified Data.Text as T import Data.Time.Clock (UTCTime) @@ -50,8 +46,7 @@ import Stack.Types.Build import Stack.Types.Cache import Stack.Types.Compiler import Stack.Types.CompilerBuild (CompilerBuild) -import Stack.Types.Config (HasConfig, configL, configStorage, CompilerPaths (..), GhcPkgExe (..)) -import Stack.Types.GhcPkgId +import Stack.Types.Config (HasConfig, configL, configUserStorage, CompilerPaths (..), GhcPkgExe (..), UserStorage (..)) import System.Posix.Types (COff (..)) import System.PosixCompat.Files (getFileStatus, fileSize, modificationTime) @@ -60,42 +55,6 @@ share [ mkPersist sqlSettings , mkMigrate "migrateAll" ] [persistLowerCase| -ConfigCacheParent sql="config_cache" - directory FilePath "default=(hex(randomblob(16)))" - type ConfigCacheType - pkgSrc CachePkgSrc - active Bool - pathEnvVar Text - haddock Bool default=0 - UniqueConfigCacheParent directory type sql="unique_config_cache" - deriving Show - -ConfigCacheDirOption - parent ConfigCacheParentId sql="config_cache_id" - index Int - value String sql="option" - UniqueConfigCacheDirOption parent index - deriving Show - -ConfigCacheNoDirOption - parent ConfigCacheParentId sql="config_cache_id" - index Int - value String sql="option" - UniqueConfigCacheNoDirOption parent index - deriving Show - -ConfigCacheDep - parent ConfigCacheParentId sql="config_cache_id" - value GhcPkgId sql="ghc_pkg_id" - UniqueConfigCacheDep parent value - deriving Show - -ConfigCacheComponent - parent ConfigCacheParentId sql="config_cache_id" - value S.ByteString sql="component" - UniqueConfigCacheComponent parent value - deriving Show - PrecompiledCacheParent sql="precompiled_cache" platformGhcDir FilePath "default=(hex(randomblob(16)))" compiler Text @@ -162,141 +121,20 @@ LastPerformed |] -- | Initialize the database. -initStorage :: +initUserStorage :: HasLogFunc env => Path Abs File -- ^ storage file - -> (SQLite.Storage -> RIO env a) + -> (UserStorage -> RIO env a) -> RIO env a -initStorage = SQLite.initStorage "Stack" migrateAll +initUserStorage fp f = SQLite.initStorage "Stack" migrateAll fp $ f . UserStorage -- | Run an action in a database transaction -withStorage :: +withUserStorage :: (HasConfig env, HasLogFunc env) => ReaderT SqlBackend (RIO env) a -> RIO env a -withStorage inner = - flip SQLite.withStorage_ inner =<< view (configL . to configStorage) - --- | Key used to retrieve configuration or flag cache -type ConfigCacheKey = Unique ConfigCacheParent - --- | Build key used to retrieve configuration or flag cache -configCacheKey :: Path Abs Dir -> ConfigCacheType -> ConfigCacheKey -configCacheKey dir = UniqueConfigCacheParent (toFilePath dir) - --- | Internal helper to read the 'ConfigCache' -readConfigCache :: - (HasConfig env, HasLogFunc env) - => Entity ConfigCacheParent - -> ReaderT SqlBackend (RIO env) ConfigCache -readConfigCache (Entity parentId ConfigCacheParent {..}) = do - let configCachePkgSrc = configCacheParentPkgSrc - coDirs <- - map (configCacheDirOptionValue . entityVal) <$> - selectList - [ConfigCacheDirOptionParent ==. parentId] - [Asc ConfigCacheDirOptionIndex] - coNoDirs <- - map (configCacheNoDirOptionValue . entityVal) <$> - selectList - [ConfigCacheNoDirOptionParent ==. parentId] - [Asc ConfigCacheNoDirOptionIndex] - let configCacheOpts = ConfigureOpts {..} - configCacheDeps <- - Set.fromList . map (configCacheDepValue . entityVal) <$> - selectList [ConfigCacheDepParent ==. parentId] [] - configCacheComponents <- - Set.fromList . map (configCacheComponentValue . entityVal) <$> - selectList [ConfigCacheComponentParent ==. parentId] [] - let configCachePathEnvVar = configCacheParentPathEnvVar - let configCacheHaddock = configCacheParentHaddock - return ConfigCache {..} - --- | Load 'ConfigCache' from the database. -loadConfigCache :: - (HasConfig env, HasLogFunc env) - => ConfigCacheKey - -> RIO env (Maybe ConfigCache) -loadConfigCache key = - withStorage $ do - mparent <- getBy key - case mparent of - Nothing -> return Nothing - Just parentEntity@(Entity _ ConfigCacheParent {..}) - | configCacheParentActive -> - Just <$> readConfigCache parentEntity - | otherwise -> return Nothing - --- | Insert or update 'ConfigCache' to the database. -saveConfigCache :: - (HasConfig env, HasLogFunc env) - => ConfigCacheKey - -> ConfigCache - -> RIO env () -saveConfigCache key@(UniqueConfigCacheParent dir type_) new = - withStorage $ do - mparent <- getBy key - (parentId, mold) <- - case mparent of - Nothing -> - (, Nothing) <$> - insert - ConfigCacheParent - { configCacheParentDirectory = dir - , configCacheParentType = type_ - , configCacheParentPkgSrc = configCachePkgSrc new - , configCacheParentActive = True - , configCacheParentPathEnvVar = configCachePathEnvVar new - , configCacheParentHaddock = configCacheHaddock new - } - Just parentEntity@(Entity parentId _) -> do - old <- readConfigCache parentEntity - update - parentId - [ ConfigCacheParentPkgSrc =. configCachePkgSrc new - , ConfigCacheParentActive =. True - , ConfigCacheParentPathEnvVar =. configCachePathEnvVar new - ] - return (parentId, Just old) - updateList - ConfigCacheDirOption - ConfigCacheDirOptionParent - parentId - ConfigCacheDirOptionIndex - (maybe [] (coDirs . configCacheOpts) mold) - (coDirs $ configCacheOpts new) - updateList - ConfigCacheNoDirOption - ConfigCacheNoDirOptionParent - parentId - ConfigCacheNoDirOptionIndex - (maybe [] (coNoDirs . configCacheOpts) mold) - (coNoDirs $ configCacheOpts new) - updateSet - ConfigCacheDep - ConfigCacheDepParent - parentId - ConfigCacheDepValue - (maybe Set.empty configCacheDeps mold) - (configCacheDeps new) - updateSet - ConfigCacheComponent - ConfigCacheComponentParent - parentId - ConfigCacheComponentValue - (maybe Set.empty configCacheComponents mold) - (configCacheComponents new) - --- | Mark 'ConfigCache' as inactive in the database. --- We use a flag instead of deleting the records since, in most cases, the same --- cache will be written again within in a few seconds (after --- `cabal configure`), so this avoids unnecessary database churn. -deactiveConfigCache :: HasConfig env => ConfigCacheKey -> RIO env () -deactiveConfigCache (UniqueConfigCacheParent dir type_) = - withStorage $ - updateWhere - [ConfigCacheParentDirectory ==. dir, ConfigCacheParentType ==. type_] - [ConfigCacheParentActive =. False] +withUserStorage inner = + flip SQLite.withStorage_ inner =<< view (configL . to configUserStorage . to unUserStorage) -- | Key used to retrieve the precompiled cache type PrecompiledCacheKey = Unique PrecompiledCacheParent @@ -339,7 +177,7 @@ loadPrecompiledCache :: (HasConfig env, HasLogFunc env) => PrecompiledCacheKey -> RIO env (Maybe (PrecompiledCache Rel)) -loadPrecompiledCache key = withStorage $ fmap snd <$> readPrecompiledCache key +loadPrecompiledCache key = withUserStorage $ fmap snd <$> readPrecompiledCache key -- | Insert or update 'PrecompiledCache' to the database. savePrecompiledCache :: @@ -348,7 +186,7 @@ savePrecompiledCache :: -> PrecompiledCache Rel -> RIO env () savePrecompiledCache key@(UniquePrecompiledCacheParent precompiledCacheParentPlatformGhcDir precompiledCacheParentCompiler precompiledCacheParentCabalVersion precompiledCacheParentPackageKey precompiledCacheParentOptionsHash precompiledCacheParentHaddock) new = - withStorage $ do + withUserStorage $ do let precompiledCacheParentLibrary = fmap toFilePath (pcLibrary new) mIdOld <- readPrecompiledCache key (parentId, mold) <- @@ -386,7 +224,7 @@ loadDockerImageExeCache :: -> UTCTime -> RIO env (Maybe Bool) loadDockerImageExeCache imageId exePath exeTimestamp = - withStorage $ + withUserStorage $ fmap (dockerImageExeCacheCompatible . entityVal) <$> getBy (DockerImageExeCacheUnique imageId (toFilePath exePath) exeTimestamp) @@ -400,7 +238,7 @@ saveDockerImageExeCache :: -> RIO env () saveDockerImageExeCache imageId exePath exeTimestamp compatible = void $ - withStorage $ + withUserStorage $ upsert (DockerImageExeCache imageId @@ -483,7 +321,7 @@ loadCompilerPaths -> Bool -- ^ sandboxed? -> RIO env (Maybe CompilerPaths) loadCompilerPaths compiler build sandboxed = do - mres <- withStorage $ getBy $ UniqueCompilerInfo $ toFilePath compiler + mres <- withUserStorage $ getBy $ UniqueCompilerInfo $ toFilePath compiler for mres $ \(Entity _ CompilerCache {..}) -> do compilerStatus <- liftIO $ getFileStatus $ toFilePath compiler when @@ -534,7 +372,7 @@ saveCompilerPaths :: HasConfig env => CompilerPaths -> RIO env () -saveCompilerPaths CompilerPaths {..} = withStorage $ do +saveCompilerPaths CompilerPaths {..} = withUserStorage $ do deleteBy $ UniqueCompilerInfo $ toFilePath cpCompiler compilerStatus <- liftIO $ getFileStatus $ toFilePath cpCompiler globalDbStatus <- liftIO $ getFileStatus $ toFilePath $ cpGlobalDB $(mkRelFile "package.cache") @@ -558,13 +396,13 @@ saveCompilerPaths CompilerPaths {..} = withStorage $ do -- | How many upgrade checks have occurred since the given timestamp? upgradeChecksSince :: HasConfig env => UTCTime -> RIO env Int -upgradeChecksSince since = withStorage $ count +upgradeChecksSince since = withUserStorage $ count [ LastPerformedAction ==. UpgradeCheck , LastPerformedTimestamp >=. since ] -- | Log in the database that an upgrade check occurred at the given time. logUpgradeCheck :: HasConfig env => UTCTime -> RIO env () -logUpgradeCheck time = withStorage $ void $ upsert +logUpgradeCheck time = withUserStorage $ void $ upsert (LastPerformed UpgradeCheck time) [LastPerformedTimestamp =. time] diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs index 1731f41e0f..a5cc22b59c 100644 --- a/src/Stack/Types/Config.hs +++ b/src/Stack/Types/Config.hs @@ -46,6 +46,9 @@ module Stack.Types.Config ,stackYamlL ,projectRootL ,HasBuildConfig(..) + -- ** Storage databases + ,UserStorage(..) + ,ProjectStorage(..) -- ** GHCVariant & HasGHCVariant ,GHCVariant(..) ,ghcVariantName @@ -365,14 +368,24 @@ data Config = ,configStackRoot :: !(Path Abs Dir) ,configResolver :: !(Maybe AbstractResolver) -- ^ Any resolver override from the command line - ,configStorage :: !Storage - -- ^ Database connection pool for Stack database + ,configUserStorage :: !UserStorage + -- ^ Database connection pool for user Stack database ,configHideSourcePaths :: !Bool -- ^ Enable GHC hiding source paths? ,configRecommendUpgrade :: !Bool -- ^ Recommend a Stack upgrade? } +-- | A bit of type safety to ensure we're talking to the right database. +newtype UserStorage = UserStorage + { unUserStorage :: Storage + } + +-- | A bit of type safety to ensure we're talking to the right database. +newtype ProjectStorage = ProjectStorage + { unProjectStorage :: Storage + } + -- | The project root directory, if in a project. configProjectRoot :: Config -> Maybe (Path Abs Dir) configProjectRoot c = @@ -611,6 +624,8 @@ data BuildConfig = BuildConfig -- Note: if the STACK_YAML environment variable is used, this may be -- different from projectRootL "stack.yaml" if a different file -- name is used. + , bcProjectStorage :: !ProjectStorage + -- ^ Database connection pool for project Stack database , bcCurator :: !(Maybe Curator) } diff --git a/src/test/Stack/ConfigSpec.hs b/src/test/Stack/ConfigSpec.hs index 1f0f14284c..f56a20fa71 100644 --- a/src/test/Stack/ConfigSpec.hs +++ b/src/test/Stack/ConfigSpec.hs @@ -191,7 +191,7 @@ spec = beforeAll setup $ do createDirectory childDir setCurrentDirectory childDir loadConfig' $ \config -> liftIO $ do - bc <- runRIO config loadBuildConfig + bc <- runRIO config $ withBuildConfig ask view projectRootL bc `shouldBe` parentDir it "respects the STACK_YAML env variable" $ inTempDir $ do @@ -200,7 +200,7 @@ spec = beforeAll setup $ do writeFile stackYamlFp sampleConfig writeFile (toFilePath dir ++ "/package.yaml") "name: foo" withEnvVar "STACK_YAML" stackYamlFp $ loadConfig' $ \config -> liftIO $ do - BuildConfig{..} <- runRIO config loadBuildConfig + BuildConfig{..} <- runRIO config $ withBuildConfig ask bcStackYaml `shouldBe` dir stackDotYaml parent bcStackYaml `shouldBe` dir @@ -214,7 +214,7 @@ spec = beforeAll setup $ do writeFile (toFilePath yamlAbs) "resolver: ghc-7.8" writeFile (toFilePath packageYaml) "name: foo" withEnvVar "STACK_YAML" (toFilePath yamlRel) $ loadConfig' $ \config -> liftIO $ do - BuildConfig{..} <- runRIO config loadBuildConfig + BuildConfig{..} <- runRIO config $ withBuildConfig ask bcStackYaml `shouldBe` yamlAbs describe "defaultConfigYaml" $