diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,9 @@ +# v2.0.0.3 + +## Fixes + +- Work around the bug in Cabal due to which documentation does not get generated for definitions reexported from sublibs. + # v2.0.0.2 Work around the bugs in Cabal/Haddock that cause missing documentation for two-hop reexported internal modules. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -5,9 +5,9 @@ PostgreSQL driver for Haskell, that prioritizes: -- Performance - Reliability - Flexibility +- Performance # Status 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: 2.0.0.2 +version: 2.0.0.3 category: Hasql, Database, PostgreSQL synopsis: Fast PostgreSQL driver with a flexible mapping API description: @@ -131,19 +131,44 @@ Hasql.Statement other-modules: + Hasql.Codecs.Decoders + Hasql.Codecs.Decoders.Array + Hasql.Codecs.Decoders.Composite + Hasql.Codecs.Decoders.NullableOrNot + Hasql.Codecs.Decoders.Value + Hasql.Codecs.Encoders + Hasql.Codecs.Encoders.Array + Hasql.Codecs.Encoders.Composite + Hasql.Codecs.Encoders.NullableOrNot + Hasql.Codecs.Encoders.Params + Hasql.Codecs.Encoders.Value Hasql.Connection.Config Hasql.Connection.ServerVersion + Hasql.Engine.Contexts.Pipeline + Hasql.Engine.Contexts.Session + Hasql.Engine.Decoders.Result + Hasql.Engine.Decoders.Row + Hasql.Engine.Errors + Hasql.Engine.PqProcedures.SelectTypeInfo + Hasql.Engine.Statement build-depends: - hasql:codecs, + aeson >=2 && <3, + bytestring >=0.10 && <0.13, + bytestring-strict-builder >=0.4.5.4 && <0.5, + hasql:codec-vocab, hasql:comms, - hasql:engine, + hasql:connection-state, hasql:platform, + hasql:to-be-resolved, + iproute >=1.7 && <1.8, + postgresql-binary ^>=0.15, postgresql-connection-string ^>=0.1, pqi >=1.0 && <1.2, text >=1 && <3, text-builder >=1 && <1.1, unordered-containers >=0.2 && <0.3, + vector >=0.10 && <0.14, library platform import: base @@ -173,41 +198,41 @@ vector >=0.10 && <0.14, witherable >=0.5 && <0.6, -library codecs +library to-be-resolved import: base - hs-source-dirs: src/codecs + hs-source-dirs: src/to-be-resolved exposed-modules: - Hasql.Codecs.Decoders - Hasql.Codecs.Decoders.Array - Hasql.Codecs.Decoders.Composite - Hasql.Codecs.Decoders.NullableOrNot - Hasql.Codecs.Decoders.Value - Hasql.Codecs.Encoders - Hasql.Codecs.Encoders.Array - Hasql.Codecs.Encoders.Composite - Hasql.Codecs.Encoders.NullableOrNot - Hasql.Codecs.Encoders.Params - 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.ToBeResolved build-depends: - aeson >=2 && <3, - base >=4.14 && <5, - bytestring >=0.10 && <0.13, - bytestring-strict-builder >=0.4.5.4 && <0.5, + base >=4.14 && <5 + +library codec-vocab + import: base + hs-source-dirs: src/codec-vocab + exposed-modules: + CodecVocab + CodecVocab.QualifiedTypeName + CodecVocab.TypeInfo + CodecVocab.TypeRef + CodecVocab.TypeShape + + build-depends: + hasql:platform + +library connection-state + import: base + hs-source-dirs: src/connection-state + exposed-modules: + Hasql.ConnectionState + Hasql.ConnectionState.OidCache + Hasql.ConnectionState.StatementCache + + build-depends: + hasql:codec-vocab, hasql:platform, - iproute >=1.7 && <1.8, - postgresql-binary ^>=0.15, - text-builder >=1 && <1.1, + pqi >=1.0 && <1.2, unordered-containers >=0.2 && <0.3, - vector >=0.10 && <0.14, library comms import: base @@ -228,31 +253,6 @@ pqi >=1.0 && <1.2, vector >=0.10 && <0.14, -library engine - import: base - hs-source-dirs: src/engine - exposed-modules: - Hasql.Engine.Contexts.Pipeline - Hasql.Engine.Contexts.Session - Hasql.Engine.Decoders.Result - Hasql.Engine.Decoders.Row - Hasql.Engine.Errors - Hasql.Engine.PqProcedures.SelectTypeInfo - Hasql.Engine.Statement - Hasql.Engine.Structures.ConnectionState - Hasql.Engine.Structures.StatementCache - - build-depends: - hasql:codecs, - hasql:comms, - hasql:platform, - postgresql-binary ^>=0.15, - pqi >=1.0 && <1.2, - text >=1 && <3, - text-builder >=1 && <1.1, - unordered-containers >=0.2 && <0.3, - vector >=0.10 && <0.14, - benchmark benchmarks import: executable type: exitcode-stdio-1.0 @@ -302,22 +302,22 @@ testcontainers-postgresql ^>=0.2, text-builder >=1 && <1.1, -test-suite engine-tests +test-suite connection-state-tests import: test type: exitcode-stdio-1.0 - hs-source-dirs: src/engine-tests + hs-source-dirs: src/connection-state-tests main-is: Main.hs other-modules: - Hasql.Engine.Structures.OidCacheSpec - Hasql.Engine.Structures.StatementCacheSpec + Hasql.ConnectionState.OidCacheSpec + Hasql.ConnectionState.StatementCacheSpec build-tool-depends: hspec-discover:hspec-discover ^>=2.11.12 build-depends: base >=4.14 && <5, - hasql:codecs, - hasql:engine, + hasql:codec-vocab, + hasql:connection-state, hspec ^>=2.11.12, unordered-containers >=0.2 && <0.3, diff --git a/src/codec-vocab/CodecVocab.hs b/src/codec-vocab/CodecVocab.hs new file mode 100644 --- /dev/null +++ b/src/codec-vocab/CodecVocab.hs @@ -0,0 +1,12 @@ +module CodecVocab + ( QualifiedTypeName (QualifiedTypeName), + TypeInfo (TypeInfo), + TypeRef (..), + TypeShape (TypeShape), + ) +where + +import CodecVocab.QualifiedTypeName +import CodecVocab.TypeInfo +import CodecVocab.TypeRef +import CodecVocab.TypeShape diff --git a/src/codec-vocab/CodecVocab/QualifiedTypeName.hs b/src/codec-vocab/CodecVocab/QualifiedTypeName.hs new file mode 100644 --- /dev/null +++ b/src/codec-vocab/CodecVocab/QualifiedTypeName.hs @@ -0,0 +1,43 @@ +module CodecVocab.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/codec-vocab/CodecVocab/TypeInfo.hs b/src/codec-vocab/CodecVocab/TypeInfo.hs new file mode 100644 --- /dev/null +++ b/src/codec-vocab/CodecVocab/TypeInfo.hs @@ -0,0 +1,235 @@ +module CodecVocab.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 + +-- | Postgres's actual @unknown@ type, assigned to untyped literals. Not to be confused with 'invalid'. +unknown :: TypeInfo +unknown = TypeInfo 705 705 + +-- | Sentinel for a type name that failed to resolve to a real OID. Not to be confused with 'unknown', which is a real Postgres type. +invalid :: TypeInfo +invalid = TypeInfo 0 0 + +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/codec-vocab/CodecVocab/TypeRef.hs b/src/codec-vocab/CodecVocab/TypeRef.hs new file mode 100644 --- /dev/null +++ b/src/codec-vocab/CodecVocab/TypeRef.hs @@ -0,0 +1,20 @@ +module CodecVocab.TypeRef + ( TypeRef (..), + ) +where + +import CodecVocab.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/codec-vocab/CodecVocab/TypeShape.hs b/src/codec-vocab/CodecVocab/TypeShape.hs new file mode 100644 --- /dev/null +++ b/src/codec-vocab/CodecVocab/TypeShape.hs @@ -0,0 +1,13 @@ +module CodecVocab.TypeShape + ( TypeShape (..), + ) +where + +import CodecVocab.TypeRef (TypeRef) +import Hasql.Platform.Prelude + +-- | A value's type shape: type reference, array dimensionality, text-format flag. +data TypeShape = TypeShape TypeRef Word Bool + deriving stock (Eq, Ord, Show, Generic) + +instance Hashable TypeShape diff --git a/src/codecs/Hasql/Codecs/Decoders.hs b/src/codecs/Hasql/Codecs/Decoders.hs deleted file mode 100644 --- a/src/codecs/Hasql/Codecs/Decoders.hs +++ /dev/null @@ -1,147 +0,0 @@ -module Hasql.Codecs.Decoders - ( -- * Nullability - NullableOrNot.NullableOrNot (..), - NullableOrNot.nonNullable, - NullableOrNot.nullable, - - -- * Value - Value.Value (..), - Value.bool, - Value.int2, - Value.int4, - Value.int8, - Value.float4, - Value.float8, - Value.numeric, - Value.char, - Value.text, - Value.varchar, - Value.bpchar, - Value.bytea, - Value.date, - Value.timestamp, - Value.timestamptz, - Value.time, - Value.timetz, - Value.interval, - Value.uuid, - Value.inet, - Value.macaddr, - Value.json, - Value.jsonBytes, - Value.jsonb, - Value.jsonbBytes, - Value.int4range, - Value.int8range, - Value.numrange, - Value.tsrange, - Value.tstzrange, - Value.daterange, - Value.int4multirange, - Value.int8multirange, - Value.nummultirange, - Value.tsmultirange, - Value.tstzmultirange, - Value.datemultirange, - Value.citext, - array, - listArray, - vectorArray, - composite, - record, - Value.hstore, - Value.enum, - Value.custom, - Value.refine, - - -- * Array - Array.Array, - Array.dimension, - Array.element, - - -- * Composite - Composite.Composite (..), - Composite.field, - ) -where - -import Data.Vector.Generic qualified as GenericVector -import Hasql.Codecs.Decoders.Array qualified as Array -import Hasql.Codecs.Decoders.Composite qualified as Composite -import Hasql.Codecs.Decoders.NullableOrNot qualified as NullableOrNot -import Hasql.Codecs.Decoders.Value qualified as Value -import Hasql.Codecs.Vocab.TypeInfo qualified as Vocab.TypeInfo -import Hasql.Platform.Prelude - --- * Value - --- | --- Lift an 'Array.Array' decoder to a 'Value.Value' decoder. -{-# INLINEABLE array #-} -array :: Array.Array a -> Value.Value a -array decoder = Value.Value (Array.toSchema decoder) (Array.toTypeName decoder) (Array.toBaseOid decoder) (Array.toArrayOid decoder) (Array.toDimensionality decoder) (Array.toValueDecoder decoder) - --- | --- Lift a value decoder of element into a unidimensional array decoder producing a list. --- --- This function is merely a shortcut to the following expression: --- --- @ --- ('array' . 'dimension' Control.Monad.'replicateM' . 'element') --- @ --- --- Please notice that in case of multidimensional arrays nesting 'listArray' decoder --- won't work. You have to explicitly construct the array decoder using 'array'. -{-# INLINE listArray #-} -listArray :: NullableOrNot.NullableOrNot Value.Value element -> Value.Value [element] -listArray = array . Array.dimension replicateM . Array.element - --- | --- Lift a value decoder of element into a unidimensional array decoder producing a generic vector. --- --- This function is merely a shortcut to the following expression: --- --- @ --- ('array' . 'dimension' Data.Vector.Generic.'GenericVector.replicateM' . 'element') --- @ --- --- Please notice that in case of multidimensional arrays nesting 'vectorArray' decoder --- won't work. You have to explicitly construct the array decoder using 'array'. -{-# INLINE vectorArray #-} -vectorArray :: (GenericVector.Vector vector element) => NullableOrNot.NullableOrNot Value.Value element -> Value.Value (vector element) -vectorArray = array . Array.dimension GenericVector.replicateM . Array.element - --- | --- Lift a 'Composite.Composite' decoder to a 'Value.Value' decoder for named composite types. --- --- This function is for named composite types where the type name is known. --- For anonymous composite types (like those created with ROW constructor), --- use 'record' instead. -{-# INLINEABLE composite #-} -composite :: Maybe Text -> Text -> Composite.Composite a -> Value.Value a -composite schema typeName composite = - Value.Value - schema - typeName - Nothing - Nothing - 0 - (Composite.toValueDecoder composite) - --- | --- Lift a 'Composite.Composite' decoder to a 'Value.Value' decoder for unnamed composite types. --- --- This is useful for decoding anonymous composites (like those created with ROW constructor) --- where no type name is required. Postgres will handle the type automatically. -{-# INLINEABLE record #-} -record :: Composite.Composite a -> Value.Value a -record composite = - Value.Value - Nothing - "record" - (Just (Vocab.TypeInfo.toBaseOid typeInfo)) - (Just (Vocab.TypeInfo.toArrayOid typeInfo)) - 0 - (Composite.toValueDecoder composite) - where - typeInfo = Vocab.TypeInfo.record diff --git a/src/codecs/Hasql/Codecs/Decoders/Array.hs b/src/codecs/Hasql/Codecs/Decoders/Array.hs deleted file mode 100644 --- a/src/codecs/Hasql/Codecs/Decoders/Array.hs +++ /dev/null @@ -1,139 +0,0 @@ -module Hasql.Codecs.Decoders.Array - ( Array, - toValueDecoder, - toTypeSig, - toSchema, - toTypeName, - toBaseOid, - toArrayOid, - toDimensionality, - dimension, - element, - ) -where - -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.Platform.Prelude -import PostgreSQL.Binary.Decoding qualified as Binary -import TextBuilder qualified - --- | --- Binary generic array decoder. --- --- Here's how you can use it to produce a specific array value decoder: --- --- @ --- x :: 'Value.Value' [[Text]] --- x = 'array' ('dimension' 'replicateM' ('dimension' 'replicateM' ('element' ('nonNullable' 'text')))) --- @ -data Array a - = Array - -- | Schema name. - (Maybe Text) - -- | Type name for the array element. - Text - -- | Statically known OID for the base (element) type. - (Maybe Word32) - -- | Statically known OID for the array type. - (Maybe Word32) - -- | Number of dimensions. - Word - -- | Decoding function - (RequestingOid.RequestingOid (Binary.Array a)) - deriving (Functor) - -{-# INLINE toValueDecoder #-} -toValueDecoder :: Array a -> RequestingOid.RequestingOid (Binary.Value a) -toValueDecoder (Array _ _ _ _ _ decoder) = - fmap Binary.array decoder - --- | Get the type signature for the array based on element type name -{-# INLINE toTypeSig #-} -toTypeSig :: Array a -> Text -toTypeSig (Array schemaName elementTypeName _ _ ndims _) = - TextBuilder.toText - ( mconcat - ( mconcat - [ foldMap - (\s -> [TextBuilder.text s, TextBuilder.char '.']) - schemaName, - [ TextBuilder.text elementTypeName - ], - replicate - (fromIntegral ndims) - (TextBuilder.text "[]") - ] - ) - ) - -toSchema :: Array a -> Maybe Text -toSchema (Array schema _ _ _ _ _) = schema - --- | Get the type name for the array based on element type name -{-# INLINE toTypeName #-} -toTypeName :: Array a -> Text -toTypeName (Array _ elementTypeName _ _ _ _) = - elementTypeName - --- | Get the base OID if statically known -{-# INLINE toBaseOid #-} -toBaseOid :: Array a -> Maybe Word32 -toBaseOid (Array _ _ baseOid _ _ _) = baseOid - --- | Get the array OID if statically known -{-# INLINE toArrayOid #-} -toArrayOid :: Array a -> Maybe Word32 -toArrayOid (Array _ _ _ arrayOid _ _) = arrayOid - --- | Get the dimensionality of the array -{-# INLINE toDimensionality #-} -toDimensionality :: Array a -> Word -toDimensionality (Array _ _ _ _ ndims _) = ndims - --- * Public API - --- | --- Binary function for parsing a dimension of an array. --- Provides support for multi-dimensional arrays. --- --- Accepts: --- --- * An implementation of the @replicateM@ function --- (@Control.Monad.'Control.Monad.replicateM'@, @Data.Vector.'Data.Vector.replicateM'@), --- which determines the output value. --- --- * Binary decoder of its components, which can be either another 'dimension' or 'element'. -{-# INLINEABLE dimension #-} -dimension :: (forall m. (Monad m) => Int -> m a -> m b) -> Array a -> Array b -dimension replicateM (Array schema typeName baseOid arrayOid ndims decoder) = - Array - schema - typeName - baseOid - arrayOid - (succ ndims) - (fmap (Binary.dimensionArray replicateM) decoder) - --- | --- Lift a 'Value.Value' decoder into an 'Array' decoder for parsing of leaf values. -{-# INLINEABLE element #-} -element :: NullableOrNot.NullableOrNot Value.Value a -> Array a -element = \case - NullableOrNot.NonNullable imp -> - Array - (Value.toSchema imp) - (Value.toTypeName imp) - (Value.toBaseOid imp) - (Value.toArrayOid imp) - 1 - (fmap Binary.valueArray (Value.toDecoder imp)) - NullableOrNot.Nullable imp -> - Array - (Value.toSchema imp) - (Value.toTypeName imp) - (Value.toBaseOid imp) - (Value.toArrayOid imp) - 1 - (fmap Binary.nullableValueArray (Value.toDecoder imp)) diff --git a/src/codecs/Hasql/Codecs/Decoders/Composite.hs b/src/codecs/Hasql/Codecs/Decoders/Composite.hs deleted file mode 100644 --- a/src/codecs/Hasql/Codecs/Decoders/Composite.hs +++ /dev/null @@ -1,52 +0,0 @@ -module Hasql.Codecs.Decoders.Composite where - -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.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 - --- | --- Composable decoder of composite values (rows, records). -newtype Composite a - = Composite (RequestingOid.RequestingOid (Binary.Composite a)) - deriving - (Functor, Applicative) - via (Compose RequestingOid.RequestingOid Binary.Composite) - -toValueDecoder :: Composite a -> RequestingOid.RequestingOid (Binary.Value a) -toValueDecoder (Composite imp) = - fmap Binary.composite imp - --- | --- Lift a 'Value.Value' decoder into a 'Composite' decoder for parsing of component values. -field :: NullableOrNot.NullableOrNot Value.Value a -> Composite a -field = \case - NullableOrNot.NonNullable imp -> - let dimensionality = Value.toDimensionality imp - staticOid = if dimensionality == 0 then Value.toBaseOid imp else Value.toArrayOid imp - in case staticOid of - Just oid -> - Composite (fmap (Binary.typedValueComposite oid) (Value.toDecoder imp)) - Nothing -> - Composite - ( RequestingOid.hoistLookingUp - (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 -> - let dimensionality = Value.toDimensionality imp - staticOid = if dimensionality == 0 then Value.toBaseOid imp else Value.toArrayOid imp - in case staticOid of - Just oid -> - Composite (fmap (Binary.typedNullableValueComposite oid) (Value.toDecoder imp)) - Nothing -> - Composite - ( RequestingOid.hoistLookingUp - (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/codecs/Hasql/Codecs/Decoders/NullableOrNot.hs b/src/codecs/Hasql/Codecs/Decoders/NullableOrNot.hs deleted file mode 100644 --- a/src/codecs/Hasql/Codecs/Decoders/NullableOrNot.hs +++ /dev/null @@ -1,27 +0,0 @@ -module Hasql.Codecs.Decoders.NullableOrNot - ( -- * Nullability - NullableOrNot (..), - nonNullable, - nullable, - ) -where - -import Hasql.Platform.Prelude - --- * Nullability - --- | --- Extensional specification of nullability over a generic decoder. -data NullableOrNot decoder a where - NonNullable :: decoder a -> NullableOrNot decoder a - Nullable :: decoder a -> NullableOrNot decoder (Maybe a) - --- | --- Specify that a decoder produces a non-nullable value. -nonNullable :: decoder a -> NullableOrNot decoder a -nonNullable = NonNullable - --- | --- Specify that a decoder produces a nullable value. -nullable :: decoder a -> NullableOrNot decoder (Maybe a) -nullable = Nullable diff --git a/src/codecs/Hasql/Codecs/Decoders/Value.hs b/src/codecs/Hasql/Codecs/Decoders/Value.hs deleted file mode 100644 --- a/src/codecs/Hasql/Codecs/Decoders/Value.hs +++ /dev/null @@ -1,461 +0,0 @@ -module Hasql.Codecs.Decoders.Value - ( Value (..), - bool, - int2, - int4, - int8, - float4, - float8, - numeric, - char, - text, - varchar, - bpchar, - bytea, - date, - timestamp, - timestamptz, - time, - timetz, - interval, - uuid, - inet, - macaddr, - json, - jsonBytes, - jsonb, - jsonbBytes, - int4range, - int8range, - numrange, - tsrange, - tstzrange, - daterange, - int4multirange, - int8multirange, - nummultirange, - tsmultirange, - tstzmultirange, - datemultirange, - citext, - custom, - refine, - hstore, - enum, - toDimensionality, - toDecoder, - toSchema, - toTypeName, - toOid, - toBaseOid, - toArrayOid, - toHandler, - toByteStringParser, - isArray, - ) -where - -import Data.Aeson qualified as Aeson -import Data.IP qualified as Iproute -import Hasql.Codecs.RequestingOid qualified as RequestingOid -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 - --- | --- Value decoder. -data Value a - = Value - -- | Schema name. - (Maybe Text) - -- | Type name. - Text - -- | Statically known OID for the type. - (Maybe Word32) - -- | Statically known OID for the array-type with this type as the element. - (Maybe Word32) - -- | Dimensionality. If 0 then it is a scalar value, otherwise it is an array with that many dimensions. - Word - -- | Decoding function on a registry of OIDs by type name. - (RequestingOid.RequestingOid (Binary.Value a)) - deriving (Functor) - -type role Value representational - -instance Filterable Value where - {-# INLINE mapMaybe #-} - mapMaybe fn = - refine (maybe (Left "Invalid value") Right . fn) - --- | --- Create a decoder from TypeInfo metadata and a decoding function. -{-# INLINE primitive #-} -primitive :: Text -> Vocab.TypeInfo.TypeInfo -> Binary.Value a -> Value a -primitive typeName pti decoder = - Value Nothing typeName (Just (Vocab.TypeInfo.toBaseOid pti)) (Just (Vocab.TypeInfo.toArrayOid pti)) 0 (RequestingOid.lift decoder) - --- * Static types - --- | --- Decoder of the @BOOL@ values. -{-# INLINEABLE bool #-} -bool :: Value Bool -bool = primitive "bool" Vocab.TypeInfo.bool Binary.bool - --- | --- Decoder of the @INT2@ values. -{-# INLINEABLE int2 #-} -int2 :: Value Int16 -int2 = primitive "int2" Vocab.TypeInfo.int2 Binary.int - --- | --- Decoder of the @INT4@ values. -{-# INLINEABLE int4 #-} -int4 :: Value Int32 -int4 = primitive "int4" Vocab.TypeInfo.int4 Binary.int - --- | --- Decoder of the @INT8@ values. -{-# INLINEABLE int8 #-} -int8 :: Value Int64 -int8 = - {-# SCC "int8" #-} - primitive "int8" Vocab.TypeInfo.int8 ({-# SCC "int8.int" #-} Binary.int) - --- | --- Decoder of the @FLOAT4@ values. -{-# INLINEABLE float4 #-} -float4 :: Value Float -float4 = primitive "float4" Vocab.TypeInfo.float4 Binary.float4 - --- | --- Decoder of the @FLOAT8@ values. -{-# INLINEABLE float8 #-} -float8 :: Value Double -float8 = primitive "float8" Vocab.TypeInfo.float8 Binary.float8 - --- | --- Decoder of the @NUMERIC@ values. -{-# INLINEABLE numeric #-} -numeric :: Value Scientific -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" Vocab.TypeInfo.char Binary.char - --- | --- Decoder of the @TEXT@ values. -{-# INLINEABLE text #-} -text :: Value Text -text = primitive "text" Vocab.TypeInfo.text Binary.text_strict - --- | --- Decoder of the @VARCHAR@ values. -{-# INLINEABLE varchar #-} -varchar :: Value Text -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" Vocab.TypeInfo.bpchar Binary.text_strict - --- | --- Decoder of the @BYTEA@ values. -{-# INLINEABLE bytea #-} -bytea :: Value ByteString -bytea = primitive "bytea" Vocab.TypeInfo.bytea Binary.bytea_strict - --- | --- Decoder of the @DATE@ values. -{-# INLINEABLE date #-} -date :: Value Day -date = primitive "date" Vocab.TypeInfo.date Binary.date - --- | --- Decoder of the @TIMESTAMP@ values. -{-# INLINEABLE timestamp #-} -timestamp :: Value LocalTime -timestamp = primitive "timestamp" Vocab.TypeInfo.timestamp Binary.timestamp_int - --- | --- Decoder of the @TIMESTAMPTZ@ values. --- --- /NOTICE/ --- --- Postgres does not store the timezone information of @TIMESTAMPTZ@. --- Instead it stores a UTC value and performs silent conversions --- to the currently set timezone, when dealt with in the text format. --- However this library bypasses the silent conversions --- and communicates with Postgres using the UTC values directly. -{-# INLINEABLE timestamptz #-} -timestamptz :: Value UTCTime -timestamptz = primitive "timestamptz" Vocab.TypeInfo.timestamptz Binary.timestamptz_int - --- | --- Decoder of the @TIME@ values. -{-# INLINEABLE time #-} -time :: Value TimeOfDay -time = primitive "time" Vocab.TypeInfo.time Binary.time_int - --- | --- Decoder of the @TIMETZ@ values. --- --- Unlike in case of @TIMESTAMPTZ@, --- Postgres does store the timezone information for @TIMETZ@. --- However the Haskell's \"time\" library does not contain any composite type, --- that fits the task, so we use a pair of 'TimeOfDay' and 'TimeZone' --- to represent a value on the Haskell's side. -{-# INLINEABLE timetz #-} -timetz :: Value (TimeOfDay, TimeZone) -timetz = primitive "timetz" Vocab.TypeInfo.timetz Binary.timetz_int - --- | --- Decoder of the @INTERVAL@ values. -{-# INLINEABLE interval #-} -interval :: Value DiffTime -interval = primitive "interval" Vocab.TypeInfo.interval Binary.interval_int - --- | --- Decoder of the @UUID@ values. -{-# INLINEABLE uuid #-} -uuid :: Value UUID -uuid = primitive "uuid" Vocab.TypeInfo.uuid Binary.uuid - --- | --- Decoder of the @INET@ values. -{-# INLINEABLE inet #-} -inet :: Value Iproute.IPRange -inet = primitive "inet" Vocab.TypeInfo.inet Binary.inet - --- | --- Decoder of the @MACADDR@ values. --- --- Represented as a 6-tuple of Word8 values in big endian order. If --- you use `ip` library consider using it with `fromOctets`. --- --- > (\(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" Vocab.TypeInfo.macaddr Binary.macaddr - --- | --- Decoder of the @JSON@ values into a JSON AST. -{-# INLINEABLE json #-} -json :: Value Aeson.Value -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" 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" 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" Vocab.TypeInfo.jsonb (Binary.jsonb_bytes fn) - --- | --- Decoder of the @INT4RANGE@ values. -{-# INLINEABLE int4range #-} -int4range :: Value (R.Range Int32) -int4range = primitive "int4range" Vocab.TypeInfo.int4range Binary.int4range - --- | --- Decoder of the @INT8RANGE@ values. -{-# INLINEABLE int8range #-} -int8range :: Value (R.Range Int64) -int8range = primitive "int8range" Vocab.TypeInfo.int8range Binary.int8range - --- | --- Decoder of the @NUMRANGE@ values. -{-# INLINEABLE numrange #-} -numrange :: Value (R.Range Scientific) -numrange = primitive "numrange" Vocab.TypeInfo.numrange Binary.numrange - --- | --- Decoder of the @TSRANGE@ values. -{-# INLINEABLE tsrange #-} -tsrange :: Value (R.Range LocalTime) -tsrange = primitive "tsrange" Vocab.TypeInfo.tsrange Binary.tsrange_int - --- | --- Decoder of the @TSTZRANGE@ values. -{-# INLINEABLE tstzrange #-} -tstzrange :: Value (R.Range UTCTime) -tstzrange = primitive "tstzrange" Vocab.TypeInfo.tstzrange Binary.tstzrange_int - --- | --- Decoder of the @DATERANGE@ values. -{-# INLINEABLE daterange #-} -daterange :: Value (R.Range Day) -daterange = primitive "daterange" Vocab.TypeInfo.daterange Binary.daterange - --- | --- Decoder of the @INT4MULTIRANGE@ values. -{-# INLINEABLE int4multirange #-} -int4multirange :: Value (R.Multirange Int32) -int4multirange = primitive "int4multirange" Vocab.TypeInfo.int4multirange Binary.int4multirange - --- | --- Decoder of the @INT8MULTIRANGE@ values. -{-# INLINEABLE int8multirange #-} -int8multirange :: Value (R.Multirange Int64) -int8multirange = primitive "int8multirange" Vocab.TypeInfo.int8multirange Binary.int8multirange - --- | --- Decoder of the @NUMMULTIRANGE@ values. -{-# INLINEABLE nummultirange #-} -nummultirange :: Value (R.Multirange Scientific) -nummultirange = primitive "nummultirange" Vocab.TypeInfo.nummultirange Binary.nummultirange - --- | --- Decoder of the @TSMULTIRANGE@ values. -{-# INLINEABLE tsmultirange #-} -tsmultirange :: Value (R.Multirange LocalTime) -tsmultirange = primitive "tsmultirange" Vocab.TypeInfo.tsmultirange Binary.tsmultirange_int - --- | --- Decoder of the @TSTZMULTIRANGE@ values. -{-# INLINEABLE tstzmultirange #-} -tstzmultirange :: Value (R.Multirange UTCTime) -tstzmultirange = primitive "tstzmultirange" Vocab.TypeInfo.tstzmultirange Binary.tstzmultirange_int - --- | --- Decoder of the @DATEMULTIRANGE@ values. -{-# INLINEABLE datemultirange #-} -datemultirange :: Value (R.Multirange Day) -datemultirange = primitive "datemultirange" Vocab.TypeInfo.datemultirange Binary.datemultirange - --- | --- Decoder of the @CITEXT@ values. --- --- Requires the @citext@ extension to be installed in the database. -{-# INLINEABLE citext #-} -citext :: Value Text -citext = Value Nothing "citext" Nothing Nothing 0 (RequestingOid.lift Binary.text_strict) - --- | --- Low level API for defining custom value decoders. -{-# INLINEABLE custom #-} -custom :: - -- | Schema name. - Maybe Text -> - -- | Type name. - Text -> - -- | Possible static OIDs for the type. The first is for scalar values the second is for arrays. - -- - -- When unspecified, the OIDs will be automatically determined at runtime by looking up by name. - Maybe (Word32, Word32) -> - -- | 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. - -- - -- When any of the requested types is missing in the database an error will be raised upon the statement execution. - [(Maybe Text, Text)] -> - -- | Deserialization function in the context of resolved OIDs of the types requested in the previous parameter. - -- - -- It's safe to assume that all of the requested types will be present. - -- In case you run the provided lookup function with unmentioned type names it will produce OID of 0 for them, standing for unknown type in Postgres. - ( ((Maybe Text, Text) -> (Word32, Word32)) -> - ByteString -> - Either Text a - ) -> - Value a -custom schema typeName staticOids requestedTypes fn = - Value - schema - typeName - (fmap fst staticOids) - (fmap snd staticOids) - 0 - (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. -{-# INLINE refine #-} -refine :: (a -> Either Text b) -> Value a -> Value b -refine fn (Value schema typeName typeOid arrayOid dimensionality decoder) = - Value schema typeName typeOid arrayOid dimensionality (fmap (Binary.refine fn) decoder) - --- | --- Binary generic decoder of @HSTORE@ values. --- --- Here's how you can use it to construct a specific value: --- --- @ --- x :: Value [(Text, Maybe Text)] --- x = hstore 'replicateM' --- @ -{-# INLINEABLE hstore #-} -hstore :: (forall m. (Monad m) => Int -> m (Text, Maybe Text) -> m a) -> Value a -hstore replicateM = - Value Nothing "hstore" Nothing Nothing 0 (RequestingOid.lift (Binary.hstore replicateM Binary.text_strict Binary.text_strict)) - --- | --- Given a partial mapping from text to value, produces a decoder of that value for a named enum type. -enum :: - -- | Schema name. - Maybe Text -> - -- | Type name. - Text -> - -- | Mapping from text to value. - (Text -> Maybe a) -> - Value a -enum schema typeName mapping = - Value schema typeName Nothing Nothing 0 (RequestingOid.lift (Binary.enum mapping)) - --- * Relations - -toDimensionality :: Value a -> Word -toDimensionality (Value _ _ _ _ dimensionality _) = dimensionality - -toSchema :: Value a -> Maybe Text -toSchema (Value schema _ _ _ _ _) = schema - -toTypeName :: Value a -> Text -toTypeName (Value _ typeName _ _ _ _) = typeName - -toOid :: Value a -> Maybe Word32 -toOid (Value _ _ baseOid arrayOid dimensionality _) = - if dimensionality > 0 - then arrayOid - else baseOid - -toBaseOid :: Value a -> Maybe Word32 -toBaseOid (Value _ _ baseOid _ _ _) = baseOid - -toArrayOid :: Value a -> Maybe Word32 -toArrayOid (Value _ _ _ oid _ _) = oid - -toDecoder :: Value a -> RequestingOid.RequestingOid (Binary.Value a) -toDecoder (Value _ _ _ _ _ decoder) = decoder - -{-# INLINE toHandler #-} -toHandler :: Value a -> Vocab.OidCache -> Binary.Value a -toHandler (Value _ _ _ _ _ decoder) = RequestingOid.toBase decoder - -{-# INLINE toByteStringParser #-} -toByteStringParser :: Value a -> (Vocab.OidCache -> ByteString -> Either Text a) -toByteStringParser (Value _ _ _ _ _ decoder) oidCache = Binary.valueParser (RequestingOid.toBase decoder oidCache) - -isArray :: Value a -> Bool -isArray (Value _ _ _ _ dimensionality _) = dimensionality > 0 diff --git a/src/codecs/Hasql/Codecs/Encoders.hs b/src/codecs/Hasql/Codecs/Encoders.hs deleted file mode 100644 --- a/src/codecs/Hasql/Codecs/Encoders.hs +++ /dev/null @@ -1,152 +0,0 @@ --- | --- A DSL for declaration of statement parameter encoders. --- --- For compactness of names all the types defined here imply being an encoder. --- E.g., the `Array` type is an __encoder__ of arrays, not the data-structure itself. -module Hasql.Codecs.Encoders - ( -- * Parameters product - Params.Params, - Params.noParams, - Params.param, - - -- * Nullability - NullableOrNot.NullableOrNot, - NullableOrNot.nonNullable, - NullableOrNot.nullable, - - -- * Value - Value.Value, - Value.bool, - Value.int2, - Value.int4, - Value.int8, - Value.float4, - Value.float8, - Value.numeric, - Value.char, - Value.text, - Value.varchar, - Value.bpchar, - Value.bytea, - Value.date, - Value.timestamp, - Value.timestamptz, - Value.time, - Value.timetz, - Value.interval, - Value.uuid, - Value.inet, - Value.macaddr, - Value.json, - Value.jsonBytes, - Value.jsonLazyBytes, - Value.jsonb, - Value.jsonbBytes, - Value.jsonbLazyBytes, - Value.int4range, - Value.int8range, - Value.numrange, - Value.tsrange, - Value.tstzrange, - Value.daterange, - Value.int4multirange, - Value.int8multirange, - Value.nummultirange, - Value.tsmultirange, - Value.tstzmultirange, - Value.datemultirange, - Value.citext, - Value.name, - Value.oid, - foldableArray, - array, - Value.hstore, - Value.enum, - composite, - Value.unknown, - Value.custom, - - -- * Array - Array.Array, - Array.element, - Array.dimension, - - -- * Composite - Composite.Composite, - Composite.field, - ) -where - -import Data.HashMap.Strict qualified as HashMap -import Hasql.Codecs.Encoders.Array qualified as Array -import Hasql.Codecs.Encoders.Composite qualified as Composite -import Hasql.Codecs.Encoders.NullableOrNot qualified as NullableOrNot -import Hasql.Codecs.Encoders.Params qualified as Params -import Hasql.Codecs.Encoders.Value qualified as Value -import Hasql.Codecs.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 - --- * Recursive definitions - --- | --- Lift a value encoder of element into a unidimensional array encoder of a foldable value. --- --- This function is merely a shortcut to the following expression: --- --- @ --- ('array' . 'Array.dimension' 'foldl'' . 'Array.element') --- @ --- --- You can use it like this: --- --- @ --- vectorOfInts :: Value (Vector Int64) --- vectorOfInts = 'foldableArray' ('nonNullable' 'int8') --- @ --- --- Please notice that in case of multidimensional arrays nesting 'foldableArray' encoder --- won't work. You have to explicitly construct the array encoder using 'array'. -{-# INLINE foldableArray #-} -foldableArray :: (Foldable foldable) => NullableOrNot.NullableOrNot Value.Value element -> Value.Value (foldable element) -foldableArray = array . Array.dimension foldl' . Array.element - --- | --- Lift an array encoder into a value encoder. -array :: Array.Array a -> Value.Value a -array (Array.Array baseTypeSchema baseTypeName _isText dimensionality scalarOidIfKnown arrayOidIfKnown unknownTypes arrayEncoder renderer) = - let encoder oidCache input = - let resolvedOid = - asum - [ scalarOidIfKnown, - oidCache - & HashMap.lookup (Vocab.QualifiedTypeName.QualifiedTypeName baseTypeSchema baseTypeName) - & fmap Vocab.TypeInfo.toBaseOid - ] - -- Should only happen on a bug. - & 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 - --- | --- Lift a composite encoder into a value encoder for named composite types. --- --- This function is for named composite types where the type name is known. --- If you need to encode an anonymous composite type (like those created with the ROW constructor), --- PostgreSQL itself does not support that. -composite :: - -- | Schema name where the composite type is defined. - Maybe Text -> - -- | Composite type name. - Text -> - Composite.Composite a -> - Value.Value a -composite schema name (Composite.Composite unknownTypes encode print) = - Value.Value schema name Nothing Nothing 0 False unknownTypes encodeValue printValue - where - encodeValue oidCache val = - Binary.composite (encode oidCache val) - printValue val = - "ROW (" <> TextBuilder.intercalate ", " (print val) <> ")" diff --git a/src/codecs/Hasql/Codecs/Encoders/Array.hs b/src/codecs/Hasql/Codecs/Encoders/Array.hs deleted file mode 100644 --- a/src/codecs/Hasql/Codecs/Encoders/Array.hs +++ /dev/null @@ -1,104 +0,0 @@ -module Hasql.Codecs.Encoders.Array where - -import Hasql.Codecs.Encoders.NullableOrNot qualified as NullableOrNot -import Hasql.Codecs.Encoders.Value qualified as Value -import Hasql.Codecs.Vocab qualified as Vocab -import Hasql.Platform.Prelude -import PostgreSQL.Binary.Encoding qualified as Binary -import TextBuilder qualified as TextBuilder - --- | --- Generic array encoder. --- --- Here's an example of its usage: --- --- @ --- someParamsEncoder :: 'Params' [[Int64]] --- someParamsEncoder = 'param' ('nonNullable' ('array' ('dimension' 'foldl'' ('dimension' 'foldl'' ('element' ('nonNullable' 'int8')))))) --- @ --- --- Please note that the PostgreSQL @IN@ keyword does not accept an array, but rather a syntactical list of --- values, thus this encoder is not suited for that. Use a @value = ANY($1)@ condition instead. -data Array a - = Array - -- | Schema name, if any. - (Maybe Text) - -- | Type name. - Text - -- | Text format? - Bool - -- | Dimensionality. If 0 then it is not an array, but a scalar value. - Word - -- | OID of the element type. - (Maybe Word32) - -- | 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 Vocab.QualifiedTypeName) - -- | Serialization function given the dictionary of resolved OIDs. - (HashMap Vocab.QualifiedTypeName Vocab.TypeInfo -> a -> Binary.Array) - -- | Render function for error messages. - (a -> TextBuilder.TextBuilder) - -instance Contravariant Array where - contramap fn (Array schemaName typeName textFormat dimensionality valueOid arrayOid unknownTypes elEncoder elRenderer) = - Array schemaName typeName textFormat dimensionality valueOid arrayOid unknownTypes (\oidCache -> elEncoder oidCache . fn) (elRenderer . fn) - --- | --- Lifts a 'Value.Value' encoder into an 'Array' encoder. -element :: NullableOrNot.NullableOrNot Value.Value a -> Array a -element = \case - NullableOrNot.NonNullable (Value.Value schemaName typeName scalarOid arrayOid dimensionality textFormat unknownTypes serialize print) -> - Array - schemaName - typeName - textFormat - dimensionality - scalarOid - arrayOid - unknownTypes - (\oidCache -> Binary.encodingArray . serialize oidCache) - print - NullableOrNot.Nullable (Value.Value schemaName typeName scalarOid arrayOid dimensionality textFormat unknownTypes serialize print) -> - let maybeSerialize oidCache = - maybe Binary.nullArray (Binary.encodingArray . serialize oidCache) - maybePrint = - maybe (TextBuilder.string "null") print - in Array - schemaName - typeName - textFormat - dimensionality - scalarOid - arrayOid - unknownTypes - maybeSerialize - maybePrint - --- | --- Encoder of an array dimension, --- which thus provides support for multidimensional arrays. --- --- Accepts: --- --- * An implementation of the left-fold operation, --- such as @Data.Foldable.'foldl''@, --- which determines the input value. --- --- * A component encoder, which can be either another 'dimension' or 'element'. -{-# INLINE dimension #-} -dimension :: (forall a. (a -> b -> a) -> a -> c -> a) -> Array b -> Array c -dimension fold (Array schemaName typeName textFormat dimensionality valueOid arrayOid unknownTypes elEncoder elRenderer) = - let encoder oidCache = - Binary.dimensionArray fold (elEncoder oidCache) - renderer els = - let folded = - let step builder el = - if TextBuilder.isEmpty builder - then TextBuilder.char '[' <> elRenderer el - else builder <> TextBuilder.string ", " <> elRenderer el - in fold step mempty els - in if TextBuilder.isEmpty folded - then TextBuilder.string "[]" - else folded <> TextBuilder.char ']' - in Array schemaName typeName textFormat (succ dimensionality) valueOid arrayOid unknownTypes encoder renderer diff --git a/src/codecs/Hasql/Codecs/Encoders/Composite.hs b/src/codecs/Hasql/Codecs/Encoders/Composite.hs deleted file mode 100644 --- a/src/codecs/Hasql/Codecs/Encoders/Composite.hs +++ /dev/null @@ -1,97 +0,0 @@ -module Hasql.Codecs.Encoders.Composite where - -import Data.HashMap.Strict qualified as HashMap -import Data.HashSet qualified as HashSet -import Hasql.Codecs.Encoders.NullableOrNot qualified as NullableOrNot -import Hasql.Codecs.Encoders.Value qualified as Value -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 - --- | --- Composite or row-types encoder. -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 Vocab.QualifiedTypeName) - -- | Serialization function given the dictionary of resolved OIDs. - (HashMap Vocab.QualifiedTypeName Vocab.TypeInfo -> a -> Binary.Composite) - -- | Render function for error messages. - (a -> [TextBuilder.TextBuilder]) - -instance Contravariant Composite where - contramap f (Composite unknownTypes encode print) = - Composite unknownTypes (\oidCache -> encode oidCache . f) (print . f) - -instance Divisible Composite where - divide f (Composite unknownTypesL encodeL printL) (Composite unknownTypesR encodeR printR) = - Composite - (unknownTypesL <> unknownTypesR) - (\oidCache val -> case f val of (lVal, rVal) -> encodeL oidCache lVal <> encodeR oidCache rVal) - (\val -> case f val of (lVal, rVal) -> printL lVal <> printR rVal) - conquer = mempty - -instance Semigroup (Composite a) where - Composite unknownTypesL encodeL printL <> Composite unknownTypesR encodeR printR = - Composite - (unknownTypesL <> unknownTypesR) - (\oidCache val -> encodeL oidCache val <> encodeR oidCache val) - (\val -> printL val <> printR val) - -instance Monoid (Composite a) where - mempty = Composite mempty mempty mempty - --- | Single field of a row-type. -field :: NullableOrNot.NullableOrNot Value.Value a -> Composite a -field = \case - NullableOrNot.NonNullable (Value.Value schemaName typeName scalarOid arrayOid dimensionality _ unknownTypes encode print) -> - let staticOid = if dimensionality == 0 then scalarOid else arrayOid - in case staticOid of - Just oid -> - Composite - unknownTypes - (\oidCache val -> Binary.field oid (encode oidCache val)) - (\val -> [print val]) - Nothing -> - Composite - (HashSet.insert (Vocab.QualifiedTypeName.QualifiedTypeName schemaName typeName) unknownTypes) - ( \oidCache val -> - 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]) - NullableOrNot.Nullable (Value.Value schemaName typeName scalarOid arrayOid dimensionality _ unknownTypes encode print) -> - let staticOid = if dimensionality == 0 then scalarOid else arrayOid - in case staticOid of - Just oid -> - Composite - unknownTypes - ( \oidCache -> \case - Nothing -> Binary.nullField oid - Just val -> Binary.field oid (encode oidCache val) - ) - ( \case - Nothing -> ["NULL"] - Just val -> [print val] - ) - Nothing -> - Composite - (HashSet.insert (Vocab.QualifiedTypeName.QualifiedTypeName schemaName typeName) unknownTypes) - ( \oidCache -> \case - Nothing -> - 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 (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 - Nothing -> ["NULL"] - Just val -> [print val] - ) diff --git a/src/codecs/Hasql/Codecs/Encoders/NullableOrNot.hs b/src/codecs/Hasql/Codecs/Encoders/NullableOrNot.hs deleted file mode 100644 --- a/src/codecs/Hasql/Codecs/Encoders/NullableOrNot.hs +++ /dev/null @@ -1,19 +0,0 @@ -module Hasql.Codecs.Encoders.NullableOrNot where - -import Hasql.Platform.Prelude - --- | --- Extensional specification of nullability over a generic encoder. -data NullableOrNot encoder a where - NonNullable :: encoder a -> NullableOrNot encoder a - Nullable :: encoder a -> NullableOrNot encoder (Maybe a) - --- | --- Specify that an encoder produces a non-nullable value. -nonNullable :: encoder a -> NullableOrNot encoder a -nonNullable = NonNullable - --- | --- Specify that an encoder produces a nullable value. -nullable :: encoder a -> NullableOrNot encoder (Maybe a) -nullable = Nullable diff --git a/src/codecs/Hasql/Codecs/Encoders/Params.hs b/src/codecs/Hasql/Codecs/Encoders/Params.hs deleted file mode 100644 --- a/src/codecs/Hasql/Codecs/Encoders/Params.hs +++ /dev/null @@ -1,198 +0,0 @@ -module Hasql.Codecs.Encoders.Params - ( Params, - noParams, - param, - toColumnsMetadata, - toUnknownTypes, - toSerializer, - toPrinter, - ) -where - -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.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 - --- | Frozen per-parameter metadata: type reference, dimensionality, text-format flag. -toColumnsMetadata :: Params a -> Vector ParamMeta -toColumnsMetadata (Params _ _ columnsMetadata _ _) = freezeColumnsMetadata columnsMetadata - where - freezeColumnsMetadata = - Vector.fromList . toList - -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. --- --- Has instances of 'Contravariant', 'Divisible' and 'Monoid', --- which you can use to compose multiple parameters together. --- E.g., --- --- @ --- someParamsEncoder :: 'Params' (Int64, Maybe Text) --- someParamsEncoder = --- ('fst' '>$<' 'param' ('nonNullable' 'int8')) '<>' --- ('snd' '>$<' 'param' ('nullable' 'text')) --- @ --- --- 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. --- E.g., here's how you can achieve the same as the above: --- --- @ --- someParamsEncoder :: 'Params' (Int64, Maybe Text) --- someParamsEncoder = --- 'contrazip2' ('param' ('nonNullable' 'int8')) ('param' ('nullable' 'text')) --- @ --- --- Here's how you can implement encoders for custom composite types: --- --- @ --- data Person = Person { name :: Text, gender :: Gender, age :: Int } --- --- data Gender = Male | Female --- --- personParams :: 'Params' Person --- personParams = --- (name '>$<' 'param' ('nonNullable' 'text')) '<>' --- (gender '>$<' 'param' ('nonNullable' genderValue)) '<>' --- ('fromIntegral' . age '>$<' 'param' ('nonNullable' 'int8')) --- --- genderValue :: 'Value.Value' Gender --- genderValue = 'enum' Nothing (Just "gender") genderText where --- genderText gender = case gender of --- Male -> "male" --- Female -> "female" --- @ -data Params a = Params - { size :: Int, - unknownTypes :: HashSet Vocab.QualifiedTypeName, - -- | (Type reference, dimensionality, Text Format) for each parameter. - columnsMetadata :: DList ParamMeta, - serializer :: Vocab.OidCache -> a -> [Maybe ByteString], - printer :: a -> DList Text - } - -instance Contravariant Params where - contramap fn (Params size unknownTypes columnsMetadata oldSerializer oldPrinter) = Params {..} - where - serializer oidCache = oldSerializer oidCache . fn - printer = oldPrinter . fn - -instance Divisible Params where - divide - divisor - (Params leftSize leftUnknownTypes leftColumnsMetadata leftSerializer leftPrinter) - (Params rightSize rightUnknownTypes rightColumnsMetadata rightSerializer rightPrinter) = - Params - { size = leftSize + rightSize, - unknownTypes = leftUnknownTypes <> rightUnknownTypes, - columnsMetadata = leftColumnsMetadata <> rightColumnsMetadata, - serializer = \oidCache input -> case divisor input of - (leftInput, rightInput) -> leftSerializer oidCache leftInput <> rightSerializer oidCache rightInput, - printer = \input -> case divisor input of - (leftInput, rightInput) -> leftPrinter leftInput <> rightPrinter rightInput - } - conquer = - Params - { size = 0, - unknownTypes = mempty, - columnsMetadata = mempty, - serializer = mempty, - printer = mempty - } - -instance Semigroup (Params a) where - Params leftSize leftUnknownTypes leftColumnsMetadata leftSerializer leftPrinter <> Params rightSize rightUnknownTypes rightColumnsMetadata rightSerializer rightPrinter = - Params - { size = leftSize + rightSize, - unknownTypes = leftUnknownTypes <> rightUnknownTypes, - columnsMetadata = leftColumnsMetadata <> rightColumnsMetadata, - serializer = \oidCache input -> leftSerializer oidCache input <> rightSerializer oidCache input, - printer = \input -> leftPrinter input <> rightPrinter input - } - -instance Monoid (Params a) where - mempty = conquer - -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 (Vocab.OidCache.toHashMap oidCache) - printer = pure . TextBuilder.toText . print - size = 1 - in case staticOid of - Just oid -> - Params - { size, - unknownTypes, - columnsMetadata = pure (ParamMeta (Vocab.TypeRef.KnownOid oid) dimensionality textFormat), - serializer, - printer - } - Nothing -> - Params - { size, - unknownTypes = HashSet.insert (Vocab.QualifiedTypeName.QualifiedTypeName schemaName typeName) unknownTypes, - columnsMetadata = pure (ParamMeta (Vocab.TypeRef.NamedType (Vocab.QualifiedTypeName.QualifiedTypeName schemaName typeName)) dimensionality textFormat), - serializer, - printer - } - -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 (Vocab.OidCache.toHashMap oidCache)) - printer = pure . maybe "null" (TextBuilder.toText . print) - size = 1 - in case staticOid of - Just oid -> - Params - { size, - unknownTypes, - columnsMetadata = pure (ParamMeta (Vocab.TypeRef.KnownOid oid) dimensionality textFormat), - serializer, - printer - } - Nothing -> - Params - { size, - unknownTypes = HashSet.insert (Vocab.QualifiedTypeName.QualifiedTypeName schemaName typeName) unknownTypes, - columnsMetadata = pure (ParamMeta (Vocab.TypeRef.NamedType (Vocab.QualifiedTypeName.QualifiedTypeName schemaName typeName)) dimensionality textFormat), - serializer, - printer - } - --- | --- No parameters. Same as `mempty` and `conquered`. -noParams :: Params () -noParams = mempty - --- | --- Lift a single parameter encoder, with its nullability specified, --- associating it with a single placeholder. -param :: NullableOrNot.NullableOrNot Value.Value a -> Params a -param = \case - NullableOrNot.NonNullable valueEnc -> value valueEnc - NullableOrNot.Nullable valueEnc -> nullableValue valueEnc diff --git a/src/codecs/Hasql/Codecs/Encoders/Value.hs b/src/codecs/Hasql/Codecs/Encoders/Value.hs deleted file mode 100644 --- a/src/codecs/Hasql/Codecs/Encoders/Value.hs +++ /dev/null @@ -1,456 +0,0 @@ -module Hasql.Codecs.Encoders.Value where - -import ByteString.StrictBuilder qualified -import Data.Aeson qualified as Aeson -import Data.ByteString.Lazy qualified as LazyByteString -import Data.HashMap.Strict qualified as HashMap -import Data.HashSet qualified as HashSet -import Data.IP qualified as Iproute -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 -import TextBuilder qualified as TextBuilder - --- | --- Value encoder. -data Value a - = Value - -- | Schema name, if any. - (Maybe Text) - -- | Type name. - Text - -- | Statically known OID for the type. - -- When unspecified, the OID may be determined at runtime by looking up by name. - (Maybe Word32) - -- | Statically known OID for the array-type with this type as the element. - -- When unspecified, the OID may be determined at runtime by looking up by name. - -- It may also mean that there may be no array type containing this type, which is the case in attempts to double-nest arrays. - (Maybe Word32) - -- | Dimensionality. If 0 then it is not an array, but a scalar value. - Word - -- | 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 Vocab.QualifiedTypeName) - -- | Serialization function on the resolved OIDs. - (HashMap Vocab.QualifiedTypeName Vocab.TypeInfo.TypeInfo -> a -> Binary.Encoding) - -- | Render function for error messages. - (a -> TextBuilder.TextBuilder) - -instance Contravariant Value where - {-# INLINE contramap #-} - contramap f (Value schemaName typeName valueOid arrayOid dimensionality textFormat unknownTypes encode render) = - Value schemaName typeName valueOid arrayOid dimensionality textFormat unknownTypes (\hashMap -> encode hashMap . f) (render . f) - -{-# INLINE primitive #-} -primitive :: Text -> Bool -> Vocab.TypeInfo.TypeInfo -> (a -> Binary.Encoding) -> (a -> TextBuilder.TextBuilder) -> Value a -primitive typeName isText typeInfo encode render = - Value - Nothing - typeName - (Just (Vocab.TypeInfo.toBaseOid typeInfo)) - (Just (Vocab.TypeInfo.toArrayOid typeInfo)) - 0 - isText - HashSet.empty - (const encode) - render - --- | --- Encoder of @BOOL@ values. -{-# INLINEABLE bool #-} -bool :: Value Bool -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 Vocab.TypeInfo.int2 Binary.int2_int16 (TextBuilder.string . show) - --- | --- Encoder of @INT4@ values. -{-# INLINEABLE int4 #-} -int4 :: Value Int32 -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 Vocab.TypeInfo.int8 Binary.int8_int64 (TextBuilder.string . show) - --- | --- Encoder of @FLOAT4@ values. -{-# INLINEABLE float4 #-} -float4 :: Value Float -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 Vocab.TypeInfo.float8 Binary.float8 (TextBuilder.string . show) - --- | --- Encoder of @NUMERIC@ values. -{-# INLINEABLE numeric #-} -numeric :: Value Scientific -numeric = primitive "numeric" False Vocab.TypeInfo.numeric Binary.numeric (TextBuilder.string . show) - --- | --- Encoder of @CHAR@ values. --- --- Note that it supports Unicode values and --- identifies itself under the @TEXT@ OID because of that. -{-# INLINEABLE char #-} -char :: Value Char -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 Vocab.TypeInfo.text Binary.text_strict (TextBuilder.string . show) - --- | --- Encoder of @VARCHAR@ values. -{-# INLINEABLE varchar #-} -varchar :: Value Text -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 Vocab.TypeInfo.bpchar Binary.text_strict (TextBuilder.string . show) - --- | --- Encoder of @BYTEA@ values. -{-# INLINEABLE bytea #-} -bytea :: Value ByteString -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 Vocab.TypeInfo.date Binary.date (TextBuilder.string . show) - --- | --- Encoder of @TIMESTAMP@ values. -{-# INLINEABLE timestamp #-} -timestamp :: Value LocalTime -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 Vocab.TypeInfo.timestamptz Binary.timestamptz_int (TextBuilder.string . show) - --- | --- Encoder of @TIME@ values. -{-# INLINEABLE time #-} -time :: Value TimeOfDay -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 Vocab.TypeInfo.timetz Binary.timetz_int (TextBuilder.string . show) - --- | --- Encoder of @INTERVAL@ values. -{-# INLINEABLE interval #-} -interval :: Value DiffTime -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 Vocab.TypeInfo.uuid Binary.uuid (TextBuilder.string . show) - --- | --- Encoder of @INET@ values. -{-# INLINEABLE inet #-} -inet :: Value Iproute.IPRange -inet = primitive "inet" False Vocab.TypeInfo.inet Binary.inet (TextBuilder.string . show) - --- | --- Encoder of @MACADDR@ values. --- --- Represented as a 6-tuple of Word8 values in big endian order. If --- you use `ip` library you can convert using its `toOctets`. --- --- > toOctets >$< macaddr -{-# INLINEABLE macaddr #-} -macaddr :: Value (Word8, Word8, Word8, Word8, Word8, Word8) -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 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 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 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 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 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 Vocab.TypeInfo.jsonb Binary.jsonb_bytes_lazy (TextBuilder.string . show) - --- | --- Encoder of @OID@ values. -{-# INLINEABLE oid #-} -oid :: Value Int32 -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 Vocab.TypeInfo.name Binary.text_strict (TextBuilder.string . show) - --- | --- Encoder of @INT4RANGE@ values. -{-# INLINEABLE int4range #-} -int4range :: Value (Range.Range Int32) -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 Vocab.TypeInfo.int8range Binary.int8range (TextBuilder.string . show) - --- | --- Encoder of @NUMRANGE@ values. -{-# INLINEABLE numrange #-} -numrange :: Value (Range.Range Scientific) -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 Vocab.TypeInfo.tsrange Binary.tsrange_int (TextBuilder.string . show) - --- | --- Encoder of @TSTZRANGE@ values. -{-# INLINEABLE tstzrange #-} -tstzrange :: Value (Range.Range UTCTime) -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 Vocab.TypeInfo.daterange Binary.daterange (TextBuilder.string . show) - --- | --- Encoder of @INT4MULTIRANGE@ values. -{-# INLINEABLE int4multirange #-} -int4multirange :: Value (Range.Multirange Int32) -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 Vocab.TypeInfo.int8multirange Binary.int8multirange (TextBuilder.string . show) - --- | --- Encoder of @NUMMULTIRANGE@ values. -{-# INLINEABLE nummultirange #-} -nummultirange :: Value (Range.Multirange Scientific) -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 Vocab.TypeInfo.tsmultirange Binary.tsmultirange_int (TextBuilder.string . show) - --- | --- Encoder of @TSTZMULTIRANGE@ values. -{-# INLINEABLE tstzmultirange #-} -tstzmultirange :: Value (Range.Multirange UTCTime) -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 Vocab.TypeInfo.datemultirange Binary.datemultirange (TextBuilder.string . show) - --- | --- Encoder of @CITEXT@ values. --- --- Requires the @citext@ extension to be installed in the database. -{-# INLINEABLE citext #-} -citext :: Value Text -citext = - Value - Nothing - "citext" - Nothing - Nothing - 0 - False - HashSet.empty - (const Binary.text_strict) - (TextBuilder.string . show) - --- | --- Given a function which maps a value into a textual enum label used on the DB side, --- produces an encoder of that value for a named enum type. -{-# INLINEABLE enum #-} -enum :: - -- | Schema name where the enum type is defined. - Maybe Text -> - -- | Enum type name. - Text -> - -- | Mapping function from value to enum label. - (a -> Text) -> - Value a -enum schemaName typeName mapping = - Value - schemaName - typeName - Nothing - Nothing - 0 - False - (HashSet.singleton (Vocab.QualifiedTypeName.QualifiedTypeName schemaName typeName)) - (const (Binary.text_strict . mapping)) - (TextBuilder.text . mapping) - --- | --- Identifies the value with the PostgreSQL's \"unknown\" type, --- thus leaving it up to Postgres to infer the actual type of the value. --- --- The value transmitted is any value encoded in the Postgres' Text data format. --- For reference, see the --- --- section of the Postgres' documentation. --- --- __Warning:__ Do not use this as part of composite encoders like 'array' since --- it is the only encoder that doesn't use the binary format. -{-# DEPRECATED unknown "Use 'custom' instead." #-} -{-# INLINEABLE unknown #-} -unknown :: Value ByteString -unknown = primitive "unknown" True Vocab.TypeInfo.unknown Binary.bytea_strict (TextBuilder.string . show) - --- | --- Low level API for defining custom value encoders. -{-# INLINEABLE custom #-} -custom :: - -- | Schema name where the type is defined. - Maybe Text -> - -- | Type name. - Text -> - -- | Possible static OIDs for the type. The first is for scalar values the second is for arrays. - -- - -- When unspecified, the OIDs will be automatically determined at runtime by looking up by name. - Maybe (Word32, Word32) -> - -- | Other named types whose OIDs are needed for serializing. - -- - -- E.g., when encoding composite types Postgres requires specifying OIDs of all of its fields. - -- - -- When any of the requested types is missing in the database an error will be raised upon the statement execution. - [(Maybe Text, Text)] -> - -- | Serialization function in the context of resolved OIDs of the types requested in the previous parameter. - -- - -- It's safe to assume that all of the requested types will be present. - -- In case you run the provided lookup function with unmentioned type names it will produce OID of 0 for them, standing for unknown type in Postgres. - ( ((Maybe Text, Text) -> (Word32, Word32)) -> - a -> - ByteString - ) -> - -- | Render function for error messages. - (a -> Text) -> - Value a -custom schemaName typeName staticOids requiredTypes encode render = - Value - schemaName - typeName - (fmap fst staticOids) - (fmap snd staticOids) - 0 - False - (HashSet.fromList (fmap Vocab.QualifiedTypeName.fromNameTuple requiredTypes)) - ( \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) - --- | --- Encoder of @HSTORE@ values from a foldable container of key-value pairs. --- --- The value part can be @Nothing@ to represent a NULL value in the hstore. -{-# INLINEABLE hstore #-} -hstore :: (Foldable foldable) => Value (foldable (Text, Maybe Text)) -hstore = - Value - Nothing - "hstore" - Nothing - Nothing - 0 - False - HashSet.empty - (const Binary.hStore_foldable) - renderHstore - where - renderHstore items = - mconcat - [ TextBuilder.text "hstore(", - TextBuilder.intercalate ", " (foldMap (\pair -> [renderPair pair]) items), - TextBuilder.text ")" - ] - renderPair (key, maybeValue) = - mconcat - [ TextBuilder.text "(", - TextBuilder.string (show key), - TextBuilder.text ", ", - case maybeValue of - Nothing -> TextBuilder.text "NULL" - Just value -> TextBuilder.string (show value), - TextBuilder.text ")" - ] diff --git a/src/codecs/Hasql/Codecs/RequestingOid.hs b/src/codecs/Hasql/Codecs/RequestingOid.hs deleted file mode 100644 --- a/src/codecs/Hasql/Codecs/RequestingOid.hs +++ /dev/null @@ -1,67 +0,0 @@ -module Hasql.Codecs.RequestingOid - ( RequestingOid, - toUnknownTypes, - toBase, - requestAndHandle, - lift, - hoist, - lookup, - lookingUp, - hoistLookingUp, - ) -where - -import Hasql.Codecs.RequestingOid.LookingUp qualified as LookingUp -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 - Vocab.QualifiedTypeName - Vocab.TypeInfo.TypeInfo - -{-# INLINE toUnknownTypes #-} -toUnknownTypes :: - RequestingOid a -> - HashSet Vocab.QualifiedTypeName -toUnknownTypes (LookingUp.LookingUp unknownTypes _) = - fromList unknownTypes - -{-# INLINE toBase #-} -toBase :: - RequestingOid a -> - Vocab.OidCache -> - a -toBase (LookingUp.LookingUp _unknownTypes decoder) oidCache = - decoder \key -> - Vocab.OidCache.lookupTypeInfo key oidCache - & fromMaybe (Vocab.TypeInfo.TypeInfo 0 0) - -{-# INLINE requestAndHandle #-} -requestAndHandle :: - [Vocab.QualifiedTypeName] -> - ((Vocab.QualifiedTypeName -> Vocab.TypeInfo.TypeInfo) -> a) -> - RequestingOid a -requestAndHandle keys fn = LookingUp.LookingUp keys fn - -{-# INLINE lift #-} -lift :: a -> RequestingOid a -lift = LookingUp.lift - -{-# INLINE hoist #-} -hoist :: (a -> b) -> RequestingOid a -> RequestingOid b -hoist fn (LookingUp.LookingUp keys use) = LookingUp.LookingUp keys (fn . use) - -{-# INLINE lookup #-} -lookup :: Vocab.QualifiedTypeName -> RequestingOid Vocab.TypeInfo.TypeInfo -lookup = LookingUp.lookup - -{-# INLINE lookingUp #-} -lookingUp :: Vocab.QualifiedTypeName -> (Vocab.TypeInfo.TypeInfo -> a) -> RequestingOid a -lookingUp = LookingUp.lookingUp - -{-# INLINE hoistLookingUp #-} -hoistLookingUp :: Vocab.QualifiedTypeName -> (Vocab.TypeInfo.TypeInfo -> a -> b) -> RequestingOid a -> RequestingOid b -hoistLookingUp = LookingUp.hoistLookingUp diff --git a/src/codecs/Hasql/Codecs/RequestingOid/LookingUp.hs b/src/codecs/Hasql/Codecs/RequestingOid/LookingUp.hs deleted file mode 100644 --- a/src/codecs/Hasql/Codecs/RequestingOid/LookingUp.hs +++ /dev/null @@ -1,45 +0,0 @@ -module Hasql.Codecs.RequestingOid.LookingUp where - -import Control.Applicative -import Prelude - -data LookingUp k v a - = LookingUp - -- | Keys requested to be available for lookup. - [k] - -- | Continuation that looks up values by keys. - ((k -> v) -> a) - -type role LookingUp _ _ representational - -deriving stock instance Functor (LookingUp k v) - -instance Applicative (LookingUp k v) where - {-# INLINE pure #-} - pure a = - LookingUp [] (\_ -> a) - {-# INLINE (<*>) #-} - LookingUp lKeys lUse <*> LookingUp rKeys rUse = - LookingUp - (lKeys <> rKeys) - (\lookup -> lUse lookup (rUse lookup)) - -{-# INLINE lookup #-} -lookup :: k -> LookingUp k v v -lookup key = - LookingUp [key] (\lookupFn -> lookupFn key) - -{-# INLINE lift #-} -lift :: a -> LookingUp k v a -lift fa = - LookingUp [] (const fa) - -{-# INLINE lookingUp #-} -lookingUp :: k -> (v -> a) -> LookingUp k v a -lookingUp key cont = - LookingUp [key] (\lookupFn -> cont (lookupFn key)) - -{-# INLINE hoistLookingUp #-} -hoistLookingUp :: k -> (v -> a -> b) -> LookingUp k v a -> LookingUp k v b -hoistLookingUp k tx (LookingUp keys use) = - LookingUp (k : keys) (\lookupFn -> tx (lookupFn k) (use lookupFn)) diff --git a/src/codecs/Hasql/Codecs/Vocab.hs b/src/codecs/Hasql/Codecs/Vocab.hs deleted file mode 100644 --- a/src/codecs/Hasql/Codecs/Vocab.hs +++ /dev/null @@ -1,14 +0,0 @@ -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/codecs/Hasql/Codecs/Vocab/OidCache.hs b/src/codecs/Hasql/Codecs/Vocab/OidCache.hs deleted file mode 100644 --- a/src/codecs/Hasql/Codecs/Vocab/OidCache.hs +++ /dev/null @@ -1,91 +0,0 @@ -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/codecs/Hasql/Codecs/Vocab/ParamMeta.hs b/src/codecs/Hasql/Codecs/Vocab/ParamMeta.hs deleted file mode 100644 --- a/src/codecs/Hasql/Codecs/Vocab/ParamMeta.hs +++ /dev/null @@ -1,13 +0,0 @@ -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/codecs/Hasql/Codecs/Vocab/QualifiedTypeName.hs b/src/codecs/Hasql/Codecs/Vocab/QualifiedTypeName.hs deleted file mode 100644 --- a/src/codecs/Hasql/Codecs/Vocab/QualifiedTypeName.hs +++ /dev/null @@ -1,43 +0,0 @@ -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/codecs/Hasql/Codecs/Vocab/TypeInfo.hs b/src/codecs/Hasql/Codecs/Vocab/TypeInfo.hs deleted file mode 100644 --- a/src/codecs/Hasql/Codecs/Vocab/TypeInfo.hs +++ /dev/null @@ -1,230 +0,0 @@ -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/codecs/Hasql/Codecs/Vocab/TypeRef.hs b/src/codecs/Hasql/Codecs/Vocab/TypeRef.hs deleted file mode 100644 --- a/src/codecs/Hasql/Codecs/Vocab/TypeRef.hs +++ /dev/null @@ -1,20 +0,0 @@ -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/comms/Hasql/Comms/ResultDecoder.hs b/src/comms/Hasql/Comms/ResultDecoder.hs --- a/src/comms/Hasql/Comms/ResultDecoder.hs +++ b/src/comms/Hasql/Comms/ResultDecoder.hs @@ -158,9 +158,10 @@ checkCompatibility :: RowDecoder.RowDecoder a -> ResultDecoder () checkCompatibility rowDec = let oids = RowDecoder.toExpectedOids rowDec + oidsLength = length oids in ResultDecoder \result -> do maxCols <- Pq.nfields result - if length oids == fromIntegral maxCols + if oidsLength == fromIntegral maxCols then let go [] _ = pure (Right ()) go (Nothing : rest) colIndex = go rest (succ colIndex) @@ -178,7 +179,7 @@ ) ) in go oids 0 - else pure (Left (UnexpectedColumnCount (length oids) (fromIntegral maxCols))) + else pure (Left (UnexpectedColumnCount oidsLength (fromIntegral maxCols))) {-# INLINE maybe #-} maybe :: RowDecoder.RowDecoder a -> ResultDecoder (Maybe a) diff --git a/src/connection-state-tests/Hasql/ConnectionState/OidCacheSpec.hs b/src/connection-state-tests/Hasql/ConnectionState/OidCacheSpec.hs new file mode 100644 --- /dev/null +++ b/src/connection-state-tests/Hasql/ConnectionState/OidCacheSpec.hs @@ -0,0 +1,114 @@ +module Hasql.ConnectionState.OidCacheSpec (spec) where + +import CodecVocab.QualifiedTypeName qualified as CodecVocab.QualifiedTypeName +import CodecVocab.TypeInfo qualified as CodecVocab.TypeInfo +import Data.HashMap.Strict qualified as HashMap +import Data.HashSet qualified as HashSet +import Hasql.ConnectionState.OidCache qualified as OidCache +import Prelude +import Test.Hspec + +int4Key :: CodecVocab.QualifiedTypeName.QualifiedTypeName +int4Key = CodecVocab.QualifiedTypeName.QualifiedTypeName Nothing "int4" + +int8Key :: CodecVocab.QualifiedTypeName.QualifiedTypeName +int8Key = CodecVocab.QualifiedTypeName.QualifiedTypeName Nothing "int8" + +spec :: Spec +spec = do + describe "empty" do + it "returns Nothing on lookup" do + OidCache.lookupTypeInfo int4Key OidCache.empty + `shouldBe` Nothing + + describe "fromHashMap and lookupTypeInfo" do + it "can look up an inserted type" do + let cache = OidCache.fromHashMap (HashMap.singleton int4Key (CodecVocab.TypeInfo.TypeInfo 23 1007)) + OidCache.lookupTypeInfo int4Key cache + `shouldBe` Just (CodecVocab.TypeInfo.TypeInfo 23 1007) + + it "returns Nothing for a non-inserted type" do + let cache = OidCache.fromHashMap (HashMap.singleton int4Key (CodecVocab.TypeInfo.TypeInfo 23 1007)) + OidCache.lookupTypeInfo int8Key cache + `shouldBe` Nothing + + it "handles schema-qualified names" do + let key = CodecVocab.QualifiedTypeName.QualifiedTypeName (Just "public") "my_type" + cache = OidCache.fromHashMap (HashMap.singleton key (CodecVocab.TypeInfo.TypeInfo 100 200)) + OidCache.lookupTypeInfo key cache + `shouldBe` Just (CodecVocab.TypeInfo.TypeInfo 100 200) + OidCache.lookupTypeInfo (CodecVocab.QualifiedTypeName.QualifiedTypeName Nothing "my_type") cache + `shouldBe` Nothing + + it "distinguishes same type name in different schemas" do + let keyA = CodecVocab.QualifiedTypeName.QualifiedTypeName (Just "schema_a") "my_type" + keyB = CodecVocab.QualifiedTypeName.QualifiedTypeName (Just "schema_b") "my_type" + cache = OidCache.fromHashMap (HashMap.fromList [(keyA, CodecVocab.TypeInfo.TypeInfo 100 200), (keyB, CodecVocab.TypeInfo.TypeInfo 300 400)]) + OidCache.lookupTypeInfo keyA cache + `shouldBe` Just (CodecVocab.TypeInfo.TypeInfo 100 200) + OidCache.lookupTypeInfo keyB cache + `shouldBe` Just (CodecVocab.TypeInfo.TypeInfo 300 400) + + describe "selectUnknownNames" do + it "returns all names when cache is empty" do + let names = HashSet.fromList [int4Key, int8Key] + OidCache.selectUnknownNames names OidCache.empty + `shouldBe` names + + it "returns empty when all names are known" do + let cache = OidCache.fromHashMap (HashMap.fromList [(int4Key, CodecVocab.TypeInfo.TypeInfo 23 1007), (int8Key, CodecVocab.TypeInfo.TypeInfo 20 1016)]) + names = HashSet.fromList [int4Key, int8Key] + OidCache.selectUnknownNames names cache + `shouldBe` HashSet.empty + + it "returns only unknown names" do + let cache = OidCache.fromHashMap (HashMap.singleton int4Key (CodecVocab.TypeInfo.TypeInfo 23 1007)) + names = HashSet.fromList [int4Key, int8Key] + OidCache.selectUnknownNames names cache + `shouldBe` HashSet.fromList [int8Key] + + describe "toResolver" do + it "resolves a known type" do + let cache = OidCache.fromHashMap (HashMap.singleton int4Key (CodecVocab.TypeInfo.TypeInfo 23 1007)) + OidCache.toResolver cache int4Key + `shouldBe` CodecVocab.TypeInfo.TypeInfo 23 1007 + + it "falls back to invalid for an unknown type" do + OidCache.toResolver OidCache.empty int4Key + `shouldBe` CodecVocab.TypeInfo.invalid + + describe "Semigroup" do + it "right operand takes precedence for duplicate keys" do + let cacheA = OidCache.fromHashMap (HashMap.singleton int4Key (CodecVocab.TypeInfo.TypeInfo 23 1007)) + cacheB = OidCache.fromHashMap (HashMap.singleton int4Key (CodecVocab.TypeInfo.TypeInfo 99 999)) + merged = cacheA <> cacheB + OidCache.lookupTypeInfo int4Key merged + `shouldBe` Just (CodecVocab.TypeInfo.TypeInfo 99 999) + + it "preserves entries from both sides when no conflict" do + let cacheA = OidCache.fromHashMap (HashMap.singleton int4Key (CodecVocab.TypeInfo.TypeInfo 23 1007)) + cacheB = OidCache.fromHashMap (HashMap.singleton int8Key (CodecVocab.TypeInfo.TypeInfo 20 1016)) + merged = cacheA <> cacheB + OidCache.lookupTypeInfo int4Key merged + `shouldBe` Just (CodecVocab.TypeInfo.TypeInfo 23 1007) + OidCache.lookupTypeInfo int8Key merged + `shouldBe` Just (CodecVocab.TypeInfo.TypeInfo 20 1016) + + it "is associative" do + let a = OidCache.fromHashMap (HashMap.singleton "t1" (CodecVocab.TypeInfo.TypeInfo 1 2)) + b = OidCache.fromHashMap (HashMap.fromList [("t1", CodecVocab.TypeInfo.TypeInfo 3 4), ("t2", CodecVocab.TypeInfo.TypeInfo 5 6)]) + c = OidCache.fromHashMap (HashMap.fromList [("t2", CodecVocab.TypeInfo.TypeInfo 7 8), ("t3", CodecVocab.TypeInfo.TypeInfo 9 10)]) + (a <> b) <> c + `shouldBe` a <> (b <> c) + + describe "Monoid" do + it "mempty is identity for Semigroup" do + let cache = OidCache.fromHashMap (HashMap.singleton int4Key (CodecVocab.TypeInfo.TypeInfo 23 1007)) + cache <> mempty + `shouldBe` cache + mempty <> cache + `shouldBe` cache + + it "empty equals mempty" do + OidCache.empty + `shouldBe` mempty diff --git a/src/connection-state-tests/Hasql/ConnectionState/StatementCacheSpec.hs b/src/connection-state-tests/Hasql/ConnectionState/StatementCacheSpec.hs new file mode 100644 --- /dev/null +++ b/src/connection-state-tests/Hasql/ConnectionState/StatementCacheSpec.hs @@ -0,0 +1,93 @@ +module Hasql.ConnectionState.StatementCacheSpec (spec) where + +import Data.Maybe +import Hasql.ConnectionState.StatementCache qualified as StatementCache +import Test.Hspec + +spec :: Spec +spec = do + describe "empty" do + it "returns Nothing on lookup" do + StatementCache.lookup "SELECT 1" [] StatementCache.empty + `shouldBe` Nothing + + describe "insert and lookup" do + it "can insert and retrieve a statement" do + let (remoteKey, cache) = StatementCache.insert "SELECT 1" [] StatementCache.empty + StatementCache.lookup "SELECT 1" [] cache + `shouldBe` Just remoteKey + + it "generates unique remote keys for different SQL" do + let (key1, cache1) = StatementCache.insert "SELECT 1" [] StatementCache.empty + (key2, _cache2) = StatementCache.insert "SELECT 2" [] cache1 + key1 `shouldNotBe` key2 + + it "generates unique remote keys for same SQL with different OIDs" do + let oid23 = 23 + oid25 = 25 + (key1, cache1) = StatementCache.insert "SELECT $1" [oid23] StatementCache.empty + (key2, _cache2) = StatementCache.insert "SELECT $1" [oid25] cache1 + key1 `shouldNotBe` key2 + + it "distinguishes statements with same SQL but different OIDs" do + let oid23 = 23 + oid25 = 25 + (_key1, cache1) = StatementCache.insert "SELECT $1" [oid23] StatementCache.empty + (_key2, cache2) = StatementCache.insert "SELECT $1" [oid25] cache1 + -- Both should be findable + StatementCache.lookup "SELECT $1" [oid23] cache2 + `shouldSatisfy` isJust + StatementCache.lookup "SELECT $1" [oid25] cache2 + `shouldSatisfy` isJust + -- And should have different remote keys + let rk1 = StatementCache.lookup "SELECT $1" [oid23] cache2 + rk2 = StatementCache.lookup "SELECT $1" [oid25] cache2 + rk1 `shouldNotBe` rk2 + + it "returns Nothing for a non-inserted SQL" do + let (_key, cache) = StatementCache.insert "SELECT 1" [] StatementCache.empty + StatementCache.lookup "SELECT 2" [] cache + `shouldBe` Nothing + + it "returns Nothing for matching SQL but different OIDs" do + let oid23 = 23 + oid25 = 25 + (_key, cache) = StatementCache.insert "SELECT $1" [oid23] StatementCache.empty + StatementCache.lookup "SELECT $1" [oid25] cache + `shouldBe` Nothing + + it "handles empty OID list" do + let (key, cache) = StatementCache.insert "SELECT 1" [] StatementCache.empty + StatementCache.lookup "SELECT 1" [] cache + `shouldBe` Just key + + it "handles multiple OIDs" do + let oids = [23, 25, 1043] + (key, cache) = StatementCache.insert "SELECT $1, $2, $3" oids StatementCache.empty + StatementCache.lookup "SELECT $1, $2, $3" oids cache + `shouldBe` Just key + + it "distinguishes different OID ordering" do + let oidsA = [23, 25] + oidsB = [25, 23] + (_keyA, cache1) = StatementCache.insert "SELECT $1, $2" oidsA StatementCache.empty + (_keyB, cache2) = StatementCache.insert "SELECT $1, $2" oidsB cache1 + StatementCache.lookup "SELECT $1, $2" oidsA cache2 + `shouldSatisfy` isJust + StatementCache.lookup "SELECT $1, $2" oidsB cache2 + `shouldSatisfy` isJust + let rkA = StatementCache.lookup "SELECT $1, $2" oidsA cache2 + rkB = StatementCache.lookup "SELECT $1, $2" oidsB cache2 + rkA `shouldNotBe` rkB + + describe "reset" do + it "clears all cached statements" do + let (_key, cache) = StatementCache.insert "SELECT 1" [] StatementCache.empty + resetCache = StatementCache.reset cache + StatementCache.lookup "SELECT 1" [] resetCache + `shouldBe` Nothing + + it "results in a cache equal to empty" do + let (_key, cache) = StatementCache.insert "SELECT 1" [] StatementCache.empty + StatementCache.reset cache + `shouldBe` StatementCache.empty diff --git a/src/connection-state-tests/Main.hs b/src/connection-state-tests/Main.hs new file mode 100644 --- /dev/null +++ b/src/connection-state-tests/Main.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/src/connection-state/Hasql/ConnectionState.hs b/src/connection-state/Hasql/ConnectionState.hs new file mode 100644 --- /dev/null +++ b/src/connection-state/Hasql/ConnectionState.hs @@ -0,0 +1,98 @@ +-- | +-- This module defines the internal state of a database connection. +module Hasql.ConnectionState + ( ConnectionState (..), + toStatementCache, + fromConnection, + setPreparedStatements, + setStatementCache, + setConnection, + setOidCache, + mapStatementCache, + mapOidCache, + traverseStatementCache, + resetPreparedStatementsCache, + ) +where + +import Hasql.ConnectionState.OidCache qualified as OidCache +import Hasql.ConnectionState.StatementCache qualified as StatementCache +import Hasql.Platform.Prelude +import Pqi qualified as Pq + +-- | +-- The internal state of a database connection. +data ConnectionState = ConnectionState + { -- | Whether prepared statements are enabled. + preparedStatements :: Bool, + -- | The statement cache for prepared statements. + statementCache :: StatementCache.StatementCache, + -- | The OID cache for type name to OID mapping. + oidCache :: OidCache.OidCache, + -- | The underlying database connection. + connection :: Pq.Connection + } + +toStatementCache :: ConnectionState -> StatementCache.StatementCache +toStatementCache ConnectionState {..} = statementCache + +fromConnection :: Pq.Connection -> ConnectionState +fromConnection connection = + ConnectionState + { preparedStatements = False, + statementCache = StatementCache.empty, + oidCache = OidCache.empty, + connection = connection + } + +setPreparedStatements :: Bool -> ConnectionState -> ConnectionState +setPreparedStatements preparedStatements connectionState = + connectionState {preparedStatements = preparedStatements} + +setStatementCache :: StatementCache.StatementCache -> ConnectionState -> ConnectionState +setStatementCache statementCache connectionState = + connectionState {statementCache = statementCache} + +setConnection :: Pq.Connection -> ConnectionState -> ConnectionState +setConnection connection connectionState = + connectionState {connection = connection} + +setOidCache :: OidCache.OidCache -> ConnectionState -> ConnectionState +setOidCache oidCache connectionState = + connectionState {oidCache} + +mapStatementCache :: + (StatementCache.StatementCache -> StatementCache.StatementCache) -> + (ConnectionState -> ConnectionState) +mapStatementCache f ConnectionState {..} = + ConnectionState + { statementCache = f statementCache, + .. + } + +mapOidCache :: + (OidCache.OidCache -> OidCache.OidCache) -> + (ConnectionState -> ConnectionState) +mapOidCache f ConnectionState {..} = + ConnectionState + { oidCache = f oidCache, + .. + } + +traverseStatementCache :: + (Functor f) => + (StatementCache.StatementCache -> f StatementCache.StatementCache) -> + (ConnectionState -> f ConnectionState) +traverseStatementCache f ConnectionState {..} = + fmap + ( \newStatementCache -> + ConnectionState + { statementCache = newStatementCache, + .. + } + ) + (f statementCache) + +resetPreparedStatementsCache :: ConnectionState -> ConnectionState +resetPreparedStatementsCache = + mapStatementCache (const StatementCache.empty) diff --git a/src/connection-state/Hasql/ConnectionState/OidCache.hs b/src/connection-state/Hasql/ConnectionState/OidCache.hs new file mode 100644 --- /dev/null +++ b/src/connection-state/Hasql/ConnectionState/OidCache.hs @@ -0,0 +1,63 @@ +module Hasql.ConnectionState.OidCache + ( OidCache, + + -- * Accessors + lookupTypeInfo, + toResolver, + + -- * Constructors + fromHashMap, + empty, + selectUnknownNames, + ) +where + +import CodecVocab qualified as CodecVocab +import CodecVocab.TypeInfo qualified as CodecVocab.TypeInfo +import Data.HashMap.Strict qualified as HashMap +import Data.HashSet qualified as HashSet +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 CodecVocab.QualifiedTypeName CodecVocab.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 CodecVocab.QualifiedTypeName -> OidCache -> HashSet CodecVocab.QualifiedTypeName +selectUnknownNames keys (OidCache byName) = + HashSet.filter (\key -> not (HashMap.member key byName)) keys + +{-# INLINE fromHashMap #-} +fromHashMap :: HashMap CodecVocab.QualifiedTypeName CodecVocab.TypeInfo -> OidCache +fromHashMap byName = OidCache byName + +-- * Accessors + +{-# INLINE lookupTypeInfo #-} +lookupTypeInfo :: CodecVocab.QualifiedTypeName -> OidCache -> Maybe CodecVocab.TypeInfo +lookupTypeInfo name (OidCache byName) = + HashMap.lookup name byName + +-- | Resolution function for a name against the cache, falling back to 'TypeInfo.invalid' on a miss. +{-# INLINE toResolver #-} +toResolver :: OidCache -> CodecVocab.QualifiedTypeName -> CodecVocab.TypeInfo +toResolver oidCache name = + lookupTypeInfo name oidCache & fromMaybe CodecVocab.TypeInfo.invalid diff --git a/src/connection-state/Hasql/ConnectionState/StatementCache.hs b/src/connection-state/Hasql/ConnectionState/StatementCache.hs new file mode 100644 --- /dev/null +++ b/src/connection-state/Hasql/ConnectionState/StatementCache.hs @@ -0,0 +1,55 @@ +module Hasql.ConnectionState.StatementCache + ( -- * Pure registry operations + StatementCache, + empty, + lookup, + insert, + reset, + ) +where + +import Data.HashMap.Strict qualified as HashMap +import Hasql.Platform.Prelude hiding (empty, insert, lookup, reset) + +-- | Pure registry state containing the hash map and counter +data StatementCache = StatementCache (HashMap LocalKey ByteString) Word + deriving stock (Show, Eq) + +-- | Create an empty registry state +{-# INLINEABLE empty #-} +empty :: StatementCache +empty = StatementCache HashMap.empty 0 + +-- | Pure lookup operation +{-# INLINEABLE lookup #-} +lookup :: ByteString -> [Word32] -> StatementCache -> Maybe ByteString +lookup sql oids (StatementCache hashMap _) = HashMap.lookup localKey hashMap + where + localKey = LocalKey sql oids + +-- | Pure insert operation that returns new state and the generated remote key +{-# INLINEABLE insert #-} +insert :: ByteString -> [Word32] -> StatementCache -> (ByteString, StatementCache) +insert sql oids (StatementCache hashMap counter) = (remoteKey, newState) + where + remoteKey = fromString $ show $ newCounter + newHashMap = HashMap.insert localKey remoteKey hashMap + newCounter = counter + 1 + newState = StatementCache newHashMap newCounter + localKey = LocalKey sql oids + +-- | Pure reset operation +{-# INLINEABLE reset #-} +reset :: StatementCache -> StatementCache +reset _ = StatementCache HashMap.empty 0 + +-- | +-- Local statement key. +data LocalKey + = LocalKey ByteString [Word32] + deriving (Show, Eq) + +instance Hashable LocalKey where + {-# INLINE hashWithSalt #-} + hashWithSalt salt (LocalKey template oids) = + hashWithSalt (hashWithSalt salt template) oids diff --git a/src/engine-tests/Hasql/Engine/Structures/OidCacheSpec.hs b/src/engine-tests/Hasql/Engine/Structures/OidCacheSpec.hs deleted file mode 100644 --- a/src/engine-tests/Hasql/Engine/Structures/OidCacheSpec.hs +++ /dev/null @@ -1,116 +0,0 @@ -module Hasql.Engine.Structures.OidCacheSpec (spec) where - -import Data.HashSet qualified as HashSet -import Hasql.Codecs.Vocab.OidCache qualified as OidCache -import Hasql.Codecs.Vocab.QualifiedTypeName qualified as Vocab.QualifiedTypeName -import Prelude -import Test.Hspec - -spec :: Spec -spec = do - describe "empty" do - it "returns Nothing on scalar lookup" do - OidCache.lookupScalar Nothing "int4" OidCache.empty - `shouldBe` Nothing - - it "returns Nothing on array lookup" do - OidCache.lookupArray Nothing "int4" OidCache.empty - `shouldBe` Nothing - - describe "insertScalar and lookup" do - it "can insert and lookup a scalar OID" do - let cache = OidCache.insertScalar Nothing "int4" 23 1007 OidCache.empty - OidCache.lookupScalar Nothing "int4" cache - `shouldBe` Just 23 - - it "can insert and lookup an array OID" do - let cache = OidCache.insertScalar Nothing "int4" 23 1007 OidCache.empty - OidCache.lookupArray Nothing "int4" cache - `shouldBe` Just 1007 - - it "returns Nothing for a non-inserted type" do - let cache = OidCache.insertScalar Nothing "int4" 23 1007 OidCache.empty - OidCache.lookupScalar Nothing "int8" cache - `shouldBe` Nothing - - it "handles schema-qualified names" do - let cache = OidCache.insertScalar (Just "public") "my_type" 100 200 OidCache.empty - OidCache.lookupScalar (Just "public") "my_type" cache - `shouldBe` Just 100 - OidCache.lookupScalar Nothing "my_type" cache - `shouldBe` Nothing - - it "distinguishes same type name in different schemas" do - let cache = - OidCache.insertScalar - (Just "schema_a") - "my_type" - 100 - 200 - (OidCache.insertScalar (Just "schema_b") "my_type" 300 400 OidCache.empty) - OidCache.lookupScalar (Just "schema_a") "my_type" cache - `shouldBe` Just 100 - OidCache.lookupScalar (Just "schema_b") "my_type" cache - `shouldBe` Just 300 - - describe "selectUnknownNames" do - it "returns all names when cache is empty" do - let names = HashSet.fromList [Vocab.QualifiedTypeName.QualifiedTypeName Nothing "int4", Vocab.QualifiedTypeName.QualifiedTypeName Nothing "int8"] - OidCache.selectUnknownNames names OidCache.empty - `shouldBe` names - - it "returns empty when all names are known" do - let cache = - OidCache.insertScalar - Nothing - "int4" - 23 - 1007 - (OidCache.insertScalar Nothing "int8" 20 1016 OidCache.empty) - names = HashSet.fromList [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 [Vocab.QualifiedTypeName.QualifiedTypeName Nothing "int4", Vocab.QualifiedTypeName.QualifiedTypeName Nothing "int8"] - OidCache.selectUnknownNames names cache - `shouldBe` HashSet.fromList [Vocab.QualifiedTypeName.QualifiedTypeName Nothing "int8"] - - describe "Semigroup" do - it "right operand takes precedence for duplicate keys" do - let cacheA = OidCache.insertScalar Nothing "int4" 23 1007 OidCache.empty - cacheB = OidCache.insertScalar Nothing "int4" 99 999 OidCache.empty - merged = cacheA <> cacheB - OidCache.lookupScalar Nothing "int4" merged - `shouldBe` Just 99 - OidCache.lookupArray Nothing "int4" merged - `shouldBe` Just 999 - - it "preserves entries from both sides when no conflict" do - let cacheA = OidCache.insertScalar Nothing "int4" 23 1007 OidCache.empty - cacheB = OidCache.insertScalar Nothing "int8" 20 1016 OidCache.empty - merged = cacheA <> cacheB - OidCache.lookupScalar Nothing "int4" merged - `shouldBe` Just 23 - OidCache.lookupScalar Nothing "int8" merged - `shouldBe` Just 20 - - it "is associative" do - let a = OidCache.insertScalar Nothing "t1" 1 2 OidCache.empty - b = OidCache.insertScalar Nothing "t1" 3 4 (OidCache.insertScalar Nothing "t2" 5 6 OidCache.empty) - c = OidCache.insertScalar Nothing "t2" 7 8 (OidCache.insertScalar Nothing "t3" 9 10 OidCache.empty) - OidCache.toHashMap ((a <> b) <> c) - `shouldBe` OidCache.toHashMap (a <> (b <> c)) - - describe "Monoid" do - it "mempty is identity for Semigroup" do - let cache = OidCache.insertScalar Nothing "int4" 23 1007 OidCache.empty - OidCache.toHashMap (cache <> mempty) - `shouldBe` OidCache.toHashMap cache - OidCache.toHashMap (mempty <> cache) - `shouldBe` OidCache.toHashMap cache - - it "empty equals mempty" do - OidCache.toHashMap OidCache.empty - `shouldBe` OidCache.toHashMap mempty diff --git a/src/engine-tests/Hasql/Engine/Structures/StatementCacheSpec.hs b/src/engine-tests/Hasql/Engine/Structures/StatementCacheSpec.hs deleted file mode 100644 --- a/src/engine-tests/Hasql/Engine/Structures/StatementCacheSpec.hs +++ /dev/null @@ -1,93 +0,0 @@ -module Hasql.Engine.Structures.StatementCacheSpec (spec) where - -import Data.Maybe -import Hasql.Engine.Structures.StatementCache qualified as StatementCache -import Test.Hspec - -spec :: Spec -spec = do - describe "empty" do - it "returns Nothing on lookup" do - StatementCache.lookup "SELECT 1" [] StatementCache.empty - `shouldBe` Nothing - - describe "insert and lookup" do - it "can insert and retrieve a statement" do - let (remoteKey, cache) = StatementCache.insert "SELECT 1" [] StatementCache.empty - StatementCache.lookup "SELECT 1" [] cache - `shouldBe` Just remoteKey - - it "generates unique remote keys for different SQL" do - let (key1, cache1) = StatementCache.insert "SELECT 1" [] StatementCache.empty - (key2, _cache2) = StatementCache.insert "SELECT 2" [] cache1 - key1 `shouldNotBe` key2 - - it "generates unique remote keys for same SQL with different OIDs" do - let oid23 = 23 - oid25 = 25 - (key1, cache1) = StatementCache.insert "SELECT $1" [oid23] StatementCache.empty - (key2, _cache2) = StatementCache.insert "SELECT $1" [oid25] cache1 - key1 `shouldNotBe` key2 - - it "distinguishes statements with same SQL but different OIDs" do - let oid23 = 23 - oid25 = 25 - (_key1, cache1) = StatementCache.insert "SELECT $1" [oid23] StatementCache.empty - (_key2, cache2) = StatementCache.insert "SELECT $1" [oid25] cache1 - -- Both should be findable - StatementCache.lookup "SELECT $1" [oid23] cache2 - `shouldSatisfy` isJust - StatementCache.lookup "SELECT $1" [oid25] cache2 - `shouldSatisfy` isJust - -- And should have different remote keys - let rk1 = StatementCache.lookup "SELECT $1" [oid23] cache2 - rk2 = StatementCache.lookup "SELECT $1" [oid25] cache2 - rk1 `shouldNotBe` rk2 - - it "returns Nothing for a non-inserted SQL" do - let (_key, cache) = StatementCache.insert "SELECT 1" [] StatementCache.empty - StatementCache.lookup "SELECT 2" [] cache - `shouldBe` Nothing - - it "returns Nothing for matching SQL but different OIDs" do - let oid23 = 23 - oid25 = 25 - (_key, cache) = StatementCache.insert "SELECT $1" [oid23] StatementCache.empty - StatementCache.lookup "SELECT $1" [oid25] cache - `shouldBe` Nothing - - it "handles empty OID list" do - let (key, cache) = StatementCache.insert "SELECT 1" [] StatementCache.empty - StatementCache.lookup "SELECT 1" [] cache - `shouldBe` Just key - - it "handles multiple OIDs" do - let oids = [23, 25, 1043] - (key, cache) = StatementCache.insert "SELECT $1, $2, $3" oids StatementCache.empty - StatementCache.lookup "SELECT $1, $2, $3" oids cache - `shouldBe` Just key - - it "distinguishes different OID ordering" do - let oidsA = [23, 25] - oidsB = [25, 23] - (_keyA, cache1) = StatementCache.insert "SELECT $1, $2" oidsA StatementCache.empty - (_keyB, cache2) = StatementCache.insert "SELECT $1, $2" oidsB cache1 - StatementCache.lookup "SELECT $1, $2" oidsA cache2 - `shouldSatisfy` isJust - StatementCache.lookup "SELECT $1, $2" oidsB cache2 - `shouldSatisfy` isJust - let rkA = StatementCache.lookup "SELECT $1, $2" oidsA cache2 - rkB = StatementCache.lookup "SELECT $1, $2" oidsB cache2 - rkA `shouldNotBe` rkB - - describe "reset" do - it "clears all cached statements" do - let (_key, cache) = StatementCache.insert "SELECT 1" [] StatementCache.empty - resetCache = StatementCache.reset cache - StatementCache.lookup "SELECT 1" [] resetCache - `shouldBe` Nothing - - it "results in a cache equal to empty" do - let (_key, cache) = StatementCache.insert "SELECT 1" [] StatementCache.empty - StatementCache.reset cache - `shouldBe` StatementCache.empty diff --git a/src/engine-tests/Main.hs b/src/engine-tests/Main.hs deleted file mode 100644 --- a/src/engine-tests/Main.hs +++ /dev/null @@ -1,1 +0,0 @@ -{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/src/engine/Hasql/Engine/Contexts/Pipeline.hs b/src/engine/Hasql/Engine/Contexts/Pipeline.hs deleted file mode 100644 --- a/src/engine/Hasql/Engine/Contexts/Pipeline.hs +++ /dev/null @@ -1,265 +0,0 @@ -module Hasql.Engine.Contexts.Pipeline - ( Pipeline, - run, - statement, - ) -where - -import Data.HashMap.Strict qualified as HashMap -import Data.HashSet qualified as HashSet -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.Errors qualified as Errors -import Hasql.Engine.PqProcedures.SelectTypeInfo qualified as PqProcedures.SelectTypeInfo -import Hasql.Engine.Statement qualified as Statement -import Hasql.Engine.Structures.StatementCache qualified as StatementCache -import Hasql.Platform.Prelude -import Pqi qualified as Pq - -run :: - Pipeline a -> - Bool -> - Pq.Connection -> - OidCache.OidCache -> - StatementCache.StatementCache -> - IO - ( Either Errors.SessionError a, - OidCache.OidCache, - StatementCache.StatementCache - ) -run (Pipeline totalStatements unknownTypes runPipeline) usePreparedStatements connection oidCache statementCache = do - let missingTypes = OidCache.selectUnknownNames unknownTypes oidCache - resolvedOidCache <- - if HashSet.null missingTypes - then pure (Right oidCache) - else do - oidCacheUpdates <- - PqProcedures.SelectTypeInfo.run connection (PqProcedures.SelectTypeInfo.SelectTypeInfo missingTypes) - pure $ case oidCacheUpdates of - Left err -> Left err - Right oidCacheUpdates -> - let foundTypes = HashMap.keysSet oidCacheUpdates - notFoundTypes = HashSet.difference missingTypes foundTypes - in if not (HashSet.null notFoundTypes) - then Left (Errors.MissingTypesSessionError (HashSet.map 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 newOidCache statementCache - contextualRoundtrip = first Just roundtrip - - executionResult <- Comms.Roundtrip.toPipelineIO contextualRoundtrip Nothing connection - - let result = - first - ( \case - Comms.Roundtrip.ClientError _context details -> - Errors.ConnectionSessionError (maybe "" decodeUtf8Lenient details) - Comms.Roundtrip.ServerError recvError -> - Errors.fromRecvError (fmap (fmap (\(Context index sql params prepared _) -> (totalStatements, index, sql, params, prepared))) recvError) - ) - executionResult - finalStatementCache = - case executionResult of - Right _ -> newStatementCache - Left executionError -> - maybe - statementCache - (\(Context _ _ _ _ statementCache) -> statementCache) - (extract executionError) - - pure (result, newOidCache, finalStatementCache) - --- | --- Composable abstraction over the execution of queries in [the pipeline mode](https://www.postgresql.org/docs/current/libpq-pipeline-mode.html). --- --- It allows you to issue multiple queries to the server in much fewer network transactions. --- If the amounts of sent and received data do not surpass the buffer sizes in the driver and on the server it will be just a single roundtrip. --- Typically the buffer size is 8KB. --- --- This execution mode is much more efficient than running queries directly from 'Hasql.Session.Session', because in session every statement execution involves a dedicated network roundtrip. --- --- An obvious question rises then: why not execute all queries like that? --- In situations where the parameters depend on the result of another query it is impossible to execute them in parallel, because the client needs to receive the results of one query before sending the request to execute the next. --- This reasoning is essentially the same as the one for the difference between 'Applicative' and 'Monad'. --- That's why 'Pipeline' does not have the 'Monad' instance. --- --- To execute 'Pipeline' lift it into 'Hasql.Session.Session' via 'Hasql.Session.pipeline'. --- --- == Examples --- --- === Insert-Many or Batch-Insert --- --- You can use pipeline to turn a single-row insert query into an efficient multi-row insertion session. --- In effect this should be comparable in performance to issuing a single multi-row insert statement. --- --- Given the following definition in a Statements module: --- --- @ --- insertOrder :: 'Hasql.Statement.Statement' OrderDetails OrderId --- @ --- --- You can lift it into the following session --- --- @ --- insertOrders :: [OrderDetails] -> 'Hasql.Session.Session' [OrderId] --- insertOrders orders = --- 'Hasql.Session.pipeline' $ --- for orders $ \order -> --- 'Hasql.Pipeline.statement' order Statements.insertOrder --- @ --- --- === Combining Queries --- --- Given the following definitions in a Statements module: --- --- @ --- selectOrderDetails :: 'Hasql.Statement.Statement' OrderId (Maybe OrderDetails) --- selectOrderProducts :: 'Hasql.Statement.Statement' OrderId [OrderProduct] --- selectOrderFinancialTransactions :: 'Hasql.Statement.Statement' OrderId [FinancialTransaction] --- @ --- --- You can combine them into a session using the `ApplicativeDo` extension as follows: --- --- @ --- selectEverythingAboutOrder :: OrderId -> 'Hasql.Session.Session' (Maybe OrderDetails, [OrderProduct], [FinancialTransaction]) --- selectEverythingAboutOrder orderId = --- 'Hasql.Session.pipeline' $ do --- details <- 'Hasql.Pipeline.statement' orderId Statements.selectOrderDetails --- products <- 'Hasql.Pipeline.statement' orderId Statements.selectOrderProducts --- transactions <- 'Hasql.Pipeline.statement' orderId Statements.selectOrderFinancialTransactions --- pure (details, products, transactions) --- @ -data Pipeline a - = Pipeline - -- | Amount of statements in this pipeline. - Int - -- | Names of types that are used in this pipeline. - -- - -- They will be used to pre-resolve type OIDs before running the pipeline providing them in OidCache. - -- 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 OID 0 for unknown types as a fallback in case of bugs. - (HashSet Vocab.QualifiedTypeName) - -- | Function that runs the pipeline. - -- - -- The integer parameter indicates the current offset of the statement in the pipeline (0-based). - -- - -- The boolean parameter indicates whether preparable statements should be prepared. - -- - -- OidCache is provided in which the names of types used in this pipeline are already resolved. - -- - -- The function takes the current statement cache and returns a tuple of: - -- 1. The actual roundtrip action to be executed in the pipeline. - -- 2. The updated statement cache after composing this part of the pipeline. - -- - -- The resulting cache is optimistic: on failure we recover the last known - -- committed cache from statement contexts carried by roundtrip errors. - ( Int -> - Bool -> - OidCache.OidCache -> - StatementCache.StatementCache -> - (Comms.Roundtrip.Roundtrip Context a, StatementCache.StatementCache) - ) - -data Context - = Context - -- | Offset of the statement in the pipeline (0-based). - Int - -- | SQL. - ByteString - -- | Parameters in a human-readable form. - [Text] - -- | Whether the statement is prepared. - Bool - -- | The so far successfully updated statement cache. - StatementCache.StatementCache - deriving stock (Show, Eq) - --- * Instances - -instance Functor Pipeline where - fmap f (Pipeline count unknownTypes run) = Pipeline count unknownTypes \offset usePreparedStatements oidCache cache -> - let (roundtrip, newStatementCache) = run offset usePreparedStatements oidCache cache - in (fmap f roundtrip, newStatementCache) - -instance Applicative Pipeline where - pure a = - Pipeline 0 mempty (\_ _ _ cache -> (pure a, cache)) - - Pipeline lCount leftUnknownTypes lRun <*> Pipeline rCount rightUnknownTypes rRun = - let unknownTypes = leftUnknownTypes <> rightUnknownTypes - in Pipeline (lCount + rCount) unknownTypes \offset usePreparedStatements oidCache statementCache -> - let (lRoundtrip, statementCache1) = lRun offset usePreparedStatements oidCache statementCache - offset1 = offset + lCount - (rRoundtrip, statementCache2) = rRun offset1 usePreparedStatements oidCache statementCache1 - in (lRoundtrip <*> rRoundtrip, statementCache2) - --- * Construction - --- | --- Execute a statement in pipelining mode. -statement :: - Statement.Statement params result -> - params -> - Pipeline result -statement stmt params = - Pipeline 1 (Statement.unknownTypes stmt) run - where - sql = Statement.sql stmt - run offset usePreparedStatements oidCache = - if prepare - then runPrepared - else runUnprepared - where - (oidList, valueAndFormatList) = - Statement.compilePreparedStatementData stmt oidCache params - - prepare = - usePreparedStatements && Statement.isPrepared stmt - - context soFarStatementCache = - Context - offset - sql - (Statement.printer stmt params) - prepare - soFarStatementCache - - runPrepared statementCache = - (roundtrip, newStatementCache) - where - (isNew, remoteKey, newStatementCache) = - case StatementCache.lookup sql oidList statementCache of - Just remoteKey -> (False, remoteKey, statementCache) - Nothing -> - let (remoteKey, newStatementCache) = StatementCache.insert sql oidList statementCache - in (True, remoteKey, newStatementCache) - - roundtrip = - when - isNew - (Comms.Roundtrip.prepare (context statementCache) remoteKey sql oidList) - *> Comms.Roundtrip.queryPrepared (context newStatementCache) remoteKey encodedParams Pq.Binary decoder' - where - encodedParams = - valueAndFormatList - & fmap (fmap (\(bytes, format) -> (bytes, bool Pq.Binary Pq.Text format))) - - runUnprepared statementCache = - (roundtrip, statementCache) - where - roundtrip = - Comms.Roundtrip.queryParams (context statementCache) sql encodedParams Pq.Binary decoder' - where - encodedParams = - Statement.compileUnpreparedStatementData stmt oidCache params - & fmap (fmap (\(oid, bytes, format) -> (oid, bytes, bool Pq.Binary Pq.Text format))) - - decoder' = - RequestingOid.toBase (Statement.decoder stmt) oidCache diff --git a/src/engine/Hasql/Engine/Contexts/Session.hs b/src/engine/Hasql/Engine/Contexts/Session.hs deleted file mode 100644 --- a/src/engine/Hasql/Engine/Contexts/Session.hs +++ /dev/null @@ -1,207 +0,0 @@ -module Hasql.Engine.Contexts.Session where - -import Data.HashMap.Strict qualified as HashMap -import Data.HashSet qualified as HashSet -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.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.StatementCache qualified as StatementCache -import Hasql.Platform.Prelude -import Pqi qualified as Pq - --- | --- A sequence of operations to be executed in the context of a single database connection with exclusive access to it. --- --- Construct sessions using helpers in this module such as --- 'statement', 'pipeline' and 'script', or use 'onLibpqConnection' for a low-level --- escape hatch. --- --- To actually execute a 'Session' use 'Hasql.Connection.use', which manages --- concurrent access to the shared connection state and returns either a --- 'Errors.SessionError' or the result: --- --- > result <- Hasql.Connection.use connection mySession --- --- Note: while most session errors are returned as values, user code executed --- inside a session may still throw exceptions; in that case the driver will --- reset the connection to a clean state. -newtype Session a - = Session (ConnectionState.ConnectionState -> IO (Either Errors.SessionError a, ConnectionState.ConnectionState)) - deriving - (Functor, Applicative, Monad, MonadError Errors.SessionError, MonadIO) - via (ExceptT Errors.SessionError (StateT ConnectionState.ConnectionState IO)) - -run :: Session a -> ConnectionState.ConnectionState -> IO (Either Errors.SessionError a, ConnectionState.ConnectionState) -run (Session session) connectionState = session connectionState - --- | --- Possibly a multi-statement query, --- which however cannot be parameterized or prepared, --- nor can any results of it be collected. -script :: ByteString -> Session () -script sql = - Session \connectionState -> do - let connection = ConnectionState.connection connectionState - result <- Comms.Roundtrip.toSerialIO (Comms.Roundtrip.script (Just sql) sql) connection - case result of - Left err -> case err of - Comms.Roundtrip.ClientError _ details -> do - pure - ( Left (Errors.ConnectionSessionError (maybe "" decodeUtf8Lenient details)), - connectionState - ) - Comms.Roundtrip.ServerError recvError -> - pure - ( Left (Errors.fromRecvErrorInScript sql recvError), - connectionState - ) - Right () -> - pure - ( Right (), - connectionState - ) - --- | --- Execute a single statement by providing parameters to it, --- running it directly in serial mode. --- --- Each execution is a dedicated network roundtrip. The first execution of a --- preparable statement costs an extra roundtrip (a separate @PARSE@), after --- which steady-state execution is a single roundtrip. --- --- To batch multiple statements into fewer roundtrips, use 'pipeline' instead. -statement :: - Statement.Statement params result -> - params -> - Session result -statement stmt params = - Session \connectionState -> do - let usePreparedStatements = ConnectionState.preparedStatements connectionState - statementCache = ConnectionState.statementCache connectionState - oidCache = ConnectionState.oidCache connectionState - connection = ConnectionState.connection connectionState - sql = Statement.sql stmt - missingTypes = OidCache.selectUnknownNames (Statement.unknownTypes stmt) oidCache - resolvedOidCache <- - if HashSet.null missingTypes - then pure (Right oidCache) - else do - oidCacheUpdates <- - PqProcedures.SelectTypeInfo.run connection (PqProcedures.SelectTypeInfo.SelectTypeInfo missingTypes) - pure $ case oidCacheUpdates of - Left err -> Left err - Right oidCacheUpdates -> - let foundTypes = HashMap.keysSet oidCacheUpdates - notFoundTypes = HashSet.difference missingTypes foundTypes - in if not (HashSet.null notFoundTypes) - then Left (Errors.MissingTypesSessionError (HashSet.map Vocab.QualifiedTypeName.toNameTuple notFoundTypes)) - else Right (oidCache <> OidCache.fromHashMap oidCacheUpdates) - case resolvedOidCache of - Left err -> pure (Left err, connectionState) - Right newOidCache -> do - 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, Statement.printer stmt params, prepared) - mapError = \case - Comms.Roundtrip.ClientError _ details -> - Errors.ConnectionSessionError (maybe "" decodeUtf8Lenient details) - Comms.Roundtrip.ServerError recvError -> - Errors.fromRecvError recvError - withState (result, newStatementCache) = - ( first mapError result, - connectionState - { ConnectionState.oidCache = newOidCache, - ConnectionState.statementCache = newStatementCache - } - ) - fmap withState - $ if prepared - then do - let (oidList, valueAndFormatList) = - Statement.compilePreparedStatementData stmt newOidCache params - encodedParams = - valueAndFormatList - & fmap (fmap (\(bytes, format) -> (bytes, bool Pq.Binary Pq.Text format))) - execute remoteKey = - Comms.Roundtrip.toSerialIO - (Comms.Roundtrip.queryPrepared context remoteKey encodedParams Pq.Binary decoder') - connection - case StatementCache.lookup sql oidList statementCache of - Just remoteKey -> do - result <- execute remoteKey - pure (result, statementCache) - Nothing -> do - let (remoteKey, newStatementCache) = StatementCache.insert sql oidList statementCache - -- In non-pipeline mode PARSE and EXECUTE cannot be sent - -- back-to-back, so prepare in a dedicated roundtrip first. - prepareResult <- - Comms.Roundtrip.toSerialIO - (Comms.Roundtrip.prepare context remoteKey sql oidList) - connection - case prepareResult of - -- PARSE failed: the statement is not on the server, so - -- keep the old cache (no entry committed). - Left err -> pure (Left err, statementCache) - Right () -> do - -- PARSE succeeded, so the statement is on the server - -- under remoteKey regardless of whether EXECUTE then - -- fails. Commit the cache so a later use hits it instead - -- of re-issuing PARSE for an already-existing name. - result <- execute remoteKey - pure (result, newStatementCache) - else do - let encodedParams = - Statement.compileUnpreparedStatementData stmt newOidCache params - & fmap (fmap (\(oid, bytes, format) -> (oid, bytes, bool Pq.Binary Pq.Text format))) - result <- - Comms.Roundtrip.toSerialIO - (Comms.Roundtrip.queryParams context sql encodedParams Pq.Binary decoder') - connection - pure (result, statementCache) - --- | --- Execute a pipeline. -pipeline :: Pipeline.Pipeline result -> Session result -pipeline pipeline = Session \connectionState -> do - let usePreparedStatements = ConnectionState.preparedStatements connectionState - statementCache = ConnectionState.statementCache connectionState - oidCache = ConnectionState.oidCache connectionState - pqConnection = ConnectionState.connection connectionState - in do - (result, newOidCache, newStatementCache) <- Pipeline.run pipeline usePreparedStatements pqConnection oidCache statementCache - let newConnectionState = - connectionState - { ConnectionState.oidCache = newOidCache, - ConnectionState.statementCache = newStatementCache - } - - pure (result, newConnectionState) - --- | --- Execute an operation on the raw libpq connection possibly producing an error and updating the connection. --- This is a low-level escape hatch for custom integrations. --- --- You can supply a new connection in the result to replace it in the running Hasql connection. --- The responsibility to close the old libpq connection is on you. --- Otherwise, just return the same connection you've received. --- --- Producing a 'Left' value will cause the session to fail with the given error. --- Regardless of success or failure, the connection will be replaced with the one you return. --- --- Throwing exceptions is okay. It will lead to the connection getting reset. -onLibpqConnection :: - (Pq.Connection -> IO (Either Errors.SessionError a, Pq.Connection)) -> - Session a -onLibpqConnection f = Session \connectionState -> do - let pqConnection = ConnectionState.connection connectionState - (result, newConnection) <- f pqConnection - let newState = ConnectionState.setConnection newConnection connectionState - pure (result, newState) diff --git a/src/engine/Hasql/Engine/Decoders/Result.hs b/src/engine/Hasql/Engine/Decoders/Result.hs deleted file mode 100644 --- a/src/engine/Hasql/Engine/Decoders/Result.hs +++ /dev/null @@ -1,95 +0,0 @@ -module Hasql.Engine.Decoders.Result where - -import Hasql.Codecs.RequestingOid qualified as RequestingOid -import Hasql.Comms.ResultDecoder qualified as ResultDecoder -import Hasql.Engine.Decoders.Row (Row (..)) -import Hasql.Engine.Decoders.Row qualified as Row -import Hasql.Platform.Prelude - --- | --- Decoder of a query result. -newtype Result a - = Result (RequestingOid.RequestingOid (ResultDecoder.ResultDecoder a)) - deriving - (Functor, Applicative, Filterable) - via (Compose RequestingOid.RequestingOid ResultDecoder.ResultDecoder) - -unwrap :: Result a -> RequestingOid.RequestingOid (ResultDecoder.ResultDecoder a) -unwrap (Result decoder) = decoder - --- * Construction - --- | --- Decode no value from the result. --- --- Useful for statements like @INSERT@ or @CREATE@. -{-# INLINE noResult #-} -noResult :: Result () -noResult = - Result (RequestingOid.lift ResultDecoder.ok) - --- | --- Get the amount of rows affected by such statements as --- @UPDATE@ or @DELETE@. -{-# INLINE rowsAffected #-} -rowsAffected :: Result Int64 -rowsAffected = - Result (RequestingOid.lift ResultDecoder.rowsAffected) - --- | --- Exactly one row. --- Will raise the 'Hasql.Errors.UnexpectedRowCountStatementError' error if it's any other. -{-# INLINE singleRow #-} -singleRow :: Row a -> Result a -singleRow decoder = - Result (fmap ResultDecoder.single (Row.toDecoder decoder)) - -refineResult :: (a -> Either Text b) -> Result a -> Result b -refineResult refiner (Result decoder) = - Result (fmap (ResultDecoder.refine refiner) decoder) - --- ** Multi-row traversers - --- | --- Foldl multiple rows. -{-# INLINE foldlRows #-} -foldlRows :: (a -> b -> a) -> a -> Row b -> Result a -foldlRows step init decoder = - Result - (fmap (ResultDecoder.foldl step init) (Row.toDecoder decoder)) - --- | --- Foldr multiple rows. -{-# INLINE foldrRows #-} -foldrRows :: (b -> a -> a) -> a -> Row b -> Result a -foldrRows step init decoder = - Result - (fmap (ResultDecoder.foldr step init) (Row.toDecoder decoder)) - --- ** Specialized multi-row results - --- | --- Maybe one row or none. -{-# INLINE rowMaybe #-} -rowMaybe :: Row a -> Result (Maybe a) -rowMaybe decoder = - Result - (fmap ResultDecoder.maybe (Row.toDecoder decoder)) - --- | --- Zero or more rows packed into the vector. --- --- It's recommended to prefer this function to 'rowList', --- since it performs notably better. -{-# INLINE rowVector #-} -rowVector :: Row a -> Result (Vector a) -rowVector decoder = - Result - (fmap ResultDecoder.vector (Row.toDecoder decoder)) - --- | --- Zero or more rows packed into the list. -{-# INLINE rowList #-} -rowList :: Row a -> Result [a] -rowList = - foldrRows strictCons [] diff --git a/src/engine/Hasql/Engine/Decoders/Row.hs b/src/engine/Hasql/Engine/Decoders/Row.hs deleted file mode 100644 --- a/src/engine/Hasql/Engine/Decoders/Row.hs +++ /dev/null @@ -1,65 +0,0 @@ -module Hasql.Engine.Decoders.Row where - -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.Platform.Prelude -import PostgreSQL.Binary.Decoding qualified as Binary - --- | --- Decoder of an individual row, --- which gets composed of column value decoders. --- E.g.: --- --- @ --- x :: 'Row' (Maybe Int64, Text, TimeOfDay) --- x = (,,) '<$>' ('column' . 'nullable') 'int8' '<*>' ('column' . 'nonNullable') 'text' '<*>' ('column' . 'nonNullable') 'time' --- @ -newtype Row a - = Row (RequestingOid.RequestingOid (Hasql.Comms.RowDecoder.RowDecoder a)) - deriving - (Functor, Applicative, Filterable) - via (Compose RequestingOid.RequestingOid Hasql.Comms.RowDecoder.RowDecoder) - -toDecoder :: - Row a -> - RequestingOid.RequestingOid (Hasql.Comms.RowDecoder.RowDecoder a) -toDecoder (Row f) = f - --- | --- Lift an individual value decoder to a composable row decoder. -{-# INLINE column #-} -column :: NullableOrNot Value a -> Row a -column = \case - Nullable valueDecoder -> - Row case Value.toOid valueDecoder of - Just oid -> - fmap - (Hasql.Comms.RowDecoder.nullableColumn (Just oid) . Binary.valueParser) - (Value.toDecoder valueDecoder) - Nothing -> do - RequestingOid.hoistLookingUp - (Vocab.QualifiedTypeName.QualifiedTypeName (Value.toSchema valueDecoder) (Value.toTypeName valueDecoder)) - ( \lookupResult decoder -> - Hasql.Comms.RowDecoder.nullableColumn (Just (chooseLookedUpOid valueDecoder lookupResult)) (Binary.valueParser decoder) - ) - (Value.toDecoder valueDecoder) - NonNullable valueDecoder -> - Row case Value.toOid valueDecoder of - Just oid -> - fmap - (Hasql.Comms.RowDecoder.nonNullableColumn (Just oid) . Binary.valueParser) - (Value.toDecoder valueDecoder) - Nothing -> do - RequestingOid.hoistLookingUp - (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 Vocab.TypeInfo.toArrayOid typeInfo - else Vocab.TypeInfo.toBaseOid typeInfo diff --git a/src/engine/Hasql/Engine/Errors.hs b/src/engine/Hasql/Engine/Errors.hs deleted file mode 100644 --- a/src/engine/Hasql/Engine/Errors.hs +++ /dev/null @@ -1,473 +0,0 @@ -module Hasql.Engine.Errors where - -import Hasql.Comms.Recv qualified -import Hasql.Comms.ResultDecoder qualified -import Hasql.Comms.Roundtrip qualified -import Hasql.Comms.RowReader qualified -import Hasql.Platform.Prelude -import TextBuilder qualified - --- * Error types - --- | --- Error that occurs when attempting to establish a database connection. --- --- These errors can occur when calling 'Hasql.Connection.acquire'. --- Connection errors are categorized into several types to help with --- error handling and logging. -data ConnectionError - = -- | Network-level error while connecting to the database server. - -- - -- This typically indicates issues like: - -- - -- * Server is not reachable (wrong host\/port or server is down) - -- * Network connectivity problems - -- * Firewall blocking the connection - -- * Connection timeout - -- - -- These errors are transient and the operation can be retried. - NetworkingConnectionError - -- | Human readable details intended for logging. - Text - | -- | Authentication failed when connecting to the database. - -- - -- This typically indicates issues like: - -- - -- * Invalid username or password - -- * User does not have permission to access the database - -- * Authentication method mismatch (e.g., server requires SSL but client doesn't use it) - -- - -- These errors are not transient and require fixing the credentials or permissions. - AuthenticationConnectionError - -- | Human readable details intended for logging. - Text - | -- | Compatibility issue between client and server. - -- - -- This typically indicates issues like: - -- - -- * Server version is too old or too new - -- * Required PostgreSQL features are not available - -- * Protocol version mismatch - -- - -- These errors are not transient and require upgrading/downgrading - -- the server or client. - CompatibilityConnectionError - -- | Human readable details intended for logging. - Text - | -- | Uncategorized error coming from @libpq@. - -- - -- This is a catch-all for connection errors that don't fit into other categories. - -- The error message may be empty if @libpq@ doesn't provide details. - -- - -- These errors are not transient by default. - OtherConnectionError - -- | Human readable details intended for logging. May be empty. - Text - deriving stock (Show, Eq) - --- | --- Error that occurs during session execution. --- --- A session is a batch of actions executed in a database connection context. --- Session errors can occur due to statement failures, connection issues, --- missing types, or internal driver errors. --- --- Session errors provide detailed context to help diagnose problems, --- including SQL text, parameters, and the location of the error within --- a pipeline of statements. -data SessionError - = -- | An error occurred while executing a statement in the session. - -- - -- This wraps statement-level errors and provides additional context about: - -- - -- * Which statement in the pipeline failed (when multiple statements are batched) - -- * The SQL text and parameters of the failing statement - -- * Whether the statement was prepared or unprepared - -- - -- The error message includes formatted output showing all this context, - -- making it easier to diagnose issues in production. - StatementSessionError - -- | Total number of statements in the running pipeline. 1 if it's executed alone. - Int - -- | 0-based index of the statement that failed. 0 if it's executed alone. - Int - -- | SQL template of the failing statement. - Text - -- | Parameter values as text (for logging purposes). - [Text] - -- | Whether the statement was executed as a prepared one. - Bool - -- | The underlying statement error. - StatementError - | -- | An error occurred while executing a script. - -- - -- Scripts are multi-statement SQL texts executed via 'Hasql.Session.script'. - -- Unlike regular statements, scripts don't support parameters or result decoding, - -- and errors are limited to server-reported issues. - ScriptSessionError - -- | The SQL text of the script. - Text - -- | The server error that occurred. - ServerError - | -- | A connection-level error occurred during session execution. - -- - -- This indicates that the connection to the database was lost or - -- became unusable during the session. These errors are transient - -- and the operation can be retried with a new connection. - -- - -- Note: As of version 1.10, connections recover from async exceptions - -- without resetting, preserving connection-local state. - ConnectionSessionError - -- | Human-readable details about the connection error. - Text - | -- | One or more types referenced in the statement could not be found in the database. - -- - -- This occurs when using custom types (enums, composite types, domains) that - -- are resolved by name at runtime, but the types don't exist in the database. - -- - -- To fix this error: - -- - -- * Ensure the types are defined in the database - -- * Check that schema search paths are configured correctly - -- * Verify that the type names in your code match those in the database - MissingTypesSessionError - -- | Set of (schema name, type name) pairs that could not be found. - -- - -- Schema name is 'Nothing' when the type was looked up without a schema qualifier. - (HashSet (Maybe Text, Text)) - | -- | An internal driver error occurred. - -- - -- This indicates either: - -- - -- * A bug in Hasql - -- * The PostgreSQL server misbehaving - -- * An unexpected response from the server - -- - -- If you encounter this error, please report it as a bug. - DriverSessionError - -- | Human-readable details about what went wrong. - Text - deriving stock (Show, Eq) - --- | --- Error that occurs when executing a single statement. --- --- Statement errors can be caused by server-side issues (SQL errors, constraint violations) --- or by mismatches between the decoder specification and the actual result structure --- (wrong number of rows/columns, type mismatches, or cell-level decoding failures). -data StatementError - = -- | The server rejected the statement and returned an error. - -- - -- This includes SQL syntax errors, constraint violations, permission errors, - -- and any other error reported by PostgreSQL during statement execution. - ServerStatementError ServerError - | -- | The statement returned a different number of rows than expected. - -- - -- This occurs when using result decoders like @Decoders.singleRow@ or - -- @Decoders.rowsAffectedAtLeast@ that have specific row count expectations. - UnexpectedRowCountStatementError - -- | Expected minimum number of rows. - Int - -- | Expected maximum number of rows. - Int - -- | Actual number of rows returned. - Int - | -- | The statement returned a different number of columns than expected. - -- - -- This indicates a mismatch between the decoder specification and the - -- actual result structure, possibly due to: - -- - -- * Schema changes (columns added or removed) - -- * Wrong query (selecting different columns than expected) - -- * Decoder configuration error - UnexpectedColumnCountStatementError - -- | Expected number of columns. - Int - -- | Actual number of columns returned. - Int - | -- | A column has a different type than expected. - -- - -- This occurs when the decoder expects a specific PostgreSQL type (by OID) - -- but the actual column has a different type. This can happen due to: - -- - -- * Schema changes (column type changed) - -- * Wrong query (selecting wrong column or using a cast) - -- * Decoder configuration error - -- - -- Note: As of version 1.10, Hasql performs strict type checking and will - -- report this error instead of attempting automatic type coercion. - UnexpectedColumnTypeStatementError - -- | 0-based column index where the type mismatch occurred. - Int - -- | Expected PostgreSQL type OID. - Word32 - -- | Actual PostgreSQL type OID of the column. - Word32 - | -- | An error occurred while decoding a specific row. - -- - -- This wraps errors that occur at the row or cell level, providing - -- context about which row failed. - RowStatementError - -- | 0-based index of the row that failed to decode. - Int - -- | The underlying row-level error. - RowError - | -- | The database returned an unexpected result structure. - -- - -- This is a catch-all error that indicates either: - -- - -- * An improper statement (e.g., executing a query that doesn't match expectations) - -- * A schema mismatch between the code and database - -- * A bug in Hasql or server misbehavior - UnexpectedResultStatementError - -- | Human-readable details about what went wrong. - Text - deriving stock (Show, Eq) - --- | --- Error reported by the PostgreSQL server when executing a statement. --- --- The server provides structured error information including error codes --- (SQL state), messages, and optional context like hints and position information. --- --- For a complete list of PostgreSQL error codes, see: --- -data ServerError - = ServerError - -- | SQL State Code (SQLSTATE). - -- - -- A five-character code that identifies the error class and condition. - -- Examples: @\"23505\"@ (unique violation), @\"42P01\"@ (undefined table). - Text - -- | Primary error message. - -- - -- A human-readable description of the error. - Text - -- | Optional detailed error information. - -- - -- Additional context about the error, if available. - (Maybe Text) - -- | Optional hint for resolving the error. - -- - -- A suggestion for how to fix the problem, if available. - (Maybe Text) - -- | Optional position in the SQL string where the error occurred. - -- - -- A 1-based character index into the SQL string, if the error - -- relates to a specific location in the query. - (Maybe Int) - deriving stock (Show, Eq) - --- | --- Error that occurs when decoding a result row. --- --- Row errors indicate problems when processing an individual row from the result set, --- either at the cell level or during row refinement/validation. -data RowError - = -- | An error occurred while decoding a specific cell in the row. - -- - -- This wraps cell-level errors (null handling, deserialization failures) - -- and provides context about which column failed and its type. - CellRowError - -- | 0-based index of the column where the error occurred. - Int - -- | PostgreSQL type OID of the column, as reported by the server. - Word32 - -- | The underlying cell-level error. - CellError - | -- | A refinement or validation error when processing the row. - -- - -- This occurs when using refinement functions in row decoders - -- (e.g., with 'Decoders.refineRow') to validate or transform - -- decoded values. The refinement function rejected the row data. - RefinementRowError - -- | Human-readable details about why the refinement failed. - Text - deriving stock (Show, Eq) - --- | --- Error that occurs when decoding a single cell (column value) in a result row. --- --- Cell errors indicate problems with individual values returned by the database, --- such as unexpected nulls or failures in binary deserialization. -data CellError - = -- | A NULL value was encountered when a non-NULL value was expected. - -- - -- This occurs when using non-nullable decoders (e.g., @Decoders.nonNullable@) - -- on a column that contains a NULL value. - UnexpectedNullCellError - | -- | Failed to deserialize the cell value from its binary representation. - -- - -- This can occur when: - -- - -- * The binary data is corrupted - -- * The decoder doesn't match the actual data type - -- * The data format is invalid for the expected type - DeserializationCellError - -- | Human-readable error message describing what went wrong. - Text - deriving stock (Show, Eq) - -fromRoundtripError :: Hasql.Comms.Roundtrip.Error context -> SessionError -fromRoundtripError = \case - Hasql.Comms.Roundtrip.ClientError _context details -> - ConnectionSessionError (maybe "" decodeUtf8Lenient details) - Hasql.Comms.Roundtrip.ServerError recvError -> - fromRecvError (Nothing <$ recvError) - -fromRecvError :: Hasql.Comms.Recv.Error (Maybe (Int, Int, ByteString, [Text], Bool)) -> SessionError -fromRecvError = \case - Hasql.Comms.Recv.ResultError location _resultOffset resultError -> - case location of - Nothing -> - (DriverSessionError . TextBuilder.toText . mconcat) - [ "Unexpected error outside of statement context. ", - "This indicates a bug in Hasql or the server misbehaving. ", - "Error: ", - TextBuilder.string (show resultError) - ] - Just (totalStatements, statementIndex, sql, parameters, prepared) -> - StatementSessionError - totalStatements - statementIndex - (decodeUtf8Lenient sql) - parameters - prepared - (fromStatementResultError resultError) - Hasql.Comms.Recv.NoResultsError location details -> - case location of - Nothing -> - (DriverSessionError . TextBuilder.toText . mconcat) - [ "Unexpectedly got no results outside of statement context. ", - "This indicates a bug in Hasql or the server misbehaving. ", - "Details: ", - TextBuilder.string (show details) - ] - Just (totalStatements, statementIndex, sql, parameters, prepared) -> - StatementSessionError - totalStatements - statementIndex - (decodeUtf8Lenient sql) - parameters - prepared - (UnexpectedRowCountStatementError 1 1 0) - Hasql.Comms.Recv.TooManyResultsError location actual -> - case location of - Nothing -> - (DriverSessionError . TextBuilder.toText . mconcat) - [ "Unexpectedly got too many results outside of statement context. ", - "This indicates a bug in Hasql or the server misbehaving. ", - "Amount: ", - TextBuilder.decimal actual - ] - Just (totalStatements, statementIndex, sql, parameters, prepared) -> - StatementSessionError - totalStatements - statementIndex - (decodeUtf8Lenient sql) - parameters - prepared - (UnexpectedRowCountStatementError 1 1 actual) - -fromStatementResultError :: Hasql.Comms.ResultDecoder.Error -> StatementError -fromStatementResultError = \case - Hasql.Comms.ResultDecoder.ServerError code message detail hint position -> - ServerStatementError - ( ServerError - (decodeUtf8Lenient code) - (decodeUtf8Lenient message) - (fmap decodeUtf8Lenient detail) - (fmap decodeUtf8Lenient hint) - position - ) - Hasql.Comms.ResultDecoder.UnexpectedResult msg -> - UnexpectedResultStatementError msg - Hasql.Comms.ResultDecoder.UnexpectedRowCount actual -> - UnexpectedRowCountStatementError 1 1 actual - Hasql.Comms.ResultDecoder.UnexpectedColumnCount expected actual -> - UnexpectedColumnCountStatementError expected actual - Hasql.Comms.ResultDecoder.DecoderTypeMismatch colIdx expectedOid actualOid -> - UnexpectedColumnTypeStatementError - colIdx - expectedOid - actualOid - Hasql.Comms.ResultDecoder.RowError rowIndex rowError -> - case rowError of - Hasql.Comms.RowReader.CellError column oid cellErr -> - RowStatementError - rowIndex - ( CellRowError - column - oid - ( case cellErr of - Hasql.Comms.RowReader.DecodingCellError msg -> DeserializationCellError msg - Hasql.Comms.RowReader.UnexpectedNullCellError -> UnexpectedNullCellError - ) - ) - Hasql.Comms.RowReader.RefinementError msg -> - RowStatementError - rowIndex - (RefinementRowError msg) - -fromRecvErrorInScript :: ByteString -> Hasql.Comms.Recv.Error (Maybe ByteString) -> SessionError -fromRecvErrorInScript scriptSql = \case - Hasql.Comms.Recv.ResultError _ _ resultError -> - case resultError of - Hasql.Comms.ResultDecoder.ServerError code message detail hint position -> - ScriptSessionError - (decodeUtf8Lenient scriptSql) - ( ServerError - (decodeUtf8Lenient code) - (decodeUtf8Lenient message) - (fmap decodeUtf8Lenient detail) - (fmap decodeUtf8Lenient hint) - position - ) - Hasql.Comms.ResultDecoder.UnexpectedResult msg -> - (DriverSessionError . TextBuilder.toText . mconcat) - [ "Unexpected result in script: ", - TextBuilder.text msg - ] - Hasql.Comms.ResultDecoder.UnexpectedRowCount actual -> - (DriverSessionError . TextBuilder.toText . mconcat) - [ "Unexpected amount of rows in script: ", - TextBuilder.decimal actual - ] - Hasql.Comms.ResultDecoder.UnexpectedColumnCount expected actual -> - (DriverSessionError . TextBuilder.toText . mconcat) - [ "Unexpected amount of columns in script: expected ", - TextBuilder.decimal expected, - ", got ", - TextBuilder.decimal actual - ] - Hasql.Comms.ResultDecoder.DecoderTypeMismatch colIdx expectedOid actualOid -> - (DriverSessionError . TextBuilder.toText . mconcat) - [ "Decoder type mismatch in script: expected OID ", - TextBuilder.string (show expectedOid), - " at column ", - TextBuilder.decimal colIdx, - ", got ", - TextBuilder.string (show actualOid) - ] - Hasql.Comms.ResultDecoder.RowError rowIndex rowError -> - (DriverSessionError . TextBuilder.toText . mconcat) - [ "Row error in script at row ", - TextBuilder.decimal rowIndex, - ": ", - TextBuilder.string (show rowError) - ] - Hasql.Comms.Recv.NoResultsError _ details -> - (DriverSessionError . TextBuilder.toText . mconcat) - [ "Got no results in script.", - " This indicates a bug in Hasql or the server misbehaving.", - details - & filter (/= "") - & foldMap (mappend " Details: " . TextBuilder.text . decodeUtf8Lenient) - ] - Hasql.Comms.Recv.TooManyResultsError _ actual -> - (DriverSessionError . TextBuilder.toText . mconcat) - [ "Got too many results in script. ", - "This indicates a bug in Hasql or the server misbehaving. ", - "Amount: ", - TextBuilder.decimal actual - ] diff --git a/src/engine/Hasql/Engine/PqProcedures/SelectTypeInfo.hs b/src/engine/Hasql/Engine/PqProcedures/SelectTypeInfo.hs deleted file mode 100644 --- a/src/engine/Hasql/Engine/PqProcedures/SelectTypeInfo.hs +++ /dev/null @@ -1,118 +0,0 @@ -module Hasql.Engine.PqProcedures.SelectTypeInfo - ( SelectTypeInfo (..), - SelectTypeInfoResult, - run, - ) -where - -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.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.Platform.Prelude -import PostgreSQL.Binary.Encoding qualified as Binary -import Pqi qualified as Pq - -newtype SelectTypeInfo = SelectTypeInfo - { -- | Set of (schema name, type name) pairs to look up. - keys :: HashSet Vocab.QualifiedTypeName - } - --- | Result maps (schema name, type name) pairs to TypeInfo (scalar OID, array OID). -type SelectTypeInfoResult = - HashMap Vocab.QualifiedTypeName Vocab.TypeInfo.TypeInfo - -run :: Pq.Connection -> SelectTypeInfo -> IO (Either Errors.SessionError SelectTypeInfoResult) -run connection (SelectTypeInfo keys) = - if HashSet.null keys - then pure (Right HashMap.empty) - else - first Errors.fromRoundtripError - <$> Hasql.Comms.Roundtrip.toSerialIO (roundtrip (SelectTypeInfo keys)) connection - -sql :: ByteString -sql = - "with\n\ - \ inputs as (\n\ - \ select *\n\ - \ from unnest($1, $2) as x(schema_name, type_name)\n\ - \ ),\n\ - \ unnamespaced_results as (\n\ - \ select\n\ - \ null :: text as schema_name,\n\ - \ pg_type.typname :: text as type_name,\n\ - \ pg_type.oid :: int4 as type_oid,\n\ - \ pg_type.typarray :: int4 as array_oid\n\ - \ from inputs\n\ - \ join pg_type on pg_type.oid = to_regtype(inputs.type_name)\n\ - \ where inputs.schema_name is null\n\ - \ ),\n\ - \ namespaced_results as (\n\ - \ select\n\ - \ pg_namespace.nspname :: text as schema_name,\n\ - \ pg_type.typname :: text as type_name,\n\ - \ pg_type.oid :: int4 as type_oid,\n\ - \ pg_type.typarray :: int4 as array_oid\n\ - \ from inputs\n\ - \ join pg_namespace on pg_namespace.nspname = inputs.schema_name\n\ - \ join pg_type\n\ - \ on pg_type.typname = inputs.type_name\n\ - \ and pg_type.typnamespace = pg_namespace.oid\n\ - \ where inputs.schema_name is not null\n\ - \ )\n\ - \select * from unnamespaced_results\n\ - \union\n\ - \select * from namespaced_results" - -roundtrip :: SelectTypeInfo -> Hasql.Comms.Roundtrip.Roundtrip () SelectTypeInfoResult -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 (Word32, ByteString, Pq.Format)] -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 (1009, schemaArray, Pq.Binary), - Just (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 (Vocab.QualifiedTypeName.QualifiedTypeName schemaName typeName) (Vocab.TypeInfo.TypeInfo typeOid arrayOid) acc - -rowDecoder :: Hasql.Comms.RowDecoder.RowDecoder (Maybe Text, Text, Word32, Word32) -rowDecoder = - (,,,) - <$> nullableColumn Decoders.Value.text - <*> nonNullableColumn Decoders.Value.text - <*> nonNullableColumn (fromIntegral <$> Decoders.Value.int4) - <*> nonNullableColumn (fromIntegral <$> Decoders.Value.int4) - where - nullableColumn valueDecoder = - Hasql.Comms.RowDecoder.nullableColumn - (Decoders.Value.toBaseOid valueDecoder) - (Decoders.Value.toByteStringParser valueDecoder mempty) - - nonNullableColumn valueDecoder = - Hasql.Comms.RowDecoder.nonNullableColumn - (Decoders.Value.toBaseOid valueDecoder) - (Decoders.Value.toByteStringParser valueDecoder mempty) diff --git a/src/engine/Hasql/Engine/Statement.hs b/src/engine/Hasql/Engine/Statement.hs deleted file mode 100644 --- a/src/engine/Hasql/Engine/Statement.hs +++ /dev/null @@ -1,188 +0,0 @@ -module Hasql.Engine.Statement - ( Statement (..), - preparable, - unpreparable, - refineResult, - toSql, - compilePreparedStatementData, - compileUnpreparedStatementData, - ) -where - -import Data.Text.Encoding qualified as TextEncoding -import Data.Vector qualified as Vector -import Hasql.Codecs.Encoders qualified as Encoders -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.Engine.Decoders.Result qualified as Decoders -import Hasql.Engine.Decoders.Result qualified as Decoders.Result -import Hasql.Platform.Prelude - --- | --- Specification of a strictly single-statement query, which can be parameterized and prepared. --- It encapsulates the mapping of parameters and results in association with an SQL template. --- --- Following is an example of a declaration of a prepared statement with its associated codecs. --- --- @ --- selectSum :: 'Statement' (Int64, Int64) Int64 --- selectSum = --- 'preparable' sql encoder decoder --- where --- sql = --- \"select ($1 + $2)\" --- encoder = --- ('fst' '>$<' Encoders.'Hasql.Encoders.param' (Encoders.'Hasql.Encoders.nonNullable' Encoders.'Hasql.Encoders.int8')) '<>' --- ('snd' '>$<' Encoders.'Hasql.Encoders.param' (Encoders.'Hasql.Encoders.nonNullable' Encoders.'Hasql.Encoders.int8')) --- decoder = --- Decoders.'Hasql.Decoders.singleRow' (Decoders.'Hasql.Decoders.column' (Decoders.'Hasql.Decoders.nonNullable' Decoders.'Hasql.Decoders.int8')) --- @ --- --- The statement above accepts a product of two parameters of type 'Int64' --- and produces a single result of type 'Int64'. -data Statement params result - = Statement - { -- | 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. --- --- Use this for statements that will be executed multiple times with different parameters. --- Preparable statements are cached by PostgreSQL, which avoids reconstructing the execution plan each time. --- --- Suitable for applications with a limited amount of queries that don't generate SQL dynamically. -preparable :: - -- | SQL template with parameters in positional notation (@$1@, @$2@, etc.) - Text -> - -- | Parameters encoder - Encoders.Params params -> - -- | Result decoder - Decoders.Result result -> - Statement params result -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. --- --- Use this for statements that are dynamically generated or executed only once. --- Unpreparable statements are not cached by PostgreSQL. --- --- Suitable for dynamic SQL or one-off queries. -unpreparable :: - -- | SQL template with parameters in positional notation (@$1@, @$2@, etc.) - Text -> - -- | Parameters encoder - Encoders.Params params -> - -- | Result decoder - Decoders.Result result -> - Statement params result -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 f stmt = stmt {decoder = fmap (fmap f) (decoder stmt)} - -instance Filterable (Statement params) where - {-# INLINE mapMaybe #-} - mapMaybe filtrator stmt = stmt {decoder = fmap (mapMaybe filtrator) (decoder stmt)} - -instance Profunctor Statement where - {-# INLINE dimap #-} - 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, --- causing the running session to fail with the 'Hasql.Errors.UnexpectedResultStatementError' error in case of a refinement failure. --- --- 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 stmt = stmt {decoder = fmap (ResultDecoder.refine refiner) (decoder stmt)} - --- | Extract the SQL template from a statement. -toSql :: Statement params result -> Text -toSql stmt = 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/engine/Hasql/Engine/Structures/ConnectionState.hs b/src/engine/Hasql/Engine/Structures/ConnectionState.hs deleted file mode 100644 --- a/src/engine/Hasql/Engine/Structures/ConnectionState.hs +++ /dev/null @@ -1,98 +0,0 @@ --- | --- This module defines the internal state of a database connection. -module Hasql.Engine.Structures.ConnectionState - ( ConnectionState (..), - toStatementCache, - fromConnection, - setPreparedStatements, - setStatementCache, - setConnection, - setOidCache, - mapStatementCache, - mapOidCache, - traverseStatementCache, - resetPreparedStatementsCache, - ) -where - -import Hasql.Codecs.Vocab.OidCache qualified as OidCache -import Hasql.Engine.Structures.StatementCache qualified as StatementCache -import Hasql.Platform.Prelude -import Pqi qualified as Pq - --- | --- The internal state of a database connection. -data ConnectionState = ConnectionState - { -- | Whether prepared statements are enabled. - preparedStatements :: Bool, - -- | The statement cache for prepared statements. - statementCache :: StatementCache.StatementCache, - -- | The OID cache for type name to OID mapping. - oidCache :: OidCache.OidCache, - -- | The underlying database connection. - connection :: Pq.Connection - } - -toStatementCache :: ConnectionState -> StatementCache.StatementCache -toStatementCache ConnectionState {..} = statementCache - -fromConnection :: Pq.Connection -> ConnectionState -fromConnection connection = - ConnectionState - { preparedStatements = False, - statementCache = StatementCache.empty, - oidCache = OidCache.empty, - connection = connection - } - -setPreparedStatements :: Bool -> ConnectionState -> ConnectionState -setPreparedStatements preparedStatements connectionState = - connectionState {preparedStatements = preparedStatements} - -setStatementCache :: StatementCache.StatementCache -> ConnectionState -> ConnectionState -setStatementCache statementCache connectionState = - connectionState {statementCache = statementCache} - -setConnection :: Pq.Connection -> ConnectionState -> ConnectionState -setConnection connection connectionState = - connectionState {connection = connection} - -setOidCache :: OidCache.OidCache -> ConnectionState -> ConnectionState -setOidCache oidCache connectionState = - connectionState {oidCache} - -mapStatementCache :: - (StatementCache.StatementCache -> StatementCache.StatementCache) -> - (ConnectionState -> ConnectionState) -mapStatementCache f ConnectionState {..} = - ConnectionState - { statementCache = f statementCache, - .. - } - -mapOidCache :: - (OidCache.OidCache -> OidCache.OidCache) -> - (ConnectionState -> ConnectionState) -mapOidCache f ConnectionState {..} = - ConnectionState - { oidCache = f oidCache, - .. - } - -traverseStatementCache :: - (Functor f) => - (StatementCache.StatementCache -> f StatementCache.StatementCache) -> - (ConnectionState -> f ConnectionState) -traverseStatementCache f ConnectionState {..} = - fmap - ( \newStatementCache -> - ConnectionState - { statementCache = newStatementCache, - .. - } - ) - (f statementCache) - -resetPreparedStatementsCache :: ConnectionState -> ConnectionState -resetPreparedStatementsCache = - mapStatementCache (const StatementCache.empty) diff --git a/src/engine/Hasql/Engine/Structures/StatementCache.hs b/src/engine/Hasql/Engine/Structures/StatementCache.hs deleted file mode 100644 --- a/src/engine/Hasql/Engine/Structures/StatementCache.hs +++ /dev/null @@ -1,55 +0,0 @@ -module Hasql.Engine.Structures.StatementCache - ( -- * Pure registry operations - StatementCache, - empty, - lookup, - insert, - reset, - ) -where - -import Data.HashMap.Strict qualified as HashMap -import Hasql.Platform.Prelude hiding (empty, insert, lookup, reset) - --- | Pure registry state containing the hash map and counter -data StatementCache = StatementCache (HashMap LocalKey ByteString) Word - deriving stock (Show, Eq) - --- | Create an empty registry state -{-# INLINEABLE empty #-} -empty :: StatementCache -empty = StatementCache HashMap.empty 0 - --- | Pure lookup operation -{-# INLINEABLE lookup #-} -lookup :: ByteString -> [Word32] -> StatementCache -> Maybe ByteString -lookup sql oids (StatementCache hashMap _) = HashMap.lookup localKey hashMap - where - localKey = LocalKey sql oids - --- | Pure insert operation that returns new state and the generated remote key -{-# INLINEABLE insert #-} -insert :: ByteString -> [Word32] -> StatementCache -> (ByteString, StatementCache) -insert sql oids (StatementCache hashMap counter) = (remoteKey, newState) - where - remoteKey = fromString $ show $ newCounter - newHashMap = HashMap.insert localKey remoteKey hashMap - newCounter = counter + 1 - newState = StatementCache newHashMap newCounter - localKey = LocalKey sql oids - --- | Pure reset operation -{-# INLINEABLE reset #-} -reset :: StatementCache -> StatementCache -reset _ = StatementCache HashMap.empty 0 - --- | --- Local statement key. -data LocalKey - = LocalKey ByteString [Word32] - deriving (Show, Eq) - -instance Hashable LocalKey where - {-# INLINE hashWithSalt #-} - hashWithSalt salt (LocalKey template oids) = - hashWithSalt (hashWithSalt salt template) oids diff --git a/src/library/Hasql/Codecs/Decoders.hs b/src/library/Hasql/Codecs/Decoders.hs new file mode 100644 --- /dev/null +++ b/src/library/Hasql/Codecs/Decoders.hs @@ -0,0 +1,147 @@ +module Hasql.Codecs.Decoders + ( -- * Nullability + NullableOrNot.NullableOrNot (..), + NullableOrNot.nonNullable, + NullableOrNot.nullable, + + -- * Value + Value.Value (..), + Value.bool, + Value.int2, + Value.int4, + Value.int8, + Value.float4, + Value.float8, + Value.numeric, + Value.char, + Value.text, + Value.varchar, + Value.bpchar, + Value.bytea, + Value.date, + Value.timestamp, + Value.timestamptz, + Value.time, + Value.timetz, + Value.interval, + Value.uuid, + Value.inet, + Value.macaddr, + Value.json, + Value.jsonBytes, + Value.jsonb, + Value.jsonbBytes, + Value.int4range, + Value.int8range, + Value.numrange, + Value.tsrange, + Value.tstzrange, + Value.daterange, + Value.int4multirange, + Value.int8multirange, + Value.nummultirange, + Value.tsmultirange, + Value.tstzmultirange, + Value.datemultirange, + Value.citext, + array, + listArray, + vectorArray, + composite, + record, + Value.hstore, + Value.enum, + Value.custom, + Value.refine, + + -- * Array + Array.Array, + Array.dimension, + Array.element, + + -- * Composite + Composite.Composite (..), + Composite.field, + ) +where + +import CodecVocab.TypeInfo qualified as CodecVocab.TypeInfo +import Data.Vector.Generic qualified as GenericVector +import Hasql.Codecs.Decoders.Array qualified as Array +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.Platform.Prelude + +-- * Value + +-- | +-- Lift an 'Array.Array' decoder to a 'Value.Value' decoder. +{-# INLINEABLE array #-} +array :: Array.Array a -> Value.Value a +array decoder = Value.Value (Array.toSchema decoder) (Array.toTypeName decoder) (Array.toBaseOid decoder) (Array.toArrayOid decoder) (Array.toDimensionality decoder) (Array.toValueDecoder decoder) + +-- | +-- Lift a value decoder of element into a unidimensional array decoder producing a list. +-- +-- This function is merely a shortcut to the following expression: +-- +-- @ +-- ('array' . 'dimension' Control.Monad.'replicateM' . 'element') +-- @ +-- +-- Please notice that in case of multidimensional arrays nesting 'listArray' decoder +-- won't work. You have to explicitly construct the array decoder using 'array'. +{-# INLINE listArray #-} +listArray :: NullableOrNot.NullableOrNot Value.Value element -> Value.Value [element] +listArray = array . Array.dimension replicateM . Array.element + +-- | +-- Lift a value decoder of element into a unidimensional array decoder producing a generic vector. +-- +-- This function is merely a shortcut to the following expression: +-- +-- @ +-- ('array' . 'dimension' Data.Vector.Generic.'GenericVector.replicateM' . 'element') +-- @ +-- +-- Please notice that in case of multidimensional arrays nesting 'vectorArray' decoder +-- won't work. You have to explicitly construct the array decoder using 'array'. +{-# INLINE vectorArray #-} +vectorArray :: (GenericVector.Vector vector element) => NullableOrNot.NullableOrNot Value.Value element -> Value.Value (vector element) +vectorArray = array . Array.dimension GenericVector.replicateM . Array.element + +-- | +-- Lift a 'Composite.Composite' decoder to a 'Value.Value' decoder for named composite types. +-- +-- This function is for named composite types where the type name is known. +-- For anonymous composite types (like those created with ROW constructor), +-- use 'record' instead. +{-# INLINEABLE composite #-} +composite :: Maybe Text -> Text -> Composite.Composite a -> Value.Value a +composite schema typeName composite = + Value.Value + schema + typeName + Nothing + Nothing + 0 + (Composite.toValueDecoder composite) + +-- | +-- Lift a 'Composite.Composite' decoder to a 'Value.Value' decoder for unnamed composite types. +-- +-- This is useful for decoding anonymous composites (like those created with ROW constructor) +-- where no type name is required. Postgres will handle the type automatically. +{-# INLINEABLE record #-} +record :: Composite.Composite a -> Value.Value a +record composite = + Value.Value + Nothing + "record" + (Just (CodecVocab.TypeInfo.toBaseOid typeInfo)) + (Just (CodecVocab.TypeInfo.toArrayOid typeInfo)) + 0 + (Composite.toValueDecoder composite) + where + typeInfo = CodecVocab.TypeInfo.record diff --git a/src/library/Hasql/Codecs/Decoders/Array.hs b/src/library/Hasql/Codecs/Decoders/Array.hs new file mode 100644 --- /dev/null +++ b/src/library/Hasql/Codecs/Decoders/Array.hs @@ -0,0 +1,141 @@ +module Hasql.Codecs.Decoders.Array + ( Array, + toValueDecoder, + toTypeSig, + toSchema, + toTypeName, + toBaseOid, + toArrayOid, + toDimensionality, + dimension, + element, + ) +where + +import CodecVocab.QualifiedTypeName qualified as CodecVocab.QualifiedTypeName +import CodecVocab.TypeInfo qualified as CodecVocab.TypeInfo +import Hasql.Codecs.Decoders.NullableOrNot qualified as NullableOrNot +import Hasql.Codecs.Decoders.Value qualified as Value +import Hasql.Platform.Prelude +import Hasql.ToBeResolved qualified as ToBeResolved +import PostgreSQL.Binary.Decoding qualified as Binary +import TextBuilder qualified + +-- | +-- Binary generic array decoder. +-- +-- Here's how you can use it to produce a specific array value decoder: +-- +-- @ +-- x :: 'Value.Value' [[Text]] +-- x = 'array' ('dimension' 'replicateM' ('dimension' 'replicateM' ('element' ('nonNullable' 'text')))) +-- @ +data Array a + = Array + -- | Schema name. + (Maybe Text) + -- | Type name for the array element. + Text + -- | Statically known OID for the base (element) type. + (Maybe Word32) + -- | Statically known OID for the array type. + (Maybe Word32) + -- | Number of dimensions. + Word + -- | Decoding function + (ToBeResolved.ToBeResolved CodecVocab.QualifiedTypeName.QualifiedTypeName CodecVocab.TypeInfo.TypeInfo (Binary.Array a)) + deriving (Functor) + +{-# INLINE toValueDecoder #-} +toValueDecoder :: Array a -> ToBeResolved.ToBeResolved CodecVocab.QualifiedTypeName.QualifiedTypeName CodecVocab.TypeInfo.TypeInfo (Binary.Value a) +toValueDecoder (Array _ _ _ _ _ decoder) = + fmap Binary.array decoder + +-- | Get the type signature for the array based on element type name +{-# INLINE toTypeSig #-} +toTypeSig :: Array a -> Text +toTypeSig (Array schemaName elementTypeName _ _ ndims _) = + TextBuilder.toText + ( mconcat + ( mconcat + [ foldMap + (\s -> [TextBuilder.text s, TextBuilder.char '.']) + schemaName, + [ TextBuilder.text elementTypeName + ], + replicate + (fromIntegral ndims) + (TextBuilder.text "[]") + ] + ) + ) + +toSchema :: Array a -> Maybe Text +toSchema (Array schema _ _ _ _ _) = schema + +-- | Get the type name for the array based on element type name +{-# INLINE toTypeName #-} +toTypeName :: Array a -> Text +toTypeName (Array _ elementTypeName _ _ _ _) = + elementTypeName + +-- | Get the base OID if statically known +{-# INLINE toBaseOid #-} +toBaseOid :: Array a -> Maybe Word32 +toBaseOid (Array _ _ baseOid _ _ _) = baseOid + +-- | Get the array OID if statically known +{-# INLINE toArrayOid #-} +toArrayOid :: Array a -> Maybe Word32 +toArrayOid (Array _ _ _ arrayOid _ _) = arrayOid + +-- | Get the dimensionality of the array +{-# INLINE toDimensionality #-} +toDimensionality :: Array a -> Word +toDimensionality (Array _ _ _ _ ndims _) = ndims + +-- * Public API + +-- | +-- Binary function for parsing a dimension of an array. +-- Provides support for multi-dimensional arrays. +-- +-- Accepts: +-- +-- * An implementation of the @replicateM@ function +-- (@Control.Monad.'Control.Monad.replicateM'@, @Data.Vector.'Data.Vector.replicateM'@), +-- which determines the output value. +-- +-- * Binary decoder of its components, which can be either another 'dimension' or 'element'. +{-# INLINEABLE dimension #-} +dimension :: (forall m. (Monad m) => Int -> m a -> m b) -> Array a -> Array b +dimension replicateM (Array schema typeName baseOid arrayOid ndims decoder) = + Array + schema + typeName + baseOid + arrayOid + (succ ndims) + (fmap (Binary.dimensionArray replicateM) decoder) + +-- | +-- Lift a 'Value.Value' decoder into an 'Array' decoder for parsing of leaf values. +{-# INLINEABLE element #-} +element :: NullableOrNot.NullableOrNot Value.Value a -> Array a +element = \case + NullableOrNot.NonNullable imp -> + Array + (Value.toSchema imp) + (Value.toTypeName imp) + (Value.toBaseOid imp) + (Value.toArrayOid imp) + 1 + (fmap Binary.valueArray (Value.toDecoder imp)) + NullableOrNot.Nullable imp -> + Array + (Value.toSchema imp) + (Value.toTypeName imp) + (Value.toBaseOid imp) + (Value.toArrayOid imp) + 1 + (fmap Binary.nullableValueArray (Value.toDecoder imp)) diff --git a/src/library/Hasql/Codecs/Decoders/Composite.hs b/src/library/Hasql/Codecs/Decoders/Composite.hs new file mode 100644 --- /dev/null +++ b/src/library/Hasql/Codecs/Decoders/Composite.hs @@ -0,0 +1,50 @@ +module Hasql.Codecs.Decoders.Composite where + +import CodecVocab.QualifiedTypeName qualified as CodecVocab.QualifiedTypeName +import CodecVocab.TypeInfo qualified as CodecVocab.TypeInfo +import Hasql.Codecs.Decoders.NullableOrNot qualified as NullableOrNot +import Hasql.Codecs.Decoders.Value qualified as Value +import Hasql.Platform.Prelude +import Hasql.ToBeResolved qualified as ToBeResolved +import PostgreSQL.Binary.Decoding qualified as Binary + +-- | +-- Composable decoder of composite values (rows, records). +newtype Composite a + = Composite (ToBeResolved.ToBeResolved CodecVocab.QualifiedTypeName.QualifiedTypeName CodecVocab.TypeInfo.TypeInfo (Binary.Composite a)) + deriving + (Functor, Applicative) + via (Compose (ToBeResolved.ToBeResolved CodecVocab.QualifiedTypeName.QualifiedTypeName CodecVocab.TypeInfo.TypeInfo) Binary.Composite) + +toValueDecoder :: Composite a -> ToBeResolved.ToBeResolved CodecVocab.QualifiedTypeName.QualifiedTypeName CodecVocab.TypeInfo.TypeInfo (Binary.Value a) +toValueDecoder (Composite imp) = + fmap Binary.composite imp + +-- | +-- Lift a 'Value.Value' decoder into a 'Composite' decoder for parsing of component values. +field :: NullableOrNot.NullableOrNot Value.Value a -> Composite a +field = \case + NullableOrNot.NonNullable imp -> + let dimensionality = Value.toDimensionality imp + staticOid = if dimensionality == 0 then Value.toBaseOid imp else Value.toArrayOid imp + in case staticOid of + Just oid -> + Composite (fmap (Binary.typedValueComposite oid) (Value.toDecoder imp)) + Nothing -> + Composite + ( (\typeInfo decoder -> Binary.typedValueComposite (if dimensionality == 0 then CodecVocab.TypeInfo.toBaseOid typeInfo else CodecVocab.TypeInfo.toArrayOid typeInfo) decoder) + <$> ToBeResolved.lookup (CodecVocab.QualifiedTypeName.QualifiedTypeName (Value.toSchema imp) (Value.toTypeName imp)) + <*> Value.toDecoder imp + ) + NullableOrNot.Nullable imp -> + let dimensionality = Value.toDimensionality imp + staticOid = if dimensionality == 0 then Value.toBaseOid imp else Value.toArrayOid imp + in case staticOid of + Just oid -> + Composite (fmap (Binary.typedNullableValueComposite oid) (Value.toDecoder imp)) + Nothing -> + Composite + ( (\typeInfo decoder -> Binary.typedNullableValueComposite (if dimensionality == 0 then CodecVocab.TypeInfo.toBaseOid typeInfo else CodecVocab.TypeInfo.toArrayOid typeInfo) decoder) + <$> ToBeResolved.lookup (CodecVocab.QualifiedTypeName.QualifiedTypeName (Value.toSchema imp) (Value.toTypeName imp)) + <*> Value.toDecoder imp + ) diff --git a/src/library/Hasql/Codecs/Decoders/NullableOrNot.hs b/src/library/Hasql/Codecs/Decoders/NullableOrNot.hs new file mode 100644 --- /dev/null +++ b/src/library/Hasql/Codecs/Decoders/NullableOrNot.hs @@ -0,0 +1,27 @@ +module Hasql.Codecs.Decoders.NullableOrNot + ( -- * Nullability + NullableOrNot (..), + nonNullable, + nullable, + ) +where + +import Hasql.Platform.Prelude + +-- * Nullability + +-- | +-- Extensional specification of nullability over a generic decoder. +data NullableOrNot decoder a where + NonNullable :: decoder a -> NullableOrNot decoder a + Nullable :: decoder a -> NullableOrNot decoder (Maybe a) + +-- | +-- Specify that a decoder produces a non-nullable value. +nonNullable :: decoder a -> NullableOrNot decoder a +nonNullable = NonNullable + +-- | +-- Specify that a decoder produces a nullable value. +nullable :: decoder a -> NullableOrNot decoder (Maybe a) +nullable = Nullable diff --git a/src/library/Hasql/Codecs/Decoders/Value.hs b/src/library/Hasql/Codecs/Decoders/Value.hs new file mode 100644 --- /dev/null +++ b/src/library/Hasql/Codecs/Decoders/Value.hs @@ -0,0 +1,450 @@ +module Hasql.Codecs.Decoders.Value + ( Value (..), + bool, + int2, + int4, + int8, + float4, + float8, + numeric, + char, + text, + varchar, + bpchar, + bytea, + date, + timestamp, + timestamptz, + time, + timetz, + interval, + uuid, + inet, + macaddr, + json, + jsonBytes, + jsonb, + jsonbBytes, + int4range, + int8range, + numrange, + tsrange, + tstzrange, + daterange, + int4multirange, + int8multirange, + nummultirange, + tsmultirange, + tstzmultirange, + datemultirange, + citext, + custom, + refine, + hstore, + enum, + toDimensionality, + toDecoder, + toSchema, + toTypeName, + toOid, + toBaseOid, + toArrayOid, + isArray, + ) +where + +import CodecVocab.QualifiedTypeName qualified as CodecVocab.QualifiedTypeName +import CodecVocab.TypeInfo qualified as CodecVocab.TypeInfo +import Data.Aeson qualified as Aeson +import Data.IP qualified as Iproute +import Hasql.Platform.Prelude hiding (bool) +import Hasql.ToBeResolved qualified as ToBeResolved +import PostgreSQL.Binary.Decoding qualified as Binary +import PostgreSQL.Binary.Range qualified as R + +-- | +-- Value decoder. +data Value a + = Value + -- | Schema name. + (Maybe Text) + -- | Type name. + Text + -- | Statically known OID for the type. + (Maybe Word32) + -- | Statically known OID for the array-type with this type as the element. + (Maybe Word32) + -- | Dimensionality. If 0 then it is a scalar value, otherwise it is an array with that many dimensions. + Word + -- | Decoding function on a registry of OIDs by type name. + (ToBeResolved.ToBeResolved CodecVocab.QualifiedTypeName.QualifiedTypeName CodecVocab.TypeInfo.TypeInfo (Binary.Value a)) + deriving (Functor) + +type role Value representational + +instance Filterable Value where + {-# INLINE mapMaybe #-} + mapMaybe fn = + refine (maybe (Left "Invalid value") Right . fn) + +-- | +-- Create a decoder from TypeInfo metadata and a decoding function. +{-# INLINE primitive #-} +primitive :: Text -> CodecVocab.TypeInfo.TypeInfo -> Binary.Value a -> Value a +primitive typeName pti decoder = + Value Nothing typeName (Just (CodecVocab.TypeInfo.toBaseOid pti)) (Just (CodecVocab.TypeInfo.toArrayOid pti)) 0 (pure decoder) + +-- * Static types + +-- | +-- Decoder of the @BOOL@ values. +{-# INLINEABLE bool #-} +bool :: Value Bool +bool = primitive "bool" CodecVocab.TypeInfo.bool Binary.bool + +-- | +-- Decoder of the @INT2@ values. +{-# INLINEABLE int2 #-} +int2 :: Value Int16 +int2 = primitive "int2" CodecVocab.TypeInfo.int2 Binary.int + +-- | +-- Decoder of the @INT4@ values. +{-# INLINEABLE int4 #-} +int4 :: Value Int32 +int4 = primitive "int4" CodecVocab.TypeInfo.int4 Binary.int + +-- | +-- Decoder of the @INT8@ values. +{-# INLINEABLE int8 #-} +int8 :: Value Int64 +int8 = + {-# SCC "int8" #-} + primitive "int8" CodecVocab.TypeInfo.int8 ({-# SCC "int8.int" #-} Binary.int) + +-- | +-- Decoder of the @FLOAT4@ values. +{-# INLINEABLE float4 #-} +float4 :: Value Float +float4 = primitive "float4" CodecVocab.TypeInfo.float4 Binary.float4 + +-- | +-- Decoder of the @FLOAT8@ values. +{-# INLINEABLE float8 #-} +float8 :: Value Double +float8 = primitive "float8" CodecVocab.TypeInfo.float8 Binary.float8 + +-- | +-- Decoder of the @NUMERIC@ values. +{-# INLINEABLE numeric #-} +numeric :: Value Scientific +numeric = primitive "numeric" CodecVocab.TypeInfo.numeric Binary.numeric + +-- | +-- Decoder of the @CHAR@ values. +-- Note that it supports Unicode values. +{-# INLINEABLE char #-} +char :: Value Char +char = primitive "char" CodecVocab.TypeInfo.char Binary.char + +-- | +-- Decoder of the @TEXT@ values. +{-# INLINEABLE text #-} +text :: Value Text +text = primitive "text" CodecVocab.TypeInfo.text Binary.text_strict + +-- | +-- Decoder of the @VARCHAR@ values. +{-# INLINEABLE varchar #-} +varchar :: Value Text +varchar = primitive "varchar" CodecVocab.TypeInfo.varchar Binary.text_strict + +-- | +-- Decoder of @BPCHAR@ or @CHAR(n)@, @CHARACTER(n)@ values. +{-# INLINEABLE bpchar #-} +bpchar :: Value Text +bpchar = primitive "bpchar" CodecVocab.TypeInfo.bpchar Binary.text_strict + +-- | +-- Decoder of the @BYTEA@ values. +{-# INLINEABLE bytea #-} +bytea :: Value ByteString +bytea = primitive "bytea" CodecVocab.TypeInfo.bytea Binary.bytea_strict + +-- | +-- Decoder of the @DATE@ values. +{-# INLINEABLE date #-} +date :: Value Day +date = primitive "date" CodecVocab.TypeInfo.date Binary.date + +-- | +-- Decoder of the @TIMESTAMP@ values. +{-# INLINEABLE timestamp #-} +timestamp :: Value LocalTime +timestamp = primitive "timestamp" CodecVocab.TypeInfo.timestamp Binary.timestamp_int + +-- | +-- Decoder of the @TIMESTAMPTZ@ values. +-- +-- /NOTICE/ +-- +-- Postgres does not store the timezone information of @TIMESTAMPTZ@. +-- Instead it stores a UTC value and performs silent conversions +-- to the currently set timezone, when dealt with in the text format. +-- However this library bypasses the silent conversions +-- and communicates with Postgres using the UTC values directly. +{-# INLINEABLE timestamptz #-} +timestamptz :: Value UTCTime +timestamptz = primitive "timestamptz" CodecVocab.TypeInfo.timestamptz Binary.timestamptz_int + +-- | +-- Decoder of the @TIME@ values. +{-# INLINEABLE time #-} +time :: Value TimeOfDay +time = primitive "time" CodecVocab.TypeInfo.time Binary.time_int + +-- | +-- Decoder of the @TIMETZ@ values. +-- +-- Unlike in case of @TIMESTAMPTZ@, +-- Postgres does store the timezone information for @TIMETZ@. +-- However the Haskell's \"time\" library does not contain any composite type, +-- that fits the task, so we use a pair of 'TimeOfDay' and 'TimeZone' +-- to represent a value on the Haskell's side. +{-# INLINEABLE timetz #-} +timetz :: Value (TimeOfDay, TimeZone) +timetz = primitive "timetz" CodecVocab.TypeInfo.timetz Binary.timetz_int + +-- | +-- Decoder of the @INTERVAL@ values. +{-# INLINEABLE interval #-} +interval :: Value DiffTime +interval = primitive "interval" CodecVocab.TypeInfo.interval Binary.interval_int + +-- | +-- Decoder of the @UUID@ values. +{-# INLINEABLE uuid #-} +uuid :: Value UUID +uuid = primitive "uuid" CodecVocab.TypeInfo.uuid Binary.uuid + +-- | +-- Decoder of the @INET@ values. +{-# INLINEABLE inet #-} +inet :: Value Iproute.IPRange +inet = primitive "inet" CodecVocab.TypeInfo.inet Binary.inet + +-- | +-- Decoder of the @MACADDR@ values. +-- +-- Represented as a 6-tuple of Word8 values in big endian order. If +-- you use `ip` library consider using it with `fromOctets`. +-- +-- > (\(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" CodecVocab.TypeInfo.macaddr Binary.macaddr + +-- | +-- Decoder of the @JSON@ values into a JSON AST. +{-# INLINEABLE json #-} +json :: Value Aeson.Value +json = primitive "json" CodecVocab.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" CodecVocab.TypeInfo.json (Binary.json_bytes fn) + +-- | +-- Decoder of the @JSONB@ values into a JSON AST. +{-# INLINEABLE jsonb #-} +jsonb :: Value Aeson.Value +jsonb = primitive "jsonb" CodecVocab.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" CodecVocab.TypeInfo.jsonb (Binary.jsonb_bytes fn) + +-- | +-- Decoder of the @INT4RANGE@ values. +{-# INLINEABLE int4range #-} +int4range :: Value (R.Range Int32) +int4range = primitive "int4range" CodecVocab.TypeInfo.int4range Binary.int4range + +-- | +-- Decoder of the @INT8RANGE@ values. +{-# INLINEABLE int8range #-} +int8range :: Value (R.Range Int64) +int8range = primitive "int8range" CodecVocab.TypeInfo.int8range Binary.int8range + +-- | +-- Decoder of the @NUMRANGE@ values. +{-# INLINEABLE numrange #-} +numrange :: Value (R.Range Scientific) +numrange = primitive "numrange" CodecVocab.TypeInfo.numrange Binary.numrange + +-- | +-- Decoder of the @TSRANGE@ values. +{-# INLINEABLE tsrange #-} +tsrange :: Value (R.Range LocalTime) +tsrange = primitive "tsrange" CodecVocab.TypeInfo.tsrange Binary.tsrange_int + +-- | +-- Decoder of the @TSTZRANGE@ values. +{-# INLINEABLE tstzrange #-} +tstzrange :: Value (R.Range UTCTime) +tstzrange = primitive "tstzrange" CodecVocab.TypeInfo.tstzrange Binary.tstzrange_int + +-- | +-- Decoder of the @DATERANGE@ values. +{-# INLINEABLE daterange #-} +daterange :: Value (R.Range Day) +daterange = primitive "daterange" CodecVocab.TypeInfo.daterange Binary.daterange + +-- | +-- Decoder of the @INT4MULTIRANGE@ values. +{-# INLINEABLE int4multirange #-} +int4multirange :: Value (R.Multirange Int32) +int4multirange = primitive "int4multirange" CodecVocab.TypeInfo.int4multirange Binary.int4multirange + +-- | +-- Decoder of the @INT8MULTIRANGE@ values. +{-# INLINEABLE int8multirange #-} +int8multirange :: Value (R.Multirange Int64) +int8multirange = primitive "int8multirange" CodecVocab.TypeInfo.int8multirange Binary.int8multirange + +-- | +-- Decoder of the @NUMMULTIRANGE@ values. +{-# INLINEABLE nummultirange #-} +nummultirange :: Value (R.Multirange Scientific) +nummultirange = primitive "nummultirange" CodecVocab.TypeInfo.nummultirange Binary.nummultirange + +-- | +-- Decoder of the @TSMULTIRANGE@ values. +{-# INLINEABLE tsmultirange #-} +tsmultirange :: Value (R.Multirange LocalTime) +tsmultirange = primitive "tsmultirange" CodecVocab.TypeInfo.tsmultirange Binary.tsmultirange_int + +-- | +-- Decoder of the @TSTZMULTIRANGE@ values. +{-# INLINEABLE tstzmultirange #-} +tstzmultirange :: Value (R.Multirange UTCTime) +tstzmultirange = primitive "tstzmultirange" CodecVocab.TypeInfo.tstzmultirange Binary.tstzmultirange_int + +-- | +-- Decoder of the @DATEMULTIRANGE@ values. +{-# INLINEABLE datemultirange #-} +datemultirange :: Value (R.Multirange Day) +datemultirange = primitive "datemultirange" CodecVocab.TypeInfo.datemultirange Binary.datemultirange + +-- | +-- Decoder of the @CITEXT@ values. +-- +-- Requires the @citext@ extension to be installed in the database. +{-# INLINEABLE citext #-} +citext :: Value Text +citext = Value Nothing "citext" Nothing Nothing 0 (pure Binary.text_strict) + +-- | +-- Low level API for defining custom value decoders. +{-# INLINEABLE custom #-} +custom :: + -- | Schema name. + Maybe Text -> + -- | Type name. + Text -> + -- | Possible static OIDs for the type. The first is for scalar values the second is for arrays. + -- + -- When unspecified, the OIDs will be automatically determined at runtime by looking up by name. + Maybe (Word32, Word32) -> + -- | 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. + -- + -- When any of the requested types is missing in the database an error will be raised upon the statement execution. + [(Maybe Text, Text)] -> + -- | Deserialization function in the context of resolved OIDs of the types requested in the previous parameter. + -- + -- It's safe to assume that all of the requested types will be present. + -- In case you run the provided lookup function with unmentioned type names it will produce OID of 0 for them, standing for unknown type in Postgres. + ( ((Maybe Text, Text) -> (Word32, Word32)) -> + ByteString -> + Either Text a + ) -> + Value a +custom schema typeName staticOids requestedTypes fn = + Value + schema + typeName + (fmap fst staticOids) + (fmap snd staticOids) + 0 + (ToBeResolved.ToBeResolved (fmap CodecVocab.QualifiedTypeName.fromNameTuple requestedTypes) (\lookup -> Binary.fn (fn (toTuple . lookup . CodecVocab.QualifiedTypeName.fromNameTuple)))) + where + toTuple typeInfo = (CodecVocab.TypeInfo.toBaseOid typeInfo, CodecVocab.TypeInfo.toArrayOid typeInfo) + +-- | +-- Refine a value decoder, lifting the possible error to the session level. +{-# INLINE refine #-} +refine :: (a -> Either Text b) -> Value a -> Value b +refine fn (Value schema typeName typeOid arrayOid dimensionality decoder) = + Value schema typeName typeOid arrayOid dimensionality (fmap (Binary.refine fn) decoder) + +-- | +-- Binary generic decoder of @HSTORE@ values. +-- +-- Here's how you can use it to construct a specific value: +-- +-- @ +-- x :: Value [(Text, Maybe Text)] +-- x = hstore 'replicateM' +-- @ +{-# INLINEABLE hstore #-} +hstore :: (forall m. (Monad m) => Int -> m (Text, Maybe Text) -> m a) -> Value a +hstore replicateM = + Value Nothing "hstore" Nothing Nothing 0 (pure (Binary.hstore replicateM Binary.text_strict Binary.text_strict)) + +-- | +-- Given a partial mapping from text to value, produces a decoder of that value for a named enum type. +enum :: + -- | Schema name. + Maybe Text -> + -- | Type name. + Text -> + -- | Mapping from text to value. + (Text -> Maybe a) -> + Value a +enum schema typeName mapping = + Value schema typeName Nothing Nothing 0 (pure (Binary.enum mapping)) + +-- * Relations + +toDimensionality :: Value a -> Word +toDimensionality (Value _ _ _ _ dimensionality _) = dimensionality + +toSchema :: Value a -> Maybe Text +toSchema (Value schema _ _ _ _ _) = schema + +toTypeName :: Value a -> Text +toTypeName (Value _ typeName _ _ _ _) = typeName + +toOid :: Value a -> Maybe Word32 +toOid (Value _ _ baseOid arrayOid dimensionality _) = + if dimensionality > 0 + then arrayOid + else baseOid + +toBaseOid :: Value a -> Maybe Word32 +toBaseOid (Value _ _ baseOid _ _ _) = baseOid + +toArrayOid :: Value a -> Maybe Word32 +toArrayOid (Value _ _ _ oid _ _) = oid + +toDecoder :: Value a -> ToBeResolved.ToBeResolved CodecVocab.QualifiedTypeName.QualifiedTypeName CodecVocab.TypeInfo.TypeInfo (Binary.Value a) +toDecoder (Value _ _ _ _ _ decoder) = decoder + +isArray :: Value a -> Bool +isArray (Value _ _ _ _ dimensionality _) = dimensionality > 0 diff --git a/src/library/Hasql/Codecs/Encoders.hs b/src/library/Hasql/Codecs/Encoders.hs new file mode 100644 --- /dev/null +++ b/src/library/Hasql/Codecs/Encoders.hs @@ -0,0 +1,147 @@ +-- | +-- A DSL for declaration of statement parameter encoders. +-- +-- For compactness of names all the types defined here imply being an encoder. +-- E.g., the `Array` type is an __encoder__ of arrays, not the data-structure itself. +module Hasql.Codecs.Encoders + ( -- * Parameters product + Params.Params, + Params.noParams, + Params.param, + + -- * Nullability + NullableOrNot.NullableOrNot, + NullableOrNot.nonNullable, + NullableOrNot.nullable, + + -- * Value + Value.Value, + Value.bool, + Value.int2, + Value.int4, + Value.int8, + Value.float4, + Value.float8, + Value.numeric, + Value.char, + Value.text, + Value.varchar, + Value.bpchar, + Value.bytea, + Value.date, + Value.timestamp, + Value.timestamptz, + Value.time, + Value.timetz, + Value.interval, + Value.uuid, + Value.inet, + Value.macaddr, + Value.json, + Value.jsonBytes, + Value.jsonLazyBytes, + Value.jsonb, + Value.jsonbBytes, + Value.jsonbLazyBytes, + Value.int4range, + Value.int8range, + Value.numrange, + Value.tsrange, + Value.tstzrange, + Value.daterange, + Value.int4multirange, + Value.int8multirange, + Value.nummultirange, + Value.tsmultirange, + Value.tstzmultirange, + Value.datemultirange, + Value.citext, + Value.name, + Value.oid, + foldableArray, + array, + Value.hstore, + Value.enum, + composite, + Value.unknown, + Value.custom, + + -- * Array + Array.Array, + Array.element, + Array.dimension, + + -- * Composite + Composite.Composite, + Composite.field, + ) +where + +import CodecVocab.QualifiedTypeName qualified as CodecVocab.QualifiedTypeName +import CodecVocab.TypeInfo qualified as CodecVocab.TypeInfo +import Hasql.Codecs.Encoders.Array qualified as Array +import Hasql.Codecs.Encoders.Composite qualified as Composite +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.Platform.Prelude hiding (bool) +import Hasql.ToBeResolved qualified as ToBeResolved +import PostgreSQL.Binary.Encoding qualified as Binary +import TextBuilder qualified + +-- * Recursive definitions + +-- | +-- Lift a value encoder of element into a unidimensional array encoder of a foldable value. +-- +-- This function is merely a shortcut to the following expression: +-- +-- @ +-- ('array' . 'Array.dimension' 'foldl'' . 'Array.element') +-- @ +-- +-- You can use it like this: +-- +-- @ +-- vectorOfInts :: Value (Vector Int64) +-- vectorOfInts = 'foldableArray' ('nonNullable' 'int8') +-- @ +-- +-- Please notice that in case of multidimensional arrays nesting 'foldableArray' encoder +-- won't work. You have to explicitly construct the array encoder using 'array'. +{-# INLINE foldableArray #-} +foldableArray :: (Foldable foldable) => NullableOrNot.NullableOrNot Value.Value element -> Value.Value (foldable element) +foldableArray = array . Array.dimension foldl' . Array.element + +-- | +-- Lift an array encoder into a value encoder. +array :: Array.Array a -> Value.Value a +array (Array.Array baseTypeSchema baseTypeName _isText dimensionality scalarOidIfKnown arrayOidIfKnown arrayEncoder renderer) = + let toEncoder baseOid encode = \input -> Binary.array baseOid (encode input) + encoder = case scalarOidIfKnown of + Just oid -> fmap (toEncoder oid) arrayEncoder + Nothing -> + (\typeInfo -> toEncoder (CodecVocab.TypeInfo.toBaseOid typeInfo)) + <$> ToBeResolved.lookup (CodecVocab.QualifiedTypeName.QualifiedTypeName baseTypeSchema baseTypeName) + <*> arrayEncoder + in Value.Value baseTypeSchema baseTypeName scalarOidIfKnown arrayOidIfKnown dimensionality False encoder renderer + +-- | +-- Lift a composite encoder into a value encoder for named composite types. +-- +-- This function is for named composite types where the type name is known. +-- If you need to encode an anonymous composite type (like those created with the ROW constructor), +-- PostgreSQL itself does not support that. +composite :: + -- | Schema name where the composite type is defined. + Maybe Text -> + -- | Composite type name. + Text -> + Composite.Composite a -> + Value.Value a +composite schema name (Composite.Composite request print) = + Value.Value schema name Nothing Nothing 0 False encoder printValue + where + encoder = fmap (Binary.composite .) request + printValue val = + "ROW (" <> TextBuilder.intercalate ", " (print val) <> ")" diff --git a/src/library/Hasql/Codecs/Encoders/Array.hs b/src/library/Hasql/Codecs/Encoders/Array.hs new file mode 100644 --- /dev/null +++ b/src/library/Hasql/Codecs/Encoders/Array.hs @@ -0,0 +1,102 @@ +module Hasql.Codecs.Encoders.Array where + +import CodecVocab.QualifiedTypeName qualified as CodecVocab.QualifiedTypeName +import CodecVocab.TypeInfo qualified as CodecVocab.TypeInfo +import Hasql.Codecs.Encoders.NullableOrNot qualified as NullableOrNot +import Hasql.Codecs.Encoders.Value qualified as Value +import Hasql.Platform.Prelude +import Hasql.ToBeResolved qualified as ToBeResolved +import PostgreSQL.Binary.Encoding qualified as Binary +import TextBuilder qualified as TextBuilder + +-- | +-- Generic array encoder. +-- +-- Here's an example of its usage: +-- +-- @ +-- someParamsEncoder :: 'Params' [[Int64]] +-- someParamsEncoder = 'param' ('nonNullable' ('array' ('dimension' 'foldl'' ('dimension' 'foldl'' ('element' ('nonNullable' 'int8')))))) +-- @ +-- +-- Please note that the PostgreSQL @IN@ keyword does not accept an array, but rather a syntactical list of +-- values, thus this encoder is not suited for that. Use a @value = ANY($1)@ condition instead. +data Array a + = Array + -- | Schema name, if any. + (Maybe Text) + -- | Type name. + Text + -- | Text format? + Bool + -- | Dimensionality. If 0 then it is not an array, but a scalar value. + Word + -- | OID of the element type. + (Maybe Word32) + -- | OID of the array type. + (Maybe Word32) + -- | Serialization function, deferring the names of types that must be looked up at runtime. + (ToBeResolved.ToBeResolved CodecVocab.QualifiedTypeName.QualifiedTypeName CodecVocab.TypeInfo.TypeInfo (a -> Binary.Array)) + -- | Render function for error messages. + (a -> TextBuilder.TextBuilder) + +instance Contravariant Array where + contramap fn (Array schemaName typeName textFormat dimensionality valueOid arrayOid elEncoder elRenderer) = + Array schemaName typeName textFormat dimensionality valueOid arrayOid (fmap (\encode -> encode . fn) elEncoder) (elRenderer . fn) + +-- | +-- Lifts a 'Value.Value' encoder into an 'Array' encoder. +element :: NullableOrNot.NullableOrNot Value.Value a -> Array a +element = \case + NullableOrNot.NonNullable (Value.Value schemaName typeName scalarOid arrayOid dimensionality textFormat serialize print) -> + Array + schemaName + typeName + textFormat + dimensionality + scalarOid + arrayOid + (fmap (Binary.encodingArray .) serialize) + print + NullableOrNot.Nullable (Value.Value schemaName typeName scalarOid arrayOid dimensionality textFormat serialize print) -> + let maybeSerialize encode = + maybe Binary.nullArray (Binary.encodingArray . encode) + maybePrint = + maybe (TextBuilder.string "null") print + in Array + schemaName + typeName + textFormat + dimensionality + scalarOid + arrayOid + (fmap maybeSerialize serialize) + maybePrint + +-- | +-- Encoder of an array dimension, +-- which thus provides support for multidimensional arrays. +-- +-- Accepts: +-- +-- * An implementation of the left-fold operation, +-- such as @Data.Foldable.'foldl''@, +-- which determines the input value. +-- +-- * A component encoder, which can be either another 'dimension' or 'element'. +{-# INLINE dimension #-} +dimension :: (forall a. (a -> b -> a) -> a -> c -> a) -> Array b -> Array c +dimension fold (Array schemaName typeName textFormat dimensionality valueOid arrayOid elEncoder elRenderer) = + let encoder = + Binary.dimensionArray fold + renderer els = + let folded = + let step builder el = + if TextBuilder.isEmpty builder + then TextBuilder.char '[' <> elRenderer el + else builder <> TextBuilder.string ", " <> elRenderer el + in fold step mempty els + in if TextBuilder.isEmpty folded + then TextBuilder.string "[]" + else folded <> TextBuilder.char ']' + in Array schemaName typeName textFormat (succ dimensionality) valueOid arrayOid (fmap encoder elEncoder) renderer diff --git a/src/library/Hasql/Codecs/Encoders/Composite.hs b/src/library/Hasql/Codecs/Encoders/Composite.hs new file mode 100644 --- /dev/null +++ b/src/library/Hasql/Codecs/Encoders/Composite.hs @@ -0,0 +1,73 @@ +module Hasql.Codecs.Encoders.Composite where + +import CodecVocab.QualifiedTypeName qualified as CodecVocab.QualifiedTypeName +import CodecVocab.TypeInfo qualified as CodecVocab.TypeInfo +import Hasql.Codecs.Encoders.NullableOrNot qualified as NullableOrNot +import Hasql.Codecs.Encoders.Value qualified as Value +import Hasql.Platform.Prelude hiding (bool) +import Hasql.ToBeResolved qualified as ToBeResolved +import PostgreSQL.Binary.Encoding qualified as Binary +import TextBuilder qualified + +-- | +-- Composite or row-types encoder. +data Composite a + = Composite + -- | Serialization function, deferring the names of types that must be looked up at runtime. + (ToBeResolved.ToBeResolved CodecVocab.QualifiedTypeName.QualifiedTypeName CodecVocab.TypeInfo.TypeInfo (a -> Binary.Composite)) + -- | Render function for error messages. + (a -> [TextBuilder.TextBuilder]) + +instance Contravariant Composite where + contramap f (Composite request print) = + Composite (fmap (. f) request) (print . f) + +instance Divisible Composite where + divide f (Composite requestL printL) (Composite requestR printR) = + Composite + ( liftA2 + (\encodeL encodeR val -> case f val of (lVal, rVal) -> encodeL lVal <> encodeR rVal) + requestL + requestR + ) + (\val -> case f val of (lVal, rVal) -> printL lVal <> printR rVal) + conquer = mempty + +instance Semigroup (Composite a) where + Composite requestL printL <> Composite requestR printR = + Composite + (liftA2 (\encodeL encodeR val -> encodeL val <> encodeR val) requestL requestR) + (\val -> printL val <> printR val) + +instance Monoid (Composite a) where + mempty = Composite (pure mempty) mempty + +-- | Single field of a row-type. +field :: NullableOrNot.NullableOrNot Value.Value a -> Composite a +field = \case + NullableOrNot.NonNullable (Value.Value schemaName typeName scalarOid arrayOid dimensionality _ serialize print) -> + let staticOid = if dimensionality == 0 then scalarOid else arrayOid + toField oid encode = \val -> Binary.field oid (encode val) + in case staticOid of + Just oid -> + Composite (fmap (toField oid) serialize) (\val -> [print val]) + Nothing -> + Composite + ( (\typeInfo -> toField (if dimensionality == 0 then CodecVocab.TypeInfo.toBaseOid typeInfo else CodecVocab.TypeInfo.toArrayOid typeInfo)) + <$> ToBeResolved.lookup (CodecVocab.QualifiedTypeName.QualifiedTypeName schemaName typeName) + <*> serialize + ) + (\val -> [print val]) + NullableOrNot.Nullable (Value.Value schemaName typeName scalarOid arrayOid dimensionality _ serialize print) -> + let staticOid = if dimensionality == 0 then scalarOid else arrayOid + toField oid encode = maybe (Binary.nullField oid) (Binary.field oid . encode) + in case staticOid of + Just oid -> + Composite (fmap (toField oid) serialize) (maybe ["NULL"] (\val -> [print val])) + Nothing -> + Composite + ( (\typeInfo -> toField (if dimensionality == 0 then CodecVocab.TypeInfo.toBaseOid typeInfo else CodecVocab.TypeInfo.toArrayOid typeInfo)) + <$> ToBeResolved.lookup (CodecVocab.QualifiedTypeName.QualifiedTypeName schemaName typeName) + <*> serialize + ) + (maybe ["NULL"] (\val -> [print val])) diff --git a/src/library/Hasql/Codecs/Encoders/NullableOrNot.hs b/src/library/Hasql/Codecs/Encoders/NullableOrNot.hs new file mode 100644 --- /dev/null +++ b/src/library/Hasql/Codecs/Encoders/NullableOrNot.hs @@ -0,0 +1,19 @@ +module Hasql.Codecs.Encoders.NullableOrNot where + +import Hasql.Platform.Prelude + +-- | +-- Extensional specification of nullability over a generic encoder. +data NullableOrNot encoder a where + NonNullable :: encoder a -> NullableOrNot encoder a + Nullable :: encoder a -> NullableOrNot encoder (Maybe a) + +-- | +-- Specify that an encoder produces a non-nullable value. +nonNullable :: encoder a -> NullableOrNot encoder a +nonNullable = NonNullable + +-- | +-- Specify that an encoder produces a nullable value. +nullable :: encoder a -> NullableOrNot encoder (Maybe a) +nullable = Nullable diff --git a/src/library/Hasql/Codecs/Encoders/Params.hs b/src/library/Hasql/Codecs/Encoders/Params.hs new file mode 100644 --- /dev/null +++ b/src/library/Hasql/Codecs/Encoders/Params.hs @@ -0,0 +1,195 @@ +module Hasql.Codecs.Encoders.Params + ( Params, + noParams, + param, + toColumnsMetadata, + toUnknownTypes, + toSerializer, + toPrinter, + ) +where + +import CodecVocab qualified as CodecVocab +import CodecVocab.QualifiedTypeName qualified as CodecVocab.QualifiedTypeName +import CodecVocab.TypeRef qualified as CodecVocab.TypeRef +import CodecVocab.TypeShape (TypeShape (..)) +import Data.Vector qualified as Vector +import Hasql.Codecs.Encoders.NullableOrNot qualified as NullableOrNot +import Hasql.Codecs.Encoders.Value qualified as Value +import Hasql.Platform.Prelude +import Hasql.ToBeResolved qualified as ToBeResolved +import PostgreSQL.Binary.Encoding qualified as Binary +import TextBuilder qualified + +-- | Frozen per-parameter type shapes: type reference, dimensionality, text-format flag. +toColumnsMetadata :: Params a -> Vector TypeShape +toColumnsMetadata (Params _ _ columnsMetadata _) = freezeColumnsMetadata columnsMetadata + where + freezeColumnsMetadata = + Vector.fromList . toList + +toUnknownTypes :: Params a -> HashSet CodecVocab.QualifiedTypeName +toUnknownTypes (Params _ (ToBeResolved.ToBeResolved unknownTypes _) _ _) = + fromList unknownTypes + +-- | Serialise params to encoded wire values given a resolver of type names to their OIDs. +toSerializer :: Params a -> (CodecVocab.QualifiedTypeName -> CodecVocab.TypeInfo) -> a -> [Maybe ByteString] +toSerializer (Params _ (ToBeResolved.ToBeResolved _ serializer) _ _) resolve = serializer resolve + +-- | 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. +-- +-- Has instances of 'Contravariant', 'Divisible' and 'Monoid', +-- which you can use to compose multiple parameters together. +-- E.g., +-- +-- @ +-- someParamsEncoder :: 'Params' (Int64, Maybe Text) +-- someParamsEncoder = +-- ('fst' '>$<' 'param' ('nonNullable' 'int8')) '<>' +-- ('snd' '>$<' 'param' ('nullable' 'text')) +-- @ +-- +-- 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. +-- E.g., here's how you can achieve the same as the above: +-- +-- @ +-- someParamsEncoder :: 'Params' (Int64, Maybe Text) +-- someParamsEncoder = +-- 'contrazip2' ('param' ('nonNullable' 'int8')) ('param' ('nullable' 'text')) +-- @ +-- +-- Here's how you can implement encoders for custom composite types: +-- +-- @ +-- data Person = Person { name :: Text, gender :: Gender, age :: Int } +-- +-- data Gender = Male | Female +-- +-- personParams :: 'Params' Person +-- personParams = +-- (name '>$<' 'param' ('nonNullable' 'text')) '<>' +-- (gender '>$<' 'param' ('nonNullable' genderValue)) '<>' +-- ('fromIntegral' . age '>$<' 'param' ('nonNullable' 'int8')) +-- +-- genderValue :: 'Value.Value' Gender +-- genderValue = 'enum' Nothing (Just "gender") genderText where +-- genderText gender = case gender of +-- Male -> "male" +-- Female -> "female" +-- @ +data Params a = Params + { size :: Int, + -- | Serialization function, deferring the names of types that must be looked up at runtime. + request :: ToBeResolved.ToBeResolved CodecVocab.QualifiedTypeName CodecVocab.TypeInfo (a -> [Maybe ByteString]), + -- | Type shape for each parameter. + columnsMetadata :: DList TypeShape, + printer :: a -> DList Text + } + +instance Contravariant Params where + contramap fn (Params size request columnsMetadata printer) = + Params size (fmap (. fn) request) columnsMetadata (printer . fn) + +instance Divisible Params where + divide + divisor + (Params leftSize leftRequest leftColumnsMetadata leftPrinter) + (Params rightSize rightRequest rightColumnsMetadata rightPrinter) = + Params + { size = leftSize + rightSize, + request = + liftA2 + ( \leftSerializer rightSerializer input -> case divisor input of + (leftInput, rightInput) -> leftSerializer leftInput <> rightSerializer rightInput + ) + leftRequest + rightRequest, + columnsMetadata = leftColumnsMetadata <> rightColumnsMetadata, + printer = \input -> case divisor input of + (leftInput, rightInput) -> leftPrinter leftInput <> rightPrinter rightInput + } + conquer = + Params + { size = 0, + request = pure mempty, + columnsMetadata = mempty, + printer = mempty + } + +instance Semigroup (Params a) where + Params leftSize leftRequest leftColumnsMetadata leftPrinter <> Params rightSize rightRequest rightColumnsMetadata rightPrinter = + Params + { size = leftSize + rightSize, + request = liftA2 (\leftSerializer rightSerializer input -> leftSerializer input <> rightSerializer input) leftRequest rightRequest, + columnsMetadata = leftColumnsMetadata <> rightColumnsMetadata, + printer = \input -> leftPrinter input <> rightPrinter input + } + +instance Monoid (Params a) where + mempty = conquer + +value :: Value.Value a -> Params a +value (Value.Value schemaName typeName scalarOid arrayOid dimensionality textFormat serialize print) = + let staticOid = if dimensionality == 0 then scalarOid else arrayOid + toRequest = fmap (\encode -> pure . Just . Binary.encodingBytes . encode) + printer = pure . TextBuilder.toText . print + size = 1 + in case staticOid of + Just oid -> + Params + { size, + request = toRequest serialize, + columnsMetadata = pure (TypeShape (CodecVocab.TypeRef.KnownOid oid) dimensionality textFormat), + printer + } + Nothing -> + let key = CodecVocab.QualifiedTypeName.QualifiedTypeName schemaName typeName + in Params + { size, + request = toRequest (ToBeResolved.lookup key *> serialize), + columnsMetadata = pure (TypeShape (CodecVocab.TypeRef.NamedType key) dimensionality textFormat), + printer + } + +nullableValue :: Value.Value a -> Params (Maybe a) +nullableValue (Value.Value schemaName typeName scalarOid arrayOid dimensionality textFormat serialize print) = + let staticOid = if dimensionality == 0 then scalarOid else arrayOid + toRequest = fmap (\encode -> pure . fmap (Binary.encodingBytes . encode)) + printer = pure . maybe "null" (TextBuilder.toText . print) + size = 1 + in case staticOid of + Just oid -> + Params + { size, + request = toRequest serialize, + columnsMetadata = pure (TypeShape (CodecVocab.TypeRef.KnownOid oid) dimensionality textFormat), + printer + } + Nothing -> + let key = CodecVocab.QualifiedTypeName.QualifiedTypeName schemaName typeName + in Params + { size, + request = toRequest (ToBeResolved.lookup key *> serialize), + columnsMetadata = pure (TypeShape (CodecVocab.TypeRef.NamedType key) dimensionality textFormat), + printer + } + +-- | +-- No parameters. Same as `mempty` and `conquered`. +noParams :: Params () +noParams = mempty + +-- | +-- Lift a single parameter encoder, with its nullability specified, +-- associating it with a single placeholder. +param :: NullableOrNot.NullableOrNot Value.Value a -> Params a +param = \case + NullableOrNot.NonNullable valueEnc -> value valueEnc + NullableOrNot.Nullable valueEnc -> nullableValue valueEnc diff --git a/src/library/Hasql/Codecs/Encoders/Value.hs b/src/library/Hasql/Codecs/Encoders/Value.hs new file mode 100644 --- /dev/null +++ b/src/library/Hasql/Codecs/Encoders/Value.hs @@ -0,0 +1,450 @@ +module Hasql.Codecs.Encoders.Value where + +import ByteString.StrictBuilder qualified +import CodecVocab qualified as CodecVocab +import CodecVocab.QualifiedTypeName qualified as CodecVocab.QualifiedTypeName +import CodecVocab.TypeInfo qualified as CodecVocab.TypeInfo +import Data.Aeson qualified as Aeson +import Data.ByteString.Lazy qualified as LazyByteString +import Data.IP qualified as Iproute +import Hasql.Platform.Prelude +import Hasql.ToBeResolved qualified as ToBeResolved +import PostgreSQL.Binary.Encoding qualified as Binary +import PostgreSQL.Binary.Range qualified as Range +import TextBuilder qualified as TextBuilder + +-- | +-- Value encoder. +data Value a + = Value + -- | Schema name, if any. + (Maybe Text) + -- | Type name. + Text + -- | Statically known OID for the type. + -- When unspecified, the OID may be determined at runtime by looking up by name. + (Maybe Word32) + -- | Statically known OID for the array-type with this type as the element. + -- When unspecified, the OID may be determined at runtime by looking up by name. + -- It may also mean that there may be no array type containing this type, which is the case in attempts to double-nest arrays. + (Maybe Word32) + -- | Dimensionality. If 0 then it is not an array, but a scalar value. + Word + -- | Text format? + Bool + -- | Serialization function, deferring the names of types that must be looked up at runtime. + (ToBeResolved.ToBeResolved CodecVocab.QualifiedTypeName CodecVocab.TypeInfo (a -> Binary.Encoding)) + -- | Render function for error messages. + (a -> TextBuilder.TextBuilder) + +instance Contravariant Value where + {-# INLINE contramap #-} + contramap f (Value schemaName typeName valueOid arrayOid dimensionality textFormat serialize render) = + Value schemaName typeName valueOid arrayOid dimensionality textFormat (fmap (\encode -> encode . f) serialize) (render . f) + +{-# INLINE primitive #-} +primitive :: Text -> Bool -> CodecVocab.TypeInfo -> (a -> Binary.Encoding) -> (a -> TextBuilder.TextBuilder) -> Value a +primitive typeName isText typeInfo encode render = + Value + Nothing + typeName + (Just (CodecVocab.TypeInfo.toBaseOid typeInfo)) + (Just (CodecVocab.TypeInfo.toArrayOid typeInfo)) + 0 + isText + (pure encode) + render + +-- | +-- Encoder of @BOOL@ values. +{-# INLINEABLE bool #-} +bool :: Value Bool +bool = primitive "bool" False CodecVocab.TypeInfo.bool Binary.bool (TextBuilder.string . show) + +-- | +-- Encoder of @INT2@ values. +{-# INLINEABLE int2 #-} +int2 :: Value Int16 +int2 = primitive "int2" False CodecVocab.TypeInfo.int2 Binary.int2_int16 (TextBuilder.string . show) + +-- | +-- Encoder of @INT4@ values. +{-# INLINEABLE int4 #-} +int4 :: Value Int32 +int4 = primitive "int4" False CodecVocab.TypeInfo.int4 Binary.int4_int32 (TextBuilder.string . show) + +-- | +-- Encoder of @INT8@ values. +{-# INLINEABLE int8 #-} +int8 :: Value Int64 +int8 = primitive "int8" False CodecVocab.TypeInfo.int8 Binary.int8_int64 (TextBuilder.string . show) + +-- | +-- Encoder of @FLOAT4@ values. +{-# INLINEABLE float4 #-} +float4 :: Value Float +float4 = primitive "float4" False CodecVocab.TypeInfo.float4 Binary.float4 (TextBuilder.string . show) + +-- | +-- Encoder of @FLOAT8@ values. +{-# INLINEABLE float8 #-} +float8 :: Value Double +float8 = primitive "float8" False CodecVocab.TypeInfo.float8 Binary.float8 (TextBuilder.string . show) + +-- | +-- Encoder of @NUMERIC@ values. +{-# INLINEABLE numeric #-} +numeric :: Value Scientific +numeric = primitive "numeric" False CodecVocab.TypeInfo.numeric Binary.numeric (TextBuilder.string . show) + +-- | +-- Encoder of @CHAR@ values. +-- +-- Note that it supports Unicode values and +-- identifies itself under the @TEXT@ OID because of that. +{-# INLINEABLE char #-} +char :: Value Char +char = primitive "char" False CodecVocab.TypeInfo.text Binary.char_utf8 (TextBuilder.string . show) + +-- | +-- Encoder of @TEXT@ values. +{-# INLINEABLE text #-} +text :: Value Text +text = primitive "text" False CodecVocab.TypeInfo.text Binary.text_strict (TextBuilder.string . show) + +-- | +-- Encoder of @VARCHAR@ values. +{-# INLINEABLE varchar #-} +varchar :: Value Text +varchar = primitive "varchar" False CodecVocab.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 CodecVocab.TypeInfo.bpchar Binary.text_strict (TextBuilder.string . show) + +-- | +-- Encoder of @BYTEA@ values. +{-# INLINEABLE bytea #-} +bytea :: Value ByteString +bytea = primitive "bytea" False CodecVocab.TypeInfo.bytea Binary.bytea_strict (TextBuilder.string . show) + +-- | +-- Encoder of @DATE@ values. +{-# INLINEABLE date #-} +date :: Value Day +date = primitive "date" False CodecVocab.TypeInfo.date Binary.date (TextBuilder.string . show) + +-- | +-- Encoder of @TIMESTAMP@ values. +{-# INLINEABLE timestamp #-} +timestamp :: Value LocalTime +timestamp = primitive "timestamp" False CodecVocab.TypeInfo.timestamp Binary.timestamp_int (TextBuilder.string . show) + +-- | +-- Encoder of @TIMESTAMPTZ@ values. +{-# INLINEABLE timestamptz #-} +timestamptz :: Value UTCTime +timestamptz = primitive "timestamptz" False CodecVocab.TypeInfo.timestamptz Binary.timestamptz_int (TextBuilder.string . show) + +-- | +-- Encoder of @TIME@ values. +{-# INLINEABLE time #-} +time :: Value TimeOfDay +time = primitive "time" False CodecVocab.TypeInfo.time Binary.time_int (TextBuilder.string . show) + +-- | +-- Encoder of @TIMETZ@ values. +{-# INLINEABLE timetz #-} +timetz :: Value (TimeOfDay, TimeZone) +timetz = primitive "timetz" False CodecVocab.TypeInfo.timetz Binary.timetz_int (TextBuilder.string . show) + +-- | +-- Encoder of @INTERVAL@ values. +{-# INLINEABLE interval #-} +interval :: Value DiffTime +interval = primitive "interval" False CodecVocab.TypeInfo.interval Binary.interval_int (TextBuilder.string . show) + +-- | +-- Encoder of @UUID@ values. +{-# INLINEABLE uuid #-} +uuid :: Value UUID +uuid = primitive "uuid" False CodecVocab.TypeInfo.uuid Binary.uuid (TextBuilder.string . show) + +-- | +-- Encoder of @INET@ values. +{-# INLINEABLE inet #-} +inet :: Value Iproute.IPRange +inet = primitive "inet" False CodecVocab.TypeInfo.inet Binary.inet (TextBuilder.string . show) + +-- | +-- Encoder of @MACADDR@ values. +-- +-- Represented as a 6-tuple of Word8 values in big endian order. If +-- you use `ip` library you can convert using its `toOctets`. +-- +-- > toOctets >$< macaddr +{-# INLINEABLE macaddr #-} +macaddr :: Value (Word8, Word8, Word8, Word8, Word8, Word8) +macaddr = primitive "macaddr" False CodecVocab.TypeInfo.macaddr Binary.macaddr (TextBuilder.string . show) + +-- | +-- Encoder of @JSON@ values from JSON AST. +{-# INLINEABLE json #-} +json :: Value Aeson.Value +json = primitive "json" False CodecVocab.TypeInfo.json Binary.json_ast (TextBuilder.string . show) + +-- | +-- Encoder of @JSON@ values from raw JSON. +{-# INLINEABLE jsonBytes #-} +jsonBytes :: Value ByteString +jsonBytes = primitive "json" False CodecVocab.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 CodecVocab.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 CodecVocab.TypeInfo.jsonb Binary.jsonb_ast (TextBuilder.string . show) + +-- | +-- Encoder of @JSONB@ values from raw JSON. +{-# INLINEABLE jsonbBytes #-} +jsonbBytes :: Value ByteString +jsonbBytes = primitive "jsonb" False CodecVocab.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 CodecVocab.TypeInfo.jsonb Binary.jsonb_bytes_lazy (TextBuilder.string . show) + +-- | +-- Encoder of @OID@ values. +{-# INLINEABLE oid #-} +oid :: Value Int32 +oid = primitive "oid" False CodecVocab.TypeInfo.oid Binary.int4_int32 (TextBuilder.string . show) + +-- | +-- Encoder of @NAME@ values. +{-# INLINEABLE name #-} +name :: Value Text +name = primitive "name" False CodecVocab.TypeInfo.name Binary.text_strict (TextBuilder.string . show) + +-- | +-- Encoder of @INT4RANGE@ values. +{-# INLINEABLE int4range #-} +int4range :: Value (Range.Range Int32) +int4range = primitive "int4range" False CodecVocab.TypeInfo.int4range Binary.int4range (TextBuilder.string . show) + +-- | +-- Encoder of @INT8RANGE@ values. +{-# INLINEABLE int8range #-} +int8range :: Value (Range.Range Int64) +int8range = primitive "int8range" False CodecVocab.TypeInfo.int8range Binary.int8range (TextBuilder.string . show) + +-- | +-- Encoder of @NUMRANGE@ values. +{-# INLINEABLE numrange #-} +numrange :: Value (Range.Range Scientific) +numrange = primitive "numrange" False CodecVocab.TypeInfo.numrange Binary.numrange (TextBuilder.string . show) + +-- | +-- Encoder of @TSRANGE@ values. +{-# INLINEABLE tsrange #-} +tsrange :: Value (Range.Range LocalTime) +tsrange = primitive "tsrange" False CodecVocab.TypeInfo.tsrange Binary.tsrange_int (TextBuilder.string . show) + +-- | +-- Encoder of @TSTZRANGE@ values. +{-# INLINEABLE tstzrange #-} +tstzrange :: Value (Range.Range UTCTime) +tstzrange = primitive "tstzrange" False CodecVocab.TypeInfo.tstzrange Binary.tstzrange_int (TextBuilder.string . show) + +-- | +-- Encoder of @DATERANGE@ values. +{-# INLINEABLE daterange #-} +daterange :: Value (Range.Range Day) +daterange = primitive "daterange" False CodecVocab.TypeInfo.daterange Binary.daterange (TextBuilder.string . show) + +-- | +-- Encoder of @INT4MULTIRANGE@ values. +{-# INLINEABLE int4multirange #-} +int4multirange :: Value (Range.Multirange Int32) +int4multirange = primitive "int4multirange" False CodecVocab.TypeInfo.int4multirange Binary.int4multirange (TextBuilder.string . show) + +-- | +-- Encoder of @INT8MULTIRANGE@ values. +{-# INLINEABLE int8multirange #-} +int8multirange :: Value (Range.Multirange Int64) +int8multirange = primitive "int8multirange" False CodecVocab.TypeInfo.int8multirange Binary.int8multirange (TextBuilder.string . show) + +-- | +-- Encoder of @NUMMULTIRANGE@ values. +{-# INLINEABLE nummultirange #-} +nummultirange :: Value (Range.Multirange Scientific) +nummultirange = primitive "nummultirange" False CodecVocab.TypeInfo.nummultirange Binary.nummultirange (TextBuilder.string . show) + +-- | +-- Encoder of @TSMULTIRANGE@ values. +{-# INLINEABLE tsmultirange #-} +tsmultirange :: Value (Range.Multirange LocalTime) +tsmultirange = primitive "tsmultirange" False CodecVocab.TypeInfo.tsmultirange Binary.tsmultirange_int (TextBuilder.string . show) + +-- | +-- Encoder of @TSTZMULTIRANGE@ values. +{-# INLINEABLE tstzmultirange #-} +tstzmultirange :: Value (Range.Multirange UTCTime) +tstzmultirange = primitive "tstzmultirange" False CodecVocab.TypeInfo.tstzmultirange Binary.tstzmultirange_int (TextBuilder.string . show) + +-- | +-- Encoder of @DATEMULTIRANGE@ values. +{-# INLINEABLE datemultirange #-} +datemultirange :: Value (Range.Multirange Day) +datemultirange = primitive "datemultirange" False CodecVocab.TypeInfo.datemultirange Binary.datemultirange (TextBuilder.string . show) + +-- | +-- Encoder of @CITEXT@ values. +-- +-- Requires the @citext@ extension to be installed in the database. +{-# INLINEABLE citext #-} +citext :: Value Text +citext = + Value + Nothing + "citext" + Nothing + Nothing + 0 + False + (pure Binary.text_strict) + (TextBuilder.string . show) + +-- | +-- Given a function which maps a value into a textual enum label used on the DB side, +-- produces an encoder of that value for a named enum type. +{-# INLINEABLE enum #-} +enum :: + -- | Schema name where the enum type is defined. + Maybe Text -> + -- | Enum type name. + Text -> + -- | Mapping function from value to enum label. + (a -> Text) -> + Value a +enum schemaName typeName mapping = + Value + schemaName + typeName + Nothing + Nothing + 0 + False + (fmap (\_typeInfo -> Binary.text_strict . mapping) (ToBeResolved.lookup (CodecVocab.QualifiedTypeName schemaName typeName))) + (TextBuilder.text . mapping) + +-- | +-- Identifies the value with the PostgreSQL's \"unknown\" type, +-- thus leaving it up to Postgres to infer the actual type of the value. +-- +-- The value transmitted is any value encoded in the Postgres' Text data format. +-- For reference, see the +-- +-- section of the Postgres' documentation. +-- +-- __Warning:__ Do not use this as part of composite encoders like 'array' since +-- it is the only encoder that doesn't use the binary format. +{-# DEPRECATED unknown "Use 'custom' instead." #-} +{-# INLINEABLE unknown #-} +unknown :: Value ByteString +unknown = primitive "unknown" True CodecVocab.TypeInfo.unknown Binary.bytea_strict (TextBuilder.string . show) + +-- | +-- Low level API for defining custom value encoders. +{-# INLINEABLE custom #-} +custom :: + -- | Schema name where the type is defined. + Maybe Text -> + -- | Type name. + Text -> + -- | Possible static OIDs for the type. The first is for scalar values the second is for arrays. + -- + -- When unspecified, the OIDs will be automatically determined at runtime by looking up by name. + Maybe (Word32, Word32) -> + -- | Other named types whose OIDs are needed for serializing. + -- + -- E.g., when encoding composite types Postgres requires specifying OIDs of all of its fields. + -- + -- When any of the requested types is missing in the database an error will be raised upon the statement execution. + [(Maybe Text, Text)] -> + -- | Serialization function in the context of resolved OIDs of the types requested in the previous parameter. + -- + -- It's safe to assume that all of the requested types will be present. + -- In case you run the provided lookup function with unmentioned type names it will produce OID of 0 for them, standing for unknown type in Postgres. + ( ((Maybe Text, Text) -> (Word32, Word32)) -> + a -> + ByteString + ) -> + -- | Render function for error messages. + (a -> Text) -> + Value a +custom schemaName typeName staticOids requiredTypes encode render = + Value + schemaName + typeName + (fmap fst staticOids) + (fmap snd staticOids) + 0 + False + ( ToBeResolved.ToBeResolved + (fmap CodecVocab.QualifiedTypeName.fromNameTuple requiredTypes) + ( \resolve -> + ByteString.StrictBuilder.bytes + . encode + ( \name -> + let typeInfo = resolve (CodecVocab.QualifiedTypeName.fromNameTuple name) + in (CodecVocab.TypeInfo.toBaseOid typeInfo, CodecVocab.TypeInfo.toArrayOid typeInfo) + ) + ) + ) + (TextBuilder.text . render) + +-- | +-- Encoder of @HSTORE@ values from a foldable container of key-value pairs. +-- +-- The value part can be @Nothing@ to represent a NULL value in the hstore. +{-# INLINEABLE hstore #-} +hstore :: (Foldable foldable) => Value (foldable (Text, Maybe Text)) +hstore = + Value + Nothing + "hstore" + Nothing + Nothing + 0 + False + (pure Binary.hStore_foldable) + renderHstore + where + renderHstore items = + mconcat + [ TextBuilder.text "hstore(", + TextBuilder.intercalate ", " (foldMap (\pair -> [renderPair pair]) items), + TextBuilder.text ")" + ] + renderPair (key, maybeValue) = + mconcat + [ TextBuilder.text "(", + TextBuilder.string (show key), + TextBuilder.text ", ", + case maybeValue of + Nothing -> TextBuilder.text "NULL" + Just value -> TextBuilder.string (show value), + TextBuilder.text ")" + ] diff --git a/src/library/Hasql/Connection.hs b/src/library/Hasql/Connection.hs --- a/src/library/Hasql/Connection.hs +++ b/src/library/Hasql/Connection.hs @@ -13,10 +13,10 @@ import Hasql.Connection.Config qualified as Config import Hasql.Connection.ServerVersion qualified as ServerVersion import Hasql.Connection.Settings qualified as Settings +import Hasql.ConnectionState qualified as ConnectionState +import Hasql.ConnectionState.StatementCache qualified as StatementCache import Hasql.Engine.Contexts.Session qualified as Session import Hasql.Engine.Errors -import Hasql.Engine.Structures.ConnectionState qualified as ConnectionState -import Hasql.Engine.Structures.StatementCache qualified as StatementCache import Hasql.Platform.Prelude import Pqi (Adapter) import Pqi qualified as Pq @@ -29,15 +29,12 @@ -- | -- Establish a connection according to the provided settings. -- --- The first argument is a 'Pqi.Adapter', which defines the backend +-- The first argument is an 'Pqi.Adapter', which defines the backend -- implementation used to talk to PostgreSQL (for example, libpq via the -- package, or a pure -- Haskell implementation via the -- package). --- -- This is the only place in the library where users choose the adapter. --- --- Typical usage is to pass the application's default adapter. -- -- This function: -- 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 @@ -86,60 +86,6 @@ ) where --- Every identifier below is imported directly from the module it's --- actually declared in, rather than from an intermediate re-export --- module. Haddock has a bug where docs of an identifier re-exported --- through more than one hop (declaration site -> intermediate re-export --- -> here) silently render blank on Hackage; importing straight from the --- declaration site keeps this a single hop. -import Hasql.Codecs.Decoders (array, composite, listArray, record, vectorArray) -import Hasql.Codecs.Decoders.Array (Array, dimension, element) -import Hasql.Codecs.Decoders.Composite (Composite, field) -import Hasql.Codecs.Decoders.NullableOrNot (NullableOrNot, nonNullable, nullable) -import Hasql.Codecs.Decoders.Value - ( Value, - bool, - bpchar, - bytea, - char, - citext, - custom, - date, - datemultirange, - daterange, - enum, - float4, - float8, - hstore, - inet, - int2, - int4, - int4multirange, - int4range, - int8, - int8multirange, - int8range, - interval, - json, - jsonBytes, - jsonb, - jsonbBytes, - macaddr, - numeric, - nummultirange, - numrange, - refine, - text, - time, - timestamp, - timestamptz, - timetz, - tsmultirange, - tsrange, - tstzmultirange, - tstzrange, - uuid, - varchar, - ) -import Hasql.Engine.Decoders.Result (Result, foldlRows, foldrRows, noResult, rowList, rowMaybe, rowVector, rowsAffected, singleRow) -import Hasql.Engine.Decoders.Row (Row, column) +import Hasql.Codecs.Decoders +import Hasql.Engine.Decoders.Result +import Hasql.Engine.Decoders.Row 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 @@ -77,63 +77,4 @@ ) where --- Every identifier below is imported directly from the module it's --- actually declared in, rather than from "Hasql.Codecs.Encoders" (which --- merely re-exports them). Haddock has a bug where docs of an identifier --- re-exported through more than one hop (declaration site -> intermediate --- re-export -> here) silently render blank on Hackage; importing straight --- from the declaration site keeps this a single hop. -import Hasql.Codecs.Encoders (array, composite, foldableArray) -import Hasql.Codecs.Encoders.Array (Array, dimension, element) -import Hasql.Codecs.Encoders.Composite (Composite, field) -import Hasql.Codecs.Encoders.NullableOrNot (NullableOrNot, nonNullable, nullable) -import Hasql.Codecs.Encoders.Params (Params, noParams, param) -import Hasql.Codecs.Encoders.Value - ( Value, - bool, - bpchar, - bytea, - char, - citext, - custom, - date, - datemultirange, - daterange, - enum, - float4, - float8, - hstore, - inet, - int2, - int4, - int4multirange, - int4range, - int8, - int8multirange, - int8range, - interval, - json, - jsonBytes, - jsonLazyBytes, - jsonb, - jsonbBytes, - jsonbLazyBytes, - macaddr, - name, - numeric, - nummultirange, - numrange, - oid, - text, - time, - timestamp, - timestamptz, - timetz, - tsmultirange, - tsrange, - tstzmultirange, - tstzrange, - unknown, - uuid, - varchar, - ) +import Hasql.Codecs.Encoders diff --git a/src/library/Hasql/Engine/Contexts/Pipeline.hs b/src/library/Hasql/Engine/Contexts/Pipeline.hs new file mode 100644 --- /dev/null +++ b/src/library/Hasql/Engine/Contexts/Pipeline.hs @@ -0,0 +1,266 @@ +module Hasql.Engine.Contexts.Pipeline + ( Pipeline, + run, + statement, + ) +where + +import CodecVocab qualified as CodecVocab +import CodecVocab.QualifiedTypeName qualified as CodecVocab.QualifiedTypeName +import Data.HashMap.Strict qualified as HashMap +import Data.HashSet qualified as HashSet +import Hasql.Comms.Roundtrip qualified as Comms.Roundtrip +import Hasql.ConnectionState.OidCache qualified as OidCache +import Hasql.ConnectionState.StatementCache qualified as StatementCache +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.Platform.Prelude +import Pqi qualified as Pq + +run :: + Pipeline a -> + Bool -> + Pq.Connection -> + OidCache.OidCache -> + StatementCache.StatementCache -> + IO + ( Either Errors.SessionError a, + OidCache.OidCache, + StatementCache.StatementCache + ) +run (Pipeline totalStatements unknownTypes runPipeline) usePreparedStatements connection oidCache statementCache = do + let missingTypes = OidCache.selectUnknownNames unknownTypes oidCache + resolvedOidCache <- + if HashSet.null missingTypes + then pure (Right oidCache) + else do + oidCacheUpdates <- + PqProcedures.SelectTypeInfo.run connection (PqProcedures.SelectTypeInfo.SelectTypeInfo missingTypes) + pure $ case oidCacheUpdates of + Left err -> Left err + Right oidCacheUpdates -> + let foundTypes = HashMap.keysSet oidCacheUpdates + notFoundTypes = HashSet.difference missingTypes foundTypes + in if not (HashSet.null notFoundTypes) + then Left (Errors.MissingTypesSessionError (HashSet.map CodecVocab.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 newOidCache statementCache + contextualRoundtrip = first Just roundtrip + + executionResult <- Comms.Roundtrip.toPipelineIO contextualRoundtrip Nothing connection + + let result = + first + ( \case + Comms.Roundtrip.ClientError _context details -> + Errors.ConnectionSessionError (maybe "" decodeUtf8Lenient details) + Comms.Roundtrip.ServerError recvError -> + Errors.fromRecvError (fmap (fmap (\(Context index sql params prepared _) -> (totalStatements, index, sql, params, prepared))) recvError) + ) + executionResult + finalStatementCache = + case executionResult of + Right _ -> newStatementCache + Left executionError -> + maybe + statementCache + (\(Context _ _ _ _ statementCache) -> statementCache) + (extract executionError) + + pure (result, newOidCache, finalStatementCache) + +-- | +-- Composable abstraction over the execution of queries in [the pipeline mode](https://www.postgresql.org/docs/current/libpq-pipeline-mode.html). +-- +-- It allows you to issue multiple queries to the server in much fewer network transactions. +-- If the amounts of sent and received data do not surpass the buffer sizes in the driver and on the server it will be just a single roundtrip. +-- Typically the buffer size is 8KB. +-- +-- This execution mode is much more efficient than running queries directly from 'Hasql.Session.Session', because in session every statement execution involves a dedicated network roundtrip. +-- +-- An obvious question rises then: why not execute all queries like that? +-- In situations where the parameters depend on the result of another query it is impossible to execute them in parallel, because the client needs to receive the results of one query before sending the request to execute the next. +-- This reasoning is essentially the same as the one for the difference between 'Applicative' and 'Monad'. +-- That's why 'Pipeline' does not have the 'Monad' instance. +-- +-- To execute 'Pipeline' lift it into 'Hasql.Session.Session' via 'Hasql.Session.pipeline'. +-- +-- == Examples +-- +-- === Insert-Many or Batch-Insert +-- +-- You can use pipeline to turn a single-row insert query into an efficient multi-row insertion session. +-- In effect this should be comparable in performance to issuing a single multi-row insert statement. +-- +-- Given the following definition in a Statements module: +-- +-- @ +-- insertOrder :: 'Hasql.Statement.Statement' OrderDetails OrderId +-- @ +-- +-- You can lift it into the following session +-- +-- @ +-- insertOrders :: [OrderDetails] -> 'Hasql.Session.Session' [OrderId] +-- insertOrders orders = +-- 'Hasql.Session.pipeline' $ +-- for orders $ \order -> +-- 'Hasql.Pipeline.statement' order Statements.insertOrder +-- @ +-- +-- === Combining Queries +-- +-- Given the following definitions in a Statements module: +-- +-- @ +-- selectOrderDetails :: 'Hasql.Statement.Statement' OrderId (Maybe OrderDetails) +-- selectOrderProducts :: 'Hasql.Statement.Statement' OrderId [OrderProduct] +-- selectOrderFinancialTransactions :: 'Hasql.Statement.Statement' OrderId [FinancialTransaction] +-- @ +-- +-- You can combine them into a session using the `ApplicativeDo` extension as follows: +-- +-- @ +-- selectEverythingAboutOrder :: OrderId -> 'Hasql.Session.Session' (Maybe OrderDetails, [OrderProduct], [FinancialTransaction]) +-- selectEverythingAboutOrder orderId = +-- 'Hasql.Session.pipeline' $ do +-- details <- 'Hasql.Pipeline.statement' orderId Statements.selectOrderDetails +-- products <- 'Hasql.Pipeline.statement' orderId Statements.selectOrderProducts +-- transactions <- 'Hasql.Pipeline.statement' orderId Statements.selectOrderFinancialTransactions +-- pure (details, products, transactions) +-- @ +data Pipeline a + = Pipeline + -- | Amount of statements in this pipeline. + Int + -- | Names of types that are used in this pipeline. + -- + -- They will be used to pre-resolve type OIDs before running the pipeline providing them in OidCache. + -- 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 OID 0 for unknown types as a fallback in case of bugs. + (HashSet CodecVocab.QualifiedTypeName) + -- | Function that runs the pipeline. + -- + -- The integer parameter indicates the current offset of the statement in the pipeline (0-based). + -- + -- The boolean parameter indicates whether preparable statements should be prepared. + -- + -- OidCache is provided in which the names of types used in this pipeline are already resolved. + -- + -- The function takes the current statement cache and returns a tuple of: + -- 1. The actual roundtrip action to be executed in the pipeline. + -- 2. The updated statement cache after composing this part of the pipeline. + -- + -- The resulting cache is optimistic: on failure we recover the last known + -- committed cache from statement contexts carried by roundtrip errors. + ( Int -> + Bool -> + OidCache.OidCache -> + StatementCache.StatementCache -> + (Comms.Roundtrip.Roundtrip Context a, StatementCache.StatementCache) + ) + +data Context + = Context + -- | Offset of the statement in the pipeline (0-based). + Int + -- | SQL. + ByteString + -- | Parameters in a human-readable form. + [Text] + -- | Whether the statement is prepared. + Bool + -- | The so far successfully updated statement cache. + StatementCache.StatementCache + deriving stock (Show, Eq) + +-- * Instances + +instance Functor Pipeline where + fmap f (Pipeline count unknownTypes run) = Pipeline count unknownTypes \offset usePreparedStatements oidCache cache -> + let (roundtrip, newStatementCache) = run offset usePreparedStatements oidCache cache + in (fmap f roundtrip, newStatementCache) + +instance Applicative Pipeline where + pure a = + Pipeline 0 mempty (\_ _ _ cache -> (pure a, cache)) + + Pipeline lCount leftUnknownTypes lRun <*> Pipeline rCount rightUnknownTypes rRun = + let unknownTypes = leftUnknownTypes <> rightUnknownTypes + in Pipeline (lCount + rCount) unknownTypes \offset usePreparedStatements oidCache statementCache -> + let (lRoundtrip, statementCache1) = lRun offset usePreparedStatements oidCache statementCache + offset1 = offset + lCount + (rRoundtrip, statementCache2) = rRun offset1 usePreparedStatements oidCache statementCache1 + in (lRoundtrip <*> rRoundtrip, statementCache2) + +-- * Construction + +-- | +-- Execute a statement in pipelining mode. +statement :: + Statement.Statement params result -> + params -> + Pipeline result +statement stmt params = + Pipeline 1 (Statement.unknownTypes stmt) run + where + sql = Statement.sql stmt + run offset usePreparedStatements oidCache = + if prepare + then runPrepared + else runUnprepared + where + resolve = OidCache.toResolver oidCache + + (oidList, valueAndFormatList) = + Statement.compilePreparedStatementData stmt resolve params + + prepare = + usePreparedStatements && Statement.isPrepared stmt + + context soFarStatementCache = + Context + offset + sql + (Statement.printer stmt params) + prepare + soFarStatementCache + + runPrepared statementCache = + (roundtrip, newStatementCache) + where + (isNew, remoteKey, newStatementCache) = + case StatementCache.lookup sql oidList statementCache of + Just remoteKey -> (False, remoteKey, statementCache) + Nothing -> + let (remoteKey, newStatementCache) = StatementCache.insert sql oidList statementCache + in (True, remoteKey, newStatementCache) + + roundtrip = + when + isNew + (Comms.Roundtrip.prepare (context statementCache) remoteKey sql oidList) + *> Comms.Roundtrip.queryPrepared (context newStatementCache) remoteKey encodedParams Pq.Binary decoder' + where + encodedParams = + valueAndFormatList + & fmap (fmap (\(bytes, format) -> (bytes, bool Pq.Binary Pq.Text format))) + + runUnprepared statementCache = + (roundtrip, statementCache) + where + roundtrip = + Comms.Roundtrip.queryParams (context statementCache) sql encodedParams Pq.Binary decoder' + where + encodedParams = + Statement.compileUnpreparedStatementData stmt resolve params + & fmap (fmap (\(oid, bytes, format) -> (oid, bytes, bool Pq.Binary Pq.Text format))) + + decoder' = + Statement.decoder stmt resolve diff --git a/src/library/Hasql/Engine/Contexts/Session.hs b/src/library/Hasql/Engine/Contexts/Session.hs new file mode 100644 --- /dev/null +++ b/src/library/Hasql/Engine/Contexts/Session.hs @@ -0,0 +1,207 @@ +module Hasql.Engine.Contexts.Session where + +import CodecVocab.QualifiedTypeName qualified as CodecVocab.QualifiedTypeName +import Data.HashMap.Strict qualified as HashMap +import Data.HashSet qualified as HashSet +import Hasql.Comms.Roundtrip qualified as Comms.Roundtrip +import Hasql.ConnectionState qualified as ConnectionState +import Hasql.ConnectionState.OidCache qualified as OidCache +import Hasql.ConnectionState.StatementCache qualified as StatementCache +import Hasql.Engine.Contexts.Pipeline qualified as Pipeline +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.Platform.Prelude +import Pqi qualified as Pq + +-- | +-- A sequence of operations to be executed in the context of a single database connection with exclusive access to it. +-- +-- Construct sessions using helpers in this module such as +-- 'statement', 'pipeline' and 'script', or use 'onLibpqConnection' for a low-level +-- escape hatch. +-- +-- To actually execute a 'Session' use 'Hasql.Connection.use', which manages +-- concurrent access to the shared connection state and returns either a +-- 'Errors.SessionError' or the result: +-- +-- > result <- Hasql.Connection.use connection mySession +-- +-- Note: while most session errors are returned as values, user code executed +-- inside a session may still throw exceptions; in that case the driver will +-- reset the connection to a clean state. +newtype Session a + = Session (ConnectionState.ConnectionState -> IO (Either Errors.SessionError a, ConnectionState.ConnectionState)) + deriving + (Functor, Applicative, Monad, MonadError Errors.SessionError, MonadIO) + via (ExceptT Errors.SessionError (StateT ConnectionState.ConnectionState IO)) + +run :: Session a -> ConnectionState.ConnectionState -> IO (Either Errors.SessionError a, ConnectionState.ConnectionState) +run (Session session) connectionState = session connectionState + +-- | +-- Possibly a multi-statement query, +-- which however cannot be parameterized or prepared, +-- nor can any results of it be collected. +script :: ByteString -> Session () +script sql = + Session \connectionState -> do + let connection = ConnectionState.connection connectionState + result <- Comms.Roundtrip.toSerialIO (Comms.Roundtrip.script (Just sql) sql) connection + case result of + Left err -> case err of + Comms.Roundtrip.ClientError _ details -> do + pure + ( Left (Errors.ConnectionSessionError (maybe "" decodeUtf8Lenient details)), + connectionState + ) + Comms.Roundtrip.ServerError recvError -> + pure + ( Left (Errors.fromRecvErrorInScript sql recvError), + connectionState + ) + Right () -> + pure + ( Right (), + connectionState + ) + +-- | +-- Execute a single statement by providing parameters to it, +-- running it directly in serial mode. +-- +-- Each execution is a dedicated network roundtrip. The first execution of a +-- preparable statement costs an extra roundtrip (a separate @PARSE@), after +-- which steady-state execution is a single roundtrip. +-- +-- To batch multiple statements into fewer roundtrips, use 'pipeline' instead. +statement :: + Statement.Statement params result -> + params -> + Session result +statement stmt params = + Session \connectionState -> do + let usePreparedStatements = ConnectionState.preparedStatements connectionState + statementCache = ConnectionState.statementCache connectionState + oidCache = ConnectionState.oidCache connectionState + connection = ConnectionState.connection connectionState + sql = Statement.sql stmt + missingTypes = OidCache.selectUnknownNames (Statement.unknownTypes stmt) oidCache + resolvedOidCache <- + if HashSet.null missingTypes + then pure (Right oidCache) + else do + oidCacheUpdates <- + PqProcedures.SelectTypeInfo.run connection (PqProcedures.SelectTypeInfo.SelectTypeInfo missingTypes) + pure $ case oidCacheUpdates of + Left err -> Left err + Right oidCacheUpdates -> + let foundTypes = HashMap.keysSet oidCacheUpdates + notFoundTypes = HashSet.difference missingTypes foundTypes + in if not (HashSet.null notFoundTypes) + then Left (Errors.MissingTypesSessionError (HashSet.map CodecVocab.QualifiedTypeName.toNameTuple notFoundTypes)) + else Right (oidCache <> OidCache.fromHashMap oidCacheUpdates) + case resolvedOidCache of + Left err -> pure (Left err, connectionState) + Right newOidCache -> do + let resolve = OidCache.toResolver newOidCache + decoder' = Statement.decoder stmt resolve + prepared = usePreparedStatements && Statement.isPrepared stmt + -- Single-statement context for error reporting: + -- total statements 1, index 0. + context = Just (1, 0, sql, Statement.printer stmt params, prepared) + mapError = \case + Comms.Roundtrip.ClientError _ details -> + Errors.ConnectionSessionError (maybe "" decodeUtf8Lenient details) + Comms.Roundtrip.ServerError recvError -> + Errors.fromRecvError recvError + withState (result, newStatementCache) = + ( first mapError result, + connectionState + { ConnectionState.oidCache = newOidCache, + ConnectionState.statementCache = newStatementCache + } + ) + fmap withState + $ if prepared + then do + let (oidList, valueAndFormatList) = + Statement.compilePreparedStatementData stmt resolve params + encodedParams = + valueAndFormatList + & fmap (fmap (\(bytes, format) -> (bytes, bool Pq.Binary Pq.Text format))) + execute remoteKey = + Comms.Roundtrip.toSerialIO + (Comms.Roundtrip.queryPrepared context remoteKey encodedParams Pq.Binary decoder') + connection + case StatementCache.lookup sql oidList statementCache of + Just remoteKey -> do + result <- execute remoteKey + pure (result, statementCache) + Nothing -> do + let (remoteKey, newStatementCache) = StatementCache.insert sql oidList statementCache + -- In non-pipeline mode PARSE and EXECUTE cannot be sent + -- back-to-back, so prepare in a dedicated roundtrip first. + prepareResult <- + Comms.Roundtrip.toSerialIO + (Comms.Roundtrip.prepare context remoteKey sql oidList) + connection + case prepareResult of + -- PARSE failed: the statement is not on the server, so + -- keep the old cache (no entry committed). + Left err -> pure (Left err, statementCache) + Right () -> do + -- PARSE succeeded, so the statement is on the server + -- under remoteKey regardless of whether EXECUTE then + -- fails. Commit the cache so a later use hits it instead + -- of re-issuing PARSE for an already-existing name. + result <- execute remoteKey + pure (result, newStatementCache) + else do + let encodedParams = + Statement.compileUnpreparedStatementData stmt resolve params + & fmap (fmap (\(oid, bytes, format) -> (oid, bytes, bool Pq.Binary Pq.Text format))) + result <- + Comms.Roundtrip.toSerialIO + (Comms.Roundtrip.queryParams context sql encodedParams Pq.Binary decoder') + connection + pure (result, statementCache) + +-- | +-- Execute a pipeline. +pipeline :: Pipeline.Pipeline result -> Session result +pipeline pipeline = Session \connectionState -> do + let usePreparedStatements = ConnectionState.preparedStatements connectionState + statementCache = ConnectionState.statementCache connectionState + oidCache = ConnectionState.oidCache connectionState + pqConnection = ConnectionState.connection connectionState + in do + (result, newOidCache, newStatementCache) <- Pipeline.run pipeline usePreparedStatements pqConnection oidCache statementCache + let newConnectionState = + connectionState + { ConnectionState.oidCache = newOidCache, + ConnectionState.statementCache = newStatementCache + } + + pure (result, newConnectionState) + +-- | +-- Execute an operation on the raw libpq connection possibly producing an error and updating the connection. +-- This is a low-level escape hatch for custom integrations. +-- +-- You can supply a new connection in the result to replace it in the running Hasql connection. +-- The responsibility to close the old libpq connection is on you. +-- Otherwise, just return the same connection you've received. +-- +-- Producing a 'Left' value will cause the session to fail with the given error. +-- Regardless of success or failure, the connection will be replaced with the one you return. +-- +-- Throwing exceptions is okay. It will lead to the connection getting reset. +onLibpqConnection :: + (Pq.Connection -> IO (Either Errors.SessionError a, Pq.Connection)) -> + Session a +onLibpqConnection f = Session \connectionState -> do + let pqConnection = ConnectionState.connection connectionState + (result, newConnection) <- f pqConnection + let newState = ConnectionState.setConnection newConnection connectionState + pure (result, newState) diff --git a/src/library/Hasql/Engine/Decoders/Result.hs b/src/library/Hasql/Engine/Decoders/Result.hs new file mode 100644 --- /dev/null +++ b/src/library/Hasql/Engine/Decoders/Result.hs @@ -0,0 +1,102 @@ +module Hasql.Engine.Decoders.Result where + +import CodecVocab.QualifiedTypeName qualified as CodecVocab.QualifiedTypeName +import CodecVocab.TypeInfo qualified as CodecVocab.TypeInfo +import Hasql.Comms.ResultDecoder qualified as ResultDecoder +import Hasql.Engine.Decoders.Row (Row (..)) +import Hasql.Engine.Decoders.Row qualified as Row +import Hasql.Platform.Prelude +import Hasql.ToBeResolved qualified as ToBeResolved + +-- | +-- Decoder of a query result. +newtype Result a + = Result (ToBeResolved.ToBeResolved CodecVocab.QualifiedTypeName.QualifiedTypeName CodecVocab.TypeInfo.TypeInfo (ResultDecoder.ResultDecoder a)) + deriving + (Functor, Applicative, Filterable) + via (Compose (ToBeResolved.ToBeResolved CodecVocab.QualifiedTypeName.QualifiedTypeName CodecVocab.TypeInfo.TypeInfo) ResultDecoder.ResultDecoder) + +-- | Names of types that must be looked up at runtime before the decoder can run. +toUnknownTypes :: Result a -> HashSet CodecVocab.QualifiedTypeName.QualifiedTypeName +toUnknownTypes (Result (ToBeResolved.ToBeResolved unknownTypes _)) = fromList unknownTypes + +-- | Resolve the decoder given a resolver of type names to their OIDs. +toBase :: Result a -> (CodecVocab.QualifiedTypeName.QualifiedTypeName -> CodecVocab.TypeInfo.TypeInfo) -> ResultDecoder.ResultDecoder a +toBase (Result (ToBeResolved.ToBeResolved _ decoder)) = decoder + +-- * Construction + +-- | +-- Decode no value from the result. +-- +-- Useful for statements like @INSERT@ or @CREATE@. +{-# INLINE noResult #-} +noResult :: Result () +noResult = + Result (pure ResultDecoder.ok) + +-- | +-- Get the amount of rows affected by such statements as +-- @UPDATE@ or @DELETE@. +{-# INLINE rowsAffected #-} +rowsAffected :: Result Int64 +rowsAffected = + Result (pure ResultDecoder.rowsAffected) + +-- | +-- Exactly one row. +-- Will raise the 'Hasql.Errors.UnexpectedRowCountStatementError' error if it's any other. +{-# INLINE singleRow #-} +singleRow :: Row a -> Result a +singleRow decoder = + Result (fmap ResultDecoder.single (Row.toDecoder decoder)) + +refineResult :: (a -> Either Text b) -> Result a -> Result b +refineResult refiner (Result decoder) = + Result (fmap (ResultDecoder.refine refiner) decoder) + +-- ** Multi-row traversers + +-- | +-- Foldl multiple rows. +{-# INLINE foldlRows #-} +foldlRows :: (a -> b -> a) -> a -> Row b -> Result a +foldlRows step init decoder = + Result + (fmap (ResultDecoder.foldl step init) (Row.toDecoder decoder)) + +-- | +-- Foldr multiple rows. +{-# INLINE foldrRows #-} +foldrRows :: (b -> a -> a) -> a -> Row b -> Result a +foldrRows step init decoder = + Result + (fmap (ResultDecoder.foldr step init) (Row.toDecoder decoder)) + +-- ** Specialized multi-row results + +-- | +-- Maybe one row or none. +{-# INLINE rowMaybe #-} +rowMaybe :: Row a -> Result (Maybe a) +rowMaybe decoder = + Result + (fmap ResultDecoder.maybe (Row.toDecoder decoder)) + +-- | +-- Zero or more rows packed into the vector. +-- +-- It's recommended to prefer this function to 'rowList', +-- since it performs notably better. +{-# INLINE rowVector #-} +rowVector :: Row a -> Result (Vector a) +rowVector decoder = + Result + (fmap ResultDecoder.vector (Row.toDecoder decoder)) + +-- | +-- Zero or more rows packed into the list. +{-# INLINE rowList #-} +rowList :: Row a -> Result [a] +rowList = + foldrRows strictCons [] diff --git a/src/library/Hasql/Engine/Decoders/Row.hs b/src/library/Hasql/Engine/Decoders/Row.hs new file mode 100644 --- /dev/null +++ b/src/library/Hasql/Engine/Decoders/Row.hs @@ -0,0 +1,63 @@ +module Hasql.Engine.Decoders.Row where + +import CodecVocab.QualifiedTypeName qualified as CodecVocab.QualifiedTypeName +import CodecVocab.TypeInfo qualified as CodecVocab.TypeInfo +import Hasql.Codecs.Decoders +import Hasql.Codecs.Decoders.Value qualified as Value +import Hasql.Comms.RowDecoder qualified +import Hasql.Platform.Prelude +import Hasql.ToBeResolved qualified as ToBeResolved +import PostgreSQL.Binary.Decoding qualified as Binary + +-- | +-- Decoder of an individual row, +-- which gets composed of column value decoders. +-- E.g.: +-- +-- @ +-- x :: 'Row' (Maybe Int64, Text, TimeOfDay) +-- x = (,,) '<$>' ('column' . 'nullable') 'int8' '<*>' ('column' . 'nonNullable') 'text' '<*>' ('column' . 'nonNullable') 'time' +-- @ +newtype Row a + = Row (ToBeResolved.ToBeResolved CodecVocab.QualifiedTypeName.QualifiedTypeName CodecVocab.TypeInfo.TypeInfo (Hasql.Comms.RowDecoder.RowDecoder a)) + deriving + (Functor, Applicative, Filterable) + via (Compose (ToBeResolved.ToBeResolved CodecVocab.QualifiedTypeName.QualifiedTypeName CodecVocab.TypeInfo.TypeInfo) Hasql.Comms.RowDecoder.RowDecoder) + +toDecoder :: + Row a -> + ToBeResolved.ToBeResolved CodecVocab.QualifiedTypeName.QualifiedTypeName CodecVocab.TypeInfo.TypeInfo (Hasql.Comms.RowDecoder.RowDecoder a) +toDecoder (Row f) = f + +-- | +-- Lift an individual value decoder to a composable row decoder. +{-# INLINE column #-} +column :: NullableOrNot Value a -> Row a +column = \case + Nullable valueDecoder -> + Row case Value.toOid valueDecoder of + Just oid -> + fmap + (Hasql.Comms.RowDecoder.nullableColumn (Just oid) . Binary.valueParser) + (Value.toDecoder valueDecoder) + Nothing -> + ( \lookupResult decoder -> + Hasql.Comms.RowDecoder.nullableColumn (Just (chooseLookedUpOid valueDecoder lookupResult)) (Binary.valueParser decoder) + ) + <$> ToBeResolved.lookup (CodecVocab.QualifiedTypeName.QualifiedTypeName (Value.toSchema valueDecoder) (Value.toTypeName valueDecoder)) + <*> Value.toDecoder valueDecoder + NonNullable valueDecoder -> + Row case Value.toOid valueDecoder of + Just oid -> + fmap + (Hasql.Comms.RowDecoder.nonNullableColumn (Just oid) . Binary.valueParser) + (Value.toDecoder valueDecoder) + Nothing -> + (\lookupResult decoder -> Hasql.Comms.RowDecoder.nonNullableColumn (Just (chooseLookedUpOid valueDecoder lookupResult)) (Binary.valueParser decoder)) + <$> ToBeResolved.lookup (CodecVocab.QualifiedTypeName.QualifiedTypeName (Value.toSchema valueDecoder) (Value.toTypeName valueDecoder)) + <*> Value.toDecoder valueDecoder + where + chooseLookedUpOid valueDecoder typeInfo = + if Value.toDimensionality valueDecoder > 0 + then CodecVocab.TypeInfo.toArrayOid typeInfo + else CodecVocab.TypeInfo.toBaseOid typeInfo diff --git a/src/library/Hasql/Engine/Errors.hs b/src/library/Hasql/Engine/Errors.hs new file mode 100644 --- /dev/null +++ b/src/library/Hasql/Engine/Errors.hs @@ -0,0 +1,473 @@ +module Hasql.Engine.Errors where + +import Hasql.Comms.Recv qualified +import Hasql.Comms.ResultDecoder qualified +import Hasql.Comms.Roundtrip qualified +import Hasql.Comms.RowReader qualified +import Hasql.Platform.Prelude +import TextBuilder qualified + +-- * Error types + +-- | +-- Error that occurs when attempting to establish a database connection. +-- +-- These errors can occur when calling 'Hasql.Connection.acquire'. +-- Connection errors are categorized into several types to help with +-- error handling and logging. +data ConnectionError + = -- | Network-level error while connecting to the database server. + -- + -- This typically indicates issues like: + -- + -- * Server is not reachable (wrong host\/port or server is down) + -- * Network connectivity problems + -- * Firewall blocking the connection + -- * Connection timeout + -- + -- These errors are transient and the operation can be retried. + NetworkingConnectionError + -- | Human readable details intended for logging. + Text + | -- | Authentication failed when connecting to the database. + -- + -- This typically indicates issues like: + -- + -- * Invalid username or password + -- * User does not have permission to access the database + -- * Authentication method mismatch (e.g., server requires SSL but client doesn't use it) + -- + -- These errors are not transient and require fixing the credentials or permissions. + AuthenticationConnectionError + -- | Human readable details intended for logging. + Text + | -- | Compatibility issue between client and server. + -- + -- This typically indicates issues like: + -- + -- * Server version is too old or too new + -- * Required PostgreSQL features are not available + -- * Protocol version mismatch + -- + -- These errors are not transient and require upgrading/downgrading + -- the server or client. + CompatibilityConnectionError + -- | Human readable details intended for logging. + Text + | -- | Uncategorized error coming from @libpq@. + -- + -- This is a catch-all for connection errors that don't fit into other categories. + -- The error message may be empty if @libpq@ doesn't provide details. + -- + -- These errors are not transient by default. + OtherConnectionError + -- | Human readable details intended for logging. May be empty. + Text + deriving stock (Show, Eq) + +-- | +-- Error that occurs during session execution. +-- +-- A session is a batch of actions executed in a database connection context. +-- Session errors can occur due to statement failures, connection issues, +-- missing types, or internal driver errors. +-- +-- Session errors provide detailed context to help diagnose problems, +-- including SQL text, parameters, and the location of the error within +-- a pipeline of statements. +data SessionError + = -- | An error occurred while executing a statement in the session. + -- + -- This wraps statement-level errors and provides additional context about: + -- + -- * Which statement in the pipeline failed (when multiple statements are batched) + -- * The SQL text and parameters of the failing statement + -- * Whether the statement was prepared or unprepared + -- + -- The error message includes formatted output showing all this context, + -- making it easier to diagnose issues in production. + StatementSessionError + -- | Total number of statements in the running pipeline. 1 if it's executed alone. + Int + -- | 0-based index of the statement that failed. 0 if it's executed alone. + Int + -- | SQL template of the failing statement. + Text + -- | Parameter values as text (for logging purposes). + [Text] + -- | Whether the statement was executed as a prepared one. + Bool + -- | The underlying statement error. + StatementError + | -- | An error occurred while executing a script. + -- + -- Scripts are multi-statement SQL texts executed via 'Hasql.Session.script'. + -- Unlike regular statements, scripts don't support parameters or result decoding, + -- and errors are limited to server-reported issues. + ScriptSessionError + -- | The SQL text of the script. + Text + -- | The server error that occurred. + ServerError + | -- | A connection-level error occurred during session execution. + -- + -- This indicates that the connection to the database was lost or + -- became unusable during the session. These errors are transient + -- and the operation can be retried with a new connection. + -- + -- Note: As of version 1.10, connections recover from async exceptions + -- without resetting, preserving connection-local state. + ConnectionSessionError + -- | Human-readable details about the connection error. + Text + | -- | One or more types referenced in the statement could not be found in the database. + -- + -- This occurs when using custom types (enums, composite types, domains) that + -- are resolved by name at runtime, but the types don't exist in the database. + -- + -- To fix this error: + -- + -- * Ensure the types are defined in the database + -- * Check that schema search paths are configured correctly + -- * Verify that the type names in your code match those in the database + MissingTypesSessionError + -- | Set of (schema name, type name) pairs that could not be found. + -- + -- Schema name is 'Nothing' when the type was looked up without a schema qualifier. + (HashSet (Maybe Text, Text)) + | -- | An internal driver error occurred. + -- + -- This indicates either: + -- + -- * A bug in Hasql + -- * The PostgreSQL server misbehaving + -- * An unexpected response from the server + -- + -- If you encounter this error, please report it as a bug. + DriverSessionError + -- | Human-readable details about what went wrong. + Text + deriving stock (Show, Eq) + +-- | +-- Error that occurs when executing a single statement. +-- +-- Statement errors can be caused by server-side issues (SQL errors, constraint violations) +-- or by mismatches between the decoder specification and the actual result structure +-- (wrong number of rows/columns, type mismatches, or cell-level decoding failures). +data StatementError + = -- | The server rejected the statement and returned an error. + -- + -- This includes SQL syntax errors, constraint violations, permission errors, + -- and any other error reported by PostgreSQL during statement execution. + ServerStatementError ServerError + | -- | The statement returned a different number of rows than expected. + -- + -- This occurs when using result decoders like @Decoders.singleRow@ or + -- @Decoders.rowsAffectedAtLeast@ that have specific row count expectations. + UnexpectedRowCountStatementError + -- | Expected minimum number of rows. + Int + -- | Expected maximum number of rows. + Int + -- | Actual number of rows returned. + Int + | -- | The statement returned a different number of columns than expected. + -- + -- This indicates a mismatch between the decoder specification and the + -- actual result structure, possibly due to: + -- + -- * Schema changes (columns added or removed) + -- * Wrong query (selecting different columns than expected) + -- * Decoder configuration error + UnexpectedColumnCountStatementError + -- | Expected number of columns. + Int + -- | Actual number of columns returned. + Int + | -- | A column has a different type than expected. + -- + -- This occurs when the decoder expects a specific PostgreSQL type (by OID) + -- but the actual column has a different type. This can happen due to: + -- + -- * Schema changes (column type changed) + -- * Wrong query (selecting wrong column or using a cast) + -- * Decoder configuration error + -- + -- Note: As of version 1.10, Hasql performs strict type checking and will + -- report this error instead of attempting automatic type coercion. + UnexpectedColumnTypeStatementError + -- | 0-based column index where the type mismatch occurred. + Int + -- | Expected PostgreSQL type OID. + Word32 + -- | Actual PostgreSQL type OID of the column. + Word32 + | -- | An error occurred while decoding a specific row. + -- + -- This wraps errors that occur at the row or cell level, providing + -- context about which row failed. + RowStatementError + -- | 0-based index of the row that failed to decode. + Int + -- | The underlying row-level error. + RowError + | -- | The database returned an unexpected result structure. + -- + -- This is a catch-all error that indicates either: + -- + -- * An improper statement (e.g., executing a query that doesn't match expectations) + -- * A schema mismatch between the code and database + -- * A bug in Hasql or server misbehavior + UnexpectedResultStatementError + -- | Human-readable details about what went wrong. + Text + deriving stock (Show, Eq) + +-- | +-- Error reported by the PostgreSQL server when executing a statement. +-- +-- The server provides structured error information including error codes +-- (SQL state), messages, and optional context like hints and position information. +-- +-- For a complete list of PostgreSQL error codes, see: +-- +data ServerError + = ServerError + -- | SQL State Code (SQLSTATE). + -- + -- A five-character code that identifies the error class and condition. + -- Examples: @\"23505\"@ (unique violation), @\"42P01\"@ (undefined table). + Text + -- | Primary error message. + -- + -- A human-readable description of the error. + Text + -- | Optional detailed error information. + -- + -- Additional context about the error, if available. + (Maybe Text) + -- | Optional hint for resolving the error. + -- + -- A suggestion for how to fix the problem, if available. + (Maybe Text) + -- | Optional position in the SQL string where the error occurred. + -- + -- A 1-based character index into the SQL string, if the error + -- relates to a specific location in the query. + (Maybe Int) + deriving stock (Show, Eq) + +-- | +-- Error that occurs when decoding a result row. +-- +-- Row errors indicate problems when processing an individual row from the result set, +-- either at the cell level or during row refinement/validation. +data RowError + = -- | An error occurred while decoding a specific cell in the row. + -- + -- This wraps cell-level errors (null handling, deserialization failures) + -- and provides context about which column failed and its type. + CellRowError + -- | 0-based index of the column where the error occurred. + Int + -- | PostgreSQL type OID of the column, as reported by the server. + Word32 + -- | The underlying cell-level error. + CellError + | -- | A refinement or validation error when processing the row. + -- + -- This occurs when using refinement functions in row decoders + -- (e.g., with 'Decoders.refineRow') to validate or transform + -- decoded values. The refinement function rejected the row data. + RefinementRowError + -- | Human-readable details about why the refinement failed. + Text + deriving stock (Show, Eq) + +-- | +-- Error that occurs when decoding a single cell (column value) in a result row. +-- +-- Cell errors indicate problems with individual values returned by the database, +-- such as unexpected nulls or failures in binary deserialization. +data CellError + = -- | A NULL value was encountered when a non-NULL value was expected. + -- + -- This occurs when using non-nullable decoders (e.g., @Decoders.nonNullable@) + -- on a column that contains a NULL value. + UnexpectedNullCellError + | -- | Failed to deserialize the cell value from its binary representation. + -- + -- This can occur when: + -- + -- * The binary data is corrupted + -- * The decoder doesn't match the actual data type + -- * The data format is invalid for the expected type + DeserializationCellError + -- | Human-readable error message describing what went wrong. + Text + deriving stock (Show, Eq) + +fromRoundtripError :: Hasql.Comms.Roundtrip.Error context -> SessionError +fromRoundtripError = \case + Hasql.Comms.Roundtrip.ClientError _context details -> + ConnectionSessionError (maybe "" decodeUtf8Lenient details) + Hasql.Comms.Roundtrip.ServerError recvError -> + fromRecvError (Nothing <$ recvError) + +fromRecvError :: Hasql.Comms.Recv.Error (Maybe (Int, Int, ByteString, [Text], Bool)) -> SessionError +fromRecvError = \case + Hasql.Comms.Recv.ResultError location _resultOffset resultError -> + case location of + Nothing -> + (DriverSessionError . TextBuilder.toText . mconcat) + [ "Unexpected error outside of statement context. ", + "This indicates a bug in Hasql or the server misbehaving. ", + "Error: ", + TextBuilder.string (show resultError) + ] + Just (totalStatements, statementIndex, sql, parameters, prepared) -> + StatementSessionError + totalStatements + statementIndex + (decodeUtf8Lenient sql) + parameters + prepared + (fromStatementResultError resultError) + Hasql.Comms.Recv.NoResultsError location details -> + case location of + Nothing -> + (DriverSessionError . TextBuilder.toText . mconcat) + [ "Unexpectedly got no results outside of statement context. ", + "This indicates a bug in Hasql or the server misbehaving. ", + "Details: ", + TextBuilder.string (show details) + ] + Just (totalStatements, statementIndex, sql, parameters, prepared) -> + StatementSessionError + totalStatements + statementIndex + (decodeUtf8Lenient sql) + parameters + prepared + (UnexpectedRowCountStatementError 1 1 0) + Hasql.Comms.Recv.TooManyResultsError location actual -> + case location of + Nothing -> + (DriverSessionError . TextBuilder.toText . mconcat) + [ "Unexpectedly got too many results outside of statement context. ", + "This indicates a bug in Hasql or the server misbehaving. ", + "Amount: ", + TextBuilder.decimal actual + ] + Just (totalStatements, statementIndex, sql, parameters, prepared) -> + StatementSessionError + totalStatements + statementIndex + (decodeUtf8Lenient sql) + parameters + prepared + (UnexpectedRowCountStatementError 1 1 actual) + +fromStatementResultError :: Hasql.Comms.ResultDecoder.Error -> StatementError +fromStatementResultError = \case + Hasql.Comms.ResultDecoder.ServerError code message detail hint position -> + ServerStatementError + ( ServerError + (decodeUtf8Lenient code) + (decodeUtf8Lenient message) + (fmap decodeUtf8Lenient detail) + (fmap decodeUtf8Lenient hint) + position + ) + Hasql.Comms.ResultDecoder.UnexpectedResult msg -> + UnexpectedResultStatementError msg + Hasql.Comms.ResultDecoder.UnexpectedRowCount actual -> + UnexpectedRowCountStatementError 1 1 actual + Hasql.Comms.ResultDecoder.UnexpectedColumnCount expected actual -> + UnexpectedColumnCountStatementError expected actual + Hasql.Comms.ResultDecoder.DecoderTypeMismatch colIdx expectedOid actualOid -> + UnexpectedColumnTypeStatementError + colIdx + expectedOid + actualOid + Hasql.Comms.ResultDecoder.RowError rowIndex rowError -> + case rowError of + Hasql.Comms.RowReader.CellError column oid cellErr -> + RowStatementError + rowIndex + ( CellRowError + column + oid + ( case cellErr of + Hasql.Comms.RowReader.DecodingCellError msg -> DeserializationCellError msg + Hasql.Comms.RowReader.UnexpectedNullCellError -> UnexpectedNullCellError + ) + ) + Hasql.Comms.RowReader.RefinementError msg -> + RowStatementError + rowIndex + (RefinementRowError msg) + +fromRecvErrorInScript :: ByteString -> Hasql.Comms.Recv.Error (Maybe ByteString) -> SessionError +fromRecvErrorInScript scriptSql = \case + Hasql.Comms.Recv.ResultError _ _ resultError -> + case resultError of + Hasql.Comms.ResultDecoder.ServerError code message detail hint position -> + ScriptSessionError + (decodeUtf8Lenient scriptSql) + ( ServerError + (decodeUtf8Lenient code) + (decodeUtf8Lenient message) + (fmap decodeUtf8Lenient detail) + (fmap decodeUtf8Lenient hint) + position + ) + Hasql.Comms.ResultDecoder.UnexpectedResult msg -> + (DriverSessionError . TextBuilder.toText . mconcat) + [ "Unexpected result in script: ", + TextBuilder.text msg + ] + Hasql.Comms.ResultDecoder.UnexpectedRowCount actual -> + (DriverSessionError . TextBuilder.toText . mconcat) + [ "Unexpected amount of rows in script: ", + TextBuilder.decimal actual + ] + Hasql.Comms.ResultDecoder.UnexpectedColumnCount expected actual -> + (DriverSessionError . TextBuilder.toText . mconcat) + [ "Unexpected amount of columns in script: expected ", + TextBuilder.decimal expected, + ", got ", + TextBuilder.decimal actual + ] + Hasql.Comms.ResultDecoder.DecoderTypeMismatch colIdx expectedOid actualOid -> + (DriverSessionError . TextBuilder.toText . mconcat) + [ "Decoder type mismatch in script: expected OID ", + TextBuilder.string (show expectedOid), + " at column ", + TextBuilder.decimal colIdx, + ", got ", + TextBuilder.string (show actualOid) + ] + Hasql.Comms.ResultDecoder.RowError rowIndex rowError -> + (DriverSessionError . TextBuilder.toText . mconcat) + [ "Row error in script at row ", + TextBuilder.decimal rowIndex, + ": ", + TextBuilder.string (show rowError) + ] + Hasql.Comms.Recv.NoResultsError _ details -> + (DriverSessionError . TextBuilder.toText . mconcat) + [ "Got no results in script.", + " This indicates a bug in Hasql or the server misbehaving.", + details + & filter (/= "") + & foldMap (mappend " Details: " . TextBuilder.text . decodeUtf8Lenient) + ] + Hasql.Comms.Recv.TooManyResultsError _ actual -> + (DriverSessionError . TextBuilder.toText . mconcat) + [ "Got too many results in script. ", + "This indicates a bug in Hasql or the server misbehaving. ", + "Amount: ", + TextBuilder.decimal actual + ] diff --git a/src/library/Hasql/Engine/PqProcedures/SelectTypeInfo.hs b/src/library/Hasql/Engine/PqProcedures/SelectTypeInfo.hs new file mode 100644 --- /dev/null +++ b/src/library/Hasql/Engine/PqProcedures/SelectTypeInfo.hs @@ -0,0 +1,124 @@ +module Hasql.Engine.PqProcedures.SelectTypeInfo + ( SelectTypeInfo (..), + SelectTypeInfoResult, + run, + ) +where + +import CodecVocab qualified as CodecVocab +import CodecVocab.QualifiedTypeName qualified as CodecVocab.QualifiedTypeName +import CodecVocab.TypeInfo qualified as CodecVocab.TypeInfo +import Data.HashMap.Strict qualified as HashMap +import Data.HashSet qualified as HashSet +import Hasql.Comms.ResultDecoder qualified +import Hasql.Comms.Roundtrip qualified +import Hasql.Comms.RowDecoder qualified +import Hasql.Engine.Errors qualified as Errors +import Hasql.Platform.Prelude +import PostgreSQL.Binary.Decoding qualified as BinaryDecoding +import PostgreSQL.Binary.Encoding qualified as Binary +import Pqi qualified as Pq + +newtype SelectTypeInfo = SelectTypeInfo + { -- | Set of (schema name, type name) pairs to look up. + keys :: HashSet CodecVocab.QualifiedTypeName + } + +-- | Result maps (schema name, type name) pairs to TypeInfo (scalar OID, array OID). +type SelectTypeInfoResult = + HashMap CodecVocab.QualifiedTypeName CodecVocab.TypeInfo.TypeInfo + +run :: Pq.Connection -> SelectTypeInfo -> IO (Either Errors.SessionError SelectTypeInfoResult) +run connection (SelectTypeInfo keys) = + if HashSet.null keys + then pure (Right HashMap.empty) + else + first Errors.fromRoundtripError + <$> Hasql.Comms.Roundtrip.toSerialIO (roundtrip (SelectTypeInfo keys)) connection + +sql :: ByteString +sql = + "with\n\ + \ inputs as (\n\ + \ select *\n\ + \ from unnest($1, $2) as x(schema_name, type_name)\n\ + \ ),\n\ + \ unnamespaced_results as (\n\ + \ select\n\ + \ null :: text as schema_name,\n\ + \ pg_type.typname :: text as type_name,\n\ + \ pg_type.oid :: int4 as type_oid,\n\ + \ pg_type.typarray :: int4 as array_oid\n\ + \ from inputs\n\ + \ join pg_type on pg_type.oid = to_regtype(inputs.type_name)\n\ + \ where inputs.schema_name is null\n\ + \ ),\n\ + \ namespaced_results as (\n\ + \ select\n\ + \ pg_namespace.nspname :: text as schema_name,\n\ + \ pg_type.typname :: text as type_name,\n\ + \ pg_type.oid :: int4 as type_oid,\n\ + \ pg_type.typarray :: int4 as array_oid\n\ + \ from inputs\n\ + \ join pg_namespace on pg_namespace.nspname = inputs.schema_name\n\ + \ join pg_type\n\ + \ on pg_type.typname = inputs.type_name\n\ + \ and pg_type.typnamespace = pg_namespace.oid\n\ + \ where inputs.schema_name is not null\n\ + \ )\n\ + \select * from unnamespaced_results\n\ + \union\n\ + \select * from namespaced_results" + +roundtrip :: SelectTypeInfo -> Hasql.Comms.Roundtrip.Roundtrip () SelectTypeInfoResult +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 (Word32, ByteString, Pq.Format)] +encodeParams (SelectTypeInfo keys) = + let (schemaNames, typeNames) = unzip (fmap CodecVocab.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 (1009, schemaArray, Pq.Binary), + Just (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 (CodecVocab.QualifiedTypeName.QualifiedTypeName schemaName typeName) (CodecVocab.TypeInfo.TypeInfo typeOid arrayOid) acc + +-- | These four columns have permanently fixed, well-known Postgres OIDs +-- (text = 25, int4 = 23), so they're decoded directly against +-- "postgresql-binary" rather than through the dynamic codec framework. +rowDecoder :: Hasql.Comms.RowDecoder.RowDecoder (Maybe Text, Text, Word32, Word32) +rowDecoder = + (,,,) + <$> nullableColumn textOid BinaryDecoding.text_strict + <*> nonNullableColumn textOid BinaryDecoding.text_strict + <*> nonNullableColumn int4Oid BinaryDecoding.int + <*> nonNullableColumn int4Oid BinaryDecoding.int + where + textOid = 25 + int4Oid = 23 + + nullableColumn oid valueDecoder = + Hasql.Comms.RowDecoder.nullableColumn + (Just oid) + (BinaryDecoding.valueParser valueDecoder) + + nonNullableColumn oid valueDecoder = + Hasql.Comms.RowDecoder.nonNullableColumn + (Just oid) + (BinaryDecoding.valueParser valueDecoder) diff --git a/src/library/Hasql/Engine/Statement.hs b/src/library/Hasql/Engine/Statement.hs new file mode 100644 --- /dev/null +++ b/src/library/Hasql/Engine/Statement.hs @@ -0,0 +1,177 @@ +module Hasql.Engine.Statement + ( Statement (..), + preparable, + unpreparable, + refineResult, + toSql, + compilePreparedStatementData, + compileUnpreparedStatementData, + ) +where + +import CodecVocab qualified as CodecVocab +import CodecVocab.TypeInfo qualified as CodecVocab.TypeInfo +import CodecVocab.TypeRef qualified as CodecVocab.TypeRef +import CodecVocab.TypeShape (TypeShape (..)) +import Data.Text.Encoding qualified as TextEncoding +import Data.Vector qualified as Vector +import Hasql.Codecs.Encoders qualified as Encoders +import Hasql.Codecs.Encoders.Params qualified as Params +import Hasql.Comms.ResultDecoder qualified as ResultDecoder +import Hasql.Engine.Decoders.Result qualified as Decoders +import Hasql.Engine.Decoders.Result qualified as Decoders.Result +import Hasql.Platform.Prelude + +-- | +-- Specification of a strictly single-statement query, which can be parameterized and prepared. +-- It encapsulates the mapping of parameters and results in association with an SQL template. +-- +-- Following is an example of a declaration of a prepared statement with its associated codecs. +-- +-- @ +-- selectSum :: 'Statement' (Int64, Int64) Int64 +-- selectSum = +-- 'preparable' sql encoder decoder +-- where +-- sql = +-- \"select ($1 + $2)\" +-- encoder = +-- ('fst' '>$<' Encoders.'Hasql.Encoders.param' (Encoders.'Hasql.Encoders.nonNullable' Encoders.'Hasql.Encoders.int8')) '<>' +-- ('snd' '>$<' Encoders.'Hasql.Encoders.param' (Encoders.'Hasql.Encoders.nonNullable' Encoders.'Hasql.Encoders.int8')) +-- decoder = +-- Decoders.'Hasql.Decoders.singleRow' (Decoders.'Hasql.Decoders.column' (Decoders.'Hasql.Decoders.nonNullable' Decoders.'Hasql.Decoders.int8')) +-- @ +-- +-- The statement above accepts a product of two parameters of type 'Int64' +-- and produces a single result of type 'Int64'. +data Statement params result + = Statement + { -- | SQL template pre-encoded as UTF-8 for execution. + sql :: ByteString, + -- | Frozen per-parameter type shapes. + -- Produced once at construction from the Params DList and reused across executions. + columnsMetadata :: Vector TypeShape, + -- | Serialise params to encoded wire values given a resolver of type names to their OIDs. + serializer :: (CodecVocab.QualifiedTypeName -> CodecVocab.TypeInfo) -> 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 CodecVocab.QualifiedTypeName, + -- | Result decoder, given a resolver of type names to their OIDs. + decoder :: (CodecVocab.QualifiedTypeName -> CodecVocab.TypeInfo) -> ResultDecoder.ResultDecoder result, + -- | Whether this statement may be prepared on the server. + isPrepared :: Bool + } + +-- | +-- Construct a preparable statement. +-- +-- Use this for statements that will be executed multiple times with different parameters. +-- Preparable statements are cached by PostgreSQL, which avoids reconstructing the execution plan each time. +-- +-- Suitable for applications with a limited amount of queries that don't generate SQL dynamically. +preparable :: + -- | SQL template with parameters in positional notation (@$1@, @$2@, etc.) + Text -> + -- | Parameters encoder + Encoders.Params params -> + -- | Result decoder + Decoders.Result result -> + Statement params result +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 <> Decoders.Result.toUnknownTypes resultDecoder, + decoder = Decoders.Result.toBase resultDecoder, + isPrepared = True + } + +-- | +-- Construct an unpreparable statement. +-- +-- Use this for statements that are dynamically generated or executed only once. +-- Unpreparable statements are not cached by PostgreSQL. +-- +-- Suitable for dynamic SQL or one-off queries. +unpreparable :: + -- | SQL template with parameters in positional notation (@$1@, @$2@, etc.) + Text -> + -- | Parameters encoder + Encoders.Params params -> + -- | Result decoder + Decoders.Result result -> + Statement params result +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 <> Decoders.Result.toUnknownTypes resultDecoder, + decoder = Decoders.Result.toBase resultDecoder, + isPrepared = False + } + +instance Functor (Statement params) where + {-# INLINE fmap #-} + fmap f stmt = stmt {decoder = fmap (fmap f) (decoder stmt)} + +instance Filterable (Statement params) where + {-# INLINE mapMaybe #-} + mapMaybe filtrator stmt = stmt {decoder = fmap (mapMaybe filtrator) (decoder stmt)} + +instance Profunctor Statement where + {-# INLINE dimap #-} + dimap f1 f2 stmt = + stmt + { serializer = \resolve -> serializer stmt resolve . f1, + printer = printer stmt . f1, + decoder = fmap (fmap f2) (decoder stmt) + } + +-- | +-- Refine the result of a statement, +-- causing the running session to fail with the 'Hasql.Errors.UnexpectedResultStatementError' error in case of a refinement failure. +-- +-- 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 stmt = stmt {decoder = fmap (ResultDecoder.refine refiner) (decoder stmt)} + +-- | Extract the SQL template from a statement. +toSql :: Statement params result -> Text +toSql stmt = decodeUtf8Lenient (sql stmt) + +-- | Compile prepared-statement data: resolve OIDs and pair encoded values with their format flags. +compilePreparedStatementData :: + Statement params result -> + (CodecVocab.QualifiedTypeName -> CodecVocab.TypeInfo) -> + params -> + ([Word32], [Maybe (ByteString, Bool)]) +compilePreparedStatementData stmt resolve params = + unzip + $ zipWith + (\(TypeShape typeRef dim fmt) encoding -> (resolveOid resolve typeRef dim, fmap (,fmt) encoding)) + (Vector.toList (columnsMetadata stmt)) + (serializer stmt resolve params) + +-- | Compile unprepared-statement data: resolve OIDs inline with encoded values. +compileUnpreparedStatementData :: + Statement params result -> + (CodecVocab.QualifiedTypeName -> CodecVocab.TypeInfo) -> + params -> + [Maybe (Word32, ByteString, Bool)] +compileUnpreparedStatementData stmt resolve params = + zipWith + (\(TypeShape typeRef dim fmt) encoding -> (,,) <$> Just (resolveOid resolve typeRef dim) <*> encoding <*> Just fmt) + (Vector.toList (columnsMetadata stmt)) + (serializer stmt resolve params) + +-- | Resolve a param's wire OID given the dictionary of resolved type names. +resolveOid :: (CodecVocab.QualifiedTypeName -> CodecVocab.TypeInfo) -> CodecVocab.TypeRef.TypeRef -> Word -> Word32 +resolveOid resolve (CodecVocab.TypeRef.NamedType name) dim = + (if dim == 0 then CodecVocab.TypeInfo.toBaseOid else CodecVocab.TypeInfo.toArrayOid) (resolve name) +resolveOid _ (CodecVocab.TypeRef.KnownOid oid) _ = oid diff --git a/src/to-be-resolved/Hasql/ToBeResolved.hs b/src/to-be-resolved/Hasql/ToBeResolved.hs new file mode 100644 --- /dev/null +++ b/src/to-be-resolved/Hasql/ToBeResolved.hs @@ -0,0 +1,40 @@ +module Hasql.ToBeResolved + ( ToBeResolved (..), + lookup, + ) +where + +import Control.Applicative +import Prelude hiding (lookup) + +-- | +-- A computation that first declares the keys it needs resolved and then, +-- once a resolver @k -> v@ is provided, produces its result. +-- +-- The defining trait is the upfront collection of keys prior to resolution, +-- hence the name. +data ToBeResolved k v a + = ToBeResolved + -- | Keys requested to be available for lookup. + [k] + -- | Continuation that looks up values by keys. + ((k -> v) -> a) + +type role ToBeResolved _ _ representational + +deriving stock instance Functor (ToBeResolved k v) + +instance Applicative (ToBeResolved k v) where + {-# INLINE pure #-} + pure a = + ToBeResolved [] (\_ -> a) + {-# INLINE (<*>) #-} + ToBeResolved lKeys lUse <*> ToBeResolved rKeys rUse = + ToBeResolved + (lKeys <> rKeys) + (\lookup -> lUse lookup (rUse lookup)) + +{-# INLINE lookup #-} +lookup :: k -> ToBeResolved k v v +lookup key = + ToBeResolved [key] (\lookupFn -> lookupFn key)