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.3.3 +version: 1.10.3.4 category: Hasql, Database, PostgreSQL synopsis: Fast PostgreSQL driver with a flexible mapping API description: @@ -125,7 +125,6 @@ Hasql.Codecs.Encoders.Value Hasql.Codecs.RequestingOid Hasql.Codecs.RequestingOid.LookingUp - Hasql.Codecs.TypeInfo Hasql.Comms.Recv Hasql.Comms.ResultDecoder Hasql.Comms.Roundtrip @@ -145,6 +144,10 @@ Hasql.Engine.Structures.ConnectionState Hasql.Engine.Structures.OidCache Hasql.Engine.Structures.StatementCache + Hasql.Kernel + Hasql.Kernel.QualifiedTypeName + Hasql.Kernel.TypeInfo + Hasql.Kernel.TypeRef Hasql.Platform.Prelude Hasql.Platform.Prelude.Text Hasql.Pq @@ -265,6 +268,10 @@ Hasql.Engine.Structures.OidCacheSpec Hasql.Engine.Structures.StatementCache Hasql.Engine.Structures.StatementCacheSpec + Hasql.Kernel + Hasql.Kernel.QualifiedTypeName + Hasql.Kernel.TypeInfo + Hasql.Kernel.TypeRef Hasql.Platform.Prelude Hasql.Platform.Prelude.Text Hasql.Pq @@ -318,6 +325,7 @@ Pure.ByUnit.ErrorsSpec Sharing.ByBug.ExceptionConnectionResetRaceSpec Sharing.ByFeature.ConcurrencySpec + Sharing.ByFeature.DecoderCompatibilityCacheSpec Sharing.ByFeature.DecoderCompatibilityCheckSpec Sharing.ByFeature.PreparedStatementCacheSpec Sharing.ByFeature.PreparedStatementsSpec diff --git a/src/benchmarks/Main.hs b/src/benchmarks/Main.hs --- a/src/benchmarks/Main.hs +++ b/src/benchmarks/Main.hs @@ -1,4 +1,4 @@ -module Main where +module Main (main) where import Criterion import Criterion.Main @@ -27,16 +27,7 @@ sessionBench "manyLargeResults" sessionWithManyLargeResults, sessionBench "manyLargeResultsViaPipeline" sessionWithManyLargeResultsViaPipeline, sessionBench "manySmallResults" sessionWithManySmallResults, - sessionBench "manySmallResultsViaPipeline" sessionWithManySmallResultsViaPipeline, - bgroup - "singleStatementOverhead" - [ sessionBench "1-sequential" sessionWith1SmallResult, - sessionBench "1-pipeline" sessionWith1SmallResultViaPipeline, - sessionBench "10-sequential" sessionWith10SmallResults, - sessionBench "10-pipeline" sessionWith10SmallResultsViaPipeline, - sessionBench "100-sequential" sessionWithManySmallResults, - sessionBench "100-pipeline" sessionWithManySmallResultsViaPipeline - ] + sessionBench "manySmallResultsViaPipeline" sessionWithManySmallResultsViaPipeline ] where sessionBench :: (NFData a) => String -> B.Session a -> Benchmark @@ -44,22 +35,6 @@ bench name (nfIO (A.use connection session >>= either (fail . show) pure)) -- * Sessions - -sessionWith1SmallResult :: B.Session (Int32, Int32) -sessionWith1SmallResult = - B.statement () statementWithSingleRow - -sessionWith1SmallResultViaPipeline :: B.Session (Int32, Int32) -sessionWith1SmallResultViaPipeline = - B.pipeline (E.statement () statementWithSingleRow) - -sessionWith10SmallResults :: B.Session [(Int32, Int32)] -sessionWith10SmallResults = - replicateM 10 (B.statement () statementWithSingleRow) - -sessionWith10SmallResultsViaPipeline :: B.Session [(Int32, Int32)] -sessionWith10SmallResultsViaPipeline = - B.pipeline (replicateM 10 (E.statement () statementWithSingleRow)) sessionWithSingleLargeResultInVector :: B.Session (Vector (Int32, Int32)) sessionWithSingleLargeResultInVector = diff --git a/src/engine-tests/Hasql/Engine/Structures/OidCacheSpec.hs b/src/engine-tests/Hasql/Engine/Structures/OidCacheSpec.hs --- a/src/engine-tests/Hasql/Engine/Structures/OidCacheSpec.hs +++ b/src/engine-tests/Hasql/Engine/Structures/OidCacheSpec.hs @@ -2,6 +2,7 @@ import Data.HashSet qualified as HashSet import Hasql.Engine.Structures.OidCache qualified as OidCache +import Hasql.Kernel.QualifiedTypeName qualified as Kernel.QualifiedTypeName import Test.Hspec import Prelude @@ -54,7 +55,7 @@ describe "selectUnknownNames" do it "returns all names when cache is empty" do - let names = HashSet.fromList [(Nothing, "int4"), (Nothing, "int8")] + let names = HashSet.fromList [Kernel.QualifiedTypeName.QualifiedTypeName Nothing "int4", Kernel.QualifiedTypeName.QualifiedTypeName Nothing "int8"] OidCache.selectUnknownNames names OidCache.empty `shouldBe` names @@ -66,15 +67,15 @@ 23 1007 (OidCache.insertScalar Nothing "int8" 20 1016 OidCache.empty) - names = HashSet.fromList [(Nothing, "int4"), (Nothing, "int8")] + names = HashSet.fromList [Kernel.QualifiedTypeName.QualifiedTypeName Nothing "int4", Kernel.QualifiedTypeName.QualifiedTypeName 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")] + names = HashSet.fromList [Kernel.QualifiedTypeName.QualifiedTypeName Nothing "int4", Kernel.QualifiedTypeName.QualifiedTypeName Nothing "int8"] OidCache.selectUnknownNames names cache - `shouldBe` HashSet.fromList [(Nothing, "int8")] + `shouldBe` HashSet.fromList [Kernel.QualifiedTypeName.QualifiedTypeName Nothing "int8"] describe "Semigroup" do it "right operand takes precedence for duplicate keys" do diff --git a/src/engine-tests/Hasql/Engine/Structures/StatementCacheSpec.hs b/src/engine-tests/Hasql/Engine/Structures/StatementCacheSpec.hs --- a/src/engine-tests/Hasql/Engine/Structures/StatementCacheSpec.hs +++ b/src/engine-tests/Hasql/Engine/Structures/StatementCacheSpec.hs @@ -1,10 +1,9 @@ module Hasql.Engine.Structures.StatementCacheSpec (spec) where -import Data.Maybe (isJust, isNothing) +import Data.Maybe import Database.PostgreSQL.LibPQ (Oid (..)) import Hasql.Engine.Structures.StatementCache qualified as StatementCache import Test.Hspec -import Prelude spec :: Spec spec = do @@ -42,8 +41,8 @@ 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 + let rk1 = StatementCache.lookup "SELECT $1" [oid23] cache2 + rk2 = StatementCache.lookup "SELECT $1" [oid25] cache2 rk1 `shouldNotBe` rk2 it "returns Nothing for a non-inserted SQL" do @@ -78,8 +77,8 @@ `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 + let rkA = StatementCache.lookup "SELECT $1, $2" oidsA cache2 + rkB = StatementCache.lookup "SELECT $1, $2" oidsB cache2 rkA `shouldNotBe` rkB describe "reset" do diff --git a/src/library-tests/Sharing/ByFeature/DecoderCompatibilityCacheSpec.hs b/src/library-tests/Sharing/ByFeature/DecoderCompatibilityCacheSpec.hs new file mode 100644 --- /dev/null +++ b/src/library-tests/Sharing/ByFeature/DecoderCompatibilityCacheSpec.hs @@ -0,0 +1,57 @@ +module Sharing.ByFeature.DecoderCompatibilityCacheSpec (spec) where + +import Hasql.Connection qualified as Connection +import Hasql.Decoders qualified as Decoders +import Hasql.Errors qualified as Errors +import Hasql.Pipeline qualified as Pipeline +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 = parallel do + byExecutor "Session" (Session.statement ()) + byExecutor "Pipeline" (Session.pipeline . Pipeline.statement ()) + +byExecutor :: + Text -> + (forall a. (Show a) => Statement.Statement () a -> Session.Session a) -> + SpecWith (Text, Word16) +byExecutor executorName executor = do + describe (toList executorName) do + it "does not hide decoder mismatches from a previously verified statement" \config -> do + Scripts.onPreparableConnection config \connection -> do + let sql = "select 1::int8, 'text'::text" + correctStatement = + Statement.preparable + sql + mempty + ( Decoders.singleRow + ( (,) + <$> Decoders.column (Decoders.nonNullable Decoders.int8) + <*> Decoders.column (Decoders.nonNullable Decoders.text) + ) + ) + mismatchingStatement = + Statement.preparable + sql + mempty + ( Decoders.singleRow + ( (,) + <$> Decoders.column (Decoders.nonNullable Decoders.int8) + <*> Decoders.column (Decoders.nonNullable Decoders.int8) + ) + ) + firstResult <- Connection.use connection (executor correctStatement) + shouldBe firstResult (Right (1, "text")) + secondResult <- Connection.use connection (executor mismatchingStatement) + case secondResult of + Left (Errors.StatementSessionError _ _ _ _ _ (Errors.UnexpectedColumnTypeStatementError column expected actual)) -> do + shouldBe column 1 + (expected, actual) `shouldBe` (20, 25) + Left err -> + expectationFailure ("Unexpected type of error: " <> show err) + result -> + expectationFailure ("Not an error: " <> show result) diff --git a/src/library-tests/Sharing/ByUnit/Decoders/CustomSpec.hs b/src/library-tests/Sharing/ByUnit/Decoders/CustomSpec.hs --- a/src/library-tests/Sharing/ByUnit/Decoders/CustomSpec.hs +++ b/src/library-tests/Sharing/ByUnit/Decoders/CustomSpec.hs @@ -4,6 +4,7 @@ import Data.HashSet qualified as HashSet import Data.Text.Encoding (encodeUtf8) import Hasql.Connection qualified as Connection +import Hasql.Decoders (TypeInfo (..)) import Hasql.Decoders qualified as Decoders import Hasql.Encoders qualified as Encoders import Hasql.Errors qualified as Errors @@ -66,7 +67,7 @@ ( Decoders.custom Nothing "int4" - (Just (23, 1007)) + (Just (TypeInfo 23 1007)) [] (\_ bytes -> Right (ByteString.length bytes)) ) @@ -107,8 +108,10 @@ Nothing [(Nothing, enumName), (Nothing, "int4")] ( \lookupOid bytes -> do - let (enumOidScalar, _enumOidArray) = lookupOid (Nothing, enumName) - (int4OidScalar, _int4OidArray) = lookupOid (Nothing, "int4") + let enumTypeInfo = lookupOid (Nothing, enumName) + int4TypeInfo = lookupOid (Nothing, "int4") + enumOidScalar = toBaseOid enumTypeInfo + int4OidScalar = toBaseOid int4TypeInfo -- Verify we got valid OIDs if enumOidScalar > 0 && int4OidScalar > 0 then Right (enumOidScalar, int4OidScalar, ByteString.length bytes) @@ -203,7 +206,7 @@ ( Decoders.custom Nothing "int4" - (Just (23, 1007)) + (Just (TypeInfo 23 1007)) [] (\_ _ -> Left "Custom decoding error") ) diff --git a/src/library-tests/Sharing/ByUnit/Encoders/CustomSpec.hs b/src/library-tests/Sharing/ByUnit/Encoders/CustomSpec.hs --- a/src/library-tests/Sharing/ByUnit/Encoders/CustomSpec.hs +++ b/src/library-tests/Sharing/ByUnit/Encoders/CustomSpec.hs @@ -4,6 +4,7 @@ import Data.Text.Encoding (encodeUtf8) import Hasql.Connection qualified as Connection import Hasql.Decoders qualified as Decoders +import Hasql.Encoders (TypeInfo (..)) import Hasql.Encoders qualified as Encoders import Hasql.Errors qualified as Errors import Hasql.Session qualified as Session @@ -57,7 +58,7 @@ ( Encoders.custom Nothing "text" - (Just (25, 1009)) + (Just (TypeInfo 25 1009)) [] (\_ val -> encodeUtf8 val) id @@ -89,7 +90,8 @@ Nothing [(Nothing, enumName)] ( \lookupOid val -> do - let (enumOidScalar, _) = lookupOid (Nothing, enumName) + let enumTypeInfo = lookupOid (Nothing, enumName) + enumOidScalar = toBaseOid enumTypeInfo -- Verify we got a valid OID (non-zero) if enumOidScalar > 0 then encodeUtf8 val 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 @@ -70,7 +70,7 @@ import Hasql.Codecs.Decoders.Composite qualified as Composite import Hasql.Codecs.Decoders.NullableOrNot qualified as NullableOrNot import Hasql.Codecs.Decoders.Value qualified as Value -import Hasql.Codecs.TypeInfo qualified as TypeInfo +import Hasql.Kernel.TypeInfo qualified as Kernel.TypeInfo import Hasql.Platform.Prelude -- * Value @@ -139,9 +139,9 @@ Value.Value Nothing "record" - (Just (TypeInfo.toBaseOid typeInfo)) - (Just (TypeInfo.toArrayOid typeInfo)) + (Just (Kernel.TypeInfo.toBaseOid typeInfo)) + (Just (Kernel.TypeInfo.toArrayOid typeInfo)) 0 (Composite.toValueDecoder composite) where - typeInfo = TypeInfo.record + typeInfo = Kernel.TypeInfo.record diff --git a/src/library/Hasql/Codecs/Decoders/Composite.hs b/src/library/Hasql/Codecs/Decoders/Composite.hs --- a/src/library/Hasql/Codecs/Decoders/Composite.hs +++ b/src/library/Hasql/Codecs/Decoders/Composite.hs @@ -3,6 +3,8 @@ import Hasql.Codecs.Decoders.NullableOrNot qualified as NullableOrNot import Hasql.Codecs.Decoders.Value qualified as Value import Hasql.Codecs.RequestingOid qualified as RequestingOid +import Hasql.Kernel.QualifiedTypeName qualified as Kernel.QualifiedTypeName +import Hasql.Kernel.TypeInfo qualified as Kernel.TypeInfo import Hasql.Platform.Prelude import PostgreSQL.Binary.Decoding qualified as Binary @@ -31,8 +33,8 @@ Nothing -> Composite ( RequestingOid.hoistLookingUp - (Value.toSchema imp, Value.toTypeName imp) - (\(baseOid, arrayOid) decoder -> Binary.typedValueComposite (if dimensionality == 0 then baseOid else arrayOid) decoder) + (Kernel.QualifiedTypeName.QualifiedTypeName (Value.toSchema imp) (Value.toTypeName imp)) + (\typeInfo decoder -> Binary.typedValueComposite (if dimensionality == 0 then Kernel.TypeInfo.toBaseOid typeInfo else Kernel.TypeInfo.toArrayOid typeInfo) decoder) (Value.toDecoder imp) ) NullableOrNot.Nullable imp -> @@ -44,7 +46,7 @@ Nothing -> Composite ( RequestingOid.hoistLookingUp - (Value.toSchema imp, Value.toTypeName imp) - (\(baseOid, arrayOid) decoder -> Binary.typedNullableValueComposite (if dimensionality == 0 then baseOid else arrayOid) decoder) + (Kernel.QualifiedTypeName.QualifiedTypeName (Value.toSchema imp) (Value.toTypeName imp)) + (\typeInfo decoder -> Binary.typedNullableValueComposite (if dimensionality == 0 then Kernel.TypeInfo.toBaseOid typeInfo else Kernel.TypeInfo.toArrayOid typeInfo) decoder) (Value.toDecoder imp) ) 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 @@ -58,7 +58,9 @@ import Data.Aeson qualified as Aeson import Data.IP qualified as Iproute import Hasql.Codecs.RequestingOid qualified as RequestingOid -import Hasql.Codecs.TypeInfo qualified as TypeInfo +import Hasql.Kernel qualified as Kernel +import Hasql.Kernel.QualifiedTypeName qualified as Kernel.QualifiedTypeName +import Hasql.Kernel.TypeInfo qualified as Kernel.TypeInfo import Hasql.Platform.Prelude hiding (bool) import PostgreSQL.Binary.Decoding qualified as Binary import PostgreSQL.Binary.Range qualified as R @@ -91,9 +93,9 @@ -- | -- Create a decoder from TypeInfo metadata and a decoding function. {-# INLINE primitive #-} -primitive :: Text -> TypeInfo.TypeInfo -> Binary.Value a -> Value a +primitive :: Text -> Kernel.TypeInfo.TypeInfo -> Binary.Value a -> Value a primitive typeName pti decoder = - Value Nothing typeName (Just (TypeInfo.toBaseOid pti)) (Just (TypeInfo.toArrayOid pti)) 0 (RequestingOid.lift decoder) + Value Nothing typeName (Just (Kernel.TypeInfo.toBaseOid pti)) (Just (Kernel.TypeInfo.toArrayOid pti)) 0 (RequestingOid.lift decoder) -- * Static types @@ -101,19 +103,19 @@ -- Decoder of the @BOOL@ values. {-# INLINEABLE bool #-} bool :: Value Bool -bool = primitive "bool" TypeInfo.bool Binary.bool +bool = primitive "bool" Kernel.TypeInfo.bool Binary.bool -- | -- Decoder of the @INT2@ values. {-# INLINEABLE int2 #-} int2 :: Value Int16 -int2 = primitive "int2" TypeInfo.int2 Binary.int +int2 = primitive "int2" Kernel.TypeInfo.int2 Binary.int -- | -- Decoder of the @INT4@ values. {-# INLINEABLE int4 #-} int4 :: Value Int32 -int4 = primitive "int4" TypeInfo.int4 Binary.int +int4 = primitive "int4" Kernel.TypeInfo.int4 Binary.int -- | -- Decoder of the @INT8@ values. @@ -121,68 +123,68 @@ int8 :: Value Int64 int8 = {-# SCC "int8" #-} - primitive "int8" TypeInfo.int8 ({-# SCC "int8.int" #-} Binary.int) + primitive "int8" Kernel.TypeInfo.int8 ({-# SCC "int8.int" #-} Binary.int) -- | -- Decoder of the @FLOAT4@ values. {-# INLINEABLE float4 #-} float4 :: Value Float -float4 = primitive "float4" TypeInfo.float4 Binary.float4 +float4 = primitive "float4" Kernel.TypeInfo.float4 Binary.float4 -- | -- Decoder of the @FLOAT8@ values. {-# INLINEABLE float8 #-} float8 :: Value Double -float8 = primitive "float8" TypeInfo.float8 Binary.float8 +float8 = primitive "float8" Kernel.TypeInfo.float8 Binary.float8 -- | -- Decoder of the @NUMERIC@ values. {-# INLINEABLE numeric #-} numeric :: Value Scientific -numeric = primitive "numeric" TypeInfo.numeric Binary.numeric +numeric = primitive "numeric" Kernel.TypeInfo.numeric Binary.numeric -- | -- Decoder of the @CHAR@ values. -- Note that it supports Unicode values. {-# INLINEABLE char #-} char :: Value Char -char = primitive "char" TypeInfo.char Binary.char +char = primitive "char" Kernel.TypeInfo.char Binary.char -- | -- Decoder of the @TEXT@ values. {-# INLINEABLE text #-} text :: Value Text -text = primitive "text" TypeInfo.text Binary.text_strict +text = primitive "text" Kernel.TypeInfo.text Binary.text_strict -- | -- Decoder of the @VARCHAR@ values. {-# INLINEABLE varchar #-} varchar :: Value Text -varchar = primitive "varchar" TypeInfo.varchar Binary.text_strict +varchar = primitive "varchar" Kernel.TypeInfo.varchar Binary.text_strict -- | -- Decoder of @BPCHAR@ or @CHAR(n)@, @CHARACTER(n)@ values. {-# INLINEABLE bpchar #-} bpchar :: Value Text -bpchar = primitive "bpchar" TypeInfo.bpchar Binary.text_strict +bpchar = primitive "bpchar" Kernel.TypeInfo.bpchar Binary.text_strict -- | -- Decoder of the @BYTEA@ values. {-# INLINEABLE bytea #-} bytea :: Value ByteString -bytea = primitive "bytea" TypeInfo.bytea Binary.bytea_strict +bytea = primitive "bytea" Kernel.TypeInfo.bytea Binary.bytea_strict -- | -- Decoder of the @DATE@ values. {-# INLINEABLE date #-} date :: Value Day -date = primitive "date" TypeInfo.date Binary.date +date = primitive "date" Kernel.TypeInfo.date Binary.date -- | -- Decoder of the @TIMESTAMP@ values. {-# INLINEABLE timestamp #-} timestamp :: Value LocalTime -timestamp = primitive "timestamp" TypeInfo.timestamp Binary.timestamp_int +timestamp = primitive "timestamp" Kernel.TypeInfo.timestamp Binary.timestamp_int -- | -- Decoder of the @TIMESTAMPTZ@ values. @@ -196,13 +198,13 @@ -- and communicates with Postgres using the UTC values directly. {-# INLINEABLE timestamptz #-} timestamptz :: Value UTCTime -timestamptz = primitive "timestamptz" TypeInfo.timestamptz Binary.timestamptz_int +timestamptz = primitive "timestamptz" Kernel.TypeInfo.timestamptz Binary.timestamptz_int -- | -- Decoder of the @TIME@ values. {-# INLINEABLE time #-} time :: Value TimeOfDay -time = primitive "time" TypeInfo.time Binary.time_int +time = primitive "time" Kernel.TypeInfo.time Binary.time_int -- | -- Decoder of the @TIMETZ@ values. @@ -214,25 +216,25 @@ -- to represent a value on the Haskell's side. {-# INLINEABLE timetz #-} timetz :: Value (TimeOfDay, TimeZone) -timetz = primitive "timetz" TypeInfo.timetz Binary.timetz_int +timetz = primitive "timetz" Kernel.TypeInfo.timetz Binary.timetz_int -- | -- Decoder of the @INTERVAL@ values. {-# INLINEABLE interval #-} interval :: Value DiffTime -interval = primitive "interval" TypeInfo.interval Binary.interval_int +interval = primitive "interval" Kernel.TypeInfo.interval Binary.interval_int -- | -- Decoder of the @UUID@ values. {-# INLINEABLE uuid #-} uuid :: Value UUID -uuid = primitive "uuid" TypeInfo.uuid Binary.uuid +uuid = primitive "uuid" Kernel.TypeInfo.uuid Binary.uuid -- | -- Decoder of the @INET@ values. {-# INLINEABLE inet #-} inet :: Value Iproute.IPRange -inet = primitive "inet" TypeInfo.inet Binary.inet +inet = primitive "inet" Kernel.TypeInfo.inet Binary.inet -- | -- Decoder of the @MACADDR@ values. @@ -243,103 +245,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 = primitive "macaddr" TypeInfo.macaddr Binary.macaddr +macaddr = primitive "macaddr" Kernel.TypeInfo.macaddr Binary.macaddr -- | -- Decoder of the @JSON@ values into a JSON AST. {-# INLINEABLE json #-} json :: Value Aeson.Value -json = primitive "json" TypeInfo.json Binary.json_ast +json = primitive "json" Kernel.TypeInfo.json Binary.json_ast -- | -- Decoder of the @JSON@ values into a raw JSON 'ByteString'. {-# INLINEABLE jsonBytes #-} jsonBytes :: (ByteString -> Either Text a) -> Value a -jsonBytes fn = primitive "json" TypeInfo.json (Binary.json_bytes fn) +jsonBytes fn = primitive "json" Kernel.TypeInfo.json (Binary.json_bytes fn) -- | -- Decoder of the @JSONB@ values into a JSON AST. {-# INLINEABLE jsonb #-} jsonb :: Value Aeson.Value -jsonb = primitive "jsonb" TypeInfo.jsonb Binary.jsonb_ast +jsonb = primitive "jsonb" Kernel.TypeInfo.jsonb Binary.jsonb_ast -- | -- Decoder of the @JSONB@ values into a raw JSON 'ByteString'. {-# INLINEABLE jsonbBytes #-} jsonbBytes :: (ByteString -> Either Text a) -> Value a -jsonbBytes fn = primitive "jsonb" TypeInfo.jsonb (Binary.jsonb_bytes fn) +jsonbBytes fn = primitive "jsonb" Kernel.TypeInfo.jsonb (Binary.jsonb_bytes fn) -- | -- Decoder of the @INT4RANGE@ values. {-# INLINEABLE int4range #-} int4range :: Value (R.Range Int32) -int4range = primitive "int4range" TypeInfo.int4range Binary.int4range +int4range = primitive "int4range" Kernel.TypeInfo.int4range Binary.int4range -- | -- Decoder of the @INT8RANGE@ values. {-# INLINEABLE int8range #-} int8range :: Value (R.Range Int64) -int8range = primitive "int8range" TypeInfo.int8range Binary.int8range +int8range = primitive "int8range" Kernel.TypeInfo.int8range Binary.int8range -- | -- Decoder of the @NUMRANGE@ values. {-# INLINEABLE numrange #-} numrange :: Value (R.Range Scientific) -numrange = primitive "numrange" TypeInfo.numrange Binary.numrange +numrange = primitive "numrange" Kernel.TypeInfo.numrange Binary.numrange -- | -- Decoder of the @TSRANGE@ values. {-# INLINEABLE tsrange #-} tsrange :: Value (R.Range LocalTime) -tsrange = primitive "tsrange" TypeInfo.tsrange Binary.tsrange_int +tsrange = primitive "tsrange" Kernel.TypeInfo.tsrange Binary.tsrange_int -- | -- Decoder of the @TSTZRANGE@ values. {-# INLINEABLE tstzrange #-} tstzrange :: Value (R.Range UTCTime) -tstzrange = primitive "tstzrange" TypeInfo.tstzrange Binary.tstzrange_int +tstzrange = primitive "tstzrange" Kernel.TypeInfo.tstzrange Binary.tstzrange_int -- | -- Decoder of the @DATERANGE@ values. {-# INLINEABLE daterange #-} daterange :: Value (R.Range Day) -daterange = primitive "daterange" TypeInfo.daterange Binary.daterange +daterange = primitive "daterange" Kernel.TypeInfo.daterange Binary.daterange -- | -- Decoder of the @INT4MULTIRANGE@ values. {-# INLINEABLE int4multirange #-} int4multirange :: Value (R.Multirange Int32) -int4multirange = primitive "int4multirange" TypeInfo.int4multirange Binary.int4multirange +int4multirange = primitive "int4multirange" Kernel.TypeInfo.int4multirange Binary.int4multirange -- | -- Decoder of the @INT8MULTIRANGE@ values. {-# INLINEABLE int8multirange #-} int8multirange :: Value (R.Multirange Int64) -int8multirange = primitive "int8multirange" TypeInfo.int8multirange Binary.int8multirange +int8multirange = primitive "int8multirange" Kernel.TypeInfo.int8multirange Binary.int8multirange -- | -- Decoder of the @NUMMULTIRANGE@ values. {-# INLINEABLE nummultirange #-} nummultirange :: Value (R.Multirange Scientific) -nummultirange = primitive "nummultirange" TypeInfo.nummultirange Binary.nummultirange +nummultirange = primitive "nummultirange" Kernel.TypeInfo.nummultirange Binary.nummultirange -- | -- Decoder of the @TSMULTIRANGE@ values. {-# INLINEABLE tsmultirange #-} tsmultirange :: Value (R.Multirange LocalTime) -tsmultirange = primitive "tsmultirange" TypeInfo.tsmultirange Binary.tsmultirange_int +tsmultirange = primitive "tsmultirange" Kernel.TypeInfo.tsmultirange Binary.tsmultirange_int -- | -- Decoder of the @TSTZMULTIRANGE@ values. {-# INLINEABLE tstzmultirange #-} tstzmultirange :: Value (R.Multirange UTCTime) -tstzmultirange = primitive "tstzmultirange" TypeInfo.tstzmultirange Binary.tstzmultirange_int +tstzmultirange = primitive "tstzmultirange" Kernel.TypeInfo.tstzmultirange Binary.tstzmultirange_int -- | -- Decoder of the @DATEMULTIRANGE@ values. {-# INLINEABLE datemultirange #-} datemultirange :: Value (R.Multirange Day) -datemultirange = primitive "datemultirange" TypeInfo.datemultirange Binary.datemultirange +datemultirange = primitive "datemultirange" Kernel.TypeInfo.datemultirange Binary.datemultirange -- | -- Decoder of the @CITEXT@ values. @@ -360,7 +362,7 @@ -- | Possible static OIDs for the type. The first is for scalar values the second is for arrays. -- -- When unspecified, the OIDs will be automatically determined at runtime by looking up by name. - Maybe (Word32, Word32) -> + Maybe Kernel.TypeInfo.TypeInfo -> -- | Other named types whose OIDs are needed for deserializing. -- -- E.g., when decoding composite types you can check the OIDs of its fields against the ones specified by Postgres. @@ -371,7 +373,7 @@ -- -- It's safe to assume that all of the requested types will be present. -- In case you run the provided lookup function with unmentioned type names it will produce OID of 0 for them, standing for unknown type in Postgres. - ( ((Maybe Text, Text) -> (Word32, Word32)) -> + ( ((Maybe Text, Text) -> Kernel.TypeInfo.TypeInfo) -> ByteString -> Either Text a ) -> @@ -380,10 +382,10 @@ Value schema typeName - (fst <$> staticOids) - (snd <$> staticOids) + (fmap Kernel.TypeInfo.toBaseOid staticOids) + (fmap Kernel.TypeInfo.toArrayOid staticOids) 0 - (RequestingOid.requestAndHandle requestedTypes (Binary.fn . fn)) + (RequestingOid.requestAndHandle (fmap Kernel.QualifiedTypeName.fromNameTuple requestedTypes) (\lookup -> Binary.fn (fn (lookup . Kernel.QualifiedTypeName.fromNameTuple)))) -- | -- Refine a value decoder, lifting the possible error to the session level. @@ -446,11 +448,11 @@ toDecoder (Value _ _ _ _ _ decoder) = decoder {-# INLINE toHandler #-} -toHandler :: Value a -> HashMap (Maybe Text, Text) (Word32, Word32) -> Binary.Value a +toHandler :: Value a -> HashMap Kernel.QualifiedTypeName Kernel.TypeInfo.TypeInfo -> Binary.Value a toHandler (Value _ _ _ _ _ decoder) = RequestingOid.toBase decoder {-# INLINE toByteStringParser #-} -toByteStringParser :: Value a -> (HashMap (Maybe Text, Text) (Word32, Word32) -> ByteString -> Either Text a) +toByteStringParser :: Value a -> (HashMap Kernel.QualifiedTypeName Kernel.TypeInfo.TypeInfo -> ByteString -> Either Text a) toByteStringParser (Value _ _ _ _ _ decoder) oidCache = Binary.valueParser (RequestingOid.toBase decoder oidCache) isArray :: Value a -> Bool 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 @@ -83,7 +83,8 @@ import Hasql.Codecs.Encoders.NullableOrNot qualified as NullableOrNot import Hasql.Codecs.Encoders.Params qualified as Params import Hasql.Codecs.Encoders.Value qualified as Value -import Hasql.Codecs.TypeInfo qualified as TypeInfo +import Hasql.Kernel.QualifiedTypeName qualified as Kernel.QualifiedTypeName +import Hasql.Kernel.TypeInfo qualified as Kernel.TypeInfo import Hasql.Platform.Prelude hiding (bool) import PostgreSQL.Binary.Encoding qualified as Binary import TextBuilder qualified @@ -121,11 +122,11 @@ asum [ scalarOidIfKnown, oidCache - & HashMap.lookup (baseTypeSchema, baseTypeName) - & fmap fst + & HashMap.lookup (Kernel.QualifiedTypeName.QualifiedTypeName baseTypeSchema baseTypeName) + & fmap Kernel.TypeInfo.toBaseOid ] -- Should only happen on a bug. - & fromMaybe (TypeInfo.toBaseOid TypeInfo.unknown) + & fromMaybe (Kernel.TypeInfo.toBaseOid Kernel.TypeInfo.unknown) in Binary.array resolvedOid (arrayEncoder oidCache input) in Value.Value baseTypeSchema baseTypeName scalarOidIfKnown arrayOidIfKnown dimensionality False unknownTypes encoder renderer diff --git a/src/library/Hasql/Codecs/Encoders/Array.hs b/src/library/Hasql/Codecs/Encoders/Array.hs --- a/src/library/Hasql/Codecs/Encoders/Array.hs +++ b/src/library/Hasql/Codecs/Encoders/Array.hs @@ -2,6 +2,7 @@ import Hasql.Codecs.Encoders.NullableOrNot qualified as NullableOrNot import Hasql.Codecs.Encoders.Value qualified as Value +import Hasql.Kernel qualified as Kernel import Hasql.Platform.Prelude import PostgreSQL.Binary.Encoding qualified as Binary import TextBuilder qualified as TextBuilder @@ -33,9 +34,9 @@ -- | OID of the array type. (Maybe Word32) -- | Names of types that are not known statically and must be looked up at runtime collected from the nested composite and array encoders. - (HashSet (Maybe Text, Text)) + (HashSet Kernel.QualifiedTypeName) -- | Serialization function given the dictionary of resolved OIDs. - (HashMap (Maybe Text, Text) (Word32, Word32) -> a -> Binary.Array) + (HashMap Kernel.QualifiedTypeName Kernel.TypeInfo -> a -> Binary.Array) -- | Render function for error messages. (a -> TextBuilder.TextBuilder) diff --git a/src/library/Hasql/Codecs/Encoders/Composite.hs b/src/library/Hasql/Codecs/Encoders/Composite.hs --- a/src/library/Hasql/Codecs/Encoders/Composite.hs +++ b/src/library/Hasql/Codecs/Encoders/Composite.hs @@ -4,6 +4,9 @@ import Data.HashSet qualified as HashSet import Hasql.Codecs.Encoders.NullableOrNot qualified as NullableOrNot import Hasql.Codecs.Encoders.Value qualified as Value +import Hasql.Kernel qualified as Kernel +import Hasql.Kernel.QualifiedTypeName qualified as Kernel.QualifiedTypeName +import Hasql.Kernel.TypeInfo qualified as Kernel.TypeInfo import Hasql.Platform.Prelude hiding (bool) import PostgreSQL.Binary.Encoding qualified as Binary import TextBuilder qualified @@ -13,9 +16,9 @@ data Composite a = Composite -- | Names of types that are not known statically and must be looked up at runtime collected from the nested composite and array encoders. - (HashSet (Maybe Text, Text)) + (HashSet Kernel.QualifiedTypeName) -- | Serialization function given the dictionary of resolved OIDs. - (HashMap (Maybe Text, Text) (Word32, Word32) -> a -> Binary.Composite) + (HashMap Kernel.QualifiedTypeName Kernel.TypeInfo -> a -> Binary.Composite) -- | Render function for error messages. (a -> [TextBuilder.TextBuilder]) @@ -54,9 +57,10 @@ (\val -> [print val]) Nothing -> Composite - (HashSet.insert (schemaName, typeName) unknownTypes) + (HashSet.insert (Kernel.QualifiedTypeName.QualifiedTypeName schemaName typeName) unknownTypes) ( \oidCache val -> - let oid = if dimensionality == 0 then maybe 0 fst (HashMap.lookup (schemaName, typeName) oidCache) else maybe 0 snd (HashMap.lookup (schemaName, typeName) oidCache) + let typeInfo = HashMap.lookup (Kernel.QualifiedTypeName.QualifiedTypeName schemaName typeName) oidCache + oid = if dimensionality == 0 then maybe 0 Kernel.TypeInfo.toBaseOid typeInfo else maybe 0 Kernel.TypeInfo.toArrayOid typeInfo in Binary.field oid (encode oidCache val) ) (\val -> [print val]) @@ -76,13 +80,15 @@ ) Nothing -> Composite - (HashSet.insert (schemaName, typeName) unknownTypes) + (HashSet.insert (Kernel.QualifiedTypeName.QualifiedTypeName schemaName typeName) unknownTypes) ( \oidCache -> \case Nothing -> - let oid = if dimensionality == 0 then maybe 0 fst (HashMap.lookup (schemaName, typeName) oidCache) else maybe 0 snd (HashMap.lookup (schemaName, typeName) oidCache) + let typeInfo = HashMap.lookup (Kernel.QualifiedTypeName.QualifiedTypeName schemaName typeName) oidCache + oid = if dimensionality == 0 then maybe 0 Kernel.TypeInfo.toBaseOid typeInfo else maybe 0 Kernel.TypeInfo.toArrayOid typeInfo in Binary.nullField oid Just val -> - let oid = if dimensionality == 0 then maybe 0 fst (HashMap.lookup (schemaName, typeName) oidCache) else maybe 0 snd (HashMap.lookup (schemaName, typeName) oidCache) + let typeInfo = HashMap.lookup (Kernel.QualifiedTypeName.QualifiedTypeName schemaName typeName) oidCache + oid = if dimensionality == 0 then maybe 0 Kernel.TypeInfo.toBaseOid typeInfo else maybe 0 Kernel.TypeInfo.toArrayOid typeInfo in Binary.field oid (encode oidCache val) ) ( \case diff --git a/src/library/Hasql/Codecs/Encoders/Params.hs b/src/library/Hasql/Codecs/Encoders/Params.hs --- a/src/library/Hasql/Codecs/Encoders/Params.hs +++ b/src/library/Hasql/Codecs/Encoders/Params.hs @@ -4,6 +4,10 @@ import Data.HashSet qualified as HashSet import Hasql.Codecs.Encoders.NullableOrNot qualified as NullableOrNot import Hasql.Codecs.Encoders.Value qualified as Value +import Hasql.Kernel qualified as Kernel +import Hasql.Kernel.QualifiedTypeName qualified as Kernel.QualifiedTypeName +import Hasql.Kernel.TypeInfo qualified as Kernel.TypeInfo +import Hasql.Kernel.TypeRef qualified as Kernel.TypeRef import Hasql.Platform.Prelude import PostgreSQL.Binary.Encoding qualified as Binary import TextBuilder qualified @@ -15,7 +19,7 @@ compilePreparedStatementData :: Params a -> - HashMap (Maybe Text, Text) (Word32, Word32) -> + HashMap Kernel.QualifiedTypeName Kernel.TypeInfo.TypeInfo -> a -> ([Word32], [Maybe (ByteString, Bool)]) compilePreparedStatementData (Params _ _ columnsMetadata serializer _) oidCache input = @@ -26,15 +30,15 @@ & toList & fmap ( \case - (Left name, dimensionality, format) -> + (Kernel.TypeRef.NamedType name, dimensionality, format) -> case HashMap.lookup name oidCache of - Just (baseOid, arrayOid) -> - ( if dimensionality == 0 then baseOid else arrayOid, + Just typeInfo -> + ( if dimensionality == 0 then Kernel.TypeInfo.toBaseOid typeInfo else Kernel.TypeInfo.toArrayOid typeInfo, format ) Nothing -> (0, format) - (Right oid, _, format) -> + (Kernel.TypeRef.KnownOid oid, _, format) -> (oid, format) ) & unzip @@ -46,24 +50,24 @@ compileUnpreparedStatementData :: Params a -> - HashMap (Maybe Text, Text) (Word32, Word32) -> + HashMap Kernel.QualifiedTypeName Kernel.TypeInfo.TypeInfo -> a -> [Maybe (Word32, ByteString, Bool)] compileUnpreparedStatementData (Params _ _ columnsMetadata serializer _) oidCache input = zipWith ( \(nameOrOid, dimensionality, format) encoding -> let oid = case nameOrOid of - Left name -> case HashMap.lookup name oidCache of - Just (baseOid, arrayOid) -> - if dimensionality == 0 then baseOid else arrayOid + Kernel.TypeRef.NamedType name -> case HashMap.lookup name oidCache of + Just typeInfo -> + if dimensionality == 0 then Kernel.TypeInfo.toBaseOid typeInfo else Kernel.TypeInfo.toArrayOid typeInfo Nothing -> 0 - Right oid -> oid + Kernel.TypeRef.KnownOid oid -> oid in (,,) <$> Just oid <*> encoding <*> Just format ) (toList columnsMetadata) (toList (serializer oidCache input)) -toUnknownTypes :: Params a -> HashSet (Maybe Text, Text) +toUnknownTypes :: Params a -> HashSet Kernel.QualifiedTypeName toUnknownTypes (Params _ unknownTypes _ _ _) = unknownTypes @@ -113,10 +117,10 @@ -- @ data Params a = Params { size :: Int, - unknownTypes :: HashSet (Maybe Text, Text), - -- | (Name or OID, dimensionality, Text Format) for each parameter. - columnsMetadata :: DList (Either (Maybe Text, Text) Word32, Word, Bool), - serializer :: HashMap (Maybe Text, Text) (Word32, Word32) -> a -> DList (Maybe ByteString), + unknownTypes :: HashSet Kernel.QualifiedTypeName, + -- | (Type reference, dimensionality, Text Format) for each parameter. + columnsMetadata :: DList (Kernel.TypeRef, Word, Bool), + serializer :: HashMap Kernel.QualifiedTypeName Kernel.TypeInfo.TypeInfo -> a -> DList (Maybe ByteString), printer :: a -> DList Text } @@ -173,15 +177,15 @@ Params { size, unknownTypes, - columnsMetadata = pure (Right oid, dimensionality, textFormat), + columnsMetadata = pure (Kernel.TypeRef.KnownOid oid, dimensionality, textFormat), serializer, printer } Nothing -> Params { size, - unknownTypes = HashSet.insert (schemaName, typeName) unknownTypes, - columnsMetadata = pure (Left (schemaName, typeName), dimensionality, textFormat), + unknownTypes = HashSet.insert (Kernel.QualifiedTypeName.QualifiedTypeName schemaName typeName) unknownTypes, + columnsMetadata = pure (Kernel.TypeRef.NamedType (Kernel.QualifiedTypeName.QualifiedTypeName schemaName typeName), dimensionality, textFormat), serializer, printer } @@ -197,15 +201,15 @@ Params { size, unknownTypes, - columnsMetadata = pure (Right oid, dimensionality, textFormat), + columnsMetadata = pure (Kernel.TypeRef.KnownOid oid, dimensionality, textFormat), serializer, printer } Nothing -> Params { size, - unknownTypes = HashSet.insert (schemaName, typeName) unknownTypes, - columnsMetadata = pure (Left (schemaName, typeName), dimensionality, textFormat), + unknownTypes = HashSet.insert (Kernel.QualifiedTypeName.QualifiedTypeName schemaName typeName) unknownTypes, + columnsMetadata = pure (Kernel.TypeRef.NamedType (Kernel.QualifiedTypeName.QualifiedTypeName schemaName typeName), dimensionality, textFormat), serializer, printer } 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 @@ -6,7 +6,9 @@ import Data.HashMap.Strict qualified as HashMap import Data.HashSet qualified as HashSet import Data.IP qualified as Iproute -import Hasql.Codecs.TypeInfo qualified as TypeInfo +import Hasql.Kernel qualified as Kernel +import Hasql.Kernel.QualifiedTypeName qualified as Kernel.QualifiedTypeName +import Hasql.Kernel.TypeInfo qualified as Kernel.TypeInfo import Hasql.Platform.Prelude import PostgreSQL.Binary.Encoding qualified as Binary import PostgreSQL.Binary.Range qualified as Range @@ -32,9 +34,9 @@ -- | Text format? Bool -- | Names of types that are not known statically and must be looked up at runtime collected from the nested composite and array encoders. - (HashSet (Maybe Text, Text)) + (HashSet Kernel.QualifiedTypeName) -- | Serialization function on the resolved OIDs. - (HashMap (Maybe Text, Text) (Word32, Word32) -> a -> Binary.Encoding) + (HashMap Kernel.QualifiedTypeName Kernel.TypeInfo.TypeInfo -> a -> Binary.Encoding) -- | Render function for error messages. (a -> TextBuilder.TextBuilder) @@ -44,13 +46,13 @@ Value schemaName typeName valueOid arrayOid dimensionality textFormat unknownTypes (\hashMap -> encode hashMap . f) (render . f) {-# INLINE primitive #-} -primitive :: Text -> Bool -> TypeInfo.TypeInfo -> (a -> Binary.Encoding) -> (a -> TextBuilder.TextBuilder) -> Value a +primitive :: Text -> Bool -> Kernel.TypeInfo.TypeInfo -> (a -> Binary.Encoding) -> (a -> TextBuilder.TextBuilder) -> Value a primitive typeName isText typeInfo encode render = Value Nothing typeName - (Just (TypeInfo.toBaseOid typeInfo)) - (Just (TypeInfo.toArrayOid typeInfo)) + (Just (Kernel.TypeInfo.toBaseOid typeInfo)) + (Just (Kernel.TypeInfo.toArrayOid typeInfo)) 0 isText HashSet.empty @@ -61,43 +63,43 @@ -- Encoder of @BOOL@ values. {-# INLINEABLE bool #-} bool :: Value Bool -bool = primitive "bool" False TypeInfo.bool Binary.bool (TextBuilder.string . show) +bool = primitive "bool" False Kernel.TypeInfo.bool Binary.bool (TextBuilder.string . show) -- | -- Encoder of @INT2@ values. {-# INLINEABLE int2 #-} int2 :: Value Int16 -int2 = primitive "int2" False TypeInfo.int2 Binary.int2_int16 (TextBuilder.string . show) +int2 = primitive "int2" False Kernel.TypeInfo.int2 Binary.int2_int16 (TextBuilder.string . show) -- | -- Encoder of @INT4@ values. {-# INLINEABLE int4 #-} int4 :: Value Int32 -int4 = primitive "int4" False TypeInfo.int4 Binary.int4_int32 (TextBuilder.string . show) +int4 = primitive "int4" False Kernel.TypeInfo.int4 Binary.int4_int32 (TextBuilder.string . show) -- | -- Encoder of @INT8@ values. {-# INLINEABLE int8 #-} int8 :: Value Int64 -int8 = primitive "int8" False TypeInfo.int8 Binary.int8_int64 (TextBuilder.string . show) +int8 = primitive "int8" False Kernel.TypeInfo.int8 Binary.int8_int64 (TextBuilder.string . show) -- | -- Encoder of @FLOAT4@ values. {-# INLINEABLE float4 #-} float4 :: Value Float -float4 = primitive "float4" False TypeInfo.float4 Binary.float4 (TextBuilder.string . show) +float4 = primitive "float4" False Kernel.TypeInfo.float4 Binary.float4 (TextBuilder.string . show) -- | -- Encoder of @FLOAT8@ values. {-# INLINEABLE float8 #-} float8 :: Value Double -float8 = primitive "float8" False TypeInfo.float8 Binary.float8 (TextBuilder.string . show) +float8 = primitive "float8" False Kernel.TypeInfo.float8 Binary.float8 (TextBuilder.string . show) -- | -- Encoder of @NUMERIC@ values. {-# INLINEABLE numeric #-} numeric :: Value Scientific -numeric = primitive "numeric" False TypeInfo.numeric Binary.numeric (TextBuilder.string . show) +numeric = primitive "numeric" False Kernel.TypeInfo.numeric Binary.numeric (TextBuilder.string . show) -- | -- Encoder of @CHAR@ values. @@ -106,79 +108,79 @@ -- identifies itself under the @TEXT@ OID because of that. {-# INLINEABLE char #-} char :: Value Char -char = primitive "char" False TypeInfo.text Binary.char_utf8 (TextBuilder.string . show) +char = primitive "char" False Kernel.TypeInfo.text Binary.char_utf8 (TextBuilder.string . show) -- | -- Encoder of @TEXT@ values. {-# INLINEABLE text #-} text :: Value Text -text = primitive "text" False TypeInfo.text Binary.text_strict (TextBuilder.string . show) +text = primitive "text" False Kernel.TypeInfo.text Binary.text_strict (TextBuilder.string . show) -- | -- Encoder of @VARCHAR@ values. {-# INLINEABLE varchar #-} varchar :: Value Text -varchar = primitive "varchar" False TypeInfo.varchar Binary.text_strict (TextBuilder.string . show) +varchar = primitive "varchar" False Kernel.TypeInfo.varchar Binary.text_strict (TextBuilder.string . show) -- | -- Encoder of @BPCHAR@ or @CHAR(n)@, @CHARACTER(n)@ values. {-# INLINEABLE bpchar #-} bpchar :: Value Text -bpchar = primitive "bpchar" False TypeInfo.bpchar Binary.text_strict (TextBuilder.string . show) +bpchar = primitive "bpchar" False Kernel.TypeInfo.bpchar Binary.text_strict (TextBuilder.string . show) -- | -- Encoder of @BYTEA@ values. {-# INLINEABLE bytea #-} bytea :: Value ByteString -bytea = primitive "bytea" False TypeInfo.bytea Binary.bytea_strict (TextBuilder.string . show) +bytea = primitive "bytea" False Kernel.TypeInfo.bytea Binary.bytea_strict (TextBuilder.string . show) -- | -- Encoder of @DATE@ values. {-# INLINEABLE date #-} date :: Value Day -date = primitive "date" False TypeInfo.date Binary.date (TextBuilder.string . show) +date = primitive "date" False Kernel.TypeInfo.date Binary.date (TextBuilder.string . show) -- | -- Encoder of @TIMESTAMP@ values. {-# INLINEABLE timestamp #-} timestamp :: Value LocalTime -timestamp = primitive "timestamp" False TypeInfo.timestamp Binary.timestamp_int (TextBuilder.string . show) +timestamp = primitive "timestamp" False Kernel.TypeInfo.timestamp Binary.timestamp_int (TextBuilder.string . show) -- | -- Encoder of @TIMESTAMPTZ@ values. {-# INLINEABLE timestamptz #-} timestamptz :: Value UTCTime -timestamptz = primitive "timestamptz" False TypeInfo.timestamptz Binary.timestamptz_int (TextBuilder.string . show) +timestamptz = primitive "timestamptz" False Kernel.TypeInfo.timestamptz Binary.timestamptz_int (TextBuilder.string . show) -- | -- Encoder of @TIME@ values. {-# INLINEABLE time #-} time :: Value TimeOfDay -time = primitive "time" False TypeInfo.time Binary.time_int (TextBuilder.string . show) +time = primitive "time" False Kernel.TypeInfo.time Binary.time_int (TextBuilder.string . show) -- | -- Encoder of @TIMETZ@ values. {-# INLINEABLE timetz #-} timetz :: Value (TimeOfDay, TimeZone) -timetz = primitive "timetz" False TypeInfo.timetz Binary.timetz_int (TextBuilder.string . show) +timetz = primitive "timetz" False Kernel.TypeInfo.timetz Binary.timetz_int (TextBuilder.string . show) -- | -- Encoder of @INTERVAL@ values. {-# INLINEABLE interval #-} interval :: Value DiffTime -interval = primitive "interval" False TypeInfo.interval Binary.interval_int (TextBuilder.string . show) +interval = primitive "interval" False Kernel.TypeInfo.interval Binary.interval_int (TextBuilder.string . show) -- | -- Encoder of @UUID@ values. {-# INLINEABLE uuid #-} uuid :: Value UUID -uuid = primitive "uuid" False TypeInfo.uuid Binary.uuid (TextBuilder.string . show) +uuid = primitive "uuid" False Kernel.TypeInfo.uuid Binary.uuid (TextBuilder.string . show) -- | -- Encoder of @INET@ values. {-# INLINEABLE inet #-} inet :: Value Iproute.IPRange -inet = primitive "inet" False TypeInfo.inet Binary.inet (TextBuilder.string . show) +inet = primitive "inet" False Kernel.TypeInfo.inet Binary.inet (TextBuilder.string . show) -- | -- Encoder of @MACADDR@ values. @@ -189,127 +191,127 @@ -- > toOctets >$< macaddr {-# INLINEABLE macaddr #-} macaddr :: Value (Word8, Word8, Word8, Word8, Word8, Word8) -macaddr = primitive "macaddr" False TypeInfo.macaddr Binary.macaddr (TextBuilder.string . show) +macaddr = primitive "macaddr" False Kernel.TypeInfo.macaddr Binary.macaddr (TextBuilder.string . show) -- | -- Encoder of @JSON@ values from JSON AST. {-# INLINEABLE json #-} json :: Value Aeson.Value -json = primitive "json" False TypeInfo.json Binary.json_ast (TextBuilder.string . show) +json = primitive "json" False Kernel.TypeInfo.json Binary.json_ast (TextBuilder.string . show) -- | -- Encoder of @JSON@ values from raw JSON. {-# INLINEABLE jsonBytes #-} jsonBytes :: Value ByteString -jsonBytes = primitive "json" False TypeInfo.json Binary.json_bytes (TextBuilder.string . show) +jsonBytes = primitive "json" False Kernel.TypeInfo.json Binary.json_bytes (TextBuilder.string . show) -- | -- Encoder of @JSON@ values from raw JSON as lazy ByteString. {-# INLINEABLE jsonLazyBytes #-} jsonLazyBytes :: Value LazyByteString.ByteString -jsonLazyBytes = primitive "json" False TypeInfo.json Binary.json_bytes_lazy (TextBuilder.string . show) +jsonLazyBytes = primitive "json" False Kernel.TypeInfo.json Binary.json_bytes_lazy (TextBuilder.string . show) -- | -- Encoder of @JSONB@ values from JSON AST. {-# INLINEABLE jsonb #-} jsonb :: Value Aeson.Value -jsonb = primitive "jsonb" False TypeInfo.jsonb Binary.jsonb_ast (TextBuilder.string . show) +jsonb = primitive "jsonb" False Kernel.TypeInfo.jsonb Binary.jsonb_ast (TextBuilder.string . show) -- | -- Encoder of @JSONB@ values from raw JSON. {-# INLINEABLE jsonbBytes #-} jsonbBytes :: Value ByteString -jsonbBytes = primitive "jsonb" False TypeInfo.jsonb Binary.jsonb_bytes (TextBuilder.string . show) +jsonbBytes = primitive "jsonb" False Kernel.TypeInfo.jsonb Binary.jsonb_bytes (TextBuilder.string . show) -- | -- Encoder of @JSONB@ values from raw JSON as lazy ByteString. {-# INLINEABLE jsonbLazyBytes #-} jsonbLazyBytes :: Value LazyByteString.ByteString -jsonbLazyBytes = primitive "jsonb" False TypeInfo.jsonb Binary.jsonb_bytes_lazy (TextBuilder.string . show) +jsonbLazyBytes = primitive "jsonb" False Kernel.TypeInfo.jsonb Binary.jsonb_bytes_lazy (TextBuilder.string . show) -- | -- Encoder of @OID@ values. {-# INLINEABLE oid #-} oid :: Value Int32 -oid = primitive "oid" False TypeInfo.oid Binary.int4_int32 (TextBuilder.string . show) +oid = primitive "oid" False Kernel.TypeInfo.oid Binary.int4_int32 (TextBuilder.string . show) -- | -- Encoder of @NAME@ values. {-# INLINEABLE name #-} name :: Value Text -name = primitive "name" False TypeInfo.name Binary.text_strict (TextBuilder.string . show) +name = primitive "name" False Kernel.TypeInfo.name Binary.text_strict (TextBuilder.string . show) -- | -- Encoder of @INT4RANGE@ values. {-# INLINEABLE int4range #-} int4range :: Value (Range.Range Int32) -int4range = primitive "int4range" False TypeInfo.int4range Binary.int4range (TextBuilder.string . show) +int4range = primitive "int4range" False Kernel.TypeInfo.int4range Binary.int4range (TextBuilder.string . show) -- | -- Encoder of @INT8RANGE@ values. {-# INLINEABLE int8range #-} int8range :: Value (Range.Range Int64) -int8range = primitive "int8range" False TypeInfo.int8range Binary.int8range (TextBuilder.string . show) +int8range = primitive "int8range" False Kernel.TypeInfo.int8range Binary.int8range (TextBuilder.string . show) -- | -- Encoder of @NUMRANGE@ values. {-# INLINEABLE numrange #-} numrange :: Value (Range.Range Scientific) -numrange = primitive "numrange" False TypeInfo.numrange Binary.numrange (TextBuilder.string . show) +numrange = primitive "numrange" False Kernel.TypeInfo.numrange Binary.numrange (TextBuilder.string . show) -- | -- Encoder of @TSRANGE@ values. {-# INLINEABLE tsrange #-} tsrange :: Value (Range.Range LocalTime) -tsrange = primitive "tsrange" False TypeInfo.tsrange Binary.tsrange_int (TextBuilder.string . show) +tsrange = primitive "tsrange" False Kernel.TypeInfo.tsrange Binary.tsrange_int (TextBuilder.string . show) -- | -- Encoder of @TSTZRANGE@ values. {-# INLINEABLE tstzrange #-} tstzrange :: Value (Range.Range UTCTime) -tstzrange = primitive "tstzrange" False TypeInfo.tstzrange Binary.tstzrange_int (TextBuilder.string . show) +tstzrange = primitive "tstzrange" False Kernel.TypeInfo.tstzrange Binary.tstzrange_int (TextBuilder.string . show) -- | -- Encoder of @DATERANGE@ values. {-# INLINEABLE daterange #-} daterange :: Value (Range.Range Day) -daterange = primitive "daterange" False TypeInfo.daterange Binary.daterange (TextBuilder.string . show) +daterange = primitive "daterange" False Kernel.TypeInfo.daterange Binary.daterange (TextBuilder.string . show) -- | -- Encoder of @INT4MULTIRANGE@ values. {-# INLINEABLE int4multirange #-} int4multirange :: Value (Range.Multirange Int32) -int4multirange = primitive "int4multirange" False TypeInfo.int4multirange Binary.int4multirange (TextBuilder.string . show) +int4multirange = primitive "int4multirange" False Kernel.TypeInfo.int4multirange Binary.int4multirange (TextBuilder.string . show) -- | -- Encoder of @INT8MULTIRANGE@ values. {-# INLINEABLE int8multirange #-} int8multirange :: Value (Range.Multirange Int64) -int8multirange = primitive "int8multirange" False TypeInfo.int8multirange Binary.int8multirange (TextBuilder.string . show) +int8multirange = primitive "int8multirange" False Kernel.TypeInfo.int8multirange Binary.int8multirange (TextBuilder.string . show) -- | -- Encoder of @NUMMULTIRANGE@ values. {-# INLINEABLE nummultirange #-} nummultirange :: Value (Range.Multirange Scientific) -nummultirange = primitive "nummultirange" False TypeInfo.nummultirange Binary.nummultirange (TextBuilder.string . show) +nummultirange = primitive "nummultirange" False Kernel.TypeInfo.nummultirange Binary.nummultirange (TextBuilder.string . show) -- | -- Encoder of @TSMULTIRANGE@ values. {-# INLINEABLE tsmultirange #-} tsmultirange :: Value (Range.Multirange LocalTime) -tsmultirange = primitive "tsmultirange" False TypeInfo.tsmultirange Binary.tsmultirange_int (TextBuilder.string . show) +tsmultirange = primitive "tsmultirange" False Kernel.TypeInfo.tsmultirange Binary.tsmultirange_int (TextBuilder.string . show) -- | -- Encoder of @TSTZMULTIRANGE@ values. {-# INLINEABLE tstzmultirange #-} tstzmultirange :: Value (Range.Multirange UTCTime) -tstzmultirange = primitive "tstzmultirange" False TypeInfo.tstzmultirange Binary.tstzmultirange_int (TextBuilder.string . show) +tstzmultirange = primitive "tstzmultirange" False Kernel.TypeInfo.tstzmultirange Binary.tstzmultirange_int (TextBuilder.string . show) -- | -- Encoder of @DATEMULTIRANGE@ values. {-# INLINEABLE datemultirange #-} datemultirange :: Value (Range.Multirange Day) -datemultirange = primitive "datemultirange" False TypeInfo.datemultirange Binary.datemultirange (TextBuilder.string . show) +datemultirange = primitive "datemultirange" False Kernel.TypeInfo.datemultirange Binary.datemultirange (TextBuilder.string . show) -- | -- Encoder of @CITEXT@ values. @@ -349,7 +351,7 @@ Nothing 0 False - (HashSet.singleton (schemaName, typeName)) + (HashSet.singleton (Kernel.QualifiedTypeName.QualifiedTypeName schemaName typeName)) (const (Binary.text_strict . mapping)) (TextBuilder.text . mapping) @@ -367,7 +369,7 @@ {-# DEPRECATED unknown "Use 'custom' instead." #-} {-# INLINEABLE unknown #-} unknown :: Value ByteString -unknown = primitive "unknown" True TypeInfo.unknown Binary.bytea_strict (TextBuilder.string . show) +unknown = primitive "unknown" True Kernel.TypeInfo.unknown Binary.bytea_strict (TextBuilder.string . show) -- | -- Low level API for defining custom value encoders. @@ -380,7 +382,7 @@ -- | Possible static OIDs for the type. The first is for scalar values the second is for arrays. -- -- When unspecified, the OIDs will be automatically determined at runtime by looking up by name. - Maybe (Word32, Word32) -> + Maybe Kernel.TypeInfo.TypeInfo -> -- | Other named types whose OIDs are needed for serializing. -- -- E.g., when encoding composite types Postgres requires specifying OIDs of all of its fields. @@ -391,7 +393,7 @@ -- -- It's safe to assume that all of the requested types will be present. -- In case you run the provided lookup function with unmentioned type names it will produce OID of 0 for them, standing for unknown type in Postgres. - ( ((Maybe Text, Text) -> (Word32, Word32)) -> + ( ((Maybe Text, Text) -> Kernel.TypeInfo.TypeInfo) -> a -> ByteString ) -> @@ -402,13 +404,13 @@ Value schemaName typeName - (fst <$> staticOids) - (snd <$> staticOids) + (fmap Kernel.TypeInfo.toBaseOid staticOids) + (fmap Kernel.TypeInfo.toArrayOid staticOids) 0 False - (HashSet.fromList requiredTypes) + (HashSet.fromList (fmap Kernel.QualifiedTypeName.fromNameTuple requiredTypes)) ( \hashMap -> - ByteString.StrictBuilder.bytes . encode (fromMaybe (0, 0) . flip HashMap.lookup hashMap) + ByteString.StrictBuilder.bytes . encode (\name -> fromMaybe (Kernel.TypeInfo.TypeInfo 0 0) (HashMap.lookup (Kernel.QualifiedTypeName.fromNameTuple name) hashMap)) ) (TextBuilder.text . render) diff --git a/src/library/Hasql/Codecs/RequestingOid.hs b/src/library/Hasql/Codecs/RequestingOid.hs --- a/src/library/Hasql/Codecs/RequestingOid.hs +++ b/src/library/Hasql/Codecs/RequestingOid.hs @@ -13,45 +13,55 @@ import Data.HashMap.Strict qualified as HashMap import Hasql.Codecs.RequestingOid.LookingUp qualified as LookingUp +import Hasql.Kernel qualified as Kernel +import Hasql.Kernel.TypeInfo qualified as Kernel.TypeInfo import Hasql.Platform.Prelude hiding (lift, lookup) type RequestingOid = LookingUp.LookingUp - (Maybe Text, Text) - (Word32, Word32) + Kernel.QualifiedTypeName + Kernel.TypeInfo.TypeInfo +{-# INLINE toUnknownTypes #-} toUnknownTypes :: RequestingOid a -> - HashSet (Maybe Text, Text) + HashSet Kernel.QualifiedTypeName toUnknownTypes (LookingUp.LookingUp unknownTypes _) = fromList unknownTypes +{-# INLINE toBase #-} toBase :: RequestingOid a -> - HashMap (Maybe Text, Text) (Word32, Word32) -> + HashMap Kernel.QualifiedTypeName Kernel.TypeInfo.TypeInfo -> a toBase (LookingUp.LookingUp _unknownTypes decoder) oidCache = decoder \key -> HashMap.lookup key oidCache - & fromMaybe (0, 0) + & fromMaybe (Kernel.TypeInfo.TypeInfo 0 0) +{-# INLINE requestAndHandle #-} requestAndHandle :: - [(Maybe Text, Text)] -> - (((Maybe Text, Text) -> (Word32, Word32)) -> a) -> + [Kernel.QualifiedTypeName] -> + ((Kernel.QualifiedTypeName -> Kernel.TypeInfo.TypeInfo) -> a) -> RequestingOid a requestAndHandle keys fn = LookingUp.LookingUp keys fn +{-# INLINE lift #-} lift :: a -> RequestingOid a lift = LookingUp.lift +{-# INLINE hoist #-} hoist :: (a -> b) -> RequestingOid a -> RequestingOid b hoist fn (LookingUp.LookingUp keys use) = LookingUp.LookingUp keys (fn . use) -lookup :: (Maybe Text, Text) -> RequestingOid (Word32, Word32) +{-# INLINE lookup #-} +lookup :: Kernel.QualifiedTypeName -> RequestingOid Kernel.TypeInfo.TypeInfo lookup = LookingUp.lookup -lookingUp :: (Maybe Text, Text) -> ((Word32, Word32) -> a) -> RequestingOid a +{-# INLINE lookingUp #-} +lookingUp :: Kernel.QualifiedTypeName -> (Kernel.TypeInfo.TypeInfo -> a) -> RequestingOid a lookingUp = LookingUp.lookingUp -hoistLookingUp :: (Maybe Text, Text) -> ((Word32, Word32) -> a -> b) -> RequestingOid a -> RequestingOid b +{-# INLINE hoistLookingUp #-} +hoistLookingUp :: Kernel.QualifiedTypeName -> (Kernel.TypeInfo.TypeInfo -> a -> b) -> RequestingOid a -> RequestingOid b hoistLookingUp = LookingUp.hoistLookingUp diff --git a/src/library/Hasql/Codecs/RequestingOid/LookingUp.hs b/src/library/Hasql/Codecs/RequestingOid/LookingUp.hs --- a/src/library/Hasql/Codecs/RequestingOid/LookingUp.hs +++ b/src/library/Hasql/Codecs/RequestingOid/LookingUp.hs @@ -1,7 +1,6 @@ module Hasql.Codecs.RequestingOid.LookingUp where import Control.Applicative -import Witherable import Prelude data LookingUp k v a @@ -16,25 +15,31 @@ deriving stock instance Functor (LookingUp k v) instance Applicative (LookingUp k v) where + {-# INLINE pure #-} pure a = LookingUp [] (\_ -> a) + {-# INLINE (<*>) #-} LookingUp lKeys lUse <*> LookingUp rKeys rUse = LookingUp (lKeys <> rKeys) (\lookup -> lUse lookup (rUse lookup)) +{-# INLINE lookup #-} lookup :: k -> LookingUp k v v lookup key = LookingUp [key] (\lookupFn -> lookupFn key) +{-# INLINE lift #-} lift :: a -> LookingUp k v a lift fa = LookingUp [] (const fa) +{-# INLINE lookingUp #-} lookingUp :: k -> (v -> a) -> LookingUp k v a lookingUp key cont = LookingUp [key] (\lookupFn -> cont (lookupFn key)) +{-# INLINE hoistLookingUp #-} hoistLookingUp :: k -> (v -> a -> b) -> LookingUp k v a -> LookingUp k v b hoistLookingUp k tx (LookingUp keys use) = LookingUp (k : keys) (\lookupFn -> tx (lookupFn k) (use lookupFn)) diff --git a/src/library/Hasql/Codecs/TypeInfo.hs b/src/library/Hasql/Codecs/TypeInfo.hs deleted file mode 100644 --- a/src/library/Hasql/Codecs/TypeInfo.hs +++ /dev/null @@ -1,228 +0,0 @@ -module Hasql.Codecs.TypeInfo where - -import Hasql.Platform.Prelude hiding (bool) - --- | A Postgresql type info -data TypeInfo = TypeInfo {toBaseOid :: Word32, toArrayOid :: Word32} - -abstime :: TypeInfo -abstime = TypeInfo 702 1023 - -aclitem :: TypeInfo -aclitem = TypeInfo 1033 1034 - -bit :: TypeInfo -bit = TypeInfo 1560 1561 - -bool :: TypeInfo -bool = TypeInfo 16 1000 - -box :: TypeInfo -box = TypeInfo 603 1020 - -bpchar :: TypeInfo -bpchar = TypeInfo 1042 1014 - -bytea :: TypeInfo -bytea = TypeInfo 17 1001 - -char :: TypeInfo -char = TypeInfo 18 1002 - -cid :: TypeInfo -cid = TypeInfo 29 1012 - -cidr :: TypeInfo -cidr = TypeInfo 650 651 - -circle :: TypeInfo -circle = TypeInfo 718 719 - -cstring :: TypeInfo -cstring = TypeInfo 2275 1263 - -date :: TypeInfo -date = TypeInfo 1082 1182 - -daterange :: TypeInfo -daterange = TypeInfo 3912 3913 - -datemultirange :: TypeInfo -datemultirange = TypeInfo 4535 6155 - -float4 :: TypeInfo -float4 = TypeInfo 700 1021 - -float8 :: TypeInfo -float8 = TypeInfo 701 1022 - -gtsvector :: TypeInfo -gtsvector = TypeInfo 3642 3644 - -inet :: TypeInfo -inet = TypeInfo 869 1041 - -int2 :: TypeInfo -int2 = TypeInfo 21 1005 - -int2vector :: TypeInfo -int2vector = TypeInfo 22 1006 - -int4 :: TypeInfo -int4 = TypeInfo 23 1007 - -int4range :: TypeInfo -int4range = TypeInfo 3904 3905 - -int4multirange :: TypeInfo -int4multirange = TypeInfo 4451 6150 - -int8 :: TypeInfo -int8 = TypeInfo 20 1016 - -int8range :: TypeInfo -int8range = TypeInfo 3926 3927 - -int8multirange :: TypeInfo -int8multirange = TypeInfo 4536 6157 - -interval :: TypeInfo -interval = TypeInfo 1186 1187 - -json :: TypeInfo -json = TypeInfo 114 199 - -jsonb :: TypeInfo -jsonb = TypeInfo 3802 3807 - -line :: TypeInfo -line = TypeInfo 628 629 - -lseg :: TypeInfo -lseg = TypeInfo 601 1018 - -macaddr :: TypeInfo -macaddr = TypeInfo 829 1040 - -money :: TypeInfo -money = TypeInfo 790 791 - -name :: TypeInfo -name = TypeInfo 19 1003 - -numeric :: TypeInfo -numeric = TypeInfo 1700 1231 - -numrange :: TypeInfo -numrange = TypeInfo 3906 3907 - -nummultirange :: TypeInfo -nummultirange = TypeInfo 4532 6151 - -oid :: TypeInfo -oid = TypeInfo 26 1028 - -oidvector :: TypeInfo -oidvector = TypeInfo 30 1013 - -path :: TypeInfo -path = TypeInfo 602 1019 - -point :: TypeInfo -point = TypeInfo 600 1017 - -polygon :: TypeInfo -polygon = TypeInfo 604 1027 - -record :: TypeInfo -record = TypeInfo 2249 2287 - -refcursor :: TypeInfo -refcursor = TypeInfo 1790 2201 - -regclass :: TypeInfo -regclass = TypeInfo 2205 2210 - -regconfig :: TypeInfo -regconfig = TypeInfo 3734 3735 - -regdictionary :: TypeInfo -regdictionary = TypeInfo 3769 3770 - -regoper :: TypeInfo -regoper = TypeInfo 2203 2208 - -regoperator :: TypeInfo -regoperator = TypeInfo 2204 2209 - -regproc :: TypeInfo -regproc = TypeInfo 24 1008 - -regprocedure :: TypeInfo -regprocedure = TypeInfo 2202 2207 - -regtype :: TypeInfo -regtype = TypeInfo 2206 2211 - -reltime :: TypeInfo -reltime = TypeInfo 703 1024 - -text :: TypeInfo -text = TypeInfo 25 1009 - -tid :: TypeInfo -tid = TypeInfo 27 1010 - -time :: TypeInfo -time = TypeInfo 1083 1183 - -timestamp :: TypeInfo -timestamp = TypeInfo 1114 1115 - -timestamptz :: TypeInfo -timestamptz = TypeInfo 1184 1185 - -timetz :: TypeInfo -timetz = TypeInfo 1266 1270 - -tinterval :: TypeInfo -tinterval = TypeInfo 704 1025 - -tsquery :: TypeInfo -tsquery = TypeInfo 3615 3645 - -tsrange :: TypeInfo -tsrange = TypeInfo 3908 3909 - -tsmultirange :: TypeInfo -tsmultirange = TypeInfo 4533 6152 - -tstzrange :: TypeInfo -tstzrange = TypeInfo 3910 3911 - -tstzmultirange :: TypeInfo -tstzmultirange = TypeInfo 4534 6153 - -tsvector :: TypeInfo -tsvector = TypeInfo 3614 3643 - -txid_snapshot :: TypeInfo -txid_snapshot = TypeInfo 2970 2949 - -unknown :: TypeInfo -unknown = TypeInfo 705 705 - -uuid :: TypeInfo -uuid = TypeInfo 2950 2951 - -varbit :: TypeInfo -varbit = TypeInfo 1562 1563 - -varchar :: TypeInfo -varchar = TypeInfo 1043 1015 - -xid :: TypeInfo -xid = TypeInfo 28 1011 - -xml :: TypeInfo -xml = TypeInfo 142 143 diff --git a/src/library/Hasql/Comms/RowDecoder.hs b/src/library/Hasql/Comms/RowDecoder.hs --- a/src/library/Hasql/Comms/RowDecoder.hs +++ b/src/library/Hasql/Comms/RowDecoder.hs @@ -69,6 +69,7 @@ type Decoder a = Pq.Result -> Pq.Row -> IO (Either Error a) +{-# INLINE toDecoder #-} toDecoder :: RowDecoder a -> Decoder a toDecoder (RowDecoder _ dec) result row = RowReader.toHandler dec result row diff --git a/src/library/Hasql/Comms/RowReader.hs b/src/library/Hasql/Comms/RowReader.hs --- a/src/library/Hasql/Comms/RowReader.hs +++ b/src/library/Hasql/Comms/RowReader.hs @@ -76,10 +76,11 @@ valueMaybe <- case valueMaybe of Nothing -> pure Nothing - Just v -> do - oid <- Pq.oidToWord32 <$> liftIO (Pq.ftype result col) + Just v -> case {-# SCC "decode" #-} valueDec v of - Left err -> throwError (CellError colInt oid (DecodingCellError err)) + Left err -> do + oid <- Pq.oidToWord32 <$> liftIO (Pq.ftype result col) + throwError (CellError colInt oid (DecodingCellError err)) Right decoded -> pure (Just decoded) case processNullable valueMaybe of 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 @@ -83,9 +83,13 @@ -- * Composite Composite, field, + + -- * TypeInfo + TypeInfo (..), ) where import Hasql.Codecs.Decoders import Hasql.Engine.Decoders.Result import Hasql.Engine.Decoders.Row +import Hasql.Kernel.TypeInfo (TypeInfo (..)) 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 @@ -74,7 +74,11 @@ -- * Composite Composite, field, + + -- * TypeInfo + TypeInfo (..), ) where import Hasql.Codecs.Encoders +import Hasql.Kernel.TypeInfo (TypeInfo (..)) diff --git a/src/library/Hasql/Engine/Contexts/Pipeline.hs b/src/library/Hasql/Engine/Contexts/Pipeline.hs --- a/src/library/Hasql/Engine/Contexts/Pipeline.hs +++ b/src/library/Hasql/Engine/Contexts/Pipeline.hs @@ -15,6 +15,9 @@ import Hasql.Engine.PqProcedures.SelectTypeInfo qualified as PqProcedures.SelectTypeInfo import Hasql.Engine.Structures.OidCache qualified as OidCache import Hasql.Engine.Structures.StatementCache qualified as StatementCache +import Hasql.Kernel qualified as Kernel +import Hasql.Kernel.QualifiedTypeName qualified as Kernel.QualifiedTypeName +import Hasql.Kernel.TypeInfo qualified as Kernel.TypeInfo import Hasql.Platform.Prelude import Hasql.Pq qualified as Pq @@ -31,42 +34,48 @@ ) run (Pipeline totalStatements unknownTypes runPipeline) usePreparedStatements connection oidCache statementCache = do let missingTypes = OidCache.selectUnknownNames unknownTypes oidCache - oidCacheUpdates <- PqProcedures.SelectTypeInfo.run connection (PqProcedures.SelectTypeInfo.SelectTypeInfo missingTypes) - case oidCacheUpdates of + resolvedOidCache <- + if HashSet.null missingTypes + then pure (Right oidCache) + else do + oidCacheUpdates <- + PqProcedures.SelectTypeInfo.run connection (PqProcedures.SelectTypeInfo.SelectTypeInfo missingTypes) + pure $ case oidCacheUpdates of + Left err -> Left err + Right oidCacheUpdates -> + let foundTypes = HashMap.keysSet oidCacheUpdates + notFoundTypes = HashSet.difference missingTypes foundTypes + in if not (HashSet.null notFoundTypes) + then Left (Errors.MissingTypesSessionError (HashSet.map Kernel.QualifiedTypeName.toNameTuple notFoundTypes)) + else Right (oidCache <> OidCache.fromHashMap oidCacheUpdates) + case resolvedOidCache of Left err -> pure (Left err, oidCache, statementCache) - Right oidCacheUpdates -> do - -- Validate that all requested types were found - let foundTypes = HashMap.keysSet oidCacheUpdates - notFoundTypes = HashSet.difference missingTypes foundTypes - if not (HashSet.null notFoundTypes) - then pure (Left (Errors.MissingTypesSessionError notFoundTypes), oidCache, statementCache) - else do - let newOidCache = oidCache <> OidCache.fromHashMap oidCacheUpdates - (roundtrip, newStatementCache) = - runPipeline 0 usePreparedStatements (OidCache.toHashMap newOidCache) statementCache - contextualRoundtrip = first Just roundtrip + Right newOidCache -> do + let (roundtrip, newStatementCache) = + runPipeline 0 usePreparedStatements (OidCache.toHashMap newOidCache) statementCache + contextualRoundtrip = first Just roundtrip - executionResult <- Comms.Roundtrip.toPipelineIO contextualRoundtrip Nothing connection + executionResult <- Comms.Roundtrip.toPipelineIO contextualRoundtrip Nothing connection - let result = - first - ( \case - Comms.Roundtrip.ClientError _context details -> - Errors.ConnectionSessionError (maybe "" decodeUtf8Lenient details) - Comms.Roundtrip.ServerError recvError -> - Errors.fromRecvError (fmap (fmap (\(Context index sql params prepared _) -> (totalStatements, index, sql, params, prepared))) recvError) - ) - executionResult - finalStatementCache = - case executionResult of - Right _ -> newStatementCache - Left executionError -> - maybe - statementCache - (\(Context _ _ _ _ statementCache) -> statementCache) - (extract executionError) + let result = + first + ( \case + Comms.Roundtrip.ClientError _context details -> + Errors.ConnectionSessionError (maybe "" decodeUtf8Lenient details) + Comms.Roundtrip.ServerError recvError -> + Errors.fromRecvError (fmap (fmap (\(Context index sql params prepared _) -> (totalStatements, index, sql, params, prepared))) recvError) + ) + executionResult + finalStatementCache = + case executionResult of + Right _ -> newStatementCache + Left executionError -> + maybe + statementCache + (\(Context _ _ _ _ statementCache) -> statementCache) + (extract executionError) - pure (result, newOidCache, finalStatementCache) + pure (result, newOidCache, finalStatementCache) -- | -- Composable abstraction over the execution of queries in [the pipeline mode](https://www.postgresql.org/docs/current/libpq-pipeline-mode.html). @@ -138,7 +147,7 @@ -- It can be assumed in the execution function that these types are always present in the cache. -- To achieve that property we will be validating the presence of all requested types in the database or failing before running the pipeline. -- In the execution function we will be defaulting to 'Pq.Oid 0' for unknown types as a fallback in case of bugs. - (HashSet (Maybe Text, Text)) + (HashSet Kernel.QualifiedTypeName) -- | Function that runs the pipeline. -- -- The integer parameter indicates the current offset of the statement in the pipeline (0-based). @@ -155,7 +164,7 @@ -- committed cache from statement contexts carried by roundtrip errors. ( Int -> Bool -> - HashMap (Maybe Text, Text) (Word32, Word32) -> + HashMap Kernel.QualifiedTypeName Kernel.TypeInfo.TypeInfo -> StatementCache.StatementCache -> (Comms.Roundtrip.Roundtrip Context a, StatementCache.StatementCache) ) diff --git a/src/library/Hasql/Engine/Contexts/Session.hs b/src/library/Hasql/Engine/Contexts/Session.hs --- a/src/library/Hasql/Engine/Contexts/Session.hs +++ b/src/library/Hasql/Engine/Contexts/Session.hs @@ -12,6 +12,7 @@ import Hasql.Engine.Structures.ConnectionState qualified as ConnectionState import Hasql.Engine.Structures.OidCache qualified as OidCache import Hasql.Engine.Structures.StatementCache qualified as StatementCache +import Hasql.Kernel.QualifiedTypeName qualified as Kernel.QualifiedTypeName import Hasql.Platform.Prelude import Hasql.Pq qualified as Pq @@ -94,82 +95,87 @@ Params.toUnknownTypes paramsEncoder <> RequestingOid.toUnknownTypes requestingDecoder missingTypes = OidCache.selectUnknownNames unknownTypes oidCache - oidCacheUpdates <- - PqProcedures.SelectTypeInfo.run connection (PqProcedures.SelectTypeInfo.SelectTypeInfo missingTypes) - case oidCacheUpdates of + resolvedOidCache <- + if HashSet.null missingTypes + then pure (Right oidCache) + else do + oidCacheUpdates <- + PqProcedures.SelectTypeInfo.run connection (PqProcedures.SelectTypeInfo.SelectTypeInfo missingTypes) + pure $ case oidCacheUpdates of + Left err -> Left err + Right oidCacheUpdates -> + let foundTypes = HashMap.keysSet oidCacheUpdates + notFoundTypes = HashSet.difference missingTypes foundTypes + in if not (HashSet.null notFoundTypes) + then Left (Errors.MissingTypesSessionError (HashSet.map Kernel.QualifiedTypeName.toNameTuple notFoundTypes)) + else Right (oidCache <> OidCache.fromHashMap oidCacheUpdates) + case resolvedOidCache of Left err -> pure (Left err, connectionState) - Right oidCacheUpdates -> do - -- Validate that all requested types were found. - let foundTypes = HashMap.keysSet oidCacheUpdates - notFoundTypes = HashSet.difference missingTypes foundTypes - if not (HashSet.null notFoundTypes) - then pure (Left (Errors.MissingTypesSessionError notFoundTypes), connectionState) - else do - let newOidCache = oidCache <> OidCache.fromHashMap oidCacheUpdates - oidHashMap = OidCache.toHashMap newOidCache - decoder' = RequestingOid.toBase requestingDecoder oidHashMap - prepared = usePreparedStatements && preparable - -- Single-statement context for error reporting: - -- total statements 1, index 0. - context = Just (1, 0, sql, Params.renderReadable paramsEncoder params, prepared) - mapError = \case - Comms.Roundtrip.ClientError _ details -> - Errors.ConnectionSessionError (maybe "" decodeUtf8Lenient details) - Comms.Roundtrip.ServerError recvError -> - Errors.fromRecvError recvError - withState (result, newStatementCache) = - ( first mapError result, - connectionState - { ConnectionState.oidCache = newOidCache, - ConnectionState.statementCache = newStatementCache - } - ) - fmap withState - $ if prepared - then do - let (oidList, valueAndFormatList) = - Params.compilePreparedStatementData paramsEncoder oidHashMap params - pqOidList = fmap (Pq.Oid . fromIntegral) oidList - encodedParams = - valueAndFormatList - & fmap (fmap (\(bytes, format) -> (bytes, bool Pq.Binary Pq.Text format))) - execute remoteKey = - Comms.Roundtrip.toSerialIO - (Comms.Roundtrip.queryPrepared context remoteKey encodedParams Pq.Binary decoder') - connection - case StatementCache.lookup sql pqOidList statementCache of - Just remoteKey -> do - result <- execute remoteKey - pure (result, statementCache) - Nothing -> do - let (remoteKey, newStatementCache) = StatementCache.insert sql pqOidList statementCache - -- In non-pipeline mode PARSE and EXECUTE cannot be sent - -- back-to-back, so prepare in a dedicated roundtrip first. - prepareResult <- - Comms.Roundtrip.toSerialIO - (Comms.Roundtrip.prepare context remoteKey sql pqOidList) - connection - case prepareResult of - -- PARSE failed: the statement is not on the server, so - -- keep the old cache (no entry committed). - Left err -> pure (Left err, statementCache) - Right () -> do - -- PARSE succeeded, so the statement is on the server - -- under remoteKey regardless of whether EXECUTE then - -- fails. Commit the cache so a later use hits it instead - -- of re-issuing PARSE for an already-existing name. - result <- execute remoteKey - pure (result, newStatementCache) - else do - let encodedParams = - params - & Params.compileUnpreparedStatementData paramsEncoder oidHashMap - & fmap (fmap (\(oid, bytes, format) -> (Pq.Oid (fromIntegral oid), bytes, bool Pq.Binary Pq.Text format))) - result <- + Right newOidCache -> do + let oidHashMap = OidCache.toHashMap newOidCache + decoder' = RequestingOid.toBase requestingDecoder oidHashMap + prepared = usePreparedStatements && preparable + -- Single-statement context for error reporting: + -- total statements 1, index 0. + context = Just (1, 0, sql, Params.renderReadable paramsEncoder params, prepared) + mapError = \case + Comms.Roundtrip.ClientError _ details -> + Errors.ConnectionSessionError (maybe "" decodeUtf8Lenient details) + Comms.Roundtrip.ServerError recvError -> + Errors.fromRecvError recvError + withState (result, newStatementCache) = + ( first mapError result, + connectionState + { ConnectionState.oidCache = newOidCache, + ConnectionState.statementCache = newStatementCache + } + ) + fmap withState + $ if prepared + then do + let (oidList, valueAndFormatList) = + Params.compilePreparedStatementData paramsEncoder oidHashMap params + pqOidList = fmap (Pq.Oid . fromIntegral) oidList + encodedParams = + valueAndFormatList + & fmap (fmap (\(bytes, format) -> (bytes, bool Pq.Binary Pq.Text format))) + execute remoteKey = Comms.Roundtrip.toSerialIO - (Comms.Roundtrip.queryParams context sql encodedParams Pq.Binary decoder') + (Comms.Roundtrip.queryPrepared context remoteKey encodedParams Pq.Binary decoder') connection + case StatementCache.lookup sql pqOidList statementCache of + Just remoteKey -> do + result <- execute remoteKey pure (result, statementCache) + Nothing -> do + let (remoteKey, newStatementCache) = StatementCache.insert sql pqOidList statementCache + -- In non-pipeline mode PARSE and EXECUTE cannot be sent + -- back-to-back, so prepare in a dedicated roundtrip first. + prepareResult <- + Comms.Roundtrip.toSerialIO + (Comms.Roundtrip.prepare context remoteKey sql pqOidList) + connection + case prepareResult of + -- PARSE failed: the statement is not on the server, so + -- keep the old cache (no entry committed). + Left err -> pure (Left err, statementCache) + Right () -> do + -- PARSE succeeded, so the statement is on the server + -- under remoteKey regardless of whether EXECUTE then + -- fails. Commit the cache so a later use hits it instead + -- of re-issuing PARSE for an already-existing name. + result <- execute remoteKey + pure (result, newStatementCache) + else do + let encodedParams = + params + & Params.compileUnpreparedStatementData paramsEncoder oidHashMap + & fmap (fmap (\(oid, bytes, format) -> (Pq.Oid (fromIntegral oid), bytes, bool Pq.Binary Pq.Text format))) + result <- + Comms.Roundtrip.toSerialIO + (Comms.Roundtrip.queryParams context sql encodedParams Pq.Binary decoder') + connection + pure (result, statementCache) -- | -- Execute a pipeline. diff --git a/src/library/Hasql/Engine/Decoders/Result.hs b/src/library/Hasql/Engine/Decoders/Result.hs --- a/src/library/Hasql/Engine/Decoders/Result.hs +++ b/src/library/Hasql/Engine/Decoders/Result.hs @@ -23,7 +23,7 @@ -- Decode no value from the result. -- -- Useful for statements like @INSERT@ or @CREATE@. -{-# INLINEABLE noResult #-} +{-# INLINE noResult #-} noResult :: Result () noResult = Result (RequestingOid.lift ResultDecoder.ok) @@ -31,7 +31,7 @@ -- | -- Get the amount of rows affected by such statements as -- @UPDATE@ or @DELETE@. -{-# INLINEABLE rowsAffected #-} +{-# INLINE rowsAffected #-} rowsAffected :: Result Int64 rowsAffected = Result (RequestingOid.lift ResultDecoder.rowsAffected) @@ -39,7 +39,7 @@ -- | -- Exactly one row. -- Will raise the 'Hasql.Errors.UnexpectedRowCountStatementError' error if it's any other. -{-# INLINEABLE singleRow #-} +{-# INLINE singleRow #-} singleRow :: Row a -> Result a singleRow decoder = Result (fmap ResultDecoder.single (Row.toDecoder decoder)) @@ -52,7 +52,7 @@ -- | -- Foldl multiple rows. -{-# INLINEABLE foldlRows #-} +{-# INLINE foldlRows #-} foldlRows :: (a -> b -> a) -> a -> Row b -> Result a foldlRows step init decoder = Result @@ -60,7 +60,7 @@ -- | -- Foldr multiple rows. -{-# INLINEABLE foldrRows #-} +{-# INLINE foldrRows #-} foldrRows :: (b -> a -> a) -> a -> Row b -> Result a foldrRows step init decoder = Result @@ -70,7 +70,7 @@ -- | -- Maybe one row or none. -{-# INLINEABLE rowMaybe #-} +{-# INLINE rowMaybe #-} rowMaybe :: Row a -> Result (Maybe a) rowMaybe decoder = Result @@ -81,7 +81,7 @@ -- -- It's recommended to prefer this function to 'rowList', -- since it performs notably better. -{-# INLINEABLE rowVector #-} +{-# INLINE rowVector #-} rowVector :: Row a -> Result (Vector a) rowVector decoder = Result @@ -89,7 +89,7 @@ -- | -- Zero or more rows packed into the list. -{-# INLINEABLE rowList #-} +{-# INLINE rowList #-} rowList :: Row a -> Result [a] rowList = foldrRows strictCons [] diff --git a/src/library/Hasql/Engine/Decoders/Row.hs b/src/library/Hasql/Engine/Decoders/Row.hs --- a/src/library/Hasql/Engine/Decoders/Row.hs +++ b/src/library/Hasql/Engine/Decoders/Row.hs @@ -4,6 +4,8 @@ import Hasql.Codecs.Decoders.Value qualified as Value import Hasql.Codecs.RequestingOid qualified as RequestingOid import Hasql.Comms.RowDecoder qualified +import Hasql.Kernel.QualifiedTypeName qualified as Kernel.QualifiedTypeName +import Hasql.Kernel.TypeInfo qualified as Kernel.TypeInfo import Hasql.Platform.Prelude import PostgreSQL.Binary.Decoding qualified as Binary @@ -29,7 +31,7 @@ -- | -- Lift an individual value decoder to a composable row decoder. -{-# INLINEABLE column #-} +{-# INLINE column #-} column :: NullableOrNot Value a -> Row a column = \case Nullable valueDecoder -> @@ -40,7 +42,7 @@ (Value.toDecoder valueDecoder) Nothing -> do RequestingOid.hoistLookingUp - (Value.toSchema valueDecoder, Value.toTypeName valueDecoder) + (Kernel.QualifiedTypeName.QualifiedTypeName (Value.toSchema valueDecoder) (Value.toTypeName valueDecoder)) ( \lookupResult decoder -> Hasql.Comms.RowDecoder.nullableColumn (Just (chooseLookedUpOid valueDecoder lookupResult)) (Binary.valueParser decoder) ) @@ -53,11 +55,11 @@ (Value.toDecoder valueDecoder) Nothing -> do RequestingOid.hoistLookingUp - (Value.toSchema valueDecoder, Value.toTypeName valueDecoder) + (Kernel.QualifiedTypeName.QualifiedTypeName (Value.toSchema valueDecoder) (Value.toTypeName valueDecoder)) (\lookupResult decoder -> Hasql.Comms.RowDecoder.nonNullableColumn (Just (chooseLookedUpOid valueDecoder lookupResult)) (Binary.valueParser decoder)) (Value.toDecoder valueDecoder) where - chooseLookedUpOid valueDecoder (elementOid, arrayOid) = + chooseLookedUpOid valueDecoder typeInfo = if Value.toDimensionality valueDecoder > 0 - then arrayOid - else elementOid + then Kernel.TypeInfo.toArrayOid typeInfo + else Kernel.TypeInfo.toBaseOid typeInfo diff --git a/src/library/Hasql/Engine/PqProcedures/SelectTypeInfo.hs b/src/library/Hasql/Engine/PqProcedures/SelectTypeInfo.hs --- a/src/library/Hasql/Engine/PqProcedures/SelectTypeInfo.hs +++ b/src/library/Hasql/Engine/PqProcedures/SelectTypeInfo.hs @@ -14,17 +14,20 @@ import Hasql.Comms.Roundtrip qualified import Hasql.Comms.RowDecoder qualified import Hasql.Engine.Errors qualified as Errors +import Hasql.Kernel qualified as Kernel +import Hasql.Kernel.QualifiedTypeName qualified as Kernel.QualifiedTypeName +import Hasql.Kernel.TypeInfo qualified as Kernel.TypeInfo import Hasql.Platform.Prelude import Hasql.Pq qualified as Pq newtype SelectTypeInfo = SelectTypeInfo { -- | Set of (schema name, type name) pairs to look up. - keys :: HashSet (Maybe Text, Text) + keys :: HashSet Kernel.QualifiedTypeName } --- | Result maps (schema name, type name) pairs to (scalar OID, array OID) pairs. +-- | Result maps (schema name, type name) pairs to TypeInfo (scalar OID, array OID). type SelectTypeInfoResult = - HashMap (Maybe Text, Text) (Word32, Word32) + HashMap Kernel.QualifiedTypeName Kernel.TypeInfo.TypeInfo run :: Pq.Connection -> SelectTypeInfo -> IO (Either Errors.SessionError SelectTypeInfoResult) run connection (SelectTypeInfo keys) = @@ -87,7 +90,7 @@ paramsEncoder :: Encoders.Params SelectTypeInfo paramsEncoder = - (\(SelectTypeInfo keys) -> unzip (HashSet.toList keys)) + (\(SelectTypeInfo keys) -> unzip (fmap Kernel.QualifiedTypeName.toNameTuple (HashSet.toList keys))) >$< mconcat [ fst >$< Encoders.param (Encoders.nonNullable (Encoders.foldableArray (Encoders.nullable Encoders.text))), snd >$< Encoders.param (Encoders.nonNullable (Encoders.foldableArray (Encoders.nonNullable Encoders.text))) @@ -98,7 +101,7 @@ Hasql.Comms.ResultDecoder.foldl step HashMap.empty rowDecoder where step acc (schemaName, typeName, typeOid, arrayOid) = - HashMap.insert (schemaName, typeName) (typeOid, arrayOid) acc + HashMap.insert (Kernel.QualifiedTypeName.QualifiedTypeName schemaName typeName) (Kernel.TypeInfo.TypeInfo typeOid arrayOid) acc rowDecoder :: Hasql.Comms.RowDecoder.RowDecoder (Maybe Text, Text, Word32, Word32) rowDecoder = diff --git a/src/library/Hasql/Engine/Statement.hs b/src/library/Hasql/Engine/Statement.hs --- a/src/library/Hasql/Engine/Statement.hs +++ b/src/library/Hasql/Engine/Statement.hs @@ -7,6 +7,7 @@ ) where +import Data.Text.Encoding qualified as TextEncoding import Hasql.Decoders qualified as Decoders import Hasql.Encoders qualified as Encoders import Hasql.Engine.Decoders.Result qualified @@ -36,14 +37,14 @@ -- and produces a single result of type 'Int64'. data Statement params result = Statement - -- | SQL template. + -- | SQL template pre-encoded as UTF-8 for execution. -- -- Must be formatted according to the Postgres standard. -- The parameters must be referred to using the positional notation, as in the following: -- @$1@, @$2@, @$3@ and etc. -- These references must be used in accordance with the order in which -- the value encoders are specified in the parameters encoder. - Text + ByteString -- | Parameters encoder. (Encoders.Params params) -- | Decoder of result. @@ -69,7 +70,7 @@ -- | Result decoder Decoders.Result result -> Statement params result -preparable sql encoder decoder = Statement sql encoder decoder True +preparable sql encoder decoder = Statement (TextEncoding.encodeUtf8 sql) encoder decoder True -- | -- Construct an unpreparable statement. @@ -86,7 +87,7 @@ -- | Result decoder Decoders.Result result -> Statement params result -unpreparable sql encoder decoder = Statement sql encoder decoder False +unpreparable sql encoder decoder = Statement (TextEncoding.encodeUtf8 sql) encoder decoder False instance Functor (Statement params) where {-# INLINE fmap #-} @@ -114,4 +115,4 @@ -- | Extract the SQL template from a statement. toSql :: Statement params result -> Text -toSql (Statement sql _ _ _) = sql +toSql (Statement sql _ _ _) = TextEncoding.decodeUtf8Lenient sql diff --git a/src/library/Hasql/Engine/Structures/OidCache.hs b/src/library/Hasql/Engine/Structures/OidCache.hs --- a/src/library/Hasql/Engine/Structures/OidCache.hs +++ b/src/library/Hasql/Engine/Structures/OidCache.hs @@ -16,6 +16,9 @@ import Data.HashMap.Strict qualified as HashMap import Data.HashSet qualified as HashSet +import Hasql.Kernel qualified as Kernel +import Hasql.Kernel.QualifiedTypeName qualified as Kernel.QualifiedTypeName +import Hasql.Kernel.TypeInfo qualified as Kernel.TypeInfo import Hasql.Platform.Prelude hiding (empty, insert, lookup, reset) -- | Pure registry state containing the hash map and counter @@ -23,8 +26,8 @@ = OidCache -- | By name of the type. -- - -- > scalar name -> (scalar OID, array OID) - (HashMap (Maybe Text, Text) (Word32, Word32)) + -- > scalar name -> TypeInfo (scalar OID, array OID) + (HashMap Kernel.QualifiedTypeName Kernel.TypeInfo.TypeInfo) deriving stock (Show, Eq) instance Semigroup OidCache where @@ -40,26 +43,31 @@ OidCache HashMap.empty -- | Having a set of required type names, select those that are not present in the cache. -selectUnknownNames :: HashSet (Maybe Text, Text) -> OidCache -> HashSet (Maybe Text, Text) +{-# INLINE selectUnknownNames #-} +selectUnknownNames :: HashSet Kernel.QualifiedTypeName -> OidCache -> HashSet Kernel.QualifiedTypeName selectUnknownNames keys (OidCache byName) = HashSet.filter (\key -> not (HashMap.member key byName)) keys insertScalar :: Maybe Text -> Text -> Word32 -> Word32 -> OidCache -> OidCache insertScalar schema name scalar array (OidCache byName) = - OidCache (HashMap.insert (schema, name) (scalar, array) byName) + OidCache (HashMap.insert (Kernel.QualifiedTypeName.QualifiedTypeName schema name) (Kernel.TypeInfo.TypeInfo scalar array) byName) -fromHashMap :: HashMap (Maybe Text, Text) (Word32, Word32) -> OidCache +{-# INLINE fromHashMap #-} +fromHashMap :: HashMap Kernel.QualifiedTypeName Kernel.TypeInfo.TypeInfo -> OidCache fromHashMap byName = OidCache byName -- * Accessors +{-# INLINE lookupScalar #-} lookupScalar :: Maybe Text -> Text -> OidCache -> Maybe Word32 lookupScalar schema name (OidCache byName) = - HashMap.lookup (schema, name) byName <&> \(scalar, _) -> scalar + HashMap.lookup (Kernel.QualifiedTypeName.QualifiedTypeName schema name) byName <&> \info -> Kernel.TypeInfo.toBaseOid info +{-# INLINE lookupArray #-} lookupArray :: Maybe Text -> Text -> OidCache -> Maybe Word32 lookupArray schema name (OidCache byName) = - HashMap.lookup (schema, name) byName <&> \(_, array) -> array + HashMap.lookup (Kernel.QualifiedTypeName.QualifiedTypeName schema name) byName <&> \info -> Kernel.TypeInfo.toArrayOid info -toHashMap :: OidCache -> HashMap (Maybe Text, Text) (Word32, Word32) +{-# INLINE toHashMap #-} +toHashMap :: OidCache -> HashMap Kernel.QualifiedTypeName Kernel.TypeInfo.TypeInfo toHashMap (OidCache byName) = byName diff --git a/src/library/Hasql/Kernel.hs b/src/library/Hasql/Kernel.hs new file mode 100644 --- /dev/null +++ b/src/library/Hasql/Kernel.hs @@ -0,0 +1,10 @@ +module Hasql.Kernel + ( QualifiedTypeName, + TypeInfo (..), + TypeRef, + ) +where + +import Hasql.Kernel.QualifiedTypeName (QualifiedTypeName) +import Hasql.Kernel.TypeInfo (TypeInfo) +import Hasql.Kernel.TypeRef (TypeRef) diff --git a/src/library/Hasql/Kernel/QualifiedTypeName.hs b/src/library/Hasql/Kernel/QualifiedTypeName.hs new file mode 100644 --- /dev/null +++ b/src/library/Hasql/Kernel/QualifiedTypeName.hs @@ -0,0 +1,43 @@ +module Hasql.Kernel.QualifiedTypeName + ( QualifiedTypeName (..), + fromNameTuple, + toNameTuple, + ) +where + +import Hasql.Platform.Prelude + +-- | +-- A Postgres type identified by name: an optional schema together with a +-- required type name. +-- +-- A 'Nothing' schema means the name is unqualified and is resolved via the +-- server's search path. +-- +-- Used as the key under which a type's OIDs are resolved and cached. +data QualifiedTypeName = QualifiedTypeName + { schema :: Maybe Text, + name :: Text + } + deriving stock (Eq, Ord, Show, Generic) + +instance Hashable QualifiedTypeName + +-- | An unqualified name constructor for convenience. +instance IsString QualifiedTypeName where + fromString = QualifiedTypeName Nothing . fromString + +-- | +-- Convert from the legacy @(schema, name)@ tuple representation. +-- +-- Used at public-API boundaries (e.g. the @custom@ codecs and error types) +-- where the tuple is still exposed but internals operate on 'QualifiedTypeName'. +fromNameTuple :: (Maybe Text, Text) -> QualifiedTypeName +fromNameTuple (schema, name) = QualifiedTypeName schema name + +-- | +-- Convert to the legacy @(schema, name)@ tuple representation. +-- +-- See 'fromNameTuple'. +toNameTuple :: QualifiedTypeName -> (Maybe Text, Text) +toNameTuple (QualifiedTypeName schema name) = (schema, name) diff --git a/src/library/Hasql/Kernel/TypeInfo.hs b/src/library/Hasql/Kernel/TypeInfo.hs new file mode 100644 --- /dev/null +++ b/src/library/Hasql/Kernel/TypeInfo.hs @@ -0,0 +1,230 @@ +module Hasql.Kernel.TypeInfo where + +import Hasql.Platform.Prelude hiding (bool) + +-- | A Postgresql type info +data TypeInfo + = TypeInfo {toBaseOid :: Word32, toArrayOid :: Word32} + deriving (Eq, Ord, Show) + +abstime :: TypeInfo +abstime = TypeInfo 702 1023 + +aclitem :: TypeInfo +aclitem = TypeInfo 1033 1034 + +bit :: TypeInfo +bit = TypeInfo 1560 1561 + +bool :: TypeInfo +bool = TypeInfo 16 1000 + +box :: TypeInfo +box = TypeInfo 603 1020 + +bpchar :: TypeInfo +bpchar = TypeInfo 1042 1014 + +bytea :: TypeInfo +bytea = TypeInfo 17 1001 + +char :: TypeInfo +char = TypeInfo 18 1002 + +cid :: TypeInfo +cid = TypeInfo 29 1012 + +cidr :: TypeInfo +cidr = TypeInfo 650 651 + +circle :: TypeInfo +circle = TypeInfo 718 719 + +cstring :: TypeInfo +cstring = TypeInfo 2275 1263 + +date :: TypeInfo +date = TypeInfo 1082 1182 + +daterange :: TypeInfo +daterange = TypeInfo 3912 3913 + +datemultirange :: TypeInfo +datemultirange = TypeInfo 4535 6155 + +float4 :: TypeInfo +float4 = TypeInfo 700 1021 + +float8 :: TypeInfo +float8 = TypeInfo 701 1022 + +gtsvector :: TypeInfo +gtsvector = TypeInfo 3642 3644 + +inet :: TypeInfo +inet = TypeInfo 869 1041 + +int2 :: TypeInfo +int2 = TypeInfo 21 1005 + +int2vector :: TypeInfo +int2vector = TypeInfo 22 1006 + +int4 :: TypeInfo +int4 = TypeInfo 23 1007 + +int4range :: TypeInfo +int4range = TypeInfo 3904 3905 + +int4multirange :: TypeInfo +int4multirange = TypeInfo 4451 6150 + +int8 :: TypeInfo +int8 = TypeInfo 20 1016 + +int8range :: TypeInfo +int8range = TypeInfo 3926 3927 + +int8multirange :: TypeInfo +int8multirange = TypeInfo 4536 6157 + +interval :: TypeInfo +interval = TypeInfo 1186 1187 + +json :: TypeInfo +json = TypeInfo 114 199 + +jsonb :: TypeInfo +jsonb = TypeInfo 3802 3807 + +line :: TypeInfo +line = TypeInfo 628 629 + +lseg :: TypeInfo +lseg = TypeInfo 601 1018 + +macaddr :: TypeInfo +macaddr = TypeInfo 829 1040 + +money :: TypeInfo +money = TypeInfo 790 791 + +name :: TypeInfo +name = TypeInfo 19 1003 + +numeric :: TypeInfo +numeric = TypeInfo 1700 1231 + +numrange :: TypeInfo +numrange = TypeInfo 3906 3907 + +nummultirange :: TypeInfo +nummultirange = TypeInfo 4532 6151 + +oid :: TypeInfo +oid = TypeInfo 26 1028 + +oidvector :: TypeInfo +oidvector = TypeInfo 30 1013 + +path :: TypeInfo +path = TypeInfo 602 1019 + +point :: TypeInfo +point = TypeInfo 600 1017 + +polygon :: TypeInfo +polygon = TypeInfo 604 1027 + +record :: TypeInfo +record = TypeInfo 2249 2287 + +refcursor :: TypeInfo +refcursor = TypeInfo 1790 2201 + +regclass :: TypeInfo +regclass = TypeInfo 2205 2210 + +regconfig :: TypeInfo +regconfig = TypeInfo 3734 3735 + +regdictionary :: TypeInfo +regdictionary = TypeInfo 3769 3770 + +regoper :: TypeInfo +regoper = TypeInfo 2203 2208 + +regoperator :: TypeInfo +regoperator = TypeInfo 2204 2209 + +regproc :: TypeInfo +regproc = TypeInfo 24 1008 + +regprocedure :: TypeInfo +regprocedure = TypeInfo 2202 2207 + +regtype :: TypeInfo +regtype = TypeInfo 2206 2211 + +reltime :: TypeInfo +reltime = TypeInfo 703 1024 + +text :: TypeInfo +text = TypeInfo 25 1009 + +tid :: TypeInfo +tid = TypeInfo 27 1010 + +time :: TypeInfo +time = TypeInfo 1083 1183 + +timestamp :: TypeInfo +timestamp = TypeInfo 1114 1115 + +timestamptz :: TypeInfo +timestamptz = TypeInfo 1184 1185 + +timetz :: TypeInfo +timetz = TypeInfo 1266 1270 + +tinterval :: TypeInfo +tinterval = TypeInfo 704 1025 + +tsquery :: TypeInfo +tsquery = TypeInfo 3615 3645 + +tsrange :: TypeInfo +tsrange = TypeInfo 3908 3909 + +tsmultirange :: TypeInfo +tsmultirange = TypeInfo 4533 6152 + +tstzrange :: TypeInfo +tstzrange = TypeInfo 3910 3911 + +tstzmultirange :: TypeInfo +tstzmultirange = TypeInfo 4534 6153 + +tsvector :: TypeInfo +tsvector = TypeInfo 3614 3643 + +txid_snapshot :: TypeInfo +txid_snapshot = TypeInfo 2970 2949 + +unknown :: TypeInfo +unknown = TypeInfo 705 705 + +uuid :: TypeInfo +uuid = TypeInfo 2950 2951 + +varbit :: TypeInfo +varbit = TypeInfo 1562 1563 + +varchar :: TypeInfo +varchar = TypeInfo 1043 1015 + +xid :: TypeInfo +xid = TypeInfo 28 1011 + +xml :: TypeInfo +xml = TypeInfo 142 143 diff --git a/src/library/Hasql/Kernel/TypeRef.hs b/src/library/Hasql/Kernel/TypeRef.hs new file mode 100644 --- /dev/null +++ b/src/library/Hasql/Kernel/TypeRef.hs @@ -0,0 +1,20 @@ +module Hasql.Kernel.TypeRef + ( TypeRef (..), + ) +where + +import Hasql.Kernel.QualifiedTypeName (QualifiedTypeName) +import Hasql.Platform.Prelude + +-- | +-- How a parameter's Postgres type is identified within parameter metadata: +-- either an already-known OID, or a 'QualifiedTypeName' still pending OID +-- resolution against the server. +data TypeRef + = -- | The type's OID is statically known. + KnownOid Word32 + | -- | The type is named and its OID must be resolved before execution. + NamedType QualifiedTypeName + deriving stock (Eq, Ord, Show, Generic) + +instance Hashable TypeRef diff --git a/src/library/Hasql/Pipeline.hs b/src/library/Hasql/Pipeline.hs --- a/src/library/Hasql/Pipeline.hs +++ b/src/library/Hasql/Pipeline.hs @@ -6,10 +6,9 @@ import Hasql.Engine.Contexts.Pipeline qualified as Pipeline import Hasql.Engine.Statement qualified as Statement -import Hasql.Platform.Prelude -- | -- Execute a statement by providing parameters to it. statement :: params -> Statement.Statement params result -> Pipeline.Pipeline result statement params (Statement.Statement sql encoder decoder preparable) = - Pipeline.statement (encodeUtf8 sql) encoder decoder preparable params + Pipeline.statement sql encoder decoder preparable params diff --git a/src/library/Hasql/Session.hs b/src/library/Hasql/Session.hs --- a/src/library/Hasql/Session.hs +++ b/src/library/Hasql/Session.hs @@ -23,7 +23,7 @@ statement :: params -> Statement.Statement params result -> Session.Session result statement params (Statement.Statement sql encoder decoder preparable) = Session.statement - (encodeUtf8 sql) + sql encoder decoder preparable