Skip to content

Commit 0680b9f

Browse files
borsboomborsboom
committed
Share database initialization code with Pantry
1 parent 2833c22 commit 0680b9f

11 files changed

Lines changed: 99 additions & 102 deletions

File tree

‎package.yaml‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -214,7 +214,6 @@ library:
214214
- Stack.Package
215215
- Stack.PackageDump
216216
- Stack.Path
217-
- Stack.PersistentTH
218217
- Stack.Prelude
219218
- Stack.Runners
220219
- Stack.Script
@@ -223,6 +222,7 @@ library:
223222
- Stack.Setup.Installed
224223
- Stack.SetupCmd
225224
- Stack.SourceMap
225+
- Stack.Storage
226226
- Stack.Types.Build
227227
- Stack.Types.CompilerBuild
228228
- Stack.Types.Compiler

‎src/Stack/Build/Cache.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -43,7 +43,7 @@ import Path
4343
import Path.IO
4444
import Stack.Constants
4545
import Stack.Constants.Config
46-
import Stack.PersistentTH
46+
import Stack.Storage
4747
import Stack.Types.Build
4848
import Stack.Types.Cache
4949
import Stack.Types.Config

‎src/Stack/Build/Execute.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -875,7 +875,7 @@ ensureConfig newConfigCache pkgDir ExecuteEnv {..} announce cabal cabalfp task =
875875
, nodirs
876876
]
877877
-- Only write the cache for local packages. Remote packages are built
878-
-- in a temporary directly so the cache would never be used anyway.
878+
-- in a temporary directory so the cache would never be used anyway.
879879
case taskType task of
880880
TTLocalMutable{} -> writeConfigCache pkgDir newConfigCache
881881
TTRemotePackage{} -> return ()

‎src/Stack/Config.hs‎

Lines changed: 4 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -64,7 +64,7 @@ import Stack.Config.Docker
6464
import Stack.Config.Nix
6565
import Stack.Constants
6666
import Stack.Build.Haddock (shouldHaddockDeps)
67-
import Stack.PersistentTH (initCacheStorage)
67+
import Stack.Storage (initStorage)
6868
import Stack.SourceMap
6969
import Stack.Types.Build
7070
import Stack.Types.Config
@@ -360,9 +360,9 @@ configFromConfigMonoid
360360
hsc
361361
(maybe HpackBundled HpackCommand $ getFirst configMonoidOverrideHpack)
362362
clConnectionCount
363-
(\configPantryConfig -> initCacheStorage
364-
(configStackRoot </> relFileCaches)
365-
(\configCachePool -> inner Config {..}))
363+
(\configPantryConfig -> initStorage
364+
(configStackRoot </> relFileStorage)
365+
(\configStorage -> inner Config {..}))
366366

367367
-- | Get the default location of the local programs directory.
368368
getDefaultLocalProgramsBase :: MonadThrow m

‎src/Stack/Constants.hs‎

Lines changed: 3 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -58,7 +58,7 @@ module Stack.Constants
5858
,relDirHoogle
5959
,relFileDatabaseHoo
6060
,relDirPkgdb
61-
,relFileCaches
61+
,relFileStorage
6262
,relDirLoadedSnapshotCache
6363
,bindirSuffix
6464
,docDirSuffix
@@ -398,8 +398,8 @@ relFileDatabaseHoo = $(mkRelFile "database.hoo")
398398
relDirPkgdb :: Path Rel Dir
399399
relDirPkgdb = $(mkRelDir "pkgdb")
400400

401-
relFileCaches :: Path Rel File
402-
relFileCaches = $(mkRelFile "caches.sqlite3")
401+
relFileStorage :: Path Rel File
402+
relFileStorage = $(mkRelFile "stack.sqlite3")
403403

404404
relDirLoadedSnapshotCache :: Path Rel Dir
405405
relDirLoadedSnapshotCache = $(mkRelDir "loaded-snapshot-cached")

src/Stack/PersistentTH.hs renamed to src/Stack/Storage.hs

