haskell/stackage-server
1
0
Fork 0
mirror of https://github.com/commercialhaskell/stackage-server.git synced 2026-01-19 07:31:55 +01:00
Code Issues Actions Packages Projects Releases Wiki Activity

Merge pull request #303 from lehins/attempt-to-fix-slow-queries

Browse Source 
Attempt to fix slow queries
This commit is contained in:
Michael Snoyman 2020-11-15 06:30:13 +02:00 committed by GitHub
commit 89e373caf1
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
4 changed files with 8 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
bench/main.hs
View File

@ -36,8 +36,8 @@ runBenchApp pool m = runSimpleApp $ runSqlPool m pool
createBenchPool :: IO ConnectionPool createBenchPool :: IO ConnectionPool
createBenchPool = do createBenchPool = do
loadYamlSettingsArgs [configSettingsYmlValue] useEnv >>= \case loadYamlSettingsArgs [configSettingsYmlValue] useEnv >>= \case
AppSettings{appDatabase = DSPostgres pgString pgPoolSize} -> AppSettings{appDatabase = DSPostgres pgString _} ->
runNoLoggingT $ createPostgresqlPool (encodeUtf8 pgString) pgPoolSize runNoLoggingT $ createPostgresqlPool (encodeUtf8 pgString) 1
_ -> throwString "Benchmarks are crafted for PostgreSQL" _ -> throwString "Benchmarks are crafted for PostgreSQL"
releasePool :: ConnectionPool -> IO () releasePool :: ConnectionPool -> IO ()

1
indices
View File

@ -1,2 +1,3 @@
create index nightly_snap on nightly(snap); create index nightly_snap on nightly(snap);
create index snapshot_package_snapshot on snapshot_package(snapshot); create index snapshot_package_snapshot on snapshot_package(snapshot);
create index snapshot_created on snapshot (created desc);

2
src/Settings.hs
View File

@ -56,7 +56,7 @@ data AppSettings = AppSettings
} }
data DatabaseSettings data DatabaseSettings
= DSPostgres !Text !Int = DSPostgres !Text !(Maybe Int)
| DSSqlite !Text !Int | DSSqlite !Text !Int
parseDatabase parseDatabase

5
src/Stackage/Database/Schema.hs
View File

@ -66,6 +66,7 @@ import RIO
import RIO.Time import RIO.Time
import Types (CompilerP(..), FlagNameP, Origin, SnapName, VersionRangeP) import Types (CompilerP(..), FlagNameP, Origin, SnapName, VersionRangeP)
import Settings (DatabaseSettings (..)) import Settings (DatabaseSettings (..))
import UnliftIO.Concurrent (getNumCapabilities)
currentSchema :: Int currentSchema :: Int
currentSchema = 1 currentSchema = 1
@ -197,7 +198,9 @@ withStackageDatabase shouldLog dbs inner = do
let makePool :: (MonadUnliftIO m, MonadLogger m) => m (Pool SqlBackend) let makePool :: (MonadUnliftIO m, MonadLogger m) => m (Pool SqlBackend)
makePool = makePool =
case dbs of case dbs of
DSPostgres connStr size -> createPostgresqlPool (encodeUtf8 connStr) size DSPostgres connStr mSize -> do
size <- maybe getNumCapabilities pure mSize
createPostgresqlPool (encodeUtf8 connStr) size
DSSqlite connStr size -> do DSSqlite connStr size -> do
pool <- createSqlitePool connStr size pool <- createSqlitePool connStr size
runSqlPool (do runSqlPool (do