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 a single project. 19module Stack.Storage.Project 20 ( initProjectStorage 21 , ConfigCacheKey 22 , configCacheKey 23 , loadConfigCache 24 , saveConfigCache 25 , deactiveConfigCache 26 ) where 27 28import qualified Data.ByteString as S 29import qualified Data.Set as Set 30import Database.Persist.Sqlite 31import Database.Persist.TH 32import qualified Pantry.Internal as SQLite 33import Path 34import Stack.Prelude hiding (MigrationFailure) 35import Stack.Storage.Util 36import Stack.Types.Build 37import Stack.Types.Cache 38import Stack.Types.Config (HasBuildConfig, buildConfigL, bcProjectStorage, ProjectStorage (..)) 39import Stack.Types.GhcPkgId 40 41share [ mkPersist sqlSettings 42 , mkDeleteCascade sqlSettings 43 , mkMigrate "migrateAll" 44 ] 45 [persistLowerCase| 46ConfigCacheParent sql="config_cache" 47 directory FilePath "default=(hex(randomblob(16)))" 48 type ConfigCacheType 49 pkgSrc CachePkgSrc 50 active Bool 51 pathEnvVar Text 52 haddock Bool default=0 53 UniqueConfigCacheParent directory type sql="unique_config_cache" 54 deriving Show 55 56ConfigCacheDirOption 57 parent ConfigCacheParentId sql="config_cache_id" 58 index Int 59 value String sql="option" 60 UniqueConfigCacheDirOption parent index 61 deriving Show 62 63ConfigCacheNoDirOption 64 parent ConfigCacheParentId sql="config_cache_id" 65 index Int 66 value String sql="option" 67 UniqueConfigCacheNoDirOption parent index 68 deriving Show 69 70ConfigCacheDep 71 parent ConfigCacheParentId sql="config_cache_id" 72 value GhcPkgId sql="ghc_pkg_id" 73 UniqueConfigCacheDep parent value 74 deriving Show 75 76ConfigCacheComponent 77 parent ConfigCacheParentId sql="config_cache_id" 78 value S.ByteString sql="component" 79 UniqueConfigCacheComponent parent value 80 deriving Show 81|] 82 83-- | Initialize the database. 84initProjectStorage :: 85 HasLogFunc env 86 => Path Abs File -- ^ storage file 87 -> (ProjectStorage -> RIO env a) 88 -> RIO env a 89initProjectStorage fp f = SQLite.initStorage "Stack" migrateAll fp $ f . ProjectStorage 90 91-- | Run an action in a database transaction 92withProjectStorage :: 93 (HasBuildConfig env, HasLogFunc env) 94 => ReaderT SqlBackend (RIO env) a 95 -> RIO env a 96withProjectStorage inner = do 97 storage <- view (buildConfigL . to bcProjectStorage . to unProjectStorage) 98 SQLite.withStorage_ storage inner 99 100-- | Key used to retrieve configuration or flag cache 101type ConfigCacheKey = Unique ConfigCacheParent 102 103-- | Build key used to retrieve configuration or flag cache 104configCacheKey :: Path Abs Dir -> ConfigCacheType -> ConfigCacheKey 105configCacheKey dir = UniqueConfigCacheParent (toFilePath dir) 106 107-- | Internal helper to read the 'ConfigCache' 108readConfigCache :: 109 (HasBuildConfig env, HasLogFunc env) 110 => Entity ConfigCacheParent 111 -> ReaderT SqlBackend (RIO env) ConfigCache 112readConfigCache (Entity parentId ConfigCacheParent {..}) = do 113 let configCachePkgSrc = configCacheParentPkgSrc 114 coDirs <- 115 map (configCacheDirOptionValue . entityVal) <$> 116 selectList 117 [ConfigCacheDirOptionParent ==. parentId] 118 [Asc ConfigCacheDirOptionIndex] 119 coNoDirs <- 120 map (configCacheNoDirOptionValue . entityVal) <$> 121 selectList 122 [ConfigCacheNoDirOptionParent ==. parentId] 123 [Asc ConfigCacheNoDirOptionIndex] 124 let configCacheOpts = ConfigureOpts {..} 125 configCacheDeps <- 126 Set.fromList . map (configCacheDepValue . entityVal) <$> 127 selectList [ConfigCacheDepParent ==. parentId] [] 128 configCacheComponents <- 129 Set.fromList . map (configCacheComponentValue . entityVal) <$> 130 selectList [ConfigCacheComponentParent ==. parentId] [] 131 let configCachePathEnvVar = configCacheParentPathEnvVar 132 let configCacheHaddock = configCacheParentHaddock 133 return ConfigCache {..} 134 135-- | Load 'ConfigCache' from the database. 136loadConfigCache :: 137 (HasBuildConfig env, HasLogFunc env) 138 => ConfigCacheKey 139 -> RIO env (Maybe ConfigCache) 140loadConfigCache key = 141 withProjectStorage $ do 142 mparent <- getBy key 143 case mparent of 144 Nothing -> return Nothing 145 Just parentEntity@(Entity _ ConfigCacheParent {..}) 146 | configCacheParentActive -> 147 Just <$> readConfigCache parentEntity 148 | otherwise -> return Nothing 149 150-- | Insert or update 'ConfigCache' to the database. 151saveConfigCache :: 152 (HasBuildConfig env, HasLogFunc env) 153 => ConfigCacheKey 154 -> ConfigCache 155 -> RIO env () 156saveConfigCache key@(UniqueConfigCacheParent dir type_) new = 157 withProjectStorage $ do 158 mparent <- getBy key 159 (parentId, mold) <- 160 case mparent of 161 Nothing -> 162 (, Nothing) <$> 163 insert 164 ConfigCacheParent 165 { configCacheParentDirectory = dir 166 , configCacheParentType = type_ 167 , configCacheParentPkgSrc = configCachePkgSrc new 168 , configCacheParentActive = True 169 , configCacheParentPathEnvVar = configCachePathEnvVar new 170 , configCacheParentHaddock = configCacheHaddock new 171 } 172 Just parentEntity@(Entity parentId _) -> do 173 old <- readConfigCache parentEntity 174 update 175 parentId 176 [ ConfigCacheParentPkgSrc =. configCachePkgSrc new 177 , ConfigCacheParentActive =. True 178 , ConfigCacheParentPathEnvVar =. configCachePathEnvVar new 179 ] 180 return (parentId, Just old) 181 updateList 182 ConfigCacheDirOption 183 ConfigCacheDirOptionParent 184 parentId 185 ConfigCacheDirOptionIndex 186 (maybe [] (coDirs . configCacheOpts) mold) 187 (coDirs $ configCacheOpts new) 188 updateList 189 ConfigCacheNoDirOption 190 ConfigCacheNoDirOptionParent 191 parentId 192 ConfigCacheNoDirOptionIndex 193 (maybe [] (coNoDirs . configCacheOpts) mold) 194 (coNoDirs $ configCacheOpts new) 195 updateSet 196 ConfigCacheDep 197 ConfigCacheDepParent 198 parentId 199 ConfigCacheDepValue 200 (maybe Set.empty configCacheDeps mold) 201 (configCacheDeps new) 202 updateSet 203 ConfigCacheComponent 204 ConfigCacheComponentParent 205 parentId 206 ConfigCacheComponentValue 207 (maybe Set.empty configCacheComponents mold) 208 (configCacheComponents new) 209 210-- | Mark 'ConfigCache' as inactive in the database. 211-- We use a flag instead of deleting the records since, in most cases, the same 212-- cache will be written again within in a few seconds (after 213-- `cabal configure`), so this avoids unnecessary database churn. 214deactiveConfigCache :: HasBuildConfig env => ConfigCacheKey -> RIO env () 215deactiveConfigCache (UniqueConfigCacheParent dir type_) = 216 withProjectStorage $ 217 updateWhere 218 [ConfigCacheParentDirectory ==. dir, ConfigCacheParentType ==. type_] 219 [ConfigCacheParentActive =. False] 220