diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,33 @@ +# 0.6.3.0 + +## Added features + +* Added the PostgreSQL-specific, placement-indexed `PgWith` CTE builder. It can + lift helpers built with the portable `With Postgres` API, while the new + data-modifying builders produce blocks which cannot be embedded in a + subquery. +* Added `pgSelectingWith` for PostgreSQL 12+ `MATERIALIZED` and + `NOT MATERIALIZED` SELECT CTEs, with `pgSelecting` retaining PostgreSQL's + default planner policy. +* Added `cteInsertReturning`, `cteUpdateReturning`, and `cteDeleteReturning` + for exposing the `RETURNING` rows of PostgreSQL data-modifying CTEs through + `reuse`. +* Added `cteInsert`, `cteUpdate`, and `cteDelete` for data-modifying CTEs which + execute for their side effects and intentionally produce no reusable rows. +* Added support for reusable zero-column CTE projections. SELECT CTEs omit the + optional output alias list, while data-modifying CTEs use a private + `NULL::boolean` `RETURNING` value to preserve one degree-zero result row per + affected row without exposing a value to Beam's result decoder. +* Added `pgSelectWithNested` and `pgSelectWithTopLevel` for consuming safe + nested and top-level `PgWith` blocks respectively, plus `pgInsertWith`, + `pgUpdateWith`, and `pgDeleteWith` for terminating a top-level `WITH` block + with a data-modifying statement. + +## Bug fixes + +* Fixed an issue where using `pgSelectWith` with no common-table expressions + would lead to an invalid SQL query at runtime. + # 0.6.2.0 ## Added features @@ -7,11 +37,6 @@ over colums of type `citext` (#818) * Exposed the functionality to implement user-defined extensions via `Database.Beam.Postgres.Extensions` (#819) - -## Bug fixes - -* Fixed an issue where using `pgSelectWith` with no common-table expressions - would lead to an invalid SQL query at runtime. # 0.6.1.0 diff --git a/Database/Beam/Postgres/Full.hs b/Database/Beam/Postgres/Full.hs --- a/Database/Beam/Postgres/Full.hs +++ b/Database/Beam/Postgres/Full.hs @@ -1,6 +1,9 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RoleAnnotations #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TypeOperators #-} @@ -9,6 +12,11 @@ -- manipulation statements. These functions shadow the functions in -- "Database.Beam.Query" and provide a strict superset of functionality. They -- map 1-to-1 with the underlying Postgres support. +-- +-- PostgreSQL-specific common table expressions use the placement-indexed +-- 'PgWith' builder. It supports explicit SELECT materialization and both +-- returning and side-effect-only data-modifying CTEs without changing the +-- portable CTE API in beam-core. module Database.Beam.Postgres.Full ( -- * Additional @SELECT@ features @@ -19,14 +27,18 @@ , locked_, lockAll_, withLocks_ - -- ** Inner WITH queries - , pgSelectWith + -- ** Common table expressions + , PgCtePlacement(..), PgWith + , pgLiftWith, pgToTopLevel + , PgCteMaterialization(..), pgSelecting, pgSelectingWith + , pgSelectWith, pgSelectWithNested, pgSelectWithTopLevel + , pgInsertWith, pgUpdateWith, pgDeleteWith -- ** Lateral joins , lateral_ -- * @INSERT@ and @INSERT RETURNING@ - , insert, insertReturning + , insert, insertReturning, cteInsert, cteInsertReturning , insertDefaults , runPgInsertReturningList @@ -45,12 +57,12 @@ -- * @UPDATE RETURNING@ , PgUpdateReturning(..) , runPgUpdateReturningList - , updateReturning + , updateReturning, cteUpdate, cteUpdateReturning -- * @DELETE RETURNING@ , PgDeleteReturning(..) , runPgDeleteReturningList - , deleteReturning + , deleteReturning, cteDelete, cteDeleteReturning -- * Generalized @RETURNING@ , PgReturning(..) @@ -66,18 +78,235 @@ import Database.Beam.Postgres.Types import Database.Beam.Postgres.Syntax +import Control.Monad.Fix (MonadFix(..)) import Control.Monad.Free.Church -import Control.Monad.State.Strict (evalState) -import Control.Monad.Writer (runWriterT) +import Control.Monad.State.Strict (evalState, get, put) +import Control.Monad.Writer (runWriterT, tell) -import Data.List.NonEmpty (nonEmpty) +import Data.List.NonEmpty (NonEmpty(..), nonEmpty) import qualified Data.List.NonEmpty as NonEmpty import Data.Kind (Type) import Data.Proxy (Proxy(..)) +import Data.String (fromString) +import Data.Text (Text) import qualified Data.Text as T -- * @SELECT@ +-- | Whether every CTE in a PostgreSQL @WITH@ block may appear in a nested +-- query, or whether the block must be attached to a top-level statement. +-- +-- PostgreSQL permits SELECT CTEs in nested queries, but permits data-modifying +-- CTEs only in a @WITH@ clause attached to the top-level statement. The index +-- on 'PgWith' records that rule for the builders in this module, so invalid +-- nesting is rejected by Haskell rather than by PostgreSQL. See PostgreSQL's +-- . +-- +-- @since 0.6.3.0 +data PgCtePlacement + = PgCteNestedAllowed + -- ^ The block contains only CTEs which may be nested. + | PgCteTopLevelOnly + -- ^ The block contains a data-modifying CTE and must remain top-level. + +-- | A PostgreSQL-specific CTE builder. +-- +-- This newtype uses beam-core's existing 'With' action and CTE accumulator. It +-- adds a placement index for PostgreSQL data-modifying CTEs without introducing +-- a second name supply or syntax writer. Consequently a lifted portable helper +-- and a native PostgreSQL CTE allocate names from the same sequence. +-- +-- Use 'pgSelecting' for SELECT CTEs, 'cteInsertReturning', +-- 'cteUpdateReturning', or 'cteDeleteReturning' for reusable modifying CTEs, +-- and 'cteInsert', 'cteUpdate', or 'cteDelete' for side-effect-only CTEs. +-- Consume the completed block with 'pgSelectWithTopLevel', 'pgInsertWith', +-- 'pgUpdateWith', or 'pgDeleteWith'. +-- +-- @since 0.6.3.0 +newtype PgWith db (placement :: PgCtePlacement) a = + PgWith { unPgWith :: With Postgres db a } + deriving (Functor, Applicative, Monad) + +-- The placement parameter is phantom at runtime. A nominal role prevents +-- Data.Coerce from relabelling a top-level-only block as nested-safe. +type role PgWith nominal nominal nominal + +-- Recursive knots are deliberately restricted to SELECT-only construction. +-- Complete such a knot first and then use 'pgToTopLevel' before adding a +-- data-modifying CTE which consumes its rows. +instance MonadFix (PgWith db 'PgCteNestedAllowed) where + mfix f = PgWith (mfix (unPgWith . f)) + +-- | Lift an existing portable PostgreSQL 'With' helper into 'PgWith'. +-- +-- Helpers constructed with the portable 'selecting' API contain SELECT +-- statements, so they are valid at either placement. The lifted action uses +-- the surrounding 'PgWith' name supply; lifting a helper which defines several +-- CTEs therefore cannot collide with CTEs defined before or after it. +-- +-- > native <- pgSelecting nativeQuery +-- > rows <- pgLiftWith existingSelectCtes +-- > changed <- cteDeleteReturning table predicate id +-- > pure $ do +-- > nativeRow <- reuse native +-- > row <- reuse rows +-- > changedRow <- reuse changed +-- > pure (nativeRow, row, changedRow) +-- +-- If @existingSelectCtes@ defines two CTEs and one native CTE precedes it, +-- Beam generates one block whose names continue through the lifted helper: +-- +-- @ +-- WITH "cte0"("res0") AS (SELECT ...), +-- "cte1"("res0") AS (SELECT ...), +-- "cte2"("res0") AS (SELECT ... FROM "cte1"), +-- "cte3"("res0", "res1") AS +-- (DELETE FROM "table" ... RETURNING "id", "value") +-- SELECT ... FROM "cte0" CROSS JOIN "cte2" CROSS JOIN "cte3" +-- @ +-- +-- The 'With' constructor is public for low-level extension code. 'pgLiftWith' +-- assumes such code preserves the portable API's SELECT-only invariant. +-- +-- @since 0.6.3.0 +pgLiftWith :: With Postgres db a -> PgWith db placement a +pgLiftWith = PgWith + +-- | Promote a completed nested-safe block for composition with +-- data-modifying CTEs. +-- +-- This operation is one-way. In particular, there is no public operation for +-- converting 'PgCteTopLevelOnly' back to 'PgCteNestedAllowed'. +-- +-- > pgSelectWithTopLevel $ do +-- > recursiveRows <- pgToTopLevel $ mdo +-- > rows <- pgSelecting recursiveQuery +-- > pure rows +-- > cteDelete table $ \row -> exists_ $ do +-- > recursiveRow <- reuse recursiveRows +-- > guard_ (rowId row ==. rowId recursiveRow) +-- > pure finalQuery +-- +-- The promotion changes no SQL. It permits the subsequent modifying CTE, so +-- the complete block has the following form: +-- +-- @ +-- WITH RECURSIVE "cte0"("res0") AS +-- (SELECT ... UNION ALL SELECT ... FROM "cte0"), +-- "cte1" AS +-- (DELETE FROM "table" +-- WHERE EXISTS (SELECT ... FROM "cte0")) +-- SELECT ... +-- @ +-- +-- @since 0.6.3.0 +pgToTopLevel + :: PgWith db 'PgCteNestedAllowed a + -> PgWith db 'PgCteTopLevelOnly a +pgToTopLevel (PgWith with) = PgWith with + +-- | PostgreSQL's materialization policy for a SELECT CTE. +-- +-- Explicit materialization control is available in PostgreSQL 12 and later. +-- 'PgCteDefault' emits no modifier and therefore retains PostgreSQL's normal +-- planner behaviour and compatibility with earlier server versions. +-- See PostgreSQL's +-- . +-- +-- @since 0.6.3.0 +data PgCteMaterialization + = PgCteDefault + -- ^ Let PostgreSQL decide whether to fold or materialize the CTE. + | PgCteMaterialized + -- ^ Emit @MATERIALIZED@, requesting separate calculation of the CTE. This + -- can act as an optimization fence or prevent duplicated computation. + | PgCteNotMaterialized + -- ^ Emit @NOT MATERIALIZED@, allowing the CTE and parent query to be + -- optimized together. PostgreSQL ignores this for recursive or + -- non-side-effect-free queries. + deriving (Eq, Show) + +-- | Introduce a SELECT query as a reusable PostgreSQL CTE using the server's +-- default materialization policy. +-- +-- This is the usual PostgreSQL-specific counterpart of 'selecting'. Use +-- 'pgSelectingWith' when the planner boundary should be controlled explicitly. +-- +-- > rows <- pgSelecting sourceQuery +-- > pure (reuse rows) +-- +-- With a top-level SELECT consumer this produces: +-- +-- @ +-- WITH "cte0"("res0", "res1") AS (SELECT ...) +-- SELECT "t0"."res0", "t0"."res1" FROM "cte0" AS "t0" +-- @ +-- +-- @since 0.6.3.0 +pgSelecting + :: ( Projectible Postgres res + , ThreadRewritable CTE.QAnyScope res ) + => Q Postgres db CTE.QAnyScope res + -> PgWith db placement (ReusableQ Postgres db res) +pgSelecting = pgSelectingWith PgCteDefault + +-- | Introduce a SELECT query as a reusable PostgreSQL CTE with an explicit +-- materialization policy. +-- +-- For example: +-- +-- > expensive <- pgSelectingWith PgCteMaterialized expensiveQuery +-- > pure $ do +-- > left <- reuse expensive +-- > right <- reuse expensive +-- > guard_ (leftId left ==. rightId right) +-- > pure (left, right) +-- +-- With 'pgSelectWithTopLevel', this produces a statement shaped like: +-- +-- @ +-- WITH "cte0"("res0", "res1") AS MATERIALIZED (SELECT ...) +-- SELECT ... +-- FROM "cte0" AS "t0" CROSS JOIN "cte0" AS "t1" +-- WHERE "t0"."res0" = "t1"."res0" +-- @ +-- +-- @NOT MATERIALIZED@ may allow restrictions in the parent query to reach the +-- CTE, but may also duplicate its computation when it is referenced more than +-- once. PostgreSQL ignores @NOT MATERIALIZED@ when folding would not be +-- semantically valid, for example for a recursive query or a query containing +-- volatile functions. +-- +-- A projection with no fields is represented by omitting the CTE column-alias +-- list. PostgreSQL then treats the CTE as a degree-zero relation: it has no +-- columns, but it retains the row cardinality of @query@. For example, a query +-- which produces two empty rows has the following shape: +-- +-- @ +-- WITH "cte0" AS MATERIALIZED (SELECT FROM ...) +-- SELECT FROM "cte0" AS "t0" +-- @ +-- +-- Reusing such a CTE remains meaningful in joins, @EXISTS@, and aggregates +-- even though no value can be projected from an individual row. +-- +-- @since 0.6.3.0 +pgSelectingWith + :: forall res db placement + . ( Projectible Postgres res + , ThreadRewritable CTE.QAnyScope res ) + => PgCteMaterialization + -> Q Postgres db CTE.QAnyScope res + -> PgWith db placement (ReusableQ Postgres db res) +pgSelectingWith materialization q = do + tblNm <- pgRegisterCte $ \name -> + let (_ :: res, fields) = mkFieldNames @Postgres (qualifiedField name) + body = fromPgSelect (buildSqlQuery (name <> "_") q) + in case nonEmpty fields of + Nothing -> pgCteSyntax name Nothing materialization body + Just fields' -> pgOutputCteSyntax name fields' materialization body + pure (CTE.reusableForCTE tblNm) + -- | An explicit lock against some tables. You can create a value of this type using the 'locked_' -- function. You can combine these values monoidally to combine multiple locks for use with the -- 'withLocks_' function. @@ -220,6 +449,101 @@ tblSettings = dbTableSettings tbl +-- | Introduce a PostgreSQL @INSERT@ statement as a side-effect-only CTE. +-- +-- The CTE has no @RETURNING@ clause and therefore produces no reusable +-- relation; PostgreSQL nevertheless executes it exactly once and to +-- completion when the surrounding top-level statement executes. +-- +-- > pgSelectWithTopLevel $ do +-- > cteInsert users (insertValues [newUser]) onConflictDefault +-- > pure finalQuery +-- +-- This produces SQL shaped like: +-- +-- @ +-- WITH cte0 AS (INSERT INTO users ...) +-- SELECT ... +-- @ +-- +-- Empty insert values register no CTE. The result is still conservatively +-- 'PgCteTopLevelOnly', because the placement index cannot vary with the +-- supplied values. +-- +-- @since 0.6.3.0 +cteInsert + :: DatabaseEntity Postgres db (TableEntity table) + -> SqlInsertValues Postgres (table (QExpr Postgres s)) + -> PgInsertOnConflict table + -> PgWith db 'PgCteTopLevelOnly () +cteInsert table values onConflict_ = + case insert table values onConflict_ of + SqlInsertNoRows -> pure () + SqlInsert _ (PgInsertSyntax syntax) -> pgDataModifyingCte_ syntax + +-- | Introduce a PostgreSQL @INSERT ... RETURNING@ statement as a +-- data-modifying common table expression. The returned value can be used in a +-- subsequent query with 'reuse'. +-- +-- Returns 'Nothing' when the supplied insert values are empty, because in that +-- case there is no statement or common table expression to reuse. +-- Data-modifying CTEs are restricted to top-level 'PgWith' blocks and cannot +-- be passed to 'pgSelectWithNested'. +-- +-- For example, this inserts a row once and makes the rows produced by +-- @RETURNING@ available to the final query: +-- +-- > pgSelectWithTopLevel $ do +-- > inserted <- cteInsertReturning +-- > users +-- > (insertValues [newUser]) +-- > onConflictDefault +-- > id +-- > case inserted of +-- > Nothing -> pure noRowsQuery +-- > Just rows -> pure (reuse rows) +-- +-- The generated statement has the shape: +-- +-- @ +-- WITH "cte0"("res0", ...) AS +-- (INSERT INTO "users" ... RETURNING ...) +-- SELECT ... FROM "cte0" AS "t0" +-- @ +-- +-- The projection may contain no fields. In that case Beam preserves one +-- degree-zero result row per inserted row. PostgreSQL requires at least one +-- @RETURNING@ expression, so the CTE contains a private boolean sentinel while +-- the final SELECT exposes no columns: +-- +-- @ +-- WITH "cte0"("res0") AS +-- (INSERT INTO "users" ... RETURNING NULL::boolean) +-- SELECT FROM "cte0" AS "t0" +-- @ +-- +-- The sentinel is not part of the returned Haskell value. If neither the final +-- statement nor another CTE needs the inserted-row output, prefer 'cteInsert'. +-- It omits @RETURNING@ and produces no reusable result. +-- +-- @since 0.6.3.0 +cteInsertReturning + :: ( Projectible Postgres a + , ThreadRewritable PostgresInaccessible a + , Projectible Postgres (WithRewrittenThread PostgresInaccessible CTE.QAnyScope a) + , ThreadRewritable CTE.QAnyScope (WithRewrittenThread PostgresInaccessible CTE.QAnyScope a) + ) + => DatabaseEntity Postgres db (TableEntity table) + -> SqlInsertValues Postgres (table (QExpr Postgres s)) + -> PgInsertOnConflict table + -> (table (QExpr Postgres PostgresInaccessible) -> a) + -> PgWith db 'PgCteTopLevelOnly (Maybe (ReusableQ Postgres db (WithRewrittenThread PostgresInaccessible CTE.QAnyScope a))) +cteInsertReturning table values onConflict_ mkProjection = + case insertReturning table values onConflict_ (Just mkProjection) of + PgInsertReturningEmpty -> pure Nothing + PgInsertReturning syntax -> + Just <$> pgDataModifyingCte syntax + runPgInsertReturningList :: ( MonadBeam be m , BeamSqlBackendSyntax be ~ PgCommandSyntax @@ -278,9 +602,7 @@ (\_ -> Nothing) (rewriteThread (Proxy @s)))) --- | The SQL standard only allows CTE expressions (WITH expressions) --- at the top-level. Postgres allows you to embed these within a --- subquery. +-- | Embed a portable SELECT CTE block within a PostgreSQL subquery. -- -- For example, -- @@ -288,13 +610,62 @@ -- SELECT a.column1, b.column2 FROM (WITH RECURSIVE ... ) a JOIN b -- @ -- --- @beam-core@ offers 'selectWith' to produce a top-level 'SqlSelect' --- but these cannot be turned into 'Q' objects for use within joins. --- The 'pgSelectWith' function is more flexible. +-- @beam-core@'s 'selectWith' produces a top-level 'SqlSelect', which cannot be +-- used as a 'Q' value within a join. PostgreSQL accepts a SELECT-only @WITH@ +-- query in that subquery position, and 'pgSelectWith' exposes that placement. +-- +-- > select $ pgSelectWith $ do +-- > reusableRows <- selecting someQuery +-- > pure (reuse reusableRows) +-- +-- This can produce a subquery such as: +-- +-- @ +-- SELECT ... FROM (WITH cte0 AS (SELECT ...) SELECT ... FROM cte0) AS nested +-- @ +-- pgSelectWith :: forall db s res . Projectible Postgres res => With Postgres db (Q Postgres db s res) -> Q Postgres db s res -pgSelectWith (CTE.With mkQ) = +pgSelectWith = pgSelectWith_ + +-- | Embed a nested-safe PostgreSQL-specific CTE block in a query. +-- +-- This is the 'PgWith' counterpart of 'pgSelectWith'. It supports +-- 'pgSelectingWith', including explicit materialization, while its placement +-- index rejects data-modifying CTEs because PostgreSQL accepts those only in a +-- @WITH@ clause attached to the top-level statement. +-- +-- > select $ pgSelectWithNested $ do +-- > rows <- pgSelectingWith PgCteMaterialized sourceQuery +-- > pure (reuse rows) +-- +-- This produces a derived table containing the complete nested @WITH@ query: +-- +-- @ +-- SELECT "t0"."res0", "t0"."res1" +-- FROM (WITH "cte0"("res0", "res1") AS MATERIALIZED (SELECT ...) +-- SELECT "sub_t0"."res0", "sub_t0"."res1" +-- FROM "cte0" AS "sub_t0") AS "t0"("res0", "res1") +-- @ +-- +-- @since 0.6.3.0 +pgSelectWithNested + :: forall db s res + . Projectible Postgres res + => PgWith db 'PgCteNestedAllowed (Q Postgres db s res) + -> Q Postgres db s res +pgSelectWithNested = pgSelectWith_ . unPgWith + +-- Shared implementation for the compatible portable and PostgreSQL-specific +-- nested APIs. Keeping the syntax conversion here avoids evaluating or +-- traversing a PgWith block a second time. +pgSelectWith_ + :: forall db s res + . Projectible Postgres res + => With Postgres db (Q Postgres db s res) + -> Q Postgres db s res +pgSelectWith_ (CTE.With mkQ) = let (q, (recursiveness, mctes)) = evalState (runWriterT mkQ) 0 fromSyntax tblPfx = case (recursiveness, nonEmpty mctes) of @@ -316,6 +687,263 @@ (const Nothing) snd)) +-- | Attach a PostgreSQL-specific CTE block to a top-level @SELECT@ statement. +-- +-- Unlike 'pgSelectWith', this consumes 'PgWith' and can therefore safely +-- accept data-modifying CTEs. SELECT-only blocks work as well, so callers can +-- use one terminal function while a workflow grows from portable SELECT CTEs +-- to PostgreSQL-specific operations. +-- +-- > pgSelectWithTopLevel $ do +-- > selected <- pgSelecting sourceQuery +-- > deleted <- cteDeleteReturning target predicate id +-- > pure $ do +-- > source <- reuse selected +-- > removed <- reuse deleted +-- > pure (source, removed) +-- +-- This produces one statement of the following form: +-- +-- @ +-- WITH "cte0"("res0", "res1") AS (SELECT ...), +-- "cte1"("res0", "res1") AS +-- (DELETE FROM "target" ... RETURNING "id", "value") +-- SELECT ... FROM "cte0" CROSS JOIN "cte1" +-- @ +-- +-- The complete @WITH ... SELECT ...@ is one 'SqlSelect' and is sent to +-- PostgreSQL in a single round trip. +-- +-- @since 0.6.3.0 +pgSelectWithTopLevel + :: Projectible Postgres res + => PgWith db placement (Q Postgres db QBaseScope res) + -> SqlSelect Postgres (QExprToIdentity res) +pgSelectWithTopLevel = selectWith . unPgWith + +-- | Attach a common-table-expression block to a top-level PostgreSQL +-- @INSERT@ statement. +-- +-- Unlike 'pgSelectWithNested', this is a top-level statement consumer and +-- therefore accepts both 'PgCteNestedAllowed' and 'PgCteTopLevelOnly' blocks. +-- The final insert can read reusable rows produced by either SELECT CTEs or +-- data-modifying CTEs: +-- +-- > pgInsertWith $ do +-- > rows <- pgSelecting sourceQuery +-- > pure $ insert destination (insertFrom (reuse rows)) onConflictDefault +-- +-- This produces a statement with the following shape: +-- +-- @ +-- WITH "cte0"("res0", "res1") AS (SELECT ...) +-- INSERT INTO "destination"("id", "value") +-- SELECT "t0"."res0", "t0"."res1" FROM "cte0" AS "t0" +-- @ +-- +-- If the final insert has no rows, the result remains 'SqlInsertNoRows'. There +-- is then no terminal statement to which PostgreSQL could attach the @WITH@ +-- block, so none of its CTE bodies are executed. +-- +-- Apply 'returning' to the resulting 'SqlInsert' when the terminal statement +-- should return rows. +-- +-- @since 0.6.3.0 +pgInsertWith + :: PgWith db placement (SqlInsert Postgres table) + -> SqlInsert Postgres table +pgInsertWith with = + case runPgWith with of + (SqlInsertNoRows, _, _) -> SqlInsertNoRows + (SqlInsert settings (PgInsertSyntax statement), recursiveness, ctes) -> + SqlInsert settings (PgInsertSyntax (pgWithSyntax recursiveness ctes statement)) + +-- | Attach a common-table-expression block to a top-level PostgreSQL +-- @UPDATE@ statement. +-- +-- Reusable CTE rows can be referenced from the final update predicate, for +-- example through 'exists_': +-- +-- > pgUpdateWith $ do +-- > wanted <- pgSelecting wantedUsers +-- > pure $ update users +-- > (\user -> userEnabled user <-. val_ False) +-- > (\user -> exists_ $ do +-- > candidate <- reuse wanted +-- > guard_ (userId user ==. userId candidate)) +-- +-- This produces SQL of the following form: +-- +-- @ +-- WITH "cte0"("res0") AS (SELECT ... AS "res0") +-- UPDATE "users" SET "enabled"=FALSE +-- WHERE EXISTS +-- (SELECT "t0"."res0" FROM "cte0" AS "t0" +-- WHERE "id" = "t0"."res0") +-- @ +-- +-- An identity update remains 'SqlIdentityUpdate'; as with an empty insert, +-- there is no terminal PostgreSQL statement and the accumulated CTEs are not +-- executed. +-- +-- Apply 'returning' to the resulting 'SqlUpdate' when the terminal statement +-- should return rows. +-- +-- @since 0.6.3.0 +pgUpdateWith + :: PgWith db placement (SqlUpdate Postgres table) + -> SqlUpdate Postgres table +pgUpdateWith with = + case runPgWith with of + (SqlIdentityUpdate, _, _) -> SqlIdentityUpdate + (SqlUpdate settings (PgUpdateSyntax statement), recursiveness, ctes) -> + SqlUpdate settings (PgUpdateSyntax (pgWithSyntax recursiveness ctes statement)) + +-- | Attach a common-table-expression block to a top-level PostgreSQL +-- @DELETE@ statement. +-- +-- > pgDeleteWith $ do +-- > expired <- pgSelecting expiredUsers +-- > pure $ delete users $ \user -> exists_ $ do +-- > candidate <- reuse expired +-- > guard_ (userId user ==. userId candidate) +-- +-- This produces SQL of the following form: +-- +-- @ +-- WITH "cte0"("res0") AS (SELECT ... AS "res0") +-- DELETE FROM "users" AS "delete_target" +-- WHERE EXISTS +-- (SELECT "t0"."res0" FROM "cte0" AS "t0" +-- WHERE "delete_target"."id" = "t0"."res0") +-- @ +-- +-- Since 'SqlDelete' always contains a statement, the accumulated CTE block is +-- always preserved. +-- Apply 'returning' to the result when the terminal statement should return +-- deleted rows. +-- +-- @since 0.6.3.0 +pgDeleteWith + :: PgWith db placement (SqlDelete Postgres table) + -> SqlDelete Postgres table +pgDeleteWith with = + case runPgWith with of + (SqlDelete settings (PgDeleteSyntax statement), recursiveness, ctes) -> + SqlDelete settings (PgDeleteSyntax (pgWithSyntax recursiveness ctes statement)) + +-- Allocate a name and append one PostgreSQL CTE definition to beam-core's +-- existing writer. All PgWith constructors use this path so lifted and native +-- actions share one monotonically increasing name supply. +pgRegisterCte + :: (Text -> PgCommonTableExpressionSyntax) + -> PgWith db placement Text +pgRegisterCte mkCte = PgWith . CTE.With $ do + cteId <- get + put (cteId + 1) + + let tblNm = fromString ("cte" ++ show cteId) + tell (CTE.Nonrecursive, [mkCte tblNm]) + pure tblNm + +-- Construct a reusable CTE with a statically non-empty physical output. Keeping +-- the invariant in the type prevents callers from accidentally rendering the +-- invalid PostgreSQL spelling @name() AS (...)@. +pgOutputCteSyntax + :: Text + -> NonEmpty Text + -> PgCteMaterialization + -> PgSyntax + -> PgCommonTableExpressionSyntax +pgOutputCteSyntax name fields materialization body = + pgCteSyntax name (Just fields) materialization body + +-- Render the common outer shape for SELECT, returning DML, and +-- side-effect-only DML CTEs. A missing column list is used for degree-zero +-- SELECT CTEs and for modifying statements without @RETURNING@. Materialization +-- is deliberately passed as PgCteDefault for every DML caller: PostgreSQL's +-- materialization controls apply to SELECT CTE folding, while modifying CTEs +-- always execute exactly once and to completion. +pgCteSyntax + :: Text + -> Maybe (NonEmpty Text) + -> PgCteMaterialization + -> PgSyntax + -> PgCommonTableExpressionSyntax +pgCteSyntax name fields materialization body = + PgCommonTableExpressionSyntax $ + pgQuotedIdentifier name <> + maybe mempty + (pgParens . pgSepBy (emit ",") . map pgQuotedIdentifier . NonEmpty.toList) + fields <> + emit " AS" <> + materializationSyntax materialization <> + emit " " <> + pgParens body + where + materializationSyntax PgCteDefault = mempty + materializationSyntax PgCteMaterialized = emit " MATERIALIZED" + materializationSyntax PgCteNotMaterialized = emit " NOT MATERIALIZED" + +-- Register a modifying CTE with @RETURNING@ output and construct the reusable +-- relation which refers to its generated name. +-- +-- PostgreSQL requires @RETURNING@ to contain at least one expression. The +-- existing INSERT, UPDATE, and DELETE returning renderers end in the keyword +-- and a space when Beam's logical projection has no fields. In that case this +-- CTE-specific path appends one private, constant boolean expression and gives +-- it the physical name @res0@. 'CTE.reusableForCTE' is still instantiated at +-- the original zero-field result type, so final Beam SELECTs project no +-- physical columns and the sentinel is never exposed to result decoding. +-- +-- One sentinel row is produced for every affected row. Consequently the +-- degree-zero relation preserves the modifying statement's cardinality when it +-- is reused by joins, @EXISTS@, or aggregates. +pgDataModifyingCte + :: forall res db + . ( Projectible Postgres res + , ThreadRewritable CTE.QAnyScope res ) + => PgSyntax + -> PgWith db 'PgCteTopLevelOnly (ReusableQ Postgres db res) +pgDataModifyingCte body = do + tblNm <- pgRegisterCte $ \name -> + let (_ :: res, fields) = mkFieldNames @Postgres (qualifiedField name) + in case nonEmpty fields of + Nothing -> + pgOutputCteSyntax + name + ("res0" :| []) + PgCteDefault + (body <> emit "NULL::boolean") + Just fields' -> pgOutputCteSyntax name fields' PgCteDefault body + pure (CTE.reusableForCTE tblNm) + +-- Register a modifying CTE without @RETURNING@. PostgreSQL executes the body, +-- but the CTE forms no temporary table and therefore has no result which can be +-- passed to 'reuse'. This accounts for both the unit result and the absence of +-- a column-alias list. +pgDataModifyingCte_ + :: PgSyntax + -> PgWith db 'PgCteTopLevelOnly () +pgDataModifyingCte_ body = do + _ <- pgRegisterCte $ \name -> + pgCteSyntax name Nothing PgCteDefault body + pure () + +-- Evaluate a PostgreSQL CTE builder once and retain the information required +-- by each top-level statement consumer. Keeping this helper local ensures that +-- the backend-independent CTE API does not acquire PostgreSQL command types. +runPgWith + :: PgWith db placement a + -> (a, PgCteRecursiveness, [BeamSql99BackendCTESyntax Postgres]) +runPgWith (PgWith with) = + let (result, (recursiveness, ctes)) = + evalState (runWriterT (CTE.runWith with)) 0 + pgRecursiveness = case recursiveness of + CTE.Nonrecursive -> PgCteNonrecursive + CTE.Recursive -> PgCteRecursive + in (result, pgRecursiveness, ctes) + -- | By default, Postgres will throw an error when a conflict is detected. This -- preserves that functionality. onConflictDefault :: PgInsertOnConflict tbl @@ -388,6 +1016,93 @@ where tblQ = changeBeamRep (\(Columnar' f) -> Columnar' (QExpr (pure (fieldE (unqualifiedField (_fieldName f)))))) tblSettings +-- | Introduce a PostgreSQL @UPDATE@ statement as a side-effect-only CTE. +-- +-- Since no @RETURNING@ clause is emitted, the result is @()@ and cannot be +-- passed to 'reuse'. PostgreSQL still executes the update exactly once when +-- the surrounding top-level statement executes: +-- +-- > pgDeleteWith $ do +-- > cteUpdate users +-- > (\user -> userActive user <-. val_ False) +-- > (\user -> userLastSeen user <. val_ cutoff) +-- > pure (delete sessions expiredSession) +-- +-- This produces one side-effect-only definition before the terminal delete: +-- +-- @ +-- WITH "cte0" AS +-- (UPDATE "users" SET "active"=FALSE WHERE "last_seen" < ...) +-- DELETE FROM "sessions" AS "delete_target" WHERE ... +-- @ +-- +-- An identity assignment registers no CTE. As with 'cteInsert', its type +-- remains 'PgCteTopLevelOnly' independently of that value-level result. +-- +-- @since 0.6.3.0 +cteUpdate + :: DatabaseEntity Postgres db (TableEntity table) + -> (forall s. table (QField s) -> QAssignment Postgres s) + -> (forall s. table (QExpr Postgres s) -> QExpr Postgres s Bool) + -> PgWith db 'PgCteTopLevelOnly () +cteUpdate table@(DatabaseEntity (DatabaseTable {})) mkAssignments mkWhere = + case update table mkAssignments mkWhere of + SqlIdentityUpdate -> pure () + SqlUpdate _ (PgUpdateSyntax syntax) -> pgDataModifyingCte_ syntax + +-- | Introduce a PostgreSQL @UPDATE ... RETURNING@ statement as a +-- data-modifying common table expression. The returned value can be used in a +-- subsequent query with 'reuse'. +-- +-- Returns 'Nothing' when the assignments form an identity update, because in +-- that case there is no statement or common table expression to reuse. +-- Data-modifying CTEs are restricted to top-level 'PgWith' blocks and cannot +-- be used with 'pgSelectWithNested'. +-- +-- > pgSelectWithTopLevel $ do +-- > updated <- cteUpdateReturning +-- > users +-- > (\user -> userEnabled user <-. val_ False) +-- > (\user -> userId user ==. val_ wantedUserId) +-- > id +-- > case updated of +-- > Nothing -> pure noRowsQuery +-- > Just rows -> pure (reuse rows) +-- +-- This renders the update once inside @WITH@ and reads its @RETURNING@ rows +-- through the reusable CTE name: +-- +-- @ +-- WITH "cte0"("res0", "res1") AS +-- (UPDATE "users" SET "enabled"=FALSE +-- WHERE "id" = ... RETURNING "id", "enabled") +-- SELECT "t0"."res0", "t0"."res1" FROM "cte0" AS "t0" +-- @ +-- +-- As with 'cteInsertReturning', a projection containing no fields is supported. +-- Beam emits @RETURNING NULL::boolean@ inside the CTE and @SELECT FROM "cte0"@ +-- outside it, retaining one zero-field row per updated row without exposing the +-- private sentinel. If neither the final statement nor another CTE needs the +-- updated-row output, use 'cteUpdate' instead. +-- +-- @since 0.6.3.0 +cteUpdateReturning + :: ( Projectible Postgres a + , ThreadRewritable PostgresInaccessible a + , Projectible Postgres (WithRewrittenThread PostgresInaccessible CTE.QAnyScope a) + , ThreadRewritable CTE.QAnyScope (WithRewrittenThread PostgresInaccessible CTE.QAnyScope a) + ) + => DatabaseEntity Postgres db (TableEntity table) + -> (forall s. table (QField s) -> QAssignment Postgres s) + -> (forall s. table (QExpr Postgres s) -> QExpr Postgres s Bool) + -> (table (QExpr Postgres PostgresInaccessible) -> a) + -> PgWith db 'PgCteTopLevelOnly (Maybe (ReusableQ Postgres db (WithRewrittenThread PostgresInaccessible CTE.QAnyScope a))) +cteUpdateReturning table mkAssignments mkWhere mkProjection = + case updateReturning table mkAssignments mkWhere mkProjection of + PgUpdateReturningEmpty -> pure Nothing + PgUpdateReturning syntax -> + Just <$> pgDataModifyingCte syntax + runPgUpdateReturningList :: ( MonadBeam be m , BeamSqlBackendSyntax be ~ PgCommandSyntax @@ -428,6 +1143,88 @@ where SqlDelete _ pgDelete = delete table $ \t -> mkWhere t tblQ = changeBeamRep (\(Columnar' f) -> Columnar' (QExpr (pure (fieldE (unqualifiedField (_fieldName f)))))) tblSettings + +-- | Introduce a PostgreSQL @DELETE@ statement as a side-effect-only CTE. +-- +-- The deletion executes exactly once even when the terminal statement does not +-- refer to it. Without @RETURNING@ it produces no reusable relation: +-- +-- > pgInsertWith $ do +-- > cteDelete stagingRows isExpired +-- > pure (insert archive newRows onConflictDefault) +-- +-- This renders a definition without an empty column list, followed by the +-- terminal insert: +-- +-- @ +-- WITH "cte0" AS +-- (DELETE FROM "staging_rows" AS "delete_target" WHERE ...) +-- INSERT INTO "archive" ... +-- @ +-- +-- Sibling modifying CTEs use the same PostgreSQL snapshot and cannot observe +-- one another's table changes. Use their @RETURNING@ output when one operation +-- needs to communicate rows to another. +-- +-- @since 0.6.3.0 +cteDelete + :: DatabaseEntity Postgres db (TableEntity table) + -> (forall s. table (QExpr Postgres s) -> QExpr Postgres s Bool) + -> PgWith db 'PgCteTopLevelOnly () +cteDelete table mkWhere = + case delete table (\row -> mkWhere row) of + SqlDelete _ (PgDeleteSyntax syntax) -> pgDataModifyingCte_ syntax + +-- | Introduce a PostgreSQL @DELETE ... RETURNING@ statement as a +-- data-modifying common table expression. The returned value can be used in a +-- subsequent query with 'reuse'. +-- +-- Data-modifying CTEs are restricted to top-level 'PgWith' blocks and cannot +-- be used with 'pgSelectWithNested'. +-- +-- Unlike insert and update, delete always has a statement to introduce, so no +-- 'Maybe' is required: +-- +-- > pgSelectWithTopLevel $ do +-- > deleted <- cteDeleteReturning +-- > users +-- > (\user -> userExpired user ==. val_ True) +-- > id +-- > pure (reuse deleted) +-- +-- The corresponding SQL has the following form: +-- +-- @ +-- WITH "cte0"("res0", "res1") AS +-- (DELETE FROM "users" AS "delete_target" +-- WHERE "delete_target"."expired" = TRUE +-- RETURNING "id", "expired") +-- SELECT "t0"."res0", "t0"."res1" FROM "cte0" AS "t0" +-- @ +-- +-- The final query observes the deleted rows through @DELETE ... RETURNING@. +-- This is also the supported way to communicate between data-modifying CTEs, +-- since PostgreSQL executes sibling statements against the same snapshot. +-- A projection containing no fields is also reusable: Beam emits a private +-- @NULL::boolean@ returning expression and an outer zero-column SELECT, so its +-- row count still equals the number of deleted rows. If neither the final +-- statement nor another CTE needs the deleted-row output, use 'cteDelete' +-- instead. +-- +-- @since 0.6.3.0 +cteDeleteReturning + :: ( Projectible Postgres a + , ThreadRewritable PostgresInaccessible a + , Projectible Postgres (WithRewrittenThread PostgresInaccessible CTE.QAnyScope a) + , ThreadRewritable CTE.QAnyScope (WithRewrittenThread PostgresInaccessible CTE.QAnyScope a) + ) + => DatabaseEntity Postgres db (TableEntity table) + -> (forall s. table (QExpr Postgres s) -> QExpr Postgres s Bool) + -> (table (QExpr Postgres PostgresInaccessible) -> a) + -> PgWith db 'PgCteTopLevelOnly (ReusableQ Postgres db (WithRewrittenThread PostgresInaccessible CTE.QAnyScope a)) +cteDeleteReturning table mkWhere mkProjection = + let PgDeleteReturning syntax = deleteReturning table mkWhere mkProjection + in pgDataModifyingCte syntax runPgDeleteReturningList :: ( MonadBeam be m 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 @@ -21,7 +21,7 @@ , emit, emitBuilder, escapeString , escapeBytea, escapeIdentifier - , pgParens + , pgParens, PgCteRecursiveness(..), pgWithSyntax , pgStringLit, pgCharLit, pgBoolLit , nextSyntaxStep @@ -30,6 +30,7 @@ , PgInsertSyntax(..) , PgDeleteSyntax(..) , PgUpdateSyntax(..) + , PgCommonTableExpressionSyntax(..) , PgExpressionSyntax(..), PgFromSyntax(..), PgTableNameSyntax(..) , PgComparisonQuantifierSyntax(..) @@ -272,9 +273,54 @@ data PgSelectLockingClauseSyntax = PgSelectLockingClauseSyntax { pgSelectLockingClauseStrength :: PgSelectLockingStrength , pgSelectLockingTables :: [T.Text] , pgSelectLockingClauseOptions :: Maybe PgSelectLockingOptions } +-- | One named definition in a PostgreSQL @WITH@ clause. +-- +-- This is exported for PostgreSQL extension modules. Application code should +-- normally construct CTEs through "Database.Beam.Postgres.Full". +-- +-- @since 0.6.3.0 newtype PgCommonTableExpressionSyntax = PgCommonTableExpressionSyntax { fromPgCommonTableExpression :: PgSyntax } +-- | Whether a PostgreSQL @WITH@ clause is recursive. +-- +-- Keeping this distinction explicit avoids assigning a context-dependent +-- meaning to a 'Bool' at the low-level syntax boundary. +-- +-- @since 0.6.3.0 +data PgCteRecursiveness + = PgCteNonrecursive + -- ^ Emit @WITH@. + | PgCteRecursive + -- ^ Emit @WITH RECURSIVE@. + deriving (Eq, Show) + +-- | Prefix a PostgreSQL statement with a common-table-expression list. +-- The public CTE consumers use this prefix before their @SELECT@, @INSERT@, +-- @UPDATE@, and @DELETE@ terminal statements, so this operation works on the +-- shared raw syntax instead of giving the terminal statement a misleading +-- type. +-- +-- An empty list leaves the statement unchanged. 'PgCteRecursive' selects +-- @WITH RECURSIVE@ when the CTE builder used recursive bindings. +-- +-- @since 0.6.3.0 +pgWithSyntax + :: PgCteRecursiveness + -> [PgCommonTableExpressionSyntax] + -> PgSyntax + -> PgSyntax +pgWithSyntax _ [] statement = statement +pgWithSyntax recursiveness ctes statement = + emit withKeyword <> + pgSepBy (emit ", ") (map fromPgCommonTableExpression ctes) <> + emit " " <> + statement + where + withKeyword = case recursiveness of + PgCteNonrecursive -> "WITH " + PgCteRecursive -> "WITH RECURSIVE " + fromPgOrdering :: PgOrderingSyntax -> PgSyntax fromPgOrdering (PgOrderingSyntax s Nothing) = s fromPgOrdering (PgOrderingSyntax s (Just PgNullOrderingNullsFirst)) = s <> emit " NULLS FIRST" @@ -622,25 +668,27 @@ type Sql99SelectCTESyntax PgSelectSyntax = PgCommonTableExpressionSyntax withSyntax ctes (PgSelectSyntax select) = - PgSelectSyntax $ - emit "WITH " <> - pgSepBy (emit ", ") (map fromPgCommonTableExpression ctes) <> - select + PgSelectSyntax (pgWithSyntax PgCteNonrecursive ctes select) instance IsSql99RecursiveCommonTableExpressionSelectSyntax PgSelectSyntax where withRecursiveSyntax ctes (PgSelectSyntax select) = - PgSelectSyntax $ - emit "WITH RECURSIVE " <> - pgSepBy (emit ", ") (map fromPgCommonTableExpression ctes) <> - select + PgSelectSyntax (pgWithSyntax PgCteRecursive ctes select) instance IsSql99CommonTableExpressionSyntax PgCommonTableExpressionSyntax where type Sql99CTESelectSyntax PgCommonTableExpressionSyntax = PgSelectSyntax cteSubquerySyntax tbl fields (PgSelectSyntax select) = PgCommonTableExpressionSyntax $ - pgQuotedIdentifier tbl <> pgParens (pgSepBy (emit ",") (map pgQuotedIdentifier fields)) <> + pgQuotedIdentifier tbl <> columnAliases <> emit " AS " <> pgParens select + where + -- PostgreSQL represents a degree-zero CTE by omitting its optional + -- column-alias list. Rendering an empty pair of parentheses instead + -- would be a syntax error. + columnAliases = + case fields of + [] -> mempty + _ -> pgParens (pgSepBy (emit ",") (map pgQuotedIdentifier fields)) instance IsSql2008BigIntDataTypeSyntax PgDataTypeSyntax where bigIntType = PgDataTypeSyntax (PgDataTypeDescrOid (Pg.typoid Pg.int8) Nothing) (emit "BIGINT") bigIntType @@ -1587,4 +1635,3 @@ where quoteIdentifierChar '"' = char8 '"' <> char8 '"' quoteIdentifierChar c = char8 c - 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.6.2.0 +version: 0.6.3.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 @@ -81,6 +81,8 @@ hs-source-dirs: test main-is: Main.hs other-modules: Database.Beam.Postgres.Test, + Database.Beam.Postgres.Test.CTE, + Database.Beam.Postgres.Test.CTENegative, Database.Beam.Postgres.Test.Copy, Database.Beam.Postgres.Test.Marshal, Database.Beam.Postgres.Test.Select, diff --git a/test/Database/Beam/Postgres/Test.hs b/test/Database/Beam/Postgres/Test.hs --- a/test/Database/Beam/Postgres/Test.hs +++ b/test/Database/Beam/Postgres/Test.hs @@ -13,19 +13,22 @@ withTestPostgres dbName getConnStr action = do connStr <- getConnStr - let connStrTemplate1 = connStr <> " dbname=template1" + -- Create and drop isolated test databases from the administrative postgres + -- database, leaving template1 free to serve as CREATE DATABASE's default + -- template. + let connStrAdmin = connStr <> " dbname=postgres" connStrDb = connStr <> " dbname=" <> fromString dbName - withTemplate1 :: (Pg.Connection -> IO b) -> IO b - withTemplate1 = bracket (Pg.connectPostgreSQL connStrTemplate1) Pg.close + withAdmin :: (Pg.Connection -> IO b) -> IO b + withAdmin = bracket (Pg.connectPostgreSQL connStrAdmin) Pg.close - createDatabase = withTemplate1 $ \c -> do + createDatabase = withAdmin $ \c -> do void $ Pg.execute_ c (fromString ("CREATE DATABASE " <> dbName)) Pg.connectPostgreSQL connStrDb dropDatabase c = do Pg.close c - withTemplate1 $ \c' -> void $ + withAdmin $ \c' -> void $ Pg.execute_ c' (fromString ("DROP DATABASE " <> dbName)) bracket createDatabase dropDatabase action diff --git a/test/Database/Beam/Postgres/Test/CTE.hs b/test/Database/Beam/Postgres/Test/CTE.hs new file mode 100644 --- /dev/null +++ b/test/Database/Beam/Postgres/Test/CTE.hs @@ -0,0 +1,1334 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE StandaloneDeriving #-} + +-- | Rendering, type-safety, and PostgreSQL integration tests for common table +-- expressions. Deliberately ill-typed expressions live in +-- "Database.Beam.Postgres.Test.CTENegative" so this module retains normal type +-- checking. +module Database.Beam.Postgres.Test.CTE (unitTests, integrationTests) where + +import Control.Exception (TypeError, evaluate, try) +import qualified Data.ByteString.Lazy.Char8 as BL +import Data.ByteString (ByteString) +import Data.Int (Int32) +import Data.Kind (Type) +import Data.List (isInfixOf, isPrefixOf, sortOn) +import Data.Text (Text) + +import Database.Beam +import Database.Beam.Postgres +import qualified Database.Beam.Postgres.Full as Pg +import qualified Database.Beam.Query.CTE as CTE +import Database.Beam.Postgres.Syntax + ( PgDeleteSyntax(..) + , PgInsertSyntax(..) + , PgSelectSyntax(..) + , PgUpdateSyntax(..) + , PostgresInaccessible + , pgRenderSyntaxScript + ) +import Database.PostgreSQL.Simple (execute_) + +import qualified Hedgehog +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range +import Test.Tasty +import Test.Tasty.HUnit + +import Database.Beam.Postgres.Test +import qualified Database.Beam.Postgres.Test.CTENegative as Negative + +data CteRowT f = CteRow + { cteId :: C f Int32 + , cteValue :: C f Text + } deriving (Generic, Beamable) + +deriving instance Show (CteRowT Identity) +deriving instance Eq (CteRowT Identity) + +-- A legal Haskell projection shape with no fields. PostgreSQL represents this +-- degree-zero relation by omitting the CTE column-alias list. Data-modifying +-- CTEs with RETURNING use a private physical sentinel to satisfy PostgreSQL's +-- grammar while retaining this zero-field shape at Beam's public boundary. +data EmptyCteT (f :: Type -> Type) = EmptyCte + deriving (Generic, Beamable) + +deriving instance Show (EmptyCteT Identity) +deriving instance Eq (EmptyCteT Identity) + +instance Table CteRowT where + data PrimaryKey CteRowT f = CteRowKey (C f Int32) + deriving (Generic, Beamable) + primaryKey = CteRowKey . cteId + +newtype CteDb entity = CteDb + { dbCteRows :: entity (TableEntity CteRowT) + } deriving (Generic, Database Postgres) + +cteDb :: DatabaseSettings Postgres CteDb +cteDb = defaultDbSettings + +unitTests :: TestTree +unitTests = testGroup "Common table expression tests" + [ renderingTests + , typeSafetyTests + ] + +integrationTests :: IO ByteString -> TestTree +integrationTests getConn = testGroup "Common table expression integration tests" + [ testMixedCteBodies getConn + , testSideEffectOnlyCtes getConn + , testMaterializationExecution getConn + , testLiftedWithExecution getConn + , testWithDmlConsumers getConn + , testCteParameterOrdering getConn + , testDataModifyingCteModel getConn + , testSideEffectOnlyCteModel getConn + , testWithDmlConsumerModel getConn + , testRecursiveCteModel getConn + , testDegreeZeroSelects getConn + , testDegreeZeroDataModifyingCtes getConn + , testDegreeZeroRepeatedReuse getConn + ] + +renderingTests :: TestTree +renderingTests = testGroup "Common table expression rendering tests" + [ testMixedCteRendering + , testMaterializationRendering + , testNestedMaterializedCteRendering + , testSideEffectOnlyRendering + , testSideEffectNoOps + , testLiftedWithNameSupply + , testNestedSelectCteRendering + , testRecursiveSelectThenDeleteRendering + , testEmptyDataModifyingCtes + , testWithDmlConsumerRendering + , testRecursiveInsertWithRendering + , testTopLevelOnlyDmlConsumerRendering + , testEmptyDmlConsumers + , testReturningAfterDmlConsumers + , testDegreeZeroSelectRendering + , testDegreeZeroDataModifyingRendering + ] + +-- These tests force expressions compiled with deferred type errors in the +-- isolated negative-fixture module. Checking fragments of GHC's error ensures +-- an unrelated deferred error cannot make a test pass accidentally. +typeSafetyTests :: TestTree +typeSafetyTests = testGroup "Common table expression type-safety tests" + [ testCase "rejects a DELETE CTE inside pgSelectWith" $ + assertPlacementTypeError Negative.invalidNestedDelete + , testCase "rejects an INSERT CTE inside pgSelectWith" $ + assertPlacementTypeError Negative.invalidNestedInsert + , testCase "rejects an UPDATE CTE inside pgSelectWith" $ + assertPlacementTypeError Negative.invalidNestedUpdate + , testCase "rejects SELECT followed by DELETE inside pgSelectWith" $ + assertPlacementTypeError Negative.invalidNestedSelectThenDelete + , testCase "rejects DELETE followed by SELECT inside pgSelectWith" $ + assertPlacementTypeError Negative.invalidNestedDeleteThenSelect + , testCase "conservatively rejects an empty INSERT inside pgSelectWith" $ + assertPlacementTypeError Negative.invalidNestedEmptyInsert + , testCase "conservatively rejects an identity UPDATE inside pgSelectWith" $ + assertPlacementTypeError Negative.invalidNestedIdentityUpdate + , testCase "rejects a side-effect-only DELETE inside pgSelectWithNested" $ + assertPlacementTypeError Negative.invalidNestedSideEffectDelete + , testCase "placement cannot be bypassed with coerce" $ + assertPlacementTypeError Negative.invalidCoercedPlacement + , testCase "rejects a recursively self-referencing INSERT CTE" $ + assertDeferredTypeErrorContaining + ["No instance", "MonadFix", "PgCteTopLevelOnly"] + Negative.invalidRecursiveInsert + , testCase "side-effect-only CTE results cannot be reused" $ + assertDeferredTypeErrorContaining + ["ReusableQ"] + Negative.invalidReuseSideEffect + ] + +assertPlacementTypeError :: SqlSelect Postgres a -> Assertion +assertPlacementTypeError = + assertDeferredTypeErrorContaining ["PgCteTopLevelOnly", "PgCteNestedAllowed"] + +assertDeferredTypeErrorContaining + :: [String] + -> SqlSelect Postgres a + -> Assertion +assertDeferredTypeErrorContaining expectedFragments sql = do + result <- try (evaluate (BL.length (renderSelectBytes sql))) + case result of + Left (err :: TypeError) -> + let message = show err + in mapM_ (assertFragment message) expectedFragments + Right _ -> + assertFailure "expected the expression to contain a deferred type error" + where + assertFragment message fragment = + assertBool + ("mentions " ++ fragment ++ "\nDeferred error was:\n" ++ message) + (fragment `isInfixOf` message) + +-- A single top-level WITH block may freely mix SELECT and data-modifying CTE +-- bodies. Besides checking the individual keywords, this guards against +-- accidentally nesting a second WITH while combining the syntax fragments. +testMixedCteRendering :: TestTree +testMixedCteRendering = testCase "renders mixed SELECT, INSERT, UPDATE, and DELETE CTEs" $ do + let sql = renderSelect mixedCteSelect + assertBool "renders one top-level WITH" ("WITH " `isPrefixOf` sql) + assertBool "does not render a nested WITH keyword" (not ("WITH WITH" `isInfixOf` sql)) + assertBool "renders INSERT" ("INSERT INTO" `isInfixOf` sql) + assertBool "renders UPDATE" ("UPDATE" `isInfixOf` sql) + assertBool "renders DELETE" ("DELETE FROM" `isInfixOf` sql) + assertEqual "renders three RETURNING clauses" 3 (length (filter (== "RETURNING") (words sql))) + +-- Materialization is an explicit PostgreSQL 12+ spelling choice. Check the +-- complete token rather than a loose MATERIALIZED substring, since the latter +-- would make the NOT MATERIALIZED case pass the positive assertion too. +testMaterializationRendering :: TestTree +testMaterializationRendering = testCase "renders every SELECT CTE materialization policy" $ do + let defaultSql = renderSelect (materializationSelect Pg.PgCteDefault) + materializedSql = renderSelect (materializationSelect Pg.PgCteMaterialized) + notMaterializedSql = renderSelect (materializationSelect Pg.PgCteNotMaterialized) + assertBool "default omits MATERIALIZED" + (not (" MATERIALIZED (" `isInfixOf` defaultSql)) + assertBool "default omits NOT MATERIALIZED" + (not (" NOT MATERIALIZED (" `isInfixOf` defaultSql)) + assertBool "renders AS MATERIALIZED" + (" AS MATERIALIZED (" `isInfixOf` materializedSql) + assertBool "renders AS NOT MATERIALIZED" + (" AS NOT MATERIALIZED (" `isInfixOf` notMaterializedSql) + +-- pgSelectWithNested is the safe nested consumer for PostgreSQL-specific +-- SELECT CTE features. This complements the compatibility test for the older +-- pgSelectWith API below. +testNestedMaterializedCteRendering :: TestTree +testNestedMaterializedCteRendering = testCase "embeds a materialized PgWith block in a subquery" $ do + let sql = renderSelect nestedMaterializedCteSelect + assertBool "renders the nested WITH" + ("FROM (WITH " `isInfixOf` sql) + assertBool "retains the materialization modifier" + (" AS MATERIALIZED (" `isInfixOf` sql) + +-- DML without RETURNING is still executed by PostgreSQL but forms no temporary +-- table and exposes no reusable result. Its CTE name must therefore have no +-- empty column-alias list. +testSideEffectOnlyRendering :: TestTree +testSideEffectOnlyRendering = testCase "renders side-effect-only INSERT, UPDATE, and DELETE CTEs" $ do + let sql = renderSelect sideEffectOnlyCteSelect + assertBool "renders INSERT" ("INSERT INTO" `isInfixOf` sql) + assertBool "renders UPDATE" ("UPDATE" `isInfixOf` sql) + assertBool "renders DELETE" ("DELETE FROM" `isInfixOf` sql) + assertBool "does not render RETURNING" (not ("RETURNING" `isInfixOf` sql)) + assertBool "does not render an empty alias list" (not ("() AS" `isInfixOf` sql)) + +-- Empty inserts and identity updates should consume neither a name nor a CTE +-- slot. With no other CTEs, the final query must not acquire an empty WITH. +testSideEffectNoOps :: TestTree +testSideEffectNoOps = testCase "omits side-effect-only empty INSERT and identity UPDATE" $ do + let sql = renderSelect sideEffectNoOpSelect + assertBool "does not render WITH" (not ("WITH " `isPrefixOf` sql)) + assertBool "does not render INSERT" (not ("INSERT INTO" `isInfixOf` sql)) + assertBool "does not render UPDATE" (not ("UPDATE" `isInfixOf` sql)) + +-- Lifting a complete portable helper must not restart its State Int name +-- supply. Four definitions from native/lifted/native construction should be +-- allocated exactly once as cte0 through cte3. +testLiftedWithNameSupply :: TestTree +testLiftedWithNameSupply = testCase "shares CTE names across lifted and native builders" $ do + let sql = renderSelect liftedWithSelect + mapM_ (\name -> assertBool ("renders " ++ name) (("\"" ++ name ++ "\"") `isInfixOf` sql)) + ["cte0", "cte1", "cte2", "cte3"] + assertBool "does not allocate cte4" (not ("\"cte4\"" `isInfixOf` sql)) + +-- pgSelectWith remains available for its original purpose: embedding a +-- SELECT-only WITH block as a subquery. +testNestedSelectCteRendering :: TestTree +testNestedSelectCteRendering = testCase "SELECT CTEs remain valid inside pgSelectWith" $ do + let sql = renderSelect nestedSelectCteSelect + assertBool "renders an inner WITH" ("FROM (WITH " `isInfixOf` sql) + +-- Closing the recursive SELECT portion with pgToTopLevel should preserve WITH +-- RECURSIVE while allowing a later DELETE CTE in the same top-level block. +testRecursiveSelectThenDeleteRendering :: TestTree +testRecursiveSelectThenDeleteRendering = testCase "recursive SELECT can feed a top-level DELETE CTE" $ do + let sql = renderSelect recursiveSelectThenDeleteCteSelect + assertBool "renders WITH RECURSIVE" ("WITH RECURSIVE " `isPrefixOf` sql) + assertBool "renders DELETE" ("DELETE FROM" `isInfixOf` sql) + +-- Value-level empty operations must not leave behind an empty or partial WITH +-- clause when the final SELECT is rendered. +testEmptyDataModifyingCtes :: TestTree +testEmptyDataModifyingCtes = testCase "omits empty INSERT and identity UPDATE CTEs" $ do + let sql = renderSelect emptyDataModifyingCteSelect + assertBool "does not render WITH" (not ("WITH " `isPrefixOf` sql)) + assertBool "does not render INSERT" (not ("INSERT INTO" `isInfixOf` sql)) + assertBool "does not render UPDATE" (not ("UPDATE" `isInfixOf` sql)) + +-- Each PostgreSQL DML consumer must place the WITH block before, rather than +-- inside, its terminal statement. These rendering checks cover INSERT, UPDATE, +-- and DELETE while retaining Beam's existing Sql* result types. +testWithDmlConsumerRendering :: TestTree +testWithDmlConsumerRendering = testCase "renders WITH before terminal INSERT, UPDATE, and DELETE" $ do + assertWithTerminal "INSERT INTO" (renderInsert insertWithStatement) + assertWithTerminal "UPDATE" (renderUpdate updateWithStatement) + assertWithTerminal "DELETE FROM" (renderDelete deleteWithStatement) + +-- A recursive SELECT CTE is legal before a terminal DML statement. This makes +-- sure pgInsertWith preserves the recursive flag collected by With. +testRecursiveInsertWithRendering :: TestTree +testRecursiveInsertWithRendering = testCase "renders WITH RECURSIVE before a terminal INSERT" $ do + sql <- requireRenderedStatement (renderInsert recursiveInsertWithStatement) + assertBool "starts with WITH RECURSIVE" ("WITH RECURSIVE " `isPrefixOf` sql) + assertBool "renders terminal INSERT" (" INSERT INTO" `isInfixOf` sql) + +-- Top-level DML consumers may accept the stronger PgCteTopLevelOnly placement. +-- A data-modifying CTE followed by DELETE exercises that fact at compile time +-- as well as checking the resulting SQL shape. +testTopLevelOnlyDmlConsumerRendering :: TestTree +testTopLevelOnlyDmlConsumerRendering = testCase "accepts a modifying CTE before terminal DELETE" $ do + sql <- requireRenderedStatement (renderDelete topLevelOnlyDeleteWithStatement) + assertBool "renders DELETE as the CTE body" + ("AS (DELETE FROM" `isInfixOf` sql) + assertBool "renders DELETE as the terminal statement" + (") DELETE FROM" `isInfixOf` sql) + +-- An empty INSERT and identity UPDATE have no terminal statement. PostgreSQL +-- cannot execute a bare WITH clause, so their consumers must retain the +-- existing no-op representation and discard the accumulated definitions. +testEmptyDmlConsumers :: TestTree +testEmptyDmlConsumers = testCase "keeps empty INSERT and identity UPDATE as no-ops" $ do + assertEqual "empty INSERT has no syntax" Nothing + (renderInsert emptyInsertWithStatement) + assertEqual "identity UPDATE has no syntax" Nothing + (renderUpdate identityUpdateWithStatement) + +-- The consumers deliberately return the existing Sql* wrappers. Their +-- PgReturning instances must therefore remain usable without a parallel +-- pgInsertReturningWith/pgUpdateReturningWith/pgDeleteReturningWith API. +testReturningAfterDmlConsumers :: TestTree +testReturningAfterDmlConsumers = testCase "supports RETURNING after each terminal DML consumer" $ do + assertReturning "INSERT" (renderInsertReturning (Pg.returning insertWithStatement id)) + assertReturning "UPDATE" (renderUpdateReturning (Pg.returning updateWithStatement id)) + assertReturning "DELETE" (renderDeleteReturning (Pg.returning deleteWithStatement id)) + +-- PostgreSQL's syntax for a degree-zero CTE has no column-alias parentheses. +-- Cover both the portable selecting renderer and the native renderer, including +-- nested and explicit materialization forms, because they enter PostgreSQL +-- syntax through different code paths. +testDegreeZeroSelectRendering :: TestTree +testDegreeZeroSelectRendering = testCase "renders reusable degree-zero SELECT CTEs" $ do + let portableSql = renderSelect emptySelectProjection + nativeSql = renderSelect + (emptyNativeSelectProjection Pg.PgCteDefault) + materializedSql = renderSelect + (emptyNativeSelectProjection Pg.PgCteMaterialized) + nestedSql = renderSelect nestedEmptySelectProjection + + mapM_ assertDegreeZeroSelect + [portableSql, nativeSql, materializedSql, nestedSql] + assertBool "retains explicit materialization" + (" AS MATERIALIZED (" `isInfixOf` materializedSql) + assertBool "remains valid in a nested SELECT" + ("FROM (WITH " `isInfixOf` nestedSql) + where + assertDegreeZeroSelect sql = do + assertBool "does not render an empty CTE alias list" + (not ("\"cte0\"()" `isInfixOf` sql)) + assertBool "the CTE body projects no columns" + ("SELECT FROM" `isInfixOf` sql || "SELECT FROM" `isInfixOf` sql) + assertBool "the consumer projects no columns" + ("SELECT FROM \"cte0\"" `isInfixOf` sql || + "SELECT FROM \"cte0\"" `isInfixOf` sql) + +-- INSERT, UPDATE, and DELETE share the sentinel path but have independent +-- RETURNING renderers. Assert every spelling, including that the physical +-- sentinel is declared once and is not selected by the zero-field consumer. +testDegreeZeroDataModifyingRendering :: TestTree +testDegreeZeroDataModifyingRendering = + testCase "renders reusable degree-zero data-modifying CTEs" $ + mapM_ assertDegreeZeroDml + [ ("INSERT", renderSelect (emptyInsertProjection [CteRow 1 "one"])) + , ("UPDATE", renderSelect (emptyUpdateProjection 1 "updated")) + , ("DELETE", renderSelect (emptyDeleteProjection 1)) + ] + where + assertDegreeZeroDml (command, sql) = do + assertBool (command ++ " declares one physical sentinel") + ("\"cte0\"(\"res0\") AS" `isInfixOf` sql) + assertBool (command ++ " appends a valid RETURNING expression") + (" RETURNING NULL::boolean" `isInfixOf` sql) + assertEqual (command ++ " emits one RETURNING keyword") + 1 + (length (filter (== "RETURNING") (words sql))) + assertBool (command ++ " does not expose the sentinel") + ("SELECT FROM \"cte0\"" `isInfixOf` sql || + "SELECT FROM \"cte0\"" `isInfixOf` sql) + +-- Rendering alone cannot verify PostgreSQL's execution and snapshot semantics. +-- This integration case checks both the RETURNING rows and the final table +-- state after all three modifying CTEs execute. +testMixedCteBodies :: IO ByteString -> TestTree +testMixedCteBodies getConn = testCase "SELECT and data-modifying CTEs can be mixed" $ + withTestPostgres "mixed_cte_bodies" getConn $ \conn -> do + execute_ conn "CREATE TABLE cte_rows (id INT PRIMARY KEY, value TEXT NOT NULL)" + execute_ conn "INSERT INTO cte_rows VALUES (1, 'selected'), (3, 'before-update'), (4, 'deleted')" + + result <- runBeamPostgres conn $ runSelectReturningList mixedCteSelect + + assertEqual "rows returned by each CTE" + [ ( CteRow 1 "selected" + , CteRow 2 "inserted" + , CteRow 3 "updated" + , CteRow 4 "deleted" + ) + ] + result + + remaining <- runBeamPostgres conn $ runSelectReturningList $ select $ + orderBy_ (asc_ . cteId) $ all_ (dbCteRows cteDb) + assertEqual "data modifications were applied" + [ CteRow 1 "selected" + , CteRow 2 "inserted" + , CteRow 3 "updated" + ] + remaining + +-- PostgreSQL executes a modifying CTE exactly once even when it has no +-- RETURNING clause and the terminal SELECT does not reference it. Verify that +-- all three commands affect the final database state, not merely that their +-- syntax parses. +testSideEffectOnlyCtes :: IO ByteString -> TestTree +testSideEffectOnlyCtes getConn = testCase "unreferenced side-effect-only CTEs execute once" $ + withTestPostgres "side_effect_only_ctes" getConn $ \conn -> do + execute_ conn "CREATE TABLE cte_rows (id INT PRIMARY KEY, value TEXT NOT NULL)" + execute_ conn "INSERT INTO cte_rows VALUES (1, 'unchanged'), (2, 'before-update'), (3, 'delete-me')" + + marker <- runBeamPostgres conn $ + runSelectReturningOne sideEffectOnlyCteSelect + assertEqual "terminal SELECT still runs" (Just (1 :: Int32)) marker + + remaining <- runBeamPostgres conn $ runSelectReturningList $ select $ + orderBy_ (asc_ . cteId) $ all_ (dbCteRows cteDb) + assertEqual "all expected side effects were applied" + [ CteRow 1 "unchanged" + , CteRow 2 "after-update" + , CteRow 4 "inserted" + ] + remaining + +-- Planner choices are deliberately not asserted because they may vary across +-- PostgreSQL releases. Successful execution and equal results validate the two +-- explicit PostgreSQL 12+ spellings without coupling the test to EXPLAIN. +testMaterializationExecution :: IO ByteString -> TestTree +testMaterializationExecution getConn = testCase "MATERIALIZED and NOT MATERIALIZED execute" $ + withTestPostgres "cte_materialization" getConn $ \conn -> do + execute_ conn "CREATE TABLE cte_rows (id INT PRIMARY KEY, value TEXT NOT NULL)" + execute_ conn "INSERT INTO cte_rows VALUES (1, 'one'), (2, 'two')" + + materialized <- runBeamPostgres conn $ runSelectReturningList $ + materializationSelect Pg.PgCteMaterialized + notMaterialized <- runBeamPostgres conn $ runSelectReturningList $ + materializationSelect Pg.PgCteNotMaterialized + assertEqual "both policies preserve query results" materialized notMaterialized + +-- Rendering checks the shared name supply; execution additionally proves that +-- ReusableQ values returned by a lifted multi-CTE helper retain their meaning. +testLiftedWithExecution :: IO ByteString -> TestTree +testLiftedWithExecution getConn = testCase "a lifted multi-CTE helper remains reusable" $ + withTestPostgres "lifted_with_execution" getConn $ \conn -> do + lifted <- runBeamPostgres conn $ runSelectReturningList liftedWithSelect + assertEqual "a lifted multi-CTE helper remains reusable" + [(1, 11, 12)] + lifted + +-- Execute each terminal DML consumer against PostgreSQL. The three statements +-- use SELECT CTEs to choose or construct their affected rows, proving that the +-- reusable names remain visible to INSERT, UPDATE, and DELETE. +testWithDmlConsumers :: IO ByteString -> TestTree +testWithDmlConsumers getConn = testCase "WITH can terminate in INSERT, UPDATE, or DELETE" $ + withTestPostgres "with_dml_consumers" getConn $ \conn -> do + execute_ conn "CREATE TABLE cte_rows (id INT PRIMARY KEY, value TEXT NOT NULL)" + execute_ conn "INSERT INTO cte_rows VALUES (1, 'source'), (3, 'before-update'), (4, 'delete-me')" + + runBeamPostgres conn $ do + runInsert insertWithStatement + runUpdate updateWithStatement + runDelete deleteWithStatement + + remaining <- runBeamPostgres conn $ runSelectReturningList $ select $ + orderBy_ (asc_ . cteId) $ all_ (dbCteRows cteDb) + assertEqual "all terminal DML statements used their CTE rows" + [ CteRow 1 "source" + , CteRow 2 "inserted-with" + , CteRow 3 "updated-with" + ] + remaining + +-- PostgreSQL receives Beam values separately from the rendered placeholders. +-- Generate distinct values at each syntactic level so any disagreement between +-- syntax construction order and parameter collection order becomes observable +-- in the returned rows, rather than merely producing valid-looking SQL. +testCteParameterOrdering :: IO ByteString -> TestTree +testCteParameterOrdering getConn = testCase "preserves parameter order across CTE bodies and the terminal query" $ + withTestPostgres "cte_parameter_ordering_property" getConn $ \conn -> do + passes <- Hedgehog.check . Hedgehog.property $ do + baseId <- Hedgehog.forAll (Gen.int (Range.linear (-100000) 100000)) + firstOffset <- Hedgehog.forAll (Gen.int (Range.linear 1 1000)) + secondOffset <- Hedgehog.forAll (Gen.int (Range.linear 1 1000)) + payload <- Hedgehog.forAll (Gen.text (Range.linear 0 24) Gen.alphaNum) + + let first = CteRow (fromIntegral baseId) ("first:" <> payload) + second = CteRow + (fromIntegral (baseId + firstOffset)) + ("second:" <> payload) + terminal = CteRow + (fromIntegral (baseId + firstOffset + secondOffset)) + ("terminal:" <> payload) + + actual <- Hedgehog.evalIO $ runBeamPostgres conn $ + runSelectReturningList (parameterOrderingSelect first second terminal) + + actual Hedgehog.=== [(first, second, terminal)] + + assertBool "CTE parameter-ordering property failed" passes + +-- Model a statement containing all three kinds of data-modifying CTE. The +-- operations use disjoint keys, avoiding PostgreSQL's deliberately unspecified +-- ordering when sibling modifying CTEs affect the same row. Both RETURNING +-- values and durable table state are compared with the pure expected result. +testDataModifyingCteModel :: IO ByteString -> TestTree +testDataModifyingCteModel getConn = testCase "data-modifying CTEs agree with a pure table model" $ + withTestPostgres "data_modifying_cte_model_property" getConn $ \conn -> do + execute_ conn "CREATE TABLE cte_rows (id INT PRIMARY KEY, value TEXT NOT NULL)" + + passes <- Hedgehog.check . Hedgehog.property $ do + baseId <- Hedgehog.forAll (Gen.int (Range.linear (-100000) 96000)) + payload <- Hedgehog.forAll (Gen.text (Range.linear 0 24) Gen.alphaNum) + + let inserted = CteRow (fromIntegral baseId) ("inserted:" <> payload) + beforeUpdate = CteRow (fromIntegral (baseId + 1)) ("before-update:" <> payload) + updated = CteRow (cteId beforeUpdate) ("updated:" <> payload) + deleted = CteRow (fromIntegral (baseId + 2)) ("deleted:" <> payload) + untouched = CteRow (fromIntegral (baseId + 3)) ("untouched:" <> payload) + initial = [beforeUpdate, deleted, untouched] + expectedFinal = [inserted, updated, untouched] + + Hedgehog.evalIO $ do + execute_ conn "TRUNCATE TABLE cte_rows" + runBeamPostgres conn $ runInsert $ + insert (dbCteRows cteDb) (insertValues initial) + + returned <- Hedgehog.evalIO $ runBeamPostgres conn $ + runSelectReturningList $ + dataModifyingCteModelSelect inserted (cteId updated) (cteValue updated) (cteId deleted) + + finalRows <- Hedgehog.evalIO $ runBeamPostgres conn $ + runSelectReturningList $ select $ + orderBy_ (asc_ . cteId) $ all_ (dbCteRows cteDb) + + returned Hedgehog.=== [(inserted, updated, deleted)] + finalRows Hedgehog.=== expectedFinal + + assertBool "data-modifying CTE model property failed" passes + +-- Repeat the three-operation model without RETURNING. This catches parameter +-- ordering or accidental omission in the side-effect-only path by +-- comparing durable state over generated inputs. +testSideEffectOnlyCteModel :: IO ByteString -> TestTree +testSideEffectOnlyCteModel getConn = testCase "side-effect-only CTEs agree with a pure table model" $ + withTestPostgres "side_effect_only_cte_model_property" getConn $ \conn -> do + execute_ conn "CREATE TABLE cte_rows (id INT PRIMARY KEY, value TEXT NOT NULL)" + + passes <- Hedgehog.check . Hedgehog.property $ do + baseId <- Hedgehog.forAll (Gen.int (Range.linear (-100000) 96000)) + payload <- Hedgehog.forAll (Gen.text (Range.linear 0 24) Gen.alphaNum) + + let inserted = CteRow (fromIntegral baseId) ("inserted:" <> payload) + beforeUpdate = CteRow (fromIntegral (baseId + 1)) ("before-update:" <> payload) + updated = CteRow (cteId beforeUpdate) ("updated:" <> payload) + deleted = CteRow (fromIntegral (baseId + 2)) ("deleted:" <> payload) + untouched = CteRow (fromIntegral (baseId + 3)) ("untouched:" <> payload) + initial = [beforeUpdate, deleted, untouched] + expectedFinal = [inserted, updated, untouched] + + Hedgehog.evalIO $ do + execute_ conn "TRUNCATE TABLE cte_rows" + runBeamPostgres conn $ runInsert $ + insert (dbCteRows cteDb) (insertValues initial) + + marker <- Hedgehog.evalIO $ runBeamPostgres conn $ + runSelectReturningOne $ + sideEffectCteModelSelect inserted (cteId updated) (cteValue updated) (cteId deleted) + finalRows <- Hedgehog.evalIO $ runBeamPostgres conn $ + runSelectReturningList $ select $ + orderBy_ (asc_ . cteId) $ all_ (dbCteRows cteDb) + + marker Hedgehog.=== Just (1 :: Int32) + finalRows Hedgehog.=== expectedFinal + + assertBool "side-effect-only CTE model property failed" passes + +-- Exercise each top-level WITH consumer with independently generated values. +-- RETURNING results prove that the existing PostgreSQL execution instances can +-- still consume the Sql* wrappers, while the final table comparison checks the +-- combined INSERT, UPDATE, and DELETE behavior against a pure model. +testWithDmlConsumerModel :: IO ByteString -> TestTree +testWithDmlConsumerModel getConn = testCase "WITH DML consumers agree with a pure table model" $ + withTestPostgres "with_dml_consumer_model_property" getConn $ \conn -> do + execute_ conn "CREATE TABLE cte_rows (id INT PRIMARY KEY, value TEXT NOT NULL)" + + passes <- Hedgehog.check . Hedgehog.property $ do + baseId <- Hedgehog.forAll (Gen.int (Range.linear (-100000) 95000)) + payload <- Hedgehog.forAll (Gen.text (Range.linear 0 24) Gen.alphaNum) + + let source = CteRow (fromIntegral baseId) ("source:" <> payload) + inserted = CteRow (fromIntegral (baseId + 1)) ("inserted:" <> payload) + beforeUpdate = CteRow (fromIntegral (baseId + 2)) ("before-update:" <> payload) + updated = CteRow (cteId beforeUpdate) ("updated:" <> payload) + deleted = CteRow (fromIntegral (baseId + 3)) ("deleted:" <> payload) + untouched = CteRow (fromIntegral (baseId + 4)) ("untouched:" <> payload) + initial = [source, beforeUpdate, deleted, untouched] + expectedFinal = [source, inserted, updated, untouched] + + Hedgehog.evalIO $ do + execute_ conn "TRUNCATE TABLE cte_rows" + runBeamPostgres conn $ runInsert $ + insert (dbCteRows cteDb) (insertValues initial) + + (insertedRows, updatedRows, deletedRows) <- Hedgehog.evalIO $ + runBeamPostgres conn $ do + insertedRows <- Pg.runPgInsertReturningList $ Pg.returning + (modelInsertWithStatement (cteId source) inserted) id + updatedRows <- Pg.runPgUpdateReturningList $ Pg.returning + (modelUpdateWithStatement (cteId updated) (cteValue updated)) id + deletedRows <- Pg.runPgDeleteReturningList $ Pg.returning + (modelDeleteWithStatement (cteId deleted)) id + pure (insertedRows, updatedRows, deletedRows) + + finalRows <- Hedgehog.evalIO $ runBeamPostgres conn $ + runSelectReturningList $ select $ + orderBy_ (asc_ . cteId) $ all_ (dbCteRows cteDb) + + insertedRows Hedgehog.=== [inserted] + updatedRows Hedgehog.=== [updated] + deletedRows Hedgehog.=== [deleted] + finalRows Hedgehog.=== expectedFinal + + assertBool "WITH DML consumer model property failed" passes + +-- Generate a bounded recursive sequence, use it to drive a DELETE CTE, and +-- compare both the returned rows and remaining table against the corresponding +-- Haskell lists. This executes the recursive SELECT, its pgToTopLevel promotion, +-- and the following modifying CTE rather than checking only rendered keywords. +testRecursiveCteModel :: IO ByteString -> TestTree +testRecursiveCteModel getConn = testCase "recursive CTE execution agrees with a bounded sequence model" $ + withTestPostgres "recursive_cte_model_property" getConn $ \conn -> do + execute_ conn "CREATE TABLE cte_rows (id INT PRIMARY KEY, value TEXT NOT NULL)" + + passes <- Hedgehog.check . Hedgehog.property $ do + start <- Hedgehog.forAll (Gen.int (Range.linear (-100000) 95000)) + count <- Hedgehog.forAll (Gen.int (Range.linear 1 25)) + payload <- Hedgehog.forAll (Gen.text (Range.linear 0 24) Gen.alphaNum) + + let startId = fromIntegral start + endId = fromIntegral (start + count - 1) + recursiveRows = + [ CteRow (fromIntegral rowId) ("recursive:" <> payload) + | rowId <- [start .. start + count - 1] + ] + untouched = CteRow (fromIntegral (start + count)) ("untouched:" <> payload) + + Hedgehog.evalIO $ do + execute_ conn "TRUNCATE TABLE cte_rows" + runBeamPostgres conn $ runInsert $ + insert (dbCteRows cteDb) (insertValues (recursiveRows ++ [untouched])) + + deletedRows <- Hedgehog.evalIO $ runBeamPostgres conn $ + runSelectReturningList (recursiveCteModelSelect startId endId) + finalRows <- Hedgehog.evalIO $ runBeamPostgres conn $ + runSelectReturningList $ select $ + orderBy_ (asc_ . cteId) $ all_ (dbCteRows cteDb) + + sortOn cteId deletedRows Hedgehog.=== recursiveRows + finalRows Hedgehog.=== [untouched] + + assertBool "recursive CTE model property failed" passes + +-- A row need not contain a projected value. PostgreSQL still returns one +-- zero-field result for every source row, and postgresql-simple must decode the +-- final rows without expecting any result fields. Exercise both the portable +-- and native builders and both explicit materialization policies. +testDegreeZeroSelects :: IO ByteString -> TestTree +testDegreeZeroSelects getConn = testCase "degree-zero SELECT CTEs preserve source cardinality" $ + withTestPostgres "degree_zero_select_ctes" getConn $ \conn -> do + execute_ conn "CREATE TABLE cte_rows (id INT PRIMARY KEY, value TEXT NOT NULL)" + + emptySummary <- runBeamPostgres conn $ runSelectReturningOne $ + emptySelectSummary + assertEqual "an empty degree-zero relation has count zero and is not present" + (Just (0, False)) + emptySummary + + execute_ conn "INSERT INTO cte_rows VALUES (1, 'one'), (2, 'two'), (3, 'three')" + + portable <- runBeamPostgres conn $ + runSelectReturningList emptySelectProjection + native <- runBeamPostgres conn $ runSelectReturningList $ + emptyNativeSelectProjection Pg.PgCteDefault + materialized <- runBeamPostgres conn $ runSelectReturningList $ + emptyNativeSelectProjection Pg.PgCteMaterialized + notMaterialized <- runBeamPostgres conn $ runSelectReturningList $ + emptyNativeSelectProjection Pg.PgCteNotMaterialized + populatedSummary <- runBeamPostgres conn $ runSelectReturningOne $ + emptySelectSummary + + let expected = replicate 3 EmptyCte + assertEqual "portable selecting preserves cardinality" expected portable + assertEqual "native default preserves cardinality" expected native + assertEqual "MATERIALIZED preserves cardinality" expected materialized + assertEqual "NOT MATERIALIZED preserves cardinality" expected notMaterialized + assertEqual "aggregates and EXISTS observe degree-zero rows" + (Just (3, True)) + populatedSummary + +-- Each modifying command has a separate RETURNING renderer. Besides validating +-- all three, this checks the boundary cases of several affected rows and no +-- affected rows, verifies that the private sentinel is not passed to the row +-- decoder, and compares the resulting durable table state. +testDegreeZeroDataModifyingCtes :: IO ByteString -> TestTree +testDegreeZeroDataModifyingCtes getConn = + testCase "degree-zero modifying CTEs preserve affected-row cardinality" $ + withTestPostgres "degree_zero_modifying_ctes" getConn $ \conn -> do + execute_ conn "CREATE TABLE cte_rows (id INT PRIMARY KEY, value TEXT NOT NULL)" + execute_ conn "INSERT INTO cte_rows VALUES (1, 'one'), (2, 'two'), (3, 'three')" + + inserted <- runBeamPostgres conn $ runSelectReturningList $ + emptyInsertProjection [CteRow 4 "four", CteRow 5 "five"] + updated <- runBeamPostgres conn $ runSelectReturningList $ + emptyUpdateProjection 2 "updated" + deleted <- runBeamPostgres conn $ runSelectReturningList $ + emptyDeleteProjection 3 + deletedNone <- runBeamPostgres conn $ runSelectReturningList $ + emptyDeleteProjection 99 + + assertEqual "INSERT retains two affected rows" + (replicate 2 EmptyCte) inserted + assertEqual "UPDATE retains two affected rows" + (replicate 2 EmptyCte) updated + assertEqual "DELETE retains three affected rows" + (replicate 3 EmptyCte) deleted + assertEqual "a command affecting no rows returns an empty relation" + [] deletedNone + + remaining <- runBeamPostgres conn $ runSelectReturningList $ select $ + orderBy_ (asc_ . cteId) $ all_ (dbCteRows cteDb) + assertEqual "all modifying commands applied their side effects" + [CteRow 1 "updated", CteRow 2 "updated"] + remaining + +-- Reusing a degree-zero modifying CTE twice is a useful stress case: no field +-- can carry cardinality through the query, so the nine rows show that both +-- references read the same three-row RETURNING result. The final table state +-- separately confirms that the DELETE removed every source row. +testDegreeZeroRepeatedReuse :: IO ByteString -> TestTree +testDegreeZeroRepeatedReuse getConn = + testCase "repeated degree-zero reuse preserves relational cardinality" $ + withTestPostgres "degree_zero_repeated_reuse" getConn $ \conn -> do + execute_ conn "CREATE TABLE cte_rows (id INT PRIMARY KEY, value TEXT NOT NULL)" + execute_ conn "INSERT INTO cte_rows VALUES (1, 'one'), (2, 'two'), (3, 'three')" + + summary <- runBeamPostgres conn $ runSelectReturningOne $ + emptyDeleteSummary + assertEqual "COUNT and EXISTS observe every returned DELETE row" + (Just (3, True)) + summary + + execute_ conn "INSERT INTO cte_rows VALUES (1, 'one'), (2, 'two'), (3, 'three')" + products <- runBeamPostgres conn $ runSelectReturningList $ + repeatedEmptyDeleteProjection + assertEqual "two references form the expected Cartesian product" + (replicate 9 EmptyCte) + products + + remaining <- runBeamPostgres conn $ runSelectReturningList $ select $ + all_ (dbCteRows cteDb) + assertEqual "the modifying CTE deletes every source row" + [] + remaining + +materializationSelect + :: Pg.PgCteMaterialization + -> SqlSelect Postgres (CteRowT Identity) +materializationSelect materialization = Pg.pgSelectWithTopLevel $ do + rows <- Pg.pgSelectingWith materialization $ all_ (dbCteRows cteDb) + pure (reuse rows) + +nestedMaterializedCteSelect :: SqlSelect Postgres (CteRowT Identity) +nestedMaterializedCteSelect = select $ Pg.pgSelectWithNested $ do + rows <- Pg.pgSelectingWith Pg.PgCteMaterialized $ + all_ (dbCteRows cteDb) + pure (reuse rows) + +sideEffectOnlyCteSelect :: SqlSelect Postgres Int32 +sideEffectOnlyCteSelect = Pg.pgSelectWithTopLevel $ do + Pg.cteInsert + (dbCteRows cteDb) + (insertValues [CteRow 4 "inserted"]) + Pg.onConflictDefault + Pg.cteUpdate + (dbCteRows cteDb) + (\row -> cteValue row <-. val_ "after-update") + (\row -> cteId row ==. val_ 2) + Pg.cteDelete + (dbCteRows cteDb) + (\row -> cteId row ==. val_ 3) + pure finalMarkerQuery + +sideEffectNoOpSelect :: SqlSelect Postgres Int32 +sideEffectNoOpSelect = Pg.pgSelectWithTopLevel $ do + Pg.cteInsert + (dbCteRows cteDb) + SqlInsertValuesEmpty + Pg.onConflictDefault + Pg.cteUpdate + (dbCteRows cteDb) + (const mempty) + (const (val_ True)) + pure finalMarkerQuery + +finalMarkerQuery + :: Q Postgres CteDb QBaseScope (QExpr Postgres QBaseScope Int32) +finalMarkerQuery = pure (val_ 1) + +-- A complete two-CTE portable helper is lifted as one action. Its internal +-- dependency also proves that lifting preserves ReusableQ values, not only the +-- emitted syntax fragments. +portableWithHelper + :: With Postgres CteDb + (ReusableQ Postgres CteDb (QExpr Postgres CTE.QAnyScope Int32)) +portableWithHelper = do + first <- selecting $ pure (as_ @Int32 (val_ 10)) + selecting $ do + value <- reuse first + pure (value + 1) + +liftedWithSelect + :: SqlSelect Postgres + (Int32, Int32, Int32) +liftedWithSelect = Pg.pgSelectWithTopLevel $ do + nativeBefore <- Pg.pgSelecting $ pure (as_ @Int32 (val_ 1)) + lifted <- Pg.pgLiftWith portableWithHelper + nativeAfter <- Pg.pgSelecting $ do + value <- reuse lifted + pure (value + 1) + pure $ do + before <- reuse nativeBefore + middle <- reuse lifted + after <- reuse nativeAfter + pure (before, middle, after) + +-- Exercise the main user-facing flow: bind a normal SELECT CTE, perform each +-- supported data modification, then join all four reusable results in the final +-- SELECT. The placement of the complete block is inferred as top-level-only. +mixedCteSelect + :: SqlSelect Postgres + ( CteRowT Identity + , CteRowT Identity + , CteRowT Identity + , CteRowT Identity + ) +mixedCteSelect = Pg.pgSelectWithTopLevel $ do + selected <- Pg.pgSelecting $ do + row <- all_ (dbCteRows cteDb) + guard_ (cteId row ==. val_ 1) + pure row + + inserted <- Pg.cteInsertReturning + (dbCteRows cteDb) + (insertValues [CteRow 2 "inserted"]) + Pg.onConflictDefault + id + + updated <- Pg.cteUpdateReturning + (dbCteRows cteDb) + (\row -> cteValue row <-. val_ "updated") + (\row -> cteId row ==. val_ 3) + id + + deleted <- Pg.cteDeleteReturning + (dbCteRows cteDb) + (\row -> cteId row ==. val_ 4) + id + + case (inserted, updated) of + (Just inserted', Just updated') -> pure $ do + selectedRow <- reuse selected + insertedRow <- reuse inserted' + updatedRow <- reuse updated' + deletedRow <- reuse deleted + pure (selectedRow, insertedRow, updatedRow, deletedRow) + _ -> error "Expected non-empty INSERT and UPDATE CTEs" + +-- Place values in two dependent CTE bodies and in the terminating SELECT. The +-- dependency prevents the second CTE from becoming an unrelated test fragment, +-- while the result exposes every bound value for exact comparison. +parameterOrderingSelect + :: CteRowT Identity + -> CteRowT Identity + -> CteRowT Identity + -> SqlSelect Postgres + (CteRowT Identity, CteRowT Identity, CteRowT Identity) +parameterOrderingSelect first second terminal = selectWith $ do + firstRows <- selecting $ pure (cteRowValues_ @CTE.QAnyScope first) + secondRows <- selecting $ do + _ <- reuse firstRows + pure (cteRowValues_ @CTE.QAnyScope second) + pure $ do + firstRow <- reuse firstRows + secondRow <- reuse secondRows + pure + ( firstRow + , secondRow + , cteRowValues_ @QBaseScope terminal + ) + +cteRowValues_ + :: forall scope. CteRowT Identity -> CteRowT (QExpr Postgres scope) +cteRowValues_ row = CteRow (val_ (cteId row)) (val_ (cteValue row)) + +-- The returned relation exposes the result of every modifying CTE. Keeping +-- their keys disjoint gives the property a deterministic reference model while +-- still exercising mixed syntax assembly and PostgreSQL execution semantics. +dataModifyingCteModelSelect + :: CteRowT Identity + -> Int32 + -> Text + -> Int32 + -> SqlSelect Postgres + (CteRowT Identity, CteRowT Identity, CteRowT Identity) +dataModifyingCteModelSelect inserted updateId updateValue deleteId = + Pg.pgSelectWithTopLevel $ do + insertedRows <- Pg.cteInsertReturning + (dbCteRows cteDb) + (insertValues [inserted]) + Pg.onConflictDefault + id + updatedRows <- Pg.cteUpdateReturning + (dbCteRows cteDb) + (\row -> cteValue row <-. val_ updateValue) + (\row -> cteId row ==. val_ updateId) + id + deletedRows <- Pg.cteDeleteReturning + (dbCteRows cteDb) + (\row -> cteId row ==. val_ deleteId) + id + + case (insertedRows, updatedRows) of + (Just insertedRows', Just updatedRows') -> pure $ do + insertedRow <- reuse insertedRows' + updatedRow <- reuse updatedRows' + deletedRow <- reuse deletedRows + pure (insertedRow, updatedRow, deletedRow) + _ -> error "Expected non-empty INSERT and UPDATE CTEs" + +sideEffectCteModelSelect + :: CteRowT Identity + -> Int32 + -> Text + -> Int32 + -> SqlSelect Postgres Int32 +sideEffectCteModelSelect inserted updateId updateValue deleteId = + Pg.pgSelectWithTopLevel $ do + Pg.cteInsert + (dbCteRows cteDb) + (insertValues [inserted]) + Pg.onConflictDefault + Pg.cteUpdate + (dbCteRows cteDb) + (\row -> cteValue row <-. val_ updateValue) + (\row -> cteId row ==. val_ updateId) + Pg.cteDelete + (dbCteRows cteDb) + (\row -> cteId row ==. val_ deleteId) + pure finalMarkerQuery + +-- The source key is selected in a CTE, then used to derive the inserted key. +-- This keeps both the CTE and terminal INSERT semantically relevant. +modelInsertWithStatement + :: Int32 + -> CteRowT Identity + -> SqlInsert Postgres CteRowT +modelInsertWithStatement sourceId inserted = Pg.pgInsertWith $ do + sourceIds <- Pg.pgSelecting $ do + row <- all_ (dbCteRows cteDb) + guard_ (cteId row ==. val_ sourceId) + pure (cteId row) + pure $ Pg.insert + (dbCteRows cteDb) + (insertFrom $ do + selectedId <- reuse sourceIds + pure $ CteRow + (selectedId + val_ (cteId inserted - sourceId)) + (val_ (cteValue inserted))) + Pg.onConflictDefault + +modelUpdateWithStatement + :: Int32 + -> Text + -> SqlUpdate Postgres CteRowT +modelUpdateWithStatement updateId updateValue = Pg.pgUpdateWith $ do + targetIds <- Pg.pgSelecting $ do + row <- all_ (dbCteRows cteDb) + guard_ (cteId row ==. val_ updateId) + pure (cteId row) + pure $ update + (dbCteRows cteDb) + (\row -> cteValue row <-. val_ updateValue) + (\row -> exists_ $ do + targetId <- reuse targetIds + guard_ (cteId row ==. targetId) + pure targetId) + +modelDeleteWithStatement + :: Int32 + -> SqlDelete Postgres CteRowT +modelDeleteWithStatement deleteId = Pg.pgDeleteWith $ do + targetIds <- Pg.pgSelecting $ do + row <- all_ (dbCteRows cteDb) + guard_ (cteId row ==. val_ deleteId) + pure (cteId row) + pure $ delete (dbCteRows cteDb) $ \row -> exists_ $ do + targetId <- reuse targetIds + guard_ (cteId row ==. targetId) + pure targetId + +recursiveCteModelSelect + :: Int32 + -> Int32 + -> SqlSelect Postgres (CteRowT Identity) +recursiveCteModelSelect startId endId = Pg.pgSelectWithTopLevel $ do + recursiveIds <- Pg.pgToTopLevel $ mdo + ids <- Pg.pgSelecting $ + pure (as_ @Int32 (val_ startId)) `unionAll_` do + previousId <- reuse ids + guard_ (previousId <. val_ endId) + pure (previousId + 1) + pure ids + + deletedRows <- Pg.cteDeleteReturning + (dbCteRows cteDb) + (\row -> exists_ $ do + recursiveId <- reuse recursiveIds + guard_ (cteId row ==. recursiveId) + pure recursiveId) + id + + pure (reuse deletedRows) + +nestedSelectCteSelect :: SqlSelect Postgres (CteRowT Identity) +nestedSelectCteSelect = select $ Pg.pgSelectWith $ do + selected <- selecting $ do + row <- all_ (dbCteRows cteDb) + guard_ (cteId row ==. val_ 1) + pure row + pure (reuse selected) + +-- PostgreSQL permits a recursive SELECT CTE to feed a later modifying CTE, but +-- not a modifying CTE to recursively reference itself. 'pgToTopLevel' closes the +-- recursive SELECT knot before the DELETE is added. +recursiveSelectThenDeleteCteSelect :: SqlSelect Postgres (CteRowT Identity) +recursiveSelectThenDeleteCteSelect = Pg.pgSelectWithTopLevel $ do + recursiveIds <- Pg.pgToTopLevel $ mdo + ids <- Pg.pgSelecting $ + pure (as_ @Int32 (val_ 1)) `unionAll_` do + previousId <- reuse ids + guard_ (previousId <. val_ 2) + pure (previousId + 1) + pure ids + + deleted <- Pg.cteDeleteReturning + (dbCteRows cteDb) + (\row -> exists_ $ do + recursiveId <- reuse recursiveIds + guard_ (cteId row ==. recursiveId) + pure recursiveId) + id + + pure (reuse deleted) + +-- Empty INSERT values and identity UPDATE assignments do not produce SQL. +-- Their wrappers return Nothing, leaving pgSelectWithTopLevel to render the +-- final query without an empty WITH clause. +emptyDataModifyingCteSelect :: SqlSelect Postgres Int32 +emptyDataModifyingCteSelect = Pg.pgSelectWithTopLevel $ do + inserted <- Pg.cteInsertReturning + (dbCteRows cteDb) + SqlInsertValuesEmpty + Pg.onConflictDefault + id + updated <- Pg.cteUpdateReturning + (dbCteRows cteDb) + (const mempty) + (const (val_ True)) + id + case (inserted, updated) of + (Nothing, Nothing) -> pure finalQuery + _ -> error "Expected empty INSERT and UPDATE CTEs" + where + finalQuery :: Q Postgres CteDb QBaseScope (QExpr Postgres QBaseScope Int32) + finalQuery = pure (val_ 1) + +-- The portable builder reaches PostgreSQL through the SQL99-shaped compatibility +-- instance. Each input table row contributes one row to the reusable +-- degree-zero relation even though the projection contains no values. +emptySelectProjection :: SqlSelect Postgres (EmptyCteT Identity) +emptySelectProjection = selectWith $ do + rows <- selecting $ do + _ <- all_ (dbCteRows cteDb) + pure (EmptyCte :: EmptyCteT (QExpr Postgres CTE.QAnyScope)) + pure (reuse rows) + +-- The native SELECT path additionally carries PostgreSQL's materialization +-- policy. Its logical result is identical for all three policies. +emptyNativeSelectProjection + :: Pg.PgCteMaterialization + -> SqlSelect Postgres (EmptyCteT Identity) +emptyNativeSelectProjection materialization = Pg.pgSelectWithTopLevel $ do + rows <- Pg.pgSelectingWith materialization $ do + _ <- all_ (dbCteRows cteDb) + pure (EmptyCte :: EmptyCteT (QExpr Postgres CTE.QAnyScope)) + pure (reuse rows) + +-- SELECT CTEs remain nestable when their relation has degree zero. +nestedEmptySelectProjection :: SqlSelect Postgres (EmptyCteT Identity) +nestedEmptySelectProjection = select $ Pg.pgSelectWithNested $ do + rows <- Pg.pgSelecting $ do + _ <- all_ (dbCteRows cteDb) + pure (EmptyCte :: EmptyCteT (QExpr Postgres CTE.QAnyScope)) + pure (reuse rows) + +-- COUNT(*) and EXISTS do not need a projected field, so they are natural +-- consumers of a degree-zero relation. Both references share one CTE body. +emptySelectSummary :: SqlSelect Postgres (Int32, Bool) +emptySelectSummary = Pg.pgSelectWithTopLevel $ do + rows <- Pg.pgSelecting $ do + _ <- all_ (dbCteRows cteDb) + pure (EmptyCte :: EmptyCteT (QExpr Postgres CTE.QAnyScope)) + pure $ do + count <- aggregate_ (const (as_ @Int32 countAll_)) (reuse rows) + pure (count, exists_ (reuse rows)) + +-- The next three fixtures deliberately return no logical values. PostgreSQL's +-- RETURNING grammar is satisfied internally, while the outer SELECT exposes no +-- physical columns and retains one row per affected table row. +emptyInsertProjection + :: [CteRowT Identity] + -> SqlSelect Postgres (EmptyCteT Identity) +emptyInsertProjection values = Pg.pgSelectWithTopLevel $ do + rows <- Pg.cteInsertReturning + (dbCteRows cteDb) + (insertValues values) + Pg.onConflictDefault + (const (EmptyCte :: EmptyCteT (QExpr Postgres PostgresInaccessible))) + case rows of + Just rows' -> pure (reuse rows') + Nothing -> error "Expected non-empty INSERT values" + +emptyUpdateProjection + :: Int32 + -> Text + -> SqlSelect Postgres (EmptyCteT Identity) +emptyUpdateProjection maximumId value = Pg.pgSelectWithTopLevel $ do + rows <- Pg.cteUpdateReturning + (dbCteRows cteDb) + (\row -> cteValue row <-. val_ value) + (\row -> cteId row <=. val_ maximumId) + (const (EmptyCte :: EmptyCteT (QExpr Postgres PostgresInaccessible))) + case rows of + Just rows' -> pure (reuse rows') + Nothing -> error "Expected a non-identity UPDATE" + +emptyDeleteProjection + :: Int32 + -> SqlSelect Postgres (EmptyCteT Identity) +emptyDeleteProjection minimumId = Pg.pgSelectWithTopLevel $ do + rows <- Pg.cteDeleteReturning + (dbCteRows cteDb) + (\row -> cteId row >=. val_ minimumId) + (const (EmptyCte :: EmptyCteT (QExpr Postgres PostgresInaccessible))) + pure (reuse rows) + +-- Two references to the same modifying CTE must multiply its row cardinality, +-- not execute the DELETE twice or expose its private sentinel. +repeatedEmptyDeleteProjection :: SqlSelect Postgres (EmptyCteT Identity) +repeatedEmptyDeleteProjection = Pg.pgSelectWithTopLevel $ do + rows <- Pg.cteDeleteReturning + (dbCteRows cteDb) + (const (val_ True)) + (const (EmptyCte :: EmptyCteT (QExpr Postgres PostgresInaccessible))) + pure $ do + _ <- reuse rows + _ <- reuse rows + pure (EmptyCte :: EmptyCteT (QExpr Postgres QBaseScope)) + +-- Aggregating the reusable DELETE result verifies that the private physical +-- sentinel supplies relational rows without becoming a Beam expression. +emptyDeleteSummary :: SqlSelect Postgres (Int32, Bool) +emptyDeleteSummary = Pg.pgSelectWithTopLevel $ do + rows <- Pg.cteDeleteReturning + (dbCteRows cteDb) + (const (val_ True)) + (const (EmptyCte :: EmptyCteT (QExpr Postgres PostgresInaccessible))) + pure $ do + count <- aggregate_ (const (as_ @Int32 countAll_)) (reuse rows) + pure (count, exists_ (reuse rows)) + +-- Copy one row selected by the CTE into a new row. insertFrom is what exposes +-- the reusable query to the terminal INSERT source. +insertWithStatement :: SqlInsert Postgres CteRowT +insertWithStatement = Pg.pgInsertWith $ do + source <- Pg.pgSelecting $ do + row <- all_ (dbCteRows cteDb) + guard_ (cteId row ==. val_ 1) + pure row + pure $ Pg.insert + (dbCteRows cteDb) + (insertFrom $ do + row <- reuse source + pure (CteRow (cteId row + 1) (val_ "inserted-with"))) + Pg.onConflictDefault + +-- Select the target key independently, then reference it through EXISTS in +-- the terminal UPDATE predicate. +updateWithStatement :: SqlUpdate Postgres CteRowT +updateWithStatement = Pg.pgUpdateWith $ do + targets <- Pg.pgSelecting $ do + row <- all_ (dbCteRows cteDb) + guard_ (cteId row ==. val_ 3) + pure (cteId row) + pure $ update + (dbCteRows cteDb) + (\row -> cteValue row <-. val_ "updated-with") + (\row -> exists_ $ do + targetId <- reuse targets + guard_ (cteId row ==. targetId) + pure targetId) + +-- The DELETE form uses the same reusable-key pattern as UPDATE, exercising +-- the third terminal syntax wrapper. +deleteWithStatement :: SqlDelete Postgres CteRowT +deleteWithStatement = Pg.pgDeleteWith $ do + targets <- Pg.pgSelecting $ do + row <- all_ (dbCteRows cteDb) + guard_ (cteId row ==. val_ 4) + pure (cteId row) + pure $ delete (dbCteRows cteDb) $ \row -> exists_ $ do + targetId <- reuse targets + guard_ (cteId row ==. targetId) + pure targetId + +-- Recursion is completed while the block is still nested-safe. The terminal +-- INSERT then consumes the recursive result at top level. +recursiveInsertWithStatement :: SqlInsert Postgres CteRowT +recursiveInsertWithStatement = Pg.pgInsertWith recursiveInsertWith + +recursiveInsertWith + :: Pg.PgWith CteDb 'Pg.PgCteNestedAllowed (SqlInsert Postgres CteRowT) +recursiveInsertWith = mdo + ids <- Pg.pgSelecting $ + pure (as_ @Int32 (val_ 1)) `unionAll_` do + previousId <- reuse ids + guard_ (previousId <. val_ 2) + pure (previousId + 1) + pure $ Pg.insert + (dbCteRows cteDb) + (insertFrom $ do + rowId <- reuse ids + pure (CteRow rowId (val_ "recursive"))) + Pg.onConflictDefault + +-- Adding a modifying CTE fixes the block to PgCteTopLevelOnly. pgDeleteWith is +-- a top-level consumer, so this remains well-typed. +topLevelOnlyDeleteWithStatement :: SqlDelete Postgres CteRowT +topLevelOnlyDeleteWithStatement = Pg.pgDeleteWith $ do + _ <- Pg.cteDeleteReturning + (dbCteRows cteDb) + (\row -> cteId row ==. val_ 99) + id + pure $ delete + (dbCteRows cteDb) + (\row -> cteId row ==. val_ 100) + +emptyInsertWithStatement :: SqlInsert Postgres CteRowT +emptyInsertWithStatement = Pg.pgInsertWith $ do + _ <- Pg.pgSelecting $ all_ (dbCteRows cteDb) + pure $ Pg.insert + (dbCteRows cteDb) + SqlInsertValuesEmpty + Pg.onConflictDefault + +identityUpdateWithStatement :: SqlUpdate Postgres CteRowT +identityUpdateWithStatement = Pg.pgUpdateWith $ do + _ <- Pg.pgSelecting $ all_ (dbCteRows cteDb) + pure $ update + (dbCteRows cteDb) + (const mempty) + (const (val_ True)) + +assertWithTerminal + :: String + -> Maybe String + -> Assertion +assertWithTerminal terminal rendered = do + sql <- requireRenderedStatement rendered + assertBool "starts with WITH" ("WITH " `isPrefixOf` sql) + assertBool ("renders terminal " ++ terminal) ((" " ++ terminal) `isInfixOf` sql) + +requireRenderedStatement + :: Maybe String + -> IO String +requireRenderedStatement rendered = + case rendered of + Nothing -> assertFailure "expected a PostgreSQL statement" >> pure "" + Just sql -> pure sql + +renderInsert :: SqlInsert Postgres table -> Maybe String +renderInsert SqlInsertNoRows = Nothing +renderInsert (SqlInsert _ (PgInsertSyntax syntax)) = + Just (BL.unpack (pgRenderSyntaxScript syntax)) + +renderUpdate :: SqlUpdate Postgres table -> Maybe String +renderUpdate SqlIdentityUpdate = Nothing +renderUpdate (SqlUpdate _ (PgUpdateSyntax syntax)) = + Just (BL.unpack (pgRenderSyntaxScript syntax)) + +renderDelete :: SqlDelete Postgres table -> Maybe String +renderDelete (SqlDelete _ (PgDeleteSyntax syntax)) = + Just (BL.unpack (pgRenderSyntaxScript syntax)) + +assertReturning :: String -> Maybe String -> Assertion +assertReturning command rendered = do + sql <- requireRenderedStatement rendered + assertBool (command ++ " retains its WITH prefix") ("WITH " `isPrefixOf` sql) + assertBool (command ++ " renders RETURNING") (" RETURNING " `isInfixOf` sql) + +renderInsertReturning :: Pg.PgInsertReturning a -> Maybe String +renderInsertReturning Pg.PgInsertReturningEmpty = Nothing +renderInsertReturning (Pg.PgInsertReturning syntax) = + Just (BL.unpack (pgRenderSyntaxScript syntax)) + +renderUpdateReturning :: Pg.PgUpdateReturning a -> Maybe String +renderUpdateReturning Pg.PgUpdateReturningEmpty = Nothing +renderUpdateReturning (Pg.PgUpdateReturning syntax) = + Just (BL.unpack (pgRenderSyntaxScript syntax)) + +renderDeleteReturning :: Pg.PgDeleteReturning a -> Maybe String +renderDeleteReturning (Pg.PgDeleteReturning syntax) = + Just (BL.unpack (pgRenderSyntaxScript syntax)) + +renderSelect :: SqlSelect Postgres a -> String +renderSelect = BL.unpack . renderSelectBytes + +renderSelectBytes :: SqlSelect Postgres a -> BL.ByteString +renderSelectBytes (SqlSelect (PgSelectSyntax syntax)) = + pgRenderSyntaxScript syntax diff --git a/test/Database/Beam/Postgres/Test/CTENegative.hs b/test/Database/Beam/Postgres/Test/CTENegative.hs new file mode 100644 --- /dev/null +++ b/test/Database/Beam/Postgres/Test/CTENegative.hs @@ -0,0 +1,180 @@ +{-# OPTIONS_GHC -fdefer-type-errors -Wno-deferred-type-errors #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE StandaloneDeriving #-} + +-- This module deliberately contains expressions which must not type-check. +-- Deferred type errors are isolated here so the positive CTE tests retain +-- normal, strict type checking. +module Database.Beam.Postgres.Test.CTENegative + ( invalidNestedDelete + , invalidNestedInsert + , invalidNestedUpdate + , invalidNestedSelectThenDelete + , invalidNestedDeleteThenSelect + , invalidNestedEmptyInsert + , invalidNestedIdentityUpdate + , invalidNestedSideEffectDelete + , invalidCoercedPlacement + , invalidRecursiveInsert + , invalidReuseSideEffect + ) where + +import qualified Data.Coerce as Coerce +import Data.Int (Int32) +import Data.Text (Text) + +import Database.Beam +import Database.Beam.Postgres +import qualified Database.Beam.Postgres.Full as Pg +import qualified Database.Beam.Query.CTE as CTE + +data NegativeCteRowT f = NegativeCteRow + { negativeCteId :: C f Int32 + , negativeCteValue :: C f Text + } deriving (Generic, Beamable) + +deriving instance Show (NegativeCteRowT Identity) +deriving instance Eq (NegativeCteRowT Identity) + +instance Table NegativeCteRowT where + data PrimaryKey NegativeCteRowT f = NegativeCteRowKey (C f Int32) + deriving (Generic, Beamable) + primaryKey = NegativeCteRowKey . negativeCteId + +newtype NegativeCteDb entity = NegativeCteDb + { negativeCteRows :: entity (TableEntity NegativeCteRowT) + } deriving (Generic, Database Postgres) + +negativeCteDb :: DatabaseSettings Postgres NegativeCteDb +negativeCteDb = defaultDbSettings + +-- Each of the following three expressions attempts to put a modifying CTE in +-- pgSelectWithNested. They must fail with PgCteTopLevelOnly versus +-- PgCteNestedAllowed, +-- independently of which data-modifying command produced the CTE. +invalidNestedDelete :: SqlSelect Postgres (NegativeCteRowT Identity) +invalidNestedDelete = select $ Pg.pgSelectWithNested $ do + deleted <- topLevelDeleteCte + pure (reuse deleted) + +invalidNestedInsert :: SqlSelect Postgres (NegativeCteRowT Identity) +invalidNestedInsert = select $ Pg.pgSelectWithNested $ do + inserted <- Pg.cteInsertReturning + (negativeCteRows negativeCteDb) + (insertValues [NegativeCteRow 2 "inserted"]) + Pg.onConflictDefault + id + case inserted of + Nothing -> pure $ all_ (negativeCteRows negativeCteDb) + Just inserted' -> pure (reuse inserted') + +invalidNestedUpdate :: SqlSelect Postgres (NegativeCteRowT Identity) +invalidNestedUpdate = select $ Pg.pgSelectWithNested $ do + updated <- Pg.cteUpdateReturning + (negativeCteRows negativeCteDb) + (\row -> negativeCteValue row <-. val_ "updated") + (\row -> negativeCteId row ==. val_ 1) + id + case updated of + Nothing -> pure $ all_ (negativeCteRows negativeCteDb) + Just updated' -> pure (reuse updated') + +-- Placement is a property of the whole With block. Reordering a normal SELECT +-- CTE around the DELETE must not weaken the top-level-only requirement. +invalidNestedSelectThenDelete :: SqlSelect Postgres (NegativeCteRowT Identity) +invalidNestedSelectThenDelete = select $ Pg.pgSelectWithNested $ do + _ <- nestedSelectCte + deleted <- topLevelDeleteCte + pure (reuse deleted) + +invalidNestedDeleteThenSelect :: SqlSelect Postgres (NegativeCteRowT Identity) +invalidNestedDeleteThenSelect = select $ Pg.pgSelectWithNested $ do + deleted <- topLevelDeleteCte + _ <- nestedSelectCte + pure (reuse deleted) + +-- The result is conservatively top-level-only even when the supplied values or +-- assignments make the INSERT or UPDATE a no-op. The placement index cannot +-- vary with that value-level outcome. +invalidNestedEmptyInsert :: SqlSelect Postgres (NegativeCteRowT Identity) +invalidNestedEmptyInsert = select $ Pg.pgSelectWithNested $ do + inserted <- Pg.cteInsertReturning + (negativeCteRows negativeCteDb) + SqlInsertValuesEmpty + Pg.onConflictDefault + id + case inserted of + Nothing -> pure $ all_ (negativeCteRows negativeCteDb) + Just inserted' -> pure (reuse inserted') + +invalidNestedIdentityUpdate :: SqlSelect Postgres (NegativeCteRowT Identity) +invalidNestedIdentityUpdate = select $ Pg.pgSelectWithNested $ do + updated <- Pg.cteUpdateReturning + (negativeCteRows negativeCteDb) + (const mempty) + (const (val_ True)) + id + case updated of + Nothing -> pure $ all_ (negativeCteRows negativeCteDb) + Just updated' -> pure (reuse updated') + +-- A no-RETURNING modifying CTE has the same top-level placement requirement as +-- its returning counterpart, even though it exposes no relation. +invalidNestedSideEffectDelete :: SqlSelect Postgres (NegativeCteRowT Identity) +invalidNestedSideEffectDelete = select $ Pg.pgSelectWithNested $ do + Pg.cteDelete + (negativeCteRows negativeCteDb) + (\row -> negativeCteId row ==. val_ 1) + pure $ all_ (negativeCteRows negativeCteDb) + +-- PgWith has nominal roles and an abstract constructor, so Data.Coerce cannot +-- be used to relabel a top-level-only block as nested-safe. +invalidCoercedPlacement :: SqlSelect Postgres (NegativeCteRowT Identity) +invalidCoercedPlacement = select $ Pg.pgSelectWithNested $ coercePlacement $ do + deleted <- topLevelDeleteCte + pure (reuse deleted) + +-- MonadFix exists only for PgCteNestedAllowed. This prevents an INSERT CTE from +-- reading its own RETURNING rows recursively, which PostgreSQL rejects. +invalidRecursiveInsert :: SqlSelect Postgres (NegativeCteRowT Identity) +invalidRecursiveInsert = Pg.pgSelectWithTopLevel $ mdo + ~(Just inserted) <- Pg.cteInsertReturning + (negativeCteRows negativeCteDb) + (insertFrom (reuse inserted)) + Pg.onConflictDefault + id + pure (reuse inserted) + +-- Side-effect-only CTEs deliberately return unit because a DML statement +-- without RETURNING forms no temporary relation in PostgreSQL. +invalidReuseSideEffect :: SqlSelect Postgres (NegativeCteRowT Identity) +invalidReuseSideEffect = Pg.pgSelectWithTopLevel $ do + deleted <- Pg.cteDelete + (negativeCteRows negativeCteDb) + (\row -> negativeCteId row ==. val_ 1) + let impossible + :: ReusableQ Postgres NegativeCteDb + (NegativeCteRowT (QExpr Postgres CTE.QAnyScope)) + impossible = deleted + pure (reuse impossible) + +coercePlacement + :: Pg.PgWith NegativeCteDb 'Pg.PgCteTopLevelOnly a + -> Pg.PgWith NegativeCteDb 'Pg.PgCteNestedAllowed a +coercePlacement = Coerce.coerce + +nestedSelectCte + :: Pg.PgWith NegativeCteDb placement + (ReusableQ Postgres NegativeCteDb + (NegativeCteRowT (QExpr Postgres CTE.QAnyScope))) +nestedSelectCte = Pg.pgSelecting $ all_ (negativeCteRows negativeCteDb) + +topLevelDeleteCte + :: Pg.PgWith NegativeCteDb 'Pg.PgCteTopLevelOnly + (ReusableQ Postgres NegativeCteDb + (NegativeCteRowT (QExpr Postgres CTE.QAnyScope))) +topLevelDeleteCte = Pg.cteDeleteReturning + (negativeCteRows negativeCteDb) + (\row -> negativeCteId row ==. val_ 1) + id diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,13 +1,14 @@ module Main where -import Data.ByteString ( ByteString ) -import Data.Text ( unpack ) +import Data.ByteString (ByteString) +import Data.Text (unpack) import qualified Data.Text.Lazy as TL import Test.Tasty import qualified TestContainers.Tasty as TC import qualified Database.Beam.Postgres.Test.Copy as Copy +import qualified Database.Beam.Postgres.Test.CTE as CTE import qualified Database.Beam.Postgres.Test.DataTypes as DataType import qualified Database.Beam.Postgres.Test.Marshal as Marshal import qualified Database.Beam.Postgres.Test.Migrate as Migrate @@ -15,44 +16,52 @@ import qualified Database.Beam.Postgres.Test.Select.PgNubBy as Select.PgNubBy 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 Database.PostgreSQL.Simple (ConnectInfo(..), defaultConnectInfo) import qualified Database.PostgreSQL.Simple as Postgres main :: IO () -main = defaultMain - $ TC.withContainers setupTempPostgresDB - $ \getConnStr -> - testGroup "beam-postgres tests" - [ Marshal.tests getConnStr - , Select.tests getConnStr - , Select.PgNubBy.tests getConnStr - , DataType.tests getConnStr - , Migrate.tests getConnStr - , TempTable.tests getConnStr - , Windowing.tests getConnStr - , Copy.tests getConnStr - ] +main = defaultMain $ testGroup "beam-postgres tests" + -- Rendering and compile-negative tests do not need Docker, so keep them + -- outside the Testcontainers resource and available as fast unit tests. + [ CTE.unitTests + , TC.withContainers setupTempPostgresDB $ \getConnStr -> + testGroup "PostgreSQL integration tests" + [ Marshal.tests getConnStr + , CTE.integrationTests getConnStr + , Select.tests getConnStr + , Select.PgNubBy.tests getConnStr + , DataType.tests getConnStr + , Migrate.tests getConnStr + , TempTable.tests getConnStr + , Windowing.tests getConnStr + , Copy.tests getConnStr + ] + ] setupTempPostgresDB :: TC.MonadDocker m => m ByteString setupTempPostgresDB = do - let user = "postgres" - password = "root" - db = "testdb" + let user = "postgres" + password = "root" + db = "testdb" - timescaleContainer <- TC.run $ TC.containerRequest (TC.fromTag "postgres:16.4") - TC.& TC.setExpose [ 5432 ] - TC.& TC.setEnv [ ("POSTGRES_USER", user) - , ("POSTGRES_PASSWORD", password) - , ("POSTGRES_DB", db) - ] - TC.& TC.setWaitingFor (TC.waitForLogLine TC.Stderr ("database system is ready to accept connections" `TL.isInfixOf`)) + -- Pin the server version so normal CI runs are reproducible. + postgresContainer <- TC.run $ + TC.containerRequest (TC.fromTag "postgres:18.4") + TC.& TC.setExpose [5432] + TC.& TC.setEnv + [ ("POSTGRES_USER", user) + , ("POSTGRES_PASSWORD", password) + , ("POSTGRES_DB", db) + ] + TC.& TC.setWaitingFor + (TC.waitForLogLine TC.Stderr + ("database system is ready to accept connections" `TL.isInfixOf`)) - pure $ Postgres.postgreSQLConnectionString - ( defaultConnectInfo { connectHost = "localhost" - , connectUser = unpack user - , connectPassword = unpack password - , connectDatabase = unpack db - , connectPort = fromIntegral $ TC.containerPort timescaleContainer 5432 - } - ) + pure $ Postgres.postgreSQLConnectionString defaultConnectInfo + { connectHost = "localhost" + , connectUser = unpack user + , connectPassword = unpack password + , connectDatabase = unpack db + , connectPort = fromIntegral $ TC.containerPort postgresContainer 5432 + }