diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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 diff --git a/Database/Beam/Postgres.hs b/Database/Beam/Postgres.hs --- a/Database/Beam/Postgres.hs +++ b/Database/Beam/Postgres.hs @@ -16,74 +16,202 @@ -- -- For examples on how to use @beam-postgres@ usage, see -- . - 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 diff --git a/Database/Beam/Postgres/Connection.hs b/Database/Beam/Postgres/Connection.hs --- a/Database/Beam/Postgres/Connection.hs +++ b/Database/Beam/Postgres/Connection.hs @@ -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) diff --git a/Database/Beam/Postgres/Extensions.hs b/Database/Beam/Postgres/Extensions.hs --- a/Database/Beam/Postgres/Extensions.hs +++ b/Database/Beam/Postgres/Extensions.hs @@ -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) + diff --git a/Database/Beam/Postgres/Extensions/Copy/File.hs b/Database/Beam/Postgres/Extensions/Copy/File.hs new file mode 100644 --- /dev/null +++ b/Database/Beam/Postgres/Extensions/Copy/File.hs @@ -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 +-- 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) + ] diff --git a/Database/Beam/Postgres/Extensions/Copy/Stream.hs b/Database/Beam/Postgres/Extensions/Copy/Stream.hs new file mode 100644 --- /dev/null +++ b/Database/Beam/Postgres/Extensions/Copy/Stream.hs @@ -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 +-- 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) diff --git a/Database/Beam/Postgres/Extensions/Internal.hs b/Database/Beam/Postgres/Extensions/Internal.hs deleted file mode 100644 --- a/Database/Beam/Postgres/Extensions/Internal.hs +++ /dev/null @@ -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 diff --git a/Database/Beam/Postgres/Extensions/UuidOssp.hs b/Database/Beam/Postgres/Extensions/UuidOssp.hs --- a/Database/Beam/Postgres/Extensions/UuidOssp.hs +++ b/Database/Beam/Postgres/Extensions/UuidOssp.hs @@ -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 diff --git a/Database/Beam/Postgres/Full.hs b/Database/Beam/Postgres/Full.hs --- a/Database/Beam/Postgres/Full.hs +++ b/Database/Beam/Postgres/Full.hs @@ -1,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 +-- . +-- +-- @since 0.6.3.0 +data PgCtePlacement + = PgCteNestedAllowed + -- ^ The block contains only CTEs which may be nested. + | PgCteTopLevelOnly + -- ^ The block contains a data-modifying CTE and must remain top-level. + +-- | A PostgreSQL-specific CTE builder. +-- +-- This newtype uses beam-core's existing 'With' action and CTE accumulator. It +-- adds a placement index for PostgreSQL data-modifying CTEs without introducing +-- a second name supply or syntax writer. Consequently a lifted portable helper +-- and a native PostgreSQL CTE allocate names from the same sequence. +-- +-- Use 'pgSelecting' for SELECT CTEs, 'cteInsertReturning', +-- 'cteUpdateReturning', or 'cteDeleteReturning' for reusable modifying CTEs, +-- and 'cteInsert', 'cteUpdate', or 'cteDelete' for side-effect-only CTEs. +-- Consume the completed block with 'pgSelectWithTopLevel', 'pgInsertWith', +-- 'pgUpdateWith', or 'pgDeleteWith'. +-- +-- @since 0.6.3.0 +newtype PgWith db (placement :: PgCtePlacement) a = + PgWith { unPgWith :: With Postgres db a } + deriving (Functor, Applicative, Monad) + +-- The placement parameter is phantom at runtime. A nominal role prevents +-- Data.Coerce from relabelling a top-level-only block as nested-safe. +type role PgWith nominal nominal nominal + +-- Recursive knots are deliberately restricted to SELECT-only construction. +-- Complete such a knot first and then use 'pgToTopLevel' before adding a +-- data-modifying CTE which consumes its rows. +instance MonadFix (PgWith db 'PgCteNestedAllowed) where + mfix f = PgWith (mfix (unPgWith . f)) + +-- | Lift an existing portable PostgreSQL 'With' helper into 'PgWith'. +-- +-- Helpers constructed with the portable 'selecting' API contain SELECT +-- statements, so they are valid at either placement. The lifted action uses +-- the surrounding 'PgWith' name supply; lifting a helper which defines several +-- CTEs therefore cannot collide with CTEs defined before or after it. +-- +-- > native <- pgSelecting nativeQuery +-- > rows <- pgLiftWith existingSelectCtes +-- > changed <- cteDeleteReturning table predicate id +-- > pure $ do +-- > nativeRow <- reuse native +-- > row <- reuse rows +-- > changedRow <- reuse changed +-- > pure (nativeRow, row, changedRow) +-- +-- If @existingSelectCtes@ defines two CTEs and one native CTE precedes it, +-- Beam generates one block whose names continue through the lifted helper: +-- +-- @ +-- WITH "cte0"("res0") AS (SELECT ...), +-- "cte1"("res0") AS (SELECT ...), +-- "cte2"("res0") AS (SELECT ... FROM "cte1"), +-- "cte3"("res0", "res1") AS +-- (DELETE FROM "table" ... RETURNING "id", "value") +-- SELECT ... FROM "cte0" CROSS JOIN "cte2" CROSS JOIN "cte3" +-- @ +-- +-- The 'With' constructor is public for low-level extension code. 'pgLiftWith' +-- assumes such code preserves the portable API's SELECT-only invariant. +-- +-- @since 0.6.3.0 +pgLiftWith :: With Postgres db a -> PgWith db placement a +pgLiftWith = PgWith + +-- | Promote a completed nested-safe block for composition with +-- data-modifying CTEs. +-- +-- This operation is one-way. In particular, there is no public operation for +-- converting 'PgCteTopLevelOnly' back to 'PgCteNestedAllowed'. +-- +-- > pgSelectWithTopLevel $ do +-- > recursiveRows <- pgToTopLevel $ mdo +-- > rows <- pgSelecting recursiveQuery +-- > pure rows +-- > cteDelete table $ \row -> exists_ $ do +-- > recursiveRow <- reuse recursiveRows +-- > guard_ (rowId row ==. rowId recursiveRow) +-- > pure finalQuery +-- +-- The promotion changes no SQL. It permits the subsequent modifying CTE, so +-- the complete block has the following form: +-- +-- @ +-- WITH RECURSIVE "cte0"("res0") AS +-- (SELECT ... UNION ALL SELECT ... FROM "cte0"), +-- "cte1" AS +-- (DELETE FROM "table" +-- WHERE EXISTS (SELECT ... FROM "cte0")) +-- SELECT ... +-- @ +-- +-- @since 0.6.3.0 +pgToTopLevel + :: PgWith db 'PgCteNestedAllowed a + -> PgWith db 'PgCteTopLevelOnly a +pgToTopLevel (PgWith with) = PgWith with + +-- | PostgreSQL's materialization policy for a SELECT CTE. +-- +-- Explicit materialization control is available in PostgreSQL 12 and later. +-- 'PgCteDefault' emits no modifier and therefore retains PostgreSQL's normal +-- planner behaviour and compatibility with earlier server versions. +-- See PostgreSQL's +-- . +-- +-- @since 0.6.3.0 +data PgCteMaterialization + = PgCteDefault + -- ^ Let PostgreSQL decide whether to fold or materialize the CTE. + | PgCteMaterialized + -- ^ Emit @MATERIALIZED@, requesting separate calculation of the CTE. This + -- can act as an optimization fence or prevent duplicated computation. + | PgCteNotMaterialized + -- ^ Emit @NOT MATERIALIZED@, allowing the CTE and parent query to be + -- optimized together. PostgreSQL ignores this for recursive or + -- non-side-effect-free queries. + deriving (Eq, Show) + +-- | Introduce a SELECT query as a reusable PostgreSQL CTE using the server's +-- default materialization policy. +-- +-- This is the usual PostgreSQL-specific counterpart of 'selecting'. Use +-- 'pgSelectingWith' when the planner boundary should be controlled explicitly. +-- +-- > rows <- pgSelecting sourceQuery +-- > pure (reuse rows) +-- +-- With a top-level SELECT consumer this produces: +-- +-- @ +-- WITH "cte0"("res0", "res1") AS (SELECT ...) +-- SELECT "t0"."res0", "t0"."res1" FROM "cte0" AS "t0" +-- @ +-- +-- @since 0.6.3.0 +pgSelecting + :: ( Projectible Postgres res + , ThreadRewritable CTE.QAnyScope res ) + => Q Postgres db CTE.QAnyScope res + -> PgWith db placement (ReusableQ Postgres db res) +pgSelecting = pgSelectingWith PgCteDefault + +-- | Introduce a SELECT query as a reusable PostgreSQL CTE with an explicit +-- materialization policy. +-- +-- For example: +-- +-- > expensive <- pgSelectingWith PgCteMaterialized expensiveQuery +-- > pure $ do +-- > left <- reuse expensive +-- > right <- reuse expensive +-- > guard_ (leftId left ==. rightId right) +-- > pure (left, right) +-- +-- With 'pgSelectWithTopLevel', this produces a statement shaped like: +-- +-- @ +-- WITH "cte0"("res0", "res1") AS MATERIALIZED (SELECT ...) +-- SELECT ... +-- FROM "cte0" AS "t0" CROSS JOIN "cte0" AS "t1" +-- WHERE "t0"."res0" = "t1"."res0" +-- @ +-- +-- @NOT MATERIALIZED@ may allow restrictions in the parent query to reach the +-- CTE, but may also duplicate its computation when it is referenced more than +-- once. PostgreSQL ignores @NOT MATERIALIZED@ when folding would not be +-- semantically valid, for example for a recursive query or a query containing +-- volatile functions. +-- +-- A projection with no fields is represented by omitting the CTE column-alias +-- list. PostgreSQL then treats the CTE as a degree-zero relation: it has no +-- columns, but it retains the row cardinality of @query@. For example, a query +-- which produces two empty rows has the following shape: +-- +-- @ +-- WITH "cte0" AS MATERIALIZED (SELECT FROM ...) +-- SELECT FROM "cte0" AS "t0" +-- @ +-- +-- Reusing such a CTE remains meaningful in joins, @EXISTS@, and aggregates +-- even though no value can be projected from an individual row. +-- +-- @since 0.6.3.0 +pgSelectingWith + :: forall res db placement + . ( Projectible Postgres res + , ThreadRewritable CTE.QAnyScope res ) + => PgCteMaterialization + -> Q Postgres db CTE.QAnyScope res + -> PgWith db placement (ReusableQ Postgres db res) +pgSelectingWith materialization q = do + tblNm <- pgRegisterCte $ \name -> + let (_ :: res, fields) = mkFieldNames @Postgres (qualifiedField name) + body = fromPgSelect (buildSqlQuery (name <> "_") q) + in case nonEmpty fields of + Nothing -> pgCteSyntax name Nothing materialization body + Just fields' -> pgOutputCteSyntax name fields' materialization body + pure (CTE.reusableForCTE tblNm) + -- | An explicit lock against some tables. You can create a value of this type using the 'locked_' -- function. You can combine these values monoidally to combine multiple locks for use with the -- 'withLocks_' function. @@ -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 diff --git a/Database/Beam/Postgres/Migrate.hs b/Database/Beam/Postgres/Migrate.hs --- a/Database/Beam/Postgres/Migrate.hs +++ b/Database/Beam/Postgres/Migrate.hs @@ -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 diff --git a/Database/Beam/Postgres/PgCrypto.hs b/Database/Beam/Postgres/PgCrypto.hs --- a/Database/Beam/Postgres/PgCrypto.hs +++ b/Database/Beam/Postgres/PgCrypto.hs @@ -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) diff --git a/Database/Beam/Postgres/PgSpecific.hs b/Database/Beam/Postgres/PgSpecific.hs --- a/Database/Beam/Postgres/PgSpecific.hs +++ b/Database/Beam/Postgres/PgSpecific.hs @@ -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 -- diff --git a/Database/Beam/Postgres/Syntax.hs b/Database/Beam/Postgres/Syntax.hs --- a/Database/Beam/Postgres/Syntax.hs +++ b/Database/Beam/Postgres/Syntax.hs @@ -21,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 - diff --git a/Database/Beam/Postgres/Types.hs b/Database/Beam/Postgres/Types.hs --- a/Database/Beam/Postgres/Types.hs +++ b/Database/Beam/Postgres/Types.hs @@ -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 diff --git a/beam-postgres.cabal b/beam-postgres.cabal --- a/beam-postgres.cabal +++ b/beam-postgres.cabal @@ -1,5 +1,5 @@ name: beam-postgres -version: 0.5.6.1 +version: 0.6.3.0 synopsis: Connection layer between beam and postgres description: Beam driver for , an advanced open-source RDBMS homepage: https://haskell-beam.github.io/beam/user-guide/backends/beam-postgres @@ -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 diff --git a/test/Database/Beam/Postgres/Test.hs b/test/Database/Beam/Postgres/Test.hs --- a/test/Database/Beam/Postgres/Test.hs +++ b/test/Database/Beam/Postgres/Test.hs @@ -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 diff --git a/test/Database/Beam/Postgres/Test/CTE.hs b/test/Database/Beam/Postgres/Test/CTE.hs new file mode 100644 --- /dev/null +++ b/test/Database/Beam/Postgres/Test/CTE.hs @@ -0,0 +1,1334 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE StandaloneDeriving #-} + +-- | Rendering, type-safety, and PostgreSQL integration tests for common table +-- expressions. Deliberately ill-typed expressions live in +-- "Database.Beam.Postgres.Test.CTENegative" so this module retains normal type +-- checking. +module Database.Beam.Postgres.Test.CTE (unitTests, integrationTests) where + +import Control.Exception (TypeError, evaluate, try) +import qualified Data.ByteString.Lazy.Char8 as BL +import Data.ByteString (ByteString) +import Data.Int (Int32) +import Data.Kind (Type) +import Data.List (isInfixOf, isPrefixOf, sortOn) +import Data.Text (Text) + +import Database.Beam +import Database.Beam.Postgres +import qualified Database.Beam.Postgres.Full as Pg +import qualified Database.Beam.Query.CTE as CTE +import Database.Beam.Postgres.Syntax + ( PgDeleteSyntax(..) + , PgInsertSyntax(..) + , PgSelectSyntax(..) + , PgUpdateSyntax(..) + , PostgresInaccessible + , pgRenderSyntaxScript + ) +import Database.PostgreSQL.Simple (execute_) + +import qualified Hedgehog +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range +import Test.Tasty +import Test.Tasty.HUnit + +import Database.Beam.Postgres.Test +import qualified Database.Beam.Postgres.Test.CTENegative as Negative + +data CteRowT f = CteRow + { cteId :: C f Int32 + , cteValue :: C f Text + } deriving (Generic, Beamable) + +deriving instance Show (CteRowT Identity) +deriving instance Eq (CteRowT Identity) + +-- A legal Haskell projection shape with no fields. PostgreSQL represents this +-- degree-zero relation by omitting the CTE column-alias list. Data-modifying +-- CTEs with RETURNING use a private physical sentinel to satisfy PostgreSQL's +-- grammar while retaining this zero-field shape at Beam's public boundary. +data EmptyCteT (f :: Type -> Type) = EmptyCte + deriving (Generic, Beamable) + +deriving instance Show (EmptyCteT Identity) +deriving instance Eq (EmptyCteT Identity) + +instance Table CteRowT where + data PrimaryKey CteRowT f = CteRowKey (C f Int32) + deriving (Generic, Beamable) + primaryKey = CteRowKey . cteId + +newtype CteDb entity = CteDb + { dbCteRows :: entity (TableEntity CteRowT) + } deriving (Generic, Database Postgres) + +cteDb :: DatabaseSettings Postgres CteDb +cteDb = defaultDbSettings + +unitTests :: TestTree +unitTests = testGroup "Common table expression tests" + [ renderingTests + , typeSafetyTests + ] + +integrationTests :: IO ByteString -> TestTree +integrationTests getConn = testGroup "Common table expression integration tests" + [ testMixedCteBodies getConn + , testSideEffectOnlyCtes getConn + , testMaterializationExecution getConn + , testLiftedWithExecution getConn + , testWithDmlConsumers getConn + , testCteParameterOrdering getConn + , testDataModifyingCteModel getConn + , testSideEffectOnlyCteModel getConn + , testWithDmlConsumerModel getConn + , testRecursiveCteModel getConn + , testDegreeZeroSelects getConn + , testDegreeZeroDataModifyingCtes getConn + , testDegreeZeroRepeatedReuse getConn + ] + +renderingTests :: TestTree +renderingTests = testGroup "Common table expression rendering tests" + [ testMixedCteRendering + , testMaterializationRendering + , testNestedMaterializedCteRendering + , testSideEffectOnlyRendering + , testSideEffectNoOps + , testLiftedWithNameSupply + , testNestedSelectCteRendering + , testRecursiveSelectThenDeleteRendering + , testEmptyDataModifyingCtes + , testWithDmlConsumerRendering + , testRecursiveInsertWithRendering + , testTopLevelOnlyDmlConsumerRendering + , testEmptyDmlConsumers + , testReturningAfterDmlConsumers + , testDegreeZeroSelectRendering + , testDegreeZeroDataModifyingRendering + ] + +-- These tests force expressions compiled with deferred type errors in the +-- isolated negative-fixture module. Checking fragments of GHC's error ensures +-- an unrelated deferred error cannot make a test pass accidentally. +typeSafetyTests :: TestTree +typeSafetyTests = testGroup "Common table expression type-safety tests" + [ testCase "rejects a DELETE CTE inside pgSelectWith" $ + assertPlacementTypeError Negative.invalidNestedDelete + , testCase "rejects an INSERT CTE inside pgSelectWith" $ + assertPlacementTypeError Negative.invalidNestedInsert + , testCase "rejects an UPDATE CTE inside pgSelectWith" $ + assertPlacementTypeError Negative.invalidNestedUpdate + , testCase "rejects SELECT followed by DELETE inside pgSelectWith" $ + assertPlacementTypeError Negative.invalidNestedSelectThenDelete + , testCase "rejects DELETE followed by SELECT inside pgSelectWith" $ + assertPlacementTypeError Negative.invalidNestedDeleteThenSelect + , testCase "conservatively rejects an empty INSERT inside pgSelectWith" $ + assertPlacementTypeError Negative.invalidNestedEmptyInsert + , testCase "conservatively rejects an identity UPDATE inside pgSelectWith" $ + assertPlacementTypeError Negative.invalidNestedIdentityUpdate + , testCase "rejects a side-effect-only DELETE inside pgSelectWithNested" $ + assertPlacementTypeError Negative.invalidNestedSideEffectDelete + , testCase "placement cannot be bypassed with coerce" $ + assertPlacementTypeError Negative.invalidCoercedPlacement + , testCase "rejects a recursively self-referencing INSERT CTE" $ + assertDeferredTypeErrorContaining + ["No instance", "MonadFix", "PgCteTopLevelOnly"] + Negative.invalidRecursiveInsert + , testCase "side-effect-only CTE results cannot be reused" $ + assertDeferredTypeErrorContaining + ["ReusableQ"] + Negative.invalidReuseSideEffect + ] + +assertPlacementTypeError :: SqlSelect Postgres a -> Assertion +assertPlacementTypeError = + assertDeferredTypeErrorContaining ["PgCteTopLevelOnly", "PgCteNestedAllowed"] + +assertDeferredTypeErrorContaining + :: [String] + -> SqlSelect Postgres a + -> Assertion +assertDeferredTypeErrorContaining expectedFragments sql = do + result <- try (evaluate (BL.length (renderSelectBytes sql))) + case result of + Left (err :: TypeError) -> + let message = show err + in mapM_ (assertFragment message) expectedFragments + Right _ -> + assertFailure "expected the expression to contain a deferred type error" + where + assertFragment message fragment = + assertBool + ("mentions " ++ fragment ++ "\nDeferred error was:\n" ++ message) + (fragment `isInfixOf` message) + +-- A single top-level WITH block may freely mix SELECT and data-modifying CTE +-- bodies. Besides checking the individual keywords, this guards against +-- accidentally nesting a second WITH while combining the syntax fragments. +testMixedCteRendering :: TestTree +testMixedCteRendering = testCase "renders mixed SELECT, INSERT, UPDATE, and DELETE CTEs" $ do + let sql = renderSelect mixedCteSelect + assertBool "renders one top-level WITH" ("WITH " `isPrefixOf` sql) + assertBool "does not render a nested WITH keyword" (not ("WITH WITH" `isInfixOf` sql)) + assertBool "renders INSERT" ("INSERT INTO" `isInfixOf` sql) + assertBool "renders UPDATE" ("UPDATE" `isInfixOf` sql) + assertBool "renders DELETE" ("DELETE FROM" `isInfixOf` sql) + assertEqual "renders three RETURNING clauses" 3 (length (filter (== "RETURNING") (words sql))) + +-- Materialization is an explicit PostgreSQL 12+ spelling choice. Check the +-- complete token rather than a loose MATERIALIZED substring, since the latter +-- would make the NOT MATERIALIZED case pass the positive assertion too. +testMaterializationRendering :: TestTree +testMaterializationRendering = testCase "renders every SELECT CTE materialization policy" $ do + let defaultSql = renderSelect (materializationSelect Pg.PgCteDefault) + materializedSql = renderSelect (materializationSelect Pg.PgCteMaterialized) + notMaterializedSql = renderSelect (materializationSelect Pg.PgCteNotMaterialized) + assertBool "default omits MATERIALIZED" + (not (" MATERIALIZED (" `isInfixOf` defaultSql)) + assertBool "default omits NOT MATERIALIZED" + (not (" NOT MATERIALIZED (" `isInfixOf` defaultSql)) + assertBool "renders AS MATERIALIZED" + (" AS MATERIALIZED (" `isInfixOf` materializedSql) + assertBool "renders AS NOT MATERIALIZED" + (" AS NOT MATERIALIZED (" `isInfixOf` notMaterializedSql) + +-- pgSelectWithNested is the safe nested consumer for PostgreSQL-specific +-- SELECT CTE features. This complements the compatibility test for the older +-- pgSelectWith API below. +testNestedMaterializedCteRendering :: TestTree +testNestedMaterializedCteRendering = testCase "embeds a materialized PgWith block in a subquery" $ do + let sql = renderSelect nestedMaterializedCteSelect + assertBool "renders the nested WITH" + ("FROM (WITH " `isInfixOf` sql) + assertBool "retains the materialization modifier" + (" AS MATERIALIZED (" `isInfixOf` sql) + +-- DML without RETURNING is still executed by PostgreSQL but forms no temporary +-- table and exposes no reusable result. Its CTE name must therefore have no +-- empty column-alias list. +testSideEffectOnlyRendering :: TestTree +testSideEffectOnlyRendering = testCase "renders side-effect-only INSERT, UPDATE, and DELETE CTEs" $ do + let sql = renderSelect sideEffectOnlyCteSelect + assertBool "renders INSERT" ("INSERT INTO" `isInfixOf` sql) + assertBool "renders UPDATE" ("UPDATE" `isInfixOf` sql) + assertBool "renders DELETE" ("DELETE FROM" `isInfixOf` sql) + assertBool "does not render RETURNING" (not ("RETURNING" `isInfixOf` sql)) + assertBool "does not render an empty alias list" (not ("() AS" `isInfixOf` sql)) + +-- Empty inserts and identity updates should consume neither a name nor a CTE +-- slot. With no other CTEs, the final query must not acquire an empty WITH. +testSideEffectNoOps :: TestTree +testSideEffectNoOps = testCase "omits side-effect-only empty INSERT and identity UPDATE" $ do + let sql = renderSelect sideEffectNoOpSelect + assertBool "does not render WITH" (not ("WITH " `isPrefixOf` sql)) + assertBool "does not render INSERT" (not ("INSERT INTO" `isInfixOf` sql)) + assertBool "does not render UPDATE" (not ("UPDATE" `isInfixOf` sql)) + +-- Lifting a complete portable helper must not restart its State Int name +-- supply. Four definitions from native/lifted/native construction should be +-- allocated exactly once as cte0 through cte3. +testLiftedWithNameSupply :: TestTree +testLiftedWithNameSupply = testCase "shares CTE names across lifted and native builders" $ do + let sql = renderSelect liftedWithSelect + mapM_ (\name -> assertBool ("renders " ++ name) (("\"" ++ name ++ "\"") `isInfixOf` sql)) + ["cte0", "cte1", "cte2", "cte3"] + assertBool "does not allocate cte4" (not ("\"cte4\"" `isInfixOf` sql)) + +-- pgSelectWith remains available for its original purpose: embedding a +-- SELECT-only WITH block as a subquery. +testNestedSelectCteRendering :: TestTree +testNestedSelectCteRendering = testCase "SELECT CTEs remain valid inside pgSelectWith" $ do + let sql = renderSelect nestedSelectCteSelect + assertBool "renders an inner WITH" ("FROM (WITH " `isInfixOf` sql) + +-- Closing the recursive SELECT portion with pgToTopLevel should preserve WITH +-- RECURSIVE while allowing a later DELETE CTE in the same top-level block. +testRecursiveSelectThenDeleteRendering :: TestTree +testRecursiveSelectThenDeleteRendering = testCase "recursive SELECT can feed a top-level DELETE CTE" $ do + let sql = renderSelect recursiveSelectThenDeleteCteSelect + assertBool "renders WITH RECURSIVE" ("WITH RECURSIVE " `isPrefixOf` sql) + assertBool "renders DELETE" ("DELETE FROM" `isInfixOf` sql) + +-- Value-level empty operations must not leave behind an empty or partial WITH +-- clause when the final SELECT is rendered. +testEmptyDataModifyingCtes :: TestTree +testEmptyDataModifyingCtes = testCase "omits empty INSERT and identity UPDATE CTEs" $ do + let sql = renderSelect emptyDataModifyingCteSelect + assertBool "does not render WITH" (not ("WITH " `isPrefixOf` sql)) + assertBool "does not render INSERT" (not ("INSERT INTO" `isInfixOf` sql)) + assertBool "does not render UPDATE" (not ("UPDATE" `isInfixOf` sql)) + +-- Each PostgreSQL DML consumer must place the WITH block before, rather than +-- inside, its terminal statement. These rendering checks cover INSERT, UPDATE, +-- and DELETE while retaining Beam's existing Sql* result types. +testWithDmlConsumerRendering :: TestTree +testWithDmlConsumerRendering = testCase "renders WITH before terminal INSERT, UPDATE, and DELETE" $ do + assertWithTerminal "INSERT INTO" (renderInsert insertWithStatement) + assertWithTerminal "UPDATE" (renderUpdate updateWithStatement) + assertWithTerminal "DELETE FROM" (renderDelete deleteWithStatement) + +-- A recursive SELECT CTE is legal before a terminal DML statement. This makes +-- sure pgInsertWith preserves the recursive flag collected by With. +testRecursiveInsertWithRendering :: TestTree +testRecursiveInsertWithRendering = testCase "renders WITH RECURSIVE before a terminal INSERT" $ do + sql <- requireRenderedStatement (renderInsert recursiveInsertWithStatement) + assertBool "starts with WITH RECURSIVE" ("WITH RECURSIVE " `isPrefixOf` sql) + assertBool "renders terminal INSERT" (" INSERT INTO" `isInfixOf` sql) + +-- Top-level DML consumers may accept the stronger PgCteTopLevelOnly placement. +-- A data-modifying CTE followed by DELETE exercises that fact at compile time +-- as well as checking the resulting SQL shape. +testTopLevelOnlyDmlConsumerRendering :: TestTree +testTopLevelOnlyDmlConsumerRendering = testCase "accepts a modifying CTE before terminal DELETE" $ do + sql <- requireRenderedStatement (renderDelete topLevelOnlyDeleteWithStatement) + assertBool "renders DELETE as the CTE body" + ("AS (DELETE FROM" `isInfixOf` sql) + assertBool "renders DELETE as the terminal statement" + (") DELETE FROM" `isInfixOf` sql) + +-- An empty INSERT and identity UPDATE have no terminal statement. PostgreSQL +-- cannot execute a bare WITH clause, so their consumers must retain the +-- existing no-op representation and discard the accumulated definitions. +testEmptyDmlConsumers :: TestTree +testEmptyDmlConsumers = testCase "keeps empty INSERT and identity UPDATE as no-ops" $ do + assertEqual "empty INSERT has no syntax" Nothing + (renderInsert emptyInsertWithStatement) + assertEqual "identity UPDATE has no syntax" Nothing + (renderUpdate identityUpdateWithStatement) + +-- The consumers deliberately return the existing Sql* wrappers. Their +-- PgReturning instances must therefore remain usable without a parallel +-- pgInsertReturningWith/pgUpdateReturningWith/pgDeleteReturningWith API. +testReturningAfterDmlConsumers :: TestTree +testReturningAfterDmlConsumers = testCase "supports RETURNING after each terminal DML consumer" $ do + assertReturning "INSERT" (renderInsertReturning (Pg.returning insertWithStatement id)) + assertReturning "UPDATE" (renderUpdateReturning (Pg.returning updateWithStatement id)) + assertReturning "DELETE" (renderDeleteReturning (Pg.returning deleteWithStatement id)) + +-- PostgreSQL's syntax for a degree-zero CTE has no column-alias parentheses. +-- Cover both the portable selecting renderer and the native renderer, including +-- nested and explicit materialization forms, because they enter PostgreSQL +-- syntax through different code paths. +testDegreeZeroSelectRendering :: TestTree +testDegreeZeroSelectRendering = testCase "renders reusable degree-zero SELECT CTEs" $ do + let portableSql = renderSelect emptySelectProjection + nativeSql = renderSelect + (emptyNativeSelectProjection Pg.PgCteDefault) + materializedSql = renderSelect + (emptyNativeSelectProjection Pg.PgCteMaterialized) + nestedSql = renderSelect nestedEmptySelectProjection + + mapM_ assertDegreeZeroSelect + [portableSql, nativeSql, materializedSql, nestedSql] + assertBool "retains explicit materialization" + (" AS MATERIALIZED (" `isInfixOf` materializedSql) + assertBool "remains valid in a nested SELECT" + ("FROM (WITH " `isInfixOf` nestedSql) + where + assertDegreeZeroSelect sql = do + assertBool "does not render an empty CTE alias list" + (not ("\"cte0\"()" `isInfixOf` sql)) + assertBool "the CTE body projects no columns" + ("SELECT FROM" `isInfixOf` sql || "SELECT FROM" `isInfixOf` sql) + assertBool "the consumer projects no columns" + ("SELECT FROM \"cte0\"" `isInfixOf` sql || + "SELECT FROM \"cte0\"" `isInfixOf` sql) + +-- INSERT, UPDATE, and DELETE share the sentinel path but have independent +-- RETURNING renderers. Assert every spelling, including that the physical +-- sentinel is declared once and is not selected by the zero-field consumer. +testDegreeZeroDataModifyingRendering :: TestTree +testDegreeZeroDataModifyingRendering = + testCase "renders reusable degree-zero data-modifying CTEs" $ + mapM_ assertDegreeZeroDml + [ ("INSERT", renderSelect (emptyInsertProjection [CteRow 1 "one"])) + , ("UPDATE", renderSelect (emptyUpdateProjection 1 "updated")) + , ("DELETE", renderSelect (emptyDeleteProjection 1)) + ] + where + assertDegreeZeroDml (command, sql) = do + assertBool (command ++ " declares one physical sentinel") + ("\"cte0\"(\"res0\") AS" `isInfixOf` sql) + assertBool (command ++ " appends a valid RETURNING expression") + (" RETURNING NULL::boolean" `isInfixOf` sql) + assertEqual (command ++ " emits one RETURNING keyword") + 1 + (length (filter (== "RETURNING") (words sql))) + assertBool (command ++ " does not expose the sentinel") + ("SELECT FROM \"cte0\"" `isInfixOf` sql || + "SELECT FROM \"cte0\"" `isInfixOf` sql) + +-- Rendering alone cannot verify PostgreSQL's execution and snapshot semantics. +-- This integration case checks both the RETURNING rows and the final table +-- state after all three modifying CTEs execute. +testMixedCteBodies :: IO ByteString -> TestTree +testMixedCteBodies getConn = testCase "SELECT and data-modifying CTEs can be mixed" $ + withTestPostgres "mixed_cte_bodies" getConn $ \conn -> do + execute_ conn "CREATE TABLE cte_rows (id INT PRIMARY KEY, value TEXT NOT NULL)" + execute_ conn "INSERT INTO cte_rows VALUES (1, 'selected'), (3, 'before-update'), (4, 'deleted')" + + result <- runBeamPostgres conn $ runSelectReturningList mixedCteSelect + + assertEqual "rows returned by each CTE" + [ ( CteRow 1 "selected" + , CteRow 2 "inserted" + , CteRow 3 "updated" + , CteRow 4 "deleted" + ) + ] + result + + remaining <- runBeamPostgres conn $ runSelectReturningList $ select $ + orderBy_ (asc_ . cteId) $ all_ (dbCteRows cteDb) + assertEqual "data modifications were applied" + [ CteRow 1 "selected" + , CteRow 2 "inserted" + , CteRow 3 "updated" + ] + remaining + +-- PostgreSQL executes a modifying CTE exactly once even when it has no +-- RETURNING clause and the terminal SELECT does not reference it. Verify that +-- all three commands affect the final database state, not merely that their +-- syntax parses. +testSideEffectOnlyCtes :: IO ByteString -> TestTree +testSideEffectOnlyCtes getConn = testCase "unreferenced side-effect-only CTEs execute once" $ + withTestPostgres "side_effect_only_ctes" getConn $ \conn -> do + execute_ conn "CREATE TABLE cte_rows (id INT PRIMARY KEY, value TEXT NOT NULL)" + execute_ conn "INSERT INTO cte_rows VALUES (1, 'unchanged'), (2, 'before-update'), (3, 'delete-me')" + + marker <- runBeamPostgres conn $ + runSelectReturningOne sideEffectOnlyCteSelect + assertEqual "terminal SELECT still runs" (Just (1 :: Int32)) marker + + remaining <- runBeamPostgres conn $ runSelectReturningList $ select $ + orderBy_ (asc_ . cteId) $ all_ (dbCteRows cteDb) + assertEqual "all expected side effects were applied" + [ CteRow 1 "unchanged" + , CteRow 2 "after-update" + , CteRow 4 "inserted" + ] + remaining + +-- Planner choices are deliberately not asserted because they may vary across +-- PostgreSQL releases. Successful execution and equal results validate the two +-- explicit PostgreSQL 12+ spellings without coupling the test to EXPLAIN. +testMaterializationExecution :: IO ByteString -> TestTree +testMaterializationExecution getConn = testCase "MATERIALIZED and NOT MATERIALIZED execute" $ + withTestPostgres "cte_materialization" getConn $ \conn -> do + execute_ conn "CREATE TABLE cte_rows (id INT PRIMARY KEY, value TEXT NOT NULL)" + execute_ conn "INSERT INTO cte_rows VALUES (1, 'one'), (2, 'two')" + + materialized <- runBeamPostgres conn $ runSelectReturningList $ + materializationSelect Pg.PgCteMaterialized + notMaterialized <- runBeamPostgres conn $ runSelectReturningList $ + materializationSelect Pg.PgCteNotMaterialized + assertEqual "both policies preserve query results" materialized notMaterialized + +-- Rendering checks the shared name supply; execution additionally proves that +-- ReusableQ values returned by a lifted multi-CTE helper retain their meaning. +testLiftedWithExecution :: IO ByteString -> TestTree +testLiftedWithExecution getConn = testCase "a lifted multi-CTE helper remains reusable" $ + withTestPostgres "lifted_with_execution" getConn $ \conn -> do + lifted <- runBeamPostgres conn $ runSelectReturningList liftedWithSelect + assertEqual "a lifted multi-CTE helper remains reusable" + [(1, 11, 12)] + lifted + +-- Execute each terminal DML consumer against PostgreSQL. The three statements +-- use SELECT CTEs to choose or construct their affected rows, proving that the +-- reusable names remain visible to INSERT, UPDATE, and DELETE. +testWithDmlConsumers :: IO ByteString -> TestTree +testWithDmlConsumers getConn = testCase "WITH can terminate in INSERT, UPDATE, or DELETE" $ + withTestPostgres "with_dml_consumers" getConn $ \conn -> do + execute_ conn "CREATE TABLE cte_rows (id INT PRIMARY KEY, value TEXT NOT NULL)" + execute_ conn "INSERT INTO cte_rows VALUES (1, 'source'), (3, 'before-update'), (4, 'delete-me')" + + runBeamPostgres conn $ do + runInsert insertWithStatement + runUpdate updateWithStatement + runDelete deleteWithStatement + + remaining <- runBeamPostgres conn $ runSelectReturningList $ select $ + orderBy_ (asc_ . cteId) $ all_ (dbCteRows cteDb) + assertEqual "all terminal DML statements used their CTE rows" + [ CteRow 1 "source" + , CteRow 2 "inserted-with" + , CteRow 3 "updated-with" + ] + remaining + +-- PostgreSQL receives Beam values separately from the rendered placeholders. +-- Generate distinct values at each syntactic level so any disagreement between +-- syntax construction order and parameter collection order becomes observable +-- in the returned rows, rather than merely producing valid-looking SQL. +testCteParameterOrdering :: IO ByteString -> TestTree +testCteParameterOrdering getConn = testCase "preserves parameter order across CTE bodies and the terminal query" $ + withTestPostgres "cte_parameter_ordering_property" getConn $ \conn -> do + passes <- Hedgehog.check . Hedgehog.property $ do + baseId <- Hedgehog.forAll (Gen.int (Range.linear (-100000) 100000)) + firstOffset <- Hedgehog.forAll (Gen.int (Range.linear 1 1000)) + secondOffset <- Hedgehog.forAll (Gen.int (Range.linear 1 1000)) + payload <- Hedgehog.forAll (Gen.text (Range.linear 0 24) Gen.alphaNum) + + let first = CteRow (fromIntegral baseId) ("first:" <> payload) + second = CteRow + (fromIntegral (baseId + firstOffset)) + ("second:" <> payload) + terminal = CteRow + (fromIntegral (baseId + firstOffset + secondOffset)) + ("terminal:" <> payload) + + actual <- Hedgehog.evalIO $ runBeamPostgres conn $ + runSelectReturningList (parameterOrderingSelect first second terminal) + + actual Hedgehog.=== [(first, second, terminal)] + + assertBool "CTE parameter-ordering property failed" passes + +-- Model a statement containing all three kinds of data-modifying CTE. The +-- operations use disjoint keys, avoiding PostgreSQL's deliberately unspecified +-- ordering when sibling modifying CTEs affect the same row. Both RETURNING +-- values and durable table state are compared with the pure expected result. +testDataModifyingCteModel :: IO ByteString -> TestTree +testDataModifyingCteModel getConn = testCase "data-modifying CTEs agree with a pure table model" $ + withTestPostgres "data_modifying_cte_model_property" getConn $ \conn -> do + execute_ conn "CREATE TABLE cte_rows (id INT PRIMARY KEY, value TEXT NOT NULL)" + + passes <- Hedgehog.check . Hedgehog.property $ do + baseId <- Hedgehog.forAll (Gen.int (Range.linear (-100000) 96000)) + payload <- Hedgehog.forAll (Gen.text (Range.linear 0 24) Gen.alphaNum) + + let inserted = CteRow (fromIntegral baseId) ("inserted:" <> payload) + beforeUpdate = CteRow (fromIntegral (baseId + 1)) ("before-update:" <> payload) + updated = CteRow (cteId beforeUpdate) ("updated:" <> payload) + deleted = CteRow (fromIntegral (baseId + 2)) ("deleted:" <> payload) + untouched = CteRow (fromIntegral (baseId + 3)) ("untouched:" <> payload) + initial = [beforeUpdate, deleted, untouched] + expectedFinal = [inserted, updated, untouched] + + Hedgehog.evalIO $ do + execute_ conn "TRUNCATE TABLE cte_rows" + runBeamPostgres conn $ runInsert $ + insert (dbCteRows cteDb) (insertValues initial) + + returned <- Hedgehog.evalIO $ runBeamPostgres conn $ + runSelectReturningList $ + dataModifyingCteModelSelect inserted (cteId updated) (cteValue updated) (cteId deleted) + + finalRows <- Hedgehog.evalIO $ runBeamPostgres conn $ + runSelectReturningList $ select $ + orderBy_ (asc_ . cteId) $ all_ (dbCteRows cteDb) + + returned Hedgehog.=== [(inserted, updated, deleted)] + finalRows Hedgehog.=== expectedFinal + + assertBool "data-modifying CTE model property failed" passes + +-- Repeat the three-operation model without RETURNING. This catches parameter +-- ordering or accidental omission in the side-effect-only path by +-- comparing durable state over generated inputs. +testSideEffectOnlyCteModel :: IO ByteString -> TestTree +testSideEffectOnlyCteModel getConn = testCase "side-effect-only CTEs agree with a pure table model" $ + withTestPostgres "side_effect_only_cte_model_property" getConn $ \conn -> do + execute_ conn "CREATE TABLE cte_rows (id INT PRIMARY KEY, value TEXT NOT NULL)" + + passes <- Hedgehog.check . Hedgehog.property $ do + baseId <- Hedgehog.forAll (Gen.int (Range.linear (-100000) 96000)) + payload <- Hedgehog.forAll (Gen.text (Range.linear 0 24) Gen.alphaNum) + + let inserted = CteRow (fromIntegral baseId) ("inserted:" <> payload) + beforeUpdate = CteRow (fromIntegral (baseId + 1)) ("before-update:" <> payload) + updated = CteRow (cteId beforeUpdate) ("updated:" <> payload) + deleted = CteRow (fromIntegral (baseId + 2)) ("deleted:" <> payload) + untouched = CteRow (fromIntegral (baseId + 3)) ("untouched:" <> payload) + initial = [beforeUpdate, deleted, untouched] + expectedFinal = [inserted, updated, untouched] + + Hedgehog.evalIO $ do + execute_ conn "TRUNCATE TABLE cte_rows" + runBeamPostgres conn $ runInsert $ + insert (dbCteRows cteDb) (insertValues initial) + + marker <- Hedgehog.evalIO $ runBeamPostgres conn $ + runSelectReturningOne $ + sideEffectCteModelSelect inserted (cteId updated) (cteValue updated) (cteId deleted) + finalRows <- Hedgehog.evalIO $ runBeamPostgres conn $ + runSelectReturningList $ select $ + orderBy_ (asc_ . cteId) $ all_ (dbCteRows cteDb) + + marker Hedgehog.=== Just (1 :: Int32) + finalRows Hedgehog.=== expectedFinal + + assertBool "side-effect-only CTE model property failed" passes + +-- Exercise each top-level WITH consumer with independently generated values. +-- RETURNING results prove that the existing PostgreSQL execution instances can +-- still consume the Sql* wrappers, while the final table comparison checks the +-- combined INSERT, UPDATE, and DELETE behavior against a pure model. +testWithDmlConsumerModel :: IO ByteString -> TestTree +testWithDmlConsumerModel getConn = testCase "WITH DML consumers agree with a pure table model" $ + withTestPostgres "with_dml_consumer_model_property" getConn $ \conn -> do + execute_ conn "CREATE TABLE cte_rows (id INT PRIMARY KEY, value TEXT NOT NULL)" + + passes <- Hedgehog.check . Hedgehog.property $ do + baseId <- Hedgehog.forAll (Gen.int (Range.linear (-100000) 95000)) + payload <- Hedgehog.forAll (Gen.text (Range.linear 0 24) Gen.alphaNum) + + let source = CteRow (fromIntegral baseId) ("source:" <> payload) + inserted = CteRow (fromIntegral (baseId + 1)) ("inserted:" <> payload) + beforeUpdate = CteRow (fromIntegral (baseId + 2)) ("before-update:" <> payload) + updated = CteRow (cteId beforeUpdate) ("updated:" <> payload) + deleted = CteRow (fromIntegral (baseId + 3)) ("deleted:" <> payload) + untouched = CteRow (fromIntegral (baseId + 4)) ("untouched:" <> payload) + initial = [source, beforeUpdate, deleted, untouched] + expectedFinal = [source, inserted, updated, untouched] + + Hedgehog.evalIO $ do + execute_ conn "TRUNCATE TABLE cte_rows" + runBeamPostgres conn $ runInsert $ + insert (dbCteRows cteDb) (insertValues initial) + + (insertedRows, updatedRows, deletedRows) <- Hedgehog.evalIO $ + runBeamPostgres conn $ do + insertedRows <- Pg.runPgInsertReturningList $ Pg.returning + (modelInsertWithStatement (cteId source) inserted) id + updatedRows <- Pg.runPgUpdateReturningList $ Pg.returning + (modelUpdateWithStatement (cteId updated) (cteValue updated)) id + deletedRows <- Pg.runPgDeleteReturningList $ Pg.returning + (modelDeleteWithStatement (cteId deleted)) id + pure (insertedRows, updatedRows, deletedRows) + + finalRows <- Hedgehog.evalIO $ runBeamPostgres conn $ + runSelectReturningList $ select $ + orderBy_ (asc_ . cteId) $ all_ (dbCteRows cteDb) + + insertedRows Hedgehog.=== [inserted] + updatedRows Hedgehog.=== [updated] + deletedRows Hedgehog.=== [deleted] + finalRows Hedgehog.=== expectedFinal + + assertBool "WITH DML consumer model property failed" passes + +-- Generate a bounded recursive sequence, use it to drive a DELETE CTE, and +-- compare both the returned rows and remaining table against the corresponding +-- Haskell lists. This executes the recursive SELECT, its pgToTopLevel promotion, +-- and the following modifying CTE rather than checking only rendered keywords. +testRecursiveCteModel :: IO ByteString -> TestTree +testRecursiveCteModel getConn = testCase "recursive CTE execution agrees with a bounded sequence model" $ + withTestPostgres "recursive_cte_model_property" getConn $ \conn -> do + execute_ conn "CREATE TABLE cte_rows (id INT PRIMARY KEY, value TEXT NOT NULL)" + + passes <- Hedgehog.check . Hedgehog.property $ do + start <- Hedgehog.forAll (Gen.int (Range.linear (-100000) 95000)) + count <- Hedgehog.forAll (Gen.int (Range.linear 1 25)) + payload <- Hedgehog.forAll (Gen.text (Range.linear 0 24) Gen.alphaNum) + + let startId = fromIntegral start + endId = fromIntegral (start + count - 1) + recursiveRows = + [ CteRow (fromIntegral rowId) ("recursive:" <> payload) + | rowId <- [start .. start + count - 1] + ] + untouched = CteRow (fromIntegral (start + count)) ("untouched:" <> payload) + + Hedgehog.evalIO $ do + execute_ conn "TRUNCATE TABLE cte_rows" + runBeamPostgres conn $ runInsert $ + insert (dbCteRows cteDb) (insertValues (recursiveRows ++ [untouched])) + + deletedRows <- Hedgehog.evalIO $ runBeamPostgres conn $ + runSelectReturningList (recursiveCteModelSelect startId endId) + finalRows <- Hedgehog.evalIO $ runBeamPostgres conn $ + runSelectReturningList $ select $ + orderBy_ (asc_ . cteId) $ all_ (dbCteRows cteDb) + + sortOn cteId deletedRows Hedgehog.=== recursiveRows + finalRows Hedgehog.=== [untouched] + + assertBool "recursive CTE model property failed" passes + +-- A row need not contain a projected value. PostgreSQL still returns one +-- zero-field result for every source row, and postgresql-simple must decode the +-- final rows without expecting any result fields. Exercise both the portable +-- and native builders and both explicit materialization policies. +testDegreeZeroSelects :: IO ByteString -> TestTree +testDegreeZeroSelects getConn = testCase "degree-zero SELECT CTEs preserve source cardinality" $ + withTestPostgres "degree_zero_select_ctes" getConn $ \conn -> do + execute_ conn "CREATE TABLE cte_rows (id INT PRIMARY KEY, value TEXT NOT NULL)" + + emptySummary <- runBeamPostgres conn $ runSelectReturningOne $ + emptySelectSummary + assertEqual "an empty degree-zero relation has count zero and is not present" + (Just (0, False)) + emptySummary + + execute_ conn "INSERT INTO cte_rows VALUES (1, 'one'), (2, 'two'), (3, 'three')" + + portable <- runBeamPostgres conn $ + runSelectReturningList emptySelectProjection + native <- runBeamPostgres conn $ runSelectReturningList $ + emptyNativeSelectProjection Pg.PgCteDefault + materialized <- runBeamPostgres conn $ runSelectReturningList $ + emptyNativeSelectProjection Pg.PgCteMaterialized + notMaterialized <- runBeamPostgres conn $ runSelectReturningList $ + emptyNativeSelectProjection Pg.PgCteNotMaterialized + populatedSummary <- runBeamPostgres conn $ runSelectReturningOne $ + emptySelectSummary + + let expected = replicate 3 EmptyCte + assertEqual "portable selecting preserves cardinality" expected portable + assertEqual "native default preserves cardinality" expected native + assertEqual "MATERIALIZED preserves cardinality" expected materialized + assertEqual "NOT MATERIALIZED preserves cardinality" expected notMaterialized + assertEqual "aggregates and EXISTS observe degree-zero rows" + (Just (3, True)) + populatedSummary + +-- Each modifying command has a separate RETURNING renderer. Besides validating +-- all three, this checks the boundary cases of several affected rows and no +-- affected rows, verifies that the private sentinel is not passed to the row +-- decoder, and compares the resulting durable table state. +testDegreeZeroDataModifyingCtes :: IO ByteString -> TestTree +testDegreeZeroDataModifyingCtes getConn = + testCase "degree-zero modifying CTEs preserve affected-row cardinality" $ + withTestPostgres "degree_zero_modifying_ctes" getConn $ \conn -> do + execute_ conn "CREATE TABLE cte_rows (id INT PRIMARY KEY, value TEXT NOT NULL)" + execute_ conn "INSERT INTO cte_rows VALUES (1, 'one'), (2, 'two'), (3, 'three')" + + inserted <- runBeamPostgres conn $ runSelectReturningList $ + emptyInsertProjection [CteRow 4 "four", CteRow 5 "five"] + updated <- runBeamPostgres conn $ runSelectReturningList $ + emptyUpdateProjection 2 "updated" + deleted <- runBeamPostgres conn $ runSelectReturningList $ + emptyDeleteProjection 3 + deletedNone <- runBeamPostgres conn $ runSelectReturningList $ + emptyDeleteProjection 99 + + assertEqual "INSERT retains two affected rows" + (replicate 2 EmptyCte) inserted + assertEqual "UPDATE retains two affected rows" + (replicate 2 EmptyCte) updated + assertEqual "DELETE retains three affected rows" + (replicate 3 EmptyCte) deleted + assertEqual "a command affecting no rows returns an empty relation" + [] deletedNone + + remaining <- runBeamPostgres conn $ runSelectReturningList $ select $ + orderBy_ (asc_ . cteId) $ all_ (dbCteRows cteDb) + assertEqual "all modifying commands applied their side effects" + [CteRow 1 "updated", CteRow 2 "updated"] + remaining + +-- Reusing a degree-zero modifying CTE twice is a useful stress case: no field +-- can carry cardinality through the query, so the nine rows show that both +-- references read the same three-row RETURNING result. The final table state +-- separately confirms that the DELETE removed every source row. +testDegreeZeroRepeatedReuse :: IO ByteString -> TestTree +testDegreeZeroRepeatedReuse getConn = + testCase "repeated degree-zero reuse preserves relational cardinality" $ + withTestPostgres "degree_zero_repeated_reuse" getConn $ \conn -> do + execute_ conn "CREATE TABLE cte_rows (id INT PRIMARY KEY, value TEXT NOT NULL)" + execute_ conn "INSERT INTO cte_rows VALUES (1, 'one'), (2, 'two'), (3, 'three')" + + summary <- runBeamPostgres conn $ runSelectReturningOne $ + emptyDeleteSummary + assertEqual "COUNT and EXISTS observe every returned DELETE row" + (Just (3, True)) + summary + + execute_ conn "INSERT INTO cte_rows VALUES (1, 'one'), (2, 'two'), (3, 'three')" + products <- runBeamPostgres conn $ runSelectReturningList $ + repeatedEmptyDeleteProjection + assertEqual "two references form the expected Cartesian product" + (replicate 9 EmptyCte) + products + + remaining <- runBeamPostgres conn $ runSelectReturningList $ select $ + all_ (dbCteRows cteDb) + assertEqual "the modifying CTE deletes every source row" + [] + remaining + +materializationSelect + :: Pg.PgCteMaterialization + -> SqlSelect Postgres (CteRowT Identity) +materializationSelect materialization = Pg.pgSelectWithTopLevel $ do + rows <- Pg.pgSelectingWith materialization $ all_ (dbCteRows cteDb) + pure (reuse rows) + +nestedMaterializedCteSelect :: SqlSelect Postgres (CteRowT Identity) +nestedMaterializedCteSelect = select $ Pg.pgSelectWithNested $ do + rows <- Pg.pgSelectingWith Pg.PgCteMaterialized $ + all_ (dbCteRows cteDb) + pure (reuse rows) + +sideEffectOnlyCteSelect :: SqlSelect Postgres Int32 +sideEffectOnlyCteSelect = Pg.pgSelectWithTopLevel $ do + Pg.cteInsert + (dbCteRows cteDb) + (insertValues [CteRow 4 "inserted"]) + Pg.onConflictDefault + Pg.cteUpdate + (dbCteRows cteDb) + (\row -> cteValue row <-. val_ "after-update") + (\row -> cteId row ==. val_ 2) + Pg.cteDelete + (dbCteRows cteDb) + (\row -> cteId row ==. val_ 3) + pure finalMarkerQuery + +sideEffectNoOpSelect :: SqlSelect Postgres Int32 +sideEffectNoOpSelect = Pg.pgSelectWithTopLevel $ do + Pg.cteInsert + (dbCteRows cteDb) + SqlInsertValuesEmpty + Pg.onConflictDefault + Pg.cteUpdate + (dbCteRows cteDb) + (const mempty) + (const (val_ True)) + pure finalMarkerQuery + +finalMarkerQuery + :: Q Postgres CteDb QBaseScope (QExpr Postgres QBaseScope Int32) +finalMarkerQuery = pure (val_ 1) + +-- A complete two-CTE portable helper is lifted as one action. Its internal +-- dependency also proves that lifting preserves ReusableQ values, not only the +-- emitted syntax fragments. +portableWithHelper + :: With Postgres CteDb + (ReusableQ Postgres CteDb (QExpr Postgres CTE.QAnyScope Int32)) +portableWithHelper = do + first <- selecting $ pure (as_ @Int32 (val_ 10)) + selecting $ do + value <- reuse first + pure (value + 1) + +liftedWithSelect + :: SqlSelect Postgres + (Int32, Int32, Int32) +liftedWithSelect = Pg.pgSelectWithTopLevel $ do + nativeBefore <- Pg.pgSelecting $ pure (as_ @Int32 (val_ 1)) + lifted <- Pg.pgLiftWith portableWithHelper + nativeAfter <- Pg.pgSelecting $ do + value <- reuse lifted + pure (value + 1) + pure $ do + before <- reuse nativeBefore + middle <- reuse lifted + after <- reuse nativeAfter + pure (before, middle, after) + +-- Exercise the main user-facing flow: bind a normal SELECT CTE, perform each +-- supported data modification, then join all four reusable results in the final +-- SELECT. The placement of the complete block is inferred as top-level-only. +mixedCteSelect + :: SqlSelect Postgres + ( CteRowT Identity + , CteRowT Identity + , CteRowT Identity + , CteRowT Identity + ) +mixedCteSelect = Pg.pgSelectWithTopLevel $ do + selected <- Pg.pgSelecting $ do + row <- all_ (dbCteRows cteDb) + guard_ (cteId row ==. val_ 1) + pure row + + inserted <- Pg.cteInsertReturning + (dbCteRows cteDb) + (insertValues [CteRow 2 "inserted"]) + Pg.onConflictDefault + id + + updated <- Pg.cteUpdateReturning + (dbCteRows cteDb) + (\row -> cteValue row <-. val_ "updated") + (\row -> cteId row ==. val_ 3) + id + + deleted <- Pg.cteDeleteReturning + (dbCteRows cteDb) + (\row -> cteId row ==. val_ 4) + id + + case (inserted, updated) of + (Just inserted', Just updated') -> pure $ do + selectedRow <- reuse selected + insertedRow <- reuse inserted' + updatedRow <- reuse updated' + deletedRow <- reuse deleted + pure (selectedRow, insertedRow, updatedRow, deletedRow) + _ -> error "Expected non-empty INSERT and UPDATE CTEs" + +-- Place values in two dependent CTE bodies and in the terminating SELECT. The +-- dependency prevents the second CTE from becoming an unrelated test fragment, +-- while the result exposes every bound value for exact comparison. +parameterOrderingSelect + :: CteRowT Identity + -> CteRowT Identity + -> CteRowT Identity + -> SqlSelect Postgres + (CteRowT Identity, CteRowT Identity, CteRowT Identity) +parameterOrderingSelect first second terminal = selectWith $ do + firstRows <- selecting $ pure (cteRowValues_ @CTE.QAnyScope first) + secondRows <- selecting $ do + _ <- reuse firstRows + pure (cteRowValues_ @CTE.QAnyScope second) + pure $ do + firstRow <- reuse firstRows + secondRow <- reuse secondRows + pure + ( firstRow + , secondRow + , cteRowValues_ @QBaseScope terminal + ) + +cteRowValues_ + :: forall scope. CteRowT Identity -> CteRowT (QExpr Postgres scope) +cteRowValues_ row = CteRow (val_ (cteId row)) (val_ (cteValue row)) + +-- The returned relation exposes the result of every modifying CTE. Keeping +-- their keys disjoint gives the property a deterministic reference model while +-- still exercising mixed syntax assembly and PostgreSQL execution semantics. +dataModifyingCteModelSelect + :: CteRowT Identity + -> Int32 + -> Text + -> Int32 + -> SqlSelect Postgres + (CteRowT Identity, CteRowT Identity, CteRowT Identity) +dataModifyingCteModelSelect inserted updateId updateValue deleteId = + Pg.pgSelectWithTopLevel $ do + insertedRows <- Pg.cteInsertReturning + (dbCteRows cteDb) + (insertValues [inserted]) + Pg.onConflictDefault + id + updatedRows <- Pg.cteUpdateReturning + (dbCteRows cteDb) + (\row -> cteValue row <-. val_ updateValue) + (\row -> cteId row ==. val_ updateId) + id + deletedRows <- Pg.cteDeleteReturning + (dbCteRows cteDb) + (\row -> cteId row ==. val_ deleteId) + id + + case (insertedRows, updatedRows) of + (Just insertedRows', Just updatedRows') -> pure $ do + insertedRow <- reuse insertedRows' + updatedRow <- reuse updatedRows' + deletedRow <- reuse deletedRows + pure (insertedRow, updatedRow, deletedRow) + _ -> error "Expected non-empty INSERT and UPDATE CTEs" + +sideEffectCteModelSelect + :: CteRowT Identity + -> Int32 + -> Text + -> Int32 + -> SqlSelect Postgres Int32 +sideEffectCteModelSelect inserted updateId updateValue deleteId = + Pg.pgSelectWithTopLevel $ do + Pg.cteInsert + (dbCteRows cteDb) + (insertValues [inserted]) + Pg.onConflictDefault + Pg.cteUpdate + (dbCteRows cteDb) + (\row -> cteValue row <-. val_ updateValue) + (\row -> cteId row ==. val_ updateId) + Pg.cteDelete + (dbCteRows cteDb) + (\row -> cteId row ==. val_ deleteId) + pure finalMarkerQuery + +-- The source key is selected in a CTE, then used to derive the inserted key. +-- This keeps both the CTE and terminal INSERT semantically relevant. +modelInsertWithStatement + :: Int32 + -> CteRowT Identity + -> SqlInsert Postgres CteRowT +modelInsertWithStatement sourceId inserted = Pg.pgInsertWith $ do + sourceIds <- Pg.pgSelecting $ do + row <- all_ (dbCteRows cteDb) + guard_ (cteId row ==. val_ sourceId) + pure (cteId row) + pure $ Pg.insert + (dbCteRows cteDb) + (insertFrom $ do + selectedId <- reuse sourceIds + pure $ CteRow + (selectedId + val_ (cteId inserted - sourceId)) + (val_ (cteValue inserted))) + Pg.onConflictDefault + +modelUpdateWithStatement + :: Int32 + -> Text + -> SqlUpdate Postgres CteRowT +modelUpdateWithStatement updateId updateValue = Pg.pgUpdateWith $ do + targetIds <- Pg.pgSelecting $ do + row <- all_ (dbCteRows cteDb) + guard_ (cteId row ==. val_ updateId) + pure (cteId row) + pure $ update + (dbCteRows cteDb) + (\row -> cteValue row <-. val_ updateValue) + (\row -> exists_ $ do + targetId <- reuse targetIds + guard_ (cteId row ==. targetId) + pure targetId) + +modelDeleteWithStatement + :: Int32 + -> SqlDelete Postgres CteRowT +modelDeleteWithStatement deleteId = Pg.pgDeleteWith $ do + targetIds <- Pg.pgSelecting $ do + row <- all_ (dbCteRows cteDb) + guard_ (cteId row ==. val_ deleteId) + pure (cteId row) + pure $ delete (dbCteRows cteDb) $ \row -> exists_ $ do + targetId <- reuse targetIds + guard_ (cteId row ==. targetId) + pure targetId + +recursiveCteModelSelect + :: Int32 + -> Int32 + -> SqlSelect Postgres (CteRowT Identity) +recursiveCteModelSelect startId endId = Pg.pgSelectWithTopLevel $ do + recursiveIds <- Pg.pgToTopLevel $ mdo + ids <- Pg.pgSelecting $ + pure (as_ @Int32 (val_ startId)) `unionAll_` do + previousId <- reuse ids + guard_ (previousId <. val_ endId) + pure (previousId + 1) + pure ids + + deletedRows <- Pg.cteDeleteReturning + (dbCteRows cteDb) + (\row -> exists_ $ do + recursiveId <- reuse recursiveIds + guard_ (cteId row ==. recursiveId) + pure recursiveId) + id + + pure (reuse deletedRows) + +nestedSelectCteSelect :: SqlSelect Postgres (CteRowT Identity) +nestedSelectCteSelect = select $ Pg.pgSelectWith $ do + selected <- selecting $ do + row <- all_ (dbCteRows cteDb) + guard_ (cteId row ==. val_ 1) + pure row + pure (reuse selected) + +-- PostgreSQL permits a recursive SELECT CTE to feed a later modifying CTE, but +-- not a modifying CTE to recursively reference itself. 'pgToTopLevel' closes the +-- recursive SELECT knot before the DELETE is added. +recursiveSelectThenDeleteCteSelect :: SqlSelect Postgres (CteRowT Identity) +recursiveSelectThenDeleteCteSelect = Pg.pgSelectWithTopLevel $ do + recursiveIds <- Pg.pgToTopLevel $ mdo + ids <- Pg.pgSelecting $ + pure (as_ @Int32 (val_ 1)) `unionAll_` do + previousId <- reuse ids + guard_ (previousId <. val_ 2) + pure (previousId + 1) + pure ids + + deleted <- Pg.cteDeleteReturning + (dbCteRows cteDb) + (\row -> exists_ $ do + recursiveId <- reuse recursiveIds + guard_ (cteId row ==. recursiveId) + pure recursiveId) + id + + pure (reuse deleted) + +-- Empty INSERT values and identity UPDATE assignments do not produce SQL. +-- Their wrappers return Nothing, leaving pgSelectWithTopLevel to render the +-- final query without an empty WITH clause. +emptyDataModifyingCteSelect :: SqlSelect Postgres Int32 +emptyDataModifyingCteSelect = Pg.pgSelectWithTopLevel $ do + inserted <- Pg.cteInsertReturning + (dbCteRows cteDb) + SqlInsertValuesEmpty + Pg.onConflictDefault + id + updated <- Pg.cteUpdateReturning + (dbCteRows cteDb) + (const mempty) + (const (val_ True)) + id + case (inserted, updated) of + (Nothing, Nothing) -> pure finalQuery + _ -> error "Expected empty INSERT and UPDATE CTEs" + where + finalQuery :: Q Postgres CteDb QBaseScope (QExpr Postgres QBaseScope Int32) + finalQuery = pure (val_ 1) + +-- The portable builder reaches PostgreSQL through the SQL99-shaped compatibility +-- instance. Each input table row contributes one row to the reusable +-- degree-zero relation even though the projection contains no values. +emptySelectProjection :: SqlSelect Postgres (EmptyCteT Identity) +emptySelectProjection = selectWith $ do + rows <- selecting $ do + _ <- all_ (dbCteRows cteDb) + pure (EmptyCte :: EmptyCteT (QExpr Postgres CTE.QAnyScope)) + pure (reuse rows) + +-- The native SELECT path additionally carries PostgreSQL's materialization +-- policy. Its logical result is identical for all three policies. +emptyNativeSelectProjection + :: Pg.PgCteMaterialization + -> SqlSelect Postgres (EmptyCteT Identity) +emptyNativeSelectProjection materialization = Pg.pgSelectWithTopLevel $ do + rows <- Pg.pgSelectingWith materialization $ do + _ <- all_ (dbCteRows cteDb) + pure (EmptyCte :: EmptyCteT (QExpr Postgres CTE.QAnyScope)) + pure (reuse rows) + +-- SELECT CTEs remain nestable when their relation has degree zero. +nestedEmptySelectProjection :: SqlSelect Postgres (EmptyCteT Identity) +nestedEmptySelectProjection = select $ Pg.pgSelectWithNested $ do + rows <- Pg.pgSelecting $ do + _ <- all_ (dbCteRows cteDb) + pure (EmptyCte :: EmptyCteT (QExpr Postgres CTE.QAnyScope)) + pure (reuse rows) + +-- COUNT(*) and EXISTS do not need a projected field, so they are natural +-- consumers of a degree-zero relation. Both references share one CTE body. +emptySelectSummary :: SqlSelect Postgres (Int32, Bool) +emptySelectSummary = Pg.pgSelectWithTopLevel $ do + rows <- Pg.pgSelecting $ do + _ <- all_ (dbCteRows cteDb) + pure (EmptyCte :: EmptyCteT (QExpr Postgres CTE.QAnyScope)) + pure $ do + count <- aggregate_ (const (as_ @Int32 countAll_)) (reuse rows) + pure (count, exists_ (reuse rows)) + +-- The next three fixtures deliberately return no logical values. PostgreSQL's +-- RETURNING grammar is satisfied internally, while the outer SELECT exposes no +-- physical columns and retains one row per affected table row. +emptyInsertProjection + :: [CteRowT Identity] + -> SqlSelect Postgres (EmptyCteT Identity) +emptyInsertProjection values = Pg.pgSelectWithTopLevel $ do + rows <- Pg.cteInsertReturning + (dbCteRows cteDb) + (insertValues values) + Pg.onConflictDefault + (const (EmptyCte :: EmptyCteT (QExpr Postgres PostgresInaccessible))) + case rows of + Just rows' -> pure (reuse rows') + Nothing -> error "Expected non-empty INSERT values" + +emptyUpdateProjection + :: Int32 + -> Text + -> SqlSelect Postgres (EmptyCteT Identity) +emptyUpdateProjection maximumId value = Pg.pgSelectWithTopLevel $ do + rows <- Pg.cteUpdateReturning + (dbCteRows cteDb) + (\row -> cteValue row <-. val_ value) + (\row -> cteId row <=. val_ maximumId) + (const (EmptyCte :: EmptyCteT (QExpr Postgres PostgresInaccessible))) + case rows of + Just rows' -> pure (reuse rows') + Nothing -> error "Expected a non-identity UPDATE" + +emptyDeleteProjection + :: Int32 + -> SqlSelect Postgres (EmptyCteT Identity) +emptyDeleteProjection minimumId = Pg.pgSelectWithTopLevel $ do + rows <- Pg.cteDeleteReturning + (dbCteRows cteDb) + (\row -> cteId row >=. val_ minimumId) + (const (EmptyCte :: EmptyCteT (QExpr Postgres PostgresInaccessible))) + pure (reuse rows) + +-- Two references to the same modifying CTE must multiply its row cardinality, +-- not execute the DELETE twice or expose its private sentinel. +repeatedEmptyDeleteProjection :: SqlSelect Postgres (EmptyCteT Identity) +repeatedEmptyDeleteProjection = Pg.pgSelectWithTopLevel $ do + rows <- Pg.cteDeleteReturning + (dbCteRows cteDb) + (const (val_ True)) + (const (EmptyCte :: EmptyCteT (QExpr Postgres PostgresInaccessible))) + pure $ do + _ <- reuse rows + _ <- reuse rows + pure (EmptyCte :: EmptyCteT (QExpr Postgres QBaseScope)) + +-- Aggregating the reusable DELETE result verifies that the private physical +-- sentinel supplies relational rows without becoming a Beam expression. +emptyDeleteSummary :: SqlSelect Postgres (Int32, Bool) +emptyDeleteSummary = Pg.pgSelectWithTopLevel $ do + rows <- Pg.cteDeleteReturning + (dbCteRows cteDb) + (const (val_ True)) + (const (EmptyCte :: EmptyCteT (QExpr Postgres PostgresInaccessible))) + pure $ do + count <- aggregate_ (const (as_ @Int32 countAll_)) (reuse rows) + pure (count, exists_ (reuse rows)) + +-- Copy one row selected by the CTE into a new row. insertFrom is what exposes +-- the reusable query to the terminal INSERT source. +insertWithStatement :: SqlInsert Postgres CteRowT +insertWithStatement = Pg.pgInsertWith $ do + source <- Pg.pgSelecting $ do + row <- all_ (dbCteRows cteDb) + guard_ (cteId row ==. val_ 1) + pure row + pure $ Pg.insert + (dbCteRows cteDb) + (insertFrom $ do + row <- reuse source + pure (CteRow (cteId row + 1) (val_ "inserted-with"))) + Pg.onConflictDefault + +-- Select the target key independently, then reference it through EXISTS in +-- the terminal UPDATE predicate. +updateWithStatement :: SqlUpdate Postgres CteRowT +updateWithStatement = Pg.pgUpdateWith $ do + targets <- Pg.pgSelecting $ do + row <- all_ (dbCteRows cteDb) + guard_ (cteId row ==. val_ 3) + pure (cteId row) + pure $ update + (dbCteRows cteDb) + (\row -> cteValue row <-. val_ "updated-with") + (\row -> exists_ $ do + targetId <- reuse targets + guard_ (cteId row ==. targetId) + pure targetId) + +-- The DELETE form uses the same reusable-key pattern as UPDATE, exercising +-- the third terminal syntax wrapper. +deleteWithStatement :: SqlDelete Postgres CteRowT +deleteWithStatement = Pg.pgDeleteWith $ do + targets <- Pg.pgSelecting $ do + row <- all_ (dbCteRows cteDb) + guard_ (cteId row ==. val_ 4) + pure (cteId row) + pure $ delete (dbCteRows cteDb) $ \row -> exists_ $ do + targetId <- reuse targets + guard_ (cteId row ==. targetId) + pure targetId + +-- Recursion is completed while the block is still nested-safe. The terminal +-- INSERT then consumes the recursive result at top level. +recursiveInsertWithStatement :: SqlInsert Postgres CteRowT +recursiveInsertWithStatement = Pg.pgInsertWith recursiveInsertWith + +recursiveInsertWith + :: Pg.PgWith CteDb 'Pg.PgCteNestedAllowed (SqlInsert Postgres CteRowT) +recursiveInsertWith = mdo + ids <- Pg.pgSelecting $ + pure (as_ @Int32 (val_ 1)) `unionAll_` do + previousId <- reuse ids + guard_ (previousId <. val_ 2) + pure (previousId + 1) + pure $ Pg.insert + (dbCteRows cteDb) + (insertFrom $ do + rowId <- reuse ids + pure (CteRow rowId (val_ "recursive"))) + Pg.onConflictDefault + +-- Adding a modifying CTE fixes the block to PgCteTopLevelOnly. pgDeleteWith is +-- a top-level consumer, so this remains well-typed. +topLevelOnlyDeleteWithStatement :: SqlDelete Postgres CteRowT +topLevelOnlyDeleteWithStatement = Pg.pgDeleteWith $ do + _ <- Pg.cteDeleteReturning + (dbCteRows cteDb) + (\row -> cteId row ==. val_ 99) + id + pure $ delete + (dbCteRows cteDb) + (\row -> cteId row ==. val_ 100) + +emptyInsertWithStatement :: SqlInsert Postgres CteRowT +emptyInsertWithStatement = Pg.pgInsertWith $ do + _ <- Pg.pgSelecting $ all_ (dbCteRows cteDb) + pure $ Pg.insert + (dbCteRows cteDb) + SqlInsertValuesEmpty + Pg.onConflictDefault + +identityUpdateWithStatement :: SqlUpdate Postgres CteRowT +identityUpdateWithStatement = Pg.pgUpdateWith $ do + _ <- Pg.pgSelecting $ all_ (dbCteRows cteDb) + pure $ update + (dbCteRows cteDb) + (const mempty) + (const (val_ True)) + +assertWithTerminal + :: String + -> Maybe String + -> Assertion +assertWithTerminal terminal rendered = do + sql <- requireRenderedStatement rendered + assertBool "starts with WITH" ("WITH " `isPrefixOf` sql) + assertBool ("renders terminal " ++ terminal) ((" " ++ terminal) `isInfixOf` sql) + +requireRenderedStatement + :: Maybe String + -> IO String +requireRenderedStatement rendered = + case rendered of + Nothing -> assertFailure "expected a PostgreSQL statement" >> pure "" + Just sql -> pure sql + +renderInsert :: SqlInsert Postgres table -> Maybe String +renderInsert SqlInsertNoRows = Nothing +renderInsert (SqlInsert _ (PgInsertSyntax syntax)) = + Just (BL.unpack (pgRenderSyntaxScript syntax)) + +renderUpdate :: SqlUpdate Postgres table -> Maybe String +renderUpdate SqlIdentityUpdate = Nothing +renderUpdate (SqlUpdate _ (PgUpdateSyntax syntax)) = + Just (BL.unpack (pgRenderSyntaxScript syntax)) + +renderDelete :: SqlDelete Postgres table -> Maybe String +renderDelete (SqlDelete _ (PgDeleteSyntax syntax)) = + Just (BL.unpack (pgRenderSyntaxScript syntax)) + +assertReturning :: String -> Maybe String -> Assertion +assertReturning command rendered = do + sql <- requireRenderedStatement rendered + assertBool (command ++ " retains its WITH prefix") ("WITH " `isPrefixOf` sql) + assertBool (command ++ " renders RETURNING") (" RETURNING " `isInfixOf` sql) + +renderInsertReturning :: Pg.PgInsertReturning a -> Maybe String +renderInsertReturning Pg.PgInsertReturningEmpty = Nothing +renderInsertReturning (Pg.PgInsertReturning syntax) = + Just (BL.unpack (pgRenderSyntaxScript syntax)) + +renderUpdateReturning :: Pg.PgUpdateReturning a -> Maybe String +renderUpdateReturning Pg.PgUpdateReturningEmpty = Nothing +renderUpdateReturning (Pg.PgUpdateReturning syntax) = + Just (BL.unpack (pgRenderSyntaxScript syntax)) + +renderDeleteReturning :: Pg.PgDeleteReturning a -> Maybe String +renderDeleteReturning (Pg.PgDeleteReturning syntax) = + Just (BL.unpack (pgRenderSyntaxScript syntax)) + +renderSelect :: SqlSelect Postgres a -> String +renderSelect = BL.unpack . renderSelectBytes + +renderSelectBytes :: SqlSelect Postgres a -> BL.ByteString +renderSelectBytes (SqlSelect (PgSelectSyntax syntax)) = + pgRenderSyntaxScript syntax diff --git a/test/Database/Beam/Postgres/Test/CTENegative.hs b/test/Database/Beam/Postgres/Test/CTENegative.hs new file mode 100644 --- /dev/null +++ b/test/Database/Beam/Postgres/Test/CTENegative.hs @@ -0,0 +1,180 @@ +{-# OPTIONS_GHC -fdefer-type-errors -Wno-deferred-type-errors #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE StandaloneDeriving #-} + +-- This module deliberately contains expressions which must not type-check. +-- Deferred type errors are isolated here so the positive CTE tests retain +-- normal, strict type checking. +module Database.Beam.Postgres.Test.CTENegative + ( invalidNestedDelete + , invalidNestedInsert + , invalidNestedUpdate + , invalidNestedSelectThenDelete + , invalidNestedDeleteThenSelect + , invalidNestedEmptyInsert + , invalidNestedIdentityUpdate + , invalidNestedSideEffectDelete + , invalidCoercedPlacement + , invalidRecursiveInsert + , invalidReuseSideEffect + ) where + +import qualified Data.Coerce as Coerce +import Data.Int (Int32) +import Data.Text (Text) + +import Database.Beam +import Database.Beam.Postgres +import qualified Database.Beam.Postgres.Full as Pg +import qualified Database.Beam.Query.CTE as CTE + +data NegativeCteRowT f = NegativeCteRow + { negativeCteId :: C f Int32 + , negativeCteValue :: C f Text + } deriving (Generic, Beamable) + +deriving instance Show (NegativeCteRowT Identity) +deriving instance Eq (NegativeCteRowT Identity) + +instance Table NegativeCteRowT where + data PrimaryKey NegativeCteRowT f = NegativeCteRowKey (C f Int32) + deriving (Generic, Beamable) + primaryKey = NegativeCteRowKey . negativeCteId + +newtype NegativeCteDb entity = NegativeCteDb + { negativeCteRows :: entity (TableEntity NegativeCteRowT) + } deriving (Generic, Database Postgres) + +negativeCteDb :: DatabaseSettings Postgres NegativeCteDb +negativeCteDb = defaultDbSettings + +-- Each of the following three expressions attempts to put a modifying CTE in +-- pgSelectWithNested. They must fail with PgCteTopLevelOnly versus +-- PgCteNestedAllowed, +-- independently of which data-modifying command produced the CTE. +invalidNestedDelete :: SqlSelect Postgres (NegativeCteRowT Identity) +invalidNestedDelete = select $ Pg.pgSelectWithNested $ do + deleted <- topLevelDeleteCte + pure (reuse deleted) + +invalidNestedInsert :: SqlSelect Postgres (NegativeCteRowT Identity) +invalidNestedInsert = select $ Pg.pgSelectWithNested $ do + inserted <- Pg.cteInsertReturning + (negativeCteRows negativeCteDb) + (insertValues [NegativeCteRow 2 "inserted"]) + Pg.onConflictDefault + id + case inserted of + Nothing -> pure $ all_ (negativeCteRows negativeCteDb) + Just inserted' -> pure (reuse inserted') + +invalidNestedUpdate :: SqlSelect Postgres (NegativeCteRowT Identity) +invalidNestedUpdate = select $ Pg.pgSelectWithNested $ do + updated <- Pg.cteUpdateReturning + (negativeCteRows negativeCteDb) + (\row -> negativeCteValue row <-. val_ "updated") + (\row -> negativeCteId row ==. val_ 1) + id + case updated of + Nothing -> pure $ all_ (negativeCteRows negativeCteDb) + Just updated' -> pure (reuse updated') + +-- Placement is a property of the whole With block. Reordering a normal SELECT +-- CTE around the DELETE must not weaken the top-level-only requirement. +invalidNestedSelectThenDelete :: SqlSelect Postgres (NegativeCteRowT Identity) +invalidNestedSelectThenDelete = select $ Pg.pgSelectWithNested $ do + _ <- nestedSelectCte + deleted <- topLevelDeleteCte + pure (reuse deleted) + +invalidNestedDeleteThenSelect :: SqlSelect Postgres (NegativeCteRowT Identity) +invalidNestedDeleteThenSelect = select $ Pg.pgSelectWithNested $ do + deleted <- topLevelDeleteCte + _ <- nestedSelectCte + pure (reuse deleted) + +-- The result is conservatively top-level-only even when the supplied values or +-- assignments make the INSERT or UPDATE a no-op. The placement index cannot +-- vary with that value-level outcome. +invalidNestedEmptyInsert :: SqlSelect Postgres (NegativeCteRowT Identity) +invalidNestedEmptyInsert = select $ Pg.pgSelectWithNested $ do + inserted <- Pg.cteInsertReturning + (negativeCteRows negativeCteDb) + SqlInsertValuesEmpty + Pg.onConflictDefault + id + case inserted of + Nothing -> pure $ all_ (negativeCteRows negativeCteDb) + Just inserted' -> pure (reuse inserted') + +invalidNestedIdentityUpdate :: SqlSelect Postgres (NegativeCteRowT Identity) +invalidNestedIdentityUpdate = select $ Pg.pgSelectWithNested $ do + updated <- Pg.cteUpdateReturning + (negativeCteRows negativeCteDb) + (const mempty) + (const (val_ True)) + id + case updated of + Nothing -> pure $ all_ (negativeCteRows negativeCteDb) + Just updated' -> pure (reuse updated') + +-- A no-RETURNING modifying CTE has the same top-level placement requirement as +-- its returning counterpart, even though it exposes no relation. +invalidNestedSideEffectDelete :: SqlSelect Postgres (NegativeCteRowT Identity) +invalidNestedSideEffectDelete = select $ Pg.pgSelectWithNested $ do + Pg.cteDelete + (negativeCteRows negativeCteDb) + (\row -> negativeCteId row ==. val_ 1) + pure $ all_ (negativeCteRows negativeCteDb) + +-- PgWith has nominal roles and an abstract constructor, so Data.Coerce cannot +-- be used to relabel a top-level-only block as nested-safe. +invalidCoercedPlacement :: SqlSelect Postgres (NegativeCteRowT Identity) +invalidCoercedPlacement = select $ Pg.pgSelectWithNested $ coercePlacement $ do + deleted <- topLevelDeleteCte + pure (reuse deleted) + +-- MonadFix exists only for PgCteNestedAllowed. This prevents an INSERT CTE from +-- reading its own RETURNING rows recursively, which PostgreSQL rejects. +invalidRecursiveInsert :: SqlSelect Postgres (NegativeCteRowT Identity) +invalidRecursiveInsert = Pg.pgSelectWithTopLevel $ mdo + ~(Just inserted) <- Pg.cteInsertReturning + (negativeCteRows negativeCteDb) + (insertFrom (reuse inserted)) + Pg.onConflictDefault + id + pure (reuse inserted) + +-- Side-effect-only CTEs deliberately return unit because a DML statement +-- without RETURNING forms no temporary relation in PostgreSQL. +invalidReuseSideEffect :: SqlSelect Postgres (NegativeCteRowT Identity) +invalidReuseSideEffect = Pg.pgSelectWithTopLevel $ do + deleted <- Pg.cteDelete + (negativeCteRows negativeCteDb) + (\row -> negativeCteId row ==. val_ 1) + let impossible + :: ReusableQ Postgres NegativeCteDb + (NegativeCteRowT (QExpr Postgres CTE.QAnyScope)) + impossible = deleted + pure (reuse impossible) + +coercePlacement + :: Pg.PgWith NegativeCteDb 'Pg.PgCteTopLevelOnly a + -> Pg.PgWith NegativeCteDb 'Pg.PgCteNestedAllowed a +coercePlacement = Coerce.coerce + +nestedSelectCte + :: Pg.PgWith NegativeCteDb placement + (ReusableQ Postgres NegativeCteDb + (NegativeCteRowT (QExpr Postgres CTE.QAnyScope))) +nestedSelectCte = Pg.pgSelecting $ all_ (negativeCteRows negativeCteDb) + +topLevelDeleteCte + :: Pg.PgWith NegativeCteDb 'Pg.PgCteTopLevelOnly + (ReusableQ Postgres NegativeCteDb + (NegativeCteRowT (QExpr Postgres CTE.QAnyScope))) +topLevelDeleteCte = Pg.cteDeleteReturning + (negativeCteRows negativeCteDb) + (\row -> negativeCteId row ==. val_ 1) + id diff --git a/test/Database/Beam/Postgres/Test/Copy.hs b/test/Database/Beam/Postgres/Test/Copy.hs new file mode 100644 --- /dev/null +++ b/test/Database/Beam/Postgres/Test/Copy.hs @@ -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" + } + } diff --git a/test/Database/Beam/Postgres/Test/DataTypes.hs b/test/Database/Beam/Postgres/Test/DataTypes.hs --- a/test/Database/Beam/Postgres/Test/DataTypes.hs +++ b/test/Database/Beam/Postgres/Test/DataTypes.hs @@ -3,10 +3,10 @@ module Database.Beam.Postgres.Test.DataTypes where import Database.Beam +import Database.Beam.Backend.SQL.BeamExtensions +import Database.Beam.Migrate import Database.Beam.Postgres import Database.Beam.Postgres.Test -import Database.Beam.Migrate -import Database.Beam.Backend.SQL.BeamExtensions import Control.Exception (SomeException(..), handle) @@ -141,15 +141,15 @@ -- | Regression test for errorOnLiteralDoubles :: IO ByteString -> TestTree errorOnLiteralDoubles pgConn = - testCase "Literal `Double`s are correctly specified as SQL `DOUBLE` (#700)" $ + testCase "Literal `Double`s are correctly specified as SQL `DOUBLE` (#700)" $ withTestPostgres "db_failures" pgConn $ \conn -> do - results <- runBeamPostgres conn $ - runSelectReturningList $ - select $ + results <- runBeamPostgres conn $ + runSelectReturningList $ + select $ query - + results @?= [(99 :: Int32, 1.0 :: Double)] - + where -- We need to provide a db for type-checking, but it will not be used query :: Q Postgres RealDb s (QExpr Postgres s Int32, QExpr Postgres s Double) diff --git a/test/Database/Beam/Postgres/Test/Marshal.hs b/test/Database/Beam/Postgres/Test/Marshal.hs --- a/test/Database/Beam/Postgres/Test/Marshal.hs +++ b/test/Database/Beam/Postgres/Test/Marshal.hs @@ -52,7 +52,7 @@ (PgPoint (max x1 x2) (max y1 y2))) arrayGen :: Hedgehog.Gen a -> Hedgehog.Gen (Vector.Vector a) -arrayGen = fmap Vector.fromList +arrayGen = fmap Vector.fromList . Gen.list (Range.linear 0 5) -- small arrays == quick tests boxCmp :: PgBox -> PgBox -> Bool @@ -100,8 +100,8 @@ -- Arrays -- - -- Testing lots of element types for arrays is important, because - -- the mapping between array Oid and element Oid is not type + -- Testing lots of element types for arrays is important, because + -- the mapping between array Oid and element Oid is not type -- safe, and hence error-prone. , marshalTest (arrayGen textGen) postgresConn , marshalTest (arrayGen (Gen.double (Range.exponentialFloat 0 1e40))) postgresConn diff --git a/test/Database/Beam/Postgres/Test/Select.hs b/test/Database/Beam/Postgres/Test/Select.hs --- a/test/Database/Beam/Postgres/Test/Select.hs +++ b/test/Database/Beam/Postgres/Test/Select.hs @@ -5,6 +5,7 @@ import Data.Aeson import Data.ByteString (ByteString) +import Data.List.NonEmpty (NonEmpty(..)) import Data.Int import Data.List (sort) import qualified Data.Text as T @@ -164,7 +165,7 @@ pgCreateExtension @UuidOssp let ext = getPgExtension $ _uuidOssp $ unCheckDatabase db runSelectReturningList $ select $ do - v <- values_ [val_ nil] + v <- values_ (val_ nil :| []) return $ pgUuidGenerateV5 ext v "" assertEqual "result" [V5.generateNamed nil []] result diff --git a/test/Database/Beam/Postgres/Test/Select/PgNubBy.hs b/test/Database/Beam/Postgres/Test/Select/PgNubBy.hs new file mode 100644 --- /dev/null +++ b/test/Database/Beam/Postgres/Test/Select/PgNubBy.hs @@ -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 diff --git a/test/Database/Beam/Postgres/Test/Windowing.hs b/test/Database/Beam/Postgres/Test/Windowing.hs new file mode 100644 --- /dev/null +++ b/test/Database/Beam/Postgres/Test/Windowing.hs @@ -0,0 +1,221 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE StandaloneDeriving #-} + +module Database.Beam.Postgres.Test.Windowing (tests) where + +import Database.Beam +import Database.Beam.Backend.SQL.BeamExtensions +import Database.Beam.Migrate +import Database.Beam.Migrate.Simple (autoMigrate) +import Database.Beam.Postgres +import Database.Beam.Postgres.Migrate (migrationBackend) +import Database.Beam.Postgres.Test + +import Control.Exception (SomeException (..), handle) + +import Data.ByteString (ByteString) +import Data.Int +import Data.Text (Text) + +import Control.Monad (void) +import Test.Tasty +import Test.Tasty.HUnit + +tests :: IO ByteString -> TestTree +tests postgresConn = + testGroup + "Windowing unit tests" + [ testLead1 postgresConn + , testLag1 postgresConn + , testLead postgresConn + , testLag postgresConn + , testLeadWithDefault postgresConn + , testLagWithDefault postgresConn + ] + +testLead1 :: IO ByteString -> TestTree +testLead1 = testCase "lead1_" . windowingQueryTest query expectation + where + query = + withWindow_ + ( \Person{name} -> + frame_ + noPartition_ + (orderPartitionBy_ (asc_ name)) + noBounds_ + ) + ( \Person{name} w -> + (name, lead1_ name `over_` w) + ) + (all_ $ persons db) + expectation = [("Alice", Just "Bob"), ("Bob", Just "Claire"), ("Claire", Nothing)] + +testLag1 :: IO ByteString -> TestTree +testLag1 = testCase "lag1_" . windowingQueryTest query expectation + where + query = + withWindow_ + ( \Person{name} -> + frame_ + noPartition_ + (orderPartitionBy_ (asc_ name)) + noBounds_ + ) + ( \Person{name} w -> + (name, lag1_ name `over_` w) + ) + (all_ $ persons db) + expectation = [("Alice", Nothing), ("Bob", Just "Alice"), ("Claire", Just "Bob")] + +testLead :: IO ByteString -> TestTree +testLead getConnStr = + testGroup + "lead_" + [ testCase "n=1" $ windowingQueryTest (query 1) [("Alice", Just "Bob"), ("Bob", Just "Claire"), ("Claire", Nothing)] getConnStr + , testCase "n=2" $ windowingQueryTest (query 2) [("Alice", Just "Claire"), ("Bob", Nothing), ("Claire", Nothing)] getConnStr + ] + where + query n = + withWindow_ + ( \Person{name} -> + frame_ + noPartition_ + (orderPartitionBy_ (asc_ name)) + noBounds_ + ) + ( \Person{name} w -> + (name, lead_ name (val_ (n :: Int32)) `over_` w) + ) + (all_ $ persons db) + expectation1 = [] + +testLag :: IO ByteString -> TestTree +testLag getConnStr = + testGroup + "lag_" + [ testCase "n=1" $ windowingQueryTest (query 1) [("Alice", Nothing), ("Bob", Just "Alice"), ("Claire", Just "Bob")] getConnStr + , testCase "n=2" $ windowingQueryTest (query 2) [("Alice", Nothing), ("Bob", Nothing), ("Claire", Just "Alice")] getConnStr + ] + where + query n = + withWindow_ + ( \Person{name} -> + frame_ + noPartition_ + (orderPartitionBy_ (asc_ name)) + noBounds_ + ) + ( \Person{name} w -> + (name, lag_ name (val_ (n :: Int32)) `over_` w) + ) + (all_ $ persons db) + expectation = [] + + +testLeadWithDefault :: IO ByteString -> TestTree +testLeadWithDefault getConnStr = + testGroup + "leadWithDefault_" + [ testCase "n=1" $ windowingQueryTest (query 1 "default") [("Alice", "Bob"), ("Bob", "Claire"), ("Claire", "default")] getConnStr + , testCase "n=2" $ windowingQueryTest (query 2 "default") [("Alice", "Claire"), ("Bob", "default"), ("Claire", "default")] getConnStr + ] + where + query n def = + withWindow_ + ( \Person{name} -> + frame_ + noPartition_ + (orderPartitionBy_ (asc_ name)) + noBounds_ + ) + ( \Person{name} w -> + (name, leadWithDefault_ name (val_ (n :: Int32)) (val_ def) `over_` w) + ) + (all_ $ persons db) + expectation1 = [] + + +testLagWithDefault :: IO ByteString -> TestTree +testLagWithDefault getConnStr = + testGroup + "lagWithDefault_" + [ testCase "n=1" $ windowingQueryTest (query 1 "default") [("Alice", "default"), ("Bob", "Alice"), ("Claire", "Bob")] getConnStr + , testCase "n=2" $ windowingQueryTest (query 2 "default") [("Alice", "default"), ("Bob", "default"), ("Claire", "Alice")] getConnStr + ] + where + query n def = + withWindow_ + ( \Person{name} -> + frame_ + noPartition_ + (orderPartitionBy_ (asc_ name)) + noBounds_ + ) + ( \Person{name} w -> + (name, lagWithDefault_ name (val_ (n :: Int32)) (val_ def) `over_` w) + ) + (all_ $ persons db) + expectation = [] + + + +data PersonT f = Person + { name :: C f Text + } + deriving (Generic) + +type Person = PersonT Identity + +type PersonExpr s = PersonT (QExpr Postgres s) + +deriving instance Show Person +deriving instance Eq Person + +instance Beamable PersonT + +instance Table PersonT where + data PrimaryKey PersonT f = PersonKey (C f Text) + deriving stock (Generic) + deriving anyclass (Beamable) + + primaryKey Person{name} = PersonKey name + +data Db f = Db + { persons :: f (TableEntity PersonT) + } + deriving (Generic) + +instance Database Postgres Db + +db :: DatabaseSettings Postgres Db +db = defaultDbSettings + +windowingQueryTest :: + (Eq a, Show a, Eq b, Show b, FromBackendRow Postgres a, FromBackendRow Postgres b) => + Q Postgres Db QBaseScope (QExpr Postgres s a, QExpr Postgres s b) -> + [(a, b)] -> + IO ByteString -> + Assertion +windowingQueryTest query expectation getConnStr = + withTestPostgres "db_windowing_psql" getConnStr $ + \conn -> do + prepareTable conn + results <- + runBeamPostgres conn $ + runSelectReturningList $ + select query + + assertEqual "Unexpected" expectation results + +prepareTable :: Connection -> IO () +prepareTable conn = + runBeamPostgres conn $ do + void $ autoMigrate migrationBackend (defaultMigratableDbSettings @Postgres @Db) + runInsert $ + insert (persons db) $ + insertValues + [ Person "Alice" + , Person "Bob" + , Person "Claire" + ] diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -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 + }