hasql-resource-pool 0.5.4.1 → 0.6.0.0

raw patch · 5 files changed

+76/−57 lines, 5 filesdep +resource-pooldep −resource-pool-fork-avanovPVP ok

version bump matches the API change (PVP)

Dependencies added: resource-pool

Dependencies removed: resource-pool-fork-avanov

API changes (from Hackage documentation)

Files

• CHANGELOG.md +6/−0
• README.md +2/−1
• hasql-resource-pool.cabal +5/−6
• library/Hasql/Pool.hs +63/−25
• library/Hasql/Pool/ResourcePool.hs +0/−25

@@ -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.

@@ -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.

@@ -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 <nikita.y.volkov@mail.ru>@@ -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:

@@ -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)

@@ -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