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. -- from there, and then create the real foundation.
let let
mkFoundation :: _ -> (forall m. MonadIO m => Custom.Pool' m DBConnLabel DBConnUseState SqlBackend) -> _ 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 tempFoundation = mkFoundation
(error "appSettings' forced in tempFoundation") (error "appSettings' forced in tempFoundation")
(error "connPool forced in tempFoundation") (error "connPool forced in tempFoundation")
(error "smtpPool forced in tempFoundation") (error "smtpPool forced in tempFoundation")
(error "ldapPool forced in tempFoundation") (error "userdbPool forced in tempFoundation")
(error "cryptoIDKey forced in tempFoundation") (error "cryptoIDKey forced in tempFoundation")
(error "sessionStore forced in tempFoundation") (error "sessionStore forced in tempFoundation")
(error "secretBoxKey forced in tempFoundation") (error "secretBoxKey forced in tempFoundation")
@ -298,14 +298,33 @@ makeFoundation appSettings''@AppSettings{..} = do
sqlPool = Custom.hoistPool (liftIO . flip runLoggingT logFunc) sqlPool' sqlPool = Custom.hoistPool (liftIO . flip runLoggingT logFunc) sqlPool'
void . Prometheus.register . poolMetrics PoolDatabaseConnections $ sqlPool @IO void . Prometheus.register . poolMetrics PoolDatabaseConnections $ sqlPool @IO
-- ldapPool <- traverse mkFailoverLabeled <=< forOf (traverse . traverse) appLdapConf $ \conf@LdapConf{..} -> do -- ldapPool <- traverse mkFailoverLabeled <=< forOf (traverse . traverse) appUserDbConf $ \conf -> if
-- let ldapLabel = case ldapHost of -- | UserDbSingleSource{..} <- conf
-- Ldap.Plain str -> pack str <> ":" <> tshow ldapPort -- , UserDbLdap LdapConf{..} <- userdbSingleSource
-- Ldap.Tls str _ -> pack str <> ":" <> tshow ldapPort -- , Just ResourcePoolConf{..} <- userdbPoolConf
-- $logDebugS "setup" $ "LDAP-Pool " <> ldapLabel -- -> do
-- (ldapLabel,) . (conf,) <$> createLdapPool ldapHost ldapPort (poolStripes ldapPool) (poolTimeout ldapPool) ldapTimeout (poolLimit ldapPool) -- 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" -- 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. -- Perform database migration using our application's logging settings.
flip runReaderT tempFoundation $ flip runReaderT tempFoundation $
if if
@ -402,7 +421,7 @@ makeFoundation appSettings''@AppSettings{..} = do
$logDebugS "Runtime configuration" $ tshowCrop appSettings' $logDebugS "Runtime configuration" $ tshowCrop appSettings'
-- TODO: reimplement user db failover -- 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 -- Return the foundation
$logInfoS "setup" "*** DONE ***" $logInfoS "setup" "*** DONE ***"