beam-postgres 0.5.6.1 → 0.6.3.0
raw patch · 25 files changed
Files
- ChangeLog.md +95/−0
- Database/Beam/Postgres.hs +175/−47
- Database/Beam/Postgres/Connection.hs +69/−21
- Database/Beam/Postgres/Extensions.hs +37/−2
- Database/Beam/Postgres/Extensions/Copy/File.hs +421/−0
- Database/Beam/Postgres/Extensions/Copy/Stream.hs +175/−0
- Database/Beam/Postgres/Extensions/Internal.hs +0/−17
- Database/Beam/Postgres/Extensions/UuidOssp.hs +1/−2
- Database/Beam/Postgres/Full.hs +822/−21
- Database/Beam/Postgres/Migrate.hs +8/−2
- Database/Beam/Postgres/PgCrypto.hs +1/−2
- Database/Beam/Postgres/PgSpecific.hs +1/−5
- Database/Beam/Postgres/Syntax.hs +83/−12
- Database/Beam/Postgres/Types.hs +23/−1
- beam-postgres.cabal +17/−10
- test/Database/Beam/Postgres/Test.hs +8/−22
- test/Database/Beam/Postgres/Test/CTE.hs +1334/−0
- test/Database/Beam/Postgres/Test/CTENegative.hs +180/−0
- test/Database/Beam/Postgres/Test/Copy.hs +444/−0
- test/Database/Beam/Postgres/Test/DataTypes.hs +8/−8
- test/Database/Beam/Postgres/Test/Marshal.hs +3/−3
- test/Database/Beam/Postgres/Test/Select.hs +2/−1
- test/Database/Beam/Postgres/Test/Select/PgNubBy.hs +119/−0
- test/Database/Beam/Postgres/Test/Windowing.hs +221/−0
- test/Main.hs +49/−34
ChangeLog.md view
@@ -1,3 +1,98 @@+# 0.6.3.0++## Added features++* Added the PostgreSQL-specific, placement-indexed `PgWith` CTE builder. It can+ lift helpers built with the portable `With Postgres` API, while the new+ data-modifying builders produce blocks which cannot be embedded in a+ subquery.+* Added `pgSelectingWith` for PostgreSQL 12+ `MATERIALIZED` and+ `NOT MATERIALIZED` SELECT CTEs, with `pgSelecting` retaining PostgreSQL's+ default planner policy.+* Added `cteInsertReturning`, `cteUpdateReturning`, and `cteDeleteReturning`+ for exposing the `RETURNING` rows of PostgreSQL data-modifying CTEs through+ `reuse`.+* Added `cteInsert`, `cteUpdate`, and `cteDelete` for data-modifying CTEs which+ execute for their side effects and intentionally produce no reusable rows.+* Added support for reusable zero-column CTE projections. SELECT CTEs omit the+ optional output alias list, while data-modifying CTEs use a private+ `NULL::boolean` `RETURNING` value to preserve one degree-zero result row per+ affected row without exposing a value to Beam's result decoder.+* Added `pgSelectWithNested` and `pgSelectWithTopLevel` for consuming safe+ nested and top-level `PgWith` blocks respectively, plus `pgInsertWith`,+ `pgUpdateWith`, and `pgDeleteWith` for terminating a top-level `WITH` block+ with a data-modifying statement.++## Bug fixes++* Fixed an issue where using `pgSelectWith` with no common-table expressions+ would lead to an invalid SQL query at runtime.++# 0.6.2.0++## Added features++* 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++* Added file-mode `COPY ... TO 'file'` / `COPY ... FROM 'file'` support+ via the new `MonadBeamCopyTo` / `MonadBeamCopyFrom` instances on `Pg`.+ Smart constructors `copyToText` / `copyToCSV` (and `copyFromText` /+ `copyFromCSV`, plus `*With` variants) build the per-format options+ records. Note that this requires the `pg_write_server_files` /+ `pg_read_server_files` role (or superuser) on the connecting role —+ see `Database.Beam.Postgres.Extensions.Copy.File`.+* Added streaming `COPY ... TO STDOUT` / `COPY ... FROM STDIN` support+ via the new `MonadBeamCopyToStream` / `MonadBeamCopyFromStream`+ instances on `Pg`. Smart constructors `copyToTextStream` /+ `copyToCSVStream` / `copyFromTextStream` / `copyFromCSVStream` build+ the per-format options. Streaming COPY does not require any special+ role attribute and is the appropriate choice when the client and+ server are on different hosts — see+ `Database.Beam.Postgres.Extensions.Copy.Stream`.++## Bug fixes++* Fixed an issue where a window function applied over the result of `nub_` (or+ the Postgres-specific `pgNubBy_`) would emit `DISTINCT` and the window+ expression in the same `SELECT`, causing the window to evaluate against the+ pre-deduplicated rows. The inner select is now materialised as a subquery+ whenever it carries `DISTINCT`, `GROUP BY`, or `HAVING` (#756).++# 0.6.0.0++## Interface changes++* Removed `week_` from `Database.Beam.Postgres.PgSpecific`. The same+ functionality is now available in `beam-core` as a backend-agnostic+ `week_` extract field; import it from `Database.Beam.Query.Extract` (or+ re-exported through `Database.Beam`) instead.+* Replaced the single `BeamSqlBackendHasSerial Postgres` instance with three+ width-specific instances `BeamSqlBackendHasSerial Int16/Int32/Int64+ Postgres`, mapping respectively to `smallserial`, `serial`, and+ `bigserial`. Existing code using `genericSerial` for a `SqlSerial Int32`+ column continues to work; other widths are now also supported (#534).++## Added features++* Implemented the new `runInsertReturningListWith` /+ `runUpdateReturningListWith` / `runDeleteReturningListWith` class methods+ on the `Pg` monad. These let callers project a subset of columns from the+ affected rows of an `INSERT` / `UPDATE` / `DELETE ... RETURNING` (#801).+* Implemented `weekField` for `PgExtractFieldSyntax`, supporting the new+ backend-agnostic `week_` extract field from `beam-core`.++## Updated dependencies++* Bumped the lower bound on `beam-core` to `0.11`.+ # 0.5.6.1 ## Bug fixes
Database/Beam/Postgres.hs view
@@ -16,74 +16,202 @@ -- -- For examples on how to use @beam-postgres@ usage, see -- <https://haskell-beam.github.io/beam/user-guide/backends/beam-postgres/ its manual>.- module Database.Beam.Postgres- ( -- * Beam Postgres backend- Postgres(..), Pg, liftIOWithHandle+ ( -- * Beam Postgres backend+ Postgres (..),+ Pg,+ liftIOWithHandle, -- ** Executing actions against the backend- , runBeamPostgres, runBeamPostgresDebug+ runBeamPostgres,+ runBeamPostgresDebug, -- ** Postgres syntax- , PgCommandSyntax, PgSyntax- , PgSelectSyntax, PgInsertSyntax- , PgUpdateSyntax, PgDeleteSyntax+ PgCommandSyntax,+ PgSyntax,+ PgSelectSyntax,+ PgInsertSyntax,+ PgUpdateSyntax,+ PgDeleteSyntax, - -- * Beam URI support- , postgresUriSyntax+ -- ** COPY support - -- * Postgres-specific features- -- ** Postgres-specific data types+ --+ -- File-mode @COPY@ support for Postgres. Use 'copyToText' / 'copyToCSV' (or 'copyFromText' /+ -- 'copyFromCSV') for default options, and the @*With@ variants to override+ -- format-specific fields. - , json, jsonb, uuid, money- , tsquery, tsvector, text, bytea- , unboundedArray+ -- *** text format+ copyToText,+ copyToTextWith,+ PgTextCopyToOptions (..),+ defaultPgTextCopyToOptions,+ copyFromText,+ copyFromTextWith,+ PgTextCopyFromOptions (..),+ defaultPgTextCopyFromOptions, - -- *** @SERIAL@ support- , smallserial, serial, bigserial+ -- *** CSV format+ copyToCSV,+ copyToCSVWith,+ PgCSVCopyToOptions (..),+ defaultPgCSVCopyToOptions,+ copyFromCSV,+ copyFromCSVWith,+ PgCSVCopyFromOptions (..),+ defaultPgCSVCopyFromOptions, - , module Database.Beam.Postgres.PgSpecific- , module Database.Beam.Postgres.TempTable+ -- *** Top-level options sums+ PgCopyToOptions,+ PgCopyFromOptions, - -- ** Postgres extension support- , PgExtensionEntity, IsPgExtension(..)- , pgCreateExtension, pgDropExtension- , getPgExtension+ -- ** Streaming COPY support - -- ** Utilities for defining custom instances- , fromPgIntegral- , fromPgScientificOrIntegral+ --+ -- Streaming @COPY ... TO STDOUT@ / @COPY ... FROM STDIN@.+ -- Use 'copyToTextStream' / 'copyToCSVStream' (or 'copyFromTextStream' /+ -- 'copyFromCSVStream') with the 'runCopyToStream' / 'runCopyFromStream'+ -- runners from "Database.Beam.Backend.SQL.BeamExtensions". - -- ** Debug support+ -- *** text format+ copyToTextStream,+ copyToTextStreamWith,+ copyFromTextStream,+ copyFromTextStreamWith, - , PgDebugStmt- , pgTraceStmtIO, pgTraceStmtIO'- , pgTraceStmt+ -- *** CSV format+ copyToCSVStream,+ copyToCSVStreamWith,+ copyFromCSVStream,+ copyFromCSVStreamWith, - -- * @postgresql-simple@ re-exports+ -- *** Top-level options sums+ PgCopyToStreamOptions,+ PgCopyFromStreamOptions, - , Pg.ResultError(..), Pg.SqlError(..)+ -- * Beam URI support+ postgresUriSyntax, - , Pg.Connection, Pg.ConnectInfo(..)- , Pg.defaultConnectInfo+ -- * Postgres-specific features - , Pg.connectPostgreSQL, Pg.connect- , Pg.close+ -- ** Postgres-specific data types+ json,+ jsonb,+ uuid,+ money,+ tsquery,+ tsvector,+ text,+ bytea,+ unboundedArray, - ) where+ -- *** @SERIAL@ support+ smallserial,+ serial,+ bigserial,+ module Database.Beam.Postgres.PgSpecific,+ module Database.Beam.Postgres.TempTable, + -- ** Postgres extension support+ PgExtensionEntity,+ IsPgExtension (..),+ pgCreateExtension,+ pgDropExtension,+ getPgExtension,++ -- ** Utilities for defining custom instances+ fromPgIntegral,+ fromPgScientificOrIntegral,++ -- ** Debug support+ PgDebugStmt,+ pgTraceStmtIO,+ pgTraceStmtIO',+ pgTraceStmt,++ -- * @postgresql-simple@ re-exports+ Pg.ResultError (..),+ Pg.SqlError (..),+ Pg.Connection,+ Pg.ConnectInfo (..),+ Pg.defaultConnectInfo,+ Pg.connectPostgreSQL,+ Pg.connect,+ Pg.close,+ )+where+ import Database.Beam.Postgres.Connection-import Database.Beam.Postgres.Full () -- for BeamHasInsertOnConflict instance-import Database.Beam.Postgres.Syntax-import Database.Beam.Postgres.Types-import Database.Beam.Postgres.PgSpecific-import Database.Beam.Postgres.Migrate ( tsquery, tsvector, text, bytea, unboundedArray- , json, jsonb, uuid, money, smallserial, serial- , bigserial)-import Database.Beam.Postgres.Extensions ( PgExtensionEntity, IsPgExtension(..)- , pgCreateExtension, pgDropExtension- , getPgExtension )+-- for BeamHasInsertOnConflict instance+ import Database.Beam.Postgres.Debug+import Database.Beam.Postgres.Extensions+ ( IsPgExtension (..),+ PgExtensionEntity,+ getPgExtension,+ pgCreateExtension,+ pgDropExtension,+ )+import Database.Beam.Postgres.Extensions.Copy.File+ ( PgCSVCopyFromOptions (..),+ PgCSVCopyToOptions (..),+ PgCopyFromOptions,+ PgCopyToOptions,+ PgTextCopyFromOptions (..),+ PgTextCopyToOptions (..),+ copyFromCSV,+ copyFromCSVWith,+ copyFromText,+ copyFromTextWith,+ copyToCSV,+ copyToCSVWith,+ copyToText,+ copyToTextWith,+ defaultPgCSVCopyFromOptions,+ defaultPgCSVCopyToOptions,+ defaultPgTextCopyFromOptions,+ defaultPgTextCopyToOptions,+ )+import Database.Beam.Postgres.Extensions.Copy.Stream+ ( PgCopyFromStreamOptions,+ PgCopyToStreamOptions,+ copyFromCSVStream,+ copyFromCSVStreamWith,+ copyFromTextStream,+ copyFromTextStreamWith,+ copyToCSVStream,+ copyToCSVStreamWith,+ copyToTextStream,+ copyToTextStreamWith,+ )+import Database.Beam.Postgres.Full ()+import Database.Beam.Postgres.Migrate+ ( bigserial,+ bytea,+ json,+ jsonb,+ money,+ serial,+ smallserial,+ text,+ tsquery,+ tsvector,+ unboundedArray,+ uuid,+ )+import Database.Beam.Postgres.PgSpecific+import Database.Beam.Postgres.Syntax+ ( PgCommandSyntax,+ PgDeleteSyntax,+ PgInsertSyntax,+ PgSelectSyntax,+ PgSyntax,+ PgUpdateSyntax,+ ) import Database.Beam.Postgres.TempTable-+import Database.Beam.Postgres.Types+ ( Postgres (..),+ fromPgIntegral,+ fromPgScientificOrIntegral,+ ) import qualified Database.PostgreSQL.Simple as Pg
Database/Beam/Postgres/Connection.hs view
@@ -9,7 +9,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} module Database.Beam.Postgres.Connection@@ -25,14 +24,15 @@ , postgresUriSyntax ) where -import Control.Exception (SomeException(..), throwIO)-import Data.IORef (newIORef, readIORef, writeIORef)-import Data.Vector (Vector)-import qualified Data.Vector as V+import Control.Exception (SomeException(..), throwIO, onException, catch)+import Control.Monad (void) import Control.Monad.Base (MonadBase(..)) import Control.Monad.Free.Church import Control.Monad.IO.Class import Control.Monad.Trans.Control (MonadBaseControl(..))+import Data.IORef (newIORef, readIORef, writeIORef)+import Data.Vector (Vector)+import qualified Data.Vector as V import Database.Beam hiding (runDelete, runUpdate, runInsert, insert) import Database.Beam.Backend.SQL.BeamExtensions@@ -41,6 +41,10 @@ import Database.Beam.Backend.URI import Database.Beam.Schema.Tables +import Database.Beam.Postgres.Extensions.Copy.File+ ( PgCopyFromSyntax(..), PgCopyToSyntax(..) )+import Database.Beam.Postgres.Extensions.Copy.Stream+ ( PgCopyFromStreamSyntax(..), PgCopyToStreamSyntax(..) ) import Database.Beam.Postgres.Syntax import Database.Beam.Postgres.Full import Database.Beam.Postgres.Types@@ -48,6 +52,7 @@ import qualified Database.PostgreSQL.LibPQ as Pg hiding (Connection, escapeStringConn, escapeIdentifier, escapeByteaConn, exec) import qualified Database.PostgreSQL.Simple as Pg+import qualified Database.PostgreSQL.Simple.Copy as PgCopy import qualified Database.PostgreSQL.Simple.FromField as Pg import qualified Database.PostgreSQL.Simple.Internal as Pg ( Field(..), RowParser(..)@@ -407,13 +412,56 @@ Just x -> collectM (acc . (x:)) in collectM id -instance MonadBeamInsertReturning Postgres Pg where- runInsertReturningList i = do- let insertReturningCmd' = i `returning`- changeBeamRep (\(Columnar' (QExpr s) :: Columnar' (QExpr Postgres PostgresInaccessible) ty) ->- Columnar' (QExpr s) :: Columnar' (QExpr Postgres ()) ty)+instance MonadBeamCopyTo Postgres Pg where+ runCopyTo SqlCopyToNoColumns = pure ()+ runCopyTo (SqlCopyTo (PgCopyToSyntax syntax)) =+ runNoReturn (PgCommandSyntax PgCommandTypeDataUpdate syntax) - -- Make savepoint+instance MonadBeamCopyFrom Postgres Pg where+ runCopyFrom SqlCopyFromNoColumns = pure ()+ runCopyFrom (SqlCopyFrom (PgCopyFromSyntax syntax)) =+ runNoReturn (PgCommandSyntax PgCommandTypeDataUpdate syntax)++instance MonadBeamCopyToStream Postgres Pg where+ -- | `runCopyToStream` is exception-safe; if the output stream+ -- produces an exception, the stream will be drained before the exception+ -- is re-thrown+ runCopyToStream SqlCopyToStreamNoColumns _ = pure ()+ runCopyToStream (SqlCopyToStream (PgCopyToStreamSyntax syntax)) sink =+ liftIOWithHandle $ \conn -> do+ query <- pgRenderSyntax conn syntax+ PgCopy.copy_ conn (Pg.Query query)+ let loop onRow = do+ PgCopy.getCopyData conn >>= \case+ PgCopy.CopyOutRow chunk -> onRow chunk >> loop onRow+ PgCopy.CopyOutDone _ -> pure ()+ -- Like 'loop', but doesn't use the sink at all. This is used+ -- to drain elements in the COPY stream before re-throwing an exception+ drain = loop (const (pure ()))+ loop sink `catch` (\(e::SomeException) -> drain >> throwIO e)+++instance MonadBeamCopyFromStream Postgres Pg where+ -- | `runCopyFromStream` is exception-safe; if the input stream+ -- produces an exception, the connection will be reset to a safe state,+ -- aborting the COPY operation.+ runCopyFromStream SqlCopyFromStreamNoColumns _ = pure ()+ runCopyFromStream (SqlCopyFromStream (PgCopyFromStreamSyntax syntax)) producer =+ liftIOWithHandle $ \conn -> do+ query <- pgRenderSyntax conn syntax+ let loop = + producer >>= \case+ Just chunk -> PgCopy.putCopyData conn chunk >> loop+ Nothing -> void $ PgCopy.putCopyEnd conn+ PgCopy.copy_ conn (Pg.Query query)+ loop `onException` PgCopy.putCopyError conn mempty++instance MonadBeamInsertReturning Postgres Pg where+ runInsertReturningListWith i mkProjection = do+ let pgProj tbl = mkProjection (changeBeamRep+ (\(Columnar' (QExpr s) :: Columnar' (QExpr Postgres PostgresInaccessible) ty) ->+ Columnar' (QExpr s) :: Columnar' (QExpr Postgres ()) ty) tbl)+ insertReturningCmd' = i `returning` pgProj case insertReturningCmd' of PgInsertReturningEmpty -> pure []@@ -421,11 +469,11 @@ runReturningList (PgCommandSyntax PgCommandTypeDataUpdateReturning insertReturningCmd) instance MonadBeamUpdateReturning Postgres Pg where- runUpdateReturningList u = do- let updateReturningCmd' = u `returning`- changeBeamRep (\(Columnar' (QExpr s) :: Columnar' (QExpr Postgres PostgresInaccessible) ty) ->- Columnar' (QExpr s) :: Columnar' (QExpr Postgres ()) ty)-+ runUpdateReturningListWith u mkProjection = do+ let pgProj tbl = mkProjection (changeBeamRep+ (\(Columnar' (QExpr s) :: Columnar' (QExpr Postgres PostgresInaccessible) ty) ->+ Columnar' (QExpr s) :: Columnar' (QExpr Postgres ()) ty) tbl)+ updateReturningCmd' = u `returning` pgProj case updateReturningCmd' of PgUpdateReturningEmpty -> pure []@@ -433,9 +481,9 @@ runReturningList (PgCommandSyntax PgCommandTypeDataUpdateReturning updateReturningCmd) instance MonadBeamDeleteReturning Postgres Pg where- runDeleteReturningList d = do- let PgDeleteReturning deleteReturningCmd = d `returning`- changeBeamRep (\(Columnar' (QExpr s) :: Columnar' (QExpr Postgres PostgresInaccessible) ty) ->- Columnar' (QExpr s) :: Columnar' (QExpr Postgres ()) ty)-+ runDeleteReturningListWith d mkProjection = do+ let pgProj tbl = mkProjection (changeBeamRep+ (\(Columnar' (QExpr s) :: Columnar' (QExpr Postgres PostgresInaccessible) ty) ->+ Columnar' (QExpr s) :: Columnar' (QExpr Postgres ()) ty) tbl)+ PgDeleteReturning deleteReturningCmd = d `returning` pgProj runReturningList (PgCommandSyntax PgCommandTypeDataUpdateReturning deleteReturningCmd)
Database/Beam/Postgres/Extensions.hs view
@@ -1,6 +1,5 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE CPP #-} -- | Postgres extensions are run-time loadable plugins that can extend Postgres -- functionality. Extensions are part of the database schema.@@ -10,9 +9,29 @@ -- the extension in a particular backend. @beam-postgres@ provides predicates -- and checks for @beam-migrate@ which allow extensions to be included as -- regular parts of beam migrations.-module Database.Beam.Postgres.Extensions where+module Database.Beam.Postgres.Extensions (+ -- * Handling extensions+ PgExtensionEntity,+ getPgExtension, + -- * Defining extensions+ IsPgExtension(..),+ -- ** Helpers+ PgExpr,+ LiftPg,+ funcE,++ -- * Migrations+ PgHasExtension(..),+ pgCreateExtension,+ pgDropExtension,+ pgExtensionActionProvider,+) where+ import Database.Beam+import Database.Beam.Backend.SQL ( IsSql92ExpressionSyntax(..), IsSql92FieldNameSyntax(..),+ IsSql99ExpressionSyntax, IsSql99FunctionExpressionSyntax(..)+ ) import Database.Beam.Schema.Tables import Database.Beam.Postgres.Types@@ -122,6 +141,21 @@ -> extension getPgExtension (DatabaseEntity (PgDatabaseExtension _ ext)) = ext +-- *** Helpers to write postgres user-defined extensions++-- | @since 0.6.2.0+type PgExpr ctxt s = QGenExpr ctxt Postgres s++-- | @since 0.6.2.0+type family LiftPg ctxt s fn where+ LiftPg ctxt s (Maybe a -> b) = Maybe (PgExpr ctxt s a) -> LiftPg ctxt s b+ LiftPg ctxt s (a -> b) = PgExpr ctxt s a -> LiftPg ctxt s b+ LiftPg ctxt s a = PgExpr ctxt s a++-- | @since 0.6.2.0+funcE :: IsSql99ExpressionSyntax expr => Text -> [expr] -> expr+funcE nm = functionCallE (fieldE (unqualifiedField nm))+ -- *** Migrations support for extensions -- | 'Migration' representing the Postgres @CREATE EXTENSION@ command. Because@@ -192,3 +226,4 @@ pure (PotentialAction (HS.fromList [p extP]) mempty (pure (MigrationCommand cmd MigrationKeepsData)) ("Unload the postgres extension " <> ext) 1)+
+ Database/Beam/Postgres/Extensions/Copy/File.hs view
@@ -0,0 +1,421 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}++module Database.Beam.Postgres.Extensions.Copy.File+ ( PgCopyToSyntax (..),+ PgCopyToSourceSyntax (..),+ PgCopyFromSyntax (..),+ PgCopyFromSourceSyntax (..),++ -- * COPY options+ PgCopyToOptions,+ PgCopyFromOptions,++ -- ** text+ copyToText,+ copyToTextWith,+ PgTextCopyToOptions (..),+ defaultPgTextCopyToOptions,+ copyFromText,+ copyFromTextWith,+ PgTextCopyFromOptions (..),+ defaultPgTextCopyFromOptions,++ -- ** CSV+ copyToCSV,+ copyToCSVWith,+ PgCSVCopyToOptions (..),+ defaultPgCSVCopyToOptions,+ copyFromCSV,+ copyFromCSVWith,+ PgCSVCopyFromOptions (..),+ defaultPgCSVCopyFromOptions,++ -- * Internal — exposed for use by sibling modules+ emitOptionList,+ textCopyToFields,+ csvCopyToFields,+ textCopyFromFields,+ csvCopyFromFields,+ )+where++import qualified Data.List.NonEmpty as NE+import Data.Maybe (catMaybes)+import Data.Text (Text)+import qualified Data.Text as T+import Database.Beam.Backend.SQL.BeamExtensions+ ( IsSqlCopyFromSourceSyntax (..),+ IsSqlCopyFromSyntax (..),+ IsSqlCopyToSourceSyntax (..),+ IsSqlCopyToSyntax (..),+ )+import Database.Beam.Postgres.Syntax+ ( PgSelectSyntax (..),+ PgSyntax,+ emit,+ pgBoolLit,+ pgCharLit,+ pgParens,+ pgQuotedIdentifier,+ pgSepBy,+ pgStringLit,+ )++-- | PostgreSQL @COPY ... TO@ source syntax. Wraps the table name (with+-- optional column list) or a @SELECT@ subquery.+--+-- @since 0.6.1.0+newtype PgCopyToSourceSyntax = PgCopyToSourceSyntax {fromPgCopyToSource :: PgSyntax}++-- | PostgreSQL @COPY ... TO@ statement syntax.+--+-- @since 0.6.1.0+newtype PgCopyToSyntax = PgCopyToSyntax {fromPgCopyTo :: PgSyntax}++-- | PostgreSQL @COPY ... FROM@ source syntax. Just the table name plus+-- optional column list — Postgres @COPY ... FROM@ does not accept a SELECT.+--+-- @since 0.6.1.0+newtype PgCopyFromSourceSyntax = PgCopyFromSourceSyntax {fromPgCopyFromSource :: PgSyntax}++-- | PostgreSQL @COPY ... FROM@ statement syntax.+--+-- @since 0.6.1.0+newtype PgCopyFromSyntax = PgCopyFromSyntax {fromPgCopyFrom :: PgSyntax}++instance IsSqlCopyToSourceSyntax PgCopyToSourceSyntax where+ type SqlCopyToSourceSelectSyntax PgCopyToSourceSyntax = PgSelectSyntax++ copyTableToSyntax mSchema tableName' mColumns =+ PgCopyToSourceSyntax $+ maybe mempty (\schema -> pgQuotedIdentifier schema <> emit ".") mSchema+ <> pgQuotedIdentifier tableName'+ <> case mColumns of+ Nothing -> mempty+ Just cols -> pgParens $ pgSepBy (emit ", ") (map pgQuotedIdentifier (NE.toList cols))++ copySelectToSyntax (PgSelectSyntax select) = PgCopyToSourceSyntax $ pgParens select++instance IsSqlCopyToSyntax PgCopyToSyntax where+ type SqlCopyToSourceSyntax PgCopyToSyntax = PgCopyToSourceSyntax+ type SqlCopyToParams PgCopyToSyntax = PgCopyToOptions++ copyToStmt (PgCopyToSourceSyntax source) options =+ let (filepath, optionsSyntax) = emitPgCopyToOptions options+ in PgCopyToSyntax $+ mconcat+ [ emit "COPY ",+ source,+ emit " TO ",+ pgStringLit (T.pack filepath),+ optionsSyntax+ ]++instance IsSqlCopyFromSourceSyntax PgCopyFromSourceSyntax where+ copyTableFromSyntax mSchema tableName' mColumns =+ PgCopyFromSourceSyntax $+ maybe mempty (\schema -> pgQuotedIdentifier schema <> emit ".") mSchema+ <> pgQuotedIdentifier tableName'+ <> case mColumns of+ Nothing -> mempty+ Just cols -> pgParens $ pgSepBy (emit ", ") (map pgQuotedIdentifier (NE.toList cols))++instance IsSqlCopyFromSyntax PgCopyFromSyntax where+ type SqlCopyFromSourceSyntax PgCopyFromSyntax = PgCopyFromSourceSyntax+ type SqlCopyFromParams PgCopyFromSyntax = PgCopyFromOptions++ copyFromStmt (PgCopyFromSourceSyntax source) options =+ let (filepath, optionsSyntax) = emitPgCopyFromOptions options+ in PgCopyFromSyntax $+ mconcat+ [ emit "COPY ",+ source,+ emit " FROM ",+ pgStringLit (T.pack filepath),+ optionsSyntax+ ]++-- | Options for PostgreSQL's @COPY ... TO@ statement, tagged by the output+-- format. Use 'copyToText' or 'copyToCSV' to construct.+--+-- See <https://www.postgresql.org/docs/current/sql-copy.html the PostgreSQL COPY documentation>+-- for the full set of options each format supports.+--+-- @since 0.6.1.0+data PgCopyToOptions+ = PgCopyToText !FilePath !PgTextCopyToOptions+ | PgCopyToCSV !FilePath !PgCSVCopyToOptions+ deriving (Eq, Show)++-- | Copy to a text file at the given path with default options.+-- Use 'copyToTextWith' to override.+--+-- @since 0.6.1.0+copyToText :: FilePath -> PgCopyToOptions+copyToText path = PgCopyToText path defaultPgTextCopyToOptions++-- | Copy to a text file at the given path with the given options.+--+-- @since 0.6.1.0+copyToTextWith :: FilePath -> PgTextCopyToOptions -> PgCopyToOptions+copyToTextWith = PgCopyToText++-- | Copy to a CSV file at the given path with default options.+-- Use 'copyToCSVWith' to override.+--+-- @since 0.6.1.0+copyToCSV :: FilePath -> PgCopyToOptions+copyToCSV path = PgCopyToCSV path defaultPgCSVCopyToOptions++-- | Copy to a CSV file at the given path with the given options.+--+-- @since 0.6.1.0+copyToCSVWith :: FilePath -> PgCSVCopyToOptions -> PgCopyToOptions+copyToCSVWith = PgCopyToCSV++-- | Options for PostgreSQL's @COPY ... FROM@ statement, tagged by the input+-- format. Use 'copyFromText' or 'copyFromCSV' to construct.+--+-- @since 0.6.1.0+data PgCopyFromOptions+ = PgCopyFromText !FilePath !PgTextCopyFromOptions+ | PgCopyFromCSV !FilePath !PgCSVCopyFromOptions+ deriving (Eq, Show)++-- | Copy from a text file at the given path with default options.+-- Use 'copyFromTextWith' to override.+--+-- @since 0.6.1.0+copyFromText :: FilePath -> PgCopyFromOptions+copyFromText path = PgCopyFromText path defaultPgTextCopyFromOptions++-- | Copy from a text file at the given path with the given options.+--+-- @since 0.6.1.0+copyFromTextWith :: FilePath -> PgTextCopyFromOptions -> PgCopyFromOptions+copyFromTextWith = PgCopyFromText++-- | Copy from a CSV file at the given path with default options.+-- Use 'copyFromCSVWith' to override.+--+-- @since 0.6.1.0+copyFromCSV :: FilePath -> PgCopyFromOptions+copyFromCSV path = PgCopyFromCSV path defaultPgCSVCopyFromOptions++-- | Copy from a CSV file at the given path with the given options.+--+-- @since 0.6.1.0+copyFromCSVWith :: FilePath -> PgCSVCopyFromOptions -> PgCopyFromOptions+copyFromCSVWith = PgCopyFromCSV++-- | Options for the @text@ format on @COPY ... TO@.+--+-- @since 0.6.1.0+data PgTextCopyToOptions = PgTextCopyToOptions+ { -- | @DELIMITER@: single-character column delimiter. Defaults to TAB.+ pgTextCopyToDelimiter :: Maybe Char,+ -- | @NULL@: token written for SQL @NULL@ values. Defaults to @\\N@.+ pgTextCopyToNullStr :: Maybe Text,+ -- | @HEADER@: emit a header row with column names.+ pgTextCopyToHeader :: Maybe Bool,+ -- | @ENCODING@: client-encoding override for the file.+ pgTextCopyToEncoding :: Maybe Text+ }+ deriving (Eq, Show)++-- | All-'Nothing' 'PgTextCopyToOptions'; a sensible starting point for+-- record-update overrides.+--+-- @since 0.6.1.0+defaultPgTextCopyToOptions :: PgTextCopyToOptions+defaultPgTextCopyToOptions =+ PgTextCopyToOptions+ { pgTextCopyToDelimiter = Nothing,+ pgTextCopyToNullStr = Nothing,+ pgTextCopyToHeader = Nothing,+ pgTextCopyToEncoding = Nothing+ }++-- | Options for the @csv@ format on @COPY ... TO@.+--+-- @since 0.6.1.0+data PgCSVCopyToOptions = PgCSVCopyToOptions+ { -- | @DELIMITER@: single-character column delimiter. Defaults to a comma.+ pgCsvCopyToDelimiter :: Maybe Char,+ -- | @NULL@: token written for SQL @NULL@ values. Defaults to the empty+ -- string.+ pgCsvCopyToNullStr :: Maybe Text,+ -- | @HEADER@: emit a header row with column names.+ pgCsvCopyToHeader :: Maybe Bool,+ -- | @QUOTE@: single-character quote character. Defaults to @\"@.+ pgCsvCopyToQuote :: Maybe Char,+ -- | @ESCAPE@: single-character escape character. Defaults to the+ -- value of 'pgCsvCopyToQuote'.+ pgCsvCopyToEscape :: Maybe Char,+ -- | @ENCODING@: client-encoding override for the file.+ pgCsvCopyToEncoding :: Maybe Text+ }+ deriving (Eq, Show)++-- | All-'Nothing' 'PgCSVCopyToOptions'.+--+-- @since 0.6.1.0+defaultPgCSVCopyToOptions :: PgCSVCopyToOptions+defaultPgCSVCopyToOptions =+ PgCSVCopyToOptions+ { pgCsvCopyToDelimiter = Nothing,+ pgCsvCopyToNullStr = Nothing,+ pgCsvCopyToHeader = Nothing,+ pgCsvCopyToQuote = Nothing,+ pgCsvCopyToEscape = Nothing,+ pgCsvCopyToEncoding = Nothing+ }++-- | Options for the @text@ format on @COPY ... FROM@.+--+-- @since 0.6.1.0+data PgTextCopyFromOptions = PgTextCopyFromOptions+ { -- | @DELIMITER@: single-character column delimiter. Defaults to TAB.+ pgTextCopyFromDelimiter :: Maybe Char,+ -- | @NULL@: token to interpret as SQL @NULL@. Defaults to @\\N@.+ pgTextCopyFromNullStr :: Maybe Text,+ -- | @HEADER@: skip the first line as a header row.+ pgTextCopyFromHeader :: Maybe Bool,+ -- | @ENCODING@: client-encoding override for the file.+ pgTextCopyFromEncoding :: Maybe Text,+ -- | @FREEZE@: skip WAL when loading; only legal under specific+ -- conditions (see the PostgreSQL @COPY@ documentation).+ pgTextCopyFromFreeze :: Maybe Bool+ }+ deriving (Eq, Show)++-- | All-'Nothing' 'PgTextCopyFromOptions'.+--+-- @since 0.6.1.0+defaultPgTextCopyFromOptions :: PgTextCopyFromOptions+defaultPgTextCopyFromOptions =+ PgTextCopyFromOptions+ { pgTextCopyFromDelimiter = Nothing,+ pgTextCopyFromNullStr = Nothing,+ pgTextCopyFromHeader = Nothing,+ pgTextCopyFromEncoding = Nothing,+ pgTextCopyFromFreeze = Nothing+ }++-- | Options for the @csv@ format on @COPY ... FROM@.+--+-- @since 0.6.1.0+data PgCSVCopyFromOptions = PgCSVCopyFromOptions+ { -- | @DELIMITER@: single-character column delimiter. Defaults to a comma.+ pgCsvCopyFromDelimiter :: Maybe Char,+ -- | @NULL@: token to interpret as SQL @NULL@. Defaults to the empty+ -- string.+ pgCsvCopyFromNullStr :: Maybe Text,+ -- | @HEADER@: skip the first line as a header row.+ pgCsvCopyFromHeader :: Maybe Bool,+ -- | @QUOTE@: single-character quote character. Defaults to @\"@.+ pgCsvCopyFromQuote :: Maybe Char,+ -- | @ESCAPE@: single-character escape character. Defaults to the+ -- value of 'pgCsvCopyFromQuote'.+ pgCsvCopyFromEscape :: Maybe Char,+ -- | @ENCODING@: client-encoding override for the file.+ pgCsvCopyFromEncoding :: Maybe Text,+ -- | @FREEZE@: skip WAL when loading; only legal under specific+ -- conditions (see the PostgreSQL @COPY@ documentation).+ pgCsvCopyFromFreeze :: Maybe Bool+ }+ deriving (Eq, Show)++-- | All-'Nothing' 'PgCSVCopyFromOptions'; a sensible starting point for+-- record-update overrides.+--+-- @since 0.6.1.0+defaultPgCSVCopyFromOptions :: PgCSVCopyFromOptions+defaultPgCSVCopyFromOptions =+ PgCSVCopyFromOptions+ { pgCsvCopyFromDelimiter = Nothing,+ pgCsvCopyFromNullStr = Nothing,+ pgCsvCopyFromHeader = Nothing,+ pgCsvCopyFromQuote = Nothing,+ pgCsvCopyFromEscape = Nothing,+ pgCsvCopyFromEncoding = Nothing,+ pgCsvCopyFromFreeze = Nothing+ }++-- * Emission++emitPgCopyToOptions :: PgCopyToOptions -> (FilePath, PgSyntax)+emitPgCopyToOptions (PgCopyToText fp o) = (fp, emitOptionList (emit "text") (textCopyToFields o))+emitPgCopyToOptions (PgCopyToCSV fp o) = (fp, emitOptionList (emit "csv") (csvCopyToFields o))++emitPgCopyFromOptions :: PgCopyFromOptions -> (FilePath, PgSyntax)+emitPgCopyFromOptions (PgCopyFromText fp o) = (fp, emitOptionList (emit "text") (textCopyFromFields o))+emitPgCopyFromOptions (PgCopyFromCSV fp o) = (fp, emitOptionList (emit "csv") (csvCopyFromFields o))++-- | Render @ (FORMAT FMT, OPT1 …, OPT2 …)@. The @FORMAT@ entry is always+-- present since the constructor of the options value pins it.+--+-- @since 0.6.1.0+emitOptionList :: PgSyntax -> [PgSyntax] -> PgSyntax+emitOptionList fmt items =+ emit " ("+ <> pgSepBy (emit ", ") ((emit "FORMAT " <> fmt) : items)+ <> emit ")"++-- | Render the per-option items for a 'PgTextCopyToOptions' value.+--+-- @since 0.6.1.0+textCopyToFields :: PgTextCopyToOptions -> [PgSyntax]+textCopyToFields o =+ catMaybes+ [ fmap (\c -> emit "DELIMITER " <> pgCharLit c) (pgTextCopyToDelimiter o),+ fmap (\s -> emit "NULL " <> pgStringLit s) (pgTextCopyToNullStr o),+ fmap (\b -> emit "HEADER " <> pgBoolLit b) (pgTextCopyToHeader o),+ fmap (\s -> emit "ENCODING " <> pgStringLit s) (pgTextCopyToEncoding o)+ ]++-- | Render the per-option items for a 'PgCSVCopyToOptions' value.+--+-- @since 0.6.1.0+csvCopyToFields :: PgCSVCopyToOptions -> [PgSyntax]+csvCopyToFields o =+ catMaybes+ [ fmap (\c -> emit "DELIMITER " <> pgCharLit c) (pgCsvCopyToDelimiter o),+ fmap (\s -> emit "NULL " <> pgStringLit s) (pgCsvCopyToNullStr o),+ fmap (\b -> emit "HEADER " <> pgBoolLit b) (pgCsvCopyToHeader o),+ fmap (\c -> emit "QUOTE " <> pgCharLit c) (pgCsvCopyToQuote o),+ fmap (\c -> emit "ESCAPE " <> pgCharLit c) (pgCsvCopyToEscape o),+ fmap (\s -> emit "ENCODING " <> pgStringLit s) (pgCsvCopyToEncoding o)+ ]++-- | Render the per-option items for a 'PgTextCopyFromOptions' value.+--+-- @since 0.6.1.0+textCopyFromFields :: PgTextCopyFromOptions -> [PgSyntax]+textCopyFromFields o =+ catMaybes+ [ fmap (\c -> emit "DELIMITER " <> pgCharLit c) (pgTextCopyFromDelimiter o),+ fmap (\s -> emit "NULL " <> pgStringLit s) (pgTextCopyFromNullStr o),+ fmap (\b -> emit "HEADER " <> pgBoolLit b) (pgTextCopyFromHeader o),+ fmap (\s -> emit "ENCODING " <> pgStringLit s) (pgTextCopyFromEncoding o),+ fmap (\b -> emit "FREEZE " <> pgBoolLit b) (pgTextCopyFromFreeze o)+ ]++-- | Render the per-option items for a 'PgCSVCopyFromOptions' value.+--+-- @since 0.6.1.0+csvCopyFromFields :: PgCSVCopyFromOptions -> [PgSyntax]+csvCopyFromFields o =+ catMaybes+ [ fmap (\c -> emit "DELIMITER " <> pgCharLit c) (pgCsvCopyFromDelimiter o),+ fmap (\s -> emit "NULL " <> pgStringLit s) (pgCsvCopyFromNullStr o),+ fmap (\b -> emit "HEADER " <> pgBoolLit b) (pgCsvCopyFromHeader o),+ fmap (\c -> emit "QUOTE " <> pgCharLit c) (pgCsvCopyFromQuote o),+ fmap (\c -> emit "ESCAPE " <> pgCharLit c) (pgCsvCopyFromEscape o),+ fmap (\s -> emit "ENCODING " <> pgStringLit s) (pgCsvCopyFromEncoding o),+ fmap (\b -> emit "FREEZE " <> pgBoolLit b) (pgCsvCopyFromFreeze o)+ ]
+ Database/Beam/Postgres/Extensions/Copy/Stream.hs view
@@ -0,0 +1,175 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}++module Database.Beam.Postgres.Extensions.Copy.Stream+ ( PgCopyToStreamSyntax (..),+ PgCopyFromStreamSyntax (..),++ -- * COPY options+ PgCopyToStreamOptions,+ PgCopyFromStreamOptions,++ -- ** text+ copyToTextStream,+ copyToTextStreamWith,+ copyFromTextStream,+ copyFromTextStreamWith,++ -- ** CSV+ copyToCSVStream,+ copyToCSVStreamWith,+ copyFromCSVStream,+ copyFromCSVStreamWith,+ )+where++import Database.Beam.Backend.SQL.BeamExtensions+ ( IsSqlCopyFromStreamSyntax (..),+ IsSqlCopyToStreamSyntax (..),+ )+import Database.Beam.Postgres.Extensions.Copy.File+ ( PgCSVCopyFromOptions (..),+ PgCSVCopyToOptions (..),+ PgCopyFromSourceSyntax (..),+ PgCopyToSourceSyntax (..),+ PgTextCopyFromOptions (..),+ PgTextCopyToOptions (..),+ csvCopyFromFields,+ csvCopyToFields,+ defaultPgCSVCopyFromOptions,+ defaultPgCSVCopyToOptions,+ defaultPgTextCopyFromOptions,+ defaultPgTextCopyToOptions,+ emitOptionList,+ textCopyFromFields,+ textCopyToFields,+ )+import Database.Beam.Postgres.Syntax (PgSyntax, emit)++-- | PostgreSQL streaming @COPY ... TO STDOUT@ statement syntax.+--+-- @since 0.6.1.0+newtype PgCopyToStreamSyntax = PgCopyToStreamSyntax {fromPgCopyToStream :: PgSyntax}++-- | PostgreSQL streaming @COPY ... FROM STDIN@ statement syntax.+--+-- @since 0.6.1.0+newtype PgCopyFromStreamSyntax = PgCopyFromStreamSyntax {fromPgCopyFromStream :: PgSyntax}++instance IsSqlCopyToStreamSyntax PgCopyToStreamSyntax where+ type SqlCopyToStreamSourceSyntax PgCopyToStreamSyntax = PgCopyToSourceSyntax+ type SqlCopyToStreamParams PgCopyToStreamSyntax = PgCopyToStreamOptions++ copyToStreamStmt (PgCopyToSourceSyntax source) options =+ PgCopyToStreamSyntax $+ mconcat+ [ emit "COPY ",+ source,+ emit " TO STDOUT",+ emitPgCopyToStreamOptions options+ ]++instance IsSqlCopyFromStreamSyntax PgCopyFromStreamSyntax where+ type SqlCopyFromStreamSourceSyntax PgCopyFromStreamSyntax = PgCopyFromSourceSyntax+ type SqlCopyFromStreamParams PgCopyFromStreamSyntax = PgCopyFromStreamOptions++ copyFromStreamStmt (PgCopyFromSourceSyntax source) options =+ PgCopyFromStreamSyntax $+ mconcat+ [ emit "COPY ",+ source,+ emit " FROM STDIN",+ emitPgCopyFromStreamOptions options+ ]++-- | Options for PostgreSQL's streaming @COPY ... TO STDOUT@ statement,+-- tagged by the output format.+--+-- See <https://www.postgresql.org/docs/current/sql-copy.html the PostgreSQL COPY documentation>+-- for the full set of options each format supports.+--+-- @since 0.6.1.0+data PgCopyToStreamOptions+ = PgCopyToStreamText !PgTextCopyToOptions+ | PgCopyToStreamCSV !PgCSVCopyToOptions+ deriving (Eq, Show)++-- | Stream out using the @text@ format with default options.+-- Use 'copyToTextStreamWith' to override.+--+-- @since 0.6.1.0+copyToTextStream :: PgCopyToStreamOptions+copyToTextStream = PgCopyToStreamText defaultPgTextCopyToOptions++-- | Stream out using the @text@ format with the given options.+--+-- @since 0.6.1.0+copyToTextStreamWith :: PgTextCopyToOptions -> PgCopyToStreamOptions+copyToTextStreamWith = PgCopyToStreamText++-- | Stream out using the @csv@ format with default options.+-- Use 'copyToCSVStreamWith' to override.+--+-- @since 0.6.1.0+copyToCSVStream :: PgCopyToStreamOptions+copyToCSVStream = PgCopyToStreamCSV defaultPgCSVCopyToOptions++-- | Stream out using the @csv@ format with the given options.+--+-- @since 0.6.1.0+copyToCSVStreamWith :: PgCSVCopyToOptions -> PgCopyToStreamOptions+copyToCSVStreamWith = PgCopyToStreamCSV++-- | Options for PostgreSQL's streaming @COPY ... FROM STDIN@ statement,+-- tagged by the input format.+--+-- @since 0.6.1.0+data PgCopyFromStreamOptions+ = PgCopyFromStreamText !PgTextCopyFromOptions+ | PgCopyFromStreamCSV !PgCSVCopyFromOptions+ deriving (Eq, Show)++-- | Stream in using the @text@ format with default options.+-- Use 'copyFromTextStreamWith' to override.+--+-- @since 0.6.1.0+copyFromTextStream :: PgCopyFromStreamOptions+copyFromTextStream = PgCopyFromStreamText defaultPgTextCopyFromOptions++-- | Stream in using the @text@ format with the given options.+--+-- @since 0.6.1.0+copyFromTextStreamWith :: PgTextCopyFromOptions -> PgCopyFromStreamOptions+copyFromTextStreamWith = PgCopyFromStreamText++-- | Stream in using the @csv@ format with default options.+-- Use 'copyFromCSVStreamWith' to override.+--+-- @since 0.6.1.0+copyFromCSVStream :: PgCopyFromStreamOptions+copyFromCSVStream = PgCopyFromStreamCSV defaultPgCSVCopyFromOptions++-- | Stream in using the @csv@ format with the given options.+--+-- @since 0.6.1.0+copyFromCSVStreamWith :: PgCSVCopyFromOptions -> PgCopyFromStreamOptions+copyFromCSVStreamWith = PgCopyFromStreamCSV++-- | Render the @WITH (FORMAT ..., ...)@ tail of a streaming+-- @COPY ... TO STDOUT@ statement.+--+-- @since 0.6.1.0+emitPgCopyToStreamOptions :: PgCopyToStreamOptions -> PgSyntax+emitPgCopyToStreamOptions (PgCopyToStreamText o) = emitOptionList (emit "text") (textCopyToFields o)+emitPgCopyToStreamOptions (PgCopyToStreamCSV o) = emitOptionList (emit "csv") (csvCopyToFields o)++-- | Render the @WITH (FORMAT ..., ...)@ tail of a streaming+-- @COPY ... FROM STDIN@ statement.+--+-- @since 0.6.1.0+emitPgCopyFromStreamOptions :: PgCopyFromStreamOptions -> PgSyntax+emitPgCopyFromStreamOptions (PgCopyFromStreamText o) = emitOptionList (emit "text") (textCopyFromFields o)+emitPgCopyFromStreamOptions (PgCopyFromStreamCSV o) = emitOptionList (emit "csv") (csvCopyFromFields o)
− Database/Beam/Postgres/Extensions/Internal.hs
@@ -1,17 +0,0 @@-module Database.Beam.Postgres.Extensions.Internal where--import Data.Text (Text)--import Database.Beam-import Database.Beam.Backend.SQL-import Database.Beam.Postgres--type PgExpr ctxt s = QGenExpr ctxt Postgres s--type family LiftPg ctxt s fn where- LiftPg ctxt s (Maybe a -> b) = Maybe (PgExpr ctxt s a) -> LiftPg ctxt s b- LiftPg ctxt s (a -> b) = PgExpr ctxt s a -> LiftPg ctxt s b- LiftPg ctxt s a = PgExpr ctxt s a--funcE :: IsSql99ExpressionSyntax expr => Text -> [expr] -> expr-funcE nm args = functionCallE (fieldE (unqualifiedField nm)) args
Database/Beam/Postgres/Extensions/UuidOssp.hs view
@@ -10,8 +10,7 @@ import Data.UUID.Types (UUID) import Database.Beam-import Database.Beam.Postgres.Extensions-import Database.Beam.Postgres.Extensions.Internal+import Database.Beam.Postgres.Extensions ( LiftPg, IsPgExtension(..), funcE ) -- | Data type representing definitions contained in the @uuid-ossp@ extension data UuidOssp = UuidOssp
Database/Beam/Postgres/Full.hs view
@@ -1,8 +1,10 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RoleAnnotations #-} {-# LANGUAGE TupleSections #-}-{-# LANGUAGE CPP #-} {-# 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 @@ , locked_, lockAll_, withLocks_ - -- ** Inner WITH queries- , pgSelectWith+ -- ** Common table expressions+ , PgCtePlacement(..), PgWith+ , pgLiftWith, pgToTopLevel+ , PgCteMaterialization(..), pgSelecting, pgSelectingWith+ , pgSelectWith, pgSelectWithNested, pgSelectWithTopLevel+ , pgInsertWith, pgUpdateWith, pgDeleteWith -- ** Lateral joins , lateral_ -- * @INSERT@ and @INSERT RETURNING@- , insert, insertReturning+ , insert, insertReturning, cteInsert, cteInsertReturning , insertDefaults , runPgInsertReturningList @@ -46,12 +57,12 @@ -- * @UPDATE RETURNING@ , PgUpdateReturning(..) , runPgUpdateReturningList- , updateReturning+ , updateReturning, cteUpdate, cteUpdateReturning -- * @DELETE RETURNING@ , PgDeleteReturning(..) , runPgDeleteReturningList- , deleteReturning+ , deleteReturning, cteDelete, cteDeleteReturning -- * Generalized @RETURNING@ , PgReturning(..)@@ -67,16 +78,235 @@ import Database.Beam.Postgres.Types import Database.Beam.Postgres.Syntax +import Control.Monad.Fix (MonadFix(..)) import Control.Monad.Free.Church-import Control.Monad.State.Strict (evalState)-import Control.Monad.Writer (runWriterT)+import Control.Monad.State.Strict (evalState, get, put)+import Control.Monad.Writer (runWriterT, tell) +import Data.List.NonEmpty (NonEmpty(..), 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+-- <https://www.postgresql.org/docs/current/queries-with.html#QUERIES-WITH-MODIFYING data-modifying WITH documentation>.+--+-- @since 0.6.3.0+data PgCtePlacement+ = PgCteNestedAllowed+ -- ^ The block contains only CTEs which may be nested.+ | PgCteTopLevelOnly+ -- ^ The block contains a data-modifying CTE and must remain top-level.++-- | A PostgreSQL-specific CTE builder.+--+-- This newtype uses beam-core's existing 'With' action and CTE accumulator. It+-- adds a placement index for PostgreSQL data-modifying CTEs without introducing+-- a second name supply or syntax writer. Consequently a lifted portable helper+-- and a native PostgreSQL CTE allocate names from the same sequence.+--+-- Use 'pgSelecting' for SELECT CTEs, 'cteInsertReturning',+-- 'cteUpdateReturning', or 'cteDeleteReturning' for reusable modifying CTEs,+-- and 'cteInsert', 'cteUpdate', or 'cteDelete' for side-effect-only CTEs.+-- Consume the completed block with 'pgSelectWithTopLevel', 'pgInsertWith',+-- 'pgUpdateWith', or 'pgDeleteWith'.+--+-- @since 0.6.3.0+newtype PgWith db (placement :: PgCtePlacement) a =+ PgWith { unPgWith :: With Postgres db a }+ deriving (Functor, Applicative, Monad)++-- The placement parameter is phantom at runtime. A nominal role prevents+-- Data.Coerce from relabelling a top-level-only block as nested-safe.+type role PgWith nominal nominal nominal++-- Recursive knots are deliberately restricted to SELECT-only construction.+-- Complete such a knot first and then use 'pgToTopLevel' before adding a+-- data-modifying CTE which consumes its rows.+instance MonadFix (PgWith db 'PgCteNestedAllowed) where+ mfix f = PgWith (mfix (unPgWith . f))++-- | Lift an existing portable PostgreSQL 'With' helper into 'PgWith'.+--+-- Helpers constructed with the portable 'selecting' API contain SELECT+-- statements, so they are valid at either placement. The lifted action uses+-- the surrounding 'PgWith' name supply; lifting a helper which defines several+-- CTEs therefore cannot collide with CTEs defined before or after it.+--+-- > native <- pgSelecting nativeQuery+-- > rows <- pgLiftWith existingSelectCtes+-- > changed <- cteDeleteReturning table predicate id+-- > pure $ do+-- > nativeRow <- reuse native+-- > row <- reuse rows+-- > changedRow <- reuse changed+-- > pure (nativeRow, row, changedRow)+--+-- If @existingSelectCtes@ defines two CTEs and one native CTE precedes it,+-- Beam generates one block whose names continue through the lifted helper:+--+-- @+-- WITH "cte0"("res0") AS (SELECT ...),+-- "cte1"("res0") AS (SELECT ...),+-- "cte2"("res0") AS (SELECT ... FROM "cte1"),+-- "cte3"("res0", "res1") AS+-- (DELETE FROM "table" ... RETURNING "id", "value")+-- SELECT ... FROM "cte0" CROSS JOIN "cte2" CROSS JOIN "cte3"+-- @+--+-- The 'With' constructor is public for low-level extension code. 'pgLiftWith'+-- assumes such code preserves the portable API's SELECT-only invariant.+--+-- @since 0.6.3.0+pgLiftWith :: With Postgres db a -> PgWith db placement a+pgLiftWith = PgWith++-- | Promote a completed nested-safe block for composition with+-- data-modifying CTEs.+--+-- This operation is one-way. In particular, there is no public operation for+-- converting 'PgCteTopLevelOnly' back to 'PgCteNestedAllowed'.+--+-- > pgSelectWithTopLevel $ do+-- > recursiveRows <- pgToTopLevel $ mdo+-- > rows <- pgSelecting recursiveQuery+-- > pure rows+-- > cteDelete table $ \row -> exists_ $ do+-- > recursiveRow <- reuse recursiveRows+-- > guard_ (rowId row ==. rowId recursiveRow)+-- > pure finalQuery+--+-- The promotion changes no SQL. It permits the subsequent modifying CTE, so+-- the complete block has the following form:+--+-- @+-- WITH RECURSIVE "cte0"("res0") AS+-- (SELECT ... UNION ALL SELECT ... FROM "cte0"),+-- "cte1" AS+-- (DELETE FROM "table"+-- WHERE EXISTS (SELECT ... FROM "cte0"))+-- SELECT ...+-- @+--+-- @since 0.6.3.0+pgToTopLevel+ :: PgWith db 'PgCteNestedAllowed a+ -> PgWith db 'PgCteTopLevelOnly a+pgToTopLevel (PgWith with) = PgWith with++-- | PostgreSQL's materialization policy for a SELECT CTE.+--+-- Explicit materialization control is available in PostgreSQL 12 and later.+-- 'PgCteDefault' emits no modifier and therefore retains PostgreSQL's normal+-- planner behaviour and compatibility with earlier server versions.+-- See PostgreSQL's+-- <https://www.postgresql.org/docs/current/queries-with.html#QUERIES-WITH-CTE-MATERIALIZATION CTE materialization documentation>.+--+-- @since 0.6.3.0+data PgCteMaterialization+ = PgCteDefault+ -- ^ Let PostgreSQL decide whether to fold or materialize the CTE.+ | PgCteMaterialized+ -- ^ Emit @MATERIALIZED@, requesting separate calculation of the CTE. This+ -- can act as an optimization fence or prevent duplicated computation.+ | PgCteNotMaterialized+ -- ^ Emit @NOT MATERIALIZED@, allowing the CTE and parent query to be+ -- optimized together. PostgreSQL ignores this for recursive or+ -- non-side-effect-free queries.+ deriving (Eq, Show)++-- | Introduce a SELECT query as a reusable PostgreSQL CTE using the server's+-- default materialization policy.+--+-- This is the usual PostgreSQL-specific counterpart of 'selecting'. Use+-- 'pgSelectingWith' when the planner boundary should be controlled explicitly.+--+-- > rows <- pgSelecting sourceQuery+-- > pure (reuse rows)+--+-- With a top-level SELECT consumer this produces:+--+-- @+-- WITH "cte0"("res0", "res1") AS (SELECT ...)+-- SELECT "t0"."res0", "t0"."res1" FROM "cte0" AS "t0"+-- @+--+-- @since 0.6.3.0+pgSelecting+ :: ( Projectible Postgres res+ , ThreadRewritable CTE.QAnyScope res )+ => Q Postgres db CTE.QAnyScope res+ -> PgWith db placement (ReusableQ Postgres db res)+pgSelecting = pgSelectingWith PgCteDefault++-- | Introduce a SELECT query as a reusable PostgreSQL CTE with an explicit+-- materialization policy.+--+-- For example:+--+-- > expensive <- pgSelectingWith PgCteMaterialized expensiveQuery+-- > pure $ do+-- > left <- reuse expensive+-- > right <- reuse expensive+-- > guard_ (leftId left ==. rightId right)+-- > pure (left, right)+--+-- With 'pgSelectWithTopLevel', this produces a statement shaped like:+--+-- @+-- WITH "cte0"("res0", "res1") AS MATERIALIZED (SELECT ...)+-- SELECT ...+-- FROM "cte0" AS "t0" CROSS JOIN "cte0" AS "t1"+-- WHERE "t0"."res0" = "t1"."res0"+-- @+--+-- @NOT MATERIALIZED@ may allow restrictions in the parent query to reach the+-- CTE, but may also duplicate its computation when it is referenced more than+-- once. PostgreSQL ignores @NOT MATERIALIZED@ when folding would not be+-- semantically valid, for example for a recursive query or a query containing+-- volatile functions.+--+-- A projection with no fields is represented by omitting the CTE column-alias+-- list. PostgreSQL then treats the CTE as a degree-zero relation: it has no+-- columns, but it retains the row cardinality of @query@. For example, a query+-- which produces two empty rows has the following shape:+--+-- @+-- WITH "cte0" AS MATERIALIZED (SELECT FROM ...)+-- SELECT FROM "cte0" AS "t0"+-- @+--+-- Reusing such a CTE remains meaningful in joins, @EXISTS@, and aggregates+-- even though no value can be projected from an individual row.+--+-- @since 0.6.3.0+pgSelectingWith+ :: forall res db placement+ . ( Projectible Postgres res+ , ThreadRewritable CTE.QAnyScope res )+ => PgCteMaterialization+ -> Q Postgres db CTE.QAnyScope res+ -> PgWith db placement (ReusableQ Postgres db res)+pgSelectingWith materialization q = do+ tblNm <- pgRegisterCte $ \name ->+ let (_ :: res, fields) = mkFieldNames @Postgres (qualifiedField name)+ body = fromPgSelect (buildSqlQuery (name <> "_") q)+ in case nonEmpty fields of+ Nothing -> pgCteSyntax name Nothing materialization body+ Just fields' -> pgOutputCteSyntax name fields' materialization body+ pure (CTE.reusableForCTE tblNm)+ -- | An explicit lock against some tables. You can create a value of this type using the 'locked_' -- function. You can combine these values monoidally to combine multiple locks for use with the -- 'withLocks_' function.@@ -219,6 +449,101 @@ tblSettings = dbTableSettings tbl +-- | Introduce a PostgreSQL @INSERT@ statement as a side-effect-only CTE.+--+-- The CTE has no @RETURNING@ clause and therefore produces no reusable+-- relation; PostgreSQL nevertheless executes it exactly once and to+-- completion when the surrounding top-level statement executes.+--+-- > pgSelectWithTopLevel $ do+-- > cteInsert users (insertValues [newUser]) onConflictDefault+-- > pure finalQuery+--+-- This produces SQL shaped like:+--+-- @+-- WITH cte0 AS (INSERT INTO users ...)+-- SELECT ...+-- @+--+-- Empty insert values register no CTE. The result is still conservatively+-- 'PgCteTopLevelOnly', because the placement index cannot vary with the+-- supplied values.+--+-- @since 0.6.3.0+cteInsert+ :: DatabaseEntity Postgres db (TableEntity table)+ -> SqlInsertValues Postgres (table (QExpr Postgres s))+ -> PgInsertOnConflict table+ -> PgWith db 'PgCteTopLevelOnly ()+cteInsert table values onConflict_ =+ case insert table values onConflict_ of+ SqlInsertNoRows -> pure ()+ SqlInsert _ (PgInsertSyntax syntax) -> pgDataModifyingCte_ syntax++-- | Introduce a PostgreSQL @INSERT ... RETURNING@ statement as a+-- data-modifying common table expression. The returned value can be used in a+-- subsequent query with 'reuse'.+--+-- Returns 'Nothing' when the supplied insert values are empty, because in that+-- case there is no statement or common table expression to reuse.+-- Data-modifying CTEs are restricted to top-level 'PgWith' blocks and cannot+-- be passed to 'pgSelectWithNested'.+--+-- For example, this inserts a row once and makes the rows produced by+-- @RETURNING@ available to the final query:+--+-- > pgSelectWithTopLevel $ do+-- > inserted <- cteInsertReturning+-- > users+-- > (insertValues [newUser])+-- > onConflictDefault+-- > id+-- > case inserted of+-- > Nothing -> pure noRowsQuery+-- > Just rows -> pure (reuse rows)+--+-- The generated statement has the shape:+--+-- @+-- WITH "cte0"("res0", ...) AS+-- (INSERT INTO "users" ... RETURNING ...)+-- SELECT ... FROM "cte0" AS "t0"+-- @+--+-- The projection may contain no fields. In that case Beam preserves one+-- degree-zero result row per inserted row. PostgreSQL requires at least one+-- @RETURNING@ expression, so the CTE contains a private boolean sentinel while+-- the final SELECT exposes no columns:+--+-- @+-- WITH "cte0"("res0") AS+-- (INSERT INTO "users" ... RETURNING NULL::boolean)+-- SELECT FROM "cte0" AS "t0"+-- @+--+-- The sentinel is not part of the returned Haskell value. If neither the final+-- statement nor another CTE needs the inserted-row output, prefer 'cteInsert'.+-- It omits @RETURNING@ and produces no reusable result.+--+-- @since 0.6.3.0+cteInsertReturning+ :: ( Projectible Postgres a+ , ThreadRewritable PostgresInaccessible a+ , Projectible Postgres (WithRewrittenThread PostgresInaccessible CTE.QAnyScope a)+ , ThreadRewritable CTE.QAnyScope (WithRewrittenThread PostgresInaccessible CTE.QAnyScope a)+ )+ => DatabaseEntity Postgres db (TableEntity table)+ -> SqlInsertValues Postgres (table (QExpr Postgres s))+ -> PgInsertOnConflict table+ -> (table (QExpr Postgres PostgresInaccessible) -> a)+ -> PgWith db 'PgCteTopLevelOnly (Maybe (ReusableQ Postgres db (WithRewrittenThread PostgresInaccessible CTE.QAnyScope a)))+cteInsertReturning table values onConflict_ mkProjection =+ case insertReturning table values onConflict_ (Just mkProjection) of+ PgInsertReturningEmpty -> pure Nothing+ PgInsertReturning syntax ->+ Just <$> pgDataModifyingCte syntax+ runPgInsertReturningList :: ( MonadBeam be m , BeamSqlBackendSyntax be ~ PgCommandSyntax@@ -277,9 +602,7 @@ (\_ -> Nothing) (rewriteThread (Proxy @s)))) --- | The SQL standard only allows CTE expressions (WITH expressions)--- at the top-level. Postgres allows you to embed these within a--- subquery.+-- | Embed a portable SELECT CTE block within a PostgreSQL subquery. -- -- For example, --@@ -287,20 +610,72 @@ -- 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.+-- @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. ----- The 'pgSelectWith' function is more flexible and indeed--- 'selectWith' for @beam-postgres@ is equivalent to se+-- > select $ pgSelectWith $ do+-- > reusableRows <- selecting someQuery+-- > pure (reuse reusableRows)+--+-- This can produce a subquery such as:+--+-- @+-- SELECT ... FROM (WITH cte0 AS (SELECT ...) SELECT ... FROM cte0) AS nested+-- @+-- pgSelectWith :: forall db s res . Projectible Postgres res => With Postgres db (Q Postgres db s res) -> Q Postgres db s res-pgSelectWith (CTE.With mkQ) =- let (q, (recursiveness, ctes)) = evalState (runWriterT mkQ) 0+pgSelectWith = pgSelectWith_++-- | Embed a nested-safe PostgreSQL-specific CTE block in a query.+--+-- This is the 'PgWith' counterpart of 'pgSelectWith'. It supports+-- 'pgSelectingWith', including explicit materialization, while its placement+-- index rejects data-modifying CTEs because PostgreSQL accepts those only in a+-- @WITH@ clause attached to the top-level statement.+--+-- > select $ pgSelectWithNested $ do+-- > rows <- pgSelectingWith PgCteMaterialized sourceQuery+-- > pure (reuse rows)+--+-- This produces a derived table containing the complete nested @WITH@ query:+--+-- @+-- SELECT "t0"."res0", "t0"."res1"+-- FROM (WITH "cte0"("res0", "res1") AS MATERIALIZED (SELECT ...)+-- SELECT "sub_t0"."res0", "sub_t0"."res1"+-- FROM "cte0" AS "sub_t0") AS "t0"("res0", "res1")+-- @+--+-- @since 0.6.3.0+pgSelectWithNested+ :: forall db s res+ . Projectible Postgres res+ => PgWith db 'PgCteNestedAllowed (Q Postgres db s res)+ -> Q Postgres db s res+pgSelectWithNested = pgSelectWith_ . unPgWith++-- Shared implementation for the compatible portable and PostgreSQL-specific+-- nested APIs. Keeping the syntax conversion here avoids evaluating or+-- traversing a PgWith block a second time.+pgSelectWith_+ :: forall db s res+ . Projectible Postgres res+ => With Postgres db (Q Postgres db s res)+ -> Q Postgres db s res+pgSelectWith_ (CTE.With mkQ) =+ let (q, (recursiveness, mctes)) = evalState (runWriterT mkQ) 0 fromSyntax tblPfx =- case recursiveness of- CTE.Nonrecursive -> withSyntax ctes (buildSqlQuery tblPfx q)- CTE.Recursive -> withRecursiveSyntax ctes (buildSqlQuery tblPfx q)+ case (recursiveness, nonEmpty mctes) of+ (CTE.Nonrecursive, Just ctes) -> withSyntax (NonEmpty.toList ctes) (buildSqlQuery tblPfx q)+ (CTE.Recursive, Just ctes) -> withRecursiveSyntax (NonEmpty.toList ctes) (buildSqlQuery tblPfx q)+ -- If there are no subqueries, we don't want to generate+ -- an empty 'WITH' statement, which would be malformed.+ -- + -- see: https://github.com/haskell-beam/beam/issues/760+ (_, Nothing) -> buildSqlQuery tblPfx q in Q (liftF (QAll (\tblPfx tName -> let (_, names) = mkFieldNames @Postgres @res (qualifiedField tName) in fromTable (PgTableSourceSyntax $@@ -309,9 +684,266 @@ (\tName -> let (projection, _) = mkFieldNames @Postgres @res (qualifiedField tName) in projection)- (\_ -> Nothing)+ (const Nothing) snd)) +-- | Attach a PostgreSQL-specific CTE block to a top-level @SELECT@ statement.+--+-- Unlike 'pgSelectWith', this consumes 'PgWith' and can therefore safely+-- accept data-modifying CTEs. SELECT-only blocks work as well, so callers can+-- use one terminal function while a workflow grows from portable SELECT CTEs+-- to PostgreSQL-specific operations.+--+-- > pgSelectWithTopLevel $ do+-- > selected <- pgSelecting sourceQuery+-- > deleted <- cteDeleteReturning target predicate id+-- > pure $ do+-- > source <- reuse selected+-- > removed <- reuse deleted+-- > pure (source, removed)+--+-- This produces one statement of the following form:+--+-- @+-- WITH "cte0"("res0", "res1") AS (SELECT ...),+-- "cte1"("res0", "res1") AS+-- (DELETE FROM "target" ... RETURNING "id", "value")+-- SELECT ... FROM "cte0" CROSS JOIN "cte1"+-- @+--+-- The complete @WITH ... SELECT ...@ is one 'SqlSelect' and is sent to+-- PostgreSQL in a single round trip.+--+-- @since 0.6.3.0+pgSelectWithTopLevel+ :: Projectible Postgres res+ => PgWith db placement (Q Postgres db QBaseScope res)+ -> SqlSelect Postgres (QExprToIdentity res)+pgSelectWithTopLevel = selectWith . unPgWith++-- | Attach a common-table-expression block to a top-level PostgreSQL+-- @INSERT@ statement.+--+-- Unlike 'pgSelectWithNested', this is a top-level statement consumer and+-- therefore accepts both 'PgCteNestedAllowed' and 'PgCteTopLevelOnly' blocks.+-- The final insert can read reusable rows produced by either SELECT CTEs or+-- data-modifying CTEs:+--+-- > pgInsertWith $ do+-- > rows <- pgSelecting sourceQuery+-- > pure $ insert destination (insertFrom (reuse rows)) onConflictDefault+--+-- This produces a statement with the following shape:+--+-- @+-- WITH "cte0"("res0", "res1") AS (SELECT ...)+-- INSERT INTO "destination"("id", "value")+-- SELECT "t0"."res0", "t0"."res1" FROM "cte0" AS "t0"+-- @+--+-- If the final insert has no rows, the result remains 'SqlInsertNoRows'. There+-- is then no terminal statement to which PostgreSQL could attach the @WITH@+-- block, so none of its CTE bodies are executed.+--+-- Apply 'returning' to the resulting 'SqlInsert' when the terminal statement+-- should return rows.+--+-- @since 0.6.3.0+pgInsertWith+ :: PgWith db placement (SqlInsert Postgres table)+ -> SqlInsert Postgres table+pgInsertWith with =+ case runPgWith with of+ (SqlInsertNoRows, _, _) -> SqlInsertNoRows+ (SqlInsert settings (PgInsertSyntax statement), recursiveness, ctes) ->+ SqlInsert settings (PgInsertSyntax (pgWithSyntax recursiveness ctes statement))++-- | Attach a common-table-expression block to a top-level PostgreSQL+-- @UPDATE@ statement.+--+-- Reusable CTE rows can be referenced from the final update predicate, for+-- example through 'exists_':+--+-- > pgUpdateWith $ do+-- > wanted <- pgSelecting wantedUsers+-- > pure $ update users+-- > (\user -> userEnabled user <-. val_ False)+-- > (\user -> exists_ $ do+-- > candidate <- reuse wanted+-- > guard_ (userId user ==. userId candidate))+--+-- This produces SQL of the following form:+--+-- @+-- WITH "cte0"("res0") AS (SELECT ... AS "res0")+-- UPDATE "users" SET "enabled"=FALSE+-- WHERE EXISTS+-- (SELECT "t0"."res0" FROM "cte0" AS "t0"+-- WHERE "id" = "t0"."res0")+-- @+--+-- An identity update remains 'SqlIdentityUpdate'; as with an empty insert,+-- there is no terminal PostgreSQL statement and the accumulated CTEs are not+-- executed.+--+-- Apply 'returning' to the resulting 'SqlUpdate' when the terminal statement+-- should return rows.+--+-- @since 0.6.3.0+pgUpdateWith+ :: PgWith db placement (SqlUpdate Postgres table)+ -> SqlUpdate Postgres table+pgUpdateWith with =+ case runPgWith with of+ (SqlIdentityUpdate, _, _) -> SqlIdentityUpdate+ (SqlUpdate settings (PgUpdateSyntax statement), recursiveness, ctes) ->+ SqlUpdate settings (PgUpdateSyntax (pgWithSyntax recursiveness ctes statement))++-- | Attach a common-table-expression block to a top-level PostgreSQL+-- @DELETE@ statement.+--+-- > pgDeleteWith $ do+-- > expired <- pgSelecting expiredUsers+-- > pure $ delete users $ \user -> exists_ $ do+-- > candidate <- reuse expired+-- > guard_ (userId user ==. userId candidate)+--+-- This produces SQL of the following form:+--+-- @+-- WITH "cte0"("res0") AS (SELECT ... AS "res0")+-- DELETE FROM "users" AS "delete_target"+-- WHERE EXISTS+-- (SELECT "t0"."res0" FROM "cte0" AS "t0"+-- WHERE "delete_target"."id" = "t0"."res0")+-- @+--+-- Since 'SqlDelete' always contains a statement, the accumulated CTE block is+-- always preserved.+-- Apply 'returning' to the result when the terminal statement should return+-- deleted rows.+--+-- @since 0.6.3.0+pgDeleteWith+ :: PgWith db placement (SqlDelete Postgres table)+ -> SqlDelete Postgres table+pgDeleteWith with =+ case runPgWith with of+ (SqlDelete settings (PgDeleteSyntax statement), recursiveness, ctes) ->+ SqlDelete settings (PgDeleteSyntax (pgWithSyntax recursiveness ctes statement))++-- Allocate a name and append one PostgreSQL CTE definition to beam-core's+-- existing writer. All PgWith constructors use this path so lifted and native+-- actions share one monotonically increasing name supply.+pgRegisterCte+ :: (Text -> PgCommonTableExpressionSyntax)+ -> PgWith db placement Text+pgRegisterCte mkCte = PgWith . CTE.With $ do+ cteId <- get+ put (cteId + 1)++ let tblNm = fromString ("cte" ++ show cteId)+ tell (CTE.Nonrecursive, [mkCte tblNm])+ pure tblNm++-- Construct a reusable CTE with a statically non-empty physical output. Keeping+-- the invariant in the type prevents callers from accidentally rendering the+-- invalid PostgreSQL spelling @name() AS (...)@.+pgOutputCteSyntax+ :: Text+ -> NonEmpty Text+ -> PgCteMaterialization+ -> PgSyntax+ -> PgCommonTableExpressionSyntax+pgOutputCteSyntax name fields materialization body =+ pgCteSyntax name (Just fields) materialization body++-- Render the common outer shape for SELECT, returning DML, and+-- side-effect-only DML CTEs. A missing column list is used for degree-zero+-- SELECT CTEs and for modifying statements without @RETURNING@. Materialization+-- is deliberately passed as PgCteDefault for every DML caller: PostgreSQL's+-- materialization controls apply to SELECT CTE folding, while modifying CTEs+-- always execute exactly once and to completion.+pgCteSyntax+ :: Text+ -> Maybe (NonEmpty Text)+ -> PgCteMaterialization+ -> PgSyntax+ -> PgCommonTableExpressionSyntax+pgCteSyntax name fields materialization body =+ PgCommonTableExpressionSyntax $+ pgQuotedIdentifier name <>+ maybe mempty+ (pgParens . pgSepBy (emit ",") . map pgQuotedIdentifier . NonEmpty.toList)+ fields <>+ emit " AS" <>+ materializationSyntax materialization <>+ emit " " <>+ pgParens body+ where+ materializationSyntax PgCteDefault = mempty+ materializationSyntax PgCteMaterialized = emit " MATERIALIZED"+ materializationSyntax PgCteNotMaterialized = emit " NOT MATERIALIZED"++-- Register a modifying CTE with @RETURNING@ output and construct the reusable+-- relation which refers to its generated name.+--+-- PostgreSQL requires @RETURNING@ to contain at least one expression. The+-- existing INSERT, UPDATE, and DELETE returning renderers end in the keyword+-- and a space when Beam's logical projection has no fields. In that case this+-- CTE-specific path appends one private, constant boolean expression and gives+-- it the physical name @res0@. 'CTE.reusableForCTE' is still instantiated at+-- the original zero-field result type, so final Beam SELECTs project no+-- physical columns and the sentinel is never exposed to result decoding.+--+-- One sentinel row is produced for every affected row. Consequently the+-- degree-zero relation preserves the modifying statement's cardinality when it+-- is reused by joins, @EXISTS@, or aggregates.+pgDataModifyingCte+ :: forall res db+ . ( Projectible Postgres res+ , ThreadRewritable CTE.QAnyScope res )+ => PgSyntax+ -> PgWith db 'PgCteTopLevelOnly (ReusableQ Postgres db res)+pgDataModifyingCte body = do+ tblNm <- pgRegisterCte $ \name ->+ let (_ :: res, fields) = mkFieldNames @Postgres (qualifiedField name)+ in case nonEmpty fields of+ Nothing ->+ pgOutputCteSyntax+ name+ ("res0" :| [])+ PgCteDefault+ (body <> emit "NULL::boolean")+ Just fields' -> pgOutputCteSyntax name fields' PgCteDefault body+ pure (CTE.reusableForCTE tblNm)++-- Register a modifying CTE without @RETURNING@. PostgreSQL executes the body,+-- but the CTE forms no temporary table and therefore has no result which can be+-- passed to 'reuse'. This accounts for both the unit result and the absence of+-- a column-alias list.+pgDataModifyingCte_+ :: PgSyntax+ -> PgWith db 'PgCteTopLevelOnly ()+pgDataModifyingCte_ body = do+ _ <- pgRegisterCte $ \name ->+ pgCteSyntax name Nothing PgCteDefault body+ pure ()++-- Evaluate a PostgreSQL CTE builder once and retain the information required+-- by each top-level statement consumer. Keeping this helper local ensures that+-- the backend-independent CTE API does not acquire PostgreSQL command types.+runPgWith+ :: PgWith db placement a+ -> (a, PgCteRecursiveness, [BeamSql99BackendCTESyntax Postgres])+runPgWith (PgWith with) =+ let (result, (recursiveness, ctes)) =+ evalState (runWriterT (CTE.runWith with)) 0+ pgRecursiveness = case recursiveness of+ CTE.Nonrecursive -> PgCteNonrecursive+ CTE.Recursive -> PgCteRecursive+ in (result, pgRecursiveness, ctes)+ -- | By default, Postgres will throw an error when a conflict is detected. This -- preserves that functionality. onConflictDefault :: PgInsertOnConflict tbl@@ -384,6 +1016,93 @@ where tblQ = changeBeamRep (\(Columnar' f) -> Columnar' (QExpr (pure (fieldE (unqualifiedField (_fieldName f)))))) tblSettings +-- | Introduce a PostgreSQL @UPDATE@ statement as a side-effect-only CTE.+--+-- Since no @RETURNING@ clause is emitted, the result is @()@ and cannot be+-- passed to 'reuse'. PostgreSQL still executes the update exactly once when+-- the surrounding top-level statement executes:+--+-- > pgDeleteWith $ do+-- > cteUpdate users+-- > (\user -> userActive user <-. val_ False)+-- > (\user -> userLastSeen user <. val_ cutoff)+-- > pure (delete sessions expiredSession)+--+-- This produces one side-effect-only definition before the terminal delete:+--+-- @+-- WITH "cte0" AS+-- (UPDATE "users" SET "active"=FALSE WHERE "last_seen" < ...)+-- DELETE FROM "sessions" AS "delete_target" WHERE ...+-- @+--+-- An identity assignment registers no CTE. As with 'cteInsert', its type+-- remains 'PgCteTopLevelOnly' independently of that value-level result.+--+-- @since 0.6.3.0+cteUpdate+ :: DatabaseEntity Postgres db (TableEntity table)+ -> (forall s. table (QField s) -> QAssignment Postgres s)+ -> (forall s. table (QExpr Postgres s) -> QExpr Postgres s Bool)+ -> PgWith db 'PgCteTopLevelOnly ()+cteUpdate table@(DatabaseEntity (DatabaseTable {})) mkAssignments mkWhere =+ case update table mkAssignments mkWhere of+ SqlIdentityUpdate -> pure ()+ SqlUpdate _ (PgUpdateSyntax syntax) -> pgDataModifyingCte_ syntax++-- | Introduce a PostgreSQL @UPDATE ... RETURNING@ statement as a+-- data-modifying common table expression. The returned value can be used in a+-- subsequent query with 'reuse'.+--+-- Returns 'Nothing' when the assignments form an identity update, because in+-- that case there is no statement or common table expression to reuse.+-- Data-modifying CTEs are restricted to top-level 'PgWith' blocks and cannot+-- be used with 'pgSelectWithNested'.+--+-- > pgSelectWithTopLevel $ do+-- > updated <- cteUpdateReturning+-- > users+-- > (\user -> userEnabled user <-. val_ False)+-- > (\user -> userId user ==. val_ wantedUserId)+-- > id+-- > case updated of+-- > Nothing -> pure noRowsQuery+-- > Just rows -> pure (reuse rows)+--+-- This renders the update once inside @WITH@ and reads its @RETURNING@ rows+-- through the reusable CTE name:+--+-- @+-- WITH "cte0"("res0", "res1") AS+-- (UPDATE "users" SET "enabled"=FALSE+-- WHERE "id" = ... RETURNING "id", "enabled")+-- SELECT "t0"."res0", "t0"."res1" FROM "cte0" AS "t0"+-- @+--+-- As with 'cteInsertReturning', a projection containing no fields is supported.+-- Beam emits @RETURNING NULL::boolean@ inside the CTE and @SELECT FROM "cte0"@+-- outside it, retaining one zero-field row per updated row without exposing the+-- private sentinel. If neither the final statement nor another CTE needs the+-- updated-row output, use 'cteUpdate' instead.+--+-- @since 0.6.3.0+cteUpdateReturning+ :: ( Projectible Postgres a+ , ThreadRewritable PostgresInaccessible a+ , Projectible Postgres (WithRewrittenThread PostgresInaccessible CTE.QAnyScope a)+ , ThreadRewritable CTE.QAnyScope (WithRewrittenThread PostgresInaccessible CTE.QAnyScope a)+ )+ => DatabaseEntity Postgres db (TableEntity table)+ -> (forall s. table (QField s) -> QAssignment Postgres s)+ -> (forall s. table (QExpr Postgres s) -> QExpr Postgres s Bool)+ -> (table (QExpr Postgres PostgresInaccessible) -> a)+ -> PgWith db 'PgCteTopLevelOnly (Maybe (ReusableQ Postgres db (WithRewrittenThread PostgresInaccessible CTE.QAnyScope a)))+cteUpdateReturning table mkAssignments mkWhere mkProjection =+ case updateReturning table mkAssignments mkWhere mkProjection of+ PgUpdateReturningEmpty -> pure Nothing+ PgUpdateReturning syntax ->+ Just <$> pgDataModifyingCte syntax+ runPgUpdateReturningList :: ( MonadBeam be m , BeamSqlBackendSyntax be ~ PgCommandSyntax@@ -424,6 +1143,88 @@ where SqlDelete _ pgDelete = delete table $ \t -> mkWhere t tblQ = changeBeamRep (\(Columnar' f) -> Columnar' (QExpr (pure (fieldE (unqualifiedField (_fieldName f)))))) tblSettings++-- | Introduce a PostgreSQL @DELETE@ statement as a side-effect-only CTE.+--+-- The deletion executes exactly once even when the terminal statement does not+-- refer to it. Without @RETURNING@ it produces no reusable relation:+--+-- > pgInsertWith $ do+-- > cteDelete stagingRows isExpired+-- > pure (insert archive newRows onConflictDefault)+--+-- This renders a definition without an empty column list, followed by the+-- terminal insert:+--+-- @+-- WITH "cte0" AS+-- (DELETE FROM "staging_rows" AS "delete_target" WHERE ...)+-- INSERT INTO "archive" ...+-- @+--+-- Sibling modifying CTEs use the same PostgreSQL snapshot and cannot observe+-- one another's table changes. Use their @RETURNING@ output when one operation+-- needs to communicate rows to another.+--+-- @since 0.6.3.0+cteDelete+ :: DatabaseEntity Postgres db (TableEntity table)+ -> (forall s. table (QExpr Postgres s) -> QExpr Postgres s Bool)+ -> PgWith db 'PgCteTopLevelOnly ()+cteDelete table mkWhere =+ case delete table (\row -> mkWhere row) of+ SqlDelete _ (PgDeleteSyntax syntax) -> pgDataModifyingCte_ syntax++-- | Introduce a PostgreSQL @DELETE ... RETURNING@ statement as a+-- data-modifying common table expression. The returned value can be used in a+-- subsequent query with 'reuse'.+--+-- Data-modifying CTEs are restricted to top-level 'PgWith' blocks and cannot+-- be used with 'pgSelectWithNested'.+--+-- Unlike insert and update, delete always has a statement to introduce, so no+-- 'Maybe' is required:+--+-- > pgSelectWithTopLevel $ do+-- > deleted <- cteDeleteReturning+-- > users+-- > (\user -> userExpired user ==. val_ True)+-- > id+-- > pure (reuse deleted)+--+-- The corresponding SQL has the following form:+--+-- @+-- WITH "cte0"("res0", "res1") AS+-- (DELETE FROM "users" AS "delete_target"+-- WHERE "delete_target"."expired" = TRUE+-- RETURNING "id", "expired")+-- SELECT "t0"."res0", "t0"."res1" FROM "cte0" AS "t0"+-- @+--+-- The final query observes the deleted rows through @DELETE ... RETURNING@.+-- This is also the supported way to communicate between data-modifying CTEs,+-- since PostgreSQL executes sibling statements against the same snapshot.+-- A projection containing no fields is also reusable: Beam emits a private+-- @NULL::boolean@ returning expression and an outer zero-column SELECT, so its+-- row count still equals the number of deleted rows. If neither the final+-- statement nor another CTE needs the deleted-row output, use 'cteDelete'+-- instead.+--+-- @since 0.6.3.0+cteDeleteReturning+ :: ( Projectible Postgres a+ , ThreadRewritable PostgresInaccessible a+ , Projectible Postgres (WithRewrittenThread PostgresInaccessible CTE.QAnyScope a)+ , ThreadRewritable CTE.QAnyScope (WithRewrittenThread PostgresInaccessible CTE.QAnyScope a)+ )+ => DatabaseEntity Postgres db (TableEntity table)+ -> (forall s. table (QExpr Postgres s) -> QExpr Postgres s Bool)+ -> (table (QExpr Postgres PostgresInaccessible) -> a)+ -> PgWith db 'PgCteTopLevelOnly (ReusableQ Postgres db (WithRewrittenThread PostgresInaccessible CTE.QAnyScope a))+cteDeleteReturning table mkWhere mkProjection =+ let PgDeleteReturning syntax = deleteReturning table mkWhere mkProjection+ in pgDataModifyingCte syntax runPgDeleteReturningList :: ( MonadBeam be m
Database/Beam/Postgres/Migrate.hs view
@@ -60,7 +60,7 @@ import Control.Exception.Lifted (mask, onException) import Control.Monad -import Data.Aeson hiding (json)+import Data.Aeson import Data.Bits import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy as BL@@ -598,5 +598,11 @@ field' _ _ nm ty _ collation constraints PgHasDefault = Db.field' (Proxy @'True) (Proxy @'False) nm ty Nothing collation constraints -instance BeamSqlBackendHasSerial Postgres where+instance BeamSqlBackendHasSerial Int16 Postgres where+ genericSerial nm = Db.field nm smallserial PgHasDefault++instance BeamSqlBackendHasSerial Int32 Postgres where genericSerial nm = Db.field nm serial PgHasDefault++instance BeamSqlBackendHasSerial Int64 Postgres where+ genericSerial nm = Db.field nm bigserial PgHasDefault
Database/Beam/Postgres/PgCrypto.hs view
@@ -9,8 +9,7 @@ import Database.Beam import Database.Beam.Backend.SQL -import Database.Beam.Postgres.Extensions-import Database.Beam.Postgres.Extensions.Internal+import Database.Beam.Postgres.Extensions( LiftPg, PgExpr, IsPgExtension(..), funcE ) import Data.Int import Data.Text (Text)
Database/Beam/Postgres/PgSpecific.hs view
@@ -9,7 +9,6 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE PolyKinds #-}-{-# LANGUAGE CPP #-} -- | Postgres-specific types, functions, and operators module Database.Beam.Postgres.PgSpecific@@ -111,7 +110,7 @@ -- * Postgres @EXTRACT@ fields , century_, decade_, dow_, doy_, epoch_, isodow_, isoyear_- , microseconds_, milliseconds_, millennium_, quarter_, week_+ , microseconds_, milliseconds_, millennium_, quarter_ -- ** Postgres functions and aggregates , pgBoolOr, pgBoolAnd, pgStringAgg, pgStringAggOver@@ -1674,9 +1673,6 @@ quarter_ :: HasSqlDate tgt => ExtractField Postgres tgt Int32 quarter_ = ExtractField (PgExtractFieldSyntax (emit "QUARTER"))--week_ :: HasSqlDate tgt => ExtractField Postgres tgt Int32-week_ = ExtractField (PgExtractFieldSyntax (emit "WEEK")) -- $full-text-search --
Database/Beam/Postgres/Syntax.hs view
@@ -21,8 +21,8 @@ , emit, emitBuilder, escapeString , escapeBytea, escapeIdentifier- , pgParens-+ , pgParens, PgCteRecursiveness(..), pgWithSyntax+ , pgStringLit, pgCharLit, pgBoolLit , nextSyntaxStep , PgCommandSyntax(..), PgCommandType(..)@@ -30,6 +30,7 @@ , PgInsertSyntax(..) , PgDeleteSyntax(..) , PgUpdateSyntax(..)+ , PgCommonTableExpressionSyntax(..) , PgExpressionSyntax(..), PgFromSyntax(..), PgTableNameSyntax(..) , PgComparisonQuantifierSyntax(..)@@ -131,6 +132,8 @@ import qualified Database.PostgreSQL.Simple.Types as Pg (Oid(..), Binary(..), Null(..)) import qualified Database.PostgreSQL.Simple.Time as Pg (Date, LocalTimestamp, UTCTimestamp) import qualified Database.PostgreSQL.Simple.HStore as Pg (HStoreList, HStoreMap, HStoreBuilder)+import Data.Text (Text)+import qualified Data.ByteString.Char8 as BS8 data PostgresInaccessible @@ -270,9 +273,54 @@ data PgSelectLockingClauseSyntax = PgSelectLockingClauseSyntax { pgSelectLockingClauseStrength :: PgSelectLockingStrength , pgSelectLockingTables :: [T.Text] , pgSelectLockingClauseOptions :: Maybe PgSelectLockingOptions }+-- | One named definition in a PostgreSQL @WITH@ clause.+--+-- This is exported for PostgreSQL extension modules. Application code should+-- normally construct CTEs through "Database.Beam.Postgres.Full".+--+-- @since 0.6.3.0 newtype PgCommonTableExpressionSyntax = PgCommonTableExpressionSyntax { fromPgCommonTableExpression :: PgSyntax } +-- | Whether a PostgreSQL @WITH@ clause is recursive.+--+-- Keeping this distinction explicit avoids assigning a context-dependent+-- meaning to a 'Bool' at the low-level syntax boundary.+--+-- @since 0.6.3.0+data PgCteRecursiveness+ = PgCteNonrecursive+ -- ^ Emit @WITH@.+ | PgCteRecursive+ -- ^ Emit @WITH RECURSIVE@.+ deriving (Eq, Show)++-- | Prefix a PostgreSQL statement with a common-table-expression list.+-- The public CTE consumers use this prefix before their @SELECT@, @INSERT@,+-- @UPDATE@, and @DELETE@ terminal statements, so this operation works on the+-- shared raw syntax instead of giving the terminal statement a misleading+-- type.+--+-- An empty list leaves the statement unchanged. 'PgCteRecursive' selects+-- @WITH RECURSIVE@ when the CTE builder used recursive bindings.+--+-- @since 0.6.3.0+pgWithSyntax+ :: PgCteRecursiveness+ -> [PgCommonTableExpressionSyntax]+ -> PgSyntax+ -> PgSyntax+pgWithSyntax _ [] statement = statement+pgWithSyntax recursiveness ctes statement =+ emit withKeyword <>+ pgSepBy (emit ", ") (map fromPgCommonTableExpression ctes) <>+ emit " " <>+ statement+ where+ withKeyword = case recursiveness of+ PgCteNonrecursive -> "WITH "+ PgCteRecursive -> "WITH RECURSIVE "+ fromPgOrdering :: PgOrderingSyntax -> PgSyntax fromPgOrdering (PgOrderingSyntax s Nothing) = s fromPgOrdering (PgOrderingSyntax s (Just PgNullOrderingNullsFirst)) = s <> emit " NULLS FIRST"@@ -620,25 +668,27 @@ type Sql99SelectCTESyntax PgSelectSyntax = PgCommonTableExpressionSyntax withSyntax ctes (PgSelectSyntax select) =- PgSelectSyntax $- emit "WITH " <>- pgSepBy (emit ", ") (map fromPgCommonTableExpression ctes) <>- select+ PgSelectSyntax (pgWithSyntax PgCteNonrecursive ctes select) instance IsSql99RecursiveCommonTableExpressionSelectSyntax PgSelectSyntax where withRecursiveSyntax ctes (PgSelectSyntax select) =- PgSelectSyntax $- emit "WITH RECURSIVE " <>- pgSepBy (emit ", ") (map fromPgCommonTableExpression ctes) <>- select+ PgSelectSyntax (pgWithSyntax PgCteRecursive ctes select) instance IsSql99CommonTableExpressionSyntax PgCommonTableExpressionSyntax where type Sql99CTESelectSyntax PgCommonTableExpressionSyntax = PgSelectSyntax cteSubquerySyntax tbl fields (PgSelectSyntax select) = PgCommonTableExpressionSyntax $- pgQuotedIdentifier tbl <> pgParens (pgSepBy (emit ",") (map pgQuotedIdentifier fields)) <>+ pgQuotedIdentifier tbl <> columnAliases <> emit " AS " <> pgParens select+ where+ -- PostgreSQL represents a degree-zero CTE by omitting its optional+ -- column-alias list. Rendering an empty pair of parentheses instead+ -- would be a syntax error.+ columnAliases =+ case fields of+ [] -> mempty+ _ -> pgParens (pgSepBy (emit ",") (map pgQuotedIdentifier fields)) instance IsSql2008BigIntDataTypeSyntax PgDataTypeSyntax where bigIntType = PgDataTypeSyntax (PgDataTypeDescrOid (Pg.typoid Pg.int8) Nothing) (emit "BIGINT") bigIntType@@ -798,6 +848,7 @@ minutesField = PgExtractFieldSyntax (emit "MINUTE") hourField = PgExtractFieldSyntax (emit "HOUR") dayField = PgExtractFieldSyntax (emit "DAY")+ weekField = PgExtractFieldSyntax (emit "WEEK") monthField = PgExtractFieldSyntax (emit "MONTH") yearField = PgExtractFieldSyntax (emit "YEAR") @@ -1389,6 +1440,27 @@ pgParens :: PgSyntax -> PgSyntax pgParens a = emit "(" <> a <> emit ")" +-- | Render a 'Text' as a single-quoted SQL string literal, with proper+-- Postgres escaping. The surrounding quotes are added here; 'escapeString'+-- only handles the escaping of the contents.+--+-- @since 0.6.1.0+pgStringLit :: Text -> PgSyntax+pgStringLit t = emit "'" <> escapeString (TE.encodeUtf8 t) <> emit "'"++-- | Render a 'Char' as a single-quoted SQL string literal.+--+-- @since 0.6.1.0+pgCharLit :: Char -> PgSyntax+pgCharLit c = emit "'" <> escapeString (BS8.singleton c) <> emit "'"++-- | Render a boolean as the literal @TRUE@ or @FALSE@.+--+-- @since 0.6.1.0+pgBoolLit :: Bool -> PgSyntax+pgBoolLit True = emit "TRUE"+pgBoolLit False = emit "FALSE"+ pgTableOp :: ByteString -> PgSelectTableSyntax -> PgSelectTableSyntax -> PgSelectTableSyntax pgTableOp op tbl1 tbl2 =@@ -1563,4 +1635,3 @@ where quoteIdentifierChar '"' = char8 '"' <> char8 '"' quoteIdentifierChar c = char8 c-
Database/Beam/Postgres/Types.hs view
@@ -1,5 +1,5 @@ {-# OPTIONS_GHC -fno-warn-orphans #-}-+{-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}@@ -18,8 +18,18 @@ import Database.Beam import Database.Beam.Backend import Database.Beam.Backend.Internal.Compat+import Database.Beam.Backend.SQL.BeamExtensions+ ( BeamSqlBackendCopyFromStreamSyntax+ , BeamSqlBackendCopyFromSyntax+ , BeamSqlBackendCopyToStreamSyntax+ , BeamSqlBackendCopyToSyntax+ ) import Database.Beam.Migrate.Generics import Database.Beam.Migrate.SQL (BeamMigrateOnlySqlBackend)+import Database.Beam.Postgres.Extensions.Copy.File+ ( PgCopyFromSyntax, PgCopyToSyntax )+import Database.Beam.Postgres.Extensions.Copy.Stream+ ( PgCopyFromStreamSyntax, PgCopyToStreamSyntax ) import Database.Beam.Postgres.Syntax import Database.Beam.Query.SQL92 @@ -166,8 +176,20 @@ instance BeamMigrateOnlySqlBackend Postgres type instance BeamSqlBackendSyntax Postgres = PgCommandSyntax +type instance BeamSqlBackendCopyToSyntax Postgres = PgCopyToSyntax+type instance BeamSqlBackendCopyFromSyntax Postgres = PgCopyFromSyntax++type instance BeamSqlBackendCopyToStreamSyntax Postgres = PgCopyToStreamSyntax+type instance BeamSqlBackendCopyFromStreamSyntax Postgres = PgCopyFromStreamSyntax+ instance BeamSqlBackendIsString Postgres String instance BeamSqlBackendIsString Postgres Text++-- | @since 0.6.2.0+instance BeamSqlBackendIsString Postgres (CI String)++-- | @since 0.6.2.0+instance BeamSqlBackendIsString Postgres (CI Text) instance HasQBuilder Postgres where buildSqlQuery = buildSql92Query' True
beam-postgres.cabal view
@@ -1,5 +1,5 @@ name: beam-postgres-version: 0.5.6.1+version: 0.6.3.0 synopsis: Connection layer between beam and postgres description: Beam driver for <https://www.postgresql.org/ PostgreSQL>, an advanced open-source RDBMS homepage: https://haskell-beam.github.io/beam/user-guide/backends/beam-postgres@@ -23,20 +23,21 @@ Database.Beam.Postgres.Full Database.Beam.Postgres.PgCrypto+ Database.Beam.Postgres.Extensions Database.Beam.Postgres.Extensions.UuidOssp Database.Beam.Postgres.TempTable other-modules: Database.Beam.Postgres.Connection Database.Beam.Postgres.Debug- Database.Beam.Postgres.Extensions- Database.Beam.Postgres.Extensions.Internal+ Database.Beam.Postgres.Extensions.Copy.File+ Database.Beam.Postgres.Extensions.Copy.Stream Database.Beam.Postgres.PgSpecific Database.Beam.Postgres.Types build-depends: base >=4.11 && <5.0,- beam-core >=0.10 && <0.11,- beam-migrate >=0.5.4.0 && <0.6,+ beam-core >=0.11.1 && <0.12,+ beam-migrate >=0.6 && <0.7, postgresql-libpq >=0.8 && <0.12, postgresql-simple >=0.5 && <0.8,@@ -48,11 +49,11 @@ hashable >=1.1 && <1.6, lifted-base >=0.2 && <0.3, free >=4.12 && <5.3,- time >=1.6 && <1.15,+ time >=1.6 && <1.17, monad-control >=1.0 && <1.1, mtl >=2.1 && <2.4, conduit >=1.2 && <1.4,- aeson >=0.11 && <2.3,+ aeson >=0.11 && <2.4, uuid-types >=1.0 && <1.1, case-insensitive >=1.2 && <1.3, scientific >=0.3 && <0.4,@@ -65,7 +66,7 @@ default-language: Haskell2010 default-extensions: ScopedTypeVariables, OverloadedStrings, MultiParamTypeClasses, RankNTypes, FlexibleInstances, DeriveDataTypeable, DeriveGeneric, StandaloneDeriving, TypeFamilies, GADTs, OverloadedStrings,- CPP, TypeApplications, FlexibleContexts+ TypeApplications, FlexibleContexts ghc-options: -Wall -Widentities -Wincomplete-uni-patterns@@ -80,11 +81,16 @@ 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,+ Database.Beam.Postgres.Test.Select.PgNubBy, Database.Beam.Postgres.Test.DataTypes, Database.Beam.Postgres.Test.Migrate,- Database.Beam.Postgres.Test.TempTable+ Database.Beam.Postgres.Test.TempTable,+ Database.Beam.Postgres.Test.Windowing build-depends: aeson, base,@@ -92,12 +98,13 @@ beam-migrate, beam-postgres, bytestring,- hedgehog,+ hedgehog >= 1.0, postgresql-simple, tasty-hunit, tasty, text, testcontainers,+ time, uuid, vector default-language: Haskell2010
test/Database/Beam/Postgres/Test.hs view
@@ -1,10 +1,5 @@-{-# LANGUAGE CPP #-} module Database.Beam.Postgres.Test where -#if MIN_VERSION_base(4,12,0)-import Prelude hiding (fail)-#endif- import qualified Database.PostgreSQL.Simple as Pg import Control.Exception (bracket)@@ -14,35 +9,26 @@ import Data.ByteString (ByteString) import Data.String -#if MIN_VERSION_base(4,12,0)-#if !MIN_VERSION_hedgehog(1,0,0)-import Control.Monad.Fail (MonadFail(..))-import qualified Hedgehog--- TODO orphan instances are bad--- Would be easier to say 'build-depends: hedgehog >= 1.0',--- but it's difficult to propagate to older Stackage snapshots-instance Monad m => MonadFail (Hedgehog.PropertyT m) where- fail _ = Hedgehog.failure-#endif-#endif- withTestPostgres :: String -> IO ByteString -> (Pg.Connection -> IO a) -> IO a withTestPostgres dbName getConnStr action = do connStr <- getConnStr - let connStrTemplate1 = connStr <> " dbname=template1"+ -- Create and drop isolated test databases from the administrative postgres+ -- database, leaving template1 free to serve as CREATE DATABASE's default+ -- template.+ let connStrAdmin = connStr <> " dbname=postgres" connStrDb = connStr <> " dbname=" <> fromString dbName - withTemplate1 :: (Pg.Connection -> IO b) -> IO b- withTemplate1 = bracket (Pg.connectPostgreSQL connStrTemplate1) Pg.close+ withAdmin :: (Pg.Connection -> IO b) -> IO b+ withAdmin = bracket (Pg.connectPostgreSQL connStrAdmin) Pg.close - createDatabase = withTemplate1 $ \c -> do+ createDatabase = withAdmin $ \c -> do void $ Pg.execute_ c (fromString ("CREATE DATABASE " <> dbName)) Pg.connectPostgreSQL connStrDb dropDatabase c = do Pg.close c- withTemplate1 $ \c' -> void $+ withAdmin $ \c' -> void $ Pg.execute_ c' (fromString ("DROP DATABASE " <> dbName)) bracket createDatabase dropDatabase action
+ test/Database/Beam/Postgres/Test/CTE.hs view
@@ -0,0 +1,1334 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE RecursiveDo #-}+{-# LANGUAGE StandaloneDeriving #-}++-- | Rendering, type-safety, and PostgreSQL integration tests for common table+-- expressions. Deliberately ill-typed expressions live in+-- "Database.Beam.Postgres.Test.CTENegative" so this module retains normal type+-- checking.+module Database.Beam.Postgres.Test.CTE (unitTests, integrationTests) where++import Control.Exception (TypeError, evaluate, try)+import qualified Data.ByteString.Lazy.Char8 as BL+import Data.ByteString (ByteString)+import Data.Int (Int32)+import Data.Kind (Type)+import Data.List (isInfixOf, isPrefixOf, sortOn)+import Data.Text (Text)++import Database.Beam+import Database.Beam.Postgres+import qualified Database.Beam.Postgres.Full as Pg+import qualified Database.Beam.Query.CTE as CTE+import Database.Beam.Postgres.Syntax+ ( PgDeleteSyntax(..)+ , PgInsertSyntax(..)+ , PgSelectSyntax(..)+ , PgUpdateSyntax(..)+ , PostgresInaccessible+ , pgRenderSyntaxScript+ )+import Database.PostgreSQL.Simple (execute_)++import qualified Hedgehog+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range+import Test.Tasty+import Test.Tasty.HUnit++import Database.Beam.Postgres.Test+import qualified Database.Beam.Postgres.Test.CTENegative as Negative++data CteRowT f = CteRow+ { cteId :: C f Int32+ , cteValue :: C f Text+ } deriving (Generic, Beamable)++deriving instance Show (CteRowT Identity)+deriving instance Eq (CteRowT Identity)++-- A legal Haskell projection shape with no fields. PostgreSQL represents this+-- degree-zero relation by omitting the CTE column-alias list. Data-modifying+-- CTEs with RETURNING use a private physical sentinel to satisfy PostgreSQL's+-- grammar while retaining this zero-field shape at Beam's public boundary.+data EmptyCteT (f :: Type -> Type) = EmptyCte+ deriving (Generic, Beamable)++deriving instance Show (EmptyCteT Identity)+deriving instance Eq (EmptyCteT Identity)++instance Table CteRowT where+ data PrimaryKey CteRowT f = CteRowKey (C f Int32)+ deriving (Generic, Beamable)+ primaryKey = CteRowKey . cteId++newtype CteDb entity = CteDb+ { dbCteRows :: entity (TableEntity CteRowT)+ } deriving (Generic, Database Postgres)++cteDb :: DatabaseSettings Postgres CteDb+cteDb = defaultDbSettings++unitTests :: TestTree+unitTests = testGroup "Common table expression tests"+ [ renderingTests+ , typeSafetyTests+ ]++integrationTests :: IO ByteString -> TestTree+integrationTests getConn = testGroup "Common table expression integration tests"+ [ testMixedCteBodies getConn+ , testSideEffectOnlyCtes getConn+ , testMaterializationExecution getConn+ , testLiftedWithExecution getConn+ , testWithDmlConsumers getConn+ , testCteParameterOrdering getConn+ , testDataModifyingCteModel getConn+ , testSideEffectOnlyCteModel getConn+ , testWithDmlConsumerModel getConn+ , testRecursiveCteModel getConn+ , testDegreeZeroSelects getConn+ , testDegreeZeroDataModifyingCtes getConn+ , testDegreeZeroRepeatedReuse getConn+ ]++renderingTests :: TestTree+renderingTests = testGroup "Common table expression rendering tests"+ [ testMixedCteRendering+ , testMaterializationRendering+ , testNestedMaterializedCteRendering+ , testSideEffectOnlyRendering+ , testSideEffectNoOps+ , testLiftedWithNameSupply+ , testNestedSelectCteRendering+ , testRecursiveSelectThenDeleteRendering+ , testEmptyDataModifyingCtes+ , testWithDmlConsumerRendering+ , testRecursiveInsertWithRendering+ , testTopLevelOnlyDmlConsumerRendering+ , testEmptyDmlConsumers+ , testReturningAfterDmlConsumers+ , testDegreeZeroSelectRendering+ , testDegreeZeroDataModifyingRendering+ ]++-- These tests force expressions compiled with deferred type errors in the+-- isolated negative-fixture module. Checking fragments of GHC's error ensures+-- an unrelated deferred error cannot make a test pass accidentally.+typeSafetyTests :: TestTree+typeSafetyTests = testGroup "Common table expression type-safety tests"+ [ testCase "rejects a DELETE CTE inside pgSelectWith" $+ assertPlacementTypeError Negative.invalidNestedDelete+ , testCase "rejects an INSERT CTE inside pgSelectWith" $+ assertPlacementTypeError Negative.invalidNestedInsert+ , testCase "rejects an UPDATE CTE inside pgSelectWith" $+ assertPlacementTypeError Negative.invalidNestedUpdate+ , testCase "rejects SELECT followed by DELETE inside pgSelectWith" $+ assertPlacementTypeError Negative.invalidNestedSelectThenDelete+ , testCase "rejects DELETE followed by SELECT inside pgSelectWith" $+ assertPlacementTypeError Negative.invalidNestedDeleteThenSelect+ , testCase "conservatively rejects an empty INSERT inside pgSelectWith" $+ assertPlacementTypeError Negative.invalidNestedEmptyInsert+ , testCase "conservatively rejects an identity UPDATE inside pgSelectWith" $+ assertPlacementTypeError Negative.invalidNestedIdentityUpdate+ , testCase "rejects a side-effect-only DELETE inside pgSelectWithNested" $+ assertPlacementTypeError Negative.invalidNestedSideEffectDelete+ , testCase "placement cannot be bypassed with coerce" $+ assertPlacementTypeError Negative.invalidCoercedPlacement+ , testCase "rejects a recursively self-referencing INSERT CTE" $+ assertDeferredTypeErrorContaining+ ["No instance", "MonadFix", "PgCteTopLevelOnly"]+ Negative.invalidRecursiveInsert+ , testCase "side-effect-only CTE results cannot be reused" $+ assertDeferredTypeErrorContaining+ ["ReusableQ"]+ Negative.invalidReuseSideEffect+ ]++assertPlacementTypeError :: SqlSelect Postgres a -> Assertion+assertPlacementTypeError =+ assertDeferredTypeErrorContaining ["PgCteTopLevelOnly", "PgCteNestedAllowed"]++assertDeferredTypeErrorContaining+ :: [String]+ -> SqlSelect Postgres a+ -> Assertion+assertDeferredTypeErrorContaining expectedFragments sql = do+ result <- try (evaluate (BL.length (renderSelectBytes sql)))+ case result of+ Left (err :: TypeError) ->+ let message = show err+ in mapM_ (assertFragment message) expectedFragments+ Right _ ->+ assertFailure "expected the expression to contain a deferred type error"+ where+ assertFragment message fragment =+ assertBool+ ("mentions " ++ fragment ++ "\nDeferred error was:\n" ++ message)+ (fragment `isInfixOf` message)++-- A single top-level WITH block may freely mix SELECT and data-modifying CTE+-- bodies. Besides checking the individual keywords, this guards against+-- accidentally nesting a second WITH while combining the syntax fragments.+testMixedCteRendering :: TestTree+testMixedCteRendering = testCase "renders mixed SELECT, INSERT, UPDATE, and DELETE CTEs" $ do+ let sql = renderSelect mixedCteSelect+ assertBool "renders one top-level WITH" ("WITH " `isPrefixOf` sql)+ assertBool "does not render a nested WITH keyword" (not ("WITH WITH" `isInfixOf` sql))+ assertBool "renders INSERT" ("INSERT INTO" `isInfixOf` sql)+ assertBool "renders UPDATE" ("UPDATE" `isInfixOf` sql)+ assertBool "renders DELETE" ("DELETE FROM" `isInfixOf` sql)+ assertEqual "renders three RETURNING clauses" 3 (length (filter (== "RETURNING") (words sql)))++-- Materialization is an explicit PostgreSQL 12+ spelling choice. Check the+-- complete token rather than a loose MATERIALIZED substring, since the latter+-- would make the NOT MATERIALIZED case pass the positive assertion too.+testMaterializationRendering :: TestTree+testMaterializationRendering = testCase "renders every SELECT CTE materialization policy" $ do+ let defaultSql = renderSelect (materializationSelect Pg.PgCteDefault)+ materializedSql = renderSelect (materializationSelect Pg.PgCteMaterialized)+ notMaterializedSql = renderSelect (materializationSelect Pg.PgCteNotMaterialized)+ assertBool "default omits MATERIALIZED"+ (not (" MATERIALIZED (" `isInfixOf` defaultSql))+ assertBool "default omits NOT MATERIALIZED"+ (not (" NOT MATERIALIZED (" `isInfixOf` defaultSql))+ assertBool "renders AS MATERIALIZED"+ (" AS MATERIALIZED (" `isInfixOf` materializedSql)+ assertBool "renders AS NOT MATERIALIZED"+ (" AS NOT MATERIALIZED (" `isInfixOf` notMaterializedSql)++-- pgSelectWithNested is the safe nested consumer for PostgreSQL-specific+-- SELECT CTE features. This complements the compatibility test for the older+-- pgSelectWith API below.+testNestedMaterializedCteRendering :: TestTree+testNestedMaterializedCteRendering = testCase "embeds a materialized PgWith block in a subquery" $ do+ let sql = renderSelect nestedMaterializedCteSelect+ assertBool "renders the nested WITH"+ ("FROM (WITH " `isInfixOf` sql)+ assertBool "retains the materialization modifier"+ (" AS MATERIALIZED (" `isInfixOf` sql)++-- DML without RETURNING is still executed by PostgreSQL but forms no temporary+-- table and exposes no reusable result. Its CTE name must therefore have no+-- empty column-alias list.+testSideEffectOnlyRendering :: TestTree+testSideEffectOnlyRendering = testCase "renders side-effect-only INSERT, UPDATE, and DELETE CTEs" $ do+ let sql = renderSelect sideEffectOnlyCteSelect+ assertBool "renders INSERT" ("INSERT INTO" `isInfixOf` sql)+ assertBool "renders UPDATE" ("UPDATE" `isInfixOf` sql)+ assertBool "renders DELETE" ("DELETE FROM" `isInfixOf` sql)+ assertBool "does not render RETURNING" (not ("RETURNING" `isInfixOf` sql))+ assertBool "does not render an empty alias list" (not ("() AS" `isInfixOf` sql))++-- Empty inserts and identity updates should consume neither a name nor a CTE+-- slot. With no other CTEs, the final query must not acquire an empty WITH.+testSideEffectNoOps :: TestTree+testSideEffectNoOps = testCase "omits side-effect-only empty INSERT and identity UPDATE" $ do+ let sql = renderSelect sideEffectNoOpSelect+ assertBool "does not render WITH" (not ("WITH " `isPrefixOf` sql))+ assertBool "does not render INSERT" (not ("INSERT INTO" `isInfixOf` sql))+ assertBool "does not render UPDATE" (not ("UPDATE" `isInfixOf` sql))++-- Lifting a complete portable helper must not restart its State Int name+-- supply. Four definitions from native/lifted/native construction should be+-- allocated exactly once as cte0 through cte3.+testLiftedWithNameSupply :: TestTree+testLiftedWithNameSupply = testCase "shares CTE names across lifted and native builders" $ do+ let sql = renderSelect liftedWithSelect+ mapM_ (\name -> assertBool ("renders " ++ name) (("\"" ++ name ++ "\"") `isInfixOf` sql))+ ["cte0", "cte1", "cte2", "cte3"]+ assertBool "does not allocate cte4" (not ("\"cte4\"" `isInfixOf` sql))++-- pgSelectWith remains available for its original purpose: embedding a+-- SELECT-only WITH block as a subquery.+testNestedSelectCteRendering :: TestTree+testNestedSelectCteRendering = testCase "SELECT CTEs remain valid inside pgSelectWith" $ do+ let sql = renderSelect nestedSelectCteSelect+ assertBool "renders an inner WITH" ("FROM (WITH " `isInfixOf` sql)++-- Closing the recursive SELECT portion with pgToTopLevel should preserve WITH+-- RECURSIVE while allowing a later DELETE CTE in the same top-level block.+testRecursiveSelectThenDeleteRendering :: TestTree+testRecursiveSelectThenDeleteRendering = testCase "recursive SELECT can feed a top-level DELETE CTE" $ do+ let sql = renderSelect recursiveSelectThenDeleteCteSelect+ assertBool "renders WITH RECURSIVE" ("WITH RECURSIVE " `isPrefixOf` sql)+ assertBool "renders DELETE" ("DELETE FROM" `isInfixOf` sql)++-- Value-level empty operations must not leave behind an empty or partial WITH+-- clause when the final SELECT is rendered.+testEmptyDataModifyingCtes :: TestTree+testEmptyDataModifyingCtes = testCase "omits empty INSERT and identity UPDATE CTEs" $ do+ let sql = renderSelect emptyDataModifyingCteSelect+ assertBool "does not render WITH" (not ("WITH " `isPrefixOf` sql))+ assertBool "does not render INSERT" (not ("INSERT INTO" `isInfixOf` sql))+ assertBool "does not render UPDATE" (not ("UPDATE" `isInfixOf` sql))++-- Each PostgreSQL DML consumer must place the WITH block before, rather than+-- inside, its terminal statement. These rendering checks cover INSERT, UPDATE,+-- and DELETE while retaining Beam's existing Sql* result types.+testWithDmlConsumerRendering :: TestTree+testWithDmlConsumerRendering = testCase "renders WITH before terminal INSERT, UPDATE, and DELETE" $ do+ assertWithTerminal "INSERT INTO" (renderInsert insertWithStatement)+ assertWithTerminal "UPDATE" (renderUpdate updateWithStatement)+ assertWithTerminal "DELETE FROM" (renderDelete deleteWithStatement)++-- A recursive SELECT CTE is legal before a terminal DML statement. This makes+-- sure pgInsertWith preserves the recursive flag collected by With.+testRecursiveInsertWithRendering :: TestTree+testRecursiveInsertWithRendering = testCase "renders WITH RECURSIVE before a terminal INSERT" $ do+ sql <- requireRenderedStatement (renderInsert recursiveInsertWithStatement)+ assertBool "starts with WITH RECURSIVE" ("WITH RECURSIVE " `isPrefixOf` sql)+ assertBool "renders terminal INSERT" (" INSERT INTO" `isInfixOf` sql)++-- Top-level DML consumers may accept the stronger PgCteTopLevelOnly placement.+-- A data-modifying CTE followed by DELETE exercises that fact at compile time+-- as well as checking the resulting SQL shape.+testTopLevelOnlyDmlConsumerRendering :: TestTree+testTopLevelOnlyDmlConsumerRendering = testCase "accepts a modifying CTE before terminal DELETE" $ do+ sql <- requireRenderedStatement (renderDelete topLevelOnlyDeleteWithStatement)+ assertBool "renders DELETE as the CTE body"+ ("AS (DELETE FROM" `isInfixOf` sql)+ assertBool "renders DELETE as the terminal statement"+ (") DELETE FROM" `isInfixOf` sql)++-- An empty INSERT and identity UPDATE have no terminal statement. PostgreSQL+-- cannot execute a bare WITH clause, so their consumers must retain the+-- existing no-op representation and discard the accumulated definitions.+testEmptyDmlConsumers :: TestTree+testEmptyDmlConsumers = testCase "keeps empty INSERT and identity UPDATE as no-ops" $ do+ assertEqual "empty INSERT has no syntax" Nothing+ (renderInsert emptyInsertWithStatement)+ assertEqual "identity UPDATE has no syntax" Nothing+ (renderUpdate identityUpdateWithStatement)++-- The consumers deliberately return the existing Sql* wrappers. Their+-- PgReturning instances must therefore remain usable without a parallel+-- pgInsertReturningWith/pgUpdateReturningWith/pgDeleteReturningWith API.+testReturningAfterDmlConsumers :: TestTree+testReturningAfterDmlConsumers = testCase "supports RETURNING after each terminal DML consumer" $ do+ assertReturning "INSERT" (renderInsertReturning (Pg.returning insertWithStatement id))+ assertReturning "UPDATE" (renderUpdateReturning (Pg.returning updateWithStatement id))+ assertReturning "DELETE" (renderDeleteReturning (Pg.returning deleteWithStatement id))++-- PostgreSQL's syntax for a degree-zero CTE has no column-alias parentheses.+-- Cover both the portable selecting renderer and the native renderer, including+-- nested and explicit materialization forms, because they enter PostgreSQL+-- syntax through different code paths.+testDegreeZeroSelectRendering :: TestTree+testDegreeZeroSelectRendering = testCase "renders reusable degree-zero SELECT CTEs" $ do+ let portableSql = renderSelect emptySelectProjection+ nativeSql = renderSelect+ (emptyNativeSelectProjection Pg.PgCteDefault)+ materializedSql = renderSelect+ (emptyNativeSelectProjection Pg.PgCteMaterialized)+ nestedSql = renderSelect nestedEmptySelectProjection++ mapM_ assertDegreeZeroSelect+ [portableSql, nativeSql, materializedSql, nestedSql]+ assertBool "retains explicit materialization"+ (" AS MATERIALIZED (" `isInfixOf` materializedSql)+ assertBool "remains valid in a nested SELECT"+ ("FROM (WITH " `isInfixOf` nestedSql)+ where+ assertDegreeZeroSelect sql = do+ assertBool "does not render an empty CTE alias list"+ (not ("\"cte0\"()" `isInfixOf` sql))+ assertBool "the CTE body projects no columns"+ ("SELECT FROM" `isInfixOf` sql || "SELECT FROM" `isInfixOf` sql)+ assertBool "the consumer projects no columns"+ ("SELECT FROM \"cte0\"" `isInfixOf` sql ||+ "SELECT FROM \"cte0\"" `isInfixOf` sql)++-- INSERT, UPDATE, and DELETE share the sentinel path but have independent+-- RETURNING renderers. Assert every spelling, including that the physical+-- sentinel is declared once and is not selected by the zero-field consumer.+testDegreeZeroDataModifyingRendering :: TestTree+testDegreeZeroDataModifyingRendering =+ testCase "renders reusable degree-zero data-modifying CTEs" $+ mapM_ assertDegreeZeroDml+ [ ("INSERT", renderSelect (emptyInsertProjection [CteRow 1 "one"]))+ , ("UPDATE", renderSelect (emptyUpdateProjection 1 "updated"))+ , ("DELETE", renderSelect (emptyDeleteProjection 1))+ ]+ where+ assertDegreeZeroDml (command, sql) = do+ assertBool (command ++ " declares one physical sentinel")+ ("\"cte0\"(\"res0\") AS" `isInfixOf` sql)+ assertBool (command ++ " appends a valid RETURNING expression")+ (" RETURNING NULL::boolean" `isInfixOf` sql)+ assertEqual (command ++ " emits one RETURNING keyword")+ 1+ (length (filter (== "RETURNING") (words sql)))+ assertBool (command ++ " does not expose the sentinel")+ ("SELECT FROM \"cte0\"" `isInfixOf` sql ||+ "SELECT FROM \"cte0\"" `isInfixOf` sql)++-- Rendering alone cannot verify PostgreSQL's execution and snapshot semantics.+-- This integration case checks both the RETURNING rows and the final table+-- state after all three modifying CTEs execute.+testMixedCteBodies :: IO ByteString -> TestTree+testMixedCteBodies getConn = testCase "SELECT and data-modifying CTEs can be mixed" $+ withTestPostgres "mixed_cte_bodies" getConn $ \conn -> do+ execute_ conn "CREATE TABLE cte_rows (id INT PRIMARY KEY, value TEXT NOT NULL)"+ execute_ conn "INSERT INTO cte_rows VALUES (1, 'selected'), (3, 'before-update'), (4, 'deleted')"++ result <- runBeamPostgres conn $ runSelectReturningList mixedCteSelect++ assertEqual "rows returned by each CTE"+ [ ( CteRow 1 "selected"+ , CteRow 2 "inserted"+ , CteRow 3 "updated"+ , CteRow 4 "deleted"+ )+ ]+ result++ remaining <- runBeamPostgres conn $ runSelectReturningList $ select $+ orderBy_ (asc_ . cteId) $ all_ (dbCteRows cteDb)+ assertEqual "data modifications were applied"+ [ CteRow 1 "selected"+ , CteRow 2 "inserted"+ , CteRow 3 "updated"+ ]+ remaining++-- PostgreSQL executes a modifying CTE exactly once even when it has no+-- RETURNING clause and the terminal SELECT does not reference it. Verify that+-- all three commands affect the final database state, not merely that their+-- syntax parses.+testSideEffectOnlyCtes :: IO ByteString -> TestTree+testSideEffectOnlyCtes getConn = testCase "unreferenced side-effect-only CTEs execute once" $+ withTestPostgres "side_effect_only_ctes" getConn $ \conn -> do+ execute_ conn "CREATE TABLE cte_rows (id INT PRIMARY KEY, value TEXT NOT NULL)"+ execute_ conn "INSERT INTO cte_rows VALUES (1, 'unchanged'), (2, 'before-update'), (3, 'delete-me')"++ marker <- runBeamPostgres conn $+ runSelectReturningOne sideEffectOnlyCteSelect+ assertEqual "terminal SELECT still runs" (Just (1 :: Int32)) marker++ remaining <- runBeamPostgres conn $ runSelectReturningList $ select $+ orderBy_ (asc_ . cteId) $ all_ (dbCteRows cteDb)+ assertEqual "all expected side effects were applied"+ [ CteRow 1 "unchanged"+ , CteRow 2 "after-update"+ , CteRow 4 "inserted"+ ]+ remaining++-- Planner choices are deliberately not asserted because they may vary across+-- PostgreSQL releases. Successful execution and equal results validate the two+-- explicit PostgreSQL 12+ spellings without coupling the test to EXPLAIN.+testMaterializationExecution :: IO ByteString -> TestTree+testMaterializationExecution getConn = testCase "MATERIALIZED and NOT MATERIALIZED execute" $+ withTestPostgres "cte_materialization" getConn $ \conn -> do+ execute_ conn "CREATE TABLE cte_rows (id INT PRIMARY KEY, value TEXT NOT NULL)"+ execute_ conn "INSERT INTO cte_rows VALUES (1, 'one'), (2, 'two')"++ materialized <- runBeamPostgres conn $ runSelectReturningList $+ materializationSelect Pg.PgCteMaterialized+ notMaterialized <- runBeamPostgres conn $ runSelectReturningList $+ materializationSelect Pg.PgCteNotMaterialized+ assertEqual "both policies preserve query results" materialized notMaterialized++-- Rendering checks the shared name supply; execution additionally proves that+-- ReusableQ values returned by a lifted multi-CTE helper retain their meaning.+testLiftedWithExecution :: IO ByteString -> TestTree+testLiftedWithExecution getConn = testCase "a lifted multi-CTE helper remains reusable" $+ withTestPostgres "lifted_with_execution" getConn $ \conn -> do+ lifted <- runBeamPostgres conn $ runSelectReturningList liftedWithSelect+ assertEqual "a lifted multi-CTE helper remains reusable"+ [(1, 11, 12)]+ lifted++-- Execute each terminal DML consumer against PostgreSQL. The three statements+-- use SELECT CTEs to choose or construct their affected rows, proving that the+-- reusable names remain visible to INSERT, UPDATE, and DELETE.+testWithDmlConsumers :: IO ByteString -> TestTree+testWithDmlConsumers getConn = testCase "WITH can terminate in INSERT, UPDATE, or DELETE" $+ withTestPostgres "with_dml_consumers" getConn $ \conn -> do+ execute_ conn "CREATE TABLE cte_rows (id INT PRIMARY KEY, value TEXT NOT NULL)"+ execute_ conn "INSERT INTO cte_rows VALUES (1, 'source'), (3, 'before-update'), (4, 'delete-me')"++ runBeamPostgres conn $ do+ runInsert insertWithStatement+ runUpdate updateWithStatement+ runDelete deleteWithStatement++ remaining <- runBeamPostgres conn $ runSelectReturningList $ select $+ orderBy_ (asc_ . cteId) $ all_ (dbCteRows cteDb)+ assertEqual "all terminal DML statements used their CTE rows"+ [ CteRow 1 "source"+ , CteRow 2 "inserted-with"+ , CteRow 3 "updated-with"+ ]+ remaining++-- PostgreSQL receives Beam values separately from the rendered placeholders.+-- Generate distinct values at each syntactic level so any disagreement between+-- syntax construction order and parameter collection order becomes observable+-- in the returned rows, rather than merely producing valid-looking SQL.+testCteParameterOrdering :: IO ByteString -> TestTree+testCteParameterOrdering getConn = testCase "preserves parameter order across CTE bodies and the terminal query" $+ withTestPostgres "cte_parameter_ordering_property" getConn $ \conn -> do+ passes <- Hedgehog.check . Hedgehog.property $ do+ baseId <- Hedgehog.forAll (Gen.int (Range.linear (-100000) 100000))+ firstOffset <- Hedgehog.forAll (Gen.int (Range.linear 1 1000))+ secondOffset <- Hedgehog.forAll (Gen.int (Range.linear 1 1000))+ payload <- Hedgehog.forAll (Gen.text (Range.linear 0 24) Gen.alphaNum)++ let first = CteRow (fromIntegral baseId) ("first:" <> payload)+ second = CteRow+ (fromIntegral (baseId + firstOffset))+ ("second:" <> payload)+ terminal = CteRow+ (fromIntegral (baseId + firstOffset + secondOffset))+ ("terminal:" <> payload)++ actual <- Hedgehog.evalIO $ runBeamPostgres conn $+ runSelectReturningList (parameterOrderingSelect first second terminal)++ actual Hedgehog.=== [(first, second, terminal)]++ assertBool "CTE parameter-ordering property failed" passes++-- Model a statement containing all three kinds of data-modifying CTE. The+-- operations use disjoint keys, avoiding PostgreSQL's deliberately unspecified+-- ordering when sibling modifying CTEs affect the same row. Both RETURNING+-- values and durable table state are compared with the pure expected result.+testDataModifyingCteModel :: IO ByteString -> TestTree+testDataModifyingCteModel getConn = testCase "data-modifying CTEs agree with a pure table model" $+ withTestPostgres "data_modifying_cte_model_property" getConn $ \conn -> do+ execute_ conn "CREATE TABLE cte_rows (id INT PRIMARY KEY, value TEXT NOT NULL)"++ passes <- Hedgehog.check . Hedgehog.property $ do+ baseId <- Hedgehog.forAll (Gen.int (Range.linear (-100000) 96000))+ payload <- Hedgehog.forAll (Gen.text (Range.linear 0 24) Gen.alphaNum)++ let inserted = CteRow (fromIntegral baseId) ("inserted:" <> payload)+ beforeUpdate = CteRow (fromIntegral (baseId + 1)) ("before-update:" <> payload)+ updated = CteRow (cteId beforeUpdate) ("updated:" <> payload)+ deleted = CteRow (fromIntegral (baseId + 2)) ("deleted:" <> payload)+ untouched = CteRow (fromIntegral (baseId + 3)) ("untouched:" <> payload)+ initial = [beforeUpdate, deleted, untouched]+ expectedFinal = [inserted, updated, untouched]++ Hedgehog.evalIO $ do+ execute_ conn "TRUNCATE TABLE cte_rows"+ runBeamPostgres conn $ runInsert $+ insert (dbCteRows cteDb) (insertValues initial)++ returned <- Hedgehog.evalIO $ runBeamPostgres conn $+ runSelectReturningList $+ dataModifyingCteModelSelect inserted (cteId updated) (cteValue updated) (cteId deleted)++ finalRows <- Hedgehog.evalIO $ runBeamPostgres conn $+ runSelectReturningList $ select $+ orderBy_ (asc_ . cteId) $ all_ (dbCteRows cteDb)++ returned Hedgehog.=== [(inserted, updated, deleted)]+ finalRows Hedgehog.=== expectedFinal++ assertBool "data-modifying CTE model property failed" passes++-- Repeat the three-operation model without RETURNING. This catches parameter+-- ordering or accidental omission in the side-effect-only path by+-- comparing durable state over generated inputs.+testSideEffectOnlyCteModel :: IO ByteString -> TestTree+testSideEffectOnlyCteModel getConn = testCase "side-effect-only CTEs agree with a pure table model" $+ withTestPostgres "side_effect_only_cte_model_property" getConn $ \conn -> do+ execute_ conn "CREATE TABLE cte_rows (id INT PRIMARY KEY, value TEXT NOT NULL)"++ passes <- Hedgehog.check . Hedgehog.property $ do+ baseId <- Hedgehog.forAll (Gen.int (Range.linear (-100000) 96000))+ payload <- Hedgehog.forAll (Gen.text (Range.linear 0 24) Gen.alphaNum)++ let inserted = CteRow (fromIntegral baseId) ("inserted:" <> payload)+ beforeUpdate = CteRow (fromIntegral (baseId + 1)) ("before-update:" <> payload)+ updated = CteRow (cteId beforeUpdate) ("updated:" <> payload)+ deleted = CteRow (fromIntegral (baseId + 2)) ("deleted:" <> payload)+ untouched = CteRow (fromIntegral (baseId + 3)) ("untouched:" <> payload)+ initial = [beforeUpdate, deleted, untouched]+ expectedFinal = [inserted, updated, untouched]++ Hedgehog.evalIO $ do+ execute_ conn "TRUNCATE TABLE cte_rows"+ runBeamPostgres conn $ runInsert $+ insert (dbCteRows cteDb) (insertValues initial)++ marker <- Hedgehog.evalIO $ runBeamPostgres conn $+ runSelectReturningOne $+ sideEffectCteModelSelect inserted (cteId updated) (cteValue updated) (cteId deleted)+ finalRows <- Hedgehog.evalIO $ runBeamPostgres conn $+ runSelectReturningList $ select $+ orderBy_ (asc_ . cteId) $ all_ (dbCteRows cteDb)++ marker Hedgehog.=== Just (1 :: Int32)+ finalRows Hedgehog.=== expectedFinal++ assertBool "side-effect-only CTE model property failed" passes++-- Exercise each top-level WITH consumer with independently generated values.+-- RETURNING results prove that the existing PostgreSQL execution instances can+-- still consume the Sql* wrappers, while the final table comparison checks the+-- combined INSERT, UPDATE, and DELETE behavior against a pure model.+testWithDmlConsumerModel :: IO ByteString -> TestTree+testWithDmlConsumerModel getConn = testCase "WITH DML consumers agree with a pure table model" $+ withTestPostgres "with_dml_consumer_model_property" getConn $ \conn -> do+ execute_ conn "CREATE TABLE cte_rows (id INT PRIMARY KEY, value TEXT NOT NULL)"++ passes <- Hedgehog.check . Hedgehog.property $ do+ baseId <- Hedgehog.forAll (Gen.int (Range.linear (-100000) 95000))+ payload <- Hedgehog.forAll (Gen.text (Range.linear 0 24) Gen.alphaNum)++ let source = CteRow (fromIntegral baseId) ("source:" <> payload)+ inserted = CteRow (fromIntegral (baseId + 1)) ("inserted:" <> payload)+ beforeUpdate = CteRow (fromIntegral (baseId + 2)) ("before-update:" <> payload)+ updated = CteRow (cteId beforeUpdate) ("updated:" <> payload)+ deleted = CteRow (fromIntegral (baseId + 3)) ("deleted:" <> payload)+ untouched = CteRow (fromIntegral (baseId + 4)) ("untouched:" <> payload)+ initial = [source, beforeUpdate, deleted, untouched]+ expectedFinal = [source, inserted, updated, untouched]++ Hedgehog.evalIO $ do+ execute_ conn "TRUNCATE TABLE cte_rows"+ runBeamPostgres conn $ runInsert $+ insert (dbCteRows cteDb) (insertValues initial)++ (insertedRows, updatedRows, deletedRows) <- Hedgehog.evalIO $+ runBeamPostgres conn $ do+ insertedRows <- Pg.runPgInsertReturningList $ Pg.returning+ (modelInsertWithStatement (cteId source) inserted) id+ updatedRows <- Pg.runPgUpdateReturningList $ Pg.returning+ (modelUpdateWithStatement (cteId updated) (cteValue updated)) id+ deletedRows <- Pg.runPgDeleteReturningList $ Pg.returning+ (modelDeleteWithStatement (cteId deleted)) id+ pure (insertedRows, updatedRows, deletedRows)++ finalRows <- Hedgehog.evalIO $ runBeamPostgres conn $+ runSelectReturningList $ select $+ orderBy_ (asc_ . cteId) $ all_ (dbCteRows cteDb)++ insertedRows Hedgehog.=== [inserted]+ updatedRows Hedgehog.=== [updated]+ deletedRows Hedgehog.=== [deleted]+ finalRows Hedgehog.=== expectedFinal++ assertBool "WITH DML consumer model property failed" passes++-- Generate a bounded recursive sequence, use it to drive a DELETE CTE, and+-- compare both the returned rows and remaining table against the corresponding+-- Haskell lists. This executes the recursive SELECT, its pgToTopLevel promotion,+-- and the following modifying CTE rather than checking only rendered keywords.+testRecursiveCteModel :: IO ByteString -> TestTree+testRecursiveCteModel getConn = testCase "recursive CTE execution agrees with a bounded sequence model" $+ withTestPostgres "recursive_cte_model_property" getConn $ \conn -> do+ execute_ conn "CREATE TABLE cte_rows (id INT PRIMARY KEY, value TEXT NOT NULL)"++ passes <- Hedgehog.check . Hedgehog.property $ do+ start <- Hedgehog.forAll (Gen.int (Range.linear (-100000) 95000))+ count <- Hedgehog.forAll (Gen.int (Range.linear 1 25))+ payload <- Hedgehog.forAll (Gen.text (Range.linear 0 24) Gen.alphaNum)++ let startId = fromIntegral start+ endId = fromIntegral (start + count - 1)+ recursiveRows =+ [ CteRow (fromIntegral rowId) ("recursive:" <> payload)+ | rowId <- [start .. start + count - 1]+ ]+ untouched = CteRow (fromIntegral (start + count)) ("untouched:" <> payload)++ Hedgehog.evalIO $ do+ execute_ conn "TRUNCATE TABLE cte_rows"+ runBeamPostgres conn $ runInsert $+ insert (dbCteRows cteDb) (insertValues (recursiveRows ++ [untouched]))++ deletedRows <- Hedgehog.evalIO $ runBeamPostgres conn $+ runSelectReturningList (recursiveCteModelSelect startId endId)+ finalRows <- Hedgehog.evalIO $ runBeamPostgres conn $+ runSelectReturningList $ select $+ orderBy_ (asc_ . cteId) $ all_ (dbCteRows cteDb)++ sortOn cteId deletedRows Hedgehog.=== recursiveRows+ finalRows Hedgehog.=== [untouched]++ assertBool "recursive CTE model property failed" passes++-- A row need not contain a projected value. PostgreSQL still returns one+-- zero-field result for every source row, and postgresql-simple must decode the+-- final rows without expecting any result fields. Exercise both the portable+-- and native builders and both explicit materialization policies.+testDegreeZeroSelects :: IO ByteString -> TestTree+testDegreeZeroSelects getConn = testCase "degree-zero SELECT CTEs preserve source cardinality" $+ withTestPostgres "degree_zero_select_ctes" getConn $ \conn -> do+ execute_ conn "CREATE TABLE cte_rows (id INT PRIMARY KEY, value TEXT NOT NULL)"++ emptySummary <- runBeamPostgres conn $ runSelectReturningOne $+ emptySelectSummary+ assertEqual "an empty degree-zero relation has count zero and is not present"+ (Just (0, False))+ emptySummary++ execute_ conn "INSERT INTO cte_rows VALUES (1, 'one'), (2, 'two'), (3, 'three')"++ portable <- runBeamPostgres conn $+ runSelectReturningList emptySelectProjection+ native <- runBeamPostgres conn $ runSelectReturningList $+ emptyNativeSelectProjection Pg.PgCteDefault+ materialized <- runBeamPostgres conn $ runSelectReturningList $+ emptyNativeSelectProjection Pg.PgCteMaterialized+ notMaterialized <- runBeamPostgres conn $ runSelectReturningList $+ emptyNativeSelectProjection Pg.PgCteNotMaterialized+ populatedSummary <- runBeamPostgres conn $ runSelectReturningOne $+ emptySelectSummary++ let expected = replicate 3 EmptyCte+ assertEqual "portable selecting preserves cardinality" expected portable+ assertEqual "native default preserves cardinality" expected native+ assertEqual "MATERIALIZED preserves cardinality" expected materialized+ assertEqual "NOT MATERIALIZED preserves cardinality" expected notMaterialized+ assertEqual "aggregates and EXISTS observe degree-zero rows"+ (Just (3, True))+ populatedSummary++-- Each modifying command has a separate RETURNING renderer. Besides validating+-- all three, this checks the boundary cases of several affected rows and no+-- affected rows, verifies that the private sentinel is not passed to the row+-- decoder, and compares the resulting durable table state.+testDegreeZeroDataModifyingCtes :: IO ByteString -> TestTree+testDegreeZeroDataModifyingCtes getConn =+ testCase "degree-zero modifying CTEs preserve affected-row cardinality" $+ withTestPostgres "degree_zero_modifying_ctes" getConn $ \conn -> do+ execute_ conn "CREATE TABLE cte_rows (id INT PRIMARY KEY, value TEXT NOT NULL)"+ execute_ conn "INSERT INTO cte_rows VALUES (1, 'one'), (2, 'two'), (3, 'three')"++ inserted <- runBeamPostgres conn $ runSelectReturningList $+ emptyInsertProjection [CteRow 4 "four", CteRow 5 "five"]+ updated <- runBeamPostgres conn $ runSelectReturningList $+ emptyUpdateProjection 2 "updated"+ deleted <- runBeamPostgres conn $ runSelectReturningList $+ emptyDeleteProjection 3+ deletedNone <- runBeamPostgres conn $ runSelectReturningList $+ emptyDeleteProjection 99++ assertEqual "INSERT retains two affected rows"+ (replicate 2 EmptyCte) inserted+ assertEqual "UPDATE retains two affected rows"+ (replicate 2 EmptyCte) updated+ assertEqual "DELETE retains three affected rows"+ (replicate 3 EmptyCte) deleted+ assertEqual "a command affecting no rows returns an empty relation"+ [] deletedNone++ remaining <- runBeamPostgres conn $ runSelectReturningList $ select $+ orderBy_ (asc_ . cteId) $ all_ (dbCteRows cteDb)+ assertEqual "all modifying commands applied their side effects"+ [CteRow 1 "updated", CteRow 2 "updated"]+ remaining++-- Reusing a degree-zero modifying CTE twice is a useful stress case: no field+-- can carry cardinality through the query, so the nine rows show that both+-- references read the same three-row RETURNING result. The final table state+-- separately confirms that the DELETE removed every source row.+testDegreeZeroRepeatedReuse :: IO ByteString -> TestTree+testDegreeZeroRepeatedReuse getConn =+ testCase "repeated degree-zero reuse preserves relational cardinality" $+ withTestPostgres "degree_zero_repeated_reuse" getConn $ \conn -> do+ execute_ conn "CREATE TABLE cte_rows (id INT PRIMARY KEY, value TEXT NOT NULL)"+ execute_ conn "INSERT INTO cte_rows VALUES (1, 'one'), (2, 'two'), (3, 'three')"++ summary <- runBeamPostgres conn $ runSelectReturningOne $+ emptyDeleteSummary+ assertEqual "COUNT and EXISTS observe every returned DELETE row"+ (Just (3, True))+ summary++ execute_ conn "INSERT INTO cte_rows VALUES (1, 'one'), (2, 'two'), (3, 'three')"+ products <- runBeamPostgres conn $ runSelectReturningList $+ repeatedEmptyDeleteProjection+ assertEqual "two references form the expected Cartesian product"+ (replicate 9 EmptyCte)+ products++ remaining <- runBeamPostgres conn $ runSelectReturningList $ select $+ all_ (dbCteRows cteDb)+ assertEqual "the modifying CTE deletes every source row"+ []+ remaining++materializationSelect+ :: Pg.PgCteMaterialization+ -> SqlSelect Postgres (CteRowT Identity)+materializationSelect materialization = Pg.pgSelectWithTopLevel $ do+ rows <- Pg.pgSelectingWith materialization $ all_ (dbCteRows cteDb)+ pure (reuse rows)++nestedMaterializedCteSelect :: SqlSelect Postgres (CteRowT Identity)+nestedMaterializedCteSelect = select $ Pg.pgSelectWithNested $ do+ rows <- Pg.pgSelectingWith Pg.PgCteMaterialized $+ all_ (dbCteRows cteDb)+ pure (reuse rows)++sideEffectOnlyCteSelect :: SqlSelect Postgres Int32+sideEffectOnlyCteSelect = Pg.pgSelectWithTopLevel $ do+ Pg.cteInsert+ (dbCteRows cteDb)+ (insertValues [CteRow 4 "inserted"])+ Pg.onConflictDefault+ Pg.cteUpdate+ (dbCteRows cteDb)+ (\row -> cteValue row <-. val_ "after-update")+ (\row -> cteId row ==. val_ 2)+ Pg.cteDelete+ (dbCteRows cteDb)+ (\row -> cteId row ==. val_ 3)+ pure finalMarkerQuery++sideEffectNoOpSelect :: SqlSelect Postgres Int32+sideEffectNoOpSelect = Pg.pgSelectWithTopLevel $ do+ Pg.cteInsert+ (dbCteRows cteDb)+ SqlInsertValuesEmpty+ Pg.onConflictDefault+ Pg.cteUpdate+ (dbCteRows cteDb)+ (const mempty)+ (const (val_ True))+ pure finalMarkerQuery++finalMarkerQuery+ :: Q Postgres CteDb QBaseScope (QExpr Postgres QBaseScope Int32)+finalMarkerQuery = pure (val_ 1)++-- A complete two-CTE portable helper is lifted as one action. Its internal+-- dependency also proves that lifting preserves ReusableQ values, not only the+-- emitted syntax fragments.+portableWithHelper+ :: With Postgres CteDb+ (ReusableQ Postgres CteDb (QExpr Postgres CTE.QAnyScope Int32))+portableWithHelper = do+ first <- selecting $ pure (as_ @Int32 (val_ 10))+ selecting $ do+ value <- reuse first+ pure (value + 1)++liftedWithSelect+ :: SqlSelect Postgres+ (Int32, Int32, Int32)+liftedWithSelect = Pg.pgSelectWithTopLevel $ do+ nativeBefore <- Pg.pgSelecting $ pure (as_ @Int32 (val_ 1))+ lifted <- Pg.pgLiftWith portableWithHelper+ nativeAfter <- Pg.pgSelecting $ do+ value <- reuse lifted+ pure (value + 1)+ pure $ do+ before <- reuse nativeBefore+ middle <- reuse lifted+ after <- reuse nativeAfter+ pure (before, middle, after)++-- Exercise the main user-facing flow: bind a normal SELECT CTE, perform each+-- supported data modification, then join all four reusable results in the final+-- SELECT. The placement of the complete block is inferred as top-level-only.+mixedCteSelect+ :: SqlSelect Postgres+ ( CteRowT Identity+ , CteRowT Identity+ , CteRowT Identity+ , CteRowT Identity+ )+mixedCteSelect = Pg.pgSelectWithTopLevel $ do+ selected <- Pg.pgSelecting $ do+ row <- all_ (dbCteRows cteDb)+ guard_ (cteId row ==. val_ 1)+ pure row++ inserted <- Pg.cteInsertReturning+ (dbCteRows cteDb)+ (insertValues [CteRow 2 "inserted"])+ Pg.onConflictDefault+ id++ updated <- Pg.cteUpdateReturning+ (dbCteRows cteDb)+ (\row -> cteValue row <-. val_ "updated")+ (\row -> cteId row ==. val_ 3)+ id++ deleted <- Pg.cteDeleteReturning+ (dbCteRows cteDb)+ (\row -> cteId row ==. val_ 4)+ id++ case (inserted, updated) of+ (Just inserted', Just updated') -> pure $ do+ selectedRow <- reuse selected+ insertedRow <- reuse inserted'+ updatedRow <- reuse updated'+ deletedRow <- reuse deleted+ pure (selectedRow, insertedRow, updatedRow, deletedRow)+ _ -> error "Expected non-empty INSERT and UPDATE CTEs"++-- Place values in two dependent CTE bodies and in the terminating SELECT. The+-- dependency prevents the second CTE from becoming an unrelated test fragment,+-- while the result exposes every bound value for exact comparison.+parameterOrderingSelect+ :: CteRowT Identity+ -> CteRowT Identity+ -> CteRowT Identity+ -> SqlSelect Postgres+ (CteRowT Identity, CteRowT Identity, CteRowT Identity)+parameterOrderingSelect first second terminal = selectWith $ do+ firstRows <- selecting $ pure (cteRowValues_ @CTE.QAnyScope first)+ secondRows <- selecting $ do+ _ <- reuse firstRows+ pure (cteRowValues_ @CTE.QAnyScope second)+ pure $ do+ firstRow <- reuse firstRows+ secondRow <- reuse secondRows+ pure+ ( firstRow+ , secondRow+ , cteRowValues_ @QBaseScope terminal+ )++cteRowValues_+ :: forall scope. CteRowT Identity -> CteRowT (QExpr Postgres scope)+cteRowValues_ row = CteRow (val_ (cteId row)) (val_ (cteValue row))++-- The returned relation exposes the result of every modifying CTE. Keeping+-- their keys disjoint gives the property a deterministic reference model while+-- still exercising mixed syntax assembly and PostgreSQL execution semantics.+dataModifyingCteModelSelect+ :: CteRowT Identity+ -> Int32+ -> Text+ -> Int32+ -> SqlSelect Postgres+ (CteRowT Identity, CteRowT Identity, CteRowT Identity)+dataModifyingCteModelSelect inserted updateId updateValue deleteId =+ Pg.pgSelectWithTopLevel $ do+ insertedRows <- Pg.cteInsertReturning+ (dbCteRows cteDb)+ (insertValues [inserted])+ Pg.onConflictDefault+ id+ updatedRows <- Pg.cteUpdateReturning+ (dbCteRows cteDb)+ (\row -> cteValue row <-. val_ updateValue)+ (\row -> cteId row ==. val_ updateId)+ id+ deletedRows <- Pg.cteDeleteReturning+ (dbCteRows cteDb)+ (\row -> cteId row ==. val_ deleteId)+ id++ case (insertedRows, updatedRows) of+ (Just insertedRows', Just updatedRows') -> pure $ do+ insertedRow <- reuse insertedRows'+ updatedRow <- reuse updatedRows'+ deletedRow <- reuse deletedRows+ pure (insertedRow, updatedRow, deletedRow)+ _ -> error "Expected non-empty INSERT and UPDATE CTEs"++sideEffectCteModelSelect+ :: CteRowT Identity+ -> Int32+ -> Text+ -> Int32+ -> SqlSelect Postgres Int32+sideEffectCteModelSelect inserted updateId updateValue deleteId =+ Pg.pgSelectWithTopLevel $ do+ Pg.cteInsert+ (dbCteRows cteDb)+ (insertValues [inserted])+ Pg.onConflictDefault+ Pg.cteUpdate+ (dbCteRows cteDb)+ (\row -> cteValue row <-. val_ updateValue)+ (\row -> cteId row ==. val_ updateId)+ Pg.cteDelete+ (dbCteRows cteDb)+ (\row -> cteId row ==. val_ deleteId)+ pure finalMarkerQuery++-- The source key is selected in a CTE, then used to derive the inserted key.+-- This keeps both the CTE and terminal INSERT semantically relevant.+modelInsertWithStatement+ :: Int32+ -> CteRowT Identity+ -> SqlInsert Postgres CteRowT+modelInsertWithStatement sourceId inserted = Pg.pgInsertWith $ do+ sourceIds <- Pg.pgSelecting $ do+ row <- all_ (dbCteRows cteDb)+ guard_ (cteId row ==. val_ sourceId)+ pure (cteId row)+ pure $ Pg.insert+ (dbCteRows cteDb)+ (insertFrom $ do+ selectedId <- reuse sourceIds+ pure $ CteRow+ (selectedId + val_ (cteId inserted - sourceId))+ (val_ (cteValue inserted)))+ Pg.onConflictDefault++modelUpdateWithStatement+ :: Int32+ -> Text+ -> SqlUpdate Postgres CteRowT+modelUpdateWithStatement updateId updateValue = Pg.pgUpdateWith $ do+ targetIds <- Pg.pgSelecting $ do+ row <- all_ (dbCteRows cteDb)+ guard_ (cteId row ==. val_ updateId)+ pure (cteId row)+ pure $ update+ (dbCteRows cteDb)+ (\row -> cteValue row <-. val_ updateValue)+ (\row -> exists_ $ do+ targetId <- reuse targetIds+ guard_ (cteId row ==. targetId)+ pure targetId)++modelDeleteWithStatement+ :: Int32+ -> SqlDelete Postgres CteRowT+modelDeleteWithStatement deleteId = Pg.pgDeleteWith $ do+ targetIds <- Pg.pgSelecting $ do+ row <- all_ (dbCteRows cteDb)+ guard_ (cteId row ==. val_ deleteId)+ pure (cteId row)+ pure $ delete (dbCteRows cteDb) $ \row -> exists_ $ do+ targetId <- reuse targetIds+ guard_ (cteId row ==. targetId)+ pure targetId++recursiveCteModelSelect+ :: Int32+ -> Int32+ -> SqlSelect Postgres (CteRowT Identity)+recursiveCteModelSelect startId endId = Pg.pgSelectWithTopLevel $ do+ recursiveIds <- Pg.pgToTopLevel $ mdo+ ids <- Pg.pgSelecting $+ pure (as_ @Int32 (val_ startId)) `unionAll_` do+ previousId <- reuse ids+ guard_ (previousId <. val_ endId)+ pure (previousId + 1)+ pure ids++ deletedRows <- Pg.cteDeleteReturning+ (dbCteRows cteDb)+ (\row -> exists_ $ do+ recursiveId <- reuse recursiveIds+ guard_ (cteId row ==. recursiveId)+ pure recursiveId)+ id++ pure (reuse deletedRows)++nestedSelectCteSelect :: SqlSelect Postgres (CteRowT Identity)+nestedSelectCteSelect = select $ Pg.pgSelectWith $ do+ selected <- selecting $ do+ row <- all_ (dbCteRows cteDb)+ guard_ (cteId row ==. val_ 1)+ pure row+ pure (reuse selected)++-- PostgreSQL permits a recursive SELECT CTE to feed a later modifying CTE, but+-- not a modifying CTE to recursively reference itself. 'pgToTopLevel' closes the+-- recursive SELECT knot before the DELETE is added.+recursiveSelectThenDeleteCteSelect :: SqlSelect Postgres (CteRowT Identity)+recursiveSelectThenDeleteCteSelect = Pg.pgSelectWithTopLevel $ do+ recursiveIds <- Pg.pgToTopLevel $ mdo+ ids <- Pg.pgSelecting $+ pure (as_ @Int32 (val_ 1)) `unionAll_` do+ previousId <- reuse ids+ guard_ (previousId <. val_ 2)+ pure (previousId + 1)+ pure ids++ deleted <- Pg.cteDeleteReturning+ (dbCteRows cteDb)+ (\row -> exists_ $ do+ recursiveId <- reuse recursiveIds+ guard_ (cteId row ==. recursiveId)+ pure recursiveId)+ id++ pure (reuse deleted)++-- Empty INSERT values and identity UPDATE assignments do not produce SQL.+-- Their wrappers return Nothing, leaving pgSelectWithTopLevel to render the+-- final query without an empty WITH clause.+emptyDataModifyingCteSelect :: SqlSelect Postgres Int32+emptyDataModifyingCteSelect = Pg.pgSelectWithTopLevel $ do+ inserted <- Pg.cteInsertReturning+ (dbCteRows cteDb)+ SqlInsertValuesEmpty+ Pg.onConflictDefault+ id+ updated <- Pg.cteUpdateReturning+ (dbCteRows cteDb)+ (const mempty)+ (const (val_ True))+ id+ case (inserted, updated) of+ (Nothing, Nothing) -> pure finalQuery+ _ -> error "Expected empty INSERT and UPDATE CTEs"+ where+ finalQuery :: Q Postgres CteDb QBaseScope (QExpr Postgres QBaseScope Int32)+ finalQuery = pure (val_ 1)++-- The portable builder reaches PostgreSQL through the SQL99-shaped compatibility+-- instance. Each input table row contributes one row to the reusable+-- degree-zero relation even though the projection contains no values.+emptySelectProjection :: SqlSelect Postgres (EmptyCteT Identity)+emptySelectProjection = selectWith $ do+ rows <- selecting $ do+ _ <- all_ (dbCteRows cteDb)+ pure (EmptyCte :: EmptyCteT (QExpr Postgres CTE.QAnyScope))+ pure (reuse rows)++-- The native SELECT path additionally carries PostgreSQL's materialization+-- policy. Its logical result is identical for all three policies.+emptyNativeSelectProjection+ :: Pg.PgCteMaterialization+ -> SqlSelect Postgres (EmptyCteT Identity)+emptyNativeSelectProjection materialization = Pg.pgSelectWithTopLevel $ do+ rows <- Pg.pgSelectingWith materialization $ do+ _ <- all_ (dbCteRows cteDb)+ pure (EmptyCte :: EmptyCteT (QExpr Postgres CTE.QAnyScope))+ pure (reuse rows)++-- SELECT CTEs remain nestable when their relation has degree zero.+nestedEmptySelectProjection :: SqlSelect Postgres (EmptyCteT Identity)+nestedEmptySelectProjection = select $ Pg.pgSelectWithNested $ do+ rows <- Pg.pgSelecting $ do+ _ <- all_ (dbCteRows cteDb)+ pure (EmptyCte :: EmptyCteT (QExpr Postgres CTE.QAnyScope))+ pure (reuse rows)++-- COUNT(*) and EXISTS do not need a projected field, so they are natural+-- consumers of a degree-zero relation. Both references share one CTE body.+emptySelectSummary :: SqlSelect Postgres (Int32, Bool)+emptySelectSummary = Pg.pgSelectWithTopLevel $ do+ rows <- Pg.pgSelecting $ do+ _ <- all_ (dbCteRows cteDb)+ pure (EmptyCte :: EmptyCteT (QExpr Postgres CTE.QAnyScope))+ pure $ do+ count <- aggregate_ (const (as_ @Int32 countAll_)) (reuse rows)+ pure (count, exists_ (reuse rows))++-- The next three fixtures deliberately return no logical values. PostgreSQL's+-- RETURNING grammar is satisfied internally, while the outer SELECT exposes no+-- physical columns and retains one row per affected table row.+emptyInsertProjection+ :: [CteRowT Identity]+ -> SqlSelect Postgres (EmptyCteT Identity)+emptyInsertProjection values = Pg.pgSelectWithTopLevel $ do+ rows <- Pg.cteInsertReturning+ (dbCteRows cteDb)+ (insertValues values)+ Pg.onConflictDefault+ (const (EmptyCte :: EmptyCteT (QExpr Postgres PostgresInaccessible)))+ case rows of+ Just rows' -> pure (reuse rows')+ Nothing -> error "Expected non-empty INSERT values"++emptyUpdateProjection+ :: Int32+ -> Text+ -> SqlSelect Postgres (EmptyCteT Identity)+emptyUpdateProjection maximumId value = Pg.pgSelectWithTopLevel $ do+ rows <- Pg.cteUpdateReturning+ (dbCteRows cteDb)+ (\row -> cteValue row <-. val_ value)+ (\row -> cteId row <=. val_ maximumId)+ (const (EmptyCte :: EmptyCteT (QExpr Postgres PostgresInaccessible)))+ case rows of+ Just rows' -> pure (reuse rows')+ Nothing -> error "Expected a non-identity UPDATE"++emptyDeleteProjection+ :: Int32+ -> SqlSelect Postgres (EmptyCteT Identity)+emptyDeleteProjection minimumId = Pg.pgSelectWithTopLevel $ do+ rows <- Pg.cteDeleteReturning+ (dbCteRows cteDb)+ (\row -> cteId row >=. val_ minimumId)+ (const (EmptyCte :: EmptyCteT (QExpr Postgres PostgresInaccessible)))+ pure (reuse rows)++-- Two references to the same modifying CTE must multiply its row cardinality,+-- not execute the DELETE twice or expose its private sentinel.+repeatedEmptyDeleteProjection :: SqlSelect Postgres (EmptyCteT Identity)+repeatedEmptyDeleteProjection = Pg.pgSelectWithTopLevel $ do+ rows <- Pg.cteDeleteReturning+ (dbCteRows cteDb)+ (const (val_ True))+ (const (EmptyCte :: EmptyCteT (QExpr Postgres PostgresInaccessible)))+ pure $ do+ _ <- reuse rows+ _ <- reuse rows+ pure (EmptyCte :: EmptyCteT (QExpr Postgres QBaseScope))++-- Aggregating the reusable DELETE result verifies that the private physical+-- sentinel supplies relational rows without becoming a Beam expression.+emptyDeleteSummary :: SqlSelect Postgres (Int32, Bool)+emptyDeleteSummary = Pg.pgSelectWithTopLevel $ do+ rows <- Pg.cteDeleteReturning+ (dbCteRows cteDb)+ (const (val_ True))+ (const (EmptyCte :: EmptyCteT (QExpr Postgres PostgresInaccessible)))+ pure $ do+ count <- aggregate_ (const (as_ @Int32 countAll_)) (reuse rows)+ pure (count, exists_ (reuse rows))++-- Copy one row selected by the CTE into a new row. insertFrom is what exposes+-- the reusable query to the terminal INSERT source.+insertWithStatement :: SqlInsert Postgres CteRowT+insertWithStatement = Pg.pgInsertWith $ do+ source <- Pg.pgSelecting $ do+ row <- all_ (dbCteRows cteDb)+ guard_ (cteId row ==. val_ 1)+ pure row+ pure $ Pg.insert+ (dbCteRows cteDb)+ (insertFrom $ do+ row <- reuse source+ pure (CteRow (cteId row + 1) (val_ "inserted-with")))+ Pg.onConflictDefault++-- Select the target key independently, then reference it through EXISTS in+-- the terminal UPDATE predicate.+updateWithStatement :: SqlUpdate Postgres CteRowT+updateWithStatement = Pg.pgUpdateWith $ do+ targets <- Pg.pgSelecting $ do+ row <- all_ (dbCteRows cteDb)+ guard_ (cteId row ==. val_ 3)+ pure (cteId row)+ pure $ update+ (dbCteRows cteDb)+ (\row -> cteValue row <-. val_ "updated-with")+ (\row -> exists_ $ do+ targetId <- reuse targets+ guard_ (cteId row ==. targetId)+ pure targetId)++-- The DELETE form uses the same reusable-key pattern as UPDATE, exercising+-- the third terminal syntax wrapper.+deleteWithStatement :: SqlDelete Postgres CteRowT+deleteWithStatement = Pg.pgDeleteWith $ do+ targets <- Pg.pgSelecting $ do+ row <- all_ (dbCteRows cteDb)+ guard_ (cteId row ==. val_ 4)+ pure (cteId row)+ pure $ delete (dbCteRows cteDb) $ \row -> exists_ $ do+ targetId <- reuse targets+ guard_ (cteId row ==. targetId)+ pure targetId++-- Recursion is completed while the block is still nested-safe. The terminal+-- INSERT then consumes the recursive result at top level.+recursiveInsertWithStatement :: SqlInsert Postgres CteRowT+recursiveInsertWithStatement = Pg.pgInsertWith recursiveInsertWith++recursiveInsertWith+ :: Pg.PgWith CteDb 'Pg.PgCteNestedAllowed (SqlInsert Postgres CteRowT)+recursiveInsertWith = mdo+ ids <- Pg.pgSelecting $+ pure (as_ @Int32 (val_ 1)) `unionAll_` do+ previousId <- reuse ids+ guard_ (previousId <. val_ 2)+ pure (previousId + 1)+ pure $ Pg.insert+ (dbCteRows cteDb)+ (insertFrom $ do+ rowId <- reuse ids+ pure (CteRow rowId (val_ "recursive")))+ Pg.onConflictDefault++-- Adding a modifying CTE fixes the block to PgCteTopLevelOnly. pgDeleteWith is+-- a top-level consumer, so this remains well-typed.+topLevelOnlyDeleteWithStatement :: SqlDelete Postgres CteRowT+topLevelOnlyDeleteWithStatement = Pg.pgDeleteWith $ do+ _ <- Pg.cteDeleteReturning+ (dbCteRows cteDb)+ (\row -> cteId row ==. val_ 99)+ id+ pure $ delete+ (dbCteRows cteDb)+ (\row -> cteId row ==. val_ 100)++emptyInsertWithStatement :: SqlInsert Postgres CteRowT+emptyInsertWithStatement = Pg.pgInsertWith $ do+ _ <- Pg.pgSelecting $ all_ (dbCteRows cteDb)+ pure $ Pg.insert+ (dbCteRows cteDb)+ SqlInsertValuesEmpty+ Pg.onConflictDefault++identityUpdateWithStatement :: SqlUpdate Postgres CteRowT+identityUpdateWithStatement = Pg.pgUpdateWith $ do+ _ <- Pg.pgSelecting $ all_ (dbCteRows cteDb)+ pure $ update+ (dbCteRows cteDb)+ (const mempty)+ (const (val_ True))++assertWithTerminal+ :: String+ -> Maybe String+ -> Assertion+assertWithTerminal terminal rendered = do+ sql <- requireRenderedStatement rendered+ assertBool "starts with WITH" ("WITH " `isPrefixOf` sql)+ assertBool ("renders terminal " ++ terminal) ((" " ++ terminal) `isInfixOf` sql)++requireRenderedStatement+ :: Maybe String+ -> IO String+requireRenderedStatement rendered =+ case rendered of+ Nothing -> assertFailure "expected a PostgreSQL statement" >> pure ""+ Just sql -> pure sql++renderInsert :: SqlInsert Postgres table -> Maybe String+renderInsert SqlInsertNoRows = Nothing+renderInsert (SqlInsert _ (PgInsertSyntax syntax)) =+ Just (BL.unpack (pgRenderSyntaxScript syntax))++renderUpdate :: SqlUpdate Postgres table -> Maybe String+renderUpdate SqlIdentityUpdate = Nothing+renderUpdate (SqlUpdate _ (PgUpdateSyntax syntax)) =+ Just (BL.unpack (pgRenderSyntaxScript syntax))++renderDelete :: SqlDelete Postgres table -> Maybe String+renderDelete (SqlDelete _ (PgDeleteSyntax syntax)) =+ Just (BL.unpack (pgRenderSyntaxScript syntax))++assertReturning :: String -> Maybe String -> Assertion+assertReturning command rendered = do+ sql <- requireRenderedStatement rendered+ assertBool (command ++ " retains its WITH prefix") ("WITH " `isPrefixOf` sql)+ assertBool (command ++ " renders RETURNING") (" RETURNING " `isInfixOf` sql)++renderInsertReturning :: Pg.PgInsertReturning a -> Maybe String+renderInsertReturning Pg.PgInsertReturningEmpty = Nothing+renderInsertReturning (Pg.PgInsertReturning syntax) =+ Just (BL.unpack (pgRenderSyntaxScript syntax))++renderUpdateReturning :: Pg.PgUpdateReturning a -> Maybe String+renderUpdateReturning Pg.PgUpdateReturningEmpty = Nothing+renderUpdateReturning (Pg.PgUpdateReturning syntax) =+ Just (BL.unpack (pgRenderSyntaxScript syntax))++renderDeleteReturning :: Pg.PgDeleteReturning a -> Maybe String+renderDeleteReturning (Pg.PgDeleteReturning syntax) =+ Just (BL.unpack (pgRenderSyntaxScript syntax))++renderSelect :: SqlSelect Postgres a -> String+renderSelect = BL.unpack . renderSelectBytes++renderSelectBytes :: SqlSelect Postgres a -> BL.ByteString+renderSelectBytes (SqlSelect (PgSelectSyntax syntax)) =+ pgRenderSyntaxScript syntax
+ test/Database/Beam/Postgres/Test/CTENegative.hs view
@@ -0,0 +1,180 @@+{-# OPTIONS_GHC -fdefer-type-errors -Wno-deferred-type-errors #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE RecursiveDo #-}+{-# LANGUAGE StandaloneDeriving #-}++-- This module deliberately contains expressions which must not type-check.+-- Deferred type errors are isolated here so the positive CTE tests retain+-- normal, strict type checking.+module Database.Beam.Postgres.Test.CTENegative+ ( invalidNestedDelete+ , invalidNestedInsert+ , invalidNestedUpdate+ , invalidNestedSelectThenDelete+ , invalidNestedDeleteThenSelect+ , invalidNestedEmptyInsert+ , invalidNestedIdentityUpdate+ , invalidNestedSideEffectDelete+ , invalidCoercedPlacement+ , invalidRecursiveInsert+ , invalidReuseSideEffect+ ) where++import qualified Data.Coerce as Coerce+import Data.Int (Int32)+import Data.Text (Text)++import Database.Beam+import Database.Beam.Postgres+import qualified Database.Beam.Postgres.Full as Pg+import qualified Database.Beam.Query.CTE as CTE++data NegativeCteRowT f = NegativeCteRow+ { negativeCteId :: C f Int32+ , negativeCteValue :: C f Text+ } deriving (Generic, Beamable)++deriving instance Show (NegativeCteRowT Identity)+deriving instance Eq (NegativeCteRowT Identity)++instance Table NegativeCteRowT where+ data PrimaryKey NegativeCteRowT f = NegativeCteRowKey (C f Int32)+ deriving (Generic, Beamable)+ primaryKey = NegativeCteRowKey . negativeCteId++newtype NegativeCteDb entity = NegativeCteDb+ { negativeCteRows :: entity (TableEntity NegativeCteRowT)+ } deriving (Generic, Database Postgres)++negativeCteDb :: DatabaseSettings Postgres NegativeCteDb+negativeCteDb = defaultDbSettings++-- Each of the following three expressions attempts to put a modifying CTE in+-- pgSelectWithNested. They must fail with PgCteTopLevelOnly versus+-- PgCteNestedAllowed,+-- independently of which data-modifying command produced the CTE.+invalidNestedDelete :: SqlSelect Postgres (NegativeCteRowT Identity)+invalidNestedDelete = select $ Pg.pgSelectWithNested $ do+ deleted <- topLevelDeleteCte+ pure (reuse deleted)++invalidNestedInsert :: SqlSelect Postgres (NegativeCteRowT Identity)+invalidNestedInsert = select $ Pg.pgSelectWithNested $ do+ inserted <- Pg.cteInsertReturning+ (negativeCteRows negativeCteDb)+ (insertValues [NegativeCteRow 2 "inserted"])+ Pg.onConflictDefault+ id+ case inserted of+ Nothing -> pure $ all_ (negativeCteRows negativeCteDb)+ Just inserted' -> pure (reuse inserted')++invalidNestedUpdate :: SqlSelect Postgres (NegativeCteRowT Identity)+invalidNestedUpdate = select $ Pg.pgSelectWithNested $ do+ updated <- Pg.cteUpdateReturning+ (negativeCteRows negativeCteDb)+ (\row -> negativeCteValue row <-. val_ "updated")+ (\row -> negativeCteId row ==. val_ 1)+ id+ case updated of+ Nothing -> pure $ all_ (negativeCteRows negativeCteDb)+ Just updated' -> pure (reuse updated')++-- Placement is a property of the whole With block. Reordering a normal SELECT+-- CTE around the DELETE must not weaken the top-level-only requirement.+invalidNestedSelectThenDelete :: SqlSelect Postgres (NegativeCteRowT Identity)+invalidNestedSelectThenDelete = select $ Pg.pgSelectWithNested $ do+ _ <- nestedSelectCte+ deleted <- topLevelDeleteCte+ pure (reuse deleted)++invalidNestedDeleteThenSelect :: SqlSelect Postgres (NegativeCteRowT Identity)+invalidNestedDeleteThenSelect = select $ Pg.pgSelectWithNested $ do+ deleted <- topLevelDeleteCte+ _ <- nestedSelectCte+ pure (reuse deleted)++-- The result is conservatively top-level-only even when the supplied values or+-- assignments make the INSERT or UPDATE a no-op. The placement index cannot+-- vary with that value-level outcome.+invalidNestedEmptyInsert :: SqlSelect Postgres (NegativeCteRowT Identity)+invalidNestedEmptyInsert = select $ Pg.pgSelectWithNested $ do+ inserted <- Pg.cteInsertReturning+ (negativeCteRows negativeCteDb)+ SqlInsertValuesEmpty+ Pg.onConflictDefault+ id+ case inserted of+ Nothing -> pure $ all_ (negativeCteRows negativeCteDb)+ Just inserted' -> pure (reuse inserted')++invalidNestedIdentityUpdate :: SqlSelect Postgres (NegativeCteRowT Identity)+invalidNestedIdentityUpdate = select $ Pg.pgSelectWithNested $ do+ updated <- Pg.cteUpdateReturning+ (negativeCteRows negativeCteDb)+ (const mempty)+ (const (val_ True))+ id+ case updated of+ Nothing -> pure $ all_ (negativeCteRows negativeCteDb)+ Just updated' -> pure (reuse updated')++-- A no-RETURNING modifying CTE has the same top-level placement requirement as+-- its returning counterpart, even though it exposes no relation.+invalidNestedSideEffectDelete :: SqlSelect Postgres (NegativeCteRowT Identity)+invalidNestedSideEffectDelete = select $ Pg.pgSelectWithNested $ do+ Pg.cteDelete+ (negativeCteRows negativeCteDb)+ (\row -> negativeCteId row ==. val_ 1)+ pure $ all_ (negativeCteRows negativeCteDb)++-- PgWith has nominal roles and an abstract constructor, so Data.Coerce cannot+-- be used to relabel a top-level-only block as nested-safe.+invalidCoercedPlacement :: SqlSelect Postgres (NegativeCteRowT Identity)+invalidCoercedPlacement = select $ Pg.pgSelectWithNested $ coercePlacement $ do+ deleted <- topLevelDeleteCte+ pure (reuse deleted)++-- MonadFix exists only for PgCteNestedAllowed. This prevents an INSERT CTE from+-- reading its own RETURNING rows recursively, which PostgreSQL rejects.+invalidRecursiveInsert :: SqlSelect Postgres (NegativeCteRowT Identity)+invalidRecursiveInsert = Pg.pgSelectWithTopLevel $ mdo+ ~(Just inserted) <- Pg.cteInsertReturning+ (negativeCteRows negativeCteDb)+ (insertFrom (reuse inserted))+ Pg.onConflictDefault+ id+ pure (reuse inserted)++-- Side-effect-only CTEs deliberately return unit because a DML statement+-- without RETURNING forms no temporary relation in PostgreSQL.+invalidReuseSideEffect :: SqlSelect Postgres (NegativeCteRowT Identity)+invalidReuseSideEffect = Pg.pgSelectWithTopLevel $ do+ deleted <- Pg.cteDelete+ (negativeCteRows negativeCteDb)+ (\row -> negativeCteId row ==. val_ 1)+ let impossible+ :: ReusableQ Postgres NegativeCteDb+ (NegativeCteRowT (QExpr Postgres CTE.QAnyScope))+ impossible = deleted+ pure (reuse impossible)++coercePlacement+ :: Pg.PgWith NegativeCteDb 'Pg.PgCteTopLevelOnly a+ -> Pg.PgWith NegativeCteDb 'Pg.PgCteNestedAllowed a+coercePlacement = Coerce.coerce++nestedSelectCte+ :: Pg.PgWith NegativeCteDb placement+ (ReusableQ Postgres NegativeCteDb+ (NegativeCteRowT (QExpr Postgres CTE.QAnyScope)))+nestedSelectCte = Pg.pgSelecting $ all_ (negativeCteRows negativeCteDb)++topLevelDeleteCte+ :: Pg.PgWith NegativeCteDb 'Pg.PgCteTopLevelOnly+ (ReusableQ Postgres NegativeCteDb+ (NegativeCteRowT (QExpr Postgres CTE.QAnyScope)))+topLevelDeleteCte = Pg.cteDeleteReturning+ (negativeCteRows negativeCteDb)+ (\row -> negativeCteId row ==. val_ 1)+ id
+ test/Database/Beam/Postgres/Test/Copy.hs view
@@ -0,0 +1,444 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-}++module Database.Beam.Postgres.Test.Copy (tests) where++import Control.Monad (void)+import Control.Monad.IO.Class (liftIO)+import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import Data.IORef (modifyIORef', newIORef, readIORef, writeIORef)+import Data.Int (Int32)+import Data.List (sort)+import Data.Text (Text)+import qualified Data.Text as T+import Database.Beam+import Database.Beam.Backend.SQL.BeamExtensions+ ( MonadBeamCopyFrom (..),+ MonadBeamCopyFromStream (..),+ MonadBeamCopyTo (..),+ MonadBeamCopyToStream (..),+ copySelectTo,+ copySelectToStream,+ copyTableFrom,+ copyTableFromStream,+ copyTableTo,+ copyTableToStream,+ )+import Database.Beam.Postgres+import Database.Beam.Postgres.Test (withTestPostgres)+import Database.PostgreSQL.Simple (Connection, execute_)+import Hedgehog ((===))+import qualified Hedgehog+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (Assertion, assertBool, assertEqual, testCase)++tests :: IO ByteString -> TestTree+tests getConn =+ testGroup+ "COPY statements"+ [ testGroup+ "COPY ... TO / ... FROM round-trip"+ [ testRoundtripCsvAllColumns getConn,+ testRoundtripCsvMultiColumnProjection getConn,+ testRoundtripCsvSingleColumnProjection getConn,+ testRoundtripCsvFromSelect getConn+ ],+ testGroup+ "options"+ [ testCustomDelimiter getConn,+ testNoHeader getConn,+ testTextFormat getConn+ ],+ testGroup+ "streaming COPY"+ [ testStreamRoundtripCsv getConn,+ testStreamFromSelect getConn+ ],+ testGroup+ "property-based round-trip"+ [ testPropCsvRoundtrip getConn,+ testPropTextRoundtrip getConn+ ]+ ]++-- | The full table is exported to a CSV, the table is truncated, and the CSV+-- is re-imported. The final rows must match the original ones.+testRoundtripCsvAllColumns :: IO ByteString -> TestTree+testRoundtripCsvAllColumns getConn =+ testCopy getConn "copy_all_columns_csv" "/tmp/copy_all_columns.csv" $ \conn path -> do+ seedWidgets conn widgetData+ runBeamPostgres conn $ do+ runCopyTo $ copyTableTo (_dbWidgets testDb) id (copyToCSV path)+ truncateWidgets conn+ runBeamPostgres conn $ do+ runCopyFrom $ copyTableFrom (_dbWidgets testDb) id (copyFromCSV path)+ rows <- queryAllWidgets conn+ assertEqual "round-tripped rows match seed" widgetData rows++-- | Project a subset of columns; the unprojected column gets its DEFAULT on+-- import.+testRoundtripCsvMultiColumnProjection :: IO ByteString -> TestTree+testRoundtripCsvMultiColumnProjection getConn =+ testCopy getConn "copy_multi_column_csv" "/tmp/copy_multi_column.csv" $ \conn path -> do+ seedWidgets conn widgetData+ runBeamPostgres conn $ do+ runCopyTo $+ copyTableTo+ (_dbWidgets testDb)+ (\w -> (_widgetId w, _widgetName w))+ (copyToCSV path)+ truncateWidgets conn+ runBeamPostgres conn $ do+ runCopyFrom $+ copyTableFrom+ (_dbWidgets testDb)+ (\w -> (_widgetId w, _widgetName w))+ (copyFromCSV path)+ rows <- queryAllWidgets conn+ -- 'price' was not in the projection, so it gets its DEFAULT (0).+ let expected = [w {_widgetPrice = 0} | w <- widgetData]+ assertEqual "id+name round-tripped, price defaulted" expected rows++-- | Single-column projection.+testRoundtripCsvSingleColumnProjection :: IO ByteString -> TestTree+testRoundtripCsvSingleColumnProjection getConn =+ testCopy getConn "copy_single_column_csv" "/tmp/copy_single_column.csv" $ \conn path -> do+ seedWidgets conn widgetData+ runBeamPostgres conn $ do+ runCopyTo $ copyTableTo (_dbWidgets testDb) _widgetId (copyToCSV path)+ truncateWidgets conn+ runBeamPostgres conn $ do+ runCopyFrom $ copyTableFrom (_dbWidgets testDb) _widgetId (copyFromCSV path)+ rows <- queryAllWidgets conn+ let expected = [w {_widgetName = "", _widgetPrice = 0} | w <- widgetData]+ assertEqual "id-only round-tripped, name+price defaulted" expected rows++-- | Use copySelectTo with a filtered query, then COPY FROM the result back+-- into the table.+testRoundtripCsvFromSelect :: IO ByteString -> TestTree+testRoundtripCsvFromSelect getConn =+ testCopy getConn "copy_select_csv" "/tmp/copy_select.csv" $ \conn path -> do+ seedWidgets conn widgetData+ runBeamPostgres conn $ do+ runCopyTo $+ copySelectTo+ ( select $ do+ w <- all_ (_dbWidgets testDb)+ guard_ (_widgetPrice w >. val_ 4.0)+ pure w+ )+ (copyToCSV path)+ truncateWidgets conn+ runBeamPostgres conn $ do+ runCopyFrom $ copyTableFrom (_dbWidgets testDb) id (copyFromCSV path)+ rows <- queryAllWidgets conn+ -- Only Widget (9.99) and Sprocket (4.5) have price > 4.0; Cog is excluded.+ let expected = sort [w | w <- widgetData, _widgetPrice w > 4.0]+ assertEqual "select-filtered round-trip" expected rows++-- | Use a custom delimiter on both sides of the round-trip.+testCustomDelimiter :: IO ByteString -> TestTree+testCustomDelimiter getConn =+ testCopy getConn "copy_custom_delim_csv" "/tmp/copy_custom_delim.csv" $ \conn path -> do+ seedWidgets conn widgetData+ let toOpts = copyToCSVWith path defaultPgCSVCopyToOptions {pgCsvCopyToDelimiter = Just '|'}+ fromOpts = copyFromCSVWith path defaultPgCSVCopyFromOptions {pgCsvCopyFromDelimiter = Just '|'}+ runBeamPostgres conn $ do+ runCopyTo $ copyTableTo (_dbWidgets testDb) id toOpts+ truncateWidgets conn+ runBeamPostgres conn $ do+ runCopyFrom $ copyTableFrom (_dbWidgets testDb) id fromOpts+ rows <- queryAllWidgets conn+ assertEqual "round-trip with '|' delimiter" widgetData rows++-- | Toggle HEADER off on TO and on on FROM; round-trip should still work+-- (as long as both sides agree).+testNoHeader :: IO ByteString -> TestTree+testNoHeader getConn =+ testCopy getConn "copy_no_header_csv" "/tmp/copy_no_header.csv" $ \conn path -> do+ seedWidgets conn widgetData+ let toOpts = copyToCSVWith path defaultPgCSVCopyToOptions {pgCsvCopyToHeader = Just False}+ fromOpts = copyFromCSVWith path defaultPgCSVCopyFromOptions {pgCsvCopyFromHeader = Just False}+ runBeamPostgres conn $ do+ runCopyTo $ copyTableTo (_dbWidgets testDb) id toOpts+ truncateWidgets conn+ runBeamPostgres conn $ do+ runCopyFrom $ copyTableFrom (_dbWidgets testDb) id fromOpts+ rows <- queryAllWidgets conn+ assertEqual "round-trip without header line" widgetData rows++-- | The 'text' format with custom delimiter, round-tripped.+testTextFormat :: IO ByteString -> TestTree+testTextFormat getConn =+ testCopy getConn "copy_text_format" "/tmp/copy_text.txt" $ \conn path -> do+ seedWidgets conn widgetData+ let toOpts = copyToTextWith path defaultPgTextCopyToOptions {pgTextCopyToDelimiter = Just '\t'}+ fromOpts = copyFromTextWith path defaultPgTextCopyFromOptions {pgTextCopyFromDelimiter = Just '\t'}+ runBeamPostgres conn $ do+ runCopyTo $ copyTableTo (_dbWidgets testDb) id toOpts+ truncateWidgets conn+ runBeamPostgres conn $ do+ runCopyFrom $ copyTableFrom (_dbWidgets testDb) id fromOpts+ rows <- queryAllWidgets conn+ assertEqual "round-trip via text format" widgetData rows++-- | Round-trip widgets through streaming @COPY ... TO STDOUT@ then+-- @COPY ... FROM STDIN@. The bytes pass through the client connection only;+-- no server-side file is touched.+testStreamRoundtripCsv :: IO ByteString -> TestTree+testStreamRoundtripCsv getConn =+ testCopy getConn "stream_roundtrip_csv" "" $ \conn _ -> do+ seedWidgets conn widgetData+ -- Drain the stream into an IORef.+ chunksRef <- newIORef []+ runBeamPostgres conn $+ runCopyToStream+ (copyTableToStream (_dbWidgets testDb) id copyToCSVStream)+ (\chunk -> modifyIORef' chunksRef (chunk :))+ payload <- BS.concat . reverse <$> readIORef chunksRef+ assertBool "stream produced non-empty payload" (not (BS.null payload))+ -- Replay the captured bytes back into the table.+ truncateWidgets conn+ sourceRef <- newIORef (Just payload)+ runBeamPostgres conn $+ runCopyFromStream+ (copyTableFromStream (_dbWidgets testDb) id copyFromCSVStream)+ ( do+ mchunk <- readIORef sourceRef+ writeIORef sourceRef Nothing+ pure mchunk+ )+ rows <- queryAllWidgets conn+ assertEqual "round-tripped rows match seed" widgetData rows++-- | @COPY (SELECT ...) TO STDOUT@ via 'copySelectToStream'.+testStreamFromSelect :: IO ByteString -> TestTree+testStreamFromSelect getConn =+ testCopy getConn "stream_from_select" "" $ \conn _ -> do+ seedWidgets conn widgetData+ chunksRef <- newIORef []+ runBeamPostgres conn $+ runCopyToStream+ ( copySelectToStream+ ( select $ do+ w <- all_ (_dbWidgets testDb)+ guard_ (_widgetPrice w >. val_ 4.0)+ pure w+ )+ copyToCSVStream+ )+ (\chunk -> modifyIORef' chunksRef (chunk :))+ payload <- BS.concat . reverse <$> readIORef chunksRef+ -- The payload should mention the two widgets with price > 4.0 and not+ -- the one priced 1.25.+ assertBool "Widget present" ("Widget" `BS.isInfixOf` payload)+ assertBool "Sprocket present" ("Sprocket" `BS.isInfixOf` payload)+ assertBool "Cog absent" (not ("Cog" `BS.isInfixOf` payload))++testPropCsvRoundtrip :: IO ByteString -> TestTree+testPropCsvRoundtrip getConn =+ testCopy getConn "prop_csv_roundtrip" "/tmp/prop_csv.csv" $ \conn path -> do+ passes <-+ Hedgehog.check . Hedgehog.property $ do+ toOpts <- Hedgehog.forAll genCsvToOpts+ let fromOpts = matchedCsvFromOpts toOpts+ rows <-+ liftIO $+ roundtripWidgets conn $ \c -> do+ runBeamPostgres c $+ runCopyTo $+ copyTableTo (_dbWidgets testDb) id (copyToCSVWith path toOpts)+ truncateWidgets c+ runBeamPostgres c $+ runCopyFrom $+ copyTableFrom (_dbWidgets testDb) id (copyFromCSVWith path fromOpts)+ rows === widgetData+ assertBool "Hedgehog property failed" passes+ where+ genCsvToOpts = do+ delim <- Gen.maybe genDelimiterChar+ hdr <- Gen.maybe Gen.bool+ quote <- Gen.maybe genQuoteChar+ escape <- Gen.maybe genEscapeChar+ nullStr <- Gen.maybe genNullStr+ pure+ defaultPgCSVCopyToOptions+ { pgCsvCopyToDelimiter = delim,+ pgCsvCopyToHeader = hdr,+ pgCsvCopyToQuote = quote,+ pgCsvCopyToEscape = escape,+ pgCsvCopyToNullStr = nullStr+ }++ matchedCsvFromOpts :: PgCSVCopyToOptions -> PgCSVCopyFromOptions+ matchedCsvFromOpts o =+ defaultPgCSVCopyFromOptions+ { pgCsvCopyFromDelimiter = pgCsvCopyToDelimiter o,+ pgCsvCopyFromHeader = pgCsvCopyToHeader o,+ pgCsvCopyFromQuote = pgCsvCopyToQuote o,+ pgCsvCopyFromEscape = pgCsvCopyToEscape o,+ pgCsvCopyFromNullStr = pgCsvCopyToNullStr o+ }++testPropTextRoundtrip :: IO ByteString -> TestTree+testPropTextRoundtrip getConn =+ testCopy getConn "prop_text_roundtrip" "/tmp/prop_text.txt" $ \conn path -> do+ passes <-+ Hedgehog.check . Hedgehog.property $ do+ toOpts <- Hedgehog.forAll genTextToOpts+ let fromOpts = matchedTextFromOpts toOpts+ rows <-+ liftIO $+ roundtripWidgets conn $ \c -> do+ runBeamPostgres c $+ runCopyTo $+ copyTableTo (_dbWidgets testDb) id (copyToTextWith path toOpts)+ truncateWidgets c+ runBeamPostgres c $+ runCopyFrom $+ copyTableFrom (_dbWidgets testDb) id (copyFromTextWith path fromOpts)+ rows === widgetData+ assertBool "Hedgehog property failed" passes+ where+ genTextToOpts = do+ delim <- Gen.maybe genDelimiterChar+ hdr <- Gen.maybe Gen.bool+ -- Avoid generating a NULL string that contains the chosen delimiter.+ nullStr <- Gen.maybe (Gen.filter (not . T.any (== ',')) genNullStr)+ pure+ defaultPgTextCopyToOptions+ { pgTextCopyToDelimiter = delim,+ pgTextCopyToHeader = hdr,+ pgTextCopyToNullStr = nullStr+ }++ -- \| Mirror of 'matchedCsvFromOpts' for the @text@ format. 'pgTextCopyFromFreeze'+ -- is intentionally left at @Nothing@: PostgreSQL only accepts @FREEZE@ when+ -- the target table has not been touched in the current (sub)transaction, but+ -- our property test truncates before the FROM, which violates that+ -- precondition.+ matchedTextFromOpts :: PgTextCopyToOptions -> PgTextCopyFromOptions+ matchedTextFromOpts o =+ defaultPgTextCopyFromOptions+ { pgTextCopyFromDelimiter = pgTextCopyToDelimiter o,+ pgTextCopyFromHeader = pgTextCopyToHeader o,+ pgTextCopyFromNullStr = pgTextCopyToNullStr o+ }++-- Single-byte delimiters that never appear in 'widgetData'. Avoiding @.@+-- matters for the @text@ format because the data contains floating-point+-- prices like @9.99@.+genDelimiterChar :: Hedgehog.Gen Char+genDelimiterChar = Gen.element [',', ';', '|', '\t']++genQuoteChar :: Hedgehog.Gen Char+genQuoteChar = Gen.element ['"', '\'']++genEscapeChar :: Hedgehog.Gen Char+genEscapeChar = Gen.element ['"', '\'', '\\']++genNullStr :: Hedgehog.Gen Text+genNullStr = Gen.element ["NULL", "~~~"]++roundtripWidgets :: Connection -> (Connection -> IO ()) -> IO [Widget]+roundtripWidgets conn action = do+ truncateWidgets conn+ seedWidgets conn widgetData+ action conn+ queryAllWidgets conn++testCopy ::+ IO ByteString ->+ String ->+ -- | Server-side file path inside the Postgres container.+ FilePath ->+ (Connection -> FilePath -> Assertion) ->+ TestTree+testCopy getConn name path action = testCase name $+ withTestPostgres name getConn $ \conn -> do+ createWidgetsTable conn+ action conn path++queryAllWidgets :: Connection -> IO [Widget]+queryAllWidgets conn =+ runBeamPostgres conn $+ runSelectReturningList $+ select $+ orderBy_ (asc_ . _widgetId) $+ all_ (_dbWidgets testDb)++createWidgetsTable :: Connection -> IO ()+createWidgetsTable conn =+ void $+ execute_+ conn+ "CREATE TABLE widgets (\+ \ id INTEGER PRIMARY KEY,\+ \ name TEXT NOT NULL DEFAULT '',\+ \ price DOUBLE PRECISION NOT NULL DEFAULT 0\+ \)"++truncateWidgets :: Connection -> IO ()+truncateWidgets conn = void $ execute_ conn "TRUNCATE TABLE widgets"++seedWidgets :: Connection -> [Widget] -> IO ()+seedWidgets conn widgets =+ runBeamPostgres conn $+ runInsert $+ insert (_dbWidgets testDb) (insertValues widgets)++widgetData :: [Widget]+widgetData =+ [ Widget 1 "Widget" 9.99,+ Widget 2 "Sprocket" 4.50,+ Widget 3 "Cog" 1.25+ ]++data WidgetT f = Widget+ { _widgetId :: Columnar f Int32,+ _widgetName :: Columnar f Text,+ _widgetPrice :: Columnar f Double+ }+ deriving (Generic)++type Widget = WidgetT Identity++deriving instance Show Widget++deriving instance Eq Widget++deriving instance Ord Widget++instance Beamable WidgetT++instance Table WidgetT where+ data PrimaryKey WidgetT f = WidgetId (Columnar f Int32)+ deriving (Generic)+ primaryKey = WidgetId . _widgetId++instance Beamable (PrimaryKey WidgetT)++newtype TestDB f = TestDB+ { _dbWidgets :: f (TableEntity WidgetT)+ }+ deriving (Generic, Database be)++testDb :: DatabaseSettings Postgres TestDB+testDb =+ defaultDbSettings+ `withDbModification` dbModification+ { _dbWidgets =+ modifyTableFields+ tableModification+ { _widgetId = "id",+ _widgetName = "name",+ _widgetPrice = "price"+ }+ }
test/Database/Beam/Postgres/Test/DataTypes.hs view
@@ -3,10 +3,10 @@ module Database.Beam.Postgres.Test.DataTypes where import Database.Beam+import Database.Beam.Backend.SQL.BeamExtensions+import Database.Beam.Migrate import Database.Beam.Postgres import Database.Beam.Postgres.Test-import Database.Beam.Migrate-import Database.Beam.Backend.SQL.BeamExtensions import Control.Exception (SomeException(..), handle) @@ -141,15 +141,15 @@ -- | Regression test for <https://github.com/haskell-beam/beam/issues/700> errorOnLiteralDoubles :: IO ByteString -> TestTree errorOnLiteralDoubles pgConn =- testCase "Literal `Double`s are correctly specified as SQL `DOUBLE` (#700)" $ + testCase "Literal `Double`s are correctly specified as SQL `DOUBLE` (#700)" $ withTestPostgres "db_failures" pgConn $ \conn -> do- results <- runBeamPostgres conn $ - runSelectReturningList $ - select $ + results <- runBeamPostgres conn $+ runSelectReturningList $+ select $ query- + results @?= [(99 :: Int32, 1.0 :: Double)]- + where -- We need to provide a db for type-checking, but it will not be used query :: Q Postgres RealDb s (QExpr Postgres s Int32, QExpr Postgres s Double)
test/Database/Beam/Postgres/Test/Marshal.hs view
@@ -52,7 +52,7 @@ (PgPoint (max x1 x2) (max y1 y2))) arrayGen :: Hedgehog.Gen a -> Hedgehog.Gen (Vector.Vector a)-arrayGen = fmap Vector.fromList +arrayGen = fmap Vector.fromList . Gen.list (Range.linear 0 5) -- small arrays == quick tests boxCmp :: PgBox -> PgBox -> Bool@@ -100,8 +100,8 @@ -- Arrays --- -- Testing lots of element types for arrays is important, because - -- the mapping between array Oid and element Oid is not type + -- Testing lots of element types for arrays is important, because+ -- the mapping between array Oid and element Oid is not type -- safe, and hence error-prone. , marshalTest (arrayGen textGen) postgresConn , marshalTest (arrayGen (Gen.double (Range.exponentialFloat 0 1e40))) postgresConn
test/Database/Beam/Postgres/Test/Select.hs view
@@ -5,6 +5,7 @@ import Data.Aeson import Data.ByteString (ByteString)+import Data.List.NonEmpty (NonEmpty(..)) import Data.Int import Data.List (sort) import qualified Data.Text as T@@ -164,7 +165,7 @@ pgCreateExtension @UuidOssp let ext = getPgExtension $ _uuidOssp $ unCheckDatabase db runSelectReturningList $ select $ do- v <- values_ [val_ nil]+ v <- values_ (val_ nil :| []) return $ pgUuidGenerateV5 ext v "" assertEqual "result" [V5.generateNamed nil []] result
+ test/Database/Beam/Postgres/Test/Select/PgNubBy.hs view
@@ -0,0 +1,119 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE StandaloneDeriving #-}++module Database.Beam.Postgres.Test.Select.PgNubBy (tests) where++import Control.Monad (void)+import Data.ByteString (ByteString)+import Data.Int (Int32)+import Data.Text (Text)+import Data.Time.Calendar (Day, fromGregorian)+import Database.Beam+import Database.Beam.Migrate (defaultMigratableDbSettings)+import Database.Beam.Migrate.Simple (autoMigrate)+import Database.Beam.Postgres+import Database.Beam.Postgres.Migrate (migrationBackend)+import Database.Beam.Postgres.Test (withTestPostgres)+import Test.Tasty+import Test.Tasty.HUnit++tests :: IO ByteString -> TestTree+tests getConn =+ testGroup+ "pgNubBy_ / nub_ with window functions (issue #746)"+ [ testPgNubByWithLead getConn,+ testNubWithLead getConn+ ]++-- Reproducer for issue #746+testPgNubByWithLead :: IO ByteString -> TestTree+testPgNubByWithLead getConn = testCase "pgNubBy_ feeding lead1_" $+ withTestPostgres "issue_746_pg_nub_by" getConn $ \conn -> do+ setupDb conn+ results <-+ runBeamPostgres conn $+ runSelectReturningList $+ select $+ withWindow_+ (\vf -> frame_ noPartition_ (orderPartitionBy_ (asc_ vf)) noBounds_)+ (\vf w -> (vf, lead1_ vf `over_` w))+ (pgNubBy_ id (validFrom <$> all_ (persons db)))++ let expected =+ [ (day 2025 1 1, Just (day 2025 1 2)),+ (day 2025 1 2, Just (day 2025 1 3)),+ (day 2025 1 3, Nothing)+ ]+ assertEqual "lead1_ over pgNubBy_ should pair each distinct date with the next" expected results++-- Reproducer for issue #746 with @nub_@+testNubWithLead :: IO ByteString -> TestTree+testNubWithLead getConn = testCase "nub_ feeding lead1_" $+ withTestPostgres "issue_746_nub" getConn $ \conn -> do+ setupDb conn+ results <-+ runBeamPostgres conn $+ runSelectReturningList $+ select $+ withWindow_+ (\vf -> frame_ noPartition_ (orderPartitionBy_ (asc_ vf)) noBounds_)+ (\vf w -> (vf, lead1_ vf `over_` w))+ (nub_ (validFrom <$> all_ (persons db)))++ let expected =+ [ (day 2025 1 1, Just (day 2025 1 2)),+ (day 2025 1 2, Just (day 2025 1 3)),+ (day 2025 1 3, Nothing)+ ]+ assertEqual "lead1_ over nub_ should pair each distinct date with the next" expected results++data PersonT f = Person+ { name :: C f Text,+ validFrom :: C f Day,+ idx :: C f Int32+ }+ deriving (Generic)++type Person = PersonT Identity++deriving instance Show Person++deriving instance Eq Person++instance Beamable PersonT++instance Table PersonT where+ data PrimaryKey PersonT f = PersonKey (C f Text)+ deriving stock (Generic)+ deriving anyclass (Beamable)++ primaryKey Person {name} = PersonKey name++newtype Db f = Db+ { persons :: f (TableEntity PersonT)+ }+ deriving (Generic)++instance Database Postgres Db++db :: DatabaseSettings Postgres Db+db = defaultDbSettings++day :: Integer -> Int -> Int -> Day+day = fromGregorian++seedRows :: [Person]+seedRows =+ [ Person "A" (day 2025 1 1) 1,+ Person "B" (day 2025 1 1) 1,+ Person "C" (day 2025 1 2) 2,+ Person "D" (day 2025 1 2) 2,+ Person "E" (day 2025 1 3) 3,+ Person "F" (day 2025 1 3) 3+ ]++setupDb :: Connection -> IO ()+setupDb conn = runBeamPostgres conn $ do+ void $ autoMigrate migrationBackend (defaultMigratableDbSettings @Postgres @Db)+ runInsert $ insert (persons db) $ insertValues seedRows
+ test/Database/Beam/Postgres/Test/Windowing.hs view
@@ -0,0 +1,221 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE StandaloneDeriving #-}++module Database.Beam.Postgres.Test.Windowing (tests) where++import Database.Beam+import Database.Beam.Backend.SQL.BeamExtensions+import Database.Beam.Migrate+import Database.Beam.Migrate.Simple (autoMigrate)+import Database.Beam.Postgres+import Database.Beam.Postgres.Migrate (migrationBackend)+import Database.Beam.Postgres.Test++import Control.Exception (SomeException (..), handle)++import Data.ByteString (ByteString)+import Data.Int+import Data.Text (Text)++import Control.Monad (void)+import Test.Tasty+import Test.Tasty.HUnit++tests :: IO ByteString -> TestTree+tests postgresConn =+ testGroup+ "Windowing unit tests"+ [ testLead1 postgresConn+ , testLag1 postgresConn+ , testLead postgresConn+ , testLag postgresConn+ , testLeadWithDefault postgresConn+ , testLagWithDefault postgresConn+ ]++testLead1 :: IO ByteString -> TestTree+testLead1 = testCase "lead1_" . windowingQueryTest query expectation+ where+ query =+ withWindow_+ ( \Person{name} ->+ frame_+ noPartition_+ (orderPartitionBy_ (asc_ name))+ noBounds_+ )+ ( \Person{name} w ->+ (name, lead1_ name `over_` w)+ )+ (all_ $ persons db)+ expectation = [("Alice", Just "Bob"), ("Bob", Just "Claire"), ("Claire", Nothing)]++testLag1 :: IO ByteString -> TestTree+testLag1 = testCase "lag1_" . windowingQueryTest query expectation+ where+ query =+ withWindow_+ ( \Person{name} ->+ frame_+ noPartition_+ (orderPartitionBy_ (asc_ name))+ noBounds_+ )+ ( \Person{name} w ->+ (name, lag1_ name `over_` w)+ )+ (all_ $ persons db)+ expectation = [("Alice", Nothing), ("Bob", Just "Alice"), ("Claire", Just "Bob")]++testLead :: IO ByteString -> TestTree+testLead getConnStr =+ testGroup+ "lead_"+ [ testCase "n=1" $ windowingQueryTest (query 1) [("Alice", Just "Bob"), ("Bob", Just "Claire"), ("Claire", Nothing)] getConnStr+ , testCase "n=2" $ windowingQueryTest (query 2) [("Alice", Just "Claire"), ("Bob", Nothing), ("Claire", Nothing)] getConnStr+ ]+ where+ query n =+ withWindow_+ ( \Person{name} ->+ frame_+ noPartition_+ (orderPartitionBy_ (asc_ name))+ noBounds_+ )+ ( \Person{name} w ->+ (name, lead_ name (val_ (n :: Int32)) `over_` w)+ )+ (all_ $ persons db)+ expectation1 = []++testLag :: IO ByteString -> TestTree+testLag getConnStr =+ testGroup+ "lag_"+ [ testCase "n=1" $ windowingQueryTest (query 1) [("Alice", Nothing), ("Bob", Just "Alice"), ("Claire", Just "Bob")] getConnStr+ , testCase "n=2" $ windowingQueryTest (query 2) [("Alice", Nothing), ("Bob", Nothing), ("Claire", Just "Alice")] getConnStr+ ]+ where+ query n =+ withWindow_+ ( \Person{name} ->+ frame_+ noPartition_+ (orderPartitionBy_ (asc_ name))+ noBounds_+ )+ ( \Person{name} w ->+ (name, lag_ name (val_ (n :: Int32)) `over_` w)+ )+ (all_ $ persons db)+ expectation = []+++testLeadWithDefault :: IO ByteString -> TestTree+testLeadWithDefault getConnStr =+ testGroup+ "leadWithDefault_"+ [ testCase "n=1" $ windowingQueryTest (query 1 "default") [("Alice", "Bob"), ("Bob", "Claire"), ("Claire", "default")] getConnStr+ , testCase "n=2" $ windowingQueryTest (query 2 "default") [("Alice", "Claire"), ("Bob", "default"), ("Claire", "default")] getConnStr+ ]+ where+ query n def =+ withWindow_+ ( \Person{name} ->+ frame_+ noPartition_+ (orderPartitionBy_ (asc_ name))+ noBounds_+ )+ ( \Person{name} w ->+ (name, leadWithDefault_ name (val_ (n :: Int32)) (val_ def) `over_` w)+ )+ (all_ $ persons db)+ expectation1 = []+++testLagWithDefault :: IO ByteString -> TestTree+testLagWithDefault getConnStr =+ testGroup+ "lagWithDefault_"+ [ testCase "n=1" $ windowingQueryTest (query 1 "default") [("Alice", "default"), ("Bob", "Alice"), ("Claire", "Bob")] getConnStr+ , testCase "n=2" $ windowingQueryTest (query 2 "default") [("Alice", "default"), ("Bob", "default"), ("Claire", "Alice")] getConnStr+ ]+ where+ query n def =+ withWindow_+ ( \Person{name} ->+ frame_+ noPartition_+ (orderPartitionBy_ (asc_ name))+ noBounds_+ )+ ( \Person{name} w ->+ (name, lagWithDefault_ name (val_ (n :: Int32)) (val_ def) `over_` w)+ )+ (all_ $ persons db)+ expectation = []++++data PersonT f = Person+ { name :: C f Text+ }+ deriving (Generic)++type Person = PersonT Identity++type PersonExpr s = PersonT (QExpr Postgres s)++deriving instance Show Person+deriving instance Eq Person++instance Beamable PersonT++instance Table PersonT where+ data PrimaryKey PersonT f = PersonKey (C f Text)+ deriving stock (Generic)+ deriving anyclass (Beamable)++ primaryKey Person{name} = PersonKey name++data Db f = Db+ { persons :: f (TableEntity PersonT)+ }+ deriving (Generic)++instance Database Postgres Db++db :: DatabaseSettings Postgres Db+db = defaultDbSettings++windowingQueryTest ::+ (Eq a, Show a, Eq b, Show b, FromBackendRow Postgres a, FromBackendRow Postgres b) =>+ Q Postgres Db QBaseScope (QExpr Postgres s a, QExpr Postgres s b) ->+ [(a, b)] ->+ IO ByteString ->+ Assertion+windowingQueryTest query expectation getConnStr =+ withTestPostgres "db_windowing_psql" getConnStr $+ \conn -> do+ prepareTable conn+ results <-+ runBeamPostgres conn $+ runSelectReturningList $+ select query++ assertEqual "Unexpected" expectation results++prepareTable :: Connection -> IO ()+prepareTable conn =+ runBeamPostgres conn $ do+ void $ autoMigrate migrationBackend (defaultMigratableDbSettings @Postgres @Db)+ runInsert $+ insert (persons db) $+ insertValues+ [ Person "Alice"+ , Person "Bob"+ , Person "Claire"+ ]
test/Main.hs view
@@ -1,52 +1,67 @@ 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.Select as Select-import qualified Database.Beam.Postgres.Test.Marshal as Marshal+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+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 Database.PostgreSQL.Simple ( ConnectInfo(..), defaultConnectInfo )+import qualified Database.Beam.Postgres.Test.Windowing as Windowing+import Database.PostgreSQL.Simple (ConnectInfo(..), defaultConnectInfo) import qualified Database.PostgreSQL.Simple as Postgres main :: IO ()-main = defaultMain - $ TC.withContainers setupTempPostgresDB - $ \getConnStr -> - testGroup "beam-postgres tests"- [ Marshal.tests getConnStr- , Select.tests getConnStr- , DataType.tests getConnStr- , Migrate.tests getConnStr- , TempTable.tests getConnStr- ]+main = defaultMain $ testGroup "beam-postgres tests"+ -- Rendering and compile-negative tests do not need Docker, so keep them+ -- outside the Testcontainers resource and available as fast unit tests.+ [ CTE.unitTests+ , TC.withContainers setupTempPostgresDB $ \getConnStr ->+ testGroup "PostgreSQL integration tests"+ [ Marshal.tests getConnStr+ , CTE.integrationTests getConnStr+ , Select.tests getConnStr+ , Select.PgNubBy.tests getConnStr+ , DataType.tests getConnStr+ , Migrate.tests getConnStr+ , TempTable.tests getConnStr+ , Windowing.tests getConnStr+ , Copy.tests getConnStr+ ]+ ] setupTempPostgresDB :: TC.MonadDocker m => m ByteString setupTempPostgresDB = do- let user = "postgres"- password = "root"- db = "testdb"+ let user = "postgres"+ password = "root"+ db = "testdb" - timescaleContainer <- TC.run $ TC.containerRequest (TC.fromTag "postgres:16.4")- TC.& TC.setExpose [ 5432 ]- TC.& TC.setEnv [ ("POSTGRES_USER", user)- , ("POSTGRES_PASSWORD", password)- , ("POSTGRES_DB", db)- ]- TC.& TC.setWaitingFor (TC.waitForLogLine TC.Stderr ("database system is ready to accept connections" `TL.isInfixOf`))- - pure $ Postgres.postgreSQLConnectionString - ( defaultConnectInfo { connectHost = "localhost"- , connectUser = unpack user - , connectPassword = unpack password- , connectDatabase = unpack db- , connectPort = fromIntegral $ TC.containerPort timescaleContainer 5432- }- )+ -- Pin the server version so normal CI runs are reproducible.+ postgresContainer <- TC.run $+ TC.containerRequest (TC.fromTag "postgres:18.4")+ TC.& TC.setExpose [5432]+ TC.& TC.setEnv+ [ ("POSTGRES_USER", user)+ , ("POSTGRES_PASSWORD", password)+ , ("POSTGRES_DB", db)+ ]+ TC.& TC.setWaitingFor+ (TC.waitForLogLine TC.Stderr+ ("database system is ready to accept connections" `TL.isInfixOf`))++ pure $ Postgres.postgreSQLConnectionString defaultConnectInfo+ { connectHost = "localhost"+ , connectUser = unpack user+ , connectPassword = unpack password+ , connectDatabase = unpack db+ , connectPort = fromIntegral $ TC.containerPort postgresContainer 5432+ }