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.4 +version: 1.10.3.5 category: Hasql, Database, PostgreSQL synopsis: Fast PostgreSQL driver with a flexible mapping API description: @@ -125,6 +125,12 @@ Hasql.Codecs.Encoders.Value Hasql.Codecs.RequestingOid Hasql.Codecs.RequestingOid.LookingUp + Hasql.Codecs.Vocab + Hasql.Codecs.Vocab.OidCache + Hasql.Codecs.Vocab.ParamMeta + Hasql.Codecs.Vocab.QualifiedTypeName + Hasql.Codecs.Vocab.TypeInfo + Hasql.Codecs.Vocab.TypeRef Hasql.Comms.Recv Hasql.Comms.ResultDecoder Hasql.Comms.Roundtrip @@ -142,12 +148,7 @@ Hasql.Engine.PqProcedures.SelectTypeInfo Hasql.Engine.Statement 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 @@ -264,14 +265,15 @@ main-is: Main.hs other-modules: - Hasql.Engine.Structures.OidCache + Hasql.Codecs.Vocab + Hasql.Codecs.Vocab.OidCache + Hasql.Codecs.Vocab.ParamMeta + Hasql.Codecs.Vocab.QualifiedTypeName + Hasql.Codecs.Vocab.TypeInfo + Hasql.Codecs.Vocab.TypeRef 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 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 @@ -1,8 +1,8 @@ module Hasql.Engine.Structures.OidCacheSpec (spec) where import Data.HashSet qualified as HashSet -import Hasql.Engine.Structures.OidCache qualified as OidCache -import Hasql.Kernel.QualifiedTypeName qualified as Kernel.QualifiedTypeName +import Hasql.Codecs.Vocab.OidCache qualified as OidCache +import Hasql.Codecs.Vocab.QualifiedTypeName qualified as Vocab.QualifiedTypeName import Test.Hspec import Prelude @@ -55,7 +55,7 @@ describe "selectUnknownNames" do it "returns all names when cache is empty" do - let names = HashSet.fromList [Kernel.QualifiedTypeName.QualifiedTypeName Nothing "int4", Kernel.QualifiedTypeName.QualifiedTypeName Nothing "int8"] + let names = HashSet.fromList [Vocab.QualifiedTypeName.QualifiedTypeName Nothing "int4", Vocab.QualifiedTypeName.QualifiedTypeName Nothing "int8"] OidCache.selectUnknownNames names OidCache.empty `shouldBe` names @@ -67,15 +67,15 @@ 23 1007 (OidCache.insertScalar Nothing "int8" 20 1016 OidCache.empty) - names = HashSet.fromList [Kernel.QualifiedTypeName.QualifiedTypeName Nothing "int4", Kernel.QualifiedTypeName.QualifiedTypeName Nothing "int8"] + names = HashSet.fromList [Vocab.QualifiedTypeName.QualifiedTypeName Nothing "int4", Vocab.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 [Kernel.QualifiedTypeName.QualifiedTypeName Nothing "int4", Kernel.QualifiedTypeName.QualifiedTypeName Nothing "int8"] + names = HashSet.fromList [Vocab.QualifiedTypeName.QualifiedTypeName Nothing "int4", Vocab.QualifiedTypeName.QualifiedTypeName Nothing "int8"] OidCache.selectUnknownNames names cache - `shouldBe` HashSet.fromList [Kernel.QualifiedTypeName.QualifiedTypeName Nothing "int8"] + `shouldBe` HashSet.fromList [Vocab.QualifiedTypeName.QualifiedTypeName Nothing "int8"] describe "Semigroup" do it "right operand takes precedence for duplicate keys" do 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,7 +4,6 @@ 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 @@ -67,7 +66,7 @@ ( Decoders.custom Nothing "int4" - (Just (TypeInfo 23 1007)) + (Just (23, 1007)) [] (\_ bytes -> Right (ByteString.length bytes)) ) @@ -108,10 +107,8 @@ Nothing [(Nothing, enumName), (Nothing, "int4")] ( \lookupOid bytes -> do - let enumTypeInfo = lookupOid (Nothing, enumName) - int4TypeInfo = lookupOid (Nothing, "int4") - enumOidScalar = toBaseOid enumTypeInfo - int4OidScalar = toBaseOid int4TypeInfo + let (enumOidScalar, _enumOidArray) = lookupOid (Nothing, enumName) + (int4OidScalar, _int4OidArray) = lookupOid (Nothing, "int4") -- Verify we got valid OIDs if enumOidScalar > 0 && int4OidScalar > 0 then Right (enumOidScalar, int4OidScalar, ByteString.length bytes) @@ -206,7 +203,7 @@ ( Decoders.custom Nothing "int4" - (Just (TypeInfo 23 1007)) + (Just (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,7 +4,6 @@ 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 @@ -58,7 +57,7 @@ ( Encoders.custom Nothing "text" - (Just (TypeInfo 25 1009)) + (Just (25, 1009)) [] (\_ val -> encodeUtf8 val) id @@ -90,8 +89,7 @@ Nothing [(Nothing, enumName)] ( \lookupOid val -> do - let enumTypeInfo = lookupOid (Nothing, enumName) - enumOidScalar = toBaseOid enumTypeInfo + let (enumOidScalar, _enumOidArray) = lookupOid (Nothing, enumName) -- 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.Kernel.TypeInfo qualified as Kernel.TypeInfo +import Hasql.Codecs.Vocab.TypeInfo qualified as Vocab.TypeInfo import Hasql.Platform.Prelude -- * Value @@ -139,9 +139,9 @@ Value.Value Nothing "record" - (Just (Kernel.TypeInfo.toBaseOid typeInfo)) - (Just (Kernel.TypeInfo.toArrayOid typeInfo)) + (Just (Vocab.TypeInfo.toBaseOid typeInfo)) + (Just (Vocab.TypeInfo.toArrayOid typeInfo)) 0 (Composite.toValueDecoder composite) where - typeInfo = Kernel.TypeInfo.record + typeInfo = Vocab.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,8 +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.Codecs.Vocab.QualifiedTypeName qualified as Vocab.QualifiedTypeName +import Hasql.Codecs.Vocab.TypeInfo qualified as Vocab.TypeInfo import Hasql.Platform.Prelude import PostgreSQL.Binary.Decoding qualified as Binary @@ -33,8 +33,8 @@ Nothing -> Composite ( RequestingOid.hoistLookingUp - (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) + (Vocab.QualifiedTypeName.QualifiedTypeName (Value.toSchema imp) (Value.toTypeName imp)) + (\typeInfo decoder -> Binary.typedValueComposite (if dimensionality == 0 then Vocab.TypeInfo.toBaseOid typeInfo else Vocab.TypeInfo.toArrayOid typeInfo) decoder) (Value.toDecoder imp) ) NullableOrNot.Nullable imp -> @@ -46,7 +46,7 @@ Nothing -> Composite ( RequestingOid.hoistLookingUp - (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) + (Vocab.QualifiedTypeName.QualifiedTypeName (Value.toSchema imp) (Value.toTypeName imp)) + (\typeInfo decoder -> Binary.typedNullableValueComposite (if dimensionality == 0 then Vocab.TypeInfo.toBaseOid typeInfo else Vocab.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,9 +58,9 @@ import Data.Aeson qualified as Aeson import Data.IP qualified as Iproute import Hasql.Codecs.RequestingOid qualified as RequestingOid -import Hasql.Kernel qualified as Kernel -import Hasql.Kernel.QualifiedTypeName qualified as Kernel.QualifiedTypeName -import Hasql.Kernel.TypeInfo qualified as Kernel.TypeInfo +import Hasql.Codecs.Vocab qualified as Vocab +import Hasql.Codecs.Vocab.QualifiedTypeName qualified as Vocab.QualifiedTypeName +import Hasql.Codecs.Vocab.TypeInfo qualified as Vocab.TypeInfo import Hasql.Platform.Prelude hiding (bool) import PostgreSQL.Binary.Decoding qualified as Binary import PostgreSQL.Binary.Range qualified as R @@ -93,9 +93,9 @@ -- | -- Create a decoder from TypeInfo metadata and a decoding function. {-# INLINE primitive #-} -primitive :: Text -> Kernel.TypeInfo.TypeInfo -> Binary.Value a -> Value a +primitive :: Text -> Vocab.TypeInfo.TypeInfo -> Binary.Value a -> Value a primitive typeName pti decoder = - Value Nothing typeName (Just (Kernel.TypeInfo.toBaseOid pti)) (Just (Kernel.TypeInfo.toArrayOid pti)) 0 (RequestingOid.lift decoder) + Value Nothing typeName (Just (Vocab.TypeInfo.toBaseOid pti)) (Just (Vocab.TypeInfo.toArrayOid pti)) 0 (RequestingOid.lift decoder) -- * Static types @@ -103,19 +103,19 @@ -- Decoder of the @BOOL@ values. {-# INLINEABLE bool #-} bool :: Value Bool -bool = primitive "bool" Kernel.TypeInfo.bool Binary.bool +bool = primitive "bool" Vocab.TypeInfo.bool Binary.bool -- | -- Decoder of the @INT2@ values. {-# INLINEABLE int2 #-} int2 :: Value Int16 -int2 = primitive "int2" Kernel.TypeInfo.int2 Binary.int +int2 = primitive "int2" Vocab.TypeInfo.int2 Binary.int -- | -- Decoder of the @INT4@ values. {-# INLINEABLE int4 #-} int4 :: Value Int32 -int4 = primitive "int4" Kernel.TypeInfo.int4 Binary.int +int4 = primitive "int4" Vocab.TypeInfo.int4 Binary.int -- | -- Decoder of the @INT8@ values. @@ -123,68 +123,68 @@ int8 :: Value Int64 int8 = {-# SCC "int8" #-} - primitive "int8" Kernel.TypeInfo.int8 ({-# SCC "int8.int" #-} Binary.int) + primitive "int8" Vocab.TypeInfo.int8 ({-# SCC "int8.int" #-} Binary.int) -- | -- Decoder of the @FLOAT4@ values. {-# INLINEABLE float4 #-} float4 :: Value Float -float4 = primitive "float4" Kernel.TypeInfo.float4 Binary.float4 +float4 = primitive "float4" Vocab.TypeInfo.float4 Binary.float4 -- | -- Decoder of the @FLOAT8@ values. {-# INLINEABLE float8 #-} float8 :: Value Double -float8 = primitive "float8" Kernel.TypeInfo.float8 Binary.float8 +float8 = primitive "float8" Vocab.TypeInfo.float8 Binary.float8 -- | -- Decoder of the @NUMERIC@ values. {-# INLINEABLE numeric #-} numeric :: Value Scientific -numeric = primitive "numeric" Kernel.TypeInfo.numeric Binary.numeric +numeric = primitive "numeric" Vocab.TypeInfo.numeric Binary.numeric -- | -- Decoder of the @CHAR@ values. -- Note that it supports Unicode values. {-# INLINEABLE char #-} char :: Value Char -char = primitive "char" Kernel.TypeInfo.char Binary.char +char = primitive "char" Vocab.TypeInfo.char Binary.char -- | -- Decoder of the @TEXT@ values. {-# INLINEABLE text #-} text :: Value Text -text = primitive "text" Kernel.TypeInfo.text Binary.text_strict +text = primitive "text" Vocab.TypeInfo.text Binary.text_strict -- | -- Decoder of the @VARCHAR@ values. {-# INLINEABLE varchar #-} varchar :: Value Text -varchar = primitive "varchar" Kernel.TypeInfo.varchar Binary.text_strict +varchar = primitive "varchar" Vocab.TypeInfo.varchar Binary.text_strict -- | -- Decoder of @BPCHAR@ or @CHAR(n)@, @CHARACTER(n)@ values. {-# INLINEABLE bpchar #-} bpchar :: Value Text -bpchar = primitive "bpchar" Kernel.TypeInfo.bpchar Binary.text_strict +bpchar = primitive "bpchar" Vocab.TypeInfo.bpchar Binary.text_strict -- | -- Decoder of the @BYTEA@ values. {-# INLINEABLE bytea #-} bytea :: Value ByteString -bytea = primitive "bytea" Kernel.TypeInfo.bytea Binary.bytea_strict +bytea = primitive "bytea" Vocab.TypeInfo.bytea Binary.bytea_strict -- | -- Decoder of the @DATE@ values. {-# INLINEABLE date #-} date :: Value Day -date = primitive "date" Kernel.TypeInfo.date Binary.date +date = primitive "date" Vocab.TypeInfo.date Binary.date -- | -- Decoder of the @TIMESTAMP@ values. {-# INLINEABLE timestamp #-} timestamp :: Value LocalTime -timestamp = primitive "timestamp" Kernel.TypeInfo.timestamp Binary.timestamp_int +timestamp = primitive "timestamp" Vocab.TypeInfo.timestamp Binary.timestamp_int -- | -- Decoder of the @TIMESTAMPTZ@ values. @@ -198,13 +198,13 @@ -- and communicates with Postgres using the UTC values directly. {-# INLINEABLE timestamptz #-} timestamptz :: Value UTCTime -timestamptz = primitive "timestamptz" Kernel.TypeInfo.timestamptz Binary.timestamptz_int +timestamptz = primitive "timestamptz" Vocab.TypeInfo.timestamptz Binary.timestamptz_int -- | -- Decoder of the @TIME@ values. {-# INLINEABLE time #-} time :: Value TimeOfDay -time = primitive "time" Kernel.TypeInfo.time Binary.time_int +time = primitive "time" Vocab.TypeInfo.time Binary.time_int -- | -- Decoder of the @TIMETZ@ values. @@ -216,25 +216,25 @@ -- to represent a value on the Haskell's side. {-# INLINEABLE timetz #-} timetz :: Value (TimeOfDay, TimeZone) -timetz = primitive "timetz" Kernel.TypeInfo.timetz Binary.timetz_int +timetz = primitive "timetz" Vocab.TypeInfo.timetz Binary.timetz_int -- | -- Decoder of the @INTERVAL@ values. {-# INLINEABLE interval #-} interval :: Value DiffTime -interval = primitive "interval" Kernel.TypeInfo.interval Binary.interval_int +interval = primitive "interval" Vocab.TypeInfo.interval Binary.interval_int -- | -- Decoder of the @UUID@ values. {-# INLINEABLE uuid #-} uuid :: Value UUID -uuid = primitive "uuid" Kernel.TypeInfo.uuid Binary.uuid +uuid = primitive "uuid" Vocab.TypeInfo.uuid Binary.uuid -- | -- Decoder of the @INET@ values. {-# INLINEABLE inet #-} inet :: Value Iproute.IPRange -inet = primitive "inet" Kernel.TypeInfo.inet Binary.inet +inet = primitive "inet" Vocab.TypeInfo.inet Binary.inet -- | -- Decoder of the @MACADDR@ values. @@ -245,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" Kernel.TypeInfo.macaddr Binary.macaddr +macaddr = primitive "macaddr" Vocab.TypeInfo.macaddr Binary.macaddr -- | -- Decoder of the @JSON@ values into a JSON AST. {-# INLINEABLE json #-} json :: Value Aeson.Value -json = primitive "json" Kernel.TypeInfo.json Binary.json_ast +json = primitive "json" Vocab.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" Kernel.TypeInfo.json (Binary.json_bytes fn) +jsonBytes fn = primitive "json" Vocab.TypeInfo.json (Binary.json_bytes fn) -- | -- Decoder of the @JSONB@ values into a JSON AST. {-# INLINEABLE jsonb #-} jsonb :: Value Aeson.Value -jsonb = primitive "jsonb" Kernel.TypeInfo.jsonb Binary.jsonb_ast +jsonb = primitive "jsonb" Vocab.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" Kernel.TypeInfo.jsonb (Binary.jsonb_bytes fn) +jsonbBytes fn = primitive "jsonb" Vocab.TypeInfo.jsonb (Binary.jsonb_bytes fn) -- | -- Decoder of the @INT4RANGE@ values. {-# INLINEABLE int4range #-} int4range :: Value (R.Range Int32) -int4range = primitive "int4range" Kernel.TypeInfo.int4range Binary.int4range +int4range = primitive "int4range" Vocab.TypeInfo.int4range Binary.int4range -- | -- Decoder of the @INT8RANGE@ values. {-# INLINEABLE int8range #-} int8range :: Value (R.Range Int64) -int8range = primitive "int8range" Kernel.TypeInfo.int8range Binary.int8range +int8range = primitive "int8range" Vocab.TypeInfo.int8range Binary.int8range -- | -- Decoder of the @NUMRANGE@ values. {-# INLINEABLE numrange #-} numrange :: Value (R.Range Scientific) -numrange = primitive "numrange" Kernel.TypeInfo.numrange Binary.numrange +numrange = primitive "numrange" Vocab.TypeInfo.numrange Binary.numrange -- | -- Decoder of the @TSRANGE@ values. {-# INLINEABLE tsrange #-} tsrange :: Value (R.Range LocalTime) -tsrange = primitive "tsrange" Kernel.TypeInfo.tsrange Binary.tsrange_int +tsrange = primitive "tsrange" Vocab.TypeInfo.tsrange Binary.tsrange_int -- | -- Decoder of the @TSTZRANGE@ values. {-# INLINEABLE tstzrange #-} tstzrange :: Value (R.Range UTCTime) -tstzrange = primitive "tstzrange" Kernel.TypeInfo.tstzrange Binary.tstzrange_int +tstzrange = primitive "tstzrange" Vocab.TypeInfo.tstzrange Binary.tstzrange_int -- | -- Decoder of the @DATERANGE@ values. {-# INLINEABLE daterange #-} daterange :: Value (R.Range Day) -daterange = primitive "daterange" Kernel.TypeInfo.daterange Binary.daterange +daterange = primitive "daterange" Vocab.TypeInfo.daterange Binary.daterange -- | -- Decoder of the @INT4MULTIRANGE@ values. {-# INLINEABLE int4multirange #-} int4multirange :: Value (R.Multirange Int32) -int4multirange = primitive "int4multirange" Kernel.TypeInfo.int4multirange Binary.int4multirange +int4multirange = primitive "int4multirange" Vocab.TypeInfo.int4multirange Binary.int4multirange -- | -- Decoder of the @INT8MULTIRANGE@ values. {-# INLINEABLE int8multirange #-} int8multirange :: Value (R.Multirange Int64) -int8multirange = primitive "int8multirange" Kernel.TypeInfo.int8multirange Binary.int8multirange +int8multirange = primitive "int8multirange" Vocab.TypeInfo.int8multirange Binary.int8multirange -- | -- Decoder of the @NUMMULTIRANGE@ values. {-# INLINEABLE nummultirange #-} nummultirange :: Value (R.Multirange Scientific) -nummultirange = primitive "nummultirange" Kernel.TypeInfo.nummultirange Binary.nummultirange +nummultirange = primitive "nummultirange" Vocab.TypeInfo.nummultirange Binary.nummultirange -- | -- Decoder of the @TSMULTIRANGE@ values. {-# INLINEABLE tsmultirange #-} tsmultirange :: Value (R.Multirange LocalTime) -tsmultirange = primitive "tsmultirange" Kernel.TypeInfo.tsmultirange Binary.tsmultirange_int +tsmultirange = primitive "tsmultirange" Vocab.TypeInfo.tsmultirange Binary.tsmultirange_int -- | -- Decoder of the @TSTZMULTIRANGE@ values. {-# INLINEABLE tstzmultirange #-} tstzmultirange :: Value (R.Multirange UTCTime) -tstzmultirange = primitive "tstzmultirange" Kernel.TypeInfo.tstzmultirange Binary.tstzmultirange_int +tstzmultirange = primitive "tstzmultirange" Vocab.TypeInfo.tstzmultirange Binary.tstzmultirange_int -- | -- Decoder of the @DATEMULTIRANGE@ values. {-# INLINEABLE datemultirange #-} datemultirange :: Value (R.Multirange Day) -datemultirange = primitive "datemultirange" Kernel.TypeInfo.datemultirange Binary.datemultirange +datemultirange = primitive "datemultirange" Vocab.TypeInfo.datemultirange Binary.datemultirange -- | -- Decoder of the @CITEXT@ values. @@ -362,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 Kernel.TypeInfo.TypeInfo -> + Maybe (Word32, Word32) -> -- | 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. @@ -373,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) -> Kernel.TypeInfo.TypeInfo) -> + ( ((Maybe Text, Text) -> (Word32, Word32)) -> ByteString -> Either Text a ) -> @@ -382,10 +382,12 @@ Value schema typeName - (fmap Kernel.TypeInfo.toBaseOid staticOids) - (fmap Kernel.TypeInfo.toArrayOid staticOids) + (fmap fst staticOids) + (fmap snd staticOids) 0 - (RequestingOid.requestAndHandle (fmap Kernel.QualifiedTypeName.fromNameTuple requestedTypes) (\lookup -> Binary.fn (fn (lookup . Kernel.QualifiedTypeName.fromNameTuple)))) + (RequestingOid.requestAndHandle (fmap Vocab.QualifiedTypeName.fromNameTuple requestedTypes) (\lookup -> Binary.fn (fn (toTuple . lookup . Vocab.QualifiedTypeName.fromNameTuple)))) + where + toTuple typeInfo = (Vocab.TypeInfo.toBaseOid typeInfo, Vocab.TypeInfo.toArrayOid typeInfo) -- | -- Refine a value decoder, lifting the possible error to the session level. @@ -448,11 +450,11 @@ toDecoder (Value _ _ _ _ _ decoder) = decoder {-# INLINE toHandler #-} -toHandler :: Value a -> HashMap Kernel.QualifiedTypeName Kernel.TypeInfo.TypeInfo -> Binary.Value a +toHandler :: Value a -> Vocab.OidCache -> Binary.Value a toHandler (Value _ _ _ _ _ decoder) = RequestingOid.toBase decoder {-# INLINE toByteStringParser #-} -toByteStringParser :: Value a -> (HashMap Kernel.QualifiedTypeName Kernel.TypeInfo.TypeInfo -> ByteString -> Either Text a) +toByteStringParser :: Value a -> (Vocab.OidCache -> 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,8 +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.Kernel.QualifiedTypeName qualified as Kernel.QualifiedTypeName -import Hasql.Kernel.TypeInfo qualified as Kernel.TypeInfo +import Hasql.Codecs.Vocab.QualifiedTypeName qualified as Vocab.QualifiedTypeName +import Hasql.Codecs.Vocab.TypeInfo qualified as Vocab.TypeInfo import Hasql.Platform.Prelude hiding (bool) import PostgreSQL.Binary.Encoding qualified as Binary import TextBuilder qualified @@ -122,11 +122,11 @@ asum [ scalarOidIfKnown, oidCache - & HashMap.lookup (Kernel.QualifiedTypeName.QualifiedTypeName baseTypeSchema baseTypeName) - & fmap Kernel.TypeInfo.toBaseOid + & HashMap.lookup (Vocab.QualifiedTypeName.QualifiedTypeName baseTypeSchema baseTypeName) + & fmap Vocab.TypeInfo.toBaseOid ] -- Should only happen on a bug. - & fromMaybe (Kernel.TypeInfo.toBaseOid Kernel.TypeInfo.unknown) + & fromMaybe (Vocab.TypeInfo.toBaseOid Vocab.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,7 +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.Codecs.Vocab qualified as Vocab import Hasql.Platform.Prelude import PostgreSQL.Binary.Encoding qualified as Binary import TextBuilder qualified as TextBuilder @@ -34,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 Kernel.QualifiedTypeName) + (HashSet Vocab.QualifiedTypeName) -- | Serialization function given the dictionary of resolved OIDs. - (HashMap Kernel.QualifiedTypeName Kernel.TypeInfo -> a -> Binary.Array) + (HashMap Vocab.QualifiedTypeName Vocab.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,9 +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.Codecs.Vocab qualified as Vocab +import Hasql.Codecs.Vocab.QualifiedTypeName qualified as Vocab.QualifiedTypeName +import Hasql.Codecs.Vocab.TypeInfo qualified as Vocab.TypeInfo import Hasql.Platform.Prelude hiding (bool) import PostgreSQL.Binary.Encoding qualified as Binary import TextBuilder qualified @@ -16,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 Kernel.QualifiedTypeName) + (HashSet Vocab.QualifiedTypeName) -- | Serialization function given the dictionary of resolved OIDs. - (HashMap Kernel.QualifiedTypeName Kernel.TypeInfo -> a -> Binary.Composite) + (HashMap Vocab.QualifiedTypeName Vocab.TypeInfo -> a -> Binary.Composite) -- | Render function for error messages. (a -> [TextBuilder.TextBuilder]) @@ -57,10 +57,10 @@ (\val -> [print val]) Nothing -> Composite - (HashSet.insert (Kernel.QualifiedTypeName.QualifiedTypeName schemaName typeName) unknownTypes) + (HashSet.insert (Vocab.QualifiedTypeName.QualifiedTypeName schemaName typeName) unknownTypes) ( \oidCache val -> - 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 + let typeInfo = HashMap.lookup (Vocab.QualifiedTypeName.QualifiedTypeName schemaName typeName) oidCache + oid = if dimensionality == 0 then maybe 0 Vocab.TypeInfo.toBaseOid typeInfo else maybe 0 Vocab.TypeInfo.toArrayOid typeInfo in Binary.field oid (encode oidCache val) ) (\val -> [print val]) @@ -80,15 +80,15 @@ ) Nothing -> Composite - (HashSet.insert (Kernel.QualifiedTypeName.QualifiedTypeName schemaName typeName) unknownTypes) + (HashSet.insert (Vocab.QualifiedTypeName.QualifiedTypeName schemaName typeName) unknownTypes) ( \oidCache -> \case Nothing -> - 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 + let typeInfo = HashMap.lookup (Vocab.QualifiedTypeName.QualifiedTypeName schemaName typeName) oidCache + oid = if dimensionality == 0 then maybe 0 Vocab.TypeInfo.toBaseOid typeInfo else maybe 0 Vocab.TypeInfo.toArrayOid typeInfo in Binary.nullField oid Just val -> - 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 + let typeInfo = HashMap.lookup (Vocab.QualifiedTypeName.QualifiedTypeName schemaName typeName) oidCache + oid = if dimensionality == 0 then maybe 0 Vocab.TypeInfo.toBaseOid typeInfo else maybe 0 Vocab.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 @@ -1,76 +1,46 @@ -module Hasql.Codecs.Encoders.Params where +module Hasql.Codecs.Encoders.Params + ( Params, + noParams, + param, + toColumnsMetadata, + toUnknownTypes, + toSerializer, + toPrinter, + ) +where -import Data.HashMap.Strict qualified as HashMap import Data.HashSet qualified as HashSet +import Data.Vector qualified as Vector 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.Codecs.Vocab qualified as Vocab +import Hasql.Codecs.Vocab.OidCache qualified as Vocab.OidCache +import Hasql.Codecs.Vocab.ParamMeta (ParamMeta (..)) +import Hasql.Codecs.Vocab.QualifiedTypeName qualified as Vocab.QualifiedTypeName +import Hasql.Codecs.Vocab.TypeRef qualified as Vocab.TypeRef import Hasql.Platform.Prelude import PostgreSQL.Binary.Encoding qualified as Binary import TextBuilder qualified -renderReadable :: Params a -> a -> [Text] -renderReadable (Params _ _ _ _ printer) params = - printer params - & toList - -compilePreparedStatementData :: - Params a -> - HashMap Kernel.QualifiedTypeName Kernel.TypeInfo.TypeInfo -> - a -> - ([Word32], [Maybe (ByteString, Bool)]) -compilePreparedStatementData (Params _ _ columnsMetadata serializer _) oidCache input = - (oidList, valueAndFormatList) +-- | Frozen per-parameter metadata: type reference, dimensionality, text-format flag. +toColumnsMetadata :: Params a -> Vector ParamMeta +toColumnsMetadata (Params _ _ columnsMetadata _ _) = freezeColumnsMetadata columnsMetadata where - (oidList, formatList) = - columnsMetadata - & toList - & fmap - ( \case - (Kernel.TypeRef.NamedType name, dimensionality, format) -> - case HashMap.lookup name oidCache of - Just typeInfo -> - ( if dimensionality == 0 then Kernel.TypeInfo.toBaseOid typeInfo else Kernel.TypeInfo.toArrayOid typeInfo, - format - ) - Nothing -> - (0, format) - (Kernel.TypeRef.KnownOid oid, _, format) -> - (oid, format) - ) - & unzip - - valueAndFormatList = - serializer oidCache input - & toList - & zipWith (\format encoding -> (,format) <$> encoding) formatList - -compileUnpreparedStatementData :: - Params a -> - 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 - 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 - Kernel.TypeRef.KnownOid oid -> oid - in (,,) <$> Just oid <*> encoding <*> Just format - ) - (toList columnsMetadata) - (toList (serializer oidCache input)) + freezeColumnsMetadata = + Vector.fromList . toList -toUnknownTypes :: Params a -> HashSet Kernel.QualifiedTypeName +toUnknownTypes :: Params a -> HashSet Vocab.QualifiedTypeName toUnknownTypes (Params _ unknownTypes _ _ _) = unknownTypes +-- | Serialise params to encoded wire values given a resolved OID cache. +toSerializer :: Params a -> Vocab.OidCache -> a -> [Maybe ByteString] +toSerializer (Params _ _ _ serializer _) = serializer + +-- | Render params in human-readable form (for error reporting). +toPrinter :: Params a -> a -> [Text] +toPrinter (Params _ _ _ _ printer) = toList . printer + -- | -- Encoder of some representation of a parameters product. -- @@ -87,7 +57,7 @@ -- -- As a general solution for tuples of any arity, instead of 'fst' and 'snd', -- consider the functions of the @contrazip@ family --- from the \"contravariant-extras\" package. +-- from the "contravariant-extras" package. -- E.g., here's how you can achieve the same as the above: -- -- @ @@ -117,10 +87,10 @@ -- @ data Params a = Params { size :: Int, - unknownTypes :: HashSet Kernel.QualifiedTypeName, + unknownTypes :: HashSet Vocab.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), + columnsMetadata :: DList ParamMeta, + serializer :: Vocab.OidCache -> a -> [Maybe ByteString], printer :: a -> DList Text } @@ -169,7 +139,7 @@ value :: Value.Value a -> Params a value (Value.Value schemaName typeName scalarOid arrayOid dimensionality textFormat unknownTypes serialize print) = let staticOid = if dimensionality == 0 then scalarOid else arrayOid - serializer oidCache = pure . Just . Binary.encodingBytes . serialize oidCache + serializer oidCache = pure . Just . Binary.encodingBytes . serialize (Vocab.OidCache.toHashMap oidCache) printer = pure . TextBuilder.toText . print size = 1 in case staticOid of @@ -177,15 +147,15 @@ Params { size, unknownTypes, - columnsMetadata = pure (Kernel.TypeRef.KnownOid oid, dimensionality, textFormat), + columnsMetadata = pure (ParamMeta (Vocab.TypeRef.KnownOid oid) dimensionality textFormat), serializer, printer } Nothing -> Params { size, - unknownTypes = HashSet.insert (Kernel.QualifiedTypeName.QualifiedTypeName schemaName typeName) unknownTypes, - columnsMetadata = pure (Kernel.TypeRef.NamedType (Kernel.QualifiedTypeName.QualifiedTypeName schemaName typeName), dimensionality, textFormat), + unknownTypes = HashSet.insert (Vocab.QualifiedTypeName.QualifiedTypeName schemaName typeName) unknownTypes, + columnsMetadata = pure (ParamMeta (Vocab.TypeRef.NamedType (Vocab.QualifiedTypeName.QualifiedTypeName schemaName typeName)) dimensionality textFormat), serializer, printer } @@ -193,7 +163,7 @@ nullableValue :: Value.Value a -> Params (Maybe a) nullableValue (Value.Value schemaName typeName scalarOid arrayOid dimensionality textFormat unknownTypes serialize print) = let staticOid = if dimensionality == 0 then scalarOid else arrayOid - serializer oidCache = pure . fmap (Binary.encodingBytes . serialize oidCache) + serializer oidCache = pure . fmap (Binary.encodingBytes . serialize (Vocab.OidCache.toHashMap oidCache)) printer = pure . maybe "null" (TextBuilder.toText . print) size = 1 in case staticOid of @@ -201,15 +171,15 @@ Params { size, unknownTypes, - columnsMetadata = pure (Kernel.TypeRef.KnownOid oid, dimensionality, textFormat), + columnsMetadata = pure (ParamMeta (Vocab.TypeRef.KnownOid oid) dimensionality textFormat), serializer, printer } Nothing -> Params { size, - unknownTypes = HashSet.insert (Kernel.QualifiedTypeName.QualifiedTypeName schemaName typeName) unknownTypes, - columnsMetadata = pure (Kernel.TypeRef.NamedType (Kernel.QualifiedTypeName.QualifiedTypeName schemaName typeName), dimensionality, textFormat), + unknownTypes = HashSet.insert (Vocab.QualifiedTypeName.QualifiedTypeName schemaName typeName) unknownTypes, + columnsMetadata = pure (ParamMeta (Vocab.TypeRef.NamedType (Vocab.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,9 +6,9 @@ import Data.HashMap.Strict qualified as HashMap import Data.HashSet qualified as HashSet import Data.IP qualified as Iproute -import Hasql.Kernel qualified as Kernel -import Hasql.Kernel.QualifiedTypeName qualified as Kernel.QualifiedTypeName -import Hasql.Kernel.TypeInfo qualified as Kernel.TypeInfo +import Hasql.Codecs.Vocab qualified as Vocab +import Hasql.Codecs.Vocab.QualifiedTypeName qualified as Vocab.QualifiedTypeName +import Hasql.Codecs.Vocab.TypeInfo qualified as Vocab.TypeInfo import Hasql.Platform.Prelude import PostgreSQL.Binary.Encoding qualified as Binary import PostgreSQL.Binary.Range qualified as Range @@ -34,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 Kernel.QualifiedTypeName) + (HashSet Vocab.QualifiedTypeName) -- | Serialization function on the resolved OIDs. - (HashMap Kernel.QualifiedTypeName Kernel.TypeInfo.TypeInfo -> a -> Binary.Encoding) + (HashMap Vocab.QualifiedTypeName Vocab.TypeInfo.TypeInfo -> a -> Binary.Encoding) -- | Render function for error messages. (a -> TextBuilder.TextBuilder) @@ -46,13 +46,13 @@ Value schemaName typeName valueOid arrayOid dimensionality textFormat unknownTypes (\hashMap -> encode hashMap . f) (render . f) {-# INLINE primitive #-} -primitive :: Text -> Bool -> Kernel.TypeInfo.TypeInfo -> (a -> Binary.Encoding) -> (a -> TextBuilder.TextBuilder) -> Value a +primitive :: Text -> Bool -> Vocab.TypeInfo.TypeInfo -> (a -> Binary.Encoding) -> (a -> TextBuilder.TextBuilder) -> Value a primitive typeName isText typeInfo encode render = Value Nothing typeName - (Just (Kernel.TypeInfo.toBaseOid typeInfo)) - (Just (Kernel.TypeInfo.toArrayOid typeInfo)) + (Just (Vocab.TypeInfo.toBaseOid typeInfo)) + (Just (Vocab.TypeInfo.toArrayOid typeInfo)) 0 isText HashSet.empty @@ -63,43 +63,43 @@ -- Encoder of @BOOL@ values. {-# INLINEABLE bool #-} bool :: Value Bool -bool = primitive "bool" False Kernel.TypeInfo.bool Binary.bool (TextBuilder.string . show) +bool = primitive "bool" False Vocab.TypeInfo.bool Binary.bool (TextBuilder.string . show) -- | -- Encoder of @INT2@ values. {-# INLINEABLE int2 #-} int2 :: Value Int16 -int2 = primitive "int2" False Kernel.TypeInfo.int2 Binary.int2_int16 (TextBuilder.string . show) +int2 = primitive "int2" False Vocab.TypeInfo.int2 Binary.int2_int16 (TextBuilder.string . show) -- | -- Encoder of @INT4@ values. {-# INLINEABLE int4 #-} int4 :: Value Int32 -int4 = primitive "int4" False Kernel.TypeInfo.int4 Binary.int4_int32 (TextBuilder.string . show) +int4 = primitive "int4" False Vocab.TypeInfo.int4 Binary.int4_int32 (TextBuilder.string . show) -- | -- Encoder of @INT8@ values. {-# INLINEABLE int8 #-} int8 :: Value Int64 -int8 = primitive "int8" False Kernel.TypeInfo.int8 Binary.int8_int64 (TextBuilder.string . show) +int8 = primitive "int8" False Vocab.TypeInfo.int8 Binary.int8_int64 (TextBuilder.string . show) -- | -- Encoder of @FLOAT4@ values. {-# INLINEABLE float4 #-} float4 :: Value Float -float4 = primitive "float4" False Kernel.TypeInfo.float4 Binary.float4 (TextBuilder.string . show) +float4 = primitive "float4" False Vocab.TypeInfo.float4 Binary.float4 (TextBuilder.string . show) -- | -- Encoder of @FLOAT8@ values. {-# INLINEABLE float8 #-} float8 :: Value Double -float8 = primitive "float8" False Kernel.TypeInfo.float8 Binary.float8 (TextBuilder.string . show) +float8 = primitive "float8" False Vocab.TypeInfo.float8 Binary.float8 (TextBuilder.string . show) -- | -- Encoder of @NUMERIC@ values. {-# INLINEABLE numeric #-} numeric :: Value Scientific -numeric = primitive "numeric" False Kernel.TypeInfo.numeric Binary.numeric (TextBuilder.string . show) +numeric = primitive "numeric" False Vocab.TypeInfo.numeric Binary.numeric (TextBuilder.string . show) -- | -- Encoder of @CHAR@ values. @@ -108,79 +108,79 @@ -- identifies itself under the @TEXT@ OID because of that. {-# INLINEABLE char #-} char :: Value Char -char = primitive "char" False Kernel.TypeInfo.text Binary.char_utf8 (TextBuilder.string . show) +char = primitive "char" False Vocab.TypeInfo.text Binary.char_utf8 (TextBuilder.string . show) -- | -- Encoder of @TEXT@ values. {-# INLINEABLE text #-} text :: Value Text -text = primitive "text" False Kernel.TypeInfo.text Binary.text_strict (TextBuilder.string . show) +text = primitive "text" False Vocab.TypeInfo.text Binary.text_strict (TextBuilder.string . show) -- | -- Encoder of @VARCHAR@ values. {-# INLINEABLE varchar #-} varchar :: Value Text -varchar = primitive "varchar" False Kernel.TypeInfo.varchar Binary.text_strict (TextBuilder.string . show) +varchar = primitive "varchar" False Vocab.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 Kernel.TypeInfo.bpchar Binary.text_strict (TextBuilder.string . show) +bpchar = primitive "bpchar" False Vocab.TypeInfo.bpchar Binary.text_strict (TextBuilder.string . show) -- | -- Encoder of @BYTEA@ values. {-# INLINEABLE bytea #-} bytea :: Value ByteString -bytea = primitive "bytea" False Kernel.TypeInfo.bytea Binary.bytea_strict (TextBuilder.string . show) +bytea = primitive "bytea" False Vocab.TypeInfo.bytea Binary.bytea_strict (TextBuilder.string . show) -- | -- Encoder of @DATE@ values. {-# INLINEABLE date #-} date :: Value Day -date = primitive "date" False Kernel.TypeInfo.date Binary.date (TextBuilder.string . show) +date = primitive "date" False Vocab.TypeInfo.date Binary.date (TextBuilder.string . show) -- | -- Encoder of @TIMESTAMP@ values. {-# INLINEABLE timestamp #-} timestamp :: Value LocalTime -timestamp = primitive "timestamp" False Kernel.TypeInfo.timestamp Binary.timestamp_int (TextBuilder.string . show) +timestamp = primitive "timestamp" False Vocab.TypeInfo.timestamp Binary.timestamp_int (TextBuilder.string . show) -- | -- Encoder of @TIMESTAMPTZ@ values. {-# INLINEABLE timestamptz #-} timestamptz :: Value UTCTime -timestamptz = primitive "timestamptz" False Kernel.TypeInfo.timestamptz Binary.timestamptz_int (TextBuilder.string . show) +timestamptz = primitive "timestamptz" False Vocab.TypeInfo.timestamptz Binary.timestamptz_int (TextBuilder.string . show) -- | -- Encoder of @TIME@ values. {-# INLINEABLE time #-} time :: Value TimeOfDay -time = primitive "time" False Kernel.TypeInfo.time Binary.time_int (TextBuilder.string . show) +time = primitive "time" False Vocab.TypeInfo.time Binary.time_int (TextBuilder.string . show) -- | -- Encoder of @TIMETZ@ values. {-# INLINEABLE timetz #-} timetz :: Value (TimeOfDay, TimeZone) -timetz = primitive "timetz" False Kernel.TypeInfo.timetz Binary.timetz_int (TextBuilder.string . show) +timetz = primitive "timetz" False Vocab.TypeInfo.timetz Binary.timetz_int (TextBuilder.string . show) -- | -- Encoder of @INTERVAL@ values. {-# INLINEABLE interval #-} interval :: Value DiffTime -interval = primitive "interval" False Kernel.TypeInfo.interval Binary.interval_int (TextBuilder.string . show) +interval = primitive "interval" False Vocab.TypeInfo.interval Binary.interval_int (TextBuilder.string . show) -- | -- Encoder of @UUID@ values. {-# INLINEABLE uuid #-} uuid :: Value UUID -uuid = primitive "uuid" False Kernel.TypeInfo.uuid Binary.uuid (TextBuilder.string . show) +uuid = primitive "uuid" False Vocab.TypeInfo.uuid Binary.uuid (TextBuilder.string . show) -- | -- Encoder of @INET@ values. {-# INLINEABLE inet #-} inet :: Value Iproute.IPRange -inet = primitive "inet" False Kernel.TypeInfo.inet Binary.inet (TextBuilder.string . show) +inet = primitive "inet" False Vocab.TypeInfo.inet Binary.inet (TextBuilder.string . show) -- | -- Encoder of @MACADDR@ values. @@ -191,127 +191,127 @@ -- > toOctets >$< macaddr {-# INLINEABLE macaddr #-} macaddr :: Value (Word8, Word8, Word8, Word8, Word8, Word8) -macaddr = primitive "macaddr" False Kernel.TypeInfo.macaddr Binary.macaddr (TextBuilder.string . show) +macaddr = primitive "macaddr" False Vocab.TypeInfo.macaddr Binary.macaddr (TextBuilder.string . show) -- | -- Encoder of @JSON@ values from JSON AST. {-# INLINEABLE json #-} json :: Value Aeson.Value -json = primitive "json" False Kernel.TypeInfo.json Binary.json_ast (TextBuilder.string . show) +json = primitive "json" False Vocab.TypeInfo.json Binary.json_ast (TextBuilder.string . show) -- | -- Encoder of @JSON@ values from raw JSON. {-# INLINEABLE jsonBytes #-} jsonBytes :: Value ByteString -jsonBytes = primitive "json" False Kernel.TypeInfo.json Binary.json_bytes (TextBuilder.string . show) +jsonBytes = primitive "json" False Vocab.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 Kernel.TypeInfo.json Binary.json_bytes_lazy (TextBuilder.string . show) +jsonLazyBytes = primitive "json" False Vocab.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 Kernel.TypeInfo.jsonb Binary.jsonb_ast (TextBuilder.string . show) +jsonb = primitive "jsonb" False Vocab.TypeInfo.jsonb Binary.jsonb_ast (TextBuilder.string . show) -- | -- Encoder of @JSONB@ values from raw JSON. {-# INLINEABLE jsonbBytes #-} jsonbBytes :: Value ByteString -jsonbBytes = primitive "jsonb" False Kernel.TypeInfo.jsonb Binary.jsonb_bytes (TextBuilder.string . show) +jsonbBytes = primitive "jsonb" False Vocab.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 Kernel.TypeInfo.jsonb Binary.jsonb_bytes_lazy (TextBuilder.string . show) +jsonbLazyBytes = primitive "jsonb" False Vocab.TypeInfo.jsonb Binary.jsonb_bytes_lazy (TextBuilder.string . show) -- | -- Encoder of @OID@ values. {-# INLINEABLE oid #-} oid :: Value Int32 -oid = primitive "oid" False Kernel.TypeInfo.oid Binary.int4_int32 (TextBuilder.string . show) +oid = primitive "oid" False Vocab.TypeInfo.oid Binary.int4_int32 (TextBuilder.string . show) -- | -- Encoder of @NAME@ values. {-# INLINEABLE name #-} name :: Value Text -name = primitive "name" False Kernel.TypeInfo.name Binary.text_strict (TextBuilder.string . show) +name = primitive "name" False Vocab.TypeInfo.name Binary.text_strict (TextBuilder.string . show) -- | -- Encoder of @INT4RANGE@ values. {-# INLINEABLE int4range #-} int4range :: Value (Range.Range Int32) -int4range = primitive "int4range" False Kernel.TypeInfo.int4range Binary.int4range (TextBuilder.string . show) +int4range = primitive "int4range" False Vocab.TypeInfo.int4range Binary.int4range (TextBuilder.string . show) -- | -- Encoder of @INT8RANGE@ values. {-# INLINEABLE int8range #-} int8range :: Value (Range.Range Int64) -int8range = primitive "int8range" False Kernel.TypeInfo.int8range Binary.int8range (TextBuilder.string . show) +int8range = primitive "int8range" False Vocab.TypeInfo.int8range Binary.int8range (TextBuilder.string . show) -- | -- Encoder of @NUMRANGE@ values. {-# INLINEABLE numrange #-} numrange :: Value (Range.Range Scientific) -numrange = primitive "numrange" False Kernel.TypeInfo.numrange Binary.numrange (TextBuilder.string . show) +numrange = primitive "numrange" False Vocab.TypeInfo.numrange Binary.numrange (TextBuilder.string . show) -- | -- Encoder of @TSRANGE@ values. {-# INLINEABLE tsrange #-} tsrange :: Value (Range.Range LocalTime) -tsrange = primitive "tsrange" False Kernel.TypeInfo.tsrange Binary.tsrange_int (TextBuilder.string . show) +tsrange = primitive "tsrange" False Vocab.TypeInfo.tsrange Binary.tsrange_int (TextBuilder.string . show) -- | -- Encoder of @TSTZRANGE@ values. {-# INLINEABLE tstzrange #-} tstzrange :: Value (Range.Range UTCTime) -tstzrange = primitive "tstzrange" False Kernel.TypeInfo.tstzrange Binary.tstzrange_int (TextBuilder.string . show) +tstzrange = primitive "tstzrange" False Vocab.TypeInfo.tstzrange Binary.tstzrange_int (TextBuilder.string . show) -- | -- Encoder of @DATERANGE@ values. {-# INLINEABLE daterange #-} daterange :: Value (Range.Range Day) -daterange = primitive "daterange" False Kernel.TypeInfo.daterange Binary.daterange (TextBuilder.string . show) +daterange = primitive "daterange" False Vocab.TypeInfo.daterange Binary.daterange (TextBuilder.string . show) -- | -- Encoder of @INT4MULTIRANGE@ values. {-# INLINEABLE int4multirange #-} int4multirange :: Value (Range.Multirange Int32) -int4multirange = primitive "int4multirange" False Kernel.TypeInfo.int4multirange Binary.int4multirange (TextBuilder.string . show) +int4multirange = primitive "int4multirange" False Vocab.TypeInfo.int4multirange Binary.int4multirange (TextBuilder.string . show) -- | -- Encoder of @INT8MULTIRANGE@ values. {-# INLINEABLE int8multirange #-} int8multirange :: Value (Range.Multirange Int64) -int8multirange = primitive "int8multirange" False Kernel.TypeInfo.int8multirange Binary.int8multirange (TextBuilder.string . show) +int8multirange = primitive "int8multirange" False Vocab.TypeInfo.int8multirange Binary.int8multirange (TextBuilder.string . show) -- | -- Encoder of @NUMMULTIRANGE@ values. {-# INLINEABLE nummultirange #-} nummultirange :: Value (Range.Multirange Scientific) -nummultirange = primitive "nummultirange" False Kernel.TypeInfo.nummultirange Binary.nummultirange (TextBuilder.string . show) +nummultirange = primitive "nummultirange" False Vocab.TypeInfo.nummultirange Binary.nummultirange (TextBuilder.string . show) -- | -- Encoder of @TSMULTIRANGE@ values. {-# INLINEABLE tsmultirange #-} tsmultirange :: Value (Range.Multirange LocalTime) -tsmultirange = primitive "tsmultirange" False Kernel.TypeInfo.tsmultirange Binary.tsmultirange_int (TextBuilder.string . show) +tsmultirange = primitive "tsmultirange" False Vocab.TypeInfo.tsmultirange Binary.tsmultirange_int (TextBuilder.string . show) -- | -- Encoder of @TSTZMULTIRANGE@ values. {-# INLINEABLE tstzmultirange #-} tstzmultirange :: Value (Range.Multirange UTCTime) -tstzmultirange = primitive "tstzmultirange" False Kernel.TypeInfo.tstzmultirange Binary.tstzmultirange_int (TextBuilder.string . show) +tstzmultirange = primitive "tstzmultirange" False Vocab.TypeInfo.tstzmultirange Binary.tstzmultirange_int (TextBuilder.string . show) -- | -- Encoder of @DATEMULTIRANGE@ values. {-# INLINEABLE datemultirange #-} datemultirange :: Value (Range.Multirange Day) -datemultirange = primitive "datemultirange" False Kernel.TypeInfo.datemultirange Binary.datemultirange (TextBuilder.string . show) +datemultirange = primitive "datemultirange" False Vocab.TypeInfo.datemultirange Binary.datemultirange (TextBuilder.string . show) -- | -- Encoder of @CITEXT@ values. @@ -351,7 +351,7 @@ Nothing 0 False - (HashSet.singleton (Kernel.QualifiedTypeName.QualifiedTypeName schemaName typeName)) + (HashSet.singleton (Vocab.QualifiedTypeName.QualifiedTypeName schemaName typeName)) (const (Binary.text_strict . mapping)) (TextBuilder.text . mapping) @@ -369,7 +369,7 @@ {-# DEPRECATED unknown "Use 'custom' instead." #-} {-# INLINEABLE unknown #-} unknown :: Value ByteString -unknown = primitive "unknown" True Kernel.TypeInfo.unknown Binary.bytea_strict (TextBuilder.string . show) +unknown = primitive "unknown" True Vocab.TypeInfo.unknown Binary.bytea_strict (TextBuilder.string . show) -- | -- Low level API for defining custom value encoders. @@ -382,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 Kernel.TypeInfo.TypeInfo -> + Maybe (Word32, Word32) -> -- | Other named types whose OIDs are needed for serializing. -- -- E.g., when encoding composite types Postgres requires specifying OIDs of all of its fields. @@ -393,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) -> Kernel.TypeInfo.TypeInfo) -> + ( ((Maybe Text, Text) -> (Word32, Word32)) -> a -> ByteString ) -> @@ -404,13 +404,19 @@ Value schemaName typeName - (fmap Kernel.TypeInfo.toBaseOid staticOids) - (fmap Kernel.TypeInfo.toArrayOid staticOids) + (fmap fst staticOids) + (fmap snd staticOids) 0 False - (HashSet.fromList (fmap Kernel.QualifiedTypeName.fromNameTuple requiredTypes)) + (HashSet.fromList (fmap Vocab.QualifiedTypeName.fromNameTuple requiredTypes)) ( \hashMap -> - ByteString.StrictBuilder.bytes . encode (\name -> fromMaybe (Kernel.TypeInfo.TypeInfo 0 0) (HashMap.lookup (Kernel.QualifiedTypeName.fromNameTuple name) hashMap)) + ByteString.StrictBuilder.bytes + . encode + ( \name -> + fromMaybe (0, 0) + $ HashMap.lookup (Vocab.QualifiedTypeName.fromNameTuple name) hashMap + <&> \typeInfo -> (Vocab.TypeInfo.toBaseOid typeInfo, Vocab.TypeInfo.toArrayOid typeInfo) + ) ) (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 @@ -11,38 +11,38 @@ ) where -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.Codecs.Vocab qualified as Vocab +import Hasql.Codecs.Vocab.OidCache qualified as Vocab.OidCache +import Hasql.Codecs.Vocab.TypeInfo qualified as Vocab.TypeInfo import Hasql.Platform.Prelude hiding (lift, lookup) type RequestingOid = LookingUp.LookingUp - Kernel.QualifiedTypeName - Kernel.TypeInfo.TypeInfo + Vocab.QualifiedTypeName + Vocab.TypeInfo.TypeInfo {-# INLINE toUnknownTypes #-} toUnknownTypes :: RequestingOid a -> - HashSet Kernel.QualifiedTypeName + HashSet Vocab.QualifiedTypeName toUnknownTypes (LookingUp.LookingUp unknownTypes _) = fromList unknownTypes {-# INLINE toBase #-} toBase :: RequestingOid a -> - HashMap Kernel.QualifiedTypeName Kernel.TypeInfo.TypeInfo -> + Vocab.OidCache -> a toBase (LookingUp.LookingUp _unknownTypes decoder) oidCache = decoder \key -> - HashMap.lookup key oidCache - & fromMaybe (Kernel.TypeInfo.TypeInfo 0 0) + Vocab.OidCache.lookupTypeInfo key oidCache + & fromMaybe (Vocab.TypeInfo.TypeInfo 0 0) {-# INLINE requestAndHandle #-} requestAndHandle :: - [Kernel.QualifiedTypeName] -> - ((Kernel.QualifiedTypeName -> Kernel.TypeInfo.TypeInfo) -> a) -> + [Vocab.QualifiedTypeName] -> + ((Vocab.QualifiedTypeName -> Vocab.TypeInfo.TypeInfo) -> a) -> RequestingOid a requestAndHandle keys fn = LookingUp.LookingUp keys fn @@ -55,13 +55,13 @@ hoist fn (LookingUp.LookingUp keys use) = LookingUp.LookingUp keys (fn . use) {-# INLINE lookup #-} -lookup :: Kernel.QualifiedTypeName -> RequestingOid Kernel.TypeInfo.TypeInfo +lookup :: Vocab.QualifiedTypeName -> RequestingOid Vocab.TypeInfo.TypeInfo lookup = LookingUp.lookup {-# INLINE lookingUp #-} -lookingUp :: Kernel.QualifiedTypeName -> (Kernel.TypeInfo.TypeInfo -> a) -> RequestingOid a +lookingUp :: Vocab.QualifiedTypeName -> (Vocab.TypeInfo.TypeInfo -> a) -> RequestingOid a lookingUp = LookingUp.lookingUp {-# INLINE hoistLookingUp #-} -hoistLookingUp :: Kernel.QualifiedTypeName -> (Kernel.TypeInfo.TypeInfo -> a -> b) -> RequestingOid a -> RequestingOid b +hoistLookingUp :: Vocab.QualifiedTypeName -> (Vocab.TypeInfo.TypeInfo -> a -> b) -> RequestingOid a -> RequestingOid b hoistLookingUp = LookingUp.hoistLookingUp diff --git a/src/library/Hasql/Codecs/Vocab.hs b/src/library/Hasql/Codecs/Vocab.hs new file mode 100644 --- /dev/null +++ b/src/library/Hasql/Codecs/Vocab.hs @@ -0,0 +1,14 @@ +module Hasql.Codecs.Vocab + ( QualifiedTypeName, + TypeInfo, + TypeRef, + ParamMeta, + OidCache, + ) +where + +import Hasql.Codecs.Vocab.OidCache (OidCache) +import Hasql.Codecs.Vocab.ParamMeta (ParamMeta) +import Hasql.Codecs.Vocab.QualifiedTypeName (QualifiedTypeName) +import Hasql.Codecs.Vocab.TypeInfo (TypeInfo) +import Hasql.Codecs.Vocab.TypeRef (TypeRef) diff --git a/src/library/Hasql/Codecs/Vocab/OidCache.hs b/src/library/Hasql/Codecs/Vocab/OidCache.hs new file mode 100644 --- /dev/null +++ b/src/library/Hasql/Codecs/Vocab/OidCache.hs @@ -0,0 +1,91 @@ +module Hasql.Codecs.Vocab.OidCache + ( OidCache, + + -- * Accessors + toHashMap, + lookupScalar, + lookupArray, + lookupTypeNameScalar, + lookupTypeNameArray, + lookupTypeInfo, + + -- * Constructors + fromHashMap, + empty, + selectUnknownNames, + insertScalar, + ) +where + +import Data.HashMap.Strict qualified as HashMap +import Data.HashSet qualified as HashSet +import Hasql.Codecs.Vocab.QualifiedTypeName (QualifiedTypeName) +import Hasql.Codecs.Vocab.QualifiedTypeName qualified as QualifiedTypeName +import Hasql.Codecs.Vocab.TypeInfo qualified as TypeInfo +import Hasql.Platform.Prelude hiding (empty, insert, lookup, reset) + +-- | Pure registry state containing the hash map and counter +newtype OidCache + = OidCache + -- | By name of the type. + -- + -- > scalar name -> TypeInfo (scalar OID, array OID) + (HashMap QualifiedTypeName TypeInfo.TypeInfo) + deriving stock (Show, Eq) + +instance Semigroup OidCache where + OidCache byNameL <> OidCache byNameR = + OidCache (HashMap.union byNameR byNameL) + +instance Monoid OidCache where + mempty = OidCache mempty + +{-# INLINEABLE empty #-} +empty :: OidCache +empty = + OidCache HashMap.empty + +-- | Having a set of required type names, select those that are not present in the cache. +{-# INLINE selectUnknownNames #-} +selectUnknownNames :: HashSet QualifiedTypeName -> OidCache -> HashSet 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 (QualifiedTypeName.QualifiedTypeName schema name) (TypeInfo.TypeInfo scalar array) byName) + +{-# INLINE fromHashMap #-} +fromHashMap :: HashMap QualifiedTypeName TypeInfo.TypeInfo -> OidCache +fromHashMap byName = OidCache byName + +-- * Accessors + +{-# INLINE lookupScalar #-} +lookupScalar :: Maybe Text -> Text -> OidCache -> Maybe Word32 +lookupScalar schema name (OidCache byName) = + HashMap.lookup (QualifiedTypeName.QualifiedTypeName schema name) byName <&> \info -> TypeInfo.toBaseOid info + +{-# INLINE lookupArray #-} +lookupArray :: Maybe Text -> Text -> OidCache -> Maybe Word32 +lookupArray schema name (OidCache byName) = + HashMap.lookup (QualifiedTypeName.QualifiedTypeName schema name) byName <&> \info -> TypeInfo.toArrayOid info + +{-# INLINE lookupTypeNameScalar #-} +lookupTypeNameScalar :: QualifiedTypeName -> OidCache -> Maybe Word32 +lookupTypeNameScalar name (OidCache byName) = + HashMap.lookup name byName <&> TypeInfo.toBaseOid + +{-# INLINE lookupTypeNameArray #-} +lookupTypeNameArray :: QualifiedTypeName -> OidCache -> Maybe Word32 +lookupTypeNameArray name (OidCache byName) = + HashMap.lookup name byName <&> TypeInfo.toArrayOid + +{-# INLINE lookupTypeInfo #-} +lookupTypeInfo :: QualifiedTypeName -> OidCache -> Maybe TypeInfo.TypeInfo +lookupTypeInfo name (OidCache byName) = + HashMap.lookup name byName + +{-# INLINE toHashMap #-} +toHashMap :: OidCache -> HashMap QualifiedTypeName TypeInfo.TypeInfo +toHashMap (OidCache byName) = byName diff --git a/src/library/Hasql/Codecs/Vocab/ParamMeta.hs b/src/library/Hasql/Codecs/Vocab/ParamMeta.hs new file mode 100644 --- /dev/null +++ b/src/library/Hasql/Codecs/Vocab/ParamMeta.hs @@ -0,0 +1,13 @@ +module Hasql.Codecs.Vocab.ParamMeta + ( ParamMeta (..), + ) +where + +import Hasql.Codecs.Vocab.TypeRef (TypeRef) +import Hasql.Platform.Prelude + +-- | Per-parameter metadata: type reference, array dimensionality, text-format flag. +data ParamMeta = ParamMeta TypeRef Word Bool + deriving stock (Eq, Ord, Show, Generic) + +instance Hashable ParamMeta diff --git a/src/library/Hasql/Codecs/Vocab/QualifiedTypeName.hs b/src/library/Hasql/Codecs/Vocab/QualifiedTypeName.hs new file mode 100644 --- /dev/null +++ b/src/library/Hasql/Codecs/Vocab/QualifiedTypeName.hs @@ -0,0 +1,43 @@ +module Hasql.Codecs.Vocab.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/Codecs/Vocab/TypeInfo.hs b/src/library/Hasql/Codecs/Vocab/TypeInfo.hs new file mode 100644 --- /dev/null +++ b/src/library/Hasql/Codecs/Vocab/TypeInfo.hs @@ -0,0 +1,230 @@ +module Hasql.Codecs.Vocab.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/Codecs/Vocab/TypeRef.hs b/src/library/Hasql/Codecs/Vocab/TypeRef.hs new file mode 100644 --- /dev/null +++ b/src/library/Hasql/Codecs/Vocab/TypeRef.hs @@ -0,0 +1,20 @@ +module Hasql.Codecs.Vocab.TypeRef + ( TypeRef (..), + ) +where + +import Hasql.Codecs.Vocab.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/Decoders.hs b/src/library/Hasql/Decoders.hs --- a/src/library/Hasql/Decoders.hs +++ b/src/library/Hasql/Decoders.hs @@ -83,13 +83,9 @@ -- * 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,11 +74,7 @@ -- * 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 @@ -7,17 +7,15 @@ import Data.HashMap.Strict qualified as HashMap import Data.HashSet qualified as HashSet -import Hasql.Codecs.Encoders.Params qualified as Params import Hasql.Codecs.RequestingOid qualified as RequestingOid +import Hasql.Codecs.Vocab qualified as Vocab +import Hasql.Codecs.Vocab.OidCache qualified as OidCache +import Hasql.Codecs.Vocab.QualifiedTypeName qualified as Vocab.QualifiedTypeName import Hasql.Comms.Roundtrip qualified as Comms.Roundtrip -import Hasql.Engine.Decoders.Result qualified as Decoders.Result import Hasql.Engine.Errors qualified as Errors import Hasql.Engine.PqProcedures.SelectTypeInfo qualified as PqProcedures.SelectTypeInfo -import Hasql.Engine.Structures.OidCache qualified as OidCache +import Hasql.Engine.Statement qualified as Statement 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 @@ -46,13 +44,13 @@ 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)) + then Left (Errors.MissingTypesSessionError (HashSet.map Vocab.QualifiedTypeName.toNameTuple notFoundTypes)) else Right (oidCache <> OidCache.fromHashMap oidCacheUpdates) case resolvedOidCache of Left err -> pure (Left err, oidCache, statementCache) Right newOidCache -> do let (roundtrip, newStatementCache) = - runPipeline 0 usePreparedStatements (OidCache.toHashMap newOidCache) statementCache + runPipeline 0 usePreparedStatements newOidCache statementCache contextualRoundtrip = first Just roundtrip executionResult <- Comms.Roundtrip.toPipelineIO contextualRoundtrip Nothing connection @@ -147,7 +145,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 Kernel.QualifiedTypeName) + (HashSet Vocab.QualifiedTypeName) -- | Function that runs the pipeline. -- -- The integer parameter indicates the current offset of the statement in the pipeline (0-based). @@ -164,7 +162,7 @@ -- committed cache from statement contexts carried by roundtrip errors. ( Int -> Bool -> - HashMap Kernel.QualifiedTypeName Kernel.TypeInfo.TypeInfo -> + OidCache.OidCache -> StatementCache.StatementCache -> (Comms.Roundtrip.Roundtrip Context a, StatementCache.StatementCache) ) @@ -207,37 +205,32 @@ -- | -- Execute a statement in pipelining mode. statement :: - ByteString -> - Params.Params params -> - Decoders.Result.Result result -> - Bool -> + Statement.Statement params result -> params -> Pipeline result -statement sql encoder (Decoders.Result.unwrap -> decoder) preparable params = - Pipeline 1 unknownTypes run +statement stmt params = + Pipeline 1 (Statement.unknownTypes stmt) run where - unknownTypes = - Params.toUnknownTypes encoder - <> RequestingOid.toUnknownTypes decoder + sql = Statement.sql stmt run offset usePreparedStatements oidCache = if prepare then runPrepared else runUnprepared where (oidList, valueAndFormatList) = - Params.compilePreparedStatementData encoder oidCache params + Statement.compilePreparedStatementData stmt oidCache params pqOidList = fmap (Pq.Oid . fromIntegral) oidList prepare = - usePreparedStatements && preparable + usePreparedStatements && Statement.isPrepared stmt context soFarStatementCache = Context offset sql - (Params.renderReadable encoder params) + (Statement.printer stmt params) prepare soFarStatementCache @@ -268,9 +261,8 @@ Comms.Roundtrip.queryParams (context statementCache) sql encodedParams Pq.Binary decoder' where encodedParams = - params - & Params.compileUnpreparedStatementData encoder oidCache + Statement.compileUnpreparedStatementData stmt oidCache params & fmap (fmap (\(oid, bytes, format) -> (Pq.Oid (fromIntegral oid), bytes, bool Pq.Binary Pq.Text format))) decoder' = - RequestingOid.toBase decoder oidCache + RequestingOid.toBase (Statement.decoder stmt) oidCache 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 @@ -2,17 +2,16 @@ import Data.HashMap.Strict qualified as HashMap import Data.HashSet qualified as HashSet -import Hasql.Codecs.Encoders.Params qualified as Params import Hasql.Codecs.RequestingOid qualified as RequestingOid +import Hasql.Codecs.Vocab.OidCache qualified as OidCache +import Hasql.Codecs.Vocab.QualifiedTypeName qualified as Vocab.QualifiedTypeName import Hasql.Comms.Roundtrip qualified as Comms.Roundtrip import Hasql.Engine.Contexts.Pipeline qualified as Pipeline -import Hasql.Engine.Decoders.Result qualified as Decoders.Result import Hasql.Engine.Errors qualified as Errors import Hasql.Engine.PqProcedures.SelectTypeInfo qualified as PqProcedures.SelectTypeInfo +import Hasql.Engine.Statement qualified as Statement 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 @@ -78,23 +77,17 @@ -- -- To batch multiple statements into fewer roundtrips, use 'pipeline' instead. statement :: - ByteString -> - Params.Params params -> - Decoders.Result.Result result -> - Bool -> + Statement.Statement params result -> params -> Session result -statement sql paramsEncoder decoder preparable params = +statement stmt params = Session \connectionState -> do let usePreparedStatements = ConnectionState.preparedStatements connectionState statementCache = ConnectionState.statementCache connectionState oidCache = ConnectionState.oidCache connectionState connection = ConnectionState.connection connectionState - requestingDecoder = Decoders.Result.unwrap decoder - unknownTypes = - Params.toUnknownTypes paramsEncoder - <> RequestingOid.toUnknownTypes requestingDecoder - missingTypes = OidCache.selectUnknownNames unknownTypes oidCache + sql = Statement.sql stmt + missingTypes = OidCache.selectUnknownNames (Statement.unknownTypes stmt) oidCache resolvedOidCache <- if HashSet.null missingTypes then pure (Right oidCache) @@ -107,17 +100,16 @@ 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)) + then Left (Errors.MissingTypesSessionError (HashSet.map Vocab.QualifiedTypeName.toNameTuple notFoundTypes)) else Right (oidCache <> OidCache.fromHashMap oidCacheUpdates) case resolvedOidCache of Left err -> pure (Left err, connectionState) Right newOidCache -> do - let oidHashMap = OidCache.toHashMap newOidCache - decoder' = RequestingOid.toBase requestingDecoder oidHashMap - prepared = usePreparedStatements && preparable + let decoder' = RequestingOid.toBase (Statement.decoder stmt) newOidCache + prepared = usePreparedStatements && Statement.isPrepared stmt -- Single-statement context for error reporting: -- total statements 1, index 0. - context = Just (1, 0, sql, Params.renderReadable paramsEncoder params, prepared) + context = Just (1, 0, sql, Statement.printer stmt params, prepared) mapError = \case Comms.Roundtrip.ClientError _ details -> Errors.ConnectionSessionError (maybe "" decodeUtf8Lenient details) @@ -134,7 +126,7 @@ $ if prepared then do let (oidList, valueAndFormatList) = - Params.compilePreparedStatementData paramsEncoder oidHashMap params + Statement.compilePreparedStatementData stmt newOidCache params pqOidList = fmap (Pq.Oid . fromIntegral) oidList encodedParams = valueAndFormatList @@ -168,8 +160,7 @@ pure (result, newStatementCache) else do let encodedParams = - params - & Params.compileUnpreparedStatementData paramsEncoder oidHashMap + Statement.compileUnpreparedStatementData stmt newOidCache params & fmap (fmap (\(oid, bytes, format) -> (Pq.Oid (fromIntegral oid), bytes, bool Pq.Binary Pq.Text format))) result <- Comms.Roundtrip.toSerialIO 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 @@ -3,9 +3,9 @@ import Hasql.Codecs.Decoders import Hasql.Codecs.Decoders.Value qualified as Value import Hasql.Codecs.RequestingOid qualified as RequestingOid +import Hasql.Codecs.Vocab.QualifiedTypeName qualified as Vocab.QualifiedTypeName +import Hasql.Codecs.Vocab.TypeInfo qualified as Vocab.TypeInfo 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 @@ -42,7 +42,7 @@ (Value.toDecoder valueDecoder) Nothing -> do RequestingOid.hoistLookingUp - (Kernel.QualifiedTypeName.QualifiedTypeName (Value.toSchema valueDecoder) (Value.toTypeName valueDecoder)) + (Vocab.QualifiedTypeName.QualifiedTypeName (Value.toSchema valueDecoder) (Value.toTypeName valueDecoder)) ( \lookupResult decoder -> Hasql.Comms.RowDecoder.nullableColumn (Just (chooseLookedUpOid valueDecoder lookupResult)) (Binary.valueParser decoder) ) @@ -55,11 +55,11 @@ (Value.toDecoder valueDecoder) Nothing -> do RequestingOid.hoistLookingUp - (Kernel.QualifiedTypeName.QualifiedTypeName (Value.toSchema valueDecoder) (Value.toTypeName valueDecoder)) + (Vocab.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 typeInfo = if Value.toDimensionality valueDecoder > 0 - then Kernel.TypeInfo.toArrayOid typeInfo - else Kernel.TypeInfo.toBaseOid typeInfo + then Vocab.TypeInfo.toArrayOid typeInfo + else Vocab.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 @@ -8,26 +8,25 @@ import Data.HashMap.Strict qualified as HashMap import Data.HashSet qualified as HashSet import Hasql.Codecs.Decoders.Value qualified as Decoders.Value -import Hasql.Codecs.Encoders qualified as Encoders -import Hasql.Codecs.Encoders.Params qualified as Encoders.Params +import Hasql.Codecs.Vocab qualified as Vocab +import Hasql.Codecs.Vocab.QualifiedTypeName qualified as Vocab.QualifiedTypeName +import Hasql.Codecs.Vocab.TypeInfo qualified as Vocab.TypeInfo import Hasql.Comms.ResultDecoder qualified 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 +import PostgreSQL.Binary.Encoding qualified as Binary newtype SelectTypeInfo = SelectTypeInfo { -- | Set of (schema name, type name) pairs to look up. - keys :: HashSet Kernel.QualifiedTypeName + keys :: HashSet Vocab.QualifiedTypeName } -- | Result maps (schema name, type name) pairs to TypeInfo (scalar OID, array OID). type SelectTypeInfoResult = - HashMap Kernel.QualifiedTypeName Kernel.TypeInfo.TypeInfo + HashMap Vocab.QualifiedTypeName Vocab.TypeInfo.TypeInfo run :: Pq.Connection -> SelectTypeInfo -> IO (Either Errors.SessionError SelectTypeInfoResult) run connection (SelectTypeInfo keys) = @@ -75,33 +74,30 @@ roundtrip params = Hasql.Comms.Roundtrip.queryParams () sql (encodeParams params) Pq.Binary decoder +-- | Encode the two text-array parameters directly. +-- Text OID is 25; text-array OID is 1009. encodeParams :: SelectTypeInfo -> [Maybe (Pq.Oid, ByteString, Pq.Format)] -encodeParams = - fmap - ( fmap - ( \(oid, bytes, format) -> - ( Pq.Oid (fromIntegral oid), - bytes, - bool Pq.Binary Pq.Text format - ) - ) - ) - . Encoders.Params.compileUnpreparedStatementData paramsEncoder mempty - -paramsEncoder :: Encoders.Params SelectTypeInfo -paramsEncoder = - (\(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))) +encodeParams (SelectTypeInfo keys) = + let (schemaNames, typeNames) = unzip (fmap Vocab.QualifiedTypeName.toNameTuple (HashSet.toList keys)) + schemaArray = Binary.encodingBytes (Binary.array 25 (encodeTextArray (encodeMaybeText schemaNames))) + typeArray = Binary.encodingBytes (Binary.array 25 (encodeTextArray (fmap (Binary.encodingArray . Binary.text_strict) typeNames))) + in [ Just (Pq.Oid 1009, schemaArray, Pq.Binary), + Just (Pq.Oid 1009, typeArray, Pq.Binary) ] + where + encodeTextArray elements = + Binary.dimensionArray foldl' id elements + encodeMaybeText = + fmap \case + Nothing -> Binary.nullArray + Just text -> Binary.encodingArray (Binary.text_strict text) decoder :: Hasql.Comms.ResultDecoder.ResultDecoder SelectTypeInfoResult decoder = Hasql.Comms.ResultDecoder.foldl step HashMap.empty rowDecoder where step acc (schemaName, typeName, typeOid, arrayOid) = - HashMap.insert (Kernel.QualifiedTypeName.QualifiedTypeName schemaName typeName) (Kernel.TypeInfo.TypeInfo typeOid arrayOid) acc + HashMap.insert (Vocab.QualifiedTypeName.QualifiedTypeName schemaName typeName) (Vocab.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 @@ -4,13 +4,23 @@ unpreparable, refineResult, toSql, + compilePreparedStatementData, + compileUnpreparedStatementData, ) where import Data.Text.Encoding qualified as TextEncoding +import Data.Vector qualified as Vector +import Hasql.Codecs.Encoders.Params qualified as Params +import Hasql.Codecs.RequestingOid qualified as RequestingOid +import Hasql.Codecs.Vocab qualified as Vocab +import Hasql.Codecs.Vocab.OidCache qualified as Vocab.OidCache +import Hasql.Codecs.Vocab.ParamMeta (ParamMeta (..)) +import Hasql.Codecs.Vocab.TypeRef qualified as Vocab.TypeRef +import Hasql.Comms.ResultDecoder qualified as ResultDecoder import Hasql.Decoders qualified as Decoders import Hasql.Encoders qualified as Encoders -import Hasql.Engine.Decoders.Result qualified +import Hasql.Engine.Decoders.Result qualified as Decoders.Result import Hasql.Platform.Prelude -- | @@ -37,23 +47,22 @@ -- and produces a single result of type 'Int64'. data Statement params result = Statement - -- | 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. - ByteString - -- | Parameters encoder. - (Encoders.Params params) - -- | Decoder of result. - (Decoders.Result result) - -- | Flag, determining whether it can be prepared. - -- - -- Set it to 'True' if your application has a limited amount of queries and doesn't generate the SQL dynamically. - -- This will boost the performance by allowing Postgres to avoid reconstructing the execution plan each time the query gets executed. - Bool + { -- | SQL template pre-encoded as UTF-8 for execution. + sql :: ByteString, + -- | Frozen per-parameter metadata: type reference, dimensionality, text-format flag. + -- Produced once at construction from the Params DList and reused across executions. + columnsMetadata :: Vector ParamMeta, + -- | Serialise params to encoded wire values given a resolved OID cache. + serializer :: Vocab.OidCache -> params -> [Maybe ByteString], + -- | Render params in human-readable form (for error reporting). + printer :: params -> [Text], + -- | Union of encoder and decoder unknown types, resolved once at construction. + unknownTypes :: HashSet Vocab.QualifiedTypeName, + -- | Unwrapped result decoder (RequestingOid layer already peeled from Result). + decoder :: RequestingOid.RequestingOid (ResultDecoder.ResultDecoder result), + -- | Whether this statement may be prepared on the server. + isPrepared :: Bool + } -- | -- Construct a preparable statement. @@ -70,7 +79,18 @@ -- | Result decoder Decoders.Result result -> Statement params result -preparable sql encoder decoder = Statement (TextEncoding.encodeUtf8 sql) encoder decoder True +preparable sqlText encoder resultDecoder = + Statement + { sql = TextEncoding.encodeUtf8 sqlText, + columnsMetadata = Params.toColumnsMetadata encoder, + serializer = Params.toSerializer encoder, + printer = Params.toPrinter encoder, + unknownTypes = Params.toUnknownTypes encoder <> RequestingOid.toUnknownTypes rawDecoder, + decoder = rawDecoder, + isPrepared = True + } + where + rawDecoder = Decoders.Result.unwrap resultDecoder -- | -- Construct an unpreparable statement. @@ -87,21 +107,35 @@ -- | Result decoder Decoders.Result result -> Statement params result -unpreparable sql encoder decoder = Statement (TextEncoding.encodeUtf8 sql) encoder decoder False +unpreparable sqlText encoder resultDecoder = + Statement + { sql = TextEncoding.encodeUtf8 sqlText, + columnsMetadata = Params.toColumnsMetadata encoder, + serializer = Params.toSerializer encoder, + printer = Params.toPrinter encoder, + unknownTypes = Params.toUnknownTypes encoder <> RequestingOid.toUnknownTypes rawDecoder, + decoder = rawDecoder, + isPrepared = False + } + where + rawDecoder = Decoders.Result.unwrap resultDecoder instance Functor (Statement params) where {-# INLINE fmap #-} - fmap = rmap + fmap f stmt = stmt {decoder = fmap (fmap f) (decoder stmt)} instance Filterable (Statement params) where {-# INLINE mapMaybe #-} - mapMaybe filtrator (Statement template encoder decoder preparable) = - Statement template encoder (mapMaybe filtrator decoder) preparable + mapMaybe filtrator stmt = stmt {decoder = fmap (mapMaybe filtrator) (decoder stmt)} instance Profunctor Statement where {-# INLINE dimap #-} - dimap f1 f2 (Statement template encoder decoder preparable) = - Statement template (contramap f1 encoder) (fmap f2 decoder) preparable + dimap f1 f2 stmt = + stmt + { serializer = \oidCache -> serializer stmt oidCache . f1, + printer = printer stmt . f1, + decoder = fmap (fmap f2) (decoder stmt) + } -- | -- Refine the result of a statement, @@ -110,9 +144,45 @@ -- This function is especially useful for refining the results of statements produced with -- . refineResult :: (a -> Either Text b) -> Statement params a -> Statement params b -refineResult refiner (Statement template encoder decoder preparable) = - Statement template encoder (Hasql.Engine.Decoders.Result.refineResult refiner decoder) preparable +refineResult refiner stmt = stmt {decoder = fmap (ResultDecoder.refine refiner) (decoder stmt)} -- | Extract the SQL template from a statement. toSql :: Statement params result -> Text -toSql (Statement sql _ _ _) = TextEncoding.decodeUtf8Lenient sql +toSql stmt = TextEncoding.decodeUtf8Lenient (sql stmt) + +-- | Compile prepared-statement data: resolve OIDs and pair encoded values with their format flags. +compilePreparedStatementData :: + Statement params result -> + Vocab.OidCache -> + params -> + ([Word32], [Maybe (ByteString, Bool)]) +compilePreparedStatementData stmt oidCache params = + unzip + $ zipWith + (\(ParamMeta typeRef dim fmt) encoding -> (resolveOid typeRef dim, fmap (,fmt) encoding)) + (Vector.toList (columnsMetadata stmt)) + (serializer stmt oidCache params) + where + resolveOid (Vocab.TypeRef.NamedType name) dim = + case Vocab.OidCache.lookupTypeNameScalar name oidCache of + Just oid -> if dim == 0 then oid else fromMaybe 0 (Vocab.OidCache.lookupTypeNameArray name oidCache) + Nothing -> 0 + resolveOid (Vocab.TypeRef.KnownOid oid) _ = oid + +-- | Compile unprepared-statement data: resolve OIDs inline with encoded values. +compileUnpreparedStatementData :: + Statement params result -> + Vocab.OidCache -> + params -> + [Maybe (Word32, ByteString, Bool)] +compileUnpreparedStatementData stmt oidCache params = + zipWith + (\(ParamMeta typeRef dim fmt) encoding -> (,,) <$> Just (resolveOid typeRef dim) <*> encoding <*> Just fmt) + (Vector.toList (columnsMetadata stmt)) + (serializer stmt oidCache params) + where + resolveOid (Vocab.TypeRef.NamedType name) dim = + case Vocab.OidCache.lookupTypeNameScalar name oidCache of + Just oid -> if dim == 0 then oid else fromMaybe 0 (Vocab.OidCache.lookupTypeNameArray name oidCache) + Nothing -> 0 + resolveOid (Vocab.TypeRef.KnownOid oid) _ = oid diff --git a/src/library/Hasql/Engine/Structures/ConnectionState.hs b/src/library/Hasql/Engine/Structures/ConnectionState.hs --- a/src/library/Hasql/Engine/Structures/ConnectionState.hs +++ b/src/library/Hasql/Engine/Structures/ConnectionState.hs @@ -15,7 +15,7 @@ ) where -import Hasql.Engine.Structures.OidCache qualified as OidCache +import Hasql.Codecs.Vocab.OidCache qualified as OidCache import Hasql.Engine.Structures.StatementCache qualified as StatementCache import Hasql.Platform.Prelude import Hasql.Pq qualified as Pq diff --git a/src/library/Hasql/Engine/Structures/OidCache.hs b/src/library/Hasql/Engine/Structures/OidCache.hs deleted file mode 100644 --- a/src/library/Hasql/Engine/Structures/OidCache.hs +++ /dev/null @@ -1,73 +0,0 @@ -module Hasql.Engine.Structures.OidCache - ( OidCache, - - -- * Accessors - toHashMap, - lookupScalar, - lookupArray, - - -- * Constructors - fromHashMap, - empty, - selectUnknownNames, - insertScalar, - ) -where - -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 -newtype OidCache - = OidCache - -- | By name of the type. - -- - -- > scalar name -> TypeInfo (scalar OID, array OID) - (HashMap Kernel.QualifiedTypeName Kernel.TypeInfo.TypeInfo) - deriving stock (Show, Eq) - -instance Semigroup OidCache where - OidCache byNameL <> OidCache byNameR = - OidCache (HashMap.union byNameR byNameL) - -instance Monoid OidCache where - mempty = OidCache mempty - -{-# INLINEABLE empty #-} -empty :: OidCache -empty = - OidCache HashMap.empty - --- | Having a set of required type names, select those that are not present in the cache. -{-# 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 (Kernel.QualifiedTypeName.QualifiedTypeName schema name) (Kernel.TypeInfo.TypeInfo scalar array) byName) - -{-# 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 (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 (Kernel.QualifiedTypeName.QualifiedTypeName schema name) byName <&> \info -> Kernel.TypeInfo.toArrayOid info - -{-# 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 deleted file mode 100644 --- a/src/library/Hasql/Kernel.hs +++ /dev/null @@ -1,10 +0,0 @@ -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 deleted file mode 100644 --- a/src/library/Hasql/Kernel/QualifiedTypeName.hs +++ /dev/null @@ -1,43 +0,0 @@ -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 deleted file mode 100644 --- a/src/library/Hasql/Kernel/TypeInfo.hs +++ /dev/null @@ -1,230 +0,0 @@ -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 deleted file mode 100644 --- a/src/library/Hasql/Kernel/TypeRef.hs +++ /dev/null @@ -1,20 +0,0 @@ -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 @@ -10,5 +10,4 @@ -- | -- 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 sql encoder decoder preparable params +statement params stmt = Pipeline.statement stmt 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 @@ -21,10 +21,4 @@ -- | -- Execute a statement by providing parameters to it. statement :: params -> Statement.Statement params result -> Session.Session result -statement params (Statement.Statement sql encoder decoder preparable) = - Session.statement - sql - encoder - decoder - preparable - params +statement params stmt = Session.statement stmt params