From 4fbc6ae8a745127f046d8225e28094ffbf266996 Mon Sep 17 00:00:00 2001 From: Kushagra Gupta Date: Sat, 11 Jul 2026 05:19:05 +0000 Subject: [PATCH 01/10] Add support for Common Table Expressions (CTEs) in PostgreSQL backend - Introduced `pgWithSyntax` to prefix PostgreSQL statements with CTEs. - Added new types for data-modifying CTEs: `PgDataModifyingCommonTableExpressionSyntax` and `PgCommonTableExpressionSyntax`. - Implemented type classes for handling CTEs in SQL queries, ensuring correct placement of data-modifying CTEs. - Created unit and integration tests for rendering and type safety of CTEs, including negative tests for invalid placements. - Updated documentation to reflect new CTE capabilities and usage examples. - Modified test setup to use PostgreSQL version 18.4 for better compatibility. --- beam-core/ChangeLog.md | 13 + beam-core/Database/Beam/Backend/SQL.hs | 15 + beam-core/Database/Beam/Backend/SQL/SQL99.hs | 17 + beam-core/Database/Beam/Query.hs | 25 +- beam-core/Database/Beam/Query/CTE.hs | 142 ++++- beam-postgres/ChangeLog.md | 9 + beam-postgres/Database/Beam/Postgres/Full.hs | 252 ++++++++- .../Database/Beam/Postgres/Syntax.hs | 50 +- beam-postgres/beam-postgres.cabal | 2 + .../test/Database/Beam/Postgres/Test.hs | 13 +- .../test/Database/Beam/Postgres/Test/CTE.hs | 515 ++++++++++++++++++ .../Beam/Postgres/Test/CTENegative.hs | 155 ++++++ beam-postgres/test/Main.hs | 82 +-- docs/user-guide/backends/beam-postgres.md | 28 + 14 files changed, 1240 insertions(+), 78 deletions(-) create mode 100644 beam-postgres/test/Database/Beam/Postgres/Test/CTE.hs create mode 100644 beam-postgres/test/Database/Beam/Postgres/Test/CTENegative.hs diff --git a/beam-core/ChangeLog.md b/beam-core/ChangeLog.md index 21f678de0..776c5f3ca 100644 --- a/beam-core/ChangeLog.md +++ b/beam-core/ChangeLog.md @@ -1,5 +1,18 @@ # 0.11.2.0 +## Interface changes + +* Added a `CtePlacement` index to `With`. Ordinary `SELECT` CTEs are valid at + either placement, while backend-specific data-modifying CTEs are marked + `CteTopLevelOnly` so they cannot be embedded where a backend forbids them. + Recursive knots are restricted to nested-safe blocks; `toTopLevel` promotes a + completed recursive `SELECT` block for composition with data-modifying CTEs. + +## New features + +* Added backend capability and syntax classes for data-modifying common table + expressions. + ## Bug fixes * Fixed an issue where using `selectWith` and no common-table expressions would lead to diff --git a/beam-core/Database/Beam/Backend/SQL.hs b/beam-core/Database/Beam/Backend/SQL.hs index 017cfe6f5..50da0bf42 100644 --- a/beam-core/Database/Beam/Backend/SQL.hs +++ b/beam-core/Database/Beam/Backend/SQL.hs @@ -17,6 +17,7 @@ module Database.Beam.Backend.SQL , BeamSql99AggregationBackend , BeamSql99ConcatExpressionBackend , BeamSql99CommonTableExpressionBackend + , BeamSql99DataModifyingCommonTableExpressionBackend , BeamSql99RecursiveCTEBackend , BeamSql2003ExpressionBackend @@ -268,6 +269,20 @@ type BeamSql99CommonTableExpressionBackend be = , IsSql99CommonTableExpressionSelectSyntax (BeamSqlBackendSelectSyntax be) , IsSql99CommonTableExpressionSyntax (BeamSql99BackendCTESyntax be) , Sql99CTESelectSyntax (BeamSql99BackendCTESyntax be) ~ BeamSqlBackendSelectSyntax be ) +-- | A SQL99 CTE backend with an extension for data-modifying CTE bodies. +-- +-- This capability is separate from 'BeamSql99CommonTableExpressionBackend' +-- because SQL99 only requires a @SELECT@ as the CTE body. Backends with this +-- extension can additionally render statements such as: +-- +-- @ +-- WITH changed AS (UPDATE items SET active = FALSE RETURNING id) +-- SELECT id FROM changed +-- @ +type BeamSql99DataModifyingCommonTableExpressionBackend be = + ( BeamSql99CommonTableExpressionBackend be + , IsSql99DataModifyingCommonTableExpressionSyntax (BeamSql99BackendCTESyntax be) + ) type BeamSql99RecursiveCTEBackend be= ( BeamSql99CommonTableExpressionBackend be , IsSql99RecursiveCommonTableExpressionSelectSyntax (BeamSqlBackendSelectSyntax be) ) diff --git a/beam-core/Database/Beam/Backend/SQL/SQL99.hs b/beam-core/Database/Beam/Backend/SQL/SQL99.hs index c7a246703..e51f88a64 100644 --- a/beam-core/Database/Beam/Backend/SQL/SQL99.hs +++ b/beam-core/Database/Beam/Backend/SQL/SQL99.hs @@ -9,6 +9,7 @@ module Database.Beam.Backend.SQL.SQL99 , IsSql99AggregationExpressionSyntax(..) , IsSql99CommonTableExpressionSelectSyntax(..) , IsSql99CommonTableExpressionSyntax(..) + , IsSql99DataModifyingCommonTableExpressionSyntax(..) , IsSql99RecursiveCommonTableExpressionSelectSyntax(..) , IsSql99SelectSyntax(..) , IsSql99DataTypeSyntax(..) ) where @@ -67,3 +68,19 @@ class IsSql99CommonTableExpressionSyntax syntax where type Sql99CTESelectSyntax syntax :: Type cteSubquerySyntax :: Text -> [Text] -> Sql99CTESelectSyntax syntax -> syntax + +-- | Extension of SQL99 common-table-expression syntax for backends that allow +-- a CTE body to be a data-modifying statement rather than a @SELECT@. +-- +-- The data-modifying body is kept distinct from 'Sql99CTESelectSyntax' so a +-- backend must opt into this extension explicitly. 'cteDataModifyingSyntax' +-- supplies the CTE name and output column names around a backend-specific +-- statement such as @DELETE ... RETURNING ...@. +class IsSql99CommonTableExpressionSyntax syntax + => IsSql99DataModifyingCommonTableExpressionSyntax syntax where + + -- | Backend-specific syntax for the statement inside the CTE body. + type Sql99CTEDataModifyingSyntax syntax :: Type + + -- | Wrap a data-modifying statement as one named CTE definition. + cteDataModifyingSyntax :: Text -> [Text] -> Sql99CTEDataModifyingSyntax syntax -> syntax diff --git a/beam-core/Database/Beam/Query.hs b/beam-core/Database/Beam/Query.hs index 1752984c9..d64fbee71 100644 --- a/beam-core/Database/Beam/Query.hs +++ b/beam-core/Database/Beam/Query.hs @@ -100,7 +100,9 @@ import Prelude hiding (lookup) import Database.Beam.Query.Aggregate import Database.Beam.Query.Combinators -import Database.Beam.Query.CTE ( With, ReusableQ, selecting, reuse ) +import Database.Beam.Query.CTE + ( CtePlacement(..), ReusableQ, With + , reuse, selecting, toTopLevel ) import qualified Database.Beam.Query.CTE as CTE import Database.Beam.Query.CustomSQL import Database.Beam.Query.DataTypes @@ -153,14 +155,25 @@ select :: forall be db res select q = SqlSelect (buildSqlQuery "t" q) --- | Create a 'SqlSelect' for a query which may have common table +-- | Create a top-level 'SqlSelect' for a query which may have common table -- expressions. See the documentation of 'With' for more details. -selectWith :: forall be db res +-- +-- Unlike a backend-specific nested CTE combinator, this is a top-level +-- consumer and therefore accepts both 'CteNestedAllowed' and +-- 'CteTopLevelOnly' blocks. For example: +-- +-- > selectWith $ do +-- > reusableRows <- selecting someQuery +-- > pure (reuse reusableRows) +-- +-- A backend-specific data-modifying CTE can appear in the same block; its +-- operation fixes the inferred placement to 'CteTopLevelOnly'. +selectWith :: forall be db placement res . ( BeamSqlBackend be, BeamSql99CommonTableExpressionBackend be , HasQBuilder be, Projectible be res ) - => With be db (Q be db QBaseScope res) -> SqlSelect be (QExprToIdentity res) -selectWith (CTE.With mkQ) = - let (q, (recursiveness, mctes)) = evalState (runWriterT mkQ) 0 + => With be db placement (Q be db QBaseScope res) -> SqlSelect be (QExprToIdentity res) +selectWith with = + let (q, (recursiveness, mctes)) = evalState (runWriterT (CTE.runWith with)) 0 in case (recursiveness, nonEmpty mctes) of (CTE.Nonrecursive, Just ctes) -> SqlSelect (withSyntax (NonEmpty.toList ctes) (buildSqlQuery "t" q)) diff --git a/beam-core/Database/Beam/Query/CTE.hs b/beam-core/Database/Beam/Query/CTE.hs index 61bc7bca0..c614c9556 100644 --- a/beam-core/Database/Beam/Query/CTE.hs +++ b/beam-core/Database/Beam/Query/CTE.hs @@ -1,7 +1,25 @@ {-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE RoleAnnotations #-} {-# LANGUAGE UndecidableInstances #-} -module Database.Beam.Query.CTE where +-- | Construction and reuse of common table expressions. +-- +-- The 'CtePlacement' index records a property which SQL otherwise checks only +-- at execution time: whether a complete @WITH@ block may be placed inside a +-- subquery. Most users do not need to mention the index because 'selecting' is +-- placement-polymorphic and backend-specific operations refine it as needed. +module Database.Beam.Query.CTE + ( CtePlacement(..) + , With, runWith + , toTopLevel + , Recursiveness(..) + , QAnyScope + , ReusableQ(..) + , reusableForCTE + , selecting + , dataModifyingCte + , reuse + ) where import Database.Beam.Backend.SQL import Database.Beam.Query.Internal @@ -31,6 +49,17 @@ instance Semigroup (Recursiveness be) where _ <> Recursive = Recursive _ <> _ = Nonrecursive +-- | Whether a common-table-expression block may be embedded in a subquery or +-- must remain attached to a top-level statement. +-- +-- Plain @SELECT@ CTEs can be built at either placement. A data-modifying CTE +-- forces its enclosing 'With' block to 'CteTopLevelOnly'. This prevents +-- backends such as PostgreSQL from embedding data-modifying statements in a +-- location where the server would reject them. +data CtePlacement + = CteNestedAllowed -- ^ The complete @WITH@ block is safe in a subquery. + | CteTopLevelOnly -- ^ The complete @WITH@ block must remain top-level. + -- | Monad in which @SELECT@ statements can be made (via 'selecting') -- and bound to result names for re-use later. This has the advantage -- of only computing each result once. In SQL, this is translated to a @@ -38,21 +67,66 @@ instance Semigroup (Recursiveness be) where -- -- Once introduced, results can be re-used in future queries with 'reuse'. -- --- 'With' is also a member of 'MonadFix' for backends that support --- recursive CTEs. In this case, you can use @mdo@ or @rec@ notation --- (with @RecursiveDo@ enabled) to bind result values (again, using --- 'reuse') even /before/ they're introduced. +-- A nested-safe 'With' block is also a member of 'MonadFix' for backends that +-- support recursive CTEs. In this case, you can use @mdo@ or @rec@ notation +-- (with @RecursiveDo@ enabled) to bind result values (again, using 'reuse') +-- even /before/ they're introduced. Use 'toTopLevel' after constructing a +-- recursive @SELECT@ block if it must be combined with data-modifying CTEs. +-- +-- The 'CtePlacement' index records whether the block may be embedded in a +-- subquery. It is normally inferred: 'selecting' is valid at either placement, +-- while a backend-specific data-modifying operation makes the complete block +-- 'CteTopLevelOnly'. +-- +-- A normal, non-recursive use looks like: +-- +-- > selectWith $ do +-- > reusableRows <- selecting someQuery +-- > pure (reuse reusableRows) -- -- See further documentation . -newtype With be (db :: (Type -> Type) -> Type) a - = With { runWith :: WriterT (Recursiveness be, [ BeamSql99BackendCTESyntax be ]) - (State Int) a } +newtype With be (db :: (Type -> Type) -> Type) (placement :: CtePlacement) a + = With + { -- | Unwrap a CTE builder. This is primarily intended for top-level + -- statement consumers such as @selectWith@ and backend-specific + -- equivalents. + runWith :: WriterT (Recursiveness be, [ BeamSql99BackendCTESyntax be ]) + (State Int) a + } deriving (Monad, Applicative, Functor) +-- The placement index is phantom in the runtime representation. Keep every +-- parameter nominal so Data.Coerce cannot relabel a top-level-only block and +-- bypass the smart constructors which establish the invariant. +type role With nominal nominal nominal nominal + +-- Restrict the recursive knot to SELECT-only, nested-safe construction. A +-- data-modifying operation fixes the placement to CteTopLevelOnly and therefore +-- cannot recursively depend on its own RETURNING rows. instance IsSql99RecursiveCommonTableExpressionSelectSyntax (BeamSqlBackendSelectSyntax be) - => MonadFix (With be db) where + => MonadFix (With be db 'CteNestedAllowed) where mfix f = With (tell (Recursive, mempty) >> mfix (runWith . f)) +-- | Promote a nested-safe CTE block for composition with top-level-only CTEs. +-- +-- Recursion is deliberately available only while constructing a +-- 'CteNestedAllowed' block. Promote the completed recursive @SELECT@ block with +-- this function before sequencing it with data-modifying CTEs. This permits +-- recursive queries to feed data-modifying statements without allowing a +-- data-modifying statement itself to participate in the recursive knot. +-- +-- For example, a backend can first finish the recursive, SELECT-only portion +-- and then continue in a top-level block: +-- +-- > recursiveRows <- toTopLevel $ mdo +-- > rows <- selecting (seedQuery `unionAll_` stepQuery (reuse rows)) +-- > pure rows +-- > changedRows <- backendDataModifyingCte recursiveRows +toTopLevel + :: With be db 'CteNestedAllowed a + -> With be db 'CteTopLevelOnly a +toTopLevel (With action) = With action + data QAnyScope -- | Query results that have been introduced into a common table @@ -77,11 +151,17 @@ reusableForCTE tblNm = -- | Introduce the result of a query as a result in a common table -- expression. The returned value can be used in future queries by -- applying 'reuse'. -selecting :: forall res be db +-- +-- > reusableRows <- selecting someQuery +-- > pure $ do +-- > row <- reuse reusableRows +-- > guard_ (isWanted row) +-- > pure row +selecting :: forall res be db placement . ( BeamSql99CommonTableExpressionBackend be, HasQBuilder be , Projectible be res , ThreadRewritable QAnyScope res ) - => Q be db QAnyScope res -> With be db (ReusableQ be db res) + => Q be db QAnyScope res -> With be db placement (ReusableQ be db res) selecting q = With $ do cteId <- get @@ -94,8 +174,46 @@ selecting q = pure (reusableForCTE tblNm) +-- | Introduce the result of a backend-specific data-modifying statement as a +-- common table expression. The statement is expected to return rows shaped like +-- @res@, for example by using @INSERT ... RETURNING@, @UPDATE ... RETURNING@, +-- or @DELETE ... RETURNING@ on backends that support those forms. +-- +-- This is a low-level helper intended for backend-specific APIs. The returned +-- value can be used in future queries by applying 'reuse'. Its enclosing +-- 'With' block is marked 'CteTopLevelOnly', so it cannot be passed to a backend +-- combinator for nested CTEs. +-- +-- Backend APIs normally obtain @body@ from an existing @... RETURNING@ +-- builder, then expose a typed wrapper to users: +-- +-- > backendCteReturning statement = +-- > dataModifyingCte (backendDataModifyingSyntax statement) +-- +-- This produces one definition such as: +-- +-- @ +-- changed(res0) AS (DELETE FROM items WHERE expired RETURNING id) +-- @ +dataModifyingCte :: forall res be db + . ( BeamSql99DataModifyingCommonTableExpressionBackend be + , Projectible be res + , ThreadRewritable QAnyScope res ) + => Sql99CTEDataModifyingSyntax (BeamSql99BackendCTESyntax be) + -> With be db 'CteTopLevelOnly (ReusableQ be db res) +dataModifyingCte body = + With $ do + cteId <- get + put (cteId + 1) + + let tblNm = fromString ("cte" ++ show cteId) + + (_ :: res, fieldNames) = mkFieldNames @be (qualifiedField tblNm) + tell (Nonrecursive, [ cteDataModifyingSyntax tblNm fieldNames body ]) + + pure (reusableForCTE tblNm) + -- | Introduces the result of a previous 'selecting' (a CTE) into a new query reuse :: forall s be db res . ReusableQ be db res -> Q be db s (WithRewrittenThread QAnyScope s res) reuse (ReusableQ _ q) = q (Proxy @s) - diff --git a/beam-postgres/ChangeLog.md b/beam-postgres/ChangeLog.md index b112de75f..4c7cd06cd 100644 --- a/beam-postgres/ChangeLog.md +++ b/beam-postgres/ChangeLog.md @@ -7,6 +7,15 @@ over colums of type `citext` (#818) * Exposed the functionality to implement user-defined extensions via `Database.Beam.Postgres.Extensions` (#819) +* Added `cteInsertReturning`, `cteUpdateReturning`, and `cteDeleteReturning` + for using PostgreSQL data-modifying statements in top-level common table + expressions. Their placement index prevents them from being passed to + `pgSelectWith`, since PostgreSQL does not allow data-modifying CTEs in + subqueries. +* Added `pgInsertWith`, `pgUpdateWith`, and `pgDeleteWith` for terminating a + top-level PostgreSQL `WITH` block with the corresponding data-modifying + statement. These consumers accept both CTE placement indices and preserve + recursive `SELECT` CTEs. ## Bug fixes diff --git a/beam-postgres/Database/Beam/Postgres/Full.hs b/beam-postgres/Database/Beam/Postgres/Full.hs index 7552f2cb2..5dd6ede43 100644 --- a/beam-postgres/Database/Beam/Postgres/Full.hs +++ b/beam-postgres/Database/Beam/Postgres/Full.hs @@ -1,5 +1,6 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -19,14 +20,14 @@ module Database.Beam.Postgres.Full , locked_, lockAll_, withLocks_ - -- ** Inner WITH queries - , pgSelectWith + -- ** @WITH@ statement consumers + , pgSelectWith, pgInsertWith, pgUpdateWith, pgDeleteWith -- ** Lateral joins , lateral_ -- * @INSERT@ and @INSERT RETURNING@ - , insert, insertReturning + , insert, insertReturning, cteInsertReturning , insertDefaults , runPgInsertReturningList @@ -45,12 +46,12 @@ module Database.Beam.Postgres.Full -- * @UPDATE RETURNING@ , PgUpdateReturning(..) , runPgUpdateReturningList - , updateReturning + , updateReturning, cteUpdateReturning -- * @DELETE RETURNING@ , PgDeleteReturning(..) , runPgDeleteReturningList - , deleteReturning + , deleteReturning, cteDeleteReturning -- * Generalized @RETURNING@ , PgReturning(..) @@ -220,6 +221,52 @@ insertReturning (DatabaseEntity tbl@(DatabaseTable {})) tblSettings = dbTableSettings tbl +-- | 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 'selectWith' blocks and +-- cannot be used with 'pgSelectWith'. +-- +-- For example, this inserts a row once and makes the rows produced by +-- @RETURNING@ available to the final query: +-- +-- > selectWith $ 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 AS (INSERT INTO users ... RETURNING ...) +-- SELECT ... FROM cte0 +-- @ +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) + -> With Postgres db 'CTE.CteTopLevelOnly (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 <$> CTE.dataModifyingCte + (PgDataModifyingCommonTableExpressionSyntax syntax) + runPgInsertReturningList :: ( MonadBeam be m , BeamSqlBackendSyntax be ~ PgCommandSyntax @@ -290,12 +337,27 @@ lateral_ using mkSubquery = do -- -- @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. +-- The 'pgSelectWith' function is more flexible. Its 'CteNestedAllowed' index +-- statically prevents PostgreSQL data-modifying CTEs from being embedded here; +-- those must be consumed by top-level 'selectWith'. +-- +-- > 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 +-- @ +-- +-- Replacing 'selecting' above with 'cteDeleteReturning', for example, does not +-- type-check because PostgreSQL requires data-modifying CTEs at the top level. 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 + => With Postgres db 'CTE.CteNestedAllowed (Q Postgres db s res) -> Q Postgres db s res +pgSelectWith with = + let (q, (recursiveness, mctes)) = evalState (runWriterT (CTE.runWith with)) 0 fromSyntax tblPfx = case (recursiveness, nonEmpty mctes) of (CTE.Nonrecursive, Just ctes) -> withSyntax (NonEmpty.toList ctes) (buildSqlQuery tblPfx q) @@ -316,6 +378,104 @@ pgSelectWith (CTE.With mkQ) = (const Nothing) snd)) +-- | Attach a common-table-expression block to a top-level PostgreSQL +-- @INSERT@ statement. +-- +-- Unlike 'pgSelectWith', this is a top-level statement consumer and therefore +-- accepts both 'CteNestedAllowed' and 'CteTopLevelOnly' blocks. The final +-- insert can read reusable rows produced by either SELECT CTEs or +-- data-modifying CTEs: +-- +-- > pgInsertWith $ do +-- > rows <- selecting sourceQuery +-- > pure $ insert destination (insertFrom (reuse rows)) onConflictDefault +-- +-- This produces a statement with the following shape: +-- +-- @ +-- WITH cte0 AS (SELECT ...) +-- INSERT INTO destination ... SELECT ... FROM cte0 +-- @ +-- +-- 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. +pgInsertWith + :: With Postgres db placement (SqlInsert Postgres table) + -> SqlInsert Postgres table +pgInsertWith with = + case runPgWith with of + (SqlInsertNoRows, _, _) -> SqlInsertNoRows + (SqlInsert settings (PgInsertSyntax statement), recursive, ctes) -> + SqlInsert settings (PgInsertSyntax (pgWithSyntax recursive 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 <- selecting wantedUsers +-- > pure $ update users +-- > (\user -> userEnabled user <-. val_ False) +-- > (\user -> exists_ $ do +-- > candidate <- reuse wanted +-- > guard_ (userId user ==. userId candidate)) +-- +-- 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. +pgUpdateWith + :: With Postgres db placement (SqlUpdate Postgres table) + -> SqlUpdate Postgres table +pgUpdateWith with = + case runPgWith with of + (SqlIdentityUpdate, _, _) -> SqlIdentityUpdate + (SqlUpdate settings (PgUpdateSyntax statement), recursive, ctes) -> + SqlUpdate settings (PgUpdateSyntax (pgWithSyntax recursive ctes statement)) + +-- | Attach a common-table-expression block to a top-level PostgreSQL +-- @DELETE@ statement. +-- +-- > pgDeleteWith $ do +-- > expired <- selecting expiredUsers +-- > pure $ delete users $ \user -> exists_ $ do +-- > candidate <- reuse expired +-- > guard_ (userId user ==. userId candidate) +-- +-- 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. +pgDeleteWith + :: With Postgres db placement (SqlDelete Postgres table) + -> SqlDelete Postgres table +pgDeleteWith with = + case runPgWith with of + (SqlDelete settings (PgDeleteSyntax statement), recursive, ctes) -> + SqlDelete settings (PgDeleteSyntax (pgWithSyntax recursive ctes statement)) + +-- 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 + :: With Postgres db placement a + -> (a, Bool, [BeamSql99BackendCTESyntax Postgres]) +runPgWith with = + let (result, (recursiveness, ctes)) = + evalState (runWriterT (CTE.runWith with)) 0 + recursive = case recursiveness of + CTE.Nonrecursive -> False + CTE.Recursive -> True + in (result, recursive, ctes) + -- | By default, Postgres will throw an error when a conflict is detected. This -- preserves that functionality. onConflictDefault :: PgInsertOnConflict tbl @@ -388,6 +548,45 @@ updateReturning table@(DatabaseEntity (DatabaseTable { dbTableSettings = tblSett where tblQ = changeBeamRep (\(Columnar' f) -> Columnar' (QExpr (pure (fieldE (unqualifiedField (_fieldName f)))))) tblSettings +-- | 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 'selectWith' blocks and +-- cannot be used with 'pgSelectWith'. +-- +-- > selectWith $ 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. +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) + -> With Postgres db 'CTE.CteTopLevelOnly (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 <$> CTE.dataModifyingCte + (PgDataModifyingCommonTableExpressionSyntax syntax) + runPgUpdateReturningList :: ( MonadBeam be m , BeamSqlBackendSyntax be ~ PgCommandSyntax @@ -429,6 +628,41 @@ 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 ... 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 'selectWith' blocks and +-- cannot be used with 'pgSelectWith'. +-- +-- Unlike insert and update, delete always has a statement to introduce, so no +-- 'Maybe' is required: +-- +-- > selectWith $ do +-- > deleted <- cteDeleteReturning +-- > users +-- > (\user -> userExpired user ==. val_ True) +-- > id +-- > pure (reuse deleted) +-- +-- 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. +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) + -> With Postgres db 'CTE.CteTopLevelOnly (ReusableQ Postgres db (WithRewrittenThread PostgresInaccessible CTE.QAnyScope a)) +cteDeleteReturning table mkWhere mkProjection = + let PgDeleteReturning syntax = deleteReturning table mkWhere mkProjection + in CTE.dataModifyingCte + (PgDataModifyingCommonTableExpressionSyntax 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 fc6e888c4..18fc3a1e6 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, pgWithSyntax , pgStringLit, pgCharLit, pgBoolLit , nextSyntaxStep @@ -30,6 +30,8 @@ module Database.Beam.Postgres.Syntax , PgInsertSyntax(..) , PgDeleteSyntax(..) , PgUpdateSyntax(..) + , PgCommonTableExpressionSyntax(..) + , PgDataModifyingCommonTableExpressionSyntax(..) , PgExpressionSyntax(..), PgFromSyntax(..), PgTableNameSyntax(..) , PgComparisonQuantifierSyntax(..) @@ -275,6 +277,29 @@ data PgSelectLockingClauseSyntax = PgSelectLockingClauseSyntax { pgSelectLocking newtype PgCommonTableExpressionSyntax = PgCommonTableExpressionSyntax { fromPgCommonTableExpression :: PgSyntax } +-- | PostgreSQL syntax for the statement placed inside a data-modifying CTE. +-- +-- The wrapped syntax is the body only, for example @DELETE ... RETURNING ...@. +-- 'cteDataModifyingSyntax' supplies the CTE name, output column aliases, +-- parentheses, and @AS@ wrapper. +newtype PgDataModifyingCommonTableExpressionSyntax + = PgDataModifyingCommonTableExpressionSyntax { fromPgDataModifyingCommonTableExpression :: PgSyntax } + +-- | Prefix a PostgreSQL statement with a common-table-expression list. +-- PostgreSQL accepts the same @WITH@ prefix before @SELECT@, @INSERT@, +-- @UPDATE@, and @DELETE@, 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. The boolean selects +-- @WITH RECURSIVE@ when the CTE builder used recursive bindings. +pgWithSyntax :: Bool -> [PgCommonTableExpressionSyntax] -> PgSyntax -> PgSyntax +pgWithSyntax _ [] statement = statement +pgWithSyntax recursive ctes statement = + emit (if recursive then "WITH RECURSIVE " else "WITH ") <> + pgSepBy (emit ", ") (map fromPgCommonTableExpression ctes) <> + emit " " <> + statement + fromPgOrdering :: PgOrderingSyntax -> PgSyntax fromPgOrdering (PgOrderingSyntax s Nothing) = s fromPgOrdering (PgOrderingSyntax s (Just PgNullOrderingNullsFirst)) = s <> emit " NULLS FIRST" @@ -622,17 +647,11 @@ instance IsSql99CommonTableExpressionSelectSyntax PgSelectSyntax where type Sql99SelectCTESyntax PgSelectSyntax = PgCommonTableExpressionSyntax withSyntax ctes (PgSelectSyntax select) = - PgSelectSyntax $ - emit "WITH " <> - pgSepBy (emit ", ") (map fromPgCommonTableExpression ctes) <> - select + PgSelectSyntax (pgWithSyntax False ctes select) instance IsSql99RecursiveCommonTableExpressionSelectSyntax PgSelectSyntax where withRecursiveSyntax ctes (PgSelectSyntax select) = - PgSelectSyntax $ - emit "WITH RECURSIVE " <> - pgSepBy (emit ", ") (map fromPgCommonTableExpression ctes) <> - select + PgSelectSyntax (pgWithSyntax True ctes select) instance IsSql99CommonTableExpressionSyntax PgCommonTableExpressionSyntax where type Sql99CTESelectSyntax PgCommonTableExpressionSyntax = PgSelectSyntax @@ -642,6 +661,18 @@ instance IsSql99CommonTableExpressionSyntax PgCommonTableExpressionSyntax where pgQuotedIdentifier tbl <> pgParens (pgSepBy (emit ",") (map pgQuotedIdentifier fields)) <> emit " AS " <> pgParens select +instance IsSql99DataModifyingCommonTableExpressionSyntax PgCommonTableExpressionSyntax where + type Sql99CTEDataModifyingSyntax PgCommonTableExpressionSyntax = PgDataModifyingCommonTableExpressionSyntax + + -- Render the same outer shape as a SELECT CTE, but preserve the raw + -- PostgreSQL data-modifying statement as its body: + -- + -- @cte0(res0) AS (DELETE ... RETURNING ...)@ + cteDataModifyingSyntax tbl fields (PgDataModifyingCommonTableExpressionSyntax body) = + PgCommonTableExpressionSyntax $ + pgQuotedIdentifier tbl <> pgParens (pgSepBy (emit ",") (map pgQuotedIdentifier fields)) <> + emit " AS " <> pgParens body + instance IsSql2008BigIntDataTypeSyntax PgDataTypeSyntax where bigIntType = PgDataTypeSyntax (PgDataTypeDescrOid (Pg.typoid Pg.int8) Nothing) (emit "BIGINT") bigIntType @@ -1587,4 +1618,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 6e14d6db0..f41ebcb05 100644 --- a/beam-postgres/beam-postgres.cabal +++ b/beam-postgres/beam-postgres.cabal @@ -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 2681ad8f1..eccdeceb4 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. Connecting to template1 while cloning it is rejected by recent + -- PostgreSQL releases because the template database is already in use. + 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 000000000..33f8d6fbd --- /dev/null +++ b/beam-postgres/test/Database/Beam/Postgres/Test/CTE.hs @@ -0,0 +1,515 @@ +{-# LANGUAGE DataKinds #-} +{-# 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.List (isInfixOf, isPrefixOf) +import Data.Text (Text) + +import Database.Beam +import Database.Beam.Postgres +import qualified Database.Beam.Postgres.Full as Pg +import Database.Beam.Postgres.Syntax + ( PgDeleteSyntax(..) + , PgInsertSyntax(..) + , PgSelectSyntax(..) + , PgUpdateSyntax(..) + , pgRenderSyntaxScript + ) +import Database.PostgreSQL.Simple (execute_) + +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) + +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 + , testWithDmlConsumers getConn + ] + +renderingTests :: TestTree +renderingTests = testGroup "Common table expression rendering tests" + [ testMixedCteRendering + , testNestedSelectCteRendering + , testRecursiveSelectThenDeleteRendering + , testEmptyDataModifyingCtes + , testWithDmlConsumerRendering + , testRecursiveInsertWithRendering + , testTopLevelOnlyDmlConsumerRendering + , testEmptyDmlConsumers + , testReturningAfterDmlConsumers + ] + +-- 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 "placement cannot be bypassed with coerce" $ + assertPlacementTypeError Negative.invalidCoercedPlacement + , testCase "rejects a recursively self-referencing INSERT CTE" $ + assertDeferredTypeErrorContaining + ["MonadFix", "CteTopLevelOnly"] + Negative.invalidRecursiveInsert + ] + +assertPlacementTypeError :: SqlSelect Postgres a -> Assertion +assertPlacementTypeError = + assertDeferredTypeErrorContaining ["CteTopLevelOnly", "CteNestedAllowed"] + +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) (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))) + +-- 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 toTopLevel 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 the three +-- independent Sql* wrappers reconstructed by the public functions. +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 CteTopLevelOnly 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)) + +-- 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 + +-- 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 + +-- 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 = selectWith $ topLevelOnly $ do + selected <- selecting $ 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" + +nestedSelectCteSelect :: SqlSelect Postgres (CteRowT Identity) +nestedSelectCteSelect = select $ Pg.pgSelectWith $ nestedAllowed $ 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. 'toTopLevel' closes the +-- recursive SELECT knot before the DELETE is added. +recursiveSelectThenDeleteCteSelect :: SqlSelect Postgres (CteRowT Identity) +recursiveSelectThenDeleteCteSelect = selectWith $ do + recursiveIds <- toTopLevel $ mdo + ids <- selecting $ + 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 selectWith to render the final query +-- without an empty WITH clause. +emptyDataModifyingCteSelect :: SqlSelect Postgres Int32 +emptyDataModifyingCteSelect = selectWith $ 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) + +-- 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 <- selecting $ 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 <- selecting $ 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 <- selecting $ 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 + (mdo + ids <- selecting $ + 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 + :: With Postgres CteDb 'CteNestedAllowed (SqlInsert Postgres CteRowT)) + +-- Adding a modifying CTE fixes the block to CteTopLevelOnly. 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 + _ <- selecting $ all_ (dbCteRows cteDb) + pure $ Pg.insert + (dbCteRows cteDb) + SqlInsertValuesEmpty + Pg.onConflictDefault + +identityUpdateWithStatement :: SqlUpdate Postgres CteRowT +identityUpdateWithStatement = Pg.pgUpdateWith $ do + _ <- selecting $ 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 + +topLevelOnly + :: With be db 'CteTopLevelOnly a + -> With be db 'CteTopLevelOnly a +topLevelOnly = id + +nestedAllowed + :: With be db 'CteNestedAllowed a + -> With be db 'CteNestedAllowed a +nestedAllowed = id 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 000000000..abfb3976c --- /dev/null +++ b/beam-postgres/test/Database/Beam/Postgres/Test/CTENegative.hs @@ -0,0 +1,155 @@ +{-# 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 + , invalidCoercedPlacement + , invalidRecursiveInsert + ) 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 +-- pgSelectWith. They must fail with CteTopLevelOnly versus CteNestedAllowed, +-- independently of which data-modifying command produced the CTE. +invalidNestedDelete :: SqlSelect Postgres (NegativeCteRowT Identity) +invalidNestedDelete = select $ Pg.pgSelectWith $ do + deleted <- topLevelDeleteCte + pure (reuse deleted) + +invalidNestedInsert :: SqlSelect Postgres (NegativeCteRowT Identity) +invalidNestedInsert = select $ Pg.pgSelectWith $ 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.pgSelectWith $ 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.pgSelectWith $ do + _ <- nestedSelectCte + deleted <- topLevelDeleteCte + pure (reuse deleted) + +invalidNestedDeleteThenSelect :: SqlSelect Postgres (NegativeCteRowT Identity) +invalidNestedDeleteThenSelect = select $ Pg.pgSelectWith $ do + deleted <- topLevelDeleteCte + _ <- nestedSelectCte + pure (reuse deleted) + +-- The result is conservatively top-level-only even when a value-level check +-- later discovers that the INSERT or UPDATE emits no statement. The placement +-- invariant cannot depend on runtime values. +invalidNestedEmptyInsert :: SqlSelect Postgres (NegativeCteRowT Identity) +invalidNestedEmptyInsert = select $ Pg.pgSelectWith $ 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.pgSelectWith $ 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') + +-- With 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.pgSelectWith $ coercePlacement $ do + deleted <- topLevelDeleteCte + pure (reuse deleted) + +-- MonadFix exists only for CteNestedAllowed. This prevents an INSERT CTE from +-- reading its own RETURNING rows recursively, which PostgreSQL rejects. +invalidRecursiveInsert :: SqlSelect Postgres (NegativeCteRowT Identity) +invalidRecursiveInsert = selectWith $ mdo + ~(Just inserted) <- Pg.cteInsertReturning + (negativeCteRows negativeCteDb) + (insertFrom (reuse inserted)) + Pg.onConflictDefault + id + pure (reuse inserted) + +coercePlacement + :: With Postgres NegativeCteDb 'CteTopLevelOnly a + -> With Postgres NegativeCteDb 'CteNestedAllowed a +coercePlacement = Coerce.coerce + +nestedSelectCte + :: With Postgres NegativeCteDb placement + (ReusableQ Postgres NegativeCteDb + (NegativeCteRowT (QExpr Postgres CTE.QAnyScope))) +nestedSelectCte = selecting $ all_ (negativeCteRows negativeCteDb) + +topLevelDeleteCte + :: With Postgres NegativeCteDb 'CteTopLevelOnly + (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 8582442b8..565c20f95 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,53 @@ 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. Compatibility + -- with newer PostgreSQL releases can be exercised by a separate matrix job. + 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 3f9d03881..cc3aa7d55 100644 --- a/docs/user-guide/backends/beam-postgres.md +++ b/docs/user-guide/backends/beam-postgres.md @@ -295,6 +295,34 @@ function for PostgreSQL, named `pgSelectWith`. For `beam-postgres`, `select (pgS equivalent to `selectWith x`. But, with the new type, we can reuse CTEs (including recursive ones) within other queries. +PostgreSQL only permits data-modifying CTEs at the top level. Accordingly, `pgSelectWith` accepts a +`With` block whose placement is `CteNestedAllowed`, while `cteInsertReturning`, +`cteUpdateReturning`, and `cteDeleteReturning` produce `CteTopLevelOnly` blocks. Mixing ordinary +`SELECT` CTEs with those operations remains valid under top-level `selectWith`, but attempting to +pass such a block to `pgSelectWith` is rejected by the Haskell type checker. + +PostgreSQL also disallows a data-modifying CTE from recursively referring to itself. Recursive +construction is therefore limited to `CteNestedAllowed` blocks. To combine a recursive `SELECT` +CTE with a later data-modifying CTE, finish the recursive block first and promote it with +`toTopLevel`; its result can then safely be reused by the modifying statement. + +A PostgreSQL `WITH` statement may also finish with `INSERT`, `UPDATE`, or `DELETE` instead of a +final `SELECT`. The `pgInsertWith`, `pgUpdateWith`, and `pgDeleteWith` functions consume a `With` +block in those cases. Because all three produce top-level statements, they accept both placement +indices, including blocks containing data-modifying CTEs. For example: + +```haskell +Pg.pgInsertWith $ do + customersToCopy <- selecting sourceCustomers + pure $ Pg.insert archiveCustomers + (insertFrom (reuse customersToCopy)) + Pg.onConflictDefault +``` + +An empty terminal insert or identity update remains a no-op. PostgreSQL cannot execute a bare +`WITH` block without a terminal statement, so CTE bodies accumulated before such a no-op 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 find, for each order, an employee who lives in the same city as the customer, but we only want the From c4381949fa12f231846e03a8170ddb76772f5ef4 Mon Sep 17 00:00:00 2001 From: Kushagra Gupta Date: Sat, 11 Jul 2026 07:19:55 +0000 Subject: [PATCH 02/10] Update dependencies and changelogs for CTE enhancements --- beam-backend-bench/beam-backend-bench.cabal | 2 +- beam-core/ChangeLog.md | 11 ++- beam-core/Database/Beam/Query/CTE.hs | 25 +++++- beam-core/beam-core.cabal | 2 +- beam-duckdb/beam-duckdb.cabal | 2 +- beam-migrate/beam-migrate.cabal | 2 +- beam-postgres/ChangeLog.md | 27 +++++-- beam-postgres/beam-postgres.cabal | 4 +- .../test/Database/Beam/Postgres/Test/CTE.hs | 76 +++++++++++++++---- beam-sqlite/beam-sqlite.cabal | 2 +- 10 files changed, 119 insertions(+), 34 deletions(-) diff --git a/beam-backend-bench/beam-backend-bench.cabal b/beam-backend-bench/beam-backend-bench.cabal index c8839baab..d1bbf2caa 100644 --- a/beam-backend-bench/beam-backend-bench.cabal +++ b/beam-backend-bench/beam-backend-bench.cabal @@ -29,7 +29,7 @@ library hs-source-dirs: src exposed-modules: Database.Beam.Bench build-depends: base >=4.11 && <5 - , beam-core >=0.11 && <0.12 + , beam-core >=0.11 && <0.13 , deepseq >=1.4 && <1.6 , text >=1.0 && <2.2 default-language: Haskell2010 diff --git a/beam-core/ChangeLog.md b/beam-core/ChangeLog.md index 776c5f3ca..a98350e8c 100644 --- a/beam-core/ChangeLog.md +++ b/beam-core/ChangeLog.md @@ -1,4 +1,4 @@ -# 0.11.2.0 +# 0.12.0.0 ## Interface changes @@ -15,6 +15,15 @@ ## Bug fixes +* Reject zero-column common table expression projections before they can + produce malformed `SELECT` or `RETURNING` SQL. +* Preserve placement inference for existing recursive `selectWith` call sites + while continuing to reject recursive data-modifying CTEs. + +# 0.11.2.0 + +## Bug fixes + * Fixed an issue where using `selectWith` and no common-table expressions would lead to invalid SQL at runtime. diff --git a/beam-core/Database/Beam/Query/CTE.hs b/beam-core/Database/Beam/Query/CTE.hs index c614c9556..e424fc02c 100644 --- a/beam-core/Database/Beam/Query/CTE.hs +++ b/beam-core/Database/Beam/Query/CTE.hs @@ -103,8 +103,14 @@ type role With nominal nominal nominal nominal -- Restrict the recursive knot to SELECT-only, nested-safe construction. A -- data-modifying operation fixes the placement to CteTopLevelOnly and therefore -- cannot recursively depend on its own RETURNING rows. -instance IsSql99RecursiveCommonTableExpressionSelectSyntax (BeamSqlBackendSelectSyntax be) - => MonadFix (With be db 'CteNestedAllowed) where +-- +-- Keep @placement@ variable in the instance head and refine it with an equality +-- constraint. This lets recursive @selectWith@ call sites infer +-- 'CteNestedAllowed' even though a top-level consumer does not otherwise expose +-- the placement index in its result type. +instance ( placement ~ 'CteNestedAllowed + , IsSql99RecursiveCommonTableExpressionSelectSyntax (BeamSqlBackendSelectSyntax be) ) + => MonadFix (With be db placement) where mfix f = With (tell (Recursive, mempty) >> mfix (runWith . f)) -- | Promote a nested-safe CTE block for composition with top-level-only CTEs. @@ -157,6 +163,9 @@ reusableForCTE tblNm = -- > row <- reuse reusableRows -- > guard_ (isWanted row) -- > pure row +-- +-- The query must project at least one column. Empty projections cannot form a +-- reusable SQL relation and are rejected while the @WITH@ block is built. selecting :: forall res be db placement . ( BeamSql99CommonTableExpressionBackend be, HasQBuilder be , Projectible be res @@ -170,7 +179,9 @@ selecting q = let tblNm = fromString ("cte" ++ show cteId) (_ :: res, fieldNames) = mkFieldNames @be (qualifiedField tblNm) - tell (Nonrecursive, [ cteSubquerySyntax tblNm fieldNames (buildSqlQuery (tblNm <> "_") q) ]) + case fieldNames of + [] -> error "Database.Beam.Query.CTE.selecting: a CTE must project at least one column" + _ -> tell (Nonrecursive, [ cteSubquerySyntax tblNm fieldNames (buildSqlQuery (tblNm <> "_") q) ]) pure (reusableForCTE tblNm) @@ -195,6 +206,10 @@ selecting q = -- @ -- changed(res0) AS (DELETE FROM items WHERE expired RETURNING id) -- @ +-- +-- The statement must return at least one column. A zero-column result cannot +-- be exposed as a reusable SQL relation and is rejected while the @WITH@ block +-- is built. dataModifyingCte :: forall res be db . ( BeamSql99DataModifyingCommonTableExpressionBackend be , Projectible be res @@ -209,7 +224,9 @@ dataModifyingCte body = let tblNm = fromString ("cte" ++ show cteId) (_ :: res, fieldNames) = mkFieldNames @be (qualifiedField tblNm) - tell (Nonrecursive, [ cteDataModifyingSyntax tblNm fieldNames body ]) + case fieldNames of + [] -> error "Database.Beam.Query.CTE.dataModifyingCte: a CTE must return at least one column" + _ -> tell (Nonrecursive, [ cteDataModifyingSyntax tblNm fieldNames body ]) pure (reusableForCTE tblNm) diff --git a/beam-core/beam-core.cabal b/beam-core/beam-core.cabal index dc6cf4322..343d29695 100644 --- a/beam-core/beam-core.cabal +++ b/beam-core/beam-core.cabal @@ -1,5 +1,5 @@ name: beam-core -version: 0.11.2.0 +version: 0.12.0.0 synopsis: Type-safe, feature-complete SQL query and manipulation interface for Haskell description: Beam is a Haskell library for type-safe querying and manipulation of SQL databases. Beam is modular and supports various backends. In order to use beam, you will need to use diff --git a/beam-duckdb/beam-duckdb.cabal b/beam-duckdb/beam-duckdb.cabal index 0a21ec0dc..7b69800c4 100644 --- a/beam-duckdb/beam-duckdb.cabal +++ b/beam-duckdb/beam-duckdb.cabal @@ -51,7 +51,7 @@ library Database.Beam.DuckDB.Syntax.Extensions.InsertOnConflict build-depends: aeson >=1.0 && <2.4 , base >=4.11 && <5 - , beam-core >=0.11.1 && <0.12 + , beam-core >=0.11.1 && <0.13 , beam-migrate ^>=0.6 , bytestring >=0.10 && <0.13 -- Version 0.1.5.0 contained a broken change (RowParser constructor not exposed) diff --git a/beam-migrate/beam-migrate.cabal b/beam-migrate/beam-migrate.cabal index 3858b3fba..e794999bb 100644 --- a/beam-migrate/beam-migrate.cabal +++ b/beam-migrate/beam-migrate.cabal @@ -56,7 +56,7 @@ library Database.Beam.Migrate.Types.Predicates build-depends: base >=4.11 && <5.0, - beam-core >=0.11 && <0.12, + beam-core >=0.11 && <0.13, text >=1.2 && <2.2, aeson >=2.0 && <2.4, bytestring >=0.10 && <0.13, diff --git a/beam-postgres/ChangeLog.md b/beam-postgres/ChangeLog.md index 4c7cd06cd..9cb02e460 100644 --- a/beam-postgres/ChangeLog.md +++ b/beam-postgres/ChangeLog.md @@ -1,12 +1,12 @@ -# 0.6.2.0 +# 0.7.0.0 + +## Interface changes + +* Restricted `pgSelectWith` to `CteNestedAllowed` blocks, preventing + PostgreSQL data-modifying CTEs from being embedded in subqueries. ## Added features -* Added instances for `BeamSqlBackendIsString Postgres (CI String)` and - `BeamSqlBackendIsString Postgres (CI Text)`, allowing the use of `toTsVector` - over colums of type `citext` (#818) -* Exposed the functionality to implement user-defined extensions via - `Database.Beam.Postgres.Extensions` (#819) * Added `cteInsertReturning`, `cteUpdateReturning`, and `cteDeleteReturning` for using PostgreSQL data-modifying statements in top-level common table expressions. Their placement index prevents them from being passed to @@ -19,6 +19,21 @@ ## Bug fixes +* Reject zero-column data-modifying CTE projections before rendering an empty + `RETURNING` list. + +# 0.6.2.0 + +## Added features + +* Added instances for `BeamSqlBackendIsString Postgres (CI String)` and + `BeamSqlBackendIsString Postgres (CI Text)`, allowing the use of `toTsVector` + over colums of type `citext` (#818) +* Exposed the functionality to implement user-defined extensions via + `Database.Beam.Postgres.Extensions` (#819) + +## Bug fixes + * Fixed an issue where using `pgSelectWith` with no common-table expressions would lead to an invalid SQL query at runtime. diff --git a/beam-postgres/beam-postgres.cabal b/beam-postgres/beam-postgres.cabal index f41ebcb05..7a635688a 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.7.0.0 synopsis: Connection layer between beam and postgres description: Beam driver for , an advanced open-source RDBMS homepage: https://haskell-beam.github.io/beam/user-guide/backends/beam-postgres @@ -36,7 +36,7 @@ library Database.Beam.Postgres.Types build-depends: base >=4.11 && <5.0, - beam-core >=0.11.1 && <0.12, + beam-core >=0.12 && <0.13, beam-migrate >=0.6 && <0.7, postgresql-libpq >=0.8 && <0.12, diff --git a/beam-postgres/test/Database/Beam/Postgres/Test/CTE.hs b/beam-postgres/test/Database/Beam/Postgres/Test/CTE.hs index 33f8d6fbd..358f6e94e 100644 --- a/beam-postgres/test/Database/Beam/Postgres/Test/CTE.hs +++ b/beam-postgres/test/Database/Beam/Postgres/Test/CTE.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} {-# LANGUAGE RecursiveDo #-} {-# LANGUAGE StandaloneDeriving #-} @@ -8,21 +9,24 @@ -- checking. module Database.Beam.Postgres.Test.CTE (unitTests, integrationTests) where -import Control.Exception (TypeError, evaluate, try) +import Control.Exception (ErrorCall, 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) 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_) @@ -41,6 +45,12 @@ data CteRowT f = CteRow deriving instance Show (CteRowT Identity) deriving instance Eq (CteRowT Identity) +-- A legal Haskell projection shape with no fields. PostgreSQL has no +-- corresponding zero-column SELECT or RETURNING relation, so the CTE builders +-- must reject it before rendering SQL. +data EmptyCteT (f :: Type -> Type) = EmptyCte + deriving (Generic, Beamable) + instance Table CteRowT where data PrimaryKey CteRowT f = CteRowKey (C f Int32) deriving (Generic, Beamable) @@ -57,6 +67,7 @@ unitTests :: TestTree unitTests = testGroup "Common table expression tests" [ renderingTests , typeSafetyTests + , projectionValidationTests ] integrationTests :: IO ByteString -> TestTree @@ -101,10 +112,18 @@ typeSafetyTests = testGroup "Common table expression type-safety tests" assertPlacementTypeError Negative.invalidCoercedPlacement , testCase "rejects a recursively self-referencing INSERT CTE" $ assertDeferredTypeErrorContaining - ["MonadFix", "CteTopLevelOnly"] + ["CteTopLevelOnly", "CteNestedAllowed"] Negative.invalidRecursiveInsert ] +projectionValidationTests :: TestTree +projectionValidationTests = testGroup "Common table expression projection validation tests" + [ testCase "rejects a zero-column SELECT CTE" $ + assertEmptyProjectionError emptySelectProjection + , testCase "rejects a zero-column data-modifying CTE" $ + assertEmptyProjectionError emptyDeleteProjection + ] + assertPlacementTypeError :: SqlSelect Postgres a -> Assertion assertPlacementTypeError = assertDeferredTypeErrorContaining ["CteTopLevelOnly", "CteNestedAllowed"] @@ -125,6 +144,16 @@ assertDeferredTypeErrorContaining expectedFragments sql = do assertFragment message fragment = assertBool ("mentions " ++ fragment) (fragment `isInfixOf` message) +assertEmptyProjectionError :: SqlSelect Postgres a -> Assertion +assertEmptyProjectionError sql = do + result <- try (evaluate (BL.length (renderSelectBytes sql))) + case result of + Left (err :: ErrorCall) -> + assertBool "explains the non-empty projection requirement" + ("at least one column" `isInfixOf` show err) + Right _ -> + assertFailure "expected the zero-column CTE projection to be rejected" + -- 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. @@ -356,6 +385,23 @@ emptyDataModifyingCteSelect = selectWith $ do finalQuery :: Q Postgres CteDb QBaseScope (QExpr Postgres QBaseScope Int32) finalQuery = pure (val_ 1) +-- Both expressions below are valid Beam projection shapes, but contain no +-- fields from which SQL columns could be built. They exercise the shared +-- validation for SELECT and data-modifying CTE bodies respectively. +emptySelectProjection :: SqlSelect Postgres (EmptyCteT Identity) +emptySelectProjection = selectWith $ do + rows <- selecting + (pure (EmptyCte :: EmptyCteT (QExpr Postgres CTE.QAnyScope))) + pure (reuse rows) + +emptyDeleteProjection :: SqlSelect Postgres (EmptyCteT Identity) +emptyDeleteProjection = selectWith $ do + rows <- Pg.cteDeleteReturning + (dbCteRows cteDb) + (const (val_ False)) + (const (EmptyCte :: EmptyCteT (QExpr Postgres PostgresInaccessible))) + pure (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 @@ -403,20 +449,18 @@ deleteWithStatement = Pg.pgDeleteWith $ do -- 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 - (mdo - ids <- selecting $ - 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 - :: With Postgres CteDb 'CteNestedAllowed (SqlInsert Postgres CteRowT)) +recursiveInsertWithStatement = Pg.pgInsertWith $ mdo + ids <- selecting $ + 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 CteTopLevelOnly. pgDeleteWith is -- a top-level consumer, so this remains well-typed. diff --git a/beam-sqlite/beam-sqlite.cabal b/beam-sqlite/beam-sqlite.cabal index 16d8bcb4e..64c818645 100644 --- a/beam-sqlite/beam-sqlite.cabal +++ b/beam-sqlite/beam-sqlite.cabal @@ -26,7 +26,7 @@ library other-modules: Database.Beam.Sqlite.SqliteSpecific build-depends: base >=4.11 && <5, - beam-core >=0.11 && <0.12, + beam-core >=0.11 && <0.13, beam-migrate >=0.6 && <0.7, sqlite-simple >=0.4 && <0.5, From f7ade4ce30042482da5e0bd429e3f89abda93468 Mon Sep 17 00:00:00 2001 From: Kushagra Gupta Date: Sat, 11 Jul 2026 08:22:48 +0000 Subject: [PATCH 03/10] Add comprehensive tests for CTE parameter ordering and data-modifying CTEs --- .../test/Database/Beam/Postgres/Test/CTE.hs | 297 +++++++++++++++++- 1 file changed, 296 insertions(+), 1 deletion(-) diff --git a/beam-postgres/test/Database/Beam/Postgres/Test/CTE.hs b/beam-postgres/test/Database/Beam/Postgres/Test/CTE.hs index 358f6e94e..aad72af0a 100644 --- a/beam-postgres/test/Database/Beam/Postgres/Test/CTE.hs +++ b/beam-postgres/test/Database/Beam/Postgres/Test/CTE.hs @@ -14,7 +14,7 @@ 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) +import Data.List (isInfixOf, isPrefixOf, sortOn) import Data.Text (Text) import Database.Beam @@ -31,6 +31,9 @@ import Database.Beam.Postgres.Syntax ) 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 @@ -74,6 +77,10 @@ integrationTests :: IO ByteString -> TestTree integrationTests getConn = testGroup "Common table expression integration tests" [ testMixedCteBodies getConn , testWithDmlConsumers getConn + , testCteParameterOrdering getConn + , testDataModifyingCteModel getConn + , testWithDmlConsumerModel getConn + , testRecursiveCteModel getConn ] renderingTests :: TestTree @@ -290,6 +297,159 @@ testWithDmlConsumers getConn = testCase "WITH can terminate in INSERT, UPDATE, o ] 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 + +-- 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 toTopLevel 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 + -- 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. @@ -332,6 +492,141 @@ mixedCteSelect = selectWith $ topLevelOnly $ do 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 = + selectWith $ 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" + +-- 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 <- selecting $ 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 <- selecting $ 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 <- selecting $ 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 = selectWith $ do + recursiveIds <- toTopLevel $ mdo + ids <- selecting $ + 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 $ nestedAllowed $ do selected <- selecting $ do From e1fa77a8f19080cf7ac0f4a610b2e73111a74b66 Mon Sep 17 00:00:00 2001 From: Kushagra Gupta Date: Wed, 15 Jul 2026 03:18:20 +0000 Subject: [PATCH 04/10] Enhance PostgreSQL CTE Support and Tests - Updated CTE handling in tests to reflect PostgreSQL's behavior with zero-column CTEs and side-effect-only CTEs. - Added new tests for materialization execution and rendering, ensuring compliance with PostgreSQL 12+ features. - Refined error handling for invalid CTE placements, particularly for side-effect-only operations. - Improved documentation on PostgreSQL-specific CTE usage, including materialization options and nested CTEs. - Adjusted dependencies in the SQLite library for compatibility. - Ensured reproducibility of CI runs by pinning PostgreSQL server version. --- beam-backend-bench/beam-backend-bench.cabal | 2 +- beam-core/ChangeLog.md | 22 - beam-core/Database/Beam/Backend/SQL.hs | 15 - beam-core/Database/Beam/Backend/SQL/SQL99.hs | 17 - beam-core/Database/Beam/Query.hs | 25 +- beam-core/Database/Beam/Query/CTE.hs | 163 +---- beam-core/beam-core.cabal | 2 +- beam-duckdb/beam-duckdb.cabal | 2 +- beam-migrate/beam-migrate.cabal | 2 +- beam-postgres/ChangeLog.md | 43 +- beam-postgres/Database/Beam/Postgres/Full.hs | 588 ++++++++++++++++-- .../Database/Beam/Postgres/Syntax.hs | 34 +- beam-postgres/beam-postgres.cabal | 4 +- .../test/Database/Beam/Postgres/Test.hs | 4 +- .../test/Database/Beam/Postgres/Test/CTE.hs | 336 ++++++++-- .../Beam/Postgres/Test/CTENegative.hs | 57 +- beam-postgres/test/Main.hs | 3 +- beam-sqlite/beam-sqlite.cabal | 2 +- docs/user-guide/backends/beam-postgres.md | 148 ++++- 19 files changed, 1048 insertions(+), 421 deletions(-) diff --git a/beam-backend-bench/beam-backend-bench.cabal b/beam-backend-bench/beam-backend-bench.cabal index d1bbf2caa..c8839baab 100644 --- a/beam-backend-bench/beam-backend-bench.cabal +++ b/beam-backend-bench/beam-backend-bench.cabal @@ -29,7 +29,7 @@ library hs-source-dirs: src exposed-modules: Database.Beam.Bench build-depends: base >=4.11 && <5 - , beam-core >=0.11 && <0.13 + , beam-core >=0.11 && <0.12 , deepseq >=1.4 && <1.6 , text >=1.0 && <2.2 default-language: Haskell2010 diff --git a/beam-core/ChangeLog.md b/beam-core/ChangeLog.md index a98350e8c..21f678de0 100644 --- a/beam-core/ChangeLog.md +++ b/beam-core/ChangeLog.md @@ -1,25 +1,3 @@ -# 0.12.0.0 - -## Interface changes - -* Added a `CtePlacement` index to `With`. Ordinary `SELECT` CTEs are valid at - either placement, while backend-specific data-modifying CTEs are marked - `CteTopLevelOnly` so they cannot be embedded where a backend forbids them. - Recursive knots are restricted to nested-safe blocks; `toTopLevel` promotes a - completed recursive `SELECT` block for composition with data-modifying CTEs. - -## New features - -* Added backend capability and syntax classes for data-modifying common table - expressions. - -## Bug fixes - -* Reject zero-column common table expression projections before they can - produce malformed `SELECT` or `RETURNING` SQL. -* Preserve placement inference for existing recursive `selectWith` call sites - while continuing to reject recursive data-modifying CTEs. - # 0.11.2.0 ## Bug fixes diff --git a/beam-core/Database/Beam/Backend/SQL.hs b/beam-core/Database/Beam/Backend/SQL.hs index 50da0bf42..017cfe6f5 100644 --- a/beam-core/Database/Beam/Backend/SQL.hs +++ b/beam-core/Database/Beam/Backend/SQL.hs @@ -17,7 +17,6 @@ module Database.Beam.Backend.SQL , BeamSql99AggregationBackend , BeamSql99ConcatExpressionBackend , BeamSql99CommonTableExpressionBackend - , BeamSql99DataModifyingCommonTableExpressionBackend , BeamSql99RecursiveCTEBackend , BeamSql2003ExpressionBackend @@ -269,20 +268,6 @@ type BeamSql99CommonTableExpressionBackend be = , IsSql99CommonTableExpressionSelectSyntax (BeamSqlBackendSelectSyntax be) , IsSql99CommonTableExpressionSyntax (BeamSql99BackendCTESyntax be) , Sql99CTESelectSyntax (BeamSql99BackendCTESyntax be) ~ BeamSqlBackendSelectSyntax be ) --- | A SQL99 CTE backend with an extension for data-modifying CTE bodies. --- --- This capability is separate from 'BeamSql99CommonTableExpressionBackend' --- because SQL99 only requires a @SELECT@ as the CTE body. Backends with this --- extension can additionally render statements such as: --- --- @ --- WITH changed AS (UPDATE items SET active = FALSE RETURNING id) --- SELECT id FROM changed --- @ -type BeamSql99DataModifyingCommonTableExpressionBackend be = - ( BeamSql99CommonTableExpressionBackend be - , IsSql99DataModifyingCommonTableExpressionSyntax (BeamSql99BackendCTESyntax be) - ) type BeamSql99RecursiveCTEBackend be= ( BeamSql99CommonTableExpressionBackend be , IsSql99RecursiveCommonTableExpressionSelectSyntax (BeamSqlBackendSelectSyntax be) ) diff --git a/beam-core/Database/Beam/Backend/SQL/SQL99.hs b/beam-core/Database/Beam/Backend/SQL/SQL99.hs index e51f88a64..c7a246703 100644 --- a/beam-core/Database/Beam/Backend/SQL/SQL99.hs +++ b/beam-core/Database/Beam/Backend/SQL/SQL99.hs @@ -9,7 +9,6 @@ module Database.Beam.Backend.SQL.SQL99 , IsSql99AggregationExpressionSyntax(..) , IsSql99CommonTableExpressionSelectSyntax(..) , IsSql99CommonTableExpressionSyntax(..) - , IsSql99DataModifyingCommonTableExpressionSyntax(..) , IsSql99RecursiveCommonTableExpressionSelectSyntax(..) , IsSql99SelectSyntax(..) , IsSql99DataTypeSyntax(..) ) where @@ -68,19 +67,3 @@ class IsSql99CommonTableExpressionSyntax syntax where type Sql99CTESelectSyntax syntax :: Type cteSubquerySyntax :: Text -> [Text] -> Sql99CTESelectSyntax syntax -> syntax - --- | Extension of SQL99 common-table-expression syntax for backends that allow --- a CTE body to be a data-modifying statement rather than a @SELECT@. --- --- The data-modifying body is kept distinct from 'Sql99CTESelectSyntax' so a --- backend must opt into this extension explicitly. 'cteDataModifyingSyntax' --- supplies the CTE name and output column names around a backend-specific --- statement such as @DELETE ... RETURNING ...@. -class IsSql99CommonTableExpressionSyntax syntax - => IsSql99DataModifyingCommonTableExpressionSyntax syntax where - - -- | Backend-specific syntax for the statement inside the CTE body. - type Sql99CTEDataModifyingSyntax syntax :: Type - - -- | Wrap a data-modifying statement as one named CTE definition. - cteDataModifyingSyntax :: Text -> [Text] -> Sql99CTEDataModifyingSyntax syntax -> syntax diff --git a/beam-core/Database/Beam/Query.hs b/beam-core/Database/Beam/Query.hs index d64fbee71..1752984c9 100644 --- a/beam-core/Database/Beam/Query.hs +++ b/beam-core/Database/Beam/Query.hs @@ -100,9 +100,7 @@ import Prelude hiding (lookup) import Database.Beam.Query.Aggregate import Database.Beam.Query.Combinators -import Database.Beam.Query.CTE - ( CtePlacement(..), ReusableQ, With - , reuse, selecting, toTopLevel ) +import Database.Beam.Query.CTE ( With, ReusableQ, selecting, reuse ) import qualified Database.Beam.Query.CTE as CTE import Database.Beam.Query.CustomSQL import Database.Beam.Query.DataTypes @@ -155,25 +153,14 @@ select :: forall be db res select q = SqlSelect (buildSqlQuery "t" q) --- | Create a top-level 'SqlSelect' for a query which may have common table +-- | Create a 'SqlSelect' for a query which may have common table -- expressions. See the documentation of 'With' for more details. --- --- Unlike a backend-specific nested CTE combinator, this is a top-level --- consumer and therefore accepts both 'CteNestedAllowed' and --- 'CteTopLevelOnly' blocks. For example: --- --- > selectWith $ do --- > reusableRows <- selecting someQuery --- > pure (reuse reusableRows) --- --- A backend-specific data-modifying CTE can appear in the same block; its --- operation fixes the inferred placement to 'CteTopLevelOnly'. -selectWith :: forall be db placement res +selectWith :: forall be db res . ( BeamSqlBackend be, BeamSql99CommonTableExpressionBackend be , HasQBuilder be, Projectible be res ) - => With be db placement (Q be db QBaseScope res) -> SqlSelect be (QExprToIdentity res) -selectWith with = - let (q, (recursiveness, mctes)) = evalState (runWriterT (CTE.runWith with)) 0 + => With be db (Q be db QBaseScope res) -> SqlSelect be (QExprToIdentity res) +selectWith (CTE.With mkQ) = + let (q, (recursiveness, mctes)) = evalState (runWriterT mkQ) 0 in case (recursiveness, nonEmpty mctes) of (CTE.Nonrecursive, Just ctes) -> SqlSelect (withSyntax (NonEmpty.toList ctes) (buildSqlQuery "t" q)) diff --git a/beam-core/Database/Beam/Query/CTE.hs b/beam-core/Database/Beam/Query/CTE.hs index e424fc02c..61bc7bca0 100644 --- a/beam-core/Database/Beam/Query/CTE.hs +++ b/beam-core/Database/Beam/Query/CTE.hs @@ -1,25 +1,7 @@ {-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE RoleAnnotations #-} {-# LANGUAGE UndecidableInstances #-} --- | Construction and reuse of common table expressions. --- --- The 'CtePlacement' index records a property which SQL otherwise checks only --- at execution time: whether a complete @WITH@ block may be placed inside a --- subquery. Most users do not need to mention the index because 'selecting' is --- placement-polymorphic and backend-specific operations refine it as needed. -module Database.Beam.Query.CTE - ( CtePlacement(..) - , With, runWith - , toTopLevel - , Recursiveness(..) - , QAnyScope - , ReusableQ(..) - , reusableForCTE - , selecting - , dataModifyingCte - , reuse - ) where +module Database.Beam.Query.CTE where import Database.Beam.Backend.SQL import Database.Beam.Query.Internal @@ -49,17 +31,6 @@ instance Semigroup (Recursiveness be) where _ <> Recursive = Recursive _ <> _ = Nonrecursive --- | Whether a common-table-expression block may be embedded in a subquery or --- must remain attached to a top-level statement. --- --- Plain @SELECT@ CTEs can be built at either placement. A data-modifying CTE --- forces its enclosing 'With' block to 'CteTopLevelOnly'. This prevents --- backends such as PostgreSQL from embedding data-modifying statements in a --- location where the server would reject them. -data CtePlacement - = CteNestedAllowed -- ^ The complete @WITH@ block is safe in a subquery. - | CteTopLevelOnly -- ^ The complete @WITH@ block must remain top-level. - -- | Monad in which @SELECT@ statements can be made (via 'selecting') -- and bound to result names for re-use later. This has the advantage -- of only computing each result once. In SQL, this is translated to a @@ -67,72 +38,21 @@ data CtePlacement -- -- Once introduced, results can be re-used in future queries with 'reuse'. -- --- A nested-safe 'With' block is also a member of 'MonadFix' for backends that --- support recursive CTEs. In this case, you can use @mdo@ or @rec@ notation --- (with @RecursiveDo@ enabled) to bind result values (again, using 'reuse') --- even /before/ they're introduced. Use 'toTopLevel' after constructing a --- recursive @SELECT@ block if it must be combined with data-modifying CTEs. --- --- The 'CtePlacement' index records whether the block may be embedded in a --- subquery. It is normally inferred: 'selecting' is valid at either placement, --- while a backend-specific data-modifying operation makes the complete block --- 'CteTopLevelOnly'. --- --- A normal, non-recursive use looks like: --- --- > selectWith $ do --- > reusableRows <- selecting someQuery --- > pure (reuse reusableRows) +-- 'With' is also a member of 'MonadFix' for backends that support +-- recursive CTEs. In this case, you can use @mdo@ or @rec@ notation +-- (with @RecursiveDo@ enabled) to bind result values (again, using +-- 'reuse') even /before/ they're introduced. -- -- See further documentation . -newtype With be (db :: (Type -> Type) -> Type) (placement :: CtePlacement) a - = With - { -- | Unwrap a CTE builder. This is primarily intended for top-level - -- statement consumers such as @selectWith@ and backend-specific - -- equivalents. - runWith :: WriterT (Recursiveness be, [ BeamSql99BackendCTESyntax be ]) - (State Int) a - } +newtype With be (db :: (Type -> Type) -> Type) a + = With { runWith :: WriterT (Recursiveness be, [ BeamSql99BackendCTESyntax be ]) + (State Int) a } deriving (Monad, Applicative, Functor) --- The placement index is phantom in the runtime representation. Keep every --- parameter nominal so Data.Coerce cannot relabel a top-level-only block and --- bypass the smart constructors which establish the invariant. -type role With nominal nominal nominal nominal - --- Restrict the recursive knot to SELECT-only, nested-safe construction. A --- data-modifying operation fixes the placement to CteTopLevelOnly and therefore --- cannot recursively depend on its own RETURNING rows. --- --- Keep @placement@ variable in the instance head and refine it with an equality --- constraint. This lets recursive @selectWith@ call sites infer --- 'CteNestedAllowed' even though a top-level consumer does not otherwise expose --- the placement index in its result type. -instance ( placement ~ 'CteNestedAllowed - , IsSql99RecursiveCommonTableExpressionSelectSyntax (BeamSqlBackendSelectSyntax be) ) - => MonadFix (With be db placement) where +instance IsSql99RecursiveCommonTableExpressionSelectSyntax (BeamSqlBackendSelectSyntax be) + => MonadFix (With be db) where mfix f = With (tell (Recursive, mempty) >> mfix (runWith . f)) --- | Promote a nested-safe CTE block for composition with top-level-only CTEs. --- --- Recursion is deliberately available only while constructing a --- 'CteNestedAllowed' block. Promote the completed recursive @SELECT@ block with --- this function before sequencing it with data-modifying CTEs. This permits --- recursive queries to feed data-modifying statements without allowing a --- data-modifying statement itself to participate in the recursive knot. --- --- For example, a backend can first finish the recursive, SELECT-only portion --- and then continue in a top-level block: --- --- > recursiveRows <- toTopLevel $ mdo --- > rows <- selecting (seedQuery `unionAll_` stepQuery (reuse rows)) --- > pure rows --- > changedRows <- backendDataModifyingCte recursiveRows -toTopLevel - :: With be db 'CteNestedAllowed a - -> With be db 'CteTopLevelOnly a -toTopLevel (With action) = With action - data QAnyScope -- | Query results that have been introduced into a common table @@ -157,20 +77,11 @@ reusableForCTE tblNm = -- | Introduce the result of a query as a result in a common table -- expression. The returned value can be used in future queries by -- applying 'reuse'. --- --- > reusableRows <- selecting someQuery --- > pure $ do --- > row <- reuse reusableRows --- > guard_ (isWanted row) --- > pure row --- --- The query must project at least one column. Empty projections cannot form a --- reusable SQL relation and are rejected while the @WITH@ block is built. -selecting :: forall res be db placement +selecting :: forall res be db . ( BeamSql99CommonTableExpressionBackend be, HasQBuilder be , Projectible be res , ThreadRewritable QAnyScope res ) - => Q be db QAnyScope res -> With be db placement (ReusableQ be db res) + => Q be db QAnyScope res -> With be db (ReusableQ be db res) selecting q = With $ do cteId <- get @@ -179,54 +90,7 @@ selecting q = let tblNm = fromString ("cte" ++ show cteId) (_ :: res, fieldNames) = mkFieldNames @be (qualifiedField tblNm) - case fieldNames of - [] -> error "Database.Beam.Query.CTE.selecting: a CTE must project at least one column" - _ -> tell (Nonrecursive, [ cteSubquerySyntax tblNm fieldNames (buildSqlQuery (tblNm <> "_") q) ]) - - pure (reusableForCTE tblNm) - --- | Introduce the result of a backend-specific data-modifying statement as a --- common table expression. The statement is expected to return rows shaped like --- @res@, for example by using @INSERT ... RETURNING@, @UPDATE ... RETURNING@, --- or @DELETE ... RETURNING@ on backends that support those forms. --- --- This is a low-level helper intended for backend-specific APIs. The returned --- value can be used in future queries by applying 'reuse'. Its enclosing --- 'With' block is marked 'CteTopLevelOnly', so it cannot be passed to a backend --- combinator for nested CTEs. --- --- Backend APIs normally obtain @body@ from an existing @... RETURNING@ --- builder, then expose a typed wrapper to users: --- --- > backendCteReturning statement = --- > dataModifyingCte (backendDataModifyingSyntax statement) --- --- This produces one definition such as: --- --- @ --- changed(res0) AS (DELETE FROM items WHERE expired RETURNING id) --- @ --- --- The statement must return at least one column. A zero-column result cannot --- be exposed as a reusable SQL relation and is rejected while the @WITH@ block --- is built. -dataModifyingCte :: forall res be db - . ( BeamSql99DataModifyingCommonTableExpressionBackend be - , Projectible be res - , ThreadRewritable QAnyScope res ) - => Sql99CTEDataModifyingSyntax (BeamSql99BackendCTESyntax be) - -> With be db 'CteTopLevelOnly (ReusableQ be db res) -dataModifyingCte body = - With $ do - cteId <- get - put (cteId + 1) - - let tblNm = fromString ("cte" ++ show cteId) - - (_ :: res, fieldNames) = mkFieldNames @be (qualifiedField tblNm) - case fieldNames of - [] -> error "Database.Beam.Query.CTE.dataModifyingCte: a CTE must return at least one column" - _ -> tell (Nonrecursive, [ cteDataModifyingSyntax tblNm fieldNames body ]) + tell (Nonrecursive, [ cteSubquerySyntax tblNm fieldNames (buildSqlQuery (tblNm <> "_") q) ]) pure (reusableForCTE tblNm) @@ -234,3 +98,4 @@ dataModifyingCte body = reuse :: forall s be db res . ReusableQ be db res -> Q be db s (WithRewrittenThread QAnyScope s res) reuse (ReusableQ _ q) = q (Proxy @s) + diff --git a/beam-core/beam-core.cabal b/beam-core/beam-core.cabal index 343d29695..dc6cf4322 100644 --- a/beam-core/beam-core.cabal +++ b/beam-core/beam-core.cabal @@ -1,5 +1,5 @@ name: beam-core -version: 0.12.0.0 +version: 0.11.2.0 synopsis: Type-safe, feature-complete SQL query and manipulation interface for Haskell description: Beam is a Haskell library for type-safe querying and manipulation of SQL databases. Beam is modular and supports various backends. In order to use beam, you will need to use diff --git a/beam-duckdb/beam-duckdb.cabal b/beam-duckdb/beam-duckdb.cabal index 7b69800c4..0a21ec0dc 100644 --- a/beam-duckdb/beam-duckdb.cabal +++ b/beam-duckdb/beam-duckdb.cabal @@ -51,7 +51,7 @@ library Database.Beam.DuckDB.Syntax.Extensions.InsertOnConflict build-depends: aeson >=1.0 && <2.4 , base >=4.11 && <5 - , beam-core >=0.11.1 && <0.13 + , beam-core >=0.11.1 && <0.12 , beam-migrate ^>=0.6 , bytestring >=0.10 && <0.13 -- Version 0.1.5.0 contained a broken change (RowParser constructor not exposed) diff --git a/beam-migrate/beam-migrate.cabal b/beam-migrate/beam-migrate.cabal index e794999bb..3858b3fba 100644 --- a/beam-migrate/beam-migrate.cabal +++ b/beam-migrate/beam-migrate.cabal @@ -56,7 +56,7 @@ library Database.Beam.Migrate.Types.Predicates build-depends: base >=4.11 && <5.0, - beam-core >=0.11 && <0.13, + beam-core >=0.11 && <0.12, text >=1.2 && <2.2, aeson >=2.0 && <2.4, bytestring >=0.10 && <0.13, diff --git a/beam-postgres/ChangeLog.md b/beam-postgres/ChangeLog.md index 9cb02e460..76ab61738 100644 --- a/beam-postgres/ChangeLog.md +++ b/beam-postgres/ChangeLog.md @@ -1,27 +1,3 @@ -# 0.7.0.0 - -## Interface changes - -* Restricted `pgSelectWith` to `CteNestedAllowed` blocks, preventing - PostgreSQL data-modifying CTEs from being embedded in subqueries. - -## Added features - -* Added `cteInsertReturning`, `cteUpdateReturning`, and `cteDeleteReturning` - for using PostgreSQL data-modifying statements in top-level common table - expressions. Their placement index prevents them from being passed to - `pgSelectWith`, since PostgreSQL does not allow data-modifying CTEs in - subqueries. -* Added `pgInsertWith`, `pgUpdateWith`, and `pgDeleteWith` for terminating a - top-level PostgreSQL `WITH` block with the corresponding data-modifying - statement. These consumers accept both CTE placement indices and preserve - recursive `SELECT` CTEs. - -## Bug fixes - -* Reject zero-column data-modifying CTE projections before rendering an empty - `RETURNING` list. - # 0.6.2.0 ## Added features @@ -31,11 +7,30 @@ over colums of type `citext` (#818) * Exposed the functionality to implement user-defined extensions via `Database.Beam.Postgres.Extensions` (#819) +* 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 `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. +* Reject zero-column reusable CTE projections before Beam can render an invalid + empty column-alias list (`cte()`), or an empty `RETURNING` list for a + data-modifying CTE. # 0.6.1.0 diff --git a/beam-postgres/Database/Beam/Postgres/Full.hs b/beam-postgres/Database/Beam/Postgres/Full.hs index 5dd6ede43..e9fb05682 100644 --- a/beam-postgres/Database/Beam/Postgres/Full.hs +++ b/beam-postgres/Database/Beam/Postgres/Full.hs @@ -1,7 +1,9 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RoleAnnotations #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TypeOperators #-} @@ -10,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 @@ -20,14 +27,18 @@ module Database.Beam.Postgres.Full , locked_, lockAll_, withLocks_ - -- ** @WITH@ statement consumers - , pgSelectWith, pgInsertWith, pgUpdateWith, pgDeleteWith + -- ** 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, cteInsertReturning + , insert, insertReturning, cteInsert, cteInsertReturning , insertDefaults , runPgInsertReturningList @@ -46,12 +57,12 @@ module Database.Beam.Postgres.Full -- * @UPDATE RETURNING@ , PgUpdateReturning(..) , runPgUpdateReturningList - , updateReturning, cteUpdateReturning + , updateReturning, cteUpdate, cteUpdateReturning -- * @DELETE RETURNING@ , PgDeleteReturning(..) , runPgDeleteReturningList - , deleteReturning, cteDeleteReturning + , deleteReturning, cteDelete, cteDeleteReturning -- * Generalized @RETURNING@ , PgReturning(..) @@ -67,18 +78,214 @@ 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 +-- . +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'. +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. +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 ... +-- @ +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 +-- . +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" +-- @ +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. +-- +-- Beam names every projected CTE column. A zero-column projection would make +-- that generated alias list @()@, which PostgreSQL rejects, so this function +-- rejects it before the SQL is sent. +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) + in pgOutputCteSyntax + "Database.Beam.Postgres.Full.pgSelectingWith" + name + fields + materialization + (fromPgSelect (buildSqlQuery (name <> "_") q)) + 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. @@ -221,19 +428,48 @@ 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 placement cannot depend on a runtime value. +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 'selectWith' blocks and --- cannot be used with 'pgSelectWith'. +-- 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: -- --- > selectWith $ do +-- > pgSelectWithTopLevel $ do -- > inserted <- cteInsertReturning -- > users -- > (insertValues [newUser]) @@ -259,13 +495,13 @@ cteInsertReturning -> SqlInsertValues Postgres (table (QExpr Postgres s)) -> PgInsertOnConflict table -> (table (QExpr Postgres PostgresInaccessible) -> a) - -> With Postgres db 'CTE.CteTopLevelOnly (Maybe (ReusableQ Postgres db (WithRewrittenThread PostgresInaccessible CTE.QAnyScope 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 <$> CTE.dataModifyingCte - (PgDataModifyingCommonTableExpressionSyntax syntax) + Just <$> pgDataModifyingCte + "Database.Beam.Postgres.Full.cteInsertReturning" syntax runPgInsertReturningList :: ( MonadBeam be m @@ -325,9 +561,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, -- @@ -335,11 +569,9 @@ 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. Its 'CteNestedAllowed' index --- statically prevents PostgreSQL data-modifying CTEs from being embedded here; --- those must be consumed by top-level 'selectWith'. +-- @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 @@ -351,13 +583,47 @@ lateral_ using mkSubquery = do -- SELECT ... FROM (WITH cte0 AS (SELECT ...) SELECT ... FROM cte0) AS nested -- @ -- --- Replacing 'selecting' above with 'cteDeleteReturning', for example, does not --- type-check because PostgreSQL requires data-modifying CTEs at the top level. pgSelectWith :: forall db s res . Projectible Postgres res - => With Postgres db 'CTE.CteNestedAllowed (Q Postgres db s res) -> Q Postgres db s res -pgSelectWith with = - let (q, (recursiveness, mctes)) = evalState (runWriterT (CTE.runWith with)) 0 + => With Postgres db (Q Postgres db s res) -> Q Postgres db s res +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") +-- @ +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 (CTE.Nonrecursive, Just ctes) -> withSyntax (NonEmpty.toList ctes) (buildSqlQuery tblPfx q) @@ -378,23 +644,56 @@ pgSelectWith with = (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. +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 'pgSelectWith', this is a top-level statement consumer and therefore --- accepts both 'CteNestedAllowed' and 'CteTopLevelOnly' blocks. The final --- insert can read reusable rows produced by either SELECT CTEs or +-- 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 <- selecting sourceQuery +-- > rows <- pgSelecting sourceQuery -- > pure $ insert destination (insertFrom (reuse rows)) onConflictDefault -- -- This produces a statement with the following shape: -- -- @ --- WITH cte0 AS (SELECT ...) --- INSERT INTO destination ... SELECT ... FROM cte0 +-- 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 @@ -404,7 +703,7 @@ pgSelectWith with = -- Apply 'returning' to the resulting 'SqlInsert' when the terminal statement -- should return rows. pgInsertWith - :: With Postgres db placement (SqlInsert Postgres table) + :: PgWith db placement (SqlInsert Postgres table) -> SqlInsert Postgres table pgInsertWith with = case runPgWith with of @@ -419,13 +718,23 @@ pgInsertWith with = -- example through 'exists_': -- -- > pgUpdateWith $ do --- > wanted <- selecting wantedUsers +-- > 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. @@ -433,7 +742,7 @@ pgInsertWith with = -- Apply 'returning' to the resulting 'SqlUpdate' when the terminal statement -- should return rows. pgUpdateWith - :: With Postgres db placement (SqlUpdate Postgres table) + :: PgWith db placement (SqlUpdate Postgres table) -> SqlUpdate Postgres table pgUpdateWith with = case runPgWith with of @@ -445,30 +754,125 @@ pgUpdateWith with = -- @DELETE@ statement. -- -- > pgDeleteWith $ do --- > expired <- selecting expiredUsers +-- > 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. pgDeleteWith - :: With Postgres db placement (SqlDelete Postgres table) + :: PgWith db placement (SqlDelete Postgres table) -> SqlDelete Postgres table pgDeleteWith with = case runPgWith with of (SqlDelete settings (PgDeleteSyntax statement), recursive, ctes) -> SqlDelete settings (PgDeleteSyntax (pgWithSyntax recursive 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 and reject an empty output before PostgreSQL can +-- receive the malformed explicit alias list @name() AS (...)@. PostgreSQL can +-- represent a zero-column SELECT CTE when the alias list is omitted, but Beam's +-- reusable projection path assigns a name to every output column. The function +-- name is included in the error so failures identify the public builder which +-- accepted the empty projection. +pgOutputCteSyntax + :: String + -> Text + -> [Text] + -> PgCteMaterialization + -> PgSyntax + -> PgCommonTableExpressionSyntax +pgOutputCteSyntax origin name fields materialization body = + case nonEmpty fields of + Nothing -> error (origin ++ ": a PostgreSQL CTE must project at least one column") + Just fields' -> 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 meaningful only for a +-- modifying statement 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. +pgDataModifyingCte + :: forall res db + . ( Projectible Postgres res + , ThreadRewritable CTE.QAnyScope res ) + => String + -> PgSyntax + -> PgWith db 'PgCteTopLevelOnly (ReusableQ Postgres db res) +pgDataModifyingCte origin body = do + tblNm <- pgRegisterCte $ \name -> + let (_ :: res, fields) = mkFieldNames @Postgres (qualifiedField name) + in pgOutputCteSyntax origin name fields PgCteDefault body + pure (CTE.reusableForCTE tblNm) + +-- Register a modifying CTE without RETURNING. PostgreSQL executes the body but +-- creates no relation which could be passed to reuse, hence 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 - :: With Postgres db placement a + :: PgWith db placement a -> (a, Bool, [BeamSql99BackendCTESyntax Postgres]) -runPgWith with = +runPgWith (PgWith with) = let (result, (recursiveness, ctes)) = evalState (runWriterT (CTE.runWith with)) 0 recursive = case recursiveness of @@ -548,16 +952,48 @@ 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. +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 'selectWith' blocks and --- cannot be used with 'pgSelectWith'. +-- Data-modifying CTEs are restricted to top-level 'PgWith' blocks and cannot +-- be used with 'pgSelectWithNested'. -- --- > selectWith $ do +-- > pgSelectWithTopLevel $ do -- > updated <- cteUpdateReturning -- > users -- > (\user -> userEnabled user <-. val_ False) @@ -568,7 +1004,14 @@ updateReturning table@(DatabaseEntity (DatabaseTable { dbTableSettings = tblSett -- > Just rows -> pure (reuse rows) -- -- This renders the update once inside @WITH@ and reads its @RETURNING@ rows --- through the reusable CTE name. +-- 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" +-- @ cteUpdateReturning :: ( Projectible Postgres a , ThreadRewritable PostgresInaccessible a @@ -579,13 +1022,13 @@ cteUpdateReturning -> (forall s. table (QField s) -> QAssignment Postgres s) -> (forall s. table (QExpr Postgres s) -> QExpr Postgres s Bool) -> (table (QExpr Postgres PostgresInaccessible) -> a) - -> With Postgres db 'CTE.CteTopLevelOnly (Maybe (ReusableQ Postgres db (WithRewrittenThread PostgresInaccessible CTE.QAnyScope 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 <$> CTE.dataModifyingCte - (PgDataModifyingCommonTableExpressionSyntax syntax) + Just <$> pgDataModifyingCte + "Database.Beam.Postgres.Full.cteUpdateReturning" syntax runPgUpdateReturningList :: ( MonadBeam be m @@ -628,23 +1071,62 @@ 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. +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 mkWhere 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 'selectWith' blocks and --- cannot be used with 'pgSelectWith'. +-- 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: -- --- > selectWith $ do +-- > 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. @@ -657,11 +1139,11 @@ cteDeleteReturning => DatabaseEntity Postgres db (TableEntity table) -> (forall s. table (QExpr Postgres s) -> QExpr Postgres s Bool) -> (table (QExpr Postgres PostgresInaccessible) -> a) - -> With Postgres db 'CTE.CteTopLevelOnly (ReusableQ Postgres db (WithRewrittenThread PostgresInaccessible CTE.QAnyScope a)) + -> PgWith db 'PgCteTopLevelOnly (ReusableQ Postgres db (WithRewrittenThread PostgresInaccessible CTE.QAnyScope a)) cteDeleteReturning table mkWhere mkProjection = let PgDeleteReturning syntax = deleteReturning table mkWhere mkProjection - in CTE.dataModifyingCte - (PgDataModifyingCommonTableExpressionSyntax syntax) + in pgDataModifyingCte + "Database.Beam.Postgres.Full.cteDeleteReturning" syntax runPgDeleteReturningList :: ( MonadBeam be m diff --git a/beam-postgres/Database/Beam/Postgres/Syntax.hs b/beam-postgres/Database/Beam/Postgres/Syntax.hs index 18fc3a1e6..1ebc25624 100644 --- a/beam-postgres/Database/Beam/Postgres/Syntax.hs +++ b/beam-postgres/Database/Beam/Postgres/Syntax.hs @@ -31,7 +31,6 @@ module Database.Beam.Postgres.Syntax , PgDeleteSyntax(..) , PgUpdateSyntax(..) , PgCommonTableExpressionSyntax(..) - , PgDataModifyingCommonTableExpressionSyntax(..) , PgExpressionSyntax(..), PgFromSyntax(..), PgTableNameSyntax(..) , PgComparisonQuantifierSyntax(..) @@ -274,21 +273,18 @@ 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". newtype PgCommonTableExpressionSyntax = PgCommonTableExpressionSyntax { fromPgCommonTableExpression :: PgSyntax } --- | PostgreSQL syntax for the statement placed inside a data-modifying CTE. --- --- The wrapped syntax is the body only, for example @DELETE ... RETURNING ...@. --- 'cteDataModifyingSyntax' supplies the CTE name, output column aliases, --- parentheses, and @AS@ wrapper. -newtype PgDataModifyingCommonTableExpressionSyntax - = PgDataModifyingCommonTableExpressionSyntax { fromPgDataModifyingCommonTableExpression :: PgSyntax } - -- | Prefix a PostgreSQL statement with a common-table-expression list. --- PostgreSQL accepts the same @WITH@ prefix before @SELECT@, @INSERT@, --- @UPDATE@, and @DELETE@, so this operation works on the shared raw syntax --- instead of giving the terminal statement a misleading type. +-- 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. The boolean selects -- @WITH RECURSIVE@ when the CTE builder used recursive bindings. @@ -656,23 +652,13 @@ instance IsSql99RecursiveCommonTableExpressionSelectSyntax PgSelectSyntax where instance IsSql99CommonTableExpressionSyntax PgCommonTableExpressionSyntax where type Sql99CTESelectSyntax PgCommonTableExpressionSyntax = PgSelectSyntax + cteSubquerySyntax _ [] _ = + error "Database.Beam.Query.CTE.selecting: a PostgreSQL CTE must project at least one column" cteSubquerySyntax tbl fields (PgSelectSyntax select) = PgCommonTableExpressionSyntax $ pgQuotedIdentifier tbl <> pgParens (pgSepBy (emit ",") (map pgQuotedIdentifier fields)) <> emit " AS " <> pgParens select -instance IsSql99DataModifyingCommonTableExpressionSyntax PgCommonTableExpressionSyntax where - type Sql99CTEDataModifyingSyntax PgCommonTableExpressionSyntax = PgDataModifyingCommonTableExpressionSyntax - - -- Render the same outer shape as a SELECT CTE, but preserve the raw - -- PostgreSQL data-modifying statement as its body: - -- - -- @cte0(res0) AS (DELETE ... RETURNING ...)@ - cteDataModifyingSyntax tbl fields (PgDataModifyingCommonTableExpressionSyntax body) = - PgCommonTableExpressionSyntax $ - pgQuotedIdentifier tbl <> pgParens (pgSepBy (emit ",") (map pgQuotedIdentifier fields)) <> - emit " AS " <> pgParens body - instance IsSql2008BigIntDataTypeSyntax PgDataTypeSyntax where bigIntType = PgDataTypeSyntax (PgDataTypeDescrOid (Pg.typoid Pg.int8) Nothing) (emit "BIGINT") bigIntType diff --git a/beam-postgres/beam-postgres.cabal b/beam-postgres/beam-postgres.cabal index 7a635688a..f41ebcb05 100644 --- a/beam-postgres/beam-postgres.cabal +++ b/beam-postgres/beam-postgres.cabal @@ -1,5 +1,5 @@ name: beam-postgres -version: 0.7.0.0 +version: 0.6.2.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 @@ -36,7 +36,7 @@ library Database.Beam.Postgres.Types build-depends: base >=4.11 && <5.0, - beam-core >=0.12 && <0.13, + beam-core >=0.11.1 && <0.12, beam-migrate >=0.6 && <0.7, postgresql-libpq >=0.8 && <0.12, diff --git a/beam-postgres/test/Database/Beam/Postgres/Test.hs b/beam-postgres/test/Database/Beam/Postgres/Test.hs index eccdeceb4..29d971506 100644 --- a/beam-postgres/test/Database/Beam/Postgres/Test.hs +++ b/beam-postgres/test/Database/Beam/Postgres/Test.hs @@ -14,8 +14,8 @@ withTestPostgres dbName getConnStr action = do connStr <- getConnStr -- Create and drop isolated test databases from the administrative postgres - -- database. Connecting to template1 while cloning it is rejected by recent - -- PostgreSQL releases because the template database is already in use. + -- database, leaving template1 free to serve as CREATE DATABASE's default + -- template. let connStrAdmin = connStr <> " dbname=postgres" connStrDb = connStr <> " dbname=" <> fromString dbName diff --git a/beam-postgres/test/Database/Beam/Postgres/Test/CTE.hs b/beam-postgres/test/Database/Beam/Postgres/Test/CTE.hs index aad72af0a..7a46f0a68 100644 --- a/beam-postgres/test/Database/Beam/Postgres/Test/CTE.hs +++ b/beam-postgres/test/Database/Beam/Postgres/Test/CTE.hs @@ -48,9 +48,11 @@ data CteRowT f = CteRow deriving instance Show (CteRowT Identity) deriving instance Eq (CteRowT Identity) --- A legal Haskell projection shape with no fields. PostgreSQL has no --- corresponding zero-column SELECT or RETURNING relation, so the CTE builders --- must reject it before rendering SQL. +-- A legal Haskell projection shape with no fields. PostgreSQL accepts a +-- zero-column SELECT CTE only when its output alias list is omitted, whereas +-- Beam's reusable CTE representation names every output column. It also cannot +-- emit a bare RETURNING keyword. The builders therefore reject this shape +-- instead of rendering cte() or an empty RETURNING list. data EmptyCteT (f :: Type -> Type) = EmptyCte deriving (Generic, Beamable) @@ -76,9 +78,13 @@ unitTests = testGroup "Common table expression tests" 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 ] @@ -86,6 +92,11 @@ integrationTests getConn = testGroup "Common table expression integration tests" renderingTests :: TestTree renderingTests = testGroup "Common table expression rendering tests" [ testMixedCteRendering + , testMaterializationRendering + , testNestedMaterializedCteRendering + , testSideEffectOnlyRendering + , testSideEffectNoOps + , testLiftedWithNameSupply , testNestedSelectCteRendering , testRecursiveSelectThenDeleteRendering , testEmptyDataModifyingCtes @@ -115,12 +126,18 @@ typeSafetyTests = testGroup "Common table expression type-safety tests" 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 - ["CteTopLevelOnly", "CteNestedAllowed"] + ["No instance", "MonadFix", "PgCteTopLevelOnly"] Negative.invalidRecursiveInsert + , testCase "side-effect-only CTE results cannot be reused" $ + assertDeferredTypeErrorContaining + ["ReusableQ"] + Negative.invalidReuseSideEffect ] projectionValidationTests :: TestTree @@ -133,7 +150,7 @@ projectionValidationTests = testGroup "Common table expression projection valida assertPlacementTypeError :: SqlSelect Postgres a -> Assertion assertPlacementTypeError = - assertDeferredTypeErrorContaining ["CteTopLevelOnly", "CteNestedAllowed"] + assertDeferredTypeErrorContaining ["PgCteTopLevelOnly", "PgCteNestedAllowed"] assertDeferredTypeErrorContaining :: [String] @@ -149,7 +166,9 @@ assertDeferredTypeErrorContaining expectedFragments sql = do assertFailure "expected the expression to contain a deferred type error" where assertFragment message fragment = - assertBool ("mentions " ++ fragment) (fragment `isInfixOf` message) + assertBool + ("mentions " ++ fragment ++ "\nDeferred error was:\n" ++ message) + (fragment `isInfixOf` message) assertEmptyProjectionError :: SqlSelect Postgres a -> Assertion assertEmptyProjectionError sql = do @@ -174,6 +193,64 @@ testMixedCteRendering = testCase "renders mixed SELECT, INSERT, UPDATE, and DELE 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 does not create a +-- relation. 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 @@ -181,7 +258,7 @@ testNestedSelectCteRendering = testCase "SELECT CTEs remain valid inside pgSelec let sql = renderSelect nestedSelectCteSelect assertBool "renders an inner WITH" ("FROM (WITH " `isInfixOf` sql) --- Closing the recursive SELECT portion with toTopLevel should preserve WITH +-- 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 @@ -215,7 +292,7 @@ testRecursiveInsertWithRendering = testCase "renders WITH RECURSIVE before a ter 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 CteTopLevelOnly placement. +-- 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 @@ -274,6 +351,54 @@ testMixedCteBodies getConn = testCase "SELECT and data-modifying CTEs can be mix ] 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 side effects were applied exactly once" + [ 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. @@ -364,6 +489,43 @@ testDataModifyingCteModel getConn = testCase "data-modifying CTEs agree with a p assertBool "data-modifying CTE model property failed" passes +-- Repeat the three-operation model without RETURNING. This catches parameter +-- ordering or accidental omission in the optimized 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 @@ -414,7 +576,7 @@ testWithDmlConsumerModel getConn = testCase "WITH DML consumers agree with a pur -- 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 toTopLevel promotion, +-- 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" $ @@ -450,6 +612,77 @@ testRecursiveCteModel getConn = testCase "recursive CTE execution agrees with a assertBool "recursive CTE model property failed" passes +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. @@ -460,8 +693,8 @@ mixedCteSelect , CteRowT Identity , CteRowT Identity ) -mixedCteSelect = selectWith $ topLevelOnly $ do - selected <- selecting $ do +mixedCteSelect = Pg.pgSelectWithTopLevel $ do + selected <- Pg.pgSelecting $ do row <- all_ (dbCteRows cteDb) guard_ (cteId row ==. val_ 1) pure row @@ -530,7 +763,7 @@ dataModifyingCteModelSelect -> SqlSelect Postgres (CteRowT Identity, CteRowT Identity, CteRowT Identity) dataModifyingCteModelSelect inserted updateId updateValue deleteId = - selectWith $ do + Pg.pgSelectWithTopLevel $ do insertedRows <- Pg.cteInsertReturning (dbCteRows cteDb) (insertValues [inserted]) @@ -554,6 +787,27 @@ dataModifyingCteModelSelect inserted updateId updateValue deleteId = 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 @@ -561,7 +815,7 @@ modelInsertWithStatement -> CteRowT Identity -> SqlInsert Postgres CteRowT modelInsertWithStatement sourceId inserted = Pg.pgInsertWith $ do - sourceIds <- selecting $ do + sourceIds <- Pg.pgSelecting $ do row <- all_ (dbCteRows cteDb) guard_ (cteId row ==. val_ sourceId) pure (cteId row) @@ -579,7 +833,7 @@ modelUpdateWithStatement -> Text -> SqlUpdate Postgres CteRowT modelUpdateWithStatement updateId updateValue = Pg.pgUpdateWith $ do - targetIds <- selecting $ do + targetIds <- Pg.pgSelecting $ do row <- all_ (dbCteRows cteDb) guard_ (cteId row ==. val_ updateId) pure (cteId row) @@ -595,7 +849,7 @@ modelDeleteWithStatement :: Int32 -> SqlDelete Postgres CteRowT modelDeleteWithStatement deleteId = Pg.pgDeleteWith $ do - targetIds <- selecting $ do + targetIds <- Pg.pgSelecting $ do row <- all_ (dbCteRows cteDb) guard_ (cteId row ==. val_ deleteId) pure (cteId row) @@ -608,9 +862,9 @@ recursiveCteModelSelect :: Int32 -> Int32 -> SqlSelect Postgres (CteRowT Identity) -recursiveCteModelSelect startId endId = selectWith $ do - recursiveIds <- toTopLevel $ mdo - ids <- selecting $ +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) @@ -628,7 +882,7 @@ recursiveCteModelSelect startId endId = selectWith $ do pure (reuse deletedRows) nestedSelectCteSelect :: SqlSelect Postgres (CteRowT Identity) -nestedSelectCteSelect = select $ Pg.pgSelectWith $ nestedAllowed $ do +nestedSelectCteSelect = select $ Pg.pgSelectWith $ do selected <- selecting $ do row <- all_ (dbCteRows cteDb) guard_ (cteId row ==. val_ 1) @@ -636,12 +890,12 @@ nestedSelectCteSelect = select $ Pg.pgSelectWith $ nestedAllowed $ do pure (reuse selected) -- PostgreSQL permits a recursive SELECT CTE to feed a later modifying CTE, but --- not a modifying CTE to recursively reference itself. 'toTopLevel' closes the +-- 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 = selectWith $ do - recursiveIds <- toTopLevel $ mdo - ids <- selecting $ +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) @@ -659,10 +913,10 @@ recursiveSelectThenDeleteCteSelect = selectWith $ do pure (reuse deleted) -- Empty INSERT values and identity UPDATE assignments do not produce SQL. --- Their wrappers return Nothing, leaving selectWith to render the final query +-- Their wrappers return Nothing, leaving pgSelectWithTopLevel to render the final query -- without an empty WITH clause. emptyDataModifyingCteSelect :: SqlSelect Postgres Int32 -emptyDataModifyingCteSelect = selectWith $ do +emptyDataModifyingCteSelect = Pg.pgSelectWithTopLevel $ do inserted <- Pg.cteInsertReturning (dbCteRows cteDb) SqlInsertValuesEmpty @@ -690,7 +944,7 @@ emptySelectProjection = selectWith $ do pure (reuse rows) emptyDeleteProjection :: SqlSelect Postgres (EmptyCteT Identity) -emptyDeleteProjection = selectWith $ do +emptyDeleteProjection = Pg.pgSelectWithTopLevel $ do rows <- Pg.cteDeleteReturning (dbCteRows cteDb) (const (val_ False)) @@ -701,7 +955,7 @@ emptyDeleteProjection = selectWith $ do -- the reusable query to the terminal INSERT source. insertWithStatement :: SqlInsert Postgres CteRowT insertWithStatement = Pg.pgInsertWith $ do - source <- selecting $ do + source <- Pg.pgSelecting $ do row <- all_ (dbCteRows cteDb) guard_ (cteId row ==. val_ 1) pure row @@ -716,7 +970,7 @@ insertWithStatement = Pg.pgInsertWith $ do -- the terminal UPDATE predicate. updateWithStatement :: SqlUpdate Postgres CteRowT updateWithStatement = Pg.pgUpdateWith $ do - targets <- selecting $ do + targets <- Pg.pgSelecting $ do row <- all_ (dbCteRows cteDb) guard_ (cteId row ==. val_ 3) pure (cteId row) @@ -732,7 +986,7 @@ updateWithStatement = Pg.pgUpdateWith $ do -- the third terminal syntax wrapper. deleteWithStatement :: SqlDelete Postgres CteRowT deleteWithStatement = Pg.pgDeleteWith $ do - targets <- selecting $ do + targets <- Pg.pgSelecting $ do row <- all_ (dbCteRows cteDb) guard_ (cteId row ==. val_ 4) pure (cteId row) @@ -744,8 +998,12 @@ deleteWithStatement = Pg.pgDeleteWith $ do -- 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 $ mdo - ids <- selecting $ +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) @@ -757,7 +1015,7 @@ recursiveInsertWithStatement = Pg.pgInsertWith $ mdo pure (CteRow rowId (val_ "recursive"))) Pg.onConflictDefault --- Adding a modifying CTE fixes the block to CteTopLevelOnly. pgDeleteWith is +-- 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 @@ -771,7 +1029,7 @@ topLevelOnlyDeleteWithStatement = Pg.pgDeleteWith $ do emptyInsertWithStatement :: SqlInsert Postgres CteRowT emptyInsertWithStatement = Pg.pgInsertWith $ do - _ <- selecting $ all_ (dbCteRows cteDb) + _ <- Pg.pgSelecting $ all_ (dbCteRows cteDb) pure $ Pg.insert (dbCteRows cteDb) SqlInsertValuesEmpty @@ -779,7 +1037,7 @@ emptyInsertWithStatement = Pg.pgInsertWith $ do identityUpdateWithStatement :: SqlUpdate Postgres CteRowT identityUpdateWithStatement = Pg.pgUpdateWith $ do - _ <- selecting $ all_ (dbCteRows cteDb) + _ <- Pg.pgSelecting $ all_ (dbCteRows cteDb) pure $ update (dbCteRows cteDb) (const mempty) @@ -842,13 +1100,3 @@ renderSelect = BL.unpack . renderSelectBytes renderSelectBytes :: SqlSelect Postgres a -> BL.ByteString renderSelectBytes (SqlSelect (PgSelectSyntax syntax)) = pgRenderSyntaxScript syntax - -topLevelOnly - :: With be db 'CteTopLevelOnly a - -> With be db 'CteTopLevelOnly a -topLevelOnly = id - -nestedAllowed - :: With be db 'CteNestedAllowed a - -> With be db 'CteNestedAllowed a -nestedAllowed = id diff --git a/beam-postgres/test/Database/Beam/Postgres/Test/CTENegative.hs b/beam-postgres/test/Database/Beam/Postgres/Test/CTENegative.hs index abfb3976c..fb2941f2d 100644 --- a/beam-postgres/test/Database/Beam/Postgres/Test/CTENegative.hs +++ b/beam-postgres/test/Database/Beam/Postgres/Test/CTENegative.hs @@ -14,8 +14,10 @@ module Database.Beam.Postgres.Test.CTENegative , invalidNestedDeleteThenSelect , invalidNestedEmptyInsert , invalidNestedIdentityUpdate + , invalidNestedSideEffectDelete , invalidCoercedPlacement , invalidRecursiveInsert + , invalidReuseSideEffect ) where import qualified Data.Coerce as Coerce @@ -48,15 +50,16 @@ negativeCteDb :: DatabaseSettings Postgres NegativeCteDb negativeCteDb = defaultDbSettings -- Each of the following three expressions attempts to put a modifying CTE in --- pgSelectWith. They must fail with CteTopLevelOnly versus CteNestedAllowed, +-- 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.pgSelectWith $ do +invalidNestedDelete = select $ Pg.pgSelectWithNested $ do deleted <- topLevelDeleteCte pure (reuse deleted) invalidNestedInsert :: SqlSelect Postgres (NegativeCteRowT Identity) -invalidNestedInsert = select $ Pg.pgSelectWith $ do +invalidNestedInsert = select $ Pg.pgSelectWithNested $ do inserted <- Pg.cteInsertReturning (negativeCteRows negativeCteDb) (insertValues [NegativeCteRow 2 "inserted"]) @@ -67,7 +70,7 @@ invalidNestedInsert = select $ Pg.pgSelectWith $ do Just inserted' -> pure (reuse inserted') invalidNestedUpdate :: SqlSelect Postgres (NegativeCteRowT Identity) -invalidNestedUpdate = select $ Pg.pgSelectWith $ do +invalidNestedUpdate = select $ Pg.pgSelectWithNested $ do updated <- Pg.cteUpdateReturning (negativeCteRows negativeCteDb) (\row -> negativeCteValue row <-. val_ "updated") @@ -80,13 +83,13 @@ invalidNestedUpdate = select $ Pg.pgSelectWith $ do -- 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.pgSelectWith $ do +invalidNestedSelectThenDelete = select $ Pg.pgSelectWithNested $ do _ <- nestedSelectCte deleted <- topLevelDeleteCte pure (reuse deleted) invalidNestedDeleteThenSelect :: SqlSelect Postgres (NegativeCteRowT Identity) -invalidNestedDeleteThenSelect = select $ Pg.pgSelectWith $ do +invalidNestedDeleteThenSelect = select $ Pg.pgSelectWithNested $ do deleted <- topLevelDeleteCte _ <- nestedSelectCte pure (reuse deleted) @@ -95,7 +98,7 @@ invalidNestedDeleteThenSelect = select $ Pg.pgSelectWith $ do -- later discovers that the INSERT or UPDATE emits no statement. The placement -- invariant cannot depend on runtime values. invalidNestedEmptyInsert :: SqlSelect Postgres (NegativeCteRowT Identity) -invalidNestedEmptyInsert = select $ Pg.pgSelectWith $ do +invalidNestedEmptyInsert = select $ Pg.pgSelectWithNested $ do inserted <- Pg.cteInsertReturning (negativeCteRows negativeCteDb) SqlInsertValuesEmpty @@ -106,7 +109,7 @@ invalidNestedEmptyInsert = select $ Pg.pgSelectWith $ do Just inserted' -> pure (reuse inserted') invalidNestedIdentityUpdate :: SqlSelect Postgres (NegativeCteRowT Identity) -invalidNestedIdentityUpdate = select $ Pg.pgSelectWith $ do +invalidNestedIdentityUpdate = select $ Pg.pgSelectWithNested $ do updated <- Pg.cteUpdateReturning (negativeCteRows negativeCteDb) (const mempty) @@ -116,17 +119,26 @@ invalidNestedIdentityUpdate = select $ Pg.pgSelectWith $ do 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) + -- With 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.pgSelectWith $ coercePlacement $ do +invalidCoercedPlacement = select $ Pg.pgSelectWithNested $ coercePlacement $ do deleted <- topLevelDeleteCte pure (reuse deleted) --- MonadFix exists only for CteNestedAllowed. This prevents an INSERT CTE from +-- 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 = selectWith $ mdo +invalidRecursiveInsert = Pg.pgSelectWithTopLevel $ mdo ~(Just inserted) <- Pg.cteInsertReturning (negativeCteRows negativeCteDb) (insertFrom (reuse inserted)) @@ -134,19 +146,32 @@ invalidRecursiveInsert = selectWith $ mdo 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 - :: With Postgres NegativeCteDb 'CteTopLevelOnly a - -> With Postgres NegativeCteDb 'CteNestedAllowed a + :: Pg.PgWith NegativeCteDb 'Pg.PgCteTopLevelOnly a + -> Pg.PgWith NegativeCteDb 'Pg.PgCteNestedAllowed a coercePlacement = Coerce.coerce nestedSelectCte - :: With Postgres NegativeCteDb placement + :: Pg.PgWith NegativeCteDb placement (ReusableQ Postgres NegativeCteDb (NegativeCteRowT (QExpr Postgres CTE.QAnyScope))) -nestedSelectCte = selecting $ all_ (negativeCteRows negativeCteDb) +nestedSelectCte = Pg.pgSelecting $ all_ (negativeCteRows negativeCteDb) topLevelDeleteCte - :: With Postgres NegativeCteDb 'CteTopLevelOnly + :: Pg.PgWith NegativeCteDb 'Pg.PgCteTopLevelOnly (ReusableQ Postgres NegativeCteDb (NegativeCteRowT (QExpr Postgres CTE.QAnyScope))) topLevelDeleteCte = Pg.cteDeleteReturning diff --git a/beam-postgres/test/Main.hs b/beam-postgres/test/Main.hs index 565c20f95..a6252acd5 100644 --- a/beam-postgres/test/Main.hs +++ b/beam-postgres/test/Main.hs @@ -45,8 +45,7 @@ setupTempPostgresDB = do password = "root" db = "testdb" - -- Pin the server version so normal CI runs are reproducible. Compatibility - -- with newer PostgreSQL releases can be exercised by a separate matrix job. + -- Pin the server version so normal CI runs are reproducible. postgresContainer <- TC.run $ TC.containerRequest (TC.fromTag "postgres:18.4") TC.& TC.setExpose [5432] diff --git a/beam-sqlite/beam-sqlite.cabal b/beam-sqlite/beam-sqlite.cabal index 64c818645..16d8bcb4e 100644 --- a/beam-sqlite/beam-sqlite.cabal +++ b/beam-sqlite/beam-sqlite.cabal @@ -26,7 +26,7 @@ library other-modules: Database.Beam.Sqlite.SqliteSpecific build-depends: base >=4.11 && <5, - beam-core >=0.11 && <0.13, + beam-core >=0.11 && <0.12, beam-migrate >=0.6 && <0.7, sqlite-simple >=0.4 && <0.5, diff --git a/docs/user-guide/backends/beam-postgres.md b/docs/user-guide/backends/beam-postgres.md index cc3aa7d55..70b921662 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,41 +286,136 @@ 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 the module which exports these PostgreSQL-specific statement +builders: + +```haskell +import qualified Database.Beam.Postgres.Full as Pg +``` + +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: + +```haskell +Pg.pgSelectWithTopLevel $ do + nativeRows <- Pg.pgSelecting nativeQuery + portableRows <- Pg.pgLiftWith portableTwoCteHelper + pure $ (,) <$> reuse nativeRows <*> reuse portableRows +``` + +```sql +WITH "cte0"("res0") AS (SELECT ...), + "cte1"("res0") AS (SELECT ...), + "cte2"("res0") AS (SELECT ... FROM "cte1") +SELECT "t0"."res0", "t1"."res0" +FROM "cte0" AS "t0" CROSS JOIN "cte2" AS "t1" +``` + +PostgreSQL 12 and later also support explicit materialization: + +```haskell +Pg.pgSelectWithTopLevel $ do + expensiveRows <- Pg.pgSelectingWith Pg.PgCteMaterialized expensiveQuery + pure (reuse expensiveRows) +``` + +This produces SQL of the following form (Beam generates the `cteN` and `resN` names): -PostgreSQL only permits data-modifying CTEs at the top level. Accordingly, `pgSelectWith` accepts a -`With` block whose placement is `CteNestedAllowed`, while `cteInsertReturning`, -`cteUpdateReturning`, and `cteDeleteReturning` produce `CteTopLevelOnly` blocks. Mixing ordinary -`SELECT` CTEs with those operations remains valid under top-level `selectWith`, but attempting to -pass such a block to `pgSelectWith` is rejected by the Haskell type checker. +```sql +WITH "cte0"("res0", "res1") AS MATERIALIZED (SELECT ...) +SELECT "t0"."res0", "t0"."res1" FROM "cte0" AS "t0" +``` + +`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 rows which can be passed to `reuse`. Their +side-effect-only counterparts, `cteInsert`, `cteUpdate`, and `cteDelete`, omit `RETURNING` and +therefore return `()`: + +```haskell +Pg.pgSelectWithTopLevel $ do + Pg.cteDelete expiredSessions isExpired + inserted <- Pg.cteInsertReturning + users + (insertValues [newUser]) + Pg.onConflictDefault + id + case inserted of + Nothing -> pure noRowsQuery + Just rows -> pure (reuse rows) +``` + +The corresponding statement contains both modifications in one `WITH` block. The first definition +has no output column list because it has no `RETURNING` relation; the second can be reused because +its generated columns name the `RETURNING` output: + +```sql +WITH "cte0" AS + (DELETE FROM "expired_sessions" AS "delete_target" WHERE ...), + "cte1"("res0", "res1") AS + (INSERT INTO "users" ... RETURNING "id", "name") +SELECT "t0"."res0", "t0"."res1" FROM "cte1" AS "t0" +``` + +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 `CteNestedAllowed` blocks. To combine a recursive `SELECT` -CTE with a later data-modifying CTE, finish the recursive block first and promote it with -`toTopLevel`; its result can then safely be reused by the modifying statement. +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 also finish with `INSERT`, `UPDATE`, or `DELETE` instead of a -final `SELECT`. The `pgInsertWith`, `pgUpdateWith`, and `pgDeleteWith` functions consume a `With` -block in those cases. Because all three produce top-level statements, they accept both placement -indices, including blocks containing data-modifying CTEs. For example: +A PostgreSQL `WITH` statement may finish with `INSERT`, `UPDATE`, or `DELETE` instead of a final +SELECT. For example: ```haskell Pg.pgInsertWith $ do - customersToCopy <- selecting sourceCustomers + customersToCopy <- Pg.pgSelecting sourceCustomers pure $ Pg.insert archiveCustomers (insertFrom (reuse customersToCopy)) Pg.onConflictDefault ``` -An empty terminal insert or identity update remains a no-op. PostgreSQL cannot execute a bare -`WITH` block without a terminal statement, so CTE bodies accumulated before such a no-op are not -executed. +This produces one terminal `INSERT`, not a separate SELECT followed by an INSERT: + +```sql +WITH "cte0"("res0", "res1") AS (SELECT ...) +INSERT INTO "archive_customers"("id", "name") +SELECT "t0"."res0", "t0"."res1" FROM "cte0" AS "t0" +``` + +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 From 4c751f11b424e0cd1199c4e6384e4b4c84cba9a5 Mon Sep 17 00:00:00 2001 From: Kushagra Gupta Date: Wed, 15 Jul 2026 04:11:12 +0000 Subject: [PATCH 05/10] Fix cteDelete to correctly apply the where clause for row deletion for ghc 9.0.2 --- beam-postgres/Database/Beam/Postgres/Full.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/beam-postgres/Database/Beam/Postgres/Full.hs b/beam-postgres/Database/Beam/Postgres/Full.hs index e9fb05682..8101f08e7 100644 --- a/beam-postgres/Database/Beam/Postgres/Full.hs +++ b/beam-postgres/Database/Beam/Postgres/Full.hs @@ -1097,7 +1097,7 @@ cteDelete -> (forall s. table (QExpr Postgres s) -> QExpr Postgres s Bool) -> PgWith db 'PgCteTopLevelOnly () cteDelete table mkWhere = - case delete table mkWhere of + case delete table (\row -> mkWhere row) of SqlDelete _ (PgDeleteSyntax syntax) -> pgDataModifyingCte_ syntax -- | Introduce a PostgreSQL @DELETE ... RETURNING@ statement as a From 796ac7b7827daf672f9286485dc0ce32c7630d43 Mon Sep 17 00:00:00 2001 From: Kushagra Gupta Date: Wed, 15 Jul 2026 18:40:00 +0000 Subject: [PATCH 06/10] Support reusable zero-column PostgreSQL CTEs --- beam-postgres/ChangeLog.md | 7 +- beam-postgres/Database/Beam/Postgres/Full.hs | 155 ++++++--- .../Database/Beam/Postgres/Syntax.hs | 45 ++- .../test/Database/Beam/Postgres/Test/CTE.hs | 314 +++++++++++++++--- .../Beam/Postgres/Test/CTENegative.hs | 10 +- docs/user-guide/backends/beam-postgres.md | 167 +++++++--- 6 files changed, 530 insertions(+), 168 deletions(-) diff --git a/beam-postgres/ChangeLog.md b/beam-postgres/ChangeLog.md index 76ab61738..f43744509 100644 --- a/beam-postgres/ChangeLog.md +++ b/beam-postgres/ChangeLog.md @@ -19,6 +19,10 @@ `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 @@ -28,9 +32,6 @@ * Fixed an issue where using `pgSelectWith` with no common-table expressions would lead to an invalid SQL query at runtime. -* Reject zero-column reusable CTE projections before Beam can render an invalid - empty column-alias list (`cte()`), or an empty `RETURNING` list for a - data-modifying CTE. # 0.6.1.0 diff --git a/beam-postgres/Database/Beam/Postgres/Full.hs b/beam-postgres/Database/Beam/Postgres/Full.hs index 8101f08e7..60593c664 100644 --- a/beam-postgres/Database/Beam/Postgres/Full.hs +++ b/beam-postgres/Database/Beam/Postgres/Full.hs @@ -265,9 +265,18 @@ pgSelecting = pgSelectingWith PgCteDefault -- semantically valid, for example for a recursive query or a query containing -- volatile functions. -- --- Beam names every projected CTE column. A zero-column projection would make --- that generated alias list @()@, which PostgreSQL rejects, so this function --- rejects it before the SQL is sent. +-- 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. pgSelectingWith :: forall res db placement . ( Projectible Postgres res @@ -278,12 +287,10 @@ pgSelectingWith pgSelectingWith materialization q = do tblNm <- pgRegisterCte $ \name -> let (_ :: res, fields) = mkFieldNames @Postgres (qualifiedField name) - in pgOutputCteSyntax - "Database.Beam.Postgres.Full.pgSelectingWith" - name - fields - materialization - (fromPgSelect (buildSqlQuery (name <> "_") q)) + 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_' @@ -446,7 +453,8 @@ insertReturning (DatabaseEntity tbl@(DatabaseTable {})) -- @ -- -- Empty insert values register no CTE. The result is still conservatively --- 'PgCteTopLevelOnly', because placement cannot depend on a runtime value. +-- 'PgCteTopLevelOnly', because the placement index cannot vary with the +-- supplied values. cteInsert :: DatabaseEntity Postgres db (TableEntity table) -> SqlInsertValues Postgres (table (QExpr Postgres s)) @@ -482,9 +490,25 @@ cteInsert table values onConflict_ = -- The generated statement has the shape: -- -- @ --- WITH cte0 AS (INSERT INTO users ... RETURNING ...) --- SELECT ... FROM cte0 +-- 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. cteInsertReturning :: ( Projectible Postgres a , ThreadRewritable PostgresInaccessible a @@ -500,8 +524,7 @@ cteInsertReturning table values onConflict_ mkProjection = case insertReturning table values onConflict_ (Just mkProjection) of PgInsertReturningEmpty -> pure Nothing PgInsertReturning syntax -> - Just <$> pgDataModifyingCte - "Database.Beam.Postgres.Full.cteInsertReturning" syntax + Just <$> pgDataModifyingCte syntax runPgInsertReturningList :: ( MonadBeam be m @@ -708,8 +731,8 @@ pgInsertWith pgInsertWith with = case runPgWith with of (SqlInsertNoRows, _, _) -> SqlInsertNoRows - (SqlInsert settings (PgInsertSyntax statement), recursive, ctes) -> - SqlInsert settings (PgInsertSyntax (pgWithSyntax recursive ctes statement)) + (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. @@ -747,8 +770,8 @@ pgUpdateWith pgUpdateWith with = case runPgWith with of (SqlIdentityUpdate, _, _) -> SqlIdentityUpdate - (SqlUpdate settings (PgUpdateSyntax statement), recursive, ctes) -> - SqlUpdate settings (PgUpdateSyntax (pgWithSyntax recursive ctes statement)) + (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. @@ -778,8 +801,8 @@ pgDeleteWith -> SqlDelete Postgres table pgDeleteWith with = case runPgWith with of - (SqlDelete settings (PgDeleteSyntax statement), recursive, ctes) -> - SqlDelete settings (PgDeleteSyntax (pgWithSyntax recursive ctes statement)) + (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 @@ -795,30 +818,24 @@ pgRegisterCte mkCte = PgWith . CTE.With $ do tell (CTE.Nonrecursive, [mkCte tblNm]) pure tblNm --- Construct a reusable CTE and reject an empty output before PostgreSQL can --- receive the malformed explicit alias list @name() AS (...)@. PostgreSQL can --- represent a zero-column SELECT CTE when the alias list is omitted, but Beam's --- reusable projection path assigns a name to every output column. The function --- name is included in the error so failures identify the public builder which --- accepted the empty projection. +-- 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 - :: String - -> Text - -> [Text] + :: Text + -> NonEmpty Text -> PgCteMaterialization -> PgSyntax -> PgCommonTableExpressionSyntax -pgOutputCteSyntax origin name fields materialization body = - case nonEmpty fields of - Nothing -> error (origin ++ ": a PostgreSQL CTE must project at least one column") - Just fields' -> pgCteSyntax name (Just fields') materialization body +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 meaningful only for a --- modifying statement 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. +-- 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) @@ -840,24 +857,43 @@ pgCteSyntax name fields materialization body = materializationSyntax PgCteMaterialized = emit " MATERIALIZED" materializationSyntax PgCteNotMaterialized = emit " NOT MATERIALIZED" --- Register a modifying CTE with RETURNING output and construct the reusable +-- 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 ) - => String - -> PgSyntax + => PgSyntax -> PgWith db 'PgCteTopLevelOnly (ReusableQ Postgres db res) -pgDataModifyingCte origin body = do +pgDataModifyingCte body = do tblNm <- pgRegisterCte $ \name -> let (_ :: res, fields) = mkFieldNames @Postgres (qualifiedField name) - in pgOutputCteSyntax origin name fields PgCteDefault body + in case nonEmpty fields of + Nothing -> + pgOutputCteSyntax + name + (NonEmpty.singleton "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 --- creates no relation which could be passed to reuse, hence the unit result and --- the absence of a column-alias list. +-- 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 () @@ -871,14 +907,14 @@ pgDataModifyingCte_ body = do -- the backend-independent CTE API does not acquire PostgreSQL command types. runPgWith :: PgWith db placement a - -> (a, Bool, [BeamSql99BackendCTESyntax Postgres]) + -> (a, PgCteRecursiveness, [BeamSql99BackendCTESyntax Postgres]) runPgWith (PgWith with) = let (result, (recursiveness, ctes)) = evalState (runWriterT (CTE.runWith with)) 0 - recursive = case recursiveness of - CTE.Nonrecursive -> False - CTE.Recursive -> True - in (result, recursive, ctes) + 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. @@ -1012,6 +1048,12 @@ cteUpdate table@(DatabaseEntity (DatabaseTable {})) mkAssignments mkWhere = -- 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. cteUpdateReturning :: ( Projectible Postgres a , ThreadRewritable PostgresInaccessible a @@ -1027,8 +1069,7 @@ cteUpdateReturning table mkAssignments mkWhere mkProjection = case updateReturning table mkAssignments mkWhere mkProjection of PgUpdateReturningEmpty -> pure Nothing PgUpdateReturning syntax -> - Just <$> pgDataModifyingCte - "Database.Beam.Postgres.Full.cteUpdateReturning" syntax + Just <$> pgDataModifyingCte syntax runPgUpdateReturningList :: ( MonadBeam be m @@ -1130,6 +1171,11 @@ cteDelete table mkWhere = -- 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. cteDeleteReturning :: ( Projectible Postgres a , ThreadRewritable PostgresInaccessible a @@ -1142,8 +1188,7 @@ cteDeleteReturning -> PgWith db 'PgCteTopLevelOnly (ReusableQ Postgres db (WithRewrittenThread PostgresInaccessible CTE.QAnyScope a)) cteDeleteReturning table mkWhere mkProjection = let PgDeleteReturning syntax = deleteReturning table mkWhere mkProjection - in pgDataModifyingCte - "Database.Beam.Postgres.Full.cteDeleteReturning" syntax + in pgDataModifyingCte syntax runPgDeleteReturningList :: ( MonadBeam be m diff --git a/beam-postgres/Database/Beam/Postgres/Syntax.hs b/beam-postgres/Database/Beam/Postgres/Syntax.hs index 1ebc25624..59b2735a7 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, pgWithSyntax + , pgParens, PgCteRecursiveness(..), pgWithSyntax , pgStringLit, pgCharLit, pgBoolLit , nextSyntaxStep @@ -280,21 +280,40 @@ data PgSelectLockingClauseSyntax = PgSelectLockingClauseSyntax { pgSelectLocking 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. +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. The boolean selects +-- An empty list leaves the statement unchanged. 'PgCteRecursive' selects -- @WITH RECURSIVE@ when the CTE builder used recursive bindings. -pgWithSyntax :: Bool -> [PgCommonTableExpressionSyntax] -> PgSyntax -> PgSyntax +pgWithSyntax + :: PgCteRecursiveness + -> [PgCommonTableExpressionSyntax] + -> PgSyntax + -> PgSyntax pgWithSyntax _ [] statement = statement -pgWithSyntax recursive ctes statement = - emit (if recursive then "WITH RECURSIVE " else "WITH ") <> +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 @@ -643,21 +662,27 @@ instance IsSql99CommonTableExpressionSelectSyntax PgSelectSyntax where type Sql99SelectCTESyntax PgSelectSyntax = PgCommonTableExpressionSyntax withSyntax ctes (PgSelectSyntax select) = - PgSelectSyntax (pgWithSyntax False ctes select) + PgSelectSyntax (pgWithSyntax PgCteNonrecursive ctes select) instance IsSql99RecursiveCommonTableExpressionSelectSyntax PgSelectSyntax where withRecursiveSyntax ctes (PgSelectSyntax select) = - PgSelectSyntax (pgWithSyntax True ctes select) + PgSelectSyntax (pgWithSyntax PgCteRecursive ctes select) instance IsSql99CommonTableExpressionSyntax PgCommonTableExpressionSyntax where type Sql99CTESelectSyntax PgCommonTableExpressionSyntax = PgSelectSyntax - cteSubquerySyntax _ [] _ = - error "Database.Beam.Query.CTE.selecting: a PostgreSQL CTE must project at least one column" 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 diff --git a/beam-postgres/test/Database/Beam/Postgres/Test/CTE.hs b/beam-postgres/test/Database/Beam/Postgres/Test/CTE.hs index 7a46f0a68..e228434ed 100644 --- a/beam-postgres/test/Database/Beam/Postgres/Test/CTE.hs +++ b/beam-postgres/test/Database/Beam/Postgres/Test/CTE.hs @@ -9,7 +9,7 @@ -- checking. module Database.Beam.Postgres.Test.CTE (unitTests, integrationTests) where -import Control.Exception (ErrorCall, TypeError, evaluate, try) +import Control.Exception (TypeError, evaluate, try) import qualified Data.ByteString.Lazy.Char8 as BL import Data.ByteString (ByteString) import Data.Int (Int32) @@ -48,14 +48,16 @@ data CteRowT f = CteRow deriving instance Show (CteRowT Identity) deriving instance Eq (CteRowT Identity) --- A legal Haskell projection shape with no fields. PostgreSQL accepts a --- zero-column SELECT CTE only when its output alias list is omitted, whereas --- Beam's reusable CTE representation names every output column. It also cannot --- emit a bare RETURNING keyword. The builders therefore reject this shape --- instead of rendering cte() or an empty RETURNING list. +-- 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) @@ -72,7 +74,6 @@ unitTests :: TestTree unitTests = testGroup "Common table expression tests" [ renderingTests , typeSafetyTests - , projectionValidationTests ] integrationTests :: IO ByteString -> TestTree @@ -87,6 +88,9 @@ integrationTests getConn = testGroup "Common table expression integration tests" , testSideEffectOnlyCteModel getConn , testWithDmlConsumerModel getConn , testRecursiveCteModel getConn + , testDegreeZeroSelects getConn + , testDegreeZeroDataModifyingCtes getConn + , testDegreeZeroRepeatedReuse getConn ] renderingTests :: TestTree @@ -105,6 +109,8 @@ renderingTests = testGroup "Common table expression rendering tests" , testTopLevelOnlyDmlConsumerRendering , testEmptyDmlConsumers , testReturningAfterDmlConsumers + , testDegreeZeroSelectRendering + , testDegreeZeroDataModifyingRendering ] -- These tests force expressions compiled with deferred type errors in the @@ -140,14 +146,6 @@ typeSafetyTests = testGroup "Common table expression type-safety tests" Negative.invalidReuseSideEffect ] -projectionValidationTests :: TestTree -projectionValidationTests = testGroup "Common table expression projection validation tests" - [ testCase "rejects a zero-column SELECT CTE" $ - assertEmptyProjectionError emptySelectProjection - , testCase "rejects a zero-column data-modifying CTE" $ - assertEmptyProjectionError emptyDeleteProjection - ] - assertPlacementTypeError :: SqlSelect Postgres a -> Assertion assertPlacementTypeError = assertDeferredTypeErrorContaining ["PgCteTopLevelOnly", "PgCteNestedAllowed"] @@ -170,16 +168,6 @@ assertDeferredTypeErrorContaining expectedFragments sql = do ("mentions " ++ fragment ++ "\nDeferred error was:\n" ++ message) (fragment `isInfixOf` message) -assertEmptyProjectionError :: SqlSelect Postgres a -> Assertion -assertEmptyProjectionError sql = do - result <- try (evaluate (BL.length (renderSelectBytes sql))) - case result of - Left (err :: ErrorCall) -> - assertBool "explains the non-empty projection requirement" - ("at least one column" `isInfixOf` show err) - Right _ -> - assertFailure "expected the zero-column CTE projection to be rejected" - -- 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. @@ -221,8 +209,9 @@ testNestedMaterializedCteRendering = testCase "embeds a materialized PgWith bloc assertBool "retains the materialization modifier" (" AS MATERIALIZED (" `isInfixOf` sql) --- DML without RETURNING is still executed by PostgreSQL but does not create a --- relation. Its CTE name must therefore have no empty column-alias list. +-- 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 @@ -276,8 +265,8 @@ testEmptyDataModifyingCtes = testCase "omits empty INSERT and identity UPDATE CT 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 the three --- independent Sql* wrappers reconstructed by the public functions. +-- 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) @@ -322,6 +311,59 @@ testReturningAfterDmlConsumers = testCase "supports RETURNING after each termina 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. @@ -367,7 +409,7 @@ testSideEffectOnlyCtes getConn = testCase "unreferenced side-effect-only CTEs ex remaining <- runBeamPostgres conn $ runSelectReturningList $ select $ orderBy_ (asc_ . cteId) $ all_ (dbCteRows cteDb) - assertEqual "all side effects were applied exactly once" + assertEqual "all expected side effects were applied" [ CteRow 1 "unchanged" , CteRow 2 "after-update" , CteRow 4 "inserted" @@ -490,7 +532,7 @@ testDataModifyingCteModel getConn = testCase "data-modifying CTEs agree with a p assertBool "data-modifying CTE model property failed" passes -- Repeat the three-operation model without RETURNING. This catches parameter --- ordering or accidental omission in the optimized side-effect-only path by +-- 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" $ @@ -612,6 +654,108 @@ testRecursiveCteModel getConn = testCase "recursive CTE execution agrees with a 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) @@ -913,8 +1057,8 @@ recursiveSelectThenDeleteCteSelect = Pg.pgSelectWithTopLevel $ do 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. +-- 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 @@ -934,23 +1078,111 @@ emptyDataModifyingCteSelect = Pg.pgSelectWithTopLevel $ do finalQuery :: Q Postgres CteDb QBaseScope (QExpr Postgres QBaseScope Int32) finalQuery = pure (val_ 1) --- Both expressions below are valid Beam projection shapes, but contain no --- fields from which SQL columns could be built. They exercise the shared --- validation for SELECT and data-modifying CTE bodies respectively. +-- 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 - (pure (EmptyCte :: EmptyCteT (QExpr Postgres CTE.QAnyScope))) + 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) -emptyDeleteProjection :: SqlSelect Postgres (EmptyCteT Identity) -emptyDeleteProjection = Pg.pgSelectWithTopLevel $ do +-- 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) - (const (val_ False)) + (\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 diff --git a/beam-postgres/test/Database/Beam/Postgres/Test/CTENegative.hs b/beam-postgres/test/Database/Beam/Postgres/Test/CTENegative.hs index fb2941f2d..2739b93a0 100644 --- a/beam-postgres/test/Database/Beam/Postgres/Test/CTENegative.hs +++ b/beam-postgres/test/Database/Beam/Postgres/Test/CTENegative.hs @@ -94,9 +94,9 @@ invalidNestedDeleteThenSelect = select $ Pg.pgSelectWithNested $ do _ <- nestedSelectCte pure (reuse deleted) --- The result is conservatively top-level-only even when a value-level check --- later discovers that the INSERT or UPDATE emits no statement. The placement --- invariant cannot depend on runtime values. +-- 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 @@ -128,8 +128,8 @@ invalidNestedSideEffectDelete = select $ Pg.pgSelectWithNested $ do (\row -> negativeCteId row ==. val_ 1) pure $ all_ (negativeCteRows negativeCteDb) --- With has nominal roles and an abstract constructor, so Data.Coerce cannot be --- used to relabel a top-level-only block as nested-safe. +-- 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 diff --git a/docs/user-guide/backends/beam-postgres.md b/docs/user-guide/backends/beam-postgres.md index 70b921662..91c37b4cd 100644 --- a/docs/user-guide/backends/beam-postgres.md +++ b/docs/user-guide/backends/beam-postgres.md @@ -301,46 +301,40 @@ either form because they all produce top-level statements. The existing portable `selectWith`, and `pgSelectWith` APIs keep their existing types; the PostgreSQL-specific builders are additive. -The examples in this section use the module which exports these PostgreSQL-specific statement -builders: - -```haskell -import qualified Database.Beam.Postgres.Full as Pg -``` +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 -Pg.pgSelectWithTopLevel $ do - nativeRows <- Pg.pgSelecting nativeQuery - portableRows <- Pg.pgLiftWith portableTwoCteHelper +!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 -``` - -```sql -WITH "cte0"("res0") AS (SELECT ...), - "cte1"("res0") AS (SELECT ...), - "cte2"("res0") AS (SELECT ... FROM "cte1") -SELECT "t0"."res0", "t1"."res0" -FROM "cte0" AS "t0" CROSS JOIN "cte2" AS "t1" +putStrLn (show rows) ``` PostgreSQL 12 and later also support explicit materialization: +!beam-query ```haskell -Pg.pgSelectWithTopLevel $ do - expensiveRows <- Pg.pgSelectingWith Pg.PgCteMaterialized expensiveQuery - pure (reuse expensiveRows) -``` - -This produces SQL of the following form (Beam generates the `cteN` and `resN` names): - -```sql -WITH "cte0"("res0", "res1") AS MATERIALIZED (SELECT ...) -SELECT "t0"."res0", "t0"."res1" FROM "cte0" AS "t0" +!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 @@ -351,35 +345,101 @@ queries. These rules, and the default behavior for single and multiple reference 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 rows which can be passed to `reuse`. Their -side-effect-only counterparts, `cteInsert`, `cteUpdate`, and `cteDelete`, omit `RETURNING` and -therefore return `()`: +`... 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 -Pg.pgSelectWithTopLevel $ do - Pg.cteDelete expiredSessions isExpired +!example chinookdml only:Postgres +rows <- runSelectReturningList $ Pg.pgSelectWithTopLevel $ do + Pg.cteDelete + (playlist chinookDb) + (\row -> playlistId row ==. val_ 1000001) inserted <- Pg.cteInsertReturning - users - (insertValues [newUser]) + (playlist chinookDb) + (insertValues [Playlist 1000000 (Just "PostgreSQL CTE example")]) Pg.onConflictDefault id case inserted of - Nothing -> pure noRowsQuery + Nothing -> pure $ + filter_ (const (val_ False)) $ all_ (playlist chinookDb) Just rows -> pure (reuse rows) +putStrLn (show rows) ``` -The corresponding statement contains both modifications in one `WITH` block. The first definition -has no output column list because it has no `RETURNING` relation; the second can be reused because -its generated columns name the `RETURNING` output: +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 - (DELETE FROM "expired_sessions" AS "delete_target" WHERE ...), - "cte1"("res0", "res1") AS - (INSERT INTO "users" ... RETURNING "id", "name") -SELECT "t0"."res0", "t0"."res1" FROM "cte1" AS "t0" + (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 @@ -397,21 +457,20 @@ modification. A PostgreSQL `WITH` statement may finish with `INSERT`, `UPDATE`, or `DELETE` instead of a final SELECT. For example: +!beam-query ```haskell -Pg.pgInsertWith $ do - customersToCopy <- Pg.pgSelecting sourceCustomers - pure $ Pg.insert archiveCustomers - (insertFrom (reuse customersToCopy)) - Pg.onConflictDefault +!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: - -```sql -WITH "cte0"("res0", "res1") AS (SELECT ...) -INSERT INTO "archive_customers"("id", "name") -SELECT "t0"."res0", "t0"."res1" FROM "cte0" AS "t0" -``` +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 From eeac2b2dd438cf15858c675c3c5bbb189669ebb0 Mon Sep 17 00:00:00 2001 From: Kushagra Gupta Date: Wed, 15 Jul 2026 18:40:09 +0000 Subject: [PATCH 07/10] Pin Chinook documentation fixture revision --- beam-postgres/beam-docs.sh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/beam-postgres/beam-docs.sh b/beam-postgres/beam-docs.sh index b75cbed8d..fbd0dce63 100644 --- a/beam-postgres/beam-docs.sh +++ b/beam-postgres/beam-docs.sh @@ -4,7 +4,7 @@ set -e . ${BEAM_DOCS_LIBRARY} -CHINOOK_POSTGRES_URL="https://raw.githubusercontent.com/lerocha/chinook-database/master/ChinookDatabase/DataSources/Chinook_PostgreSql.sql" +CHINOOK_POSTGRES_URL="https://raw.githubusercontent.com/lerocha/chinook-database/1b6138b3f70a8090db48011ff4abc0e3627b22b6/ChinookDatabase/DataSources/Chinook_PostgreSql.sql" EXPECTED_SHA256="6945d59e3bca94591e2a96451b9bd69084b026f7fb7dbda3d15d06114ffb34c4" PGCONNSTR=$1 From 5e5fa9e9bd14bf2891a9aba07713020e887c735e Mon Sep 17 00:00:00 2001 From: Kushagra Gupta Date: Wed, 15 Jul 2026 18:54:13 +0000 Subject: [PATCH 08/10] Support GHC 8.10 NonEmpty API --- beam-postgres/Database/Beam/Postgres/Full.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/beam-postgres/Database/Beam/Postgres/Full.hs b/beam-postgres/Database/Beam/Postgres/Full.hs index 60593c664..b8d102947 100644 --- a/beam-postgres/Database/Beam/Postgres/Full.hs +++ b/beam-postgres/Database/Beam/Postgres/Full.hs @@ -83,7 +83,7 @@ import Control.Monad.Free.Church import Control.Monad.State.Strict (evalState, get, put) import Control.Monad.Writer (runWriterT, tell) -import Data.List.NonEmpty (NonEmpty, nonEmpty) +import Data.List.NonEmpty (NonEmpty(..), nonEmpty) import qualified Data.List.NonEmpty as NonEmpty import Data.Kind (Type) import Data.Proxy (Proxy(..)) @@ -884,7 +884,7 @@ pgDataModifyingCte body = do Nothing -> pgOutputCteSyntax name - (NonEmpty.singleton "res0") + ("res0" :| []) PgCteDefault (body <> emit "NULL::boolean") Just fields' -> pgOutputCteSyntax name fields' PgCteDefault body From 698bd1e8e989da0cb5b9f75c86276786f1b9f17e Mon Sep 17 00:00:00 2001 From: Kushagra Gupta Date: Thu, 16 Jul 2026 13:20:00 +0000 Subject: [PATCH 09/10] Prepare beam-postgres 0.6.3.0 documentation --- beam-postgres/ChangeLog.md | 17 +++++---- beam-postgres/Database/Beam/Postgres/Full.hs | 36 +++++++++++++++++++ .../Database/Beam/Postgres/Syntax.hs | 6 ++++ beam-postgres/beam-postgres.cabal | 2 +- 4 files changed, 54 insertions(+), 7 deletions(-) diff --git a/beam-postgres/ChangeLog.md b/beam-postgres/ChangeLog.md index f43744509..0761c22da 100644 --- a/beam-postgres/ChangeLog.md +++ b/beam-postgres/ChangeLog.md @@ -1,12 +1,7 @@ -# 0.6.2.0 +# 0.6.3.0 ## Added features -* Added instances for `BeamSqlBackendIsString Postgres (CI String)` and - `BeamSqlBackendIsString Postgres (CI Text)`, allowing the use of `toTsVector` - over colums of type `citext` (#818) -* Exposed the functionality to implement user-defined extensions via - `Database.Beam.Postgres.Extensions` (#819) * 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 @@ -33,6 +28,16 @@ * 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 + +* Added instances for `BeamSqlBackendIsString Postgres (CI String)` and + `BeamSqlBackendIsString Postgres (CI Text)`, allowing the use of `toTsVector` + over colums of type `citext` (#818) +* Exposed the functionality to implement user-defined extensions via + `Database.Beam.Postgres.Extensions` (#819) + # 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 b8d102947..e60d820b7 100644 --- a/beam-postgres/Database/Beam/Postgres/Full.hs +++ b/beam-postgres/Database/Beam/Postgres/Full.hs @@ -101,6 +101,8 @@ import qualified Data.Text as T -- 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. @@ -119,6 +121,8 @@ data PgCtePlacement -- 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) @@ -163,6 +167,8 @@ instance MonadFix (PgWith db 'PgCteNestedAllowed) where -- -- 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 @@ -192,6 +198,8 @@ pgLiftWith = PgWith -- WHERE EXISTS (SELECT ... FROM "cte0")) -- SELECT ... -- @ +-- +-- @since 0.6.3.0 pgToTopLevel :: PgWith db 'PgCteNestedAllowed a -> PgWith db 'PgCteTopLevelOnly a @@ -204,6 +212,8 @@ pgToTopLevel (PgWith with) = PgWith with -- 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. @@ -231,6 +241,8 @@ data PgCteMaterialization -- 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 ) @@ -277,6 +289,8 @@ pgSelecting = pgSelectingWith PgCteDefault -- -- 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 @@ -455,6 +469,8 @@ insertReturning (DatabaseEntity tbl@(DatabaseTable {})) -- 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)) @@ -509,6 +525,8 @@ cteInsert table values onConflict_ = -- 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 @@ -630,6 +648,8 @@ pgSelectWith = pgSelectWith_ -- 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 @@ -693,6 +713,8 @@ pgSelectWith_ (CTE.With mkQ) = -- -- 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) @@ -725,6 +747,8 @@ pgSelectWithTopLevel = selectWith . unPgWith -- -- 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 @@ -764,6 +788,8 @@ pgInsertWith with = -- -- 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 @@ -796,6 +822,8 @@ pgUpdateWith with = -- 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 @@ -1010,6 +1038,8 @@ updateReturning table@(DatabaseEntity (DatabaseTable { dbTableSettings = tblSett -- -- 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) @@ -1054,6 +1084,8 @@ cteUpdate table@(DatabaseEntity (DatabaseTable {})) mkAssignments mkWhere = -- 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 @@ -1133,6 +1165,8 @@ deleteReturning table@(DatabaseEntity (DatabaseTable { dbTableSettings = tblSett -- 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) @@ -1176,6 +1210,8 @@ cteDelete table mkWhere = -- 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 diff --git a/beam-postgres/Database/Beam/Postgres/Syntax.hs b/beam-postgres/Database/Beam/Postgres/Syntax.hs index 59b2735a7..582443e13 100644 --- a/beam-postgres/Database/Beam/Postgres/Syntax.hs +++ b/beam-postgres/Database/Beam/Postgres/Syntax.hs @@ -277,6 +277,8 @@ data PgSelectLockingClauseSyntax = PgSelectLockingClauseSyntax { pgSelectLocking -- -- 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 } @@ -284,6 +286,8 @@ newtype PgCommonTableExpressionSyntax -- -- 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@. @@ -299,6 +303,8 @@ data PgCteRecursiveness -- -- 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] diff --git a/beam-postgres/beam-postgres.cabal b/beam-postgres/beam-postgres.cabal index f41ebcb05..598017506 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 From 076e8072c2aff5e3d601c88e6f33061d8e167cb0 Mon Sep 17 00:00:00 2001 From: Kushagra Gupta Date: Thu, 16 Jul 2026 13:40:10 +0000 Subject: [PATCH 10/10] reverting this change back to what it was --- beam-postgres/beam-docs.sh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/beam-postgres/beam-docs.sh b/beam-postgres/beam-docs.sh index fbd0dce63..b75cbed8d 100644 --- a/beam-postgres/beam-docs.sh +++ b/beam-postgres/beam-docs.sh @@ -4,7 +4,7 @@ set -e . ${BEAM_DOCS_LIBRARY} -CHINOOK_POSTGRES_URL="https://raw.githubusercontent.com/lerocha/chinook-database/1b6138b3f70a8090db48011ff4abc0e3627b22b6/ChinookDatabase/DataSources/Chinook_PostgreSql.sql" +CHINOOK_POSTGRES_URL="https://raw.githubusercontent.com/lerocha/chinook-database/master/ChinookDatabase/DataSources/Chinook_PostgreSql.sql" EXPECTED_SHA256="6945d59e3bca94591e2a96451b9bd69084b026f7fb7dbda3d15d06114ffb34c4" PGCONNSTR=$1