beam-postgres 0.4.0.0 → 0.6.3.0
raw patch · 30 files changed
Files
- ChangeLog.md +254/−0
- Database/Beam/Postgres.hs +179/−43
- Database/Beam/Postgres/Conduit.hs +184/−76
- Database/Beam/Postgres/Connection.hs +238/−93
- Database/Beam/Postgres/CustomTypes.hs +0/−3
- Database/Beam/Postgres/Debug.hs +3/−5
- Database/Beam/Postgres/Extensions.hs +38/−6
- Database/Beam/Postgres/Extensions/Copy/File.hs +421/−0
- Database/Beam/Postgres/Extensions/Copy/Stream.hs +175/−0
- Database/Beam/Postgres/Extensions/UuidOssp.hs +62/−0
- Database/Beam/Postgres/Full.hs +1354/−557
- Database/Beam/Postgres/Migrate.hs +204/−42
- Database/Beam/Postgres/PgCrypto.hs +4/−13
- Database/Beam/Postgres/PgSpecific.hs +385/−59
- Database/Beam/Postgres/Syntax.hs +261/−36
- Database/Beam/Postgres/TempTable.hs +62/−0
- Database/Beam/Postgres/Types.hs +73/−22
- beam-postgres.cabal +57/−26
- test/Database/Beam/Postgres/Test.hs +11/−65
- test/Database/Beam/Postgres/Test/CTE.hs +1334/−0
- test/Database/Beam/Postgres/Test/CTENegative.hs +180/−0
- test/Database/Beam/Postgres/Test/Copy.hs +444/−0
- test/Database/Beam/Postgres/Test/DataTypes.hs +32/−14
- test/Database/Beam/Postgres/Test/Marshal.hs +32/−11
- test/Database/Beam/Postgres/Test/Migrate.hs +253/−0
- test/Database/Beam/Postgres/Test/Select.hs +262/−26
- test/Database/Beam/Postgres/Test/Select/PgNubBy.hs +119/−0
- test/Database/Beam/Postgres/Test/TempTable.hs +87/−0
- test/Database/Beam/Postgres/Test/Windowing.hs +221/−0
- test/Main.hs +59/−9
ChangeLog.md view
@@ -1,3 +1,257 @@+# 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++* Fixed a critical bug introduced by the performance improvements of 0.5.6.0, which would+ result in unexpected type errors when executing database queries.+ While the bug has been fixed, performance remains as good as the 0.5.6.0 release (#803)++# 0.5.6.0++## Added features++* Support for temporary tables.++* `getDbConstraintsForSchemas` now discovers foreign key constraints+ via `pg_constraint`, including `ON DELETE` / `ON UPDATE` actions.++## Performance improvements++* By minimizing redundant work in the hot loop, the performance of `beam-postgres`+ when fetching data from a database has been improved by 30%. The performance+ of `beam-postgres` is now within 10% of raw queries via `postgresql-simple` (#797).++# 0.5.5.0++## Added features++* Add support for creating secondary indices, supporting both `CREATE INDEX` and+ `CREATE UNIQUE INDEX`. `getDbConstraintsForSchemas` now discovers user-created+ secondary indices via `pg_index` (excluding primary keys and+ constraint-backing indices).++# 0.5.4.4++## Added features++* Added the array functions `arrayAppend_`, `arrayPrepend_`, `arrayRemove_`, `arrayReplace_`, `arrayShuffle_`, `arraySample_`, `arrayToString_`, and `arrayToStringWithNull_` (#770)++## Updated dependencies++* Updated the upper bound on `time` to include `time-1.14`++# 0.5.4.3++## Added features++ * Added `pgSelectWith`, a combinator like `selectWith` which allows to nest common table expressions in subqueries (#720).++## Bug fixes++ * Added the ability to migrate Postgres' array types (#354).+ * Remove dependency on `haskell-src-exts`, which was not in use anymore.++# 0.5.4.2++## Bug fixes++ * Fixed an issue where columns of type `Maybe (Vector a)` did not marshall correctly from the database. In particular, querying a `Nothing` would return `Just (Vector.fromList [])` instead (#692).++# 0.5.4.1++## Bug fixes++ * Fixed an issue where inexact numeric literals (e.g. Haskell type `Double`) were implicitly converted to Postgres `NUMERIC`, triggering a runtime conversion error (#700).++# 0.5.4.0++## Added features++ * Better error messages on column type mismatches (#696).+ * Added support for creating and dropping database schemas and associated tables with `createDatabaseSchema`, `dropDatabaseSchema`, and `createTableWithSchema` (#716).++## Documentation++ * Make `runBeamPostgres` and `runBeamPostgresDebug` easier to find (#663).++# 0.5.3.1++## Added features++ * Loosen some version bounds++# 0.5.3.0++## Bug fixes++ * Make sure lateral join names do not overlap+ * Fix `bool_or`++## Addded features++ * Add `runSelectReturningFirst`+ * `IN (SELECT ...)` syntax via `inQuery_`++# 0.5.2.1++## Added features++ * Aeson 2.0 support++# 0.5.2.0++## Added features++ * New `conduit` streaming variants which work directly in `MonadResource`+ * Heterogeneous variant of `ilike_`: `ilike_'`+ * Postgres-specific `EXTRACT` fields+ * GHC 9.2 and 9.0 support++## Bug fixes++ * Throw correct exception for row errors in `conduit` implementation+ * Support emitting UUID values in context where type cannot be inferred by Postgres++# 0.5.1.0++## Added features++ * `MonadBase` and `MonadBaseControl` instances for `Pg`++## Bug fixes++ * Fix possible memory corruption by copying row data+ * Remove invalid parentheses emitted by `pgUnnest`++# 0.5.0.0++## Interface changes++ * Removed instances for machine-dependent ambiguous integer types `Int` and `Word`+ * Fixed types for some functions that only work with `jsonb` and not `json`++## Added features++ * Support for `in_` on row values+ * Various Postgres regex functions+ * Expose `fromPgIntegral` and `fromPgScientificOrIntegral`+ * Add `liftIOWithHandle :: (Connection -> IO a) -> Pg a`+ * Add `getDbConstraintsForSchemas` to get constraints without relying on the state of the connection+ * Poly-kinded instances for `Data.Tagged.Tagged`+ * Add `HasDefaultDatatype` for `UTCTime`+ * Support for specifically-sized `SqlSerial` integers (`smallserial`, `serial`, `bigserial`)+ * Predicate detection for extensions+ * `pgArrayToJson` for `array_to_json`+ * Extension definition and all functions provided by `uuid-ossp`+ * GHC 8.8 support++## Bug fixes++ * Only detect primary keys of tables in visible schemas+ * Fix emitting of `DECIMAL` type+ * Report JSON correct decoding errors instead of throwing `UnexpectedNull`++## Behavior changes++ * `runReturningOne` and `runResturningList` now fetch all rows at once instead of using cursors++# 0.4.0.0+ # 0.3.2.0 Add `Semigroup` instances to prepare for GHC 8.4 and Stackage nightly
Database/Beam/Postgres.hs view
@@ -15,67 +15,203 @@ -- <https://www.postgresql.org/docs/current/static/index.html behavior>. -- -- For examples on how to use @beam-postgres@ usage, see--- <http://tathougies.github.io/beam/user-guide/backends/beam-postgres/ its manual>.-+-- <https://haskell-beam.github.io/beam/user-guide/backends/beam-postgres/ its manual>. module Database.Beam.Postgres- ( -- * Beam Postgres backend- Postgres(..), Pg+ ( -- * Beam Postgres backend+ Postgres (..),+ Pg,+ liftIOWithHandle, + -- ** Executing actions against the backend+ 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+ -- *** Top-level options sums+ PgCopyToOptions,+ PgCopyFromOptions, - , runBeamPostgres, runBeamPostgresDebug+ -- ** Streaming COPY support - -- ** Postgres extension support- , PgExtensionEntity, IsPgExtension(..)- , pgCreateExtension, pgDropExtension- , getPgExtension+ --+ -- 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.Syntax hiding (PostgresInaccessible)-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 )-import Database.Beam.Postgres.Debug+-- for BeamHasInsertOnConflict instance +import Database.Beam.Postgres.Debug+import Database.Beam.Postgres.Extensions+ ( IsPgExtension (..),+ PgExtensionEntity,+ getPgExtension,+ pgCreateExtension,+ pgDropExtension,+ )+import Database.Beam.Postgres.Extensions.Copy.File+ ( PgCSVCopyFromOptions (..),+ PgCSVCopyToOptions (..),+ PgCopyFromOptions,+ PgCopyToOptions,+ PgTextCopyFromOptions (..),+ PgTextCopyToOptions (..),+ copyFromCSV,+ copyFromCSVWith,+ copyFromText,+ copyFromTextWith,+ copyToCSV,+ copyToCSVWith,+ copyToText,+ copyToTextWith,+ defaultPgCSVCopyFromOptions,+ defaultPgCSVCopyToOptions,+ defaultPgTextCopyFromOptions,+ defaultPgTextCopyToOptions,+ )+import Database.Beam.Postgres.Extensions.Copy.Stream+ ( PgCopyFromStreamOptions,+ PgCopyToStreamOptions,+ copyFromCSVStream,+ copyFromCSVStreamWith,+ copyFromTextStream,+ copyFromTextStreamWith,+ copyToCSVStream,+ copyToCSVStreamWith,+ copyToTextStream,+ copyToTextStreamWith,+ )+import Database.Beam.Postgres.Full ()+import Database.Beam.Postgres.Migrate+ ( bigserial,+ bytea,+ json,+ jsonb,+ money,+ serial,+ smallserial,+ text,+ tsquery,+ tsvector,+ unboundedArray,+ uuid,+ )+import Database.Beam.Postgres.PgSpecific+import Database.Beam.Postgres.Syntax+ ( PgCommandSyntax,+ PgDeleteSyntax,+ PgInsertSyntax,+ PgSelectSyntax,+ PgSyntax,+ PgUpdateSyntax,+ )+import Database.Beam.Postgres.TempTable+import Database.Beam.Postgres.Types+ ( Postgres (..),+ fromPgIntegral,+ fromPgScientificOrIntegral,+ ) import qualified Database.PostgreSQL.Simple as Pg
Database/Beam/Postgres/Conduit.hs view
@@ -1,34 +1,57 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-} -- | More efficient query execution functions for @beam-postgres@. These -- functions use the @conduit@ package, to execute @beam-postgres@ statements in -- an arbitrary 'MonadIO'. These functions may be more efficient for streaming -- operations than 'MonadBeam'.-module Database.Beam.Postgres.Conduit where+module Database.Beam.Postgres.Conduit+ ( streamingRunSelect+ , runInsert+ , streamingRunInsertReturning+ , runUpdate+ , streamingRunUpdateReturning+ , runDelete+ , streamingRunDeleteReturning+ , executeStatement+ , streamingRunQueryReturning+ -- * Deprecated streaming variants+ , runSelect+ , runInsertReturning+ , runUpdateReturning+ , runDeleteReturning+ , runQueryReturning+ ) where -import Database.Beam+import Database.Beam hiding (runInsert, runUpdate, runDelete) import Database.Beam.Postgres.Connection import Database.Beam.Postgres.Full import Database.Beam.Postgres.Syntax import Database.Beam.Postgres.Types +import Control.Concurrent.MVar (takeMVar, putMVar)+import Control.Exception.Base (bracket, throwIO) import Control.Exception.Lifted (finally)+import qualified Control.Exception.Lifted as Lifted+import qualified Control.Concurrent.MVar.Lifted as Lifted import Control.Monad.Trans.Control (MonadBaseControl) import qualified Database.PostgreSQL.LibPQ as Pg hiding (Connection, escapeStringConn, escapeIdentifier, escapeByteaConn, exec)+import qualified Database.PostgreSQL.LibPQ as Pq import qualified Database.PostgreSQL.Simple as Pg-import qualified Database.PostgreSQL.Simple.Internal as Pg (withConnection)+import qualified Database.PostgreSQL.Simple.Internal as Pg+import Database.PostgreSQL.Simple.Internal (connectionHandle) import qualified Database.PostgreSQL.Simple.Types as Pg (Query(..)) -import qualified Data.Conduit as C+import qualified Conduit as C import Data.Int (Int64) import Data.Maybe (fromMaybe)-#if !MIN_VERSION_base(4, 11, 0)-import Data.Semigroup-#endif+import qualified Data.Vector as V +import qualified Control.Monad.Fail as Fail+ #if MIN_VERSION_conduit(1,3,0) #define CONDUIT_TRANSFORMER C.ConduitT #else@@ -37,13 +60,22 @@ -- * @SELECT@ +-- | Run a PostgreSQL @SELECT@ statement in any 'C.MonadResource'.+streamingRunSelect :: ( C.MonadResource m, Fail.MonadFail m, FromBackendRow Postgres a )+ => Pg.Connection -> SqlSelect Postgres a+ -> CONDUIT_TRANSFORMER () a m ()+streamingRunSelect conn (SqlSelect (PgSelectSyntax syntax)) =+ streamingRunQueryReturning conn syntax+ -- | Run a PostgreSQL @SELECT@ statement in any 'MonadIO'.-runSelect :: ( MonadIO m, MonadBaseControl IO m, FromBackendRow Postgres a )+runSelect :: ( MonadIO m, Fail.MonadFail m, MonadBaseControl IO m, FromBackendRow Postgres a ) => Pg.Connection -> SqlSelect Postgres a -> (CONDUIT_TRANSFORMER () a m () -> m b) -> m b runSelect conn (SqlSelect (PgSelectSyntax syntax)) withSrc = runQueryReturning conn syntax withSrc+{-# DEPRECATED runSelect "Use streamingRunSelect" #-} + -- * @INSERT@ -- | Run a PostgreSQL @INSERT@ statement in any 'MonadIO'. Returns the number of@@ -54,9 +86,19 @@ runInsert conn (SqlInsert _ (PgInsertSyntax i)) = executeStatement conn i +-- | Run a PostgreSQL @INSERT ... RETURNING ...@ statement in any 'C.MonadResource' and+-- get a 'C.Source' of the newly inserted rows.+streamingRunInsertReturning :: ( C.MonadResource m, Fail.MonadFail m, FromBackendRow Postgres a )+ => Pg.Connection+ -> PgInsertReturning a+ -> CONDUIT_TRANSFORMER () a m ()+streamingRunInsertReturning _ PgInsertReturningEmpty = pure ()+streamingRunInsertReturning conn (PgInsertReturning i) =+ streamingRunQueryReturning conn i+ -- | Run a PostgreSQL @INSERT ... RETURNING ...@ statement in any 'MonadIO' and -- get a 'C.Source' of the newly inserted rows.-runInsertReturning :: ( MonadIO m, MonadBaseControl IO m, FromBackendRow Postgres a )+runInsertReturning :: ( MonadIO m, Fail.MonadFail m, MonadBaseControl IO m, FromBackendRow Postgres a ) => Pg.Connection -> PgInsertReturning a -> (CONDUIT_TRANSFORMER () a m () -> m b)@@ -64,6 +106,7 @@ runInsertReturning _ PgInsertReturningEmpty withSrc = withSrc (pure ()) runInsertReturning conn (PgInsertReturning i) withSrc = runQueryReturning conn i withSrc+{-# DEPRECATED runInsertReturning "Use streamingRunInsertReturning" #-} -- * @UPDATE@ @@ -75,9 +118,19 @@ runUpdate conn (SqlUpdate _ (PgUpdateSyntax i)) = executeStatement conn i +-- | Run a PostgreSQL @UPDATE ... RETURNING ...@ statement in any 'C.MonadResource' and+-- get a 'C.Source' of the newly updated rows.+streamingRunUpdateReturning :: ( C.MonadResource m, Fail.MonadFail m, FromBackendRow Postgres a)+ => Pg.Connection+ -> PgUpdateReturning a+ -> CONDUIT_TRANSFORMER () a m ()+streamingRunUpdateReturning _ PgUpdateReturningEmpty = pure ()+streamingRunUpdateReturning conn (PgUpdateReturning u) =+ streamingRunQueryReturning conn u+ -- | Run a PostgreSQL @UPDATE ... RETURNING ...@ statement in any 'MonadIO' and -- get a 'C.Source' of the newly updated rows.-runUpdateReturning :: ( MonadIO m, MonadBaseControl IO m, FromBackendRow Postgres a)+runUpdateReturning :: ( MonadIO m, Fail.MonadFail m, MonadBaseControl IO m, FromBackendRow Postgres a) => Pg.Connection -> PgUpdateReturning a -> (CONDUIT_TRANSFORMER () a m () -> m b)@@ -85,6 +138,7 @@ runUpdateReturning _ PgUpdateReturningEmpty withSrc = withSrc (pure ()) runUpdateReturning conn (PgUpdateReturning u) withSrc = runQueryReturning conn u withSrc+{-# DEPRECATED runUpdateReturning "Use streamingRunUpdateReturning" #-} -- * @DELETE@ @@ -97,12 +151,21 @@ executeStatement conn d -- | Run a PostgreSQl @DELETE ... RETURNING ...@ statement in any+-- 'C.MonadResource' and get a 'C.Source' of the deleted rows.+streamingRunDeleteReturning :: ( C.MonadResource m, Fail.MonadFail m, FromBackendRow Postgres a )+ => Pg.Connection -> PgDeleteReturning a+ -> CONDUIT_TRANSFORMER () a m ()+streamingRunDeleteReturning conn (PgDeleteReturning d) =+ streamingRunQueryReturning conn d++-- | Run a PostgreSQl @DELETE ... RETURNING ...@ statement in any -- 'MonadIO' and get a 'C.Source' of the deleted rows.-runDeleteReturning :: ( MonadIO m, MonadBaseControl IO m, FromBackendRow Postgres a )+runDeleteReturning :: ( MonadIO m, Fail.MonadFail m, MonadBaseControl IO m, FromBackendRow Postgres a ) => Pg.Connection -> PgDeleteReturning a -> (CONDUIT_TRANSFORMER () a m () -> m b) -> m b runDeleteReturning conn (PgDeleteReturning d) withSrc = runQueryReturning conn d withSrc+{-# DEPRECATED runDeleteReturning "Use streamingRunDeleteReturning" #-} -- * Convenience functions @@ -113,77 +176,122 @@ syntax <- pgRenderSyntax conn x Pg.execute_ conn (Pg.Query syntax) + -- | Runs any query that returns a set of values-runQueryReturning- :: ( MonadIO m, MonadBaseControl IO m, Functor m, FromBackendRow Postgres r )+streamingRunQueryReturning+ :: ( C.MonadResource m, Fail.MonadFail m, FromBackendRow Postgres r ) => Pg.Connection -> PgSyntax- -> (CONDUIT_TRANSFORMER () r m () -> m b)- -> m b-runQueryReturning conn x withSrc = do- success <- liftIO $ do- syntax <- pgRenderSyntax conn x+ -> CONDUIT_TRANSFORMER () r m ()+streamingRunQueryReturning (conn@Pg.Connection {connectionHandle}) x = do+ syntax <- liftIO $ pgRenderSyntax conn x+ -- We need to own the connection for the duration of the conduit's+ -- lifetime, since it will be in a streaming state until we clean up+ C.bracketP+ (takeMVar connectionHandle)+ (putMVar connectionHandle)+ (\conn' -> do+ success <- liftIO $+ if Pg.isNullConnection conn'+ then throwIO Pg.disconnectedError+ else Pg.sendQuery conn' syntax - Pg.withConnection conn (\conn' -> Pg.sendQuery conn' syntax)+ if success+ then do+ singleRowModeSet <- liftIO $ Pg.setSingleRowMode conn'+ if singleRowModeSet+ then+ C.bracketP+ (pure ())+ (\_ -> gracefulShutdown conn')+ (\_ -> streamResults conn conn' Nothing)+ else Fail.fail "Could not enable single row mode"+ else do+ errMsg <- fromMaybe "No libpq error provided" <$> liftIO (Pg.errorMessage conn')+ Fail.fail (show errMsg)) - if success- then do- singleRowModeSet <- liftIO (Pg.withConnection conn Pg.setSingleRowMode)- if singleRowModeSet- then withSrc (streamResults Nothing) `finally` gracefulShutdown- else fail "Could not enable single row mode"- else do- errMsg <- fromMaybe "No libpq error provided" <$> liftIO (Pg.withConnection conn Pg.errorMessage)- fail (show errMsg)+streamResults :: (Fail.MonadFail m, FromBackendRow Postgres r, MonadIO m) => Pg.Connection -> Pq.Connection -> Maybe [Pg.Field] -> C.ConduitT i r m ()+streamResults (conn@Pg.Connection {connectionHandle}) conn' fields = do+ nextRow <- liftIO (Pg.getResult conn')+ case nextRow of+ Nothing -> pure ()+ Just row ->+ liftIO (Pg.resultStatus row) >>=+ \case+ Pg.SingleTuple ->+ do fields' <- liftIO (maybe (getFields row) (pure . V.fromList) fields)+ parsedRow <- liftIO $ bracket+ (putMVar connectionHandle conn')+ (\_ -> takeMVar connectionHandle)+ (\_ -> runPgRowReader conn 0 row fields' fromBackendRow)+ case parsedRow of+ Left err -> liftIO (bailEarly conn' row ("Could not read row: " <> show err))+ Right parsedRow' ->+ do C.yield parsedRow'+ streamResults conn conn' (Just (V.toList fields'))+ Pg.TuplesOk -> liftIO (finishQuery conn')+ Pg.EmptyQuery -> Fail.fail "No query"+ Pg.CommandOk -> pure ()+ status@Pg.BadResponse -> liftIO (Pg.throwResultError "streamResults" row status)+ status@Pg.NonfatalError -> liftIO (Pg.throwResultError "streamResults" row status)+ status@Pg.FatalError -> liftIO (Pg.throwResultError "streamResults" row status)+ _ -> do errMsg <- liftIO (Pg.resultErrorMessage row)+ Fail.fail ("Postgres error: " <> show errMsg) - where- streamResults fields = do- nextRow <- liftIO (Pg.withConnection conn Pg.getResult)- case nextRow of- Nothing -> pure ()- Just row ->- liftIO (Pg.resultStatus row) >>=- \case- Pg.SingleTuple ->- do fields' <- liftIO (maybe (getFields row) pure fields)- parsedRow <- liftIO (runPgRowReader conn 0 row fields' fromBackendRow)- case parsedRow of- Left err -> liftIO (bailEarly row ("Could not read row: " <> show err))- Right parsedRow' ->- do C.yield parsedRow'- streamResults (Just fields')- Pg.TuplesOk -> liftIO (Pg.withConnection conn finishQuery)- Pg.EmptyQuery -> fail "No query"- Pg.CommandOk -> pure ()- _ -> do errMsg <- liftIO (Pg.resultErrorMessage row)- fail ("Postgres error: " <> show errMsg)+bailEarly :: Pq.Connection -> Pg.Result -> String -> IO a+bailEarly conn' row errorString = do+ Pg.unsafeFreeResult row+ cancelQuery conn'+ Fail.fail errorString - bailEarly row errorString = do- Pg.unsafeFreeResult row- Pg.withConnection conn $ cancelQuery- fail errorString+cancelQuery :: Pq.Connection -> IO ()+cancelQuery conn' = do+ cancel <- Pg.getCancel conn'+ case cancel of+ Nothing -> pure ()+ Just cancel' -> do+ res <- Pg.cancel cancel'+ case res of+ Right () -> liftIO (finishQuery conn')+ Left err -> Fail.fail ("Could not cancel: " <> show err) - cancelQuery conn' = do- cancel <- Pg.getCancel conn'- case cancel of- Nothing -> pure ()- Just cancel' -> do- res <- Pg.cancel cancel'- case res of- Right () -> liftIO (finishQuery conn')- Left err -> fail ("Could not cancel: " <> show err)+finishQuery :: Pq.Connection -> IO ()+finishQuery conn' = do+ nextRow <- Pg.getResult conn'+ case nextRow of+ Nothing -> pure ()+ Just _ -> finishQuery conn' - finishQuery conn' = do- nextRow <- Pg.getResult conn'- case nextRow of- Nothing -> pure ()- Just _ -> finishQuery conn'+gracefulShutdown :: Pq.Connection -> IO ()+gracefulShutdown conn' = do+ sts <- Pg.transactionStatus conn'+ case sts of+ Pg.TransIdle -> pure ()+ Pg.TransInTrans -> pure ()+ Pg.TransInError -> pure ()+ Pg.TransUnknown -> pure ()+ Pg.TransActive -> cancelQuery conn' - gracefulShutdown =- liftIO . Pg.withConnection conn $ \conn' ->- do sts <- Pg.transactionStatus conn'- case sts of- Pg.TransIdle -> pure ()- Pg.TransInTrans -> pure ()- Pg.TransInError -> pure ()- Pg.TransUnknown -> pure ()- Pg.TransActive -> cancelQuery conn'+-- | Runs any query that returns a set of values+runQueryReturning+ :: ( MonadIO m, Fail.MonadFail m, MonadBaseControl IO m, Functor m, FromBackendRow Postgres r )+ => Pg.Connection -> PgSyntax+ -> (CONDUIT_TRANSFORMER () r m () -> m b)+ -> m b+runQueryReturning (conn@Pg.Connection {connectionHandle}) x withSrc = do+ syntax <- liftIO $ pgRenderSyntax conn x++ Lifted.bracket+ (Lifted.takeMVar connectionHandle)+ (Lifted.putMVar connectionHandle)+ (\conn' -> do+ success <- liftIO $ Pg.sendQuery conn' syntax+ if success+ then do+ singleRowModeSet <- liftIO (Pg.setSingleRowMode conn')+ if singleRowModeSet+ then withSrc (streamResults conn conn' Nothing) `finally` (liftIO $ gracefulShutdown conn')+ else Fail.fail "Could not enable single row mode"+ else do+ errMsg <- fromMaybe "No libpq error provided" <$> liftIO (Pg.errorMessage conn')+ Fail.fail (show errMsg))+{-# DEPRECATED runQueryReturning "Use streamingRunQueryReturning" #-}
Database/Beam/Postgres/Connection.hs view
@@ -5,16 +5,17 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-} module Database.Beam.Postgres.Connection ( Pg(..), PgF(..) + , liftIOWithHandle+ , runBeamPostgres, runBeamPostgresDebug , pgRenderSyntax, runPgRowReader, getFields@@ -23,18 +24,27 @@ , postgresUriSyntax ) where -import Control.Exception (SomeException(..), throwIO)+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 import Database.Beam.Backend.SQL.Row ( FromBackendRowF(..), FromBackendRowM(..) , BeamRowReadError(..), ColumnParseError(..) ) import Database.Beam.Backend.URI-import Database.Beam.Query.Types (QGenExpr(..)) 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@@ -42,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(..)@@ -53,7 +64,6 @@ import Control.Monad.Reader import Control.Monad.State-import Control.Monad.Fail (MonadFail) import qualified Control.Monad.Fail as Fail import Data.ByteString (ByteString)@@ -64,14 +74,7 @@ import Data.String import qualified Data.Text as T import Data.Text.Encoding (decodeUtf8)-#if MIN_VERSION_base(4,12,0) import Data.Typeable (cast)-#else-import Data.Typeable (cast, typeOf)-#endif-#if !MIN_VERSION_base(4, 11, 0)-import Data.Semigroup-#endif import Foreign.C.Types @@ -123,29 +126,34 @@ -- * Run row readers -getFields :: Pg.Result -> IO [Pg.Field]+getFields :: Pg.Result -> IO (Vector Pg.Field) getFields res = do Pg.Col colCount <- Pg.nfields res-- let getField col =- Pg.Field res (Pg.Col col) <$> Pg.ftype res (Pg.Col col)-- mapM getField [0..colCount - 1]+ V.generateM (fromIntegral colCount) $ \i ->+ let col = Pg.Col (fromIntegral i)+ in Pg.Field res col <$> Pg.ftype res col runPgRowReader ::- Pg.Connection -> Pg.Row -> Pg.Result -> [Pg.Field] -> FromBackendRowM Postgres a -> IO (Either BeamRowReadError a)+ Pg.Connection -> Pg.Row -> Pg.Result -> Vector Pg.Field -> FromBackendRowM Postgres a -> IO (Either BeamRowReadError a) runPgRowReader conn rowIdx res fields (FromBackendRowM readRow) =- Pg.nfields res >>= \(Pg.Col colCount) ->- runF readRow finish step 0 colCount fields+ -- 'colCount' and 'fields' are both invariant for the duration of one+ -- 'runPgRowReader' call, so we capture them in the closure of 'step'+ -- rather than threading them through the free-monad result type.+ -- That makes the per-step closure smaller and avoids an O(n) 'length'+ -- per row (Vector stores its length, so 'V.length' is O(1)).+ runF readRow finish step 0 where+ !colCount = fromIntegral (V.length fields) :: CInt - step :: forall x. FromBackendRowF Postgres (CInt -> CInt -> [PgI.Field] -> IO (Either BeamRowReadError x))- -> CInt -> CInt -> [PgI.Field] -> IO (Either BeamRowReadError x)- step (ParseOneField _) curCol colCount [] = pure (Left (BeamRowReadError (Just (fromIntegral curCol)) (ColumnNotEnoughColumns (fromIntegral colCount))))- step (ParseOneField _) curCol colCount _- | curCol >= colCount = pure (Left (BeamRowReadError (Just (fromIntegral curCol)) (ColumnNotEnoughColumns (fromIntegral colCount))))- step (ParseOneField (next' :: next -> _)) curCol colCount (field:remainingFields) =- do fieldValue <- Pg.getvalue res rowIdx (Pg.Col curCol)+ step :: forall x. FromBackendRowF Postgres (CInt -> IO (Either BeamRowReadError x))+ -> CInt -> IO (Either BeamRowReadError x)+ step (ParseOneField _) curCol+ | curCol >= colCount =+ pure (Left (BeamRowReadError (Just (fromIntegral curCol))+ (ColumnNotEnoughColumns (fromIntegral colCount))))+ step (ParseOneField (next' :: next -> _)) curCol =+ do let field = V.unsafeIndex fields (fromIntegral curCol)+ fieldValue <- Pg.getvalue' res rowIdx (Pg.Col curCol) res' <- Pg.runConversion (Pg.fromField field fieldValue) conn case res' of Pg.Errors errs ->@@ -156,39 +164,62 @@ case pgErr of Pg.ConversionFailed { Pg.errSQLType = sql , Pg.errHaskellType = hs- , Pg.errMessage = msg } ->- pure (ColumnTypeMismatch hs sql msg)+ , Pg.errMessage = msg+ , Pg.errSQLField = errField } ->+ pure (ColumnTypeMismatch hs sql ("Conversion failed for field'" <> errField <> "': " <> msg)) Pg.Incompatible { Pg.errSQLType = sql , Pg.errHaskellType = hs- , Pg.errMessage = msg } ->- pure (ColumnTypeMismatch hs sql msg)+ , Pg.errMessage = msg+ , Pg.errSQLField = errField } ->+ pure (ColumnTypeMismatch hs sql ("Incompatible field: '" <> errField <> "': " <> msg)) Pg.UnexpectedNull {} -> pure ColumnUnexpectedNull in pure (Left (BeamRowReadError (Just (fromIntegral curCol)) err))- Pg.Ok x -> next' x (curCol + 1) colCount remainingFields+ Pg.Ok x -> next' x (curCol + 1) - step (Alt (FromBackendRowM a) (FromBackendRowM b) next) curCol colCount cols =- do aRes <- runF a (\x curCol' colCount' cols' -> pure (Right (next x curCol' colCount' cols'))) step curCol colCount cols+ step (Alt (FromBackendRowM a) (FromBackendRowM b) next) curCol =+ do aRes <- runF a (\x curCol' -> pure (Right (next x curCol'))) step curCol case aRes of Right next' -> next' Left aErr -> do- bRes <- runF b (\x curCol' colCount' cols' -> pure (Right (next x curCol' colCount' cols'))) step curCol colCount cols+ bRes <- runF b (\x curCol' -> pure (Right (next x curCol'))) step curCol case bRes of Right next' -> next' Left {} -> pure (Left aErr) - step (FailParseWith err) _ _ _ =+ step (FailParseWith err) _ = pure (Left err) - finish x _ _ _ = pure (Right x)+ finish x _ = pure (Right x) withPgDebug :: (String -> IO ()) -> Pg.Connection -> Pg a -> IO (Either BeamRowReadError a)-withPgDebug dbg conn (Pg action) =- let finish x = pure (Right x)+withPgDebug dbg conn (Pg action) = do+ -- One-entry cache for the cursor-batch path: 'Pg.Result' is constant+ -- within a batch but changes between batches. Caching by 'Pg.Result'+ -- equality (a 'ForeignPtr' comparison, ~free) avoids the redundant+ -- 'getFields' / 'nfields' / 'ftype' calls within each batch.+ --+ -- Default batch size is 256 rows, set by 'postgresql-simple'+ -- 'defaultFoldOptions' (FetchQuantity = Automatic, which resolves to+ -- 256 in 'Database.PostgreSQL.Simple').+ fieldsCache <- newIORef (Nothing :: Maybe (Pg.Result, Vector Pg.Field))++ let cachedGetFields :: Pg.Result -> IO (Vector Pg.Field)+ cachedGetFields res = do+ cached <- readIORef fieldsCache+ case cached of+ Just (cachedRes, fs) | cachedRes == res -> pure fs+ _ -> do+ fs <- getFields res+ writeIORef fieldsCache (Just (res, fs))+ pure fs++ finish x = pure (Right x) step (PgLiftIO io next) = io >>= next- step (PgLiftWithHandle withConn next) = withConn conn >>= next+ step (PgLiftWithHandle withConn next) = withConn dbg conn >>= next step (PgFetchNext next) = next Nothing- step (PgRunReturning (PgCommandSyntax PgCommandTypeQuery syntax)+ step (PgRunReturning CursorBatching+ (PgCommandSyntax PgCommandTypeQuery syntax) (mkProcess :: Pg (Maybe x) -> Pg a') next) = do query <- pgRenderSyntax conn syntax@@ -205,44 +236,61 @@ columnCount = fromIntegral $ valuesNeeded (Proxy @Postgres) (Proxy @x) in Pg.foldWith_ (Pg.RP (put columnCount >> ask)) conn (Pg.Query query) (PgStreamContinue nextStream) runConsumer >>= finishUp- step (PgRunReturning (PgCommandSyntax PgCommandTypeDataUpdateReturning syntax) mkProcess next) =+ step (PgRunReturning AtOnce+ (PgCommandSyntax PgCommandTypeQuery syntax)+ (mkProcess :: Pg (Maybe x) -> Pg a')+ next) =+ renderExecReturningList "No tuples returned to Postgres query" syntax mkProcess next+ step (PgRunReturning _ (PgCommandSyntax PgCommandTypeDataUpdateReturning syntax) mkProcess next) =+ renderExecReturningList "No tuples returned to Postgres update/insert returning" syntax mkProcess next+ step (PgRunReturning _ (PgCommandSyntax _ syntax) mkProcess next) = do query <- pgRenderSyntax conn syntax dbg (T.unpack (decodeUtf8 query))+ _ <- Pg.execute_ conn (Pg.Query query) + let Pg process = mkProcess (Pg (liftF (PgFetchNext id)))+ runF process next stepReturningNone++ renderExecReturningList :: (FromBackendRow Postgres x) => _ -> PgSyntax -> (Pg (Maybe x) -> Pg a') -> _ -> _+ renderExecReturningList errMsg syntax mkProcess next =+ do query <- pgRenderSyntax conn syntax+ dbg (T.unpack (decodeUtf8 query))+ res <- Pg.exec conn query sts <- Pg.resultStatus res case sts of Pg.TuplesOk -> do+ -- Hoist per-query metadata out of the per-row loop: the+ -- same 'Pg.Result' is used for every row, so 'fields'+ -- and 'rowCount' are loop-invariant.+ -- Use getFields directly: unsafeFreeResult below lets libpq+ -- reuse the pointer address, which would cause a false hit in+ -- cachedGetFields on the next query.+ fields <- getFields res+ Pg.Row rowCount <- Pg.ntuples res let Pg process = mkProcess (Pg (liftF (PgFetchNext id)))- runF process (\x _ -> Pg.unsafeFreeResult res >> next x) (stepReturningList res) 0- _ -> Pg.throwResultError "No tuples returned to Postgres update/insert returning"- res sts- step (PgRunReturning (PgCommandSyntax _ syntax) mkProcess next) =- do query <- pgRenderSyntax conn syntax- dbg (T.unpack (decodeUtf8 query))- _ <- Pg.execute_ conn (Pg.Query query)-- let Pg process = mkProcess (Pg (liftF (PgFetchNext id)))- runF process next stepReturningNone+ runF process (\x _ -> Pg.unsafeFreeResult res >> next x)+ (stepReturningList fields rowCount res) 0+ _ -> Pg.throwResultError errMsg res sts stepReturningNone :: forall a. PgF (IO (Either BeamRowReadError a)) -> IO (Either BeamRowReadError a) stepReturningNone (PgLiftIO action' next) = action' >>= next- stepReturningNone (PgLiftWithHandle withConn next) = withConn conn >>= next+ stepReturningNone (PgLiftWithHandle withConn next) = withConn dbg conn >>= next stepReturningNone (PgFetchNext next) = next Nothing- stepReturningNone (PgRunReturning _ _ _) = pure (Left (BeamRowReadError Nothing (ColumnErrorInternal "Nested queries not allowed")))+ stepReturningNone (PgRunReturning {}) = pure (Left (BeamRowReadError Nothing (ColumnErrorInternal "Nested queries not allowed"))) - stepReturningList :: forall a. Pg.Result -> PgF (CInt -> IO (Either BeamRowReadError a)) -> CInt -> IO (Either BeamRowReadError a)- stepReturningList _ (PgLiftIO action' next) rowIdx = action' >>= \x -> next x rowIdx- stepReturningList res (PgFetchNext next) rowIdx =- do fields <- getFields res- Pg.Row rowCount <- Pg.ntuples res- if rowIdx >= rowCount- then next Nothing rowIdx- else runPgRowReader conn (Pg.Row rowIdx) res fields fromBackendRow >>= \case- Left err -> pure (Left err)- Right r -> next (Just r) (rowIdx + 1)- stepReturningList _ (PgRunReturning _ _ _) _ = pure (Left (BeamRowReadError Nothing (ColumnErrorInternal "Nested queries not allowed")))- stepReturningList _ (PgLiftWithHandle {}) _ = pure (Left (BeamRowReadError Nothing (ColumnErrorInternal "Nested queries not allowed")))+ stepReturningList :: forall a. Vector Pg.Field -> CInt -> Pg.Result+ -> PgF (CInt -> IO (Either BeamRowReadError a))+ -> CInt -> IO (Either BeamRowReadError a)+ stepReturningList _ _ _ (PgLiftIO action' next) rowIdx = action' >>= \x -> next x rowIdx+ stepReturningList fields rowCount res (PgFetchNext next) rowIdx =+ if rowIdx >= rowCount+ then next Nothing rowIdx+ else runPgRowReader conn (Pg.Row rowIdx) res fields fromBackendRow >>= \case+ Left err -> pure (Left err)+ Right r -> next (Just r) (rowIdx + 1)+ stepReturningList _ _ _ (PgRunReturning {}) _ = pure (Left (BeamRowReadError Nothing (ColumnErrorInternal "Nested queries not allowed")))+ stepReturningList _ _ _ (PgLiftWithHandle {}) _ = pure (Left (BeamRowReadError Nothing (ColumnErrorInternal "Nested queries not allowed"))) finishProcess :: forall a. a -> Maybe PgI.Row -> IO (PgStream a) finishProcess x _ = pure (PgStreamDone (Right x))@@ -254,51 +302,78 @@ case res of Nothing -> next Nothing Nothing Just (PgI.Row rowIdx res') ->- getFields res' >>= \fields ->+ cachedGetFields res' >>= \fields -> runPgRowReader conn rowIdx res' fields fromBackendRow >>= \case Left err -> pure (PgStreamDone (Left err)) Right r -> next (Just r) Nothing stepProcess (PgFetchNext next) (Just (PgI.Row rowIdx res)) =- getFields res >>= \fields ->+ cachedGetFields res >>= \fields -> runPgRowReader conn rowIdx res fields fromBackendRow >>= \case Left err -> pure (PgStreamDone (Left err)) Right r -> pure (PgStreamContinue (next (Just r)))- stepProcess (PgRunReturning _ _ _) _ = pure (PgStreamDone (Left (BeamRowReadError Nothing (ColumnErrorInternal "Nested queries not allowed"))))+ stepProcess (PgRunReturning {}) _ = pure (PgStreamDone (Left (BeamRowReadError Nothing (ColumnErrorInternal "Nested queries not allowed")))) stepProcess (PgLiftWithHandle _ _) _ = pure (PgStreamDone (Left (BeamRowReadError Nothing (ColumnErrorInternal "Nested queries not allowed")))) runConsumer :: forall a. PgStream a -> PgI.Row -> IO (PgStream a) runConsumer s@(PgStreamDone {}) _ = pure s runConsumer (PgStreamContinue next) row = next (Just row)- in runF action finish step + runF action finish step+ -- * Beam Monad class data PgF next where PgLiftIO :: IO a -> (a -> next) -> PgF next PgRunReturning :: FromBackendRow Postgres x =>- PgCommandSyntax -> (Pg (Maybe x) -> Pg a) -> (a -> next) -> PgF next+ FetchMode -> PgCommandSyntax -> (Pg (Maybe x) -> Pg a) -> (a -> next) -> PgF next PgFetchNext :: FromBackendRow Postgres x => (Maybe x -> next) -> PgF next- PgLiftWithHandle :: (Pg.Connection -> IO a) -> (a -> next) -> PgF next-deriving instance Functor PgF+ PgLiftWithHandle :: ((String -> IO ()) -> Pg.Connection -> IO a) -> (a -> next) -> PgF next+instance Functor PgF where+ fmap f = \case+ PgLiftIO io n -> PgLiftIO io $ f . n+ PgRunReturning mode cmd consume n -> PgRunReturning mode cmd consume $ f . n+ PgFetchNext n -> PgFetchNext $ f . n+ PgLiftWithHandle withConn n -> PgLiftWithHandle withConn $ f . n +-- | How to fetch results.+data FetchMode+ = CursorBatching -- ^ Fetch in batches of ~256 rows via cursor for SELECT.+ | AtOnce -- ^ Fetch all rows at once.+ -- | 'MonadBeam' in which we can run Postgres commands. See the documentation -- for 'MonadBeam' on examples of how to use. -- -- @beam-postgres@ also provides functions that let you run queries without -- 'MonadBeam'. These functions may be more efficient and offer a conduit -- API. See "Database.Beam.Postgres.Conduit" for more information.+--+-- You can execute 'Pg' actions using 'runBeamPostgres' or 'runBeamPostgresDebug'. newtype Pg a = Pg { runPg :: F PgF a } deriving (Monad, Applicative, Functor, MonadFree PgF) -instance MonadFail Pg where- fail e = fail $ "Internal Error with: " <> show e+instance Fail.MonadFail Pg where+ fail e = liftIO (Fail.fail $ "Internal Error with: " <> show e) instance MonadIO Pg where liftIO x = liftF (PgLiftIO x id) +instance MonadBase IO Pg where+ liftBase = liftIO++instance MonadBaseControl IO Pg where+ type StM Pg a = a++ liftBaseWith action =+ liftF (PgLiftWithHandle (\dbg conn -> action (runBeamPostgresDebug dbg conn)) id)++ restoreM = pure++liftIOWithHandle :: (Pg.Connection -> IO a) -> Pg a+liftIOWithHandle f = liftF (PgLiftWithHandle (\_ -> f) id)+ runBeamPostgresDebug :: (String -> IO ()) -> Pg.Connection -> Pg a -> IO a runBeamPostgresDebug dbg conn action = withPgDebug dbg conn action >>= either throwIO pure@@ -308,15 +383,85 @@ instance MonadBeam Postgres Pg where runReturningMany cmd consume =- liftF (PgRunReturning cmd consume id)+ liftF (PgRunReturning CursorBatching cmd consume 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)+ runReturningOne cmd =+ liftF (PgRunReturning AtOnce cmd consume id)+ where+ consume next = do+ a <- next+ case a of+ Nothing -> pure Nothing+ Just x -> do+ a' <- next+ case a' of+ Nothing -> pure (Just x)+ Just _ -> pure Nothing - -- Make savepoint+ runReturningFirst cmd =+ liftF (PgRunReturning AtOnce cmd id id)++ runReturningList cmd =+ liftF (PgRunReturning AtOnce cmd consume id)+ where+ consume next =+ let collectM acc = do+ a <- next+ case a of+ Nothing -> pure (acc [])+ Just x -> collectM (acc . (x:))+ in collectM id++instance MonadBeamCopyTo Postgres Pg where+ runCopyTo SqlCopyToNoColumns = pure ()+ runCopyTo (SqlCopyTo (PgCopyToSyntax syntax)) =+ runNoReturn (PgCommandSyntax PgCommandTypeDataUpdate syntax)++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 []@@ -324,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 []@@ -336,9 +481,9 @@ runReturningList (PgCommandSyntax PgCommandTypeDataUpdateReturning updateReturningCmd) instance MonadBeamDeleteReturning Postgres Pg where- runDeleteReturningList d = do- let PgDeleteReturning deleteReturningCmd = d `returning`- changeBeamRep (\(Columnar' (QExpr s) :: Columnar' (QExpr Postgres PostgresInaccessible) ty) ->- Columnar' (QExpr s) :: Columnar' (QExpr Postgres ()) ty)-+ runDeleteReturningListWith d mkProjection = do+ let pgProj tbl = mkProjection (changeBeamRep+ (\(Columnar' (QExpr s) :: Columnar' (QExpr Postgres PostgresInaccessible) ty) ->+ Columnar' (QExpr s) :: Columnar' (QExpr Postgres ()) ty) tbl)+ PgDeleteReturning deleteReturningCmd = d `returning` pgProj runReturningList (PgCommandSyntax PgCommandTypeDataUpdateReturning deleteReturningCmd)
Database/Beam/Postgres/CustomTypes.hs view
@@ -40,9 +40,6 @@ import Data.Functor.Const import qualified Data.HashSet as HS import Data.Proxy (Proxy(..))-#if !MIN_VERSION_base(4,11,0)-import Data.Semigroup-#endif import Data.Text (Text) import qualified Data.Text.Encoding as TE
Database/Beam/Postgres/Debug.hs view
@@ -4,7 +4,8 @@ import Database.Beam.Query import Database.Beam.Postgres.Types (Postgres(..)) import Database.Beam.Postgres.Connection- ( Pg, PgF(..)+ ( Pg+ , liftIOWithHandle , pgRenderSyntax ) import Database.Beam.Postgres.Full ( PgInsertReturning(..)@@ -17,10 +18,7 @@ , PgUpdateSyntax(..) , PgDeleteSyntax(..) ) -import Control.Monad.Free ( liftF )- import qualified Data.ByteString.Char8 as BC-import Data.Maybe (maybe) import qualified Database.PostgreSQL.Simple as Pg @@ -69,5 +67,5 @@ pgTraceStmt :: PgDebugStmt statement => statement -> Pg () pgTraceStmt stmt =- liftF (PgLiftWithHandle (flip pgTraceStmtIO stmt) id)+ liftIOWithHandle (flip pgTraceStmtIO stmt)
Database/Beam/Postgres/Extensions.hs view
@@ -1,6 +1,5 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE CPP #-} -- | Postgres extensions are run-time loadable plugins that can extend Postgres -- functionality. Extensions are part of the database schema.@@ -10,9 +9,29 @@ -- the extension in a particular backend. @beam-postgres@ provides predicates -- and checks for @beam-migrate@ which allow extensions to be included as -- regular parts of beam migrations.-module Database.Beam.Postgres.Extensions where+module Database.Beam.Postgres.Extensions (+ -- * Handling extensions+ PgExtensionEntity,+ getPgExtension, + -- * Defining extensions+ IsPgExtension(..),+ -- ** Helpers+ PgExpr,+ LiftPg,+ funcE,++ -- * Migrations+ PgHasExtension(..),+ pgCreateExtension,+ pgDropExtension,+ pgExtensionActionProvider,+) where+ import Database.Beam+import Database.Beam.Backend.SQL ( IsSql92ExpressionSyntax(..), IsSql92FieldNameSyntax(..),+ IsSql99ExpressionSyntax, IsSql99FunctionExpressionSyntax(..)+ ) import Database.Beam.Schema.Tables import Database.Beam.Postgres.Types@@ -27,9 +46,6 @@ import Data.Hashable (Hashable) import Data.Proxy import Data.Text (Text)-#if !MIN_VERSION_base(4, 11, 0)-import Data.Semigroup-#endif -- *** Embedding extensions in databases @@ -39,7 +55,7 @@ -- database, -- -- @--- import Database.Beam.Migrate.PgCrypto+-- import Database.Beam.Postgres.PgCrypto -- -- data MyDatabase entity -- = MyDatabase@@ -125,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@@ -195,3 +226,4 @@ pure (PotentialAction (HS.fromList [p extP]) mempty (pure (MigrationCommand cmd MigrationKeepsData)) ("Unload the postgres extension " <> ext) 1)+
+ Database/Beam/Postgres/Extensions/Copy/File.hs view
@@ -0,0 +1,421 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}++module Database.Beam.Postgres.Extensions.Copy.File+ ( PgCopyToSyntax (..),+ PgCopyToSourceSyntax (..),+ PgCopyFromSyntax (..),+ PgCopyFromSourceSyntax (..),++ -- * COPY options+ PgCopyToOptions,+ PgCopyFromOptions,++ -- ** text+ copyToText,+ copyToTextWith,+ PgTextCopyToOptions (..),+ defaultPgTextCopyToOptions,+ copyFromText,+ copyFromTextWith,+ PgTextCopyFromOptions (..),+ defaultPgTextCopyFromOptions,++ -- ** CSV+ copyToCSV,+ copyToCSVWith,+ PgCSVCopyToOptions (..),+ defaultPgCSVCopyToOptions,+ copyFromCSV,+ copyFromCSVWith,+ PgCSVCopyFromOptions (..),+ defaultPgCSVCopyFromOptions,++ -- * Internal — exposed for use by sibling modules+ emitOptionList,+ textCopyToFields,+ csvCopyToFields,+ textCopyFromFields,+ csvCopyFromFields,+ )+where++import qualified Data.List.NonEmpty as NE+import Data.Maybe (catMaybes)+import Data.Text (Text)+import qualified Data.Text as T+import Database.Beam.Backend.SQL.BeamExtensions+ ( IsSqlCopyFromSourceSyntax (..),+ IsSqlCopyFromSyntax (..),+ IsSqlCopyToSourceSyntax (..),+ IsSqlCopyToSyntax (..),+ )+import Database.Beam.Postgres.Syntax+ ( PgSelectSyntax (..),+ PgSyntax,+ emit,+ pgBoolLit,+ pgCharLit,+ pgParens,+ pgQuotedIdentifier,+ pgSepBy,+ pgStringLit,+ )++-- | PostgreSQL @COPY ... TO@ source syntax. Wraps the table name (with+-- optional column list) or a @SELECT@ subquery.+--+-- @since 0.6.1.0+newtype PgCopyToSourceSyntax = PgCopyToSourceSyntax {fromPgCopyToSource :: PgSyntax}++-- | PostgreSQL @COPY ... TO@ statement syntax.+--+-- @since 0.6.1.0+newtype PgCopyToSyntax = PgCopyToSyntax {fromPgCopyTo :: PgSyntax}++-- | PostgreSQL @COPY ... FROM@ source syntax. Just the table name plus+-- optional column list — Postgres @COPY ... FROM@ does not accept a SELECT.+--+-- @since 0.6.1.0+newtype PgCopyFromSourceSyntax = PgCopyFromSourceSyntax {fromPgCopyFromSource :: PgSyntax}++-- | PostgreSQL @COPY ... FROM@ statement syntax.+--+-- @since 0.6.1.0+newtype PgCopyFromSyntax = PgCopyFromSyntax {fromPgCopyFrom :: PgSyntax}++instance IsSqlCopyToSourceSyntax PgCopyToSourceSyntax where+ type SqlCopyToSourceSelectSyntax PgCopyToSourceSyntax = PgSelectSyntax++ copyTableToSyntax mSchema tableName' mColumns =+ PgCopyToSourceSyntax $+ maybe mempty (\schema -> pgQuotedIdentifier schema <> emit ".") mSchema+ <> pgQuotedIdentifier tableName'+ <> case mColumns of+ Nothing -> mempty+ Just cols -> pgParens $ pgSepBy (emit ", ") (map pgQuotedIdentifier (NE.toList cols))++ copySelectToSyntax (PgSelectSyntax select) = PgCopyToSourceSyntax $ pgParens select++instance IsSqlCopyToSyntax PgCopyToSyntax where+ type SqlCopyToSourceSyntax PgCopyToSyntax = PgCopyToSourceSyntax+ type SqlCopyToParams PgCopyToSyntax = PgCopyToOptions++ copyToStmt (PgCopyToSourceSyntax source) options =+ let (filepath, optionsSyntax) = emitPgCopyToOptions options+ in PgCopyToSyntax $+ mconcat+ [ emit "COPY ",+ source,+ emit " TO ",+ pgStringLit (T.pack filepath),+ optionsSyntax+ ]++instance IsSqlCopyFromSourceSyntax PgCopyFromSourceSyntax where+ copyTableFromSyntax mSchema tableName' mColumns =+ PgCopyFromSourceSyntax $+ maybe mempty (\schema -> pgQuotedIdentifier schema <> emit ".") mSchema+ <> pgQuotedIdentifier tableName'+ <> case mColumns of+ Nothing -> mempty+ Just cols -> pgParens $ pgSepBy (emit ", ") (map pgQuotedIdentifier (NE.toList cols))++instance IsSqlCopyFromSyntax PgCopyFromSyntax where+ type SqlCopyFromSourceSyntax PgCopyFromSyntax = PgCopyFromSourceSyntax+ type SqlCopyFromParams PgCopyFromSyntax = PgCopyFromOptions++ copyFromStmt (PgCopyFromSourceSyntax source) options =+ let (filepath, optionsSyntax) = emitPgCopyFromOptions options+ in PgCopyFromSyntax $+ mconcat+ [ emit "COPY ",+ source,+ emit " FROM ",+ pgStringLit (T.pack filepath),+ optionsSyntax+ ]++-- | Options for PostgreSQL's @COPY ... TO@ statement, tagged by the output+-- format. Use 'copyToText' or 'copyToCSV' to construct.+--+-- See <https://www.postgresql.org/docs/current/sql-copy.html the PostgreSQL COPY documentation>+-- for the full set of options each format supports.+--+-- @since 0.6.1.0+data PgCopyToOptions+ = PgCopyToText !FilePath !PgTextCopyToOptions+ | PgCopyToCSV !FilePath !PgCSVCopyToOptions+ deriving (Eq, Show)++-- | Copy to a text file at the given path with default options.+-- Use 'copyToTextWith' to override.+--+-- @since 0.6.1.0+copyToText :: FilePath -> PgCopyToOptions+copyToText path = PgCopyToText path defaultPgTextCopyToOptions++-- | Copy to a text file at the given path with the given options.+--+-- @since 0.6.1.0+copyToTextWith :: FilePath -> PgTextCopyToOptions -> PgCopyToOptions+copyToTextWith = PgCopyToText++-- | Copy to a CSV file at the given path with default options.+-- Use 'copyToCSVWith' to override.+--+-- @since 0.6.1.0+copyToCSV :: FilePath -> PgCopyToOptions+copyToCSV path = PgCopyToCSV path defaultPgCSVCopyToOptions++-- | Copy to a CSV file at the given path with the given options.+--+-- @since 0.6.1.0+copyToCSVWith :: FilePath -> PgCSVCopyToOptions -> PgCopyToOptions+copyToCSVWith = PgCopyToCSV++-- | Options for PostgreSQL's @COPY ... FROM@ statement, tagged by the input+-- format. Use 'copyFromText' or 'copyFromCSV' to construct.+--+-- @since 0.6.1.0+data PgCopyFromOptions+ = PgCopyFromText !FilePath !PgTextCopyFromOptions+ | PgCopyFromCSV !FilePath !PgCSVCopyFromOptions+ deriving (Eq, Show)++-- | Copy from a text file at the given path with default options.+-- Use 'copyFromTextWith' to override.+--+-- @since 0.6.1.0+copyFromText :: FilePath -> PgCopyFromOptions+copyFromText path = PgCopyFromText path defaultPgTextCopyFromOptions++-- | Copy from a text file at the given path with the given options.+--+-- @since 0.6.1.0+copyFromTextWith :: FilePath -> PgTextCopyFromOptions -> PgCopyFromOptions+copyFromTextWith = PgCopyFromText++-- | Copy from a CSV file at the given path with default options.+-- Use 'copyFromCSVWith' to override.+--+-- @since 0.6.1.0+copyFromCSV :: FilePath -> PgCopyFromOptions+copyFromCSV path = PgCopyFromCSV path defaultPgCSVCopyFromOptions++-- | Copy from a CSV file at the given path with the given options.+--+-- @since 0.6.1.0+copyFromCSVWith :: FilePath -> PgCSVCopyFromOptions -> PgCopyFromOptions+copyFromCSVWith = PgCopyFromCSV++-- | Options for the @text@ format on @COPY ... TO@.+--+-- @since 0.6.1.0+data PgTextCopyToOptions = PgTextCopyToOptions+ { -- | @DELIMITER@: single-character column delimiter. Defaults to TAB.+ pgTextCopyToDelimiter :: Maybe Char,+ -- | @NULL@: token written for SQL @NULL@ values. Defaults to @\\N@.+ pgTextCopyToNullStr :: Maybe Text,+ -- | @HEADER@: emit a header row with column names.+ pgTextCopyToHeader :: Maybe Bool,+ -- | @ENCODING@: client-encoding override for the file.+ pgTextCopyToEncoding :: Maybe Text+ }+ deriving (Eq, Show)++-- | All-'Nothing' 'PgTextCopyToOptions'; a sensible starting point for+-- record-update overrides.+--+-- @since 0.6.1.0+defaultPgTextCopyToOptions :: PgTextCopyToOptions+defaultPgTextCopyToOptions =+ PgTextCopyToOptions+ { pgTextCopyToDelimiter = Nothing,+ pgTextCopyToNullStr = Nothing,+ pgTextCopyToHeader = Nothing,+ pgTextCopyToEncoding = Nothing+ }++-- | Options for the @csv@ format on @COPY ... TO@.+--+-- @since 0.6.1.0+data PgCSVCopyToOptions = PgCSVCopyToOptions+ { -- | @DELIMITER@: single-character column delimiter. Defaults to a comma.+ pgCsvCopyToDelimiter :: Maybe Char,+ -- | @NULL@: token written for SQL @NULL@ values. Defaults to the empty+ -- string.+ pgCsvCopyToNullStr :: Maybe Text,+ -- | @HEADER@: emit a header row with column names.+ pgCsvCopyToHeader :: Maybe Bool,+ -- | @QUOTE@: single-character quote character. Defaults to @\"@.+ pgCsvCopyToQuote :: Maybe Char,+ -- | @ESCAPE@: single-character escape character. Defaults to the+ -- value of 'pgCsvCopyToQuote'.+ pgCsvCopyToEscape :: Maybe Char,+ -- | @ENCODING@: client-encoding override for the file.+ pgCsvCopyToEncoding :: Maybe Text+ }+ deriving (Eq, Show)++-- | All-'Nothing' 'PgCSVCopyToOptions'.+--+-- @since 0.6.1.0+defaultPgCSVCopyToOptions :: PgCSVCopyToOptions+defaultPgCSVCopyToOptions =+ PgCSVCopyToOptions+ { pgCsvCopyToDelimiter = Nothing,+ pgCsvCopyToNullStr = Nothing,+ pgCsvCopyToHeader = Nothing,+ pgCsvCopyToQuote = Nothing,+ pgCsvCopyToEscape = Nothing,+ pgCsvCopyToEncoding = Nothing+ }++-- | Options for the @text@ format on @COPY ... FROM@.+--+-- @since 0.6.1.0+data PgTextCopyFromOptions = PgTextCopyFromOptions+ { -- | @DELIMITER@: single-character column delimiter. Defaults to TAB.+ pgTextCopyFromDelimiter :: Maybe Char,+ -- | @NULL@: token to interpret as SQL @NULL@. Defaults to @\\N@.+ pgTextCopyFromNullStr :: Maybe Text,+ -- | @HEADER@: skip the first line as a header row.+ pgTextCopyFromHeader :: Maybe Bool,+ -- | @ENCODING@: client-encoding override for the file.+ pgTextCopyFromEncoding :: Maybe Text,+ -- | @FREEZE@: skip WAL when loading; only legal under specific+ -- conditions (see the PostgreSQL @COPY@ documentation).+ pgTextCopyFromFreeze :: Maybe Bool+ }+ deriving (Eq, Show)++-- | All-'Nothing' 'PgTextCopyFromOptions'.+--+-- @since 0.6.1.0+defaultPgTextCopyFromOptions :: PgTextCopyFromOptions+defaultPgTextCopyFromOptions =+ PgTextCopyFromOptions+ { pgTextCopyFromDelimiter = Nothing,+ pgTextCopyFromNullStr = Nothing,+ pgTextCopyFromHeader = Nothing,+ pgTextCopyFromEncoding = Nothing,+ pgTextCopyFromFreeze = Nothing+ }++-- | Options for the @csv@ format on @COPY ... FROM@.+--+-- @since 0.6.1.0+data PgCSVCopyFromOptions = PgCSVCopyFromOptions+ { -- | @DELIMITER@: single-character column delimiter. Defaults to a comma.+ pgCsvCopyFromDelimiter :: Maybe Char,+ -- | @NULL@: token to interpret as SQL @NULL@. Defaults to the empty+ -- string.+ pgCsvCopyFromNullStr :: Maybe Text,+ -- | @HEADER@: skip the first line as a header row.+ pgCsvCopyFromHeader :: Maybe Bool,+ -- | @QUOTE@: single-character quote character. Defaults to @\"@.+ pgCsvCopyFromQuote :: Maybe Char,+ -- | @ESCAPE@: single-character escape character. Defaults to the+ -- value of 'pgCsvCopyFromQuote'.+ pgCsvCopyFromEscape :: Maybe Char,+ -- | @ENCODING@: client-encoding override for the file.+ pgCsvCopyFromEncoding :: Maybe Text,+ -- | @FREEZE@: skip WAL when loading; only legal under specific+ -- conditions (see the PostgreSQL @COPY@ documentation).+ pgCsvCopyFromFreeze :: Maybe Bool+ }+ deriving (Eq, Show)++-- | All-'Nothing' 'PgCSVCopyFromOptions'; a sensible starting point for+-- record-update overrides.+--+-- @since 0.6.1.0+defaultPgCSVCopyFromOptions :: PgCSVCopyFromOptions+defaultPgCSVCopyFromOptions =+ PgCSVCopyFromOptions+ { pgCsvCopyFromDelimiter = Nothing,+ pgCsvCopyFromNullStr = Nothing,+ pgCsvCopyFromHeader = Nothing,+ pgCsvCopyFromQuote = Nothing,+ pgCsvCopyFromEscape = Nothing,+ pgCsvCopyFromEncoding = Nothing,+ pgCsvCopyFromFreeze = Nothing+ }++-- * Emission++emitPgCopyToOptions :: PgCopyToOptions -> (FilePath, PgSyntax)+emitPgCopyToOptions (PgCopyToText fp o) = (fp, emitOptionList (emit "text") (textCopyToFields o))+emitPgCopyToOptions (PgCopyToCSV fp o) = (fp, emitOptionList (emit "csv") (csvCopyToFields o))++emitPgCopyFromOptions :: PgCopyFromOptions -> (FilePath, PgSyntax)+emitPgCopyFromOptions (PgCopyFromText fp o) = (fp, emitOptionList (emit "text") (textCopyFromFields o))+emitPgCopyFromOptions (PgCopyFromCSV fp o) = (fp, emitOptionList (emit "csv") (csvCopyFromFields o))++-- | Render @ (FORMAT FMT, OPT1 …, OPT2 …)@. The @FORMAT@ entry is always+-- present since the constructor of the options value pins it.+--+-- @since 0.6.1.0+emitOptionList :: PgSyntax -> [PgSyntax] -> PgSyntax+emitOptionList fmt items =+ emit " ("+ <> pgSepBy (emit ", ") ((emit "FORMAT " <> fmt) : items)+ <> emit ")"++-- | Render the per-option items for a 'PgTextCopyToOptions' value.+--+-- @since 0.6.1.0+textCopyToFields :: PgTextCopyToOptions -> [PgSyntax]+textCopyToFields o =+ catMaybes+ [ fmap (\c -> emit "DELIMITER " <> pgCharLit c) (pgTextCopyToDelimiter o),+ fmap (\s -> emit "NULL " <> pgStringLit s) (pgTextCopyToNullStr o),+ fmap (\b -> emit "HEADER " <> pgBoolLit b) (pgTextCopyToHeader o),+ fmap (\s -> emit "ENCODING " <> pgStringLit s) (pgTextCopyToEncoding o)+ ]++-- | Render the per-option items for a 'PgCSVCopyToOptions' value.+--+-- @since 0.6.1.0+csvCopyToFields :: PgCSVCopyToOptions -> [PgSyntax]+csvCopyToFields o =+ catMaybes+ [ fmap (\c -> emit "DELIMITER " <> pgCharLit c) (pgCsvCopyToDelimiter o),+ fmap (\s -> emit "NULL " <> pgStringLit s) (pgCsvCopyToNullStr o),+ fmap (\b -> emit "HEADER " <> pgBoolLit b) (pgCsvCopyToHeader o),+ fmap (\c -> emit "QUOTE " <> pgCharLit c) (pgCsvCopyToQuote o),+ fmap (\c -> emit "ESCAPE " <> pgCharLit c) (pgCsvCopyToEscape o),+ fmap (\s -> emit "ENCODING " <> pgStringLit s) (pgCsvCopyToEncoding o)+ ]++-- | Render the per-option items for a 'PgTextCopyFromOptions' value.+--+-- @since 0.6.1.0+textCopyFromFields :: PgTextCopyFromOptions -> [PgSyntax]+textCopyFromFields o =+ catMaybes+ [ fmap (\c -> emit "DELIMITER " <> pgCharLit c) (pgTextCopyFromDelimiter o),+ fmap (\s -> emit "NULL " <> pgStringLit s) (pgTextCopyFromNullStr o),+ fmap (\b -> emit "HEADER " <> pgBoolLit b) (pgTextCopyFromHeader o),+ fmap (\s -> emit "ENCODING " <> pgStringLit s) (pgTextCopyFromEncoding o),+ fmap (\b -> emit "FREEZE " <> pgBoolLit b) (pgTextCopyFromFreeze o)+ ]++-- | Render the per-option items for a 'PgCSVCopyFromOptions' value.+--+-- @since 0.6.1.0+csvCopyFromFields :: PgCSVCopyFromOptions -> [PgSyntax]+csvCopyFromFields o =+ catMaybes+ [ fmap (\c -> emit "DELIMITER " <> pgCharLit c) (pgCsvCopyFromDelimiter o),+ fmap (\s -> emit "NULL " <> pgStringLit s) (pgCsvCopyFromNullStr o),+ fmap (\b -> emit "HEADER " <> pgBoolLit b) (pgCsvCopyFromHeader o),+ fmap (\c -> emit "QUOTE " <> pgCharLit c) (pgCsvCopyFromQuote o),+ fmap (\c -> emit "ESCAPE " <> pgCharLit c) (pgCsvCopyFromEscape o),+ fmap (\s -> emit "ENCODING " <> pgStringLit s) (pgCsvCopyFromEncoding o),+ fmap (\b -> emit "FREEZE " <> pgBoolLit b) (pgCsvCopyFromFreeze o)+ ]
+ Database/Beam/Postgres/Extensions/Copy/Stream.hs view
@@ -0,0 +1,175 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}++module Database.Beam.Postgres.Extensions.Copy.Stream+ ( PgCopyToStreamSyntax (..),+ PgCopyFromStreamSyntax (..),++ -- * COPY options+ PgCopyToStreamOptions,+ PgCopyFromStreamOptions,++ -- ** text+ copyToTextStream,+ copyToTextStreamWith,+ copyFromTextStream,+ copyFromTextStreamWith,++ -- ** CSV+ copyToCSVStream,+ copyToCSVStreamWith,+ copyFromCSVStream,+ copyFromCSVStreamWith,+ )+where++import Database.Beam.Backend.SQL.BeamExtensions+ ( IsSqlCopyFromStreamSyntax (..),+ IsSqlCopyToStreamSyntax (..),+ )+import Database.Beam.Postgres.Extensions.Copy.File+ ( PgCSVCopyFromOptions (..),+ PgCSVCopyToOptions (..),+ PgCopyFromSourceSyntax (..),+ PgCopyToSourceSyntax (..),+ PgTextCopyFromOptions (..),+ PgTextCopyToOptions (..),+ csvCopyFromFields,+ csvCopyToFields,+ defaultPgCSVCopyFromOptions,+ defaultPgCSVCopyToOptions,+ defaultPgTextCopyFromOptions,+ defaultPgTextCopyToOptions,+ emitOptionList,+ textCopyFromFields,+ textCopyToFields,+ )+import Database.Beam.Postgres.Syntax (PgSyntax, emit)++-- | PostgreSQL streaming @COPY ... TO STDOUT@ statement syntax.+--+-- @since 0.6.1.0+newtype PgCopyToStreamSyntax = PgCopyToStreamSyntax {fromPgCopyToStream :: PgSyntax}++-- | PostgreSQL streaming @COPY ... FROM STDIN@ statement syntax.+--+-- @since 0.6.1.0+newtype PgCopyFromStreamSyntax = PgCopyFromStreamSyntax {fromPgCopyFromStream :: PgSyntax}++instance IsSqlCopyToStreamSyntax PgCopyToStreamSyntax where+ type SqlCopyToStreamSourceSyntax PgCopyToStreamSyntax = PgCopyToSourceSyntax+ type SqlCopyToStreamParams PgCopyToStreamSyntax = PgCopyToStreamOptions++ copyToStreamStmt (PgCopyToSourceSyntax source) options =+ PgCopyToStreamSyntax $+ mconcat+ [ emit "COPY ",+ source,+ emit " TO STDOUT",+ emitPgCopyToStreamOptions options+ ]++instance IsSqlCopyFromStreamSyntax PgCopyFromStreamSyntax where+ type SqlCopyFromStreamSourceSyntax PgCopyFromStreamSyntax = PgCopyFromSourceSyntax+ type SqlCopyFromStreamParams PgCopyFromStreamSyntax = PgCopyFromStreamOptions++ copyFromStreamStmt (PgCopyFromSourceSyntax source) options =+ PgCopyFromStreamSyntax $+ mconcat+ [ emit "COPY ",+ source,+ emit " FROM STDIN",+ emitPgCopyFromStreamOptions options+ ]++-- | Options for PostgreSQL's streaming @COPY ... TO STDOUT@ statement,+-- tagged by the output format.+--+-- See <https://www.postgresql.org/docs/current/sql-copy.html the PostgreSQL COPY documentation>+-- for the full set of options each format supports.+--+-- @since 0.6.1.0+data PgCopyToStreamOptions+ = PgCopyToStreamText !PgTextCopyToOptions+ | PgCopyToStreamCSV !PgCSVCopyToOptions+ deriving (Eq, Show)++-- | Stream out using the @text@ format with default options.+-- Use 'copyToTextStreamWith' to override.+--+-- @since 0.6.1.0+copyToTextStream :: PgCopyToStreamOptions+copyToTextStream = PgCopyToStreamText defaultPgTextCopyToOptions++-- | Stream out using the @text@ format with the given options.+--+-- @since 0.6.1.0+copyToTextStreamWith :: PgTextCopyToOptions -> PgCopyToStreamOptions+copyToTextStreamWith = PgCopyToStreamText++-- | Stream out using the @csv@ format with default options.+-- Use 'copyToCSVStreamWith' to override.+--+-- @since 0.6.1.0+copyToCSVStream :: PgCopyToStreamOptions+copyToCSVStream = PgCopyToStreamCSV defaultPgCSVCopyToOptions++-- | Stream out using the @csv@ format with the given options.+--+-- @since 0.6.1.0+copyToCSVStreamWith :: PgCSVCopyToOptions -> PgCopyToStreamOptions+copyToCSVStreamWith = PgCopyToStreamCSV++-- | Options for PostgreSQL's streaming @COPY ... FROM STDIN@ statement,+-- tagged by the input format.+--+-- @since 0.6.1.0+data PgCopyFromStreamOptions+ = PgCopyFromStreamText !PgTextCopyFromOptions+ | PgCopyFromStreamCSV !PgCSVCopyFromOptions+ deriving (Eq, Show)++-- | Stream in using the @text@ format with default options.+-- Use 'copyFromTextStreamWith' to override.+--+-- @since 0.6.1.0+copyFromTextStream :: PgCopyFromStreamOptions+copyFromTextStream = PgCopyFromStreamText defaultPgTextCopyFromOptions++-- | Stream in using the @text@ format with the given options.+--+-- @since 0.6.1.0+copyFromTextStreamWith :: PgTextCopyFromOptions -> PgCopyFromStreamOptions+copyFromTextStreamWith = PgCopyFromStreamText++-- | Stream in using the @csv@ format with default options.+-- Use 'copyFromCSVStreamWith' to override.+--+-- @since 0.6.1.0+copyFromCSVStream :: PgCopyFromStreamOptions+copyFromCSVStream = PgCopyFromStreamCSV defaultPgCSVCopyFromOptions++-- | Stream in using the @csv@ format with the given options.+--+-- @since 0.6.1.0+copyFromCSVStreamWith :: PgCSVCopyFromOptions -> PgCopyFromStreamOptions+copyFromCSVStreamWith = PgCopyFromStreamCSV++-- | Render the @WITH (FORMAT ..., ...)@ tail of a streaming+-- @COPY ... TO STDOUT@ statement.+--+-- @since 0.6.1.0+emitPgCopyToStreamOptions :: PgCopyToStreamOptions -> PgSyntax+emitPgCopyToStreamOptions (PgCopyToStreamText o) = emitOptionList (emit "text") (textCopyToFields o)+emitPgCopyToStreamOptions (PgCopyToStreamCSV o) = emitOptionList (emit "csv") (csvCopyToFields o)++-- | Render the @WITH (FORMAT ..., ...)@ tail of a streaming+-- @COPY ... FROM STDIN@ statement.+--+-- @since 0.6.1.0+emitPgCopyFromStreamOptions :: PgCopyFromStreamOptions -> PgSyntax+emitPgCopyFromStreamOptions (PgCopyFromStreamText o) = emitOptionList (emit "text") (textCopyFromFields o)+emitPgCopyFromStreamOptions (PgCopyFromStreamCSV o) = emitOptionList (emit "csv") (csvCopyFromFields o)
+ Database/Beam/Postgres/Extensions/UuidOssp.hs view
@@ -0,0 +1,62 @@+-- | The @uuid-ossp@ extension provides functions for constructing UUIDs.+--+-- For an example of usage, see the documentation for 'PgExtensionEntity'.+module Database.Beam.Postgres.Extensions.UuidOssp+ ( UuidOssp(..)+ ) where++import Data.Proxy (Proxy(..))+import Data.Text (Text)+import Data.UUID.Types (UUID)++import Database.Beam+import Database.Beam.Postgres.Extensions ( LiftPg, IsPgExtension(..), funcE )++-- | Data type representing definitions contained in the @uuid-ossp@ extension+data UuidOssp = UuidOssp+ { pgUuidNil ::+ forall ctxt s. LiftPg ctxt s UUID+ , pgUuidNsDns ::+ forall ctxt s. LiftPg ctxt s UUID+ , pgUuidNsUrl ::+ forall ctxt s. LiftPg ctxt s UUID+ , pgUuidNsOid ::+ forall ctxt s. LiftPg ctxt s UUID+ , pgUuidNsX500 ::+ forall ctxt s. LiftPg ctxt s UUID+ , pgUuidGenerateV1 ::+ forall ctxt s. LiftPg ctxt s UUID+ , pgUuidGenerateV1Mc ::+ forall ctxt s. LiftPg ctxt s UUID+ , pgUuidGenerateV3 ::+ forall ctxt s. LiftPg ctxt s (UUID -> Text -> UUID)+ , pgUuidGenerateV4 ::+ forall ctxt s. LiftPg ctxt s UUID+ , pgUuidGenerateV5 ::+ forall ctxt s. LiftPg ctxt s (UUID -> Text -> UUID)+ }++instance IsPgExtension UuidOssp where+ pgExtensionName Proxy = "uuid-ossp"+ pgExtensionBuild = UuidOssp+ { pgUuidNil =+ QExpr $ funcE "uuid_nil" <$> sequenceA []+ , pgUuidNsDns =+ QExpr $ funcE "uuid_ns_dns" <$> sequenceA []+ , pgUuidNsUrl =+ QExpr $ funcE "uuid_ns_url" <$> sequenceA []+ , pgUuidNsOid =+ QExpr $ funcE "uuid_ns_oid" <$> sequenceA []+ , pgUuidNsX500 =+ QExpr $ funcE "uuid_ns_x500" <$> sequenceA []+ , pgUuidGenerateV1 =+ QExpr $ funcE "uuid_generate_v1" <$> sequenceA []+ , pgUuidGenerateV1Mc =+ QExpr $ funcE "uuid_generate_v1mc" <$> sequenceA []+ , pgUuidGenerateV3 = \(QExpr ns) (QExpr t) ->+ QExpr $ funcE "uuid_generate_v3" <$> sequenceA [ns, t]+ , pgUuidGenerateV4 =+ QExpr $ funcE "uuid_generate_v4" <$> sequenceA []+ , pgUuidGenerateV5 = \(QExpr ns) (QExpr t) ->+ QExpr $ funcE "uuid_generate_v5" <$> sequenceA [ns, t]+ }
Database/Beam/Postgres/Full.hs view
@@ -1,557 +1,1354 @@-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}---- | Module providing (almost) full support for Postgres query and data--- 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.-module Database.Beam.Postgres.Full- ( -- * Additional @SELECT@ features-- -- ** @SELECT@ Locking clause- PgWithLocking, PgLockedTables- , PgSelectLockingStrength(..), PgSelectLockingOptions(..)- , lockingAllTablesFor_, lockingFor_-- , locked_, lockAll_, withLocks_-- -- ** Lateral joins- , lateral_-- -- * @INSERT@ and @INSERT RETURNING@- , insert, insertReturning- , insertDefaults- , runPgInsertReturningList-- , PgInsertReturning(..)-- -- ** Specifying conflict actions-- , PgInsertOnConflict(..), PgInsertOnConflictTarget(..)- , PgConflictAction(..)-- , onConflictDefault, onConflict, anyConflict, conflictingFields- , conflictingFieldsWhere, conflictingConstraint- , onConflictDoNothing, onConflictUpdateSet- , onConflictUpdateSetWhere, onConflictUpdateInstead- , onConflictSetAll-- -- * @UPDATE RETURNING@- , PgUpdateReturning(..)- , runPgUpdateReturningList- , updateReturning-- -- * @DELETE RETURNING@- , PgDeleteReturning(..)- , runPgDeleteReturningList- , deleteReturning-- -- * Generalized @RETURNING@- , PgReturning(..)- ) where--import Database.Beam hiding (insert, insertValues)-import Database.Beam.Query.Internal-import Database.Beam.Backend.SQL-import Database.Beam.Schema.Tables--import Database.Beam.Postgres.Types-import Database.Beam.Postgres.Syntax--import Control.Monad.Free.Church-import Control.Monad.Writer (execWriter, tell)--import Data.Functor.Const-import Data.Proxy (Proxy(..))-import qualified Data.Text as T-#if !MIN_VERSION_base(4, 11, 0)-import Data.Semigroup-#endif---- * @SELECT@---- | 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.-newtype PgLockedTables s = PgLockedTables [ T.Text ]- deriving (Semigroup, Monoid)---- | Combines the result of a query along with a set of locked tables. Used as a--- return value for the 'lockingFor_' function.-data PgWithLocking s a = PgWithLocking (PgLockedTables s) a-instance ProjectibleWithPredicate c be res a => ProjectibleWithPredicate c be res (PgWithLocking s a) where- project' p be mutateM (PgWithLocking tbls a) =- PgWithLocking tbls <$> project' p be mutateM a-- projectSkeleton' ctxt be mkM =- PgWithLocking mempty <$> projectSkeleton' ctxt be mkM---- | Use with 'lockingFor_' to lock all tables mentioned in the query-lockAll_ :: a -> PgWithLocking s a-lockAll_ = PgWithLocking mempty---- | Return and lock the given tables. Typically used as an infix operator. See the--- <http://tathougies.github.io/beam/user-guide/backends/beam-postgres/ the user guide> for usage--- examples-withLocks_ :: a -> PgLockedTables s -> PgWithLocking s a-withLocks_ = flip PgWithLocking---- | Join with a table while locking it explicitly. Provides a 'PgLockedTables' value that can be--- used with 'withLocks_' to explicitly lock a table during a @SELECT@ statement-locked_ :: (Beamable tbl, Database Postgres db)- => DatabaseEntity Postgres db (TableEntity tbl)- -> Q Postgres db s (PgLockedTables s, tbl (QExpr Postgres s))-locked_ (DatabaseEntity dt) = do- (nm, joined) <- Q (liftF (QAll (\_ -> fromTable (tableNamed (tableName (dbTableSchema dt) (dbTableCurrentName dt))) .- Just . (,Nothing))- (tableFieldsToExpressions (dbTableSettings dt))- (\_ -> Nothing) id))- pure (PgLockedTables [nm], joined)---- | Lock some tables during the execution of a query. This is rather complicated, and there are--- several usage examples in--- <http://tathougies.github.io/beam/user-guide/backends/beam-postgres/ the user guide>------ The Postgres locking clause is rather complex, and beam currently does not check several--- pre-conditions. It is assumed you kinda know what you're doing.------ Things which postgres doesn't like, but beam will do------ * Using aggregates within a query that has a locking clause--- * Using @UNION@, @INTERSECT@, or @EXCEPT@------ See <https://www.postgresql.org/docs/10/static/sql-select.html#SQL-FOR-UPDATE-SHARE here> for--- more details.------ This function accepts a locking strength (@UPDATE@, @SHARE@, @KEY SHARE@, etc), an optional--- locking option (@NOWAIT@ or @SKIP LOCKED@), and a query whose rows to lock. The query should--- return its result wrapped in 'PgWithLocking', via the `withLocks_` or `lockAll_` function.------ If you want to use the most common behavior (lock all rows in every table mentioned), the--- 'lockingAllTablesFor_' function may be what you're after.-lockingFor_ :: forall a db s- . ( Database Postgres db, Projectible Postgres a, ThreadRewritable (QNested s) a )- => PgSelectLockingStrength- -> Maybe PgSelectLockingOptions- -> Q Postgres db (QNested s) (PgWithLocking (QNested s) a)- -> Q Postgres db s (WithRewrittenThread (QNested s) s a)-lockingFor_ lockStrength mLockOptions (Q q) =- Q (liftF (QForceSelect (\(PgWithLocking (PgLockedTables tblNms) _) tbl ords limit offset ->- let locking = PgSelectLockingClauseSyntax lockStrength tblNms mLockOptions- in pgSelectStmt tbl ords limit offset (Just locking))- q (\(PgWithLocking _ a) -> rewriteThread (Proxy @s) a)))---- | Like 'lockingFor_', but does not require an explicit set of locked tables. This produces an--- empty @FOR .. OF@ clause.-lockingAllTablesFor_ :: ( Database Postgres db, Projectible Postgres a, ThreadRewritable (QNested s) a )- => PgSelectLockingStrength- -> Maybe PgSelectLockingOptions- -> Q Postgres db (QNested s) a- -> Q Postgres db s (WithRewrittenThread (QNested s) s a)-lockingAllTablesFor_ lockStrength mLockOptions q =- lockingFor_ lockStrength mLockOptions (lockAll_ <$> q)---- * @INSERT@---- | The Postgres @DEFAULT VALUES@ clause for the @INSERT@ command.-insertDefaults :: SqlInsertValues Postgres tbl-insertDefaults = SqlInsertValues (PgInsertValuesSyntax (emit "DEFAULT VALUES"))---- | A @beam-postgres@-specific version of 'Database.Beam.Query.insert', which--- provides fuller support for the much richer Postgres @INSERT@ syntax. This--- allows you to specify @ON CONFLICT@ actions. For even more complete support,--- see 'insertReturning'.-insert :: DatabaseEntity Postgres db (TableEntity table)- -> SqlInsertValues Postgres (table (QExpr Postgres s)) -- TODO arbitrary projectibles- -> PgInsertOnConflict table- -> SqlInsert Postgres table-insert tbl@(DatabaseEntity dt@(DatabaseTable {})) values onConflict_ =- case insertReturning tbl values onConflict_- (Nothing :: Maybe (table (QExpr Postgres PostgresInaccessible) -> QExpr Postgres PostgresInaccessible Int)) of- PgInsertReturning a ->- SqlInsert (dbTableSettings dt) (PgInsertSyntax a)- PgInsertReturningEmpty ->- SqlInsertNoRows---- | The most general kind of @INSERT@ that postgres can perform-data PgInsertReturning a- = PgInsertReturning PgSyntax- | PgInsertReturningEmpty---- | The full Postgres @INSERT@ syntax, supporting conflict actions and the--- @RETURNING CLAUSE@. See 'PgInsertOnConflict' for how to specify a conflict--- action or provide 'onConflictDefault' to preserve the behavior without any--- @ON CONFLICT@ clause. The last argument takes a newly inserted row and--- returns the expression to be returned as part of the @RETURNING@ clause. For--- a backend-agnostic version of this functionality see--- 'MonadBeamInsertReturning'. Use 'runInsertReturning' to get the results.-insertReturning :: Projectible Postgres a- => DatabaseEntity Postgres be (TableEntity table)- -> SqlInsertValues Postgres (table (QExpr Postgres s))- -> PgInsertOnConflict table- -> Maybe (table (QExpr Postgres PostgresInaccessible) -> a)- -> PgInsertReturning (QExprToIdentity a)--insertReturning _ SqlInsertValuesEmpty _ _ = PgInsertReturningEmpty-insertReturning (DatabaseEntity tbl@(DatabaseTable {}))- (SqlInsertValues (PgInsertValuesSyntax insertValues_))- (PgInsertOnConflict mkOnConflict)- mMkProjection =- PgInsertReturning $- emit "INSERT INTO " <> fromPgTableName (tableName (dbTableSchema tbl) (dbTableCurrentName tbl)) <>- emit "(" <> pgSepBy (emit ", ") (allBeamValues (\(Columnar' f) -> pgQuotedIdentifier (_fieldName f)) tblSettings) <> emit ") " <>- insertValues_ <> emit " " <> fromPgInsertOnConflict (mkOnConflict tblFields) <>- (case mMkProjection of- Nothing -> mempty- Just mkProjection ->- emit " RETURNING " <>- pgSepBy (emit ", ") (map fromPgExpression (project (Proxy @Postgres) (mkProjection tblQ) "t")))- where- tblQ = changeBeamRep (\(Columnar' f) -> Columnar' (QExpr (\_ -> fieldE (unqualifiedField (_fieldName f))))) tblSettings- tblFields = changeBeamRep (\(Columnar' f) -> Columnar' (QField True (dbTableCurrentName tbl) (_fieldName f))) tblSettings-- tblSettings = dbTableSettings tbl--runPgInsertReturningList- :: ( MonadBeam be m- , BeamSqlBackendSyntax be ~ PgCommandSyntax- , FromBackendRow be a- )- => PgInsertReturning a- -> m [a]-runPgInsertReturningList = \case- PgInsertReturningEmpty -> pure []- PgInsertReturning syntax -> runReturningList $ PgCommandSyntax PgCommandTypeDataUpdateReturning syntax---- ** @ON CONFLICT@ clause---- | What to do when an @INSERT@ statement inserts a row into the table @tbl@--- that violates a constraint.-newtype PgInsertOnConflict (tbl :: (* -> *) -> *) =- PgInsertOnConflict (tbl (QField PostgresInaccessible) -> PgInsertOnConflictSyntax)---- | Specifies the kind of constraint that must be violated for the action to occur-newtype PgInsertOnConflictTarget (tbl :: (* -> *) -> *) =- PgInsertOnConflictTarget (tbl (QExpr Postgres PostgresInaccessible) -> PgInsertOnConflictTargetSyntax)---- | A description of what to do when a constraint or index is violated.-newtype PgConflictAction (tbl :: (* -> *) -> *) =- PgConflictAction (tbl (QField PostgresInaccessible) -> PgConflictActionSyntax)---- | Postgres @LATERAL JOIN@ support------ Allows the use of variables introduced on the left side of a @JOIN@ to be used on the right hand--- side.------ Because of the default scoping rules, we can't use the typical monadic bind (@>>=@) operator to--- create this join.------ Instead, 'lateral_' takes two arguments. The first is the left hand side of the @JOIN@. The--- second is a function that takes the result of the first join and uses those variables to create--- the right hand side.------ For example, to join table A with a subquery that returns the first three rows in B which matches--- a column in A, ordered by another column in B:------ > lateral_ (_tableA database) $ \tblA ->--- > limit_ 3 $--- > ordering_ (\(_, b) -> asc_ (_bField2 b)) $ do--- > b <- _tableB database--- > guard_ (_bField1 b ==. _aField1 a)--- > pure (a, b0-lateral_ :: forall s a b db- . ( ThreadRewritable s a, ThreadRewritable (QNested s) b, Projectible Postgres b )- => a -> (WithRewrittenThread s (QNested s) a -> Q Postgres db (QNested s) b)- -> Q Postgres db s (WithRewrittenThread (QNested s) s b)-lateral_ using mkSubquery = do- let Q subquery = mkSubquery (rewriteThread (Proxy @(QNested s)) using)- Q (liftF (QArbitraryJoin subquery- (\a b on' ->- case on' of- Nothing ->- PgFromSyntax $- fromPgFrom a <> emit " CROSS JOIN LATERAL " <> fromPgFrom b- Just on'' ->- PgFromSyntax $- fromPgFrom a <> emit " JOIN LATERAL " <> fromPgFrom b <> emit " ON " <> fromPgExpression on'')- (\_ -> Nothing)- (rewriteThread (Proxy @s))))---- | By default, Postgres will throw an error when a conflict is detected. This--- preserves that functionality.-onConflictDefault :: PgInsertOnConflict tbl-onConflictDefault = PgInsertOnConflict (\_ -> PgInsertOnConflictSyntax mempty)---- | Tells postgres what to do on an @INSERT@ conflict. The first argument is--- the type of conflict to provide an action for. For example, to only provide--- an action for certain fields, use 'conflictingFields'. Or to only provide an--- action over certain fields where a particular condition is met, use--- 'conflictingFields'. If you have a particular constraint violation in mind,--- use 'conflictingConstraint'. To perform an action on any conflict, use--- 'anyConflict'.------ See the--- <https://www.postgresql.org/docs/current/static/sql-insert.html Postgres documentation>.-onConflict :: Beamable tbl- => PgInsertOnConflictTarget tbl- -> PgConflictAction tbl- -> PgInsertOnConflict tbl-onConflict (PgInsertOnConflictTarget tgt) (PgConflictAction update_) =- PgInsertOnConflict $ \tbl ->- let exprTbl = changeBeamRep (\(Columnar' (QField _ _ nm)) ->- Columnar' (QExpr (\_ -> fieldE (unqualifiedField nm))))- tbl- in PgInsertOnConflictSyntax $- emit "ON CONFLICT " <> fromPgInsertOnConflictTarget (tgt exprTbl)- <> fromPgConflictAction (update_ tbl)---- | Perform the conflict action when any constraint or index conflict occurs.--- Syntactically, this is the @ON CONFLICT@ clause, without any /conflict target/.-anyConflict :: PgInsertOnConflictTarget tbl-anyConflict = PgInsertOnConflictTarget (\_ -> PgInsertOnConflictTargetSyntax mempty)---- | Perform the conflict action only when these fields conflict. The first--- argument gets the current row as a table of expressions. Return the conflict--- key. For more information, see the @beam-postgres@ manual.-conflictingFields :: Projectible Postgres proj- => (tbl (QExpr Postgres PostgresInaccessible) -> proj)- -> PgInsertOnConflictTarget tbl-conflictingFields makeProjection =- PgInsertOnConflictTarget $ \tbl ->- PgInsertOnConflictTargetSyntax $- pgParens (pgSepBy (emit ", ") $- map fromPgExpression $- project (Proxy @Postgres) (makeProjection tbl) "t") <>- emit " "---- | Like 'conflictingFields', but only perform the action if the condition--- given in the second argument is met. See the postgres--- <https://www.postgresql.org/docs/current/static/sql-insert.html manual> for--- more information.-conflictingFieldsWhere :: Projectible Postgres proj- => (tbl (QExpr Postgres PostgresInaccessible) -> proj)- -> (tbl (QExpr Postgres PostgresInaccessible) ->- QExpr Postgres PostgresInaccessible Bool)- -> PgInsertOnConflictTarget tbl-conflictingFieldsWhere makeProjection makeWhere =- PgInsertOnConflictTarget $ \tbl ->- PgInsertOnConflictTargetSyntax $- pgParens (pgSepBy (emit ", ") $- map fromPgExpression (project (Proxy @Postgres)- (makeProjection tbl) "t")) <>- emit " WHERE " <>- pgParens (let QExpr mkE = makeWhere tbl- PgExpressionSyntax e = mkE "t"- in e) <>- emit " "---- | Perform the action only if the given named constraint is violated-conflictingConstraint :: T.Text -> PgInsertOnConflictTarget tbl-conflictingConstraint nm =- PgInsertOnConflictTarget $ \_ ->- PgInsertOnConflictTargetSyntax $- emit "ON CONSTRAINT " <> pgQuotedIdentifier nm <> emit " "---- | The Postgres @DO NOTHING@ action-onConflictDoNothing :: PgConflictAction tbl-onConflictDoNothing = PgConflictAction $ \_ -> PgConflictActionSyntax (emit "DO NOTHING")---- | The Postgres @DO UPDATE SET@ action, without the @WHERE@ clause. The--- argument takes an updatable row (like the one used in 'update') and the--- conflicting row. Use 'current_' on the first argument to get the current--- value of the row in the database.-onConflictUpdateSet :: Beamable tbl- => (tbl (QField PostgresInaccessible) ->- tbl (QExpr Postgres PostgresInaccessible) ->- QAssignment Postgres PostgresInaccessible)- -> PgConflictAction tbl-onConflictUpdateSet mkAssignments =- PgConflictAction $ \tbl ->- let QAssignment assignments = mkAssignments tbl tblExcluded- tblExcluded = changeBeamRep (\(Columnar' (QField _ _ nm)) -> Columnar' (QExpr (\_ -> fieldE (qualifiedField "excluded" nm)))) tbl-- assignmentSyntaxes =- [ fromPgFieldName fieldNm <> emit "=" <> pgParens (fromPgExpression expr)- | (fieldNm, expr) <- assignments ]- in PgConflictActionSyntax $- emit "DO UPDATE SET " <> pgSepBy (emit ", ") assignmentSyntaxes---- | The Postgres @DO UPDATE SET@ action, with the @WHERE@ clause. This is like--- 'onConflictUpdateSet', but only rows satisfying the given condition are--- updated. Sometimes this results in more efficient locking. See the Postgres--- <https://www.postgresql.org/docs/current/static/sql-insert.html manual> for--- more information.-onConflictUpdateSetWhere :: Beamable tbl- => (tbl (QField PostgresInaccessible) ->- tbl (QExpr Postgres PostgresInaccessible) ->- QAssignment Postgres PostgresInaccessible)- -> (tbl (QExpr Postgres PostgresInaccessible) -> QExpr Postgres PostgresInaccessible Bool)- -> PgConflictAction tbl-onConflictUpdateSetWhere mkAssignments where_ =- PgConflictAction $ \tbl ->- let QAssignment assignments = mkAssignments tbl tblExcluded- QExpr where_' = where_ (changeBeamRep (\(Columnar' f) -> Columnar' (current_ f)) tbl)- tblExcluded = changeBeamRep (\(Columnar' (QField _ _ nm)) -> Columnar' (QExpr (\_ -> fieldE (qualifiedField "excluded" nm)))) tbl-- assignmentSyntaxes =- [ fromPgFieldName fieldNm <> emit "=" <> pgParens (fromPgExpression expr)- | (fieldNm, expr) <- assignments ]- in PgConflictActionSyntax $- emit "DO UPDATE SET " <> pgSepBy (emit ", ") assignmentSyntaxes <> emit " WHERE " <> fromPgExpression (where_' "t")---- | Sometimes you want to update certain columns in the row. Given a--- projection from a row to the fields you want, Beam can auto-generate--- an assignment that assigns the corresponding fields of the conflicting row.-onConflictUpdateInstead :: (Beamable tbl, ProjectibleWithPredicate AnyType () T.Text proj)- => (tbl (Const T.Text) -> proj)- -> PgConflictAction tbl-onConflictUpdateInstead mkProj =- onConflictUpdateSet $ \tbl _ ->- let tblFields = changeBeamRep (\(Columnar' (QField _ _ nm) :: Columnar' (QField PostgresInaccessible) a) -> Columnar' (Const nm) :: Columnar' (Const T.Text) a) tbl- proj = execWriter (project' (Proxy @AnyType) (Proxy @((), T.Text))- (\_ _ e -> tell [e] >> pure e)- (mkProj tblFields))-- in QAssignment (map (\fieldNm -> (unqualifiedField fieldNm, fieldE (qualifiedField "excluded" fieldNm))) proj)---- | Sometimes you want to update every value in the row. Beam can auto-generate--- an assignment that assigns the conflicting row to every field in the database--- row. This may not always be what you want.-onConflictSetAll :: ( Beamable tbl- , ProjectibleWithPredicate AnyType () T.Text (tbl (Const T.Text)) )- => PgConflictAction tbl-onConflictSetAll = onConflictUpdateInstead id---- * @UPDATE@---- | The most general kind of @UPDATE@ that postgres can perform------ You can build this from a 'SqlUpdate' by using 'returning'------ > update tbl where `returning` projection------ Run the result with 'runPgUpdateReturningList'-data PgUpdateReturning a- = PgUpdateReturning PgSyntax- | PgUpdateReturningEmpty---- | Postgres @UPDATE ... RETURNING@ statement support. The last--- argument takes the newly inserted row and returns the values to be--- returned. Use 'runUpdateReturning' to get the results.-updateReturning :: Projectible Postgres a- => DatabaseEntity Postgres be (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)- -> PgUpdateReturning (QExprToIdentity a)-updateReturning table@(DatabaseEntity (DatabaseTable { dbTableSettings = tblSettings }))- mkAssignments- mkWhere- mkProjection =- case update table mkAssignments mkWhere of- SqlUpdate _ pgUpdate ->- PgUpdateReturning $- fromPgUpdate pgUpdate <>- emit " RETURNING " <>- pgSepBy (emit ", ") (map fromPgExpression (project (Proxy @Postgres) (mkProjection tblQ) "t"))-- SqlIdentityUpdate -> PgUpdateReturningEmpty- where- tblQ = changeBeamRep (\(Columnar' f) -> Columnar' (QExpr (pure (fieldE (unqualifiedField (_fieldName f)))))) tblSettings--runPgUpdateReturningList- :: ( MonadBeam be m- , BeamSqlBackendSyntax be ~ PgCommandSyntax- , FromBackendRow be a- )- => PgUpdateReturning a- -> m [a]-runPgUpdateReturningList = \case- PgUpdateReturningEmpty -> pure []- PgUpdateReturning syntax -> runReturningList $ PgCommandSyntax PgCommandTypeDataUpdateReturning syntax---- * @DELETE@---- | The most general kind of @DELETE@ that postgres can perform------ You can build this from a 'SqlDelete' by using 'returning'------ > delete tbl where `returning` projection------ Run the result with 'runPgDeleteReturningList'-newtype PgDeleteReturning a = PgDeleteReturning PgSyntax---- | Postgres @DELETE ... RETURNING@ statement support. The last--- argument takes the newly inserted row and returns the values to be--- returned. Use 'runDeleteReturning' to get the results.-deleteReturning :: Projectible Postgres a- => DatabaseEntity Postgres be (TableEntity table)- -> (forall s. table (QExpr Postgres s) -> QExpr Postgres s Bool)- -> (table (QExpr Postgres PostgresInaccessible) -> a)- -> PgDeleteReturning (QExprToIdentity a)-deleteReturning table@(DatabaseEntity (DatabaseTable { dbTableSettings = tblSettings }))- mkWhere- mkProjection =- PgDeleteReturning $- fromPgDelete pgDelete <>- emit " RETURNING " <>- pgSepBy (emit ", ") (map fromPgExpression (project (Proxy @Postgres) (mkProjection tblQ) "t"))- where- SqlDelete _ pgDelete = delete table mkWhere- tblQ = changeBeamRep (\(Columnar' f) -> Columnar' (QExpr (pure (fieldE (unqualifiedField (_fieldName f)))))) tblSettings--runPgDeleteReturningList- :: ( MonadBeam be m- , BeamSqlBackendSyntax be ~ PgCommandSyntax- , FromBackendRow be a- )- => PgDeleteReturning a- -> m [a]-runPgDeleteReturningList (PgDeleteReturning syntax) = runReturningList $ PgCommandSyntax PgCommandTypeDataUpdateReturning syntax---- * General @RETURNING@ support--class PgReturning cmd where- type PgReturningType cmd :: * -> *-- returning :: (Beamable tbl, Projectible Postgres a)- => cmd Postgres tbl -> (tbl (QExpr Postgres PostgresInaccessible) -> a)- -> PgReturningType cmd (QExprToIdentity a)--instance PgReturning SqlInsert where- type PgReturningType SqlInsert = PgInsertReturning-- returning SqlInsertNoRows _ = PgInsertReturningEmpty- returning (SqlInsert tblSettings (PgInsertSyntax syntax)) mkProjection =- PgInsertReturning $- syntax <> emit " RETURNING " <>- pgSepBy (emit ", ") (map fromPgExpression (project (Proxy @Postgres) (mkProjection tblQ) "t"))-- where- tblQ = changeBeamRep (\(Columnar' f) -> Columnar' (QExpr . pure . fieldE . unqualifiedField . _fieldName $ f)) tblSettings--instance PgReturning SqlUpdate where- type PgReturningType SqlUpdate = PgUpdateReturning-- returning SqlIdentityUpdate _ = PgUpdateReturningEmpty- returning (SqlUpdate tblSettings (PgUpdateSyntax syntax)) mkProjection =- PgUpdateReturning $- syntax <> emit " RETURNING " <>- pgSepBy (emit ", ") (map fromPgExpression (project (Proxy @Postgres) (mkProjection tblQ) "t"))-- where- tblQ = changeBeamRep (\(Columnar' f) -> Columnar' (QExpr . pure . fieldE . unqualifiedField . _fieldName $ f)) tblSettings--instance PgReturning SqlDelete where- type PgReturningType SqlDelete = PgDeleteReturning-- returning (SqlDelete tblSettings (PgDeleteSyntax syntax)) mkProjection =- PgDeleteReturning $- syntax <> emit " RETURNING " <>- pgSepBy (emit ", ") (map fromPgExpression (project (Proxy @Postgres) (mkProjection tblQ) "t"))-- where- tblQ = changeBeamRep (\(Columnar' f) -> Columnar' (QExpr . pure . fieldE . unqualifiedField . _fieldName $ f)) tblSettings+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RoleAnnotations #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TypeOperators #-}++-- | Module providing (almost) full support for Postgres query and data+-- 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++ -- ** @SELECT@ Locking clause+ PgWithLocking, PgLockedTables+ , PgSelectLockingStrength(..), PgSelectLockingOptions(..)+ , lockingAllTablesFor_, lockingFor_++ , locked_, lockAll_, withLocks_++ -- ** 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, cteInsert, cteInsertReturning+ , insertDefaults+ , runPgInsertReturningList++ , PgInsertReturning(..)++ -- ** Specifying conflict actions++ , PgInsertOnConflict(..)++ , onConflictDefault, onConflict+ , conflictingConstraint+ , BeamHasInsertOnConflict(..)+ , onConflictUpdateAll+ , onConflictUpdateInstead++ -- * @UPDATE RETURNING@+ , PgUpdateReturning(..)+ , runPgUpdateReturningList+ , updateReturning, cteUpdate, cteUpdateReturning++ -- * @DELETE RETURNING@+ , PgDeleteReturning(..)+ , runPgDeleteReturningList+ , deleteReturning, cteDelete, cteDeleteReturning++ -- * Generalized @RETURNING@+ , PgReturning(..)+ ) where++import Database.Beam hiding (insert, insertValues)+import Database.Beam.Backend.SQL+import Database.Beam.Backend.SQL.BeamExtensions+import qualified Database.Beam.Query.CTE as CTE+import Database.Beam.Query.Internal+import Database.Beam.Schema.Tables++import Database.Beam.Postgres.Types+import Database.Beam.Postgres.Syntax++import Control.Monad.Fix (MonadFix(..))+import Control.Monad.Free.Church+import Control.Monad.State.Strict (evalState, get, put)+import Control.Monad.Writer (runWriterT, tell)++import Data.List.NonEmpty (NonEmpty(..), nonEmpty)+import qualified Data.List.NonEmpty as NonEmpty+import Data.Kind (Type)+import Data.Proxy (Proxy(..))+import Data.String (fromString)+import Data.Text (Text)+import qualified Data.Text as T++-- * @SELECT@++-- | Whether every CTE in a PostgreSQL @WITH@ block may appear in a nested+-- query, or whether the block must be attached to a top-level statement.+--+-- PostgreSQL permits SELECT CTEs in nested queries, but permits data-modifying+-- CTEs only in a @WITH@ clause attached to the top-level statement. The index+-- on 'PgWith' records that rule for the builders in this module, so invalid+-- nesting is rejected by Haskell rather than by PostgreSQL. See PostgreSQL's+-- <https://www.postgresql.org/docs/current/queries-with.html#QUERIES-WITH-MODIFYING data-modifying WITH documentation>.+--+-- @since 0.6.3.0+data PgCtePlacement+ = PgCteNestedAllowed+ -- ^ The block contains only CTEs which may be nested.+ | PgCteTopLevelOnly+ -- ^ The block contains a data-modifying CTE and must remain top-level.++-- | A PostgreSQL-specific CTE builder.+--+-- This newtype uses beam-core's existing 'With' action and CTE accumulator. It+-- adds a placement index for PostgreSQL data-modifying CTEs without introducing+-- a second name supply or syntax writer. Consequently a lifted portable helper+-- and a native PostgreSQL CTE allocate names from the same sequence.+--+-- Use 'pgSelecting' for SELECT CTEs, 'cteInsertReturning',+-- 'cteUpdateReturning', or 'cteDeleteReturning' for reusable modifying CTEs,+-- and 'cteInsert', 'cteUpdate', or 'cteDelete' for side-effect-only CTEs.+-- Consume the completed block with 'pgSelectWithTopLevel', 'pgInsertWith',+-- 'pgUpdateWith', or 'pgDeleteWith'.+--+-- @since 0.6.3.0+newtype PgWith db (placement :: PgCtePlacement) a =+ PgWith { unPgWith :: With Postgres db a }+ deriving (Functor, Applicative, Monad)++-- The placement parameter is phantom at runtime. A nominal role prevents+-- Data.Coerce from relabelling a top-level-only block as nested-safe.+type role PgWith nominal nominal nominal++-- Recursive knots are deliberately restricted to SELECT-only construction.+-- Complete such a knot first and then use 'pgToTopLevel' before adding a+-- data-modifying CTE which consumes its rows.+instance MonadFix (PgWith db 'PgCteNestedAllowed) where+ mfix f = PgWith (mfix (unPgWith . f))++-- | Lift an existing portable PostgreSQL 'With' helper into 'PgWith'.+--+-- Helpers constructed with the portable 'selecting' API contain SELECT+-- statements, so they are valid at either placement. The lifted action uses+-- the surrounding 'PgWith' name supply; lifting a helper which defines several+-- CTEs therefore cannot collide with CTEs defined before or after it.+--+-- > native <- pgSelecting nativeQuery+-- > rows <- pgLiftWith existingSelectCtes+-- > changed <- cteDeleteReturning table predicate id+-- > pure $ do+-- > nativeRow <- reuse native+-- > row <- reuse rows+-- > changedRow <- reuse changed+-- > pure (nativeRow, row, changedRow)+--+-- If @existingSelectCtes@ defines two CTEs and one native CTE precedes it,+-- Beam generates one block whose names continue through the lifted helper:+--+-- @+-- WITH "cte0"("res0") AS (SELECT ...),+-- "cte1"("res0") AS (SELECT ...),+-- "cte2"("res0") AS (SELECT ... FROM "cte1"),+-- "cte3"("res0", "res1") AS+-- (DELETE FROM "table" ... RETURNING "id", "value")+-- SELECT ... FROM "cte0" CROSS JOIN "cte2" CROSS JOIN "cte3"+-- @+--+-- The 'With' constructor is public for low-level extension code. 'pgLiftWith'+-- assumes such code preserves the portable API's SELECT-only invariant.+--+-- @since 0.6.3.0+pgLiftWith :: With Postgres db a -> PgWith db placement a+pgLiftWith = PgWith++-- | Promote a completed nested-safe block for composition with+-- data-modifying CTEs.+--+-- This operation is one-way. In particular, there is no public operation for+-- converting 'PgCteTopLevelOnly' back to 'PgCteNestedAllowed'.+--+-- > pgSelectWithTopLevel $ do+-- > recursiveRows <- pgToTopLevel $ mdo+-- > rows <- pgSelecting recursiveQuery+-- > pure rows+-- > cteDelete table $ \row -> exists_ $ do+-- > recursiveRow <- reuse recursiveRows+-- > guard_ (rowId row ==. rowId recursiveRow)+-- > pure finalQuery+--+-- The promotion changes no SQL. It permits the subsequent modifying CTE, so+-- the complete block has the following form:+--+-- @+-- WITH RECURSIVE "cte0"("res0") AS+-- (SELECT ... UNION ALL SELECT ... FROM "cte0"),+-- "cte1" AS+-- (DELETE FROM "table"+-- WHERE EXISTS (SELECT ... FROM "cte0"))+-- SELECT ...+-- @+--+-- @since 0.6.3.0+pgToTopLevel+ :: PgWith db 'PgCteNestedAllowed a+ -> PgWith db 'PgCteTopLevelOnly a+pgToTopLevel (PgWith with) = PgWith with++-- | PostgreSQL's materialization policy for a SELECT CTE.+--+-- Explicit materialization control is available in PostgreSQL 12 and later.+-- 'PgCteDefault' emits no modifier and therefore retains PostgreSQL's normal+-- planner behaviour and compatibility with earlier server versions.+-- See PostgreSQL's+-- <https://www.postgresql.org/docs/current/queries-with.html#QUERIES-WITH-CTE-MATERIALIZATION CTE materialization documentation>.+--+-- @since 0.6.3.0+data PgCteMaterialization+ = PgCteDefault+ -- ^ Let PostgreSQL decide whether to fold or materialize the CTE.+ | PgCteMaterialized+ -- ^ Emit @MATERIALIZED@, requesting separate calculation of the CTE. This+ -- can act as an optimization fence or prevent duplicated computation.+ | PgCteNotMaterialized+ -- ^ Emit @NOT MATERIALIZED@, allowing the CTE and parent query to be+ -- optimized together. PostgreSQL ignores this for recursive or+ -- non-side-effect-free queries.+ deriving (Eq, Show)++-- | Introduce a SELECT query as a reusable PostgreSQL CTE using the server's+-- default materialization policy.+--+-- This is the usual PostgreSQL-specific counterpart of 'selecting'. Use+-- 'pgSelectingWith' when the planner boundary should be controlled explicitly.+--+-- > rows <- pgSelecting sourceQuery+-- > pure (reuse rows)+--+-- With a top-level SELECT consumer this produces:+--+-- @+-- WITH "cte0"("res0", "res1") AS (SELECT ...)+-- SELECT "t0"."res0", "t0"."res1" FROM "cte0" AS "t0"+-- @+--+-- @since 0.6.3.0+pgSelecting+ :: ( Projectible Postgres res+ , ThreadRewritable CTE.QAnyScope res )+ => Q Postgres db CTE.QAnyScope res+ -> PgWith db placement (ReusableQ Postgres db res)+pgSelecting = pgSelectingWith PgCteDefault++-- | Introduce a SELECT query as a reusable PostgreSQL CTE with an explicit+-- materialization policy.+--+-- For example:+--+-- > expensive <- pgSelectingWith PgCteMaterialized expensiveQuery+-- > pure $ do+-- > left <- reuse expensive+-- > right <- reuse expensive+-- > guard_ (leftId left ==. rightId right)+-- > pure (left, right)+--+-- With 'pgSelectWithTopLevel', this produces a statement shaped like:+--+-- @+-- WITH "cte0"("res0", "res1") AS MATERIALIZED (SELECT ...)+-- SELECT ...+-- FROM "cte0" AS "t0" CROSS JOIN "cte0" AS "t1"+-- WHERE "t0"."res0" = "t1"."res0"+-- @+--+-- @NOT MATERIALIZED@ may allow restrictions in the parent query to reach the+-- CTE, but may also duplicate its computation when it is referenced more than+-- once. PostgreSQL ignores @NOT MATERIALIZED@ when folding would not be+-- semantically valid, for example for a recursive query or a query containing+-- volatile functions.+--+-- A projection with no fields is represented by omitting the CTE column-alias+-- list. PostgreSQL then treats the CTE as a degree-zero relation: it has no+-- columns, but it retains the row cardinality of @query@. For example, a query+-- which produces two empty rows has the following shape:+--+-- @+-- WITH "cte0" AS MATERIALIZED (SELECT FROM ...)+-- SELECT FROM "cte0" AS "t0"+-- @+--+-- Reusing such a CTE remains meaningful in joins, @EXISTS@, and aggregates+-- even though no value can be projected from an individual row.+--+-- @since 0.6.3.0+pgSelectingWith+ :: forall res db placement+ . ( Projectible Postgres res+ , ThreadRewritable CTE.QAnyScope res )+ => PgCteMaterialization+ -> Q Postgres db CTE.QAnyScope res+ -> PgWith db placement (ReusableQ Postgres db res)+pgSelectingWith materialization q = do+ tblNm <- pgRegisterCte $ \name ->+ let (_ :: res, fields) = mkFieldNames @Postgres (qualifiedField name)+ body = fromPgSelect (buildSqlQuery (name <> "_") q)+ in case nonEmpty fields of+ Nothing -> pgCteSyntax name Nothing materialization body+ Just fields' -> pgOutputCteSyntax name fields' materialization body+ pure (CTE.reusableForCTE tblNm)++-- | An explicit lock against some tables. You can create a value of this type using the 'locked_'+-- function. You can combine these values monoidally to combine multiple locks for use with the+-- 'withLocks_' function.+newtype PgLockedTables s = PgLockedTables [ T.Text ]+ deriving (Semigroup, Monoid)++-- | Combines the result of a query along with a set of locked tables. Used as a+-- return value for the 'lockingFor_' function.+data PgWithLocking s a = PgWithLocking (PgLockedTables s) a+instance ProjectibleWithPredicate c be res a => ProjectibleWithPredicate c be res (PgWithLocking s a) where+ project' p be mutateM (PgWithLocking tbls a) =+ PgWithLocking tbls <$> project' p be mutateM a++ projectSkeleton' ctxt be mkM =+ PgWithLocking mempty <$> projectSkeleton' ctxt be mkM++-- | Use with 'lockingFor_' to lock all tables mentioned in the query+lockAll_ :: a -> PgWithLocking s a+lockAll_ = PgWithLocking mempty++-- | Return and lock the given tables. Typically used as an infix operator. See the+-- <https://haskell-beam.github.io/beam/user-guide/backends/beam-postgres/ the user guide> for usage+-- examples+withLocks_ :: a -> PgLockedTables s -> PgWithLocking s a+withLocks_ = flip PgWithLocking++-- | Join with a table while locking it explicitly. Provides a 'PgLockedTables' value that can be+-- used with 'withLocks_' to explicitly lock a table during a @SELECT@ statement+locked_ :: (Beamable tbl, Database Postgres db)+ => DatabaseEntity Postgres db (TableEntity tbl)+ -> Q Postgres db s (PgLockedTables s, tbl (QExpr Postgres s))+locked_ (DatabaseEntity dt) = do+ (nm, joined) <- Q (liftF (QAll (\_ -> fromTable (tableNamed (tableName (dbTableSchema dt) (dbTableCurrentName dt))) .+ Just . (,Nothing))+ (tableFieldsToExpressions (dbTableSettings dt))+ (\_ -> Nothing) id))+ pure (PgLockedTables [nm], joined)++-- | Lock some tables during the execution of a query. This is rather complicated, and there are+-- several usage examples in+-- <https://haskell-beam.github.io/beam/user-guide/backends/beam-postgres/ the user guide>+--+-- The Postgres locking clause is rather complex, and beam currently does not check several+-- pre-conditions. It is assumed you kinda know what you're doing.+--+-- Things which postgres doesn't like, but beam will do+--+-- * Using aggregates within a query that has a locking clause+-- * Using @UNION@, @INTERSECT@, or @EXCEPT@+--+-- See <https://www.postgresql.org/docs/10/static/sql-select.html#SQL-FOR-UPDATE-SHARE here> for+-- more details.+--+-- This function accepts a locking strength (@UPDATE@, @SHARE@, @KEY SHARE@, etc), an optional+-- locking option (@NOWAIT@ or @SKIP LOCKED@), and a query whose rows to lock. The query should+-- return its result wrapped in 'PgWithLocking', via the `withLocks_` or `lockAll_` function.+--+-- If you want to use the most common behavior (lock all rows in every table mentioned), the+-- 'lockingAllTablesFor_' function may be what you're after.+lockingFor_ :: forall a db s+ . ( Database Postgres db, Projectible Postgres a, ThreadRewritable (QNested s) a )+ => PgSelectLockingStrength+ -> Maybe PgSelectLockingOptions+ -> Q Postgres db (QNested s) (PgWithLocking (QNested s) a)+ -> Q Postgres db s (WithRewrittenThread (QNested s) s a)+lockingFor_ lockStrength mLockOptions (Q q) =+ Q (liftF (QForceSelect (\(PgWithLocking (PgLockedTables tblNms) _) tbl ords limit offset ->+ let locking = PgSelectLockingClauseSyntax lockStrength tblNms mLockOptions+ in pgSelectStmt tbl ords limit offset (Just locking))+ q (\(PgWithLocking _ a) -> rewriteThread (Proxy @s) a)))++-- | Like 'lockingFor_', but does not require an explicit set of locked tables. This produces an+-- empty @FOR .. OF@ clause.+lockingAllTablesFor_ :: ( Database Postgres db, Projectible Postgres a, ThreadRewritable (QNested s) a )+ => PgSelectLockingStrength+ -> Maybe PgSelectLockingOptions+ -> Q Postgres db (QNested s) a+ -> Q Postgres db s (WithRewrittenThread (QNested s) s a)+lockingAllTablesFor_ lockStrength mLockOptions q =+ lockingFor_ lockStrength mLockOptions (lockAll_ <$> q)++-- * @INSERT@++-- | The Postgres @DEFAULT VALUES@ clause for the @INSERT@ command.+insertDefaults :: SqlInsertValues Postgres tbl+insertDefaults = SqlInsertValues (PgInsertValuesSyntax (emit "DEFAULT VALUES"))++-- | A @beam-postgres@-specific version of 'Database.Beam.Query.insert', which+-- provides fuller support for the much richer Postgres @INSERT@ syntax. This+-- allows you to specify @ON CONFLICT@ actions. For even more complete support,+-- see 'insertReturning'.+insert :: DatabaseEntity Postgres db (TableEntity table)+ -> SqlInsertValues Postgres (table (QExpr Postgres s)) -- TODO arbitrary projectibles+ -> PgInsertOnConflict table+ -> SqlInsert Postgres table+insert tbl@(DatabaseEntity dt@(DatabaseTable {})) values onConflict_ =+ case insertReturning tbl values onConflict_+ (Nothing :: Maybe (table (QExpr Postgres PostgresInaccessible) -> QExpr Postgres PostgresInaccessible Int)) of+ PgInsertReturning a ->+ SqlInsert (dbTableSettings dt) (PgInsertSyntax a)+ PgInsertReturningEmpty ->+ SqlInsertNoRows++-- | The most general kind of @INSERT@ that postgres can perform+data PgInsertReturning a+ = PgInsertReturning PgSyntax+ | PgInsertReturningEmpty++-- | The full Postgres @INSERT@ syntax, supporting conflict actions and the+-- @RETURNING CLAUSE@. See 'PgInsertOnConflict' for how to specify a conflict+-- action or provide 'onConflictDefault' to preserve the behavior without any+-- @ON CONFLICT@ clause. The last argument takes a newly inserted row and+-- returns the expression to be returned as part of the @RETURNING@ clause. For+-- a backend-agnostic version of this functionality see+-- 'MonadBeamInsertReturning'. Use 'runInsertReturning' to get the results.+insertReturning :: Projectible Postgres a+ => DatabaseEntity Postgres be (TableEntity table)+ -> SqlInsertValues Postgres (table (QExpr Postgres s))+ -> PgInsertOnConflict table+ -> Maybe (table (QExpr Postgres PostgresInaccessible) -> a)+ -> PgInsertReturning (QExprToIdentity a)++insertReturning _ SqlInsertValuesEmpty _ _ = PgInsertReturningEmpty+insertReturning (DatabaseEntity tbl@(DatabaseTable {}))+ (SqlInsertValues (PgInsertValuesSyntax insertValues_))+ (PgInsertOnConflict mkOnConflict)+ mMkProjection =+ PgInsertReturning $+ emit "INSERT INTO " <> fromPgTableName (tableName (dbTableSchema tbl) (dbTableCurrentName tbl)) <>+ emit "(" <> pgSepBy (emit ", ") (allBeamValues (\(Columnar' f) -> pgQuotedIdentifier (_fieldName f)) tblSettings) <> emit ") " <>+ insertValues_ <> emit " " <> fromPgInsertOnConflict (mkOnConflict tblFields) <>+ (case mMkProjection of+ Nothing -> mempty+ Just mkProjection ->+ emit " RETURNING " <>+ pgSepBy (emit ", ") (map fromPgExpression (project (Proxy @Postgres) (mkProjection tblQ) "t")))+ where+ tblQ = changeBeamRep (\(Columnar' f) -> Columnar' (QExpr (\_ -> fieldE (unqualifiedField (_fieldName f))))) tblSettings+ tblFields = changeBeamRep (\(Columnar' f) -> Columnar' (QField True (dbTableCurrentName tbl) (_fieldName f))) tblSettings++ 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+ , FromBackendRow be a+ )+ => PgInsertReturning a+ -> m [a]+runPgInsertReturningList = \case+ PgInsertReturningEmpty -> pure []+ PgInsertReturning syntax -> runReturningList $ PgCommandSyntax PgCommandTypeDataUpdateReturning syntax++-- ** @ON CONFLICT@ clause++-- | What to do when an @INSERT@ statement inserts a row into the table @tbl@+-- that violates a constraint.+newtype PgInsertOnConflict (tbl :: (Type -> Type) -> Type) =+ PgInsertOnConflict (tbl (QField QInternal) -> PgInsertOnConflictSyntax)++-- | Postgres @LATERAL JOIN@ support+--+-- Allows the use of variables introduced on the left side of a @JOIN@ to be used on the right hand+-- side.+--+-- Because of the default scoping rules, we can't use the typical monadic bind (@>>=@) operator to+-- create this join.+--+-- Instead, 'lateral_' takes two arguments. The first is the left hand side of the @JOIN@. The+-- second is a function that takes the result of the first join and uses those variables to create+-- the right hand side.+--+-- For example, to join table A with a subquery that returns the first three rows in B which matches+-- a column in A, ordered by another column in B:+--+-- > lateral_ (_tableA database) $ \tblA ->+-- > limit_ 3 $+-- > ordering_ (\(_, b) -> asc_ (_bField2 b)) $ do+-- > b <- _tableB database+-- > guard_ (_bField1 b ==. _aField1 a)+-- > pure (a, b0+lateral_ :: forall s a b db+ . ( ThreadRewritable s a, ThreadRewritable (QNested s) b, Projectible Postgres b )+ => a -> (WithRewrittenThread s (QNested s) a -> Q Postgres db (QNested s) b)+ -> Q Postgres db s (WithRewrittenThread (QNested s) s b)+lateral_ using mkSubquery = do+ let Q subquery = mkSubquery (rewriteThread (Proxy @(QNested s)) using)+ Q (liftF (QArbitraryJoin subquery+ "lat_"+ (\a b on' ->+ case on' of+ Nothing ->+ PgFromSyntax $+ fromPgFrom a <> emit " CROSS JOIN LATERAL " <> fromPgFrom b+ Just on'' ->+ PgFromSyntax $+ fromPgFrom a <> emit " JOIN LATERAL " <> fromPgFrom b <> emit " ON " <> fromPgExpression on'')+ (\_ -> Nothing)+ (rewriteThread (Proxy @s))))++-- | Embed a portable SELECT CTE block within a PostgreSQL subquery.+--+-- For example,+--+-- @+-- SELECT a.column1, b.column2 FROM (WITH RECURSIVE ... ) a JOIN b+-- @+--+-- @beam-core@'s 'selectWith' produces a top-level 'SqlSelect', which cannot be+-- used as a 'Q' value within a join. PostgreSQL accepts a SELECT-only @WITH@+-- query in that subquery position, and 'pgSelectWith' exposes that placement.+--+-- > select $ pgSelectWith $ do+-- > reusableRows <- selecting someQuery+-- > pure (reuse reusableRows)+--+-- This can produce a subquery such as:+--+-- @+-- SELECT ... FROM (WITH cte0 AS (SELECT ...) SELECT ... FROM cte0) AS nested+-- @+--+pgSelectWith :: forall db s res+ . Projectible Postgres res+ => With Postgres db (Q Postgres db s res) -> Q Postgres db s res+pgSelectWith = pgSelectWith_++-- | Embed a nested-safe PostgreSQL-specific CTE block in a query.+--+-- This is the 'PgWith' counterpart of 'pgSelectWith'. It supports+-- 'pgSelectingWith', including explicit materialization, while its placement+-- index rejects data-modifying CTEs because PostgreSQL accepts those only in a+-- @WITH@ clause attached to the top-level statement.+--+-- > select $ pgSelectWithNested $ do+-- > rows <- pgSelectingWith PgCteMaterialized sourceQuery+-- > pure (reuse rows)+--+-- This produces a derived table containing the complete nested @WITH@ query:+--+-- @+-- SELECT "t0"."res0", "t0"."res1"+-- FROM (WITH "cte0"("res0", "res1") AS MATERIALIZED (SELECT ...)+-- SELECT "sub_t0"."res0", "sub_t0"."res1"+-- FROM "cte0" AS "sub_t0") AS "t0"("res0", "res1")+-- @+--+-- @since 0.6.3.0+pgSelectWithNested+ :: forall db s res+ . Projectible Postgres res+ => PgWith db 'PgCteNestedAllowed (Q Postgres db s res)+ -> Q Postgres db s res+pgSelectWithNested = pgSelectWith_ . unPgWith++-- Shared implementation for the compatible portable and PostgreSQL-specific+-- nested APIs. Keeping the syntax conversion here avoids evaluating or+-- traversing a PgWith block a second time.+pgSelectWith_+ :: forall db s res+ . Projectible Postgres res+ => With Postgres db (Q Postgres db s res)+ -> Q Postgres db s res+pgSelectWith_ (CTE.With mkQ) =+ let (q, (recursiveness, mctes)) = evalState (runWriterT mkQ) 0+ fromSyntax tblPfx =+ case (recursiveness, nonEmpty mctes) of+ (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 $+ mconcat [ emit "(", fromPgSelect (fromSyntax tblPfx), emit ")" ])+ (Just (tName, Just names)))+ (\tName ->+ let (projection, _) = mkFieldNames @Postgres @res (qualifiedField tName)+ in projection)+ (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+onConflictDefault = PgInsertOnConflict (\_ -> PgInsertOnConflictSyntax mempty)++-- | Tells postgres what to do on an @INSERT@ conflict. The first argument is+-- the type of conflict to provide an action for. For example, to only provide+-- an action for certain fields, use 'conflictingFields'. Or to only provide an+-- action over certain fields where a particular condition is met, use+-- 'conflictingFields'. If you have a particular constraint violation in mind,+-- use 'conflictingConstraint'. To perform an action on any conflict, use+-- 'anyConflict'.+--+-- See the+-- <https://www.postgresql.org/docs/current/static/sql-insert.html Postgres documentation>.+onConflict :: Beamable tbl+ => SqlConflictTarget Postgres tbl+ -> SqlConflictAction Postgres tbl+ -> PgInsertOnConflict tbl+onConflict (PgInsertOnConflictTarget tgt) (PgConflictAction update_) =+ PgInsertOnConflict $ \tbl ->+ let exprTbl = changeBeamRep (\(Columnar' (QField _ _ nm)) ->+ Columnar' (QExpr (\_ -> fieldE (unqualifiedField nm))))+ tbl+ in PgInsertOnConflictSyntax $+ emit "ON CONFLICT " <> fromPgInsertOnConflictTarget (tgt exprTbl)+ <> fromPgConflictAction (update_ tbl)++-- | Perform the action only if the given named constraint is violated+conflictingConstraint :: T.Text -> SqlConflictTarget Postgres tbl+conflictingConstraint nm =+ PgInsertOnConflictTarget $ \_ ->+ PgInsertOnConflictTargetSyntax $+ emit "ON CONSTRAINT " <> pgQuotedIdentifier nm <> emit " "++-- * @UPDATE@++-- | The most general kind of @UPDATE@ that postgres can perform+--+-- You can build this from a 'SqlUpdate' by using 'returning'+--+-- > update tbl where `returning` projection+--+-- Run the result with 'runPgUpdateReturningList'+data PgUpdateReturning a+ = PgUpdateReturning PgSyntax+ | PgUpdateReturningEmpty++-- | Postgres @UPDATE ... RETURNING@ statement support. The last+-- argument takes the newly inserted row and returns the values to be+-- returned. Use 'runUpdateReturning' to get the results.+updateReturning :: Projectible Postgres a+ => DatabaseEntity Postgres be (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)+ -> PgUpdateReturning (QExprToIdentity a)+updateReturning table@(DatabaseEntity (DatabaseTable { dbTableSettings = tblSettings }))+ mkAssignments+ mkWhere+ mkProjection =+ case update table mkAssignments mkWhere of+ SqlUpdate _ pgUpdate ->+ PgUpdateReturning $+ fromPgUpdate pgUpdate <>+ emit " RETURNING " <>+ pgSepBy (emit ", ") (map fromPgExpression (project (Proxy @Postgres) (mkProjection tblQ) "t"))++ SqlIdentityUpdate -> PgUpdateReturningEmpty+ 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+ , FromBackendRow be a+ )+ => PgUpdateReturning a+ -> m [a]+runPgUpdateReturningList = \case+ PgUpdateReturningEmpty -> pure []+ PgUpdateReturning syntax -> runReturningList $ PgCommandSyntax PgCommandTypeDataUpdateReturning syntax++-- * @DELETE@++-- | The most general kind of @DELETE@ that postgres can perform+--+-- You can build this from a 'SqlDelete' by using 'returning'+--+-- > delete tbl where `returning` projection+--+-- Run the result with 'runPgDeleteReturningList'+newtype PgDeleteReturning a = PgDeleteReturning PgSyntax++-- | Postgres @DELETE ... RETURNING@ statement support. The last+-- argument takes the newly inserted row and returns the values to be+-- returned. Use 'runDeleteReturning' to get the results.+deleteReturning :: Projectible Postgres a+ => DatabaseEntity Postgres be (TableEntity table)+ -> (forall s. table (QExpr Postgres s) -> QExpr Postgres s Bool)+ -> (table (QExpr Postgres PostgresInaccessible) -> a)+ -> PgDeleteReturning (QExprToIdentity a)+deleteReturning table@(DatabaseEntity (DatabaseTable { dbTableSettings = tblSettings }))+ mkWhere+ mkProjection =+ PgDeleteReturning $+ fromPgDelete pgDelete <>+ emit " RETURNING " <>+ pgSepBy (emit ", ") (map fromPgExpression (project (Proxy @Postgres) (mkProjection tblQ) "t"))+ 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+ , BeamSqlBackendSyntax be ~ PgCommandSyntax+ , FromBackendRow be a+ )+ => PgDeleteReturning a+ -> m [a]+runPgDeleteReturningList (PgDeleteReturning syntax) = runReturningList $ PgCommandSyntax PgCommandTypeDataUpdateReturning syntax++-- * General @RETURNING@ support++class PgReturning cmd where+ type PgReturningType cmd :: Type -> Type++ returning :: (Beamable tbl, Projectible Postgres a)+ => cmd Postgres tbl -> (tbl (QExpr Postgres PostgresInaccessible) -> a)+ -> PgReturningType cmd (QExprToIdentity a)++instance PgReturning SqlInsert where+ type PgReturningType SqlInsert = PgInsertReturning++ returning SqlInsertNoRows _ = PgInsertReturningEmpty+ returning (SqlInsert tblSettings (PgInsertSyntax syntax)) mkProjection =+ PgInsertReturning $+ syntax <> emit " RETURNING " <>+ pgSepBy (emit ", ") (map fromPgExpression (project (Proxy @Postgres) (mkProjection tblQ) "t"))++ where+ tblQ = changeBeamRep (\(Columnar' f) -> Columnar' (QExpr . pure . fieldE . unqualifiedField . _fieldName $ f)) tblSettings++instance PgReturning SqlUpdate where+ type PgReturningType SqlUpdate = PgUpdateReturning++ returning SqlIdentityUpdate _ = PgUpdateReturningEmpty+ returning (SqlUpdate tblSettings (PgUpdateSyntax syntax)) mkProjection =+ PgUpdateReturning $+ syntax <> emit " RETURNING " <>+ pgSepBy (emit ", ") (map fromPgExpression (project (Proxy @Postgres) (mkProjection tblQ) "t"))++ where+ tblQ = changeBeamRep (\(Columnar' f) -> Columnar' (QExpr . pure . fieldE . unqualifiedField . _fieldName $ f)) tblSettings++instance PgReturning SqlDelete where+ type PgReturningType SqlDelete = PgDeleteReturning++ returning (SqlDelete tblSettings (PgDeleteSyntax syntax)) mkProjection =+ PgDeleteReturning $+ syntax <> emit " RETURNING " <>+ pgSepBy (emit ", ") (map fromPgExpression (project (Proxy @Postgres) (mkProjection tblQ) "t"))++ where+ tblQ = changeBeamRep (\(Columnar' f) -> Columnar' (QExpr . pure . fieldE . unqualifiedField . _fieldName $ f)) tblSettings++instance BeamHasInsertOnConflict Postgres where+ newtype SqlConflictTarget Postgres table =+ PgInsertOnConflictTarget (table (QExpr Postgres QInternal) -> PgInsertOnConflictTargetSyntax)+ newtype SqlConflictAction Postgres table =+ PgConflictAction (table (QField QInternal) -> PgConflictActionSyntax)++ insertOnConflict tbl vs target action = insert tbl vs $ onConflict target action++ -- | Perform the conflict action when any constraint or index conflict occurs.+ -- Syntactically, this is the @ON CONFLICT@ clause, without any /conflict target/.+ anyConflict = PgInsertOnConflictTarget (\_ -> PgInsertOnConflictTargetSyntax mempty)++ -- | The Postgres @DO NOTHING@ action+ onConflictDoNothing = PgConflictAction $ \_ -> PgConflictActionSyntax (emit "DO NOTHING")++ -- | The Postgres @DO UPDATE SET@ action, without the @WHERE@ clause. The+ -- argument takes an updatable row (like the one used in 'update') and the+ -- conflicting row. Use 'current_' on the first argument to get the current+ -- value of the row in the database.+ onConflictUpdateSet mkAssignments =+ PgConflictAction $ \tbl ->+ let QAssignment assignments = mkAssignments tbl tblExcluded+ tblExcluded = changeBeamRep (\(Columnar' (QField _ _ nm)) -> Columnar' (QExpr (\_ -> fieldE (qualifiedField "excluded" nm)))) tbl++ assignmentSyntaxes =+ [ fromPgFieldName fieldNm <> emit "=" <> pgParens (fromPgExpression expr)+ | (fieldNm, expr) <- assignments ]+ in PgConflictActionSyntax $+ emit "DO UPDATE SET " <> pgSepBy (emit ", ") assignmentSyntaxes++ -- | The Postgres @DO UPDATE SET@ action, with the @WHERE@ clause. This is like+ -- 'onConflictUpdateSet', but only rows satisfying the given condition are+ -- updated. Sometimes this results in more efficient locking. See the Postgres+ -- <https://www.postgresql.org/docs/current/static/sql-insert.html manual> for+ -- more information.+ onConflictUpdateSetWhere mkAssignments where_ =+ PgConflictAction $ \tbl ->+ let QAssignment assignments = mkAssignments tbl tblExcluded+ QExpr where_' = where_ tbl tblExcluded+ tblExcluded = changeBeamRep (\(Columnar' (QField _ _ nm)) -> Columnar' (QExpr (\_ -> fieldE (qualifiedField "excluded" nm)))) tbl++ assignmentSyntaxes =+ [ fromPgFieldName fieldNm <> emit "=" <> pgParens (fromPgExpression expr)+ | (fieldNm, expr) <- assignments ]+ in PgConflictActionSyntax $+ emit "DO UPDATE SET " <> pgSepBy (emit ", ") assignmentSyntaxes <> emit " WHERE " <> fromPgExpression (where_' "t")++ -- | Perform the conflict action only when these fields conflict. The first+ -- argument gets the current row as a table of expressions. Return the conflict+ -- key. For more information, see the @beam-postgres@ manual.+ conflictingFields makeProjection =+ PgInsertOnConflictTarget $ \tbl ->+ PgInsertOnConflictTargetSyntax $+ pgParens (pgSepBy (emit ", ") $+ map fromPgExpression $+ project (Proxy @Postgres) (makeProjection tbl) "t") <>+ emit " "++ -- | Like 'conflictingFields', but only perform the action if the condition+ -- given in the second argument is met. See the postgres+ -- <https://www.postgresql.org/docs/current/static/sql-insert.html manual> for+ -- more information.+ conflictingFieldsWhere makeProjection makeWhere =+ PgInsertOnConflictTarget $ \tbl ->+ PgInsertOnConflictTargetSyntax $+ pgParens (pgSepBy (emit ", ") $+ map fromPgExpression (project (Proxy @Postgres)+ (makeProjection tbl) "t")) <>+ emit " WHERE " <>+ pgParens (let QExpr mkE = makeWhere tbl+ PgExpressionSyntax e = mkE "t"+ in e) <>+ emit " "
Database/Beam/Postgres/Migrate.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -14,6 +16,7 @@ , postgresDataTypeDeserializers , pgPredConverter , getDbConstraints+ , getDbConstraintsForSchemas , pgTypeToHs , migrateScript , writeMigrationScript@@ -28,7 +31,9 @@ ) where import Database.Beam.Backend.SQL-import Database.Beam.Migrate.Actions (defaultActionProvider)+import Database.Beam.Migrate.Actions (defaultActionProvider,+ defaultSchemaActionProvider,+ createIndexActionProvider, dropIndexActionProvider) import qualified Database.Beam.Migrate.Backend as Tool import qualified Database.Beam.Migrate.Checks as Db import qualified Database.Beam.Migrate.SQL as Db@@ -52,17 +57,17 @@ import Control.Applicative ((<|>)) import Control.Arrow-import Control.Exception (bracket)+import Control.Exception.Lifted (mask, onException) import Control.Monad-import Control.Monad.Free.Church (liftF) -import Data.Aeson hiding (json)+import Data.Aeson import Data.Bits import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Lazy.Char8 as BCL import qualified Data.HashMap.Strict as HM import Data.Int+import qualified Data.List.NonEmpty as NE (nonEmpty) import Data.Maybe import Data.String import qualified Data.Text as T@@ -70,36 +75,56 @@ import Data.Typeable import Data.UUID.Types (UUID) import qualified Data.Vector as V-#if !MIN_VERSION_base(4, 11, 0) import Data.Semigroup-#else-import Data.Monoid (Endo(..))-#endif import Data.Word (Word64) +import GHC.Generics ( Generic )+ -- | Top-level migration backend for use by @beam-migrate@ tools migrationBackend :: Tool.BeamMigrationBackend Postgres Pg migrationBackend = Tool.BeamMigrationBackend- "postgres"- (unlines [ "For beam-postgres, this is a libpq connection string which can either be a list of key value pairs or a URI"- , ""- , "For example, 'host=localhost port=5432 dbname=mydb connect_timeout=10' or 'dbname=mydb'"- , ""- , "Or use URIs, for which the general form is:"- , " postgresql://[user[:password]@][netloc][:port][/dbname][?param1=value1&...]"- , ""- , "See <https://www.postgresql.org/docs/9.5/static/libpq-connect.html#LIBPQ-CONNSTRING> for more information" ])- (liftF (PgLiftWithHandle getDbConstraints id))- (Db.sql92Deserializers <> Db.sql99DataTypeDeserializers <>- Db.sql2008BigIntDataTypeDeserializers <>- postgresDataTypeDeserializers <>- Db.beamCheckDeserializers)- (BCL.unpack . (<> ";") . pgRenderSyntaxScript . fromPgCommand) "postgres.sql"- pgPredConverter (defaultActionProvider <> pgExtensionActionProvider <>- pgCustomEnumActionProvider)- (\options action ->- bracket (Pg.connectPostgreSQL (fromString options)) Pg.close $ \conn ->- left show <$> withPgDebug (\_ -> pure ()) conn action)+ { Tool.backendName = "postgres"+ , Tool.backendConnStringExplanation =+ unlines [ "For beam-postgres, this is a libpq connection string which can either be a list of key value pairs or a URI"+ , ""+ , "For example, 'host=localhost port=5432 dbname=mydb connect_timeout=10' or 'dbname=mydb'"+ , ""+ , "Or use URIs, for which the general form is:"+ , " postgresql://[user[:password]@][netloc][:port][/dbname][?param1=value1&...]"+ , ""+ , "See <https://www.postgresql.org/docs/9.5/static/libpq-connect.html#LIBPQ-CONNSTRING> for more information" ]+ , Tool.backendGetDbConstraints = liftIOWithHandle getDbConstraints+ , Tool.backendPredicateParsers =+ Db.sql92Deserializers <> Db.sql99DataTypeDeserializers <>+ Db.sql2008BigIntDataTypeDeserializers <>+ postgresDataTypeDeserializers <>+ Db.beamCheckDeserializers+ , Tool.backendRenderSyntax = (BCL.unpack . (<> ";") . pgRenderSyntaxScript . fromPgCommand)+ , Tool.backendFileExtension = "postgres.sql"+ , Tool.backendConvertToHaskell = pgPredConverter+ , Tool.backendActionProvider =+ mconcat [ defaultActionProvider+ , defaultSchemaActionProvider+ , createIndexActionProvider+ , dropIndexActionProvider+ , pgExtensionActionProvider+ , pgCustomEnumActionProvider+ ]+ , Tool.backendRunSqlScript = \t -> liftIOWithHandle (\hdl -> void $ Pg.execute_ hdl (Pg.Query (TE.encodeUtf8 t)))+ , Tool.backendWithTransaction =+ \go -> mask $ \unmask -> do+ liftIOWithHandle Pg.begin+ x <- unmask go `onException` liftIOWithHandle Pg.rollback+ liftIOWithHandle Pg.commit+ pure x+ , Tool.backendConnect = \options -> do+ conn <- Pg.connectPostgreSQL (fromString options)+ pure Tool.BeamMigrateConnection+ { Tool.backendRun = \action ->+ left show <$> withPgDebug (\_ -> pure ()) conn action+ , Tool.backendClose = Pg.close conn+ }+ } -- | 'BeamDeserializers' for postgres-specific types: --@@ -321,22 +346,37 @@ PgDataTypeSyntax (PgDataTypeDescrOid oid pgMod) (emit "{- UNKNOWN -}") (pgDataTypeJSON (object [ "oid" .= (fromIntegral oid' :: Word), "mod" .= pgMod ])) --- * Create constraints from a connection +newtype SchemaName = MkSchemaName T.Text+ deriving (Generic, Pg.FromRow)++-- * Create constraints from a connection getDbConstraints :: Pg.Connection -> IO [ Db.SomeDatabasePredicate ]-getDbConstraints conn =- do tbls <- Pg.query_ conn "SELECT cl.oid, relname FROM pg_catalog.pg_class \"cl\" join pg_catalog.pg_namespace \"ns\" on (ns.oid = relnamespace) where nspname = any (current_schemas(false)) and relkind='r'"- let tblsExist = map (\(_, tbl) -> Db.SomeDatabasePredicate (Db.TableExistsPredicate (Db.QualifiedName Nothing tbl))) tbls+getDbConstraints conn = do + schemata <- Pg.query_ conn "SELECT schema_name FROM information_schema.schemata WHERE schema_name NOT LIKE '%pg_%' AND schema_name <> 'information_schema' AND schema_name <> 'public';"+ case schemata of+ [] -> getDbConstraintsForSchemas Nothing conn+ schemata' -> + (++) <$> getDbConstraintsForSchemas (Just ((\(MkSchemaName nm) -> T.unpack nm) <$> schemata')) conn+ <*> getDbConstraintsForSchemas Nothing conn +getDbConstraintsForSchemas :: Maybe [String] -> Pg.Connection -> IO [ Db.SomeDatabasePredicate ]+getDbConstraintsForSchemas subschemas conn =+ do (tbls :: [(Pg.Oid, Maybe T.Text, T.Text)]) <- case subschemas of+ Nothing -> Pg.query_ conn "SELECT cl.oid, NULL, relname FROM pg_catalog.pg_class \"cl\" join pg_catalog.pg_namespace \"ns\" on (ns.oid = relnamespace) where nspname = any (current_schemas(false)) and relkind='r'"+ Just ss -> Pg.query conn "SELECT cl.oid, nspname, relname FROM pg_catalog.pg_class \"cl\" join pg_catalog.pg_namespace \"ns\" on (ns.oid = relnamespace) where nspname IN ? and relkind='r'" (Pg.Only (Pg.In ss))+ let tblsExist = map (\(_, mschema, tbl) -> Db.SomeDatabasePredicate (Db.TableExistsPredicate (Db.QualifiedName mschema tbl))) tbls+ schemaChecks = fromMaybe [] $ (fmap (Db.SomeDatabasePredicate . Db.SchemaExistsPredicate . T.pack)) <$> subschemas enumerationData <- Pg.query_ conn (fromString (unlines [ "SELECT t.typname, t.oid, array_agg(e.enumlabel ORDER BY e.enumsortorder)" , "FROM pg_enum e JOIN pg_type t ON t.oid = e.enumtypid"- , "GROUP BY t.typname, t.oid" ]))+ , "GROUP BY t.typname, t.oid" + ])) columnChecks <-- fmap mconcat . forM tbls $ \(oid, tbl) ->+ fmap mconcat . forM tbls $ \(oid, mschema, tbl) -> do columns <- Pg.query conn "SELECT attname, atttypid, atttypmod, attnotnull, pg_catalog.format_type(atttypid, atttypmod) FROM pg_catalog.pg_attribute att WHERE att.attrelid=? AND att.attnum>0 AND att.attisdropped='f'" (Pg.Only (oid :: Pg.Oid)) let columnChecks = map (\(nm, typId :: Pg.Oid, typmod, _, typ :: ByteString) ->@@ -346,29 +386,145 @@ pgDataTypeFromAtt typ typId typmod' <|> pgEnumerationTypeFromAtt enumerationData typ typId typmod' - in Db.SomeDatabasePredicate (Db.TableHasColumn (Db.QualifiedName Nothing tbl) nm pgDataType :: Db.TableHasColumn Postgres)) columns+ in Db.SomeDatabasePredicate (Db.TableHasColumn (Db.QualifiedName mschema tbl) nm pgDataType :: Db.TableHasColumn Postgres)) columns notNullChecks = concatMap (\(nm, _, _, isNotNull, _) -> if isNotNull then- [Db.SomeDatabasePredicate (Db.TableColumnHasConstraint (Db.QualifiedName Nothing tbl) nm (Db.constraintDefinitionSyntax Nothing Db.notNullConstraintSyntax Nothing)+ [Db.SomeDatabasePredicate (Db.TableColumnHasConstraint (Db.QualifiedName mschema tbl) nm (Db.constraintDefinitionSyntax Nothing Db.notNullConstraintSyntax Nothing) :: Db.TableColumnHasConstraint Postgres)] else [] ) columns - pure (columnChecks ++ notNullChecks)+ pure (columnChecks ++ notNullChecks ++ schemaChecks) primaryKeys <-- map (\(relnm, cols) -> Db.SomeDatabasePredicate (Db.TableHasPrimaryKey (Db.QualifiedName Nothing relnm) (V.toList cols))) <$>- Pg.query_ conn (fromString (unlines [ "SELECT c.relname, array_agg(a.attname ORDER BY k.n ASC)"+ map (\(schema, relnm, cols) -> Db.SomeDatabasePredicate (Db.TableHasPrimaryKey (Db.QualifiedName schema relnm) (V.toList cols))) <$>+ -- We nullify the 'public' schema, which is the implicit default in Postgres+ Pg.query_ conn (fromString (unlines [ "SELECT NULLIF(ns.nspname, 'public'), c.relname, array_agg(a.attname ORDER BY k.n ASC)" , "FROM pg_index i" , "CROSS JOIN unnest(i.indkey) WITH ORDINALITY k(attid, n)" , "JOIN pg_attribute a ON a.attnum=k.attid AND a.attrelid=i.indrelid" , "JOIN pg_class c ON c.oid=i.indrelid"- , "WHERE c.relkind='r' AND i.indisprimary GROUP BY relname, i.indrelid" ]))+ , "JOIN pg_namespace ns ON ns.oid=c.relnamespace"+ -- Recall that schema of the form 'pg_' are Postgres internal tables that should not be taken into account+ , "WHERE nspname NOT LIKE '%pg_%' AND c.relkind='r' AND i.indisprimary GROUP BY nspname, relname, i.indrelid" ])) + -- Collect user-created secondary indices.+ --+ -- Excludes:+ -- - primary keys+ -- - indices that back a constraint (i.e. those created implicitly by UNIQUE/EXCLUDE)+ -- - expression indices e.g. CREATE INDEX ON users (LOWER(email))+ secondaryIndices <-+ mapMaybe (\(schema, tblNm, idxNm, isUniq, cols) ->+ case NE.nonEmpty (V.toList cols) of+ Nothing -> Nothing+ Just colsNE ->+ let opts = Db.setUniqueIndexOptions @(BeamSqlBackendSyntax Postgres) isUniq+ $ Db.defaultIndexOptions @(BeamSqlBackendSyntax Postgres)+ in+ Just $+ Db.SomeDatabasePredicate @(Db.TableHasIndex Postgres)+ (Db.TableHasIndex (Db.QualifiedName schema tblNm) idxNm colsNE opts)) <$>+ Pg.query_ conn (fromString (unlines+ [ -- NULL out 'public' since it is the implicit default schema in Postgres+ "SELECT NULLIF(ns.nspname, 'public'), c.relname, i.relname, ix.indisunique,"+ -- re-aggregate column names in index-key order (see ORDINALITY below)+ , " array_agg(a.attname ORDER BY k.n ASC)"+ , "FROM pg_index ix"+ , "JOIN pg_class c ON c.oid = ix.indrelid"+ , "JOIN pg_class i ON i.oid = ix.indexrelid"+ , "JOIN pg_namespace ns ON ns.oid = c.relnamespace"+ -- ORDINALITY allows retaining ordering of index columns+ , "CROSS JOIN unnest(ix.indkey) WITH ORDINALITY k(attid, n)"+ , "JOIN pg_attribute a ON a.attnum = k.attid AND a.attrelid = ix.indrelid"+ -- only regular tables (not views, sequences, etc.)+ , "WHERE c.relkind = 'r'"+ -- exclude Postgres system schemas+ , " AND ns.nspname NOT LIKE 'pg_%'"+ , " AND ns.nspname != 'information_schema'"+ -- exclude primary key indices+ , " AND NOT ix.indisprimary"+ -- exclude indices created implicitly by a UNIQUE or EXCLUDE constraint+ , " AND NOT EXISTS (SELECT 1 FROM pg_constraint con WHERE con.conindid = ix.indexrelid)"+ -- exclude expression indices: a key column number of 0 means that+ -- position is an expression (e.g. lower(col)) rather than a plain+ -- column reference, which TableHasIndex cannot represent+ , " AND NOT EXISTS (SELECT 1 FROM unnest(ix.indkey) AS k(attnum) WHERE k.attnum = 0)"+ , "GROUP BY ns.nspname, c.relname, i.relname, ix.indisunique" ]))++ -- Collect foreign key constraints via pg_constraint.+ let fkBaseQuery = unlines+ [ -- NULL out 'public' since it is the implicit default schema in Postgres+ "SELECT NULLIF(ns.nspname, 'public'),"+ , " c.relname,"+ -- re-aggregate local and referenced column names in key order (see ORDINALITY below)+ , " array_agg(a.attname ORDER BY k.n),"+ , " NULLIF(fns.nspname, 'public'),"+ , " fc.relname,"+ , " array_agg(fa.attname ORDER BY k.n),"+ , " con.confupdtype,"+ , " con.confdeltype"+ , "FROM pg_constraint con"+ , "JOIN pg_class c ON c.oid = con.conrelid"+ , "JOIN pg_namespace ns ON ns.oid = c.relnamespace"+ , "JOIN pg_class fc ON fc.oid = con.confrelid"+ , "JOIN pg_namespace fns ON fns.oid = fc.relnamespace"+ -- ORDINALITY retains column ordering for both local and referenced sides+ , "CROSS JOIN unnest(con.conkey, con.confkey)"+ , " WITH ORDINALITY AS k(attnum, fattnum, n)"+ , "JOIN pg_attribute a ON a.attnum = k.attnum AND a.attrelid = con.conrelid"+ , "JOIN pg_attribute fa ON fa.attnum = k.fattnum AND fa.attrelid = con.confrelid"+ -- retain only foreign key constraints+ , "WHERE con.contype = 'f'" ]+ mkFkPred (srcSchema, srcTbl, localCols, refSchema, refTbl, refCols, updCode, delCode) =+ case (NE.nonEmpty (V.toList localCols), NE.nonEmpty (V.toList refCols)) of+ (Just lcNE, Just rcNE) ->+ Just $ Db.SomeDatabasePredicate+ (Db.TableHasForeignKey (Db.QualifiedName srcSchema srcTbl) lcNE+ (Db.QualifiedName refSchema refTbl) rcNE+ (parsePgForeignKeyAction updCode)+ (parsePgForeignKeyAction delCode))+ _ -> Nothing+ foreignKeyChecks <- mapMaybe mkFkPred <$>+ case subschemas of+ Nothing ->+ Pg.query_ conn (fromString (fkBaseQuery <>+ " AND ns.nspname = any(current_schemas(false))\n" <>+ "GROUP BY ns.nspname, c.relname, con.oid, fns.nspname, fc.relname,\n" <>+ " con.confupdtype, con.confdeltype"))+ Just ss ->+ Pg.query conn (fromString (fkBaseQuery <>+ " AND ns.nspname IN ?\n" <>+ "GROUP BY ns.nspname, c.relname, con.oid, fns.nspname, fc.relname,\n" <>+ " con.confupdtype, con.confdeltype"))+ (Pg.Only (Pg.In ss))+ let enumerations = map (\(enumNm, _, options) -> Db.SomeDatabasePredicate (PgHasEnum enumNm (V.toList options))) enumerationData - pure (tblsExist ++ columnChecks ++ primaryKeys ++ enumerations)+ extensions <-+ map (\(Pg.Only extname) -> Db.SomeDatabasePredicate (PgHasExtension extname)) <$>+ Pg.query_ conn "SELECT extname from pg_extension" + pure $+ concat+ [ tblsExist+ , columnChecks+ , primaryKeys+ , secondaryIndices+ , foreignKeyChecks+ , enumerations+ , extensions+ ]++parsePgForeignKeyAction :: Char -> Db.ForeignKeyAction+parsePgForeignKeyAction 'c' = Db.ForeignKeyActionCascade+parsePgForeignKeyAction 'n' = Db.ForeignKeyActionSetNull+parsePgForeignKeyAction 'd' = Db.ForeignKeyActionSetDefault+parsePgForeignKeyAction 'r' = Db.ForeignKeyActionRestrict+parsePgForeignKeyAction 'a' = Db.ForeignKeyNoAction+parsePgForeignKeyAction c = error $+ "parsePgForeignKeyAction: unrecognised foreign key action code: " ++ show c+ -- * Postgres-specific data types -- | 'Db.DataType' for @tsquery@. See 'TsQuery' for more information@@ -442,5 +598,11 @@ field' _ _ nm ty _ collation constraints PgHasDefault = Db.field' (Proxy @'True) (Proxy @'False) nm ty Nothing collation constraints -instance BeamSqlBackendHasSerial Postgres where+instance BeamSqlBackendHasSerial Int16 Postgres where+ genericSerial nm = Db.field nm smallserial PgHasDefault++instance BeamSqlBackendHasSerial Int32 Postgres where genericSerial nm = Db.field nm serial PgHasDefault++instance BeamSqlBackendHasSerial Int64 Postgres where+ genericSerial nm = Db.field nm bigserial PgHasDefault
Database/Beam/Postgres/PgCrypto.hs view
@@ -1,3 +1,4 @@+ -- | The @pgcrypto@ extension provides several cryptographic functions to -- Postgres. This module provides a @beam-postgres@ extension to access this -- functionality. For an example of usage, see the documentation for@@ -8,21 +9,14 @@ import Database.Beam import Database.Beam.Backend.SQL -import Database.Beam.Postgres.Types-import Database.Beam.Postgres.Extensions+import Database.Beam.Postgres.Extensions( LiftPg, PgExpr, IsPgExtension(..), funcE ) +import Data.Int import Data.Text (Text) import Data.ByteString (ByteString) import Data.Vector (Vector) import Data.UUID.Types (UUID) -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- -- | Data type representing definitions contained in the @pgcrypto@ extension -- -- Each field maps closely to the underlying @pgcrypto@ function, which are@@ -41,7 +35,7 @@ , pgCryptoCrypt :: forall ctxt s. LiftPg ctxt s (Text -> Text -> Text) , pgCryptoGenSalt ::- forall ctxt s. LiftPg ctxt s (Text -> Maybe Int -> Text)+ forall ctxt s. LiftPg ctxt s (Text -> Maybe Int32 -> Text) -- Pgp functions , pgCryptoPgpSymEncrypt ::@@ -83,9 +77,6 @@ , pgCryptoGenRandomUUID :: forall ctxt s. PgExpr ctxt s UUID }--funcE :: IsSql99ExpressionSyntax expr => Text -> [expr] -> expr-funcE nm args = functionCallE (fieldE (unqualifiedField nm)) args instance IsPgExtension PgCrypto where pgExtensionName _ = "pgcrypto"
Database/Beam/Postgres/PgSpecific.hs view
@@ -9,7 +9,6 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE PolyKinds #-}-{-# LANGUAGE CPP #-} -- | Postgres-specific types, functions, and operators module Database.Beam.Postgres.PgSpecific@@ -38,6 +37,7 @@ , withoutKeys , pgJsonArrayLength+ , pgArrayToJson , pgJsonbUpdate, pgJsonbSet , pgJsonbPretty @@ -56,6 +56,12 @@ , PgBox(..), PgPath(..), PgPolygon(..) , PgCircle(..) + -- ** Regular expressions+ , PgRegex(..), pgRegex_+ , (~.), (~*.), (!~.), (!~*.)+ , pgRegexpReplace_, pgRegexpMatch_+ , pgRegexpSplitToTable, pgRegexpSplitToArray+ -- ** Set-valued functions -- $set-valued-funs , PgSetOf, pgUnnest@@ -74,6 +80,9 @@ , arrayUpper_, arrayLower_ , arrayUpperUnsafe_, arrayLowerUnsafe_ , arrayLength_, arrayLengthUnsafe_+ , arrayAppend_, arrayPrepend_, arrayRemove_+ , arrayReplace_, arrayShuffle_, arraySample_+ , arrayToString_, arrayToStringWithNull_ , isSupersetOf_, isSubsetOf_ @@ -86,7 +95,7 @@ -- *** Building ranges from expressions , range_- + -- *** Building @PgRangeBound@s , inclusive, exclusive, unbounded @@ -98,13 +107,17 @@ , rLower_, rUpper_, isEmpty_ , lowerInc_, upperInc_, lowerInf_, upperInf_ , rangeMerge_- ++ -- * Postgres @EXTRACT@ fields+ , century_, decade_, dow_, doy_, epoch_, isodow_, isoyear_+ , microseconds_, milliseconds_, millennium_, quarter_+ -- ** Postgres functions and aggregates , pgBoolOr, pgBoolAnd, pgStringAgg, pgStringAggOver , pgNubBy_ - , now_, ilike_+ , now_, ilike_, ilike_' ) where @@ -127,18 +140,18 @@ import qualified Data.ByteString.Char8 as BC import qualified Data.ByteString.Lazy as BL import Data.Foldable+import Data.Functor import Data.Hashable+import Data.Int+import Data.Kind (Type) import qualified Data.List.NonEmpty as NE import Data.Proxy import Data.Scientific (Scientific, formatScientific, FPFormat(Fixed)) import Data.String import qualified Data.Text as T-import Data.Time (LocalTime)+import Data.Time (LocalTime, NominalDiffTime) import Data.Type.Bool import qualified Data.Vector as V-#if !MIN_VERSION_base(4, 11, 0)-import Data.Semigroup-#endif import qualified Database.PostgreSQL.Simple.FromField as Pg import qualified Database.PostgreSQL.Simple.ToField as Pg@@ -147,6 +160,7 @@ import GHC.TypeLits import GHC.Exts hiding (toList)+import Data.Text (Text) -- ** Postgres-specific functions @@ -155,12 +169,23 @@ now_ = QExpr (\_ -> PgExpressionSyntax (emit "NOW()")) -- | Postgres @ILIKE@ operator. A case-insensitive version of 'like_'.-ilike_ :: BeamSqlBackendIsString Postgres text- => QExpr Postgres s text- -> QExpr Postgres s text- -> QExpr Postgres s Bool-ilike_ (QExpr a) (QExpr b) = QExpr (pgBinOp "ILIKE" <$> a <*> b)+ilike_+ :: BeamSqlBackendIsString Postgres text+ => QExpr Postgres s text+ -> QExpr Postgres s text+ -> QExpr Postgres s Bool+ilike_ = ilike_' +-- | Postgres @ILIKE@ operator. A case-insensitive version of 'like_''.+ilike_'+ :: ( BeamSqlBackendIsString Postgres left+ , BeamSqlBackendIsString Postgres right+ )+ => QExpr Postgres s left+ -> QExpr Postgres s right+ -> QExpr Postgres s Bool+ilike_' (QExpr a) (QExpr b) = QExpr (pgBinOp "ILIKE" <$> a <*> b)+ -- ** TsVector type -- | The type of a document preprocessed for full-text search. The contained@@ -284,10 +309,10 @@ -> QGenExpr context Postgres s text arrayDims_ (QExpr v) = QExpr (fmap (\(PgExpressionSyntax v') -> PgExpressionSyntax (emit "array_dims(" <> v' <> emit ")")) v) -type family CountDims (v :: *) :: Nat where+type family CountDims (v :: Type) :: Nat where CountDims (V.Vector a) = 1 + CountDims a CountDims a = 0-type family WithinBounds (dim :: Nat) (v :: *) :: Constraint where+type family WithinBounds (dim :: Nat) (v :: Type) :: Constraint where WithinBounds dim v = If ((dim <=? CountDims v) && (1 <=? dim)) (() :: Constraint)@@ -388,6 +413,165 @@ QExpr a ++. QExpr b = QExpr (pgBinOp "||" <$> a <*> b) +-- | Postgres array_append(value) function.+--+-- Appends an element to the end of an array. Equivalent to the+-- @anycompatiblearray || anycompatible@ operator.+--+-- Notes:+-- - The array must be empty or one-dimensional (per Postgres rules for+-- concatenating an element with an array).+-- - If the array is NULL, the result is NULL. If the element is NULL,+-- a NULL element is appended.+--+-- @since 0.5.4.4+arrayAppend_+ :: QGenExpr ctxt Postgres s (V.Vector a)+ -> QGenExpr ctxt Postgres s a+ -> QGenExpr ctxt Postgres s (V.Vector a)+arrayAppend_ (QExpr arr) (QExpr el) =+ QExpr (PgExpressionSyntax . mappend (emit "array_append") . pgParens . mconcat <$> sequenceA+ [ fromPgExpression <$> arr+ , pure (emit ", ")+ , fromPgExpression <$> el+ ])++-- | Postgres array_prepend(value) function.+--+-- Prepends an element to the beginning of an array. Equivalent to the+-- @anycompatible || anycompatiblearray@ operator.+--+-- Notes:+-- - The array must be empty or one-dimensional.+-- - If the array is NULL, the result is NULL. If the element is NULL,+-- a NULL element is prepended.+--+-- @since 0.5.4.4+arrayPrepend_+ :: QGenExpr ctxt Postgres s a+ -> QGenExpr ctxt Postgres s (V.Vector a)+ -> QGenExpr ctxt Postgres s (V.Vector a)+arrayPrepend_ (QExpr el) (QExpr arr) =+ QExpr (PgExpressionSyntax . mappend (emit "array_prepend") . pgParens . mconcat <$> sequenceA+ [ fromPgExpression <$> el+ , pure (emit ", ")+ , fromPgExpression <$> arr+ ])++-- | Postgres array_remove(value) function.+--+-- Removes all elements equal to the given value from the array.+-- Comparisons use @IS NOT DISTINCT FROM@ semantics, so this can remove NULLs.+--+-- Notes:+-- - The array must be one-dimensional.+-- - Returns NULL only if the array is NULL; if the value is not present,+-- the original array is returned unchanged.+--+-- @since 0.5.4.4+arrayRemove_+ :: QGenExpr ctxt Postgres s (V.Vector a)+ -> QGenExpr ctxt Postgres s a+ -> QGenExpr ctxt Postgres s (V.Vector a)+arrayRemove_ (QExpr arr) (QExpr el) =+ QExpr (PgExpressionSyntax . mappend (emit "array_remove") . pgParens . mconcat <$> sequenceA+ [ fromPgExpression <$> arr+ , pure (emit ", ")+ , fromPgExpression <$> el+ ])++-- | Postgres array_replace(array, from, to) function.+--+-- Replaces each element equal to the second argument with the third.+--+-- Notes:+-- - Comparisons use IS NOT DISTINCT FROM semantics; can replace NULLs.+-- - The array must be one-dimensional.+--+-- Example:+--+-- @+-- select_ $ pure $ arrayReplace_ (val_ $ V.fromList [1::Int32,2,5,4]) (val_ 5) (val_ 3)+-- -- => {1,2,3,4}+-- @+--+-- @since 0.5.4.4+arrayReplace_+ :: QGenExpr ctxt Postgres s (V.Vector a) -- ^ The array to operate on+ -> QGenExpr ctxt Postgres s a -- ^ The value to be replaced+ -> QGenExpr ctxt Postgres s a -- ^ The new value+ -> QGenExpr ctxt Postgres s (V.Vector a)+arrayReplace_ (QExpr arr) (QExpr fromVal) (QExpr toVal) =+ QExpr (PgExpressionSyntax . mappend (emit "array_replace") . pgParens . mconcat <$> sequenceA+ [ fromPgExpression <$> arr+ , pure (emit ", ")+ , fromPgExpression <$> fromVal+ , pure (emit ", ")+ , fromPgExpression <$> toVal+ ])++-- | Postgres array_shuffle(array) function.+-- Randomly shuffles the first dimension.+--+-- @since 0.5.4.4+arrayShuffle_+ :: QGenExpr ctxt Postgres s (V.Vector a)+ -> QGenExpr ctxt Postgres s (V.Vector a)+arrayShuffle_ (QExpr arr) =+ QExpr (PgExpressionSyntax . mappend (emit "array_shuffle") . pgParens . fromPgExpression <$> arr)++-- | Postgres array_sample(array, n) function.+-- Randomly selects @n@ items from the array. For multidimensional arrays,+-- an "item" is a slice with a given first subscript.+--+-- Precondition: @n@ must not exceed the length of the first dimension.+-- If n is negative, it will be treated as 0.+--+-- @since 0.5.4.4+arraySample_+ :: Integral n+ => QGenExpr ctxt Postgres s (V.Vector a) -- ^ The source array+ -> QGenExpr ctxt Postgres s n -- ^ Number of elements to sample (negative values treated as 0)+ -> QGenExpr ctxt Postgres s (V.Vector a)+arraySample_ (QExpr arr) (QExpr n) =+ QExpr (PgExpressionSyntax . mappend (emit "array_sample") . pgParens . mconcat <$> sequenceA+ [ fromPgExpression <$> arr+ , pure (emit ", greatest(0, ")+ , fromPgExpression <$> n+ , pure (emit ")")+ ])++-- | Postgres array_to_string(array, delimiter) function.+-- Converts each element to text and joins with the delimiter. NULLs are omitted.+--+-- @since 0.5.4.4+arrayToString_+ :: QGenExpr ctxt Postgres s (V.Vector a)+ -> QGenExpr ctxt Postgres s Text+ -> QGenExpr ctxt Postgres s Text+arrayToString_ (QExpr arr) (QExpr delim) =+ QExpr (PgExpressionSyntax <$> do+ arrExpr <- fromPgExpression <$> arr+ delimExpr <- fromPgExpression <$> delim+ pure $ emit "array_to_string" <> pgParens (arrExpr <> emit ", " <> delimExpr))++-- | Postgres array_to_string(array, delimiter, null_string) function.+-- Converts each element to text and joins with the delimiter. NULLs are+-- represented by the provided @null_string@.+--+-- @since 0.5.4.4+arrayToStringWithNull_+ :: QGenExpr ctxt Postgres s (V.Vector a)+ -> QGenExpr ctxt Postgres s Text+ -> QGenExpr ctxt Postgres s Text+ -> QGenExpr ctxt Postgres s Text+arrayToStringWithNull_ (QExpr arr) (QExpr delim) (QExpr nullStr) =+ QExpr (PgExpressionSyntax <$> do+ arrExpr <- fromPgExpression <$> arr+ delimExpr <- fromPgExpression <$> delim+ nullStrExpr <- fromPgExpression <$> nullStr+ pure $ emit "array_to_string" <>+ pgParens (mconcat [arrExpr, emit ", ", delimExpr, emit ", ", nullStrExpr])) -- ** Array expressions -- | An expression context that determines which types of expressions can be put@@ -433,7 +617,7 @@ data PgBoundType = Inclusive | Exclusive- deriving (Show, Generic)+ deriving (Eq, Show, Generic) instance Hashable PgBoundType lBound :: PgBoundType -> ByteString@@ -446,7 +630,7 @@ -- | Represents a single bound on a Range. A bound always has a type, but may not have a value -- (the absense of a value represents unbounded).-data PgRangeBound a = PgRangeBound PgBoundType (Maybe a) deriving (Show, Generic)+data PgRangeBound a = PgRangeBound PgBoundType (Maybe a) deriving (Eq, Show, Generic) inclusive :: a -> PgRangeBound a inclusive = PgRangeBound Inclusive . Just@@ -462,10 +646,10 @@ -- -- A reasonable example might be @Range PgInt8Range Int64@. -- This represents a range of Haskell @Int64@ values stored as a range of 'bigint' in Postgres.-data PgRange (n :: *) a+data PgRange (n :: Type) a = PgEmptyRange | PgRange (PgRangeBound a) (PgRangeBound a)- deriving (Show, Generic)+ deriving (Eq, Show, Generic) instance Hashable a => Hashable (PgRangeBound a) @@ -703,9 +887,10 @@ fromField field d = if Pg.typeOid field /= Pg.typoid Pg.json then Pg.returnError Pg.Incompatible field ""- else case decodeStrict =<< d of- Just d' -> pure (PgJSON d')+ else case eitherDecodeStrict <$> d of Nothing -> Pg.returnError Pg.UnexpectedNull field ""+ Just (Left e) -> Pg.returnError Pg.ConversionFailed field e+ Just (Right d') -> pure (PgJSON d') instance (Typeable a, FromJSON a) => FromBackendRow Postgres (PgJSON a) instance ToJSON a => HasSqlValueSyntax PgValueSyntax (PgJSON a) where@@ -715,7 +900,7 @@ -- | The Postgres @JSONB@ type, which stores JSON-encoded data in a -- postgres-specific binary format. Like 'PgJSON', the type parameter indicates--- the Hgaskell type which the JSON encodes.+-- the Haskell type which the JSON encodes. -- -- Fields with this type are automatically given the Postgres @JSONB@ type newtype PgJSONB a = PgJSONB a@@ -728,9 +913,10 @@ fromField field d = if Pg.typeOid field /= Pg.typoid Pg.jsonb then Pg.returnError Pg.Incompatible field ""- else case decodeStrict =<< d of- Just d' -> pure (PgJSONB d')+ else case eitherDecodeStrict <$> d of Nothing -> Pg.returnError Pg.UnexpectedNull field ""+ Just (Left e) -> Pg.returnError Pg.ConversionFailed field e+ Just (Right d') -> pure (PgJSONB d') instance (Typeable a, FromJSON a) => FromBackendRow Postgres (PgJSONB a) instance ToJSON a => HasSqlValueSyntax PgValueSyntax (PgJSONB a) where@@ -763,7 +949,7 @@ -- section on -- <https://www.postgresql.org/docs/current/static/functions-json.html JSON>. ---class IsPgJSON (json :: * -> *) where+class IsPgJSON (json :: Type -> Type) where -- | The @json_each@ or @jsonb_each@ function. Values returned as @json@ or -- @jsonb@ respectively. Use 'pgUnnest' to join against the result pgJsonEach :: QGenExpr ctxt Postgres s (json a)@@ -867,10 +1053,10 @@ -- | Postgres @@>@ and @<@@ operators for JSON. Return true if the -- json object pointed to by the arrow is completely contained in the other. See -- the Postgres documentation for more in formation on what this means.-(@>), (<@) :: IsPgJSON json- => QGenExpr ctxt Postgres s (json a)- -> QGenExpr ctxt Postgres s (json b)- -> QGenExpr ctxt Postgres s Bool+(@>), (<@)+ :: QGenExpr ctxt Postgres s (PgJSONB a)+ -> QGenExpr ctxt Postgres s (PgJSONB b)+ -> QGenExpr ctxt Postgres s Bool QExpr a @> QExpr b = QExpr (pgBinOp "@>" <$> a <*> b) QExpr a <@ QExpr b =@@ -880,7 +1066,7 @@ -- See '(->$)' for the corresponding operator for object access. (->#) :: IsPgJSON json => QGenExpr ctxt Postgres s (json a)- -> QGenExpr ctxt Postgres s Int+ -> QGenExpr ctxt Postgres s Int32 -> QGenExpr ctxt Postgres s (json b) QExpr a -># QExpr b = QExpr (pgBinOp "->" <$> a <*> b)@@ -899,7 +1085,7 @@ -- corresponding operator on objects. (->>#) :: IsPgJSON json => QGenExpr ctxt Postgres s (json a)- -> QGenExpr ctxt Postgres s Int+ -> QGenExpr ctxt Postgres s Int32 -> QGenExpr ctxt Postgres s T.Text QExpr a ->># QExpr b = QExpr (pgBinOp "->>" <$> a <*> b)@@ -936,19 +1122,19 @@ -- | Postgres @?@ operator. Checks if the given string exists as top-level key -- of the json object.-(?) :: IsPgJSON json- => QGenExpr ctxt Postgres s (json a)- -> QGenExpr ctxt Postgres s T.Text- -> QGenExpr ctxt Postgres s Bool+(?)+ :: QGenExpr ctxt Postgres s (PgJSONB a)+ -> QGenExpr ctxt Postgres s T.Text+ -> QGenExpr ctxt Postgres s Bool QExpr a ? QExpr b = QExpr (pgBinOp "?" <$> a <*> b) -- | Postgres @?|@ and @?&@ operators. Check if any or all of the given strings -- exist as top-level keys of the json object respectively.-(?|), (?&) :: IsPgJSON json- => QGenExpr ctxt Postgres s (json a)- -> QGenExpr ctxt Postgres s (V.Vector T.Text)- -> QGenExpr ctxt Postgres s Bool+(?|), (?&)+ :: QGenExpr ctxt Postgres s (PgJSONB a)+ -> QGenExpr ctxt Postgres s (V.Vector T.Text)+ -> QGenExpr ctxt Postgres s Bool QExpr a ?| QExpr b = QExpr (pgBinOp "?|" <$> a <*> b) QExpr a ?& QExpr b =@@ -957,39 +1143,48 @@ -- | Postgres @-@ operator on json objects. Returns the supplied json object -- with the supplied key deleted. See 'withoutIdx' for the corresponding -- operator on arrays.-withoutKey :: IsPgJSON json- => QGenExpr ctxt Postgres s (json a)- -> QGenExpr ctxt Postgres s T.Text- -> QGenExpr ctxt Postgres s (json b)+withoutKey+ :: QGenExpr ctxt Postgres s (PgJSONB a)+ -> QGenExpr ctxt Postgres s T.Text+ -> QGenExpr ctxt Postgres s (PgJSONB b) QExpr a `withoutKey` QExpr b = QExpr (pgBinOp "-" <$> a <*> b) -- | Postgres @-@ operator on json arrays. See 'withoutKey' for the -- corresponding operator on objects.-withoutIdx :: IsPgJSON json- => QGenExpr ctxt Postgres s (json a)- -> QGenExpr ctxt Postgres s Int- -> QGenExpr ctxt Postgres s (json b)+withoutIdx+ :: QGenExpr ctxt Postgres s (PgJSONB a)+ -> QGenExpr ctxt Postgres s Int32+ -> QGenExpr ctxt Postgres s (PgJSONB b) QExpr a `withoutIdx` QExpr b = QExpr (pgBinOp "-" <$> a <*> b) -- | Postgres @#-@ operator. Removes all the keys specificied from the JSON -- object and returns the result.-withoutKeys :: IsPgJSON json- => QGenExpr ctxt Postgres s (json a)- -> QGenExpr ctxt Postgres s (V.Vector T.Text)- -> QGenExpr ctxt Postgres s (json b)+withoutKeys+ :: QGenExpr ctxt Postgres s (PgJSONB a)+ -> QGenExpr ctxt Postgres s (V.Vector T.Text)+ -> QGenExpr ctxt Postgres s (PgJSONB b) QExpr a `withoutKeys` QExpr b = QExpr (pgBinOp "#-" <$> a <*> b) -- | Postgres @json_array_length@ function. The supplied json object should be -- an array, but this isn't checked at compile-time. pgJsonArrayLength :: IsPgJSON json => QGenExpr ctxt Postgres s (json a)- -> QGenExpr ctxt Postgres s Int+ -> QGenExpr ctxt Postgres s Int32 pgJsonArrayLength (QExpr a) = QExpr $ \tbl -> PgExpressionSyntax (emit "json_array_length(" <> fromPgExpression (a tbl) <> emit ")") +-- | Postgres @array_to_json@ function.+pgArrayToJson+ :: QGenExpr ctxt Postgres s (V.Vector e)+ -> QGenExpr ctxt Postgres s (PgJSON a)+pgArrayToJson (QExpr a) = QExpr $ a <&> PgExpressionSyntax .+ mappend (emit "array_to_json") .+ pgParens .+ fromPgExpression+ -- | The postgres @jsonb_set@ function. 'pgJsonUpdate' expects the value -- specified by the path in the second argument to exist. If it does not, the -- first argument is not modified. 'pgJsonbSet' will create any intermediate@@ -1260,10 +1455,104 @@ <*> pgPointParser instance FromBackendRow Postgres PgBox +-- ** Regular expressions +-- | The type of Postgres regular expressions. Only a+-- 'HasSqlValueSyntax' instance is supplied, because you won't need to+-- be reading these back from the database.+--+-- If you're generating regexes dynamically, then use 'pgRegex_' to+-- convert a string expression into a regex one.+newtype PgRegex = PgRegex T.Text+ deriving (Show, Eq, Ord, IsString)++instance HasSqlValueSyntax PgValueSyntax PgRegex where+ sqlValueSyntax (PgRegex r) = sqlValueSyntax r++-- | Convert a string valued expression (which could be generated+-- dynamically) into a 'PgRegex'-typed one.+pgRegex_ :: BeamSqlBackendIsString Postgres text => QGenExpr ctxt Postgres s text -> QGenExpr ctxt Postgres s PgRegex+pgRegex_ (QExpr e) = QExpr e++-- | Match regular expression, case-sensitive+(~.) :: BeamSqlBackendIsString Postgres text+ => QGenExpr ctxt Postgres s text -> QGenExpr ctxt Postgres s PgRegex+ -> QGenExpr ctxt Postgres s Bool+QExpr t ~. QExpr re = QExpr (pgBinOp "~" <$> t <*> re)++-- | Match regular expression, case-insensitive+(~*.) :: BeamSqlBackendIsString Postgres text+ => QGenExpr ctxt Postgres s text -> QGenExpr ctxt Postgres s PgRegex+ -> QGenExpr ctxt Postgres s Bool+QExpr t ~*. QExpr re = QExpr (pgBinOp "~*" <$> t <*> re)++-- | Does not match regular expression, case-sensitive+(!~.) :: BeamSqlBackendIsString Postgres text+ => QGenExpr ctxt Postgres s text -> QGenExpr ctxt Postgres s PgRegex+ -> QGenExpr ctxt Postgres s Bool+QExpr t !~. QExpr re = QExpr (pgBinOp "!~" <$> t <*> re)++-- | Does not match regular expression, case-insensitive+(!~*.) :: BeamSqlBackendIsString Postgres text+ => QGenExpr ctxt Postgres s text -> QGenExpr ctxt Postgres s PgRegex+ -> QGenExpr ctxt Postgres s Bool+QExpr t !~*. QExpr re = QExpr (pgBinOp "!~*" <$> t <*> re)++-- | Postgres @regexp_replace@. Replaces all instances of the regex in+-- the first argument with the third argument. The fourth argument is+-- the postgres regex options to provide.+pgRegexpReplace_ :: BeamSqlBackendIsString Postgres text+ => QGenExpr ctxt Postgres s text -> QGenExpr ctxt Postgres s PgRegex+ -> QGenExpr ctxt Postgres s text -> QGenExpr ctxt Postgres s T.Text+ -> QGenExpr ctxt Postgres s txt+pgRegexpReplace_ (QExpr haystack) (QExpr needle) (QExpr replacement) (QExpr opts) =+ QExpr (\t -> PgExpressionSyntax $+ emit "regexp_replace(" <> fromPgExpression (haystack t) <> emit ", "+ <> fromPgExpression (needle t) <> emit ", "+ <> fromPgExpression (replacement t) <> emit ", "+ <> fromPgExpression (opts t) <> emit ")")++-- | Postgres @regexp_match@. Matches the regular expression against+-- the string given and returns an array where each element+-- corresponds to a match in the string, or @NULL@ if nothing was+-- found+pgRegexpMatch_ :: BeamSqlBackendIsString Postgres text+ => QGenExpr ctxt Postgres s text -> QGenExpr ctxt Postgres s PgRegex+ -> QGenExpr ctxt Postgres s (Maybe (V.Vector text))+pgRegexpMatch_ (QExpr s) (QExpr re) =+ QExpr (\t -> PgExpressionSyntax $+ emit "regexp_match(" <> fromPgExpression (s t) <> emit ", "+ <> fromPgExpression (re t) <> emit ")")++-- | Postgres @regexp_split_to_array@. Splits the given string by the+-- given regex and returns the result as an array.+pgRegexpSplitToArray :: BeamSqlBackendIsString Postgres text+ => QGenExpr ctxt Postgres s text -> QGenExpr ctxt Postgres s PgRegex+ -> QGenExpr ctxt Postgres s (V.Vector text)+pgRegexpSplitToArray (QExpr s) (QExpr re) =+ QExpr (\t -> PgExpressionSyntax $+ emit "regexp_split_to_array(" <> fromPgExpression (s t) <> emit ", "+ <> fromPgExpression (re t) <> emit ")")++newtype PgReResultT f+ = PgReResultT { reResult :: C f T.Text }+ deriving Generic+instance Beamable PgReResultT++-- | Postgres @regexp_split_to_table@. Splits the given string by the+-- given regex and return a result set that can be joined against.+pgRegexpSplitToTable :: BeamSqlBackendIsString Postgres text+ => QGenExpr ctxt Postgres s text -> QGenExpr ctxt Postgres s PgRegex++ -> Q Postgres db s (QExpr Postgres s T.Text)+pgRegexpSplitToTable (QExpr s) (QExpr re) =+ fmap reResult $+ pgUnnest' (\t -> emit "regexp_split_to_table(" <> fromPgExpression (s t) <> emit ", "+ <> fromPgExpression (re t) <> emit ")")+ -- ** Set-valued functions -data PgSetOf (tbl :: (* -> *) -> *)+data PgSetOf (tbl :: (Type -> Type) -> Type) pgUnnest' :: forall tbl db s . Beamable tbl@@ -1288,29 +1577,32 @@ pure (Columnar' (TableField (pure fieldNm) fieldNm))) tblSkeleton tblSkeleton) (0 :: Int) +-- | Join the results of the given set-valued function to the query pgUnnest :: forall tbl db s . Beamable tbl => QExpr Postgres s (PgSetOf tbl) -> Q Postgres db s (QExprTable Postgres s tbl)-pgUnnest (QExpr q) =- pgUnnest' (\t -> pgParens (fromPgExpression (q t)))+pgUnnest (QExpr q) = pgUnnest' $ fromPgExpression . q data PgUnnestArrayTbl a f = PgUnnestArrayTbl (C f a) deriving Generic instance Beamable (PgUnnestArrayTbl a) +-- | Introduce each element of the array as a row pgUnnestArray :: QExpr Postgres s (V.Vector a) -> Q Postgres db s (QExpr Postgres s a) pgUnnestArray (QExpr q) = fmap (\(PgUnnestArrayTbl x) -> x) $ pgUnnest' (\t -> emit "UNNEST" <> pgParens (fromPgExpression (q t))) -data PgUnnestArrayWithOrdinalityTbl a f = PgUnnestArrayWithOrdinalityTbl (C f Int) (C f a)+data PgUnnestArrayWithOrdinalityTbl a f = PgUnnestArrayWithOrdinalityTbl (C f Int64) (C f a) deriving Generic instance Beamable (PgUnnestArrayWithOrdinalityTbl a) +-- | Introduce each element of the array as a row, along with the+-- element's index pgUnnestArrayWithOrdinality :: QExpr Postgres s (V.Vector a)- -> Q Postgres db s (QExpr Postgres s Int, QExpr Postgres s a)+ -> Q Postgres db s (QExpr Postgres s Int64, QExpr Postgres s a) pgUnnestArrayWithOrdinality (QExpr q) = fmap (\(PgUnnestArrayWithOrdinalityTbl i x) -> (i, x)) $ pgUnnest' (\t -> emit "UNNEST" <> pgParens (fromPgExpression (q t)) <> emit " WITH ORDINALITY")@@ -1347,6 +1639,41 @@ defaultSqlDataType _ be embedded = pgUnboundedArrayType (defaultSqlDataType (Proxy :: Proxy a) be embedded) +-- ** Extract++century_ :: HasSqlDate tgt => ExtractField Postgres tgt Int32+century_ = ExtractField (PgExtractFieldSyntax (emit "CENTURY"))++decade_ :: HasSqlDate tgt => ExtractField Postgres tgt Int32+decade_ = ExtractField (PgExtractFieldSyntax (emit "DECADE"))++dow_ :: HasSqlDate tgt => ExtractField Postgres tgt Int32+dow_ = ExtractField (PgExtractFieldSyntax (emit "DOW"))++doy_ :: HasSqlDate tgt => ExtractField Postgres tgt Int32+doy_ = ExtractField (PgExtractFieldSyntax (emit "DOY"))++epoch_ :: HasSqlTime tgt => ExtractField Postgres tgt NominalDiffTime+epoch_ = ExtractField (PgExtractFieldSyntax (emit "EPOCH"))++isodow_ :: HasSqlDate tgt => ExtractField Postgres tgt Int32+isodow_ = ExtractField (PgExtractFieldSyntax (emit "ISODOW"))++isoyear_ :: HasSqlDate tgt => ExtractField Postgres tgt Int32+isoyear_ = ExtractField (PgExtractFieldSyntax (emit "ISOYEAR"))++microseconds_ :: HasSqlTime tgt => ExtractField Postgres tgt Int32+microseconds_ = ExtractField (PgExtractFieldSyntax (emit "MICROSECONDS"))++milliseconds_ :: HasSqlTime tgt => ExtractField Postgres tgt Int32+milliseconds_ = ExtractField (PgExtractFieldSyntax (emit "MILLISECONDS"))++millennium_ :: HasSqlDate tgt => ExtractField Postgres tgt Int32+millennium_ = ExtractField (PgExtractFieldSyntax (emit "MILLENNIUM"))++quarter_ :: HasSqlDate tgt => ExtractField Postgres tgt Int32+quarter_ = ExtractField (PgExtractFieldSyntax (emit "QUARTER"))+ -- $full-text-search -- -- Postgres has comprehensive, and thus complicated, support for full text@@ -1406,7 +1733,7 @@ -- know the shape of the data stored, substitute 'Value' for this type -- parameter. ----- For more information on Psotgres json support see the postgres+-- For more information on Postgres JSON support see the postgres -- <https://www.postgresql.org/docs/current/static/functions-json.html manual>. @@ -1434,4 +1761,3 @@ -- 'pgUnnestArrayWithOrdinality' function allows you to join against the -- elements of an array along with its index. This corresponds to the -- @UNNEST .. WITH ORDINALITY@ clause.-
Database/Beam/Postgres/Syntax.hs view
@@ -11,6 +11,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE CPP #-}+{-# LANGUAGE UndecidableInstances #-} -- | Data types for Postgres syntax. Access is given mainly for extension -- modules. The types and definitions here are likely to change.@@ -20,8 +21,8 @@ , emit, emitBuilder, escapeString , escapeBytea, escapeIdentifier- , pgParens-+ , pgParens, PgCteRecursiveness(..), pgWithSyntax+ , pgStringLit, pgCharLit, pgBoolLit , nextSyntaxStep , PgCommandSyntax(..), PgCommandType(..)@@ -29,6 +30,7 @@ , PgInsertSyntax(..) , PgDeleteSyntax(..) , PgUpdateSyntax(..)+ , PgCommonTableExpressionSyntax(..) , PgExpressionSyntax(..), PgFromSyntax(..), PgTableNameSyntax(..) , PgComparisonQuantifierSyntax(..)@@ -45,6 +47,7 @@ , PgAlterTableSyntax(..), PgAlterTableActionSyntax(..), PgAlterColumnActionSyntax(..) + , PgWindowFrameSyntax(..), PgWindowFrameBoundsSyntax(..), PgWindowFrameBoundSyntax(..) , PgSelectLockingClauseSyntax(..)@@ -57,6 +60,8 @@ , PgDataTypeDescr(..) , PgHasEnum(..) + , PgIndexOptions(..)+ , pgCreateExtensionSyntax, pgDropExtensionSyntax , pgCreateEnumSyntax, pgDropTypeSyntax @@ -86,9 +91,9 @@ , PostgresInaccessible ) where import Database.Beam hiding (insert)+import Database.Beam.Backend.Internal.Compat import Database.Beam.Backend.SQL import Database.Beam.Migrate-import Database.Beam.Migrate.Checks (HasDataTypeCreatedCheck(..)) import Database.Beam.Migrate.SQL.Builder hiding (fromSqlConstraintAttributes) import Database.Beam.Migrate.Serialization @@ -96,10 +101,10 @@ import Control.Monad.Free import Control.Monad.Free.Church -import Data.Aeson (Value, object, (.=))+import Data.Aeson (Value, object, withObject, (.=), (.:)) import Data.Bits import Data.ByteString (ByteString)-import Data.ByteString.Builder (Builder, byteString, char8, toLazyByteString)+import Data.ByteString.Builder (Builder, doubleDec, floatDec, byteString, char8, toLazyByteString) import qualified Data.ByteString.Char8 as B import Data.ByteString.Lazy.Char8 (toStrict) import qualified Data.ByteString.Lazy.Char8 as BL@@ -109,25 +114,26 @@ import Data.Functor.Classes import Data.Hashable import Data.Int+import qualified Data.List.NonEmpty as NE (toList) import Data.Maybe-#if !MIN_VERSION_base(4, 11, 0)-import Data.Semigroup-#endif import Data.Scientific (Scientific) import Data.String (IsString(..), fromString) import qualified Data.Text as T import qualified Data.Text.Encoding as TE import qualified Data.Text.Lazy as TL import Data.Time (LocalTime, UTCTime, TimeOfDay, NominalDiffTime, Day)-import Data.UUID.Types (UUID)+import Data.UUID.Types (UUID, toASCIIBytes) import Data.Word import qualified Data.Vector as V+import GHC.TypeLits import qualified Database.PostgreSQL.Simple.ToField as Pg import qualified Database.PostgreSQL.Simple.TypeInfo.Static as Pg 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 @@ -249,6 +255,7 @@ newtype PgAggregationSetQuantifierSyntax = PgAggregationSetQuantifierSyntax { fromPgAggregationSetQuantifier :: PgSyntax } newtype PgSelectSetQuantifierSyntax = PgSelectSetQuantifierSyntax { fromPgSelectSetQuantifier :: PgSyntax } newtype PgFromSyntax = PgFromSyntax { fromPgFrom :: PgSyntax }+newtype PgSchemaNameSyntax = PgSchemaNameSyntax { fromPgSchemaName :: PgSyntax } newtype PgTableNameSyntax = PgTableNameSyntax { fromPgTableName :: PgSyntax } newtype PgComparisonQuantifierSyntax = PgComparisonQuantifierSyntax { fromPgComparisonQuantifier :: PgSyntax } newtype PgExtractFieldSyntax = PgExtractFieldSyntax { fromPgExtractField :: PgSyntax }@@ -266,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"@@ -333,6 +385,9 @@ hashWithSalt salt (PgDataTypeDescrDomain t) = hashWithSalt salt (1 :: Int, t) +newtype PgCreateSchemaSyntax = PgCreateSchemaSyntax { fromPgCreateSchema :: PgSyntax }+newtype PgDropSchemaSyntax = PgDropSchemaSyntax { fromPgDropSchema :: PgSyntax }+ newtype PgCreateTableSyntax = PgCreateTableSyntax { fromPgCreateTable :: PgSyntax } data PgTableOptionsSyntax = PgTableOptionsSyntax PgSyntax PgSyntax newtype PgColumnSchemaSyntax = PgColumnSchemaSyntax { fromPgColumnSchema :: PgSyntax } deriving (Show, Eq)@@ -408,6 +463,13 @@ deleteCmd = PgCommandSyntax PgCommandTypeDataUpdate . coerce updateCmd = PgCommandSyntax PgCommandTypeDataUpdate . coerce +instance IsSql92DdlSchemaCommandSyntax PgCommandSyntax where+ type Sql92DdlCommandCreateSchemaSyntax PgCommandSyntax = PgCreateSchemaSyntax+ type Sql92DdlCommandDropSchemaSyntax PgCommandSyntax = PgDropSchemaSyntax++ createSchemaCmd = PgCommandSyntax PgCommandTypeDdl . coerce+ dropSchemaCmd = PgCommandSyntax PgCommandTypeDdl . coerce+ instance IsSql92DdlCommandSyntax PgCommandSyntax where type Sql92DdlCommandCreateTableSyntax PgCommandSyntax = PgCreateTableSyntax type Sql92DdlCommandDropTableSyntax PgCommandSyntax = PgDropTableSyntax@@ -417,6 +479,38 @@ dropTableCmd = PgCommandSyntax PgCommandTypeDdl . coerce alterTableCmd = PgCommandSyntax PgCommandTypeDdl . coerce +newtype PgIndexOptions = PgIndexOptions { pgIndexUnique :: Bool }+ deriving (Show, Eq, Hashable)++instance IsSql92CreateDropIndexSyntax PgCommandSyntax where+ type instance Sql92CreateIndexOptionsSyntax PgCommandSyntax = PgIndexOptions++ defaultIndexOptions = PgIndexOptions { pgIndexUnique = False }++ createIndexCmd idxNm tblNm cols opts =+ PgCommandSyntax PgCommandTypeDdl $+ emit (if pgIndexUnique opts then "CREATE UNIQUE INDEX " else "CREATE INDEX ") <>+ pgQuotedIdentifier idxNm <>+ emit " ON " <> fromPgTableName tblNm <>+ pgParens (pgSepBy (emit ", ") (NE.toList $ fmap pgQuotedIdentifier cols))++ dropIndexCmd idxNm =+ PgCommandSyntax PgCommandTypeDdl (emit "DROP INDEX " <> pgQuotedIdentifier idxNm)++ serializeIndexOptions opts =+ object ["unique" .= pgIndexUnique opts]++ deserializeIndexOptions =+ withObject "PgIndexOptions" $ \v ->+ PgIndexOptions <$> v .: "unique"++instance IsSql92UniqueIndexSyntax PgCommandSyntax where+ setUniqueIndexOptions u opts = opts { pgIndexUnique = u }+ indexIsUnique opts = pgIndexUnique opts++instance IsSql92SchemaNameSyntax PgSchemaNameSyntax where+ schemaName s = PgSchemaNameSyntax (pgQuotedIdentifier s)+ instance IsSql92TableNameSyntax PgTableNameSyntax where tableName Nothing t = PgTableNameSyntax (pgQuotedIdentifier t) tableName (Just s) t = PgTableNameSyntax (pgQuotedIdentifier s <> emit "." <> pgQuotedIdentifier t)@@ -541,7 +635,7 @@ (emit "NUMERIC" <> pgOptNumericPrec prec) (numericType prec) decimalType prec = PgDataTypeSyntax (PgDataTypeDescrOid (Pg.typoid Pg.numeric) (mkNumericPrec prec))- (emit "DOUBLE" <> pgOptNumericPrec prec)+ (emit "DECIMAL" <> pgOptNumericPrec prec) (decimalType prec) intType = PgDataTypeSyntax (PgDataTypeDescrOid (Pg.typoid Pg.int4) Nothing) (emit "INT") intType@@ -564,8 +658,8 @@ binaryLargeObjectType = pgByteaType { pgDataTypeSerialized = binaryLargeObjectType } booleanType = PgDataTypeSyntax (PgDataTypeDescrOid (Pg.typoid Pg.bool) Nothing) (emit "BOOLEAN") booleanType- arrayType (PgDataTypeSyntax _ syntax serialized) sz =- PgDataTypeSyntax (error "TODO: array migrations")+ arrayType (PgDataTypeSyntax descr syntax serialized) sz =+ PgDataTypeSyntax (PgDataTypeDescrOid (fromMaybe (error "Unsupported array type") (arrayTypeDescr descr)) Nothing) (syntax <> emit "[" <> emit (fromString (show sz)) <> emit "]") (arrayType serialized sz) rowType = error "rowType"@@ -574,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@@ -631,12 +727,73 @@ pgLineSegmentType = PgDataTypeSyntax (PgDataTypeDescrOid (Pg.typoid Pg.lseg) Nothing) (emit "LSEG") (pgDataTypeJSON "lseg") pgBoxType = PgDataTypeSyntax (PgDataTypeDescrOid (Pg.typoid Pg.box) Nothing) (emit "BOX") (pgDataTypeJSON "box") +-- TODO: better mechanism to tell, at compile time, that some type+-- cannot be placed in an array pgUnboundedArrayType :: PgDataTypeSyntax -> PgDataTypeSyntax-pgUnboundedArrayType (PgDataTypeSyntax _ syntax serialized) =- PgDataTypeSyntax (error "Can't do array migrations yet")+pgUnboundedArrayType (PgDataTypeSyntax descr syntax serialized) =+ PgDataTypeSyntax (PgDataTypeDescrOid (fromMaybe (error "Unsupported array type") (arrayTypeDescr descr)) Nothing) (syntax <> emit "[]") (pgDataTypeJSON (object [ "unbounded-array" .= fromBeamSerializedDataType serialized ])) +-- TODO: define CPP macro to make sure the left hand side (e.g. `Pg.recordOid`) +-- always matches right hand side (e.g. `Pg.array_recordOid)++-- | Get the Oid of Pg arrays which contains elements of a certain type+arrayTypeDescr :: PgDataTypeDescr -> Maybe Pg.Oid+arrayTypeDescr (PgDataTypeDescrDomain _) = Nothing+arrayTypeDescr (PgDataTypeDescrOid elemOid _)+ | elemOid == Pg.recordOid = Just $ Pg.array_recordOid+ | elemOid == Pg.xmlOid = Just $ Pg.array_xmlOid+ | elemOid == Pg.jsonOid = Just $ Pg.array_jsonOid+ | elemOid == Pg.lineOid = Just $ Pg.array_lineOid+ | elemOid == Pg.cidrOid = Just $ Pg.array_cidOid+ | elemOid == Pg.circleOid = Just $ Pg.array_circleOid+ | elemOid == Pg.moneyOid = Just $ Pg.array_moneyOid+ | elemOid == Pg.boolOid = Just $ Pg.array_boolOid+ | elemOid == Pg.byteaOid = Just $ Pg.array_byteaOid+ | elemOid == Pg.charOid = Just $ Pg.array_charOid+ | elemOid == Pg.nameOid = Just $ Pg.array_nameOid+ | elemOid == Pg.int2Oid = Just $ Pg.array_int2Oid+ | elemOid == Pg.int2vectorOid = Just $ Pg.array_int2vectorOid+ | elemOid == Pg.int4Oid = Just $ Pg.array_int4Oid+ | elemOid == Pg.regprocOid = Just $ Pg.array_regprocOid+ | elemOid == Pg.textOid = Just $ Pg.array_textOid+ | elemOid == Pg.tidOid = Just $ Pg.array_tidOid+ | elemOid == Pg.xidOid = Just $ Pg.array_xidOid+ | elemOid == Pg.cidOid = Just $ Pg.array_cidOid+ | elemOid == Pg.bpcharOid = Just $ Pg.array_bpcharOid+ | elemOid == Pg.varcharOid = Just $ Pg.array_varcharOid+ | elemOid == Pg.int8Oid = Just $ Pg.array_int8Oid+ | elemOid == Pg.pointOid = Just $ Pg.array_pointOid+ | elemOid == Pg.lsegOid = Just $ Pg.array_lsegOid+ | elemOid == Pg.pathOid = Just $ Pg.array_pathOid+ | elemOid == Pg.boxOid = Just $ Pg.array_boxOid+ | elemOid == Pg.float4Oid = Just $ Pg.array_float4Oid+ | elemOid == Pg.float8Oid = Just $ Pg.array_float8Oid+ | elemOid == Pg.polygonOid = Just $ Pg.array_polygonOid+ | elemOid == Pg.oidOid = Just $ Pg.array_oidOid+ | elemOid == Pg.macaddrOid = Just $ Pg.array_macaddrOid+ | elemOid == Pg.inetOid = Just $ Pg.array_inetOid+ | elemOid == Pg.timestampOid = Just $ Pg.array_timestampOid+ | elemOid == Pg.dateOid = Just $ Pg.array_dateOid+ | elemOid == Pg.timeOid = Just $ Pg.array_timeOid+ | elemOid == Pg.timestamptzOid = Just $ Pg.array_timestamptzOid+ | elemOid == Pg.intervalOid = Just $ Pg.array_intervalOid+ | elemOid == Pg.numericOid = Just $ Pg.array_numericOid+ | elemOid == Pg.timetzOid = Just $ Pg.array_timetzOid+ | elemOid == Pg.bitOid = Just $ Pg.array_bitOid+ | elemOid == Pg.varbitOid = Just $ Pg.array_varbitOid+ | elemOid == Pg.refcursorOid = Just $ Pg.array_refcursorOid+ | elemOid == Pg.regprocedureOid = Just $ Pg.array_regprocedureOid+ | elemOid == Pg.regoperOid = Just $ Pg.array_regoperOid+ | elemOid == Pg.regoperatorOid = Just $ Pg.array_regoperatorOid+ | elemOid == Pg.regclassOid = Just $ Pg.array_regclassOid+ | elemOid == Pg.regtypeOid = Just $ Pg.array_regtypeOid+ | elemOid == Pg.uuidOid = Just $ Pg.array_uuidOid+ | elemOid == Pg.jsonbOid = Just $ Pg.array_jsonbOid+ | otherwise = Nothing++ pgTsQueryTypeInfo :: Pg.TypeInfo pgTsQueryTypeInfo = Pg.Basic (Pg.Oid 3615) 'U' ',' "tsquery" @@ -675,13 +832,10 @@ instance IsCustomSqlSyntax PgExpressionSyntax where newtype CustomSqlSyntax PgExpressionSyntax = PgCustomExpressionSyntax { fromPgCustomExpression :: PgSyntax }- deriving Monoid+ deriving (Semigroup, Monoid) customExprSyntax = PgExpressionSyntax . fromPgCustomExpression renderSyntax = PgCustomExpressionSyntax . pgParens . fromPgExpression -instance Semigroup (CustomSqlSyntax PgExpressionSyntax) where- (<>) = mappend- instance IsString (CustomSqlSyntax PgExpressionSyntax) where fromString = PgCustomExpressionSyntax . emit . fromString @@ -694,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") @@ -772,6 +927,8 @@ inE e es = PgExpressionSyntax $ pgParens (fromPgExpression e) <> emit " IN " <> pgParens (pgSepBy (emit ", ") (map fromPgExpression es))+ inSelectE e sel = PgExpressionSyntax $ pgParens (fromPgExpression e) <> emit " IN " <>+ pgParens (fromPgSelect sel) instance IsSql99FunctionExpressionSyntax PgExpressionSyntax where functionCallE name args =@@ -919,8 +1076,8 @@ -- According to the note at <https://www.postgresql.org/docs/9.2/static/functions-aggregate.html> -- the following functions are equivalent.- someE = pgUnAgg "BOOL_ANY"- anyE = pgUnAgg "BOOL_ANY"+ someE = pgUnAgg "BOOL_OR"+ anyE = pgUnAgg "BOOL_OR" instance IsSql92AggregationSetQuantifierSyntax PgAggregationSetQuantifierSyntax where setQuantifierDistinct = PgAggregationSetQuantifierSyntax $ emit "DISTINCT"@@ -1040,6 +1197,18 @@ setNullSyntax = PgAlterColumnActionSyntax (emit "DROP NOT NULL") setNotNullSyntax = PgAlterColumnActionSyntax (emit "SET NOT NULL") +instance IsSql92SchemaNameSyntax PgSchemaNameSyntax => IsSql92CreateSchemaSyntax PgCreateSchemaSyntax where+ type Sql92CreateSchemaSchemaNameSyntax PgCreateSchemaSyntax = PgSchemaNameSyntax++ createSchemaSyntax schemaName = PgCreateSchemaSyntax $+ emit "CREATE SCHEMA " <> fromPgSchemaName schemaName++instance IsSql92SchemaNameSyntax PgSchemaNameSyntax => IsSql92DropSchemaSyntax PgDropSchemaSyntax where+ type Sql92DropSchemaSchemaNameSyntax PgDropSchemaSyntax = PgSchemaNameSyntax++ dropSchemaSyntax schemaName = PgDropSchemaSyntax $+ emit "DROP SCHEMA " <> fromPgSchemaName schemaName+ instance IsSql92CreateTableSyntax PgCreateTableSyntax where type Sql92CreateTableTableNameSyntax PgCreateTableSyntax = PgTableNameSyntax type Sql92CreateTableColumnSchemaSyntax PgCreateTableSyntax = PgColumnSchemaSyntax@@ -1061,10 +1230,24 @@ map fromPgTableConstraint constraints) <> emit ")" <> afterOptions +pgForeignKeyAction :: ForeignKeyAction -> PgSyntax+pgForeignKeyAction ForeignKeyActionCascade = emit "CASCADE"+pgForeignKeyAction ForeignKeyActionSetNull = emit "SET NULL"+pgForeignKeyAction ForeignKeyActionSetDefault = emit "SET DEFAULT"+pgForeignKeyAction ForeignKeyActionRestrict = emit "RESTRICT"+pgForeignKeyAction ForeignKeyNoAction = emit "NO ACTION"+ instance IsSql92TableConstraintSyntax PgTableConstraintSyntax where primaryKeyConstraintSyntax fieldNames = PgTableConstraintSyntax $- emit "PRIMARY KEY(" <> pgSepBy (emit ", ") (map pgQuotedIdentifier fieldNames) <> emit ")"+ emit "PRIMARY KEY(" <> pgSepBy (emit ", ") (map pgQuotedIdentifier $ NE.toList fieldNames) <> emit ")"+ foreignKeyConstraintSyntax localCols refTbl refCols onUpdate onDelete =+ PgTableConstraintSyntax $+ emit "FOREIGN KEY(" <> pgSepBy (emit ", ") (map pgQuotedIdentifier $ NE.toList localCols) <> emit ")" <>+ emit " REFERENCES " <> pgQuotedIdentifier refTbl <>+ emit "(" <> pgSepBy (emit ", ") (map pgQuotedIdentifier $ NE.toList refCols) <> emit ")" <>+ emit " ON UPDATE " <> pgForeignKeyAction onUpdate <>+ emit " ON DELETE " <> pgForeignKeyAction onDelete instance Hashable PgColumnSchemaSyntax where hashWithSalt salt = hashWithSalt salt . fromPgColumnSchema@@ -1175,15 +1358,11 @@ sqlValueSyntax = defaultPgValueSyntax DEFAULT_SQL_SYNTAX(Bool)-DEFAULT_SQL_SYNTAX(Double)-DEFAULT_SQL_SYNTAX(Float)-DEFAULT_SQL_SYNTAX(Int) DEFAULT_SQL_SYNTAX(Int8) DEFAULT_SQL_SYNTAX(Int16) DEFAULT_SQL_SYNTAX(Int32) DEFAULT_SQL_SYNTAX(Int64) DEFAULT_SQL_SYNTAX(Integer)-DEFAULT_SQL_SYNTAX(Word) DEFAULT_SQL_SYNTAX(Word8) DEFAULT_SQL_SYNTAX(Word16) DEFAULT_SQL_SYNTAX(Word32)@@ -1197,7 +1376,6 @@ DEFAULT_SQL_SYNTAX(TimeOfDay) DEFAULT_SQL_SYNTAX(NominalDiffTime) DEFAULT_SQL_SYNTAX(Day)-DEFAULT_SQL_SYNTAX(UUID) DEFAULT_SQL_SYNTAX([Char]) DEFAULT_SQL_SYNTAX(Pg.HStoreMap) DEFAULT_SQL_SYNTAX(Pg.HStoreList)@@ -1207,6 +1385,21 @@ DEFAULT_SQL_SYNTAX(Pg.UTCTimestamp) DEFAULT_SQL_SYNTAX(Scientific) +-- We have a 'manual' instance for Double and Float because the default value of a+-- literal like "1.0" is NUMERIC, not DOUBLE. However, NUMERIC values are exact, +-- while DOUBLEs are inexact. This means that converting from SQL NUMERIC+-- to Haskell Double is lossy.+-- See #700+instance HasSqlValueSyntax PgValueSyntax Float where+ sqlValueSyntax v + | isNaN v || isInfinite v = PgValueSyntax $ emit "'" <> emitBuilder (floatDec v) <> emit "'"+ | otherwise = PgValueSyntax $ emit "'" <> emitBuilder (floatDec v) <> emit "'::double precision"++instance HasSqlValueSyntax PgValueSyntax Double where+ sqlValueSyntax v + | isNaN v || isInfinite v = PgValueSyntax $ emit "'" <> emitBuilder (doubleDec v) <> emit "'"+ | otherwise = PgValueSyntax $ emit "'" <> emitBuilder (doubleDec v) <> emit "'::double precision"+ instance HasSqlValueSyntax PgValueSyntax (CI T.Text) where sqlValueSyntax = sqlValueSyntax . CI.original instance HasSqlValueSyntax PgValueSyntax (CI TL.Text) where@@ -1225,9 +1418,21 @@ instance HasSqlValueSyntax PgValueSyntax BL.ByteString where sqlValueSyntax = defaultPgValueSyntax . Pg.Binary +-- This should be removed in favor of the default syntax if/when+-- https://github.com/lpsmith/postgresql-simple/issues/277 is fixed upstream.+instance HasSqlValueSyntax PgValueSyntax UUID where+ sqlValueSyntax v = PgValueSyntax $+ emit "'" <> emit (toASCIIBytes v) <> emit "'::uuid"+ instance Pg.ToField a => HasSqlValueSyntax PgValueSyntax (V.Vector a) where sqlValueSyntax = defaultPgValueSyntax +instance TypeError (PreferExplicitSize Int Int32) => HasSqlValueSyntax PgValueSyntax Int where+ sqlValueSyntax = defaultPgValueSyntax++instance TypeError (PreferExplicitSize Word Word32) => HasSqlValueSyntax PgValueSyntax Word where+ sqlValueSyntax = defaultPgValueSyntax+ pgQuotedIdentifier :: T.Text -> PgSyntax pgQuotedIdentifier t = escapeIdentifier (TE.encodeUtf8 t)@@ -1235,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 =@@ -1409,4 +1635,3 @@ where quoteIdentifierChar '"' = char8 '"' <> char8 '"' quoteIdentifierChar c = char8 c-
+ Database/Beam/Postgres/TempTable.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE ConstraintKinds #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}++module Database.Beam.Postgres.TempTable+ ( -- * Temporary tables++ -- ** @CREATE TEMPORARY TABLE@+ runCreateTempTable++ -- ** Options+ , TempTableCreateMode(..)+ , TempTableOptions(..)+ , defaultTempTableOptions++ -- ** Schema constraint+ , HasDefaultPostgresTempTableSchema++ ) where++import Database.Beam.Migrate.TempTable+ ( BeamHasTempTables(..)+ , HasDefaultTempTableSchema+ , TempTableCreateMode(..)+ , TempTableOptions(..)+ , defaultTempTableOptions+ , runCreateTempTable+ )+import Database.Beam.Postgres.Types (Postgres)+import Database.Beam.Postgres.Syntax+ ( PgCommandSyntax(..), PgCommandType(..)+ , fromPgColumnSchema+ , emit, pgQuotedIdentifier, pgSepBy, pgParens+ )++--------------------------------------------------------------------------------++-- | Tables for which @CREATE TEMPORARY TABLE@ statements can be emitted+-- automatically.+type HasDefaultPostgresTempTableSchema tbl = HasDefaultTempTableSchema Postgres tbl++instance BeamHasTempTables Postgres where+ createTempTableCmd nm colDefs pkCols ifNotExists =+ PgCommandSyntax PgCommandTypeDdl $+ emit "CREATE TEMPORARY TABLE "+ <> (if ifNotExists then emit "IF NOT EXISTS " else mempty)+ <> pgQuotedIdentifier nm+ <> pgParens (pgSepBy (emit ", ") (colDefPieces ++ pkPiece))+ where+ colDefPieces =+ map (\(n, s) -> pgQuotedIdentifier n <> emit " " <> fromPgColumnSchema s)+ colDefs++ pkPiece+ | null pkCols = []+ | otherwise =+ [ emit "PRIMARY KEY "+ <> pgParens (pgSepBy (emit ", ") (map pgQuotedIdentifier pkCols)) ]++ dropTempTableIfExistsCmd nm =+ PgCommandSyntax PgCommandTypeDdl $+ emit "DROP TABLE IF EXISTS " <> pgQuotedIdentifier nm
Database/Beam/Postgres/Types.hs view
@@ -1,19 +1,35 @@ {-# OPTIONS_GHC -fno-warn-orphans #-}-+{-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-} module Database.Beam.Postgres.Types- ( Postgres(..) ) where+ ( Postgres(..)+ , fromPgIntegral+ , fromPgScientificOrIntegral+ ) where 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 @@ -28,6 +44,7 @@ import qualified Data.ByteString.Lazy as BL import Data.CaseInsensitive (CI) import Data.Int+import Data.Proxy import Data.Ratio (Ratio) import Data.Scientific (Scientific, toBoundedInteger) import Data.Tagged@@ -37,11 +54,12 @@ import Data.UUID.Types (UUID) import Data.Vector (Vector) import Data.Word+import GHC.TypeLits -- | The Postgres backend type, used to parameterize 'MonadBeam'. See the -- definitions there for more information. The corresponding query monad is -- 'Pg'. See documentation for 'MonadBeam' and the--- <https://tathougies.github/beam/ user guide> for more information on using+-- <https://haskell-beam.github/beam/ user guide> for more information on using -- this backend. data Postgres = Postgres@@ -49,11 +67,16 @@ instance BeamBackend Postgres where type BackendFromField Postgres = Pg.FromField +instance HasSqlInTable Postgres where+ instance Pg.FromField SqlNull where fromField field d = fmap (\Pg.Null -> SqlNull) (Pg.fromField field d) -fromScientificOrIntegral :: (Bounded a, Integral a) => FromBackendRowM Postgres a-fromScientificOrIntegral = do+-- | Deserialize integral fields, possibly downcasting from a larger numeric type+-- via 'Scientific' if we won't lose data, and then falling back to any integral+-- type via 'Integer'+fromPgScientificOrIntegral :: (Bounded a, Integral a) => FromBackendRowM Postgres a+fromPgScientificOrIntegral = do sciVal <- fmap (toBoundedInteger =<<) peekField case sciVal of Just sciVal' -> do@@ -83,24 +106,28 @@ instance FromBackendRow Postgres Bool instance FromBackendRow Postgres Char instance FromBackendRow Postgres Double-instance FromBackendRow Postgres Int where- fromBackendRow = fromPgIntegral instance FromBackendRow Postgres Int16 where fromBackendRow = fromPgIntegral instance FromBackendRow Postgres Int32 where fromBackendRow = fromPgIntegral instance FromBackendRow Postgres Int64 where fromBackendRow = fromPgIntegral++instance TypeError (PreferExplicitSize Int Int32) => FromBackendRow Postgres Int where+ fromBackendRow = fromPgIntegral+ -- Word values are serialized as SQL @NUMBER@ types to guarantee full domain coverage.--- However, we wan them te be serialized/deserialized as whichever type makes sense-instance FromBackendRow Postgres Word where- fromBackendRow = fromScientificOrIntegral+-- However, we want them te be serialized/deserialized as whichever type makes sense instance FromBackendRow Postgres Word16 where- fromBackendRow = fromScientificOrIntegral+ fromBackendRow = fromPgScientificOrIntegral instance FromBackendRow Postgres Word32 where- fromBackendRow = fromScientificOrIntegral+ fromBackendRow = fromPgScientificOrIntegral instance FromBackendRow Postgres Word64 where- fromBackendRow = fromScientificOrIntegral+ fromBackendRow = fromPgScientificOrIntegral++instance TypeError (PreferExplicitSize Word Word32) => FromBackendRow Postgres Word where+ fromBackendRow = fromPgScientificOrIntegral+ instance FromBackendRow Postgres Integer instance FromBackendRow Postgres ByteString instance FromBackendRow Postgres Scientific@@ -138,12 +165,7 @@ instance FromBackendRow Postgres (Ratio Integer) instance FromBackendRow Postgres (CI Text) instance FromBackendRow Postgres (CI TL.Text)-instance (Pg.FromField a, Typeable a) => FromBackendRow Postgres (Vector a) where- fromBackendRow = do- isNull <- peekField- case isNull of- Just SqlNull -> pure mempty- Nothing -> parseOneField @Postgres @(Vector a)+instance (Pg.FromField a, Typeable a) => FromBackendRow Postgres (Vector a) instance (Pg.FromField a, Typeable a) => FromBackendRow Postgres (Pg.PGArray a) instance FromBackendRow Postgres (Pg.Binary ByteString) instance FromBackendRow Postgres (Pg.Binary BL.ByteString)@@ -154,9 +176,21 @@ 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 @@ -168,10 +202,24 @@ instance HasDefaultSqlDataType Postgres LocalTime where defaultSqlDataType _ _ _ = timestampType Nothing False -instance HasDefaultSqlDataType Postgres (SqlSerial Int) where+instance HasDefaultSqlDataType Postgres UTCTime where+ defaultSqlDataType _ _ _ = timestampType Nothing True++instance HasDefaultSqlDataType Postgres (SqlSerial Int16) where+ defaultSqlDataType _ _ False = pgSmallSerialType+ defaultSqlDataType _ _ _ = smallIntType++instance HasDefaultSqlDataType Postgres (SqlSerial Int32) where defaultSqlDataType _ _ False = pgSerialType defaultSqlDataType _ _ _ = intType +instance HasDefaultSqlDataType Postgres (SqlSerial Int64) where+ defaultSqlDataType _ _ False = pgBigSerialType+ defaultSqlDataType _ _ _ = bigIntType++instance TypeError (PreferExplicitSize Int Int32) => HasDefaultSqlDataType Postgres (SqlSerial Int) where+ defaultSqlDataType _ = defaultSqlDataType (Proxy @(SqlSerial Int32))+ instance HasDefaultSqlDataType Postgres UUID where defaultSqlDataType _ _ _ = pgUuidType @@ -184,13 +232,11 @@ PG_HAS_EQUALITY_CHECK(Bool) PG_HAS_EQUALITY_CHECK(Double) PG_HAS_EQUALITY_CHECK(Float)-PG_HAS_EQUALITY_CHECK(Int) PG_HAS_EQUALITY_CHECK(Int8) PG_HAS_EQUALITY_CHECK(Int16) PG_HAS_EQUALITY_CHECK(Int32) PG_HAS_EQUALITY_CHECK(Int64) PG_HAS_EQUALITY_CHECK(Integer)-PG_HAS_EQUALITY_CHECK(Word) PG_HAS_EQUALITY_CHECK(Word8) PG_HAS_EQUALITY_CHECK(Word16) PG_HAS_EQUALITY_CHECK(Word32)@@ -219,6 +265,11 @@ PG_HAS_EQUALITY_CHECK(Vector a) PG_HAS_EQUALITY_CHECK(CI Text) PG_HAS_EQUALITY_CHECK(CI TL.Text)++instance TypeError (PreferExplicitSize Int Int32) => HasSqlEqualityCheck Postgres Int+instance TypeError (PreferExplicitSize Int Int32) => HasSqlQuantifiedEqualityCheck Postgres Int+instance TypeError (PreferExplicitSize Word Word32) => HasSqlEqualityCheck Postgres Word+instance TypeError (PreferExplicitSize Word Word32) => HasSqlQuantifiedEqualityCheck Postgres Word instance HasSqlEqualityCheck Postgres a => HasSqlEqualityCheck Postgres (Tagged t a)
beam-postgres.cabal view
@@ -1,8 +1,8 @@ name: beam-postgres-version: 0.4.0.0+version: 0.6.3.0 synopsis: Connection layer between beam and postgres description: Beam driver for <https://www.postgresql.org/ PostgreSQL>, an advanced open-source RDBMS-homepage: http://tathougies.github.io/beam/user-guide/backends/beam-postgres+homepage: https://haskell-beam.github.io/beam/user-guide/backends/beam-postgres license: MIT license-file: LICENSE author: Travis Athougies@@ -11,71 +11,102 @@ build-type: Simple cabal-version: 1.18 extra-doc-files: ChangeLog.md-bug-reports: https://github.com/tathougies/beam/issues+bug-reports: https://github.com/haskell-beam/beam/issues library exposed-modules: Database.Beam.Postgres Database.Beam.Postgres.Migrate- Database.Beam.Postgres.PgCrypto Database.Beam.Postgres.Syntax Database.Beam.Postgres.CustomTypes Database.Beam.Postgres.Conduit 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.Copy.File+ Database.Beam.Postgres.Extensions.Copy.Stream Database.Beam.Postgres.PgSpecific Database.Beam.Postgres.Types - build-depends: base >=4.7 && <5.0,- beam-core >=0.8 && <0.9,- beam-migrate >=0.4 && <0.5,+ build-depends: base >=4.11 && <5.0,+ beam-core >=0.11.1 && <0.12,+ beam-migrate >=0.6 && <0.7, - postgresql-libpq >=0.8 && <0.10,- postgresql-simple >=0.5 && <0.7,+ postgresql-libpq >=0.8 && <0.12,+ postgresql-simple >=0.5 && <0.8, - text >=1.0 && <1.3,- bytestring >=0.10 && <0.11,+ text >=1.0 && <2.2,+ bytestring >=0.10 && <0.13, - attoparsec >=0.13 && <0.14,- hashable >=1.1 && <1.3,+ attoparsec >=0.13 && <0.15,+ hashable >=1.1 && <1.6, lifted-base >=0.2 && <0.3,- free >=4.12 && <5.2,- time >=1.6 && <1.10,+ free >=4.12 && <5.3,+ time >=1.6 && <1.17, monad-control >=1.0 && <1.1,- mtl >=2.1 && <2.3,+ mtl >=2.1 && <2.4, conduit >=1.2 && <1.4,- aeson >=0.11 && <1.5,+ aeson >=0.11 && <2.4, uuid-types >=1.0 && <1.1, case-insensitive >=1.2 && <1.3, scientific >=0.3 && <0.4,- vector >=0.11 && <0.13,+ vector >=0.11 && <0.14, network-uri >=2.6 && <2.7, unordered-containers >= 0.2 && <0.3, tagged >=0.8 && <0.9,+ transformers-base >=0.4 && <0.5 - haskell-src-exts >=1.18 && <1.22 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+ -Wincomplete-record-updates+ if impl(ghc >= 8.10)+ ghc-options: -Wunused-packages if flag(werror)- ghc-options: -Werror+ ghc-options: -Werror test-suite beam-postgres-tests type: exitcode-stdio-1.0 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- build-depends: base, beam-core, beam-migrate, beam-postgres, text, bytestring, tasty, tasty-hunit,- postgresql-simple, process, temporary, hedgehog, uuid, filepath, directory+ Database.Beam.Postgres.Test.Migrate,+ Database.Beam.Postgres.Test.TempTable,+ Database.Beam.Postgres.Test.Windowing+ build-depends:+ aeson,+ base,+ beam-core,+ beam-migrate,+ beam-postgres,+ bytestring,+ hedgehog >= 1.0,+ postgresql-simple,+ tasty-hunit,+ tasty,+ text,+ testcontainers,+ time,+ uuid,+ vector default-language: Haskell2010 default-extensions: OverloadedStrings, FlexibleInstances, FlexibleContexts, TypeFamilies, ScopedTypeVariables, MultiParamTypeClasses, TypeApplications, DeriveGeneric,@@ -88,5 +119,5 @@ source-repository head type: git- location: https://github.com/tathougies/beam.git+ location: https://github.com/haskell-beam/beam.git subdir: beam-postgres
test/Database/Beam/Postgres/Test.hs view
@@ -1,88 +1,34 @@-{-# 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 (SomeException(..), bracket, catch)-import Control.Concurrent (threadDelay)+import Control.Exception (bracket) import Control.Monad (void)-#if MIN_VERSION_base(4,12,0)-import Control.Monad.Fail (MonadFail(..))-#endif import Data.ByteString (ByteString)-import Data.Semigroup import Data.String -import qualified Hedgehog--import System.IO.Temp-import System.Process-import System.Exit-import System.FilePath-import System.Directory- 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- Pg.execute_ c (fromString ("CREATE DATABASE " <> dbName))+ createDatabase = withAdmin $ \c -> do+ void $ Pg.execute_ c (fromString ("CREATE DATABASE " <> dbName)) Pg.connectPostgreSQL connStrDb dropDatabase c = do Pg.close c- withTemplate1 $ \c' -> do- Pg.execute_ c' (fromString ("DROP DATABASE " <> dbName))- pure ()+ withAdmin $ \c' -> void $+ Pg.execute_ c' (fromString ("DROP DATABASE " <> dbName)) bracket createDatabase dropDatabase action--startTempPostgres :: IO (ByteString, IO ())-startTempPostgres = do- tmpDir <- getCanonicalTemporaryDirectory- pgDataDir <- createTempDirectory tmpDir "postgres-data"-- callProcess "pg_ctl" [ "init", "-D", pgDataDir ]-- -- Use 'D' because otherwise, the path is too long on OS X- pgHdl <- spawnProcess "postgres"- [ "-D", pgDataDir- , "-k", pgDataDir, "-h", "" ]-- putStrLn ("Using " ++ pgDataDir ++ " as postgres host")-- let waitForPort 10 = fail "Could not connect to postgres"- waitForPort n = do- (code, stdout, stderr) <- readProcessWithExitCode "pg_ctl" [ "status", "-D", pgDataDir ] ""- case code of- ExitSuccess -> waitForSocket 0- ExitFailure _ -> threadDelay 1000000 >> waitForPort (n + 1)-- waitForSocket 10 = fail "Could not connect to postgres (waitForSocket)"- waitForSocket n = do- skExists <- doesFileExist (pgDataDir </> ".s.PGSQL.5432")- if skExists then pure () else threadDelay 1000000 >> waitForSocket (n + 1)-- waitForPort 0- putStrLn "Completed waiting for postgres"-- pure ( fromString ("host=" ++ pgDataDir)- , void (callProcess "pg_ctl" [ "stop", "-D", pgDataDir ]))--#if MIN_VERSION_base(4,12,0)--- TODO orphan instances are bad-instance Monad m => MonadFail (Hedgehog.PropertyT m) where- fail _ = Hedgehog.failure-#endif
+ test/Database/Beam/Postgres/Test/CTE.hs view
@@ -0,0 +1,1334 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE RecursiveDo #-}+{-# LANGUAGE StandaloneDeriving #-}++-- | Rendering, type-safety, and PostgreSQL integration tests for common table+-- expressions. Deliberately ill-typed expressions live in+-- "Database.Beam.Postgres.Test.CTENegative" so this module retains normal type+-- checking.+module Database.Beam.Postgres.Test.CTE (unitTests, integrationTests) where++import Control.Exception (TypeError, evaluate, try)+import qualified Data.ByteString.Lazy.Char8 as BL+import Data.ByteString (ByteString)+import Data.Int (Int32)+import Data.Kind (Type)+import Data.List (isInfixOf, isPrefixOf, sortOn)+import Data.Text (Text)++import Database.Beam+import Database.Beam.Postgres+import qualified Database.Beam.Postgres.Full as Pg+import qualified Database.Beam.Query.CTE as CTE+import Database.Beam.Postgres.Syntax+ ( PgDeleteSyntax(..)+ , PgInsertSyntax(..)+ , PgSelectSyntax(..)+ , PgUpdateSyntax(..)+ , PostgresInaccessible+ , pgRenderSyntaxScript+ )+import Database.PostgreSQL.Simple (execute_)++import qualified Hedgehog+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range+import Test.Tasty+import Test.Tasty.HUnit++import Database.Beam.Postgres.Test+import qualified Database.Beam.Postgres.Test.CTENegative as Negative++data CteRowT f = CteRow+ { cteId :: C f Int32+ , cteValue :: C f Text+ } deriving (Generic, Beamable)++deriving instance Show (CteRowT Identity)+deriving instance Eq (CteRowT Identity)++-- A legal Haskell projection shape with no fields. PostgreSQL represents this+-- degree-zero relation by omitting the CTE column-alias list. Data-modifying+-- CTEs with RETURNING use a private physical sentinel to satisfy PostgreSQL's+-- grammar while retaining this zero-field shape at Beam's public boundary.+data EmptyCteT (f :: Type -> Type) = EmptyCte+ deriving (Generic, Beamable)++deriving instance Show (EmptyCteT Identity)+deriving instance Eq (EmptyCteT Identity)++instance Table CteRowT where+ data PrimaryKey CteRowT f = CteRowKey (C f Int32)+ deriving (Generic, Beamable)+ primaryKey = CteRowKey . cteId++newtype CteDb entity = CteDb+ { dbCteRows :: entity (TableEntity CteRowT)+ } deriving (Generic, Database Postgres)++cteDb :: DatabaseSettings Postgres CteDb+cteDb = defaultDbSettings++unitTests :: TestTree+unitTests = testGroup "Common table expression tests"+ [ renderingTests+ , typeSafetyTests+ ]++integrationTests :: IO ByteString -> TestTree+integrationTests getConn = testGroup "Common table expression integration tests"+ [ testMixedCteBodies getConn+ , testSideEffectOnlyCtes getConn+ , testMaterializationExecution getConn+ , testLiftedWithExecution getConn+ , testWithDmlConsumers getConn+ , testCteParameterOrdering getConn+ , testDataModifyingCteModel getConn+ , testSideEffectOnlyCteModel getConn+ , testWithDmlConsumerModel getConn+ , testRecursiveCteModel getConn+ , testDegreeZeroSelects getConn+ , testDegreeZeroDataModifyingCtes getConn+ , testDegreeZeroRepeatedReuse getConn+ ]++renderingTests :: TestTree+renderingTests = testGroup "Common table expression rendering tests"+ [ testMixedCteRendering+ , testMaterializationRendering+ , testNestedMaterializedCteRendering+ , testSideEffectOnlyRendering+ , testSideEffectNoOps+ , testLiftedWithNameSupply+ , testNestedSelectCteRendering+ , testRecursiveSelectThenDeleteRendering+ , testEmptyDataModifyingCtes+ , testWithDmlConsumerRendering+ , testRecursiveInsertWithRendering+ , testTopLevelOnlyDmlConsumerRendering+ , testEmptyDmlConsumers+ , testReturningAfterDmlConsumers+ , testDegreeZeroSelectRendering+ , testDegreeZeroDataModifyingRendering+ ]++-- These tests force expressions compiled with deferred type errors in the+-- isolated negative-fixture module. Checking fragments of GHC's error ensures+-- an unrelated deferred error cannot make a test pass accidentally.+typeSafetyTests :: TestTree+typeSafetyTests = testGroup "Common table expression type-safety tests"+ [ testCase "rejects a DELETE CTE inside pgSelectWith" $+ assertPlacementTypeError Negative.invalidNestedDelete+ , testCase "rejects an INSERT CTE inside pgSelectWith" $+ assertPlacementTypeError Negative.invalidNestedInsert+ , testCase "rejects an UPDATE CTE inside pgSelectWith" $+ assertPlacementTypeError Negative.invalidNestedUpdate+ , testCase "rejects SELECT followed by DELETE inside pgSelectWith" $+ assertPlacementTypeError Negative.invalidNestedSelectThenDelete+ , testCase "rejects DELETE followed by SELECT inside pgSelectWith" $+ assertPlacementTypeError Negative.invalidNestedDeleteThenSelect+ , testCase "conservatively rejects an empty INSERT inside pgSelectWith" $+ assertPlacementTypeError Negative.invalidNestedEmptyInsert+ , testCase "conservatively rejects an identity UPDATE inside pgSelectWith" $+ assertPlacementTypeError Negative.invalidNestedIdentityUpdate+ , testCase "rejects a side-effect-only DELETE inside pgSelectWithNested" $+ assertPlacementTypeError Negative.invalidNestedSideEffectDelete+ , testCase "placement cannot be bypassed with coerce" $+ assertPlacementTypeError Negative.invalidCoercedPlacement+ , testCase "rejects a recursively self-referencing INSERT CTE" $+ assertDeferredTypeErrorContaining+ ["No instance", "MonadFix", "PgCteTopLevelOnly"]+ Negative.invalidRecursiveInsert+ , testCase "side-effect-only CTE results cannot be reused" $+ assertDeferredTypeErrorContaining+ ["ReusableQ"]+ Negative.invalidReuseSideEffect+ ]++assertPlacementTypeError :: SqlSelect Postgres a -> Assertion+assertPlacementTypeError =+ assertDeferredTypeErrorContaining ["PgCteTopLevelOnly", "PgCteNestedAllowed"]++assertDeferredTypeErrorContaining+ :: [String]+ -> SqlSelect Postgres a+ -> Assertion+assertDeferredTypeErrorContaining expectedFragments sql = do+ result <- try (evaluate (BL.length (renderSelectBytes sql)))+ case result of+ Left (err :: TypeError) ->+ let message = show err+ in mapM_ (assertFragment message) expectedFragments+ Right _ ->+ assertFailure "expected the expression to contain a deferred type error"+ where+ assertFragment message fragment =+ assertBool+ ("mentions " ++ fragment ++ "\nDeferred error was:\n" ++ message)+ (fragment `isInfixOf` message)++-- A single top-level WITH block may freely mix SELECT and data-modifying CTE+-- bodies. Besides checking the individual keywords, this guards against+-- accidentally nesting a second WITH while combining the syntax fragments.+testMixedCteRendering :: TestTree+testMixedCteRendering = testCase "renders mixed SELECT, INSERT, UPDATE, and DELETE CTEs" $ do+ let sql = renderSelect mixedCteSelect+ assertBool "renders one top-level WITH" ("WITH " `isPrefixOf` sql)+ assertBool "does not render a nested WITH keyword" (not ("WITH WITH" `isInfixOf` sql))+ assertBool "renders INSERT" ("INSERT INTO" `isInfixOf` sql)+ assertBool "renders UPDATE" ("UPDATE" `isInfixOf` sql)+ assertBool "renders DELETE" ("DELETE FROM" `isInfixOf` sql)+ assertEqual "renders three RETURNING clauses" 3 (length (filter (== "RETURNING") (words sql)))++-- Materialization is an explicit PostgreSQL 12+ spelling choice. Check the+-- complete token rather than a loose MATERIALIZED substring, since the latter+-- would make the NOT MATERIALIZED case pass the positive assertion too.+testMaterializationRendering :: TestTree+testMaterializationRendering = testCase "renders every SELECT CTE materialization policy" $ do+ let defaultSql = renderSelect (materializationSelect Pg.PgCteDefault)+ materializedSql = renderSelect (materializationSelect Pg.PgCteMaterialized)+ notMaterializedSql = renderSelect (materializationSelect Pg.PgCteNotMaterialized)+ assertBool "default omits MATERIALIZED"+ (not (" MATERIALIZED (" `isInfixOf` defaultSql))+ assertBool "default omits NOT MATERIALIZED"+ (not (" NOT MATERIALIZED (" `isInfixOf` defaultSql))+ assertBool "renders AS MATERIALIZED"+ (" AS MATERIALIZED (" `isInfixOf` materializedSql)+ assertBool "renders AS NOT MATERIALIZED"+ (" AS NOT MATERIALIZED (" `isInfixOf` notMaterializedSql)++-- pgSelectWithNested is the safe nested consumer for PostgreSQL-specific+-- SELECT CTE features. This complements the compatibility test for the older+-- pgSelectWith API below.+testNestedMaterializedCteRendering :: TestTree+testNestedMaterializedCteRendering = testCase "embeds a materialized PgWith block in a subquery" $ do+ let sql = renderSelect nestedMaterializedCteSelect+ assertBool "renders the nested WITH"+ ("FROM (WITH " `isInfixOf` sql)+ assertBool "retains the materialization modifier"+ (" AS MATERIALIZED (" `isInfixOf` sql)++-- DML without RETURNING is still executed by PostgreSQL but forms no temporary+-- table and exposes no reusable result. Its CTE name must therefore have no+-- empty column-alias list.+testSideEffectOnlyRendering :: TestTree+testSideEffectOnlyRendering = testCase "renders side-effect-only INSERT, UPDATE, and DELETE CTEs" $ do+ let sql = renderSelect sideEffectOnlyCteSelect+ assertBool "renders INSERT" ("INSERT INTO" `isInfixOf` sql)+ assertBool "renders UPDATE" ("UPDATE" `isInfixOf` sql)+ assertBool "renders DELETE" ("DELETE FROM" `isInfixOf` sql)+ assertBool "does not render RETURNING" (not ("RETURNING" `isInfixOf` sql))+ assertBool "does not render an empty alias list" (not ("() AS" `isInfixOf` sql))++-- Empty inserts and identity updates should consume neither a name nor a CTE+-- slot. With no other CTEs, the final query must not acquire an empty WITH.+testSideEffectNoOps :: TestTree+testSideEffectNoOps = testCase "omits side-effect-only empty INSERT and identity UPDATE" $ do+ let sql = renderSelect sideEffectNoOpSelect+ assertBool "does not render WITH" (not ("WITH " `isPrefixOf` sql))+ assertBool "does not render INSERT" (not ("INSERT INTO" `isInfixOf` sql))+ assertBool "does not render UPDATE" (not ("UPDATE" `isInfixOf` sql))++-- Lifting a complete portable helper must not restart its State Int name+-- supply. Four definitions from native/lifted/native construction should be+-- allocated exactly once as cte0 through cte3.+testLiftedWithNameSupply :: TestTree+testLiftedWithNameSupply = testCase "shares CTE names across lifted and native builders" $ do+ let sql = renderSelect liftedWithSelect+ mapM_ (\name -> assertBool ("renders " ++ name) (("\"" ++ name ++ "\"") `isInfixOf` sql))+ ["cte0", "cte1", "cte2", "cte3"]+ assertBool "does not allocate cte4" (not ("\"cte4\"" `isInfixOf` sql))++-- pgSelectWith remains available for its original purpose: embedding a+-- SELECT-only WITH block as a subquery.+testNestedSelectCteRendering :: TestTree+testNestedSelectCteRendering = testCase "SELECT CTEs remain valid inside pgSelectWith" $ do+ let sql = renderSelect nestedSelectCteSelect+ assertBool "renders an inner WITH" ("FROM (WITH " `isInfixOf` sql)++-- Closing the recursive SELECT portion with pgToTopLevel should preserve WITH+-- RECURSIVE while allowing a later DELETE CTE in the same top-level block.+testRecursiveSelectThenDeleteRendering :: TestTree+testRecursiveSelectThenDeleteRendering = testCase "recursive SELECT can feed a top-level DELETE CTE" $ do+ let sql = renderSelect recursiveSelectThenDeleteCteSelect+ assertBool "renders WITH RECURSIVE" ("WITH RECURSIVE " `isPrefixOf` sql)+ assertBool "renders DELETE" ("DELETE FROM" `isInfixOf` sql)++-- Value-level empty operations must not leave behind an empty or partial WITH+-- clause when the final SELECT is rendered.+testEmptyDataModifyingCtes :: TestTree+testEmptyDataModifyingCtes = testCase "omits empty INSERT and identity UPDATE CTEs" $ do+ let sql = renderSelect emptyDataModifyingCteSelect+ assertBool "does not render WITH" (not ("WITH " `isPrefixOf` sql))+ assertBool "does not render INSERT" (not ("INSERT INTO" `isInfixOf` sql))+ assertBool "does not render UPDATE" (not ("UPDATE" `isInfixOf` sql))++-- Each PostgreSQL DML consumer must place the WITH block before, rather than+-- inside, its terminal statement. These rendering checks cover INSERT, UPDATE,+-- and DELETE while retaining Beam's existing Sql* result types.+testWithDmlConsumerRendering :: TestTree+testWithDmlConsumerRendering = testCase "renders WITH before terminal INSERT, UPDATE, and DELETE" $ do+ assertWithTerminal "INSERT INTO" (renderInsert insertWithStatement)+ assertWithTerminal "UPDATE" (renderUpdate updateWithStatement)+ assertWithTerminal "DELETE FROM" (renderDelete deleteWithStatement)++-- A recursive SELECT CTE is legal before a terminal DML statement. This makes+-- sure pgInsertWith preserves the recursive flag collected by With.+testRecursiveInsertWithRendering :: TestTree+testRecursiveInsertWithRendering = testCase "renders WITH RECURSIVE before a terminal INSERT" $ do+ sql <- requireRenderedStatement (renderInsert recursiveInsertWithStatement)+ assertBool "starts with WITH RECURSIVE" ("WITH RECURSIVE " `isPrefixOf` sql)+ assertBool "renders terminal INSERT" (" INSERT INTO" `isInfixOf` sql)++-- Top-level DML consumers may accept the stronger PgCteTopLevelOnly placement.+-- A data-modifying CTE followed by DELETE exercises that fact at compile time+-- as well as checking the resulting SQL shape.+testTopLevelOnlyDmlConsumerRendering :: TestTree+testTopLevelOnlyDmlConsumerRendering = testCase "accepts a modifying CTE before terminal DELETE" $ do+ sql <- requireRenderedStatement (renderDelete topLevelOnlyDeleteWithStatement)+ assertBool "renders DELETE as the CTE body"+ ("AS (DELETE FROM" `isInfixOf` sql)+ assertBool "renders DELETE as the terminal statement"+ (") DELETE FROM" `isInfixOf` sql)++-- An empty INSERT and identity UPDATE have no terminal statement. PostgreSQL+-- cannot execute a bare WITH clause, so their consumers must retain the+-- existing no-op representation and discard the accumulated definitions.+testEmptyDmlConsumers :: TestTree+testEmptyDmlConsumers = testCase "keeps empty INSERT and identity UPDATE as no-ops" $ do+ assertEqual "empty INSERT has no syntax" Nothing+ (renderInsert emptyInsertWithStatement)+ assertEqual "identity UPDATE has no syntax" Nothing+ (renderUpdate identityUpdateWithStatement)++-- The consumers deliberately return the existing Sql* wrappers. Their+-- PgReturning instances must therefore remain usable without a parallel+-- pgInsertReturningWith/pgUpdateReturningWith/pgDeleteReturningWith API.+testReturningAfterDmlConsumers :: TestTree+testReturningAfterDmlConsumers = testCase "supports RETURNING after each terminal DML consumer" $ do+ assertReturning "INSERT" (renderInsertReturning (Pg.returning insertWithStatement id))+ assertReturning "UPDATE" (renderUpdateReturning (Pg.returning updateWithStatement id))+ assertReturning "DELETE" (renderDeleteReturning (Pg.returning deleteWithStatement id))++-- PostgreSQL's syntax for a degree-zero CTE has no column-alias parentheses.+-- Cover both the portable selecting renderer and the native renderer, including+-- nested and explicit materialization forms, because they enter PostgreSQL+-- syntax through different code paths.+testDegreeZeroSelectRendering :: TestTree+testDegreeZeroSelectRendering = testCase "renders reusable degree-zero SELECT CTEs" $ do+ let portableSql = renderSelect emptySelectProjection+ nativeSql = renderSelect+ (emptyNativeSelectProjection Pg.PgCteDefault)+ materializedSql = renderSelect+ (emptyNativeSelectProjection Pg.PgCteMaterialized)+ nestedSql = renderSelect nestedEmptySelectProjection++ mapM_ assertDegreeZeroSelect+ [portableSql, nativeSql, materializedSql, nestedSql]+ assertBool "retains explicit materialization"+ (" AS MATERIALIZED (" `isInfixOf` materializedSql)+ assertBool "remains valid in a nested SELECT"+ ("FROM (WITH " `isInfixOf` nestedSql)+ where+ assertDegreeZeroSelect sql = do+ assertBool "does not render an empty CTE alias list"+ (not ("\"cte0\"()" `isInfixOf` sql))+ assertBool "the CTE body projects no columns"+ ("SELECT FROM" `isInfixOf` sql || "SELECT FROM" `isInfixOf` sql)+ assertBool "the consumer projects no columns"+ ("SELECT FROM \"cte0\"" `isInfixOf` sql ||+ "SELECT FROM \"cte0\"" `isInfixOf` sql)++-- INSERT, UPDATE, and DELETE share the sentinel path but have independent+-- RETURNING renderers. Assert every spelling, including that the physical+-- sentinel is declared once and is not selected by the zero-field consumer.+testDegreeZeroDataModifyingRendering :: TestTree+testDegreeZeroDataModifyingRendering =+ testCase "renders reusable degree-zero data-modifying CTEs" $+ mapM_ assertDegreeZeroDml+ [ ("INSERT", renderSelect (emptyInsertProjection [CteRow 1 "one"]))+ , ("UPDATE", renderSelect (emptyUpdateProjection 1 "updated"))+ , ("DELETE", renderSelect (emptyDeleteProjection 1))+ ]+ where+ assertDegreeZeroDml (command, sql) = do+ assertBool (command ++ " declares one physical sentinel")+ ("\"cte0\"(\"res0\") AS" `isInfixOf` sql)+ assertBool (command ++ " appends a valid RETURNING expression")+ (" RETURNING NULL::boolean" `isInfixOf` sql)+ assertEqual (command ++ " emits one RETURNING keyword")+ 1+ (length (filter (== "RETURNING") (words sql)))+ assertBool (command ++ " does not expose the sentinel")+ ("SELECT FROM \"cte0\"" `isInfixOf` sql ||+ "SELECT FROM \"cte0\"" `isInfixOf` sql)++-- Rendering alone cannot verify PostgreSQL's execution and snapshot semantics.+-- This integration case checks both the RETURNING rows and the final table+-- state after all three modifying CTEs execute.+testMixedCteBodies :: IO ByteString -> TestTree+testMixedCteBodies getConn = testCase "SELECT and data-modifying CTEs can be mixed" $+ withTestPostgres "mixed_cte_bodies" getConn $ \conn -> do+ execute_ conn "CREATE TABLE cte_rows (id INT PRIMARY KEY, value TEXT NOT NULL)"+ execute_ conn "INSERT INTO cte_rows VALUES (1, 'selected'), (3, 'before-update'), (4, 'deleted')"++ result <- runBeamPostgres conn $ runSelectReturningList mixedCteSelect++ assertEqual "rows returned by each CTE"+ [ ( CteRow 1 "selected"+ , CteRow 2 "inserted"+ , CteRow 3 "updated"+ , CteRow 4 "deleted"+ )+ ]+ result++ remaining <- runBeamPostgres conn $ runSelectReturningList $ select $+ orderBy_ (asc_ . cteId) $ all_ (dbCteRows cteDb)+ assertEqual "data modifications were applied"+ [ CteRow 1 "selected"+ , CteRow 2 "inserted"+ , CteRow 3 "updated"+ ]+ remaining++-- PostgreSQL executes a modifying CTE exactly once even when it has no+-- RETURNING clause and the terminal SELECT does not reference it. Verify that+-- all three commands affect the final database state, not merely that their+-- syntax parses.+testSideEffectOnlyCtes :: IO ByteString -> TestTree+testSideEffectOnlyCtes getConn = testCase "unreferenced side-effect-only CTEs execute once" $+ withTestPostgres "side_effect_only_ctes" getConn $ \conn -> do+ execute_ conn "CREATE TABLE cte_rows (id INT PRIMARY KEY, value TEXT NOT NULL)"+ execute_ conn "INSERT INTO cte_rows VALUES (1, 'unchanged'), (2, 'before-update'), (3, 'delete-me')"++ marker <- runBeamPostgres conn $+ runSelectReturningOne sideEffectOnlyCteSelect+ assertEqual "terminal SELECT still runs" (Just (1 :: Int32)) marker++ remaining <- runBeamPostgres conn $ runSelectReturningList $ select $+ orderBy_ (asc_ . cteId) $ all_ (dbCteRows cteDb)+ assertEqual "all expected side effects were applied"+ [ CteRow 1 "unchanged"+ , CteRow 2 "after-update"+ , CteRow 4 "inserted"+ ]+ remaining++-- Planner choices are deliberately not asserted because they may vary across+-- PostgreSQL releases. Successful execution and equal results validate the two+-- explicit PostgreSQL 12+ spellings without coupling the test to EXPLAIN.+testMaterializationExecution :: IO ByteString -> TestTree+testMaterializationExecution getConn = testCase "MATERIALIZED and NOT MATERIALIZED execute" $+ withTestPostgres "cte_materialization" getConn $ \conn -> do+ execute_ conn "CREATE TABLE cte_rows (id INT PRIMARY KEY, value TEXT NOT NULL)"+ execute_ conn "INSERT INTO cte_rows VALUES (1, 'one'), (2, 'two')"++ materialized <- runBeamPostgres conn $ runSelectReturningList $+ materializationSelect Pg.PgCteMaterialized+ notMaterialized <- runBeamPostgres conn $ runSelectReturningList $+ materializationSelect Pg.PgCteNotMaterialized+ assertEqual "both policies preserve query results" materialized notMaterialized++-- Rendering checks the shared name supply; execution additionally proves that+-- ReusableQ values returned by a lifted multi-CTE helper retain their meaning.+testLiftedWithExecution :: IO ByteString -> TestTree+testLiftedWithExecution getConn = testCase "a lifted multi-CTE helper remains reusable" $+ withTestPostgres "lifted_with_execution" getConn $ \conn -> do+ lifted <- runBeamPostgres conn $ runSelectReturningList liftedWithSelect+ assertEqual "a lifted multi-CTE helper remains reusable"+ [(1, 11, 12)]+ lifted++-- Execute each terminal DML consumer against PostgreSQL. The three statements+-- use SELECT CTEs to choose or construct their affected rows, proving that the+-- reusable names remain visible to INSERT, UPDATE, and DELETE.+testWithDmlConsumers :: IO ByteString -> TestTree+testWithDmlConsumers getConn = testCase "WITH can terminate in INSERT, UPDATE, or DELETE" $+ withTestPostgres "with_dml_consumers" getConn $ \conn -> do+ execute_ conn "CREATE TABLE cte_rows (id INT PRIMARY KEY, value TEXT NOT NULL)"+ execute_ conn "INSERT INTO cte_rows VALUES (1, 'source'), (3, 'before-update'), (4, 'delete-me')"++ runBeamPostgres conn $ do+ runInsert insertWithStatement+ runUpdate updateWithStatement+ runDelete deleteWithStatement++ remaining <- runBeamPostgres conn $ runSelectReturningList $ select $+ orderBy_ (asc_ . cteId) $ all_ (dbCteRows cteDb)+ assertEqual "all terminal DML statements used their CTE rows"+ [ CteRow 1 "source"+ , CteRow 2 "inserted-with"+ , CteRow 3 "updated-with"+ ]+ remaining++-- PostgreSQL receives Beam values separately from the rendered placeholders.+-- Generate distinct values at each syntactic level so any disagreement between+-- syntax construction order and parameter collection order becomes observable+-- in the returned rows, rather than merely producing valid-looking SQL.+testCteParameterOrdering :: IO ByteString -> TestTree+testCteParameterOrdering getConn = testCase "preserves parameter order across CTE bodies and the terminal query" $+ withTestPostgres "cte_parameter_ordering_property" getConn $ \conn -> do+ passes <- Hedgehog.check . Hedgehog.property $ do+ baseId <- Hedgehog.forAll (Gen.int (Range.linear (-100000) 100000))+ firstOffset <- Hedgehog.forAll (Gen.int (Range.linear 1 1000))+ secondOffset <- Hedgehog.forAll (Gen.int (Range.linear 1 1000))+ payload <- Hedgehog.forAll (Gen.text (Range.linear 0 24) Gen.alphaNum)++ let first = CteRow (fromIntegral baseId) ("first:" <> payload)+ second = CteRow+ (fromIntegral (baseId + firstOffset))+ ("second:" <> payload)+ terminal = CteRow+ (fromIntegral (baseId + firstOffset + secondOffset))+ ("terminal:" <> payload)++ actual <- Hedgehog.evalIO $ runBeamPostgres conn $+ runSelectReturningList (parameterOrderingSelect first second terminal)++ actual Hedgehog.=== [(first, second, terminal)]++ assertBool "CTE parameter-ordering property failed" passes++-- Model a statement containing all three kinds of data-modifying CTE. The+-- operations use disjoint keys, avoiding PostgreSQL's deliberately unspecified+-- ordering when sibling modifying CTEs affect the same row. Both RETURNING+-- values and durable table state are compared with the pure expected result.+testDataModifyingCteModel :: IO ByteString -> TestTree+testDataModifyingCteModel getConn = testCase "data-modifying CTEs agree with a pure table model" $+ withTestPostgres "data_modifying_cte_model_property" getConn $ \conn -> do+ execute_ conn "CREATE TABLE cte_rows (id INT PRIMARY KEY, value TEXT NOT NULL)"++ passes <- Hedgehog.check . Hedgehog.property $ do+ baseId <- Hedgehog.forAll (Gen.int (Range.linear (-100000) 96000))+ payload <- Hedgehog.forAll (Gen.text (Range.linear 0 24) Gen.alphaNum)++ let inserted = CteRow (fromIntegral baseId) ("inserted:" <> payload)+ beforeUpdate = CteRow (fromIntegral (baseId + 1)) ("before-update:" <> payload)+ updated = CteRow (cteId beforeUpdate) ("updated:" <> payload)+ deleted = CteRow (fromIntegral (baseId + 2)) ("deleted:" <> payload)+ untouched = CteRow (fromIntegral (baseId + 3)) ("untouched:" <> payload)+ initial = [beforeUpdate, deleted, untouched]+ expectedFinal = [inserted, updated, untouched]++ Hedgehog.evalIO $ do+ execute_ conn "TRUNCATE TABLE cte_rows"+ runBeamPostgres conn $ runInsert $+ insert (dbCteRows cteDb) (insertValues initial)++ returned <- Hedgehog.evalIO $ runBeamPostgres conn $+ runSelectReturningList $+ dataModifyingCteModelSelect inserted (cteId updated) (cteValue updated) (cteId deleted)++ finalRows <- Hedgehog.evalIO $ runBeamPostgres conn $+ runSelectReturningList $ select $+ orderBy_ (asc_ . cteId) $ all_ (dbCteRows cteDb)++ returned Hedgehog.=== [(inserted, updated, deleted)]+ finalRows Hedgehog.=== expectedFinal++ assertBool "data-modifying CTE model property failed" passes++-- Repeat the three-operation model without RETURNING. This catches parameter+-- ordering or accidental omission in the side-effect-only path by+-- comparing durable state over generated inputs.+testSideEffectOnlyCteModel :: IO ByteString -> TestTree+testSideEffectOnlyCteModel getConn = testCase "side-effect-only CTEs agree with a pure table model" $+ withTestPostgres "side_effect_only_cte_model_property" getConn $ \conn -> do+ execute_ conn "CREATE TABLE cte_rows (id INT PRIMARY KEY, value TEXT NOT NULL)"++ passes <- Hedgehog.check . Hedgehog.property $ do+ baseId <- Hedgehog.forAll (Gen.int (Range.linear (-100000) 96000))+ payload <- Hedgehog.forAll (Gen.text (Range.linear 0 24) Gen.alphaNum)++ let inserted = CteRow (fromIntegral baseId) ("inserted:" <> payload)+ beforeUpdate = CteRow (fromIntegral (baseId + 1)) ("before-update:" <> payload)+ updated = CteRow (cteId beforeUpdate) ("updated:" <> payload)+ deleted = CteRow (fromIntegral (baseId + 2)) ("deleted:" <> payload)+ untouched = CteRow (fromIntegral (baseId + 3)) ("untouched:" <> payload)+ initial = [beforeUpdate, deleted, untouched]+ expectedFinal = [inserted, updated, untouched]++ Hedgehog.evalIO $ do+ execute_ conn "TRUNCATE TABLE cte_rows"+ runBeamPostgres conn $ runInsert $+ insert (dbCteRows cteDb) (insertValues initial)++ marker <- Hedgehog.evalIO $ runBeamPostgres conn $+ runSelectReturningOne $+ sideEffectCteModelSelect inserted (cteId updated) (cteValue updated) (cteId deleted)+ finalRows <- Hedgehog.evalIO $ runBeamPostgres conn $+ runSelectReturningList $ select $+ orderBy_ (asc_ . cteId) $ all_ (dbCteRows cteDb)++ marker Hedgehog.=== Just (1 :: Int32)+ finalRows Hedgehog.=== expectedFinal++ assertBool "side-effect-only CTE model property failed" passes++-- Exercise each top-level WITH consumer with independently generated values.+-- RETURNING results prove that the existing PostgreSQL execution instances can+-- still consume the Sql* wrappers, while the final table comparison checks the+-- combined INSERT, UPDATE, and DELETE behavior against a pure model.+testWithDmlConsumerModel :: IO ByteString -> TestTree+testWithDmlConsumerModel getConn = testCase "WITH DML consumers agree with a pure table model" $+ withTestPostgres "with_dml_consumer_model_property" getConn $ \conn -> do+ execute_ conn "CREATE TABLE cte_rows (id INT PRIMARY KEY, value TEXT NOT NULL)"++ passes <- Hedgehog.check . Hedgehog.property $ do+ baseId <- Hedgehog.forAll (Gen.int (Range.linear (-100000) 95000))+ payload <- Hedgehog.forAll (Gen.text (Range.linear 0 24) Gen.alphaNum)++ let source = CteRow (fromIntegral baseId) ("source:" <> payload)+ inserted = CteRow (fromIntegral (baseId + 1)) ("inserted:" <> payload)+ beforeUpdate = CteRow (fromIntegral (baseId + 2)) ("before-update:" <> payload)+ updated = CteRow (cteId beforeUpdate) ("updated:" <> payload)+ deleted = CteRow (fromIntegral (baseId + 3)) ("deleted:" <> payload)+ untouched = CteRow (fromIntegral (baseId + 4)) ("untouched:" <> payload)+ initial = [source, beforeUpdate, deleted, untouched]+ expectedFinal = [source, inserted, updated, untouched]++ Hedgehog.evalIO $ do+ execute_ conn "TRUNCATE TABLE cte_rows"+ runBeamPostgres conn $ runInsert $+ insert (dbCteRows cteDb) (insertValues initial)++ (insertedRows, updatedRows, deletedRows) <- Hedgehog.evalIO $+ runBeamPostgres conn $ do+ insertedRows <- Pg.runPgInsertReturningList $ Pg.returning+ (modelInsertWithStatement (cteId source) inserted) id+ updatedRows <- Pg.runPgUpdateReturningList $ Pg.returning+ (modelUpdateWithStatement (cteId updated) (cteValue updated)) id+ deletedRows <- Pg.runPgDeleteReturningList $ Pg.returning+ (modelDeleteWithStatement (cteId deleted)) id+ pure (insertedRows, updatedRows, deletedRows)++ finalRows <- Hedgehog.evalIO $ runBeamPostgres conn $+ runSelectReturningList $ select $+ orderBy_ (asc_ . cteId) $ all_ (dbCteRows cteDb)++ insertedRows Hedgehog.=== [inserted]+ updatedRows Hedgehog.=== [updated]+ deletedRows Hedgehog.=== [deleted]+ finalRows Hedgehog.=== expectedFinal++ assertBool "WITH DML consumer model property failed" passes++-- Generate a bounded recursive sequence, use it to drive a DELETE CTE, and+-- compare both the returned rows and remaining table against the corresponding+-- Haskell lists. This executes the recursive SELECT, its pgToTopLevel promotion,+-- and the following modifying CTE rather than checking only rendered keywords.+testRecursiveCteModel :: IO ByteString -> TestTree+testRecursiveCteModel getConn = testCase "recursive CTE execution agrees with a bounded sequence model" $+ withTestPostgres "recursive_cte_model_property" getConn $ \conn -> do+ execute_ conn "CREATE TABLE cte_rows (id INT PRIMARY KEY, value TEXT NOT NULL)"++ passes <- Hedgehog.check . Hedgehog.property $ do+ start <- Hedgehog.forAll (Gen.int (Range.linear (-100000) 95000))+ count <- Hedgehog.forAll (Gen.int (Range.linear 1 25))+ payload <- Hedgehog.forAll (Gen.text (Range.linear 0 24) Gen.alphaNum)++ let startId = fromIntegral start+ endId = fromIntegral (start + count - 1)+ recursiveRows =+ [ CteRow (fromIntegral rowId) ("recursive:" <> payload)+ | rowId <- [start .. start + count - 1]+ ]+ untouched = CteRow (fromIntegral (start + count)) ("untouched:" <> payload)++ Hedgehog.evalIO $ do+ execute_ conn "TRUNCATE TABLE cte_rows"+ runBeamPostgres conn $ runInsert $+ insert (dbCteRows cteDb) (insertValues (recursiveRows ++ [untouched]))++ deletedRows <- Hedgehog.evalIO $ runBeamPostgres conn $+ runSelectReturningList (recursiveCteModelSelect startId endId)+ finalRows <- Hedgehog.evalIO $ runBeamPostgres conn $+ runSelectReturningList $ select $+ orderBy_ (asc_ . cteId) $ all_ (dbCteRows cteDb)++ sortOn cteId deletedRows Hedgehog.=== recursiveRows+ finalRows Hedgehog.=== [untouched]++ assertBool "recursive CTE model property failed" passes++-- A row need not contain a projected value. PostgreSQL still returns one+-- zero-field result for every source row, and postgresql-simple must decode the+-- final rows without expecting any result fields. Exercise both the portable+-- and native builders and both explicit materialization policies.+testDegreeZeroSelects :: IO ByteString -> TestTree+testDegreeZeroSelects getConn = testCase "degree-zero SELECT CTEs preserve source cardinality" $+ withTestPostgres "degree_zero_select_ctes" getConn $ \conn -> do+ execute_ conn "CREATE TABLE cte_rows (id INT PRIMARY KEY, value TEXT NOT NULL)"++ emptySummary <- runBeamPostgres conn $ runSelectReturningOne $+ emptySelectSummary+ assertEqual "an empty degree-zero relation has count zero and is not present"+ (Just (0, False))+ emptySummary++ execute_ conn "INSERT INTO cte_rows VALUES (1, 'one'), (2, 'two'), (3, 'three')"++ portable <- runBeamPostgres conn $+ runSelectReturningList emptySelectProjection+ native <- runBeamPostgres conn $ runSelectReturningList $+ emptyNativeSelectProjection Pg.PgCteDefault+ materialized <- runBeamPostgres conn $ runSelectReturningList $+ emptyNativeSelectProjection Pg.PgCteMaterialized+ notMaterialized <- runBeamPostgres conn $ runSelectReturningList $+ emptyNativeSelectProjection Pg.PgCteNotMaterialized+ populatedSummary <- runBeamPostgres conn $ runSelectReturningOne $+ emptySelectSummary++ let expected = replicate 3 EmptyCte+ assertEqual "portable selecting preserves cardinality" expected portable+ assertEqual "native default preserves cardinality" expected native+ assertEqual "MATERIALIZED preserves cardinality" expected materialized+ assertEqual "NOT MATERIALIZED preserves cardinality" expected notMaterialized+ assertEqual "aggregates and EXISTS observe degree-zero rows"+ (Just (3, True))+ populatedSummary++-- Each modifying command has a separate RETURNING renderer. Besides validating+-- all three, this checks the boundary cases of several affected rows and no+-- affected rows, verifies that the private sentinel is not passed to the row+-- decoder, and compares the resulting durable table state.+testDegreeZeroDataModifyingCtes :: IO ByteString -> TestTree+testDegreeZeroDataModifyingCtes getConn =+ testCase "degree-zero modifying CTEs preserve affected-row cardinality" $+ withTestPostgres "degree_zero_modifying_ctes" getConn $ \conn -> do+ execute_ conn "CREATE TABLE cte_rows (id INT PRIMARY KEY, value TEXT NOT NULL)"+ execute_ conn "INSERT INTO cte_rows VALUES (1, 'one'), (2, 'two'), (3, 'three')"++ inserted <- runBeamPostgres conn $ runSelectReturningList $+ emptyInsertProjection [CteRow 4 "four", CteRow 5 "five"]+ updated <- runBeamPostgres conn $ runSelectReturningList $+ emptyUpdateProjection 2 "updated"+ deleted <- runBeamPostgres conn $ runSelectReturningList $+ emptyDeleteProjection 3+ deletedNone <- runBeamPostgres conn $ runSelectReturningList $+ emptyDeleteProjection 99++ assertEqual "INSERT retains two affected rows"+ (replicate 2 EmptyCte) inserted+ assertEqual "UPDATE retains two affected rows"+ (replicate 2 EmptyCte) updated+ assertEqual "DELETE retains three affected rows"+ (replicate 3 EmptyCte) deleted+ assertEqual "a command affecting no rows returns an empty relation"+ [] deletedNone++ remaining <- runBeamPostgres conn $ runSelectReturningList $ select $+ orderBy_ (asc_ . cteId) $ all_ (dbCteRows cteDb)+ assertEqual "all modifying commands applied their side effects"+ [CteRow 1 "updated", CteRow 2 "updated"]+ remaining++-- Reusing a degree-zero modifying CTE twice is a useful stress case: no field+-- can carry cardinality through the query, so the nine rows show that both+-- references read the same three-row RETURNING result. The final table state+-- separately confirms that the DELETE removed every source row.+testDegreeZeroRepeatedReuse :: IO ByteString -> TestTree+testDegreeZeroRepeatedReuse getConn =+ testCase "repeated degree-zero reuse preserves relational cardinality" $+ withTestPostgres "degree_zero_repeated_reuse" getConn $ \conn -> do+ execute_ conn "CREATE TABLE cte_rows (id INT PRIMARY KEY, value TEXT NOT NULL)"+ execute_ conn "INSERT INTO cte_rows VALUES (1, 'one'), (2, 'two'), (3, 'three')"++ summary <- runBeamPostgres conn $ runSelectReturningOne $+ emptyDeleteSummary+ assertEqual "COUNT and EXISTS observe every returned DELETE row"+ (Just (3, True))+ summary++ execute_ conn "INSERT INTO cte_rows VALUES (1, 'one'), (2, 'two'), (3, 'three')"+ products <- runBeamPostgres conn $ runSelectReturningList $+ repeatedEmptyDeleteProjection+ assertEqual "two references form the expected Cartesian product"+ (replicate 9 EmptyCte)+ products++ remaining <- runBeamPostgres conn $ runSelectReturningList $ select $+ all_ (dbCteRows cteDb)+ assertEqual "the modifying CTE deletes every source row"+ []+ remaining++materializationSelect+ :: Pg.PgCteMaterialization+ -> SqlSelect Postgres (CteRowT Identity)+materializationSelect materialization = Pg.pgSelectWithTopLevel $ do+ rows <- Pg.pgSelectingWith materialization $ all_ (dbCteRows cteDb)+ pure (reuse rows)++nestedMaterializedCteSelect :: SqlSelect Postgres (CteRowT Identity)+nestedMaterializedCteSelect = select $ Pg.pgSelectWithNested $ do+ rows <- Pg.pgSelectingWith Pg.PgCteMaterialized $+ all_ (dbCteRows cteDb)+ pure (reuse rows)++sideEffectOnlyCteSelect :: SqlSelect Postgres Int32+sideEffectOnlyCteSelect = Pg.pgSelectWithTopLevel $ do+ Pg.cteInsert+ (dbCteRows cteDb)+ (insertValues [CteRow 4 "inserted"])+ Pg.onConflictDefault+ Pg.cteUpdate+ (dbCteRows cteDb)+ (\row -> cteValue row <-. val_ "after-update")+ (\row -> cteId row ==. val_ 2)+ Pg.cteDelete+ (dbCteRows cteDb)+ (\row -> cteId row ==. val_ 3)+ pure finalMarkerQuery++sideEffectNoOpSelect :: SqlSelect Postgres Int32+sideEffectNoOpSelect = Pg.pgSelectWithTopLevel $ do+ Pg.cteInsert+ (dbCteRows cteDb)+ SqlInsertValuesEmpty+ Pg.onConflictDefault+ Pg.cteUpdate+ (dbCteRows cteDb)+ (const mempty)+ (const (val_ True))+ pure finalMarkerQuery++finalMarkerQuery+ :: Q Postgres CteDb QBaseScope (QExpr Postgres QBaseScope Int32)+finalMarkerQuery = pure (val_ 1)++-- A complete two-CTE portable helper is lifted as one action. Its internal+-- dependency also proves that lifting preserves ReusableQ values, not only the+-- emitted syntax fragments.+portableWithHelper+ :: With Postgres CteDb+ (ReusableQ Postgres CteDb (QExpr Postgres CTE.QAnyScope Int32))+portableWithHelper = do+ first <- selecting $ pure (as_ @Int32 (val_ 10))+ selecting $ do+ value <- reuse first+ pure (value + 1)++liftedWithSelect+ :: SqlSelect Postgres+ (Int32, Int32, Int32)+liftedWithSelect = Pg.pgSelectWithTopLevel $ do+ nativeBefore <- Pg.pgSelecting $ pure (as_ @Int32 (val_ 1))+ lifted <- Pg.pgLiftWith portableWithHelper+ nativeAfter <- Pg.pgSelecting $ do+ value <- reuse lifted+ pure (value + 1)+ pure $ do+ before <- reuse nativeBefore+ middle <- reuse lifted+ after <- reuse nativeAfter+ pure (before, middle, after)++-- Exercise the main user-facing flow: bind a normal SELECT CTE, perform each+-- supported data modification, then join all four reusable results in the final+-- SELECT. The placement of the complete block is inferred as top-level-only.+mixedCteSelect+ :: SqlSelect Postgres+ ( CteRowT Identity+ , CteRowT Identity+ , CteRowT Identity+ , CteRowT Identity+ )+mixedCteSelect = Pg.pgSelectWithTopLevel $ do+ selected <- Pg.pgSelecting $ do+ row <- all_ (dbCteRows cteDb)+ guard_ (cteId row ==. val_ 1)+ pure row++ inserted <- Pg.cteInsertReturning+ (dbCteRows cteDb)+ (insertValues [CteRow 2 "inserted"])+ Pg.onConflictDefault+ id++ updated <- Pg.cteUpdateReturning+ (dbCteRows cteDb)+ (\row -> cteValue row <-. val_ "updated")+ (\row -> cteId row ==. val_ 3)+ id++ deleted <- Pg.cteDeleteReturning+ (dbCteRows cteDb)+ (\row -> cteId row ==. val_ 4)+ id++ case (inserted, updated) of+ (Just inserted', Just updated') -> pure $ do+ selectedRow <- reuse selected+ insertedRow <- reuse inserted'+ updatedRow <- reuse updated'+ deletedRow <- reuse deleted+ pure (selectedRow, insertedRow, updatedRow, deletedRow)+ _ -> error "Expected non-empty INSERT and UPDATE CTEs"++-- Place values in two dependent CTE bodies and in the terminating SELECT. The+-- dependency prevents the second CTE from becoming an unrelated test fragment,+-- while the result exposes every bound value for exact comparison.+parameterOrderingSelect+ :: CteRowT Identity+ -> CteRowT Identity+ -> CteRowT Identity+ -> SqlSelect Postgres+ (CteRowT Identity, CteRowT Identity, CteRowT Identity)+parameterOrderingSelect first second terminal = selectWith $ do+ firstRows <- selecting $ pure (cteRowValues_ @CTE.QAnyScope first)+ secondRows <- selecting $ do+ _ <- reuse firstRows+ pure (cteRowValues_ @CTE.QAnyScope second)+ pure $ do+ firstRow <- reuse firstRows+ secondRow <- reuse secondRows+ pure+ ( firstRow+ , secondRow+ , cteRowValues_ @QBaseScope terminal+ )++cteRowValues_+ :: forall scope. CteRowT Identity -> CteRowT (QExpr Postgres scope)+cteRowValues_ row = CteRow (val_ (cteId row)) (val_ (cteValue row))++-- The returned relation exposes the result of every modifying CTE. Keeping+-- their keys disjoint gives the property a deterministic reference model while+-- still exercising mixed syntax assembly and PostgreSQL execution semantics.+dataModifyingCteModelSelect+ :: CteRowT Identity+ -> Int32+ -> Text+ -> Int32+ -> SqlSelect Postgres+ (CteRowT Identity, CteRowT Identity, CteRowT Identity)+dataModifyingCteModelSelect inserted updateId updateValue deleteId =+ Pg.pgSelectWithTopLevel $ do+ insertedRows <- Pg.cteInsertReturning+ (dbCteRows cteDb)+ (insertValues [inserted])+ Pg.onConflictDefault+ id+ updatedRows <- Pg.cteUpdateReturning+ (dbCteRows cteDb)+ (\row -> cteValue row <-. val_ updateValue)+ (\row -> cteId row ==. val_ updateId)+ id+ deletedRows <- Pg.cteDeleteReturning+ (dbCteRows cteDb)+ (\row -> cteId row ==. val_ deleteId)+ id++ case (insertedRows, updatedRows) of+ (Just insertedRows', Just updatedRows') -> pure $ do+ insertedRow <- reuse insertedRows'+ updatedRow <- reuse updatedRows'+ deletedRow <- reuse deletedRows+ pure (insertedRow, updatedRow, deletedRow)+ _ -> error "Expected non-empty INSERT and UPDATE CTEs"++sideEffectCteModelSelect+ :: CteRowT Identity+ -> Int32+ -> Text+ -> Int32+ -> SqlSelect Postgres Int32+sideEffectCteModelSelect inserted updateId updateValue deleteId =+ Pg.pgSelectWithTopLevel $ do+ Pg.cteInsert+ (dbCteRows cteDb)+ (insertValues [inserted])+ Pg.onConflictDefault+ Pg.cteUpdate+ (dbCteRows cteDb)+ (\row -> cteValue row <-. val_ updateValue)+ (\row -> cteId row ==. val_ updateId)+ Pg.cteDelete+ (dbCteRows cteDb)+ (\row -> cteId row ==. val_ deleteId)+ pure finalMarkerQuery++-- The source key is selected in a CTE, then used to derive the inserted key.+-- This keeps both the CTE and terminal INSERT semantically relevant.+modelInsertWithStatement+ :: Int32+ -> CteRowT Identity+ -> SqlInsert Postgres CteRowT+modelInsertWithStatement sourceId inserted = Pg.pgInsertWith $ do+ sourceIds <- Pg.pgSelecting $ do+ row <- all_ (dbCteRows cteDb)+ guard_ (cteId row ==. val_ sourceId)+ pure (cteId row)+ pure $ Pg.insert+ (dbCteRows cteDb)+ (insertFrom $ do+ selectedId <- reuse sourceIds+ pure $ CteRow+ (selectedId + val_ (cteId inserted - sourceId))+ (val_ (cteValue inserted)))+ Pg.onConflictDefault++modelUpdateWithStatement+ :: Int32+ -> Text+ -> SqlUpdate Postgres CteRowT+modelUpdateWithStatement updateId updateValue = Pg.pgUpdateWith $ do+ targetIds <- Pg.pgSelecting $ do+ row <- all_ (dbCteRows cteDb)+ guard_ (cteId row ==. val_ updateId)+ pure (cteId row)+ pure $ update+ (dbCteRows cteDb)+ (\row -> cteValue row <-. val_ updateValue)+ (\row -> exists_ $ do+ targetId <- reuse targetIds+ guard_ (cteId row ==. targetId)+ pure targetId)++modelDeleteWithStatement+ :: Int32+ -> SqlDelete Postgres CteRowT+modelDeleteWithStatement deleteId = Pg.pgDeleteWith $ do+ targetIds <- Pg.pgSelecting $ do+ row <- all_ (dbCteRows cteDb)+ guard_ (cteId row ==. val_ deleteId)+ pure (cteId row)+ pure $ delete (dbCteRows cteDb) $ \row -> exists_ $ do+ targetId <- reuse targetIds+ guard_ (cteId row ==. targetId)+ pure targetId++recursiveCteModelSelect+ :: Int32+ -> Int32+ -> SqlSelect Postgres (CteRowT Identity)+recursiveCteModelSelect startId endId = Pg.pgSelectWithTopLevel $ do+ recursiveIds <- Pg.pgToTopLevel $ mdo+ ids <- Pg.pgSelecting $+ pure (as_ @Int32 (val_ startId)) `unionAll_` do+ previousId <- reuse ids+ guard_ (previousId <. val_ endId)+ pure (previousId + 1)+ pure ids++ deletedRows <- Pg.cteDeleteReturning+ (dbCteRows cteDb)+ (\row -> exists_ $ do+ recursiveId <- reuse recursiveIds+ guard_ (cteId row ==. recursiveId)+ pure recursiveId)+ id++ pure (reuse deletedRows)++nestedSelectCteSelect :: SqlSelect Postgres (CteRowT Identity)+nestedSelectCteSelect = select $ Pg.pgSelectWith $ do+ selected <- selecting $ do+ row <- all_ (dbCteRows cteDb)+ guard_ (cteId row ==. val_ 1)+ pure row+ pure (reuse selected)++-- PostgreSQL permits a recursive SELECT CTE to feed a later modifying CTE, but+-- not a modifying CTE to recursively reference itself. 'pgToTopLevel' closes the+-- recursive SELECT knot before the DELETE is added.+recursiveSelectThenDeleteCteSelect :: SqlSelect Postgres (CteRowT Identity)+recursiveSelectThenDeleteCteSelect = Pg.pgSelectWithTopLevel $ do+ recursiveIds <- Pg.pgToTopLevel $ mdo+ ids <- Pg.pgSelecting $+ pure (as_ @Int32 (val_ 1)) `unionAll_` do+ previousId <- reuse ids+ guard_ (previousId <. val_ 2)+ pure (previousId + 1)+ pure ids++ deleted <- Pg.cteDeleteReturning+ (dbCteRows cteDb)+ (\row -> exists_ $ do+ recursiveId <- reuse recursiveIds+ guard_ (cteId row ==. recursiveId)+ pure recursiveId)+ id++ pure (reuse deleted)++-- Empty INSERT values and identity UPDATE assignments do not produce SQL.+-- Their wrappers return Nothing, leaving pgSelectWithTopLevel to render the+-- final query without an empty WITH clause.+emptyDataModifyingCteSelect :: SqlSelect Postgres Int32+emptyDataModifyingCteSelect = Pg.pgSelectWithTopLevel $ do+ inserted <- Pg.cteInsertReturning+ (dbCteRows cteDb)+ SqlInsertValuesEmpty+ Pg.onConflictDefault+ id+ updated <- Pg.cteUpdateReturning+ (dbCteRows cteDb)+ (const mempty)+ (const (val_ True))+ id+ case (inserted, updated) of+ (Nothing, Nothing) -> pure finalQuery+ _ -> error "Expected empty INSERT and UPDATE CTEs"+ where+ finalQuery :: Q Postgres CteDb QBaseScope (QExpr Postgres QBaseScope Int32)+ finalQuery = pure (val_ 1)++-- The portable builder reaches PostgreSQL through the SQL99-shaped compatibility+-- instance. Each input table row contributes one row to the reusable+-- degree-zero relation even though the projection contains no values.+emptySelectProjection :: SqlSelect Postgres (EmptyCteT Identity)+emptySelectProjection = selectWith $ do+ rows <- selecting $ do+ _ <- all_ (dbCteRows cteDb)+ pure (EmptyCte :: EmptyCteT (QExpr Postgres CTE.QAnyScope))+ pure (reuse rows)++-- The native SELECT path additionally carries PostgreSQL's materialization+-- policy. Its logical result is identical for all three policies.+emptyNativeSelectProjection+ :: Pg.PgCteMaterialization+ -> SqlSelect Postgres (EmptyCteT Identity)+emptyNativeSelectProjection materialization = Pg.pgSelectWithTopLevel $ do+ rows <- Pg.pgSelectingWith materialization $ do+ _ <- all_ (dbCteRows cteDb)+ pure (EmptyCte :: EmptyCteT (QExpr Postgres CTE.QAnyScope))+ pure (reuse rows)++-- SELECT CTEs remain nestable when their relation has degree zero.+nestedEmptySelectProjection :: SqlSelect Postgres (EmptyCteT Identity)+nestedEmptySelectProjection = select $ Pg.pgSelectWithNested $ do+ rows <- Pg.pgSelecting $ do+ _ <- all_ (dbCteRows cteDb)+ pure (EmptyCte :: EmptyCteT (QExpr Postgres CTE.QAnyScope))+ pure (reuse rows)++-- COUNT(*) and EXISTS do not need a projected field, so they are natural+-- consumers of a degree-zero relation. Both references share one CTE body.+emptySelectSummary :: SqlSelect Postgres (Int32, Bool)+emptySelectSummary = Pg.pgSelectWithTopLevel $ do+ rows <- Pg.pgSelecting $ do+ _ <- all_ (dbCteRows cteDb)+ pure (EmptyCte :: EmptyCteT (QExpr Postgres CTE.QAnyScope))+ pure $ do+ count <- aggregate_ (const (as_ @Int32 countAll_)) (reuse rows)+ pure (count, exists_ (reuse rows))++-- The next three fixtures deliberately return no logical values. PostgreSQL's+-- RETURNING grammar is satisfied internally, while the outer SELECT exposes no+-- physical columns and retains one row per affected table row.+emptyInsertProjection+ :: [CteRowT Identity]+ -> SqlSelect Postgres (EmptyCteT Identity)+emptyInsertProjection values = Pg.pgSelectWithTopLevel $ do+ rows <- Pg.cteInsertReturning+ (dbCteRows cteDb)+ (insertValues values)+ Pg.onConflictDefault+ (const (EmptyCte :: EmptyCteT (QExpr Postgres PostgresInaccessible)))+ case rows of+ Just rows' -> pure (reuse rows')+ Nothing -> error "Expected non-empty INSERT values"++emptyUpdateProjection+ :: Int32+ -> Text+ -> SqlSelect Postgres (EmptyCteT Identity)+emptyUpdateProjection maximumId value = Pg.pgSelectWithTopLevel $ do+ rows <- Pg.cteUpdateReturning+ (dbCteRows cteDb)+ (\row -> cteValue row <-. val_ value)+ (\row -> cteId row <=. val_ maximumId)+ (const (EmptyCte :: EmptyCteT (QExpr Postgres PostgresInaccessible)))+ case rows of+ Just rows' -> pure (reuse rows')+ Nothing -> error "Expected a non-identity UPDATE"++emptyDeleteProjection+ :: Int32+ -> SqlSelect Postgres (EmptyCteT Identity)+emptyDeleteProjection minimumId = Pg.pgSelectWithTopLevel $ do+ rows <- Pg.cteDeleteReturning+ (dbCteRows cteDb)+ (\row -> cteId row >=. val_ minimumId)+ (const (EmptyCte :: EmptyCteT (QExpr Postgres PostgresInaccessible)))+ pure (reuse rows)++-- Two references to the same modifying CTE must multiply its row cardinality,+-- not execute the DELETE twice or expose its private sentinel.+repeatedEmptyDeleteProjection :: SqlSelect Postgres (EmptyCteT Identity)+repeatedEmptyDeleteProjection = Pg.pgSelectWithTopLevel $ do+ rows <- Pg.cteDeleteReturning+ (dbCteRows cteDb)+ (const (val_ True))+ (const (EmptyCte :: EmptyCteT (QExpr Postgres PostgresInaccessible)))+ pure $ do+ _ <- reuse rows+ _ <- reuse rows+ pure (EmptyCte :: EmptyCteT (QExpr Postgres QBaseScope))++-- Aggregating the reusable DELETE result verifies that the private physical+-- sentinel supplies relational rows without becoming a Beam expression.+emptyDeleteSummary :: SqlSelect Postgres (Int32, Bool)+emptyDeleteSummary = Pg.pgSelectWithTopLevel $ do+ rows <- Pg.cteDeleteReturning+ (dbCteRows cteDb)+ (const (val_ True))+ (const (EmptyCte :: EmptyCteT (QExpr Postgres PostgresInaccessible)))+ pure $ do+ count <- aggregate_ (const (as_ @Int32 countAll_)) (reuse rows)+ pure (count, exists_ (reuse rows))++-- Copy one row selected by the CTE into a new row. insertFrom is what exposes+-- the reusable query to the terminal INSERT source.+insertWithStatement :: SqlInsert Postgres CteRowT+insertWithStatement = Pg.pgInsertWith $ do+ source <- Pg.pgSelecting $ do+ row <- all_ (dbCteRows cteDb)+ guard_ (cteId row ==. val_ 1)+ pure row+ pure $ Pg.insert+ (dbCteRows cteDb)+ (insertFrom $ do+ row <- reuse source+ pure (CteRow (cteId row + 1) (val_ "inserted-with")))+ Pg.onConflictDefault++-- Select the target key independently, then reference it through EXISTS in+-- the terminal UPDATE predicate.+updateWithStatement :: SqlUpdate Postgres CteRowT+updateWithStatement = Pg.pgUpdateWith $ do+ targets <- Pg.pgSelecting $ do+ row <- all_ (dbCteRows cteDb)+ guard_ (cteId row ==. val_ 3)+ pure (cteId row)+ pure $ update+ (dbCteRows cteDb)+ (\row -> cteValue row <-. val_ "updated-with")+ (\row -> exists_ $ do+ targetId <- reuse targets+ guard_ (cteId row ==. targetId)+ pure targetId)++-- The DELETE form uses the same reusable-key pattern as UPDATE, exercising+-- the third terminal syntax wrapper.+deleteWithStatement :: SqlDelete Postgres CteRowT+deleteWithStatement = Pg.pgDeleteWith $ do+ targets <- Pg.pgSelecting $ do+ row <- all_ (dbCteRows cteDb)+ guard_ (cteId row ==. val_ 4)+ pure (cteId row)+ pure $ delete (dbCteRows cteDb) $ \row -> exists_ $ do+ targetId <- reuse targets+ guard_ (cteId row ==. targetId)+ pure targetId++-- Recursion is completed while the block is still nested-safe. The terminal+-- INSERT then consumes the recursive result at top level.+recursiveInsertWithStatement :: SqlInsert Postgres CteRowT+recursiveInsertWithStatement = Pg.pgInsertWith recursiveInsertWith++recursiveInsertWith+ :: Pg.PgWith CteDb 'Pg.PgCteNestedAllowed (SqlInsert Postgres CteRowT)+recursiveInsertWith = mdo+ ids <- Pg.pgSelecting $+ pure (as_ @Int32 (val_ 1)) `unionAll_` do+ previousId <- reuse ids+ guard_ (previousId <. val_ 2)+ pure (previousId + 1)+ pure $ Pg.insert+ (dbCteRows cteDb)+ (insertFrom $ do+ rowId <- reuse ids+ pure (CteRow rowId (val_ "recursive")))+ Pg.onConflictDefault++-- Adding a modifying CTE fixes the block to PgCteTopLevelOnly. pgDeleteWith is+-- a top-level consumer, so this remains well-typed.+topLevelOnlyDeleteWithStatement :: SqlDelete Postgres CteRowT+topLevelOnlyDeleteWithStatement = Pg.pgDeleteWith $ do+ _ <- Pg.cteDeleteReturning+ (dbCteRows cteDb)+ (\row -> cteId row ==. val_ 99)+ id+ pure $ delete+ (dbCteRows cteDb)+ (\row -> cteId row ==. val_ 100)++emptyInsertWithStatement :: SqlInsert Postgres CteRowT+emptyInsertWithStatement = Pg.pgInsertWith $ do+ _ <- Pg.pgSelecting $ all_ (dbCteRows cteDb)+ pure $ Pg.insert+ (dbCteRows cteDb)+ SqlInsertValuesEmpty+ Pg.onConflictDefault++identityUpdateWithStatement :: SqlUpdate Postgres CteRowT+identityUpdateWithStatement = Pg.pgUpdateWith $ do+ _ <- Pg.pgSelecting $ all_ (dbCteRows cteDb)+ pure $ update+ (dbCteRows cteDb)+ (const mempty)+ (const (val_ True))++assertWithTerminal+ :: String+ -> Maybe String+ -> Assertion+assertWithTerminal terminal rendered = do+ sql <- requireRenderedStatement rendered+ assertBool "starts with WITH" ("WITH " `isPrefixOf` sql)+ assertBool ("renders terminal " ++ terminal) ((" " ++ terminal) `isInfixOf` sql)++requireRenderedStatement+ :: Maybe String+ -> IO String+requireRenderedStatement rendered =+ case rendered of+ Nothing -> assertFailure "expected a PostgreSQL statement" >> pure ""+ Just sql -> pure sql++renderInsert :: SqlInsert Postgres table -> Maybe String+renderInsert SqlInsertNoRows = Nothing+renderInsert (SqlInsert _ (PgInsertSyntax syntax)) =+ Just (BL.unpack (pgRenderSyntaxScript syntax))++renderUpdate :: SqlUpdate Postgres table -> Maybe String+renderUpdate SqlIdentityUpdate = Nothing+renderUpdate (SqlUpdate _ (PgUpdateSyntax syntax)) =+ Just (BL.unpack (pgRenderSyntaxScript syntax))++renderDelete :: SqlDelete Postgres table -> Maybe String+renderDelete (SqlDelete _ (PgDeleteSyntax syntax)) =+ Just (BL.unpack (pgRenderSyntaxScript syntax))++assertReturning :: String -> Maybe String -> Assertion+assertReturning command rendered = do+ sql <- requireRenderedStatement rendered+ assertBool (command ++ " retains its WITH prefix") ("WITH " `isPrefixOf` sql)+ assertBool (command ++ " renders RETURNING") (" RETURNING " `isInfixOf` sql)++renderInsertReturning :: Pg.PgInsertReturning a -> Maybe String+renderInsertReturning Pg.PgInsertReturningEmpty = Nothing+renderInsertReturning (Pg.PgInsertReturning syntax) =+ Just (BL.unpack (pgRenderSyntaxScript syntax))++renderUpdateReturning :: Pg.PgUpdateReturning a -> Maybe String+renderUpdateReturning Pg.PgUpdateReturningEmpty = Nothing+renderUpdateReturning (Pg.PgUpdateReturning syntax) =+ Just (BL.unpack (pgRenderSyntaxScript syntax))++renderDeleteReturning :: Pg.PgDeleteReturning a -> Maybe String+renderDeleteReturning (Pg.PgDeleteReturning syntax) =+ Just (BL.unpack (pgRenderSyntaxScript syntax))++renderSelect :: SqlSelect Postgres a -> String+renderSelect = BL.unpack . renderSelectBytes++renderSelectBytes :: SqlSelect Postgres a -> BL.ByteString+renderSelectBytes (SqlSelect (PgSelectSyntax syntax)) =+ pgRenderSyntaxScript syntax
+ test/Database/Beam/Postgres/Test/CTENegative.hs view
@@ -0,0 +1,180 @@+{-# OPTIONS_GHC -fdefer-type-errors -Wno-deferred-type-errors #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE RecursiveDo #-}+{-# LANGUAGE StandaloneDeriving #-}++-- This module deliberately contains expressions which must not type-check.+-- Deferred type errors are isolated here so the positive CTE tests retain+-- normal, strict type checking.+module Database.Beam.Postgres.Test.CTENegative+ ( invalidNestedDelete+ , invalidNestedInsert+ , invalidNestedUpdate+ , invalidNestedSelectThenDelete+ , invalidNestedDeleteThenSelect+ , invalidNestedEmptyInsert+ , invalidNestedIdentityUpdate+ , invalidNestedSideEffectDelete+ , invalidCoercedPlacement+ , invalidRecursiveInsert+ , invalidReuseSideEffect+ ) where++import qualified Data.Coerce as Coerce+import Data.Int (Int32)+import Data.Text (Text)++import Database.Beam+import Database.Beam.Postgres+import qualified Database.Beam.Postgres.Full as Pg+import qualified Database.Beam.Query.CTE as CTE++data NegativeCteRowT f = NegativeCteRow+ { negativeCteId :: C f Int32+ , negativeCteValue :: C f Text+ } deriving (Generic, Beamable)++deriving instance Show (NegativeCteRowT Identity)+deriving instance Eq (NegativeCteRowT Identity)++instance Table NegativeCteRowT where+ data PrimaryKey NegativeCteRowT f = NegativeCteRowKey (C f Int32)+ deriving (Generic, Beamable)+ primaryKey = NegativeCteRowKey . negativeCteId++newtype NegativeCteDb entity = NegativeCteDb+ { negativeCteRows :: entity (TableEntity NegativeCteRowT)+ } deriving (Generic, Database Postgres)++negativeCteDb :: DatabaseSettings Postgres NegativeCteDb+negativeCteDb = defaultDbSettings++-- Each of the following three expressions attempts to put a modifying CTE in+-- pgSelectWithNested. They must fail with PgCteTopLevelOnly versus+-- PgCteNestedAllowed,+-- independently of which data-modifying command produced the CTE.+invalidNestedDelete :: SqlSelect Postgres (NegativeCteRowT Identity)+invalidNestedDelete = select $ Pg.pgSelectWithNested $ do+ deleted <- topLevelDeleteCte+ pure (reuse deleted)++invalidNestedInsert :: SqlSelect Postgres (NegativeCteRowT Identity)+invalidNestedInsert = select $ Pg.pgSelectWithNested $ do+ inserted <- Pg.cteInsertReturning+ (negativeCteRows negativeCteDb)+ (insertValues [NegativeCteRow 2 "inserted"])+ Pg.onConflictDefault+ id+ case inserted of+ Nothing -> pure $ all_ (negativeCteRows negativeCteDb)+ Just inserted' -> pure (reuse inserted')++invalidNestedUpdate :: SqlSelect Postgres (NegativeCteRowT Identity)+invalidNestedUpdate = select $ Pg.pgSelectWithNested $ do+ updated <- Pg.cteUpdateReturning+ (negativeCteRows negativeCteDb)+ (\row -> negativeCteValue row <-. val_ "updated")+ (\row -> negativeCteId row ==. val_ 1)+ id+ case updated of+ Nothing -> pure $ all_ (negativeCteRows negativeCteDb)+ Just updated' -> pure (reuse updated')++-- Placement is a property of the whole With block. Reordering a normal SELECT+-- CTE around the DELETE must not weaken the top-level-only requirement.+invalidNestedSelectThenDelete :: SqlSelect Postgres (NegativeCteRowT Identity)+invalidNestedSelectThenDelete = select $ Pg.pgSelectWithNested $ do+ _ <- nestedSelectCte+ deleted <- topLevelDeleteCte+ pure (reuse deleted)++invalidNestedDeleteThenSelect :: SqlSelect Postgres (NegativeCteRowT Identity)+invalidNestedDeleteThenSelect = select $ Pg.pgSelectWithNested $ do+ deleted <- topLevelDeleteCte+ _ <- nestedSelectCte+ pure (reuse deleted)++-- The result is conservatively top-level-only even when the supplied values or+-- assignments make the INSERT or UPDATE a no-op. The placement index cannot+-- vary with that value-level outcome.+invalidNestedEmptyInsert :: SqlSelect Postgres (NegativeCteRowT Identity)+invalidNestedEmptyInsert = select $ Pg.pgSelectWithNested $ do+ inserted <- Pg.cteInsertReturning+ (negativeCteRows negativeCteDb)+ SqlInsertValuesEmpty+ Pg.onConflictDefault+ id+ case inserted of+ Nothing -> pure $ all_ (negativeCteRows negativeCteDb)+ Just inserted' -> pure (reuse inserted')++invalidNestedIdentityUpdate :: SqlSelect Postgres (NegativeCteRowT Identity)+invalidNestedIdentityUpdate = select $ Pg.pgSelectWithNested $ do+ updated <- Pg.cteUpdateReturning+ (negativeCteRows negativeCteDb)+ (const mempty)+ (const (val_ True))+ id+ case updated of+ Nothing -> pure $ all_ (negativeCteRows negativeCteDb)+ Just updated' -> pure (reuse updated')++-- A no-RETURNING modifying CTE has the same top-level placement requirement as+-- its returning counterpart, even though it exposes no relation.+invalidNestedSideEffectDelete :: SqlSelect Postgres (NegativeCteRowT Identity)+invalidNestedSideEffectDelete = select $ Pg.pgSelectWithNested $ do+ Pg.cteDelete+ (negativeCteRows negativeCteDb)+ (\row -> negativeCteId row ==. val_ 1)+ pure $ all_ (negativeCteRows negativeCteDb)++-- PgWith has nominal roles and an abstract constructor, so Data.Coerce cannot+-- be used to relabel a top-level-only block as nested-safe.+invalidCoercedPlacement :: SqlSelect Postgres (NegativeCteRowT Identity)+invalidCoercedPlacement = select $ Pg.pgSelectWithNested $ coercePlacement $ do+ deleted <- topLevelDeleteCte+ pure (reuse deleted)++-- MonadFix exists only for PgCteNestedAllowed. This prevents an INSERT CTE from+-- reading its own RETURNING rows recursively, which PostgreSQL rejects.+invalidRecursiveInsert :: SqlSelect Postgres (NegativeCteRowT Identity)+invalidRecursiveInsert = Pg.pgSelectWithTopLevel $ mdo+ ~(Just inserted) <- Pg.cteInsertReturning+ (negativeCteRows negativeCteDb)+ (insertFrom (reuse inserted))+ Pg.onConflictDefault+ id+ pure (reuse inserted)++-- Side-effect-only CTEs deliberately return unit because a DML statement+-- without RETURNING forms no temporary relation in PostgreSQL.+invalidReuseSideEffect :: SqlSelect Postgres (NegativeCteRowT Identity)+invalidReuseSideEffect = Pg.pgSelectWithTopLevel $ do+ deleted <- Pg.cteDelete+ (negativeCteRows negativeCteDb)+ (\row -> negativeCteId row ==. val_ 1)+ let impossible+ :: ReusableQ Postgres NegativeCteDb+ (NegativeCteRowT (QExpr Postgres CTE.QAnyScope))+ impossible = deleted+ pure (reuse impossible)++coercePlacement+ :: Pg.PgWith NegativeCteDb 'Pg.PgCteTopLevelOnly a+ -> Pg.PgWith NegativeCteDb 'Pg.PgCteNestedAllowed a+coercePlacement = Coerce.coerce++nestedSelectCte+ :: Pg.PgWith NegativeCteDb placement+ (ReusableQ Postgres NegativeCteDb+ (NegativeCteRowT (QExpr Postgres CTE.QAnyScope)))+nestedSelectCte = Pg.pgSelecting $ all_ (negativeCteRows negativeCteDb)++topLevelDeleteCte+ :: Pg.PgWith NegativeCteDb 'Pg.PgCteTopLevelOnly+ (ReusableQ Postgres NegativeCteDb+ (NegativeCteRowT (QExpr Postgres CTE.QAnyScope)))+topLevelDeleteCte = Pg.cteDeleteReturning+ (negativeCteRows negativeCteDb)+ (\row -> negativeCteId row ==. val_ 1)+ id
+ test/Database/Beam/Postgres/Test/Copy.hs view
@@ -0,0 +1,444 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-}++module Database.Beam.Postgres.Test.Copy (tests) where++import Control.Monad (void)+import Control.Monad.IO.Class (liftIO)+import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import Data.IORef (modifyIORef', newIORef, readIORef, writeIORef)+import Data.Int (Int32)+import Data.List (sort)+import Data.Text (Text)+import qualified Data.Text as T+import Database.Beam+import Database.Beam.Backend.SQL.BeamExtensions+ ( MonadBeamCopyFrom (..),+ MonadBeamCopyFromStream (..),+ MonadBeamCopyTo (..),+ MonadBeamCopyToStream (..),+ copySelectTo,+ copySelectToStream,+ copyTableFrom,+ copyTableFromStream,+ copyTableTo,+ copyTableToStream,+ )+import Database.Beam.Postgres+import Database.Beam.Postgres.Test (withTestPostgres)+import Database.PostgreSQL.Simple (Connection, execute_)+import Hedgehog ((===))+import qualified Hedgehog+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (Assertion, assertBool, assertEqual, testCase)++tests :: IO ByteString -> TestTree+tests getConn =+ testGroup+ "COPY statements"+ [ testGroup+ "COPY ... TO / ... FROM round-trip"+ [ testRoundtripCsvAllColumns getConn,+ testRoundtripCsvMultiColumnProjection getConn,+ testRoundtripCsvSingleColumnProjection getConn,+ testRoundtripCsvFromSelect getConn+ ],+ testGroup+ "options"+ [ testCustomDelimiter getConn,+ testNoHeader getConn,+ testTextFormat getConn+ ],+ testGroup+ "streaming COPY"+ [ testStreamRoundtripCsv getConn,+ testStreamFromSelect getConn+ ],+ testGroup+ "property-based round-trip"+ [ testPropCsvRoundtrip getConn,+ testPropTextRoundtrip getConn+ ]+ ]++-- | The full table is exported to a CSV, the table is truncated, and the CSV+-- is re-imported. The final rows must match the original ones.+testRoundtripCsvAllColumns :: IO ByteString -> TestTree+testRoundtripCsvAllColumns getConn =+ testCopy getConn "copy_all_columns_csv" "/tmp/copy_all_columns.csv" $ \conn path -> do+ seedWidgets conn widgetData+ runBeamPostgres conn $ do+ runCopyTo $ copyTableTo (_dbWidgets testDb) id (copyToCSV path)+ truncateWidgets conn+ runBeamPostgres conn $ do+ runCopyFrom $ copyTableFrom (_dbWidgets testDb) id (copyFromCSV path)+ rows <- queryAllWidgets conn+ assertEqual "round-tripped rows match seed" widgetData rows++-- | Project a subset of columns; the unprojected column gets its DEFAULT on+-- import.+testRoundtripCsvMultiColumnProjection :: IO ByteString -> TestTree+testRoundtripCsvMultiColumnProjection getConn =+ testCopy getConn "copy_multi_column_csv" "/tmp/copy_multi_column.csv" $ \conn path -> do+ seedWidgets conn widgetData+ runBeamPostgres conn $ do+ runCopyTo $+ copyTableTo+ (_dbWidgets testDb)+ (\w -> (_widgetId w, _widgetName w))+ (copyToCSV path)+ truncateWidgets conn+ runBeamPostgres conn $ do+ runCopyFrom $+ copyTableFrom+ (_dbWidgets testDb)+ (\w -> (_widgetId w, _widgetName w))+ (copyFromCSV path)+ rows <- queryAllWidgets conn+ -- 'price' was not in the projection, so it gets its DEFAULT (0).+ let expected = [w {_widgetPrice = 0} | w <- widgetData]+ assertEqual "id+name round-tripped, price defaulted" expected rows++-- | Single-column projection.+testRoundtripCsvSingleColumnProjection :: IO ByteString -> TestTree+testRoundtripCsvSingleColumnProjection getConn =+ testCopy getConn "copy_single_column_csv" "/tmp/copy_single_column.csv" $ \conn path -> do+ seedWidgets conn widgetData+ runBeamPostgres conn $ do+ runCopyTo $ copyTableTo (_dbWidgets testDb) _widgetId (copyToCSV path)+ truncateWidgets conn+ runBeamPostgres conn $ do+ runCopyFrom $ copyTableFrom (_dbWidgets testDb) _widgetId (copyFromCSV path)+ rows <- queryAllWidgets conn+ let expected = [w {_widgetName = "", _widgetPrice = 0} | w <- widgetData]+ assertEqual "id-only round-tripped, name+price defaulted" expected rows++-- | Use copySelectTo with a filtered query, then COPY FROM the result back+-- into the table.+testRoundtripCsvFromSelect :: IO ByteString -> TestTree+testRoundtripCsvFromSelect getConn =+ testCopy getConn "copy_select_csv" "/tmp/copy_select.csv" $ \conn path -> do+ seedWidgets conn widgetData+ runBeamPostgres conn $ do+ runCopyTo $+ copySelectTo+ ( select $ do+ w <- all_ (_dbWidgets testDb)+ guard_ (_widgetPrice w >. val_ 4.0)+ pure w+ )+ (copyToCSV path)+ truncateWidgets conn+ runBeamPostgres conn $ do+ runCopyFrom $ copyTableFrom (_dbWidgets testDb) id (copyFromCSV path)+ rows <- queryAllWidgets conn+ -- Only Widget (9.99) and Sprocket (4.5) have price > 4.0; Cog is excluded.+ let expected = sort [w | w <- widgetData, _widgetPrice w > 4.0]+ assertEqual "select-filtered round-trip" expected rows++-- | Use a custom delimiter on both sides of the round-trip.+testCustomDelimiter :: IO ByteString -> TestTree+testCustomDelimiter getConn =+ testCopy getConn "copy_custom_delim_csv" "/tmp/copy_custom_delim.csv" $ \conn path -> do+ seedWidgets conn widgetData+ let toOpts = copyToCSVWith path defaultPgCSVCopyToOptions {pgCsvCopyToDelimiter = Just '|'}+ fromOpts = copyFromCSVWith path defaultPgCSVCopyFromOptions {pgCsvCopyFromDelimiter = Just '|'}+ runBeamPostgres conn $ do+ runCopyTo $ copyTableTo (_dbWidgets testDb) id toOpts+ truncateWidgets conn+ runBeamPostgres conn $ do+ runCopyFrom $ copyTableFrom (_dbWidgets testDb) id fromOpts+ rows <- queryAllWidgets conn+ assertEqual "round-trip with '|' delimiter" widgetData rows++-- | Toggle HEADER off on TO and on on FROM; round-trip should still work+-- (as long as both sides agree).+testNoHeader :: IO ByteString -> TestTree+testNoHeader getConn =+ testCopy getConn "copy_no_header_csv" "/tmp/copy_no_header.csv" $ \conn path -> do+ seedWidgets conn widgetData+ let toOpts = copyToCSVWith path defaultPgCSVCopyToOptions {pgCsvCopyToHeader = Just False}+ fromOpts = copyFromCSVWith path defaultPgCSVCopyFromOptions {pgCsvCopyFromHeader = Just False}+ runBeamPostgres conn $ do+ runCopyTo $ copyTableTo (_dbWidgets testDb) id toOpts+ truncateWidgets conn+ runBeamPostgres conn $ do+ runCopyFrom $ copyTableFrom (_dbWidgets testDb) id fromOpts+ rows <- queryAllWidgets conn+ assertEqual "round-trip without header line" widgetData rows++-- | The 'text' format with custom delimiter, round-tripped.+testTextFormat :: IO ByteString -> TestTree+testTextFormat getConn =+ testCopy getConn "copy_text_format" "/tmp/copy_text.txt" $ \conn path -> do+ seedWidgets conn widgetData+ let toOpts = copyToTextWith path defaultPgTextCopyToOptions {pgTextCopyToDelimiter = Just '\t'}+ fromOpts = copyFromTextWith path defaultPgTextCopyFromOptions {pgTextCopyFromDelimiter = Just '\t'}+ runBeamPostgres conn $ do+ runCopyTo $ copyTableTo (_dbWidgets testDb) id toOpts+ truncateWidgets conn+ runBeamPostgres conn $ do+ runCopyFrom $ copyTableFrom (_dbWidgets testDb) id fromOpts+ rows <- queryAllWidgets conn+ assertEqual "round-trip via text format" widgetData rows++-- | Round-trip widgets through streaming @COPY ... TO STDOUT@ then+-- @COPY ... FROM STDIN@. The bytes pass through the client connection only;+-- no server-side file is touched.+testStreamRoundtripCsv :: IO ByteString -> TestTree+testStreamRoundtripCsv getConn =+ testCopy getConn "stream_roundtrip_csv" "" $ \conn _ -> do+ seedWidgets conn widgetData+ -- Drain the stream into an IORef.+ chunksRef <- newIORef []+ runBeamPostgres conn $+ runCopyToStream+ (copyTableToStream (_dbWidgets testDb) id copyToCSVStream)+ (\chunk -> modifyIORef' chunksRef (chunk :))+ payload <- BS.concat . reverse <$> readIORef chunksRef+ assertBool "stream produced non-empty payload" (not (BS.null payload))+ -- Replay the captured bytes back into the table.+ truncateWidgets conn+ sourceRef <- newIORef (Just payload)+ runBeamPostgres conn $+ runCopyFromStream+ (copyTableFromStream (_dbWidgets testDb) id copyFromCSVStream)+ ( do+ mchunk <- readIORef sourceRef+ writeIORef sourceRef Nothing+ pure mchunk+ )+ rows <- queryAllWidgets conn+ assertEqual "round-tripped rows match seed" widgetData rows++-- | @COPY (SELECT ...) TO STDOUT@ via 'copySelectToStream'.+testStreamFromSelect :: IO ByteString -> TestTree+testStreamFromSelect getConn =+ testCopy getConn "stream_from_select" "" $ \conn _ -> do+ seedWidgets conn widgetData+ chunksRef <- newIORef []+ runBeamPostgres conn $+ runCopyToStream+ ( copySelectToStream+ ( select $ do+ w <- all_ (_dbWidgets testDb)+ guard_ (_widgetPrice w >. val_ 4.0)+ pure w+ )+ copyToCSVStream+ )+ (\chunk -> modifyIORef' chunksRef (chunk :))+ payload <- BS.concat . reverse <$> readIORef chunksRef+ -- The payload should mention the two widgets with price > 4.0 and not+ -- the one priced 1.25.+ assertBool "Widget present" ("Widget" `BS.isInfixOf` payload)+ assertBool "Sprocket present" ("Sprocket" `BS.isInfixOf` payload)+ assertBool "Cog absent" (not ("Cog" `BS.isInfixOf` payload))++testPropCsvRoundtrip :: IO ByteString -> TestTree+testPropCsvRoundtrip getConn =+ testCopy getConn "prop_csv_roundtrip" "/tmp/prop_csv.csv" $ \conn path -> do+ passes <-+ Hedgehog.check . Hedgehog.property $ do+ toOpts <- Hedgehog.forAll genCsvToOpts+ let fromOpts = matchedCsvFromOpts toOpts+ rows <-+ liftIO $+ roundtripWidgets conn $ \c -> do+ runBeamPostgres c $+ runCopyTo $+ copyTableTo (_dbWidgets testDb) id (copyToCSVWith path toOpts)+ truncateWidgets c+ runBeamPostgres c $+ runCopyFrom $+ copyTableFrom (_dbWidgets testDb) id (copyFromCSVWith path fromOpts)+ rows === widgetData+ assertBool "Hedgehog property failed" passes+ where+ genCsvToOpts = do+ delim <- Gen.maybe genDelimiterChar+ hdr <- Gen.maybe Gen.bool+ quote <- Gen.maybe genQuoteChar+ escape <- Gen.maybe genEscapeChar+ nullStr <- Gen.maybe genNullStr+ pure+ defaultPgCSVCopyToOptions+ { pgCsvCopyToDelimiter = delim,+ pgCsvCopyToHeader = hdr,+ pgCsvCopyToQuote = quote,+ pgCsvCopyToEscape = escape,+ pgCsvCopyToNullStr = nullStr+ }++ matchedCsvFromOpts :: PgCSVCopyToOptions -> PgCSVCopyFromOptions+ matchedCsvFromOpts o =+ defaultPgCSVCopyFromOptions+ { pgCsvCopyFromDelimiter = pgCsvCopyToDelimiter o,+ pgCsvCopyFromHeader = pgCsvCopyToHeader o,+ pgCsvCopyFromQuote = pgCsvCopyToQuote o,+ pgCsvCopyFromEscape = pgCsvCopyToEscape o,+ pgCsvCopyFromNullStr = pgCsvCopyToNullStr o+ }++testPropTextRoundtrip :: IO ByteString -> TestTree+testPropTextRoundtrip getConn =+ testCopy getConn "prop_text_roundtrip" "/tmp/prop_text.txt" $ \conn path -> do+ passes <-+ Hedgehog.check . Hedgehog.property $ do+ toOpts <- Hedgehog.forAll genTextToOpts+ let fromOpts = matchedTextFromOpts toOpts+ rows <-+ liftIO $+ roundtripWidgets conn $ \c -> do+ runBeamPostgres c $+ runCopyTo $+ copyTableTo (_dbWidgets testDb) id (copyToTextWith path toOpts)+ truncateWidgets c+ runBeamPostgres c $+ runCopyFrom $+ copyTableFrom (_dbWidgets testDb) id (copyFromTextWith path fromOpts)+ rows === widgetData+ assertBool "Hedgehog property failed" passes+ where+ genTextToOpts = do+ delim <- Gen.maybe genDelimiterChar+ hdr <- Gen.maybe Gen.bool+ -- Avoid generating a NULL string that contains the chosen delimiter.+ nullStr <- Gen.maybe (Gen.filter (not . T.any (== ',')) genNullStr)+ pure+ defaultPgTextCopyToOptions+ { pgTextCopyToDelimiter = delim,+ pgTextCopyToHeader = hdr,+ pgTextCopyToNullStr = nullStr+ }++ -- \| Mirror of 'matchedCsvFromOpts' for the @text@ format. 'pgTextCopyFromFreeze'+ -- is intentionally left at @Nothing@: PostgreSQL only accepts @FREEZE@ when+ -- the target table has not been touched in the current (sub)transaction, but+ -- our property test truncates before the FROM, which violates that+ -- precondition.+ matchedTextFromOpts :: PgTextCopyToOptions -> PgTextCopyFromOptions+ matchedTextFromOpts o =+ defaultPgTextCopyFromOptions+ { pgTextCopyFromDelimiter = pgTextCopyToDelimiter o,+ pgTextCopyFromHeader = pgTextCopyToHeader o,+ pgTextCopyFromNullStr = pgTextCopyToNullStr o+ }++-- Single-byte delimiters that never appear in 'widgetData'. Avoiding @.@+-- matters for the @text@ format because the data contains floating-point+-- prices like @9.99@.+genDelimiterChar :: Hedgehog.Gen Char+genDelimiterChar = Gen.element [',', ';', '|', '\t']++genQuoteChar :: Hedgehog.Gen Char+genQuoteChar = Gen.element ['"', '\'']++genEscapeChar :: Hedgehog.Gen Char+genEscapeChar = Gen.element ['"', '\'', '\\']++genNullStr :: Hedgehog.Gen Text+genNullStr = Gen.element ["NULL", "~~~"]++roundtripWidgets :: Connection -> (Connection -> IO ()) -> IO [Widget]+roundtripWidgets conn action = do+ truncateWidgets conn+ seedWidgets conn widgetData+ action conn+ queryAllWidgets conn++testCopy ::+ IO ByteString ->+ String ->+ -- | Server-side file path inside the Postgres container.+ FilePath ->+ (Connection -> FilePath -> Assertion) ->+ TestTree+testCopy getConn name path action = testCase name $+ withTestPostgres name getConn $ \conn -> do+ createWidgetsTable conn+ action conn path++queryAllWidgets :: Connection -> IO [Widget]+queryAllWidgets conn =+ runBeamPostgres conn $+ runSelectReturningList $+ select $+ orderBy_ (asc_ . _widgetId) $+ all_ (_dbWidgets testDb)++createWidgetsTable :: Connection -> IO ()+createWidgetsTable conn =+ void $+ execute_+ conn+ "CREATE TABLE widgets (\+ \ id INTEGER PRIMARY KEY,\+ \ name TEXT NOT NULL DEFAULT '',\+ \ price DOUBLE PRECISION NOT NULL DEFAULT 0\+ \)"++truncateWidgets :: Connection -> IO ()+truncateWidgets conn = void $ execute_ conn "TRUNCATE TABLE widgets"++seedWidgets :: Connection -> [Widget] -> IO ()+seedWidgets conn widgets =+ runBeamPostgres conn $+ runInsert $+ insert (_dbWidgets testDb) (insertValues widgets)++widgetData :: [Widget]+widgetData =+ [ Widget 1 "Widget" 9.99,+ Widget 2 "Sprocket" 4.50,+ Widget 3 "Cog" 1.25+ ]++data WidgetT f = Widget+ { _widgetId :: Columnar f Int32,+ _widgetName :: Columnar f Text,+ _widgetPrice :: Columnar f Double+ }+ deriving (Generic)++type Widget = WidgetT Identity++deriving instance Show Widget++deriving instance Eq Widget++deriving instance Ord Widget++instance Beamable WidgetT++instance Table WidgetT where+ data PrimaryKey WidgetT f = WidgetId (Columnar f Int32)+ deriving (Generic)+ primaryKey = WidgetId . _widgetId++instance Beamable (PrimaryKey WidgetT)++newtype TestDB f = TestDB+ { _dbWidgets :: f (TableEntity WidgetT)+ }+ deriving (Generic, Database be)++testDb :: DatabaseSettings Postgres TestDB+testDb =+ defaultDbSettings+ `withDbModification` dbModification+ { _dbWidgets =+ modifyTableFields+ tableModification+ { _widgetId = "id",+ _widgetName = "name",+ _widgetPrice = "price"+ }+ }
test/Database/Beam/Postgres/Test/DataTypes.hs view
@@ -3,15 +3,15 @@ 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.Migrate import Database.Beam.Postgres.Test-import Database.Beam.Migrate-import Database.Beam.Backend.SQL.BeamExtensions import Control.Exception (SomeException(..), handle) import Data.ByteString (ByteString)+import Data.Int import Data.Text (Text) import Test.Tasty@@ -21,16 +21,17 @@ tests postgresConn = testGroup "Data-type unit tests" [ jsonNulTest postgresConn- , errorOnSchemaMismatch postgresConn ]+ , errorOnSchemaMismatch postgresConn+ , errorOnLiteralDoubles postgresConn ] data JsonT f = JsonT- { _key :: C f Int+ { _key :: C f Int32 , _field1 :: C f (PgJSON String) } deriving (Generic, Beamable) instance Table JsonT where- data PrimaryKey JsonT f = JsonKey (C f Int)+ data PrimaryKey JsonT f = JsonKey (C f Int32) deriving (Generic, Beamable) primaryKey = JsonKey <$> _key @@ -39,7 +40,7 @@ { jsonTable :: entity (TableEntity JsonT) } deriving (Generic, Database Postgres) --- | Regression test for <https://github.com/tathougies/beam/issues/297 #297>+-- | Regression test for <https://github.com/haskell-beam/beam/issues/297 #297> jsonNulTest :: IO ByteString -> TestTree jsonNulTest pgConn = testCase "JSON NUL handling (#297)" $@@ -68,7 +69,7 @@ fmap (fmap (\(PgJSON v) -> v)) $ runSelectReturningList $ select $ fmap (\(JsonT _ v) -> v) $- orderBy_ (\(JsonT pk _) -> asc_ pk) $+ orderBy_ (\(JsonT k _) -> asc_ k) $ all_ (jsonTable db) readback @?= [ "hello\0world"@@ -81,23 +82,23 @@ return () data TblT f- = Tbl { _tblKey :: C f Int, _tblValue :: C f Text }+ = Tbl { _tblKey :: C f Int32, _tblValue :: C f Text } deriving (Generic, Beamable) deriving instance Show (TblT Identity) deriving instance Eq (TblT Identity) instance Table TblT where- data PrimaryKey TblT f = TblKey (C f Int)+ data PrimaryKey TblT f = TblKey (C f Int32) deriving (Generic, Beamable) primaryKey = TblKey <$> _tblKey data WrongTblT f- = WrongTbl { _wrongTblKey :: C f Int, _wrongTblValue :: C f Int }+ = WrongTbl { _wrongTblKey :: C f Int32, _wrongTblValue :: C f Int32 } deriving (Generic, Beamable) instance Table WrongTblT where- data PrimaryKey WrongTblT f = WrongTblKey (C f Int)+ data PrimaryKey WrongTblT f = WrongTblKey (C f Int32) deriving (Generic, Beamable) primaryKey = WrongTblKey <$> _wrongTblKey @@ -109,7 +110,7 @@ = WrongDb { _wrongTbl :: entity (TableEntity WrongTblT) } deriving (Generic, Database Postgres) --- | Regression test for <https://github.com/tathougies/beam/issues/112>+-- | Regression test for <https://github.com/haskell-beam/beam/issues/112> errorOnSchemaMismatch :: IO ByteString -> TestTree errorOnSchemaMismatch pgConn = testCase "runInsertReturningList should error on schema mismatch (#112)" $@@ -129,10 +130,27 @@ (WrongTbl (field "key" int notNull) (field "value" int notNull))) - didFail <- handle (\(e :: SomeException) -> pure True) $+ didFail <- handle (\(_ :: SomeException) -> pure True) $ runBeamPostgres conn $ do _ <- runInsertReturningList $ insert (_wrongTbl wrongDb) $ insertValues [ WrongTbl 4 23, WrongTbl 5 24, WrongTbl 6 24 ] pure False assertBool "runInsertReturningList succeeded" didFail didFail @?= True++-- | Regression test for <https://github.com/haskell-beam/beam/issues/700>+errorOnLiteralDoubles :: IO ByteString -> TestTree+errorOnLiteralDoubles pgConn =+ testCase "Literal `Double`s are correctly specified as SQL `DOUBLE` (#700)" $+ withTestPostgres "db_failures" pgConn $ \conn -> do+ 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)+ query = pure (val_ 99, val_ 1.0)
test/Database/Beam/Postgres/Test/Marshal.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE StandaloneDeriving #-} module Database.Beam.Postgres.Test.Marshal where import Database.Beam@@ -9,18 +10,16 @@ import Database.Beam.Postgres import Database.Beam.Postgres.Migrate (migrationBackend) import Database.Beam.Postgres.Test-import qualified Database.PostgreSQL.Simple as Pg+import Database.PostgreSQL.Simple (execute_) import Data.ByteString (ByteString) import Data.Functor.Classes import Data.Int-import Data.Proxy (Proxy(..))-import Data.Semigroup import qualified Data.Text as T-import qualified Data.Text.Lazy as TL import Data.Typeable import Data.UUID (UUID, fromWords) import Data.Word+import qualified Data.Vector as Vector import qualified Hedgehog import Hedgehog ((===))@@ -32,6 +31,10 @@ import Unsafe.Coerce ++textGen :: Hedgehog.Gen T.Text+textGen = Gen.text (Range.constant 0 1000) $ Gen.filter (/= '\NUL') Gen.unicode+ uuidGen :: Hedgehog.Gen UUID uuidGen = fromWords <$> Gen.integral Range.constantBounded <*> Gen.integral Range.constantBounded@@ -48,6 +51,10 @@ pure (PgBox (PgPoint (min x1 x2) (min y1 y2)) (PgPoint (max x1 x2) (max y1 y2))) +arrayGen :: Hedgehog.Gen a -> Hedgehog.Gen (Vector.Vector a)+arrayGen = fmap Vector.fromList+ . Gen.list (Range.linear 0 5) -- small arrays == quick tests+ boxCmp :: PgBox -> PgBox -> Bool boxCmp (PgBox a1 b1) (PgBox a2 b2) = (a1 `ptCmp` a2 && b1 `ptCmp` b2) ||@@ -72,7 +79,7 @@ , marshalTest (Gen.integral (Range.constantBounded @Word16)) postgresConn , marshalTest (Gen.integral (Range.constantBounded @Word32)) postgresConn , marshalTest (Gen.integral (Range.constantBounded @Word64)) postgresConn- , marshalTest (Gen.text (Range.constant 0 1000) Gen.unicode) postgresConn+ , marshalTest textGen postgresConn , marshalTest uuidGen postgresConn , marshalTest' (\a b -> Hedgehog.assert (ptCmp a b)) pointGen postgresConn@@ -85,14 +92,29 @@ , marshalTest (Gen.maybe (Gen.integral (Range.constantBounded @Word16))) postgresConn , marshalTest (Gen.maybe (Gen.integral (Range.constantBounded @Word32))) postgresConn , marshalTest (Gen.maybe (Gen.integral (Range.constantBounded @Word64))) postgresConn- , marshalTest (Gen.maybe (Gen.text (Range.constant 0 1000) Gen.unicode)) postgresConn+ , marshalTest (Gen.maybe textGen) postgresConn , marshalTest (Gen.maybe uuidGen) postgresConn , marshalTest' (\a b -> Hedgehog.assert (liftEq ptCmp a b)) (Gen.maybe pointGen) postgresConn , marshalTest' (\a b -> Hedgehog.assert (liftEq boxCmp a b)) (Gen.maybe boxGen) postgresConn --- , marshalTest (Gen.double (Range.exponentialFloat 0 1e40)) postgresConn--- , marshalTest (Gen.integral (Range.constantBounded @Word)) postgresConn+ -- Arrays+ --+ -- 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+ , marshalTest (arrayGen ((Gen.integral (Range.constantBounded @Int16)))) postgresConn+ , marshalTest (arrayGen ((Gen.integral (Range.constantBounded @Int32)))) postgresConn+ , marshalTest (arrayGen ((Gen.integral (Range.constantBounded @Int64)))) postgresConn+ , marshalTest (Gen.maybe (arrayGen textGen)) postgresConn+ , marshalTest (Gen.maybe (arrayGen (Gen.double (Range.exponentialFloat 0 1e40)))) postgresConn+ , marshalTest (Gen.maybe (arrayGen ((Gen.integral (Range.constantBounded @Int16))))) postgresConn+ , marshalTest (Gen.maybe (arrayGen ((Gen.integral (Range.constantBounded @Int32))))) postgresConn+ , marshalTest (Gen.maybe (arrayGen ((Gen.integral (Range.constantBounded @Int64))))) postgresConn++ , marshalTest (Gen.double (Range.exponentialFloat 0 1e40)) postgresConn -- , marshalTest (Gen.integral (Range.constantBounded @Int)) postgresConn -- , marshalTest @Int8 postgresConn@@ -104,13 +126,13 @@ data MarshalTable a f = MarshalTable- { _marshalTableId :: C f (SqlSerial Int)+ { _marshalTableId :: C f (SqlSerial Int32) , _marshalTableEntry :: C f a } deriving (Generic) instance Beamable (MarshalTable a) instance Typeable a => Table (MarshalTable a) where- data PrimaryKey (MarshalTable a) f = MarshalTableKey (C f (SqlSerial Int))+ data PrimaryKey (MarshalTable a) f = MarshalTableKey (C f (SqlSerial Int32)) deriving (Generic, Beamable) primaryKey = MarshalTableKey . _marshalTableId @@ -160,4 +182,3 @@ v' `cmp` a assertBool "Hedgehog test failed" passes-
test/Database/Beam/Postgres/Test/Migrate.hs view
@@ -1,15 +1,21 @@+{-# LANGUAGE LambdaCase #-} module Database.Beam.Postgres.Test.Migrate where import Database.Beam import Database.Beam.Postgres import Database.Beam.Postgres.Migrate+import Database.Beam.Postgres.PgCrypto (PgCrypto) import Database.Beam.Postgres.Test import Database.Beam.Migrate import Database.Beam.Migrate.Simple import Data.ByteString (ByteString)+import Data.Int (Int32)+import qualified Data.List.NonEmpty as NE import Data.Text (Text) +import qualified Database.PostgreSQL.Simple as Pg+ import Test.Tasty import Test.Tasty.HUnit @@ -20,6 +26,14 @@ , charNoWidthVerification postgresConn "VARCHAR" varchar , charWidthVerification postgresConn "CHAR" char , charNoWidthVerification postgresConn "CHAR" char+ , extensionVerification postgresConn+ , createTableWithSchemaWorks postgresConn+ , dropSchemaWorks postgresConn+ , indexVerification postgresConn+ , uniqueIndexVerification postgresConn+ , foreignKeyVerification postgresConn+ , foreignKeyOnDeleteCascadeVerification postgresConn+ , foreignKeyActionsWork postgresConn ] data CharT f@@ -37,6 +51,11 @@ { vcTbl :: entity (TableEntity CharT) } deriving (Generic, Database Postgres) +data CryptoDb entity+ = CryptoDb+ { cryptoExtension :: entity (PgExtensionEntity PgCrypto) }+ deriving (Generic, Database Postgres)+ -- | Verifies that 'verifySchema' correctly checks the width of -- @VARCHAR@ or @CHAR@ columns. charWidthVerification :: IO ByteString -> String -> (Maybe Word -> DataType Postgres Text) -> TestTree@@ -70,3 +89,237 @@ case res of VerificationSucceeded -> return () VerificationFailed failures -> fail ("Verification failed: " ++ show failures)++-- | Verifies that 'verifySchema' correctly checks enabled PgCrypto extension+extensionVerification :: IO ByteString -> TestTree+extensionVerification pgConn =+ testCase "verifySchema correctly checks enabled PgCrypto extension" $+ withTestPostgres "db_extension_pgcrypto" pgConn $ \conn ->+ runBeamPostgres conn $ do+ let migration = CryptoDb <$> pgCreateExtension+ dbBefore <- executeMigration (const $ return ()) migration+ resBefore <- verifySchema migrationBackend dbBefore+ case resBefore of+ VerificationSucceeded -> fail "Verification succeeded before migration when it should have failed"+ VerificationFailed _ -> return ()++ dbAfter <- executeMigration runNoReturn migration+ resAfter <- verifySchema migrationBackend dbAfter+ case resAfter of+ VerificationSucceeded -> return ()+ VerificationFailed failures -> fail ("Verification failed: " ++ show failures)+++-- | Verifies that 'createTableWithSchema' correctly creates a table+-- with a schema.+createTableWithSchemaWorks :: IO ByteString -> TestTree+createTableWithSchemaWorks pgConn =+ testCase ("createTableWithSchema works correctly") $ do+ withTestPostgres "create_table_with_schema" pgConn $ \conn -> do+ res <- runBeamPostgres conn $ do+ db <- executeMigration runNoReturn $ do+ internalSchema <- createDatabaseSchema "internal_schema"+ (CharDb <$> createTableWithSchema (Just internalSchema) "char_test"+ (CharT (field "key" (varchar Nothing) notNull)))++ verifySchema migrationBackend db++ case res of+ VerificationSucceeded -> return ()+ VerificationFailed failures -> fail ("Verification failed: " ++ show failures)+++-- | Verifies that creating a schema and dropping it works+dropSchemaWorks :: IO ByteString -> TestTree+dropSchemaWorks pgConn =+ testCase ("dropDatabaseSchema works correctly") $ do+ withTestPostgres "drop_schema" pgConn $ \conn -> do+ runBeamPostgres conn $ do+ db <- executeMigration runNoReturn $ do+ internalSchema <- createDatabaseSchema "internal_schema"+ willBeDroppedSchema <- createDatabaseSchema "will_be_dropped"+ db <- (CharDb <$> createTableWithSchema (Just internalSchema) "char_test"+ (CharT (field "key" (varchar Nothing) notNull)))+ dropDatabaseSchema willBeDroppedSchema+ pure db++ verifySchema migrationBackend db >>= \case+ VerificationFailed failures -> fail ("Verification failed: " ++ show failures)+ VerificationSucceeded -> pure ()++-- Shared table type for index tests++newtype IdxT f = IdxT+ { _idx_value :: C f Int32+ } deriving (Generic, Beamable)++instance Table IdxT where+ newtype PrimaryKey IdxT f = IdxPk (C f Int32)+ deriving (Generic, Beamable)+ primaryKey = IdxPk . _idx_value++data IdxDb entity = IdxDb+ { _idx_tbl :: entity (TableEntity IdxT)+ } deriving (Generic, Database Postgres)++-- | Verifies that 'verifySchema' correctly detects a secondary index+indexVerification :: IO ByteString -> TestTree+indexVerification pgConn =+ testCase "verifySchema correctly detects a secondary index" $+ withTestPostgres "db_index" pgConn $ \conn -> do+ Pg.execute_ conn "CREATE TABLE idx_tbl (idx_value integer NOT NULL PRIMARY KEY)"+ Pg.execute_ conn "CREATE INDEX idx_tbl_value ON idx_tbl (idx_value)"+ let db :: CheckedDatabaseSettings Postgres IdxDb+ db = defaultMigratableDbSettings `withDbModification`+ (dbModification @_ @Postgres)+ { _idx_tbl = addTableIndex "idx_tbl_value" (defaultIndexOptions @PgCommandSyntax)+ (\t -> selectorColumnName _idx_value t NE.:| []) }+ runBeamPostgres conn (verifySchema migrationBackend db) >>= \case+ VerificationSucceeded -> return ()+ VerificationFailed failures -> fail ("Verification failed: " ++ show failures)++-- | Verifies that 'verifySchema' correctly detects a UNIQUE secondary index+uniqueIndexVerification :: IO ByteString -> TestTree+uniqueIndexVerification pgConn =+ testCase "verifySchema correctly detects a UNIQUE secondary index" $+ withTestPostgres "db_unique_index" pgConn $ \conn -> do+ Pg.execute_ conn "CREATE TABLE idx_tbl (idx_value integer NOT NULL PRIMARY KEY)"+ Pg.execute_ conn "CREATE UNIQUE INDEX idx_tbl_value_uniq ON idx_tbl (idx_value)"+ let idxOpts = setUniqueIndexOptions @PgCommandSyntax True+ $ defaultIndexOptions @PgCommandSyntax+ db :: CheckedDatabaseSettings Postgres IdxDb+ db = defaultMigratableDbSettings `withDbModification`+ (dbModification @_ @Postgres)+ { _idx_tbl = addTableIndex "idx_tbl_value_uniq" idxOpts+ (\t -> selectorColumnName _idx_value t NE.:| []) }+ runBeamPostgres conn (verifySchema migrationBackend db) >>= \case+ VerificationSucceeded -> return ()+ VerificationFailed failures -> fail ("Verification failed: " ++ show failures)++-- Foreign key test tables++data FkParentT f = FkParentT+ { _fk_parent_id :: C f Int32+ } deriving (Generic, Beamable)++instance Table FkParentT where+ newtype PrimaryKey FkParentT f = FkParentPk (C f Int32)+ deriving (Generic, Beamable)+ primaryKey = FkParentPk . _fk_parent_id++data FkChildT f = FkChildT+ { _fk_child_id :: C f Int32+ , _fk_child_parent_id :: PrimaryKey FkParentT f+ } deriving (Generic, Beamable)++instance Table FkChildT where+ newtype PrimaryKey FkChildT f = FkChildPk (C f Int32)+ deriving (Generic, Beamable)+ primaryKey = FkChildPk . _fk_child_id++data FkDb entity = FkDb+ { _fk_parent :: entity (TableEntity FkParentT)+ , _fk_child :: entity (TableEntity FkChildT)+ } deriving (Generic, Database Postgres)++-- | Verifies that 'verifySchema' correctly detects a plain foreign key+foreignKeyVerification :: IO ByteString -> TestTree+foreignKeyVerification pgConn =+ testCase "verifySchema correctly detects a plain foreign key" $+ withTestPostgres "db_fk" pgConn $ \conn -> do+ Pg.execute_ conn "CREATE TABLE fk_parent (fk_parent_id integer NOT NULL PRIMARY KEY)"+ Pg.execute_ conn "CREATE TABLE fk_child (fk_child_id integer NOT NULL PRIMARY KEY, \+ \fk_child_parent_id integer NOT NULL, \+ \FOREIGN KEY (fk_child_parent_id) REFERENCES fk_parent (fk_parent_id))"+ let db :: CheckedDatabaseSettings Postgres FkDb+ db = defaultMigratableDbSettings `withDbModification`+ (dbModification @_ @Postgres)+ { _fk_child =+ addTableForeignKey (_fk_parent db)+ (foreignKeyColumns _fk_child_parent_id)+ primaryKeyColumns+ ForeignKeyNoAction+ ForeignKeyNoAction+ <> modifyCheckedTable id+ (FkChildT { _fk_child_id = "fk_child_id"+ , _fk_child_parent_id = FkParentPk "fk_child_parent_id" }) }+ runBeamPostgres conn (verifySchema migrationBackend db) >>= \case+ VerificationSucceeded -> return ()+ VerificationFailed failures -> fail ("Verification failed: " ++ show failures)++-- | Verifies that foreign key actions are enforced at runtime.+foreignKeyActionsWork :: IO ByteString -> TestTree+foreignKeyActionsWork pgConn =+ testCase "cascading foreign key actions" $+ withTestPostgres "db_fk_actions" pgConn $ \conn -> do+ let db :: CheckedDatabaseSettings Postgres FkDb+ db = defaultMigratableDbSettings `withDbModification`+ (dbModification @_ @Postgres)+ { _fk_child =+ addTableForeignKey (_fk_parent db)+ (foreignKeyColumns _fk_child_parent_id)+ primaryKeyColumns+ ForeignKeyActionCascade+ ForeignKeyActionCascade+ }+ unc = unCheckDatabase db+ runBeamPostgres conn $ autoMigrate migrationBackend db++ -- Insert two parents and three children (two for parent 1, one for parent 2).+ runBeamPostgres conn $ do+ runInsert $ insert (_fk_parent unc) $ insertValues+ [ FkParentT 1, FkParentT 2 ]+ runInsert $ insert (_fk_child unc) $ insertValues+ [ FkChildT 1 (FkParentPk 1), FkChildT 2 (FkParentPk 1), FkChildT 3 (FkParentPk 2) ]++ -- ON UPDATE CASCADE: changing fk_parent_id 1 → 10 should cascade to child rows.+ runBeamPostgres conn $+ runUpdate $ update (_fk_parent unc)+ (\p -> _fk_parent_id p <-. val_ 10)+ (\p -> _fk_parent_id p ==. val_ 1)+ childrenOf10 <- runBeamPostgres conn $ runSelectReturningList $ select $+ filter_ (\c -> let FkParentPk pid = _fk_child_parent_id c in pid ==. val_ 10) $ all_ (_fk_child unc)+ assertEqual "two children should now reference updated parent id 10"+ 2 (length childrenOf10)+ childrenOf1 <- runBeamPostgres conn $ runSelectReturningList $ select $+ filter_ (\c -> let FkParentPk pid = _fk_child_parent_id c in pid ==. val_ 1) $ all_ (_fk_child unc)+ assertEqual "no children should still reference old parent id 1"+ 0 (length childrenOf1)++ -- ON DELETE CASCADE: deleting parent 2 should remove its child row.+ runBeamPostgres conn $+ runDelete $ delete (_fk_parent unc) (\p -> _fk_parent_id p ==. val_ 2)+ childrenOf2 <- runBeamPostgres conn $ runSelectReturningList $ select $+ filter_ (\c -> let FkParentPk pid = _fk_child_parent_id c in pid ==. val_ 2) $ all_ (_fk_child unc)+ assertEqual "child of deleted parent 2 should be removed"+ 0 (length childrenOf2)+ allChildren <- runBeamPostgres conn $ runSelectReturningList $ select $+ all_ (_fk_child unc)+ assertEqual "only the two children of parent 10 should remain"+ 2 (length allChildren)++-- | Verifies that 'verifySchema' correctly detects a foreign key with ON DELETE CASCADE+foreignKeyOnDeleteCascadeVerification :: IO ByteString -> TestTree+foreignKeyOnDeleteCascadeVerification pgConn =+ testCase "verifySchema correctly detects a foreign key with ON DELETE CASCADE" $+ withTestPostgres "db_fk_cascade" pgConn $ \conn -> do+ Pg.execute_ conn "CREATE TABLE fk_parent (fk_parent_id integer NOT NULL PRIMARY KEY)"+ Pg.execute_ conn "CREATE TABLE fk_child (fk_child_id integer NOT NULL PRIMARY KEY, \+ \fk_child_parent_id integer NOT NULL, \+ \FOREIGN KEY (fk_child_parent_id) REFERENCES fk_parent (fk_parent_id) \+ \ON DELETE CASCADE)"+ let db :: CheckedDatabaseSettings Postgres FkDb+ db = defaultMigratableDbSettings `withDbModification`+ (dbModification @_ @Postgres)+ { _fk_child =+ addTableForeignKey (_fk_parent db)+ (foreignKeyColumns _fk_child_parent_id)+ primaryKeyColumns+ ForeignKeyNoAction+ ForeignKeyActionCascade+ <> modifyCheckedTable id+ (FkChildT { _fk_child_id = "fk_child_id"+ , _fk_child_parent_id = FkParentPk "fk_child_parent_id" }) }+ runBeamPostgres conn (verifySchema migrationBackend db) >>= \case+ VerificationSucceeded -> return ()+ VerificationFailed failures -> fail ("Verification failed: " ++ show failures)
test/Database/Beam/Postgres/Test/Select.hs view
@@ -1,36 +1,272 @@-module Database.Beam.Postgres.Test.Select where+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE StandaloneDeriving #-} -import Database.Beam-import Database.Beam.Backend.SQL-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 qualified Database.PostgreSQL.Simple as Pg+module Database.Beam.Postgres.Test.Select (tests) where +import Data.Aeson import Data.ByteString (ByteString)-import Data.Functor.Classes+import Data.List.NonEmpty (NonEmpty(..)) import Data.Int-import Data.Proxy (Proxy(..))-import Data.Semigroup+import Data.List (sort) import qualified Data.Text as T-import qualified Data.Text.Lazy as TL-import Data.Typeable-import Data.UUID (UUID, fromWords)-import Data.Word--import qualified Hedgehog-import Hedgehog ((===))-import qualified Hedgehog.Gen as Gen-import qualified Hedgehog.Range as Range-+import qualified Data.Vector as V import Test.Tasty import Test.Tasty.HUnit+import Data.UUID (UUID, nil)+import qualified Data.UUID.V5 as V5+import Database.PostgreSQL.Simple (execute_) -import Unsafe.Coerce+import Database.Beam+import Database.Beam.Backend.SQL.SQL92+import Database.Beam.Migrate+import Database.Beam.Postgres+import Database.Beam.Postgres.Extensions.UuidOssp +import Database.Beam.Postgres.Test+ tests :: IO ByteString -> TestTree-tests postgresConn =- testGroup "Postgres Select Tests" []+tests getConn = testGroup "Selection Tests"+ [ testGroup "JSON"+ [ testPgArrayToJSON getConn+ ]+ , testGroup "ARRAY functions"+ [ testArrayReplace getConn+ , testArrayShuffle getConn+ , testArraySample getConn+ , testArrayToStringBasic getConn+ , testArrayToStringWithNull getConn+ , testArrayAppend getConn+ , testArrayPrepend getConn+ , testArrayRemove getConn+ ]+ , testGroup "UUID"+ [ testUuidFunction getConn "uuid_nil" $ \ext -> pgUuidNil ext+ , testUuidFunction getConn "uuid_ns_dns" $ \ext -> pgUuidNsDns ext+ , testUuidFunction getConn "uuid_ns_url" $ \ext -> pgUuidNsUrl ext+ , testUuidFunction getConn "uuid_ns_oid" $ \ext -> pgUuidNsOid ext+ , testUuidFunction getConn "uuid_ns_x500" $ \ext -> pgUuidNsX500 ext+ , testUuidFunction getConn "uuid_generate_v1" $ \ext ->+ pgUuidGenerateV1 ext+ , testUuidFunction getConn "uuid_generate_v1mc" $ \ext ->+ pgUuidGenerateV1Mc ext+ , testUuidFunction getConn "uuid_generate_v3" $ \ext ->+ pgUuidGenerateV3 ext (val_ nil) "nil"+ , testUuidFunction getConn "uuid_generate_v4" $ \ext ->+ pgUuidGenerateV4 ext+ , testUuidFunction getConn "uuid_generate_v5" $ \ext ->+ pgUuidGenerateV5 ext (val_ nil) "nil"+ , testUuuidInValues getConn+ ]+ , testInRowValues getConn+ , testInSelect getConn+ , testReturningMany getConn+ , testPgUnnest getConn+ , testFieldsCacheStale getConn+ ]++testPgArrayToJSON :: IO ByteString -> TestTree+testPgArrayToJSON getConn = testFunction getConn "array_to_json" $ \conn -> do+ let values :: [Int32] = [1, 2, 3]+ actual :: [PgJSON Value] <-+ runBeamPostgres conn $ runSelectReturningList $ select $+ return $ pgArrayToJson $ val_ $ V.fromList values+ assertEqual "JSON list" [PgJSON $ toJSON values] actual++testArrayReplace :: IO ByteString -> TestTree+testArrayReplace getConn = testFunction getConn "array_replace" $ \conn -> do+ let arr = V.fromList [1::Int32,2,5,4]+ res <- runBeamPostgres conn $ runSelectReturningList $ select $ do+ pure $ arrayReplace_ (val_ arr) (val_ (5::Int32)) (val_ (3::Int32))+ assertEqual "array_replace" [V.fromList [1,2,3,4 :: Int32]] res++testArrayShuffle :: IO ByteString -> TestTree+testArrayShuffle getConn = testFunction getConn "array_shuffle" $ \conn -> do+ let arr = V.fromList [1::Int32,2,3,4,5]+ res <- runBeamPostgres conn $ runSelectReturningList $ select $ do+ pure $ arrayShuffle_ (val_ arr)+ -- shuffled result has same length and elements, order may change+ case res of+ [shuf] -> do+ assertEqual "length" (V.length arr) (V.length shuf)+ assertBool "is permutation"+ (sort (V.toList arr) == sort (V.toList shuf))+ _ -> assertFailure "unexpected result"++testArraySample :: IO ByteString -> TestTree+testArraySample getConn = testFunction getConn "array_sample" $ \conn -> do+ let arr = V.fromList [1::Int32,2,3,4,5,6]+ res <- runBeamPostgres conn $ runSelectReturningList $ select $ do+ pure $ arraySample_ (val_ arr) (val_ (3::Int32))+ case res of+ [samp] -> do+ assertEqual "length 3" 3 (V.length samp)+ assertBool "subset" (V.all (`V.elem` arr) samp)+ _ -> assertFailure "unexpected result"++testArrayToStringBasic :: IO ByteString -> TestTree+testArrayToStringBasic getConn = testFunction getConn "array_to_string_basic" $ \conn -> do+ let arr = V.fromList [1::Int32,2,3]+ res <- runBeamPostgres conn $ runSelectReturningList $ select $ do+ pure $ arrayToString_ (val_ arr) (val_ ",")+ assertEqual "join" ["1,2,3" :: T.Text] res++testArrayToStringWithNull :: IO ByteString -> TestTree+testArrayToStringWithNull getConn = testFunction getConn "array_to_string_with_null" $ \conn -> do+ let arr :: V.Vector (Maybe T.Text)+ arr = V.fromList [Just "a", Nothing, Just "b"]+ res <- runBeamPostgres conn $ runSelectReturningList $ select $ do+ pure $ arrayToStringWithNull_ (val_ arr) (val_ "-") (val_ "*")+ assertEqual "join with null" ["a-*-b" :: T.Text] res++testArrayAppend :: IO ByteString -> TestTree+testArrayAppend getConn = testFunction getConn "array_append" $ \conn -> do+ let arr = V.fromList [1::Int32,2]+ res <- runBeamPostgres conn $ runSelectReturningList $ select $ do+ pure $ arrayAppend_ (val_ arr) (val_ (3::Int32))+ assertEqual "append" [V.fromList [1,2,3 :: Int32]] res++testArrayPrepend :: IO ByteString -> TestTree+testArrayPrepend getConn = testFunction getConn "array_prepend" $ \conn -> do+ let arr = V.fromList [2::Int32,3]+ res <- runBeamPostgres conn $ runSelectReturningList $ select $ do+ pure $ arrayPrepend_ (val_ (1::Int32)) (val_ arr)+ assertEqual "prepend" [V.fromList [1,2,3 :: Int32]] res++testArrayRemove :: IO ByteString -> TestTree+testArrayRemove getConn = testFunction getConn "array_remove" $ \conn -> do+ let arr = V.fromList [1::Int32,2,3,2]+ res <- runBeamPostgres conn $ runSelectReturningList $ select $ do+ pure $ arrayRemove_ (val_ arr) (val_ (2::Int32))+ assertEqual "remove" [V.fromList [1,3 :: Int32]] res++data UuidSchema f = UuidSchema+ { _uuidOssp :: f (PgExtensionEntity UuidOssp)+ } deriving (Generic, Database Postgres)++testUuidFunction+ :: IO ByteString+ -> String+ -> (forall s. UuidOssp -> QExpr Postgres s UUID)+ -> TestTree+testUuidFunction getConn name mkUuid = testFunction getConn name $ \conn ->+ runBeamPostgres conn $ do+ db <- executeMigration runNoReturn $ UuidSchema <$>+ pgCreateExtension @UuidOssp+ [_] <- runSelectReturningList $ select $+ return $ mkUuid $ getPgExtension $ _uuidOssp $ unCheckDatabase db+ return ()++-- | Regression test for <https://github.com/haskell-beam/beam/issues/555 #555>+testUuuidInValues :: IO ByteString -> TestTree+testUuuidInValues getConn = testCase "UUID in values_ works" $+ withTestPostgres "uuid_values" getConn $ \conn -> do+ result <- runBeamPostgres conn $ do+ db <- executeMigration runNoReturn $ UuidSchema <$>+ pgCreateExtension @UuidOssp+ let ext = getPgExtension $ _uuidOssp $ unCheckDatabase db+ runSelectReturningList $ select $ do+ v <- values_ (val_ nil :| [])+ return $ pgUuidGenerateV5 ext v ""+ assertEqual "result" [V5.generateNamed nil []] result++data Pair f = Pair+ { _left :: C f Bool+ , _right :: C f Bool+ } deriving (Generic, Beamable)++testInRowValues :: IO ByteString -> TestTree+testInRowValues getConn = testCase "IN with row values works" $+ withTestPostgres "db_in_row_values" getConn $ \conn -> do+ result <- runBeamPostgres conn $ runSelectReturningList $ select $ do+ let pair :: forall ctx s. Pair (QGenExpr ctx Postgres s)+ pair = val_ $ Pair False False+ return $ pair `in_` [pair, pair]+ assertEqual "result" [True] result++testInSelect :: IO ByteString -> TestTree+testInSelect getConn = testCase "IN (SELECT ...) works" $+ withTestPostgres "db_in_row_values" getConn $ \conn -> do+ result <- runBeamPostgres conn $ runSelectReturningList $ select $ do+ let x = as_ @Int32 (val_ 1)+ return $ x `inQuery_` ( pgUnnestArray $ array_ $ (as_ @Int32 . val_) <$> [0..100])+ assertEqual "result" [True] result++testReturningMany :: IO ByteString -> TestTree+testReturningMany getConn = testCase "runReturningMany (batching via cursor) works" $+ withTestPostgres "run_returning_many_cursor" getConn $ \conn -> do+ result <- runBeamPostgres conn $ runSelectReturningMany+ (select $ pgUnnestArray $ array_ $ (as_ @Int32 . val_) <$> [0..rowCount - 1])+ (\fetch ->+ let count n = fetch >>= \case+ Nothing -> pure n+ Just _ -> count (n + 1)+ in count 0)+ assertEqual "result" rowCount result+ where+ rowCount = 500+ runSelectReturningMany ::+ (FromBackendRow Postgres x) =>+ SqlSelect Postgres x -> (Pg (Maybe x) -> Pg a) -> Pg a+ runSelectReturningMany (SqlSelect s) =+ runReturningMany (selectCmd s)++-- Tables for fieldsCache regression test (PR #797).+-- AlphaT has a Text column; BetaT has an Int32 column.+-- Querying both within a single runBeamPostgres call exposes the+-- stale-cache bug: the second query gets field OID metadata from the+-- first (text OID 25 instead of int4 OID 23), causing a type mismatch.++data AlphaT f = Alpha { alphaName :: C f T.Text } deriving (Generic, Beamable)++instance Table AlphaT where+ data PrimaryKey AlphaT f = AlphaPk (C f T.Text) deriving (Generic, Beamable)+ primaryKey = AlphaPk . alphaName++data BetaT f = Beta { betaValue :: C f Int32 } deriving (Generic, Beamable)++instance Table BetaT where+ data PrimaryKey BetaT f = BetaPk (C f Int32) deriving (Generic, Beamable)+ primaryKey = BetaPk . betaValue++data FieldsCacheDb e = FieldsCacheDb+ { dbAlpha :: e (TableEntity AlphaT)+ , dbBeta :: e (TableEntity BetaT)+ } deriving (Generic, Database Postgres)++fieldsCacheDb :: DatabaseSettings Postgres FieldsCacheDb+fieldsCacheDb = defaultDbSettings++-- | Regression test for the fieldsCache bug introduced in PR #797.+-- withPgDebug keeps a per-invocation IORef (Maybe (Vector Field)).+-- The cache hit arm (Just fs -> pure fs) never validates against the+-- current Pg.Result, so the second SELECT in one runBeamPostgres call+-- inherits stale OID metadata from the first, producing a type-mismatch+-- error when the two queries return different column types.+testFieldsCacheStale :: IO ByteString -> TestTree+testFieldsCacheStale getConn =+ testCase "fieldsCache is not reused across queries with different schemas" $+ withTestPostgres "fields_cache_stale" getConn $ \conn -> do+ execute_ conn "CREATE TABLE alpha (name TEXT NOT NULL)"+ execute_ conn "CREATE TABLE beta (value INT4 NOT NULL)"+ execute_ conn "INSERT INTO alpha VALUES ('hello')"+ execute_ conn "INSERT INTO beta VALUES (42)"+ (names, values) <- runBeamPostgres conn $ do+ ns <- runSelectReturningList $ select $ all_ (dbAlpha fieldsCacheDb)+ vs <- runSelectReturningList $ select $ all_ (dbBeta fieldsCacheDb)+ pure (ns, vs)+ assertEqual "alpha rows" ["hello" :: T.Text] (alphaName <$> names)+ assertEqual "beta rows" [42 :: Int32] (betaValue <$> values)++testFunction :: IO ByteString -> String -> (Connection -> Assertion) -> TestTree+testFunction getConn name mkAssertion = testCase name $+ withTestPostgres name getConn mkAssertion++-- | Regression test for <https://github.com/haskell-beam/beam/issues/541 #541>+testPgUnnest :: IO ByteString -> TestTree+testPgUnnest getConn = testCase "pgUnnest works" $+ withTestPostgres "pg_unnest" getConn $ \conn -> do+ let values = [Bool True, Number 1]+ result <- runBeamPostgres conn $ runSelectReturningList $ select $+ pgUnnest $ pgJsonArrayElements $ val_ $+ PgJSONB $ Array $ V.fromList values+ assertEqual "result" (PgJSONB <$> values) $ pgJsonElement <$> result
+ test/Database/Beam/Postgres/Test/Select/PgNubBy.hs view
@@ -0,0 +1,119 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE StandaloneDeriving #-}++module Database.Beam.Postgres.Test.Select.PgNubBy (tests) where++import Control.Monad (void)+import Data.ByteString (ByteString)+import Data.Int (Int32)+import Data.Text (Text)+import Data.Time.Calendar (Day, fromGregorian)+import Database.Beam+import Database.Beam.Migrate (defaultMigratableDbSettings)+import Database.Beam.Migrate.Simple (autoMigrate)+import Database.Beam.Postgres+import Database.Beam.Postgres.Migrate (migrationBackend)+import Database.Beam.Postgres.Test (withTestPostgres)+import Test.Tasty+import Test.Tasty.HUnit++tests :: IO ByteString -> TestTree+tests getConn =+ testGroup+ "pgNubBy_ / nub_ with window functions (issue #746)"+ [ testPgNubByWithLead getConn,+ testNubWithLead getConn+ ]++-- Reproducer for issue #746+testPgNubByWithLead :: IO ByteString -> TestTree+testPgNubByWithLead getConn = testCase "pgNubBy_ feeding lead1_" $+ withTestPostgres "issue_746_pg_nub_by" getConn $ \conn -> do+ setupDb conn+ results <-+ runBeamPostgres conn $+ runSelectReturningList $+ select $+ withWindow_+ (\vf -> frame_ noPartition_ (orderPartitionBy_ (asc_ vf)) noBounds_)+ (\vf w -> (vf, lead1_ vf `over_` w))+ (pgNubBy_ id (validFrom <$> all_ (persons db)))++ let expected =+ [ (day 2025 1 1, Just (day 2025 1 2)),+ (day 2025 1 2, Just (day 2025 1 3)),+ (day 2025 1 3, Nothing)+ ]+ assertEqual "lead1_ over pgNubBy_ should pair each distinct date with the next" expected results++-- Reproducer for issue #746 with @nub_@+testNubWithLead :: IO ByteString -> TestTree+testNubWithLead getConn = testCase "nub_ feeding lead1_" $+ withTestPostgres "issue_746_nub" getConn $ \conn -> do+ setupDb conn+ results <-+ runBeamPostgres conn $+ runSelectReturningList $+ select $+ withWindow_+ (\vf -> frame_ noPartition_ (orderPartitionBy_ (asc_ vf)) noBounds_)+ (\vf w -> (vf, lead1_ vf `over_` w))+ (nub_ (validFrom <$> all_ (persons db)))++ let expected =+ [ (day 2025 1 1, Just (day 2025 1 2)),+ (day 2025 1 2, Just (day 2025 1 3)),+ (day 2025 1 3, Nothing)+ ]+ assertEqual "lead1_ over nub_ should pair each distinct date with the next" expected results++data PersonT f = Person+ { name :: C f Text,+ validFrom :: C f Day,+ idx :: C f Int32+ }+ deriving (Generic)++type Person = PersonT Identity++deriving instance Show Person++deriving instance Eq Person++instance Beamable PersonT++instance Table PersonT where+ data PrimaryKey PersonT f = PersonKey (C f Text)+ deriving stock (Generic)+ deriving anyclass (Beamable)++ primaryKey Person {name} = PersonKey name++newtype Db f = Db+ { persons :: f (TableEntity PersonT)+ }+ deriving (Generic)++instance Database Postgres Db++db :: DatabaseSettings Postgres Db+db = defaultDbSettings++day :: Integer -> Int -> Int -> Day+day = fromGregorian++seedRows :: [Person]+seedRows =+ [ Person "A" (day 2025 1 1) 1,+ Person "B" (day 2025 1 1) 1,+ Person "C" (day 2025 1 2) 2,+ Person "D" (day 2025 1 2) 2,+ Person "E" (day 2025 1 3) 3,+ Person "F" (day 2025 1 3) 3+ ]++setupDb :: Connection -> IO ()+setupDb conn = runBeamPostgres conn $ do+ void $ autoMigrate migrationBackend (defaultMigratableDbSettings @Postgres @Db)+ runInsert $ insert (persons db) $ insertValues seedRows
+ test/Database/Beam/Postgres/Test/TempTable.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StandaloneDeriving #-}++module Database.Beam.Postgres.Test.TempTable (tests) where++import Data.ByteString (ByteString)+import Data.Int (Int32)+import Data.Kind (Type)+import GHC.Exts (Any)++import Database.Beam+import Database.Beam.Postgres+import Database.PostgreSQL.Simple (execute_)++import Test.Tasty+import Test.Tasty.HUnit++import Database.Beam.Postgres.Test++tests :: IO ByteString -> TestTree+tests getConn = testGroup "Temporary table tests"+ [ testStageFilteredRows getConn+ , testDropAndCreate getConn+ ]++-- | A permanent table of items.+data ItemT f = Item+ { itemId :: C f Int32+ , itemValue :: C f Int32+ } deriving (Generic, Beamable)++deriving instance Show (ItemT Identity)+deriving instance Eq (ItemT Identity)++instance Table ItemT where+ data PrimaryKey ItemT f = ItemKey (C f Int32)+ deriving (Generic, Beamable)+ primaryKey = ItemKey . itemId++data ItemDb entity = ItemDb+ { dbItems :: entity (TableEntity ItemT)+ } deriving (Generic, Database Postgres)++itemDb :: DatabaseSettings be ItemDb+itemDb = defaultDbSettings++-- | Stage a filtered subset of a permanent table in a temp table using+-- INSERT INTO temp SELECT ... FROM permanent WHERE ..., then read it back.+testStageFilteredRows :: IO ByteString -> TestTree+testStageFilteredRows getConn = testCase "sanity test" $+ withTestPostgres "temp_table_stage" getConn $ \conn -> do+ execute_ conn "CREATE TABLE items (id INT PRIMARY KEY, value INT NOT NULL)"+ result <- runBeamPostgres conn $ do+ runInsert $ insert (dbItems itemDb) $ insertValues+ [ Item 1 5, Item 2 10, Item 3 15, Item 4 20, Item 5 25 ]+ scratch <- runCreateTempTable @_ @Any @ItemT+ defaultTempTableOptions "high_value_items"+ runInsert $ insert scratch $ insertFrom $+ filter_ (\r -> itemValue r >. val_ 15) $+ all_ (dbItems itemDb)+ runSelectReturningList $ select $+ orderBy_ (asc_ . itemId) $ all_ scratch+ assertEqual "high-value items staged" [Item 4 20, Item 5 25] result++testDropAndCreate :: IO ByteString -> TestTree+testDropAndCreate getConn = testCase "drop-and-create" $+ withTestPostgres "temp_table_drop_and_create" getConn $ \conn -> do+ execute_ conn "CREATE TABLE items (id INT PRIMARY KEY, value INT NOT NULL)"+ result <- runBeamPostgres conn $ do+ runInsert $ insert (dbItems itemDb) $ insertValues+ [ Item 1 5, Item 2 10, Item 3 15, Item 4 20, Item 5 25 ]+ -- First pass: stage low-value items.+ scratch <- runCreateTempTable @_ @Any @ItemT+ defaultTempTableOptions "scratch"+ runInsert $ insert scratch $ insertFrom $+ filter_ (\r -> itemValue r <=. val_ 15) $+ all_ (dbItems itemDb)+ -- Second pass: drop and recreate, then stage high-value items only.+ scratch' <- runCreateTempTable @_ @Any @ItemT+ (defaultTempTableOptions { tempTableCreateMode = DropAndCreate })+ "scratch"+ runInsert $ insert scratch' $ insertFrom $+ filter_ (\r -> itemValue r >. val_ 15) $+ all_ (dbItems itemDb)+ runSelectReturningList $ select $+ orderBy_ (asc_ . itemId) $ all_ scratch'+ assertEqual "only high-value items after reset" [Item 4 20, Item 5 25] result
+ test/Database/Beam/Postgres/Test/Windowing.hs view
@@ -0,0 +1,221 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE StandaloneDeriving #-}++module Database.Beam.Postgres.Test.Windowing (tests) where++import Database.Beam+import Database.Beam.Backend.SQL.BeamExtensions+import Database.Beam.Migrate+import Database.Beam.Migrate.Simple (autoMigrate)+import Database.Beam.Postgres+import Database.Beam.Postgres.Migrate (migrationBackend)+import Database.Beam.Postgres.Test++import Control.Exception (SomeException (..), handle)++import Data.ByteString (ByteString)+import Data.Int+import Data.Text (Text)++import Control.Monad (void)+import Test.Tasty+import Test.Tasty.HUnit++tests :: IO ByteString -> TestTree+tests postgresConn =+ testGroup+ "Windowing unit tests"+ [ testLead1 postgresConn+ , testLag1 postgresConn+ , testLead postgresConn+ , testLag postgresConn+ , testLeadWithDefault postgresConn+ , testLagWithDefault postgresConn+ ]++testLead1 :: IO ByteString -> TestTree+testLead1 = testCase "lead1_" . windowingQueryTest query expectation+ where+ query =+ withWindow_+ ( \Person{name} ->+ frame_+ noPartition_+ (orderPartitionBy_ (asc_ name))+ noBounds_+ )+ ( \Person{name} w ->+ (name, lead1_ name `over_` w)+ )+ (all_ $ persons db)+ expectation = [("Alice", Just "Bob"), ("Bob", Just "Claire"), ("Claire", Nothing)]++testLag1 :: IO ByteString -> TestTree+testLag1 = testCase "lag1_" . windowingQueryTest query expectation+ where+ query =+ withWindow_+ ( \Person{name} ->+ frame_+ noPartition_+ (orderPartitionBy_ (asc_ name))+ noBounds_+ )+ ( \Person{name} w ->+ (name, lag1_ name `over_` w)+ )+ (all_ $ persons db)+ expectation = [("Alice", Nothing), ("Bob", Just "Alice"), ("Claire", Just "Bob")]++testLead :: IO ByteString -> TestTree+testLead getConnStr =+ testGroup+ "lead_"+ [ testCase "n=1" $ windowingQueryTest (query 1) [("Alice", Just "Bob"), ("Bob", Just "Claire"), ("Claire", Nothing)] getConnStr+ , testCase "n=2" $ windowingQueryTest (query 2) [("Alice", Just "Claire"), ("Bob", Nothing), ("Claire", Nothing)] getConnStr+ ]+ where+ query n =+ withWindow_+ ( \Person{name} ->+ frame_+ noPartition_+ (orderPartitionBy_ (asc_ name))+ noBounds_+ )+ ( \Person{name} w ->+ (name, lead_ name (val_ (n :: Int32)) `over_` w)+ )+ (all_ $ persons db)+ expectation1 = []++testLag :: IO ByteString -> TestTree+testLag getConnStr =+ testGroup+ "lag_"+ [ testCase "n=1" $ windowingQueryTest (query 1) [("Alice", Nothing), ("Bob", Just "Alice"), ("Claire", Just "Bob")] getConnStr+ , testCase "n=2" $ windowingQueryTest (query 2) [("Alice", Nothing), ("Bob", Nothing), ("Claire", Just "Alice")] getConnStr+ ]+ where+ query n =+ withWindow_+ ( \Person{name} ->+ frame_+ noPartition_+ (orderPartitionBy_ (asc_ name))+ noBounds_+ )+ ( \Person{name} w ->+ (name, lag_ name (val_ (n :: Int32)) `over_` w)+ )+ (all_ $ persons db)+ expectation = []+++testLeadWithDefault :: IO ByteString -> TestTree+testLeadWithDefault getConnStr =+ testGroup+ "leadWithDefault_"+ [ testCase "n=1" $ windowingQueryTest (query 1 "default") [("Alice", "Bob"), ("Bob", "Claire"), ("Claire", "default")] getConnStr+ , testCase "n=2" $ windowingQueryTest (query 2 "default") [("Alice", "Claire"), ("Bob", "default"), ("Claire", "default")] getConnStr+ ]+ where+ query n def =+ withWindow_+ ( \Person{name} ->+ frame_+ noPartition_+ (orderPartitionBy_ (asc_ name))+ noBounds_+ )+ ( \Person{name} w ->+ (name, leadWithDefault_ name (val_ (n :: Int32)) (val_ def) `over_` w)+ )+ (all_ $ persons db)+ expectation1 = []+++testLagWithDefault :: IO ByteString -> TestTree+testLagWithDefault getConnStr =+ testGroup+ "lagWithDefault_"+ [ testCase "n=1" $ windowingQueryTest (query 1 "default") [("Alice", "default"), ("Bob", "Alice"), ("Claire", "Bob")] getConnStr+ , testCase "n=2" $ windowingQueryTest (query 2 "default") [("Alice", "default"), ("Bob", "default"), ("Claire", "Alice")] getConnStr+ ]+ where+ query n def =+ withWindow_+ ( \Person{name} ->+ frame_+ noPartition_+ (orderPartitionBy_ (asc_ name))+ noBounds_+ )+ ( \Person{name} w ->+ (name, lagWithDefault_ name (val_ (n :: Int32)) (val_ def) `over_` w)+ )+ (all_ $ persons db)+ expectation = []++++data PersonT f = Person+ { name :: C f Text+ }+ deriving (Generic)++type Person = PersonT Identity++type PersonExpr s = PersonT (QExpr Postgres s)++deriving instance Show Person+deriving instance Eq Person++instance Beamable PersonT++instance Table PersonT where+ data PrimaryKey PersonT f = PersonKey (C f Text)+ deriving stock (Generic)+ deriving anyclass (Beamable)++ primaryKey Person{name} = PersonKey name++data Db f = Db+ { persons :: f (TableEntity PersonT)+ }+ deriving (Generic)++instance Database Postgres Db++db :: DatabaseSettings Postgres Db+db = defaultDbSettings++windowingQueryTest ::+ (Eq a, Show a, Eq b, Show b, FromBackendRow Postgres a, FromBackendRow Postgres b) =>+ Q Postgres Db QBaseScope (QExpr Postgres s a, QExpr Postgres s b) ->+ [(a, b)] ->+ IO ByteString ->+ Assertion+windowingQueryTest query expectation getConnStr =+ withTestPostgres "db_windowing_psql" getConnStr $+ \conn -> do+ prepareTable conn+ results <-+ runBeamPostgres conn $+ runSelectReturningList $+ select query++ assertEqual "Unexpected" expectation results++prepareTable :: Connection -> IO ()+prepareTable conn =+ runBeamPostgres conn $ do+ void $ autoMigrate migrationBackend (defaultMigratableDbSettings @Postgres @Db)+ runInsert $+ insert (persons db) $+ insertValues+ [ Person "Alice"+ , Person "Bob"+ , Person "Claire"+ ]
test/Main.hs view
@@ -1,17 +1,67 @@ module Main where +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 Database.Beam.Postgres.Test (startTempPostgres)-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 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 (withResource startTempPostgres snd $ \getConnStr ->- testGroup "beam-postgres tests"- [ Marshal.tests (fst <$> getConnStr)- , Select.tests (fst <$> getConnStr)- , DataType.tests (fst <$> getConnStr)- , Migrate.tests (fst <$> 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"++ -- 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+ }