diff --git a/beam-postgres/ChangeLog.md b/beam-postgres/ChangeLog.md index ed43a40e..9b8b7b44 100644 --- a/beam-postgres/ChangeLog.md +++ b/beam-postgres/ChangeLog.md @@ -1,3 +1,9 @@ +# Unreleased + +## Bug fixes + + * Fixed an issue where columns of type `Maybe (Vector a)` did not marshall correctly from the database. In particular, querying a `Nothing` would return `Just (Vector.fromList [])` instead (#692). + # 0.5.4.1 ## Bug fixes diff --git a/beam-postgres/Database/Beam/Postgres/Types.hs b/beam-postgres/Database/Beam/Postgres/Types.hs index b00b3840..efc93b5d 100644 --- a/beam-postgres/Database/Beam/Postgres/Types.hs +++ b/beam-postgres/Database/Beam/Postgres/Types.hs @@ -155,12 +155,7 @@ instance FromBackendRow Postgres [Char] instance FromBackendRow Postgres (Ratio Integer) instance FromBackendRow Postgres (CI Text) instance FromBackendRow Postgres (CI TL.Text) -instance (Pg.FromField a, Typeable a) => FromBackendRow Postgres (Vector a) where - fromBackendRow = do - isNull <- peekField - case isNull of - Just SqlNull -> pure mempty - Nothing -> parseOneField @Postgres @(Vector a) +instance (Pg.FromField a, Typeable a) => FromBackendRow Postgres (Vector a) instance (Pg.FromField a, Typeable a) => FromBackendRow Postgres (Pg.PGArray a) instance FromBackendRow Postgres (Pg.Binary ByteString) instance FromBackendRow Postgres (Pg.Binary BL.ByteString) diff --git a/beam-postgres/test/Database/Beam/Postgres/Test/Marshal.hs b/beam-postgres/test/Database/Beam/Postgres/Test/Marshal.hs index 08838264..23c47027 100644 --- a/beam-postgres/test/Database/Beam/Postgres/Test/Marshal.hs +++ b/beam-postgres/test/Database/Beam/Postgres/Test/Marshal.hs @@ -1,4 +1,5 @@ {-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE StandaloneDeriving #-} module Database.Beam.Postgres.Test.Marshal where import Database.Beam @@ -9,6 +10,7 @@ import Database.Beam.Migrate.Simple (autoMigrate) import Database.Beam.Postgres import Database.Beam.Postgres.Migrate (migrationBackend) import Database.Beam.Postgres.Test +import Database.PostgreSQL.Simple (execute_) import Data.ByteString (ByteString) import Data.Functor.Classes @@ -17,6 +19,7 @@ import qualified Data.Text as T import Data.Typeable import Data.UUID (UUID, fromWords) import Data.Word +import qualified Data.Vector as Vector import qualified Hedgehog import Hedgehog ((===)) @@ -28,6 +31,7 @@ import Test.Tasty.HUnit import Unsafe.Coerce + textGen :: Hedgehog.Gen T.Text textGen = Gen.text (Range.constant 0 1000) $ Gen.filter (/= '\NUL') Gen.unicode @@ -86,6 +90,7 @@ tests postgresConn = , marshalTest (Gen.maybe (Gen.integral (Range.constantBounded @Word64))) postgresConn , marshalTest (Gen.maybe textGen) postgresConn , marshalTest (Gen.maybe uuidGen) postgresConn + , marshalTest692 postgresConn , marshalTest' (\a b -> Hedgehog.assert (liftEq ptCmp a b)) (Gen.maybe pointGen) postgresConn , marshalTest' (\a b -> Hedgehog.assert (liftEq boxCmp a b)) (Gen.maybe boxGen) postgresConn @@ -160,3 +165,69 @@ marshalTest' cmp gen postgresConn = assertBool "Hedgehog test failed" passes + +-- Ensure that both `Vector Text` and `Maybe (Vector Text)` can be +-- marshalled correctly (see issue 692). +-- +-- At this time, the postgres migration backend can't create columns of arrays, +-- and hence this test does not use `marshalTest`. +marshalTest692 :: IO ByteString -> TestTree +marshalTest692 postgresConn = + testCase "Can marshal Vector Text and Maybe (Vector Text) (#692)" $ + withTestPostgres ("db_marshal_maybe_vector_text_issue_692") postgresConn $ \conn -> do + liftIO $ execute_ conn $ "CREATE TABLE mytable (\nmyid SERIAL PRIMARY KEY, mycolumn text[], mynullablecolumn text[]\n);" + + passes <- Hedgehog.check . Hedgehog.property $ do + nullable <- Hedgehog.forAll (Gen.maybe (Vector.fromList <$> (Gen.list (Range.linear 0 10) textGen))) + nonnull <- Hedgehog.forAll (Vector.fromList <$> (Gen.list (Range.linear 0 10) textGen)) + + [MkTbl692 rowId v vnull] <- + liftIO . runBeamPostgres conn + $ runInsertReturningList + $ insert (_myTable myDB) + $ insertExpressions [ MkTbl692 default_ (val_ nonnull) (val_ nullable) ] + + v === nonnull + vnull === nullable + + Just (MkTbl692 _ v' vnull') <- + liftIO . runBeamPostgres conn + $ runSelectReturningOne (lookup_ (_myTable myDB) (Tbl692Key rowId)) + v' === nonnull + vnull' === nullable + + assertBool "Hedgehog test failed" passes + where + myDB :: DatabaseSettings Postgres MyDB692 + myDB = defaultDbSettings `withDbModification` + MkMyDB692 { + _myTable = + setEntityName "mytable" <> + modifyTableFields + tableModification { + myid = fieldNamed "myid", + mycolumn = fieldNamed "mycolumn", + mynullablecolumn = fieldNamed "mynullablecolumn" + } + } + +data Tbl692 f + = MkTbl692 + { myid :: C f (SqlSerial Int32) + , mycolumn :: C f (Vector.Vector T.Text) + , mynullablecolumn :: C f (Maybe (Vector.Vector T.Text)) + } + deriving (Generic, Beamable) + +deriving instance Show (Tbl692 Identity) +deriving instance Eq (Tbl692 Identity) + +instance Table Tbl692 where + data PrimaryKey Tbl692 f = Tbl692Key (C f (SqlSerial Int32)) + deriving (Generic, Beamable) + primaryKey = Tbl692Key <$> myid +data MyDB692 entity + = MkMyDB692 + { _myTable :: entity (TableEntity Tbl692) + } deriving (Generic) +instance Database Postgres MyDB692 \ No newline at end of file