diff --git a/beam-postgres/ChangeLog.md b/beam-postgres/ChangeLog.md index b112de75..0761c22d 100644 --- a/beam-postgres/ChangeLog.md +++ b/beam-postgres/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 @@ -8,11 +38,6 @@ * 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 ## Added features diff --git a/beam-postgres/Database/Beam/Postgres/Full.hs b/beam-postgres/Database/Beam/Postgres/Full.hs index 7552f2cb..e60d820b 100644 --- a/beam-postgres/Database/Beam/Postgres/Full.hs +++ b/beam-postgres/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 @@ module Database.Beam.Postgres.Full , 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 @@ module Database.Beam.Postgres.Full -- * @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.Schema.Tables 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 @@ insertReturning (DatabaseEntity tbl@(DatabaseTable {})) 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 @@ lateral_ using mkSubquery = do (\_ -> 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 @@ lateral_ using mkSubquery = do -- 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 @@ pgSelectWith (CTE.With mkQ) = (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 @@ updateReturning table@(DatabaseEntity (DatabaseTable { dbTableSettings = tblSett 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 @@ -429,6 +1144,88 @@ deleteReturning table@(DatabaseEntity (DatabaseTable { dbTableSettings = tblSett 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 , BeamSqlBackendSyntax be ~ PgCommandSyntax diff --git a/beam-postgres/Database/Beam/Postgres/Syntax.hs b/beam-postgres/Database/Beam/Postgres/Syntax.hs index fc6e888c..582443e1 100644 --- a/beam-postgres/Database/Beam/Postgres/Syntax.hs +++ b/beam-postgres/Database/Beam/Postgres/Syntax.hs @@ -21,7 +21,7 @@ module Database.Beam.Postgres.Syntax , emit, emitBuilder, escapeString , escapeBytea, escapeIdentifier - , pgParens + , pgParens, PgCteRecursiveness(..), pgWithSyntax , pgStringLit, pgCharLit, pgBoolLit , nextSyntaxStep @@ -30,6 +30,7 @@ module Database.Beam.Postgres.Syntax , PgInsertSyntax(..) , PgDeleteSyntax(..) , PgUpdateSyntax(..) + , PgCommonTableExpressionSyntax(..) , PgExpressionSyntax(..), PgFromSyntax(..), PgTableNameSyntax(..) , PgComparisonQuantifierSyntax(..) @@ -272,9 +273,54 @@ data PgOrderingSyntax = PgOrderingSyntax { pgOrderingSyntax :: PgSyntax, pgOrder 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 @@ instance IsSql99CommonTableExpressionSelectSyntax PgSelectSyntax where 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 @@ pgRenderSyntaxScript (PgSyntax mkQuery) = where quoteIdentifierChar '"' = char8 '"' <> char8 '"' quoteIdentifierChar c = char8 c - diff --git a/beam-postgres/beam-postgres.cabal b/beam-postgres/beam-postgres.cabal index 6e14d6db..59801750 100644 --- a/beam-postgres/beam-postgres.cabal +++ b/beam-postgres/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 @@ test-suite beam-postgres-tests 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/beam-postgres/test/Database/Beam/Postgres/Test.hs b/beam-postgres/test/Database/Beam/Postgres/Test.hs index 2681ad8f..29d97150 100644 --- a/beam-postgres/test/Database/Beam/Postgres/Test.hs +++ b/beam-postgres/test/Database/Beam/Postgres/Test.hs @@ -13,19 +13,22 @@ withTestPostgres :: String -> IO ByteString -> (Pg.Connection -> IO a) -> IO a 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/beam-postgres/test/Database/Beam/Postgres/Test/CTE.hs b/beam-postgres/test/Database/Beam/Postgres/Test/CTE.hs new file mode 100644 index 00000000..e228434e --- /dev/null +++ b/beam-postgres/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/beam-postgres/test/Database/Beam/Postgres/Test/CTENegative.hs b/beam-postgres/test/Database/Beam/Postgres/Test/CTENegative.hs new file mode 100644 index 00000000..2739b93a --- /dev/null +++ b/beam-postgres/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/beam-postgres/test/Main.hs b/beam-postgres/test/Main.hs index 8582442b..a6252acd 100644 --- a/beam-postgres/test/Main.hs +++ b/beam-postgres/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 as Select 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" - - 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`)) - - pure $ Postgres.postgreSQLConnectionString - ( defaultConnectInfo { connectHost = "localhost" - , connectUser = unpack user - , connectPassword = unpack password - , connectDatabase = unpack db - , connectPort = fromIntegral $ TC.containerPort timescaleContainer 5432 - } - ) + let user = "postgres" + password = "root" + db = "testdb" + + -- 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 postgresContainer 5432 + } diff --git a/docs/user-guide/backends/beam-postgres.md b/docs/user-guide/backends/beam-postgres.md index 3f9d0388..91c37b4c 100644 --- a/docs/user-guide/backends/beam-postgres.md +++ b/docs/user-guide/backends/beam-postgres.md @@ -276,10 +276,9 @@ runInsert $ ### Inner CTEs -Standard SQL only allows CTEs (`WITH` expressions) at the top-level SELECT. However, PostgreSQL -allows them anywhere, including in subqueries for joins. - -For example, the following is valid Postgres, but not valid standard SQL. +`beam-core`'s `selectWith` produces a top-level `SqlSelect`. PostgreSQL also accepts a SELECT-only +`WITH` query in a derived table, which is useful when the result must participate in a larger Beam +query. For example: ```sql SELECT a.column1, b.column2 @@ -287,13 +286,195 @@ FROM (WITH RECURSIVE ... SELECT ...) a INNER JOIN b ``` -`beam-core` enforces this by forcing `selectWith` to only return a `SqlSelect`, which represents a -top-level SQL `SELECT` statement that can be executed against a backend. However, if we want to -allow `WITH` expressions to appear within joins, then we will need a function similar to -`selectWith` but returning a `Q` value, which is a re-usable query. `beam-postgres` provides this -function for PostgreSQL, named `pgSelectWith`. For `beam-postgres`, `select (pgSelectWith x)` is -equivalent to `selectWith x`. But, with the new type, we can reuse CTEs (including recursive ones) -within other queries. +`beam-postgres` provides `pgSelectWith` for this placement. It returns a `Q` value, so its result can +be reused in joins. Calling `select (pgSelectWith x)` projects the same rows as `selectWith x`, but +the generated SQL contains the derived-table wrapper shown above. `pgSelectWith` is useful precisely +when that nested `Q` is required. + +### PostgreSQL-specific CTEs + +PostgreSQL requires data-modifying CTEs to appear in a `WITH` clause attached to the top-level +statement. `Database.Beam.Postgres.Full` provides `PgWith`, whose `PgCteNestedAllowed` +and `PgCteTopLevelOnly` indices record that placement rule. `pgSelectWithNested` accepts only the +nested-safe form; `pgSelectWithTopLevel`, `pgInsertWith`, `pgUpdateWith`, and `pgDeleteWith` accept +either form because they all produce top-level statements. The existing portable `selecting`, +`selectWith`, and `pgSelectWith` APIs keep their existing types; the PostgreSQL-specific builders +are additive. + +The examples in this section use `Database.Beam.Postgres.Full`, qualified as `Pg`, which exports +these PostgreSQL-specific statement builders. + +Use `pgSelecting` to define an ordinary SELECT CTE in `PgWith`. Existing helpers returning +`With Postgres` can be composed without rewriting them by applying `pgLiftWith`; lifted and native +CTEs share one name supply. For example, if one native CTE precedes a portable helper containing two +CTEs, the generated names continue through the lifted action: + +!beam-query +```haskell +!example chinookdml only:Postgres +rows <- runSelectReturningList $ Pg.pgSelectWithTopLevel $ do + nativeRows <- Pg.pgSelecting $ + pure (as_ @Int32 (val_ 1)) + portableRows <- Pg.pgLiftWith $ do + first <- selecting $ + pure (as_ @Int32 (val_ 2)) + selecting $ do + value <- reuse first + pure (value + 1) + pure $ (,) <$> reuse nativeRows <*> reuse portableRows +putStrLn (show rows) +``` + +PostgreSQL 12 and later also support explicit materialization: + +!beam-query +```haskell +!example chinookdml only:Postgres +rows <- runSelectReturningList $ Pg.pgSelectWithTopLevel $ do + materializedRows <- Pg.pgSelectingWith Pg.PgCteMaterialized $ + pure (as_ @Int32 (val_ 1), as_ @Int32 (val_ 2)) + pure (reuse materializedRows) +putStrLn (show rows) +``` + +`PgCteDefault` emits no modifier and leaves the choice to PostgreSQL. `PgCteMaterialized` requests +separate calculation of the CTE, which can act as an optimization fence or prevent duplicated +computation. `PgCteNotMaterialized` allows the CTE and parent query to be optimized together, but +may duplicate work. PostgreSQL ignores `NOT MATERIALIZED` for recursive or non-side-effect-free +queries. These rules, and the default behavior for single and multiple references, are described in +the [PostgreSQL CTE materialization documentation](https://www.postgresql.org/docs/current/queries-with.html#QUERIES-WITH-CTE-MATERIALIZATION). + +`cteInsertReturning`, `cteUpdateReturning`, and `cteDeleteReturning` put the corresponding +`... RETURNING` statement in a CTE and return a `ReusableQ` handle to its output. Later CTEs or the +final statement can read that output with `reuse`. Their side-effect-only counterparts, +`cteInsert`, `cteUpdate`, and `cteDelete`, omit `RETURNING` and therefore return `()`: + +!beam-query +```haskell +!example chinookdml only:Postgres +rows <- runSelectReturningList $ Pg.pgSelectWithTopLevel $ do + Pg.cteDelete + (playlist chinookDb) + (\row -> playlistId row ==. val_ 1000001) + inserted <- Pg.cteInsertReturning + (playlist chinookDb) + (insertValues [Playlist 1000000 (Just "PostgreSQL CTE example")]) + Pg.onConflictDefault + id + case inserted of + Nothing -> pure $ + filter_ (const (val_ False)) $ all_ (playlist chinookDb) + Just rows -> pure (reuse rows) +putStrLn (show rows) +``` + +The generated statement contains both modifications in one `WITH` block. The first definition has +no output column list because it has no `RETURNING` output. The second exposes its `RETURNING` +output through generated column names, so it can be reused. + +#### Zero-column CTE projections + +A Beam projection may have no fields—for example, a custom `Beamable` product with a single +constructor and no record fields. Such a result is still a relation: it has no columns, but it has +one row for every input row. `selecting`, `pgSelecting`, and `pgSelectingWith` preserve that +cardinality. A projection type and query can be written as follows (the helper signature lets the +query scope be inferred at each use): + +```haskell +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE KindSignatures #-} + +import Data.Kind (Type) +import GHC.Generics (Generic) + +data NoColumns (f :: Type -> Type) = NoColumns + deriving (Generic, Beamable) + +noColumns :: NoColumns (QExpr Postgres scope) +noColumns = NoColumns + +degreeZeroPlaylists = Pg.pgSelectWithTopLevel $ do + rows <- Pg.pgSelecting $ do + _ <- all_ (playlist chinookDb) + pure noColumns + pure (reuse rows) +``` + +PostgreSQL represents the result by omitting the optional CTE column-alias list and by using a +SELECT with an empty target list: + +```sql +WITH "cte0" AS + (SELECT FROM "source" AS "t0") +SELECT FROM "cte0" AS "t0" +``` + +When this query is run with `runSelectReturningList`, its result contains one zero-field Haskell +value for every source row. The CTE can also be used with `EXISTS`, aggregation, or joins. Reusing +it twice in a Cartesian product multiplies its row count in the same way as any other relation; the +absence of columns does not make it a side-effect-only operation. The `MATERIALIZED` and +`NOT MATERIALIZED` policies have their normal meaning for a zero-column SELECT CTE. + +PostgreSQL requires a data-modifying `RETURNING` clause to contain an expression. Therefore, when +the projection supplied to `cteInsertReturning`, `cteUpdateReturning`, or `cteDeleteReturning` has +no fields, `beam-postgres` adds one private boolean result inside the CTE: + +```sql +WITH "cte0"("res0") AS + (DELETE FROM "source" AS "delete_target" + WHERE ... + RETURNING NULL::boolean) +SELECT FROM "cte0" AS "t0" +``` + +The private `res0` value is not selected or passed to the Haskell result decoder. It exists only to +satisfy PostgreSQL's grammar, and one sentinel row is returned for every affected row. This makes +the degree-zero relation useful for counting, existence checks, and repeated reuse. A statement +which affects no rows produces no result rows. + +When neither the final statement nor another CTE needs the rows affected by the operation, use +`cteInsert`, `cteUpdate`, or `cteDelete`. These functions omit `RETURNING` and therefore do not +produce a result that can be passed to `reuse`. + +The private-sentinel handling is specific to zero-field projections in these reusable CTE +builders. A standalone `returning` call still requires a projection containing at least one value. + +PostgreSQL executes every data-modifying CTE exactly once and to completion, even when its output +is not referenced. Sibling modifying statements use the same snapshot and cannot observe one +another's table changes; `RETURNING` rows are the supported way to communicate between them. Avoid +having sibling statements modify the same row, since PostgreSQL does not define which modification +wins. + +See PostgreSQL's [data-modifying `WITH` documentation](https://www.postgresql.org/docs/current/queries-with.html#QUERIES-WITH-MODIFYING) +for these execution and visibility rules. + +PostgreSQL also disallows a data-modifying CTE from recursively referring to itself. Recursive +construction is therefore limited to `PgCteNestedAllowed`. To let a recursive SELECT feed a later +modifying CTE, finish the recursive block and promote it with `pgToTopLevel` before adding the +modification. + +A PostgreSQL `WITH` statement may finish with `INSERT`, `UPDATE`, or `DELETE` instead of a final +SELECT. For example: + +!beam-query +```haskell +!example chinookdml only:Postgres +runInsert $ Pg.pgInsertWith $ do + playlistToInsert <- Pg.pgSelecting $ + filter_ (\source -> playlistId source ==. val_ 1) $ + all_ (playlist chinookDb) + pure $ Pg.insert + (playlist chinookDb) + (insertFrom (reuse playlistToInsert)) + (Pg.onConflict Pg.anyConflict Pg.onConflictDoNothing) +``` + +This produces one terminal `INSERT`, not a separate SELECT followed by an INSERT. + +An empty CTE insert or identity CTE update registers no definition. An empty terminal insert or +identity terminal update remains a no-op: PostgreSQL cannot execute a bare `WITH` block, so CTE +bodies accumulated before that missing terminal statement are not executed. As an example using our Chinook schema, suppose we had an error with all orders in the month of September 2024, and needed to send out employees to customer homes to correct the issue. We want to