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): fix ldapPool setup

Browse Source
This commit is contained in:
Sarah Vaupel 2024-01-30 21:54:46 +01:00
parent dfa774f655
commit d9ed893b52
1 changed files with 8 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
src/Application.hs
View File

@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2023 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,David Mosbach <david.mosbach@uniworx.de> -- SPDX-FileCopyrightText: 2023-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, Gregor Kleen <gregor.kleen@ifi.lmu.de>, Sarah Vaupel <sarah.vaupel@ifi.lmu.de>, Sarah Vaupel <vaupel.sarah@campus.lmu.de>, Steffen Jost <jost@tcs.ifi.lmu.de>, David Mosbach <david.mosbach@uniworx.de>
-- --
-- SPDX-License-Identifier: AGPL-3.0-or-later -- SPDX-License-Identifier: AGPL-3.0-or-later
@ -107,7 +107,7 @@ import Handler.Utils.Routes (classifyHandler)
import qualified Data.Acid.Memory as Acid import qualified Data.Acid.Memory as Acid
import qualified Web.ServerSession.Backend.Acid as Acid import qualified Web.ServerSession.Backend.Acid as Acid
-- import qualified Ldap.Client as Ldap (Host(Plain, Tls)) import qualified Ldap.Client as Ldap (Host(Plain, Tls))
import qualified Network.Minio as Minio import qualified Network.Minio as Minio
@ -241,7 +241,7 @@ 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 appUserDbPool appCryptoIDKey appSessionStore appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID appMemcached appMemcachedLocal appUploadCache appVerpSecret appAuthKey appAuthPlugins appPersonalisedSheetFilesSeedKey appVolatileClusterSettingsCache appAvsQuery = UniWorX{..} mkFoundation appSettings' appConnPool appSmtpPool appLdapPool 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")
@ -313,17 +313,17 @@ makeFoundation appSettings''@AppSettings{..} = do
-- forM_ ldapPool $ registerFailoverMetrics "ldap" -- forM_ ldapPool $ registerFailoverMetrics "ldap"
-- TODO: reintroduce failover once UserDbFailover is implemented (see above) -- TODO: reintroduce failover once UserDbFailover is implemented (see above)
ldapPool <- forOf (traverse . traverse) appLdapPoolConf $ \RessourcePoolConf{..} -> if ldapPool <- fmap join . forM appLdapPoolConf $ \ResourcePoolConf{..} -> if
| UserSourceConfSingleSource{..} <- appUserSourceConf | UserSourceConfSingleSource{..} <- appUserSourceConf
, UserSourceLdap LdapConf{..} <- usersrcSingleSource , UserSourceLdap conf@LdapConf{..} <- usersrcSingleSource
-> do -- set up a singleton ldap pool with no failover -> do -- set up a singleton ldap pool with no failover
let ldapLabel = case ldapHost of let ldapLabel = case ldapHost of
Ldap.Plain str -> pack str <> ":" <> tshow ldapPort Ldap.Plain str -> pack str <> ":" <> tshow ldapPort
Ldap.Tls str _ -> pack str <> ":" <> tshow ldapPort Ldap.Tls str _ -> pack str <> ":" <> tshow ldapPort
$logDebugS "setup" $ "LDAP-Pool " <> ldapLabel $logDebugS "setup" $ "LDAP-Pool " <> ldapLabel
(ldapLabel,) . (conf,) <$> createLdapPool ldapHost ldapPort poolStripes poolTimeout ldapTimeout poolLimit Just . (conf,) <$> createLdapPool ldapHost ldapPort poolStripes poolTimeout ldapTimeout poolLimit
| otherwise -- No LDAP pool to be initialized | otherwise -- No LDAP pool to be initialized
-> return mempty -> return Nothing
-- Perform database migration using our application's logging settings. -- Perform database migration using our application's logging settings.
flip runReaderT tempFoundation $ flip runReaderT tempFoundation $
@ -778,7 +778,7 @@ shutdownApp app = do
liftIO $ do liftIO $ do
Custom.purgePool $ appConnPool app Custom.purgePool $ appConnPool app
for_ (appSmtpPool app) destroyAllResources for_ (appSmtpPool app) destroyAllResources
for_ (appLdapPool app) . mapFailover $ views _2 destroyAllResources for_ (appLdapPool app) $ views _2 destroyAllResources
for_ (appWidgetMemcached app) Memcached.close for_ (appWidgetMemcached app) Memcached.close
for_ (appMemcached app) $ views _memcachedConn Memcached.close for_ (appMemcached app) $ views _memcachedConn Memcached.close
release . fst $ appLogger app release . fst $ appLogger app