feat(db): optionally disable some db connection pooling

2021-02-21 20:44:45 +01:00 · 2021-02-21 20:44:45 +01:00 · 35ac503bf9
commit 35ac503bf9
parent e4f10ec1f3
7 changed files with 60 additions and 48 deletions
--- 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
--- 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
--- 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
--- 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
--- 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
--- 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
--- 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