haskell/stackage-server
1
0
Fork 0
mirror of https://github.com/commercialhaskell/stackage-server.git synced 2026-01-12 04:08:29 +01:00
Code Issues Actions Packages Projects Releases Wiki Activity

Fix compilation of benchmarks

Browse Source
This commit is contained in:
Alexey Kuleshevich 2020-11-10 18:29:13 +03:00
parent 9a77dd3394
commit b7908241d7
No known key found for this signature in database
GPG Key ID: E59B216127119E3E
1 changed files with 9 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

25
bench/main.hs
View File

@ -1,6 +1,7 @@
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
import Control.Monad.Logger (runNoLoggingT, runStdoutLoggingT) import Control.Monad.Logger (runNoLoggingT, runStdoutLoggingT)
@ -10,7 +11,7 @@ import Database.Persist.Sql (ConnectionPool, SqlBackend, runSqlPool)
import Gauge import Gauge
import Pantry.Internal.Stackage (PackageNameP(..)) import Pantry.Internal.Stackage (PackageNameP(..))
import RIO import RIO
import Settings (getAppSettings, AppSettings(..), configSettingsYmlValue) import Settings (getAppSettings, AppSettings(..), DatabaseSettings(..), configSettingsYmlValue)
import Stackage.Database.Query import Stackage.Database.Query
import Stackage.Database.Schema (withStackageDatabase, runDatabase) import Stackage.Database.Schema (withStackageDatabase, runDatabase)
import Stackage.Database.Types (LatestInfo, SnapName(..), SnapshotPackageInfo(..)) import Stackage.Database.Types (LatestInfo, SnapName(..), SnapshotPackageInfo(..))
@ -19,17 +20,12 @@ import Yesod.Default.Config2
main :: IO () main :: IO ()
main = do main = do
appSettings <- getAppSettings appSettings <- getAppSettings
let pgConf =
PostgresConf
{ pgPoolSize = appPostgresPoolsize appSettings
, pgConnStr = encodeUtf8 $ appPostgresString appSettings
}
let snapName = SNLts 16 4 let snapName = SNLts 16 4
mSnapInfo <- mSnapInfo <-
runSimpleApp $ runSimpleApp $
withStackageDatabase withStackageDatabase
True True
pgConf (appDatabase appSettings)
(\db -> runDatabase db $ getSnapshotPackageInfoQuery snapName (PackageNameP "yesod")) (\db -> runDatabase db $ getSnapshotPackageInfoQuery snapName (PackageNameP "yesod"))
let snapInfo = fromMaybe (error "snapInfo not retrieved") mSnapInfo let snapInfo = fromMaybe (error "snapInfo not retrieved") mSnapInfo
defaultMain [benchs snapInfo] defaultMain [benchs snapInfo]
@ -39,13 +35,10 @@ runBenchApp pool m = runSimpleApp $ runSqlPool m pool
createBenchPool :: IO ConnectionPool createBenchPool :: IO ConnectionPool
createBenchPool = do createBenchPool = do
baSettings <- loadYamlSettingsArgs [configSettingsYmlValue] useEnv loadYamlSettingsArgs [configSettingsYmlValue] useEnv >>= \case
pool <- AppSettings{appDatabase = DSPostgres pgString pgPoolSize} ->
runNoLoggingT $ runNoLoggingT $ createPostgresqlPool (encodeUtf8 pgString) pgPoolSize
createPostgresqlPool _ -> throwString "Benchmarks are crafted for PostgreSQL"
(encodeUtf8 $ appPostgresString baSettings)
(appPostgresPoolsize baSettings)
pure pool
releasePool :: ConnectionPool -> IO () releasePool :: ConnectionPool -> IO ()
releasePool = destroyAllResources releasePool = destroyAllResources