From 35ac503bf971ace21c49646aa15e8b94b7a3e823 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Sun, 21 Feb 2021 20:44:45 +0100 Subject: [PATCH] feat(db): optionally disable some db connection pooling --- src/Application.hs | 76 ++++++++++++++++++--------------- src/Foundation/DB.hs | 15 ++++--- src/Foundation/Type.hs | 6 +-- src/Foundation/Yesod/Persist.hs | 5 ++- src/Settings.hs | 2 + test/Database.hs | 2 +- test/TestImport.hs | 2 +- 7 files changed, 60 insertions(+), 48 deletions(-) diff --git a/src/Application.hs b/src/Application.hs index feb2980ec..03d798600 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -18,7 +18,7 @@ module Application import Control.Monad.Logger (liftLoc, LoggingT(..), MonadLoggerIO(..)) import Database.Persist.Postgresql (createPostgresqlPool, pgConnStr, - pgPoolSize, runSqlPool, ConnectionPool) + pgPoolSize, runSqlPool, ConnectionPool, runSqlConn, withPostgresqlConn) import Import hiding (cancel, respond) import Language.Haskell.TH.Syntax (qLocation) import Network.Wai (Middleware) @@ -202,25 +202,28 @@ makeFoundation appSettings''@AppSettings{..} = do -- logging function. To get out of this loop, we initially create a -- temporary foundation without a real connection pool, get a log function -- from there, and then create the real foundation. - let mkFoundation appSettings' appConnPool appSmtpPool appLdapPool appCryptoIDKey appSessionStore appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID appMemcached appUploadCache appVerpSecret appAuthKey = UniWorX {..} - -- The UniWorX {..} syntax is an example of record wild cards. For more - -- information, see: - -- https://ocharles.org.uk/blog/posts/2014-12-04-record-wildcards.html - tempFoundation = mkFoundation - (error "appSettings' forced in tempFoundation") - (error "connPool forced in tempFoundation") - (error "smtpPool forced in tempFoundation") - (error "ldapPool forced in tempFoundation") - (error "cryptoIDKey forced in tempFoundation") - (error "sessionStore forced in tempFoundation") - (error "secretBoxKey forced in tempFoundation") - (error "widgetMemcached forced in tempFoundation") - (error "JSONWebKeySet forced in tempFoundation") - (error "ClusterID forced in tempFoundation") - (error "memcached forced in tempFoundation") - (error "MinioConn forced in tempFoundation") - (error "VerpSecret forced in tempFoundation") - (error "AuthKey forced in tempFoundation") + let + mkFoundation :: _ -> _ -> (forall backend m a. (MonadUnliftIO m, BackendCompatible backend SqlBackend, MonadLogger m) => ReaderT backend m a -> m a) -> _ + mkFoundation appSettings' appDatabaseConnPool appDatabaseAccess appSmtpPool appLdapPool appCryptoIDKey appSessionStore appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID appMemcached appUploadCache appVerpSecret appAuthKey = UniWorX {..} + -- The UniWorX {..} syntax is an example of record wild cards. For more + -- information, see: + -- https://ocharles.org.uk/blog/posts/2014-12-04-record-wildcards.html + tempFoundation = mkFoundation + (error "appSettings' forced in tempFoundation") + (error "databaseConnPool forced in tempFoundation") + (error "databaseAccess forced in tempFoundation") + (error "smtpPool forced in tempFoundation") + (error "ldapPool forced in tempFoundation") + (error "cryptoIDKey forced in tempFoundation") + (error "sessionStore forced in tempFoundation") + (error "secretBoxKey forced in tempFoundation") + (error "widgetMemcached forced in tempFoundation") + (error "JSONWebKeySet forced in tempFoundation") + (error "ClusterID forced in tempFoundation") + (error "memcached forced in tempFoundation") + (error "MinioConn forced in tempFoundation") + (error "VerpSecret forced in tempFoundation") + (error "AuthKey forced in tempFoundation") runAppLoggingT tempFoundation $ do $logInfoS "InstanceID" $ UUID.toText appInstanceID @@ -237,9 +240,14 @@ makeFoundation appSettings''@AppSettings{..} = do -- Create the database connection pool $logDebugS "setup" "PostgreSQL-Pool" - sqlPool <- createPostgresqlPool + appDatabaseConnPool <- createPostgresqlPool (pgConnStr appDatabaseConf) (pgPoolSize appDatabaseConf) + let + appDatabaseAccess :: forall backend m a. (MonadUnliftIO m, BackendCompatible backend SqlBackend, MonadLogger m) => ReaderT backend m a -> m a + appDatabaseAccess + | appDatabasePool = flip runSqlPool appDatabaseConnPool . withReaderT projectBackend + | otherwise = withPostgresqlConn (pgConnStr appDatabaseConf) . runSqlConn . withReaderT projectBackend ldapPool <- traverse mkFailoverLabeled <=< forOf (traverse . traverse) appLdapConf $ \conf@LdapConf{..} -> do let ldapLabel = case ldapHost of @@ -254,33 +262,33 @@ makeFoundation appSettings''@AppSettings{..} = do if | appAutoDbMigrate -> do $logDebugS "setup" "Migration" - migrateAll `runSqlPool` sqlPool - | otherwise -> whenM (requiresMigration `runSqlPool` sqlPool) $ do + appDatabaseAccess migrateAll + | otherwise -> whenM (appDatabaseAccess requiresMigration) $ do $logErrorS "setup" "Migration required" liftIO . exitWith $ ExitFailure 130 $logDebugS "setup" "Cluster-Config" - appCryptoIDKey <- clusterSetting (Proxy :: Proxy 'ClusterCryptoIDKey) `runSqlPool` sqlPool - appSecretBoxKey <- clusterSetting (Proxy :: Proxy 'ClusterSecretBoxKey) `runSqlPool` sqlPool - appJSONWebKeySet <- clusterSetting (Proxy :: Proxy 'ClusterJSONWebKeySet) `runSqlPool` sqlPool - appClusterID <- clusterSetting (Proxy :: Proxy 'ClusterId) `runSqlPool` sqlPool - appVerpSecret <- clusterSetting (Proxy :: Proxy 'ClusterVerpSecret) `runSqlPool` sqlPool - appAuthKey <- clusterSetting (Proxy :: Proxy 'ClusterAuthKey) `runSqlPool` sqlPool + appCryptoIDKey <- appDatabaseAccess . clusterSetting $ Proxy @'ClusterCryptoIDKey + appSecretBoxKey <- appDatabaseAccess . clusterSetting $ Proxy @'ClusterSecretBoxKey + appJSONWebKeySet <- appDatabaseAccess . clusterSetting $ Proxy @'ClusterJSONWebKeySet + appClusterID <- appDatabaseAccess . clusterSetting $ Proxy @'ClusterId + appVerpSecret <- appDatabaseAccess . clusterSetting $ Proxy @'ClusterVerpSecret + appAuthKey <- appDatabaseAccess . clusterSetting $ Proxy @'ClusterAuthKey - needsRechunk <- exists [FileContentChunkContentBased !=. True] `runSqlPool` sqlPool + needsRechunk <- appDatabaseAccess @SqlReadBackend $ exists [FileContentChunkContentBased !=. True] let appSettings' = appSettings'' & _appRechunkFiles %~ guardOnM needsRechunk appMemcached <- for appMemcachedConf $ \memcachedConf -> do $logDebugS "setup" "Memcached" - memcachedKey <- clusterSetting (Proxy :: Proxy 'ClusterMemcachedKey) `runSqlPool` sqlPool + memcachedKey <- appDatabaseAccess . clusterSetting $ Proxy @'ClusterMemcachedKey memcached <- createMemcached memcachedConf when appClearCache $ do $logWarnS "setup" "Clearing memcached" liftIO $ Memcached.flushAll memcached return (memcachedKey, memcached) - appSessionStore <- mkSessionStore appSettings'' sqlPool `runSqlPool` sqlPool + appSessionStore <- appDatabaseAccess $ mkSessionStore appSettings'' appDatabaseConnPool appUploadCache <- for appUploadCacheConf $ \minioConf -> liftIO $ do conn <- Minio.connect minioConf @@ -293,7 +301,7 @@ makeFoundation appSettings''@AppSettings{..} = do $logDebugS "Runtime configuration" $ tshow appSettings' - let foundation = mkFoundation appSettings' sqlPool smtpPool ldapPool appCryptoIDKey appSessionStore appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID appMemcached appUploadCache appVerpSecret appAuthKey + let foundation = mkFoundation appSettings' appDatabaseConnPool appDatabaseAccess smtpPool ldapPool appCryptoIDKey appSessionStore appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID appMemcached appUploadCache appVerpSecret appAuthKey -- Return the foundation $logDebugS "setup" "Done" @@ -644,7 +652,7 @@ shutdownApp :: (MonadIO m, MonadUnliftIO m) => UniWorX -> m () shutdownApp app = do stopJobCtl app liftIO $ do - destroyAllResources $ appConnPool app + destroyAllResources $ appDatabaseConnPool app for_ (appSmtpPool app) destroyAllResources for_ (appLdapPool app) . mapFailover $ views _2 destroyAllResources for_ (appWidgetMemcached app) Memcached.close diff --git a/src/Foundation/DB.hs b/src/Foundation/DB.hs index f871cc026..9730c3a5a 100644 --- a/src/Foundation/DB.hs +++ b/src/Foundation/DB.hs @@ -10,18 +10,18 @@ import Foundation.Type import qualified Control.Retry as Retry import GHC.IO.Exception (IOErrorType(OtherError)) -import Database.Persist.Sql (runSqlPool, SqlReadBackend(..)) +import Database.Persist.Sql (SqlReadBackend(..)) import Database.Persist.Sql.Raw.QQ (executeQQ) runSqlPoolRetry :: forall m a backend. - ( MonadUnliftIO m, BackendCompatible SqlBackend backend + ( MonadUnliftIO m , MonadLogger m, MonadMask m ) - => ReaderT backend m a - -> Pool backend + => (ReaderT backend m a -> m a) + -> ReaderT backend m a -> m a -runSqlPoolRetry action pool = do +runSqlPoolRetry dbAccess action = do let policy = Retry.fullJitterBackoff 1e3 & Retry.limitRetriesByCumulativeDelay 10e6 handlers = Retry.skipAsyncExceptions `snoc` Retry.logRetries suggestRetry logRetry where suggestRetry :: IOException -> m Bool @@ -39,9 +39,10 @@ runSqlPoolRetry action pool = do Retry.recovering policy handlers $ \Retry.RetryStatus{..} -> do $logDebugS "runSqlPoolRetry" $ "rsIterNumber = " <> tshow rsIterNumber - runSqlPool action pool + dbAccess action runDBRead :: ReaderT SqlReadBackend (HandlerFor UniWorX) a -> (HandlerFor UniWorX) a runDBRead action = do $logDebugS "YesodPersist" "runDBRead" - runSqlPoolRetry (withReaderT SqlReadBackend $ [executeQQ|SET TRANSACTION READ ONLY|] *> action) . appConnPool =<< getYesod + dbAccess <- getsYesod appDatabaseAccess + runSqlPoolRetry dbAccess . withReaderT SqlReadBackend $ [executeQQ|SET TRANSACTION READ ONLY|] *> action diff --git a/src/Foundation/Type.hs b/src/Foundation/Type.hs index 9c525dfd6..3e70ec2ad 100644 --- a/src/Foundation/Type.hs +++ b/src/Foundation/Type.hs @@ -6,12 +6,11 @@ module Foundation.Type , SomeSessionStorage(..) , _SessionStorageMemcachedSql, _SessionStorageAcid , SMTPPool - , _appSettings', _appStatic, _appConnPool, _appSmtpPool, _appLdapPool, _appWidgetMemcached, _appHttpManager, _appLogger, _appLogSettings, _appCryptoIDKey, _appClusterID, _appInstanceID, _appJobState, _appSessionStore, _appSecretBoxKey, _appJSONWebKeySet, _appHealthReport, _appMemcached, _appUploadCache, _appVerpSecret, _appAuthKey + , _appSettings', _appStatic, _appDatabaseConnPool, _appDatabaseAccess, _appSmtpPool, _appLdapPool, _appWidgetMemcached, _appHttpManager, _appLogger, _appLogSettings, _appCryptoIDKey, _appClusterID, _appInstanceID, _appJobState, _appSessionStore, _appSecretBoxKey, _appJSONWebKeySet, _appHealthReport, _appMemcached, _appUploadCache, _appVerpSecret, _appAuthKey , DB, Form, MsgRenderer, MailM, DBFile ) where import Import.NoFoundation -import Database.Persist.Sql (ConnectionPool) import Jobs.Types @@ -43,7 +42,8 @@ makePrisms ''SomeSessionStorage data UniWorX = UniWorX { appSettings' :: AppSettings , appStatic :: EmbeddedStatic -- ^ Settings for static file serving. - , appConnPool :: ConnectionPool -- ^ Database connection pool. + , appDatabaseConnPool :: Pool SqlBackend + , appDatabaseAccess :: forall backend m a. (MonadUnliftIO m, BackendCompatible backend SqlBackend, MonadLogger m) => ReaderT backend m a -> m a , appSmtpPool :: Maybe SMTPPool , appLdapPool :: Maybe (Failover (LdapConf, LdapPool)) , appWidgetMemcached :: Maybe Memcached.Connection -- ^ Actually a proper pool diff --git a/src/Foundation/Yesod/Persist.hs b/src/Foundation/Yesod/Persist.hs index 98462eda7..e467da4fe 100644 --- a/src/Foundation/Yesod/Persist.hs +++ b/src/Foundation/Yesod/Persist.hs @@ -25,14 +25,15 @@ runDB action = do | dryRun = action <* transactionUndo | otherwise = action - runSqlPoolRetry action' . appConnPool =<< getYesod + dbAccess <- getsYesod appDatabaseAccess + runSqlPoolRetry dbAccess action' getDBRunner :: ( YesodPersistBackend UniWorX ~ SqlBackend , BearerAuthSite UniWorX ) => HandlerFor UniWorX (DBRunner UniWorX, HandlerFor UniWorX ()) getDBRunner = do - (DBRunner{..}, cleanup) <- defaultGetDBRunner appConnPool + (DBRunner{..}, cleanup) <- defaultGetDBRunner appDatabaseConnPool return . (, cleanup) $ DBRunner (\action -> do dryRun <- isDryRun diff --git a/src/Settings.hs b/src/Settings.hs index 9006adba0..893170a89 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -90,6 +90,7 @@ data AppSettings = AppSettings , appWellKnownDir :: FilePath , appWellKnownLinkFile :: FilePath , appDatabaseConf :: PostgresConf + , appDatabasePool :: Bool -- ^ Configuration settings for accessing the database. , appAutoDbMigrate :: Bool , appLdapConf :: Maybe (PointedList LdapConf) @@ -516,6 +517,7 @@ instance FromJSON AppSettings where appWellKnownLinkFile <- o .: "well-known-link-file" appWebpackEntrypoints <- o .: "webpack-manifest" appDatabaseConf <- o .: "database" + appDatabasePool <- o .:? "database-pool" .!= True appAutoDbMigrate <- o .: "auto-db-migrate" let nonEmptyHost LdapConf{..} = case ldapHost of Ldap.Tls host _ -> not $ null host diff --git a/test/Database.hs b/test/Database.hs index 1317574a8..87f85aa84 100755 --- a/test/Database.hs +++ b/test/Database.hs @@ -48,7 +48,7 @@ main = do [executeQQ|drop owned by current_user|] :: ReaderT SqlBackend _ () DBTruncate -> db' $ do foundation <- getYesod - liftIO . destroyAllResources $ appConnPool foundation + liftIO . destroyAllResources $ appDatabaseConnPool foundation truncateDb DBMigrate -> db' $ return () DBFill -> db' $ fillDb diff --git a/test/TestImport.hs b/test/TestImport.hs index 348cd1c89..3cd9539d4 100644 --- a/test/TestImport.hs +++ b/test/TestImport.hs @@ -78,7 +78,7 @@ runDB query = do liftIO $ runDBWithApp app query runDBWithApp :: MonadIO m => UniWorX -> SqlPersistM a -> m a -runDBWithApp app query = liftIO $ runSqlPersistMPool query (appConnPool app) +runDBWithApp app query = liftIO $ runSqlPersistMPool query (appDatabaseConnPool app) runHandler :: Handler a -> YesodExample UniWorX a runHandler handler = do