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

Versionbump: Creation of Data.Pool.Pool has changed.

Browse Source
This commit is contained in:
Stephan Barth 2024-02-18 04:51:52 +01:00
parent 38aaed87db
commit 3516335587
3 changed files with 15 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
package.yaml
View File

@ -101,7 +101,7 @@ dependencies:
- network - network
- network-bsd - network-bsd
- unliftio - unliftio
- unliftio-pool - unliftio-pool>=0.4
- mime-mail - mime-mail
- aeson-pretty - aeson-pretty
- resourcet - resourcet
@ -135,7 +135,8 @@ dependencies:
- constraints - constraints
- memory - memory
- pqueue - pqueue
- deepseq - deepseq>=1.5
- resource-pool
- multiset - multiset
- retry - retry
- generic-lens - generic-lens

14
src/Ldap/Client/Pool.hs
View File

@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de> -- SPDX-FileCopyrightText: 2024 Stephan Barth <stephan.barth@uniworx.de>, 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>
-- --
-- SPDX-License-Identifier: AGPL-3.0-or-later -- SPDX-License-Identifier: AGPL-3.0-or-later
@ -23,6 +23,7 @@ import qualified Ldap.Client as Ldap
import UnliftIO.Pool import UnliftIO.Pool
import UnliftIO.Async.Utils import UnliftIO.Async.Utils
import Data.Pool.Internal (PoolConfig(..))
import Control.Monad.Logger import Control.Monad.Logger
import Data.Time.Clock (NominalDiffTime) import Data.Time.Clock (NominalDiffTime)
@ -37,7 +38,6 @@ import Data.Fixed (Nano)
import Network.Connection import Network.Connection
type LdapPool = Pool LdapExecutor type LdapPool = Pool LdapExecutor
data LdapExecutor = LdapExecutor data LdapExecutor = LdapExecutor
{ ldapExec :: forall a m. (Typeable a, MonadUnliftIO m) => (Ldap -> m a) -> m (Either LdapPoolError a) { 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 () atomically . void $ tryPutTMVar ldapDestroy ()
wait ldapAsync wait ldapAsync
withRunInIO $ \runInIO -> 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 where
withTimeout :: forall m' a. (MonadUnliftIO m', MonadThrow m') => m' a -> m' a withTimeout :: forall m' a. (MonadUnliftIO m', MonadThrow m') => m' a -> m' a
withTimeout = maybe (throwM LdapPoolTimeout) return <=< timeout timeoutAct withTimeout = maybe (throwM LdapPoolTimeout) return <=< timeout timeoutAct

2
src/Utils/Failover.hs
View File

@ -33,7 +33,7 @@ import Control.Monad.Trans.Except (ExceptT, runExceptT)
import Control.Monad.State.Strict (runState) import Control.Monad.State.Strict (runState)
import Control.Monad.Logger import Control.Monad.Logger
import Control.Concurrent.STM.TVar (stateTVar) --import Control.Concurrent.STM.TVar (stateTVar)
import Data.Fixed import Data.Fixed