From 471982d24511657acf4868e54e769bf839dc2b82 Mon Sep 17 00:00:00 2001
From: Sarah Vaupel <sarah.vaupel@uniworx.de>
Date: Fri, 26 Jan 2024 23:32:45 +0100
Subject: [PATCH] chore(application): reimplement ldapPool startup

---
 src/Application.hs | 37 ++++++++++++++++++++++++++++---------
 1 file changed, 28 insertions(+), 9 deletions(-)

diff --git a/src/Application.hs b/src/Application.hs
index 1f0499da5..8eb2a1151 100644
--- a/src/Application.hs
+++ b/src/Application.hs
@@ -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 ***"