diff --git a/package.yaml b/package.yaml index 98d6707aa..f340b2806 100644 --- a/package.yaml +++ b/package.yaml @@ -101,7 +101,7 @@ dependencies: - network - network-bsd - unliftio - - unliftio-pool + - unliftio-pool>=0.4 - mime-mail - aeson-pretty - resourcet @@ -135,7 +135,8 @@ dependencies: - constraints - memory - pqueue - - deepseq + - deepseq>=1.5 + - resource-pool - multiset - retry - generic-lens diff --git a/src/Ldap/Client/Pool.hs b/src/Ldap/Client/Pool.hs index 47eb4147c..1c9526199 100644 --- a/src/Ldap/Client/Pool.hs +++ b/src/Ldap/Client/Pool.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen +-- SPDX-FileCopyrightText: 2024 Stephan Barth , 2022 Gregor Kleen -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -23,6 +23,7 @@ import qualified Ldap.Client as Ldap import UnliftIO.Pool import UnliftIO.Async.Utils +import Data.Pool.Internal (PoolConfig(..)) import Control.Monad.Logger import Data.Time.Clock (NominalDiffTime) @@ -37,7 +38,6 @@ import Data.Fixed (Nano) import Network.Connection - type LdapPool = Pool LdapExecutor data LdapExecutor = LdapExecutor { ldapExec :: forall a m. (Typeable a, MonadUnliftIO m) => (Ldap -> m a) -> m (Either LdapPoolError a) @@ -143,7 +143,15 @@ createLdapPool host port stripes timeoutConn (round . (* 1e6) -> timeoutAct) lim atomically . void $ tryPutTMVar ldapDestroy () wait ldapAsync withRunInIO $ \runInIO -> - createPool (runInIO mkExecutor) delExecutor stripes timeoutConn limit + -- pool configuration has changed on a newer version; it only supports 1 ressource per stripe now and hence only takes 1 parameter; multiply of the old parameters to get the same behaviour + --createPool (runInIO mkExecutor) delExecutor stripes timeoutConn limit + newPool (PoolConfig + { createResource = runInIO mkExecutor + , freeResource = delExecutor + , poolCacheTTL = realToFrac timeoutConn + , poolMaxResources = stripes * limit + , poolNumStripes = Nothing + }) where withTimeout :: forall m' a. (MonadUnliftIO m', MonadThrow m') => m' a -> m' a withTimeout = maybe (throwM LdapPoolTimeout) return <=< timeout timeoutAct diff --git a/src/Utils/Failover.hs b/src/Utils/Failover.hs index 26b695471..73a10d91a 100644 --- a/src/Utils/Failover.hs +++ b/src/Utils/Failover.hs @@ -33,7 +33,7 @@ import Control.Monad.Trans.Except (ExceptT, runExceptT) import Control.Monad.State.Strict (runState) import Control.Monad.Logger -import Control.Concurrent.STM.TVar (stateTVar) +--import Control.Concurrent.STM.TVar (stateTVar) import Data.Fixed