{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-unused-top-binds -Wno-identities #-}
module Stack.Storage.User
( initUserStorage
, PrecompiledCacheKey
, precompiledCacheKey
, loadPrecompiledCache
, savePrecompiledCache
, loadDockerImageExeCache
, saveDockerImageExeCache
, loadCompilerPaths
, saveCompilerPaths
, upgradeChecksSince
, logUpgradeCheck
) where
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.Storage.Util
import Stack.Types.Build
import Stack.Types.Cache
import Stack.Types.Compiler
import Stack.Types.CompilerBuild (CompilerBuild)
import Stack.Types.Config (HasConfig, configL, configUserStorage, CompilerPaths (..), GhcPkgExe (..), UserStorage (..))
import System.Posix.Types (COff (..))
import System.PosixCompat.Files (getFileStatus, fileSize, modificationTime)
share [ mkPersist sqlSettings
, mkDeleteCascade sqlSettings
, mkMigrate "migrateAll"
]
[persistLowerCase|
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
|]
initUserStorage ::
HasLogFunc env
=> Path Abs File
-> (UserStorage -> RIO env a)
-> RIO env a
initUserStorage fp f = SQLite.initStorage "Stack" migrateAll fp $ f . UserStorage
withUserStorage ::
(HasConfig env, HasLogFunc env)
=> ReaderT SqlBackend (RIO env) a
-> RIO env a
withUserStorage inner =
flip SQLite.withStorage_ inner =<< view (configL . to configUserStorage . to unUserStorage)
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 = withUserStorage $ fmap snd <$> readPrecompiledCache key
savePrecompiledCache ::
(HasConfig env, HasLogFunc env)
=> PrecompiledCacheKey
-> PrecompiledCache Rel
-> RIO env ()
savePrecompiledCache key@(UniquePrecompiledCacheParent precompiledCacheParentPlatformGhcDir precompiledCacheParentCompiler precompiledCacheParentCabalVersion precompiledCacheParentPackageKey precompiledCacheParentOptionsHash precompiledCacheParentHaddock) new =
withUserStorage $ 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 =
withUserStorage $
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 $
withUserStorage $
upsert
(DockerImageExeCache
imageId
(toFilePath exePath)
exeTimestamp
compatible)
[]
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 <- withUserStorage $ 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 {..} = withUserStorage $ 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 = withUserStorage $ count
[ LastPerformedAction ==. UpgradeCheck
, LastPerformedTimestamp >=. since
]
logUpgradeCheck :: HasConfig env => UTCTime -> RIO env ()
logUpgradeCheck time = withUserStorage $ void $ upsert
(LastPerformed UpgradeCheck time)
[LastPerformedTimestamp =. time]