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