{-# 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 #-}
module Stack.Storage
( initStorage
, withStorage
, ConfigCacheKey
, configCacheKey
, loadConfigCache
, saveConfigCache
, deactiveConfigCache
, PrecompiledCacheKey
, precompiledCacheKey
, loadPrecompiledCache
, savePrecompiledCache
, loadDockerImageExeCache
, saveDockerImageExeCache
, loadCompilerPaths
, saveCompilerPaths
, upgradeChecksSince
, logUpgradeCheck
) where
import qualified Data.ByteString as S
import qualified Data.Set as Set
import qualified Data.Text as T
import Data.Time.Clock (UTCTime)
import Database.Persist.Sql (SqlBackend)
import Database.Persist.Sqlite
import Database.Persist.TH
import Distribution.Text (simpleParse, display)
import Foreign.C.Types (CTime (..))
import qualified Pantry.Internal as SQLite
import Path
import Path.IO (resolveFile', resolveDir')
import qualified RIO.FilePath as FP
import Stack.Prelude hiding (MigrationFailure)
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 System.Posix.Types (COff (..))
import System.PosixCompat.Files (getFileStatus, fileSize, modificationTime)
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
PrecompiledCacheParent sql="precompiled_cache"
platformGhcDir FilePath "default=(hex(randomblob(16)))"
compiler Text
cabalVersion Text
packageKey Text
optionsHash ByteString
haddock Bool default=0
library FilePath Maybe
UniquePrecompiledCacheParent platformGhcDir compiler cabalVersion packageKey optionsHash haddock sql="unique_precompiled_cache"
deriving Show
PrecompiledCacheSubLib
parent PrecompiledCacheParentId sql="precompiled_cache_id"
value FilePath sql="sub_lib"
UniquePrecompiledCacheSubLib parent value
deriving Show
PrecompiledCacheExe
parent PrecompiledCacheParentId sql="precompiled_cache_id"
value FilePath sql="exe"
UniquePrecompiledCacheExe parent value
deriving Show
DockerImageExeCache
imageHash Text
exePath FilePath
exeTimestamp UTCTime
compatible Bool
DockerImageExeCacheUnique imageHash exePath exeTimestamp
deriving Show
CompilerCache
actualVersion ActualCompiler
arch Text
-- Include ghc executable size and modified time for sanity checking entries
ghcPath FilePath
ghcSize Int64
ghcModified Int64
ghcPkgPath FilePath
runghcPath FilePath
haddockPath FilePath
cabalVersion Text
globalDb FilePath
globalDbCacheSize Int64
globalDbCacheModified Int64
info ByteString
-- This is the ugliest part of this table, simply storing a Show/Read version of the
-- data. We could do a better job with normalized data and proper table structure.
-- However, recomputing this value in the future if the data representation changes
-- is very cheap, so we'll take the easy way out for now.
globalDump Text
UniqueCompilerInfo ghcPath
-- Last time certain actions were performed
LastPerformed
action Action
timestamp UTCTime
UniqueAction action
|]
initStorage ::
HasLogFunc env
=> Path Abs File
-> (SQLite.Storage -> RIO env a)
-> RIO env a
initStorage = SQLite.initStorage "Stack" migrateAll
withStorage ::
(HasConfig env, HasLogFunc env)
=> ReaderT SqlBackend (RIO env) a
-> RIO env a
withStorage inner =
flip SQLite.withStorage_ inner =<< view (configL . to configStorage)
type ConfigCacheKey = Unique ConfigCacheParent
configCacheKey :: Path Abs Dir -> ConfigCacheType -> ConfigCacheKey
configCacheKey dir = UniqueConfigCacheParent (toFilePath dir)
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 {..}
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
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)
deactiveConfigCache :: HasConfig env => ConfigCacheKey -> RIO env ()
deactiveConfigCache (UniqueConfigCacheParent dir type_) =
withStorage $
updateWhere
[ConfigCacheParentDirectory ==. dir, ConfigCacheParentType ==. type_]
[ConfigCacheParentActive =. False]
type PrecompiledCacheKey = Unique PrecompiledCacheParent
precompiledCacheKey ::
Path Rel Dir
-> ActualCompiler
-> Version
-> Text
-> ByteString
-> Bool
-> PrecompiledCacheKey
precompiledCacheKey platformGhcDir compiler cabalVersion =
UniquePrecompiledCacheParent
(toFilePath platformGhcDir)
(compilerVersionText compiler)
(T.pack $ versionString cabalVersion)
readPrecompiledCache ::
(HasConfig env, HasLogFunc env)
=> PrecompiledCacheKey
-> ReaderT SqlBackend (RIO env) (Maybe ( PrecompiledCacheParentId
, PrecompiledCache Rel))
readPrecompiledCache key = do
mparent <- getBy key
forM mparent $ \(Entity parentId PrecompiledCacheParent {..}) -> do
pcLibrary <- mapM parseRelFile precompiledCacheParentLibrary
pcSubLibs <-
mapM (parseRelFile . precompiledCacheSubLibValue . entityVal) =<<
selectList [PrecompiledCacheSubLibParent ==. parentId] []
pcExes <-
mapM (parseRelFile . precompiledCacheExeValue . entityVal) =<<
selectList [PrecompiledCacheExeParent ==. parentId] []
return (parentId, PrecompiledCache {..})
loadPrecompiledCache ::
(HasConfig env, HasLogFunc env)
=> PrecompiledCacheKey
-> RIO env (Maybe (PrecompiledCache Rel))
loadPrecompiledCache key = withStorage $ fmap snd <$> readPrecompiledCache key
savePrecompiledCache ::
(HasConfig env, HasLogFunc env)
=> PrecompiledCacheKey
-> PrecompiledCache Rel
-> RIO env ()
savePrecompiledCache key@(UniquePrecompiledCacheParent precompiledCacheParentPlatformGhcDir precompiledCacheParentCompiler precompiledCacheParentCabalVersion precompiledCacheParentPackageKey precompiledCacheParentOptionsHash precompiledCacheParentHaddock) new =
withStorage $ do
let precompiledCacheParentLibrary = fmap toFilePath (pcLibrary new)
mIdOld <- readPrecompiledCache key
(parentId, mold) <-
case mIdOld of
Nothing -> (, Nothing) <$> insert PrecompiledCacheParent {..}
Just (parentId, old) -> do
update
parentId
[ PrecompiledCacheParentLibrary =.
precompiledCacheParentLibrary
]
return (parentId, Just old)
updateSet
PrecompiledCacheSubLib
PrecompiledCacheSubLibParent
parentId
PrecompiledCacheSubLibValue
(maybe Set.empty (toFilePathSet . pcSubLibs) mold)
(toFilePathSet $ pcSubLibs new)
updateSet
PrecompiledCacheExe
PrecompiledCacheExeParent
parentId
PrecompiledCacheExeValue
(maybe Set.empty (toFilePathSet . pcExes) mold)
(toFilePathSet $ pcExes new)
where
toFilePathSet = Set.fromList . map toFilePath
loadDockerImageExeCache ::
(HasConfig env, HasLogFunc env)
=> Text
-> Path Abs File
-> UTCTime
-> RIO env (Maybe Bool)
loadDockerImageExeCache imageId exePath exeTimestamp =
withStorage $
fmap (dockerImageExeCacheCompatible . entityVal) <$>
getBy (DockerImageExeCacheUnique imageId (toFilePath exePath) exeTimestamp)
saveDockerImageExeCache ::
(HasConfig env, HasLogFunc env)
=> Text
-> Path Abs File
-> UTCTime
-> Bool
-> RIO env ()
saveDockerImageExeCache imageId exePath exeTimestamp compatible =
void $
withStorage $
upsert
(DockerImageExeCache
imageId
(toFilePath exePath)
exeTimestamp
compatible)
[]
updateSet ::
( PersistEntityBackend record ~ BaseBackend backend
, PersistField parentid
, PersistField value
, Ord value
, PersistEntity record
, MonadIO m
, PersistQueryWrite backend
)
=> (parentid -> value -> record)
-> EntityField record parentid
-> parentid
-> EntityField record value
-> Set value
-> Set value
-> ReaderT backend m ()
updateSet recordCons parentFieldCons parentId valueFieldCons old new =
when (old /= new) $ do
deleteWhere
[ parentFieldCons ==. parentId
, valueFieldCons <-. Set.toList (Set.difference old new)
]
insertMany_ $
map (recordCons parentId) $ Set.toList (Set.difference new old)
updateList ::
( PersistEntityBackend record ~ BaseBackend backend
, PersistField parentid
, Ord value
, PersistEntity record
, MonadIO m
, PersistQueryWrite backend
)
=> (parentid -> Int -> value -> record)
-> EntityField record parentid
-> parentid
-> EntityField record Int
-> [value]
-> [value]
-> ReaderT backend m ()
updateList recordCons parentFieldCons parentId indexFieldCons old new =
when (old /= new) $ do
let oldSet = Set.fromList (zip [0 ..] old)
newSet = Set.fromList (zip [0 ..] new)
deleteWhere
[ parentFieldCons ==. parentId
, indexFieldCons <-.
map fst (Set.toList $ Set.difference oldSet newSet)
]
insertMany_ $
map (uncurry $ recordCons parentId) $
Set.toList (Set.difference newSet oldSet)
sizeToInt64 :: COff -> Int64
sizeToInt64 (COff i) = fromIntegral i
timeToInt64 :: CTime -> Int64
timeToInt64 (CTime i) = fromIntegral i
loadCompilerPaths
:: HasConfig env
=> Path Abs File
-> CompilerBuild
-> Bool
-> RIO env (Maybe CompilerPaths)
loadCompilerPaths compiler build sandboxed = do
mres <- withStorage $ getBy $ UniqueCompilerInfo $ toFilePath compiler
for mres $ \(Entity _ CompilerCache {..}) -> do
compilerStatus <- liftIO $ getFileStatus $ toFilePath compiler
when
(compilerCacheGhcSize /= sizeToInt64 (fileSize compilerStatus) ||
compilerCacheGhcModified /= timeToInt64 (modificationTime compilerStatus))
(throwString "Compiler file metadata mismatch, ignoring cache")
globalDbStatus <- liftIO $ getFileStatus $ compilerCacheGlobalDb FP.</> "package.cache"
when
(compilerCacheGlobalDbCacheSize /= sizeToInt64 (fileSize globalDbStatus) ||
compilerCacheGlobalDbCacheModified /= timeToInt64 (modificationTime globalDbStatus))
(throwString "Global package cache file metadata mismatch, ignoring cache")
pkgexe <- resolveFile' compilerCacheGhcPkgPath
runghc <- resolveFile' compilerCacheRunghcPath
haddock <- resolveFile' compilerCacheHaddockPath
globaldb <- resolveDir' compilerCacheGlobalDb
cabalVersion <- parseVersionThrowing $ T.unpack compilerCacheCabalVersion
globalDump <-
case readMaybe $ T.unpack compilerCacheGlobalDump of
Nothing -> throwString "Global dump did not parse correctly"
Just globalDump -> pure globalDump
arch <-
case simpleParse $ T.unpack compilerCacheArch of
Nothing -> throwString $ "Invalid arch: " ++ show compilerCacheArch
Just arch -> pure arch
pure CompilerPaths
{ cpCompiler = compiler
, cpCompilerVersion = compilerCacheActualVersion
, cpArch = arch
, cpBuild = build
, cpPkg = GhcPkgExe pkgexe
, cpInterpreter = runghc
, cpHaddock = haddock
, cpSandboxed = sandboxed
, cpCabalVersion = cabalVersion
, cpGlobalDB = globaldb
, cpGhcInfo = compilerCacheInfo
, cpGlobalDump = globalDump
}
saveCompilerPaths
:: HasConfig env
=> CompilerPaths
-> RIO env ()
saveCompilerPaths CompilerPaths {..} = withStorage $ do
deleteBy $ UniqueCompilerInfo $ toFilePath cpCompiler
compilerStatus <- liftIO $ getFileStatus $ toFilePath cpCompiler
globalDbStatus <- liftIO $ getFileStatus $ toFilePath $ cpGlobalDB </> $(mkRelFile "package.cache")
let GhcPkgExe pkgexe = cpPkg
insert_ CompilerCache
{ compilerCacheActualVersion = cpCompilerVersion
, compilerCacheGhcPath = toFilePath cpCompiler
, compilerCacheGhcSize = sizeToInt64 $ fileSize compilerStatus
, compilerCacheGhcModified = timeToInt64 $ modificationTime compilerStatus
, compilerCacheGhcPkgPath = toFilePath pkgexe
, compilerCacheRunghcPath = toFilePath cpInterpreter
, compilerCacheHaddockPath = toFilePath cpHaddock
, compilerCacheCabalVersion = T.pack $ versionString cpCabalVersion
, compilerCacheGlobalDb = toFilePath cpGlobalDB
, compilerCacheGlobalDbCacheSize = sizeToInt64 $ fileSize globalDbStatus
, compilerCacheGlobalDbCacheModified = timeToInt64 $ modificationTime globalDbStatus
, compilerCacheInfo = cpGhcInfo
, compilerCacheGlobalDump = tshow cpGlobalDump
, compilerCacheArch = T.pack $ Distribution.Text.display cpArch
}
upgradeChecksSince :: HasConfig env => UTCTime -> RIO env Int
upgradeChecksSince since = withStorage $ count
[ LastPerformedAction ==. UpgradeCheck
, LastPerformedTimestamp >=. since
]
logUpgradeCheck :: HasConfig env => UTCTime -> RIO env ()
logUpgradeCheck time = withStorage $ void $ upsert
(LastPerformed UpgradeCheck time)
[LastPerformedTimestamp =. time]