diff --git a/CHANGELOG.md b/CHANGELOG.md index 1ac038e..fb1d8f8 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,7 +1,18 @@ -# Unreleased (PostgREST fork) +# 0.8.0.2 -Added support for timing out resource acquisition ([PR #](https://github.com/PostgREST/hasql-pool/pull/3)). -Added support for flushing the pool without destroying it ([PR #2](https://github.com/PostgREST/hasql-pool/pull/2)). +Fixed Windows build. + +# 0.8 + +`release` became reusable. You can use it to destroy the whole pool (same as before), but now also you can use it to reset the connections. + +Acquisition timeout added. + +Breaking changes in API: + +- Removed `PoolIsReleasedUsageError` +- `acquire` extended with the acquisition timeout parameter +- `acquireDynamically` extended with the acquisition timeout parameter # 0.7.2 diff --git a/build.bash b/build.bash deleted file mode 100755 index 6d6e68b..0000000 --- a/build.bash +++ /dev/null @@ -1,50 +0,0 @@ -#!/bin/bash -set -eo pipefail - -function format { - ormolu --mode inplace -ce \ - $(find . -name "*.hs" \ - -not -path "./.git/*" \ - -not -path "./*.stack-work/*" \ - -not -path "./samples/*" \ - -not -path "./sketches/*" \ - -not -path "./output/*" \ - -not -path "./ideas/*" \ - -not -path "./refs/*" \ - -not -path "./temp/*") -} - -function build_and_test { - stack build \ - --fast --test \ - --ghc-options "-j +RTS -A128m -n2m -RTS -fwarn-incomplete-patterns" -} - -function build_and_test_by_pattern { - stack build \ - --fast --test \ - --ghc-options "-j +RTS -A128m -n2m -RTS -fwarn-incomplete-patterns" \ - --ta "-p \"$1\"" -} - -function build { - stack build \ - --ghc-options "-j +RTS -A128m -n2m -RTS -fwarn-incomplete-patterns" \ - --fast -} - -function build_failing_on_incomplete_patterns { - stack build \ - --ghc-options "-j +RTS -A128m -n2m -RTS -Werror=incomplete-patterns" \ - --fast -} - -function install { - stack \ - --work-dir ".install.stack-work" \ - install \ - --ghc-options "-j +RTS -A128m -n2m -RTS" -} - -format -build_and_test diff --git a/hasql-pool.cabal b/hasql-pool.cabal index 6abb8f7..8bed580 100644 --- a/hasql-pool.cabal +++ b/hasql-pool.cabal @@ -1,76 +1,53 @@ -name: - hasql-pool -version: - 0.7.2 -category: - Hasql, Database, PostgreSQL -synopsis: - A pool of connections for Hasql -homepage: - https://github.com/nikita-volkov/hasql-pool -bug-reports: - https://github.com/nikita-volkov/hasql-pool/issues -author: - Nikita Volkov -maintainer: - Nikita Volkov -copyright: - (c) 2015, Nikita Volkov -license: - MIT -license-file: - LICENSE -build-type: - Simple -cabal-version: - >=1.10 -extra-source-files: - CHANGELOG.md +cabal-version: 3.0 +name: hasql-pool +version: 0.8.0.2 + +category: Hasql, Database, PostgreSQL +synopsis: Pool of connections for Hasql +homepage: https://github.com/nikita-volkov/hasql-pool +bug-reports: https://github.com/nikita-volkov/hasql-pool/issues +author: Nikita Volkov +maintainer: Nikita Volkov +copyright: (c) 2015, Nikita Volkov +license: MIT +license-file: LICENSE +extra-source-files: CHANGELOG.md source-repository head - type: - git - location: - git://github.com/nikita-volkov/hasql-pool.git + type: git + location: git://github.com/nikita-volkov/hasql-pool.git +common base-settings + default-extensions: BangPatterns, BlockArguments, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DerivingVia, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, InstanceSigs, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, StrictData, TemplateHaskell, TupleSections, TypeApplications, TypeFamilies, TypeOperators, UnboxedTuples + default-language: Haskell2010 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 + import: base-settings + hs-source-dirs: library exposed-modules: Hasql.Pool other-modules: Hasql.Pool.Prelude + Hasql.Pool.TimeExtras.IO + Hasql.Pool.TimeExtras.Conversions build-depends: base >=4.11 && <5, - hasql >=1.3 && <1.6, + hasql >=1.6.0.1 && <1.7, stm >=2.5 && <3, time >=1.5 && <2, - transformers >=0.5 && <0.7 - + transformers >=0.5 && <0.7, 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 + import: base-settings + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs ghc-options: -threaded build-depends: + async >=2.2 && <3, hasql, hasql-pool, - async, hspec >=2.6 && <3, rerebase >=1.15 && <2, - stm >=2.5 && <3 + stm >=2.5 && <3, diff --git a/library/Hasql/Pool.hs b/library/Hasql/Pool.hs index 656edcb..1c705bb 100644 --- a/library/Hasql/Pool.hs +++ b/library/Hasql/Pool.hs @@ -3,7 +3,6 @@ module Hasql.Pool Pool, acquire, acquireDynamically, - flush, release, use, @@ -18,7 +17,7 @@ import Hasql.Pool.Prelude import Hasql.Session (Session) import qualified Hasql.Session as Session --- | A pool of connections to DB. +-- | Pool of connections to DB. data Pool = Pool { -- | Connection settings. poolFetchConnectionSettings :: IO Connection.Settings, @@ -28,66 +27,62 @@ data Pool = Pool poolConnectionQueue :: TQueue Connection, -- | Remaining capacity. -- The pool size limits the sum of poolCapacity, the length - -- of length poolConnectionQueue and the number of in-flight + -- of poolConnectionQueue and the number of in-flight -- connections. poolCapacity :: TVar Int, - -- | Liveness state of the current generation. - -- The pool as a whole is alive if the current generation is alive, - -- while a connection is returned to the pool if the generation it - -- was acquired in is still alive. - poolAlive :: TVar (TVar Bool) + -- | Whether to return a connection to the pool. + poolReuse :: TVar (TVar Bool) } --- | Given the pool-size and connection settings create a connection-pool. +-- | Create a connection-pool. -- -- No connections actually get established by this function. It is delegated -- to 'use'. -acquire :: Int -> Maybe Int -> Connection.Settings -> IO Pool +acquire :: + -- | Pool size. + Int -> + -- | Connection acquisition timeout. + Maybe Int -> + -- | Connection settings. + Connection.Settings -> + IO Pool acquire poolSize timeout connectionSettings = acquireDynamically poolSize timeout (pure connectionSettings) --- | Given the pool-size and connection settings constructor action --- create a connection-pool. --- --- No connections actually get established by this function. It is delegated --- to 'use'. +-- | Create a connection-pool. -- -- In difference to 'acquire' new settings get fetched each time a connection -- is created. This may be useful for some security models. -acquireDynamically :: Int -> Maybe Int -> IO Connection.Settings -> IO Pool +-- +-- No connections actually get established by this function. It is delegated +-- to 'use'. +acquireDynamically :: + -- | Pool size. + Int -> + -- | Connection acquisition timeout. + Maybe Int -> + -- | Action fetching connection settings. + IO Connection.Settings -> + IO Pool acquireDynamically poolSize timeout fetchConnectionSettings = do Pool fetchConnectionSettings timeout <$> newTQueueIO <*> newTVarIO poolSize <*> (newTVarIO =<< newTVarIO True) --- | Release all the idle connections in the pool and mark the pool as dead. --- In-use connections will survive this and be closed once they would be returned --- to the pool. +-- | Release all the idle connections in the pool, and mark the in-use connections +-- to be released on return. Any connections acquired after the call will be +-- newly established. release :: Pool -> IO () -release Pool {..} = do - connections <- atomically $ do - alive <- readTVar poolAlive - writeTVar alive False - flushTQueue poolConnectionQueue - forM_ connections Connection.release - --- | Flush the pool, so that using the pool doesn't reuse any connection from --- before the call. Release all the idle connections in the pool, and mark --- in-use connections to be closed once they would be returned. -flush :: Pool -> IO () -flush Pool {..} = +release Pool {..} = join . atomically $ do - prevAlive <- readTVar poolAlive - alive <- readTVar prevAlive - if alive - then do - writeTVar prevAlive False - writeTVar poolAlive =<< newTVar True - conns <- flushTQueue poolConnectionQueue - modifyTVar' poolCapacity (+ (length conns)) - return $ forM_ conns Connection.release - else return (return ()) + prevReuse <- readTVar poolReuse + writeTVar prevReuse False + newReuse <- newTVar True + writeTVar poolReuse newReuse + conns <- flushTQueue poolConnectionQueue + modifyTVar' poolCapacity (+ (length conns)) + return $ forM_ conns Connection.release -- | Use a connection from the pool to run a session and return the connection -- to the pool, when finished. @@ -105,36 +100,32 @@ use Pool {..} sess = do Nothing -> return $ return False join . atomically $ do - aliveVar <- readTVar poolAlive - alive <- readTVar aliveVar - if alive - then do - asum - [ readTQueue poolConnectionQueue <&> onConn aliveVar, - do - capVal <- readTVar poolCapacity - if capVal > 0 - then do - writeTVar poolCapacity $! pred capVal - return $ onNewConn aliveVar - else retry, - do - timedOut <- timeout - if timedOut - then return . return . Left $ AcquisitionTimeout - else retry - ] - else return . return . Left $ PoolIsReleasedUsageError + reuseVar <- readTVar poolReuse + asum + [ readTQueue poolConnectionQueue <&> onConn reuseVar, + do + capVal <- readTVar poolCapacity + if capVal > 0 + then do + writeTVar poolCapacity $! pred capVal + return $ onNewConn reuseVar + else retry, + do + timedOut <- timeout + if timedOut + then return . return . Left $ AcquisitionTimeoutUsageError + else retry + ] where - onNewConn aliveVar = do + onNewConn reuseVar = do settings <- poolFetchConnectionSettings connRes <- Connection.acquire settings case connRes of Left connErr -> do atomically $ modifyTVar' poolCapacity succ return $ Left $ ConnectionUsageError connErr - Right conn -> onConn aliveVar conn - onConn aliveVar conn = do + Right conn -> onConn reuseVar conn + onConn reuseVar conn = do sessRes <- Session.run sess conn case sessRes of Left err -> case err of @@ -150,8 +141,8 @@ use Pool {..} sess = do where returnConn = join . atomically $ do - alive <- readTVar aliveVar - if alive + reuse <- readTVar reuseVar + if reuse then writeTQueue poolConnectionQueue conn $> return () else do modifyTVar' poolCapacity succ @@ -163,10 +154,8 @@ data UsageError ConnectionUsageError Connection.ConnectionError | -- | Session execution failed. SessionUsageError Session.QueryError - | -- | Attempt to use a pool, which has already been called 'release' upon. - PoolIsReleasedUsageError | -- | Timeout acquiring a connection. - AcquisitionTimeout + AcquisitionTimeoutUsageError deriving (Show, Eq) instance Exception UsageError diff --git a/library/Hasql/Pool/Prelude.hs b/library/Hasql/Pool/Prelude.hs index 6f4d868..c923c78 100644 --- a/library/Hasql/Pool/Prelude.hs +++ b/library/Hasql/Pool/Prelude.hs @@ -1,6 +1,5 @@ module Hasql.Pool.Prelude ( module Exports, - getMillisecondsSinceEpoch, ) where @@ -81,10 +80,3 @@ import Text.Printf as Exports (hPrintf, printf) import Text.Read as Exports (Read (..), readEither, readMaybe) import Unsafe.Coerce as Exports import Prelude as Exports hiding (all, and, any, concat, concatMap, elem, fail, foldl, foldl1, foldr, foldr1, id, mapM, mapM_, maximum, minimum, notElem, or, product, sequence, sequence_, sum, (.)) - -getMillisecondsSinceEpoch :: IO Int -getMillisecondsSinceEpoch = - fmap (fromIntegral . systemTimeToMicros) getSystemTime - where - systemTimeToMicros (MkSystemTime s ns) = - s * 1000 + fromIntegral (div ns 1000000) diff --git a/library/Hasql/Pool/TimeExtras/Conversions.hs b/library/Hasql/Pool/TimeExtras/Conversions.hs new file mode 100644 index 0000000..ae070d3 --- /dev/null +++ b/library/Hasql/Pool/TimeExtras/Conversions.hs @@ -0,0 +1,10 @@ +module Hasql.Pool.TimeExtras.Conversions where + +import Hasql.Pool.Prelude + +class ToMilliseconds a where + toMilliseconds :: a -> Int + +instance ToMilliseconds SystemTime where + toMilliseconds (MkSystemTime s ns) = + fromIntegral s * 1000 + fromIntegral (div ns 1000000) diff --git a/library/Hasql/Pool/TimeExtras/IO.hs b/library/Hasql/Pool/TimeExtras/IO.hs new file mode 100644 index 0000000..40694ff --- /dev/null +++ b/library/Hasql/Pool/TimeExtras/IO.hs @@ -0,0 +1,8 @@ +module Hasql.Pool.TimeExtras.IO where + +import Hasql.Pool.Prelude +import Hasql.Pool.TimeExtras.Conversions + +getMillisecondsSinceEpoch :: IO Int +getMillisecondsSinceEpoch = + fmap toMilliseconds getSystemTime diff --git a/stack.yaml b/stack.yaml index c3fd390..799a83c 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1 +1 @@ -resolver: nightly-2022-05-31 +resolver: nightly-2022-08-26 diff --git a/stack.yaml.lock b/stack.yaml.lock index 24d692d..dcf7c6f 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -6,7 +6,7 @@ packages: [] snapshots: - completed: - sha256: c92a0359aa608c8528e0a6a3f952e7b8501c7fac946b8b0e037125e1ab271423 - size: 590824 - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/nightly/2022/5/31.yaml - original: nightly-2022-05-31 + sha256: 4467e8867668da207eae2bf418100b6e4262374a626586a9e2d0444bd27662d8 + size: 631956 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/nightly/2022/8/26.yaml + original: nightly-2022-08-26 diff --git a/test/Main.hs b/test/Main.hs index 99c247a..823454e 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -1,20 +1,20 @@ module Main where +import Control.Concurrent.Async (race) +import qualified Data.ByteString.Char8 as B8 import qualified Hasql.Connection as Connection import qualified Hasql.Decoders as Decoders import qualified Hasql.Encoders as Encoders import Hasql.Pool import qualified Hasql.Session as Session import qualified Hasql.Statement as Statement +import qualified System.Environment import Test.Hspec import Prelude -import qualified System.Environment -import qualified Data.ByteString.Char8 as B8 -import Control.Concurrent.Async (race) main = do connectionSettings <- getConnectionSettings - hspec $ describe "" $ do + hspec . describe "" $ do it "Releases a spot in the pool when there is a query error" $ do pool <- acquire 1 Nothing connectionSettings use pool badQuerySession `shouldNotReturn` (Right ()) @@ -48,6 +48,12 @@ main = do res <- use pool $ badQuerySession res <- use pool $ selectOneSession shouldSatisfy res $ isRight + it "The pool remains usable after release" $ do + pool <- acquire 1 Nothing connectionSettings + res <- use pool $ selectOneSession + release pool + res <- use pool $ selectOneSession + shouldSatisfy res $ isRight it "Getting and setting session variables works" $ do pool <- acquire 1 Nothing connectionSettings res <- use pool $ getSettingSession "testing.foo" @@ -62,42 +68,42 @@ main = do res `shouldBe` Right () res2 <- use pool $ getSettingSession "testing.foo" res2 `shouldBe` Right (Just "hello world") - it "Flushing the pool resets session variables" $ do + it "Releasing the pool resets session variables" $ do pool <- acquire 1 Nothing connectionSettings res <- use pool $ setSettingSession "testing.foo" "hello world" res `shouldBe` Right () - flush pool + release pool res <- use pool $ getSettingSession "testing.foo" res `shouldBe` Right Nothing - it "Flushing a released pool leaves it dead" $ do - pool <- acquire 1 Nothing connectionSettings - release pool - flush pool - res <- use pool $ selectOneSession - res `shouldBe` Left PoolIsReleasedUsageError it "Times out connection acquisition" $ do pool <- acquire 1 (Just 1000) connectionSettings -- 1ms timeout sleeping <- newEmptyMVar t0 <- getCurrentTime - res <- race - (use pool $ liftIO $ do - putMVar sleeping () - threadDelay 1000000) -- 1s - (do - takeMVar sleeping - use pool $ selectOneSession) + res <- + race + ( use pool $ + liftIO $ do + putMVar sleeping () + threadDelay 1000000 -- 1s + ) + ( do + takeMVar sleeping + use pool $ selectOneSession + ) t1 <- getCurrentTime - res `shouldBe` Right (Left AcquisitionTimeout) + res `shouldBe` Right (Left AcquisitionTimeoutUsageError) diffUTCTime t1 t0 `shouldSatisfy` (< 0.5) -- 0.5s getConnectionSettings :: IO Connection.Settings -getConnectionSettings = B8.unwords . catMaybes <$> sequence - [ setting "host" $ defaultEnv "POSTGRES_HOST" "localhost" - , setting "port" $ defaultEnv "POSTGRES_PORT" "5432" - , setting "user" $ defaultEnv "POSTGRES_USER" "postgres" - , setting "password" $ maybeEnv "POSTGRES_PASSWORD" - , setting "dbname" $ defaultEnv "POSTGRES_DBNAME" "postgres" - ] +getConnectionSettings = + B8.unwords . catMaybes + <$> sequence + [ setting "host" $ defaultEnv "POSTGRES_HOST" "localhost", + setting "port" $ defaultEnv "POSTGRES_PORT" "5432", + setting "user" $ defaultEnv "POSTGRES_USER" "postgres", + setting "password" $ maybeEnv "POSTGRES_PASSWORD", + setting "dbname" $ defaultEnv "POSTGRES_DBNAME" "postgres" + ] where maybeEnv env = fmap B8.pack <$> System.Environment.lookupEnv env defaultEnv env val = Just . fromMaybe val <$> maybeEnv env @@ -116,7 +122,7 @@ badQuerySession :: Session.Session () badQuerySession = Session.statement () statement where - statement = Statement.Statement "" Encoders.noParams Decoders.noResult True + statement = Statement.Statement "zzz" Encoders.noParams Decoders.noResult True closeConnSession :: Session.Session () closeConnSession = do