diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,6 @@ +# 0.5.3 + +Initial release as a new package. The implementation is based on `hasql-pool` v0.5.2.2 +and continues using `resource-pool` v0.2.x +(actually, a [fork with important performance and stats changes applied](https://github.com/bos/pool/pull/43)). +The long-term plan is to make a switch to a [newer v0.3.x maintained by scrive](https://github.com/bos/pool/pull/43). diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,22 @@ +Copyright (c) 2015, Nikita Volkov + +Permission is hereby granted, free of charge, to any person +obtaining a copy of this software and associated documentation +files (the "Software"), to deal in the Software without +restriction, including without limitation the rights to use, +copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the +Software is furnished to do so, subject to the following +conditions: + +The above copyright notice and this permission notice shall be +included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES +OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT +HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, +WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR +OTHER DEALINGS IN THE SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,16 @@ +hasql-resource-pool +=================== + +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. + +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: + +* Connections are based on settings with IO actions. + This change to the API makes the library usable with the custom authentication methods + 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/). +* No reliance on Stack tooling. diff --git a/hasql-resource-pool.cabal b/hasql-resource-pool.cabal new file mode 100644 --- /dev/null +++ b/hasql-resource-pool.cabal @@ -0,0 +1,80 @@ +name: + hasql-resource-pool +version: + 0.5.3.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. +homepage: + https://github.com/avanov/hasql-resource-pool +bug-reports: + https://github.com/avanov/hasql-resource-pool/issues +author: + Nikita Volkov +maintainer: + Maxim Avanov +copyright: + (c) 2022, Maxim Avanov +license: + MIT +license-file: + LICENSE +build-type: + Simple +cabal-version: + >=1.10 +extra-source-files: + CHANGELOG.md + README.md + +source-repository head + type: + git + location: + git://github.com/avanov/hasql-resource-pool.git + + +library + hs-source-dirs: + library + ghc-options: + default-extensions: + 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.Observer + Hasql.Pool.Prelude + Hasql.Pool.ResourcePool + exposed-modules: + Hasql.Pool + build-depends: + -- resources: + resource-pool-fork-avanov, + -- database: + hasql >= 1.3 && < 1.6, + -- data: + time >= 1.5 && < 2, + clock >= 0.8, + -- general: + base-prelude >= 1 && < 2 + +test-suite test + type: + exitcode-stdio-1.0 + hs-source-dirs: + test + main-is: + Main.hs + default-extensions: + 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 + build-depends: + base-prelude, + hasql, + hasql-pool, + hspec >= 2.6 && < 3 diff --git a/library/Hasql/Pool.hs b/library/Hasql/Pool.hs new file mode 100644 --- /dev/null +++ b/library/Hasql/Pool.hs @@ -0,0 +1,123 @@ +module Hasql.Pool +( Pool +, Settings(..) +, UsageError(..) +, acquire +, acquireWithStripes +, release +, use +, useWithObserver +, getPoolUsageStat +) +where + +import qualified Data.Pool as ResourcePool +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) + + +-- | +-- A pool of connections to DB. +newtype Pool = + Pool (ResourcePool.Pool (Either Hasql.Connection.ConnectionError Hasql.Connection.Connection)) + deriving (Show) + + +type PoolSize = Int +type PoolStripes = Int +type ResidenceTimeout = NominalDiffTime + +-- | +-- Settings of the connection pool. Consist of: +-- +-- * Pool-size. +-- +-- * Timeout. +-- An amount of time for which an unused resource is kept open. +-- The smallest acceptable value is 0.5 seconds. +-- +-- * Connection settings. +-- +type Settings = + (PoolSize, ResidenceTimeout, Hasql.Connection.Settings) + +-- | +-- Given the pool-size, timeout and connection settings +-- create a connection-pool. +acquire :: Settings -> IO Pool +acquire = + acquireWithStripes stripes + where + stripes = 1 + + +acquireWithStripes :: PoolStripes + -> Settings + -> IO Pool +acquireWithStripes stripes (size, timeout, connectionSettings) = + fmap Pool $ + ResourcePool.createPool acquire release stripes timeout size + where + acquire = Hasql.Connection.acquire connectionSettings + release = either (const (pure ())) Hasql.Connection.release + + +-- | +-- Release the connection-pool. +release :: Pool -> IO () +release (Pool pool) = + ResourcePool.destroyAllResources pool + + +-- | +-- A union over the connection establishment error and the session error. +data UsageError + = ConnectionError Hasql.Connection.ConnectionError + | SessionError Hasql.Session.QueryError + deriving (Show, Eq) + +-- | +-- Use a connection from the pool to run a session and +-- return the connection to the pool, when finished. +use :: Pool -> Hasql.Session.Session a -> IO (Either UsageError a) +use = useWithObserver Nothing + +-- | +-- Same as 'use' but allows for a custom observer action. You can use it for gathering latency metrics. +useWithObserver :: Maybe ObserverAction + -> Pool + -> Hasql.Session.Session a + -> IO (Either UsageError a) +useWithObserver observer (Pool pool) session = + fmap (either (Left . ConnectionError) (either (Left . SessionError) Right)) $ + ResourcePool.withResourceOnEither pool $ + traverse runQuery + where + runQuery dbConn = maybe action (runWithObserver action) observer + where + action = Hasql.Session.run session dbConn + + runWithObserver action doObserve = do + let measure = getTime Monotonic + start <- measure + result <- action + end <- measure + let nsRatio = 1000000000 + observed = Observed { latency = toRational (toNanoSecs (end `diffTimeSpec` start) % nsRatio) + } + doObserve observed >> pure result + + +getPoolStats :: Pool -> IO ResourcePool.Stats +getPoolStats (Pool p) = ResourcePool.stats p performStatsReset where + performStatsReset = False + + +getPoolUsageStat :: Pool -> IO PoolSize +getPoolUsageStat pool = getPoolStats pool >>= gather where + gather = pure . ResourcePool.currentUsage . ResourcePool.poolStats diff --git a/library/Hasql/Pool/Observer.hs b/library/Hasql/Pool/Observer.hs new file mode 100644 --- /dev/null +++ b/library/Hasql/Pool/Observer.hs @@ -0,0 +1,17 @@ +module Hasql.Pool.Observer +( Observed(..) +, ObserverAction +) +where + +import Hasql.Pool.Prelude + + +-- | Represents properties of an observed IO action associated with a pool item +newtype Observed = Observed + { latency :: Rational + } deriving (Show) + + +type ObserverAction = Observed -> IO () + diff --git a/library/Hasql/Pool/Prelude.hs b/library/Hasql/Pool/Prelude.hs new file mode 100644 --- /dev/null +++ b/library/Hasql/Pool/Prelude.hs @@ -0,0 +1,14 @@ +module Hasql.Pool.Prelude +( + module Exports, +) +where + + +-- base-prelude +------------------------- +import BasePrelude as Exports hiding (assert, left, right, isLeft, isRight, error) + +-- time +------------------------- +import Data.Time as Exports diff --git a/library/Hasql/Pool/ResourcePool.hs b/library/Hasql/Pool/ResourcePool.hs new file mode 100644 --- /dev/null +++ b/library/Hasql/Pool/ResourcePool.hs @@ -0,0 +1,21 @@ +{-| +Extras for the resource-pool library. +-} +module Hasql.Pool.ResourcePool +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 + return (Right success) + Left failure -> do + destroyResource pool localPool resource + return (Left failure) diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,29 @@ +module Main where + +import BasePrelude +import Test.Hspec +import Hasql.Pool +import qualified Hasql.Connection as Connection +import qualified Hasql.Decoders as Decoders +import qualified Hasql.Encoders as Encoders +import qualified Hasql.Session as Session +import qualified Hasql.Statement as Statement + + +main = hspec $ do + describe "Hasql.Pool.use" $ do + it "releases a spot in the pool when there is an error" $ do + pool <- acquire (1, 1, "host=localhost port=5432 user=postgres dbname=postgres") + let + statement = Statement.Statement "" Encoders.noParams Decoders.noResult True + session = Session.statement () statement + in do + use pool session `shouldNotReturn` (Right ()) + let + session = let + statement = let + decoder = Decoders.singleRow (Decoders.column (Decoders.nonNullable Decoders.int8)) + in Statement.Statement "SELECT 1" Encoders.noParams decoder True + in Session.statement () statement + in do + use pool session `shouldReturn` (Right 1)