hasql 1.9.3.1 → 1.9.3.2
raw patch · 22 files changed
+704/−771 lines, 22 filesdep +QuickCheckdep +unordered-containersdep −hashtablesdep −tastydep −tasty-hunitdep ~rerebasePVP ok
version bump matches the API change (PVP)
Dependencies added: QuickCheck, unordered-containers
Dependencies removed: hashtables, tasty, tasty-hunit, tasty-quickcheck
Dependency ranges changed: rerebase
API changes (from Hackage documentation)
Files
- README.md +7/−4
- hasql.cabal +14/−32
- hspec/Hasql/ConcurrencySpec.hs +44/−0
- hspec/Hasql/EncodingDecodingSpec.hs +132/−0
- hspec/Hasql/MiscSpec.hs +112/−0
- hspec/Hasql/PipelineSpec.hs +21/−19
- hspec/Hasql/SessionSpec.hs +77/−0
- hspec/Hasql/StatementSpec.hs +88/−0
- library/Hasql/Decoders/All.hs +40/−40
- library/Hasql/Decoders/Value.hs +33/−9
- library/Hasql/Encoders/Value.hs +9/−1
- library/Hasql/PreparedStatementRegistry.hs +16/−43
- library/Hasql/PreparedStatementRegistry/Map.hs +56/−0
- profiling/Main.hs +2/−19
- tasty/Main.hs +0/−473
- tasty/Main/Connection.hs +0/−16
- tasty/Main/Prelude.hs +0/−6
- tasty/Main/Statements.hs +0/−33
- testing-kit/Hasql/TestingKit/Testcontainers.hs +38/−0
- testing-kit/Hasql/TestingKit/TestingDsl.hs +15/−5
- threads-test/Main.hs +0/−54
- threads-test/Main/Statements.hs +0/−17
README.md view
@@ -1,13 +1,16 @@-# Fast PostgreSQL driver for Haskell with a flexible mapping API+# Hasql -Hasql is a highly efficient PostgreSQL driver for Haskell with a typesafe yet flexible mapping API. It targets both the users, who need maximum control, and the users who face the typical tasks of DB-powered applications, providing them with higher-level APIs. Currently it is known to be [the fastest driver](https://nikita-volkov.github.io/hasql-benchmarks/) in the Haskell ecosystem.+PostgreSQL driver for Haskell, that prioritizes: -> [!IMPORTANT]-> Hasql is one of the supported targets of the [pGenie](https://pgenie.io) code generator, which empowers it with schema and query validation, and relieves you from boilerplate.+- Performance+- Typesafety+- Flexibility+- Decentralization # Status [](https://hackage.haskell.org/package/hasql)+[](https://nikita-volkov.github.io/hasql/) Hasql is production-ready, actively maintained and the API is pretty stable. It's used by many companies and most notably by the [Postgrest](https://postgrest.org/) project.
hasql.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.0 name: hasql-version: 1.9.3.1+version: 1.9.3.2 category: Hasql, Database, PostgreSQL synopsis: Fast PostgreSQL driver with a flexible mapping API description:@@ -134,6 +134,7 @@ Hasql.PostgresTypeInfo Hasql.Prelude Hasql.PreparedStatementRegistry+ Hasql.PreparedStatementRegistry.Map Hasql.Session.Core build-depends:@@ -146,7 +147,6 @@ contravariant >=1.3 && <2, dlist >=0.8 && <0.9 || >=1 && <2, hashable >=1.2 && <2,- hashtables >=1.1 && <2, iproute >=1.7 && <1.8, mtl >=2 && <3, postgresql-binary >=0.14.2 && <0.15,@@ -157,6 +157,7 @@ text-builder >=1 && <1.1, time >=1.9 && <2, transformers >=0.6 && <0.7,+ unordered-containers >=0.2 && <0.3, uuid >=1.3 && <2, vector >=0.10 && <0.14, witherable >=0.5 && <0.6,@@ -171,45 +172,17 @@ Hasql.TestingKit.Statements.BrokenSyntax Hasql.TestingKit.Statements.GenerateSeries Hasql.TestingKit.Statements.WrongDecoder+ Hasql.TestingKit.Testcontainers Hasql.TestingKit.TestingDsl build-depends: base, bytestring, hasql,+ testcontainers-postgresql >=0.0.1 && <0.1, transformers, uuid, -test-suite tasty- import: base- type: exitcode-stdio-1.0- hs-source-dirs: tasty- main-is: Main.hs- other-modules:- Main.Connection- Main.Prelude- Main.Statements-- build-depends:- contravariant-extras >=0.3.5.2 && <0.4,- hasql,- hasql:testing-kit,- quickcheck-instances >=0.3.11 && <0.4,- rerebase <2,- tasty >=0.12 && <2,- tasty-hunit >=0.9 && <0.11,- tasty-quickcheck >=0.9 && <0.12,--test-suite threads-test- import: test- type: exitcode-stdio-1.0- hs-source-dirs: threads-test- main-is: Main.hs- other-modules: Main.Statements- build-depends:- hasql,- rerebase,- benchmark benchmarks import: executable type: exitcode-stdio-1.0@@ -232,6 +205,7 @@ build-depends: hasql,+ hasql:testing-kit, rerebase >=1 && <2, test-suite hspec@@ -240,13 +214,21 @@ hs-source-dirs: hspec main-is: Main.hs other-modules:+ Hasql.ConcurrencySpec Hasql.ConnectionSpec+ Hasql.EncodingDecodingSpec+ Hasql.MiscSpec Hasql.PipelineSpec+ Hasql.SessionSpec+ Hasql.StatementSpec build-tool-depends: hspec-discover:hspec-discover build-depends:+ QuickCheck,+ contravariant-extras >=0.3.5.2 && <0.4, hasql, hasql:testing-kit, hspec,+ quickcheck-instances >=0.3.11 && <0.4, rerebase >=1 && <2, testcontainers-postgresql >=0.0.1 && <0.1,
+ hspec/Hasql/ConcurrencySpec.hs view
@@ -0,0 +1,44 @@+module Hasql.ConcurrencySpec (spec) where++import Control.Concurrent+import Hasql.Connection qualified as Connection+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.TestingKit.Testcontainers qualified as Testcontainers+import Test.Hspec+import Prelude++spec :: Spec+spec = aroundAll Testcontainers.withConnection do+ describe "Concurrency" do+ it "handles concurrent connections properly" \_ -> do+ -- We need two separate connections for this test+ Testcontainers.withConnectionSettings \settings -> do+ connection1 <- Connection.acquire settings >>= either (fail . show) return+ connection2 <- Connection.acquire settings >>= either (fail . show) return++ let selectSleep =+ Statement.Statement+ "select pg_sleep($1)"+ (Encoders.param (Encoders.nonNullable Encoders.float8))+ Decoders.noResult+ True++ beginVar <- newEmptyMVar+ finishVar <- newEmptyMVar++ _ <- forkIO do+ putMVar beginVar ()+ _ <- Session.run (Session.statement (0.2 :: Double) selectSleep) connection1+ void (tryPutMVar finishVar False)++ _ <- forkIO do+ takeMVar beginVar+ _ <- Session.run (Session.statement (0.1 :: Double) selectSleep) connection2+ void (tryPutMVar finishVar True)++ -- The second connection should finish first (True)+ result <- takeMVar finishVar+ result `shouldBe` True
+ hspec/Hasql/EncodingDecodingSpec.hs view
@@ -0,0 +1,132 @@+module Hasql.EncodingDecodingSpec (spec) where++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.TestingKit.Testcontainers qualified as Testcontainers+import Test.Hspec+import Test.QuickCheck+import Test.QuickCheck.Instances ()+import Test.QuickCheck.Monadic (assert, monadicIO, pre, run)+import Prelude hiding (assert)++spec :: Spec+spec = aroundAll Testcontainers.withConnection do+ describe "Encoding and Decoding" do+ describe "Array roundtrips" do+ it "handles 1D arrays" \connection -> property $ \(values :: [Int64]) -> monadicIO $ do+ let statement =+ Statement.Statement+ "select $1"+ (Encoders.param (Encoders.nonNullable (Encoders.array (Encoders.dimension foldl' (Encoders.element (Encoders.nonNullable Encoders.int8))))))+ (Decoders.singleRow (Decoders.column (Decoders.nonNullable (Decoders.array (Decoders.dimension replicateM (Decoders.element (Decoders.nonNullable Decoders.int8)))))))+ True+ result <- run $ Session.run (Session.statement values statement) connection+ assert $ result == Right values++ it "handles 2D arrays" \connection -> property $ \(values :: [Int64]) -> monadicIO $ do+ pre (not (null values))+ let input = replicate 3 values+ let statement =+ Statement.Statement+ "select $1"+ (Encoders.param (Encoders.nonNullable (Encoders.array (Encoders.dimension foldl' (Encoders.dimension foldl' (Encoders.element (Encoders.nonNullable Encoders.int8)))))))+ (Decoders.singleRow (Decoders.column (Decoders.nonNullable (Decoders.array (Decoders.dimension replicateM (Decoders.dimension replicateM (Decoders.element (Decoders.nonNullable Decoders.int8))))))))+ True+ result <- run $ Session.run (Session.statement input statement) connection+ assert $ result == Right input++ describe "Composite types" do+ it "decodes simple composites" \connection -> do+ let statement =+ Statement.Statement+ "select (1, true)"+ mempty+ (Decoders.singleRow (Decoders.column (Decoders.nonNullable (Decoders.composite ((,) <$> (Decoders.field (Decoders.nonNullable Decoders.int8)) <*> (Decoders.field (Decoders.nonNullable Decoders.bool)))))))+ True+ result <- Session.run (Session.statement () statement) connection+ result `shouldBe` Right (1 :: Int64, True)++ it "decodes complex composites" \connection -> do+ let statement =+ Statement.Statement+ "select ((1, true), ('hello', 3))"+ mempty+ ( Decoders.singleRow+ ( Decoders.column+ ( Decoders.nonNullable+ ( Decoders.composite+ ( (,)+ <$> ( Decoders.field+ ( Decoders.nonNullable+ ( Decoders.composite+ ( (,)+ <$> (Decoders.field (Decoders.nonNullable Decoders.int8))+ <*> (Decoders.field (Decoders.nonNullable Decoders.bool))+ )+ )+ )+ )+ <*> ( Decoders.field+ ( Decoders.nonNullable+ ( Decoders.composite+ ( (,)+ <$> (Decoders.field (Decoders.nonNullable Decoders.text))+ <*> (Decoders.field (Decoders.nonNullable Decoders.int8))+ )+ )+ )+ )+ )+ )+ )+ )+ )+ True+ result <- Session.run (Session.statement () statement) connection+ result `shouldBe` Right ((1 :: Int64, True), ("hello", 3 :: Int64))++ describe "Enum types" do+ it "handles enum encoding and decoding" \connection -> do+ -- First create the enum type+ let dropStatement = Statement.Statement "drop type if exists mood" mempty Decoders.noResult True+ let createStatement = Statement.Statement "create type mood as enum ('sad', 'ok', 'happy')" mempty Decoders.noResult True+ let testStatement =+ Statement.Statement+ "select ($1 :: mood)"+ (Encoders.param (Encoders.nonNullable (Encoders.enum id)))+ (Decoders.singleRow (Decoders.column (Decoders.nonNullable (Decoders.enum (Just . id)))))+ True++ result <-+ Session.run+ ( do+ Session.statement () dropStatement+ Session.statement () createStatement+ Session.statement "ok" testStatement+ )+ connection+ result `shouldBe` Right "ok"++ describe "Unknown enum" do+ it "handles unknown enum encoding" \connection -> do+ -- First create the enum type+ let dropStatement = Statement.Statement "drop type if exists mood" mempty Decoders.noResult True+ let createStatement = Statement.Statement "create type mood as enum ('sad', 'ok', 'happy')" mempty Decoders.noResult True+ let testStatement =+ Statement.Statement+ "select $1"+ (Encoders.param (Encoders.nonNullable (Encoders.unknownEnum id)))+ (Decoders.singleRow (Decoders.column (Decoders.nonNullable (Decoders.enum (Just . id)))))+ True++ result <-+ Session.run+ ( do+ Session.statement () dropStatement+ Session.statement () createStatement+ Session.statement "ok" testStatement+ )+ connection+ result `shouldBe` Right "ok"
+ hspec/Hasql/MiscSpec.hs view
@@ -0,0 +1,112 @@+module Hasql.MiscSpec (spec) where++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.TestingKit.Testcontainers qualified as Testcontainers+import Test.Hspec+import Prelude++spec :: Spec+spec = aroundAll Testcontainers.withConnection do+ describe "Miscellaneous Tests" do+ describe "Interval types" do+ it "encodes intervals correctly" \connection -> do+ let statement =+ Statement.Statement+ "select $1 = interval '10 seconds'"+ (Encoders.param (Encoders.nonNullable Encoders.interval))+ (Decoders.singleRow (Decoders.column (Decoders.nonNullable Decoders.bool)))+ True+ result <- Session.run (Session.statement (10 :: DiffTime) statement) connection+ result `shouldBe` Right True++ it "decodes intervals correctly" \connection -> do+ let statement =+ Statement.Statement+ "select interval '10 seconds'"+ Encoders.noParams+ (Decoders.singleRow (Decoders.column (Decoders.nonNullable Decoders.interval)))+ True+ result <- Session.run (Session.statement () statement) connection+ result `shouldBe` Right (10 :: DiffTime)++ it "roundtrips intervals correctly" \connection -> do+ let statement =+ Statement.Statement+ "select $1"+ (Encoders.param (Encoders.nonNullable Encoders.interval))+ (Decoders.singleRow (Decoders.column (Decoders.nonNullable Decoders.interval)))+ True+ result <- Session.run (Session.statement (10 :: DiffTime) statement) connection+ result `shouldBe` Right (10 :: DiffTime)++ describe "Unknown types" do+ it "handles unknown type encoding" \connection -> do+ -- First create the enum type+ let dropStatement = Statement.Statement "drop type if exists mood" mempty Decoders.noResult True+ let createStatement = Statement.Statement "create type mood as enum ('sad', 'ok', 'happy')" mempty Decoders.noResult True+ let testStatement =+ Statement.Statement+ "select $1 = ('ok' :: mood)"+ (Encoders.param (Encoders.nonNullable Encoders.unknown))+ (Decoders.singleRow (Decoders.column (Decoders.nonNullable Decoders.bool)))+ True++ result <-+ Session.run+ ( do+ Session.statement () dropStatement+ Session.statement () createStatement+ Session.statement "ok" testStatement+ )+ connection+ result `shouldBe` Right True++ describe "Transaction-like operations" do+ it "handles in progress after error scenario" \connection -> do+ let sumStatement =+ Statement.Statement+ "select ($1 + $2)"+ ( contramap fst (Encoders.param (Encoders.nonNullable Encoders.int8))+ <> contramap snd (Encoders.param (Encoders.nonNullable Encoders.int8))+ )+ (Decoders.singleRow (Decoders.column (Decoders.nonNullable Decoders.int8)))+ True++ result <-+ Session.run+ ( do+ Session.sql "begin;"+ s <- Session.statement (1 :: Int64, 1 :: Int64) sumStatement+ Session.sql "end;"+ return s+ )+ connection+ result `shouldBe` Right (2 :: Int64)++ it "recovers properly after query errors" \connection -> do+ let tryStatement =+ Statement.Statement+ "select $1 :: int8"+ (Encoders.param (Encoders.nonNullable Encoders.int8))+ (Decoders.singleRow (Decoders.column (Decoders.nonNullable Decoders.int8)))+ True++ result <-+ Session.run+ ( do+ -- First successful query+ _ <- Session.statement (1 :: Int64) tryStatement+ -- This should fail but connection should remain usable+ _ <- catchError (Session.sql "absurd") (const (pure ()))+ -- Second successful query+ Session.statement (1 :: Int64) tryStatement+ )+ connection++ result `shouldSatisfy` isRight+ where+ isRight (Right _) = True+ isRight _ = False
hspec/Hasql/PipelineSpec.hs view
@@ -1,62 +1,64 @@ module Hasql.PipelineSpec (spec) where +import Hasql.Session qualified as Session import Hasql.TestingKit.Statements.BrokenSyntax qualified as BrokenSyntax import Hasql.TestingKit.Statements.GenerateSeries qualified as GenerateSeries import Hasql.TestingKit.Statements.WrongDecoder qualified as WrongDecoder+import Hasql.TestingKit.Testcontainers qualified as Testcontainers import Hasql.TestingKit.TestingDsl qualified as Dsl import Test.Hspec import Prelude spec :: Spec-spec = do+spec = aroundAll Testcontainers.withConnection do describe "Single-statement" do describe "Unprepared" do- it "Collects results and sends params" do+ it "Collects results and sends params" \connection -> do result <-- Dsl.runPipelineOnLocalDb+ (flip Session.run connection . Session.pipeline) $ GenerateSeries.pipeline False GenerateSeries.Params {start = 0, end = 2} shouldBe result (Right [0 .. 2]) describe "Prepared" do- it "Collects results and sends params" do+ it "Collects results and sends params" \connection -> do result <-- Dsl.runPipelineOnLocalDb+ (flip Session.run connection . Session.pipeline) $ GenerateSeries.pipeline True GenerateSeries.Params {start = 0, end = 2} shouldBe result (Right [0 .. 2]) describe "Multi-statement" do describe "On unprepared statements" do- it "Collects results and sends params" do+ it "Collects results and sends params" \connection -> do result <-- Dsl.runPipelineOnLocalDb+ (flip Session.run connection . Session.pipeline) $ replicateM 2 $ GenerateSeries.pipeline False GenerateSeries.Params {start = 0, end = 2} shouldBe result (Right [[0 .. 2], [0 .. 2]]) describe "On prepared statements" do- it "Collects results and sends params" do+ it "Collects results and sends params" \connection -> do result <-- Dsl.runPipelineOnLocalDb+ (flip Session.run connection . Session.pipeline) $ replicateM 2 $ GenerateSeries.pipeline True GenerateSeries.Params {start = 0, end = 2} shouldBe result (Right [[0 .. 2], [0 .. 2]]) describe "When a part in the middle fails" do describe "With query error" do- it "Captures the error" do+ it "Captures the error" \connection -> do result <-- Dsl.runPipelineOnLocalDb+ (flip Session.run connection . Session.pipeline) $ (,,) <$> GenerateSeries.pipeline True GenerateSeries.Params {start = 0, end = 2} <*> BrokenSyntax.pipeline True BrokenSyntax.Params {start = 0, end = 2} <*> GenerateSeries.pipeline True GenerateSeries.Params {start = 0, end = 2} case result of- Left (Dsl.SessionError (Dsl.QueryError _ _ _)) -> pure ()+ Left (Session.QueryError _ _ _) -> pure () _ -> expectationFailure $ "Unexpected result: " <> show result - it "Leaves the connection usable" do+ it "Leaves the connection usable" \connection -> do result <-- Dsl.runSessionOnLocalDb do+ (flip Session.run connection) do _ <- tryError $ Dsl.runPipelineInSession@@ -68,20 +70,20 @@ shouldBe result (Right [0]) describe "With decoding error" do- it "Captures the error" do+ it "Captures the error" \connection -> do result <-- Dsl.runPipelineOnLocalDb+ (flip Session.run connection . Session.pipeline) $ (,,) <$> GenerateSeries.pipeline True GenerateSeries.Params {start = 0, end = 2} <*> WrongDecoder.pipeline True WrongDecoder.Params {start = 0, end = 2} <*> GenerateSeries.pipeline True GenerateSeries.Params {start = 0, end = 2} case result of- Left (Dsl.SessionError (Dsl.QueryError _ _ _)) -> pure ()+ Left (Session.QueryError _ _ _) -> pure () _ -> expectationFailure $ "Unexpected result: " <> show result - it "Leaves the connection usable" do+ it "Leaves the connection usable" \connection -> do result <-- Dsl.runSessionOnLocalDb do+ (flip Session.run connection) do _ <- tryError $ Dsl.runPipelineInSession
+ hspec/Hasql/SessionSpec.hs view
@@ -0,0 +1,77 @@+module Hasql.SessionSpec (spec) where++import Contravariant.Extras+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.TestingKit.Testcontainers qualified as Testcontainers+import Test.Hspec+import Test.QuickCheck.Instances ()+import Prelude++spec :: Spec+spec = aroundAll Testcontainers.withConnection do+ describe "Basic Session Operations" do+ describe "Roundtrips" do+ it "handles simple values correctly" \connection -> do+ let statement =+ Statement.Statement+ "select $1"+ (Encoders.param (Encoders.nonNullable Encoders.int8))+ (Decoders.singleRow (Decoders.column (Decoders.nonNullable Decoders.int8)))+ True+ result <- Session.run (Session.statement (42 :: Int64) statement) connection+ result `shouldBe` Right 42++ describe "Error Handling" do+ it "captures query errors correctly" \connection -> do+ let statement =+ Statement.Statement+ "select true where 1 = any ($1) and $2"+ ( contrazip2+ (Encoders.param (Encoders.nonNullable (Encoders.array (Encoders.dimension foldl' (Encoders.element (Encoders.nonNullable Encoders.int8))))))+ (Encoders.param (Encoders.nonNullable Encoders.text))+ )+ (fmap (maybe False (const True)) (Decoders.rowMaybe (Decoders.column (Decoders.nonNullable Decoders.bool))))+ True+ result <- Session.run (Session.statement ([3, 7] :: [Int64], "a") statement) connection+ case result of+ Left (Session.QueryError "select true where 1 = any ($1) and $2" ["[3, 7]", "\"a\""] _) -> pure ()+ _ -> expectationFailure $ "Unexpected result: " <> show result++ describe "IN simulation" do+ it "works with arrays" \connection -> do+ let statement =+ Statement.Statement+ "select true where 1 = any ($1)"+ (Encoders.param (Encoders.nonNullable (Encoders.array (Encoders.dimension foldl' (Encoders.element (Encoders.nonNullable Encoders.int8))))))+ (fmap (maybe False (const True)) (Decoders.rowMaybe (Decoders.column (Decoders.nonNullable Decoders.bool))))+ True+ result <-+ Session.run+ ( do+ result1 <- Session.statement ([1, 2] :: [Int64]) statement+ result2 <- Session.statement ([2, 3] :: [Int64]) statement+ return (result1, result2)+ )+ connection+ result `shouldBe` Right (True, False)++ describe "NOT IN simulation" do+ it "works with arrays" \connection -> do+ let statement =+ Statement.Statement+ "select true where 3 <> all ($1)"+ (Encoders.param (Encoders.nonNullable (Encoders.array (Encoders.dimension foldl' (Encoders.element (Encoders.nonNullable Encoders.int8))))))+ (fmap (maybe False (const True)) (Decoders.rowMaybe (Decoders.column (Decoders.nonNullable Decoders.bool))))+ True+ result <-+ Session.run+ ( do+ result1 <- Session.statement ([1, 2] :: [Int64]) statement+ result2 <- Session.statement ([2, 3] :: [Int64]) statement+ return (result1, result2)+ )+ connection+ result `shouldBe` Right (True, False)
+ hspec/Hasql/StatementSpec.hs view
@@ -0,0 +1,88 @@+module Hasql.StatementSpec (spec) where++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.TestingKit.Testcontainers qualified as Testcontainers+import Test.Hspec+import Prelude++spec :: Spec+spec = aroundAll Testcontainers.withConnection do+ describe "Statement Functionality" do+ describe "Prepared statements" do+ it "allows reuse of the same prepared statement on different types" \connection -> do+ let statement1 =+ Statement.Statement+ "select $1"+ (Encoders.param (Encoders.nonNullable Encoders.text))+ (Decoders.singleRow (Decoders.column (Decoders.nonNullable Decoders.text)))+ True+ let statement2 =+ Statement.Statement+ "select $1"+ (Encoders.param (Encoders.nonNullable Encoders.int8))+ (Decoders.singleRow (Decoders.column (Decoders.nonNullable Decoders.int8)))+ True++ result <-+ Session.run+ ( do+ result1 <- Session.statement "ok" statement1+ result2 <- Session.statement (1 :: Int64) statement2+ return (result1, result2)+ )+ connection+ result `shouldBe` Right ("ok", 1 :: Int64)++ describe "Row counting" do+ it "counts affected rows correctly" \connection -> do+ let dropTable = Statement.Statement "drop table if exists a" mempty Decoders.noResult True+ let createTable = Statement.Statement "create table a (id bigserial not null, name varchar not null, primary key (id))" mempty Decoders.noResult True+ let insertRow = Statement.Statement "insert into a (name) values ('a')" mempty Decoders.noResult False+ let deleteRows = Statement.Statement "delete from a" mempty Decoders.rowsAffected False++ result <-+ Session.run+ ( do+ Session.statement () dropTable+ Session.statement () createTable+ replicateM_ 100 (Session.statement () insertRow)+ affectedRows <- Session.statement () deleteRows+ Session.statement () dropTable+ return affectedRows+ )+ connection+ result `shouldBe` Right 100++ describe "Auto-incremented columns" do+ it "returns auto-incremented column results" \connection -> do+ let dropTable = Statement.Statement "drop table if exists a" mempty Decoders.noResult True+ let createTable = Statement.Statement "create table a (id bigserial not null, name varchar not null, primary key (id))" mempty Decoders.noResult True+ let insertRow = Statement.Statement "insert into a (name) values ('a') returning id" mempty (Decoders.singleRow (Decoders.column (Decoders.nonNullable Decoders.int8))) False+ let insertRow2 = Statement.Statement "insert into a (name) values ('b') returning id" mempty (Decoders.singleRow (Decoders.column (Decoders.nonNullable Decoders.int8))) False++ result <-+ Session.run+ ( do+ Session.statement () dropTable+ Session.statement () createTable+ id1 <- Session.statement () insertRow+ id2 <- Session.statement () insertRow2+ Session.statement () dropTable+ return (id1, id2)+ )+ connection+ result `shouldBe` Right (1 :: Int64, 2 :: Int64)++ describe "List decoding" do+ it "decodes lists correctly" \connection -> do+ let statement =+ Statement.Statement+ "values (1,2), (3,4), (5,6)"+ mempty+ (Decoders.rowList ((,) <$> (Decoders.column (Decoders.nonNullable Decoders.int8)) <*> (Decoders.column (Decoders.nonNullable Decoders.int8))))+ True+ result <- Session.run (Session.statement () statement) connection+ result `shouldBe` Right [(1 :: Int64, 2 :: Int64), (3, 4), (5, 6)]
library/Hasql/Decoders/All.hs view
@@ -11,8 +11,8 @@ import Hasql.Decoders.Results qualified as Results import Hasql.Decoders.Row qualified as Row import Hasql.Decoders.Value qualified as Value+import Hasql.PostgresTypeInfo qualified as PTI import Hasql.Prelude hiding (bool, maybe)-import Hasql.Prelude qualified as Prelude import PostgreSQL.Binary.Decoding qualified as A import PostgreSQL.Binary.Range qualified as R @@ -138,19 +138,19 @@ -- Decoder of the @BOOL@ values. {-# INLINEABLE bool #-} bool :: Value Bool-bool = Value (Value.decoder (const A.bool))+bool = Value (Value.unsafePTI "bool" PTI.bool A.bool A.bool) -- | -- Decoder of the @INT2@ values. {-# INLINEABLE int2 #-} int2 :: Value Int16-int2 = Value (Value.decoder (const A.int))+int2 = Value (Value.unsafePTI "int2" PTI.int2 A.int A.int) -- | -- Decoder of the @INT4@ values. {-# INLINEABLE int4 #-} int4 :: Value Int32-int4 = Value (Value.decoder (const A.int))+int4 = Value (Value.unsafePTI "int4" PTI.int4 A.int A.int) -- | -- Decoder of the @INT8@ values.@@ -158,56 +158,56 @@ int8 :: Value Int64 int8 = {-# SCC "int8" #-}- Value (Value.decoder (const ({-# SCC "int8.int" #-} A.int)))+ Value (Value.unsafePTI "int8" PTI.int8 ({-# SCC "int8.int" #-} A.int) ({-# SCC "int8.int" #-} A.int)) -- | -- Decoder of the @FLOAT4@ values. {-# INLINEABLE float4 #-} float4 :: Value Float-float4 = Value (Value.decoder (const A.float4))+float4 = Value (Value.unsafePTI "float4" PTI.float4 A.float4 A.float4) -- | -- Decoder of the @FLOAT8@ values. {-# INLINEABLE float8 #-} float8 :: Value Double-float8 = Value (Value.decoder (const A.float8))+float8 = Value (Value.unsafePTI "float8" PTI.float8 A.float8 A.float8) -- | -- Decoder of the @NUMERIC@ values. {-# INLINEABLE numeric #-} numeric :: Value Scientific-numeric = Value (Value.decoder (const A.numeric))+numeric = Value (Value.unsafePTI "numeric" PTI.numeric A.numeric A.numeric) -- | -- Decoder of the @CHAR@ values. -- Note that it supports Unicode values. {-# INLINEABLE char #-} char :: Value Char-char = Value (Value.decoder (const A.char))+char = Value (Value.unsafePTI "char" PTI.char A.char A.char) -- | -- Decoder of the @TEXT@ values. {-# INLINEABLE text #-} text :: Value Text-text = Value (Value.decoder (const A.text_strict))+text = Value (Value.unsafePTI "text" PTI.text A.text_strict A.text_strict) -- | -- Decoder of the @BYTEA@ values. {-# INLINEABLE bytea #-} bytea :: Value ByteString-bytea = Value (Value.decoder (const A.bytea_strict))+bytea = Value (Value.unsafePTI "bytea" PTI.bytea A.bytea_strict A.bytea_strict) -- | -- Decoder of the @DATE@ values. {-# INLINEABLE date #-} date :: Value Day-date = Value (Value.decoder (const A.date))+date = Value (Value.unsafePTI "date" PTI.date A.date A.date) -- | -- Decoder of the @TIMESTAMP@ values. {-# INLINEABLE timestamp #-} timestamp :: Value LocalTime-timestamp = Value (Value.decoder (Prelude.bool A.timestamp_float A.timestamp_int))+timestamp = Value (Value.unsafePTI "timestamp" PTI.timestamp A.timestamp_float A.timestamp_int) -- | -- Decoder of the @TIMESTAMPTZ@ values.@@ -221,13 +221,13 @@ -- and communicates with Postgres using the UTC values directly. {-# INLINEABLE timestamptz #-} timestamptz :: Value UTCTime-timestamptz = Value (Value.decoder (Prelude.bool A.timestamptz_float A.timestamptz_int))+timestamptz = Value (Value.unsafePTI "timestamptz" PTI.timestamptz A.timestamptz_float A.timestamptz_int) -- | -- Decoder of the @TIME@ values. {-# INLINEABLE time #-} time :: Value TimeOfDay-time = Value (Value.decoder (Prelude.bool A.time_float A.time_int))+time = Value (Value.unsafePTI "time" PTI.time A.time_float A.time_int) -- | -- Decoder of the @TIMETZ@ values.@@ -239,25 +239,25 @@ -- to represent a value on the Haskell's side. {-# INLINEABLE timetz #-} timetz :: Value (TimeOfDay, TimeZone)-timetz = Value (Value.decoder (Prelude.bool A.timetz_float A.timetz_int))+timetz = Value (Value.unsafePTI "timetz" PTI.timetz A.timetz_float A.timetz_int) -- | -- Decoder of the @INTERVAL@ values. {-# INLINEABLE interval #-} interval :: Value DiffTime-interval = Value (Value.decoder (Prelude.bool A.interval_float A.interval_int))+interval = Value (Value.unsafePTI "interval" PTI.interval A.interval_float A.interval_int) -- | -- Decoder of the @UUID@ values. {-# INLINEABLE uuid #-} uuid :: Value UUID-uuid = Value (Value.decoder (const A.uuid))+uuid = Value (Value.unsafePTI "uuid" PTI.uuid A.uuid A.uuid) -- | -- Decoder of the @INET@ values. {-# INLINEABLE inet #-} inet :: Value Iproute.IPRange-inet = Value (Value.decoder (const A.inet))+inet = Value (Value.unsafePTI "inet" PTI.inet A.inet A.inet) -- | -- Decoder of the @MACADDR@ values.@@ -268,103 +268,103 @@ -- > (\(a,b,c,d,e,f) -> fromOctets a b c d e f) <$> macaddr {-# INLINEABLE macaddr #-} macaddr :: Value (Word8, Word8, Word8, Word8, Word8, Word8)-macaddr = Value (Value.decoder (const A.macaddr))+macaddr = Value (Value.unsafePTI "macaddr" PTI.macaddr A.macaddr A.macaddr) -- | -- Decoder of the @JSON@ values into a JSON AST. {-# INLINEABLE json #-} json :: Value Aeson.Value-json = Value (Value.decoder (const A.json_ast))+json = Value (Value.unsafePTI "json" PTI.json A.json_ast A.json_ast) -- | -- Decoder of the @JSON@ values into a raw JSON 'ByteString'. {-# INLINEABLE jsonBytes #-} jsonBytes :: (ByteString -> Either Text a) -> Value a-jsonBytes fn = Value (Value.decoder (const (A.json_bytes fn)))+jsonBytes fn = Value (Value.decoder (A.json_bytes fn)) -- | -- Decoder of the @JSONB@ values into a JSON AST. {-# INLINEABLE jsonb #-} jsonb :: Value Aeson.Value-jsonb = Value (Value.decoder (const A.jsonb_ast))+jsonb = Value (Value.unsafePTI "jsonb" PTI.jsonb A.jsonb_ast A.jsonb_ast) -- | -- Decoder of the @JSONB@ values into a raw JSON 'ByteString'. {-# INLINEABLE jsonbBytes #-} jsonbBytes :: (ByteString -> Either Text a) -> Value a-jsonbBytes fn = Value (Value.decoder (const (A.jsonb_bytes fn)))+jsonbBytes fn = Value (Value.decoder (A.jsonb_bytes fn)) -- | -- Decoder of the @INT4RANGE@ values. {-# INLINEABLE int4range #-} int4range :: Value (R.Range Int32)-int4range = Value (Value.decoder (const A.int4range))+int4range = Value (Value.unsafePTI "int4range" PTI.int4range A.int4range A.int4range) -- | -- Decoder of the @INT8RANGE@ values. {-# INLINEABLE int8range #-} int8range :: Value (R.Range Int64)-int8range = Value (Value.decoder (const A.int8range))+int8range = Value (Value.unsafePTI "int8range" PTI.int8range A.int8range A.int8range) -- | -- Decoder of the @NUMRANGE@ values. {-# INLINEABLE numrange #-} numrange :: Value (R.Range Scientific)-numrange = Value (Value.decoder (const A.numrange))+numrange = Value (Value.unsafePTI "numrange" PTI.numrange A.numrange A.numrange) -- | -- Decoder of the @TSRANGE@ values. {-# INLINEABLE tsrange #-} tsrange :: Value (R.Range LocalTime)-tsrange = Value (Value.decoder (Prelude.bool A.tsrange_float A.tsrange_int))+tsrange = Value (Value.unsafePTI "tsrange" PTI.tsrange A.tsrange_float A.tsrange_int) -- | -- Decoder of the @TSTZRANGE@ values. {-# INLINEABLE tstzrange #-} tstzrange :: Value (R.Range UTCTime)-tstzrange = Value (Value.decoder (Prelude.bool A.tstzrange_float A.tstzrange_int))+tstzrange = Value (Value.unsafePTI "tstzrange" PTI.tstzrange A.tstzrange_float A.tstzrange_int) -- | -- Decoder of the @DATERANGE@ values. {-# INLINEABLE daterange #-} daterange :: Value (R.Range Day)-daterange = Value (Value.decoder (const A.daterange))+daterange = Value (Value.unsafePTI "daterange" PTI.daterange A.daterange A.daterange) -- | -- Decoder of the @INT4MULTIRANGE@ values. {-# INLINEABLE int4multirange #-} int4multirange :: Value (R.Multirange Int32)-int4multirange = Value (Value.decoder (const A.int4multirange))+int4multirange = Value (Value.unsafePTI "int4multirange" PTI.int4multirange A.int4multirange A.int4multirange) -- | -- Decoder of the @INT8MULTIRANGE@ values. {-# INLINEABLE int8multirange #-} int8multirange :: Value (R.Multirange Int64)-int8multirange = Value (Value.decoder (const A.int8multirange))+int8multirange = Value (Value.unsafePTI "int8multirange" PTI.int8multirange A.int8multirange A.int8multirange) -- | -- Decoder of the @NUMMULTIRANGE@ values. {-# INLINEABLE nummultirange #-} nummultirange :: Value (R.Multirange Scientific)-nummultirange = Value (Value.decoder (const A.nummultirange))+nummultirange = Value (Value.unsafePTI "nummultirange" PTI.nummultirange A.nummultirange A.nummultirange) -- | -- Decoder of the @TSMULTIRANGE@ values. {-# INLINEABLE tsmultirange #-} tsmultirange :: Value (R.Multirange LocalTime)-tsmultirange = Value (Value.decoder (Prelude.bool A.tsmultirange_float A.tsmultirange_int))+tsmultirange = Value (Value.unsafePTI "tsmultirange" PTI.tsmultirange A.tsmultirange_float A.tsmultirange_int) -- | -- Decoder of the @TSTZMULTIRANGE@ values. {-# INLINEABLE tstzmultirange #-} tstzmultirange :: Value (R.Multirange UTCTime)-tstzmultirange = Value (Value.decoder (Prelude.bool A.tstzmultirange_float A.tstzmultirange_int))+tstzmultirange = Value (Value.unsafePTI "tstzmultirange" PTI.tstzmultirange A.tstzmultirange_float A.tstzmultirange_int) -- | -- Decoder of the @DATEMULTIRANGE@ values. {-# INLINEABLE datemultirange #-} datemultirange :: Value (R.Multirange Day)-datemultirange = Value (Value.decoder (const A.datemultirange))+datemultirange = Value (Value.unsafePTI "datemultirange" PTI.datemultirange A.datemultirange A.datemultirange) -- | -- Lift a custom value decoder function to a 'Value' decoder.@@ -389,19 +389,19 @@ -- @ {-# INLINEABLE hstore #-} hstore :: (forall m. (Monad m) => Int -> m (Text, Maybe Text) -> m a) -> Value a-hstore replicateM = Value (Value.decoder (const (A.hstore replicateM A.text_strict A.text_strict)))+hstore replicateM = Value (Value.decoder (A.hstore replicateM A.text_strict A.text_strict)) -- | -- Given a partial mapping from text to value, -- produces a decoder of that value. enum :: (Text -> Maybe a) -> Value a-enum mapping = Value (Value.decoder (const (A.enum mapping)))+enum mapping = Value (Value.decoder (A.enum mapping)) -- | -- Lift an 'Array' decoder to a 'Value' decoder. {-# INLINEABLE array #-} array :: Array a -> Value a-array (Array imp) = Value (Value.decoder (Array.run imp))+array (Array imp) = Value (Value.Value "unknown" Nothing Nothing (Array.run imp False) (Array.run imp True)) -- | -- Lift a value decoder of element into a unidimensional array decoder producing a list.@@ -437,7 +437,7 @@ -- Lift a 'Composite' decoder to a 'Value' decoder. {-# INLINEABLE composite #-} composite :: Composite a -> Value a-composite (Composite imp) = Value (Value.decoder (Composite.run imp))+composite (Composite imp) = Value (Value.Value "unknown" Nothing Nothing (Composite.run imp False) (Composite.run imp True)) -- * Array decoders
library/Hasql/Decoders/Value.hs view
@@ -1,10 +1,21 @@ module Hasql.Decoders.Value where +import Hasql.PostgresTypeInfo qualified as PTI import Hasql.Prelude import PostgreSQL.Binary.Decoding qualified as A -newtype Value a- = Value (Bool -> A.Value a)+data Value a+ = Value+ -- | Type name.+ Text+ -- | Statically known OID for the type.+ (Maybe PTI.OID)+ -- | Statically known OID for the array-type with this type as the element.+ (Maybe PTI.OID)+ -- | Decoding function for float timestamps (integerDatetimes = False).+ (A.Value a)+ -- | Decoding function for integer timestamps (integerDatetimes = True).+ (A.Value a) deriving (Functor) instance Filterable Value where@@ -14,22 +25,35 @@ {-# INLINE run #-} run :: Value a -> Bool -> A.Value a-run (Value imp) integerDatetimes =- imp integerDatetimes+run (Value _ _ _ floatDecoder intDecoder) integerDatetimes =+ if integerDatetimes then intDecoder else floatDecoder {-# INLINE decoder #-}-decoder :: (Bool -> A.Value a) -> Value a-decoder =+decoder :: A.Value a -> Value a+decoder aDecoder = {-# SCC "decoder" #-}- Value+ Value "unknown" Nothing Nothing aDecoder aDecoder {-# INLINE decoderFn #-} decoderFn :: (Bool -> ByteString -> Either Text a) -> Value a decoderFn fn =- Value $ \integerDatetimes -> A.fn $ fn integerDatetimes+ Value+ "unknown"+ Nothing+ Nothing+ (A.fn $ fn False)+ (A.fn $ fn True) -- | -- Refine a value decoder, lifting the possible error to the session level. {-# INLINE refine #-} refine :: (a -> Either Text b) -> Value a -> Value b-refine fn (Value run) = Value (A.refine fn . run)+refine fn (Value typeName typeOID arrayOID floatDecoder intDecoder) =+ Value typeName typeOID arrayOID (A.refine fn floatDecoder) (A.refine fn intDecoder)++-- |+-- Create a decoder from PTI metadata and a decoding function.+{-# INLINE unsafePTI #-}+unsafePTI :: Text -> PTI.PTI -> A.Value a -> A.Value a -> Value a+unsafePTI typeName pti floatDecoder intDecoder =+ Value typeName (Just (PTI.ptiOID pti)) (PTI.ptiArrayOID pti) floatDecoder intDecoder
library/Hasql/Encoders/Value.hs view
@@ -6,7 +6,15 @@ import TextBuilder qualified as C data Value a- = Value PTI.OID PTI.OID (Bool -> a -> B.Encoding) (a -> C.TextBuilder)+ = Value+ -- | Statically known OID for the type.+ PTI.OID+ -- | Statically known OID for the array-type with this type as the element.+ PTI.OID+ -- | Serialization function.+ (Bool -> a -> B.Encoding)+ -- | Render function for error messages.+ (a -> C.TextBuilder) instance Contravariant Value where {-# INLINE contramap #-}
library/Hasql/PreparedStatementRegistry.hs view
@@ -7,58 +7,31 @@ ) where -import ByteString.StrictBuilder qualified as B-import Data.HashTable.IO qualified as A-import Hasql.LibPq14 qualified as Pq import Hasql.Prelude hiding (lookup, reset)+import Hasql.PreparedStatementRegistry.Map (LocalKey (..))+import Hasql.PreparedStatementRegistry.Map qualified as Map +-- | Registry data structure containing a pure RegistryState wrapped in IORef data PreparedStatementRegistry- = PreparedStatementRegistry !(A.BasicHashTable LocalKey ByteString) !(IORef Word)+ = PreparedStatementRegistry !(IORef Map.RegistryState) {-# INLINEABLE new #-} new :: IO PreparedStatementRegistry new =- PreparedStatementRegistry <$> A.new <*> newIORef 0+ PreparedStatementRegistry <$> newIORef Map.empty {-# INLINEABLE update #-} update :: LocalKey -> (ByteString -> IO (Bool, a)) -> (ByteString -> IO a) -> PreparedStatementRegistry -> IO a-update localKey onNewRemoteKey onOldRemoteKey (PreparedStatementRegistry table counter) =- lookup >>= maybe new old- where- lookup =- A.lookup table localKey- new =- readIORef counter >>= onN- where- onN n =- do- (save, result) <- onNewRemoteKey remoteKey- when save $ do- A.insert table localKey remoteKey- writeIORef counter (succ n)- return result- where- remoteKey =- B.builderBytes . B.asciiIntegral $ n- old =- onOldRemoteKey+update localKey onNewRemoteKey onOldRemoteKey (PreparedStatementRegistry registryRef) = do+ registryState <- readIORef registryRef+ case Map.lookup localKey registryState of+ Just remoteKey -> onOldRemoteKey remoteKey+ Nothing -> do+ let (remoteKey, newState) = Map.insert localKey registryState+ (save, result) <- onNewRemoteKey remoteKey+ when save $ writeIORef registryRef newState+ return result reset :: PreparedStatementRegistry -> IO ()-reset (PreparedStatementRegistry table counter) = do- -- TODO: This is a temporary measure.- -- We should just move to a pure implementation.- do- entries <- A.toList table- forM_ entries \(k, _) -> A.delete table k- writeIORef counter 0---- |--- Local statement key.-data LocalKey- = LocalKey !ByteString ![Pq.Oid]- deriving (Show, Eq)--instance Hashable LocalKey where- {-# INLINE hashWithSalt #-}- hashWithSalt salt (LocalKey template _) =- hashWithSalt salt template+reset (PreparedStatementRegistry registryRef) = do+ writeIORef registryRef Map.empty
+ library/Hasql/PreparedStatementRegistry/Map.hs view
@@ -0,0 +1,56 @@+module Hasql.PreparedStatementRegistry.Map+ ( -- * Pure registry operations+ RegistryState,+ empty,+ lookup,+ insert,+ reset,++ -- * Key type+ LocalKey (..),+ )+where++import ByteString.StrictBuilder qualified as B+import Data.HashMap.Strict qualified as HashMap+import Hasql.LibPq14 qualified as Pq+import Hasql.Prelude hiding (empty, insert, lookup, reset)++-- | Pure registry state containing the hash map and counter+data RegistryState = RegistryState (HashMap.HashMap LocalKey ByteString) Word++-- | Create an empty registry state+{-# INLINEABLE empty #-}+empty :: RegistryState+empty = RegistryState HashMap.empty 0++-- | Pure lookup operation+{-# INLINEABLE lookup #-}+lookup :: LocalKey -> RegistryState -> Maybe ByteString+lookup localKey (RegistryState hashMap _) = HashMap.lookup localKey hashMap++-- | Pure insert operation that returns new state and the generated remote key+{-# INLINEABLE insert #-}+insert :: LocalKey -> RegistryState -> (ByteString, RegistryState)+insert localKey (RegistryState hashMap counter) = (remoteKey, newState)+ where+ remoteKey = B.builderBytes . B.asciiIntegral $ counter+ newHashMap = HashMap.insert localKey remoteKey hashMap+ newCounter = succ counter+ newState = RegistryState newHashMap newCounter++-- | Pure reset operation+{-# INLINEABLE reset #-}+reset :: RegistryState -> RegistryState+reset _ = RegistryState HashMap.empty 0++-- |+-- Local statement key.+data LocalKey+ = LocalKey !ByteString ![Pq.Oid]+ deriving (Show, Eq)++instance Hashable LocalKey where+ {-# INLINE hashWithSalt #-}+ hashWithSalt salt (LocalKey template _) =+ hashWithSalt salt template
profiling/Main.hs view
@@ -1,36 +1,19 @@ module Main where import Data.Vector qualified as F-import Hasql.Connection qualified as A-import Hasql.Connection.Setting qualified as E-import Hasql.Connection.Setting.Connection qualified as F-import Hasql.Connection.Setting.Connection.Param qualified as G import Hasql.Decoders qualified as D import Hasql.Session qualified as B import Hasql.Statement qualified as C+import Hasql.TestingKit.Testcontainers qualified as Testcontainers import Prelude main :: IO () main =- do- Right connection <- acquireConnection+ Testcontainers.withConnection \connection -> do traceEventIO "START Session" Right _ <- B.run sessionWithManySmallResults connection traceEventIO "STOP Session" return ()- where- acquireConnection =- A.acquire- [ E.connection- ( F.params- [ G.host "localhost",- G.port 5432,- G.user "postgres",- G.password "postgres",- G.dbname "postgres"- ]- )- ] -- * Sessions
− tasty/Main.hs
@@ -1,473 +0,0 @@-module Main where--import Contravariant.Extras-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.TestingKit.TestingDsl qualified as Session-import Main.Connection qualified as Connection-import Main.Prelude hiding (assert)-import Main.Statements qualified as Statements-import Test.QuickCheck.Instances ()-import Test.Tasty-import Test.Tasty.HUnit-import Test.Tasty.QuickCheck-import Test.Tasty.Runners--main :: IO ()-main =- defaultMain tree--tree :: TestTree-tree =- localOption (NumThreads 1)- $ testGroup- "All tests"- [ testGroup "Roundtrips"- $ let roundtrip encoder decoder input =- let session =- let statement = Statement.Statement "select $1" encoder decoder True- in Session.statement input statement- in unsafePerformIO $ do- x <- Connection.with (Session.run session)- return (Right (Right input) === x)- in [ testProperty "Array"- $ let encoder = Encoders.param (Encoders.nonNullable (Encoders.array (Encoders.dimension foldl' (Encoders.element (Encoders.nonNullable Encoders.int8)))))- decoder = Decoders.singleRow (Decoders.column (Decoders.nonNullable (Decoders.array (Decoders.dimension replicateM (Decoders.element (Decoders.nonNullable Decoders.int8))))))- in roundtrip encoder decoder,- testProperty "2D Array"- $ let encoder = Encoders.param (Encoders.nonNullable (Encoders.array (Encoders.dimension foldl' (Encoders.dimension foldl' (Encoders.element (Encoders.nonNullable Encoders.int8))))))- decoder = Decoders.singleRow (Decoders.column (Decoders.nonNullable (Decoders.array (Decoders.dimension replicateM (Decoders.dimension replicateM (Decoders.element (Decoders.nonNullable Decoders.int8)))))))- in \list -> list /= [] ==> roundtrip encoder decoder (replicate 3 list)- ],- testCase "Failed query"- $ let statement =- Statement.Statement "select true where 1 = any ($1) and $2" encoder decoder True- where- encoder =- contrazip2- (Encoders.param (Encoders.nonNullable (Encoders.array (Encoders.dimension foldl' (Encoders.element (Encoders.nonNullable Encoders.int8))))))- (Encoders.param (Encoders.nonNullable (Encoders.text)))- decoder =- fmap (maybe False (const True)) (Decoders.rowMaybe ((Decoders.column . Decoders.nonNullable) Decoders.bool))- session =- Session.statement ([3, 7], "a") statement- in do- x <- Connection.with (Session.run session)- assertBool (show x) $ case x of- Right (Left (Session.QueryError "select true where 1 = any ($1) and $2" ["[3, 7]", "\"a\""] _)) -> True- _ -> False,- testCase "IN simulation"- $ let statement =- Statement.Statement "select true where 1 = any ($1)" encoder decoder True- where- encoder =- Encoders.param (Encoders.nonNullable (Encoders.array (Encoders.dimension foldl' (Encoders.element (Encoders.nonNullable Encoders.int8)))))- decoder =- fmap (maybe False (const True)) (Decoders.rowMaybe ((Decoders.column . Decoders.nonNullable) Decoders.bool))- session =- do- result1 <- Session.statement [1, 2] statement- result2 <- Session.statement [2, 3] statement- return (result1, result2)- in do- x <- Connection.with (Session.run session)- assertEqual (show x) (Right (Right (True, False))) x,- testCase "NOT IN simulation"- $ let statement =- Statement.Statement "select true where 3 <> all ($1)" encoder decoder True- where- encoder =- Encoders.param (Encoders.nonNullable (Encoders.array (Encoders.dimension foldl' (Encoders.element (Encoders.nonNullable Encoders.int8)))))- decoder =- fmap (maybe False (const True)) (Decoders.rowMaybe ((Decoders.column . Decoders.nonNullable) Decoders.bool))- session =- do- result1 <- Session.statement [1, 2] statement- result2 <- Session.statement [2, 3] statement- return (result1, result2)- in do- x <- Connection.with (Session.run session)- assertEqual (show x) (Right (Right (True, False))) x,- testCase "Composite decoding"- $ let statement =- Statement.Statement sql encoder decoder True- where- sql =- "select (1, true)"- encoder =- mempty- decoder =- Decoders.singleRow ((Decoders.column . Decoders.nonNullable) (Decoders.composite ((,) <$> (Decoders.field . Decoders.nonNullable) Decoders.int8 <*> (Decoders.field . Decoders.nonNullable) Decoders.bool)))- session =- Session.statement () statement- in do- x <- Connection.with (Session.run session)- assertEqual (show x) (Right (Right (1, True))) x,- testCase "Complex composite decoding"- $ let statement =- Statement.Statement sql encoder decoder True- where- sql =- "select (1, true) as entity1, ('hello', 3) as entity2"- encoder =- mempty- decoder =- Decoders.singleRow- $ (,)- <$> (Decoders.column . Decoders.nonNullable) entity1- <*> (Decoders.column . Decoders.nonNullable) entity2- where- entity1 =- Decoders.composite- $ (,)- <$> (Decoders.field . Decoders.nonNullable) Decoders.int8- <*> (Decoders.field . Decoders.nonNullable) Decoders.bool- entity2 =- Decoders.composite- $ (,)- <$> (Decoders.field . Decoders.nonNullable) Decoders.text- <*> (Decoders.field . Decoders.nonNullable) Decoders.int8- session =- Session.statement () statement- in do- x <- Connection.with (Session.run session)- assertEqual (show x) (Right (Right ((1, True), ("hello", 3)))) x,- testGroup "unknownEnum"- $ [ testCase "" $ do- res <- Session.runSessionOnLocalDb $ do- let statement =- Statement.Statement sql mempty Decoders.noResult True- where- sql =- "drop type if exists mood"- in Session.statement () statement- let statement =- Statement.Statement sql mempty Decoders.noResult True- where- sql =- "create type mood as enum ('sad', 'ok', 'happy')"- in Session.statement () statement- let statement =- Statement.Statement sql encoder decoder True- where- sql =- "select $1"- decoder =- (Decoders.singleRow ((Decoders.column . Decoders.nonNullable) (Decoders.enum (Just . id))))- encoder =- Encoders.param (Encoders.nonNullable (Encoders.unknownEnum id))- in Session.statement "ok" statement-- assertEqual "" (Right "ok") res- ],- testCase "Composite encoding" $ do- let value =- (123, 456, 789, "abc")- res <-- let statement =- Statement.Statement sql encoder decoder True- where- sql =- "select $1 :: pg_enum"- encoder =- Encoders.param- . Encoders.nonNullable- . Encoders.composite- . mconcat- $ [ contramap (\(a, _, _, _) -> a) . Encoders.field . Encoders.nonNullable $ Encoders.oid,- contramap (\(_, a, _, _) -> a) . Encoders.field . Encoders.nonNullable $ Encoders.oid,- contramap (\(_, _, a, _) -> a) . Encoders.field . Encoders.nonNullable $ Encoders.float4,- contramap (\(_, _, _, a) -> a) . Encoders.field . Encoders.nonNullable $ Encoders.name- ]- decoder =- Decoders.singleRow- $ (Decoders.column . Decoders.nonNullable . Decoders.composite)- ( (,,,)- <$> (Decoders.field . Decoders.nonNullable) Decoders.int4- <*> (Decoders.field . Decoders.nonNullable) Decoders.int4- <*> (Decoders.field . Decoders.nonNullable) Decoders.float4- <*> (Decoders.field . Decoders.nonNullable) Decoders.text- )- in Connection.with $ Session.run $ Session.statement value statement- assertEqual "" (Right (Right value)) res,- testCase "Empty array"- $ let io =- do- x <- Connection.with (Session.run session)- assertEqual (show x) (Right (Right [])) x- where- session =- Session.statement () statement- where- statement =- Statement.Statement sql encoder decoder True- where- sql =- "select array[]::int8[]"- encoder =- mempty- decoder =- Decoders.singleRow ((Decoders.column . Decoders.nonNullable) (Decoders.array (Decoders.dimension replicateM (Decoders.element (Decoders.nonNullable Decoders.int8)))))- in io,- testCase "Failing prepared statements"- $ let io =- Connection.with (Session.run session)- >>= (assertBool <$> show <*> resultTest)- where- resultTest =- \case- Right (Left (Session.QueryError _ _ (Session.ResultError (Session.ServerError "26000" _ _ _ _)))) -> False- _ -> True- session =- catchError session (const (pure ())) *> session- where- session =- Session.statement () statement- where- statement =- Statement.Statement sql encoder decoder True- where- sql =- "absurd"- encoder =- mempty- decoder =- Decoders.noResult- in io,- testCase "Prepared statements after error"- $ let io =- Connection.with (Session.run session)- >>= \x -> assertBool (show x) (either (const False) isRight x)- where- session =- try *> fail *> try- where- try =- Session.statement 1 statement- where- statement =- Statement.Statement sql encoder decoder True- where- sql =- "select $1 :: int8"- encoder =- Encoders.param (Encoders.nonNullable (Encoders.int8))- decoder =- Decoders.singleRow $ (Decoders.column . Decoders.nonNullable) Decoders.int8- fail =- catchError (Session.sql "absurd") (const (pure ()))- in io,- testCase "\"in progress after error\" bugfix"- $ let sumStatement :: Statement.Statement (Int64, Int64) Int64- sumStatement =- Statement.Statement sql encoder decoder True- where- sql =- "select ($1 + $2)"- encoder =- contramap fst (Encoders.param (Encoders.nonNullable (Encoders.int8)))- <> contramap snd (Encoders.param (Encoders.nonNullable (Encoders.int8)))- decoder =- Decoders.singleRow ((Decoders.column . Decoders.nonNullable) Decoders.int8)- sumSession :: Session.Session Int64- sumSession =- Session.sql "begin" *> Session.statement (1, 1) sumStatement <* Session.sql "end"- errorSession :: Session.Session ()- errorSession =- Session.sql "asldfjsldk"- io =- Connection.with $ \c -> do- _ <- Session.run errorSession c- Session.run sumSession c- in io >>= \x -> assertBool (show x) (either (const False) isRight x),- testCase "\"another command is already in progress\" bugfix"- $ let sumStatement :: Statement.Statement (Int64, Int64) Int64- sumStatement =- Statement.Statement sql encoder decoder True- where- sql =- "select ($1 + $2)"- encoder =- contramap fst (Encoders.param (Encoders.nonNullable (Encoders.int8)))- <> contramap snd (Encoders.param (Encoders.nonNullable (Encoders.int8)))- decoder =- Decoders.singleRow ((Decoders.column . Decoders.nonNullable) Decoders.int8)- session :: Session.Session Int64- session =- do- Session.sql "begin;"- s <- Session.statement (1, 1) sumStatement- Session.sql "end;"- return s- in Session.runSessionOnLocalDb session >>= \x -> assertEqual (show x) (Right 2) x,- testCase "Executing the same query twice"- $ pure (),- testCase "Interval Encoding"- $ let actualIO =- Session.runSessionOnLocalDb $ do- let statement =- Statement.Statement sql encoder decoder True- where- sql =- "select $1 = interval '10 seconds'"- decoder =- (Decoders.singleRow ((Decoders.column . Decoders.nonNullable) (Decoders.bool)))- encoder =- Encoders.param (Encoders.nonNullable (Encoders.interval))- in Session.statement (10 :: DiffTime) statement- in actualIO >>= \x -> assertEqual (show x) (Right True) x,- testCase "Interval Decoding"- $ let actualIO =- Session.runSessionOnLocalDb $ do- let statement =- Statement.Statement sql encoder decoder True- where- sql =- "select interval '10 seconds'"- decoder =- (Decoders.singleRow ((Decoders.column . Decoders.nonNullable) (Decoders.interval)))- encoder =- Encoders.noParams- in Session.statement () statement- in actualIO >>= \x -> assertEqual (show x) (Right (10 :: DiffTime)) x,- testCase "Interval Encoding/Decoding"- $ let actualIO =- Session.runSessionOnLocalDb $ do- let statement =- Statement.Statement sql encoder decoder True- where- sql =- "select $1"- decoder =- (Decoders.singleRow ((Decoders.column . Decoders.nonNullable) (Decoders.interval)))- encoder =- Encoders.param (Encoders.nonNullable (Encoders.interval))- in Session.statement (10 :: DiffTime) statement- in actualIO >>= \x -> assertEqual (show x) (Right (10 :: DiffTime)) x,- testCase "Unknown"- $ let actualIO =- Session.runSessionOnLocalDb $ do- let statement =- Statement.Statement sql mempty Decoders.noResult True- where- sql =- "drop type if exists mood"- in Session.statement () statement- let statement =- Statement.Statement sql mempty Decoders.noResult True- where- sql =- "create type mood as enum ('sad', 'ok', 'happy')"- in Session.statement () statement- let statement =- Statement.Statement sql encoder decoder True- where- sql =- "select $1 = ('ok' :: mood)"- decoder =- (Decoders.singleRow ((Decoders.column . Decoders.nonNullable) (Decoders.bool)))- encoder =- Encoders.param (Encoders.nonNullable (Encoders.unknown))- in Session.statement "ok" statement- in actualIO >>= assertEqual "" (Right True),- testCase "Enum"- $ let actualIO =- Session.runSessionOnLocalDb $ do- let statement =- Statement.Statement sql mempty Decoders.noResult True- where- sql =- "drop type if exists mood"- in Session.statement () statement- let statement =- Statement.Statement sql mempty Decoders.noResult True- where- sql =- "create type mood as enum ('sad', 'ok', 'happy')"- in Session.statement () statement- let statement =- Statement.Statement sql encoder decoder True- where- sql =- "select ($1 :: mood)"- decoder =- (Decoders.singleRow ((Decoders.column . Decoders.nonNullable) (Decoders.enum (Just . id))))- encoder =- Encoders.param (Encoders.nonNullable ((Encoders.enum id)))- in Session.statement "ok" statement- in actualIO >>= assertEqual "" (Right "ok"),- testCase "The same prepared statement used on different types"- $ let actualIO =- Session.runSessionOnLocalDb $ do- let effect1 =- Session.statement "ok" statement- where- statement =- Statement.Statement sql encoder decoder True- where- sql =- "select $1"- encoder =- Encoders.param (Encoders.nonNullable (Encoders.text))- decoder =- (Decoders.singleRow ((Decoders.column . Decoders.nonNullable) (Decoders.text)))- effect2 =- Session.statement 1 statement- where- statement =- Statement.Statement sql encoder decoder True- where- sql =- "select $1"- encoder =- Encoders.param (Encoders.nonNullable (Encoders.int8))- decoder =- (Decoders.singleRow ((Decoders.column . Decoders.nonNullable) Decoders.int8))- in (,) <$> effect1 <*> effect2- in actualIO >>= assertEqual "" (Right ("ok", 1)),- testCase "Affected rows counting"- $ replicateM_ 13- $ let actualIO =- Session.runSessionOnLocalDb $ do- dropTable- createTable- replicateM_ 100 insertRow- deleteRows <* dropTable- where- dropTable =- Session.statement ()- $ Statements.plain- $ "drop table if exists a"- createTable =- Session.statement ()- $ Statements.plain- $ "create table a (id bigserial not null, name varchar not null, primary key (id))"- insertRow =- Session.statement ()- $ Statements.plain- $ "insert into a (name) values ('a')"- deleteRows =- Session.statement () $ Statement.Statement sql mempty decoder False- where- sql =- "delete from a"- decoder =- Decoders.rowsAffected- in actualIO >>= assertEqual "" (Right 100),- testCase "Result of an auto-incremented column"- $ let actualIO =- Session.runSessionOnLocalDb $ 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 =- Session.runSessionOnLocalDb $ Session.statement () $ Statements.selectList- in assertEqual "" (Right [(1, 2), (3, 4), (5, 6)]) =<< actualIO- ]
− tasty/Main/Connection.hs
@@ -1,16 +0,0 @@-module Main.Connection where--import Hasql.Connection qualified as HC-import Hasql.TestingKit.Constants qualified as Constants-import Main.Prelude--with :: (HC.Connection -> IO a) -> IO (Either HC.ConnectionError a)-with handler =- runExceptT $ acquire >>= \connection -> use connection <* release connection- where- acquire =- ExceptT $ HC.acquire Constants.localConnectionSettings- use connection =- lift $ handler connection- release connection =- lift $ HC.release connection
− tasty/Main/Prelude.hs
@@ -1,6 +0,0 @@-module Main.Prelude- ( module Exports,- )-where--import Prelude as Exports
− tasty/Main/Statements.hs
@@ -1,33 +0,0 @@-module Main.Statements where--import Hasql.Decoders qualified as HD-import Hasql.Statement qualified as HQ-import Main.Prelude--plain :: ByteString -> HQ.Statement () ()-plain sql =- HQ.Statement sql mempty HD.noResult False--dropType :: ByteString -> HQ.Statement () ()-dropType name =- plain- $ "drop type if exists "- <> name--createEnum :: ByteString -> [ByteString] -> HQ.Statement () ()-createEnum name values =- plain- $ "create type "- <> name- <> " as enum ("- <> mconcat (intersperse ", " (map (\x -> "'" <> x <> "'") values))- <> ")"--selectList :: HQ.Statement () ([] (Int64, Int64))-selectList =- HQ.Statement sql mempty decoder True- where- sql =- "values (1,2), (3,4), (5,6)"- decoder =- HD.rowList ((,) <$> (HD.column . HD.nonNullable) HD.int8 <*> (HD.column . HD.nonNullable) HD.int8)
+ testing-kit/Hasql/TestingKit/Testcontainers.hs view
@@ -0,0 +1,38 @@+module Hasql.TestingKit.Testcontainers where++import Control.Exception+import Hasql.Connection qualified+import Hasql.Connection.Setting qualified+import Hasql.Connection.Setting.Connection qualified+import Hasql.Connection.Setting.Connection.Param qualified+import TestcontainersPostgresql qualified+import Prelude++withConnectionSettings :: ([Hasql.Connection.Setting.Setting] -> IO ()) -> IO ()+withConnectionSettings action = do+ TestcontainersPostgresql.run config \(host, port) -> do+ action+ [ Hasql.Connection.Setting.connection+ ( Hasql.Connection.Setting.Connection.params+ [ Hasql.Connection.Setting.Connection.Param.host host,+ Hasql.Connection.Setting.Connection.Param.port (fromIntegral port),+ Hasql.Connection.Setting.Connection.Param.user "postgres",+ Hasql.Connection.Setting.Connection.Param.password "",+ Hasql.Connection.Setting.Connection.Param.dbname "postgres"+ ]+ )+ ]+ where+ config =+ TestcontainersPostgresql.Config+ { forwardLogs = False,+ distro = TestcontainersPostgresql.Distro17,+ auth = TestcontainersPostgresql.TrustAuth+ }++withConnection :: (Hasql.Connection.Connection -> IO ()) -> IO ()+withConnection action = withConnectionSettings $ \settings -> do+ connection <- Hasql.Connection.acquire settings+ case connection of+ Left err -> fail ("Connection failed: " <> show err)+ Right conn -> finally (action conn) (Hasql.Connection.release conn)
testing-kit/Hasql/TestingKit/TestingDsl.hs view
@@ -14,12 +14,15 @@ -- * Execution runSessionOnLocalDb, runPipelineOnLocalDb,+ runSessionWithSettings,+ runPipelineWithSettings, runStatementInSession, runPipelineInSession, ) where import Hasql.Connection qualified as Connection+import Hasql.Connection.Setting qualified as Connection.Setting import Hasql.Pipeline qualified as Pipeline import Hasql.Session qualified as Session import Hasql.Statement qualified as Statement@@ -32,11 +35,18 @@ deriving (Show, Eq) runSessionOnLocalDb :: Session.Session a -> IO (Either Error a)-runSessionOnLocalDb session =+runSessionOnLocalDb = runSessionWithSettings Constants.localConnectionSettings++runPipelineOnLocalDb :: Pipeline.Pipeline a -> IO (Either Error a)+runPipelineOnLocalDb =+ runSessionOnLocalDb . Session.pipeline++runSessionWithSettings :: [Connection.Setting.Setting] -> Session.Session a -> IO (Either Error a)+runSessionWithSettings settings session = runExceptT $ acquire >>= \connection -> use connection <* release connection where acquire =- ExceptT $ fmap (first ConnectionError) $ Connection.acquire Constants.localConnectionSettings+ ExceptT $ fmap (first ConnectionError) $ Connection.acquire settings use connection = ExceptT $ fmap (first SessionError)@@ -44,9 +54,9 @@ release connection = lift $ Connection.release connection -runPipelineOnLocalDb :: Pipeline.Pipeline a -> IO (Either Error a)-runPipelineOnLocalDb =- runSessionOnLocalDb . Session.pipeline+runPipelineWithSettings :: [Connection.Setting.Setting] -> Pipeline.Pipeline a -> IO (Either Error a)+runPipelineWithSettings settings =+ runSessionWithSettings settings . Session.pipeline runStatementInSession :: Statement.Statement a b -> a -> Session.Session b runStatementInSession statement params =
− threads-test/Main.hs
@@ -1,54 +0,0 @@-module Main where--import Hasql.Connection qualified-import Hasql.Connection.Setting qualified-import Hasql.Connection.Setting.Connection qualified-import Hasql.Connection.Setting.Connection.Param qualified-import Hasql.Session qualified-import Main.Statements qualified as Statements-import Prelude--main :: IO ()-main =- acquire >>= use- where- acquire =- (,) <$> acquire <*> acquire- where- acquire =- join- $ fmap (either (fail . show) return)- $ Hasql.Connection.acquire connectionSettings- where- connectionSettings =- [ Hasql.Connection.Setting.connection- ( Hasql.Connection.Setting.Connection.params- [ Hasql.Connection.Setting.Connection.Param.host "localhost",- Hasql.Connection.Setting.Connection.Param.port 5432,- Hasql.Connection.Setting.Connection.Param.user "postgres",- Hasql.Connection.Setting.Connection.Param.password "postgres",- Hasql.Connection.Setting.Connection.Param.dbname "postgres"- ]- )- ]- use (connection1, connection2) =- do- beginVar <- newEmptyMVar- finishVar <- newEmptyMVar- forkIO $ do- traceM "1: in"- putMVar beginVar ()- session connection1 (Hasql.Session.statement 0.2 Statements.selectSleep)- traceM "1: out"- void (tryPutMVar finishVar False)- forkIO $ do- takeMVar beginVar- traceM "2: in"- session connection2 (Hasql.Session.statement 0.1 Statements.selectSleep)- traceM "2: out"- void (tryPutMVar finishVar True)- bool exitFailure exitSuccess . traceShowId =<< takeMVar finishVar- where- session connection session =- Hasql.Session.run session connection- >>= either (fail . show) return
− threads-test/Main/Statements.hs
@@ -1,17 +0,0 @@-module Main.Statements where--import Hasql.Decoders qualified as D-import Hasql.Encoders qualified as E-import Hasql.Statement-import Prelude--selectSleep :: Statement Double ()-selectSleep =- Statement sql encoder decoder True- where- sql =- "select pg_sleep($1)"- encoder =- E.param (E.nonNullable E.float8)- decoder =- D.noResult