feat(db): optionally disable some db connection pooling

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 {..}
+    let
-        -- The UniWorX {..} syntax is an example of record wild cards. For more
+      mkFoundation :: _ -> _ -> (forall backend m a. (MonadUnliftIO m, BackendCompatible backend SqlBackend, MonadLogger m) => ReaderT backend m a -> m a) -> _
-        -- information, see:
+      mkFoundation appSettings' appDatabaseConnPool appDatabaseAccess appSmtpPool appLdapPool appCryptoIDKey appSessionStore appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID appMemcached appUploadCache appVerpSecret appAuthKey = UniWorX {..}
-        -- https://ocharles.org.uk/blog/posts/2014-12-04-record-wildcards.html
+      -- The UniWorX {..} syntax is an example of record wild cards. For more
-        tempFoundation = mkFoundation
+      -- information, see:
-          (error "appSettings' forced in tempFoundation")
+      -- https://ocharles.org.uk/blog/posts/2014-12-04-record-wildcards.html
-          (error "connPool forced in tempFoundation")
+      tempFoundation = mkFoundation
-          (error "smtpPool forced in tempFoundation")
+        (error "appSettings' forced in tempFoundation")
-          (error "ldapPool forced in tempFoundation")
+        (error "databaseConnPool forced in tempFoundation")
-          (error "cryptoIDKey forced in tempFoundation")
+        (error "databaseAccess forced in tempFoundation")
-          (error "sessionStore forced in tempFoundation")
+        (error "smtpPool forced in tempFoundation")
-          (error "secretBoxKey forced in tempFoundation")
+        (error "ldapPool forced in tempFoundation")
-          (error "widgetMemcached forced in tempFoundation")
+        (error "cryptoIDKey forced in tempFoundation")
-          (error "JSONWebKeySet forced in tempFoundation")
+        (error "sessionStore forced in tempFoundation")
-          (error "ClusterID forced in tempFoundation")
+        (error "secretBoxKey forced in tempFoundation")
-          (error "memcached forced in tempFoundation")
+        (error "widgetMemcached forced in tempFoundation")
-          (error "MinioConn forced in tempFoundation")
+        (error "JSONWebKeySet forced in tempFoundation")
-          (error "VerpSecret forced in tempFoundation")
+        (error "ClusterID forced in tempFoundation")
-          (error "AuthKey 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
+              appDatabaseAccess migrateAll
-          | otherwise -> whenM (requiresMigration `runSqlPool` sqlPool) $ do
+          | otherwise -> whenM (appDatabaseAccess requiresMigration) $ do
               $logErrorS "setup" "Migration required"
               liftIO . exitWith $ ExitFailure 130
 
       $logDebugS "setup" "Cluster-Config"
-      appCryptoIDKey <- clusterSetting (Proxy :: Proxy 'ClusterCryptoIDKey) `runSqlPool` sqlPool
+      appCryptoIDKey <- appDatabaseAccess . clusterSetting $ Proxy @'ClusterCryptoIDKey
-      appSecretBoxKey <- clusterSetting (Proxy :: Proxy 'ClusterSecretBoxKey) `runSqlPool` sqlPool
+      appSecretBoxKey <- appDatabaseAccess . clusterSetting $ Proxy @'ClusterSecretBoxKey
-      appJSONWebKeySet <- clusterSetting (Proxy :: Proxy 'ClusterJSONWebKeySet) `runSqlPool` sqlPool
+      appJSONWebKeySet <- appDatabaseAccess . clusterSetting $ Proxy @'ClusterJSONWebKeySet
-      appClusterID <- clusterSetting (Proxy :: Proxy 'ClusterId) `runSqlPool` sqlPool
+      appClusterID <- appDatabaseAccess . clusterSetting $ Proxy @'ClusterId
-      appVerpSecret <- clusterSetting (Proxy :: Proxy 'ClusterVerpSecret) `runSqlPool` sqlPool
+      appVerpSecret <- appDatabaseAccess . clusterSetting $ Proxy @'ClusterVerpSecret
-      appAuthKey <- clusterSetting (Proxy :: Proxy 'ClusterAuthKey) `runSqlPool` sqlPool
+      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

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
+                => (ReaderT backend m a -> m a)
-                -> Pool backend
+                -> 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

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

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

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

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

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