diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,30 @@ +# 0.6.0.0 + +## Interface changes + +* Removed `week_` from `Database.Beam.Postgres.PgSpecific`. The same + functionality is now available in `beam-core` as a backend-agnostic + `week_` extract field; import it from `Database.Beam.Query.Extract` (or + re-exported through `Database.Beam`) instead. +* Replaced the single `BeamSqlBackendHasSerial Postgres` instance with three + width-specific instances `BeamSqlBackendHasSerial Int16/Int32/Int64 + Postgres`, mapping respectively to `smallserial`, `serial`, and + `bigserial`. Existing code using `genericSerial` for a `SqlSerial Int32` + column continues to work; other widths are now also supported (#534). + +## Added features + +* Implemented the new `runInsertReturningListWith` / + `runUpdateReturningListWith` / `runDeleteReturningListWith` class methods + on the `Pg` monad. These let callers project a subset of columns from the + affected rows of an `INSERT` / `UPDATE` / `DELETE ... RETURNING` (#801). +* Implemented `weekField` for `PgExtractFieldSyntax`, supporting the new + backend-agnostic `week_` extract field from `beam-core`. + +## Updated dependencies + +* Bumped the lower bound on `beam-core` to `0.11`. + # 0.5.6.1 ## Bug fixes diff --git a/Database/Beam/Postgres/Connection.hs b/Database/Beam/Postgres/Connection.hs --- a/Database/Beam/Postgres/Connection.hs +++ b/Database/Beam/Postgres/Connection.hs @@ -26,13 +26,13 @@ , postgresUriSyntax ) where import Control.Exception (SomeException(..), throwIO) -import Data.IORef (newIORef, readIORef, writeIORef) -import Data.Vector (Vector) -import qualified Data.Vector as V import Control.Monad.Base (MonadBase(..)) import Control.Monad.Free.Church import Control.Monad.IO.Class import Control.Monad.Trans.Control (MonadBaseControl(..)) +import Data.IORef (newIORef, readIORef, writeIORef) +import Data.Vector (Vector) +import qualified Data.Vector as V import Database.Beam hiding (runDelete, runUpdate, runInsert, insert) import Database.Beam.Backend.SQL.BeamExtensions @@ -408,12 +408,11 @@ in collectM id instance MonadBeamInsertReturning Postgres Pg where - runInsertReturningList i = do - let insertReturningCmd' = i `returning` - changeBeamRep (\(Columnar' (QExpr s) :: Columnar' (QExpr Postgres PostgresInaccessible) ty) -> - Columnar' (QExpr s) :: Columnar' (QExpr Postgres ()) ty) - - -- Make savepoint + runInsertReturningListWith i mkProjection = do + let pgProj tbl = mkProjection (changeBeamRep + (\(Columnar' (QExpr s) :: Columnar' (QExpr Postgres PostgresInaccessible) ty) -> + Columnar' (QExpr s) :: Columnar' (QExpr Postgres ()) ty) tbl) + insertReturningCmd' = i `returning` pgProj case insertReturningCmd' of PgInsertReturningEmpty -> pure [] @@ -421,11 +420,11 @@ runReturningList (PgCommandSyntax PgCommandTypeDataUpdateReturning insertReturningCmd) instance MonadBeamUpdateReturning Postgres Pg where - runUpdateReturningList u = do - let updateReturningCmd' = u `returning` - changeBeamRep (\(Columnar' (QExpr s) :: Columnar' (QExpr Postgres PostgresInaccessible) ty) -> - Columnar' (QExpr s) :: Columnar' (QExpr Postgres ()) ty) - + runUpdateReturningListWith u mkProjection = do + let pgProj tbl = mkProjection (changeBeamRep + (\(Columnar' (QExpr s) :: Columnar' (QExpr Postgres PostgresInaccessible) ty) -> + Columnar' (QExpr s) :: Columnar' (QExpr Postgres ()) ty) tbl) + updateReturningCmd' = u `returning` pgProj case updateReturningCmd' of PgUpdateReturningEmpty -> pure [] @@ -433,9 +432,9 @@ runReturningList (PgCommandSyntax PgCommandTypeDataUpdateReturning updateReturningCmd) instance MonadBeamDeleteReturning Postgres Pg where - runDeleteReturningList d = do - let PgDeleteReturning deleteReturningCmd = d `returning` - changeBeamRep (\(Columnar' (QExpr s) :: Columnar' (QExpr Postgres PostgresInaccessible) ty) -> - Columnar' (QExpr s) :: Columnar' (QExpr Postgres ()) ty) - + runDeleteReturningListWith d mkProjection = do + let pgProj tbl = mkProjection (changeBeamRep + (\(Columnar' (QExpr s) :: Columnar' (QExpr Postgres PostgresInaccessible) ty) -> + Columnar' (QExpr s) :: Columnar' (QExpr Postgres ()) ty) tbl) + PgDeleteReturning deleteReturningCmd = d `returning` pgProj runReturningList (PgCommandSyntax PgCommandTypeDataUpdateReturning deleteReturningCmd) diff --git a/Database/Beam/Postgres/Migrate.hs b/Database/Beam/Postgres/Migrate.hs --- a/Database/Beam/Postgres/Migrate.hs +++ b/Database/Beam/Postgres/Migrate.hs @@ -598,5 +598,11 @@ field' _ _ nm ty _ collation constraints PgHasDefault = Db.field' (Proxy @'True) (Proxy @'False) nm ty Nothing collation constraints -instance BeamSqlBackendHasSerial Postgres where +instance BeamSqlBackendHasSerial Int16 Postgres where + genericSerial nm = Db.field nm smallserial PgHasDefault + +instance BeamSqlBackendHasSerial Int32 Postgres where genericSerial nm = Db.field nm serial PgHasDefault + +instance BeamSqlBackendHasSerial Int64 Postgres where + genericSerial nm = Db.field nm bigserial PgHasDefault diff --git a/Database/Beam/Postgres/PgSpecific.hs b/Database/Beam/Postgres/PgSpecific.hs --- a/Database/Beam/Postgres/PgSpecific.hs +++ b/Database/Beam/Postgres/PgSpecific.hs @@ -111,7 +111,7 @@ -- * Postgres @EXTRACT@ fields , century_, decade_, dow_, doy_, epoch_, isodow_, isoyear_ - , microseconds_, milliseconds_, millennium_, quarter_, week_ + , microseconds_, milliseconds_, millennium_, quarter_ -- ** Postgres functions and aggregates , pgBoolOr, pgBoolAnd, pgStringAgg, pgStringAggOver @@ -1674,9 +1674,6 @@ quarter_ :: HasSqlDate tgt => ExtractField Postgres tgt Int32 quarter_ = ExtractField (PgExtractFieldSyntax (emit "QUARTER")) - -week_ :: HasSqlDate tgt => ExtractField Postgres tgt Int32 -week_ = ExtractField (PgExtractFieldSyntax (emit "WEEK")) -- $full-text-search -- diff --git a/Database/Beam/Postgres/Syntax.hs b/Database/Beam/Postgres/Syntax.hs --- a/Database/Beam/Postgres/Syntax.hs +++ b/Database/Beam/Postgres/Syntax.hs @@ -798,6 +798,7 @@ minutesField = PgExtractFieldSyntax (emit "MINUTE") hourField = PgExtractFieldSyntax (emit "HOUR") dayField = PgExtractFieldSyntax (emit "DAY") + weekField = PgExtractFieldSyntax (emit "WEEK") monthField = PgExtractFieldSyntax (emit "MONTH") yearField = PgExtractFieldSyntax (emit "YEAR") diff --git a/beam-postgres.cabal b/beam-postgres.cabal --- a/beam-postgres.cabal +++ b/beam-postgres.cabal @@ -1,5 +1,5 @@ name: beam-postgres -version: 0.5.6.1 +version: 0.6.0.0 synopsis: Connection layer between beam and postgres description: Beam driver for , an advanced open-source RDBMS homepage: https://haskell-beam.github.io/beam/user-guide/backends/beam-postgres @@ -35,8 +35,8 @@ Database.Beam.Postgres.Types build-depends: base >=4.11 && <5.0, - beam-core >=0.10 && <0.11, - beam-migrate >=0.5.4.0 && <0.6, + beam-core >=0.11 && <0.12, + beam-migrate >=0.6 && <0.7, postgresql-libpq >=0.8 && <0.12, postgresql-simple >=0.5 && <0.8, @@ -84,7 +84,8 @@ Database.Beam.Postgres.Test.Select, Database.Beam.Postgres.Test.DataTypes, Database.Beam.Postgres.Test.Migrate, - Database.Beam.Postgres.Test.TempTable + Database.Beam.Postgres.Test.TempTable, + Database.Beam.Postgres.Test.Windowing build-depends: aeson, base, diff --git a/test/Database/Beam/Postgres/Test/DataTypes.hs b/test/Database/Beam/Postgres/Test/DataTypes.hs --- a/test/Database/Beam/Postgres/Test/DataTypes.hs +++ b/test/Database/Beam/Postgres/Test/DataTypes.hs @@ -3,10 +3,10 @@ module Database.Beam.Postgres.Test.DataTypes where import Database.Beam +import Database.Beam.Backend.SQL.BeamExtensions +import Database.Beam.Migrate import Database.Beam.Postgres import Database.Beam.Postgres.Test -import Database.Beam.Migrate -import Database.Beam.Backend.SQL.BeamExtensions import Control.Exception (SomeException(..), handle) @@ -141,15 +141,15 @@ -- | Regression test for errorOnLiteralDoubles :: IO ByteString -> TestTree errorOnLiteralDoubles pgConn = - testCase "Literal `Double`s are correctly specified as SQL `DOUBLE` (#700)" $ + testCase "Literal `Double`s are correctly specified as SQL `DOUBLE` (#700)" $ withTestPostgres "db_failures" pgConn $ \conn -> do - results <- runBeamPostgres conn $ - runSelectReturningList $ - select $ + results <- runBeamPostgres conn $ + runSelectReturningList $ + select $ query - + results @?= [(99 :: Int32, 1.0 :: Double)] - + where -- We need to provide a db for type-checking, but it will not be used query :: Q Postgres RealDb s (QExpr Postgres s Int32, QExpr Postgres s Double) diff --git a/test/Database/Beam/Postgres/Test/Marshal.hs b/test/Database/Beam/Postgres/Test/Marshal.hs --- a/test/Database/Beam/Postgres/Test/Marshal.hs +++ b/test/Database/Beam/Postgres/Test/Marshal.hs @@ -52,7 +52,7 @@ (PgPoint (max x1 x2) (max y1 y2))) arrayGen :: Hedgehog.Gen a -> Hedgehog.Gen (Vector.Vector a) -arrayGen = fmap Vector.fromList +arrayGen = fmap Vector.fromList . Gen.list (Range.linear 0 5) -- small arrays == quick tests boxCmp :: PgBox -> PgBox -> Bool @@ -100,8 +100,8 @@ -- Arrays -- - -- Testing lots of element types for arrays is important, because - -- the mapping between array Oid and element Oid is not type + -- Testing lots of element types for arrays is important, because + -- the mapping between array Oid and element Oid is not type -- safe, and hence error-prone. , marshalTest (arrayGen textGen) postgresConn , marshalTest (arrayGen (Gen.double (Range.exponentialFloat 0 1e40))) postgresConn diff --git a/test/Database/Beam/Postgres/Test/Select.hs b/test/Database/Beam/Postgres/Test/Select.hs --- a/test/Database/Beam/Postgres/Test/Select.hs +++ b/test/Database/Beam/Postgres/Test/Select.hs @@ -5,6 +5,7 @@ import Data.Aeson import Data.ByteString (ByteString) +import Data.List.NonEmpty (NonEmpty(..)) import Data.Int import Data.List (sort) import qualified Data.Text as T @@ -164,7 +165,7 @@ pgCreateExtension @UuidOssp let ext = getPgExtension $ _uuidOssp $ unCheckDatabase db runSelectReturningList $ select $ do - v <- values_ [val_ nil] + v <- values_ (val_ nil :| []) return $ pgUuidGenerateV5 ext v "" assertEqual "result" [V5.generateNamed nil []] result diff --git a/test/Database/Beam/Postgres/Test/Windowing.hs b/test/Database/Beam/Postgres/Test/Windowing.hs new file mode 100644 --- /dev/null +++ b/test/Database/Beam/Postgres/Test/Windowing.hs @@ -0,0 +1,221 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE StandaloneDeriving #-} + +module Database.Beam.Postgres.Test.Windowing (tests) where + +import Database.Beam +import Database.Beam.Backend.SQL.BeamExtensions +import Database.Beam.Migrate +import Database.Beam.Migrate.Simple (autoMigrate) +import Database.Beam.Postgres +import Database.Beam.Postgres.Migrate (migrationBackend) +import Database.Beam.Postgres.Test + +import Control.Exception (SomeException (..), handle) + +import Data.ByteString (ByteString) +import Data.Int +import Data.Text (Text) + +import Control.Monad (void) +import Test.Tasty +import Test.Tasty.HUnit + +tests :: IO ByteString -> TestTree +tests postgresConn = + testGroup + "Windowing unit tests" + [ testLead1 postgresConn + , testLag1 postgresConn + , testLead postgresConn + , testLag postgresConn + , testLeadWithDefault postgresConn + , testLagWithDefault postgresConn + ] + +testLead1 :: IO ByteString -> TestTree +testLead1 = testCase "lead1_" . windowingQueryTest query expectation + where + query = + withWindow_ + ( \Person{name} -> + frame_ + noPartition_ + (orderPartitionBy_ (asc_ name)) + noBounds_ + ) + ( \Person{name} w -> + (name, lead1_ name `over_` w) + ) + (all_ $ persons db) + expectation = [("Alice", Just "Bob"), ("Bob", Just "Claire"), ("Claire", Nothing)] + +testLag1 :: IO ByteString -> TestTree +testLag1 = testCase "lag1_" . windowingQueryTest query expectation + where + query = + withWindow_ + ( \Person{name} -> + frame_ + noPartition_ + (orderPartitionBy_ (asc_ name)) + noBounds_ + ) + ( \Person{name} w -> + (name, lag1_ name `over_` w) + ) + (all_ $ persons db) + expectation = [("Alice", Nothing), ("Bob", Just "Alice"), ("Claire", Just "Bob")] + +testLead :: IO ByteString -> TestTree +testLead getConnStr = + testGroup + "lead_" + [ testCase "n=1" $ windowingQueryTest (query 1) [("Alice", Just "Bob"), ("Bob", Just "Claire"), ("Claire", Nothing)] getConnStr + , testCase "n=2" $ windowingQueryTest (query 2) [("Alice", Just "Claire"), ("Bob", Nothing), ("Claire", Nothing)] getConnStr + ] + where + query n = + withWindow_ + ( \Person{name} -> + frame_ + noPartition_ + (orderPartitionBy_ (asc_ name)) + noBounds_ + ) + ( \Person{name} w -> + (name, lead_ name (val_ (n :: Int32)) `over_` w) + ) + (all_ $ persons db) + expectation1 = [] + +testLag :: IO ByteString -> TestTree +testLag getConnStr = + testGroup + "lag_" + [ testCase "n=1" $ windowingQueryTest (query 1) [("Alice", Nothing), ("Bob", Just "Alice"), ("Claire", Just "Bob")] getConnStr + , testCase "n=2" $ windowingQueryTest (query 2) [("Alice", Nothing), ("Bob", Nothing), ("Claire", Just "Alice")] getConnStr + ] + where + query n = + withWindow_ + ( \Person{name} -> + frame_ + noPartition_ + (orderPartitionBy_ (asc_ name)) + noBounds_ + ) + ( \Person{name} w -> + (name, lag_ name (val_ (n :: Int32)) `over_` w) + ) + (all_ $ persons db) + expectation = [] + + +testLeadWithDefault :: IO ByteString -> TestTree +testLeadWithDefault getConnStr = + testGroup + "leadWithDefault_" + [ testCase "n=1" $ windowingQueryTest (query 1 "default") [("Alice", "Bob"), ("Bob", "Claire"), ("Claire", "default")] getConnStr + , testCase "n=2" $ windowingQueryTest (query 2 "default") [("Alice", "Claire"), ("Bob", "default"), ("Claire", "default")] getConnStr + ] + where + query n def = + withWindow_ + ( \Person{name} -> + frame_ + noPartition_ + (orderPartitionBy_ (asc_ name)) + noBounds_ + ) + ( \Person{name} w -> + (name, leadWithDefault_ name (val_ (n :: Int32)) (val_ def) `over_` w) + ) + (all_ $ persons db) + expectation1 = [] + + +testLagWithDefault :: IO ByteString -> TestTree +testLagWithDefault getConnStr = + testGroup + "lagWithDefault_" + [ testCase "n=1" $ windowingQueryTest (query 1 "default") [("Alice", "default"), ("Bob", "Alice"), ("Claire", "Bob")] getConnStr + , testCase "n=2" $ windowingQueryTest (query 2 "default") [("Alice", "default"), ("Bob", "default"), ("Claire", "Alice")] getConnStr + ] + where + query n def = + withWindow_ + ( \Person{name} -> + frame_ + noPartition_ + (orderPartitionBy_ (asc_ name)) + noBounds_ + ) + ( \Person{name} w -> + (name, lagWithDefault_ name (val_ (n :: Int32)) (val_ def) `over_` w) + ) + (all_ $ persons db) + expectation = [] + + + +data PersonT f = Person + { name :: C f Text + } + deriving (Generic) + +type Person = PersonT Identity + +type PersonExpr s = PersonT (QExpr Postgres s) + +deriving instance Show Person +deriving instance Eq Person + +instance Beamable PersonT + +instance Table PersonT where + data PrimaryKey PersonT f = PersonKey (C f Text) + deriving stock (Generic) + deriving anyclass (Beamable) + + primaryKey Person{name} = PersonKey name + +data Db f = Db + { persons :: f (TableEntity PersonT) + } + deriving (Generic) + +instance Database Postgres Db + +db :: DatabaseSettings Postgres Db +db = defaultDbSettings + +windowingQueryTest :: + (Eq a, Show a, Eq b, Show b, FromBackendRow Postgres a, FromBackendRow Postgres b) => + Q Postgres Db QBaseScope (QExpr Postgres s a, QExpr Postgres s b) -> + [(a, b)] -> + IO ByteString -> + Assertion +windowingQueryTest query expectation getConnStr = + withTestPostgres "db_windowing_psql" getConnStr $ + \conn -> do + prepareTable conn + results <- + runBeamPostgres conn $ + runSelectReturningList $ + select query + + assertEqual "Unexpected" expectation results + +prepareTable :: Connection -> IO () +prepareTable conn = + runBeamPostgres conn $ do + void $ autoMigrate migrationBackend (defaultMigratableDbSettings @Postgres @Db) + runInsert $ + insert (persons db) $ + insertValues + [ Person "Alice" + , Person "Bob" + , Person "Claire" + ] diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -12,19 +12,21 @@ import qualified Database.Beam.Postgres.Test.DataTypes as DataType import qualified Database.Beam.Postgres.Test.Migrate as Migrate import qualified Database.Beam.Postgres.Test.TempTable as TempTable +import qualified Database.Beam.Postgres.Test.Windowing as Windowing import Database.PostgreSQL.Simple ( ConnectInfo(..), defaultConnectInfo ) import qualified Database.PostgreSQL.Simple as Postgres main :: IO () -main = defaultMain - $ TC.withContainers setupTempPostgresDB - $ \getConnStr -> +main = defaultMain + $ TC.withContainers setupTempPostgresDB + $ \getConnStr -> testGroup "beam-postgres tests" [ Marshal.tests getConnStr , Select.tests getConnStr , DataType.tests getConnStr , Migrate.tests getConnStr , TempTable.tests getConnStr + , Windowing.tests getConnStr ] @@ -41,10 +43,10 @@ , ("POSTGRES_DB", db) ] TC.& TC.setWaitingFor (TC.waitForLogLine TC.Stderr ("database system is ready to accept connections" `TL.isInfixOf`)) - - pure $ Postgres.postgreSQLConnectionString + + pure $ Postgres.postgreSQLConnectionString ( defaultConnectInfo { connectHost = "localhost" - , connectUser = unpack user + , connectUser = unpack user , connectPassword = unpack password , connectDatabase = unpack db , connectPort = fromIntegral $ TC.containerPort timescaleContainer 5432