From e2b9c623af0b922a248f2aed1ad99f2fadac9b97 Mon Sep 17 00:00:00 2001 From: Nikita Volkov Date: Wed, 20 Jul 2022 22:48:24 +0300 Subject: [PATCH 01/25] Update hasql --- hasql-pool.cabal | 2 +- stack.yaml | 2 +- stack.yaml.lock | 121 +++++++++++++++++++++++++++++++++++++++++++++-- test/Main.hs | 2 +- 4 files changed, 119 insertions(+), 8 deletions(-) diff --git a/hasql-pool.cabal b/hasql-pool.cabal index 8f8422a..e1b2a5f 100644 --- a/hasql-pool.cabal +++ b/hasql-pool.cabal @@ -49,7 +49,7 @@ library Hasql.Pool.Prelude build-depends: base >=4.11 && <5, - hasql >=1.3 && <1.6, + hasql >=1.6 && <1.7, stm >=2.5 && <3, time >=1.5 && <2, transformers >=0.5 && <0.7 diff --git a/stack.yaml b/stack.yaml index c3fd390..d696256 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1 +1 @@ -resolver: nightly-2022-05-31 +resolver: https://raw.githubusercontent.com/nikita-volkov/stack-snapshot/f55bfe4e3f2bd73ffa6d9255ea20ab31a993661c/snapshot.yaml diff --git a/stack.yaml.lock b/stack.yaml.lock index 24d692d..33135bc 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -3,10 +3,121 @@ # For more information, please see the documentation at: # https://docs.haskellstack.org/en/stable/lock_files -packages: [] +packages: +- completed: + name: coalmine + pantry-tree: + sha256: 8896e428a656c392d25d499f9b024abd0c30459db09e8a78e1645bad43d4fb89 + size: 9564 + commit: a2857feca4d8a25bd868e0a4ff985b7ef4db6ec3 + git: https://github.com/nikita-volkov/coalmine + version: 0.1.0.4 + original: + commit: a2857feca4d8a25bd868e0a4ff985b7ef4db6ec3 + git: https://github.com/nikita-volkov/coalmine +- completed: + name: moore-machines + pantry-tree: + sha256: 3d1505067d5c8599e9843ed45ec2bc587fa5100c448f558ca5db2c97fb55706f + size: 887 + commit: 7e95c33b203a1cfe42dbc0e0de3cec8e6fe94290 + git: https://github.com/nikita-volkov/moore-machines + version: '0.1' + original: + commit: 7e95c33b203a1cfe42dbc0e0de3cec8e6fe94290 + git: https://github.com/nikita-volkov/moore-machines +- completed: + name: structure-kit + pantry-tree: + sha256: b7779ebe935d65c0b4f6e3ea8b5f5011abdabf362b1673826545c93625e050ad + size: 3500 + commit: 46ffb6527c48f8a718adecd21a313f0b1ba5e81c + git: https://github.com/nikita-volkov/structure-kit + version: 0.1.0.1 + original: + commit: 46ffb6527c48f8a718adecd21a313f0b1ba5e81c + git: https://github.com/nikita-volkov/structure-kit +- completed: + name: canapi + pantry-tree: + sha256: 54c44986c3d7f8daa4464e4e097f312dc3ac0c02f7eb5fbb8bba3a6e6d19487a + size: 1319 + commit: 02f1d9ffea90522a3a0968305793a7f507c7da59 + git: https://github.com/nikita-volkov/canapi + version: '0.1' + original: + commit: 02f1d9ffea90522a3a0968305793a7f507c7da59 + git: https://github.com/nikita-volkov/canapi +- completed: + name: lean-http-client + pantry-tree: + sha256: 64da0f3390166969e2fe6a140d847c315258f9bcb8fcaf3169fd78b4b25b6f6f + size: 544 + commit: 52343895df1e5ae49159b8c5f76a50ac438216b1 + git: https://github.com/nikita-volkov/lean-http-client + version: '0.1' + original: + commit: 52343895df1e5ae49159b8c5f76a50ac438216b1 + git: https://github.com/nikita-volkov/lean-http-client +- completed: + name: distillery + pantry-tree: + sha256: 03d32965a35914b68bdaa149db48ce66e774783360f5b7d8b18db72de61b7baf + size: 524 + commit: 2c2905f2addb0d1925c43d427fcf65340ee64b2a + git: https://github.com/nikita-volkov/distillery + version: '0.1' + original: + commit: 2c2905f2addb0d1925c43d427fcf65340ee64b2a + git: https://github.com/nikita-volkov/distillery +- completed: + name: acquire + pantry-tree: + sha256: e194150d070a0e4f07e5f2285e82f177312f328c7490f3a659f361b4f6324d00 + size: 438 + commit: 75194757308ae9340b0e2eda46d8db4d25af7516 + git: https://github.com/metrix-ai/acquire + version: 0.3.1 + original: + commit: 75194757308ae9340b0e2eda46d8db4d25af7516 + git: https://github.com/metrix-ai/acquire +- completed: + pantry-tree: + sha256: 520aa5f59b55c14d27115a801f499f940a563849b0c54876bcd6be41f6450713 + size: 456 + hackage: cereal-data-dword-0.1.1@sha256:a3fa6dfafaeeb3774c5888dfa601d561ce05b0af66f52859970247e58135d47e,1381 + original: + hackage: cereal-data-dword-0.1.1 +- completed: + pantry-tree: + sha256: f2fd5281b8fcea2ffa1f323feca1c84d030914dfec18f61e52be8a60d6939037 + size: 2622 + hackage: hasql-1.6@sha256:78f5fd9e732862cbffb06123015866312bf6f3889c18508018820536490a8460,6624 + original: + hackage: hasql-1.6 +- completed: + pantry-tree: + sha256: 946dbffdad0a92dbdeeaaabb1c7ac2451f3002561407068543fcd860cd860f15 + size: 473 + hackage: punycode-2.0@sha256:dce7f481b5eedc750cf49d21a80b839cb366afd2d29bc506acca5ad9d0c06a8f,1503 + original: + hackage: punycode-2.0 +- completed: + pantry-tree: + sha256: 51dc0ab22269973eec829ae476fb3102cfe155ffde2fd1d039dedf65c7842031 + size: 509 + hackage: timestamp-0.2@sha256:103fe49ce206922d3b14d57d8aff25eaf03c70fef5fcdaeaeb8416aaee163e51,1598 + original: + hackage: timestamp-0.2 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: a4a05670f8e2a2bc108aca4e093c57eb82f562afd6949f299b0116861444f6f6 + size: 887 + url: https://raw.githubusercontent.com/nikita-volkov/stack-snapshot/f55bfe4e3f2bd73ffa6d9255ea20ab31a993661c/snapshot.yaml + original: + url: https://raw.githubusercontent.com/nikita-volkov/stack-snapshot/f55bfe4e3f2bd73ffa6d9255ea20ab31a993661c/snapshot.yaml +- completed: + sha256: 6a7d84094bf948100b933f83f8cff586a41633d59cb1adbb89eefc25405fabe8 + size: 616794 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/nightly/2022/7/16.yaml + original: nightly-2022-07-16 diff --git a/test/Main.hs b/test/Main.hs index 97e7b77..e7deef2 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -60,7 +60,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 From f00ff15d6ef4e5fc3f998fe5a90e7f887b6943f0 Mon Sep 17 00:00:00 2001 From: Nikita Volkov Date: Wed, 20 Jul 2022 22:59:28 +0300 Subject: [PATCH 02/25] Bump --- hasql-pool.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/hasql-pool.cabal b/hasql-pool.cabal index e1b2a5f..22212aa 100644 --- a/hasql-pool.cabal +++ b/hasql-pool.cabal @@ -1,7 +1,7 @@ name: hasql-pool version: - 0.7.2 + 0.7.2.1 category: Hasql, Database, PostgreSQL synopsis: From 258a1796d90185d9b993c69949ad2a56feb9fb33 Mon Sep 17 00:00:00 2001 From: Nikita Volkov Date: Fri, 26 Aug 2022 23:51:30 +0300 Subject: [PATCH 03/25] Modernize cabal and update deps --- hasql-pool.cabal | 81 +++++++++++-------------------- stack.yaml | 2 +- stack.yaml.lock | 121 ++--------------------------------------------- 3 files changed, 34 insertions(+), 170 deletions(-) diff --git a/hasql-pool.cabal b/hasql-pool.cabal index 22212aa..2da319c 100644 --- a/hasql-pool.cabal +++ b/hasql-pool.cabal @@ -1,74 +1,49 @@ -name: - hasql-pool -version: - 0.7.2.1 -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.7.2.1 + +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 build-depends: base >=4.11 && <5, - hasql >=1.6 && <1.7, + 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 build-depends: hasql, hasql-pool, hspec >=2.6 && <3, rerebase >=1.15 && <2, - stm >=2.5 && <3 + stm >=2.5 && <3, diff --git a/stack.yaml b/stack.yaml index d696256..799a83c 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1 +1 @@ -resolver: https://raw.githubusercontent.com/nikita-volkov/stack-snapshot/f55bfe4e3f2bd73ffa6d9255ea20ab31a993661c/snapshot.yaml +resolver: nightly-2022-08-26 diff --git a/stack.yaml.lock b/stack.yaml.lock index 33135bc..dcf7c6f 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -3,121 +3,10 @@ # For more information, please see the documentation at: # https://docs.haskellstack.org/en/stable/lock_files -packages: -- completed: - name: coalmine - pantry-tree: - sha256: 8896e428a656c392d25d499f9b024abd0c30459db09e8a78e1645bad43d4fb89 - size: 9564 - commit: a2857feca4d8a25bd868e0a4ff985b7ef4db6ec3 - git: https://github.com/nikita-volkov/coalmine - version: 0.1.0.4 - original: - commit: a2857feca4d8a25bd868e0a4ff985b7ef4db6ec3 - git: https://github.com/nikita-volkov/coalmine -- completed: - name: moore-machines - pantry-tree: - sha256: 3d1505067d5c8599e9843ed45ec2bc587fa5100c448f558ca5db2c97fb55706f - size: 887 - commit: 7e95c33b203a1cfe42dbc0e0de3cec8e6fe94290 - git: https://github.com/nikita-volkov/moore-machines - version: '0.1' - original: - commit: 7e95c33b203a1cfe42dbc0e0de3cec8e6fe94290 - git: https://github.com/nikita-volkov/moore-machines -- completed: - name: structure-kit - pantry-tree: - sha256: b7779ebe935d65c0b4f6e3ea8b5f5011abdabf362b1673826545c93625e050ad - size: 3500 - commit: 46ffb6527c48f8a718adecd21a313f0b1ba5e81c - git: https://github.com/nikita-volkov/structure-kit - version: 0.1.0.1 - original: - commit: 46ffb6527c48f8a718adecd21a313f0b1ba5e81c - git: https://github.com/nikita-volkov/structure-kit -- completed: - name: canapi - pantry-tree: - sha256: 54c44986c3d7f8daa4464e4e097f312dc3ac0c02f7eb5fbb8bba3a6e6d19487a - size: 1319 - commit: 02f1d9ffea90522a3a0968305793a7f507c7da59 - git: https://github.com/nikita-volkov/canapi - version: '0.1' - original: - commit: 02f1d9ffea90522a3a0968305793a7f507c7da59 - git: https://github.com/nikita-volkov/canapi -- completed: - name: lean-http-client - pantry-tree: - sha256: 64da0f3390166969e2fe6a140d847c315258f9bcb8fcaf3169fd78b4b25b6f6f - size: 544 - commit: 52343895df1e5ae49159b8c5f76a50ac438216b1 - git: https://github.com/nikita-volkov/lean-http-client - version: '0.1' - original: - commit: 52343895df1e5ae49159b8c5f76a50ac438216b1 - git: https://github.com/nikita-volkov/lean-http-client -- completed: - name: distillery - pantry-tree: - sha256: 03d32965a35914b68bdaa149db48ce66e774783360f5b7d8b18db72de61b7baf - size: 524 - commit: 2c2905f2addb0d1925c43d427fcf65340ee64b2a - git: https://github.com/nikita-volkov/distillery - version: '0.1' - original: - commit: 2c2905f2addb0d1925c43d427fcf65340ee64b2a - git: https://github.com/nikita-volkov/distillery -- completed: - name: acquire - pantry-tree: - sha256: e194150d070a0e4f07e5f2285e82f177312f328c7490f3a659f361b4f6324d00 - size: 438 - commit: 75194757308ae9340b0e2eda46d8db4d25af7516 - git: https://github.com/metrix-ai/acquire - version: 0.3.1 - original: - commit: 75194757308ae9340b0e2eda46d8db4d25af7516 - git: https://github.com/metrix-ai/acquire -- completed: - pantry-tree: - sha256: 520aa5f59b55c14d27115a801f499f940a563849b0c54876bcd6be41f6450713 - size: 456 - hackage: cereal-data-dword-0.1.1@sha256:a3fa6dfafaeeb3774c5888dfa601d561ce05b0af66f52859970247e58135d47e,1381 - original: - hackage: cereal-data-dword-0.1.1 -- completed: - pantry-tree: - sha256: f2fd5281b8fcea2ffa1f323feca1c84d030914dfec18f61e52be8a60d6939037 - size: 2622 - hackage: hasql-1.6@sha256:78f5fd9e732862cbffb06123015866312bf6f3889c18508018820536490a8460,6624 - original: - hackage: hasql-1.6 -- completed: - pantry-tree: - sha256: 946dbffdad0a92dbdeeaaabb1c7ac2451f3002561407068543fcd860cd860f15 - size: 473 - hackage: punycode-2.0@sha256:dce7f481b5eedc750cf49d21a80b839cb366afd2d29bc506acca5ad9d0c06a8f,1503 - original: - hackage: punycode-2.0 -- completed: - pantry-tree: - sha256: 51dc0ab22269973eec829ae476fb3102cfe155ffde2fd1d039dedf65c7842031 - size: 509 - hackage: timestamp-0.2@sha256:103fe49ce206922d3b14d57d8aff25eaf03c70fef5fcdaeaeb8416aaee163e51,1598 - original: - hackage: timestamp-0.2 +packages: [] snapshots: - completed: - sha256: a4a05670f8e2a2bc108aca4e093c57eb82f562afd6949f299b0116861444f6f6 - size: 887 - url: https://raw.githubusercontent.com/nikita-volkov/stack-snapshot/f55bfe4e3f2bd73ffa6d9255ea20ab31a993661c/snapshot.yaml - original: - url: https://raw.githubusercontent.com/nikita-volkov/stack-snapshot/f55bfe4e3f2bd73ffa6d9255ea20ab31a993661c/snapshot.yaml -- completed: - sha256: 6a7d84094bf948100b933f83f8cff586a41633d59cb1adbb89eefc25405fabe8 - size: 616794 - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/nightly/2022/7/16.yaml - original: nightly-2022-07-16 + sha256: 4467e8867668da207eae2bf418100b6e4262374a626586a9e2d0444bd27662d8 + size: 631956 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/nightly/2022/8/26.yaml + original: nightly-2022-08-26 From 5b29918beae04a280057a69ec93da9292562dff9 Mon Sep 17 00:00:00 2001 From: Nikita Volkov Date: Sat, 27 Aug 2022 15:53:27 +0300 Subject: [PATCH 04/25] Correct things --- library/Hasql/Pool/Prelude.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/library/Hasql/Pool/Prelude.hs b/library/Hasql/Pool/Prelude.hs index 6f4d868..32aa579 100644 --- a/library/Hasql/Pool/Prelude.hs +++ b/library/Hasql/Pool/Prelude.hs @@ -84,7 +84,7 @@ import Prelude as Exports hiding (all, and, any, concat, concatMap, elem, fail, getMillisecondsSinceEpoch :: IO Int getMillisecondsSinceEpoch = - fmap (fromIntegral . systemTimeToMicros) getSystemTime + fmap systemTimeToMillis getSystemTime where - systemTimeToMicros (MkSystemTime s ns) = - s * 1000 + fromIntegral (div ns 1000000) + systemTimeToMillis (MkSystemTime s ns) = + fromIntegral s * 1000 + fromIntegral (div ns 1000000) From 48d0106cab686d277ed7d4c3ea6a2f26f16d44e7 Mon Sep 17 00:00:00 2001 From: Nikita Volkov Date: Sat, 27 Aug 2022 15:57:58 +0300 Subject: [PATCH 05/25] Isolate the time extras --- hasql-pool.cabal | 2 ++ library/Hasql/Pool/Prelude.hs | 8 -------- library/Hasql/Pool/Time/Conversions.hs | 10 ++++++++++ library/Hasql/Pool/Time/IO.hs | 8 ++++++++ 4 files changed, 20 insertions(+), 8 deletions(-) create mode 100644 library/Hasql/Pool/Time/Conversions.hs create mode 100644 library/Hasql/Pool/Time/IO.hs diff --git a/hasql-pool.cabal b/hasql-pool.cabal index 2da319c..e793a32 100644 --- a/hasql-pool.cabal +++ b/hasql-pool.cabal @@ -29,6 +29,8 @@ library Hasql.Pool other-modules: Hasql.Pool.Prelude + Hasql.Pool.Time.IO + Hasql.Pool.Time.Conversions build-depends: base >=4.11 && <5, hasql >=1.6.0.1 && <1.7, diff --git a/library/Hasql/Pool/Prelude.hs b/library/Hasql/Pool/Prelude.hs index 32aa579..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 systemTimeToMillis getSystemTime - where - systemTimeToMillis (MkSystemTime s ns) = - fromIntegral s * 1000 + fromIntegral (div ns 1000000) diff --git a/library/Hasql/Pool/Time/Conversions.hs b/library/Hasql/Pool/Time/Conversions.hs new file mode 100644 index 0000000..1d4c468 --- /dev/null +++ b/library/Hasql/Pool/Time/Conversions.hs @@ -0,0 +1,10 @@ +module Hasql.Pool.Time.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/Time/IO.hs b/library/Hasql/Pool/Time/IO.hs new file mode 100644 index 0000000..e4379e3 --- /dev/null +++ b/library/Hasql/Pool/Time/IO.hs @@ -0,0 +1,8 @@ +module Hasql.Pool.Time.IO where + +import Hasql.Pool.Prelude +import Hasql.Pool.Time.Conversions + +getMillisecondsSinceEpoch :: IO Int +getMillisecondsSinceEpoch = + fmap toMilliseconds getSystemTime From aa44a02864916b8f4a9182d63d1d05f0acaafe32 Mon Sep 17 00:00:00 2001 From: Nikita Volkov Date: Sat, 27 Aug 2022 15:58:48 +0300 Subject: [PATCH 06/25] Rename Time to TimeExtras --- hasql-pool.cabal | 4 ++-- library/Hasql/Pool/{Time => TimeExtras}/Conversions.hs | 2 +- library/Hasql/Pool/{Time => TimeExtras}/IO.hs | 4 ++-- 3 files changed, 5 insertions(+), 5 deletions(-) rename library/Hasql/Pool/{Time => TimeExtras}/Conversions.hs (82%) rename library/Hasql/Pool/{Time => TimeExtras}/IO.hs (61%) diff --git a/hasql-pool.cabal b/hasql-pool.cabal index e793a32..fd4411e 100644 --- a/hasql-pool.cabal +++ b/hasql-pool.cabal @@ -29,8 +29,8 @@ library Hasql.Pool other-modules: Hasql.Pool.Prelude - Hasql.Pool.Time.IO - Hasql.Pool.Time.Conversions + Hasql.Pool.TimeExtras.IO + Hasql.Pool.TimeExtras.Conversions build-depends: base >=4.11 && <5, hasql >=1.6.0.1 && <1.7, diff --git a/library/Hasql/Pool/Time/Conversions.hs b/library/Hasql/Pool/TimeExtras/Conversions.hs similarity index 82% rename from library/Hasql/Pool/Time/Conversions.hs rename to library/Hasql/Pool/TimeExtras/Conversions.hs index 1d4c468..ae070d3 100644 --- a/library/Hasql/Pool/Time/Conversions.hs +++ b/library/Hasql/Pool/TimeExtras/Conversions.hs @@ -1,4 +1,4 @@ -module Hasql.Pool.Time.Conversions where +module Hasql.Pool.TimeExtras.Conversions where import Hasql.Pool.Prelude diff --git a/library/Hasql/Pool/Time/IO.hs b/library/Hasql/Pool/TimeExtras/IO.hs similarity index 61% rename from library/Hasql/Pool/Time/IO.hs rename to library/Hasql/Pool/TimeExtras/IO.hs index e4379e3..40694ff 100644 --- a/library/Hasql/Pool/Time/IO.hs +++ b/library/Hasql/Pool/TimeExtras/IO.hs @@ -1,7 +1,7 @@ -module Hasql.Pool.Time.IO where +module Hasql.Pool.TimeExtras.IO where import Hasql.Pool.Prelude -import Hasql.Pool.Time.Conversions +import Hasql.Pool.TimeExtras.Conversions getMillisecondsSinceEpoch :: IO Int getMillisecondsSinceEpoch = From 8a23ef26588b745fcb763ce34294688ff59cb5e0 Mon Sep 17 00:00:00 2001 From: Robert Vollmert Date: Wed, 24 Aug 2022 14:21:00 +0200 Subject: [PATCH 07/25] Make test postgresql connection details configurable by env var --- test/Main.hs | 25 ++++++++++++++++++++----- 1 file changed, 20 insertions(+), 5 deletions(-) diff --git a/test/Main.hs b/test/Main.hs index e7deef2..5a70a31 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -8,9 +8,13 @@ import qualified Hasql.Session as Session import qualified Hasql.Statement as Statement import Test.Hspec import Prelude +import qualified System.Environment +import qualified Data.ByteString.Char8 as B8 -main = hspec $ do - describe "" $ do +main = do + connectionSettings <- getConnectionSettings + putStrLn $ show connectionSettings + hspec $ describe "" $ do it "Releases a spot in the pool when there is a query error" $ do pool <- acquire 1 connectionSettings use pool badQuerySession `shouldNotReturn` (Right ()) @@ -45,9 +49,20 @@ main = hspec $ do res <- use pool $ selectOneSession shouldSatisfy res $ isRight -connectionSettings :: Connection.Settings -connectionSettings = - "host=localhost port=5432 user=postgres dbname=postgres" +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" + ] + where + maybeEnv env = fmap B8.pack <$> System.Environment.lookupEnv env + defaultEnv env val = Just . fromMaybe val <$> maybeEnv env + setting label getEnv = do + val <- getEnv + return $ (\v -> label <> "=" <> v) <$> val selectOneSession :: Session.Session Int64 selectOneSession = From b30b0edc0b40b40105f244df2fea073642f3600b Mon Sep 17 00:00:00 2001 From: Robert Vollmert Date: Wed, 24 Aug 2022 13:35:03 +0200 Subject: [PATCH 08/25] Set up CI with github actions --- .github/workflows/haskell.yml | 60 +++++++++++++++++++++++++++++++++++ test/Main.hs | 1 - 2 files changed, 60 insertions(+), 1 deletion(-) create mode 100644 .github/workflows/haskell.yml diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml new file mode 100644 index 0000000..f287ba0 --- /dev/null +++ b/.github/workflows/haskell.yml @@ -0,0 +1,60 @@ +name: Haskell CI + +on: + push: + branches: [ master ] + pull_request: + branches: [ master ] + +permissions: + contents: read + +jobs: + build: + strategy: + matrix: + ghc: ['8.10.7', '9.2.4'] + fail-fast: false + + runs-on: ubuntu-latest + + services: + postgres: + image: postgres + env: + POSTGRES_PASSWORD: postgres + options: >- + --health-cmd pg_isready + --health-interval 10s + --health-timeout 5s + --health-retries 5 + ports: + - 5432:5432 + + steps: + - uses: actions/checkout@v3 + - name: ghcup + run: | + ghcup install ghc ${{ matrix.ghc }} + ghcup set ghc ${{ matrix.ghc }} + ghcup install cabal latest + ghcup set cabal latest + + - name: Cache + uses: actions/cache@v3 + with: + path: ~/.cabal + key: ${{ runner.os }}-${{ matrix.ghc }}-${{ hashFiles('**/*.cabal') }}-${{ hashFiles('**/cabal.project') }} + restore-keys: | + ${{ runner.os }}-${{ matrix.ghc }}- + + - name: Install dependencies + run: | + cabal update + cabal build --only-dependencies --enable-tests --enable-benchmarks + - name: Build + run: cabal build --enable-tests --enable-benchmarks all + - name: Run tests + run: | + export POSTGRES_PASSWORD=postgres + cabal test all diff --git a/test/Main.hs b/test/Main.hs index 5a70a31..70c0657 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -13,7 +13,6 @@ import qualified Data.ByteString.Char8 as B8 main = do connectionSettings <- getConnectionSettings - putStrLn $ show connectionSettings hspec $ describe "" $ do it "Releases a spot in the pool when there is a query error" $ do pool <- acquire 1 connectionSettings From fda45edb6e534c075486209afcc4cd4562be5475 Mon Sep 17 00:00:00 2001 From: Robert Vollmert Date: Wed, 24 Aug 2022 14:34:04 +0200 Subject: [PATCH 09/25] Remove travis CI --- .travis.yml | 60 ----------------------------------------------------- 1 file changed, 60 deletions(-) delete mode 100644 .travis.yml diff --git a/.travis.yml b/.travis.yml deleted file mode 100644 index afc7d3b..0000000 --- a/.travis.yml +++ /dev/null @@ -1,60 +0,0 @@ -if: tag IS blank - -env: - - ghc=8.4.2 - - ghc=8.6.5 - - ghc=8.8.1 - - ghc=8.10.1 benchmarks=1 tests=1 - -services: - - postgresql - -install: - # Set up the Shell to treat the semicolon as && - - set -eo pipefail - # Install GHC and Cabal - - - cabal=${cabal=2.4}; - travis_retry sudo add-apt-repository -y ppa:hvr/ghc; - travis_retry sudo apt-get update; - travis_retry sudo apt-get install cabal-install-$cabal ghc-$ghc; - export PATH=/opt/ghc/$ghc/bin:/opt/cabal/$cabal/bin:$PATH; - # Update the Cabal database - - cabal v1-update - # Switch to the distro: - - - export pkg_name=$(cabal info . | awk '{print $2;exit}'); - cabal sdist; - cd dist; - tar xzvf $pkg_name.tar.gz; - cd $pkg_name; - # Install the lower bound dependencies - - - if [ "$lower_bound_dependencies" = "1" ]; - then - constraint_options=( - ); - fi; - # Install executables - - cabal v1-install happy - - cabal v1-install doctest - # Install the library dependencies - - cabal v1-install --only-dependencies --reorder-goals --force-reinstalls - ${constraint_options[@]} - $([ "$tests" = "1" ] && echo "--enable-tests") - $([ "$benchmarks" = "1" ] && echo "--enable-benchmarks") - # Build the library - - cabal v1-build - # Configure and build the remaining stuff - - cabal v1-configure - $([ "$tests" = "1" ] && echo "--enable-tests") - $([ "$benchmarks" = "1" ] && echo "--enable-benchmarks") - -f doctest - - cabal v1-build - -script: - - | - if [ "$tests" = "1" ]; - then - cabal v1-test --show-details=always; - fi; From d481750dc384d5159aa6300517e691b52bc023c2 Mon Sep 17 00:00:00 2001 From: Robert Vollmert Date: Mon, 8 Aug 2022 14:58:03 +0200 Subject: [PATCH 10/25] Extend documentation --- library/Hasql/Pool.hs | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/library/Hasql/Pool.hs b/library/Hasql/Pool.hs index ac91e3b..f8960cc 100644 --- a/library/Hasql/Pool.hs +++ b/library/Hasql/Pool.hs @@ -23,7 +23,10 @@ data Pool = Pool poolFetchConnectionSettings :: IO Connection.Settings, -- | Avail connections. poolConnectionQueue :: TQueue Connection, - -- | Capacity. + -- | Remaining capacity. + -- The pool size limits the sum of poolCapacity, the length + -- of length poolConnectionQueue and the number of in-flight + -- connections. poolCapacity :: TVar Int, -- | Alive. poolAlive :: TVar Bool @@ -52,7 +55,9 @@ acquireDynamically poolSize fetchConnectionSettings = do <*> newTVarIO poolSize <*> newTVarIO True --- | Release all the connections in the pool. +-- | 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 :: Pool -> IO () release Pool {..} = do connections <- atomically $ do From e7a460ebd500e0d99245946cefa11fe866495c18 Mon Sep 17 00:00:00 2001 From: Robert Vollmert Date: Mon, 8 Aug 2022 14:59:03 +0200 Subject: [PATCH 11/25] Add some tests for session variables --- test/Main.hs | 31 +++++++++++++++++++++++++++++++ 1 file changed, 31 insertions(+) diff --git a/test/Main.hs b/test/Main.hs index e7deef2..51e5c1e 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -44,6 +44,20 @@ main = hspec $ do res <- use pool $ badQuerySession res <- use pool $ selectOneSession shouldSatisfy res $ isRight + it "Getting and setting session variables works" $ do + pool <- acquire 1 connectionSettings + res <- use pool $ getSettingSession "testing.foo" + res `shouldBe` Right Nothing + res <- use pool $ do + setSettingSession "testing.foo" "hello world" + getSettingSession "testing.foo" + res `shouldBe` Right (Just "hello world") + it "Session variables stay set when a connection gets reused" $ do + pool <- acquire 1 connectionSettings + res <- use pool $ setSettingSession "testing.foo" "hello world" + res `shouldBe` Right () + res2 <- use pool $ getSettingSession "testing.foo" + res2 `shouldBe` Right (Just "hello world") connectionSettings :: Connection.Settings connectionSettings = @@ -66,3 +80,20 @@ closeConnSession :: Session.Session () closeConnSession = do conn <- ask liftIO $ Connection.release conn + +setSettingSession :: Text -> Text -> Session.Session () +setSettingSession name value = do + Session.statement (name, value) statement + where + statement = Statement.Statement "SELECT set_config($1, $2, false)" encoder Decoders.noResult True + encoder = + contramap fst (Encoders.param (Encoders.nonNullable Encoders.text)) + <> contramap snd (Encoders.param (Encoders.nonNullable Encoders.text)) + +getSettingSession :: Text -> Session.Session (Maybe Text) +getSettingSession name = do + Session.statement name statement + where + statement = Statement.Statement "SELECT current_setting($1, true)" encoder decoder True + encoder = Encoders.param (Encoders.nonNullable Encoders.text) + decoder = Decoders.singleRow (Decoders.column (Decoders.nullable Decoders.text)) From 45ec9cd79bd8c71d04c14b1eff2435bf1b5550c4 Mon Sep 17 00:00:00 2001 From: Robert Vollmert Date: Mon, 8 Aug 2022 14:59:39 +0200 Subject: [PATCH 12/25] Allow flushing the connection pool Connections created before calling 'flush' won't be reused afterwards. --- library/Hasql/Pool.hs | 51 ++++++++++++++++++++++++++++++++----------- test/Main.hs | 13 +++++++++++ 2 files changed, 51 insertions(+), 13 deletions(-) diff --git a/library/Hasql/Pool.hs b/library/Hasql/Pool.hs index f8960cc..7424939 100644 --- a/library/Hasql/Pool.hs +++ b/library/Hasql/Pool.hs @@ -3,6 +3,7 @@ module Hasql.Pool Pool, acquire, acquireDynamically, + flush, release, use, @@ -28,8 +29,11 @@ data Pool = Pool -- of length poolConnectionQueue and the number of in-flight -- connections. poolCapacity :: TVar Int, - -- | Alive. - poolAlive :: TVar Bool + -- | 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) } -- | Given the pool-size and connection settings create a connection-pool. @@ -53,7 +57,7 @@ acquireDynamically poolSize fetchConnectionSettings = do Pool fetchConnectionSettings <$> newTQueueIO <*> newTVarIO poolSize - <*> newTVarIO True + <*> (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 @@ -61,10 +65,28 @@ acquireDynamically poolSize fetchConnectionSettings = do release :: Pool -> IO () release Pool {..} = do connections <- atomically $ do - writeTVar poolAlive False + 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 {..} = + 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 ()) + -- | Use a connection from the pool to run a session and return the connection -- to the pool, when finished. -- @@ -75,30 +97,31 @@ release Pool {..} = do use :: Pool -> Session.Session a -> IO (Either UsageError a) use Pool {..} sess = join . atomically $ do - alive <- readTVar poolAlive + aliveVar <- readTVar poolAlive + alive <- readTVar aliveVar if alive - then + then do asum - [ readTQueue poolConnectionQueue <&> onConn, + [ readTQueue poolConnectionQueue <&> onConn aliveVar, do capVal <- readTVar poolCapacity if capVal > 0 then do writeTVar poolCapacity $! pred capVal - return onNewConn + return $ onNewConn aliveVar else retry ] else return . return . Left $ PoolIsReleasedUsageError where - onNewConn = do + onNewConn aliveVar = do settings <- poolFetchConnectionSettings connRes <- Connection.acquire settings case connRes of Left connErr -> do atomically $ modifyTVar' poolCapacity succ return $ Left $ ConnectionUsageError connErr - Right conn -> onConn conn - onConn conn = do + Right conn -> onConn aliveVar conn + onConn aliveVar conn = do sessRes <- Session.run sess conn case sessRes of Left err -> case err of @@ -114,10 +137,12 @@ use Pool {..} sess = where returnConn = join . atomically $ do - alive <- readTVar poolAlive + alive <- readTVar aliveVar if alive then writeTQueue poolConnectionQueue conn $> return () - else return $ Connection.release conn + else do + modifyTVar' poolCapacity succ + return $ Connection.release conn -- | Union over all errors that 'use' can result in. data UsageError diff --git a/test/Main.hs b/test/Main.hs index 51e5c1e..6f20680 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -58,6 +58,19 @@ main = hspec $ do res `shouldBe` Right () res2 <- use pool $ getSettingSession "testing.foo" res2 `shouldBe` Right (Just "hello world") + it "Flushing the pool resets session variables" $ do + pool <- acquire 1 connectionSettings + res <- use pool $ setSettingSession "testing.foo" "hello world" + res `shouldBe` Right () + flush pool + res <- use pool $ getSettingSession "testing.foo" + res `shouldBe` Right Nothing + it "Flushing a released pool leaves it dead" $ do + pool <- acquire 1 connectionSettings + release pool + flush pool + res <- use pool $ selectOneSession + res `shouldBe` Left PoolIsReleasedUsageError connectionSettings :: Connection.Settings connectionSettings = From ae6da2d796eef8f6caad7ff55b5c68432117b0aa Mon Sep 17 00:00:00 2001 From: Robert Vollmert Date: Mon, 29 Aug 2022 10:08:18 +0200 Subject: [PATCH 13/25] make 'release' flush but not destroy the pool instead --- library/Hasql/Pool.hs | 60 ++++++++++++++----------------------------- test/Main.hs | 16 ++++++------ 2 files changed, 27 insertions(+), 49 deletions(-) diff --git a/library/Hasql/Pool.hs b/library/Hasql/Pool.hs index 7424939..d51438c 100644 --- a/library/Hasql/Pool.hs +++ b/library/Hasql/Pool.hs @@ -3,7 +3,6 @@ module Hasql.Pool Pool, acquire, acquireDynamically, - flush, release, use, @@ -59,33 +58,18 @@ acquireDynamically poolSize fetchConnectionSettings = do <*> 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 ()) + writeTVar prevAlive False + writeTVar poolAlive =<< newTVar True + 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. @@ -98,20 +82,16 @@ use :: Pool -> Session.Session a -> IO (Either UsageError a) use Pool {..} sess = 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 - ] - else return . return . Left $ PoolIsReleasedUsageError + asum + [ readTQueue poolConnectionQueue <&> onConn aliveVar, + do + capVal <- readTVar poolCapacity + if capVal > 0 + then do + writeTVar poolCapacity $! pred capVal + return $ onNewConn aliveVar + else retry + ] where onNewConn aliveVar = do settings <- poolFetchConnectionSettings @@ -150,8 +130,6 @@ data UsageError ConnectionUsageError Connection.ConnectionError | -- | Session execution failed. SessionUsageError Session.QueryError - | -- | Attempt to use a pool, which has already been called 'release' upon. - PoolIsReleasedUsageError deriving (Show, Eq) instance Exception UsageError diff --git a/test/Main.hs b/test/Main.hs index 6f20680..b2efcb9 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -44,6 +44,12 @@ main = hspec $ do res <- use pool $ badQuerySession res <- use pool $ selectOneSession shouldSatisfy res $ isRight + it "The pool remains usable after release" $ do + pool <- acquire 1 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 connectionSettings res <- use pool $ getSettingSession "testing.foo" @@ -58,19 +64,13 @@ main = hspec $ 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 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 connectionSettings - release pool - flush pool - res <- use pool $ selectOneSession - res `shouldBe` Left PoolIsReleasedUsageError connectionSettings :: Connection.Settings connectionSettings = From 31af4fe3a389cb520b8c19b34f08aa8bc133cc6b Mon Sep 17 00:00:00 2001 From: Robert Vollmert Date: Mon, 29 Aug 2022 13:30:06 +0200 Subject: [PATCH 14/25] an attempt at naming things a bit more clearly --- library/Hasql/Pool.hs | 38 +++++++++++++++++++------------------- 1 file changed, 19 insertions(+), 19 deletions(-) diff --git a/library/Hasql/Pool.hs b/library/Hasql/Pool.hs index d51438c..c3432a3 100644 --- a/library/Hasql/Pool.hs +++ b/library/Hasql/Pool.hs @@ -17,6 +17,8 @@ import Hasql.Pool.Prelude import Hasql.Session (Session) import qualified Hasql.Session as Session +data ReuseConnection = Keep | Close + -- | A pool of connections to DB. data Pool = Pool { -- | Connection settings. @@ -28,11 +30,8 @@ data Pool = Pool -- of length 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. + poolReuseToggle :: TVar (TVar ReuseConnection) } -- | Given the pool-size and connection settings create a connection-pool. @@ -56,7 +55,7 @@ acquireDynamically poolSize fetchConnectionSettings = do Pool fetchConnectionSettings <$> newTQueueIO <*> newTVarIO poolSize - <*> (newTVarIO =<< newTVarIO True) + <*> (newTVarIO =<< newTVarIO Keep) -- | 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 @@ -64,9 +63,10 @@ acquireDynamically poolSize fetchConnectionSettings = do release :: Pool -> IO () release Pool {..} = join . atomically $ do - prevAlive <- readTVar poolAlive - writeTVar prevAlive False - writeTVar poolAlive =<< newTVar True + prevReuseToggle <- readTVar poolReuseToggle + writeTVar prevReuseToggle Close + newReuseToggle <- newTVar Keep + writeTVar poolReuseToggle newReuseToggle conns <- flushTQueue poolConnectionQueue modifyTVar' poolCapacity (+ (length conns)) return $ forM_ conns Connection.release @@ -81,27 +81,27 @@ release Pool {..} = use :: Pool -> Session.Session a -> IO (Either UsageError a) use Pool {..} sess = join . atomically $ do - aliveVar <- readTVar poolAlive + reuseToggle <- readTVar poolReuseToggle asum - [ readTQueue poolConnectionQueue <&> onConn aliveVar, + [ readTQueue poolConnectionQueue <&> onConn reuseToggle, do capVal <- readTVar poolCapacity if capVal > 0 then do writeTVar poolCapacity $! pred capVal - return $ onNewConn aliveVar + return $ onNewConn reuseToggle else retry ] where - onNewConn aliveVar = do + onNewConn reuseToggle = 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 reuseToggle conn + onConn reuseToggle conn = do sessRes <- Session.run sess conn case sessRes of Left err -> case err of @@ -117,10 +117,10 @@ use Pool {..} sess = where returnConn = join . atomically $ do - alive <- readTVar aliveVar - if alive - then writeTQueue poolConnectionQueue conn $> return () - else do + reuse <- readTVar reuseToggle + case reuse of + Keep -> writeTQueue poolConnectionQueue conn $> return () + Close -> do modifyTVar' poolCapacity succ return $ Connection.release conn From 946358eebac009b9332ca369d2a9da82937712b0 Mon Sep 17 00:00:00 2001 From: Robert Vollmert Date: Fri, 22 Jul 2022 14:38:39 +0200 Subject: [PATCH 15/25] Acquisition timeout --- hasql-pool.cabal | 2 ++ library/Hasql/Pool.hs | 31 +++++++++++++++++++++++-------- test/Main.hs | 33 ++++++++++++++++++++++++--------- 3 files changed, 49 insertions(+), 17 deletions(-) diff --git a/hasql-pool.cabal b/hasql-pool.cabal index fd4411e..40cc7d3 100644 --- a/hasql-pool.cabal +++ b/hasql-pool.cabal @@ -43,9 +43,11 @@ test-suite test type: exitcode-stdio-1.0 hs-source-dirs: test main-is: Main.hs + ghc-options: -threaded build-depends: hasql, hasql-pool, + async, hspec >=2.6 && <3, rerebase >=1.15 && <2, stm >=2.5 && <3, diff --git a/library/Hasql/Pool.hs b/library/Hasql/Pool.hs index c3432a3..8b74090 100644 --- a/library/Hasql/Pool.hs +++ b/library/Hasql/Pool.hs @@ -23,6 +23,8 @@ data ReuseConnection = Keep | Close data Pool = Pool { -- | Connection settings. poolFetchConnectionSettings :: IO Connection.Settings, + -- | Acquisition timeout, in microseconds. + poolAcquisitionTimeout :: Maybe Int, -- | Avail connections. poolConnectionQueue :: TQueue Connection, -- | Remaining capacity. @@ -38,9 +40,9 @@ data Pool = Pool -- -- No connections actually get established by this function. It is delegated -- to 'use'. -acquire :: Int -> Connection.Settings -> IO Pool -acquire poolSize connectionSettings = - acquireDynamically poolSize (pure connectionSettings) +acquire :: Int -> Maybe Int -> 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. @@ -50,9 +52,9 @@ acquire poolSize connectionSettings = -- -- In difference to 'acquire' new settings get fetched each time a connection -- is created. This may be useful for some security models. -acquireDynamically :: Int -> IO Connection.Settings -> IO Pool -acquireDynamically poolSize fetchConnectionSettings = do - Pool fetchConnectionSettings +acquireDynamically :: Int -> Maybe Int -> IO Connection.Settings -> IO Pool +acquireDynamically poolSize timeout fetchConnectionSettings = do + Pool fetchConnectionSettings timeout <$> newTQueueIO <*> newTVarIO poolSize <*> (newTVarIO =<< newTVarIO Keep) @@ -79,7 +81,13 @@ release Pool {..} = -- and a slot gets freed up for a new connection to be established the next -- time one is needed. The error still gets returned from this function. use :: Pool -> Session.Session a -> IO (Either UsageError a) -use Pool {..} sess = +use Pool {..} sess = do + timeout <- case poolAcquisitionTimeout of + Just delta -> do + delay <- registerDelay delta + return $ readTVar delay + Nothing -> + return $ return False join . atomically $ do reuseToggle <- readTVar poolReuseToggle asum @@ -90,7 +98,12 @@ use Pool {..} sess = then do writeTVar poolCapacity $! pred capVal return $ onNewConn reuseToggle - else retry + else retry, + do + timedOut <- timeout + if timedOut + then return . return . Left $ AcquisitionTimeout + else retry ] where onNewConn reuseToggle = do @@ -130,6 +143,8 @@ data UsageError ConnectionUsageError Connection.ConnectionError | -- | Session execution failed. SessionUsageError Session.QueryError + | -- | Timeout acquiring a connection. + AcquisitionTimeout deriving (Show, Eq) instance Exception UsageError diff --git a/test/Main.hs b/test/Main.hs index b2efcb9..d80c91a 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -8,28 +8,29 @@ import qualified Hasql.Session as Session import qualified Hasql.Statement as Statement import Test.Hspec import Prelude +import Control.Concurrent.Async (race) main = hspec $ do describe "" $ do it "Releases a spot in the pool when there is a query error" $ do - pool <- acquire 1 connectionSettings + pool <- acquire 1 Nothing connectionSettings use pool badQuerySession `shouldNotReturn` (Right ()) use pool selectOneSession `shouldReturn` (Right 1) it "Simulation of connection error works" $ do - pool <- acquire 3 connectionSettings + pool <- acquire 3 Nothing connectionSettings res <- use pool $ closeConnSession >> selectOneSession shouldSatisfy res $ \case Left (SessionUsageError (Session.QueryError _ _ (Session.ClientError _))) -> True _ -> False it "Connection errors cause eviction of connection" $ do - pool <- acquire 3 connectionSettings + pool <- acquire 3 Nothing connectionSettings res <- use pool $ closeConnSession >> selectOneSession res <- use pool $ closeConnSession >> selectOneSession res <- use pool $ closeConnSession >> selectOneSession res <- use pool $ selectOneSession shouldSatisfy res $ isRight it "Connection gets returned to the pool after normal use" $ do - pool <- acquire 3 connectionSettings + pool <- acquire 3 Nothing connectionSettings res <- use pool $ selectOneSession res <- use pool $ selectOneSession res <- use pool $ selectOneSession @@ -37,7 +38,7 @@ main = hspec $ do res <- use pool $ selectOneSession shouldSatisfy res $ isRight it "Connection gets returned to the pool after non-connection error" $ do - pool <- acquire 3 connectionSettings + pool <- acquire 3 Nothing connectionSettings res <- use pool $ badQuerySession res <- use pool $ badQuerySession res <- use pool $ badQuerySession @@ -45,13 +46,13 @@ main = hspec $ do res <- use pool $ selectOneSession shouldSatisfy res $ isRight it "The pool remains usable after release" $ do - pool <- acquire 1 connectionSettings + 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 connectionSettings + pool <- acquire 1 Nothing connectionSettings res <- use pool $ getSettingSession "testing.foo" res `shouldBe` Right Nothing res <- use pool $ do @@ -59,18 +60,32 @@ main = hspec $ do getSettingSession "testing.foo" res `shouldBe` Right (Just "hello world") it "Session variables stay set when a connection gets reused" $ do - pool <- acquire 1 connectionSettings + pool <- acquire 1 Nothing connectionSettings res <- use pool $ setSettingSession "testing.foo" "hello world" res `shouldBe` Right () res2 <- use pool $ getSettingSession "testing.foo" res2 `shouldBe` Right (Just "hello world") it "Releasing the pool resets session variables" $ do - pool <- acquire 1 connectionSettings + pool <- acquire 1 Nothing connectionSettings res <- use pool $ setSettingSession "testing.foo" "hello world" res `shouldBe` Right () release pool res <- use pool $ getSettingSession "testing.foo" res `shouldBe` Right Nothing + 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) + t1 <- getCurrentTime + res `shouldBe` Right (Left AcquisitionTimeout) + diffUTCTime t1 t0 `shouldSatisfy` (< 0.5) -- 0.5s connectionSettings :: Connection.Settings connectionSettings = From 74d2de086369082da43b52b86012d561b88464c9 Mon Sep 17 00:00:00 2001 From: Nikita Volkov Date: Mon, 29 Aug 2022 15:18:41 +0300 Subject: [PATCH 16/25] Remove the build script Since it better be local to the dev environment --- build.bash | 50 -------------------------------------------------- 1 file changed, 50 deletions(-) delete mode 100755 build.bash 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 From 624ffecd9558d22c93f1ef864854f1c9a3cd1de9 Mon Sep 17 00:00:00 2001 From: Nikita Volkov Date: Mon, 29 Aug 2022 15:45:29 +0300 Subject: [PATCH 17/25] Remove the build script Since it better be local to the dev environment --- build.bash | 50 -------------------------------------------------- 1 file changed, 50 deletions(-) delete mode 100755 build.bash 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 From aa8a4e02a0355cfc7af5909249ce15ac2dbe52b0 Mon Sep 17 00:00:00 2001 From: Nikita Volkov Date: Mon, 29 Aug 2022 15:44:56 +0300 Subject: [PATCH 18/25] Format with Ormolu --- test/Main.hs | 22 ++++++++++++---------- 1 file changed, 12 insertions(+), 10 deletions(-) diff --git a/test/Main.hs b/test/Main.hs index 70c0657..f21d3d4 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -1,19 +1,19 @@ module Main where +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 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 connectionSettings use pool badQuerySession `shouldNotReturn` (Right ()) @@ -49,13 +49,15 @@ main = do shouldSatisfy res $ isRight 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 From 48bac0c2d5b2f9b16f25522dacd81a99cfa47421 Mon Sep 17 00:00:00 2001 From: Nikita Volkov Date: Mon, 29 Aug 2022 16:12:22 +0300 Subject: [PATCH 19/25] Apply Ormolu formatting and conform error naming to convention --- library/Hasql/Pool.hs | 12 ++++++------ test/Main.hs | 22 +++++++++++++--------- 2 files changed, 19 insertions(+), 15 deletions(-) diff --git a/library/Hasql/Pool.hs b/library/Hasql/Pool.hs index 8b74090..cbcd687 100644 --- a/library/Hasql/Pool.hs +++ b/library/Hasql/Pool.hs @@ -99,11 +99,11 @@ use Pool {..} sess = do writeTVar poolCapacity $! pred capVal return $ onNewConn reuseToggle else retry, - do - timedOut <- timeout - if timedOut - then return . return . Left $ AcquisitionTimeout - else retry + do + timedOut <- timeout + if timedOut + then return . return . Left $ AcquisitionTimeoutUsageError + else retry ] where onNewConn reuseToggle = do @@ -144,7 +144,7 @@ data UsageError | -- | Session execution failed. SessionUsageError Session.QueryError | -- | Timeout acquiring a connection. - AcquisitionTimeout + AcquisitionTimeoutUsageError deriving (Show, Eq) instance Exception UsageError diff --git a/test/Main.hs b/test/Main.hs index d80c91a..bcfae6f 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -1,5 +1,6 @@ module Main where +import Control.Concurrent.Async (race) import qualified Hasql.Connection as Connection import qualified Hasql.Decoders as Decoders import qualified Hasql.Encoders as Encoders @@ -8,7 +9,6 @@ import qualified Hasql.Session as Session import qualified Hasql.Statement as Statement import Test.Hspec import Prelude -import Control.Concurrent.Async (race) main = hspec $ do describe "" $ do @@ -76,15 +76,19 @@ main = hspec $ 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 connectionSettings :: Connection.Settings From 387fa5d5fb168fd706d82c997759aebd865de6ff Mon Sep 17 00:00:00 2001 From: Nikita Volkov Date: Mon, 29 Aug 2022 16:16:18 +0300 Subject: [PATCH 20/25] Update the docs --- library/Hasql/Pool.hs | 29 +++++++++++++++++++++-------- 1 file changed, 21 insertions(+), 8 deletions(-) diff --git a/library/Hasql/Pool.hs b/library/Hasql/Pool.hs index cbcd687..0989bcb 100644 --- a/library/Hasql/Pool.hs +++ b/library/Hasql/Pool.hs @@ -36,23 +36,36 @@ data Pool = Pool poolReuseToggle :: TVar (TVar ReuseConnection) } --- | 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 settings. + IO Connection.Settings -> + IO Pool acquireDynamically poolSize timeout fetchConnectionSettings = do Pool fetchConnectionSettings timeout <$> newTQueueIO From 705ad2a5235de8205f0216c36749052daa5ec7b4 Mon Sep 17 00:00:00 2001 From: Nikita Volkov Date: Mon, 29 Aug 2022 16:26:15 +0300 Subject: [PATCH 21/25] Update the changelog and bump --- CHANGELOG.md | 12 ++++++++++++ hasql-pool.cabal | 2 +- 2 files changed, 13 insertions(+), 1 deletion(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 96e35c2..8b145e5 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,15 @@ +# 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 Added support for dynamic connection configuration ([issue #11](https://github.com/nikita-volkov/hasql-pool/issues/11)). diff --git a/hasql-pool.cabal b/hasql-pool.cabal index b34b10e..c2ec894 100644 --- a/hasql-pool.cabal +++ b/hasql-pool.cabal @@ -1,7 +1,7 @@ cabal-version: 3.0 name: hasql-pool -version: 0.7.2.1 +version: 0.8 category: Hasql, Database, PostgreSQL synopsis: Pool of connections for Hasql From 971afa9796b5418caad12a9b180e802d29fdb5b2 Mon Sep 17 00:00:00 2001 From: Nikita Volkov Date: Mon, 29 Aug 2022 16:56:33 +0300 Subject: [PATCH 22/25] Refine docs --- library/Hasql/Pool.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/library/Hasql/Pool.hs b/library/Hasql/Pool.hs index 0989bcb..64be7a1 100644 --- a/library/Hasql/Pool.hs +++ b/library/Hasql/Pool.hs @@ -19,7 +19,7 @@ import qualified Hasql.Session as Session data ReuseConnection = Keep | Close --- | A pool of connections to DB. +-- | Pool of connections to DB. data Pool = Pool { -- | Connection settings. poolFetchConnectionSettings :: IO Connection.Settings, @@ -63,7 +63,7 @@ acquireDynamically :: Int -> -- | Connection acquisition timeout. Maybe Int -> - -- | Action fetching connection settings settings. + -- | Action fetching connection settings. IO Connection.Settings -> IO Pool acquireDynamically poolSize timeout fetchConnectionSettings = do From 49518cb2553ba96d7e7595ea30a6f7c122ffa87a Mon Sep 17 00:00:00 2001 From: Nikita Volkov Date: Mon, 29 Aug 2022 16:56:55 +0300 Subject: [PATCH 23/25] Bump --- hasql-pool.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/hasql-pool.cabal b/hasql-pool.cabal index c2ec894..fdd972b 100644 --- a/hasql-pool.cabal +++ b/hasql-pool.cabal @@ -1,7 +1,7 @@ cabal-version: 3.0 name: hasql-pool -version: 0.8 +version: 0.8.0.1 category: Hasql, Database, PostgreSQL synopsis: Pool of connections for Hasql From bbdec40300137d3bdb784e4622fc15a11d3986db Mon Sep 17 00:00:00 2001 From: Robert Vollmert Date: Tue, 30 Aug 2022 15:24:15 +0200 Subject: [PATCH 24/25] Comment fix --- CHANGELOG.md | 4 ++++ hasql-pool.cabal | 2 +- library/Hasql/Pool.hs | 2 +- 3 files changed, 6 insertions(+), 2 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 8b145e5..fb1d8f8 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,7 @@ +# 0.8.0.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. diff --git a/hasql-pool.cabal b/hasql-pool.cabal index fdd972b..8bed580 100644 --- a/hasql-pool.cabal +++ b/hasql-pool.cabal @@ -1,7 +1,7 @@ cabal-version: 3.0 name: hasql-pool -version: 0.8.0.1 +version: 0.8.0.2 category: Hasql, Database, PostgreSQL synopsis: Pool of connections for Hasql diff --git a/library/Hasql/Pool.hs b/library/Hasql/Pool.hs index 64be7a1..af4b4a3 100644 --- a/library/Hasql/Pool.hs +++ b/library/Hasql/Pool.hs @@ -29,7 +29,7 @@ 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, -- | Whether to return a connection to the pool. From a0ca8531be780bc0af7abebc00432ee920b85ae4 Mon Sep 17 00:00:00 2001 From: Robert Vollmert Date: Tue, 30 Aug 2022 13:26:08 +0200 Subject: [PATCH 25/25] Drop ReuseConnection type to avoid name ambiguity, fixing Windows build Somehow, we import GHC.Event.Windows.ConsoleEvent.Close on Windows via Hasql.Pool.Prelude, which conflicts with Close. --- library/Hasql/Pool.hs | 34 ++++++++++++++++------------------ 1 file changed, 16 insertions(+), 18 deletions(-) diff --git a/library/Hasql/Pool.hs b/library/Hasql/Pool.hs index af4b4a3..1c705bb 100644 --- a/library/Hasql/Pool.hs +++ b/library/Hasql/Pool.hs @@ -17,8 +17,6 @@ import Hasql.Pool.Prelude import Hasql.Session (Session) import qualified Hasql.Session as Session -data ReuseConnection = Keep | Close - -- | Pool of connections to DB. data Pool = Pool { -- | Connection settings. @@ -33,7 +31,7 @@ data Pool = Pool -- connections. poolCapacity :: TVar Int, -- | Whether to return a connection to the pool. - poolReuseToggle :: TVar (TVar ReuseConnection) + poolReuse :: TVar (TVar Bool) } -- | Create a connection-pool. @@ -70,7 +68,7 @@ acquireDynamically poolSize timeout fetchConnectionSettings = do Pool fetchConnectionSettings timeout <$> newTQueueIO <*> newTVarIO poolSize - <*> (newTVarIO =<< newTVarIO Keep) + <*> (newTVarIO =<< newTVarIO True) -- | 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 @@ -78,10 +76,10 @@ acquireDynamically poolSize timeout fetchConnectionSettings = do release :: Pool -> IO () release Pool {..} = join . atomically $ do - prevReuseToggle <- readTVar poolReuseToggle - writeTVar prevReuseToggle Close - newReuseToggle <- newTVar Keep - writeTVar poolReuseToggle newReuseToggle + prevReuse <- readTVar poolReuse + writeTVar prevReuse False + newReuse <- newTVar True + writeTVar poolReuse newReuse conns <- flushTQueue poolConnectionQueue modifyTVar' poolCapacity (+ (length conns)) return $ forM_ conns Connection.release @@ -102,15 +100,15 @@ use Pool {..} sess = do Nothing -> return $ return False join . atomically $ do - reuseToggle <- readTVar poolReuseToggle + reuseVar <- readTVar poolReuse asum - [ readTQueue poolConnectionQueue <&> onConn reuseToggle, + [ readTQueue poolConnectionQueue <&> onConn reuseVar, do capVal <- readTVar poolCapacity if capVal > 0 then do writeTVar poolCapacity $! pred capVal - return $ onNewConn reuseToggle + return $ onNewConn reuseVar else retry, do timedOut <- timeout @@ -119,15 +117,15 @@ use Pool {..} sess = do else retry ] where - onNewConn reuseToggle = 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 reuseToggle conn - onConn reuseToggle conn = do + Right conn -> onConn reuseVar conn + onConn reuseVar conn = do sessRes <- Session.run sess conn case sessRes of Left err -> case err of @@ -143,10 +141,10 @@ use Pool {..} sess = do where returnConn = join . atomically $ do - reuse <- readTVar reuseToggle - case reuse of - Keep -> writeTQueue poolConnectionQueue conn $> return () - Close -> do + reuse <- readTVar reuseVar + if reuse + then writeTQueue poolConnectionQueue conn $> return () + else do modifyTVar' poolCapacity succ return $ Connection.release conn