From cbea968ac4b298d129fc103ccdf8cdf824359db8 Mon Sep 17 00:00:00 2001 From: Nikita Volkov Date: Sat, 20 Apr 2024 13:22:26 +0300 Subject: [PATCH 1/3] Update the actions --- .github/workflows/check.yaml | 5 ++++- .github/workflows/on-push-to-master-or-pr.yaml | 2 +- .github/workflows/on-push-to-release.yaml | 4 ++-- 3 files changed, 7 insertions(+), 4 deletions(-) diff --git a/.github/workflows/check.yaml b/.github/workflows/check.yaml index 6a7c0e0..e454bb4 100644 --- a/.github/workflows/check.yaml +++ b/.github/workflows/check.yaml @@ -13,8 +13,10 @@ jobs: include: - ghc: 8.10.1 ghc-options: "" - ignore-haddock: "true" + ignore-haddock: true + ignore-cabal-check: true - ghc: latest + ignore-cabal-check: true runs-on: ubuntu-latest @@ -40,3 +42,4 @@ jobs: ghc: ${{matrix.ghc}} ghc-options: ${{matrix.ghc-options}} ignore-haddock: ${{matrix.ignore-haddock}} + ignore-cabal-check: ${{matrix.ignore-cabal-check}} diff --git a/.github/workflows/on-push-to-master-or-pr.yaml b/.github/workflows/on-push-to-master-or-pr.yaml index 7e14ae2..4a8dd27 100644 --- a/.github/workflows/on-push-to-master-or-pr.yaml +++ b/.github/workflows/on-push-to-master-or-pr.yaml @@ -7,7 +7,7 @@ on: jobs: format: - uses: nikita-volkov/haskell-hackage-lib-github-actions-workflows/.github/workflows/format.yaml@v1 + uses: nikita-volkov/haskell-hackage-lib-github-actions-workflows/.github/workflows/format.yaml@v3 secrets: inherit check: diff --git a/.github/workflows/on-push-to-release.yaml b/.github/workflows/on-push-to-release.yaml index 19636d0..1e89639 100644 --- a/.github/workflows/on-push-to-release.yaml +++ b/.github/workflows/on-push-to-release.yaml @@ -13,7 +13,7 @@ concurrency: jobs: format: - uses: nikita-volkov/haskell-hackage-lib-github-actions-workflows/.github/workflows/format.yaml@v1 + uses: nikita-volkov/haskell-hackage-lib-github-actions-workflows/.github/workflows/format.yaml@v3 secrets: inherit check: @@ -24,7 +24,7 @@ jobs: needs: - format - check - uses: nikita-volkov/haskell-hackage-lib-github-actions-workflows/.github/workflows/release.yaml@v1 + uses: nikita-volkov/haskell-hackage-lib-github-actions-workflows/.github/workflows/release.yaml@v3 secrets: inherit with: prefix-tag-with-v: false From ad9f2d6bf13b751a4ded3b95f2bd8ce7ad008385 Mon Sep 17 00:00:00 2001 From: nikita-volkov Date: Sat, 20 Apr 2024 10:23:08 +0000 Subject: [PATCH 2/3] Format --- hasql.cabal | 152 ++++++++++++++++++++++++++++------------------------ 1 file changed, 81 insertions(+), 71 deletions(-) diff --git a/hasql.cabal b/hasql.cabal index c7c2719..c849200 100644 --- a/hasql.cabal +++ b/hasql.cabal @@ -1,34 +1,32 @@ -cabal-version: 3.0 -name: hasql -version: 1.6.4.3 -category: Hasql, Database, PostgreSQL -synopsis: An efficient PostgreSQL driver with a flexible mapping API +cabal-version: 3.0 +name: hasql +version: 1.6.4.3 +category: Hasql, Database, PostgreSQL +synopsis: An efficient PostgreSQL driver with a flexible mapping API description: Root of the \"hasql\" ecosystem. For details and tutorials see . The API comes free from all kinds of exceptions. All error-reporting is explicit and is presented using the 'Either' type. -homepage: https://github.com/nikita-volkov/hasql -bug-reports: https://github.com/nikita-volkov/hasql/issues -author: Nikita Volkov -maintainer: Nikita Volkov -copyright: (c) 2014, Nikita Volkov -license: MIT -license-file: LICENSE +homepage: https://github.com/nikita-volkov/hasql +bug-reports: https://github.com/nikita-volkov/hasql/issues +author: Nikita Volkov +maintainer: Nikita Volkov +copyright: (c) 2014, Nikita Volkov +license: MIT +license-file: LICENSE extra-source-files: CHANGELOG.md README.md source-repository head - type: git + type: git location: git://github.com/nikita-volkov/hasql.git common base - default-language: Haskell2010 + default-language: Haskell2010 default-extensions: - NoImplicitPrelude - NoMonomorphismRestriction Arrows BangPatterns ConstraintKinds @@ -51,6 +49,8 @@ common base MagicHash MultiParamTypeClasses MultiWayIf + NoImplicitPrelude + NoMonomorphismRestriction OverloadedStrings ParallelListComp PatternGuards @@ -67,17 +67,23 @@ common base UnboxedTuples common executable - import: base + import: base ghc-options: - -O2 -threaded -with-rtsopts=-N -rtsopts -funbox-strict-fields + -O2 + -threaded + -with-rtsopts=-N + -rtsopts + -funbox-strict-fields common test - import: base - ghc-options: -threaded -with-rtsopts=-N + import: base + ghc-options: + -threaded + -with-rtsopts=-N library - import: base - hs-source-dirs: library + import: base + hs-source-dirs: library exposed-modules: Hasql.Connection Hasql.Decoders @@ -108,33 +114,33 @@ library Hasql.Settings build-depends: - , aeson >=2 && <3 - , attoparsec >=0.10 && <0.15 - , base >=4.14 && <5 - , bytestring >=0.10 && <0.13 - , bytestring-strict-builder >=0.4.5.1 && <0.5 - , contravariant >=1.3 && <2 - , dlist >=0.8 && <0.9 || >=1 && <2 - , hashable >=1.2 && <2 - , hashtables >=1.1 && <2 - , mtl >=2 && <3 - , network-ip >=0.3.0.3 && <0.4 - , postgresql-binary >=0.13.1 && <0.14 - , postgresql-libpq >=0.9 && <0.11 - , profunctors >=5.1 && <6 - , scientific >=0.3 && <0.4 - , text >=1 && <3 - , text-builder >=0.6.7 && <0.7 - , time >=1.9 && <2 - , transformers >=0.3 && <0.7 - , uuid >=1.3 && <2 - , vector >=0.10 && <0.14 + aeson >=2 && <3, + attoparsec >=0.10 && <0.15, + base >=4.14 && <5, + bytestring >=0.10 && <0.13, + bytestring-strict-builder >=0.4.5.1 && <0.5, + contravariant >=1.3 && <2, + dlist >=0.8 && <0.9 || >=1 && <2, + hashable >=1.2 && <2, + hashtables >=1.1 && <2, + mtl >=2 && <3, + network-ip >=0.3.0.3 && <0.4, + postgresql-binary >=0.13.1 && <0.14, + postgresql-libpq >=0.9 && <0.11, + profunctors >=5.1 && <6, + scientific >=0.3 && <0.4, + text >=1 && <3, + text-builder >=0.6.7 && <0.7, + time >=1.9 && <2, + transformers >=0.3 && <0.7, + uuid >=1.3 && <2, + vector >=0.10 && <0.14, test-suite tasty - import: base - type: exitcode-stdio-1.0 + import: base + type: exitcode-stdio-1.0 hs-source-dirs: tasty - main-is: Main.hs + main-is: Main.hs other-modules: Main.Connection Main.DSL @@ -142,40 +148,44 @@ test-suite tasty Main.Statements build-depends: - , contravariant-extras >=0.3.5.2 && <0.4 - , hasql - , quickcheck-instances >=0.3.11 && <0.4 - , rerebase <2 - , tasty >=0.12 && <2 - , tasty-hunit >=0.9 && <0.11 - , tasty-quickcheck >=0.9 && <0.11 + contravariant-extras >=0.3.5.2 && <0.4, + hasql, + quickcheck-instances >=0.3.11 && <0.4, + rerebase <2, + tasty >=0.12 && <2, + tasty-hunit >=0.9 && <0.11, + tasty-quickcheck >=0.9 && <0.11, test-suite threads-test - import: test - type: exitcode-stdio-1.0 + import: test + type: exitcode-stdio-1.0 hs-source-dirs: threads-test - main-is: Main.hs - other-modules: Main.Statements + main-is: Main.hs + other-modules: Main.Statements build-depends: - , hasql - , rerebase + hasql, + rerebase, benchmark benchmarks - import: executable - type: exitcode-stdio-1.0 + import: executable + type: exitcode-stdio-1.0 hs-source-dirs: benchmarks - main-is: Main.hs + main-is: Main.hs build-depends: - , criterion >=1.6 && <2 - , hasql - , rerebase <2 + criterion >=1.6 && <2, + hasql, + rerebase <2, test-suite profiling - import: base - type: exitcode-stdio-1.0 + import: base + type: exitcode-stdio-1.0 hs-source-dirs: profiling - main-is: Main.hs - ghc-options: -O2 -threaded -rtsopts + main-is: Main.hs + ghc-options: + -O2 + -threaded + -rtsopts + build-depends: - , hasql - , rerebase >=1 && <2 + hasql, + rerebase >=1 && <2, From 463559446dec3d4738eb044cf6c8cb03c564fae8 Mon Sep 17 00:00:00 2001 From: Nikita Volkov Date: Sat, 20 Apr 2024 13:46:51 +0300 Subject: [PATCH 3/3] Isolate testing utils --- hasql.cabal | 12 +++- tasty/Main.hs | 78 ++++++++++----------- tasty/Main/DSL.hs | 42 ----------- testing-utils/Hasql/TestingUtils/Session.hs | 45 ++++++++++++ 4 files changed, 95 insertions(+), 82 deletions(-) delete mode 100644 tasty/Main/DSL.hs create mode 100644 testing-utils/Hasql/TestingUtils/Session.hs diff --git a/hasql.cabal b/hasql.cabal index c849200..4ea6717 100644 --- a/hasql.cabal +++ b/hasql.cabal @@ -136,6 +136,16 @@ library uuid >=1.3 && <2, vector >=0.10 && <0.14, +library testing-utils + import: base + hs-source-dirs: testing-utils + exposed-modules: + Hasql.TestingUtils.Session + + build-depends: + hasql, + rerebase <2, + test-suite tasty import: base type: exitcode-stdio-1.0 @@ -143,13 +153,13 @@ test-suite tasty main-is: Main.hs other-modules: Main.Connection - Main.DSL Main.Prelude Main.Statements build-depends: contravariant-extras >=0.3.5.2 && <0.4, hasql, + hasql:testing-utils, quickcheck-instances >=0.3.11 && <0.4, rerebase <2, tasty >=0.12 && <2, diff --git a/tasty/Main.hs b/tasty/Main.hs index 05626ae..0dff5c2 100644 --- a/tasty/Main.hs +++ b/tasty/Main.hs @@ -5,8 +5,8 @@ import Hasql.Decoders qualified as Decoders import Hasql.Encoders qualified as Encoders import Hasql.Session qualified as Session import Hasql.Statement qualified as Statement +import Hasql.TestingUtils.Session qualified as Session import Main.Connection qualified as Connection -import Main.DSL qualified as DSL import Main.Prelude hiding (assert) import Main.Statements qualified as Statements import Test.QuickCheck.Instances () @@ -136,19 +136,19 @@ tree = assertEqual (show x) (Right (Right ((1, True), ("hello", 3)))) x, testGroup "unknownEnum" $ [ testCase "" $ do - res <- DSL.session $ do + res <- Session.runSession $ do let statement = Statement.Statement sql mempty Decoders.noResult True where sql = "drop type if exists mood" - in DSL.statement () statement + in Session.statement () statement let statement = Statement.Statement sql mempty Decoders.noResult True where sql = "create type mood as enum ('sad', 'ok', 'happy')" - in DSL.statement () statement + in Session.statement () statement let statement = Statement.Statement sql encoder decoder True where @@ -158,7 +158,7 @@ tree = (Decoders.singleRow ((Decoders.column . Decoders.nonNullable) (Decoders.enum (Just . id)))) encoder = Encoders.param (Encoders.nonNullable (Encoders.unknownEnum id)) - in DSL.statement "ok" statement + in Session.statement "ok" statement assertEqual "" (Right "ok") res ], @@ -301,12 +301,12 @@ tree = s <- Session.statement (1, 1) sumStatement Session.sql "end;" return s - in DSL.session session >>= \x -> assertEqual (show x) (Right 2) x, + in Session.runSession session >>= \x -> assertEqual (show x) (Right 2) x, testCase "Executing the same query twice" $ pure (), testCase "Interval Encoding" $ let actualIO = - DSL.session $ do + Session.runSession $ do let statement = Statement.Statement sql encoder decoder True where @@ -316,11 +316,11 @@ tree = (Decoders.singleRow ((Decoders.column . Decoders.nonNullable) (Decoders.bool))) encoder = Encoders.param (Encoders.nonNullable (Encoders.interval)) - in DSL.statement (10 :: DiffTime) statement + in Session.statement (10 :: DiffTime) statement in actualIO >>= \x -> assertEqual (show x) (Right True) x, testCase "Interval Decoding" $ let actualIO = - DSL.session $ do + Session.runSession $ do let statement = Statement.Statement sql encoder decoder True where @@ -330,11 +330,11 @@ tree = (Decoders.singleRow ((Decoders.column . Decoders.nonNullable) (Decoders.interval))) encoder = Encoders.noParams - in DSL.statement () statement + in Session.statement () statement in actualIO >>= \x -> assertEqual (show x) (Right (10 :: DiffTime)) x, testCase "Interval Encoding/Decoding" $ let actualIO = - DSL.session $ do + Session.runSession $ do let statement = Statement.Statement sql encoder decoder True where @@ -344,23 +344,23 @@ tree = (Decoders.singleRow ((Decoders.column . Decoders.nonNullable) (Decoders.interval))) encoder = Encoders.param (Encoders.nonNullable (Encoders.interval)) - in DSL.statement (10 :: DiffTime) statement + in Session.statement (10 :: DiffTime) statement in actualIO >>= \x -> assertEqual (show x) (Right (10 :: DiffTime)) x, testCase "Unknown" $ let actualIO = - DSL.session $ do + Session.runSession $ do let statement = Statement.Statement sql mempty Decoders.noResult True where sql = "drop type if exists mood" - in DSL.statement () statement + in Session.statement () statement let statement = Statement.Statement sql mempty Decoders.noResult True where sql = "create type mood as enum ('sad', 'ok', 'happy')" - in DSL.statement () statement + in Session.statement () statement let statement = Statement.Statement sql encoder decoder True where @@ -370,23 +370,23 @@ tree = (Decoders.singleRow ((Decoders.column . Decoders.nonNullable) (Decoders.bool))) encoder = Encoders.param (Encoders.nonNullable (Encoders.unknown)) - in DSL.statement "ok" statement + in Session.statement "ok" statement in actualIO >>= assertEqual "" (Right True), testCase "Textual Unknown" $ let actualIO = - DSL.session $ do + Session.runSession $ do let statement = Statement.Statement sql mempty Decoders.noResult True where sql = "create or replace function overloaded(a int, b int) returns int as $$ select a + b $$ language sql;" - in DSL.statement () statement + in Session.statement () statement let statement = Statement.Statement sql mempty Decoders.noResult True where sql = "create or replace function overloaded(a text, b text, c text) returns text as $$ select a || b || c $$ language sql;" - in DSL.statement () statement + in Session.statement () statement let statement = Statement.Statement sql encoder decoder True where @@ -396,23 +396,23 @@ tree = (Decoders.singleRow ((Decoders.column . Decoders.nonNullable) (Decoders.text))) encoder = contramany (Encoders.param (Encoders.nonNullable (Encoders.unknown))) - in DSL.statement ["1", "2", "4", "5", "6"] statement + in Session.statement ["1", "2", "4", "5", "6"] statement in actualIO >>= assertEqual "" (Right "3456"), testCase "Enum" $ let actualIO = - DSL.session $ do + Session.runSession $ do let statement = Statement.Statement sql mempty Decoders.noResult True where sql = "drop type if exists mood" - in DSL.statement () statement + in Session.statement () statement let statement = Statement.Statement sql mempty Decoders.noResult True where sql = "create type mood as enum ('sad', 'ok', 'happy')" - in DSL.statement () statement + in Session.statement () statement let statement = Statement.Statement sql encoder decoder True where @@ -422,13 +422,13 @@ tree = (Decoders.singleRow ((Decoders.column . Decoders.nonNullable) (Decoders.enum (Just . id)))) encoder = Encoders.param (Encoders.nonNullable ((Encoders.enum id))) - in DSL.statement "ok" statement + in Session.statement "ok" statement in actualIO >>= assertEqual "" (Right "ok"), testCase "The same prepared statement used on different types" $ let actualIO = - DSL.session $ do + Session.runSession $ do let effect1 = - DSL.statement "ok" statement + Session.statement "ok" statement where statement = Statement.Statement sql encoder decoder True @@ -440,7 +440,7 @@ tree = decoder = (Decoders.singleRow ((Decoders.column . Decoders.nonNullable) (Decoders.text))) effect2 = - DSL.statement 1 statement + Session.statement 1 statement where statement = Statement.Statement sql encoder decoder True @@ -456,26 +456,26 @@ tree = testCase "Affected rows counting" $ replicateM_ 13 $ let actualIO = - DSL.session $ do + Session.runSession $ do dropTable createTable replicateM_ 100 insertRow deleteRows <* dropTable where dropTable = - DSL.statement () + Session.statement () $ Statements.plain $ "drop table if exists a" createTable = - DSL.statement () + Session.statement () $ Statements.plain $ "create table a (id bigserial not null, name varchar not null, primary key (id))" insertRow = - DSL.statement () + Session.statement () $ Statements.plain $ "insert into a (name) values ('a')" deleteRows = - DSL.statement () $ Statement.Statement sql mempty decoder False + Session.statement () $ Statement.Statement sql mempty decoder False where sql = "delete from a" @@ -484,16 +484,16 @@ tree = in actualIO >>= assertEqual "" (Right 100), testCase "Result of an auto-incremented column" $ let actualIO = - DSL.session $ do - DSL.statement () $ Statements.plain $ "drop table if exists a" - DSL.statement () $ Statements.plain $ "create table a (id serial not null, v char not null, primary key (id))" - id1 <- DSL.statement () $ Statement.Statement "insert into a (v) values ('a') returning id" mempty (Decoders.singleRow ((Decoders.column . Decoders.nonNullable) Decoders.int4)) False - id2 <- DSL.statement () $ Statement.Statement "insert into a (v) values ('b') returning id" mempty (Decoders.singleRow ((Decoders.column . Decoders.nonNullable) Decoders.int4)) False - DSL.statement () $ Statements.plain $ "drop table if exists a" + Session.runSession $ do + Session.statement () $ Statements.plain $ "drop table if exists a" + Session.statement () $ Statements.plain $ "create table a (id serial not null, v char not null, primary key (id))" + id1 <- Session.statement () $ Statement.Statement "insert into a (v) values ('a') returning id" mempty (Decoders.singleRow ((Decoders.column . Decoders.nonNullable) Decoders.int4)) False + id2 <- Session.statement () $ Statement.Statement "insert into a (v) values ('b') returning id" mempty (Decoders.singleRow ((Decoders.column . Decoders.nonNullable) Decoders.int4)) False + Session.statement () $ Statements.plain $ "drop table if exists a" pure (id1, id2) in assertEqual "" (Right (1, 2)) =<< actualIO, testCase "List decoding" $ let actualIO = - DSL.session $ DSL.statement () $ Statements.selectList + Session.runSession $ Session.statement () $ Statements.selectList in assertEqual "" (Right [(1, 2), (3, 4), (5, 6)]) =<< actualIO ] diff --git a/tasty/Main/DSL.hs b/tasty/Main/DSL.hs deleted file mode 100644 index f964157..0000000 --- a/tasty/Main/DSL.hs +++ /dev/null @@ -1,42 +0,0 @@ -module Main.DSL - ( Session, - SessionError (..), - session, - Hasql.Session.statement, - Hasql.Session.sql, - ) -where - -import Hasql.Connection qualified as HC -import Hasql.Session qualified -import Main.Prelude - -type Session = - Hasql.Session.Session - -data SessionError - = ConnectionError (HC.ConnectionError) - | SessionError (Hasql.Session.QueryError) - deriving (Show, Eq) - -session :: Session a -> IO (Either SessionError a) -session session = - runExceptT $ acquire >>= \connection -> use connection <* release connection - where - acquire = - ExceptT $ fmap (mapLeft ConnectionError) $ HC.acquire settings - where - settings = - HC.settings host port user password database - where - host = "localhost" - port = 5432 - user = "postgres" - password = "postgres" - database = "postgres" - use connection = - ExceptT - $ fmap (mapLeft SessionError) - $ Hasql.Session.run session connection - release connection = - lift $ HC.release connection diff --git a/testing-utils/Hasql/TestingUtils/Session.hs b/testing-utils/Hasql/TestingUtils/Session.hs new file mode 100644 index 0000000..f9fe865 --- /dev/null +++ b/testing-utils/Hasql/TestingUtils/Session.hs @@ -0,0 +1,45 @@ +module Hasql.TestingUtils.Session + ( Session.Session, + SessionError (..), + Session.QueryError (..), + Session.CommandError (..), + runSession, + runStatementInSession, + ) +where + +import Hasql.Connection qualified as Connection +import Hasql.Session qualified as Session +import Hasql.Statement qualified as Statement +import Prelude + +data SessionError + = ConnectionError (Connection.ConnectionError) + | SessionError (Session.QueryError) + deriving (Show, Eq) + +runSession :: Session.Session a -> IO (Either SessionError a) +runSession session = + runExceptT $ acquire >>= \connection -> use connection <* release connection + where + acquire = + ExceptT $ fmap (mapLeft ConnectionError) $ Connection.acquire settings + where + settings = + Connection.settings host port user password database + where + host = "localhost" + port = 5432 + user = "postgres" + password = "postgres" + database = "postgres" + use connection = + ExceptT + $ fmap (mapLeft SessionError) + $ Session.run session connection + release connection = + lift $ Connection.release connection + +runStatementInSession :: Statement.Statement a b -> a -> Session.Session b +runStatementInSession statement params = + Session.statement params statement