diff --git a/postgresql-simple-postgresql-types.cabal b/postgresql-simple-postgresql-types.cabal --- a/postgresql-simple-postgresql-types.cabal +++ b/postgresql-simple-postgresql-types.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: postgresql-simple-postgresql-types -version: 0.1.1 +version: 0.1.2.0 category: PostgreSQL, Codecs synopsis: Integration of "postgresql-simple" with "postgresql-types" homepage: https://github.com/nikita-volkov/postgresql-simple-postgresql-types @@ -90,14 +90,14 @@ other-modules: Database.PostgreSQL.Simple.PostgresqlTypes.Prelude - Database.PostgreSQL.Simple.PostgresqlTypes.ViaIsScalar + Database.PostgreSQL.Simple.PostgresqlTypes.ViaIsPrimitive build-depends: attoparsec ^>=0.14.4, base >=4.11 && <5, postgresql-simple >=0.7.0.1 && <0.8, - postgresql-types ^>=0.1, - postgresql-types-algebra ^>=0.1, + postgresql-types ^>=0.1.5, + postgresql-types-algebra ^>=0.2, tagged ^>=0.8.9, text >=1.2 && <3, text-builder ^>=1.0.0.5, @@ -118,8 +118,8 @@ hspec >=2.11 && <3, postgresql-simple >=0.7.0.1 && <0.8, postgresql-simple-postgresql-types, - postgresql-types ^>=0.1, - postgresql-types-algebra ^>=0.1, + postgresql-types ^>=0.1.5, + postgresql-types-algebra ^>=0.2, quickcheck-instances ^>=0.3.33, stm >=2.5 && <3, tagged ^>=0.8.9, diff --git a/src/integration-tests/IntegrationTests/Scopes.hs b/src/integration-tests/IntegrationTests/Scopes.hs --- a/src/integration-tests/IntegrationTests/Scopes.hs +++ b/src/integration-tests/IntegrationTests/Scopes.hs @@ -53,6 +53,7 @@ void do Ps.execute_ connection "SET client_min_messages TO WARNING" createExtensionIfNotExists connection "hstore" + createExtensionIfNotExists connection "citext" pure connection where createExtensionIfNotExists connection extension = diff --git a/src/integration-tests/IntegrationTests/Scripts.hs b/src/integration-tests/IntegrationTests/Scripts.hs --- a/src/integration-tests/IntegrationTests/Scripts.hs +++ b/src/integration-tests/IntegrationTests/Scripts.hs @@ -26,7 +26,7 @@ QuickCheck.Arbitrary a, Show a, Eq a, - Pta.IsScalar a, + Pta.IsPrimitive a, Ps.ToField a, Ps.FromField a, Typeable a diff --git a/src/integration-tests/Main.hs b/src/integration-tests/Main.hs --- a/src/integration-tests/Main.hs +++ b/src/integration-tests/Main.hs @@ -34,6 +34,7 @@ withType @Pt.Char [mappingSpec True] withType @Pt.Cidr [mappingSpec True] withType @Pt.Circle [mappingSpec True] + withType @Pt.Citext [mappingSpec True] withType @Pt.Date [mappingSpec True] withType @Pt.Float4 [mappingSpec True] withType @Pt.Float8 [mappingSpec True] @@ -89,6 +90,7 @@ withType @Pt.Char [mappingSpec True] withType @Pt.Cidr [mappingSpec True] withType @Pt.Circle [mappingSpec True] + withType @Pt.Citext [mappingSpec True] withType @Pt.Date [mappingSpec True] withType @Pt.Float4 [mappingSpec True] withType @Pt.Float8 [mappingSpec True] diff --git a/src/library/Database/PostgreSQL/Simple/PostgresqlTypes.hs b/src/library/Database/PostgreSQL/Simple/PostgresqlTypes.hs --- a/src/library/Database/PostgreSQL/Simple/PostgresqlTypes.hs +++ b/src/library/Database/PostgreSQL/Simple/PostgresqlTypes.hs @@ -23,171 +23,182 @@ import Data.Data (Typeable) import Database.PostgreSQL.Simple.FromField (FromField) -import Database.PostgreSQL.Simple.PostgresqlTypes.ViaIsScalar (ViaIsScalar (ViaIsScalar)) +import Database.PostgreSQL.Simple.PostgresqlTypes.ViaIsPrimitive (ViaIsPrimitive (ViaIsPrimitive)) import Database.PostgreSQL.Simple.ToField import GHC.TypeLits import PostgresqlTypes import PostgresqlTypes.Algebra -deriving via ViaIsScalar (Bit length) instance (KnownNat length) => FromField (Bit length) +deriving via ViaIsPrimitive (Bit length) instance (KnownNat length) => FromField (Bit length) -deriving via ViaIsScalar (Bit length) instance (KnownNat length) => ToField (Bit length) +deriving via ViaIsPrimitive (Bit length) instance (KnownNat length) => ToField (Bit length) -deriving via ViaIsScalar (Bpchar length) instance (KnownNat length) => FromField (Bpchar length) +deriving via ViaIsPrimitive (Bpchar length) instance (KnownNat length) => FromField (Bpchar length) -deriving via ViaIsScalar (Bpchar length) instance (KnownNat length) => ToField (Bpchar length) +deriving via ViaIsPrimitive (Bpchar length) instance (KnownNat length) => ToField (Bpchar length) -deriving via ViaIsScalar (Numeric precision scale) instance (KnownNat precision, KnownNat scale) => FromField (Numeric precision scale) +deriving via ViaIsPrimitive (Numeric precision scale) instance (KnownNat precision, KnownNat scale) => FromField (Numeric precision scale) -deriving via ViaIsScalar (Numeric precision scale) instance (KnownNat precision, KnownNat scale) => ToField (Numeric precision scale) +deriving via ViaIsPrimitive (Numeric precision scale) instance (KnownNat precision, KnownNat scale) => ToField (Numeric precision scale) -deriving via ViaIsScalar (Varbit maxLen) instance (KnownNat maxLen) => FromField (Varbit maxLen) +deriving via ViaIsPrimitive (Varbit maxLen) instance (KnownNat maxLen) => FromField (Varbit maxLen) -deriving via ViaIsScalar (Varbit maxLen) instance (KnownNat maxLen) => ToField (Varbit maxLen) +deriving via ViaIsPrimitive (Varbit maxLen) instance (KnownNat maxLen) => ToField (Varbit maxLen) -deriving via ViaIsScalar (Varchar maxLen) instance (KnownNat maxLen) => FromField (Varchar maxLen) +deriving via ViaIsPrimitive (Varchar maxLen) instance (KnownNat maxLen) => FromField (Varchar maxLen) -deriving via ViaIsScalar (Varchar maxLen) instance (KnownNat maxLen) => ToField (Varchar maxLen) +deriving via ViaIsPrimitive (Varchar maxLen) instance (KnownNat maxLen) => ToField (Varchar maxLen) -- | Decoder of 'Multirange' types. -- -- Notice that \"postgresql-simple\" has an issue due to which queries producing arrays of multiranges always fail. See https://github.com/haskellari/postgresql-simple/issues/163. In other cases everything should work fine. -deriving via ViaIsScalar (Multirange a) instance (IsMultirangeElement a, Typeable a) => FromField (Multirange a) +deriving via ViaIsPrimitive (Multirange a) instance (IsMultirangeElement a, Typeable a) => FromField (Multirange a) -deriving via ViaIsScalar (Multirange a) instance (IsMultirangeElement a) => ToField (Multirange a) +deriving via ViaIsPrimitive (Multirange a) instance (IsMultirangeElement a) => ToField (Multirange a) -deriving via ViaIsScalar (Range a) instance (IsRangeElement a, Typeable a) => FromField (Range a) +deriving via ViaIsPrimitive (Range a) instance (IsRangeElement a, Typeable a) => FromField (Range a) -deriving via ViaIsScalar (Range a) instance (IsRangeElement a) => ToField (Range a) +deriving via ViaIsPrimitive (Range a) instance (IsRangeElement a) => ToField (Range a) -deriving via ViaIsScalar Bool instance FromField Bool +deriving via ViaIsPrimitive Bool instance FromField Bool -deriving via ViaIsScalar Bool instance ToField Bool +deriving via ViaIsPrimitive Bool instance ToField Bool -deriving via ViaIsScalar Box instance FromField Box +deriving via ViaIsPrimitive Box instance FromField Box -deriving via ViaIsScalar Box instance ToField Box +deriving via ViaIsPrimitive Box instance ToField Box -deriving via ViaIsScalar Bytea instance FromField Bytea +deriving via ViaIsPrimitive Bytea instance FromField Bytea -deriving via ViaIsScalar Bytea instance ToField Bytea +deriving via ViaIsPrimitive Bytea instance ToField Bytea -deriving via ViaIsScalar Char instance FromField Char +deriving via ViaIsPrimitive Char instance FromField Char -deriving via ViaIsScalar Char instance ToField Char +deriving via ViaIsPrimitive Char instance ToField Char -deriving via ViaIsScalar Cidr instance FromField Cidr +deriving via ViaIsPrimitive Cidr instance FromField Cidr -deriving via ViaIsScalar Cidr instance ToField Cidr +deriving via ViaIsPrimitive Cidr instance ToField Cidr -deriving via ViaIsScalar Circle instance FromField Circle +deriving via ViaIsPrimitive Circle instance FromField Circle -deriving via ViaIsScalar Circle instance ToField Circle +deriving via ViaIsPrimitive Circle instance ToField Circle -deriving via ViaIsScalar Date instance FromField Date +deriving via ViaIsPrimitive Citext instance FromField Citext -deriving via ViaIsScalar Date instance ToField Date +deriving via ViaIsPrimitive Citext instance ToField Citext -deriving via ViaIsScalar Float4 instance FromField Float4 +deriving via ViaIsPrimitive Date instance FromField Date -deriving via ViaIsScalar Float4 instance ToField Float4 +deriving via ViaIsPrimitive Date instance ToField Date -deriving via ViaIsScalar Float8 instance FromField Float8 +deriving via ViaIsPrimitive Float4 instance FromField Float4 -deriving via ViaIsScalar Float8 instance ToField Float8 +deriving via ViaIsPrimitive Float4 instance ToField Float4 -deriving via ViaIsScalar Hstore instance FromField Hstore +deriving via ViaIsPrimitive Float8 instance FromField Float8 -deriving via ViaIsScalar Hstore instance ToField Hstore +deriving via ViaIsPrimitive Float8 instance ToField Float8 -deriving via ViaIsScalar Inet instance FromField Inet +-- | Decoder of the 'Geometry' PostGIS type. +-- +-- Requires the @postgis@ extension to be installed in PostgreSQL. +deriving via ViaIsPrimitive Geometry instance FromField Geometry -deriving via ViaIsScalar Inet instance ToField Inet +deriving via ViaIsPrimitive Geometry instance ToField Geometry -deriving via ViaIsScalar Int2 instance FromField Int2 +deriving via ViaIsPrimitive Hstore instance FromField Hstore -deriving via ViaIsScalar Int2 instance ToField Int2 +deriving via ViaIsPrimitive Hstore instance ToField Hstore -deriving via ViaIsScalar Int4 instance FromField Int4 +deriving via ViaIsPrimitive Inet instance FromField Inet -deriving via ViaIsScalar Int4 instance ToField Int4 +deriving via ViaIsPrimitive Inet instance ToField Inet -deriving via ViaIsScalar Int8 instance FromField Int8 +deriving via ViaIsPrimitive Int2 instance FromField Int2 -deriving via ViaIsScalar Int8 instance ToField Int8 +deriving via ViaIsPrimitive Int2 instance ToField Int2 -deriving via ViaIsScalar Interval instance FromField Interval +deriving via ViaIsPrimitive Int4 instance FromField Int4 -deriving via ViaIsScalar Interval instance ToField Interval +deriving via ViaIsPrimitive Int4 instance ToField Int4 -deriving via ViaIsScalar Json instance FromField Json +deriving via ViaIsPrimitive Int8 instance FromField Int8 -deriving via ViaIsScalar Json instance ToField Json +deriving via ViaIsPrimitive Int8 instance ToField Int8 -deriving via ViaIsScalar Jsonb instance FromField Jsonb +deriving via ViaIsPrimitive Interval instance FromField Interval -deriving via ViaIsScalar Jsonb instance ToField Jsonb +deriving via ViaIsPrimitive Interval instance ToField Interval -deriving via ViaIsScalar Line instance FromField Line +deriving via ViaIsPrimitive Json instance FromField Json -deriving via ViaIsScalar Line instance ToField Line +deriving via ViaIsPrimitive Json instance ToField Json -deriving via ViaIsScalar Lseg instance FromField Lseg +deriving via ViaIsPrimitive Jsonb instance FromField Jsonb -deriving via ViaIsScalar Lseg instance ToField Lseg +deriving via ViaIsPrimitive Jsonb instance ToField Jsonb -deriving via ViaIsScalar Macaddr instance FromField Macaddr +deriving via ViaIsPrimitive Line instance FromField Line -deriving via ViaIsScalar Macaddr instance ToField Macaddr +deriving via ViaIsPrimitive Line instance ToField Line -deriving via ViaIsScalar Macaddr8 instance FromField Macaddr8 +deriving via ViaIsPrimitive Lseg instance FromField Lseg -deriving via ViaIsScalar Macaddr8 instance ToField Macaddr8 +deriving via ViaIsPrimitive Lseg instance ToField Lseg -deriving via ViaIsScalar Money instance FromField Money +deriving via ViaIsPrimitive Macaddr instance FromField Macaddr -deriving via ViaIsScalar Money instance ToField Money +deriving via ViaIsPrimitive Macaddr instance ToField Macaddr -deriving via ViaIsScalar Oid instance FromField Oid +deriving via ViaIsPrimitive Macaddr8 instance FromField Macaddr8 -deriving via ViaIsScalar Oid instance ToField Oid +deriving via ViaIsPrimitive Macaddr8 instance ToField Macaddr8 -deriving via ViaIsScalar Path instance FromField Path +deriving via ViaIsPrimitive Money instance FromField Money -deriving via ViaIsScalar Path instance ToField Path +deriving via ViaIsPrimitive Money instance ToField Money -deriving via ViaIsScalar Point instance FromField Point +deriving via ViaIsPrimitive Oid instance FromField Oid -deriving via ViaIsScalar Point instance ToField Point +deriving via ViaIsPrimitive Oid instance ToField Oid -deriving via ViaIsScalar Polygon instance FromField Polygon +deriving via ViaIsPrimitive Path instance FromField Path -deriving via ViaIsScalar Polygon instance ToField Polygon +deriving via ViaIsPrimitive Path instance ToField Path -deriving via ViaIsScalar Text instance FromField Text +deriving via ViaIsPrimitive Point instance FromField Point -deriving via ViaIsScalar Text instance ToField Text +deriving via ViaIsPrimitive Point instance ToField Point -deriving via ViaIsScalar Time instance FromField Time +deriving via ViaIsPrimitive Polygon instance FromField Polygon -deriving via ViaIsScalar Time instance ToField Time +deriving via ViaIsPrimitive Polygon instance ToField Polygon -deriving via ViaIsScalar Timestamp instance FromField Timestamp +deriving via ViaIsPrimitive Text instance FromField Text -deriving via ViaIsScalar Timestamp instance ToField Timestamp +deriving via ViaIsPrimitive Text instance ToField Text -deriving via ViaIsScalar Timestamptz instance FromField Timestamptz +deriving via ViaIsPrimitive Time instance FromField Time -deriving via ViaIsScalar Timestamptz instance ToField Timestamptz +deriving via ViaIsPrimitive Time instance ToField Time -deriving via ViaIsScalar Timetz instance FromField Timetz +deriving via ViaIsPrimitive Timestamp instance FromField Timestamp -deriving via ViaIsScalar Timetz instance ToField Timetz +deriving via ViaIsPrimitive Timestamp instance ToField Timestamp -deriving via ViaIsScalar Tsvector instance FromField Tsvector +deriving via ViaIsPrimitive Timestamptz instance FromField Timestamptz -deriving via ViaIsScalar Tsvector instance ToField Tsvector +deriving via ViaIsPrimitive Timestamptz instance ToField Timestamptz -deriving via ViaIsScalar Uuid instance FromField Uuid +deriving via ViaIsPrimitive Timetz instance FromField Timetz -deriving via ViaIsScalar Uuid instance ToField Uuid +deriving via ViaIsPrimitive Timetz instance ToField Timetz + +deriving via ViaIsPrimitive Tsvector instance FromField Tsvector + +deriving via ViaIsPrimitive Tsvector instance ToField Tsvector + +deriving via ViaIsPrimitive Uuid instance FromField Uuid + +deriving via ViaIsPrimitive Uuid instance ToField Uuid diff --git a/src/library/Database/PostgreSQL/Simple/PostgresqlTypes/ViaIsPrimitive.hs b/src/library/Database/PostgreSQL/Simple/PostgresqlTypes/ViaIsPrimitive.hs new file mode 100644 --- /dev/null +++ b/src/library/Database/PostgreSQL/Simple/PostgresqlTypes/ViaIsPrimitive.hs @@ -0,0 +1,125 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + +-- | +-- This module provides a bridge between PostgreSQL's standard types and the postgresql-simple library, +-- offering automatic ToField and FromField instance generation for types that implement the 'IsPrimitive' constraint. +-- +-- = Usage +-- +-- Import this module in addition to @Database.PostgreSQL.Simple@ to get encoding/decoding support +-- for postgresql-types in postgresql-simple queries: +-- +-- > import Database.PostgreSQL.Simple +-- > import Database.PostgreSQL.Simple.PostgresqlTypes +-- > import PostgresqlTypes.Types (Int4, Text) +-- > +-- > -- Now you can use postgresql-types directly in queries +-- > example :: Connection -> Int4 -> IO [Only Text] +-- > example conn myInt = query conn "SELECT name FROM users WHERE id = ?" (Only myInt) +-- +-- = How it works +-- +-- * 'toFieldVia' creates a 'ToField' compatible 'Action' using the 'textualEncoder' from 'Pta.IsPrimitive' +-- * 'fromFieldVia' creates a 'FromField' compatible parser using the 'textualDecoder' from 'Pta.IsPrimitive' +-- +-- The module uses textual format for encoding/decoding since that's what postgresql-simple primarily uses. +module Database.PostgreSQL.Simple.PostgresqlTypes.ViaIsPrimitive (ViaIsPrimitive (..)) where + +import qualified Data.Attoparsec.Text as Attoparsec +import qualified Data.Text as Text +import qualified Data.Text.Encoding as TextEncoding +import qualified Data.Text.Encoding.Error as TextEncoding +import Database.PostgreSQL.Simple +import Database.PostgreSQL.Simple.FromField +import Database.PostgreSQL.Simple.PostgresqlTypes.Prelude +import Database.PostgreSQL.Simple.ToField +import qualified PostgresqlTypes.Algebra as Pta +import qualified TextBuilder + +newtype ViaIsPrimitive a = ViaIsPrimitive a + +instance (Pta.IsPrimitive a) => ToField (ViaIsPrimitive a) where + toField (ViaIsPrimitive value) = toFieldVia value + +instance (Typeable a, Pta.IsPrimitive a) => FromField (ViaIsPrimitive a) where + fromField field mdata = ViaIsPrimitive <$> fromFieldVia field mdata + +-- | Convert a postgresql-types value to a postgresql-simple 'Action'. +-- +-- This function uses the textual encoder from 'IsPrimitive' to produce +-- an escaped text value suitable for use in SQL queries. +-- +-- > instance ToField Int4 where +-- > toField = toFieldVia +toFieldVia :: forall a. (Pta.IsPrimitive a) => a -> Action +toFieldVia value = + Many + [ Escape (TextEncoding.encodeUtf8 (TextBuilder.toText (Pta.textualEncoder value))), + Plain ("::" <> TextEncoding.encodeUtf8Builder (untag (Pta.typeSignature @a))) + ] + +-- | Parse a postgresql-types value from a postgresql-simple field. +-- +-- This function uses the textual decoder from 'Pta.IsPrimitive' to parse +-- values received from PostgreSQL in text format. +-- +-- It validates the field's type by comparing: +-- * The field's OID against the type's expected base OID or array OID +-- * When OID is not statically known, falls back to comparing type names +-- * Automatically handles array types by checking against arrayOid +-- +-- > instance FromField Int4 where +-- > fromField = fromFieldVia +fromFieldVia :: forall a. (Typeable a, Pta.IsPrimitive a) => FieldParser a +fromFieldVia field mdata = do + -- Type validation: check OID or name + let expectedBaseOid = untag (Pta.baseOid @a) + expectedArrayOid = untag (Pta.arrayOid @a) + expectedTypeName = untag (Pta.typeName @a) + fieldOid = typeOid field + + case (expectedBaseOid, expectedArrayOid) of + -- For types with known OIDs, validate against OID without calling typename + (Just expectedBaseOid, Just expectedArrayOid) -> do + let typeMatches = + fieldOid == Oid (fromIntegral expectedBaseOid) + || fieldOid == Oid (fromIntegral expectedArrayOid) + + unless typeMatches do + returnError Incompatible field $ + mconcat + [ "Type mismatch: expected ", + Text.unpack expectedTypeName, + " (OID ", + show expectedBaseOid, + ", array OID " <> show expectedArrayOid, + ") but got field with OID ", + show fieldOid + ] + + -- Only call typename if we need it for validation (when OID is not available) + _ -> do + fieldTypeName <- typename field + let expectedName = TextEncoding.encodeUtf8 expectedTypeName + unless (fieldTypeName == expectedName) do + returnError Incompatible field $ + mconcat + [ "Type mismatch: expected ", + Text.unpack expectedTypeName, + " (OID unknown) but got field with type name ", + show (TextEncoding.decodeUtf8With TextEncoding.lenientDecode fieldTypeName) + ] + + -- Data validation and parsing + case mdata of + Nothing -> returnError UnexpectedNull field "" + Just bytes -> case TextEncoding.decodeUtf8' bytes of + Left err -> + returnError ConversionFailed field $ + "UTF-8 decoding failed: " <> show err + Right text -> + case Attoparsec.parseOnly (Pta.textualDecoder @a <* Attoparsec.endOfInput) text of + Left err -> + returnError ConversionFailed field $ + "Parsing failed: " <> err + Right value -> pure value diff --git a/src/library/Database/PostgreSQL/Simple/PostgresqlTypes/ViaIsScalar.hs b/src/library/Database/PostgreSQL/Simple/PostgresqlTypes/ViaIsScalar.hs deleted file mode 100644 --- a/src/library/Database/PostgreSQL/Simple/PostgresqlTypes/ViaIsScalar.hs +++ /dev/null @@ -1,125 +0,0 @@ -{-# OPTIONS_GHC -Wno-orphans #-} - --- | --- This module provides a bridge between PostgreSQL's standard types and the postgresql-simple library, --- offering automatic ToField and FromField instance generation for types that implement the 'IsScalar' constraint. --- --- = Usage --- --- Import this module in addition to @Database.PostgreSQL.Simple@ to get encoding/decoding support --- for postgresql-types in postgresql-simple queries: --- --- > import Database.PostgreSQL.Simple --- > import Database.PostgreSQL.Simple.PostgresqlTypes --- > import PostgresqlTypes.Types (Int4, Text) --- > --- > -- Now you can use postgresql-types directly in queries --- > example :: Connection -> Int4 -> IO [Only Text] --- > example conn myInt = query conn "SELECT name FROM users WHERE id = ?" (Only myInt) --- --- = How it works --- --- * 'toFieldVia' creates a 'ToField' compatible 'Action' using the 'textualEncoder' from 'Pta.IsScalar' --- * 'fromFieldVia' creates a 'FromField' compatible parser using the 'textualDecoder' from 'Pta.IsScalar' --- --- The module uses textual format for encoding/decoding since that's what postgresql-simple primarily uses. -module Database.PostgreSQL.Simple.PostgresqlTypes.ViaIsScalar (ViaIsScalar (..)) where - -import qualified Data.Attoparsec.Text as Attoparsec -import qualified Data.Text as Text -import qualified Data.Text.Encoding as TextEncoding -import qualified Data.Text.Encoding.Error as TextEncoding -import Database.PostgreSQL.Simple -import Database.PostgreSQL.Simple.FromField -import Database.PostgreSQL.Simple.PostgresqlTypes.Prelude -import Database.PostgreSQL.Simple.ToField -import qualified PostgresqlTypes.Algebra as Pta -import qualified TextBuilder - -newtype ViaIsScalar a = ViaIsScalar a - -instance (Pta.IsScalar a) => ToField (ViaIsScalar a) where - toField (ViaIsScalar value) = toFieldVia value - -instance (Typeable a, Pta.IsScalar a) => FromField (ViaIsScalar a) where - fromField field mdata = ViaIsScalar <$> fromFieldVia field mdata - --- | Convert a postgresql-types value to a postgresql-simple 'Action'. --- --- This function uses the textual encoder from 'IsScalar' to produce --- an escaped text value suitable for use in SQL queries. --- --- > instance ToField Int4 where --- > toField = toFieldVia -toFieldVia :: forall a. (Pta.IsScalar a) => a -> Action -toFieldVia value = - Many - [ Escape (TextEncoding.encodeUtf8 (TextBuilder.toText (Pta.textualEncoder value))), - Plain ("::" <> TextEncoding.encodeUtf8Builder (untag (Pta.typeSignature @a))) - ] - --- | Parse a postgresql-types value from a postgresql-simple field. --- --- This function uses the textual decoder from 'Pta.IsScalar' to parse --- values received from PostgreSQL in text format. --- --- It validates the field's type by comparing: --- * The field's OID against the type's expected base OID or array OID --- * When OID is not statically known, falls back to comparing type names --- * Automatically handles array types by checking against arrayOid --- --- > instance FromField Int4 where --- > fromField = fromFieldVia -fromFieldVia :: forall a. (Typeable a, Pta.IsScalar a) => FieldParser a -fromFieldVia field mdata = do - -- Type validation: check OID or name - let expectedBaseOid = untag (Pta.baseOid @a) - expectedArrayOid = untag (Pta.arrayOid @a) - expectedTypeName = untag (Pta.typeName @a) - fieldOid = typeOid field - - case (expectedBaseOid, expectedArrayOid) of - -- For types with known OIDs, validate against OID without calling typename - (Just expectedBaseOid, Just expectedArrayOid) -> do - let typeMatches = - fieldOid == Oid (fromIntegral expectedBaseOid) - || fieldOid == Oid (fromIntegral expectedArrayOid) - - unless typeMatches do - returnError Incompatible field $ - mconcat - [ "Type mismatch: expected ", - Text.unpack expectedTypeName, - " (OID ", - show expectedBaseOid, - ", array OID " <> show expectedArrayOid, - ") but got field with OID ", - show fieldOid - ] - - -- Only call typename if we need it for validation (when OID is not available) - _ -> do - fieldTypeName <- typename field - let expectedName = TextEncoding.encodeUtf8 expectedTypeName - unless (fieldTypeName == expectedName) do - returnError Incompatible field $ - mconcat - [ "Type mismatch: expected ", - Text.unpack expectedTypeName, - " (OID unknown) but got field with type name ", - show (TextEncoding.decodeUtf8With TextEncoding.lenientDecode fieldTypeName) - ] - - -- Data validation and parsing - case mdata of - Nothing -> returnError UnexpectedNull field "" - Just bytes -> case TextEncoding.decodeUtf8' bytes of - Left err -> - returnError ConversionFailed field $ - "UTF-8 decoding failed: " <> show err - Right text -> - case Attoparsec.parseOnly (Pta.textualDecoder @a <* Attoparsec.endOfInput) text of - Left err -> - returnError ConversionFailed field $ - "Parsing failed: " <> err - Right value -> pure value