1{-# LANGUAGE DataKinds #-} 2{-# LANGUAGE DerivingStrategies #-} 3{-# LANGUAGE FlexibleInstances #-} 4{-# LANGUAGE GADTs #-} 5{-# LANGUAGE GeneralizedNewtypeDeriving #-} 6{-# LANGUAGE MultiParamTypeClasses #-} 7{-# LANGUAGE NoImplicitPrelude #-} 8{-# LANGUAGE OverloadedStrings #-} 9{-# LANGUAGE QuasiQuotes #-} 10{-# LANGUAGE RecordWildCards #-} 11{-# LANGUAGE StandaloneDeriving #-} 12{-# LANGUAGE TemplateHaskell #-} 13{-# LANGUAGE TupleSections #-} 14{-# LANGUAGE TypeFamilies #-} 15{-# LANGUAGE UndecidableInstances #-} 16{-# OPTIONS_GHC -Wno-unused-top-binds -Wno-identities #-} 17 18-- | Work with SQLite database used for caches across an entire user account. 19module Stack.Storage.User 20 ( initUserStorage 21 , PrecompiledCacheKey 22 , precompiledCacheKey 23 , loadPrecompiledCache 24 , savePrecompiledCache 25 , loadDockerImageExeCache 26 , saveDockerImageExeCache 27 , loadCompilerPaths 28 , saveCompilerPaths 29 , upgradeChecksSince 30 , logUpgradeCheck 31 ) where 32 33import qualified Data.Set as Set 34import qualified Data.Text as T 35import Data.Time.Clock (UTCTime) 36import Database.Persist.Sqlite 37import Database.Persist.TH 38import Distribution.Text (simpleParse, display) 39import Foreign.C.Types (CTime (..)) 40import qualified Pantry.Internal as SQLite 41import Path 42import Path.IO (resolveFile', resolveDir') 43import qualified RIO.FilePath as FP 44import Stack.Prelude hiding (MigrationFailure) 45import Stack.Storage.Util 46import Stack.Types.Build 47import Stack.Types.Cache 48import Stack.Types.Compiler 49import Stack.Types.CompilerBuild (CompilerBuild) 50import Stack.Types.Config (HasConfig, configL, configUserStorage, CompilerPaths (..), GhcPkgExe (..), UserStorage (..)) 51import System.Posix.Types (COff (..)) 52import System.PosixCompat.Files (getFileStatus, fileSize, modificationTime) 53 54share [ mkPersist sqlSettings 55 , mkDeleteCascade sqlSettings 56 , mkMigrate "migrateAll" 57 ] 58 [persistLowerCase| 59PrecompiledCacheParent sql="precompiled_cache" 60 platformGhcDir FilePath "default=(hex(randomblob(16)))" 61 compiler Text 62 cabalVersion Text 63 packageKey Text 64 optionsHash ByteString 65 haddock Bool default=0 66 library FilePath Maybe 67 UniquePrecompiledCacheParent platformGhcDir compiler cabalVersion packageKey optionsHash haddock sql="unique_precompiled_cache" 68 deriving Show 69 70PrecompiledCacheSubLib 71 parent PrecompiledCacheParentId sql="precompiled_cache_id" 72 value FilePath sql="sub_lib" 73 UniquePrecompiledCacheSubLib parent value 74 deriving Show 75 76PrecompiledCacheExe 77 parent PrecompiledCacheParentId sql="precompiled_cache_id" 78 value FilePath sql="exe" 79 UniquePrecompiledCacheExe parent value 80 deriving Show 81 82DockerImageExeCache 83 imageHash Text 84 exePath FilePath 85 exeTimestamp UTCTime 86 compatible Bool 87 DockerImageExeCacheUnique imageHash exePath exeTimestamp 88 deriving Show 89 90CompilerCache 91 actualVersion ActualCompiler 92 arch Text 93 94 -- Include ghc executable size and modified time for sanity checking entries 95 ghcPath FilePath 96 ghcSize Int64 97 ghcModified Int64 98 99 ghcPkgPath FilePath 100 runghcPath FilePath 101 haddockPath FilePath 102 103 cabalVersion Text 104 globalDb FilePath 105 globalDbCacheSize Int64 106 globalDbCacheModified Int64 107 info ByteString 108 109 -- This is the ugliest part of this table, simply storing a Show/Read version of the 110 -- data. We could do a better job with normalized data and proper table structure. 111 -- However, recomputing this value in the future if the data representation changes 112 -- is very cheap, so we'll take the easy way out for now. 113 globalDump Text 114 115 UniqueCompilerInfo ghcPath 116 117-- Last time certain actions were performed 118LastPerformed 119 action Action 120 timestamp UTCTime 121 UniqueAction action 122|] 123 124-- | Initialize the database. 125initUserStorage :: 126 HasLogFunc env 127 => Path Abs File -- ^ storage file 128 -> (UserStorage -> RIO env a) 129 -> RIO env a 130initUserStorage fp f = SQLite.initStorage "Stack" migrateAll fp $ f . UserStorage 131 132-- | Run an action in a database transaction 133withUserStorage :: 134 (HasConfig env, HasLogFunc env) 135 => ReaderT SqlBackend (RIO env) a 136 -> RIO env a 137withUserStorage inner = do 138 storage <- view (configL . to configUserStorage . to unUserStorage) 139 SQLite.withStorage_ storage inner 140 141-- | Key used to retrieve the precompiled cache 142type PrecompiledCacheKey = Unique PrecompiledCacheParent 143 144-- | Build key used to retrieve the precompiled cache 145precompiledCacheKey :: 146 Path Rel Dir 147 -> ActualCompiler 148 -> Version 149 -> Text 150 -> ByteString 151 -> Bool 152 -> PrecompiledCacheKey 153precompiledCacheKey platformGhcDir compiler cabalVersion = 154 UniquePrecompiledCacheParent 155 (toFilePath platformGhcDir) 156 (compilerVersionText compiler) 157 (T.pack $ versionString cabalVersion) 158 159-- | Internal helper to read the 'PrecompiledCache' from the database 160readPrecompiledCache :: 161 (HasConfig env, HasLogFunc env) 162 => PrecompiledCacheKey 163 -> ReaderT SqlBackend (RIO env) (Maybe ( PrecompiledCacheParentId 164 , PrecompiledCache Rel)) 165readPrecompiledCache key = do 166 mparent <- getBy key 167 forM mparent $ \(Entity parentId PrecompiledCacheParent {..}) -> do 168 pcLibrary <- mapM parseRelFile precompiledCacheParentLibrary 169 pcSubLibs <- 170 mapM (parseRelFile . precompiledCacheSubLibValue . entityVal) =<< 171 selectList [PrecompiledCacheSubLibParent ==. parentId] [] 172 pcExes <- 173 mapM (parseRelFile . precompiledCacheExeValue . entityVal) =<< 174 selectList [PrecompiledCacheExeParent ==. parentId] [] 175 return (parentId, PrecompiledCache {..}) 176 177-- | Load 'PrecompiledCache' from the database. 178loadPrecompiledCache :: 179 (HasConfig env, HasLogFunc env) 180 => PrecompiledCacheKey 181 -> RIO env (Maybe (PrecompiledCache Rel)) 182loadPrecompiledCache key = withUserStorage $ fmap snd <$> readPrecompiledCache key 183 184-- | Insert or update 'PrecompiledCache' to the database. 185savePrecompiledCache :: 186 (HasConfig env, HasLogFunc env) 187 => PrecompiledCacheKey 188 -> PrecompiledCache Rel 189 -> RIO env () 190savePrecompiledCache key@(UniquePrecompiledCacheParent precompiledCacheParentPlatformGhcDir precompiledCacheParentCompiler precompiledCacheParentCabalVersion precompiledCacheParentPackageKey precompiledCacheParentOptionsHash precompiledCacheParentHaddock) new = 191 withUserStorage $ do 192 let precompiledCacheParentLibrary = fmap toFilePath (pcLibrary new) 193 mIdOld <- readPrecompiledCache key 194 (parentId, mold) <- 195 case mIdOld of 196 Nothing -> (, Nothing) <$> insert PrecompiledCacheParent {..} 197 Just (parentId, old) -> do 198 update 199 parentId 200 [ PrecompiledCacheParentLibrary =. 201 precompiledCacheParentLibrary 202 ] 203 return (parentId, Just old) 204 updateSet 205 PrecompiledCacheSubLib 206 PrecompiledCacheSubLibParent 207 parentId 208 PrecompiledCacheSubLibValue 209 (maybe Set.empty (toFilePathSet . pcSubLibs) mold) 210 (toFilePathSet $ pcSubLibs new) 211 updateSet 212 PrecompiledCacheExe 213 PrecompiledCacheExeParent 214 parentId 215 PrecompiledCacheExeValue 216 (maybe Set.empty (toFilePathSet . pcExes) mold) 217 (toFilePathSet $ pcExes new) 218 where 219 toFilePathSet = Set.fromList . map toFilePath 220 221-- | Get the record of whether an executable is compatible with a Docker image 222loadDockerImageExeCache :: 223 (HasConfig env, HasLogFunc env) 224 => Text 225 -> Path Abs File 226 -> UTCTime 227 -> RIO env (Maybe Bool) 228loadDockerImageExeCache imageId exePath exeTimestamp = 229 withUserStorage $ 230 fmap (dockerImageExeCacheCompatible . entityVal) <$> 231 getBy (DockerImageExeCacheUnique imageId (toFilePath exePath) exeTimestamp) 232 233-- | Sest the record of whether an executable is compatible with a Docker image 234saveDockerImageExeCache :: 235 (HasConfig env, HasLogFunc env) 236 => Text 237 -> Path Abs File 238 -> UTCTime 239 -> Bool 240 -> RIO env () 241saveDockerImageExeCache imageId exePath exeTimestamp compatible = 242 void $ 243 withUserStorage $ 244 upsert 245 (DockerImageExeCache 246 imageId 247 (toFilePath exePath) 248 exeTimestamp 249 compatible) 250 [] 251 252-- | Type-restricted version of 'fromIntegral' to ensure we're making 253-- the value bigger, not smaller. 254sizeToInt64 :: COff -> Int64 255sizeToInt64 (COff i) = fromIntegral i -- fromIntegral added for 32-bit systems 256 257-- | Type-restricted version of 'fromIntegral' to ensure we're making 258-- the value bigger, not smaller. 259timeToInt64 :: CTime -> Int64 260timeToInt64 (CTime i) = fromIntegral i -- fromIntegral added for 32-bit systems 261 262-- | Load compiler information, if available, and confirm that the 263-- referenced files are unchanged. May throw exceptions! 264loadCompilerPaths 265 :: HasConfig env 266 => Path Abs File -- ^ compiler executable 267 -> CompilerBuild 268 -> Bool -- ^ sandboxed? 269 -> RIO env (Maybe CompilerPaths) 270loadCompilerPaths compiler build sandboxed = do 271 mres <- withUserStorage $ getBy $ UniqueCompilerInfo $ toFilePath compiler 272 for mres $ \(Entity _ CompilerCache {..}) -> do 273 compilerStatus <- liftIO $ getFileStatus $ toFilePath compiler 274 when 275 (compilerCacheGhcSize /= sizeToInt64 (fileSize compilerStatus) || 276 compilerCacheGhcModified /= timeToInt64 (modificationTime compilerStatus)) 277 (throwString "Compiler file metadata mismatch, ignoring cache") 278 globalDbStatus <- liftIO $ getFileStatus $ compilerCacheGlobalDb FP.</> "package.cache" 279 when 280 (compilerCacheGlobalDbCacheSize /= sizeToInt64 (fileSize globalDbStatus) || 281 compilerCacheGlobalDbCacheModified /= timeToInt64 (modificationTime globalDbStatus)) 282 (throwString "Global package cache file metadata mismatch, ignoring cache") 283 284 -- We could use parseAbsFile instead of resolveFile' below to 285 -- bypass some system calls, at the cost of some really wonky 286 -- error messages in case someone screws up their GHC installation 287 pkgexe <- resolveFile' compilerCacheGhcPkgPath 288 runghc <- resolveFile' compilerCacheRunghcPath 289 haddock <- resolveFile' compilerCacheHaddockPath 290 globaldb <- resolveDir' compilerCacheGlobalDb 291 292 cabalVersion <- parseVersionThrowing $ T.unpack compilerCacheCabalVersion 293 globalDump <- 294 case readMaybe $ T.unpack compilerCacheGlobalDump of 295 Nothing -> throwString "Global dump did not parse correctly" 296 Just globalDump -> pure globalDump 297 arch <- 298 case simpleParse $ T.unpack compilerCacheArch of 299 Nothing -> throwString $ "Invalid arch: " ++ show compilerCacheArch 300 Just arch -> pure arch 301 302 pure CompilerPaths 303 { cpCompiler = compiler 304 , cpCompilerVersion = compilerCacheActualVersion 305 , cpArch = arch 306 , cpBuild = build 307 , cpPkg = GhcPkgExe pkgexe 308 , cpInterpreter = runghc 309 , cpHaddock = haddock 310 , cpSandboxed = sandboxed 311 , cpCabalVersion = cabalVersion 312 , cpGlobalDB = globaldb 313 , cpGhcInfo = compilerCacheInfo 314 , cpGlobalDump = globalDump 315 } 316 317-- | Save compiler information. May throw exceptions! 318saveCompilerPaths 319 :: HasConfig env 320 => CompilerPaths 321 -> RIO env () 322saveCompilerPaths CompilerPaths {..} = withUserStorage $ do 323 deleteBy $ UniqueCompilerInfo $ toFilePath cpCompiler 324 compilerStatus <- liftIO $ getFileStatus $ toFilePath cpCompiler 325 globalDbStatus <- liftIO $ getFileStatus $ toFilePath $ cpGlobalDB </> $(mkRelFile "package.cache") 326 let GhcPkgExe pkgexe = cpPkg 327 insert_ CompilerCache 328 { compilerCacheActualVersion = cpCompilerVersion 329 , compilerCacheGhcPath = toFilePath cpCompiler 330 , compilerCacheGhcSize = sizeToInt64 $ fileSize compilerStatus 331 , compilerCacheGhcModified = timeToInt64 $ modificationTime compilerStatus 332 , compilerCacheGhcPkgPath = toFilePath pkgexe 333 , compilerCacheRunghcPath = toFilePath cpInterpreter 334 , compilerCacheHaddockPath = toFilePath cpHaddock 335 , compilerCacheCabalVersion = T.pack $ versionString cpCabalVersion 336 , compilerCacheGlobalDb = toFilePath cpGlobalDB 337 , compilerCacheGlobalDbCacheSize = sizeToInt64 $ fileSize globalDbStatus 338 , compilerCacheGlobalDbCacheModified = timeToInt64 $ modificationTime globalDbStatus 339 , compilerCacheInfo = cpGhcInfo 340 , compilerCacheGlobalDump = tshow cpGlobalDump 341 , compilerCacheArch = T.pack $ Distribution.Text.display cpArch 342 } 343 344-- | How many upgrade checks have occurred since the given timestamp? 345upgradeChecksSince :: HasConfig env => UTCTime -> RIO env Int 346upgradeChecksSince since = withUserStorage $ count 347 [ LastPerformedAction ==. UpgradeCheck 348 , LastPerformedTimestamp >=. since 349 ] 350 351-- | Log in the database that an upgrade check occurred at the given time. 352logUpgradeCheck :: HasConfig env => UTCTime -> RIO env () 353logUpgradeCheck time = withUserStorage $ void $ upsert 354 (LastPerformed UpgradeCheck time) 355 [LastPerformedTimestamp =. time] 356