Lines changed: 27 additions & 63 deletions
Original file line numberDiff line numberDiff line change
@@ -12,9 +12,9 @@
1212
{-# OPTIONS_GHC -Wno-unused-top-binds #-}
1313

1414
-- | Work with SQLite database used for caches.
15-
module Stack.PersistentTH
16-
( initCacheStorage
17-
, withCacheStorage
15+
module Stack.Storage
16+
( initStorage
17+
, withStorage
1818
, loadConfigCache
1919
, saveConfigCache
2020
, deactiveConfigCache
@@ -23,24 +23,21 @@ module Stack.PersistentTH
2323
) where
2424

2525
import qualified Data.ByteString as S
26-
import Data.Pool (Pool, destroyAllResources)
2726
import qualified Data.Set as Set
28-
import Database.Persist.Sql (SqlBackend, runMigrationSilent, runSqlPool)
27+
import Database.Persist.Sql (SqlBackend)
2928
import Database.Persist.Sqlite
3029
import Database.Persist.TH
31-
import Database.Sqlite (SqliteException)
30+
import qualified Pantry.SQLite as SQLite
3231
import Path
33-
import Path.IO (ensureDir)
34-
import qualified RIO.Text as T
3532
import Stack.Prelude hiding (MigrationFailure)
3633
import Stack.Types.Build
3734
import Stack.Types.Cache
38-
import Stack.Types.Config (HasConfig, configCachePool, configL)
35+
import Stack.Types.Config (HasConfig, configStorage, configL)
3936
import Stack.Types.GhcPkgId
4037

4138
share [ mkPersist sqlSettings
4239
, mkDeleteCascade sqlSettings
43-
, mkMigrate "migrateAllCache"
40+
, mkMigrate "migrateAll"
4441
]
4542
[persistLowerCase|
4643
ConfigCacheParent sql="config_cache"
@@ -88,58 +85,22 @@ PrecompiledCacheExe
8885
deriving Show
8986
|]
9087

91-
data PersistentException =
92-
MigrationFailure !(Path Abs File)
93-
!SqliteException
94-
deriving (Typeable)
88+
-- | Initialize the database.
89+
initStorage
90+
:: HasLogFunc env
91+
=> Path Abs File -- ^ storage file
92+
-> (SQLite.Storage -> RIO env a)
93+
-> RIO env a
94+
initStorage =
95+
SQLite.initStorage "Stack" migrateAll
9596

96-
instance Exception PersistentException
97-
98-
instance Show PersistentException where
99-
show = T.unpack . utf8BuilderToText . display
100-
101-
instance Display PersistentException where
102-
display (MigrationFailure fp ex) =
103-
"Encountered error while migrating cache database:" <> "\n " <>
104-
displayShow ex <>
105-
"\nPlease report this on https://github.com/commercialhaskell/stack/issues" <>
106-
"\nAs a workaround you may delete the database in " <>
107-
fromString (toFilePath fp) <>
108-
" triggering its recreation."
109-
110-
-- | Initialize the cache database.
111-
initCacheStorage ::
112-
HasLogFunc env
113-
=> Path Abs File -- ^ storage file
114-
-> (Pool SqlBackend -> RIO env a)
115-
-> RIO env a
116-
initCacheStorage fp inner = do
117-
ensureDir $ parent fp
118-
bracket
119-
(createSqlitePoolFromInfo (sqinfo False) 1)
120-
(liftIO . destroyAllResources) $ \pool -> do
121-
migrates <-
122-
wrapMigrationFailure $
123-
runSqlPool (runMigrationSilent migrateAllCache) pool
124-
forM_ migrates $ \mig ->
125-
logDebug $ "Migration executed: " <> display mig
126-
bracket
127-
(createSqlitePoolFromInfo (sqinfo True) 1)
128-
(liftIO . destroyAllResources) $ \pool -> inner pool
129-
where
130-
wrapMigrationFailure = handle (throwIO . MigrationFailure fp)
131-
sqinfo fk =
132-
set extraPragmas ["PRAGMA busy_timeout=2000;"] $
133-
set fkEnabled fk $ mkSqliteConnectionInfo (fromString $ toFilePath fp)
134-
135-
-- | Run an action in a cache database transaction.
136-
withCacheStorage ::
97+
-- | Run an action in a database transaction
98+
withStorage ::
13799
(HasConfig env, HasLogFunc env)
138100
=> ReaderT SqlBackend (RIO env) a
139101
-> RIO env a
140-
withCacheStorage action = do
141-
pool <- view $ configL . to configCachePool
142-
runSqlPool action pool
102+
withStorage inner =
103+
SQLite.withStorage inner =<< view (configL . to configStorage)
143104

144105
-- | Internal helper to read the 'ConfigCache'
145106
readConfigCache ::
@@ -173,7 +134,7 @@ loadConfigCache ::
173134
=> ConfigCacheKey
174135
-> RIO env (Maybe ConfigCache)
175136
loadConfigCache key =
176-
withCacheStorage $ do
137+
withStorage $ do
177138
mparent <- getBy (UniqueConfigCacheParent key)
178139
case mparent of
179140
Nothing -> return Nothing
@@ -189,7 +150,7 @@ saveConfigCache ::
189150
-> ConfigCache
190151
-> RIO env ()
191152
saveConfigCache key new =
192-
withCacheStorage $ do
153+
withStorage $ do
193154
mparent <- getBy (UniqueConfigCacheParent key)
194155
(parentId, mold) <-
195156
case mparent of
@@ -239,9 +200,12 @@ saveConfigCache key new =
239200
(configCacheComponents new)
240201

241202
-- | Mark 'ConfigCache' as inactive in the database.
203+
-- We use a flag instead of deleting the records since, in most cases, the same
204+
-- cache will be written again within in a few seconds (after
205+
-- `cabal configure`), so this avoids unnecessary database churn.
242206
deactiveConfigCache :: HasConfig env => ConfigCacheKey -> RIO env ()
243207
deactiveConfigCache key =
244-
withCacheStorage $
208+
withStorage $
245209
updateWhere
246210
[ConfigCacheParentKey ==. key]
247211
[ConfigCacheParentActive =. False]
@@ -270,7 +234,7 @@ loadPrecompiledCache ::
270234
=> PrecompiledCacheKey
271235
-> RIO env (Maybe (PrecompiledCache Rel))
272236
loadPrecompiledCache key =
273-
withCacheStorage $ fmap snd <$> readPrecompiledCache key
237+
withStorage $ fmap snd <$> readPrecompiledCache key
274238

275239
-- | Insert or update 'PrecompiledCache' to the database.
276240
savePrecompiledCache ::
@@ -279,7 +243,7 @@ savePrecompiledCache ::
279243
-> PrecompiledCache Rel
280244
-> RIO env ()
281245
savePrecompiledCache key new =
282-
withCacheStorage $ do
246+
withStorage $ do
283247
mIdOld <- readPrecompiledCache key
284248
(parentId, mold) <-
285249
case mIdOld of

‎src/Stack/Types/Config.hs‎

Lines changed: 3 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -189,13 +189,11 @@ import qualified Data.Map as Map
189189
import qualified Data.Map.Strict as M
190190
import qualified Data.Monoid as Monoid
191191
import Data.Monoid.Map (MonoidMap(..))
192-
import Data.Pool (Pool)
193192
import qualified Data.Set as Set
194193
import qualified Data.Text as T
195194
import Data.Text.Encoding (encodeUtf8)
196195
import Data.Yaml (ParseException)
197196
import qualified Data.Yaml as Yaml
198-
import Database.Persist.Sql (SqlBackend)
199197
import Distribution.PackageDescription (GenericPackageDescription)
200198
import qualified Distribution.PackageDescription as C
201199
import Distribution.System (Platform)
@@ -207,6 +205,7 @@ import Lens.Micro (Lens', lens, _1, _2, to)
207205
import Options.Applicative (ReadM)
208206
import qualified Options.Applicative as OA
209207
import qualified Options.Applicative.Types as OA
208+
import Pantry.SQLite (Storage)
210209
import Path
211210
import qualified Paths_stack as Meta
212211
import RIO.PrettyPrint (HasTerm (..))
@@ -355,8 +354,8 @@ data Config =
355354
,configStackRoot :: !(Path Abs Dir)
356355
,configResolver :: !(Maybe AbstractResolver)
357356
-- ^ Any resolver override from the command line
358-
,configCachePool :: !(Pool SqlBackend)
359-
-- ^ Database connection pool for caches
357+
,configStorage :: !Storage
358+
-- ^ Database connection pool for Stack database
360359
}
361360

362361
-- | The project root directory, if in a project.

‎subs/pantry/package.yaml‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -99,6 +99,7 @@ library:
9999
- Pantry
100100
- Pantry.SHA256
101101
- Pantry.HPack
102+
- Pantry.SQLite
102103

103104
# For testing
104105
- Pantry.Internal

‎subs/pantry/src/Pantry/SQLite.hs‎

Lines changed: 47 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,47 @@
1+
{-# LANGUAGE NoImplicitPrelude #-}
2+
{-# LANGUAGE OverloadedStrings #-}
3+
module Pantry.SQLite
4+
( P.Storage
5+
, initStorage
6+
, withStorage
7+
) where
8+
9+
import RIO hiding (FilePath)
10+
import qualified Pantry.Types as P
11+
import Database.Persist.Sqlite
12+
import RIO.Orphans ()
13+
import Path (Path, Abs, File, toFilePath, parent)
14+
import Path.IO (ensureDir)
15+
import Data.Pool (destroyAllResources)
16+
import Pantry.Types (PantryException (MigrationFailure))
17+
18+
initStorage
19+
:: HasLogFunc env
20+
=> Text
21+
-> Migration
22+
-> Path Abs File -- ^ storage file
23+
-> (P.Storage -> RIO env a)
24+
-> RIO env a
25+
initStorage description migration fp inner = do
26+
ensureDir $ parent fp
27+
bracket
28+
(createSqlitePoolFromInfo (sqinfo False) 1)
29+
(liftIO . destroyAllResources) $ \pool -> do
30+
migrates <- wrapMigrationFailure $ runSqlPool (runMigrationSilent migration) pool
31+
forM_ migrates $ \mig -> logDebug $ "Migration executed: " <> display mig
32+
bracket
33+
(createSqlitePoolFromInfo (sqinfo True) 1)
34+
(liftIO . destroyAllResources) $ \pool -> inner (P.Storage pool)
35+
where
36+
wrapMigrationFailure = handle (throwIO . MigrationFailure description fp)
37+
sqinfo fk = set extraPragmas ["PRAGMA busy_timeout=2000;"]
38+
$ set fkEnabled fk
39+
$ mkSqliteConnectionInfo (fromString $ toFilePath fp)
40+
41+
withStorage
42+
:: HasLogFunc env
43+
=> ReaderT SqlBackend (RIO env) a
44+
-> P.Storage
45+
-> RIO env a
46+
withStorage action (P.Storage pool) =
47+
runSqlPool action pool

‎subs/pantry/src/Pantry/Storage.hs‎

Lines changed: 8 additions & 22 deletions
Original file line numberDiff line numberDiff line change
@@ -84,13 +84,13 @@ import qualified Pantry.SHA256 as SHA256
8484
import qualified RIO.Map as Map
8585
import qualified RIO.Text as T
8686
import RIO.Time (UTCTime, getCurrentTime)
87-
import Path (Path, Abs, File, Dir, toFilePath, parent, filename, parseAbsDir, fromAbsFile, fromRelFile)
88-
import Path.IO (ensureDir, listDir, createTempDir, getTempDir, removeDirRecur)
89-
import Data.Pool (destroyAllResources)
87+
import Path (Path, Abs, File, Dir, toFilePath, filename, parseAbsDir, fromAbsFile, fromRelFile)
88+
import Path.IO (listDir, createTempDir, getTempDir, removeDirRecur)
9089
import Pantry.HPack (hpackVersion, hpack)
9190
import Conduit
9291
import Data.Acquire (with)
93-
import Pantry.Types (PackageNameP (..), VersionP (..), SHA256, FileSize (..), FileType (..), HasPantryConfig, BlobKey, Repo (..), TreeKey, SafeFilePath, Revision (..), Package (..), PantryException (MigrationFailure), SnapshotCacheHash (..))
92+
import Pantry.Types (PackageNameP (..), VersionP (..), SHA256, FileSize (..), FileType (..), HasPantryConfig, BlobKey, Repo (..), TreeKey, SafeFilePath, Revision (..), Package (..), SnapshotCacheHash (..))
93+
import qualified Pantry.SQLite as SQLite
9494

9595
share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
9696
-- Raw blobs
@@ -233,29 +233,15 @@ initStorage
233233
=> Path Abs File -- ^ storage file
234234
-> (P.Storage -> RIO env a)
235235
-> RIO env a
236-
initStorage fp inner = do
237-
ensureDir $ parent fp
238-
bracket
239-
(createSqlitePoolFromInfo (sqinfo False) 1)
240-
(liftIO . destroyAllResources) $ \pool -> do
241-
migrates <- wrapMigrationFailure $ runSqlPool (runMigrationSilent migrateAll) pool
242-
forM_ migrates $ \mig -> logDebug $ "Migration executed: " <> display mig
243-
bracket
244-
(createSqlitePoolFromInfo (sqinfo True) 1)
245-
(liftIO . destroyAllResources) $ \pool -> inner (P.Storage pool)
246-
where
247-
wrapMigrationFailure = handle (throwIO . MigrationFailure fp)
248-
sqinfo fk = set extraPragmas ["PRAGMA busy_timeout=2000;"]
249-
$ set fkEnabled fk
250-
$ mkSqliteConnectionInfo (fromString $ toFilePath fp)
236+
initStorage =
237+
SQLite.initStorage "Pantry" migrateAll
251238

252239
withStorage
253240
:: (HasPantryConfig env, HasLogFunc env)
254241
=> ReaderT SqlBackend (RIO env) a
255242
-> RIO env a
256-
withStorage action = do
257-
P.Storage pool <- view $ P.pantryConfigL.to P.pcStorage
258-
runSqlPool action pool
243+
withStorage action =
244+
SQLite.withStorage action =<< view (P.pantryConfigL.to P.pcStorage)
259245

260246
getPackageNameId
261247
:: (HasPantryConfig env, HasLogFunc env)

0 commit comments

Comments
 (0)