beam-postgres 0.5.6.1 → 0.6.2.0
raw patch · 23 files changed
Files
- ChangeLog.md +70/−0
- Database/Beam/Postgres.hs +175/−47
- Database/Beam/Postgres/Connection.hs +69/−21
- Database/Beam/Postgres/Extensions.hs +37/−2
- Database/Beam/Postgres/Extensions/Copy/File.hs +421/−0
- Database/Beam/Postgres/Extensions/Copy/Stream.hs +175/−0
- Database/Beam/Postgres/Extensions/Internal.hs +0/−17
- Database/Beam/Postgres/Extensions/UuidOssp.hs +1/−2
- Database/Beam/Postgres/Full.hs +13/−9
- Database/Beam/Postgres/Migrate.hs +8/−2
- Database/Beam/Postgres/PgCrypto.hs +1/−2
- Database/Beam/Postgres/PgSpecific.hs +1/−5
- Database/Beam/Postgres/Syntax.hs +25/−1
- Database/Beam/Postgres/Types.hs +23/−1
- beam-postgres.cabal +15/−10
- test/Database/Beam/Postgres/Test.hs +0/−17
- test/Database/Beam/Postgres/Test/Copy.hs +444/−0
- test/Database/Beam/Postgres/Test/DataTypes.hs +8/−8
- test/Database/Beam/Postgres/Test/Marshal.hs +3/−3
- test/Database/Beam/Postgres/Test/Select.hs +2/−1
- test/Database/Beam/Postgres/Test/Select/PgNubBy.hs +119/−0
- test/Database/Beam/Postgres/Test/Windowing.hs +221/−0
- test/Main.hs +14/−8
ChangeLog.md view
@@ -1,3 +1,73 @@+# 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
Database/Beam/Postgres.hs view
@@ -16,74 +16,202 @@ -- -- For examples on how to use @beam-postgres@ usage, see -- <https://haskell-beam.github.io/beam/user-guide/backends/beam-postgres/ its manual>.- module Database.Beam.Postgres- ( -- * Beam Postgres backend- Postgres(..), Pg, liftIOWithHandle+ ( -- * Beam Postgres backend+ Postgres (..),+ Pg,+ liftIOWithHandle, -- ** Executing actions against the backend- , runBeamPostgres, runBeamPostgresDebug+ runBeamPostgres,+ runBeamPostgresDebug, -- ** Postgres syntax- , PgCommandSyntax, PgSyntax- , PgSelectSyntax, PgInsertSyntax- , PgUpdateSyntax, PgDeleteSyntax+ PgCommandSyntax,+ PgSyntax,+ PgSelectSyntax,+ PgInsertSyntax,+ PgUpdateSyntax,+ PgDeleteSyntax, - -- * Beam URI support- , postgresUriSyntax+ -- ** COPY support - -- * Postgres-specific features- -- ** Postgres-specific data types+ --+ -- File-mode @COPY@ support for Postgres. Use 'copyToText' / 'copyToCSV' (or 'copyFromText' /+ -- 'copyFromCSV') for default options, and the @*With@ variants to override+ -- format-specific fields. - , json, jsonb, uuid, money- , tsquery, tsvector, text, bytea- , unboundedArray+ -- *** text format+ copyToText,+ copyToTextWith,+ PgTextCopyToOptions (..),+ defaultPgTextCopyToOptions,+ copyFromText,+ copyFromTextWith,+ PgTextCopyFromOptions (..),+ defaultPgTextCopyFromOptions, - -- *** @SERIAL@ support- , smallserial, serial, bigserial+ -- *** CSV format+ copyToCSV,+ copyToCSVWith,+ PgCSVCopyToOptions (..),+ defaultPgCSVCopyToOptions,+ copyFromCSV,+ copyFromCSVWith,+ PgCSVCopyFromOptions (..),+ defaultPgCSVCopyFromOptions, - , module Database.Beam.Postgres.PgSpecific- , module Database.Beam.Postgres.TempTable+ -- *** Top-level options sums+ PgCopyToOptions,+ PgCopyFromOptions, - -- ** Postgres extension support- , PgExtensionEntity, IsPgExtension(..)- , pgCreateExtension, pgDropExtension- , getPgExtension+ -- ** Streaming COPY support - -- ** Utilities for defining custom instances- , fromPgIntegral- , fromPgScientificOrIntegral+ --+ -- Streaming @COPY ... TO STDOUT@ / @COPY ... FROM STDIN@.+ -- Use 'copyToTextStream' / 'copyToCSVStream' (or 'copyFromTextStream' /+ -- 'copyFromCSVStream') with the 'runCopyToStream' / 'runCopyFromStream'+ -- runners from "Database.Beam.Backend.SQL.BeamExtensions". - -- ** Debug support+ -- *** text format+ copyToTextStream,+ copyToTextStreamWith,+ copyFromTextStream,+ copyFromTextStreamWith, - , PgDebugStmt- , pgTraceStmtIO, pgTraceStmtIO'- , pgTraceStmt+ -- *** CSV format+ copyToCSVStream,+ copyToCSVStreamWith,+ copyFromCSVStream,+ copyFromCSVStreamWith, - -- * @postgresql-simple@ re-exports+ -- *** Top-level options sums+ PgCopyToStreamOptions,+ PgCopyFromStreamOptions, - , Pg.ResultError(..), Pg.SqlError(..)+ -- * Beam URI support+ postgresUriSyntax, - , Pg.Connection, Pg.ConnectInfo(..)- , Pg.defaultConnectInfo+ -- * Postgres-specific features - , Pg.connectPostgreSQL, Pg.connect- , Pg.close+ -- ** Postgres-specific data types+ json,+ jsonb,+ uuid,+ money,+ tsquery,+ tsvector,+ text,+ bytea,+ unboundedArray, - ) where+ -- *** @SERIAL@ support+ smallserial,+ serial,+ bigserial,+ module Database.Beam.Postgres.PgSpecific,+ module Database.Beam.Postgres.TempTable, + -- ** Postgres extension support+ PgExtensionEntity,+ IsPgExtension (..),+ pgCreateExtension,+ pgDropExtension,+ getPgExtension,++ -- ** Utilities for defining custom instances+ fromPgIntegral,+ fromPgScientificOrIntegral,++ -- ** Debug support+ PgDebugStmt,+ pgTraceStmtIO,+ pgTraceStmtIO',+ pgTraceStmt,++ -- * @postgresql-simple@ re-exports+ Pg.ResultError (..),+ Pg.SqlError (..),+ Pg.Connection,+ Pg.ConnectInfo (..),+ Pg.defaultConnectInfo,+ Pg.connectPostgreSQL,+ Pg.connect,+ Pg.close,+ )+where+ import Database.Beam.Postgres.Connection-import Database.Beam.Postgres.Full () -- for BeamHasInsertOnConflict instance-import Database.Beam.Postgres.Syntax-import Database.Beam.Postgres.Types-import Database.Beam.Postgres.PgSpecific-import Database.Beam.Postgres.Migrate ( tsquery, tsvector, text, bytea, unboundedArray- , json, jsonb, uuid, money, smallserial, serial- , bigserial)-import Database.Beam.Postgres.Extensions ( PgExtensionEntity, IsPgExtension(..)- , pgCreateExtension, pgDropExtension- , getPgExtension )+-- for BeamHasInsertOnConflict instance+ import Database.Beam.Postgres.Debug+import Database.Beam.Postgres.Extensions+ ( IsPgExtension (..),+ PgExtensionEntity,+ getPgExtension,+ pgCreateExtension,+ pgDropExtension,+ )+import Database.Beam.Postgres.Extensions.Copy.File+ ( PgCSVCopyFromOptions (..),+ PgCSVCopyToOptions (..),+ PgCopyFromOptions,+ PgCopyToOptions,+ PgTextCopyFromOptions (..),+ PgTextCopyToOptions (..),+ copyFromCSV,+ copyFromCSVWith,+ copyFromText,+ copyFromTextWith,+ copyToCSV,+ copyToCSVWith,+ copyToText,+ copyToTextWith,+ defaultPgCSVCopyFromOptions,+ defaultPgCSVCopyToOptions,+ defaultPgTextCopyFromOptions,+ defaultPgTextCopyToOptions,+ )+import Database.Beam.Postgres.Extensions.Copy.Stream+ ( PgCopyFromStreamOptions,+ PgCopyToStreamOptions,+ copyFromCSVStream,+ copyFromCSVStreamWith,+ copyFromTextStream,+ copyFromTextStreamWith,+ copyToCSVStream,+ copyToCSVStreamWith,+ copyToTextStream,+ copyToTextStreamWith,+ )+import Database.Beam.Postgres.Full ()+import Database.Beam.Postgres.Migrate+ ( bigserial,+ bytea,+ json,+ jsonb,+ money,+ serial,+ smallserial,+ text,+ tsquery,+ tsvector,+ unboundedArray,+ uuid,+ )+import Database.Beam.Postgres.PgSpecific+import Database.Beam.Postgres.Syntax+ ( PgCommandSyntax,+ PgDeleteSyntax,+ PgInsertSyntax,+ PgSelectSyntax,+ PgSyntax,+ PgUpdateSyntax,+ ) import Database.Beam.Postgres.TempTable-+import Database.Beam.Postgres.Types+ ( Postgres (..),+ fromPgIntegral,+ fromPgScientificOrIntegral,+ ) import qualified Database.PostgreSQL.Simple as Pg
Database/Beam/Postgres/Connection.hs view
@@ -9,7 +9,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} module Database.Beam.Postgres.Connection@@ -25,14 +24,15 @@ , postgresUriSyntax ) where -import Control.Exception (SomeException(..), throwIO)-import Data.IORef (newIORef, readIORef, writeIORef)-import Data.Vector (Vector)-import qualified Data.Vector as V+import Control.Exception (SomeException(..), throwIO, onException, catch)+import Control.Monad (void) import Control.Monad.Base (MonadBase(..)) import Control.Monad.Free.Church import Control.Monad.IO.Class import Control.Monad.Trans.Control (MonadBaseControl(..))+import Data.IORef (newIORef, readIORef, writeIORef)+import Data.Vector (Vector)+import qualified Data.Vector as V import Database.Beam hiding (runDelete, runUpdate, runInsert, insert) import Database.Beam.Backend.SQL.BeamExtensions@@ -41,6 +41,10 @@ import Database.Beam.Backend.URI import Database.Beam.Schema.Tables +import Database.Beam.Postgres.Extensions.Copy.File+ ( PgCopyFromSyntax(..), PgCopyToSyntax(..) )+import Database.Beam.Postgres.Extensions.Copy.Stream+ ( PgCopyFromStreamSyntax(..), PgCopyToStreamSyntax(..) ) import Database.Beam.Postgres.Syntax import Database.Beam.Postgres.Full import Database.Beam.Postgres.Types@@ -48,6 +52,7 @@ import qualified Database.PostgreSQL.LibPQ as Pg hiding (Connection, escapeStringConn, escapeIdentifier, escapeByteaConn, exec) import qualified Database.PostgreSQL.Simple as Pg+import qualified Database.PostgreSQL.Simple.Copy as PgCopy import qualified Database.PostgreSQL.Simple.FromField as Pg import qualified Database.PostgreSQL.Simple.Internal as Pg ( Field(..), RowParser(..)@@ -407,13 +412,56 @@ Just x -> collectM (acc . (x:)) in collectM id -instance MonadBeamInsertReturning Postgres Pg where- runInsertReturningList i = do- let insertReturningCmd' = i `returning`- changeBeamRep (\(Columnar' (QExpr s) :: Columnar' (QExpr Postgres PostgresInaccessible) ty) ->- Columnar' (QExpr s) :: Columnar' (QExpr Postgres ()) ty)+instance MonadBeamCopyTo Postgres Pg where+ runCopyTo SqlCopyToNoColumns = pure ()+ runCopyTo (SqlCopyTo (PgCopyToSyntax syntax)) =+ runNoReturn (PgCommandSyntax PgCommandTypeDataUpdate syntax) - -- Make savepoint+instance MonadBeamCopyFrom Postgres Pg where+ runCopyFrom SqlCopyFromNoColumns = pure ()+ runCopyFrom (SqlCopyFrom (PgCopyFromSyntax syntax)) =+ runNoReturn (PgCommandSyntax PgCommandTypeDataUpdate syntax)++instance MonadBeamCopyToStream Postgres Pg where+ -- | `runCopyToStream` is exception-safe; if the output stream+ -- produces an exception, the stream will be drained before the exception+ -- is re-thrown+ runCopyToStream SqlCopyToStreamNoColumns _ = pure ()+ runCopyToStream (SqlCopyToStream (PgCopyToStreamSyntax syntax)) sink =+ liftIOWithHandle $ \conn -> do+ query <- pgRenderSyntax conn syntax+ PgCopy.copy_ conn (Pg.Query query)+ let loop onRow = do+ PgCopy.getCopyData conn >>= \case+ PgCopy.CopyOutRow chunk -> onRow chunk >> loop onRow+ PgCopy.CopyOutDone _ -> pure ()+ -- Like 'loop', but doesn't use the sink at all. This is used+ -- to drain elements in the COPY stream before re-throwing an exception+ drain = loop (const (pure ()))+ loop sink `catch` (\(e::SomeException) -> drain >> throwIO e)+++instance MonadBeamCopyFromStream Postgres Pg where+ -- | `runCopyFromStream` is exception-safe; if the input stream+ -- produces an exception, the connection will be reset to a safe state,+ -- aborting the COPY operation.+ runCopyFromStream SqlCopyFromStreamNoColumns _ = pure ()+ runCopyFromStream (SqlCopyFromStream (PgCopyFromStreamSyntax syntax)) producer =+ liftIOWithHandle $ \conn -> do+ query <- pgRenderSyntax conn syntax+ let loop = + producer >>= \case+ Just chunk -> PgCopy.putCopyData conn chunk >> loop+ Nothing -> void $ PgCopy.putCopyEnd conn+ PgCopy.copy_ conn (Pg.Query query)+ loop `onException` PgCopy.putCopyError conn mempty++instance MonadBeamInsertReturning Postgres Pg where+ runInsertReturningListWith i mkProjection = do+ let pgProj tbl = mkProjection (changeBeamRep+ (\(Columnar' (QExpr s) :: Columnar' (QExpr Postgres PostgresInaccessible) ty) ->+ Columnar' (QExpr s) :: Columnar' (QExpr Postgres ()) ty) tbl)+ insertReturningCmd' = i `returning` pgProj case insertReturningCmd' of PgInsertReturningEmpty -> pure []@@ -421,11 +469,11 @@ runReturningList (PgCommandSyntax PgCommandTypeDataUpdateReturning insertReturningCmd) instance MonadBeamUpdateReturning Postgres Pg where- runUpdateReturningList u = do- let updateReturningCmd' = u `returning`- changeBeamRep (\(Columnar' (QExpr s) :: Columnar' (QExpr Postgres PostgresInaccessible) ty) ->- Columnar' (QExpr s) :: Columnar' (QExpr Postgres ()) ty)-+ runUpdateReturningListWith u mkProjection = do+ let pgProj tbl = mkProjection (changeBeamRep+ (\(Columnar' (QExpr s) :: Columnar' (QExpr Postgres PostgresInaccessible) ty) ->+ Columnar' (QExpr s) :: Columnar' (QExpr Postgres ()) ty) tbl)+ updateReturningCmd' = u `returning` pgProj case updateReturningCmd' of PgUpdateReturningEmpty -> pure []@@ -433,9 +481,9 @@ runReturningList (PgCommandSyntax PgCommandTypeDataUpdateReturning updateReturningCmd) instance MonadBeamDeleteReturning Postgres Pg where- runDeleteReturningList d = do- let PgDeleteReturning deleteReturningCmd = d `returning`- changeBeamRep (\(Columnar' (QExpr s) :: Columnar' (QExpr Postgres PostgresInaccessible) ty) ->- Columnar' (QExpr s) :: Columnar' (QExpr Postgres ()) ty)-+ runDeleteReturningListWith d mkProjection = do+ let pgProj tbl = mkProjection (changeBeamRep+ (\(Columnar' (QExpr s) :: Columnar' (QExpr Postgres PostgresInaccessible) ty) ->+ Columnar' (QExpr s) :: Columnar' (QExpr Postgres ()) ty) tbl)+ PgDeleteReturning deleteReturningCmd = d `returning` pgProj runReturningList (PgCommandSyntax PgCommandTypeDataUpdateReturning deleteReturningCmd)
Database/Beam/Postgres/Extensions.hs view
@@ -1,6 +1,5 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE CPP #-} -- | Postgres extensions are run-time loadable plugins that can extend Postgres -- functionality. Extensions are part of the database schema.@@ -10,9 +9,29 @@ -- the extension in a particular backend. @beam-postgres@ provides predicates -- and checks for @beam-migrate@ which allow extensions to be included as -- regular parts of beam migrations.-module Database.Beam.Postgres.Extensions where+module Database.Beam.Postgres.Extensions (+ -- * Handling extensions+ PgExtensionEntity,+ getPgExtension, + -- * Defining extensions+ IsPgExtension(..),+ -- ** Helpers+ PgExpr,+ LiftPg,+ funcE,++ -- * Migrations+ PgHasExtension(..),+ pgCreateExtension,+ pgDropExtension,+ pgExtensionActionProvider,+) where+ import Database.Beam+import Database.Beam.Backend.SQL ( IsSql92ExpressionSyntax(..), IsSql92FieldNameSyntax(..),+ IsSql99ExpressionSyntax, IsSql99FunctionExpressionSyntax(..)+ ) import Database.Beam.Schema.Tables import Database.Beam.Postgres.Types@@ -122,6 +141,21 @@ -> extension getPgExtension (DatabaseEntity (PgDatabaseExtension _ ext)) = ext +-- *** Helpers to write postgres user-defined extensions++-- | @since 0.6.2.0+type PgExpr ctxt s = QGenExpr ctxt Postgres s++-- | @since 0.6.2.0+type family LiftPg ctxt s fn where+ LiftPg ctxt s (Maybe a -> b) = Maybe (PgExpr ctxt s a) -> LiftPg ctxt s b+ LiftPg ctxt s (a -> b) = PgExpr ctxt s a -> LiftPg ctxt s b+ LiftPg ctxt s a = PgExpr ctxt s a++-- | @since 0.6.2.0+funcE :: IsSql99ExpressionSyntax expr => Text -> [expr] -> expr+funcE nm = functionCallE (fieldE (unqualifiedField nm))+ -- *** Migrations support for extensions -- | 'Migration' representing the Postgres @CREATE EXTENSION@ command. Because@@ -192,3 +226,4 @@ pure (PotentialAction (HS.fromList [p extP]) mempty (pure (MigrationCommand cmd MigrationKeepsData)) ("Unload the postgres extension " <> ext) 1)+
+ Database/Beam/Postgres/Extensions/Copy/File.hs view
@@ -0,0 +1,421 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}++module Database.Beam.Postgres.Extensions.Copy.File+ ( PgCopyToSyntax (..),+ PgCopyToSourceSyntax (..),+ PgCopyFromSyntax (..),+ PgCopyFromSourceSyntax (..),++ -- * COPY options+ PgCopyToOptions,+ PgCopyFromOptions,++ -- ** text+ copyToText,+ copyToTextWith,+ PgTextCopyToOptions (..),+ defaultPgTextCopyToOptions,+ copyFromText,+ copyFromTextWith,+ PgTextCopyFromOptions (..),+ defaultPgTextCopyFromOptions,++ -- ** CSV+ copyToCSV,+ copyToCSVWith,+ PgCSVCopyToOptions (..),+ defaultPgCSVCopyToOptions,+ copyFromCSV,+ copyFromCSVWith,+ PgCSVCopyFromOptions (..),+ defaultPgCSVCopyFromOptions,++ -- * Internal — exposed for use by sibling modules+ emitOptionList,+ textCopyToFields,+ csvCopyToFields,+ textCopyFromFields,+ csvCopyFromFields,+ )+where++import qualified Data.List.NonEmpty as NE+import Data.Maybe (catMaybes)+import Data.Text (Text)+import qualified Data.Text as T+import Database.Beam.Backend.SQL.BeamExtensions+ ( IsSqlCopyFromSourceSyntax (..),+ IsSqlCopyFromSyntax (..),+ IsSqlCopyToSourceSyntax (..),+ IsSqlCopyToSyntax (..),+ )+import Database.Beam.Postgres.Syntax+ ( PgSelectSyntax (..),+ PgSyntax,+ emit,+ pgBoolLit,+ pgCharLit,+ pgParens,+ pgQuotedIdentifier,+ pgSepBy,+ pgStringLit,+ )++-- | PostgreSQL @COPY ... TO@ source syntax. Wraps the table name (with+-- optional column list) or a @SELECT@ subquery.+--+-- @since 0.6.1.0+newtype PgCopyToSourceSyntax = PgCopyToSourceSyntax {fromPgCopyToSource :: PgSyntax}++-- | PostgreSQL @COPY ... TO@ statement syntax.+--+-- @since 0.6.1.0+newtype PgCopyToSyntax = PgCopyToSyntax {fromPgCopyTo :: PgSyntax}++-- | PostgreSQL @COPY ... FROM@ source syntax. Just the table name plus+-- optional column list — Postgres @COPY ... FROM@ does not accept a SELECT.+--+-- @since 0.6.1.0+newtype PgCopyFromSourceSyntax = PgCopyFromSourceSyntax {fromPgCopyFromSource :: PgSyntax}++-- | PostgreSQL @COPY ... FROM@ statement syntax.+--+-- @since 0.6.1.0+newtype PgCopyFromSyntax = PgCopyFromSyntax {fromPgCopyFrom :: PgSyntax}++instance IsSqlCopyToSourceSyntax PgCopyToSourceSyntax where+ type SqlCopyToSourceSelectSyntax PgCopyToSourceSyntax = PgSelectSyntax++ copyTableToSyntax mSchema tableName' mColumns =+ PgCopyToSourceSyntax $+ maybe mempty (\schema -> pgQuotedIdentifier schema <> emit ".") mSchema+ <> pgQuotedIdentifier tableName'+ <> case mColumns of+ Nothing -> mempty+ Just cols -> pgParens $ pgSepBy (emit ", ") (map pgQuotedIdentifier (NE.toList cols))++ copySelectToSyntax (PgSelectSyntax select) = PgCopyToSourceSyntax $ pgParens select++instance IsSqlCopyToSyntax PgCopyToSyntax where+ type SqlCopyToSourceSyntax PgCopyToSyntax = PgCopyToSourceSyntax+ type SqlCopyToParams PgCopyToSyntax = PgCopyToOptions++ copyToStmt (PgCopyToSourceSyntax source) options =+ let (filepath, optionsSyntax) = emitPgCopyToOptions options+ in PgCopyToSyntax $+ mconcat+ [ emit "COPY ",+ source,+ emit " TO ",+ pgStringLit (T.pack filepath),+ optionsSyntax+ ]++instance IsSqlCopyFromSourceSyntax PgCopyFromSourceSyntax where+ copyTableFromSyntax mSchema tableName' mColumns =+ PgCopyFromSourceSyntax $+ maybe mempty (\schema -> pgQuotedIdentifier schema <> emit ".") mSchema+ <> pgQuotedIdentifier tableName'+ <> case mColumns of+ Nothing -> mempty+ Just cols -> pgParens $ pgSepBy (emit ", ") (map pgQuotedIdentifier (NE.toList cols))++instance IsSqlCopyFromSyntax PgCopyFromSyntax where+ type SqlCopyFromSourceSyntax PgCopyFromSyntax = PgCopyFromSourceSyntax+ type SqlCopyFromParams PgCopyFromSyntax = PgCopyFromOptions++ copyFromStmt (PgCopyFromSourceSyntax source) options =+ let (filepath, optionsSyntax) = emitPgCopyFromOptions options+ in PgCopyFromSyntax $+ mconcat+ [ emit "COPY ",+ source,+ emit " FROM ",+ pgStringLit (T.pack filepath),+ optionsSyntax+ ]++-- | Options for PostgreSQL's @COPY ... TO@ statement, tagged by the output+-- format. Use 'copyToText' or 'copyToCSV' to construct.+--+-- See <https://www.postgresql.org/docs/current/sql-copy.html the PostgreSQL COPY documentation>+-- for the full set of options each format supports.+--+-- @since 0.6.1.0+data PgCopyToOptions+ = PgCopyToText !FilePath !PgTextCopyToOptions+ | PgCopyToCSV !FilePath !PgCSVCopyToOptions+ deriving (Eq, Show)++-- | Copy to a text file at the given path with default options.+-- Use 'copyToTextWith' to override.+--+-- @since 0.6.1.0+copyToText :: FilePath -> PgCopyToOptions+copyToText path = PgCopyToText path defaultPgTextCopyToOptions++-- | Copy to a text file at the given path with the given options.+--+-- @since 0.6.1.0+copyToTextWith :: FilePath -> PgTextCopyToOptions -> PgCopyToOptions+copyToTextWith = PgCopyToText++-- | Copy to a CSV file at the given path with default options.+-- Use 'copyToCSVWith' to override.+--+-- @since 0.6.1.0+copyToCSV :: FilePath -> PgCopyToOptions+copyToCSV path = PgCopyToCSV path defaultPgCSVCopyToOptions++-- | Copy to a CSV file at the given path with the given options.+--+-- @since 0.6.1.0+copyToCSVWith :: FilePath -> PgCSVCopyToOptions -> PgCopyToOptions+copyToCSVWith = PgCopyToCSV++-- | Options for PostgreSQL's @COPY ... FROM@ statement, tagged by the input+-- format. Use 'copyFromText' or 'copyFromCSV' to construct.+--+-- @since 0.6.1.0+data PgCopyFromOptions+ = PgCopyFromText !FilePath !PgTextCopyFromOptions+ | PgCopyFromCSV !FilePath !PgCSVCopyFromOptions+ deriving (Eq, Show)++-- | Copy from a text file at the given path with default options.+-- Use 'copyFromTextWith' to override.+--+-- @since 0.6.1.0+copyFromText :: FilePath -> PgCopyFromOptions+copyFromText path = PgCopyFromText path defaultPgTextCopyFromOptions++-- | Copy from a text file at the given path with the given options.+--+-- @since 0.6.1.0+copyFromTextWith :: FilePath -> PgTextCopyFromOptions -> PgCopyFromOptions+copyFromTextWith = PgCopyFromText++-- | Copy from a CSV file at the given path with default options.+-- Use 'copyFromCSVWith' to override.+--+-- @since 0.6.1.0+copyFromCSV :: FilePath -> PgCopyFromOptions+copyFromCSV path = PgCopyFromCSV path defaultPgCSVCopyFromOptions++-- | Copy from a CSV file at the given path with the given options.+--+-- @since 0.6.1.0+copyFromCSVWith :: FilePath -> PgCSVCopyFromOptions -> PgCopyFromOptions+copyFromCSVWith = PgCopyFromCSV++-- | Options for the @text@ format on @COPY ... TO@.+--+-- @since 0.6.1.0+data PgTextCopyToOptions = PgTextCopyToOptions+ { -- | @DELIMITER@: single-character column delimiter. Defaults to TAB.+ pgTextCopyToDelimiter :: Maybe Char,+ -- | @NULL@: token written for SQL @NULL@ values. Defaults to @\\N@.+ pgTextCopyToNullStr :: Maybe Text,+ -- | @HEADER@: emit a header row with column names.+ pgTextCopyToHeader :: Maybe Bool,+ -- | @ENCODING@: client-encoding override for the file.+ pgTextCopyToEncoding :: Maybe Text+ }+ deriving (Eq, Show)++-- | All-'Nothing' 'PgTextCopyToOptions'; a sensible starting point for+-- record-update overrides.+--+-- @since 0.6.1.0+defaultPgTextCopyToOptions :: PgTextCopyToOptions+defaultPgTextCopyToOptions =+ PgTextCopyToOptions+ { pgTextCopyToDelimiter = Nothing,+ pgTextCopyToNullStr = Nothing,+ pgTextCopyToHeader = Nothing,+ pgTextCopyToEncoding = Nothing+ }++-- | Options for the @csv@ format on @COPY ... TO@.+--+-- @since 0.6.1.0+data PgCSVCopyToOptions = PgCSVCopyToOptions+ { -- | @DELIMITER@: single-character column delimiter. Defaults to a comma.+ pgCsvCopyToDelimiter :: Maybe Char,+ -- | @NULL@: token written for SQL @NULL@ values. Defaults to the empty+ -- string.+ pgCsvCopyToNullStr :: Maybe Text,+ -- | @HEADER@: emit a header row with column names.+ pgCsvCopyToHeader :: Maybe Bool,+ -- | @QUOTE@: single-character quote character. Defaults to @\"@.+ pgCsvCopyToQuote :: Maybe Char,+ -- | @ESCAPE@: single-character escape character. Defaults to the+ -- value of 'pgCsvCopyToQuote'.+ pgCsvCopyToEscape :: Maybe Char,+ -- | @ENCODING@: client-encoding override for the file.+ pgCsvCopyToEncoding :: Maybe Text+ }+ deriving (Eq, Show)++-- | All-'Nothing' 'PgCSVCopyToOptions'.+--+-- @since 0.6.1.0+defaultPgCSVCopyToOptions :: PgCSVCopyToOptions+defaultPgCSVCopyToOptions =+ PgCSVCopyToOptions+ { pgCsvCopyToDelimiter = Nothing,+ pgCsvCopyToNullStr = Nothing,+ pgCsvCopyToHeader = Nothing,+ pgCsvCopyToQuote = Nothing,+ pgCsvCopyToEscape = Nothing,+ pgCsvCopyToEncoding = Nothing+ }++-- | Options for the @text@ format on @COPY ... FROM@.+--+-- @since 0.6.1.0+data PgTextCopyFromOptions = PgTextCopyFromOptions+ { -- | @DELIMITER@: single-character column delimiter. Defaults to TAB.+ pgTextCopyFromDelimiter :: Maybe Char,+ -- | @NULL@: token to interpret as SQL @NULL@. Defaults to @\\N@.+ pgTextCopyFromNullStr :: Maybe Text,+ -- | @HEADER@: skip the first line as a header row.+ pgTextCopyFromHeader :: Maybe Bool,+ -- | @ENCODING@: client-encoding override for the file.+ pgTextCopyFromEncoding :: Maybe Text,+ -- | @FREEZE@: skip WAL when loading; only legal under specific+ -- conditions (see the PostgreSQL @COPY@ documentation).+ pgTextCopyFromFreeze :: Maybe Bool+ }+ deriving (Eq, Show)++-- | All-'Nothing' 'PgTextCopyFromOptions'.+--+-- @since 0.6.1.0+defaultPgTextCopyFromOptions :: PgTextCopyFromOptions+defaultPgTextCopyFromOptions =+ PgTextCopyFromOptions+ { pgTextCopyFromDelimiter = Nothing,+ pgTextCopyFromNullStr = Nothing,+ pgTextCopyFromHeader = Nothing,+ pgTextCopyFromEncoding = Nothing,+ pgTextCopyFromFreeze = Nothing+ }++-- | Options for the @csv@ format on @COPY ... FROM@.+--+-- @since 0.6.1.0+data PgCSVCopyFromOptions = PgCSVCopyFromOptions+ { -- | @DELIMITER@: single-character column delimiter. Defaults to a comma.+ pgCsvCopyFromDelimiter :: Maybe Char,+ -- | @NULL@: token to interpret as SQL @NULL@. Defaults to the empty+ -- string.+ pgCsvCopyFromNullStr :: Maybe Text,+ -- | @HEADER@: skip the first line as a header row.+ pgCsvCopyFromHeader :: Maybe Bool,+ -- | @QUOTE@: single-character quote character. Defaults to @\"@.+ pgCsvCopyFromQuote :: Maybe Char,+ -- | @ESCAPE@: single-character escape character. Defaults to the+ -- value of 'pgCsvCopyFromQuote'.+ pgCsvCopyFromEscape :: Maybe Char,+ -- | @ENCODING@: client-encoding override for the file.+ pgCsvCopyFromEncoding :: Maybe Text,+ -- | @FREEZE@: skip WAL when loading; only legal under specific+ -- conditions (see the PostgreSQL @COPY@ documentation).+ pgCsvCopyFromFreeze :: Maybe Bool+ }+ deriving (Eq, Show)++-- | All-'Nothing' 'PgCSVCopyFromOptions'; a sensible starting point for+-- record-update overrides.+--+-- @since 0.6.1.0+defaultPgCSVCopyFromOptions :: PgCSVCopyFromOptions+defaultPgCSVCopyFromOptions =+ PgCSVCopyFromOptions+ { pgCsvCopyFromDelimiter = Nothing,+ pgCsvCopyFromNullStr = Nothing,+ pgCsvCopyFromHeader = Nothing,+ pgCsvCopyFromQuote = Nothing,+ pgCsvCopyFromEscape = Nothing,+ pgCsvCopyFromEncoding = Nothing,+ pgCsvCopyFromFreeze = Nothing+ }++-- * Emission++emitPgCopyToOptions :: PgCopyToOptions -> (FilePath, PgSyntax)+emitPgCopyToOptions (PgCopyToText fp o) = (fp, emitOptionList (emit "text") (textCopyToFields o))+emitPgCopyToOptions (PgCopyToCSV fp o) = (fp, emitOptionList (emit "csv") (csvCopyToFields o))++emitPgCopyFromOptions :: PgCopyFromOptions -> (FilePath, PgSyntax)+emitPgCopyFromOptions (PgCopyFromText fp o) = (fp, emitOptionList (emit "text") (textCopyFromFields o))+emitPgCopyFromOptions (PgCopyFromCSV fp o) = (fp, emitOptionList (emit "csv") (csvCopyFromFields o))++-- | Render @ (FORMAT FMT, OPT1 …, OPT2 …)@. The @FORMAT@ entry is always+-- present since the constructor of the options value pins it.+--+-- @since 0.6.1.0+emitOptionList :: PgSyntax -> [PgSyntax] -> PgSyntax+emitOptionList fmt items =+ emit " ("+ <> pgSepBy (emit ", ") ((emit "FORMAT " <> fmt) : items)+ <> emit ")"++-- | Render the per-option items for a 'PgTextCopyToOptions' value.+--+-- @since 0.6.1.0+textCopyToFields :: PgTextCopyToOptions -> [PgSyntax]+textCopyToFields o =+ catMaybes+ [ fmap (\c -> emit "DELIMITER " <> pgCharLit c) (pgTextCopyToDelimiter o),+ fmap (\s -> emit "NULL " <> pgStringLit s) (pgTextCopyToNullStr o),+ fmap (\b -> emit "HEADER " <> pgBoolLit b) (pgTextCopyToHeader o),+ fmap (\s -> emit "ENCODING " <> pgStringLit s) (pgTextCopyToEncoding o)+ ]++-- | Render the per-option items for a 'PgCSVCopyToOptions' value.+--+-- @since 0.6.1.0+csvCopyToFields :: PgCSVCopyToOptions -> [PgSyntax]+csvCopyToFields o =+ catMaybes+ [ fmap (\c -> emit "DELIMITER " <> pgCharLit c) (pgCsvCopyToDelimiter o),+ fmap (\s -> emit "NULL " <> pgStringLit s) (pgCsvCopyToNullStr o),+ fmap (\b -> emit "HEADER " <> pgBoolLit b) (pgCsvCopyToHeader o),+ fmap (\c -> emit "QUOTE " <> pgCharLit c) (pgCsvCopyToQuote o),+ fmap (\c -> emit "ESCAPE " <> pgCharLit c) (pgCsvCopyToEscape o),+ fmap (\s -> emit "ENCODING " <> pgStringLit s) (pgCsvCopyToEncoding o)+ ]++-- | Render the per-option items for a 'PgTextCopyFromOptions' value.+--+-- @since 0.6.1.0+textCopyFromFields :: PgTextCopyFromOptions -> [PgSyntax]+textCopyFromFields o =+ catMaybes+ [ fmap (\c -> emit "DELIMITER " <> pgCharLit c) (pgTextCopyFromDelimiter o),+ fmap (\s -> emit "NULL " <> pgStringLit s) (pgTextCopyFromNullStr o),+ fmap (\b -> emit "HEADER " <> pgBoolLit b) (pgTextCopyFromHeader o),+ fmap (\s -> emit "ENCODING " <> pgStringLit s) (pgTextCopyFromEncoding o),+ fmap (\b -> emit "FREEZE " <> pgBoolLit b) (pgTextCopyFromFreeze o)+ ]++-- | Render the per-option items for a 'PgCSVCopyFromOptions' value.+--+-- @since 0.6.1.0+csvCopyFromFields :: PgCSVCopyFromOptions -> [PgSyntax]+csvCopyFromFields o =+ catMaybes+ [ fmap (\c -> emit "DELIMITER " <> pgCharLit c) (pgCsvCopyFromDelimiter o),+ fmap (\s -> emit "NULL " <> pgStringLit s) (pgCsvCopyFromNullStr o),+ fmap (\b -> emit "HEADER " <> pgBoolLit b) (pgCsvCopyFromHeader o),+ fmap (\c -> emit "QUOTE " <> pgCharLit c) (pgCsvCopyFromQuote o),+ fmap (\c -> emit "ESCAPE " <> pgCharLit c) (pgCsvCopyFromEscape o),+ fmap (\s -> emit "ENCODING " <> pgStringLit s) (pgCsvCopyFromEncoding o),+ fmap (\b -> emit "FREEZE " <> pgBoolLit b) (pgCsvCopyFromFreeze o)+ ]
+ Database/Beam/Postgres/Extensions/Copy/Stream.hs view
@@ -0,0 +1,175 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}++module Database.Beam.Postgres.Extensions.Copy.Stream+ ( PgCopyToStreamSyntax (..),+ PgCopyFromStreamSyntax (..),++ -- * COPY options+ PgCopyToStreamOptions,+ PgCopyFromStreamOptions,++ -- ** text+ copyToTextStream,+ copyToTextStreamWith,+ copyFromTextStream,+ copyFromTextStreamWith,++ -- ** CSV+ copyToCSVStream,+ copyToCSVStreamWith,+ copyFromCSVStream,+ copyFromCSVStreamWith,+ )+where++import Database.Beam.Backend.SQL.BeamExtensions+ ( IsSqlCopyFromStreamSyntax (..),+ IsSqlCopyToStreamSyntax (..),+ )+import Database.Beam.Postgres.Extensions.Copy.File+ ( PgCSVCopyFromOptions (..),+ PgCSVCopyToOptions (..),+ PgCopyFromSourceSyntax (..),+ PgCopyToSourceSyntax (..),+ PgTextCopyFromOptions (..),+ PgTextCopyToOptions (..),+ csvCopyFromFields,+ csvCopyToFields,+ defaultPgCSVCopyFromOptions,+ defaultPgCSVCopyToOptions,+ defaultPgTextCopyFromOptions,+ defaultPgTextCopyToOptions,+ emitOptionList,+ textCopyFromFields,+ textCopyToFields,+ )+import Database.Beam.Postgres.Syntax (PgSyntax, emit)++-- | PostgreSQL streaming @COPY ... TO STDOUT@ statement syntax.+--+-- @since 0.6.1.0+newtype PgCopyToStreamSyntax = PgCopyToStreamSyntax {fromPgCopyToStream :: PgSyntax}++-- | PostgreSQL streaming @COPY ... FROM STDIN@ statement syntax.+--+-- @since 0.6.1.0+newtype PgCopyFromStreamSyntax = PgCopyFromStreamSyntax {fromPgCopyFromStream :: PgSyntax}++instance IsSqlCopyToStreamSyntax PgCopyToStreamSyntax where+ type SqlCopyToStreamSourceSyntax PgCopyToStreamSyntax = PgCopyToSourceSyntax+ type SqlCopyToStreamParams PgCopyToStreamSyntax = PgCopyToStreamOptions++ copyToStreamStmt (PgCopyToSourceSyntax source) options =+ PgCopyToStreamSyntax $+ mconcat+ [ emit "COPY ",+ source,+ emit " TO STDOUT",+ emitPgCopyToStreamOptions options+ ]++instance IsSqlCopyFromStreamSyntax PgCopyFromStreamSyntax where+ type SqlCopyFromStreamSourceSyntax PgCopyFromStreamSyntax = PgCopyFromSourceSyntax+ type SqlCopyFromStreamParams PgCopyFromStreamSyntax = PgCopyFromStreamOptions++ copyFromStreamStmt (PgCopyFromSourceSyntax source) options =+ PgCopyFromStreamSyntax $+ mconcat+ [ emit "COPY ",+ source,+ emit " FROM STDIN",+ emitPgCopyFromStreamOptions options+ ]++-- | Options for PostgreSQL's streaming @COPY ... TO STDOUT@ statement,+-- tagged by the output format.+--+-- See <https://www.postgresql.org/docs/current/sql-copy.html the PostgreSQL COPY documentation>+-- for the full set of options each format supports.+--+-- @since 0.6.1.0+data PgCopyToStreamOptions+ = PgCopyToStreamText !PgTextCopyToOptions+ | PgCopyToStreamCSV !PgCSVCopyToOptions+ deriving (Eq, Show)++-- | Stream out using the @text@ format with default options.+-- Use 'copyToTextStreamWith' to override.+--+-- @since 0.6.1.0+copyToTextStream :: PgCopyToStreamOptions+copyToTextStream = PgCopyToStreamText defaultPgTextCopyToOptions++-- | Stream out using the @text@ format with the given options.+--+-- @since 0.6.1.0+copyToTextStreamWith :: PgTextCopyToOptions -> PgCopyToStreamOptions+copyToTextStreamWith = PgCopyToStreamText++-- | Stream out using the @csv@ format with default options.+-- Use 'copyToCSVStreamWith' to override.+--+-- @since 0.6.1.0+copyToCSVStream :: PgCopyToStreamOptions+copyToCSVStream = PgCopyToStreamCSV defaultPgCSVCopyToOptions++-- | Stream out using the @csv@ format with the given options.+--+-- @since 0.6.1.0+copyToCSVStreamWith :: PgCSVCopyToOptions -> PgCopyToStreamOptions+copyToCSVStreamWith = PgCopyToStreamCSV++-- | Options for PostgreSQL's streaming @COPY ... FROM STDIN@ statement,+-- tagged by the input format.+--+-- @since 0.6.1.0+data PgCopyFromStreamOptions+ = PgCopyFromStreamText !PgTextCopyFromOptions+ | PgCopyFromStreamCSV !PgCSVCopyFromOptions+ deriving (Eq, Show)++-- | Stream in using the @text@ format with default options.+-- Use 'copyFromTextStreamWith' to override.+--+-- @since 0.6.1.0+copyFromTextStream :: PgCopyFromStreamOptions+copyFromTextStream = PgCopyFromStreamText defaultPgTextCopyFromOptions++-- | Stream in using the @text@ format with the given options.+--+-- @since 0.6.1.0+copyFromTextStreamWith :: PgTextCopyFromOptions -> PgCopyFromStreamOptions+copyFromTextStreamWith = PgCopyFromStreamText++-- | Stream in using the @csv@ format with default options.+-- Use 'copyFromCSVStreamWith' to override.+--+-- @since 0.6.1.0+copyFromCSVStream :: PgCopyFromStreamOptions+copyFromCSVStream = PgCopyFromStreamCSV defaultPgCSVCopyFromOptions++-- | Stream in using the @csv@ format with the given options.+--+-- @since 0.6.1.0+copyFromCSVStreamWith :: PgCSVCopyFromOptions -> PgCopyFromStreamOptions+copyFromCSVStreamWith = PgCopyFromStreamCSV++-- | Render the @WITH (FORMAT ..., ...)@ tail of a streaming+-- @COPY ... TO STDOUT@ statement.+--+-- @since 0.6.1.0+emitPgCopyToStreamOptions :: PgCopyToStreamOptions -> PgSyntax+emitPgCopyToStreamOptions (PgCopyToStreamText o) = emitOptionList (emit "text") (textCopyToFields o)+emitPgCopyToStreamOptions (PgCopyToStreamCSV o) = emitOptionList (emit "csv") (csvCopyToFields o)++-- | Render the @WITH (FORMAT ..., ...)@ tail of a streaming+-- @COPY ... FROM STDIN@ statement.+--+-- @since 0.6.1.0+emitPgCopyFromStreamOptions :: PgCopyFromStreamOptions -> PgSyntax+emitPgCopyFromStreamOptions (PgCopyFromStreamText o) = emitOptionList (emit "text") (textCopyFromFields o)+emitPgCopyFromStreamOptions (PgCopyFromStreamCSV o) = emitOptionList (emit "csv") (csvCopyFromFields o)
− Database/Beam/Postgres/Extensions/Internal.hs
@@ -1,17 +0,0 @@-module Database.Beam.Postgres.Extensions.Internal where--import Data.Text (Text)--import Database.Beam-import Database.Beam.Backend.SQL-import Database.Beam.Postgres--type PgExpr ctxt s = QGenExpr ctxt Postgres s--type family LiftPg ctxt s fn where- LiftPg ctxt s (Maybe a -> b) = Maybe (PgExpr ctxt s a) -> LiftPg ctxt s b- LiftPg ctxt s (a -> b) = PgExpr ctxt s a -> LiftPg ctxt s b- LiftPg ctxt s a = PgExpr ctxt s a--funcE :: IsSql99ExpressionSyntax expr => Text -> [expr] -> expr-funcE nm args = functionCallE (fieldE (unqualifiedField nm)) args
Database/Beam/Postgres/Extensions/UuidOssp.hs view
@@ -10,8 +10,7 @@ import Data.UUID.Types (UUID) import Database.Beam-import Database.Beam.Postgres.Extensions-import Database.Beam.Postgres.Extensions.Internal+import Database.Beam.Postgres.Extensions ( LiftPg, IsPgExtension(..), funcE ) -- | Data type representing definitions contained in the @uuid-ossp@ extension data UuidOssp = UuidOssp
Database/Beam/Postgres/Full.hs view
@@ -2,7 +2,6 @@ {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE TupleSections #-}-{-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TypeOperators #-} @@ -71,6 +70,8 @@ import Control.Monad.State.Strict (evalState) import Control.Monad.Writer (runWriterT) +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@@ -289,18 +290,21 @@ -- -- @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 and indeed--- 'selectWith' for @beam-postgres@ is equivalent to se+-- 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, ctes)) = evalState (runWriterT mkQ) 0+ let (q, (recursiveness, mctes)) = evalState (runWriterT mkQ) 0 fromSyntax tblPfx =- case recursiveness of- CTE.Nonrecursive -> withSyntax ctes (buildSqlQuery tblPfx q)- CTE.Recursive -> withRecursiveSyntax ctes (buildSqlQuery tblPfx q)+ case (recursiveness, nonEmpty mctes) of+ (CTE.Nonrecursive, Just ctes) -> withSyntax (NonEmpty.toList ctes) (buildSqlQuery tblPfx q)+ (CTE.Recursive, Just ctes) -> withRecursiveSyntax (NonEmpty.toList ctes) (buildSqlQuery tblPfx q)+ -- If there are no subqueries, we don't want to generate+ -- an empty 'WITH' statement, which would be malformed.+ -- + -- see: https://github.com/haskell-beam/beam/issues/760+ (_, Nothing) -> buildSqlQuery tblPfx q in Q (liftF (QAll (\tblPfx tName -> let (_, names) = mkFieldNames @Postgres @res (qualifiedField tName) in fromTable (PgTableSourceSyntax $@@ -309,7 +313,7 @@ (\tName -> let (projection, _) = mkFieldNames @Postgres @res (qualifiedField tName) in projection)- (\_ -> Nothing)+ (const Nothing) snd)) -- | By default, Postgres will throw an error when a conflict is detected. This
Database/Beam/Postgres/Migrate.hs view
@@ -60,7 +60,7 @@ import Control.Exception.Lifted (mask, onException) import Control.Monad -import Data.Aeson hiding (json)+import Data.Aeson import Data.Bits import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy as BL@@ -598,5 +598,11 @@ field' _ _ nm ty _ collation constraints PgHasDefault = Db.field' (Proxy @'True) (Proxy @'False) nm ty Nothing collation constraints -instance BeamSqlBackendHasSerial Postgres where+instance BeamSqlBackendHasSerial Int16 Postgres where+ genericSerial nm = Db.field nm smallserial PgHasDefault++instance BeamSqlBackendHasSerial Int32 Postgres where genericSerial nm = Db.field nm serial PgHasDefault++instance BeamSqlBackendHasSerial Int64 Postgres where+ genericSerial nm = Db.field nm bigserial PgHasDefault
Database/Beam/Postgres/PgCrypto.hs view
@@ -9,8 +9,7 @@ import Database.Beam import Database.Beam.Backend.SQL -import Database.Beam.Postgres.Extensions-import Database.Beam.Postgres.Extensions.Internal+import Database.Beam.Postgres.Extensions( LiftPg, PgExpr, IsPgExtension(..), funcE ) import Data.Int import Data.Text (Text)
Database/Beam/Postgres/PgSpecific.hs view
@@ -9,7 +9,6 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE PolyKinds #-}-{-# LANGUAGE CPP #-} -- | Postgres-specific types, functions, and operators module Database.Beam.Postgres.PgSpecific@@ -111,7 +110,7 @@ -- * Postgres @EXTRACT@ fields , century_, decade_, dow_, doy_, epoch_, isodow_, isoyear_- , microseconds_, milliseconds_, millennium_, quarter_, week_+ , microseconds_, milliseconds_, millennium_, quarter_ -- ** Postgres functions and aggregates , pgBoolOr, pgBoolAnd, pgStringAgg, pgStringAggOver@@ -1674,9 +1673,6 @@ quarter_ :: HasSqlDate tgt => ExtractField Postgres tgt Int32 quarter_ = ExtractField (PgExtractFieldSyntax (emit "QUARTER"))--week_ :: HasSqlDate tgt => ExtractField Postgres tgt Int32-week_ = ExtractField (PgExtractFieldSyntax (emit "WEEK")) -- $full-text-search --
Database/Beam/Postgres/Syntax.hs view
@@ -22,7 +22,7 @@ , emit, emitBuilder, escapeString , escapeBytea, escapeIdentifier , pgParens-+ , pgStringLit, pgCharLit, pgBoolLit , nextSyntaxStep , PgCommandSyntax(..), PgCommandType(..)@@ -131,6 +131,8 @@ import qualified Database.PostgreSQL.Simple.Types as Pg (Oid(..), Binary(..), Null(..)) import qualified Database.PostgreSQL.Simple.Time as Pg (Date, LocalTimestamp, UTCTimestamp) import qualified Database.PostgreSQL.Simple.HStore as Pg (HStoreList, HStoreMap, HStoreBuilder)+import Data.Text (Text)+import qualified Data.ByteString.Char8 as BS8 data PostgresInaccessible @@ -798,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") @@ -1388,6 +1391,27 @@ pgParens :: PgSyntax -> PgSyntax pgParens a = emit "(" <> a <> emit ")"++-- | Render a 'Text' as a single-quoted SQL string literal, with proper+-- Postgres escaping. The surrounding quotes are added here; 'escapeString'+-- only handles the escaping of the contents.+--+-- @since 0.6.1.0+pgStringLit :: Text -> PgSyntax+pgStringLit t = emit "'" <> escapeString (TE.encodeUtf8 t) <> emit "'"++-- | Render a 'Char' as a single-quoted SQL string literal.+--+-- @since 0.6.1.0+pgCharLit :: Char -> PgSyntax+pgCharLit c = emit "'" <> escapeString (BS8.singleton c) <> emit "'"++-- | Render a boolean as the literal @TRUE@ or @FALSE@.+--+-- @since 0.6.1.0+pgBoolLit :: Bool -> PgSyntax+pgBoolLit True = emit "TRUE"+pgBoolLit False = emit "FALSE" pgTableOp :: ByteString -> PgSelectTableSyntax -> PgSelectTableSyntax -> PgSelectTableSyntax
Database/Beam/Postgres/Types.hs view
@@ -1,5 +1,5 @@ {-# OPTIONS_GHC -fno-warn-orphans #-}-+{-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}@@ -18,8 +18,18 @@ import Database.Beam import Database.Beam.Backend import Database.Beam.Backend.Internal.Compat+import Database.Beam.Backend.SQL.BeamExtensions+ ( BeamSqlBackendCopyFromStreamSyntax+ , BeamSqlBackendCopyFromSyntax+ , BeamSqlBackendCopyToStreamSyntax+ , BeamSqlBackendCopyToSyntax+ ) import Database.Beam.Migrate.Generics import Database.Beam.Migrate.SQL (BeamMigrateOnlySqlBackend)+import Database.Beam.Postgres.Extensions.Copy.File+ ( PgCopyFromSyntax, PgCopyToSyntax )+import Database.Beam.Postgres.Extensions.Copy.Stream+ ( PgCopyFromStreamSyntax, PgCopyToStreamSyntax ) import Database.Beam.Postgres.Syntax import Database.Beam.Query.SQL92 @@ -166,8 +176,20 @@ instance BeamMigrateOnlySqlBackend Postgres type instance BeamSqlBackendSyntax Postgres = PgCommandSyntax +type instance BeamSqlBackendCopyToSyntax Postgres = PgCopyToSyntax+type instance BeamSqlBackendCopyFromSyntax Postgres = PgCopyFromSyntax++type instance BeamSqlBackendCopyToStreamSyntax Postgres = PgCopyToStreamSyntax+type instance BeamSqlBackendCopyFromStreamSyntax Postgres = PgCopyFromStreamSyntax+ instance BeamSqlBackendIsString Postgres String instance BeamSqlBackendIsString Postgres Text++-- | @since 0.6.2.0+instance BeamSqlBackendIsString Postgres (CI String)++-- | @since 0.6.2.0+instance BeamSqlBackendIsString Postgres (CI Text) instance HasQBuilder Postgres where buildSqlQuery = buildSql92Query' True
beam-postgres.cabal view
@@ -1,5 +1,5 @@ name: beam-postgres-version: 0.5.6.1+version: 0.6.2.0 synopsis: Connection layer between beam and postgres description: Beam driver for <https://www.postgresql.org/ PostgreSQL>, an advanced open-source RDBMS homepage: https://haskell-beam.github.io/beam/user-guide/backends/beam-postgres@@ -23,20 +23,21 @@ Database.Beam.Postgres.Full Database.Beam.Postgres.PgCrypto+ Database.Beam.Postgres.Extensions Database.Beam.Postgres.Extensions.UuidOssp Database.Beam.Postgres.TempTable other-modules: Database.Beam.Postgres.Connection Database.Beam.Postgres.Debug- Database.Beam.Postgres.Extensions- Database.Beam.Postgres.Extensions.Internal+ Database.Beam.Postgres.Extensions.Copy.File+ Database.Beam.Postgres.Extensions.Copy.Stream Database.Beam.Postgres.PgSpecific Database.Beam.Postgres.Types build-depends: base >=4.11 && <5.0,- beam-core >=0.10 && <0.11,- beam-migrate >=0.5.4.0 && <0.6,+ beam-core >=0.11.1 && <0.12,+ beam-migrate >=0.6 && <0.7, postgresql-libpq >=0.8 && <0.12, postgresql-simple >=0.5 && <0.8,@@ -48,11 +49,11 @@ hashable >=1.1 && <1.6, lifted-base >=0.2 && <0.3, free >=4.12 && <5.3,- time >=1.6 && <1.15,+ time >=1.6 && <1.17, monad-control >=1.0 && <1.1, mtl >=2.1 && <2.4, conduit >=1.2 && <1.4,- aeson >=0.11 && <2.3,+ aeson >=0.11 && <2.4, uuid-types >=1.0 && <1.1, case-insensitive >=1.2 && <1.3, scientific >=0.3 && <0.4,@@ -65,7 +66,7 @@ default-language: Haskell2010 default-extensions: ScopedTypeVariables, OverloadedStrings, MultiParamTypeClasses, RankNTypes, FlexibleInstances, DeriveDataTypeable, DeriveGeneric, StandaloneDeriving, TypeFamilies, GADTs, OverloadedStrings,- CPP, TypeApplications, FlexibleContexts+ TypeApplications, FlexibleContexts ghc-options: -Wall -Widentities -Wincomplete-uni-patterns@@ -80,11 +81,14 @@ 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,- Database.Beam.Postgres.Test.TempTable+ Database.Beam.Postgres.Test.TempTable,+ Database.Beam.Postgres.Test.Windowing build-depends: aeson, base,@@ -92,12 +96,13 @@ beam-migrate, beam-postgres, bytestring,- hedgehog,+ hedgehog >= 1.0, postgresql-simple, tasty-hunit, tasty, text, testcontainers,+ time, uuid, vector default-language: Haskell2010
test/Database/Beam/Postgres/Test.hs view
@@ -1,10 +1,5 @@-{-# LANGUAGE CPP #-} module Database.Beam.Postgres.Test where -#if MIN_VERSION_base(4,12,0)-import Prelude hiding (fail)-#endif- import qualified Database.PostgreSQL.Simple as Pg import Control.Exception (bracket)@@ -13,18 +8,6 @@ import Data.ByteString (ByteString) import Data.String--#if MIN_VERSION_base(4,12,0)-#if !MIN_VERSION_hedgehog(1,0,0)-import Control.Monad.Fail (MonadFail(..))-import qualified Hedgehog--- TODO orphan instances are bad--- Would be easier to say 'build-depends: hedgehog >= 1.0',--- but it's difficult to propagate to older Stackage snapshots-instance Monad m => MonadFail (Hedgehog.PropertyT m) where- fail _ = Hedgehog.failure-#endif-#endif withTestPostgres :: String -> IO ByteString -> (Pg.Connection -> IO a) -> IO a withTestPostgres dbName getConnStr action = do
+ test/Database/Beam/Postgres/Test/Copy.hs view
@@ -0,0 +1,444 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-}++module Database.Beam.Postgres.Test.Copy (tests) where++import Control.Monad (void)+import Control.Monad.IO.Class (liftIO)+import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import Data.IORef (modifyIORef', newIORef, readIORef, writeIORef)+import Data.Int (Int32)+import Data.List (sort)+import Data.Text (Text)+import qualified Data.Text as T+import Database.Beam+import Database.Beam.Backend.SQL.BeamExtensions+ ( MonadBeamCopyFrom (..),+ MonadBeamCopyFromStream (..),+ MonadBeamCopyTo (..),+ MonadBeamCopyToStream (..),+ copySelectTo,+ copySelectToStream,+ copyTableFrom,+ copyTableFromStream,+ copyTableTo,+ copyTableToStream,+ )+import Database.Beam.Postgres+import Database.Beam.Postgres.Test (withTestPostgres)+import Database.PostgreSQL.Simple (Connection, execute_)+import Hedgehog ((===))+import qualified Hedgehog+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (Assertion, assertBool, assertEqual, testCase)++tests :: IO ByteString -> TestTree+tests getConn =+ testGroup+ "COPY statements"+ [ testGroup+ "COPY ... TO / ... FROM round-trip"+ [ testRoundtripCsvAllColumns getConn,+ testRoundtripCsvMultiColumnProjection getConn,+ testRoundtripCsvSingleColumnProjection getConn,+ testRoundtripCsvFromSelect getConn+ ],+ testGroup+ "options"+ [ testCustomDelimiter getConn,+ testNoHeader getConn,+ testTextFormat getConn+ ],+ testGroup+ "streaming COPY"+ [ testStreamRoundtripCsv getConn,+ testStreamFromSelect getConn+ ],+ testGroup+ "property-based round-trip"+ [ testPropCsvRoundtrip getConn,+ testPropTextRoundtrip getConn+ ]+ ]++-- | The full table is exported to a CSV, the table is truncated, and the CSV+-- is re-imported. The final rows must match the original ones.+testRoundtripCsvAllColumns :: IO ByteString -> TestTree+testRoundtripCsvAllColumns getConn =+ testCopy getConn "copy_all_columns_csv" "/tmp/copy_all_columns.csv" $ \conn path -> do+ seedWidgets conn widgetData+ runBeamPostgres conn $ do+ runCopyTo $ copyTableTo (_dbWidgets testDb) id (copyToCSV path)+ truncateWidgets conn+ runBeamPostgres conn $ do+ runCopyFrom $ copyTableFrom (_dbWidgets testDb) id (copyFromCSV path)+ rows <- queryAllWidgets conn+ assertEqual "round-tripped rows match seed" widgetData rows++-- | Project a subset of columns; the unprojected column gets its DEFAULT on+-- import.+testRoundtripCsvMultiColumnProjection :: IO ByteString -> TestTree+testRoundtripCsvMultiColumnProjection getConn =+ testCopy getConn "copy_multi_column_csv" "/tmp/copy_multi_column.csv" $ \conn path -> do+ seedWidgets conn widgetData+ runBeamPostgres conn $ do+ runCopyTo $+ copyTableTo+ (_dbWidgets testDb)+ (\w -> (_widgetId w, _widgetName w))+ (copyToCSV path)+ truncateWidgets conn+ runBeamPostgres conn $ do+ runCopyFrom $+ copyTableFrom+ (_dbWidgets testDb)+ (\w -> (_widgetId w, _widgetName w))+ (copyFromCSV path)+ rows <- queryAllWidgets conn+ -- 'price' was not in the projection, so it gets its DEFAULT (0).+ let expected = [w {_widgetPrice = 0} | w <- widgetData]+ assertEqual "id+name round-tripped, price defaulted" expected rows++-- | Single-column projection.+testRoundtripCsvSingleColumnProjection :: IO ByteString -> TestTree+testRoundtripCsvSingleColumnProjection getConn =+ testCopy getConn "copy_single_column_csv" "/tmp/copy_single_column.csv" $ \conn path -> do+ seedWidgets conn widgetData+ runBeamPostgres conn $ do+ runCopyTo $ copyTableTo (_dbWidgets testDb) _widgetId (copyToCSV path)+ truncateWidgets conn+ runBeamPostgres conn $ do+ runCopyFrom $ copyTableFrom (_dbWidgets testDb) _widgetId (copyFromCSV path)+ rows <- queryAllWidgets conn+ let expected = [w {_widgetName = "", _widgetPrice = 0} | w <- widgetData]+ assertEqual "id-only round-tripped, name+price defaulted" expected rows++-- | Use copySelectTo with a filtered query, then COPY FROM the result back+-- into the table.+testRoundtripCsvFromSelect :: IO ByteString -> TestTree+testRoundtripCsvFromSelect getConn =+ testCopy getConn "copy_select_csv" "/tmp/copy_select.csv" $ \conn path -> do+ seedWidgets conn widgetData+ runBeamPostgres conn $ do+ runCopyTo $+ copySelectTo+ ( select $ do+ w <- all_ (_dbWidgets testDb)+ guard_ (_widgetPrice w >. val_ 4.0)+ pure w+ )+ (copyToCSV path)+ truncateWidgets conn+ runBeamPostgres conn $ do+ runCopyFrom $ copyTableFrom (_dbWidgets testDb) id (copyFromCSV path)+ rows <- queryAllWidgets conn+ -- Only Widget (9.99) and Sprocket (4.5) have price > 4.0; Cog is excluded.+ let expected = sort [w | w <- widgetData, _widgetPrice w > 4.0]+ assertEqual "select-filtered round-trip" expected rows++-- | Use a custom delimiter on both sides of the round-trip.+testCustomDelimiter :: IO ByteString -> TestTree+testCustomDelimiter getConn =+ testCopy getConn "copy_custom_delim_csv" "/tmp/copy_custom_delim.csv" $ \conn path -> do+ seedWidgets conn widgetData+ let toOpts = copyToCSVWith path defaultPgCSVCopyToOptions {pgCsvCopyToDelimiter = Just '|'}+ fromOpts = copyFromCSVWith path defaultPgCSVCopyFromOptions {pgCsvCopyFromDelimiter = Just '|'}+ runBeamPostgres conn $ do+ runCopyTo $ copyTableTo (_dbWidgets testDb) id toOpts+ truncateWidgets conn+ runBeamPostgres conn $ do+ runCopyFrom $ copyTableFrom (_dbWidgets testDb) id fromOpts+ rows <- queryAllWidgets conn+ assertEqual "round-trip with '|' delimiter" widgetData rows++-- | Toggle HEADER off on TO and on on FROM; round-trip should still work+-- (as long as both sides agree).+testNoHeader :: IO ByteString -> TestTree+testNoHeader getConn =+ testCopy getConn "copy_no_header_csv" "/tmp/copy_no_header.csv" $ \conn path -> do+ seedWidgets conn widgetData+ let toOpts = copyToCSVWith path defaultPgCSVCopyToOptions {pgCsvCopyToHeader = Just False}+ fromOpts = copyFromCSVWith path defaultPgCSVCopyFromOptions {pgCsvCopyFromHeader = Just False}+ runBeamPostgres conn $ do+ runCopyTo $ copyTableTo (_dbWidgets testDb) id toOpts+ truncateWidgets conn+ runBeamPostgres conn $ do+ runCopyFrom $ copyTableFrom (_dbWidgets testDb) id fromOpts+ rows <- queryAllWidgets conn+ assertEqual "round-trip without header line" widgetData rows++-- | The 'text' format with custom delimiter, round-tripped.+testTextFormat :: IO ByteString -> TestTree+testTextFormat getConn =+ testCopy getConn "copy_text_format" "/tmp/copy_text.txt" $ \conn path -> do+ seedWidgets conn widgetData+ let toOpts = copyToTextWith path defaultPgTextCopyToOptions {pgTextCopyToDelimiter = Just '\t'}+ fromOpts = copyFromTextWith path defaultPgTextCopyFromOptions {pgTextCopyFromDelimiter = Just '\t'}+ runBeamPostgres conn $ do+ runCopyTo $ copyTableTo (_dbWidgets testDb) id toOpts+ truncateWidgets conn+ runBeamPostgres conn $ do+ runCopyFrom $ copyTableFrom (_dbWidgets testDb) id fromOpts+ rows <- queryAllWidgets conn+ assertEqual "round-trip via text format" widgetData rows++-- | Round-trip widgets through streaming @COPY ... TO STDOUT@ then+-- @COPY ... FROM STDIN@. The bytes pass through the client connection only;+-- no server-side file is touched.+testStreamRoundtripCsv :: IO ByteString -> TestTree+testStreamRoundtripCsv getConn =+ testCopy getConn "stream_roundtrip_csv" "" $ \conn _ -> do+ seedWidgets conn widgetData+ -- Drain the stream into an IORef.+ chunksRef <- newIORef []+ runBeamPostgres conn $+ runCopyToStream+ (copyTableToStream (_dbWidgets testDb) id copyToCSVStream)+ (\chunk -> modifyIORef' chunksRef (chunk :))+ payload <- BS.concat . reverse <$> readIORef chunksRef+ assertBool "stream produced non-empty payload" (not (BS.null payload))+ -- Replay the captured bytes back into the table.+ truncateWidgets conn+ sourceRef <- newIORef (Just payload)+ runBeamPostgres conn $+ runCopyFromStream+ (copyTableFromStream (_dbWidgets testDb) id copyFromCSVStream)+ ( do+ mchunk <- readIORef sourceRef+ writeIORef sourceRef Nothing+ pure mchunk+ )+ rows <- queryAllWidgets conn+ assertEqual "round-tripped rows match seed" widgetData rows++-- | @COPY (SELECT ...) TO STDOUT@ via 'copySelectToStream'.+testStreamFromSelect :: IO ByteString -> TestTree+testStreamFromSelect getConn =+ testCopy getConn "stream_from_select" "" $ \conn _ -> do+ seedWidgets conn widgetData+ chunksRef <- newIORef []+ runBeamPostgres conn $+ runCopyToStream+ ( copySelectToStream+ ( select $ do+ w <- all_ (_dbWidgets testDb)+ guard_ (_widgetPrice w >. val_ 4.0)+ pure w+ )+ copyToCSVStream+ )+ (\chunk -> modifyIORef' chunksRef (chunk :))+ payload <- BS.concat . reverse <$> readIORef chunksRef+ -- The payload should mention the two widgets with price > 4.0 and not+ -- the one priced 1.25.+ assertBool "Widget present" ("Widget" `BS.isInfixOf` payload)+ assertBool "Sprocket present" ("Sprocket" `BS.isInfixOf` payload)+ assertBool "Cog absent" (not ("Cog" `BS.isInfixOf` payload))++testPropCsvRoundtrip :: IO ByteString -> TestTree+testPropCsvRoundtrip getConn =+ testCopy getConn "prop_csv_roundtrip" "/tmp/prop_csv.csv" $ \conn path -> do+ passes <-+ Hedgehog.check . Hedgehog.property $ do+ toOpts <- Hedgehog.forAll genCsvToOpts+ let fromOpts = matchedCsvFromOpts toOpts+ rows <-+ liftIO $+ roundtripWidgets conn $ \c -> do+ runBeamPostgres c $+ runCopyTo $+ copyTableTo (_dbWidgets testDb) id (copyToCSVWith path toOpts)+ truncateWidgets c+ runBeamPostgres c $+ runCopyFrom $+ copyTableFrom (_dbWidgets testDb) id (copyFromCSVWith path fromOpts)+ rows === widgetData+ assertBool "Hedgehog property failed" passes+ where+ genCsvToOpts = do+ delim <- Gen.maybe genDelimiterChar+ hdr <- Gen.maybe Gen.bool+ quote <- Gen.maybe genQuoteChar+ escape <- Gen.maybe genEscapeChar+ nullStr <- Gen.maybe genNullStr+ pure+ defaultPgCSVCopyToOptions+ { pgCsvCopyToDelimiter = delim,+ pgCsvCopyToHeader = hdr,+ pgCsvCopyToQuote = quote,+ pgCsvCopyToEscape = escape,+ pgCsvCopyToNullStr = nullStr+ }++ matchedCsvFromOpts :: PgCSVCopyToOptions -> PgCSVCopyFromOptions+ matchedCsvFromOpts o =+ defaultPgCSVCopyFromOptions+ { pgCsvCopyFromDelimiter = pgCsvCopyToDelimiter o,+ pgCsvCopyFromHeader = pgCsvCopyToHeader o,+ pgCsvCopyFromQuote = pgCsvCopyToQuote o,+ pgCsvCopyFromEscape = pgCsvCopyToEscape o,+ pgCsvCopyFromNullStr = pgCsvCopyToNullStr o+ }++testPropTextRoundtrip :: IO ByteString -> TestTree+testPropTextRoundtrip getConn =+ testCopy getConn "prop_text_roundtrip" "/tmp/prop_text.txt" $ \conn path -> do+ passes <-+ Hedgehog.check . Hedgehog.property $ do+ toOpts <- Hedgehog.forAll genTextToOpts+ let fromOpts = matchedTextFromOpts toOpts+ rows <-+ liftIO $+ roundtripWidgets conn $ \c -> do+ runBeamPostgres c $+ runCopyTo $+ copyTableTo (_dbWidgets testDb) id (copyToTextWith path toOpts)+ truncateWidgets c+ runBeamPostgres c $+ runCopyFrom $+ copyTableFrom (_dbWidgets testDb) id (copyFromTextWith path fromOpts)+ rows === widgetData+ assertBool "Hedgehog property failed" passes+ where+ genTextToOpts = do+ delim <- Gen.maybe genDelimiterChar+ hdr <- Gen.maybe Gen.bool+ -- Avoid generating a NULL string that contains the chosen delimiter.+ nullStr <- Gen.maybe (Gen.filter (not . T.any (== ',')) genNullStr)+ pure+ defaultPgTextCopyToOptions+ { pgTextCopyToDelimiter = delim,+ pgTextCopyToHeader = hdr,+ pgTextCopyToNullStr = nullStr+ }++ -- \| Mirror of 'matchedCsvFromOpts' for the @text@ format. 'pgTextCopyFromFreeze'+ -- is intentionally left at @Nothing@: PostgreSQL only accepts @FREEZE@ when+ -- the target table has not been touched in the current (sub)transaction, but+ -- our property test truncates before the FROM, which violates that+ -- precondition.+ matchedTextFromOpts :: PgTextCopyToOptions -> PgTextCopyFromOptions+ matchedTextFromOpts o =+ defaultPgTextCopyFromOptions+ { pgTextCopyFromDelimiter = pgTextCopyToDelimiter o,+ pgTextCopyFromHeader = pgTextCopyToHeader o,+ pgTextCopyFromNullStr = pgTextCopyToNullStr o+ }++-- Single-byte delimiters that never appear in 'widgetData'. Avoiding @.@+-- matters for the @text@ format because the data contains floating-point+-- prices like @9.99@.+genDelimiterChar :: Hedgehog.Gen Char+genDelimiterChar = Gen.element [',', ';', '|', '\t']++genQuoteChar :: Hedgehog.Gen Char+genQuoteChar = Gen.element ['"', '\'']++genEscapeChar :: Hedgehog.Gen Char+genEscapeChar = Gen.element ['"', '\'', '\\']++genNullStr :: Hedgehog.Gen Text+genNullStr = Gen.element ["NULL", "~~~"]++roundtripWidgets :: Connection -> (Connection -> IO ()) -> IO [Widget]+roundtripWidgets conn action = do+ truncateWidgets conn+ seedWidgets conn widgetData+ action conn+ queryAllWidgets conn++testCopy ::+ IO ByteString ->+ String ->+ -- | Server-side file path inside the Postgres container.+ FilePath ->+ (Connection -> FilePath -> Assertion) ->+ TestTree+testCopy getConn name path action = testCase name $+ withTestPostgres name getConn $ \conn -> do+ createWidgetsTable conn+ action conn path++queryAllWidgets :: Connection -> IO [Widget]+queryAllWidgets conn =+ runBeamPostgres conn $+ runSelectReturningList $+ select $+ orderBy_ (asc_ . _widgetId) $+ all_ (_dbWidgets testDb)++createWidgetsTable :: Connection -> IO ()+createWidgetsTable conn =+ void $+ execute_+ conn+ "CREATE TABLE widgets (\+ \ id INTEGER PRIMARY KEY,\+ \ name TEXT NOT NULL DEFAULT '',\+ \ price DOUBLE PRECISION NOT NULL DEFAULT 0\+ \)"++truncateWidgets :: Connection -> IO ()+truncateWidgets conn = void $ execute_ conn "TRUNCATE TABLE widgets"++seedWidgets :: Connection -> [Widget] -> IO ()+seedWidgets conn widgets =+ runBeamPostgres conn $+ runInsert $+ insert (_dbWidgets testDb) (insertValues widgets)++widgetData :: [Widget]+widgetData =+ [ Widget 1 "Widget" 9.99,+ Widget 2 "Sprocket" 4.50,+ Widget 3 "Cog" 1.25+ ]++data WidgetT f = Widget+ { _widgetId :: Columnar f Int32,+ _widgetName :: Columnar f Text,+ _widgetPrice :: Columnar f Double+ }+ deriving (Generic)++type Widget = WidgetT Identity++deriving instance Show Widget++deriving instance Eq Widget++deriving instance Ord Widget++instance Beamable WidgetT++instance Table WidgetT where+ data PrimaryKey WidgetT f = WidgetId (Columnar f Int32)+ deriving (Generic)+ primaryKey = WidgetId . _widgetId++instance Beamable (PrimaryKey WidgetT)++newtype TestDB f = TestDB+ { _dbWidgets :: f (TableEntity WidgetT)+ }+ deriving (Generic, Database be)++testDb :: DatabaseSettings Postgres TestDB+testDb =+ defaultDbSettings+ `withDbModification` dbModification+ { _dbWidgets =+ modifyTableFields+ tableModification+ { _widgetId = "id",+ _widgetName = "name",+ _widgetPrice = "price"+ }+ }
test/Database/Beam/Postgres/Test/DataTypes.hs view
@@ -3,10 +3,10 @@ module Database.Beam.Postgres.Test.DataTypes where import Database.Beam+import Database.Beam.Backend.SQL.BeamExtensions+import Database.Beam.Migrate import Database.Beam.Postgres import Database.Beam.Postgres.Test-import Database.Beam.Migrate-import Database.Beam.Backend.SQL.BeamExtensions import Control.Exception (SomeException(..), handle) @@ -141,15 +141,15 @@ -- | Regression test for <https://github.com/haskell-beam/beam/issues/700> errorOnLiteralDoubles :: IO ByteString -> TestTree errorOnLiteralDoubles pgConn =- testCase "Literal `Double`s are correctly specified as SQL `DOUBLE` (#700)" $ + testCase "Literal `Double`s are correctly specified as SQL `DOUBLE` (#700)" $ withTestPostgres "db_failures" pgConn $ \conn -> do- results <- runBeamPostgres conn $ - runSelectReturningList $ - select $ + results <- runBeamPostgres conn $+ runSelectReturningList $+ select $ query- + results @?= [(99 :: Int32, 1.0 :: Double)]- + where -- We need to provide a db for type-checking, but it will not be used query :: Q Postgres RealDb s (QExpr Postgres s Int32, QExpr Postgres s Double)
test/Database/Beam/Postgres/Test/Marshal.hs view
@@ -52,7 +52,7 @@ (PgPoint (max x1 x2) (max y1 y2))) arrayGen :: Hedgehog.Gen a -> Hedgehog.Gen (Vector.Vector a)-arrayGen = fmap Vector.fromList +arrayGen = fmap Vector.fromList . Gen.list (Range.linear 0 5) -- small arrays == quick tests boxCmp :: PgBox -> PgBox -> Bool@@ -100,8 +100,8 @@ -- Arrays --- -- Testing lots of element types for arrays is important, because - -- the mapping between array Oid and element Oid is not type + -- Testing lots of element types for arrays is important, because+ -- the mapping between array Oid and element Oid is not type -- safe, and hence error-prone. , marshalTest (arrayGen textGen) postgresConn , marshalTest (arrayGen (Gen.double (Range.exponentialFloat 0 1e40))) postgresConn
test/Database/Beam/Postgres/Test/Select.hs view
@@ -5,6 +5,7 @@ import Data.Aeson import Data.ByteString (ByteString)+import Data.List.NonEmpty (NonEmpty(..)) import Data.Int import Data.List (sort) import qualified Data.Text as T@@ -164,7 +165,7 @@ pgCreateExtension @UuidOssp let ext = getPgExtension $ _uuidOssp $ unCheckDatabase db runSelectReturningList $ select $ do- v <- values_ [val_ nil]+ v <- values_ (val_ nil :| []) return $ pgUuidGenerateV5 ext v "" assertEqual "result" [V5.generateNamed nil []] result
+ test/Database/Beam/Postgres/Test/Select/PgNubBy.hs view
@@ -0,0 +1,119 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE StandaloneDeriving #-}++module Database.Beam.Postgres.Test.Select.PgNubBy (tests) where++import Control.Monad (void)+import Data.ByteString (ByteString)+import Data.Int (Int32)+import Data.Text (Text)+import Data.Time.Calendar (Day, fromGregorian)+import Database.Beam+import Database.Beam.Migrate (defaultMigratableDbSettings)+import Database.Beam.Migrate.Simple (autoMigrate)+import Database.Beam.Postgres+import Database.Beam.Postgres.Migrate (migrationBackend)+import Database.Beam.Postgres.Test (withTestPostgres)+import Test.Tasty+import Test.Tasty.HUnit++tests :: IO ByteString -> TestTree+tests getConn =+ testGroup+ "pgNubBy_ / nub_ with window functions (issue #746)"+ [ testPgNubByWithLead getConn,+ testNubWithLead getConn+ ]++-- Reproducer for issue #746+testPgNubByWithLead :: IO ByteString -> TestTree+testPgNubByWithLead getConn = testCase "pgNubBy_ feeding lead1_" $+ withTestPostgres "issue_746_pg_nub_by" getConn $ \conn -> do+ setupDb conn+ results <-+ runBeamPostgres conn $+ runSelectReturningList $+ select $+ withWindow_+ (\vf -> frame_ noPartition_ (orderPartitionBy_ (asc_ vf)) noBounds_)+ (\vf w -> (vf, lead1_ vf `over_` w))+ (pgNubBy_ id (validFrom <$> all_ (persons db)))++ let expected =+ [ (day 2025 1 1, Just (day 2025 1 2)),+ (day 2025 1 2, Just (day 2025 1 3)),+ (day 2025 1 3, Nothing)+ ]+ assertEqual "lead1_ over pgNubBy_ should pair each distinct date with the next" expected results++-- Reproducer for issue #746 with @nub_@+testNubWithLead :: IO ByteString -> TestTree+testNubWithLead getConn = testCase "nub_ feeding lead1_" $+ withTestPostgres "issue_746_nub" getConn $ \conn -> do+ setupDb conn+ results <-+ runBeamPostgres conn $+ runSelectReturningList $+ select $+ withWindow_+ (\vf -> frame_ noPartition_ (orderPartitionBy_ (asc_ vf)) noBounds_)+ (\vf w -> (vf, lead1_ vf `over_` w))+ (nub_ (validFrom <$> all_ (persons db)))++ let expected =+ [ (day 2025 1 1, Just (day 2025 1 2)),+ (day 2025 1 2, Just (day 2025 1 3)),+ (day 2025 1 3, Nothing)+ ]+ assertEqual "lead1_ over nub_ should pair each distinct date with the next" expected results++data PersonT f = Person+ { name :: C f Text,+ validFrom :: C f Day,+ idx :: C f Int32+ }+ deriving (Generic)++type Person = PersonT Identity++deriving instance Show Person++deriving instance Eq Person++instance Beamable PersonT++instance Table PersonT where+ data PrimaryKey PersonT f = PersonKey (C f Text)+ deriving stock (Generic)+ deriving anyclass (Beamable)++ primaryKey Person {name} = PersonKey name++newtype Db f = Db+ { persons :: f (TableEntity PersonT)+ }+ deriving (Generic)++instance Database Postgres Db++db :: DatabaseSettings Postgres Db+db = defaultDbSettings++day :: Integer -> Int -> Int -> Day+day = fromGregorian++seedRows :: [Person]+seedRows =+ [ Person "A" (day 2025 1 1) 1,+ Person "B" (day 2025 1 1) 1,+ Person "C" (day 2025 1 2) 2,+ Person "D" (day 2025 1 2) 2,+ Person "E" (day 2025 1 3) 3,+ Person "F" (day 2025 1 3) 3+ ]++setupDb :: Connection -> IO ()+setupDb conn = runBeamPostgres conn $ do+ void $ autoMigrate migrationBackend (defaultMigratableDbSettings @Postgres @Db)+ runInsert $ insert (persons db) $ insertValues seedRows
+ test/Database/Beam/Postgres/Test/Windowing.hs view
@@ -0,0 +1,221 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE StandaloneDeriving #-}++module Database.Beam.Postgres.Test.Windowing (tests) where++import Database.Beam+import Database.Beam.Backend.SQL.BeamExtensions+import Database.Beam.Migrate+import Database.Beam.Migrate.Simple (autoMigrate)+import Database.Beam.Postgres+import Database.Beam.Postgres.Migrate (migrationBackend)+import Database.Beam.Postgres.Test++import Control.Exception (SomeException (..), handle)++import Data.ByteString (ByteString)+import Data.Int+import Data.Text (Text)++import Control.Monad (void)+import Test.Tasty+import Test.Tasty.HUnit++tests :: IO ByteString -> TestTree+tests postgresConn =+ testGroup+ "Windowing unit tests"+ [ testLead1 postgresConn+ , testLag1 postgresConn+ , testLead postgresConn+ , testLag postgresConn+ , testLeadWithDefault postgresConn+ , testLagWithDefault postgresConn+ ]++testLead1 :: IO ByteString -> TestTree+testLead1 = testCase "lead1_" . windowingQueryTest query expectation+ where+ query =+ withWindow_+ ( \Person{name} ->+ frame_+ noPartition_+ (orderPartitionBy_ (asc_ name))+ noBounds_+ )+ ( \Person{name} w ->+ (name, lead1_ name `over_` w)+ )+ (all_ $ persons db)+ expectation = [("Alice", Just "Bob"), ("Bob", Just "Claire"), ("Claire", Nothing)]++testLag1 :: IO ByteString -> TestTree+testLag1 = testCase "lag1_" . windowingQueryTest query expectation+ where+ query =+ withWindow_+ ( \Person{name} ->+ frame_+ noPartition_+ (orderPartitionBy_ (asc_ name))+ noBounds_+ )+ ( \Person{name} w ->+ (name, lag1_ name `over_` w)+ )+ (all_ $ persons db)+ expectation = [("Alice", Nothing), ("Bob", Just "Alice"), ("Claire", Just "Bob")]++testLead :: IO ByteString -> TestTree+testLead getConnStr =+ testGroup+ "lead_"+ [ testCase "n=1" $ windowingQueryTest (query 1) [("Alice", Just "Bob"), ("Bob", Just "Claire"), ("Claire", Nothing)] getConnStr+ , testCase "n=2" $ windowingQueryTest (query 2) [("Alice", Just "Claire"), ("Bob", Nothing), ("Claire", Nothing)] getConnStr+ ]+ where+ query n =+ withWindow_+ ( \Person{name} ->+ frame_+ noPartition_+ (orderPartitionBy_ (asc_ name))+ noBounds_+ )+ ( \Person{name} w ->+ (name, lead_ name (val_ (n :: Int32)) `over_` w)+ )+ (all_ $ persons db)+ expectation1 = []++testLag :: IO ByteString -> TestTree+testLag getConnStr =+ testGroup+ "lag_"+ [ testCase "n=1" $ windowingQueryTest (query 1) [("Alice", Nothing), ("Bob", Just "Alice"), ("Claire", Just "Bob")] getConnStr+ , testCase "n=2" $ windowingQueryTest (query 2) [("Alice", Nothing), ("Bob", Nothing), ("Claire", Just "Alice")] getConnStr+ ]+ where+ query n =+ withWindow_+ ( \Person{name} ->+ frame_+ noPartition_+ (orderPartitionBy_ (asc_ name))+ noBounds_+ )+ ( \Person{name} w ->+ (name, lag_ name (val_ (n :: Int32)) `over_` w)+ )+ (all_ $ persons db)+ expectation = []+++testLeadWithDefault :: IO ByteString -> TestTree+testLeadWithDefault getConnStr =+ testGroup+ "leadWithDefault_"+ [ testCase "n=1" $ windowingQueryTest (query 1 "default") [("Alice", "Bob"), ("Bob", "Claire"), ("Claire", "default")] getConnStr+ , testCase "n=2" $ windowingQueryTest (query 2 "default") [("Alice", "Claire"), ("Bob", "default"), ("Claire", "default")] getConnStr+ ]+ where+ query n def =+ withWindow_+ ( \Person{name} ->+ frame_+ noPartition_+ (orderPartitionBy_ (asc_ name))+ noBounds_+ )+ ( \Person{name} w ->+ (name, leadWithDefault_ name (val_ (n :: Int32)) (val_ def) `over_` w)+ )+ (all_ $ persons db)+ expectation1 = []+++testLagWithDefault :: IO ByteString -> TestTree+testLagWithDefault getConnStr =+ testGroup+ "lagWithDefault_"+ [ testCase "n=1" $ windowingQueryTest (query 1 "default") [("Alice", "default"), ("Bob", "Alice"), ("Claire", "Bob")] getConnStr+ , testCase "n=2" $ windowingQueryTest (query 2 "default") [("Alice", "default"), ("Bob", "default"), ("Claire", "Alice")] getConnStr+ ]+ where+ query n def =+ withWindow_+ ( \Person{name} ->+ frame_+ noPartition_+ (orderPartitionBy_ (asc_ name))+ noBounds_+ )+ ( \Person{name} w ->+ (name, lagWithDefault_ name (val_ (n :: Int32)) (val_ def) `over_` w)+ )+ (all_ $ persons db)+ expectation = []++++data PersonT f = Person+ { name :: C f Text+ }+ deriving (Generic)++type Person = PersonT Identity++type PersonExpr s = PersonT (QExpr Postgres s)++deriving instance Show Person+deriving instance Eq Person++instance Beamable PersonT++instance Table PersonT where+ data PrimaryKey PersonT f = PersonKey (C f Text)+ deriving stock (Generic)+ deriving anyclass (Beamable)++ primaryKey Person{name} = PersonKey name++data Db f = Db+ { persons :: f (TableEntity PersonT)+ }+ deriving (Generic)++instance Database Postgres Db++db :: DatabaseSettings Postgres Db+db = defaultDbSettings++windowingQueryTest ::+ (Eq a, Show a, Eq b, Show b, FromBackendRow Postgres a, FromBackendRow Postgres b) =>+ Q Postgres Db QBaseScope (QExpr Postgres s a, QExpr Postgres s b) ->+ [(a, b)] ->+ IO ByteString ->+ Assertion+windowingQueryTest query expectation getConnStr =+ withTestPostgres "db_windowing_psql" getConnStr $+ \conn -> do+ prepareTable conn+ results <-+ runBeamPostgres conn $+ runSelectReturningList $+ select query++ assertEqual "Unexpected" expectation results++prepareTable :: Connection -> IO ()+prepareTable conn =+ runBeamPostgres conn $ do+ void $ autoMigrate migrationBackend (defaultMigratableDbSettings @Postgres @Db)+ runInsert $+ insert (persons db) $+ insertValues+ [ Person "Alice"+ , Person "Bob"+ , Person "Claire"+ ]
test/Main.hs view
@@ -7,24 +7,30 @@ import Test.Tasty import qualified TestContainers.Tasty as TC -import qualified Database.Beam.Postgres.Test.Select as Select-import qualified Database.Beam.Postgres.Test.Marshal as Marshal+import qualified Database.Beam.Postgres.Test.Copy as Copy import qualified Database.Beam.Postgres.Test.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 - $ TC.withContainers setupTempPostgresDB - $ \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 ] @@ -41,10 +47,10 @@ , ("POSTGRES_DB", db) ] TC.& TC.setWaitingFor (TC.waitForLogLine TC.Stderr ("database system is ready to accept connections" `TL.isInfixOf`))- - pure $ Postgres.postgreSQLConnectionString ++ pure $ Postgres.postgreSQLConnectionString ( defaultConnectInfo { connectHost = "localhost"- , connectUser = unpack user + , connectUser = unpack user , connectPassword = unpack password , connectDatabase = unpack db , connectPort = fromIntegral $ TC.containerPort timescaleContainer 5432