diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,9 @@ +# 0.6.0.0 + +* Upgrade to support [`reasource-pool`](https://github.com/scrive/pool) from the new maintainer. +* `acquireWith` no longer accepts the stripes number, due to semantic changes in `resource-pool`. + + # 0.5.4.1 * Upgrade to support breaking changes of `hasql-1.6.3`. No breaking changes introduced to the library. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -3,7 +3,7 @@ This is a fork of [hasql-pool](https://github.com/nikita-volkov/hasql-pool) that continues using [resource-pool](https://hackage.haskell.org/package/resource-pool) for -the underlying pool implementation. +its underlying pool implementation. The fork is based on [0.5.2.2 release](https://hackage.haskell.org/package/hasql-pool) (as the latest original implementation based on `resource-pool`), and it includes the following API and layout changes: @@ -13,4 +13,5 @@ such as [AWS RDS IAM tokens](https://docs.aws.amazon.com/AmazonRDS/latest/UserGuide/UsingWithRDS.IAMDBAuth.html). * Pool interface allows for specifying IO observer actions. These actions are useful for collecting and tracking various pool metrics with tools like [Prometheus](https://prometheus.io/docs/introduction/overview/). +* Decision making on the size of the stripes is delegated to the upgraded `resource-pool` (which has slightly different semantics compared to v0.2.x). * No reliance on Stack tooling. diff --git a/hasql-resource-pool.cabal b/hasql-resource-pool.cabal --- a/hasql-resource-pool.cabal +++ b/hasql-resource-pool.cabal @@ -1,8 +1,8 @@ name: hasql-resource-pool -version: 0.5.4.1 +version: 0.6.0.0 category: Hasql, Database, PostgreSQL synopsis: A pool of connections for Hasql based on resource-pool. -description: This package is derived from hasql-pool v0.5.2.2 and continues using resource-pool for an underlying pool implementation. +description: This package is originally derived from hasql-pool v0.5.2.2 and continues using `resource-pool` for its pool implementation. homepage: https://github.com/avanov/hasql-resource-pool bug-reports: https://github.com/avanov/hasql-resource-pool/issues author: Nikita Volkov @@ -29,15 +29,14 @@ Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples default-language: Haskell2010 - other-modules: - Hasql.Pool.Prelude - Hasql.Pool.ResourcePool exposed-modules: Hasql.Pool Hasql.Pool.Observer + other-modules: + Hasql.Pool.Prelude build-depends: -- resources: - resource-pool-fork-avanov, + resource-pool >= 0.4.0.0, -- database: hasql >= 1.6.3, -- data: diff --git a/library/Hasql/Pool.hs b/library/Hasql/Pool.hs --- a/library/Hasql/Pool.hs +++ b/library/Hasql/Pool.hs @@ -1,31 +1,27 @@ -{-| This module represents an extension to 'hasql-pool', it allows for a mix of dynamic credentials - and static settings for connections in a pool. - Due to the fact that the module tries to extend 'hasql-pool' rather than rewrite it, the exposed API relies on - combining existing 'hasql' types with new types, whereas a rewrite would just extend the original types. - It is done so to simplify maintenance of the extended functionality and make it more compatible with any - future development of 'hasql-pool'. --} module Hasql.Pool ( Pool , Settings(..) , UsageError(..) , ConnectionGetter +, Stats(..) +, stats +, getPoolUsageStat , acquire , acquireWith , release , use , useWithObserver -, getPoolUsageStat +, withResourceOnEither ) where import qualified Data.Pool as ResourcePool +import qualified Data.Pool.Internal as Unstable import System.Clock (Clock(Monotonic), diffTimeSpec, getTime, toNanoSecs) import Hasql.Pool.Prelude import qualified Hasql.Connection import qualified Hasql.Session -import qualified Hasql.Pool.ResourcePool as ResourcePool import Hasql.Pool.Observer (Observed(..), ObserverAction) @@ -33,9 +29,9 @@ -- A pool of open DB connections. newtype Pool = Pool (ResourcePool.Pool (Either Hasql.Connection.ConnectionError Hasql.Connection.Connection)) - deriving (Show) + type PoolSize = Int type PoolStripes = Int type ResidenceTimeout = NominalDiffTime @@ -64,24 +60,30 @@ -- create a connection-pool. acquire :: Settings -> IO Pool acquire settings@(_size, _timeout, connectionSettings) = - acquireWith stripes (Hasql.Connection.acquire connectionSettings) settings - where - stripes = 1 + acquireWith (Hasql.Connection.acquire connectionSettings) settings -- | -- Similar to 'acquire', allows for finer configuration. -acquireWith :: PoolStripes - -> ConnectionGetter +acquireWith :: ConnectionGetter -> Settings -> IO Pool -acquireWith stripes connGetter (size, timeout, connectionSettings) = - fmap Pool $ - ResourcePool.createPool connGetter release stripes timeout size +acquireWith connGetter (maxSize, timeout, connectionSettings) = + fmap Pool $ createPool connGetter release timeout maxSize where release = either (const (pure ())) Hasql.Connection.release +createPool :: IO a + -> (a -> IO ()) + -> NominalDiffTime + -> Int + -> IO (ResourcePool.Pool a) +createPool create free idleTime maxResources = ResourcePool.newPool cfg where + -- defaultPoolConfig create free cacheTTL maxResources = PoolConfig + cfg = ResourcePool.defaultPoolConfig create free (realToFrac idleTime) maxResources + + -- | -- Release the connection-pool by closing and removing all connections. release :: Pool -> IO () @@ -110,7 +112,7 @@ -> IO (Either UsageError a) useWithObserver observer (Pool pool) session = fmap (either (Left . ConnectionError) (either (Left . SessionError) Right)) $ - ResourcePool.withResourceOnEither pool $ + withResourceOnEither pool $ traverse runQuery where runQuery dbConn = maybe action (runWithObserver action) observer @@ -128,12 +130,48 @@ doObserve observed >> pure result -getPoolStats :: Pool -> IO ResourcePool.Stats -getPoolStats (Pool p) = ResourcePool.stats p performStatsReset - where - performStatsReset = False +withResourceOnEither :: ResourcePool.Pool resource + -> (resource -> IO (Either failure success)) + -> IO (Either failure success) +withResourceOnEither pool act = mask_ $ do + (resource, localPool) <- ResourcePool.takeResource pool + failureOrSuccess <- act resource `onException` ResourcePool.destroyResource pool localPool resource + case failureOrSuccess of + Right success -> do + ResourcePool.putResource localPool resource + pure $ Right success + Left failure -> do + ResourcePool.destroyResource pool localPool resource + pure $ Left failure +data Stats = Stats + { currentUsage :: !Int + -- ^ Current number of items. + , available :: !Int + -- ^ Total items available for consumption. + } deriving Show + + +stats :: Pool -> IO Stats +stats (Pool pool) = currentlyAvailablePerStripe >>= collect where + -- attributes extraction and counting + collect xs = pure $ Stats inUse avail where + inUse = maxResources - avail + avail = sum xs + + currentlyAvailablePerStripe = traverse id peekAvailable + peekAvailable = (fmap stripeAvailability) <$> allStripes -- array of IO Int + stripeAvailability ms = maybe quotaPerStripe Unstable.available ms -- if the stripe ref is uninitialised, count the default availability + allStripes = peekStripe <$> Unstable.localPools pool -- array of IO Maybe + peekStripe = tryReadMVar . Unstable.stripeVar + + -- data from the pool + quotaPerStripe = maxResources `quotCeil` numStripes + numStripes = length $ Unstable.localPools pool -- can be 'sizeofSmallArray' but requires 'primitive' as dependency + maxResources = Unstable.poolMaxResources . Unstable.poolConfig $ pool + quotCeil x y = let (z, r) = x `quotRem` y in if r == 0 then z else z + 1 -- copied from 'Data.Pool.Internal' + + getPoolUsageStat :: Pool -> IO PoolSize -getPoolUsageStat pool = getPoolStats pool >>= gather where - gather = pure . ResourcePool.currentUsage . ResourcePool.poolStats +getPoolUsageStat pool = stats pool >>= (pure . currentUsage) diff --git a/library/Hasql/Pool/ResourcePool.hs b/library/Hasql/Pool/ResourcePool.hs deleted file mode 100644 --- a/library/Hasql/Pool/ResourcePool.hs +++ /dev/null @@ -1,25 +0,0 @@ -{-| -Extras for the resource-pool library. --} -module Hasql.Pool.ResourcePool -( withResourceOnEither -) -where - -import Hasql.Pool.Prelude -import Data.Pool - - -withResourceOnEither :: Pool resource - -> (resource -> IO (Either failure success)) - -> IO (Either failure success) -withResourceOnEither pool act = mask_ $ do - (resource, localPool) <- takeResource pool - failureOrSuccess <- act resource `onException` destroyResource pool localPool resource - case failureOrSuccess of - Right success -> do - putResource localPool resource - pure $ Right success - Left failure -> do - destroyResource pool localPool resource - pure $ Left failure