beam-postgres 0.4.0.0 → 0.6.2.0
raw patch · 28 files changed
Files
- ChangeLog.md +229/−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 +141/−141
- 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 +203/−25
- Database/Beam/Postgres/TempTable.hs +62/−0
- Database/Beam/Postgres/Types.hs +73/−22
- beam-postgres.cabal +55/−26
- test/Database/Beam/Postgres/Test.hs +4/−61
- 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 +50/−9
ChangeLog.md view
@@ -1,3 +1,232 @@+# 0.6.2.0++## Added features++* Added instances for `BeamSqlBackendIsString Postgres (CI String)` and+ `BeamSqlBackendIsString Postgres (CI Text)`, allowing the use of `toTsVector`+ over colums of type `citext` (#818)+* Exposed the functionality to implement user-defined extensions via+ `Database.Beam.Postgres.Extensions` (#819)++## Bug fixes++* Fixed an issue where using `pgSelectWith` with no common-table expressions+ would lead to an invalid SQL query at runtime.++# 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,8 +1,9 @@+{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE TupleSections #-}-{-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TypeOperators #-} -- | Module providing (almost) full support for Postgres query and data -- manipulation statements. These functions shadow the functions in@@ -18,6 +19,9 @@ , locked_, lockAll_, withLocks_ + -- ** Inner WITH queries+ , pgSelectWith+ -- ** Lateral joins , lateral_ @@ -30,14 +34,13 @@ -- ** Specifying conflict actions - , PgInsertOnConflict(..), PgInsertOnConflictTarget(..)- , PgConflictAction(..)+ , PgInsertOnConflict(..) - , onConflictDefault, onConflict, anyConflict, conflictingFields- , conflictingFieldsWhere, conflictingConstraint- , onConflictDoNothing, onConflictUpdateSet- , onConflictUpdateSetWhere, onConflictUpdateInstead- , onConflictSetAll+ , onConflictDefault, onConflict+ , conflictingConstraint+ , BeamHasInsertOnConflict(..)+ , onConflictUpdateAll+ , onConflictUpdateInstead -- * @UPDATE RETURNING@ , PgUpdateReturning(..)@@ -54,22 +57,24 @@ ) where import Database.Beam hiding (insert, insertValues)-import Database.Beam.Query.Internal 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.Free.Church-import Control.Monad.Writer (execWriter, tell)+import Control.Monad.State.Strict (evalState)+import Control.Monad.Writer (runWriterT) -import Data.Functor.Const+import Data.List.NonEmpty (nonEmpty)+import qualified Data.List.NonEmpty as NonEmpty+import Data.Kind (Type) import Data.Proxy (Proxy(..)) import qualified Data.Text as T-#if !MIN_VERSION_base(4, 11, 0)-import Data.Semigroup-#endif -- * @SELECT@ @@ -94,7 +99,7 @@ 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+-- <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@@ -113,7 +118,7 @@ -- | 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>+-- <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.@@ -230,16 +235,8 @@ -- | 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)+newtype PgInsertOnConflict (tbl :: (Type -> Type) -> Type) =+ PgInsertOnConflict (tbl (QField QInternal) -> PgInsertOnConflictSyntax) -- | Postgres @LATERAL JOIN@ support --@@ -269,6 +266,7 @@ 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 ->@@ -280,6 +278,44 @@ (\_ -> Nothing) (rewriteThread (Proxy @s)))) +-- | The SQL standard only allows CTE expressions (WITH expressions)+-- at the top-level. Postgres allows you to embed these within a+-- subquery.+--+-- For example,+--+-- @+-- SELECT a.column1, b.column2 FROM (WITH RECURSIVE ... ) a JOIN b+-- @+--+-- @beam-core@ offers 'selectWith' to produce a top-level 'SqlSelect'+-- but these cannot be turned into 'Q' objects for use within joins.+-- The 'pgSelectWith' function is more flexible.+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))+ -- | By default, Postgres will throw an error when a conflict is detected. This -- preserves that functionality. onConflictDefault :: PgInsertOnConflict tbl@@ -296,8 +332,8 @@ -- See the -- <https://www.postgresql.org/docs/current/static/sql-insert.html Postgres documentation>. onConflict :: Beamable tbl- => PgInsertOnConflictTarget tbl- -> PgConflictAction tbl+ => SqlConflictTarget Postgres tbl+ -> SqlConflictAction Postgres tbl -> PgInsertOnConflict tbl onConflict (PgInsertOnConflictTarget tgt) (PgConflictAction update_) = PgInsertOnConflict $ \tbl ->@@ -308,123 +344,13 @@ 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 :: T.Text -> SqlConflictTarget Postgres 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@@ -500,7 +426,7 @@ emit " RETURNING " <> pgSepBy (emit ", ") (map fromPgExpression (project (Proxy @Postgres) (mkProjection tblQ) "t")) where- SqlDelete _ pgDelete = delete table mkWhere+ SqlDelete _ pgDelete = delete table $ \t -> mkWhere t tblQ = changeBeamRep (\(Columnar' f) -> Columnar' (QExpr (pure (fieldE (unqualifiedField (_fieldName f)))))) tblSettings runPgDeleteReturningList@@ -515,7 +441,7 @@ -- * General @RETURNING@ support class PgReturning cmd where- type PgReturningType cmd :: * -> *+ type PgReturningType cmd :: Type -> Type returning :: (Beamable tbl, Projectible Postgres a) => cmd Postgres tbl -> (tbl (QExpr Postgres PostgresInaccessible) -> a)@@ -555,3 +481,77 @@ 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.@@ -21,7 +22,7 @@ , emit, emitBuilder, escapeString , escapeBytea, escapeIdentifier , pgParens-+ , pgStringLit, pgCharLit, pgBoolLit , nextSyntaxStep , PgCommandSyntax(..), PgCommandType(..)@@ -45,6 +46,7 @@ , PgAlterTableSyntax(..), PgAlterTableActionSyntax(..), PgAlterColumnActionSyntax(..) + , PgWindowFrameSyntax(..), PgWindowFrameBoundsSyntax(..), PgWindowFrameBoundSyntax(..) , PgSelectLockingClauseSyntax(..)@@ -57,6 +59,8 @@ , PgDataTypeDescr(..) , PgHasEnum(..) + , PgIndexOptions(..)+ , pgCreateExtensionSyntax, pgDropExtensionSyntax , pgCreateEnumSyntax, pgDropTypeSyntax @@ -86,9 +90,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 +100,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 +113,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 +254,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 }@@ -333,6 +339,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 +417,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 +433,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 +589,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 +612,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"@@ -631,12 +679,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 +784,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 +800,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 +879,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 +1028,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 +1149,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 +1182,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 +1310,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 +1328,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 +1337,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,15 +1370,48 @@ 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) 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
+ 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.2.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,100 @@ 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.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 +117,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,32 +1,14 @@-{-# 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@@ -38,51 +20,12 @@ withTemplate1 = bracket (Pg.connectPostgreSQL connStrTemplate1) Pg.close createDatabase = withTemplate1 $ \c -> do- Pg.execute_ c (fromString ("CREATE DATABASE " <> dbName))+ 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 ()+ withTemplate1 $ \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/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,58 @@ 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.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+ $ TC.withContainers setupTempPostgresDB+ $ \getConnStr ->+ testGroup "beam-postgres tests"+ [ Marshal.tests getConnStr+ , Select.tests getConnStr+ , Select.PgNubBy.tests getConnStr+ , DataType.tests getConnStr+ , Migrate.tests getConnStr+ , TempTable.tests getConnStr+ , Windowing.tests getConnStr+ , Copy.tests getConnStr+ ]+++setupTempPostgresDB :: TC.MonadDocker m => m ByteString+setupTempPostgresDB = do+ let user = "postgres"+ password = "root"+ db = "testdb"++ timescaleContainer <- TC.run $ TC.containerRequest (TC.fromTag "postgres:16.4")+ TC.& TC.setExpose [ 5432 ]+ TC.& TC.setEnv [ ("POSTGRES_USER", user)+ , ("POSTGRES_PASSWORD", password)+ , ("POSTGRES_DB", db)+ ]+ TC.& TC.setWaitingFor (TC.waitForLogLine TC.Stderr ("database system is ready to accept connections" `TL.isInfixOf`))++ pure $ Postgres.postgreSQLConnectionString+ ( defaultConnectInfo { connectHost = "localhost"+ , connectUser = unpack user+ , connectPassword = unpack password+ , connectDatabase = unpack db+ , connectPort = fromIntegral $ TC.containerPort timescaleContainer 5432+ }+ )