diff --git a/hasql.cabal b/hasql.cabal --- a/hasql.cabal +++ b/hasql.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: hasql -version: 1.10.2.4 +version: 1.10.3 category: Hasql, Database, PostgreSQL synopsis: Fast PostgreSQL driver with a flexible mapping API description: @@ -250,6 +250,48 @@ vector >=0.10 && <0.14, witherable >=0.5 && <0.6, +test-suite engine-tests + import: test + type: exitcode-stdio-1.0 + hs-source-dirs: + src/engine-tests + src/library + + main-is: Main.hs + other-modules: + Hasql.Engine.Structures.OidCache + Hasql.Engine.Structures.OidCacheSpec + Hasql.Engine.Structures.StatementCache + Hasql.Engine.Structures.StatementCacheSpec + Hasql.Platform.Prelude + Hasql.Platform.Prelude.Text + Hasql.Pq + Hasql.Pq.Ffi + Hasql.Pq.Mappings + + build-tool-depends: + hspec-discover:hspec-discover ^>=2.11.12 + + build-depends: + base >=4.14 && <5, + bytestring >=0.10 && <0.13, + contravariant >=1.3 && <2, + dlist >=0.8 && <0.9 || >=1 && <2, + hashable >=1.2 && <2, + hspec ^>=2.11.12, + mtl >=2 && <3, + postgresql-libpq >=0.10.1 && <0.12, + profunctors >=5.1 && <6, + scientific >=0.3 && <0.4, + text >=1 && <3, + text-builder >=1 && <1.1, + time >=1.9 && <2, + transformers >=0.5 && <0.7, + unordered-containers >=0.2 && <0.3, + uuid >=1.3 && <2, + vector >=0.10 && <0.14, + witherable >=0.5 && <0.6, + test-suite library-tests import: test type: exitcode-stdio-1.0 @@ -278,6 +320,7 @@ Sharing.ByFeature.PreparedStatementsSpec Sharing.ByFeature.SyntaxErrorsSpec Sharing.ByUnit.Connection.UseSpec + Sharing.ByUnit.Decoders.CitextSpec Sharing.ByUnit.Decoders.Composite.OidMismatchSpec Sharing.ByUnit.Decoders.CompositeSpec Sharing.ByUnit.Decoders.CustomSpec @@ -291,6 +334,7 @@ Sharing.ByUnit.Decoders.RecordSpec Sharing.ByUnit.Decoders.UuidSpec Sharing.ByUnit.Encoders.ArraySpec + Sharing.ByUnit.Encoders.CitextSpec Sharing.ByUnit.Encoders.Composite.OidMismatchSpec Sharing.ByUnit.Encoders.CompositeSpec Sharing.ByUnit.Encoders.CustomSpec diff --git a/src/engine-tests/Hasql/Engine/Structures/OidCacheSpec.hs b/src/engine-tests/Hasql/Engine/Structures/OidCacheSpec.hs new file mode 100644 --- /dev/null +++ b/src/engine-tests/Hasql/Engine/Structures/OidCacheSpec.hs @@ -0,0 +1,115 @@ +module Hasql.Engine.Structures.OidCacheSpec (spec) where + +import Data.HashSet qualified as HashSet +import Hasql.Engine.Structures.OidCache qualified as OidCache +import Test.Hspec +import Prelude + +spec :: Spec +spec = do + describe "empty" do + it "returns Nothing on scalar lookup" do + OidCache.lookupScalar Nothing "int4" OidCache.empty + `shouldBe` Nothing + + it "returns Nothing on array lookup" do + OidCache.lookupArray Nothing "int4" OidCache.empty + `shouldBe` Nothing + + describe "insertScalar and lookup" do + it "can insert and lookup a scalar OID" do + let cache = OidCache.insertScalar Nothing "int4" 23 1007 OidCache.empty + OidCache.lookupScalar Nothing "int4" cache + `shouldBe` Just 23 + + it "can insert and lookup an array OID" do + let cache = OidCache.insertScalar Nothing "int4" 23 1007 OidCache.empty + OidCache.lookupArray Nothing "int4" cache + `shouldBe` Just 1007 + + it "returns Nothing for a non-inserted type" do + let cache = OidCache.insertScalar Nothing "int4" 23 1007 OidCache.empty + OidCache.lookupScalar Nothing "int8" cache + `shouldBe` Nothing + + it "handles schema-qualified names" do + let cache = OidCache.insertScalar (Just "public") "my_type" 100 200 OidCache.empty + OidCache.lookupScalar (Just "public") "my_type" cache + `shouldBe` Just 100 + OidCache.lookupScalar Nothing "my_type" cache + `shouldBe` Nothing + + it "distinguishes same type name in different schemas" do + let cache = + OidCache.insertScalar + (Just "schema_a") + "my_type" + 100 + 200 + (OidCache.insertScalar (Just "schema_b") "my_type" 300 400 OidCache.empty) + OidCache.lookupScalar (Just "schema_a") "my_type" cache + `shouldBe` Just 100 + OidCache.lookupScalar (Just "schema_b") "my_type" cache + `shouldBe` Just 300 + + describe "selectUnknownNames" do + it "returns all names when cache is empty" do + let names = HashSet.fromList [(Nothing, "int4"), (Nothing, "int8")] + OidCache.selectUnknownNames names OidCache.empty + `shouldBe` names + + it "returns empty when all names are known" do + let cache = + OidCache.insertScalar + Nothing + "int4" + 23 + 1007 + (OidCache.insertScalar Nothing "int8" 20 1016 OidCache.empty) + names = HashSet.fromList [(Nothing, "int4"), (Nothing, "int8")] + OidCache.selectUnknownNames names cache + `shouldBe` HashSet.empty + + it "returns only unknown names" do + let cache = OidCache.insertScalar Nothing "int4" 23 1007 OidCache.empty + names = HashSet.fromList [(Nothing, "int4"), (Nothing, "int8")] + OidCache.selectUnknownNames names cache + `shouldBe` HashSet.fromList [(Nothing, "int8")] + + describe "Semigroup" do + it "right operand takes precedence for duplicate keys" do + let cacheA = OidCache.insertScalar Nothing "int4" 23 1007 OidCache.empty + cacheB = OidCache.insertScalar Nothing "int4" 99 999 OidCache.empty + merged = cacheA <> cacheB + OidCache.lookupScalar Nothing "int4" merged + `shouldBe` Just 99 + OidCache.lookupArray Nothing "int4" merged + `shouldBe` Just 999 + + it "preserves entries from both sides when no conflict" do + let cacheA = OidCache.insertScalar Nothing "int4" 23 1007 OidCache.empty + cacheB = OidCache.insertScalar Nothing "int8" 20 1016 OidCache.empty + merged = cacheA <> cacheB + OidCache.lookupScalar Nothing "int4" merged + `shouldBe` Just 23 + OidCache.lookupScalar Nothing "int8" merged + `shouldBe` Just 20 + + it "is associative" do + let a = OidCache.insertScalar Nothing "t1" 1 2 OidCache.empty + b = OidCache.insertScalar Nothing "t1" 3 4 (OidCache.insertScalar Nothing "t2" 5 6 OidCache.empty) + c = OidCache.insertScalar Nothing "t2" 7 8 (OidCache.insertScalar Nothing "t3" 9 10 OidCache.empty) + OidCache.toHashMap ((a <> b) <> c) + `shouldBe` OidCache.toHashMap (a <> (b <> c)) + + describe "Monoid" do + it "mempty is identity for Semigroup" do + let cache = OidCache.insertScalar Nothing "int4" 23 1007 OidCache.empty + OidCache.toHashMap (cache <> mempty) + `shouldBe` OidCache.toHashMap cache + OidCache.toHashMap (mempty <> cache) + `shouldBe` OidCache.toHashMap cache + + it "empty equals mempty" do + OidCache.toHashMap OidCache.empty + `shouldBe` OidCache.toHashMap mempty diff --git a/src/engine-tests/Hasql/Engine/Structures/StatementCacheSpec.hs b/src/engine-tests/Hasql/Engine/Structures/StatementCacheSpec.hs new file mode 100644 --- /dev/null +++ b/src/engine-tests/Hasql/Engine/Structures/StatementCacheSpec.hs @@ -0,0 +1,95 @@ +module Hasql.Engine.Structures.StatementCacheSpec (spec) where + +import Data.Maybe (isJust, isNothing) +import Database.PostgreSQL.LibPQ (Oid (..)) +import Hasql.Engine.Structures.StatementCache qualified as StatementCache +import Test.Hspec +import Prelude + +spec :: Spec +spec = do + describe "empty" do + it "returns Nothing on lookup" do + StatementCache.lookup "SELECT 1" [] StatementCache.empty + `shouldBe` Nothing + + describe "insert and lookup" do + it "can insert and retrieve a statement" do + let (remoteKey, cache) = StatementCache.insert "SELECT 1" [] StatementCache.empty + StatementCache.lookup "SELECT 1" [] cache + `shouldBe` Just remoteKey + + it "generates unique remote keys for different SQL" do + let (key1, cache1) = StatementCache.insert "SELECT 1" [] StatementCache.empty + (key2, _cache2) = StatementCache.insert "SELECT 2" [] cache1 + key1 `shouldNotBe` key2 + + it "generates unique remote keys for same SQL with different OIDs" do + let oid23 = Oid 23 + oid25 = Oid 25 + (key1, cache1) = StatementCache.insert "SELECT $1" [oid23] StatementCache.empty + (key2, _cache2) = StatementCache.insert "SELECT $1" [oid25] cache1 + key1 `shouldNotBe` key2 + + it "distinguishes statements with same SQL but different OIDs" do + let oid23 = Oid 23 + oid25 = Oid 25 + (_key1, cache1) = StatementCache.insert "SELECT $1" [oid23] StatementCache.empty + (_key2, cache2) = StatementCache.insert "SELECT $1" [oid25] cache1 + -- Both should be findable + StatementCache.lookup "SELECT $1" [oid23] cache2 + `shouldSatisfy` isJust + StatementCache.lookup "SELECT $1" [oid25] cache2 + `shouldSatisfy` isJust + -- And should have different remote keys + let Just rk1 = StatementCache.lookup "SELECT $1" [oid23] cache2 + Just rk2 = StatementCache.lookup "SELECT $1" [oid25] cache2 + rk1 `shouldNotBe` rk2 + + it "returns Nothing for a non-inserted SQL" do + let (_key, cache) = StatementCache.insert "SELECT 1" [] StatementCache.empty + StatementCache.lookup "SELECT 2" [] cache + `shouldBe` Nothing + + it "returns Nothing for matching SQL but different OIDs" do + let oid23 = Oid 23 + oid25 = Oid 25 + (_key, cache) = StatementCache.insert "SELECT $1" [oid23] StatementCache.empty + StatementCache.lookup "SELECT $1" [oid25] cache + `shouldBe` Nothing + + it "handles empty OID list" do + let (key, cache) = StatementCache.insert "SELECT 1" [] StatementCache.empty + StatementCache.lookup "SELECT 1" [] cache + `shouldBe` Just key + + it "handles multiple OIDs" do + let oids = [Oid 23, Oid 25, Oid 1043] + (key, cache) = StatementCache.insert "SELECT $1, $2, $3" oids StatementCache.empty + StatementCache.lookup "SELECT $1, $2, $3" oids cache + `shouldBe` Just key + + it "distinguishes different OID ordering" do + let oidsA = [Oid 23, Oid 25] + oidsB = [Oid 25, Oid 23] + (_keyA, cache1) = StatementCache.insert "SELECT $1, $2" oidsA StatementCache.empty + (_keyB, cache2) = StatementCache.insert "SELECT $1, $2" oidsB cache1 + StatementCache.lookup "SELECT $1, $2" oidsA cache2 + `shouldSatisfy` isJust + StatementCache.lookup "SELECT $1, $2" oidsB cache2 + `shouldSatisfy` isJust + let Just rkA = StatementCache.lookup "SELECT $1, $2" oidsA cache2 + Just rkB = StatementCache.lookup "SELECT $1, $2" oidsB cache2 + rkA `shouldNotBe` rkB + + describe "reset" do + it "clears all cached statements" do + let (_key, cache) = StatementCache.insert "SELECT 1" [] StatementCache.empty + resetCache = StatementCache.reset cache + StatementCache.lookup "SELECT 1" [] resetCache + `shouldBe` Nothing + + it "results in a cache equal to empty" do + let (_key, cache) = StatementCache.insert "SELECT 1" [] StatementCache.empty + StatementCache.reset cache + `shouldBe` StatementCache.empty diff --git a/src/engine-tests/Main.hs b/src/engine-tests/Main.hs new file mode 100644 --- /dev/null +++ b/src/engine-tests/Main.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/src/library-tests/Sharing/ByUnit/Decoders/CitextSpec.hs b/src/library-tests/Sharing/ByUnit/Decoders/CitextSpec.hs new file mode 100644 --- /dev/null +++ b/src/library-tests/Sharing/ByUnit/Decoders/CitextSpec.hs @@ -0,0 +1,85 @@ +module Sharing.ByUnit.Decoders.CitextSpec (spec) where + +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 Helpers.Scripts qualified as Scripts +import Test.Hspec +import Prelude + +spec :: SpecWith (Text, Word16) +spec = do + describe "Citext Decoders" do + it "decodes a citext value" \config -> do + Scripts.onPreparableConnection config \connection -> do + result <- Connection.use connection do + catchError + ( Session.statement () + $ Statement.unpreparable + "CREATE EXTENSION IF NOT EXISTS citext" + Encoders.noParams + Decoders.noResult + ) + (const (pure ())) + Session.statement () + $ Statement.preparable + "select 'Hello World'::citext" + mempty + (Decoders.singleRow (Decoders.column (Decoders.nonNullable Decoders.citext))) + result `shouldBe` Right "Hello World" + + it "decodes a citext value preserving case" \config -> do + Scripts.onPreparableConnection config \connection -> do + result <- Connection.use connection do + catchError + ( Session.statement () + $ Statement.unpreparable + "CREATE EXTENSION IF NOT EXISTS citext" + Encoders.noParams + Decoders.noResult + ) + (const (pure ())) + Session.statement () + $ Statement.preparable + "select 'HeLLo WoRLd'::citext" + mempty + (Decoders.singleRow (Decoders.column (Decoders.nonNullable Decoders.citext))) + result `shouldBe` Right "HeLLo WoRLd" + + it "decodes a nullable citext value" \config -> do + Scripts.onPreparableConnection config \connection -> do + result <- Connection.use connection do + catchError + ( Session.statement () + $ Statement.unpreparable + "CREATE EXTENSION IF NOT EXISTS citext" + Encoders.noParams + Decoders.noResult + ) + (const (pure ())) + Session.statement () + $ Statement.preparable + "select null::citext" + mempty + (Decoders.singleRow (Decoders.column (Decoders.nullable Decoders.citext))) + result `shouldBe` Right (Nothing :: Maybe Text) + + it "decodes citext case-insensitive comparison in SQL" \config -> do + Scripts.onPreparableConnection config \connection -> do + result <- Connection.use connection do + catchError + ( Session.statement () + $ Statement.unpreparable + "CREATE EXTENSION IF NOT EXISTS citext" + Encoders.noParams + Decoders.noResult + ) + (const (pure ())) + Session.statement () + $ Statement.preparable + "select 'hello'::citext = 'HELLO'::citext" + mempty + (Decoders.singleRow (Decoders.column (Decoders.nonNullable Decoders.bool))) + result `shouldBe` Right True diff --git a/src/library-tests/Sharing/ByUnit/Encoders/CitextSpec.hs b/src/library-tests/Sharing/ByUnit/Encoders/CitextSpec.hs new file mode 100644 --- /dev/null +++ b/src/library-tests/Sharing/ByUnit/Encoders/CitextSpec.hs @@ -0,0 +1,67 @@ +module Sharing.ByUnit.Encoders.CitextSpec (spec) where + +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 Helpers.Scripts qualified as Scripts +import Test.Hspec +import Prelude + +spec :: SpecWith (Text, Word16) +spec = do + describe "Citext Encoders" do + it "encodes a citext value and compares with static value" \config -> do + Scripts.onPreparableConnection config \connection -> do + result <- Connection.use connection do + catchError + ( Session.statement () + $ Statement.unpreparable + "CREATE EXTENSION IF NOT EXISTS citext" + Encoders.noParams + Decoders.noResult + ) + (const (pure ())) + Session.statement "hello" + $ Statement.preparable + "select $1 = 'hello'" + (Encoders.param (Encoders.nonNullable Encoders.citext)) + (Decoders.singleRow (Decoders.column (Decoders.nonNullable Decoders.bool))) + result `shouldBe` Right True + + it "encodes a citext value with case-insensitive comparison" \config -> do + Scripts.onPreparableConnection config \connection -> do + result <- Connection.use connection do + catchError + ( Session.statement () + $ Statement.unpreparable + "CREATE EXTENSION IF NOT EXISTS citext" + Encoders.noParams + Decoders.noResult + ) + (const (pure ())) + Session.statement "Hello" + $ Statement.preparable + "select $1 = 'hello'" + (Encoders.param (Encoders.nonNullable Encoders.citext)) + (Decoders.singleRow (Decoders.column (Decoders.nonNullable Decoders.bool))) + result `shouldBe` Right True + + it "roundtrips a citext value" \config -> do + Scripts.onPreparableConnection config \connection -> do + result <- Connection.use connection do + catchError + ( Session.statement () + $ Statement.unpreparable + "CREATE EXTENSION IF NOT EXISTS citext" + Encoders.noParams + Decoders.noResult + ) + (const (pure ())) + Session.statement "Hello World" + $ Statement.preparable + "select $1" + (Encoders.param (Encoders.nonNullable Encoders.citext)) + (Decoders.singleRow (Decoders.column (Decoders.nonNullable Decoders.citext))) + result `shouldBe` Right "Hello World" diff --git a/src/library/Hasql/Codecs/Decoders.hs b/src/library/Hasql/Codecs/Decoders.hs --- a/src/library/Hasql/Codecs/Decoders.hs +++ b/src/library/Hasql/Codecs/Decoders.hs @@ -43,6 +43,7 @@ Value.tsmultirange, Value.tstzmultirange, Value.datemultirange, + Value.citext, array, listArray, vectorArray, diff --git a/src/library/Hasql/Codecs/Decoders/Value.hs b/src/library/Hasql/Codecs/Decoders/Value.hs --- a/src/library/Hasql/Codecs/Decoders/Value.hs +++ b/src/library/Hasql/Codecs/Decoders/Value.hs @@ -37,6 +37,7 @@ tsmultirange, tstzmultirange, datemultirange, + citext, custom, refine, hstore, @@ -339,6 +340,14 @@ {-# INLINEABLE datemultirange #-} datemultirange :: Value (R.Multirange Day) datemultirange = primitive "datemultirange" TypeInfo.datemultirange Binary.datemultirange + +-- | +-- Decoder of the @CITEXT@ values. +-- +-- Requires the @citext@ extension to be installed in the database. +{-# INLINEABLE citext #-} +citext :: Value Text +citext = Value Nothing "citext" Nothing Nothing 0 (RequestingOid.lift Binary.text_strict) -- | -- Low level API for defining custom value decoders. diff --git a/src/library/Hasql/Codecs/Encoders.hs b/src/library/Hasql/Codecs/Encoders.hs --- a/src/library/Hasql/Codecs/Encoders.hs +++ b/src/library/Hasql/Codecs/Encoders.hs @@ -55,6 +55,7 @@ Value.tsmultirange, Value.tstzmultirange, Value.datemultirange, + Value.citext, Value.name, Value.oid, foldableArray, diff --git a/src/library/Hasql/Codecs/Encoders/Value.hs b/src/library/Hasql/Codecs/Encoders/Value.hs --- a/src/library/Hasql/Codecs/Encoders/Value.hs +++ b/src/library/Hasql/Codecs/Encoders/Value.hs @@ -312,6 +312,24 @@ datemultirange = primitive "datemultirange" False TypeInfo.datemultirange Binary.datemultirange (TextBuilder.string . show) -- | +-- Encoder of @CITEXT@ values. +-- +-- Requires the @citext@ extension to be installed in the database. +{-# INLINEABLE citext #-} +citext :: Value Text +citext = + Value + Nothing + "citext" + Nothing + Nothing + 0 + False + HashSet.empty + (const Binary.text_strict) + (TextBuilder.string . show) + +-- | -- Given a function which maps a value into a textual enum label used on the DB side, -- produces an encoder of that value for a named enum type. {-# INLINEABLE enum #-} diff --git a/src/library/Hasql/Decoders.hs b/src/library/Hasql/Decoders.hs --- a/src/library/Hasql/Decoders.hs +++ b/src/library/Hasql/Decoders.hs @@ -64,6 +64,7 @@ tsmultirange, tstzmultirange, datemultirange, + citext, array, listArray, vectorArray, diff --git a/src/library/Hasql/Encoders.hs b/src/library/Hasql/Encoders.hs --- a/src/library/Hasql/Encoders.hs +++ b/src/library/Hasql/Encoders.hs @@ -55,6 +55,7 @@ tsmultirange, tstzmultirange, datemultirange, + citext, name, oid, foldableArray, diff --git a/src/library/Hasql/Engine/Structures/StatementCache.hs b/src/library/Hasql/Engine/Structures/StatementCache.hs --- a/src/library/Hasql/Engine/Structures/StatementCache.hs +++ b/src/library/Hasql/Engine/Structures/StatementCache.hs @@ -35,7 +35,7 @@ where remoteKey = fromString $ show $ newCounter newHashMap = HashMap.insert localKey remoteKey hashMap - newCounter = succ counter + newCounter = counter + 1 newState = StatementCache newHashMap newCounter localKey = LocalKey sql oids @@ -52,5 +52,5 @@ instance Hashable LocalKey where {-# INLINE hashWithSalt #-} - hashWithSalt salt (LocalKey template _) = - hashWithSalt salt template + hashWithSalt salt (LocalKey template oids) = + hashWithSalt (hashWithSalt salt template) (fmap Pq.oidToWord32 oids)