fraport/fradrive-old
fraport/fradrive-old
Archived
3
1
Fork 0
Code Issues 65 Pull Requests 5 Actions Packages Projects Releases 197 Wiki Activity

chore(application): reimplement ldapPool startup

Browse Source
This commit is contained in:
Sarah Vaupel 2024-01-26 23:32:45 +01:00
parent 3eec9ef8df
commit 471982d245
1 changed files with 28 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

37
src/Application.hs
View File

@ -241,12 +241,12 @@ makeFoundation appSettings''@AppSettings{..} = do
-- from there, and then create the real foundation.
let
mkFoundation :: _ -> (forall m. MonadIO m => Custom.Pool' m DBConnLabel DBConnUseState SqlBackend) -> _
mkFoundation appSettings' appConnPool appSmtpPool appLdapPool appCryptoIDKey appSessionStore appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID appMemcached appMemcachedLocal appUploadCache appVerpSecret appAuthKey appAuthPlugins appPersonalisedSheetFilesSeedKey appVolatileClusterSettingsCache appAvsQuery = UniWorX{..}
mkFoundation appSettings' appConnPool appSmtpPool appUserDbPool appCryptoIDKey appSessionStore appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID appMemcached appMemcachedLocal appUploadCache appVerpSecret appAuthKey appAuthPlugins appPersonalisedSheetFilesSeedKey appVolatileClusterSettingsCache appAvsQuery = UniWorX{..}
tempFoundation = mkFoundation
(error "appSettings' forced in tempFoundation")
(error "connPool forced in tempFoundation")
(error "smtpPool forced in tempFoundation")
(error "ldapPool forced in tempFoundation")
(error "userdbPool forced in tempFoundation")
(error "cryptoIDKey forced in tempFoundation")
(error "sessionStore forced in tempFoundation")
(error "secretBoxKey forced in tempFoundation")
@ -298,14 +298,33 @@ makeFoundation appSettings''@AppSettings{..} = do
sqlPool = Custom.hoistPool (liftIO . flip runLoggingT logFunc) sqlPool'
void . Prometheus.register . poolMetrics PoolDatabaseConnections $ sqlPool @IO
-- ldapPool <- traverse mkFailoverLabeled <=< forOf (traverse . traverse) appLdapConf $ \conf@LdapConf{..} -> do
-- let ldapLabel = case ldapHost of
-- Ldap.Plain str -> pack str <> ":" <> tshow ldapPort
-- Ldap.Tls str _ -> pack str <> ":" <> tshow ldapPort
-- $logDebugS "setup" $ "LDAP-Pool " <> ldapLabel
-- (ldapLabel,) . (conf,) <$> createLdapPool ldapHost ldapPort (poolStripes ldapPool) (poolTimeout ldapPool) ldapTimeout (poolLimit ldapPool)
-- ldapPool <- traverse mkFailoverLabeled <=< forOf (traverse . traverse) appUserDbConf $ \conf -> if
-- | UserDbSingleSource{..} <- conf
-- , UserDbLdap LdapConf{..} <- userdbSingleSource
-- , Just ResourcePoolConf{..} <- userdbPoolConf
-- -> do
-- let ldapLabel = case ldapHost of
-- Ldap.Plain str -> pack str <> ":" <> tshow ldapPort
-- Ldap.Tls str _ -> pack str <> ":" <> tshow ldapPort
-- $logDebugS "setup" $ "LDAP-Pool " <> ldapLabel
-- (ldapLabel,) . (conf,) <$> createLdapPool ldapHost ldapPort poolStripes poolTimeout ldapTimeout poolLimit
-- | otherwise
-- -> return mempty
-- forM_ ldapPool $ registerFailoverMetrics "ldap"
-- TODO: reintroduce failover once UserDbFailover is implemented (see above)
ldapPool <- forOf (traverse . traverse) appLdapPoolConf $ \RessourcePoolConf{..} -> if
| UserDbSingleSource{..} <- appUserDbConf
, UserDbLdap LdapConf{..} <- userdbSingleSource
-> do -- set up a singleton ldap pool with no failover
let ldapLabel = case ldapHost of
Ldap.Plain str -> pack str <> ":" <> tshow ldapPort
Ldap.Tls str _ -> pack str <> ":" <> tshow ldapPort
$logDebugS "setup" $ "LDAP-Pool " <> ldapLabel
(ldapLabel,) . (conf,) <$> createLdapPool ldapHost ldapPort poolStripes poolTimeout ldapTimeout poolLimit
| otherwise -- No LDAP pool to be initialized
-> return mempty
-- Perform database migration using our application's logging settings.
flip runReaderT tempFoundation $
if
@ -402,7 +421,7 @@ makeFoundation appSettings''@AppSettings{..} = do
$logDebugS "Runtime configuration" $ tshowCrop appSettings'
-- TODO: reimplement user db failover
let foundation = mkFoundation appSettings' sqlPool smtpPool Nothing appCryptoIDKey appSessionStore appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID appMemcached appMemcachedLocal appUploadCache appVerpSecret appAuthKey appAuthPlugins appPersonalisedSheetFilesSeedKey appVolatileClusterSettingsCache appAvsQuery
let foundation = mkFoundation appSettings' sqlPool smtpPool userdbPool appCryptoIDKey appSessionStore appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID appMemcached appMemcachedLocal appUploadCache appVerpSecret appAuthKey appAuthPlugins appPersonalisedSheetFilesSeedKey appVolatileClusterSettingsCache appAvsQuery
-- Return the foundation
$logInfoS "setup" "*** DONE ***"